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