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