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.001021';
  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   dircopy($tmp_output_dir, $output_dir);
 722
 723   if (-e $output_dir) {
 724     $self->msg("- clearing tmp dir $tmp_output_dir");
 725     # delete existing fixture set
 726     $tmp_output_dir->remove;
 727   }
 728
 729   $self->msg("done");
 730
 731   return 1;
 732 }
 733
 734 sub load_config_file {
 735   my ($self, $config_file) = @_;
 736   DBIx::Class::Exception->throw("config does not exist at $config_file")
 737     unless -e $config_file;
 738
 739   my $config = Config::Any::JSON->load($config_file);
 740
 741   #process includes
 742   if (my $incs = $config->{includes}) {
 743     $self->msg($incs);
 744     DBIx::Class::Exception->throw(
 745       'includes params of config must be an array ref of hashrefs'
 746     ) unless ref $incs eq 'ARRAY';
 747
 748     foreach my $include_config (@$incs) {
 749       DBIx::Class::Exception->throw(
 750         'includes params of config must be an array ref of hashrefs'
 751       ) unless (ref $include_config eq 'HASH') && $include_config->{file};
 752
 753       my $include_file = $self->config_dir->file($include_config->{file});
 754
 755       DBIx::Class::Exception->throw("config does not exist at $include_file")
 756         unless -e $include_file;
 757
 758       my $include = Config::Any::JSON->load($include_file);
 759       $self->msg($include);
 760       $config = merge( $config, $include );
 761     }
 762     delete $config->{includes};
 763   }
 764
 765   # validate config
 766   return DBIx::Class::Exception->throw('config has no sets')
 767     unless $config && $config->{sets} &&
 768            ref $config->{sets} eq 'ARRAY' && scalar @{$config->{sets}};
 769
 770   $config->{might_have} = { fetch => 0 } unless exists $config->{might_have};
 771   $config->{has_many} = { fetch => 0 }   unless exists $config->{has_many};
 772   $config->{belongs_to} = { fetch => 1 } unless exists $config->{belongs_to};
 773
 774   return $config;
 775 }
 776
 777 sub dump_rs {
 778     my ($self, $rs, $params) = @_;
 779
 780     while (my $row = $rs->next) {
 781         $self->dump_object($row, $params);
 782     }
 783 }
 784
 785 sub dump_object {
 786   my ($self, $object, $params) = @_;
 787   my $set = $params->{set};
 788
 789   my $v = Data::Visitor::Callback->new(
 790     plain_value => sub {
 791       my ($visitor, $data) = @_;
 792       my $subs = {
 793        ENV => sub {
 794           my ( $self, $v ) = @_;
 795           if (! defined($ENV{$v})) {
 796             return "";
 797           } else {
 798             return $ENV{ $v };
 799           }
 800         },
 801         ATTR => sub {
 802           my ($self, $v) = @_;
 803           if(my $attr = $self->config_attrs->{$v}) {
 804             return $attr;
 805           } else {
 806             return "";
 807           }
 808         },
 809         catfile => sub {
 810           my ($self, @args) = @_;
 811           catfile(@args);
 812         },
 813         catdir => sub {
 814           my ($self, @args) = @_;
 815           catdir(@args);
 816         },
 817       };
 818
 819       my $subsre = join( '|', keys %$subs );
 820       $_ =~ s{__($subsre)(?:\((.+?)\))?__}{ $subs->{ $1 }->( $self, $2 ? split( /,/, $2 ) : () ) }eg;
 821
 822       return $_;
 823     }
 824   );
 825
 826   $v->visit( $set );
 827
 828   die 'no dir passed to dump_object' unless $params->{set_dir};
 829   die 'no object passed to dump_object' unless $object;
 830
 831   my @inherited_attrs = @{$self->_inherited_attributes};
 832
 833   my @pk_vals = map {
 834     $object->get_column($_)
 835   } $object->primary_columns;
 836
 837   my $key = join("\0", @pk_vals);
 838
 839   my $src = $object->result_source;
 840   my $exists = $self->dumped_objects->{$src->name}{$key}++;
 841
 842
 843   # write dir and gen filename
 844   my $source_dir = $params->{set_dir}->subdir(lc $src->from);
 845   $source_dir->mkpath(0, 0777);
 846
 847   # strip dir separators from file name
 848   my $file = $source_dir->file(
 849       join('-', map { s|[/\\]|_|g; $_; } @pk_vals) . '.fix'
 850   );
 851
 852   # write file
 853   unless ($exists) {
 854     $self->msg('-- dumping ' . $file->stringify, 2);
 855     my %ds = $object->get_columns;
 856
 857     if($set->{external}) {
 858       foreach my $field (keys %{$set->{external}}) {
 859         my $key = $ds{$field};
 860         my ($plus, $class) = ( $set->{external}->{$field}->{class}=~/^(\+)*(.+)$/);
 861         my $args = $set->{external}->{$field}->{args};
 862
 863         $class = "DBIx::Class::Fixtures::External::$class" unless $plus;
 864         eval "use $class";
 865
 866         $ds{external}->{$field} =
 867           encode_base64( $class
 868            ->backup($key => $args));
 869       }
 870     }
 871
 872     # mess with dates if specified
 873     if ($set->{datetime_relative}) {
 874       my $formatter= $object->result_source->schema->storage->datetime_parser;
 875       unless ($@ || !$formatter) {
 876         my $dt;
 877         if ($set->{datetime_relative} eq 'today') {
 878           $dt = DateTime->today;
 879         } else {
 880           $dt = $formatter->parse_datetime($set->{datetime_relative}) unless ($@);
 881         }
 882
 883         while (my ($col, $value) = each %ds) {
 884           my $col_info = $object->result_source->column_info($col);
 885
 886           next unless $value
 887             && $col_info->{_inflate_info}
 888               && (
 889                   (uc($col_info->{data_type}) eq 'DATETIME')
 890                     or (uc($col_info->{data_type}) eq 'DATE')
 891                     or (uc($col_info->{data_type}) eq 'TIME')
 892                     or (uc($col_info->{data_type}) eq 'TIMESTAMP')
 893                     or (uc($col_info->{data_type}) eq 'INTERVAL')
 894                  );
 895
 896           $ds{$col} = $object->get_inflated_column($col)->subtract_datetime($dt);
 897         }
 898       } else {
 899         warn "datetime_relative not supported for this db driver at the moment";
 900       }
 901     }
 902
 903     # do the actual dumping
 904     my $serialized = Dump(\%ds)->Out();
 905     $file->openw->print($serialized);
 906   }
 907
 908   # don't bother looking at rels unless we are actually planning to dump at least one type
 909   my ($might_have, $belongs_to, $has_many) = map {
 910     $set->{$_}{fetch} || $set->{rules}{$src->source_name}{$_}{fetch}
 911   } qw/might_have belongs_to has_many/;
 912
 913   return unless $might_have
 914              || $belongs_to
 915              || $has_many
 916              || $set->{fetch};
 917
 918   # dump rels of object
 919   unless ($exists) {
 920     foreach my $name (sort $src->relationships) {
 921       my $info = $src->relationship_info($name);
 922       my $r_source = $src->related_source($name);
 923       # if belongs_to or might_have with might_have param set or has_many with
 924       # has_many param set then
 925       if (
 926             ( $info->{attrs}{accessor} eq 'single' &&
 927               (!$info->{attrs}{join_type} || $might_have)
 928             )
 929          || $info->{attrs}{accessor} eq 'filter'
 930          ||
 931             ($info->{attrs}{accessor} eq 'multi' && $has_many)
 932       ) {
 933         my $related_rs = $object->related_resultset($name);
 934         my $rule = $set->{rules}->{$related_rs->result_source->source_name};
 935         # these parts of the rule only apply to has_many rels
 936         if ($rule && $info->{attrs}{accessor} eq 'multi') {
 937           $related_rs = $related_rs->search(
 938             $rule->{cond},
 939             { join => $rule->{join} }
 940           ) if ($rule->{cond});
 941
 942           $related_rs = $related_rs->search(
 943             {},
 944             { rows => $rule->{quantity} }
 945           ) if ($rule->{quantity} && $rule->{quantity} ne 'all');
 946
 947           $related_rs = $related_rs->search(
 948             {},
 949             { order_by => $rule->{order_by} }
 950           ) if ($rule->{order_by});
 951
 952         }
 953         if ($set->{has_many}{quantity} &&
 954             $set->{has_many}{quantity} =~ /^\d+$/) {
 955           $related_rs = $related_rs->search(
 956             {},
 957             { rows => $set->{has_many}->{quantity} }
 958           );
 959         }
 960
 961         my %c_params = %{$params};
 962         # inherit date param
 963         my %mock_set = map {
 964           $_ => $set->{$_}
 965         } grep { $set->{$_} } @inherited_attrs;
 966
 967         $c_params{set} = \%mock_set;
 968         $c_params{set} = merge( $c_params{set}, $rule)
 969           if $rule && $rule->{fetch};
 970
 971         $self->dump_rs($related_rs, \%c_params);
 972       }
 973     }
 974   }
 975
 976   return unless $set && $set->{fetch};
 977   foreach my $fetch (@{$set->{fetch}}) {
 978     # inherit date param
 979     $fetch->{$_} = $set->{$_} foreach
 980       grep { !$fetch->{$_} && $set->{$_} } @inherited_attrs;
 981     my $related_rs = $object->related_resultset($fetch->{rel});
 982     my $rule = $set->{rules}->{$related_rs->result_source->source_name};
 983
 984     if ($rule) {
 985       my $info = $object->result_source->relationship_info($fetch->{rel});
 986       if ($info->{attrs}{accessor} eq 'multi') {
 987         $fetch = merge( $fetch, $rule );
 988       } elsif ($rule->{fetch}) {
 989         $fetch = merge( $fetch, { fetch => $rule->{fetch} } );
 990       }
 991     }
 992
 993     die "relationship $fetch->{rel} does not exist for " . $src->source_name
 994       unless ($related_rs);
 995
 996     if ($fetch->{cond} and ref $fetch->{cond} eq 'HASH') {
 997       # if value starts with \ assume it's meant to be passed as a scalar ref
 998       # to dbic.  ideally this would substitute deeply
 999       $fetch->{cond} = { map {
1000           $_ => ($fetch->{cond}->{$_} =~ s/^\\//) ? \$fetch->{cond}->{$_}
1001                                                   : $fetch->{cond}->{$_}
1002       } keys %{$fetch->{cond}} };
1003     }
1004
1005     $related_rs = $related_rs->search(
1006       $fetch->{cond},
1007       { join => $fetch->{join} }
1008     ) if $fetch->{cond};
1009
1010     $related_rs = $related_rs->search(
1011       {},
1012       { rows => $fetch->{quantity} }
1013     ) if $fetch->{quantity} && $fetch->{quantity} ne 'all';
1014     $related_rs = $related_rs->search(
1015       {},
1016       { order_by => $fetch->{order_by} }
1017     ) if $fetch->{order_by};
1018
1019     $self->dump_rs($related_rs, { %{$params}, set => $fetch });
1020   }
1021 }
1022
1023 sub _generate_schema {
1024   my $self = shift;
1025   my $params = shift || {};
1026   require DBI;
1027   $self->msg("\ncreating schema");
1028
1029   my $schema_class = $self->schema_class || "DBIx::Class::Fixtures::Schema";
1030   eval "require $schema_class";
1031   die $@ if $@;
1032
1033   my $pre_schema;
1034   my $connection_details = $params->{connection_details};
1035
1036   $namespace_counter++;
1037
1038   my $namespace = "DBIx::Class::Fixtures::GeneratedSchema_$namespace_counter";
1039   Class::C3::Componentised->inject_base( $namespace => $schema_class );
1040
1041   $pre_schema = $namespace->connect(@{$connection_details});
1042   unless( $pre_schema ) {
1043     return DBIx::Class::Exception->throw('connection details not valid');
1044   }
1045   my @tables = map { $pre_schema->source($_)->from } $pre_schema->sources;
1046   $self->msg("Tables to drop: [". join(', ', sort @tables) . "]");
1047   my $dbh = $pre_schema->storage->dbh;
1048
1049   # clear existing db
1050   $self->msg("- clearing DB of existing tables");
1051   $pre_schema->storage->txn_do(sub {
1052     $pre_schema->storage->with_deferred_fk_checks(sub {
1053       foreach my $table (@tables) {
1054         eval {
1055           $dbh->do("drop table $table" . ($params->{cascade} ? ' cascade' : '') )
1056         };
1057       }
1058     });
1059   });
1060
1061   # import new ddl file to db
1062   my $ddl_file = $params->{ddl};
1063   $self->msg("- deploying schema using $ddl_file");
1064   my $data = _read_sql($ddl_file);
1065   foreach (@$data) {
1066     eval { $dbh->do($_) or warn "SQL was:\n $_"};
1067           if ($@ && !$self->{ignore_sql_errors}) { die "SQL was:\n $_\n$@"; }
1068   }
1069   $self->msg("- finished importing DDL into DB");
1070
1071   # load schema object from our new DB
1072   $namespace_counter++;
1073   my $namespace2 = "DBIx::Class::Fixtures::GeneratedSchema_$namespace_counter";
1074   Class::C3::Componentised->inject_base( $namespace2 => $schema_class );
1075   my $schema = $namespace2->connect(@{$connection_details});
1076   return $schema;
1077 }
1078
1079 sub _read_sql {
1080   my $ddl_file = shift;
1081   my $fh;
1082   open $fh, "<$ddl_file" or die ("Can't open DDL file, $ddl_file ($!)");
1083   my @data = split(/\n/, join('', <$fh>));
1084   @data = grep(!/^--/, @data);
1085   @data = split(/;/, join('', @data));
1086   close($fh);
1087   @data = grep { $_ && $_ !~ /^-- / } @data;
1088   return \@data;
1089 }
1090
1091 =head2 dump_config_sets
1092
1093 Works just like L</dump> but instead of specifying a single json config set
1094 located in L</config_dir> we dump each set named in the C<configs> parameter.
1095
1096 The parameters are the same as for L</dump> except instead of a C<directory>
1097 parameter we have a C<directory_template> which is a coderef expected to return
1098 a scalar that is a root directory where we will do the actual dumping.  This
1099 coderef get three arguments: C<$self>, C<$params> and C<$set_name>.  For
1100 example:
1101
1102     $fixture->dump_all_config_sets({
1103       schema => $schema,
1104       configs => [qw/one.json other.json/],
1105       directory_template => sub {
1106         my ($fixture, $params, $set) = @_;
1107         return File::Spec->catdir('var', 'fixtures', $params->{schema}->version, $set);
1108       },
1109     });
1110
1111 =cut
1112
1113 sub dump_config_sets {
1114   my ($self, $params) = @_;
1115   my $available_config_sets = delete $params->{configs};
1116   my $directory_template = delete $params->{directory_template} ||
1117     DBIx::Class::Exception->throw("'directory_template is required parameter");
1118
1119   for my $set (@$available_config_sets) {
1120     my $localparams = $params;
1121     $localparams->{directory} = $directory_template->($self, $localparams, $set);
1122     $localparams->{config} = $set;
1123     $self->dump($localparams);
1124     $self->dumped_objects({}); ## Clear dumped for next go, if there is one!
1125   }
1126 }
1127
1128 =head2 dump_all_config_sets
1129
1130     my %local_params = %$params;
1131     my $local_self = bless { %$self }, ref($self);
1132     $local_params{directory} = $directory_template->($self, \%local_params, $set);
1133     $local_params{config} = $set;
1134     $self->dump(\%local_params);
1135
1136
1137 Works just like L</dump> but instead of specifying a single json config set
1138 located in L</config_dir> we dump each set in turn to the specified directory.
1139
1140 The parameters are the same as for L</dump> except instead of a C<directory>
1141 parameter we have a C<directory_template> which is a coderef expected to return
1142 a scalar that is a root directory where we will do the actual dumping.  This
1143 coderef get three arguments: C<$self>, C<$params> and C<$set_name>.  For
1144 example:
1145
1146     $fixture->dump_all_config_sets({
1147       schema => $schema,
1148       directory_template => sub {
1149         my ($fixture, $params, $set) = @_;
1150         return File::Spec->catdir('var', 'fixtures', $params->{schema}->version, $set);
1151       },
1152     });
1153
1154 =cut
1155
1156 sub dump_all_config_sets {
1157   my ($self, $params) = @_;
1158   $self->dump_config_sets({
1159     %$params,
1160     configs=>[$self->available_config_sets],
1161   });
1162 }
1163
1164 =head2 populate
1165
1166 =over 4
1167
1168 =item Arguments: \%$attrs
1169
1170 =item Return Value: 1
1171
1172 =back
1173
1174  $fixtures->populate( {
1175    # directory to look for fixtures in, as specified to dump
1176    directory => '/home/me/app/fixtures',
1177
1178    # DDL to deploy
1179    ddl => '/home/me/app/sql/ddl.sql',
1180
1181    # database to clear, deploy and then populate
1182    connection_details => ['dbi:mysql:dbname=app_dev', 'me', 'password'],
1183
1184    # DDL to deploy after populating records, ie. FK constraints
1185    post_ddl => '/home/me/app/sql/post_ddl.sql',
1186
1187    # use CASCADE option when dropping tables
1188    cascade => 1,
1189
1190    # optional, set to 1 to run ddl but not populate
1191    no_populate => 0,
1192
1193         # optional, set to 1 to run each fixture through ->create rather than have
1194    # each $rs populated using $rs->populate. Useful if you have overridden new() logic
1195         # that effects the value of column(s).
1196         use_create => 0,
1197
1198    # Dont try to clean the database, just populate over whats there. Requires
1199    # schema option. Use this if you want to handle removing old data yourself
1200    # no_deploy => 1
1201    # schema => $schema
1202  } );
1203
1204 In this case the database app_dev will be cleared of all tables, then the
1205 specified DDL deployed to it, then finally all fixtures found in
1206 /home/me/app/fixtures will be added to it. populate will generate its own
1207 DBIx::Class schema from the DDL rather than being passed one to use. This is
1208 better as custom insert methods are avoided which can to get in the way. In
1209 some cases you might not have a DDL, and so this method will eventually allow a
1210 $schema object to be passed instead.
1211
1212 If needed, you can specify a post_ddl attribute which is a DDL to be applied
1213 after all the fixtures have been added to the database. A good use of this
1214 option would be to add foreign key constraints since databases like Postgresql
1215 cannot disable foreign key checks.
1216
1217 If your tables have foreign key constraints you may want to use the cascade
1218 attribute which will make the drop table functionality cascade, ie 'DROP TABLE
1219 $table CASCADE'.
1220
1221 C<directory> is a required attribute.
1222
1223 If you wish for DBIx::Class::Fixtures to clear the database for you pass in
1224 C<dll> (path to a DDL sql file) and C<connection_details> (array ref  of DSN,
1225 user and pass).
1226
1227 If you wish to deal with cleaning the schema yourself, then pass in a C<schema>
1228 attribute containing the connected schema you wish to operate on and set the
1229 C<no_deploy> attribute.
1230
1231 =cut
1232
1233 sub populate {
1234   my $self = shift;
1235   my ($params) = @_;
1236   DBIx::Class::Exception->throw('first arg to populate must be hash ref')
1237     unless ref $params eq 'HASH';
1238
1239   DBIx::Class::Exception->throw('directory param not specified')
1240     unless $params->{directory};
1241
1242   my $fixture_dir = dir(delete $params->{directory});
1243   DBIx::Class::Exception->throw("fixture directory '$fixture_dir' does not exist")
1244     unless -d $fixture_dir;
1245
1246   my $ddl_file;
1247   my $dbh;
1248   my $schema;
1249   if ($params->{ddl} && $params->{connection_details}) {
1250     $ddl_file = file(delete $params->{ddl});
1251     unless (-e $ddl_file) {
1252       return DBIx::Class::Exception->throw('DDL does not exist at ' . $ddl_file);
1253     }
1254     unless (ref $params->{connection_details} eq 'ARRAY') {
1255       return DBIx::Class::Exception->throw('connection details must be an arrayref');
1256     }
1257     $schema = $self->_generate_schema({
1258       ddl => $ddl_file,
1259       connection_details => delete $params->{connection_details},
1260       %{$params}
1261     });
1262   } elsif ($params->{schema} && $params->{no_deploy}) {
1263     $schema = $params->{schema};
1264   } else {
1265     DBIx::Class::Exception->throw('you must set the ddl and connection_details params');
1266   }
1267
1268
1269   return 1 if $params->{no_populate};
1270
1271   $self->msg("\nimporting fixtures");
1272   my $tmp_fixture_dir = tempdir();
1273   my $version_file = file($fixture_dir, '_dumper_version');
1274   my $config_set_path = file($fixture_dir, '_config_set');
1275   my $config_set = -e $config_set_path ? do { my $VAR1; eval($config_set_path->slurp); $VAR1 } : '';
1276
1277   my $v = Data::Visitor::Callback->new(
1278     plain_value => sub {
1279       my ($visitor, $data) = @_;
1280       my $subs = {
1281        ENV => sub {
1282           my ( $self, $v ) = @_;
1283           if (! defined($ENV{$v})) {
1284             return "";
1285           } else {
1286             return $ENV{ $v };
1287           }
1288         },
1289         ATTR => sub {
1290           my ($self, $v) = @_;
1291           if(my $attr = $self->config_attrs->{$v}) {
1292             return $attr;
1293           } else {
1294             return "";
1295           }
1296         },
1297         catfile => sub {
1298           my ($self, @args) = @_;
1299           catfile(@args);
1300         },
1301         catdir => sub {
1302           my ($self, @args) = @_;
1303           catdir(@args);
1304         },
1305       };
1306
1307       my $subsre = join( '|', keys %$subs );
1308       $_ =~ s{__($subsre)(?:\((.+?)\))?__}{ $subs->{ $1 }->( $self, $2 ? split( /,/, $2 ) : () ) }eg;
1309
1310       return $_;
1311     }
1312   );
1313
1314   $v->visit( $config_set );
1315
1316
1317   my %sets_by_src;
1318   if($config_set) {
1319     %sets_by_src = map { delete($_->{class}) => $_ }
1320       @{$config_set->{sets}}
1321   }
1322
1323 #  DBIx::Class::Exception->throw('no version file found');
1324 #    unless -e $version_file;
1325
1326   if (-e $tmp_fixture_dir) {
1327     $self->msg("- deleting existing temp directory $tmp_fixture_dir");
1328     $tmp_fixture_dir->rmtree;
1329   }
1330   $self->msg("- creating temp dir");
1331   $tmp_fixture_dir->mkpath();
1332   for ( map { $schema->source($_)->from } $schema->sources) {
1333     my $from_dir = $fixture_dir->subdir($_);
1334     next unless -e $from_dir;
1335     dircopy($from_dir, $tmp_fixture_dir->subdir($_) );
1336   }
1337
1338   unless (-d $tmp_fixture_dir) {
1339     DBIx::Class::Exception->throw("Unable to create temporary fixtures dir: $tmp_fixture_dir: $!");
1340   }
1341
1342   my $fixup_visitor;
1343   my $formatter = $schema->storage->datetime_parser;
1344   unless ($@ || !$formatter) {
1345     my %callbacks;
1346     if ($params->{datetime_relative_to}) {
1347       $callbacks{'DateTime::Duration'} = sub {
1348         $params->{datetime_relative_to}->clone->add_duration($_);
1349       };
1350     } else {
1351       $callbacks{'DateTime::Duration'} = sub {
1352         $formatter->format_datetime(DateTime->today->add_duration($_))
1353       };
1354     }
1355     $callbacks{object} ||= "visit_ref";
1356     $fixup_visitor = new Data::Visitor::Callback(%callbacks);
1357   }
1358
1359   $schema->storage->txn_do(sub {
1360     $schema->storage->with_deferred_fk_checks(sub {
1361       foreach my $source (sort $schema->sources) {
1362         $self->msg("- adding " . $source);
1363         my $rs = $schema->resultset($source);
1364         my $source_dir = $tmp_fixture_dir->subdir( lc $rs->result_source->from );
1365         next unless (-e $source_dir);
1366         my @rows;
1367         while (my $file = $source_dir->next) {
1368           next unless ($file =~ /\.fix$/);
1369           next if $file->is_dir;
1370           my $contents = $file->slurp;
1371           my $HASH1;
1372           eval($contents);
1373           $HASH1 = $fixup_visitor->visit($HASH1) if $fixup_visitor;
1374           if(my $external = delete $HASH1->{external}) {
1375             my @fields = keys %{$sets_by_src{$source}->{external}};
1376             foreach my $field(@fields) {
1377               my $key = $HASH1->{$field};
1378               my $content = decode_base64 ($external->{$field});
1379               my $args = $sets_by_src{$source}->{external}->{$field}->{args};
1380               my ($plus, $class) = ( $sets_by_src{$source}->{external}->{$field}->{class}=~/^(\+)*(.+)$/);
1381               $class = "DBIx::Class::Fixtures::External::$class" unless $plus;
1382               eval "use $class";
1383               $class->restore($key, $content, $args);
1384             }
1385           }
1386           if ( $params->{use_create} ) {
1387             $rs->create( $HASH1 );
1388           } else {
1389             push(@rows, $HASH1);
1390           }
1391         }
1392         $rs->populate(\@rows) if scalar(@rows);
1393
1394         ## Now we need to do some db specific cleanup
1395         ## this probably belongs in a more isolated space.  Right now this is
1396         ## to just handle postgresql SERIAL types that use Sequences
1397
1398         my $table = $rs->result_source->name;
1399         for my $column(my @columns =  $rs->result_source->columns) {
1400           my $info = $rs->result_source->column_info($column);
1401           if(my $sequence = $info->{sequence}) {
1402              $self->msg("- updating sequence $sequence");
1403             $rs->result_source->storage->dbh_do(sub {
1404               my ($storage, $dbh, @cols) = @_;
1405               $self->msg(my $sql = "SELECT setval('${sequence}', (SELECT max($column) FROM ${table}));");
1406               my $sth = $dbh->prepare($sql);
1407               my $rv = $sth->execute or die $sth->errstr;
1408               $self->msg("- $sql");
1409             });
1410           }
1411         }
1412
1413       }
1414     });
1415   });
1416   $self->do_post_ddl( {
1417     schema=>$schema,
1418     post_ddl=>$params->{post_ddl}
1419   } ) if $params->{post_ddl};
1420
1421   $self->msg("- fixtures imported");
1422   $self->msg("- cleaning up");
1423   $tmp_fixture_dir->rmtree;
1424   return 1;
1425 }
1426
1427 sub do_post_ddl {
1428   my ($self, $params) = @_;
1429
1430   my $schema = $params->{schema};
1431   my $data = _read_sql($params->{post_ddl});
1432   foreach (@$data) {
1433     eval { $schema->storage->dbh->do($_) or warn "SQL was:\n $_"};
1434           if ($@ && !$self->{ignore_sql_errors}) { die "SQL was:\n $_\n$@"; }
1435   }
1436   $self->msg("- finished importing post-populate DDL into DB");
1437 }
1438
1439 sub msg {
1440   my $self = shift;
1441   my $subject = shift || return;
1442   my $level = shift || 1;
1443   return unless $self->debug >= $level;
1444   if (ref $subject) {
1445         print Dumper($subject);
1446   } else {
1447         print $subject . "\n";
1448   }
1449 }
1450
1451 =head1 AUTHOR
1452
1453   Luke Saunders <luke@shadowcatsystems.co.uk>
1454
1455   Initial development sponsored by and (c) Takkle, Inc. 2007
1456
1457 =head1 CONTRIBUTORS
1458
1459   Ash Berlin <ash@shadowcatsystems.co.uk>
1460
1461   Matt S. Trout <mst@shadowcatsystems.co.uk>
1462
1463   Drew Taylor <taylor.andrew.j@gmail.com>
1464
1465   Frank Switalski <fswitalski@gmail.com>
1466
1467   Chris Akins <chris.hexx@gmail.com>
1468
1469 =head1 LICENSE
1470
1471   This library is free software under the same license as perl itself
1472
1473 =cut
1474
1475 1;