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