lib/DBIx/Class/Fixtures.pm

   1 package DBIx::Class::Fixtures;
   2
   3 use strict;
   4 use warnings;
   5
   6 use DBIx::Class 0.08100;
   7 use DBIx::Class::Exception;
   8 use Class::Accessor::Grouped;
   9 use Config::Any::JSON;
  10 use Data::Dump::Streamer;
  11 use Data::Visitor::Callback;
  12 use Hash::Merge qw( merge );
  13 use Data::Dumper;
  14 use Class::C3::Componentised;
  15 use MIME::Base64;
  16 use IO::All;
  17 use File::Temp qw/tempdir/;
  18
  19 use base qw(Class::Accessor::Grouped);
  20
  21 our $namespace_counter = 0;
  22
  23 __PACKAGE__->mk_group_accessors( 'simple' => qw/config_dir
  24     _inherited_attributes debug schema_class dumped_objects config_attrs/);
  25
  26 our $VERSION = '1.001_030';
  27
  28 $VERSION = eval $VERSION;
  29
  30 =head1 NAME
  31
  32 DBIx::Class::Fixtures - Dump data and repopulate a database using rules
  33
  34 =head1 SYNOPSIS
  35
  36  use DBIx::Class::Fixtures;
  37
  38  ...
  39
  40  my $fixtures = DBIx::Class::Fixtures->new({
  41      config_dir => '/home/me/app/fixture_configs'
  42  });
  43
  44  $fixtures->dump({
  45    config => 'set_config.json',
  46    schema => $source_dbic_schema,
  47    directory => '/home/me/app/fixtures'
  48  });
  49
  50  $fixtures->populate({
  51    directory => '/home/me/app/fixtures',
  52    ddl => '/home/me/app/sql/ddl.sql',
  53    connection_details => ['dbi:mysql:dbname=app_dev', 'me', 'password'],
  54    post_ddl => '/home/me/app/sql/post_ddl.sql',
  55  });
  56
  57 =head1 DESCRIPTION
  58
  59 Dump fixtures from source database to filesystem then import to another
  60 database (with same schema) at any time. Use as a constant dataset for running
  61 tests against or for populating development databases when impractical to use
  62 production clones. Describe fixture set using relations and conditions based on
  63 your DBIx::Class schema.
  64
  65 =head1 DEFINE YOUR FIXTURE SET
  66
  67 Fixture sets are currently defined in .json files which must reside in your
  68 config_dir (e.g. /home/me/app/fixture_configs/a_fixture_set.json). They
  69 describe which data to pull and dump from the source database.
  70
  71 For example:
  72
  73  {
  74    "sets": [
  75      {
  76        "class": "Artist",
  77        "ids": ["1", "3"]
  78      },
  79      {
  80        "class": "Producer",
  81        "ids": ["5"],
  82        "fetch": [
  83          {
  84            "rel": "artists",
  85            "quantity": "2"
  86          }
  87        ]
  88      }
  89    ]
  90  }
  91
  92 This will fetch artists with primary keys 1 and 3, the producer with primary
  93 key 5 and two of producer 5's artists where 'artists' is a has_many DBIx::Class
  94 rel from Producer to Artist.
  95
  96 The top level attributes are as follows:
  97
  98 =head2 sets
  99
 100 Sets must be an array of hashes, as in the example given above. Each set
 101 defines a set of objects to be included in the fixtures. For details on valid
 102 set attributes see L</SET ATTRIBUTES> below.
 103
 104 =head2 rules
 105
 106 Rules place general conditions on classes. For example if whenever an artist
 107 was dumped you also wanted all of their cds dumped too, then you could use a
 108 rule to specify this. For example:
 109
 110  {
 111    "sets": [
 112      {
 113        "class": "Artist",
 114        "ids": ["1", "3"]
 115      },
 116      {
 117        "class": "Producer",
 118        "ids": ["5"],
 119        "fetch": [
 120          {
 121            "rel": "artists",
 122            "quantity": "2"
 123          }
 124        ]
 125      }
 126    ],
 127    "rules": {
 128      "Artist": {
 129        "fetch": [ {
 130          "rel": "cds",
 131          "quantity": "all"
 132        } ]
 133      }
 134    }
 135  }
 136
 137 In this case all the cds of artists 1, 3 and all producer 5's artists will be
 138 dumped as well. Note that 'cds' is a has_many DBIx::Class relation from Artist
 139 to CD. This is eqivalent to:
 140
 141  {
 142    "sets": [
 143     {
 144        "class": "Artist",
 145        "ids": ["1", "3"],
 146        "fetch": [ {
 147          "rel": "cds",
 148          "quantity": "all"
 149        } ]
 150      },
 151      {
 152        "class": "Producer",
 153        "ids": ["5"],
 154        "fetch": [ {
 155          "rel": "artists",
 156          "quantity": "2",
 157          "fetch": [ {
 158            "rel": "cds",
 159            "quantity": "all"
 160          } ]
 161        } ]
 162      }
 163    ]
 164  }
 165
 166 rules must be a hash keyed by class name.
 167
 168 L</RULE ATTRIBUTES>
 169
 170 =head2 includes
 171
 172 To prevent repetition between configs you can include other configs. For
 173 example:
 174
 175  {
 176    "sets": [ {
 177      "class": "Producer",
 178      "ids": ["5"]
 179    } ],
 180    "includes": [
 181      { "file": "base.json" }
 182    ]
 183  }
 184
 185 Includes must be an arrayref of hashrefs where the hashrefs have key 'file'
 186 which is the name of another config file in the same directory. The original
 187 config is merged with its includes using L<Hash::Merge>.
 188
 189 =head2 datetime_relative
 190
 191 Only available for MySQL and PostgreSQL at the moment, must be a value that
 192 DateTime::Format::* can parse. For example:
 193
 194  {
 195    "sets": [ {
 196      "class": "RecentItems",
 197      "ids": ["9"]
 198    } ],
 199    "datetime_relative": "2007-10-30 00:00:00"
 200  }
 201
 202 This will work when dumping from a MySQL database and will cause any datetime
 203 fields (where datatype => 'datetime' in the column def of the schema class) to
 204 be dumped as a DateTime::Duration object relative to the date specified in the
 205 datetime_relative value. For example if the RecentItem object had a date field
 206 set to 2007-10-25, then when the fixture is imported the field will be set to 5
 207 days in the past relative to the current time.
 208
 209 =head2 might_have
 210
 211 Specifies whether to automatically dump might_have relationships. Should be a
 212 hash with one attribute - fetch. Set fetch to 1 or 0.
 213
 214  {
 215    "might_have": { "fetch": 1 },
 216    "sets": [
 217      {
 218        "class": "Artist",
 219        "ids": ["1", "3"]
 220      },
 221      {
 222        "class": "Producer",
 223        "ids": ["5"]
 224      }
 225    ]
 226  }
 227
 228 Note: belongs_to rels are automatically dumped whether you like it or not, this
 229 is to avoid FKs to nowhere when importing.  General rules on has_many rels are
 230 not accepted at this top level, but you can turn them on for individual sets -
 231 see L</SET ATTRIBUTES>.
 232
 233 =head1 SET ATTRIBUTES
 234
 235 =head2 class
 236
 237 Required attribute. Specifies the DBIx::Class object class you wish to dump.
 238
 239 =head2 ids
 240
 241 Array of primary key ids to fetch, basically causing an $rs->find($_) for each.
 242 If the id is not in the source db then it just won't get dumped, no warnings or
 243 death.
 244
 245 =head2 quantity
 246
 247 Must be either an integer or the string 'all'. Specifying an integer will
 248 effectively set the 'rows' attribute on the resultset clause, specifying 'all'
 249 will cause the rows attribute to be left off and for all matching rows to be
 250 dumped. There's no randomising here, it's just the first x rows.
 251
 252 =head2 cond
 253
 254 A hash specifying the conditions dumped objects must match. Essentially this is
 255 a JSON representation of a DBIx::Class search clause. For example:
 256
 257  {
 258    "sets": [{
 259      "class": "Artist",
 260      "quantiy": "all",
 261      "cond": { "name": "Dave" }
 262    }]
 263  }
 264
 265 This will dump all artists whose name is 'dave'. Essentially
 266 $artist_rs->search({ name => 'Dave' })->all.
 267
 268 Sometimes in a search clause it's useful to use scalar refs to do things like:
 269
 270  $artist_rs->search({ no1_singles => \'> no1_albums' })
 271
 272 This could be specified in the cond hash like so:
 273
 274  {
 275    "sets": [ {
 276      "class": "Artist",
 277      "quantiy": "all",
 278      "cond": { "no1_singles": "\> no1_albums" }
 279    } ]
 280  }
 281
 282 So if the value starts with a backslash the value is made a scalar ref before
 283 being passed to search.
 284
 285 =head2 join
 286
 287 An array of relationships to be used in the cond clause.
 288
 289  {
 290    "sets": [ {
 291      "class": "Artist",
 292      "quantiy": "all",
 293      "cond": { "cds.position": { ">": 4 } },
 294      "join": ["cds"]
 295    } ]
 296  }
 297
 298 Fetch all artists who have cds with position greater than 4.
 299
 300 =head2 fetch
 301
 302 Must be an array of hashes. Specifies which rels to also dump. For example:
 303
 304  {
 305    "sets": [ {
 306      "class": "Artist",
 307      "ids": ["1", "3"],
 308      "fetch": [ {
 309        "rel": "cds",
 310        "quantity": "3",
 311        "cond": { "position": "2" }
 312      } ]
 313    } ]
 314  }
 315
 316 Will cause the cds of artists 1 and 3 to be dumped where the cd position is 2.
 317
 318 Valid attributes are: 'rel', 'quantity', 'cond', 'has_many', 'might_have' and
 319 'join'. rel is the name of the DBIx::Class rel to follow, the rest are the same
 320 as in the set attributes. quantity is necessary for has_many relationships, but
 321 not if using for belongs_to or might_have relationships.
 322
 323 =head2 has_many
 324
 325 Specifies whether to fetch has_many rels for this set. Must be a hash
 326 containing keys fetch and quantity.
 327
 328 Set fetch to 1 if you want to fetch them, and quantity to either 'all' or an
 329 integer.
 330
 331 Be careful here, dumping has_many rels can lead to a lot of data being dumped.
 332
 333 =head2 might_have
 334
 335 As with has_many but for might_have relationships. Quantity doesn't do anything
 336 in this case.
 337
 338 This value will be inherited by all fetches in this set. This is not true for
 339 the has_many attribute.
 340
 341 =head2 external
 342
 343 In some cases your database information might be keys to values in some sort of
 344 external storage.  The classic example is you are using L<DBIx::Class::InflateColumn::FS>
 345 to store blob information on the filesystem.  In this case you may wish the ability
 346 to backup your external storage in the same way your database data.  The L</external>
 347 attribute lets you specify a handler for this type of issue.  For example:
 348
 349     {
 350         "sets": [{
 351             "class": "Photo",
 352             "quantity": "all",
 353             "external": {
 354                 "file": {
 355                     "class": "File",
 356                     "args": {"path":"__ATTR(photo_dir)__"}
 357                 }
 358             }
 359         }]
 360     }
 361
 362 This would use L<DBIx::Class::Fixtures::External::File> to read from a directory
 363 where the path to a file is specified by the C<file> field of the C<Photo> source.
 364 We use the uninflated value of the field so you need to completely handle backup
 365 and restore.  For the common case we provide  L<DBIx::Class::Fixtures::External::File>
 366 and you can create your own custom handlers by placing a '+' in the namespace:
 367
 368     "class": "+MyApp::Schema::SomeExternalStorage",
 369
 370 Although if possible I'd love to get patches to add some of the other common
 371 types (I imagine storage in MogileFS, Redis, etc or even Amazon might be popular.)
 372
 373 See L<DBIx::Class::Fixtures::External::File> for the external handler interface.
 374
 375 =head1 RULE ATTRIBUTES
 376
 377 =head2 cond
 378
 379 Same as with L</SET ATTRIBUTES>
 380
 381 =head2 fetch
 382
 383 Same as with L</SET ATTRIBUTES>
 384
 385 =head2 join
 386
 387 Same as with L</SET ATTRIBUTES>
 388
 389 =head2 has_many
 390
 391 Same as with L</SET ATTRIBUTES>
 392
 393 =head2 might_have
 394
 395 Same as with L</SET ATTRIBUTES>
 396
 397 =head1 RULE SUBSTITUTIONS
 398
 399 You can provide the following substitution patterns for your rule values. An
 400 example of this might be:
 401
 402     {
 403         "sets": [{
 404             "class": "Photo",
 405             "quantity": "__ENV(NUMBER_PHOTOS_DUMPED)__",
 406         }]
 407     }
 408
 409 =head2 ENV
 410
 411 Provide a value from %ENV
 412
 413 =head2 ATTR
 414
 415 Provide a value from L</config_attrs>
 416
 417 =head2 catfile
 418
 419 Create the path to a file from a list
 420
 421 =head2 catdir
 422
 423 Create the path to a directory from a list
 424
 425 =head1 METHODS
 426
 427 =head2 new
 428
 429 =over 4
 430
 431 =item Arguments: \%$attrs
 432
 433 =item Return Value: $fixture_object
 434
 435 =back
 436
 437 Returns a new DBIx::Class::Fixture object. %attrs can have the following
 438 parameters:
 439
 440 =over
 441
 442 =item config_dir:
 443
 444 required. must contain a valid path to the directory in which your .json
 445 configs reside.
 446
 447 =item debug:
 448
 449 determines whether to be verbose
 450
 451 =item ignore_sql_errors:
 452
 453 ignore errors on import of DDL etc
 454
 455 =item config_attrs
 456
 457 A hash of information you can use to do replacements inside your configuration
 458 sets.  For example, if your set looks like:
 459
 460    {
 461      "sets": [ {
 462        "class": "Artist",
 463        "ids": ["1", "3"],
 464        "fetch": [ {
 465          "rel": "cds",
 466          "quantity": "__ATTR(quantity)__",
 467        } ]
 468      } ]
 469    }
 470
 471     my $fixtures = DBIx::Class::Fixtures->new( {
 472       config_dir => '/home/me/app/fixture_configs'
 473       config_attrs => {
 474         quantity => 100,
 475       },
 476     });
 477
 478 You may wish to do this if you want to let whoever runs the dumps have a bit
 479 more control
 480
 481 =back
 482
 483  my $fixtures = DBIx::Class::Fixtures->new( {
 484    config_dir => '/home/me/app/fixture_configs'
 485  } );
 486
 487 =cut
 488
 489 sub new {
 490   my $class = shift;
 491
 492   my ($params) = @_;
 493   unless (ref $params eq 'HASH') {
 494     return DBIx::Class::Exception->throw('first arg to DBIx::Class::Fixtures->new() must be hash ref');
 495   }
 496
 497   unless ($params->{config_dir}) {
 498     return DBIx::Class::Exception->throw('config_dir param not specified');
 499   }
 500
 501   my $config_dir = io->dir($params->{config_dir});
 502   unless (-e $params->{config_dir}) {
 503     return DBIx::Class::Exception->throw('config_dir directory doesn\'t exist');
 504   }
 505
 506   my $self = {
 507               config_dir            => $config_dir,
 508               _inherited_attributes => [qw/datetime_relative might_have rules belongs_to/],
 509               debug                 => $params->{debug} || 0,
 510               ignore_sql_errors     => $params->{ignore_sql_errors},
 511               dumped_objects        => {},
 512               use_create            => $params->{use_create} || 0,
 513               use_find_or_create    => $params->{use_find_or_create} || 0,
 514               config_attrs          => $params->{config_attrs} || {},
 515   };
 516
 517   bless $self, $class;
 518
 519   return $self;
 520 }
 521
 522 =head2 available_config_sets
 523
 524 Returns a list of all the config sets found in the L</config_dir>.  These will
 525 be a list of the json based files containing dump rules.
 526
 527 =cut
 528
 529 my @config_sets;
 530 sub available_config_sets {
 531   @config_sets = scalar(@config_sets) ? @config_sets : map {
 532     $_->filename;
 533   } grep {
 534     -f "$_" && $_=~/json$/;
 535   } shift->config_dir->all;
 536 }
 537
 538 =head2 dump
 539
 540 =over 4
 541
 542 =item Arguments: \%$attrs
 543
 544 =item Return Value: 1
 545
 546 =back
 547
 548  $fixtures->dump({
 549    config => 'set_config.json', # config file to use. must be in the config
 550                                 # directory specified in the constructor
 551    schema => $source_dbic_schema,
 552    directory => '/home/me/app/fixtures' # output directory
 553  });
 554
 555 or
 556
 557  $fixtures->dump({
 558    all => 1, # just dump everything that's in the schema
 559    schema => $source_dbic_schema,
 560    directory => '/home/me/app/fixtures' # output directory
 561  });
 562
 563 In this case objects will be dumped to subdirectories in the specified
 564 directory. For example:
 565
 566  /home/me/app/fixtures/artist/1.fix
 567  /home/me/app/fixtures/artist/3.fix
 568  /home/me/app/fixtures/producer/5.fix
 569
 570 schema and directory are required attributes. also, one of config or all must
 571 be specified.
 572
 573 Lastly, the C<config> parameter can be a Perl HashRef instead of a file name.
 574 If this form is used your HashRef should conform to the structure rules defined
 575 for the JSON representations.
 576
 577 =cut
 578
 579 sub dump {
 580   my $self = shift;
 581
 582   my ($params) = @_;
 583   unless (ref $params eq 'HASH') {
 584     return DBIx::Class::Exception->throw('first arg to dump must be hash ref');
 585   }
 586
 587   foreach my $param (qw/schema directory/) {
 588     unless ($params->{$param}) {
 589       return DBIx::Class::Exception->throw($param . ' param not specified');
 590     }
 591   }
 592
 593   if($params->{excludes} && !$params->{all}) {
 594     return DBIx::Class::Exception->throw("'excludes' param only works when using the 'all' param");
 595   }
 596
 597   my $schema = $params->{schema};
 598   my $config;
 599   if ($params->{config}) {
 600     $config = ref $params->{config} eq 'HASH' ?
 601       $params->{config} :
 602       do {
 603         #read config
 604         my $config_file = io->catfile($self->config_dir, $params->{config});
 605         $self->load_config_file("$config_file");
 606       };
 607   } elsif ($params->{all}) {
 608     my %excludes = map {$_=>1} @{$params->{excludes}||[]};
 609     $config = {
 610       might_have => { fetch => 0 },
 611       has_many => { fetch => 0 },
 612       belongs_to => { fetch => 0 },
 613       sets => [
 614         map {
 615           { class => $_, quantity => 'all' };
 616         } grep {
 617           !$excludes{$_}
 618         } $schema->sources],
 619     };
 620   } else {
 621     DBIx::Class::Exception->throw('must pass config or set all');
 622   }
 623
 624   my $output_dir = io->dir($params->{directory});
 625   unless (-e "$output_dir") {
 626     $output_dir->mkpath ||
 627     DBIx::Class::Exception->throw("output directory does not exist at $output_dir");
 628   }
 629
 630   $self->msg("generating  fixtures");
 631   my $tmp_output_dir = io->dir(tempdir);
 632
 633   if (-e "$tmp_output_dir") {
 634     $self->msg("- clearing existing $tmp_output_dir");
 635     $tmp_output_dir->rmtree;
 636   }
 637   $self->msg("- creating $tmp_output_dir");
 638   $tmp_output_dir->mkpath;
 639
 640   # write version file (for the potential benefit of populate)
 641   $tmp_output_dir->file('_dumper_version')->print($VERSION);
 642
 643   # write our current config set
 644   $tmp_output_dir->file('_config_set')->print( Dumper $config );
 645
 646   $config->{rules} ||= {};
 647   my @sources = sort { $a->{class} cmp $b->{class} } @{delete $config->{sets}};
 648
 649   while ( my ($k,$v) = each %{ $config->{rules} } ) {
 650     if ( my $source = eval { $schema->source($k) } ) {
 651       $config->{rules}{$source->source_name} = $v;
 652     }
 653   }
 654
 655   foreach my $source (@sources) {
 656     # apply rule to set if specified
 657     my $rule = $config->{rules}->{$source->{class}};
 658     $source = merge( $source, $rule ) if ($rule);
 659
 660     # fetch objects
 661     my $rs = $schema->resultset($source->{class});
 662
 663     if ($source->{cond} and ref $source->{cond} eq 'HASH') {
 664       # if value starts with \ assume it's meant to be passed as a scalar ref
 665       # to dbic. ideally this would substitute deeply
 666       $source->{cond} = {
 667         map {
 668           $_ => ($source->{cond}->{$_} =~ s/^\\//) ? \$source->{cond}->{$_}
 669                                                    : $source->{cond}->{$_}
 670         } keys %{$source->{cond}}
 671       };
 672     }
 673
 674     $rs = $rs->search($source->{cond}, { join => $source->{join} })
 675       if $source->{cond};
 676
 677     $self->msg("- dumping $source->{class}");
 678
 679     my %source_options = ( set => { %{$config}, %{$source} } );
 680     if ($source->{quantity}) {
 681       $rs = $rs->search({}, { order_by => $source->{order_by} })
 682         if $source->{order_by};
 683
 684       if ($source->{quantity} =~ /^\d+$/) {
 685         $rs = $rs->search({}, { rows => $source->{quantity} });
 686       } elsif ($source->{quantity} ne 'all') {
 687         DBIx::Class::Exception->throw("invalid value for quantity - $source->{quantity}");
 688       }
 689     }
 690     elsif ($source->{ids} && @{$source->{ids}}) {
 691       my @ids = @{$source->{ids}};
 692       my (@pks) = $rs->result_source->primary_columns;
 693       die "Can't dump multiple col-pks using 'id' option" if @pks > 1;
 694       $rs = $rs->search_rs( { $pks[0] => { -in => \@ids } } );
 695     }
 696     else {
 697       DBIx::Class::Exception->throw('must specify either quantity or ids');
 698     }
 699
 700     $source_options{set_dir} = $tmp_output_dir;
 701     $self->dump_rs($rs, \%source_options );
 702   }
 703
 704   # clear existing output dir
 705   foreach my $child ($output_dir->all) {
 706     if ($child->is_dir) {
 707       next if ("$child" eq "$tmp_output_dir");
 708       if (grep { $_ =~ /\.fix/ } $child->all) {
 709         $child->rmtree;
 710       }
 711     } elsif ($child =~ /_dumper_version$/) {
 712       $child->unlink;
 713     }
 714   }
 715
 716   $self->msg("- moving temp dir to $output_dir");
 717   $tmp_output_dir->copy("$output_dir");
 718
 719   if (-e "$output_dir") {
 720     $self->msg("- clearing tmp dir $tmp_output_dir");
 721     # delete existing fixture set
 722     $tmp_output_dir->rmtree;
 723   }
 724
 725   $self->msg("done");
 726
 727   return 1;
 728 }
 729
 730 sub load_config_file {
 731   my ($self, $config_file) = @_;
 732   DBIx::Class::Exception->throw("config does not exist at $config_file")
 733     unless -e "$config_file";
 734
 735   my $config = Config::Any::JSON->load($config_file);
 736
 737   #process includes
 738   if (my $incs = $config->{includes}) {
 739     $self->msg($incs);
 740     DBIx::Class::Exception->throw(
 741       'includes params of config must be an array ref of hashrefs'
 742     ) unless ref $incs eq 'ARRAY';
 743
 744     foreach my $include_config (@$incs) {
 745       DBIx::Class::Exception->throw(
 746         'includes params of config must be an array ref of hashrefs'
 747       ) unless (ref $include_config eq 'HASH') && $include_config->{file};
 748
 749       my $include_file = $self->config_dir->file($include_config->{file});
 750
 751       DBIx::Class::Exception->throw("config does not exist at $include_file")
 752         unless -e "$include_file";
 753
 754       my $include = Config::Any::JSON->load($include_file);
 755       $self->msg($include);
 756       $config = merge( $config, $include );
 757     }
 758     delete $config->{includes};
 759   }
 760
 761   # validate config
 762   return DBIx::Class::Exception->throw('config has no sets')
 763     unless $config && $config->{sets} &&
 764            ref $config->{sets} eq 'ARRAY' && scalar @{$config->{sets}};
 765
 766   $config->{might_have} = { fetch => 0 } unless exists $config->{might_have};
 767   $config->{has_many} = { fetch => 0 }   unless exists $config->{has_many};
 768   $config->{belongs_to} = { fetch => 1 } unless exists $config->{belongs_to};
 769
 770   return $config;
 771 }
 772
 773 sub dump_rs {
 774     my ($self, $rs, $params) = @_;
 775
 776     while (my $row = $rs->next) {
 777         $self->dump_object($row, $params);
 778     }
 779 }
 780
 781 sub dump_object {
 782   my ($self, $object, $params) = @_;
 783   my $set = $params->{set};
 784
 785   my $v = Data::Visitor::Callback->new(
 786     plain_value => sub {
 787       my ($visitor, $data) = @_;
 788       my $subs = {
 789        ENV => sub {
 790           my ( $self, $v ) = @_;
 791           if (! defined($ENV{$v})) {
 792             return "";
 793           } else {
 794             return $ENV{ $v };
 795           }
 796         },
 797         ATTR => sub {
 798           my ($self, $v) = @_;
 799           if(my $attr = $self->config_attrs->{$v}) {
 800             return $attr;
 801           } else {
 802             return "";
 803           }
 804         },
 805         catfile => sub {
 806           my ($self, @args) = @_;
 807           "".io->catfile(@args);
 808         },
 809         catdir => sub {
 810           my ($self, @args) = @_;
 811           "".io->catdir(@args);
 812         },
 813       };
 814
 815       my $subsre = join( '|', keys %$subs );
 816       $_ =~ s{__($subsre)(?:\((.+?)\))?__}{ $subs->{ $1 }->( $self, $2 ? split( /,/, $2 ) : () ) }eg;
 817
 818       return $_;
 819     }
 820   );
 821
 822   $v->visit( $set );
 823
 824   die 'no dir passed to dump_object' unless $params->{set_dir};
 825   die 'no object passed to dump_object' unless $object;
 826
 827   my @inherited_attrs = @{$self->_inherited_attributes};
 828
 829   my @pk_vals = map {
 830     $object->get_column($_)
 831   } $object->primary_columns;
 832
 833   my $key = join("\0", @pk_vals);
 834
 835   my $src = $object->result_source;
 836   my $exists = $self->dumped_objects->{$src->name}{$key}++;
 837
 838
 839   # write dir and gen filename
 840   my $source_dir = io->catdir($params->{set_dir}, $self->_name_for_source($src));
 841   $source_dir->mkpath(0, 0777);
 842
 843   # Convert characters not allowed on windows
 844   my $file = io->catfile("$source_dir",
 845       join('-', map { s|[/\\:\*\|\?"<>]|_|g; $_; } @pk_vals) . '.fix'
 846   );
 847
 848   # write file
 849   unless ($exists) {
 850     $self->msg('-- dumping ' . "$file", 2);
 851     my %ds = $object->get_columns;
 852
 853     if($set->{external}) {
 854       foreach my $field (keys %{$set->{external}}) {
 855         my $key = $ds{$field};
 856         my ($plus, $class) = ( $set->{external}->{$field}->{class}=~/^(\+)*(.+)$/);
 857         my $args = $set->{external}->{$field}->{args};
 858
 859         $class = "DBIx::Class::Fixtures::External::$class" unless $plus;
 860         eval "use $class";
 861
 862         $ds{external}->{$field} =
 863           encode_base64( $class
 864            ->backup($key => $args),'');
 865       }
 866     }
 867
 868     # mess with dates if specified
 869     if ($set->{datetime_relative}) {
 870       my $formatter= $object->result_source->schema->storage->datetime_parser;
 871       unless ($@ || !$formatter) {
 872         my $dt;
 873         if ($set->{datetime_relative} eq 'today') {
 874           $dt = DateTime->today;
 875         } else {
 876           $dt = $formatter->parse_datetime($set->{datetime_relative}) unless ($@);
 877         }
 878
 879         while (my ($col, $value) = each %ds) {
 880           my $col_info = $object->result_source->column_info($col);
 881
 882           next unless $value
 883             && $col_info->{_inflate_info}
 884               && (
 885                   (uc($col_info->{data_type}) eq 'DATETIME')
 886                     or (uc($col_info->{data_type}) eq 'DATE')
 887                     or (uc($col_info->{data_type}) eq 'TIME')
 888                     or (uc($col_info->{data_type}) eq 'TIMESTAMP')
 889                     or (uc($col_info->{data_type}) eq 'INTERVAL')
 890                  );
 891
 892           $ds{$col} = $object->get_inflated_column($col)->subtract_datetime($dt);
 893         }
 894       } else {
 895         warn "datetime_relative not supported for this db driver at the moment";
 896       }
 897     }
 898
 899     # do the actual dumping
 900     my $serialized = Dump(\%ds)->Out();
 901
 902     $file->print($serialized);
 903   }
 904
 905   # don't bother looking at rels unless we are actually planning to dump at least one type
 906   my ($might_have, $belongs_to, $has_many) = map {
 907     $set->{$_}{fetch} || $set->{rules}{$src->source_name}{$_}{fetch}
 908   } qw/might_have belongs_to has_many/;
 909
 910   return unless $might_have
 911              || $belongs_to
 912              || $has_many
 913              || $set->{fetch};
 914
 915   # dump rels of object
 916   unless ($exists) {
 917     foreach my $name (sort $src->relationships) {
 918       my $info = $src->relationship_info($name);
 919       my $r_source = $src->related_source($name);
 920       # if belongs_to or might_have with might_have param set or has_many with
 921       # has_many param set then
 922       if (
 923             ( $info->{attrs}{accessor} eq 'single' &&
 924               (!$info->{attrs}{join_type} || $might_have)
 925             )
 926          || $info->{attrs}{accessor} eq 'filter'
 927          ||
 928             ($info->{attrs}{accessor} eq 'multi' && $has_many)
 929       ) {
 930         my $related_rs = $object->related_resultset($name);
 931         my $rule = $set->{rules}->{$related_rs->result_source->source_name};
 932         # these parts of the rule only apply to has_many rels
 933         if ($rule && $info->{attrs}{accessor} eq 'multi') {
 934           $related_rs = $related_rs->search(
 935             $rule->{cond},
 936             { join => $rule->{join} }
 937           ) if ($rule->{cond});
 938
 939           $related_rs = $related_rs->search(
 940             {},
 941             { rows => $rule->{quantity} }
 942           ) if ($rule->{quantity} && $rule->{quantity} ne 'all');
 943
 944           $related_rs = $related_rs->search(
 945             {},
 946             { order_by => $rule->{order_by} }
 947           ) if ($rule->{order_by});
 948
 949         }
 950         if ($set->{has_many}{quantity} &&
 951             $set->{has_many}{quantity} =~ /^\d+$/) {
 952           $related_rs = $related_rs->search(
 953             {},
 954             { rows => $set->{has_many}->{quantity} }
 955           );
 956         }
 957
 958         my %c_params = %{$params};
 959         # inherit date param
 960         my %mock_set = map {
 961           $_ => $set->{$_}
 962         } grep { $set->{$_} } @inherited_attrs;
 963
 964         $c_params{set} = \%mock_set;
 965         $c_params{set} = merge( $c_params{set}, $rule)
 966           if $rule && $rule->{fetch};
 967
 968         $self->dump_rs($related_rs, \%c_params);
 969       }
 970     }
 971   }
 972
 973   return unless $set && $set->{fetch};
 974   foreach my $fetch (@{$set->{fetch}}) {
 975     # inherit date param
 976     $fetch->{$_} = $set->{$_} foreach
 977       grep { !$fetch->{$_} && $set->{$_} } @inherited_attrs;
 978     my $related_rs = $object->related_resultset($fetch->{rel});
 979     my $rule = $set->{rules}->{$related_rs->result_source->source_name};
 980
 981     if ($rule) {
 982       my $info = $object->result_source->relationship_info($fetch->{rel});
 983       if ($info->{attrs}{accessor} eq 'multi') {
 984         $fetch = merge( $fetch, $rule );
 985       } elsif ($rule->{fetch}) {
 986         $fetch = merge( $fetch, { fetch => $rule->{fetch} } );
 987       }
 988     }
 989
 990     die "relationship $fetch->{rel} does not exist for " . $src->source_name
 991       unless ($related_rs);
 992
 993     if ($fetch->{cond} and ref $fetch->{cond} eq 'HASH') {
 994       # if value starts with \ assume it's meant to be passed as a scalar ref
 995       # to dbic.  ideally this would substitute deeply
 996       $fetch->{cond} = { map {
 997           $_ => ($fetch->{cond}->{$_} =~ s/^\\//) ? \$fetch->{cond}->{$_}
 998                                                   : $fetch->{cond}->{$_}
 999       } keys %{$fetch->{cond}} };
1000     }
1001
1002     $related_rs = $related_rs->search(
1003       $fetch->{cond},
1004       { join => $fetch->{join} }
1005     ) if $fetch->{cond};
1006
1007     $related_rs = $related_rs->search(
1008       {},
1009       { rows => $fetch->{quantity} }
1010     ) if $fetch->{quantity} && $fetch->{quantity} ne 'all';
1011     $related_rs = $related_rs->search(
1012       {},
1013       { order_by => $fetch->{order_by} }
1014     ) if $fetch->{order_by};
1015
1016     $self->dump_rs($related_rs, { %{$params}, set => $fetch });
1017   }
1018 }
1019
1020 sub _generate_schema {
1021   my $self = shift;
1022   my $params = shift || {};
1023   require DBI;
1024   $self->msg("\ncreating schema");
1025
1026   my $schema_class = $self->schema_class || "DBIx::Class::Fixtures::Schema";
1027   eval "require $schema_class";
1028   die $@ if $@;
1029
1030   my $pre_schema;
1031   my $connection_details = $params->{connection_details};
1032
1033   $namespace_counter++;
1034
1035   my $namespace = "DBIx::Class::Fixtures::GeneratedSchema_$namespace_counter";
1036   Class::C3::Componentised->inject_base( $namespace => $schema_class );
1037
1038   $pre_schema = $namespace->connect(@{$connection_details});
1039   unless( $pre_schema ) {
1040     return DBIx::Class::Exception->throw('connection details not valid');
1041   }
1042   my @tables = map { $self->_name_for_source($pre_schema->source($_)) } $pre_schema->sources;
1043   $self->msg("Tables to drop: [". join(', ', sort @tables) . "]");
1044   my $dbh = $pre_schema->storage->dbh;
1045
1046   # clear existing db
1047   $self->msg("- clearing DB of existing tables");
1048   $pre_schema->storage->txn_do(sub {
1049     $pre_schema->storage->with_deferred_fk_checks(sub {
1050       foreach my $table (@tables) {
1051         eval {
1052           $dbh->do("drop table $table" . ($params->{cascade} ? ' cascade' : '') )
1053         };
1054       }
1055     });
1056   });
1057
1058   # import new ddl file to db
1059   my $ddl_file = $params->{ddl};
1060   $self->msg("- deploying schema using $ddl_file");
1061   my $data = _read_sql($ddl_file);
1062   foreach (@$data) {
1063     eval { $dbh->do($_) or warn "SQL was:\n $_"};
1064           if ($@ && !$self->{ignore_sql_errors}) { die "SQL was:\n $_\n$@"; }
1065   }
1066   $self->msg("- finished importing DDL into DB");
1067
1068   # load schema object from our new DB
1069   $namespace_counter++;
1070   my $namespace2 = "DBIx::Class::Fixtures::GeneratedSchema_$namespace_counter";
1071   Class::C3::Componentised->inject_base( $namespace2 => $schema_class );
1072   my $schema = $namespace2->connect(@{$connection_details});
1073   return $schema;
1074 }
1075
1076 sub _read_sql {
1077   my $ddl_file = shift;
1078   my $fh;
1079   open $fh, "<$ddl_file" or die ("Can't open DDL file, $ddl_file ($!)");
1080   my @data = split(/\n/, join('', <$fh>));
1081   @data = grep(!/^--/, @data);
1082   @data = split(/;/, join('', @data));
1083   close($fh);
1084   @data = grep { $_ && $_ !~ /^-- / } @data;
1085   return \@data;
1086 }
1087
1088 =head2 dump_config_sets
1089
1090 Works just like L</dump> but instead of specifying a single json config set
1091 located in L</config_dir> we dump each set named in the C<configs> parameter.
1092
1093 The parameters are the same as for L</dump> except instead of a C<directory>
1094 parameter we have a C<directory_template> which is a coderef expected to return
1095 a scalar that is a root directory where we will do the actual dumping.  This
1096 coderef get three arguments: C<$self>, C<$params> and C<$set_name>.  For
1097 example:
1098
1099     $fixture->dump_all_config_sets({
1100       schema => $schema,
1101       configs => [qw/one.json other.json/],
1102       directory_template => sub {
1103         my ($fixture, $params, $set) = @_;
1104         return io->catdir('var', 'fixtures', $params->{schema}->version, $set);
1105       },
1106     });
1107
1108 =cut
1109
1110 sub dump_config_sets {
1111   my ($self, $params) = @_;
1112   my $available_config_sets = delete $params->{configs};
1113   my $directory_template = delete $params->{directory_template} ||
1114     DBIx::Class::Exception->throw("'directory_template is required parameter");
1115
1116   for my $set (@$available_config_sets) {
1117     my $localparams = $params;
1118     $localparams->{directory} = $directory_template->($self, $localparams, $set);
1119     $localparams->{config} = $set;
1120     $self->dump($localparams);
1121     $self->dumped_objects({}); ## Clear dumped for next go, if there is one!
1122   }
1123 }
1124
1125 =head2 dump_all_config_sets
1126
1127     my %local_params = %$params;
1128     my $local_self = bless { %$self }, ref($self);
1129     $local_params{directory} = $directory_template->($self, \%local_params, $set);
1130     $local_params{config} = $set;
1131     $self->dump(\%local_params);
1132
1133
1134 Works just like L</dump> but instead of specifying a single json config set
1135 located in L</config_dir> we dump each set in turn to the specified directory.
1136
1137 The parameters are the same as for L</dump> except instead of a C<directory>
1138 parameter we have a C<directory_template> which is a coderef expected to return
1139 a scalar that is a root directory where we will do the actual dumping.  This
1140 coderef get three arguments: C<$self>, C<$params> and C<$set_name>.  For
1141 example:
1142
1143     $fixture->dump_all_config_sets({
1144       schema => $schema,
1145       directory_template => sub {
1146         my ($fixture, $params, $set) = @_;
1147         return io->catdir('var', 'fixtures', $params->{schema}->version, $set);
1148       },
1149     });
1150
1151 =cut
1152
1153 sub dump_all_config_sets {
1154   my ($self, $params) = @_;
1155   $self->dump_config_sets({
1156     %$params,
1157     configs=>[$self->available_config_sets],
1158   });
1159 }
1160
1161 =head2 populate
1162
1163 =over 4
1164
1165 =item Arguments: \%$attrs
1166
1167 =item Return Value: 1
1168
1169 =back
1170
1171  $fixtures->populate( {
1172    # directory to look for fixtures in, as specified to dump
1173    directory => '/home/me/app/fixtures',
1174
1175    # DDL to deploy
1176    ddl => '/home/me/app/sql/ddl.sql',
1177
1178    # database to clear, deploy and then populate
1179    connection_details => ['dbi:mysql:dbname=app_dev', 'me', 'password'],
1180
1181    # DDL to deploy after populating records, ie. FK constraints
1182    post_ddl => '/home/me/app/sql/post_ddl.sql',
1183
1184    # use CASCADE option when dropping tables
1185    cascade => 1,
1186
1187    # optional, set to 1 to run ddl but not populate
1188    no_populate => 0,
1189
1190    # optional, set to 1 to run each fixture through ->create rather than have
1191    # each $rs populated using $rs->populate. Useful if you have overridden new() logic
1192    # that effects the value of column(s).
1193    use_create => 0,
1194
1195    # optional, same as use_create except with find_or_create.
1196    # Useful if you are populating a persistent data store.
1197    use_find_or_create => 0,
1198
1199    # Dont try to clean the database, just populate over whats there. Requires
1200    # schema option. Use this if you want to handle removing old data yourself
1201    # no_deploy => 1
1202    # schema => $schema
1203  } );
1204
1205 In this case the database app_dev will be cleared of all tables, then the
1206 specified DDL deployed to it, then finally all fixtures found in
1207 /home/me/app/fixtures will be added to it. populate will generate its own
1208 DBIx::Class schema from the DDL rather than being passed one to use. This is
1209 better as custom insert methods are avoided which can to get in the way. In
1210 some cases you might not have a DDL, and so this method will eventually allow a
1211 $schema object to be passed instead.
1212
1213 If needed, you can specify a post_ddl attribute which is a DDL to be applied
1214 after all the fixtures have been added to the database. A good use of this
1215 option would be to add foreign key constraints since databases like Postgresql
1216 cannot disable foreign key checks.
1217
1218 If your tables have foreign key constraints you may want to use the cascade
1219 attribute which will make the drop table functionality cascade, ie 'DROP TABLE
1220 $table CASCADE'.
1221
1222 C<directory> is a required attribute.
1223
1224 If you wish for DBIx::Class::Fixtures to clear the database for you pass in
1225 C<dll> (path to a DDL sql file) and C<connection_details> (array ref  of DSN,
1226 user and pass).
1227
1228 If you wish to deal with cleaning the schema yourself, then pass in a C<schema>
1229 attribute containing the connected schema you wish to operate on and set the
1230 C<no_deploy> attribute.
1231
1232 =cut
1233
1234 sub populate {
1235   my $self = shift;
1236   my ($params) = @_;
1237   DBIx::Class::Exception->throw('first arg to populate must be hash ref')
1238     unless ref $params eq 'HASH';
1239
1240   DBIx::Class::Exception->throw('directory param not specified')
1241     unless $params->{directory};
1242
1243   my $fixture_dir = io->dir(delete $params->{directory});
1244   DBIx::Class::Exception->throw("fixture directory '$fixture_dir' does not exist")
1245     unless -d "$fixture_dir";
1246
1247   my $ddl_file;
1248   my $dbh;
1249   my $schema;
1250   if ($params->{ddl} && $params->{connection_details}) {
1251     $ddl_file = io->file(delete $params->{ddl});
1252     unless (-e "$ddl_file") {
1253       return DBIx::Class::Exception->throw('DDL does not exist at ' . $ddl_file);
1254     }
1255     unless (ref $params->{connection_details} eq 'ARRAY') {
1256       return DBIx::Class::Exception->throw('connection details must be an arrayref');
1257     }
1258     $schema = $self->_generate_schema({
1259       ddl => "$ddl_file",
1260       connection_details => delete $params->{connection_details},
1261       %{$params}
1262     });
1263   } elsif ($params->{schema} && $params->{no_deploy}) {
1264     $schema = $params->{schema};
1265   } else {
1266     DBIx::Class::Exception->throw('you must set the ddl and connection_details params');
1267   }
1268
1269
1270   return 1 if $params->{no_populate};
1271
1272   $self->msg("\nimporting fixtures");
1273   my $tmp_fixture_dir = io->dir(tempdir());
1274   my $config_set_path = io->file($fixture_dir, '_config_set');
1275   my $config_set = -e "$config_set_path" ? do { my $VAR1; eval($config_set_path->slurp); $VAR1 } : '';
1276
1277   my $v = Data::Visitor::Callback->new(
1278     plain_value => sub {
1279       my ($visitor, $data) = @_;
1280       my $subs = {
1281        ENV => sub {
1282           my ( $self, $v ) = @_;
1283           if (! defined($ENV{$v})) {
1284             return "";
1285           } else {
1286             return $ENV{ $v };
1287           }
1288         },
1289         ATTR => sub {
1290           my ($self, $v) = @_;
1291           if(my $attr = $self->config_attrs->{$v}) {
1292             return $attr;
1293           } else {
1294             return "";
1295           }
1296         },
1297         catfile => sub {
1298           my ($self, @args) = @_;
1299           io->catfile(@args);
1300         },
1301         catdir => sub {
1302           my ($self, @args) = @_;
1303           io->catdir(@args);
1304         },
1305       };
1306
1307       my $subsre = join( '|', keys %$subs );
1308       $_ =~ s{__($subsre)(?:\((.+?)\))?__}{ $subs->{ $1 }->( $self, $2 ? split( /,/, $2 ) : () ) }eg;
1309
1310       return $_;
1311     }
1312   );
1313
1314   $v->visit( $config_set );
1315
1316
1317   my %sets_by_src;
1318   if($config_set) {
1319     %sets_by_src = map { delete($_->{class}) => $_ }
1320       @{$config_set->{sets}}
1321   }
1322
1323   if (-e "$tmp_fixture_dir") {
1324     $self->msg("- deleting existing temp directory $tmp_fixture_dir");
1325     $tmp_fixture_dir->rmtree;
1326   }
1327   $self->msg("- creating temp dir");
1328   $tmp_fixture_dir->mkpath();
1329   for ( map { $self->_name_for_source($schema->source($_)) } $schema->sources) {
1330     my $from_dir = io->catdir($fixture_dir, $_);
1331     next unless -e "$from_dir";
1332     $from_dir->copy( io->catdir($tmp_fixture_dir, $_)."" );
1333   }
1334
1335   unless (-d "$tmp_fixture_dir") {
1336     DBIx::Class::Exception->throw("Unable to create temporary fixtures dir: $tmp_fixture_dir: $!");
1337   }
1338
1339   my $fixup_visitor;
1340   my $formatter = $schema->storage->datetime_parser;
1341   unless ($@ || !$formatter) {
1342     my %callbacks;
1343     if ($params->{datetime_relative_to}) {
1344       $callbacks{'DateTime::Duration'} = sub {
1345         $params->{datetime_relative_to}->clone->add_duration($_);
1346       };
1347     } else {
1348       $callbacks{'DateTime::Duration'} = sub {
1349         $formatter->format_datetime(DateTime->today->add_duration($_))
1350       };
1351     }
1352     $callbacks{object} ||= "visit_ref";
1353     $fixup_visitor = new Data::Visitor::Callback(%callbacks);
1354   }
1355
1356   $schema->storage->txn_do(sub {
1357     $schema->storage->with_deferred_fk_checks(sub {
1358       foreach my $source (sort $schema->sources) {
1359         $self->msg("- adding " . $source);
1360         my $rs = $schema->resultset($source);
1361         my $source_dir = io->catdir($tmp_fixture_dir, $self->_name_for_source($rs->result_source));
1362         next unless (-e "$source_dir");
1363         my @rows;
1364         while (my $file = $source_dir->next) {
1365           next unless ($file =~ /\.fix$/);
1366           next if $file->is_dir;
1367           my $contents = $file->slurp;
1368           my $HASH1;
1369           eval($contents);
1370           $HASH1 = $fixup_visitor->visit($HASH1) if $fixup_visitor;
1371           if(my $external = delete $HASH1->{external}) {
1372             my @fields = keys %{$sets_by_src{$source}->{external}};
1373             foreach my $field(@fields) {
1374               my $key = $HASH1->{$field};
1375               my $content = decode_base64 ($external->{$field});
1376               my $args = $sets_by_src{$source}->{external}->{$field}->{args};
1377               my ($plus, $class) = ( $sets_by_src{$source}->{external}->{$field}->{class}=~/^(\+)*(.+)$/);
1378               $class = "DBIx::Class::Fixtures::External::$class" unless $plus;
1379               eval "use $class";
1380               $class->restore($key, $content, $args);
1381             }
1382           }
1383           if ( $params->{use_create} ) {
1384             $rs->create( $HASH1 );
1385           } elsif( $params->{use_find_or_create} ) {
1386             $rs->find_or_create( $HASH1 );
1387           } else {
1388             push(@rows, $HASH1);
1389           }
1390         }
1391         $rs->populate(\@rows) if scalar(@rows);
1392
1393         ## Now we need to do some db specific cleanup
1394         ## this probably belongs in a more isolated space.  Right now this is
1395         ## to just handle postgresql SERIAL types that use Sequences
1396
1397         my $table = $rs->result_source->name;
1398         for my $column(my @columns =  $rs->result_source->columns) {
1399           my $info = $rs->result_source->column_info($column);
1400           if(my $sequence = $info->{sequence}) {
1401              $self->msg("- updating sequence $sequence");
1402             $rs->result_source->storage->dbh_do(sub {
1403               my ($storage, $dbh, @cols) = @_;
1404               $self->msg(my $sql = "SELECT setval('${sequence}', (SELECT max($column) FROM ${table}));");
1405               my $sth = $dbh->prepare($sql);
1406               my $rv = $sth->execute or die $sth->errstr;
1407               $self->msg("- $sql");
1408             });
1409           }
1410         }
1411
1412       }
1413     });
1414   });
1415   $self->do_post_ddl( {
1416     schema=>$schema,
1417     post_ddl=>$params->{post_ddl}
1418   } ) if $params->{post_ddl};
1419
1420   $self->msg("- fixtures imported");
1421   $self->msg("- cleaning up");
1422   $tmp_fixture_dir->rmtree;
1423   return 1;
1424 }
1425
1426 sub do_post_ddl {
1427   my ($self, $params) = @_;
1428
1429   my $schema = $params->{schema};
1430   my $data = _read_sql($params->{post_ddl});
1431   foreach (@$data) {
1432     eval { $schema->storage->dbh->do($_) or warn "SQL was:\n $_"};
1433           if ($@ && !$self->{ignore_sql_errors}) { die "SQL was:\n $_\n$@"; }
1434   }
1435   $self->msg("- finished importing post-populate DDL into DB");
1436 }
1437
1438 sub msg {
1439   my $self = shift;
1440   my $subject = shift || return;
1441   my $level = shift || 1;
1442   return unless $self->debug >= $level;
1443   if (ref $subject) {
1444         print Dumper($subject);
1445   } else {
1446         print $subject . "\n";
1447   }
1448 }
1449
1450 # Helper method for ensuring that the name used for a given source
1451 # is always the same (This is used to name the fixture directories
1452 # for example)
1453
1454 sub _name_for_source {
1455     my ($self, $source) = @_;
1456
1457     return ref $source->name ? $source->source_name : $source->name;
1458 }
1459
1460 =head1 AUTHOR
1461
1462   Luke Saunders <luke@shadowcatsystems.co.uk>
1463
1464   Initial development sponsored by and (c) Takkle, Inc. 2007
1465
1466 =head1 CONTRIBUTORS
1467
1468   Ash Berlin <ash@shadowcatsystems.co.uk>
1469
1470   Matt S. Trout <mst@shadowcatsystems.co.uk>
1471
1472   Drew Taylor <taylor.andrew.j@gmail.com>
1473
1474   Frank Switalski <fswitalski@gmail.com>
1475
1476   Chris Akins <chris.hexx@gmail.com>
1477
1478 =head1 LICENSE
1479
1480   This library is free software under the same license as perl itself
1481
1482 =cut
1483
1484 1;