changed the way args are passed to a storage, should make it easier to use existing...
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Schema.pm
index ff30b53..c3ce0e6 100644 (file)
@@ -3,8 +3,10 @@ package DBIx::Class::Schema;
 use strict;
 use warnings;
 
+use DBIx::Class::Exception;
 use Carp::Clan qw/^DBIx::Class/;
 use Scalar::Util qw/weaken/;
+use File::Spec;
 require Module::Find;
 
 use base qw/DBIx::Class/;
@@ -14,6 +16,8 @@ __PACKAGE__->mk_classdata('source_registrations' => {});
 __PACKAGE__->mk_classdata('storage_type' => '::DBI');
 __PACKAGE__->mk_classdata('storage');
 __PACKAGE__->mk_classdata('exception_action');
+__PACKAGE__->mk_classdata('stacktrace' => $ENV{DBIC_TRACE} || 0);
+__PACKAGE__->mk_classdata('default_resultset_attributes' => {});
 
 =head1 NAME
 
@@ -93,10 +97,15 @@ moniker.
 
 sub register_source {
   my ($self, $moniker, $source) = @_;
+
+  %$source = %{ $source->new( { %$source, source_name => $moniker }) };
+
   my %reg = %{$self->source_registrations};
   $reg{$moniker} = $source;
   $self->source_registrations(\%reg);
+
   $source->schema($self);
+
   weaken($source->{schema}) if ref($self);
   if ($source->result_class) {
     my %map = %{$self->class_mappings};
@@ -105,6 +114,19 @@ sub register_source {
   }
 }
 
+sub _unregister_source {
+    my ($self, $moniker) = @_;
+    my %reg = %{$self->source_registrations}; 
+
+    my $source = delete $reg{$moniker};
+    $self->source_registrations(\%reg);
+    if ($source->result_class) {
+        my %map = %{$self->class_mappings};
+        delete $map{$source->result_class};
+        $self->class_mappings(\%map);
+    }
+}
+
 =head2 class
 
 =over 4
@@ -267,10 +289,18 @@ sub load_classes {
     foreach my $prefix (keys %comps_for) {
       foreach my $comp (@{$comps_for{$prefix}||[]}) {
         my $comp_class = "${prefix}::${comp}";
+        { # try to untaint module name. mods where this fails
+          # are left alone so we don't have to change the old behavior
+          no locale; # localized \w doesn't untaint expression
+          if ( $comp_class =~ m/^( (?:\w+::)* \w+ )$/x ) {
+            $comp_class = $1;
+          }
+        }
         $class->ensure_class_loaded($comp_class);
-        $comp_class->source_name($comp) unless $comp_class->source_name;
 
-        push(@to_register, [ $comp_class->source_name, $comp_class ]);
+        $comp = $comp_class->source_name || $comp;
+#  $DB::single = 1;
+        push(@to_register, [ $comp, $comp_class ]);
       }
     }
   }
@@ -440,7 +470,7 @@ sub load_namespaces {
   return;
 }
 
-=head2 compose_connection
+=head2 compose_connection (DEPRECATED)
 
 =over 4
 
@@ -450,6 +480,14 @@ sub load_namespaces {
 
 =back
 
+DEPRECATED. You probably wanted compose_namespace.
+
+Actually, you probably just wanted to call connect.
+
+=begin hidden
+
+(hidden due to deprecation)
+
 Calls L<DBIx::Class::Schema/"compose_namespace"> to the target namespace,
 calls L<DBIx::Class::Schema/connection> with @db_info on the new schema,
 then injects the L<DBix::Class::ResultSetProxy> component and a
@@ -462,45 +500,55 @@ L<DBIx::Class::Schema/connect> and use the resulting schema object to operate
 on L<DBIx::Class::ResultSet> objects with L<DBIx::Class::Schema/resultset> for
 more information.
 
-=cut
+=end hidden
 
-sub compose_connection {
-  my ($self, $target, @info) = @_;
-  my $base = 'DBIx::Class::ResultSetProxy';
-  eval "require ${base};";
-  $self->throw_exception
-    ("No arguments to load_classes and couldn't load ${base} ($@)")
-      if $@;
+=cut
 
-  if ($self eq $target) {
-    # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
-    foreach my $moniker ($self->sources) {
-      my $source = $self->source($moniker);
+{
+  my $warn;
+
+  sub compose_connection {
+    my ($self, $target, @info) = @_;
+
+    warn "compose_connection deprecated as of 0.08000"
+      unless ($INC{"DBIx/Class/CDBICompat.pm"} || $warn++);
+
+    my $base = 'DBIx::Class::ResultSetProxy';
+    eval "require ${base};";
+    $self->throw_exception
+      ("No arguments to load_classes and couldn't load ${base} ($@)")
+        if $@;
+  
+    if ($self eq $target) {
+      # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
+      foreach my $moniker ($self->sources) {
+        my $source = $self->source($moniker);
+        my $class = $source->result_class;
+        $self->inject_base($class, $base);
+        $class->mk_classdata(resultset_instance => $source->resultset);
+        $class->mk_classdata(class_resolver => $self);
+      }
+      $self->connection(@info);
+      return $self;
+    }
+  
+    my $schema = $self->compose_namespace($target, $base);
+    {
+      no strict 'refs';
+      *{"${target}::schema"} = sub { $schema };
+    }
+  
+    $schema->connection(@info);
+    foreach my $moniker ($schema->sources) {
+      my $source = $schema->source($moniker);
       my $class = $source->result_class;
-      $self->inject_base($class, $base);
+      #warn "$moniker $class $source ".$source->storage;
+      $class->mk_classdata(result_source_instance => $source);
       $class->mk_classdata(resultset_instance => $source->resultset);
-      $class->mk_classdata(class_resolver => $self);
+      $class->mk_classdata(class_resolver => $schema);
     }
-    $self->connection(@info);
-    return $self;
-  }
-
-  my $schema = $self->compose_namespace($target, $base);
-  {
-    no strict 'refs';
-    *{"${target}::schema"} = sub { $schema };
-  }
-
-  $schema->connection(@info);
-  foreach my $moniker ($schema->sources) {
-    my $source = $schema->source($moniker);
-    my $class = $source->result_class;
-    #warn "$moniker $class $source ".$source->storage;
-    $class->mk_classdata(result_source_instance => $source);
-    $class->mk_classdata(resultset_instance => $source->resultset);
-    $class->mk_classdata(class_resolver => $schema);
+    return $schema;
   }
-  return $schema;
 }
 
 =head2 compose_namespace
@@ -538,9 +586,6 @@ will produce the output
 
 sub compose_namespace {
   my ($self, $target, $base) = @_;
-  my %reg = %{ $self->source_registrations };
-  my %target;
-  my %map;
   my $schema = $self->clone;
   {
     no warnings qw/redefine/;
@@ -559,6 +604,7 @@ sub compose_namespace {
   Class::C3->reinitialize();
   {
     no strict 'refs';
+    no warnings 'redefine';
     foreach my $meth (qw/class source resultset/) {
       *{"${target}::${meth}"} =
         sub { shift->schema->$meth(@_) };
@@ -591,9 +637,9 @@ sub setup_connection_class {
 
 =over 4
 
-=item Arguments: $storage_type
+=item Arguments: $storage_type|[$storage_type, \%args]
 
-=item Return Value: $storage_type
+=item Return Value: $storage_type|[$storage_type, \%args]
 
 =back
 
@@ -607,6 +653,11 @@ in cases where the appropriate subclass is not autodetected, such as when
 dealing with MSSQL via L<DBD::Sybase>, in which case you'd set it to
 C<::DBI::Sybase::MSSQL>.
 
+If your storage type requires instantiation arguments, those are defined as a 
+second argument in the form of a hashref and the entire value needs to be
+wrapped into an arrayref.  See L<DBIx::Class::Storage::DBI::Replicated> for an
+example of this.
+
 =head2 connection
 
 =over 4
@@ -629,14 +680,17 @@ or L<DBIx::Class::Storage> in general.
 sub connection {
   my ($self, @info) = @_;
   return $self if !@info && $self->storage;
-  my $storage_class = $self->storage_type;
+  
+  my ($storage_class, $args) = ref $self->storage_type ? 
+    (@{$self->storage_type},{}) : ($self->storage_type, {});
+    
   $storage_class = 'DBIx::Class::Storage'.$storage_class
     if $storage_class =~ m/^::/;
   eval "require ${storage_class};";
   $self->throw_exception(
     "No arguments to load_classes and couldn't load ${storage_class} ($@)"
   ) if $@;
-  my $storage = $storage_class->new($self);
+  my $storage = $storage_class->new($self=>$args);
   $storage->connect_info(\@info);
   $self->storage($storage);
   return $self;
@@ -688,6 +742,21 @@ sub txn_do {
   $self->storage->txn_do(@_);
 }
 
+=head2 txn_scope_guard
+
+Runs C<txn_scope_guard> on the schema's storage.
+
+=cut
+
+sub txn_scope_guard {
+  my $self = shift;
+
+  $self->storage or $self->throw_exception
+    ('txn_scope_guard called on $schema without storage');
+
+  $self->storage->txn_scope_guard(@_);
+}
+
 =head2 txn_begin
 
 Begins a transaction (does nothing if AutoCommit is off). Equivalent to
@@ -739,6 +808,57 @@ sub txn_rollback {
   $self->storage->txn_rollback;
 }
 
+=head2 svp_begin
+
+Creates a new savepoint (does nothing outside a transaction). 
+Equivalent to calling $schema->storage->svp_begin.  See
+L<DBIx::Class::Storage::DBI/"svp_begin"> for more information.
+
+=cut
+
+sub svp_begin {
+  my ($self, $name) = @_;
+
+  $self->storage or $self->throw_exception
+    ('svp_begin called on $schema without storage');
+
+  $self->storage->svp_begin($name);
+}
+
+=head2 svp_release
+
+Releases a savepoint (does nothing outside a transaction). 
+Equivalent to calling $schema->storage->svp_release.  See
+L<DBIx::Class::Storage::DBI/"svp_release"> for more information.
+
+=cut
+
+sub svp_release {
+  my ($self, $name) = @_;
+
+  $self->storage or $self->throw_exception
+    ('svp_release called on $schema without storage');
+
+  $self->storage->svp_release($name);
+}
+
+=head2 svp_rollback
+
+Rollback to a savepoint (does nothing outside a transaction). 
+Equivalent to calling $schema->storage->svp_rollback.  See
+L<DBIx::Class::Storage::DBI/"svp_rollback"> for more information.
+
+=cut
+
+sub svp_rollback {
+  my ($self, $name) = @_;
+
+  $self->storage or $self->throw_exception
+    ('svp_rollback called on $schema without storage');
+
+  $self->storage->svp_rollback($name);
+}
+
 =head2 clone
 
 =over 4
@@ -778,7 +898,12 @@ Pass this method a resultsource name, and an arrayref of
 arrayrefs. The arrayrefs should contain a list of column names,
 followed by one or many sets of matching data for the given columns. 
 
-Each set of data is inserted into the database using
+In void context, C<insert_bulk> in L<DBIx::Class::Storage::DBI> is used
+to insert the data, as this is a fast method. However, insert_bulk currently
+assumes that your datasets all contain the same type of values, using scalar
+references in a column in one row, and not in another will probably not work.
+
+Otherwise, each set of data is inserted into the database using
 L<DBIx::Class::ResultSet/create>, and a arrayref of the resulting row
 objects is returned.
 
@@ -790,6 +915,18 @@ i.e.,
     [ 2, 'Indie Band' ],
     ...
   ]);
+  
+Since wantarray context is basically the same as looping over $rs->create(...) 
+you won't see any performance benefits and in this case the method is more for
+convenience. Void context sends the column information directly to storage
+using <DBI>s bulk insert method. So the performance will be much better for 
+storages that support this method.
+
+Because of this difference in the way void context inserts rows into your 
+database you need to note how this will effect any loaded components that
+override or augment insert.  For example if you are using a component such 
+as L<DBIx::Class::UUIDColumns> to populate your primary keys you MUST use 
+wantarray context if you want the PKs automatically created.
 
 =cut
 
@@ -797,13 +934,24 @@ sub populate {
   my ($self, $name, $data) = @_;
   my $rs = $self->resultset($name);
   my @names = @{shift(@$data)};
-  my @created;
-  foreach my $item (@$data) {
-    my %create;
-    @create{@names} = @$item;
-    push(@created, $rs->create(\%create));
+  if(defined wantarray) {
+    my @created;
+    foreach my $item (@$data) {
+      my %create;
+      @create{@names} = @$item;
+      push(@created, $rs->create(\%create));
+    }
+    return @created;
+  }
+  my @results_to_create;
+  foreach my $datum (@$data) {
+    my %result_to_create;
+    foreach my $index (0..$#names) {
+      $result_to_create{$names[$index]} = $$datum[$index];
+    }
+    push @results_to_create, \%result_to_create;
   }
-  return @created;
+  $rs->populate(\@results_to_create);
 }
 
 =head2 exception_action
@@ -816,7 +964,7 @@ sub populate {
 
 If C<exception_action> is set for this class/object, L</throw_exception>
 will prefer to call this code reference with the exception as an argument,
-rather than its normal <croak> action.
+rather than its normal C<croak> or C<confess> action.
 
 Your subroutine should probably just wrap the error in the exception
 object/class of your choosing and rethrow.  If, against all sage advice,
@@ -838,6 +986,18 @@ Example:
    # suppress all exceptions, like a moron:
    $schema_obj->exception_action(sub { 1 });
 
+=head2 stacktrace
+
+=over 4
+
+=item Arguments: boolean
+
+=back
+
+Whether L</throw_exception> should include stack trace information.
+Defaults to false normally, but defaults to true if C<$ENV{DBIC_TRACE}>
+is true.
+
 =head2 throw_exception
 
 =over 4
@@ -848,16 +1008,19 @@ Example:
 
 Throws an exception. Defaults to using L<Carp::Clan> to report errors from
 user's perspective.  See L</exception_action> for details on overriding
-this method's behavior.
+this method's behavior.  If L</stacktrace> is turned on, C<throw_exception>'s
+default behavior will provide a detailed stack trace.
 
 =cut
 
 sub throw_exception {
   my $self = shift;
-  croak @_ if !$self->exception_action || !$self->exception_action->(@_);
+
+  DBIx::Class::Exception->throw($_[0], $self->stacktrace)
+    if !$self->exception_action || !$self->exception_action->(@_);
 }
 
-=head2 deploy (EXPERIMENTAL)
+=head2 deploy
 
 =over 4
 
@@ -867,13 +1030,14 @@ sub throw_exception {
 
 Attempts to deploy the schema to the current storage using L<SQL::Translator>.
 
-Note that this feature is currently EXPERIMENTAL and may not work correctly
-across all databases, or fully handle complex relationships.
-
 See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>. The most
 common value for this would be C<< { add_drop_table => 1, } >> to have the SQL
 produced include a DROP TABLE statement for each table created.
 
+Additionally, the DBIx::Class parser accepts a C<sources> parameter as a hash 
+ref or an array ref, containing a list of source to deploy. If present, then 
+only the sources listed will get deployed.
+
 =cut
 
 sub deploy {
@@ -882,20 +1046,69 @@ sub deploy {
   $self->storage->deploy($self, undef, $sqltargs, $dir);
 }
 
+=head2 deployment_statements
+
+=over 4
+
+=item Arguments: $rdbms_type
+
+=back
+
+Returns the SQL statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
+C<$rdbms_type> provides the DBI database driver name for which the SQL
+statements are produced. If not supplied, the type of the current schema storage
+will be used.
+
+=cut
+
+sub deployment_statements {
+  my ($self, $rdbms_type) = @_;
+
+  $self->throw_exception("Can't generate deployment statements without a storage")
+    if not $self->storage;
+
+  $self->storage->deployment_statements($self, $rdbms_type);
+}
+
 =head2 create_ddl_dir (EXPERIMENTAL)
 
 =over 4
 
-=item Arguments: \@databases, $version, $directory, $sqlt_args
+=item Arguments: \@databases, $version, $directory, $preversion, $sqlt_args
 
 =back
 
 Creates an SQL file based on the Schema, for each of the specified
-database types, in the given directory.
+database types, in the given directory. Given a previous version number,
+this will also create a file containing the ALTER TABLE statements to
+transform the previous schema into the current one. Note that these
+statements may contain DROP TABLE or DROP COLUMN statements that can
+potentially destroy data.
+
+The file names are created using the C<ddl_filename> method below, please
+override this method in your schema if you would like a different file
+name format. For the ALTER file, the same format is used, replacing
+$version in the name with "$preversion-$version".
+
+If no arguments are passed, then the following default values are used:
+
+=over 4
+
+=item databases  - ['MySQL', 'SQLite', 'PostgreSQL']
+
+=item version    - $schema->VERSION
+
+=item directory  - './'
+
+=item preversion - <none>
+
+=back
 
 Note that this feature is currently EXPERIMENTAL and may not work correctly
 across all databases, or fully handle complex relationships.
 
+WARNING: Please check all SQL files created, before applying them.
+
 =cut
 
 sub create_ddl_dir {
@@ -907,23 +1120,81 @@ sub create_ddl_dir {
 
 =head2 ddl_filename (EXPERIMENTAL)
 
-  my $filename = $table->ddl_filename($type, $dir, $version)
+=over 4
+
+=item Arguments: $directory, $database-type, $version, $preversion
 
-Creates a filename for a SQL file based on the table class name.  Not
-intended for direct end user use.
+=back
+
+  my $filename = $table->ddl_filename($type, $dir, $version, $preversion)
+
+This method is called by C<create_ddl_dir> to compose a file name out of
+the supplied directory, database type and version number. The default file
+name format is: C<$dir$schema-$version-$type.sql>.
+
+You may override this method in your schema if you wish to use a different
+format.
 
 =cut
 
 sub ddl_filename {
-    my ($self, $type, $dir, $version) = @_;
+    my ($self, $type, $dir, $version, $pversion) = @_;
 
     my $filename = ref($self);
-    $filename =~ s/::/-/;
-    $filename = "$dir$filename-$version-$type.sql";
+    $filename =~ s/::/-/g;
+    $filename = File::Spec->catfile($dir, "$filename-$version-$type.sql");
+    $filename =~ s/$version/$pversion-$version/ if($pversion);
 
     return $filename;
 }
 
+=head2 sqlt_deploy_hook($sqlt_schema)
+
+An optional sub which you can declare in your own Schema class that will get 
+passed the L<SQL::Translator::Schema> object when you deploy the schema via
+L</create_ddl_dir> or L</deploy>.
+
+For an example of what you can do with this, see 
+L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
+
+=head2 thaw
+
+Provided as the recommened way of thawing schema objects. You can call 
+C<Storable::thaw> directly if you wish, but the thawed objects will not have a
+reference to any schema, so are rather useless
+
+=cut
+
+sub thaw {
+  my ($self, $obj) = @_;
+  local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
+  return Storable::thaw($obj);
+}
+
+=head2 freeze
+
+This doesn't actualy do anything more than call L<Storable/freeze>, it is just
+provided here for symetry.
+
+=cut
+
+sub freeze {
+  return Storable::freeze($_[1]);
+}
+
+=head2 dclone
+
+Recommeneded way of dcloning objects. This is needed to properly maintain
+references to the schema object (which itself is B<not> cloned.)
+
+=cut
+
+sub dclone {
+  my ($self, $obj) = @_;
+  local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
+  return Storable::dclone($obj);
+}
+
 1;
 
 =head1 AUTHORS