lib/DBIx/Class/Schema/Loader/Base.pm

   1 package DBIx::Class::Schema::Loader::Base;
   2
   3 use strict;
   4 use warnings;
   5 use base qw/Class::Accessor::Grouped Class::C3::Componentised/;
   6 use Class::C3;
   7 use Carp::Clan qw/^DBIx::Class/;
   8 use DBIx::Class::Schema::Loader::RelBuilder;
   9 use Data::Dump qw/ dump /;
  10 use POSIX qw//;
  11 use File::Spec qw//;
  12 use Cwd qw//;
  13 use Digest::MD5 qw//;
  14 use Lingua::EN::Inflect::Number qw//;
  15 use File::Temp qw//;
  16 use Class::Unload;
  17 require DBIx::Class;
  18
  19 our $VERSION = '0.04999_13';
  20
  21 __PACKAGE__->mk_group_ro_accessors('simple', qw/
  22                                 schema
  23                                 schema_class
  24
  25                                 exclude
  26                                 constraint
  27                                 additional_classes
  28                                 additional_base_classes
  29                                 left_base_classes
  30                                 components
  31                                 resultset_components
  32                                 skip_relationships
  33                                 skip_load_external
  34                                 moniker_map
  35                                 inflect_singular
  36                                 inflect_plural
  37                                 debug
  38                                 dump_directory
  39                                 dump_overwrite
  40                                 really_erase_my_files
  41                                 result_namespace
  42                                 resultset_namespace
  43                                 default_resultset_class
  44                                 schema_base_class
  45                                 result_base_class
  46                                 overwrite_modifications
  47
  48                                 relationship_attrs
  49
  50                                 db_schema
  51                                 _tables
  52                                 classes
  53                                 _upgrading_classes
  54                                 monikers
  55                                 dynamic
  56                                 naming
  57 /);
  58
  59
  60 __PACKAGE__->mk_group_accessors('simple', qw/
  61                                 version_to_dump
  62                                 schema_version_to_dump
  63                                 _upgrading_from
  64                                 _upgrading_from_load_classes
  65                                 use_namespaces
  66 /);
  67
  68 =head1 NAME
  69
  70 DBIx::Class::Schema::Loader::Base - Base DBIx::Class::Schema::Loader Implementation.
  71
  72 =head1 SYNOPSIS
  73
  74 See L<DBIx::Class::Schema::Loader>
  75
  76 =head1 DESCRIPTION
  77
  78 This is the base class for the storage-specific C<DBIx::Class::Schema::*>
  79 classes, and implements the common functionality between them.
  80
  81 =head1 CONSTRUCTOR OPTIONS
  82
  83 These constructor options are the base options for
  84 L<DBIx::Class::Schema::Loader/loader_options>.  Available constructor options are:
  85
  86 =head2 skip_relationships
  87
  88 Skip setting up relationships.  The default is to attempt the loading
  89 of relationships.
  90
  91 =head2 skip_load_external
  92
  93 Skip loading of other classes in @INC. The default is to merge all other classes
  94 with the same name found in @INC into the schema file we are creating.
  95
  96 =head2 naming
  97
  98 Static schemas (ones dumped to disk) will, by default, use the new-style 0.05XXX
  99 relationship names and singularized Results, unless you're overwriting an
 100 existing dump made by a 0.04XXX version of L<DBIx::Class::Schema::Loader>, in
 101 which case the backward compatible RelBuilder will be activated, and
 102 singularization will be turned off.
 103
 104 Specifying
 105
 106     naming => 'v5'
 107
 108 will disable the backward-compatible RelBuilder and use
 109 the new-style relationship names along with singularized Results, even when
 110 overwriting a dump made with an earlier version.
 111
 112 The option also takes a hashref:
 113
 114     naming => { relationships => 'v5', monikers => 'v4' }
 115
 116 The keys are:
 117
 118 =over 4
 119
 120 =item relationships
 121
 122 How to name relationship accessors.
 123
 124 =item monikers
 125
 126 How to name Result classes.
 127
 128 =back
 129
 130 The values can be:
 131
 132 =over 4
 133
 134 =item current
 135
 136 Latest default style, whatever that happens to be.
 137
 138 =item v5
 139
 140 Version 0.05XXX style.
 141
 142 =item v4
 143
 144 Version 0.04XXX style.
 145
 146 =back
 147
 148 Dynamic schemas will always default to the 0.04XXX relationship names and won't
 149 singularize Results for backward compatibility, to activate the new RelBuilder
 150 and singularization put this in your C<Schema.pm> file:
 151
 152     __PACKAGE__->naming('current');
 153
 154 Or if you prefer to use 0.05XXX features but insure that nothing breaks in the
 155 next major version upgrade:
 156
 157     __PACKAGE__->naming('v5');
 158
 159 =head2 relationship_attrs
 160
 161 Hashref of attributes to pass to each generated relationship, listed
 162 by type.  Also supports relationship type 'all', containing options to
 163 pass to all generated relationships.  Attributes set for more specific
 164 relationship types override those set in 'all'.
 165
 166 For example:
 167
 168   relationship_attrs => {
 169     all      => { cascade_delete => 0 },
 170     has_many => { cascade_delete => 1 },
 171   },
 172
 173 will set the C<cascade_delete> option to 0 for all generated relationships,
 174 except for C<has_many>, which will have cascade_delete as 1.
 175
 176 NOTE: this option is not supported if v4 backward-compatible naming is
 177 set either globally (naming => 'v4') or just for relationships.
 178
 179 =head2 debug
 180
 181 If set to true, each constructive L<DBIx::Class> statement the loader
 182 decides to execute will be C<warn>-ed before execution.
 183
 184 =head2 db_schema
 185
 186 Set the name of the schema to load (schema in the sense that your database
 187 vendor means it).  Does not currently support loading more than one schema
 188 name.
 189
 190 =head2 constraint
 191
 192 Only load tables matching regex.  Best specified as a qr// regex.
 193
 194 =head2 exclude
 195
 196 Exclude tables matching regex.  Best specified as a qr// regex.
 197
 198 =head2 moniker_map
 199
 200 Overrides the default table name to moniker translation.  Can be either
 201 a hashref of table keys and moniker values, or a coderef for a translator
 202 function taking a single scalar table name argument and returning
 203 a scalar moniker.  If the hash entry does not exist, or the function
 204 returns a false value, the code falls back to default behavior
 205 for that table name.
 206
 207 The default behavior is to singularize the table name, and: C<join '', map
 208 ucfirst, split /[\W_]+/, lc $table>, which is to say: lowercase everything,
 209 split up the table name into chunks anywhere a non-alpha-numeric character
 210 occurs, change the case of first letter of each chunk to upper case, and put
 211 the chunks back together.  Examples:
 212
 213     Table Name  | Moniker Name
 214     ---------------------------
 215     luser       | Luser
 216     luser_group | LuserGroup
 217     luser-opts  | LuserOpt
 218
 219 =head2 inflect_plural
 220
 221 Just like L</moniker_map> above (can be hash/code-ref, falls back to default
 222 if hash key does not exist or coderef returns false), but acts as a map
 223 for pluralizing relationship names.  The default behavior is to utilize
 224 L<Lingua::EN::Inflect::Number/to_PL>.
 225
 226 =head2 inflect_singular
 227
 228 As L</inflect_plural> above, but for singularizing relationship names.
 229 Default behavior is to utilize L<Lingua::EN::Inflect::Number/to_S>.
 230
 231 =head2 schema_base_class
 232
 233 Base class for your schema classes. Defaults to 'DBIx::Class::Schema'.
 234
 235 =head2 result_base_class
 236
 237 Base class for your table classes (aka result classes). Defaults to
 238 'DBIx::Class::Core'.
 239
 240 =head2 additional_base_classes
 241
 242 List of additional base classes all of your table classes will use.
 243
 244 =head2 left_base_classes
 245
 246 List of additional base classes all of your table classes will use
 247 that need to be leftmost.
 248
 249 =head2 additional_classes
 250
 251 List of additional classes which all of your table classes will use.
 252
 253 =head2 components
 254
 255 List of additional components to be loaded into all of your table
 256 classes.  A good example would be C<ResultSetManager>.
 257
 258 =head2 resultset_components
 259
 260 List of additional ResultSet components to be loaded into your table
 261 classes.  A good example would be C<AlwaysRS>.  Component
 262 C<ResultSetManager> will be automatically added to the above
 263 C<components> list if this option is set.
 264
 265 =head2 use_namespaces
 266
 267 This is now the default, to go back to L<DBIx::Class::Schema/load_classes> pass
 268 a C<0>.
 269
 270 Generate result class names suitable for
 271 L<DBIx::Class::Schema/load_namespaces> and call that instead of
 272 L<DBIx::Class::Schema/load_classes>. When using this option you can also
 273 specify any of the options for C<load_namespaces> (i.e. C<result_namespace>,
 274 C<resultset_namespace>, C<default_resultset_class>), and they will be added
 275 to the call (and the generated result class names adjusted appropriately).
 276
 277 =head2 dump_directory
 278
 279 This option is designed to be a tool to help you transition from this
 280 loader to a manually-defined schema when you decide it's time to do so.
 281
 282 The value of this option is a perl libdir pathname.  Within
 283 that directory this module will create a baseline manual
 284 L<DBIx::Class::Schema> module set, based on what it creates at runtime
 285 in memory.
 286
 287 The created schema class will have the same classname as the one on
 288 which you are setting this option (and the ResultSource classes will be
 289 based on this name as well).
 290
 291 Normally you wouldn't hard-code this setting in your schema class, as it
 292 is meant for one-time manual usage.
 293
 294 See L<DBIx::Class::Schema::Loader/dump_to_dir> for examples of the
 295 recommended way to access this functionality.
 296
 297 =head2 dump_overwrite
 298
 299 Deprecated.  See L</really_erase_my_files> below, which does *not* mean
 300 the same thing as the old C<dump_overwrite> setting from previous releases.
 301
 302 =head2 really_erase_my_files
 303
 304 Default false.  If true, Loader will unconditionally delete any existing
 305 files before creating the new ones from scratch when dumping a schema to disk.
 306
 307 The default behavior is instead to only replace the top portion of the
 308 file, up to and including the final stanza which contains
 309 C<# DO NOT MODIFY THIS OR ANYTHING ABOVE!>
 310 leaving any customizations you placed after that as they were.
 311
 312 When C<really_erase_my_files> is not set, if the output file already exists,
 313 but the aforementioned final stanza is not found, or the checksum
 314 contained there does not match the generated contents, Loader will
 315 croak and not touch the file.
 316
 317 You should really be using version control on your schema classes (and all
 318 of the rest of your code for that matter).  Don't blame me if a bug in this
 319 code wipes something out when it shouldn't have, you've been warned.
 320
 321 =head2 overwrite_modifications
 322
 323 Default false.  If false, when updating existing files, Loader will
 324 refuse to modify any Loader-generated code that has been modified
 325 since its last run (as determined by the checksum Loader put in its
 326 comment lines).
 327
 328 If true, Loader will discard any manual modifications that have been
 329 made to Loader-generated code.
 330
 331 Again, you should be using version control on your schema classes.  Be
 332 careful with this option.
 333
 334 =head1 METHODS
 335
 336 None of these methods are intended for direct invocation by regular
 337 users of L<DBIx::Class::Schema::Loader>.  Anything you can find here
 338 can also be found via standard L<DBIx::Class::Schema> methods somehow.
 339
 340 =cut
 341
 342 use constant CURRENT_V => 'v5';
 343
 344 # ensure that a peice of object data is a valid arrayref, creating
 345 # an empty one or encapsulating whatever's there.
 346 sub _ensure_arrayref {
 347     my $self = shift;
 348
 349     foreach (@_) {
 350         $self->{$_} ||= [];
 351         $self->{$_} = [ $self->{$_} ]
 352             unless ref $self->{$_} eq 'ARRAY';
 353     }
 354 }
 355
 356 =head2 new
 357
 358 Constructor for L<DBIx::Class::Schema::Loader::Base>, used internally
 359 by L<DBIx::Class::Schema::Loader>.
 360
 361 =cut
 362
 363 sub new {
 364     my ( $class, %args ) = @_;
 365
 366     my $self = { %args };
 367
 368     bless $self => $class;
 369
 370     $self->_ensure_arrayref(qw/additional_classes
 371                                additional_base_classes
 372                                left_base_classes
 373                                components
 374                                resultset_components
 375                               /);
 376
 377     push(@{$self->{components}}, 'ResultSetManager')
 378         if @{$self->{resultset_components}};
 379
 380     $self->{monikers} = {};
 381     $self->{classes} = {};
 382     $self->{_upgrading_classes} = {};
 383
 384     $self->{schema_class} ||= ( ref $self->{schema} || $self->{schema} );
 385     $self->{schema} ||= $self->{schema_class};
 386
 387     croak "dump_overwrite is deprecated.  Please read the"
 388         . " DBIx::Class::Schema::Loader::Base documentation"
 389             if $self->{dump_overwrite};
 390
 391     $self->{dynamic} = ! $self->{dump_directory};
 392     $self->{temp_directory} ||= File::Temp::tempdir( 'dbicXXXX',
 393                                                      TMPDIR  => 1,
 394                                                      CLEANUP => 1,
 395                                                    );
 396
 397     $self->{dump_directory} ||= $self->{temp_directory};
 398
 399     $self->version_to_dump($DBIx::Class::Schema::Loader::VERSION);
 400     $self->schema_version_to_dump($DBIx::Class::Schema::Loader::VERSION);
 401
 402     if ((not ref $self->naming) && defined $self->naming) {
 403         my $naming_ver = $self->naming;
 404         $self->{naming} = {
 405             relationships => $naming_ver,
 406             monikers => $naming_ver,
 407         };
 408     }
 409
 410     if ($self->naming) {
 411         for (values %{ $self->naming }) {
 412             $_ = CURRENT_V if $_ eq 'current';
 413         }
 414     }
 415     $self->{naming} ||= {};
 416
 417     $self->_check_back_compat;
 418
 419     $self->use_namespaces(1) unless defined $self->use_namespaces;
 420
 421     $self;
 422 }
 423
 424 sub _check_back_compat {
 425     my ($self) = @_;
 426
 427 # dynamic schemas will always be in 0.04006 mode, unless overridden
 428     if ($self->dynamic) {
 429 # just in case, though no one is likely to dump a dynamic schema
 430         $self->schema_version_to_dump('0.04006');
 431
 432         if (not %{ $self->naming }) {
 433             warn <<EOF unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 434
 435 Dynamic schema detected, will run in 0.04006 mode.
 436
 437 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
 438 to disable this warning.
 439
 440 Also consider setting 'use_namespaces => 1' if/when upgrading.
 441
 442 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
 443 details.
 444 EOF
 445         }
 446         else {
 447             $self->_upgrading_from('v4');
 448         }
 449
 450         $self->naming->{relationships} ||= 'v4';
 451         $self->naming->{monikers}      ||= 'v4';
 452
 453         if ($self->use_namespaces) {
 454             $self->_upgrading_from_load_classes(1);
 455         }
 456         else {
 457             $self->use_namespaces(0);
 458         }
 459
 460         return;
 461     }
 462
 463 # otherwise check if we need backcompat mode for a static schema
 464     my $filename = $self->_get_dump_filename($self->schema_class);
 465     return unless -e $filename;
 466
 467     open(my $fh, '<', $filename)
 468         or croak "Cannot open '$filename' for reading: $!";
 469
 470     my $load_classes = 0;
 471
 472     while (<$fh>) {
 473         if (/^__PACKAGE__->load_classes;/) {
 474             $load_classes = 1;
 475         } elsif (my ($real_ver) =
 476                 /^# Created by DBIx::Class::Schema::Loader v(\d+\.\d+)/) {
 477
 478             if ($load_classes && (not defined $self->use_namespaces)) {
 479                 warn <<"EOF"  unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 480
 481 'load_classes;' static schema detected, turning off 'use_namespaces'.
 482
 483 Set the 'use_namespaces' attribute or the SCHEMA_LOADER_BACKCOMPAT environment
 484 variable to disable this warning.
 485
 486 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
 487 details.
 488 EOF
 489                 $self->use_namespaces(0);
 490             }
 491             elsif ($load_classes && $self->use_namespaces) {
 492                 $self->_upgrading_from_load_classes(1);
 493             }
 494
 495             # XXX when we go past .0 this will need fixing
 496             my ($v) = $real_ver =~ /([1-9])/;
 497             $v = "v$v";
 498
 499             last if $v eq CURRENT_V || $real_ver =~ /^0\.\d\d999/;
 500
 501             if (not %{ $self->naming }) {
 502                 warn <<"EOF" unless $ENV{SCHEMA_LOADER_BACKCOMPAT};
 503
 504 Version $real_ver static schema detected, turning on backcompat mode.
 505
 506 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
 507 to disable this warning.
 508
 509 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 for more
 510 details.
 511 EOF
 512             }
 513             else {
 514                 $self->_upgrading_from($v);
 515                 last;
 516             }
 517
 518             $self->naming->{relationships} ||= $v;
 519             $self->naming->{monikers}      ||= $v;
 520
 521             $self->schema_version_to_dump($real_ver);
 522
 523             last;
 524         }
 525     }
 526     close $fh;
 527 }
 528
 529 sub _find_file_in_inc {
 530     my ($self, $file) = @_;
 531
 532     foreach my $prefix (@INC) {
 533         my $fullpath = File::Spec->catfile($prefix, $file);
 534         return $fullpath if -f $fullpath
 535             and Cwd::abs_path($fullpath) ne
 536                (Cwd::abs_path(File::Spec->catfile($self->dump_directory, $file)) || '');
 537     }
 538
 539     return;
 540 }
 541
 542 sub _class_path {
 543     my ($self, $class) = @_;
 544
 545     my $class_path = $class;
 546     $class_path =~ s{::}{/}g;
 547     $class_path .= '.pm';
 548
 549     return $class_path;
 550 }
 551
 552 sub _find_class_in_inc {
 553     my ($self, $class) = @_;
 554
 555     return $self->_find_file_in_inc($self->_class_path($class));
 556 }
 557
 558 sub _rewrite_old_classnames {
 559     my ($self, $code) = @_;
 560
 561     return $code unless $self->_upgrading_from;
 562
 563     my %old_classes = reverse %{ $self->_upgrading_classes };
 564
 565     my $re = join '|', keys %old_classes;
 566     $re = qr/\b($re)\b/;
 567
 568     $code =~ s/$re/$old_classes{$1} || $1/eg;
 569
 570     return $code;
 571 }
 572
 573 sub _load_external {
 574     my ($self, $class) = @_;
 575
 576     return if $self->{skip_load_external};
 577
 578     # so that we don't load our own classes, under any circumstances
 579     local *INC = [ grep $_ ne $self->dump_directory, @INC ];
 580
 581     my $real_inc_path = $self->_find_class_in_inc($class);
 582
 583     my $old_class = $self->_upgrading_classes->{$class}
 584         if $self->_upgrading_from;
 585
 586     my $old_real_inc_path = $self->_find_class_in_inc($old_class)
 587         if $old_class && $old_class ne $class;
 588
 589     return unless $real_inc_path || $old_real_inc_path;
 590
 591     if ($real_inc_path) {
 592         # If we make it to here, we loaded an external definition
 593         warn qq/# Loaded external class definition for '$class'\n/
 594             if $self->debug;
 595
 596         open(my $fh, '<', $real_inc_path)
 597             or croak "Failed to open '$real_inc_path' for reading: $!";
 598         my $code = do { local $/; <$fh> };
 599         close($fh)
 600             or croak "Failed to close $real_inc_path: $!";
 601         $code = $self->_rewrite_old_classnames($code);
 602
 603         if ($self->dynamic) { # load the class too
 604             # kill redefined warnings
 605             my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
 606             local $SIG{__WARN__} = sub {
 607                 $warn_handler->(@_)
 608                     unless $_[0] =~ /^Subroutine \S+ redefined/;
 609             };
 610             eval $code;
 611             die $@ if $@;
 612         }
 613
 614         $self->_ext_stmt($class,
 615           qq|# These lines were loaded from '$real_inc_path' found in \@INC.\n|
 616          .qq|# They are now part of the custom portion of this file\n|
 617          .qq|# for you to hand-edit.  If you do not either delete\n|
 618          .qq|# this section or remove that file from \@INC, this section\n|
 619          .qq|# will be repeated redundantly when you re-create this\n|
 620          .qq|# file again via Loader!  See skip_load_external to disable\n|
 621          .qq|# this feature.\n|
 622         );
 623         chomp $code;
 624         $self->_ext_stmt($class, $code);
 625         $self->_ext_stmt($class,
 626             qq|# End of lines loaded from '$real_inc_path' |
 627         );
 628     }
 629
 630     if ($old_real_inc_path) {
 631         open(my $fh, '<', $old_real_inc_path)
 632             or croak "Failed to open '$old_real_inc_path' for reading: $!";
 633         $self->_ext_stmt($class, <<"EOF");
 634
 635 # These lines were loaded from '$old_real_inc_path',
 636 # based on the Result class name that would have been created by an 0.04006
 637 # version of the Loader. For a static schema, this happens only once during
 638 # upgrade. See skip_load_external to disable this feature.
 639 EOF
 640
 641         my $code = do {
 642             local ($/, @ARGV) = (undef, $old_real_inc_path); <>
 643         };
 644         $code = $self->_rewrite_old_classnames($code);
 645
 646         if ($self->dynamic) {
 647             warn <<"EOF";
 648
 649 Detected external content in '$old_real_inc_path', a class name that would have
 650 been used by an 0.04006 version of the Loader.
 651
 652 * PLEASE RENAME THIS CLASS: from '$old_class' to '$class', as that is the
 653 new name of the Result.
 654 EOF
 655             # kill redefined warnings
 656             my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
 657             local $SIG{__WARN__} = sub {
 658                 $warn_handler->(@_)
 659                     unless $_[0] =~ /^Subroutine \S+ redefined/;
 660             };
 661             eval $code;
 662             die $@ if $@;
 663         }
 664
 665         chomp $code;
 666         $self->_ext_stmt($class, $code);
 667         $self->_ext_stmt($class,
 668             qq|# End of lines loaded from '$old_real_inc_path' |
 669         );
 670     }
 671 }
 672
 673 =head2 load
 674
 675 Does the actual schema-construction work.
 676
 677 =cut
 678
 679 sub load {
 680     my $self = shift;
 681
 682     $self->_load_tables($self->_tables_list);
 683 }
 684
 685 =head2 rescan
 686
 687 Arguments: schema
 688
 689 Rescan the database for newly added tables.  Does
 690 not process drops or changes.  Returns a list of
 691 the newly added table monikers.
 692
 693 The schema argument should be the schema class
 694 or object to be affected.  It should probably
 695 be derived from the original schema_class used
 696 during L</load>.
 697
 698 =cut
 699
 700 sub rescan {
 701     my ($self, $schema) = @_;
 702
 703     $self->{schema} = $schema;
 704     $self->_relbuilder->{schema} = $schema;
 705
 706     my @created;
 707     my @current = $self->_tables_list;
 708     foreach my $table ($self->_tables_list) {
 709         if(!exists $self->{_tables}->{$table}) {
 710             push(@created, $table);
 711         }
 712     }
 713
 714     my $loaded = $self->_load_tables(@created);
 715
 716     return map { $self->monikers->{$_} } @$loaded;
 717 }
 718
 719 sub _relbuilder {
 720     no warnings 'uninitialized';
 721     my ($self) = @_;
 722
 723     return if $self->{skip_relationships};
 724
 725     if ($self->naming->{relationships} eq 'v4') {
 726         require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040;
 727         return $self->{relbuilder} ||=
 728             DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040->new(
 729                 $self->schema, $self->inflect_plural, $self->inflect_singular
 730             );
 731     }
 732
 733     $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new (
 734          $self->schema,
 735          $self->inflect_plural,
 736          $self->inflect_singular,
 737          $self->relationship_attrs,
 738     );
 739 }
 740
 741 sub _load_tables {
 742     my ($self, @tables) = @_;
 743
 744     # First, use _tables_list with constraint and exclude
 745     #  to get a list of tables to operate on
 746
 747     my $constraint   = $self->constraint;
 748     my $exclude      = $self->exclude;
 749
 750     @tables = grep { /$constraint/ } @tables if $constraint;
 751     @tables = grep { ! /$exclude/ } @tables if $exclude;
 752
 753     # Save the new tables to the tables list
 754     foreach (@tables) {
 755         $self->{_tables}->{$_} = 1;
 756     }
 757
 758     $self->_make_src_class($_) for @tables;
 759     $self->_setup_src_meta($_) for @tables;
 760
 761     if(!$self->skip_relationships) {
 762         # The relationship loader needs a working schema
 763         $self->{quiet} = 1;
 764         local $self->{dump_directory} = $self->{temp_directory};
 765         $self->_reload_classes(\@tables);
 766         $self->_load_relationships($_) for @tables;
 767         $self->{quiet} = 0;
 768
 769         # Remove that temp dir from INC so it doesn't get reloaded
 770         @INC = grep $_ ne $self->dump_directory, @INC;
 771     }
 772
 773     $self->_load_external($_)
 774         for map { $self->classes->{$_} } @tables;
 775
 776     # Reload without unloading first to preserve any symbols from external
 777     # packages.
 778     $self->_reload_classes(\@tables, 0);
 779
 780     # Drop temporary cache
 781     delete $self->{_cache};
 782
 783     return \@tables;
 784 }
 785
 786 sub _reload_classes {
 787     my ($self, $tables, $unload) = @_;
 788
 789     my @tables = @$tables;
 790     $unload = 1 unless defined $unload;
 791
 792     # so that we don't repeat custom sections
 793     @INC = grep $_ ne $self->dump_directory, @INC;
 794
 795     $self->_dump_to_dir(map { $self->classes->{$_} } @tables);
 796
 797     unshift @INC, $self->dump_directory;
 798
 799     my @to_register;
 800     my %have_source = map { $_ => $self->schema->source($_) }
 801         $self->schema->sources;
 802
 803     for my $table (@tables) {
 804         my $moniker = $self->monikers->{$table};
 805         my $class = $self->classes->{$table};
 806
 807         {
 808             no warnings 'redefine';
 809             local *Class::C3::reinitialize = sub {};
 810             use warnings;
 811
 812             Class::Unload->unload($class) if $unload;
 813             my ($source, $resultset_class);
 814             if (
 815                 ($source = $have_source{$moniker})
 816                 && ($resultset_class = $source->resultset_class)
 817                 && ($resultset_class ne 'DBIx::Class::ResultSet')
 818             ) {
 819                 my $has_file = Class::Inspector->loaded_filename($resultset_class);
 820                 Class::Unload->unload($resultset_class) if $unload;
 821                 $self->_reload_class($resultset_class) if $has_file;
 822             }
 823             $self->_reload_class($class);
 824         }
 825         push @to_register, [$moniker, $class];
 826     }
 827
 828     Class::C3->reinitialize;
 829     for (@to_register) {
 830         $self->schema->register_class(@$_);
 831     }
 832 }
 833
 834 # We use this instead of ensure_class_loaded when there are package symbols we
 835 # want to preserve.
 836 sub _reload_class {
 837     my ($self, $class) = @_;
 838
 839     my $class_path = $self->_class_path($class);
 840     delete $INC{ $class_path };
 841
 842 # kill redefined warnings
 843     my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
 844     local $SIG{__WARN__} = sub {
 845         $warn_handler->(@_)
 846             unless $_[0] =~ /^Subroutine \S+ redefined/;
 847     };
 848     eval "require $class;";
 849 }
 850
 851 sub _get_dump_filename {
 852     my ($self, $class) = (@_);
 853
 854     $class =~ s{::}{/}g;
 855     return $self->dump_directory . q{/} . $class . q{.pm};
 856 }
 857
 858 sub _ensure_dump_subdirs {
 859     my ($self, $class) = (@_);
 860
 861     my @name_parts = split(/::/, $class);
 862     pop @name_parts; # we don't care about the very last element,
 863                      # which is a filename
 864
 865     my $dir = $self->dump_directory;
 866     while (1) {
 867         if(!-d $dir) {
 868             mkdir($dir) or croak "mkdir('$dir') failed: $!";
 869         }
 870         last if !@name_parts;
 871         $dir = File::Spec->catdir($dir, shift @name_parts);
 872     }
 873 }
 874
 875 sub _dump_to_dir {
 876     my ($self, @classes) = @_;
 877
 878     my $schema_class = $self->schema_class;
 879     my $schema_base_class = $self->schema_base_class || 'DBIx::Class::Schema';
 880
 881     my $target_dir = $self->dump_directory;
 882     warn "Dumping manual schema for $schema_class to directory $target_dir ...\n"
 883         unless $self->{dynamic} or $self->{quiet};
 884
 885     my $schema_text =
 886           qq|package $schema_class;\n\n|
 887         . qq|# Created by DBIx::Class::Schema::Loader\n|
 888         . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
 889         . qq|use strict;\nuse warnings;\n\n|
 890         . qq|use base '$schema_base_class';\n\n|;
 891
 892     if ($self->use_namespaces) {
 893         $schema_text .= qq|__PACKAGE__->load_namespaces|;
 894         my $namespace_options;
 895         for my $attr (qw(result_namespace
 896                          resultset_namespace
 897                          default_resultset_class)) {
 898             if ($self->$attr) {
 899                 $namespace_options .= qq|    $attr => '| . $self->$attr . qq|',\n|
 900             }
 901         }
 902         $schema_text .= qq|(\n$namespace_options)| if $namespace_options;
 903         $schema_text .= qq|;\n|;
 904     }
 905     else {
 906         $schema_text .= qq|__PACKAGE__->load_classes;\n|;
 907     }
 908
 909     {
 910         local $self->{version_to_dump} = $self->schema_version_to_dump;
 911         $self->_write_classfile($schema_class, $schema_text, 1);
 912     }
 913
 914     my $result_base_class = $self->result_base_class || 'DBIx::Class::Core';
 915
 916     foreach my $src_class (@classes) {
 917         my $src_text =
 918               qq|package $src_class;\n\n|
 919             . qq|# Created by DBIx::Class::Schema::Loader\n|
 920             . qq|# DO NOT MODIFY THE FIRST PART OF THIS FILE\n\n|
 921             . qq|use strict;\nuse warnings;\n\n|
 922             . qq|use base '$result_base_class';\n\n|;
 923
 924         $self->_write_classfile($src_class, $src_text);
 925     }
 926
 927     warn "Schema dump completed.\n" unless $self->{dynamic} or $self->{quiet};
 928
 929 }
 930
 931 sub _sig_comment {
 932     my ($self, $version, $ts) = @_;
 933     return qq|\n\n# Created by DBIx::Class::Schema::Loader|
 934          . qq| v| . $version
 935          . q| @ | . $ts
 936          . qq|\n# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:|;
 937 }
 938
 939 sub _write_classfile {
 940     my ($self, $class, $text, $is_schema) = @_;
 941
 942     my $filename = $self->_get_dump_filename($class);
 943     $self->_ensure_dump_subdirs($class);
 944
 945     if (-f $filename && $self->really_erase_my_files) {
 946         warn "Deleting existing file '$filename' due to "
 947             . "'really_erase_my_files' setting\n" unless $self->{quiet};
 948         unlink($filename);
 949     }
 950
 951     my ($custom_content, $old_md5, $old_ver, $old_ts) = $self->_get_custom_content($class, $filename);
 952
 953     if (my $old_class = $self->_upgrading_classes->{$class}) {
 954         my $old_filename = $self->_get_dump_filename($old_class);
 955
 956         my ($old_custom_content) = $self->_get_custom_content(
 957             $old_class, $old_filename, 0 # do not add default comment
 958         );
 959
 960         $old_custom_content =~ s/\n\n# You can replace.*\n1;\n//;
 961
 962         if ($old_custom_content) {
 963             $custom_content =
 964                 "\n" . $old_custom_content . "\n" . $custom_content;
 965         }
 966
 967         unlink $old_filename;
 968     }
 969
 970     $custom_content = $self->_rewrite_old_classnames($custom_content);
 971
 972     $text .= qq|$_\n|
 973         for @{$self->{_dump_storage}->{$class} || []};
 974
 975     # Check and see if the dump is infact differnt
 976
 977     my $compare_to;
 978     if ($old_md5) {
 979       $compare_to = $text . $self->_sig_comment($old_ver, $old_ts);
 980
 981
 982       if (Digest::MD5::md5_base64($compare_to) eq $old_md5) {
 983         return unless $self->_upgrading_from && $is_schema;
 984       }
 985     }
 986
 987     $text .= $self->_sig_comment(
 988       $self->version_to_dump,
 989       POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime)
 990     );
 991
 992     open(my $fh, '>', $filename)
 993         or croak "Cannot open '$filename' for writing: $!";
 994
 995     # Write the top half and its MD5 sum
 996     print $fh $text . Digest::MD5::md5_base64($text) . "\n";
 997
 998     # Write out anything loaded via external partial class file in @INC
 999     print $fh qq|$_\n|
1000         for @{$self->{_ext_storage}->{$class} || []};
1001
1002     # Write out any custom content the user has added
1003     print $fh $custom_content;
1004
1005     close($fh)
1006         or croak "Error closing '$filename': $!";
1007 }
1008
1009 sub _default_custom_content {
1010     return qq|\n\n# You can replace this text with custom|
1011          . qq| content, and it will be preserved on regeneration|
1012          . qq|\n1;\n|;
1013 }
1014
1015 sub _get_custom_content {
1016     my ($self, $class, $filename, $add_default) = @_;
1017
1018     $add_default = 1 unless defined $add_default;
1019
1020     return ($self->_default_custom_content) if ! -f $filename;
1021
1022     open(my $fh, '<', $filename)
1023         or croak "Cannot open '$filename' for reading: $!";
1024
1025     my $mark_re =
1026         qr{^(# DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:)([A-Za-z0-9/+]{22})\n};
1027
1028     my $buffer = '';
1029     my ($md5, $ts, $ver);
1030     while(<$fh>) {
1031         if(!$md5 && /$mark_re/) {
1032             $md5 = $2;
1033             my $line = $1;
1034
1035             # Pull out the previous version and timestamp
1036             ($ver, $ts) = $buffer =~ m/# Created by DBIx::Class::Schema::Loader v(.*?) @ (.*?)$/s;
1037
1038             $buffer .= $line;
1039             croak "Checksum mismatch in '$filename', the auto-generated part of the file has been modified outside of this loader.  Aborting.\nIf you want to overwrite these modifications, set the 'overwrite_modifications' loader option.\n"
1040                 if !$self->overwrite_modifications && Digest::MD5::md5_base64($buffer) ne $md5;
1041
1042             $buffer = '';
1043         }
1044         else {
1045             $buffer .= $_;
1046         }
1047     }
1048
1049     croak "Cannot not overwrite '$filename' without 'really_erase_my_files',"
1050         . " it does not appear to have been generated by Loader"
1051             if !$md5;
1052
1053     # Default custom content:
1054     $buffer ||= $self->_default_custom_content if $add_default;
1055
1056     return ($buffer, $md5, $ver, $ts);
1057 }
1058
1059 sub _use {
1060     my $self = shift;
1061     my $target = shift;
1062
1063     foreach (@_) {
1064         warn "$target: use $_;" if $self->debug;
1065         $self->_raw_stmt($target, "use $_;");
1066     }
1067 }
1068
1069 sub _inject {
1070     my $self = shift;
1071     my $target = shift;
1072     my $schema_class = $self->schema_class;
1073
1074     my $blist = join(q{ }, @_);
1075     warn "$target: use base qw/ $blist /;" if $self->debug && @_;
1076     $self->_raw_stmt($target, "use base qw/ $blist /;") if @_;
1077 }
1078
1079 # Create class with applicable bases, setup monikers, etc
1080 sub _make_src_class {
1081     my ($self, $table) = @_;
1082
1083     my $schema       = $self->schema;
1084     my $schema_class = $self->schema_class;
1085
1086     my $table_moniker = $self->_table2moniker($table);
1087     my @result_namespace = ($schema_class);
1088     if ($self->use_namespaces) {
1089         my $result_namespace = $self->result_namespace || 'Result';
1090         if ($result_namespace =~ /^\+(.*)/) {
1091             # Fully qualified namespace
1092             @result_namespace =  ($1)
1093         }
1094         else {
1095             # Relative namespace
1096             push @result_namespace, $result_namespace;
1097         }
1098     }
1099     my $table_class = join(q{::}, @result_namespace, $table_moniker);
1100
1101     if ((my $upgrading_v = $self->_upgrading_from)
1102             || $self->_upgrading_from_load_classes) {
1103         local $self->naming->{monikers} = $upgrading_v
1104             if $upgrading_v;
1105
1106         my @result_namespace = @result_namespace;
1107         @result_namespace = ($schema_class)
1108             if $self->_upgrading_from_load_classes;
1109
1110         my $old_class = join(q{::}, @result_namespace,
1111             $self->_table2moniker($table));
1112
1113         $self->_upgrading_classes->{$table_class} = $old_class
1114             unless $table_class eq $old_class;
1115     }
1116
1117     my $table_normalized = lc $table;
1118     $self->classes->{$table} = $table_class;
1119     $self->classes->{$table_normalized} = $table_class;
1120     $self->monikers->{$table} = $table_moniker;
1121     $self->monikers->{$table_normalized} = $table_moniker;
1122
1123     $self->_use   ($table_class, @{$self->additional_classes});
1124     $self->_inject($table_class, @{$self->left_base_classes});
1125
1126     if (my @components = @{ $self->components }) {
1127         $self->_dbic_stmt($table_class, 'load_components', @components);
1128     }
1129
1130     $self->_dbic_stmt($table_class, 'load_resultset_components', @{$self->resultset_components})
1131         if @{$self->resultset_components};
1132     $self->_inject($table_class, @{$self->additional_base_classes});
1133 }
1134
1135 # Set up metadata (cols, pks, etc)
1136 sub _setup_src_meta {
1137     my ($self, $table) = @_;
1138
1139     my $schema       = $self->schema;
1140     my $schema_class = $self->schema_class;
1141
1142     my $table_class = $self->classes->{$table};
1143     my $table_moniker = $self->monikers->{$table};
1144
1145     my $table_name = $table;
1146     my $name_sep   = $self->schema->storage->sql_maker->name_sep;
1147
1148     if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
1149         $table_name = \ $self->_quote_table_name($table_name);
1150     }
1151
1152     $self->_dbic_stmt($table_class,'table',$table_name);
1153
1154     my $cols = $self->_table_columns($table);
1155     my $col_info;
1156     eval { $col_info = $self->_columns_info_for($table) };
1157     if($@) {
1158         $self->_dbic_stmt($table_class,'add_columns',@$cols);
1159     }
1160     else {
1161         if ($self->_is_case_sensitive) {
1162             for my $col (keys %$col_info) {
1163                 $col_info->{$col}{accessor} = lc $col
1164                     if $col ne lc($col);
1165             }
1166         } else {
1167             $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
1168         }
1169
1170         my $fks = $self->_table_fk_info($table);
1171
1172         for my $fkdef (@$fks) {
1173             for my $col (@{ $fkdef->{local_columns} }) {
1174                 $col_info->{$col}{is_foreign_key} = 1;
1175             }
1176         }
1177         $self->_dbic_stmt(
1178             $table_class,
1179             'add_columns',
1180             map { $_, ($col_info->{$_}||{}) } @$cols
1181         );
1182     }
1183
1184     my %uniq_tag; # used to eliminate duplicate uniqs
1185
1186     my $pks = $self->_table_pk_info($table) || [];
1187     @$pks ? $self->_dbic_stmt($table_class,'set_primary_key',@$pks)
1188           : carp("$table has no primary key");
1189     $uniq_tag{ join("\0", @$pks) }++ if @$pks; # pk is a uniq
1190
1191     my $uniqs = $self->_table_uniq_info($table) || [];
1192     for (@$uniqs) {
1193         my ($name, $cols) = @$_;
1194         next if $uniq_tag{ join("\0", @$cols) }++; # skip duplicates
1195         $self->_dbic_stmt($table_class,'add_unique_constraint', $name, $cols);
1196     }
1197
1198 }
1199
1200 =head2 tables
1201
1202 Returns a sorted list of loaded tables, using the original database table
1203 names.
1204
1205 =cut
1206
1207 sub tables {
1208     my $self = shift;
1209
1210     return keys %{$self->_tables};
1211 }
1212
1213 # Make a moniker from a table
1214 sub _default_table2moniker {
1215     no warnings 'uninitialized';
1216     my ($self, $table) = @_;
1217
1218     if ($self->naming->{monikers} eq 'v4') {
1219         return join '', map ucfirst, split /[\W_]+/, lc $table;
1220     }
1221
1222     return join '', map ucfirst, split /[\W_]+/,
1223         Lingua::EN::Inflect::Number::to_S(lc $table);
1224 }
1225
1226 sub _table2moniker {
1227     my ( $self, $table ) = @_;
1228
1229     my $moniker;
1230
1231     if( ref $self->moniker_map eq 'HASH' ) {
1232         $moniker = $self->moniker_map->{$table};
1233     }
1234     elsif( ref $self->moniker_map eq 'CODE' ) {
1235         $moniker = $self->moniker_map->($table);
1236     }
1237
1238     $moniker ||= $self->_default_table2moniker($table);
1239
1240     return $moniker;
1241 }
1242
1243 sub _load_relationships {
1244     my ($self, $table) = @_;
1245
1246     my $tbl_fk_info = $self->_table_fk_info($table);
1247     foreach my $fkdef (@$tbl_fk_info) {
1248         $fkdef->{remote_source} =
1249             $self->monikers->{delete $fkdef->{remote_table}};
1250     }
1251     my $tbl_uniq_info = $self->_table_uniq_info($table);
1252
1253     my $local_moniker = $self->monikers->{$table};
1254     my $rel_stmts = $self->_relbuilder->generate_code($local_moniker, $tbl_fk_info, $tbl_uniq_info);
1255
1256     foreach my $src_class (sort keys %$rel_stmts) {
1257         my $src_stmts = $rel_stmts->{$src_class};
1258         foreach my $stmt (@$src_stmts) {
1259             $self->_dbic_stmt($src_class,$stmt->{method},@{$stmt->{args}});
1260         }
1261     }
1262 }
1263
1264 # Overload these in driver class:
1265
1266 # Returns an arrayref of column names
1267 sub _table_columns { croak "ABSTRACT METHOD" }
1268
1269 # Returns arrayref of pk col names
1270 sub _table_pk_info { croak "ABSTRACT METHOD" }
1271
1272 # Returns an arrayref of uniqs [ [ foo => [ col1, col2 ] ], [ bar => [ ... ] ] ]
1273 sub _table_uniq_info { croak "ABSTRACT METHOD" }
1274
1275 # Returns an arrayref of foreign key constraints, each
1276 #   being a hashref with 3 keys:
1277 #   local_columns (arrayref), remote_columns (arrayref), remote_table
1278 sub _table_fk_info { croak "ABSTRACT METHOD" }
1279
1280 # Returns an array of lower case table names
1281 sub _tables_list { croak "ABSTRACT METHOD" }
1282
1283 # Execute a constructive DBIC class method, with debug/dump_to_dir hooks.
1284 sub _dbic_stmt {
1285     my $self   = shift;
1286     my $class  = shift;
1287     my $method = shift;
1288
1289     # generate the pod for this statement, storing it with $self->_pod
1290     $self->_make_pod( $class, $method, @_ );
1291
1292     my $args = dump(@_);
1293     $args = '(' . $args . ')' if @_ < 2;
1294     my $stmt = $method . $args . q{;};
1295
1296     warn qq|$class\->$stmt\n| if $self->debug;
1297     $self->_raw_stmt($class, '__PACKAGE__->' . $stmt);
1298     return;
1299 }
1300
1301 # generates the accompanying pod for a DBIC class method statement,
1302 # storing it with $self->_pod
1303 sub _make_pod {
1304     my $self   = shift;
1305     my $class  = shift;
1306     my $method = shift;
1307
1308     if ( $method eq 'table' ) {
1309         my ($table) = @_;
1310         $self->_pod( $class, "=head1 NAME" );
1311         my $table_descr = $class;
1312         if ( $self->can('_table_comment') ) {
1313             my $comment = $self->_table_comment($table);
1314             $table_descr .= " - " . $comment if $comment;
1315         }
1316         $self->{_class2table}{ $class } = $table;
1317         $self->_pod( $class, $table_descr );
1318         $self->_pod_cut( $class );
1319     } elsif ( $method eq 'add_columns' ) {
1320         $self->_pod( $class, "=head1 ACCESSORS" );
1321         my $col_counter = 0;
1322         my @cols = @_;
1323         while( my ($name,$attrs) = splice @cols,0,2 ) {
1324             $col_counter++;
1325             $self->_pod( $class, '=head2 ' . $name  );
1326             $self->_pod( $class,
1327                          join "\n", map {
1328                              my $s = $attrs->{$_};
1329                              $s = !defined $s      ? 'undef'          :
1330                                   length($s) == 0  ? '(empty string)' :
1331                                                      $s;
1332
1333                              "  $_: $s"
1334                          } sort keys %$attrs,
1335                        );
1336
1337             if( $self->can('_column_comment')
1338                 and my $comment = $self->_column_comment( $self->{_class2table}{$class}, $col_counter)
1339               ) {
1340                 $self->_pod( $class, $comment );
1341             }
1342         }
1343         $self->_pod_cut( $class );
1344     } elsif ( $method =~ /^(belongs_to|has_many|might_have)$/ ) {
1345         $self->_pod( $class, "=head1 RELATIONS" ) unless $self->{_relations_started} { $class } ;
1346         my ( $accessor, $rel_class ) = @_;
1347         $self->_pod( $class, "=head2 $accessor" );
1348         $self->_pod( $class, 'Type: ' . $method );
1349         $self->_pod( $class, "Related object: L<$rel_class>" );
1350         $self->_pod_cut( $class );
1351         $self->{_relations_started} { $class } = 1;
1352     }
1353 }
1354
1355 # Stores a POD documentation
1356 sub _pod {
1357     my ($self, $class, $stmt) = @_;
1358     $self->_raw_stmt( $class, "\n" . $stmt  );
1359 }
1360
1361 sub _pod_cut {
1362     my ($self, $class ) = @_;
1363     $self->_raw_stmt( $class, "\n=cut\n" );
1364 }
1365
1366
1367 # Store a raw source line for a class (for dumping purposes)
1368 sub _raw_stmt {
1369     my ($self, $class, $stmt) = @_;
1370     push(@{$self->{_dump_storage}->{$class}}, $stmt);
1371 }
1372
1373 # Like above, but separately for the externally loaded stuff
1374 sub _ext_stmt {
1375     my ($self, $class, $stmt) = @_;
1376     push(@{$self->{_ext_storage}->{$class}}, $stmt);
1377 }
1378
1379 sub _quote_table_name {
1380     my ($self, $table) = @_;
1381
1382     my $qt = $self->schema->storage->sql_maker->quote_char;
1383
1384     return $table unless $qt;
1385
1386     if (ref $qt) {
1387         return $qt->[0] . $table . $qt->[1];
1388     }
1389
1390     return $qt . $table . $qt;
1391 }
1392
1393 sub _is_case_sensitive { 0 }
1394
1395 # remove the dump dir from @INC on destruction
1396 sub DESTROY {
1397     my $self = shift;
1398
1399     @INC = grep $_ ne $self->dump_directory, @INC;
1400 }
1401
1402 =head2 monikers
1403
1404 Returns a hashref of loaded table to moniker mappings.  There will
1405 be two entries for each table, the original name and the "normalized"
1406 name, in the case that the two are different (such as databases
1407 that like uppercase table names, or preserve your original mixed-case
1408 definitions, or what-have-you).
1409
1410 =head2 classes
1411
1412 Returns a hashref of table to class mappings.  In some cases it will
1413 contain multiple entries per table for the original and normalized table
1414 names, as above in L</monikers>.
1415
1416 =head1 SEE ALSO
1417
1418 L<DBIx::Class::Schema::Loader>
1419
1420 =head1 AUTHOR
1421
1422 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
1423
1424 =head1 LICENSE
1425
1426 This library is free software; you can redistribute it and/or modify it under
1427 the same terms as Perl itself.
1428
1429 =cut
1430
1431 1;