use DBI;
use DBIx::Class::Storage::DBI::Cursor;
use DBIx::Class::Storage::Statistics;
+use Path::Class::File ();
use Scalar::Util();
use List::Util();
+ use Data::Dumper::Concise();
+ use Sub::Name ();
__PACKAGE__->mk_group_accessors('simple' =>
- qw/_connect_info _dbi_connect_info _dbh _sql_maker _sql_maker_opts
- _conn_pid _conn_tid transaction_depth _dbh_autocommit savepoints/
+ qw/_connect_info _dbi_connect_info _dbh _sql_maker _sql_maker_opts _conn_pid
+ _conn_tid transaction_depth _dbh_autocommit _driver_determined savepoints/
);
# the values for these accessors are picked out (and deleted) from
my $filename = $schema->ddl_filename($type, $version, $dir);
if(-f $filename)
{
- my $file;
- open($file, "<$filename")
- or $self->throw_exception("Can't open $filename ($!)");
- my @rows = <$file>;
- close($file);
- return join('', @rows);
+ my $fh = $self->_normalize_fh_from_args($filename);
+ my @lines = $self->_normalize_lines(<$fh>);
+ return wantarray ? @lines : join(';', @lines);
}
- $self->throw_exception(q{Can't deploy without SQL::Translator 0.09003: '}
- . $self->_check_sqlt_message . q{'})
- if !$self->_check_sqlt_version;
-
- require SQL::Translator::Parser::DBIx::Class;
- eval qq{use SQL::Translator::Producer::${type}};
- $self->throw_exception($@) if $@;
+ unless (DBIx::Class::Optional::Dependencies->req_ok_for ('deploy') ) {
+ $self->throw_exception("Can't deploy without a ddl_dir or " . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') );
+ }
- # sources needs to be a parser arg, but for simplicty allow at top level
+ # sources needs to be a parser arg, but for simplicty allow at top level
# coming in
$sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
if exists $sqltargs->{sources};
sub deploy {
my ($self, $schema, $type, $sqltargs, $dir) = @_;
- my $deploy = sub {
- my $line = shift;
- return if($line =~ /^--/);
- return if(!$line);
- # next if($line =~ /^DROP/m);
- return if($line =~ /^BEGIN TRANSACTION/m);
- return if($line =~ /^COMMIT/m);
- return if $line =~ /^\s+$/; # skip whitespace only
- $self->_query_start($line);
- eval {
- # do a dbh_do cycle here, as we need some error checking in
- # place (even though we will ignore errors)
- $self->dbh_do (sub { $_[1]->do($line) });
- };
- if ($@) {
- carp qq{$@ (running "${line}")};
- }
- $self->_query_end($line);
- };
- my @statements = $schema->deployment_statements($type, undef, $dir, { %{ $sqltargs || {} }, no_comments => 1 } );
- if (@statements > 1) {
- foreach my $statement (@statements) {
- $deploy->( $statement );
- }
- }
- elsif (@statements == 1) {
- foreach my $line ( split(";\n", $statements[0])) {
- $deploy->( $line );
- }
- }
+ my @statements = $self->deployment_statements(
- $schema, $type, undef, $dir, { %{ $sqltargs || {} }, no_comments => 1 }
++ $schema, $type, undef, $dir, { %{ $sqltargs || {} }, no_comments => 1 }
+ );
- return $self->_execute_statements(@statements);
}
=head2 datetime_parser
return;
}
+=head2 run_file_against_storage
+
+ my @results = $storage->run_file_against_storage($path_to_file)
+
+=over
+
+=item Arguments: (Path::Class::File|String|@Strings)
+
+=item Returns: Array of results from executing each statement.
+
+=back
+
+Given a path to file, will try to execute it line by line against the connected
+database engine. Throws an exception and tries to rollback if an error occurs.
+
+Will normalize the contents of the file to strip comments and properly deal
+with command scattered across several lines.
+
+Will accept either a L<Path::Class::File> object or a string or array that we
+can use to create one.
+
+Returns an array of whatever comes back from executing each statement. Should
+be true if the script executes anything at all.
+
+=cut
+
+sub run_file_against_storage {
+ my ($self, @args) = @_;
+ my $fh = $self->_normalize_fh_from_args(@args);
+ my @lines = $self->_normalize_lines(<$fh>);
+ my @statements = $self->_normalize_statements_from_lines(@lines);
+ return $self->txn_do(sub {
+ return $self->_execute_statements(@_);
+ }, @statements);
+}
+
+=head2 _execute_statements
+
+ $storage->_execute_statements(@statements)
+
+=over
+
+=item Arguments: Array of Statements
+
+=item Returns: An Array of Results from each executed String
+
+=back
+
+Given a list of @statements as returned my L</_normalize_statements_from_lines>
+try to execute them cleanly.
+
+=cut
+
+sub _execute_statements {
+ my ($self, @statements) = @_;
+ if(@statements) {
+ return $self->txn_do(sub {
+ my @return;
+ foreach my $statement (@_) {
+ my $single_statement = ref $statement eq 'ARRAY' ? join(' ',@$statement) : $statement;
+ push @return, $self->_execute_single_statement($single_statement);
+ }
+ return @return;
+ }, @statements);
+ } else {
+ $self->debugobj->print("No statement to execute!")
+ if $self->debug;
+ }
+}
+
+=head2 _execute_single_statement
+
+ $storage->_execute_single_statement($statement)
+
+=over
+
+=item Arguments: String
+
+=item Returns: Result of $dbh->do($string) or throws exception
+
+=back
+
+Given a SQL statement, do our best to safely execute it.
+
+=cut
+
+sub _execute_single_statement {
+ my ($self, $statement) = @_;
+ if($statement) {
+ return $self->dbh_do(sub {
+ my ($storage, $dbh, $schema, $statement) = @_;
- my $return;
- $schema->_query_start($statement);
- eval {
++ my $return;
++ $schema->_query_start($statement);
++ eval {
+ $return = $dbh->do($statement)
+ || $schema->throw_exception("Can't execute line: $statement, Error: ". $dbh->errstr);
- };
- if($@) {
- carp "$@ (running $statement)";
- }
++ };
++ if($@) {
++ carp "$@ (running $statement)";
++ }
+ $schema->_query_end($statement);
- return $return;
++ return $return;
+ }, $self, $statement);
- } else {
++ }
++ else {
+ $self->debugobj->print("No statement to execute!")
+ if $self->debug;
+ return;
+ }
+}
+
+=head2 _normalize_fh_from_args
+
+ my $fh = $storage->_normalize_fh_from_args(qw/share sql defaults.sql/);
+
+=over
+
+=item Arguments: (Path::Class::File|String|@Strings|Filehandle)
+
+=item Returns: A FileHandle
+
+=back
+
+Given arguments, return a $filehandle that is an open read filehandle object
+based on the args. Accepts a L<Path::Class::File> object or arguments suitable
+for constructing one. Also will passthru an exiting FileHandle as a sanity
+measure.
+
+Throws an exception if a read filehandle can't be created.
+
+=cut
+
+sub _normalize_fh_from_args {
+ my ($self, @args) = @_;
+ if(my $fh = Scalar::Util::openhandle($args[0])) {
+ return $fh;
+ } else {
+ my $file = Path::Class::File->new(@args);
+ open(my $fh, "<", $file) ||
+ $self->throw_exception("Can't open file '$file'. Error: $!");
+ return $fh;
+ }
+}
+
+=head2 _normalize_lines
+
+ my @lines = $storage->_normalize_lines(<$fh>);
+ my @lines = $storage->_normalize_lines(@unknown_lines);
+
+=over
+
+=item Arguments: (@Strings|Filehandle)
+
+=item Returns: An Array of Strings.
+
+=back
+
+Given an array of strings, as might come out of a sql script file or generated
+from a SQLT Producer, we normalize it for execution against the given storage
+engine. We do our best to strip out comment lines, blank lines and anything
+else that might cause an error. We also split lines based on the ';'
+deliminator, since that's pretty standard.
+
+The idea here is that you should get in clean array of strings.
+
+=cut
+
+sub _normalize_lines {
+ my $self = shift @_;
+ my $comment = qr{--};
+ my @lines;
+ foreach my $line (@_) {
- $line=~s/\n|\r|\r\n|\n\r//g; ## Clear any type of eol characters
++ $line=~s/\n|\r|\r\n|\n\r//g; ## Clear any type of eol characters
+ ## Skip if the line is blank, whitespace only or a comment line
+ if(!$line || $line=~m/^\s* $comment/x || $line=~m/^\s*$/) {
+ next;
+ } else {
+ ## a line may contain several commands
+ my @parts = $self->_split_line_into_statements($line);
+ ## clean empty or comment only lines
+ @parts = grep { $_ && $_ !~m/^\s* $comment/x } @parts;
+ ## We are going to wrap it all in a transaction anyway
+ @parts = grep { $_ !~ /^(BEGIN|BEGIN TRANSACTION|COMMIT)/m } @parts;
+ ## Some cleanup
+ @parts = map {
+ $_=~s/;\s*?$comment.*?$//m; ## trim off ending comments
+ $_=~s/^\s*//mg; ## trim leading whitespace
+ $_=~s/\s*$//mg; ## trim ending whitespace
+ $_;
+ } @parts;
+ push @lines, @parts;
+ }
+ }
+ return @lines;
+}
+
+=head2 _split_line_into_statements
+
+ my @statements = $storage->_split_line_into_statements($line);
+
+=over
+
+=item Arguments: String
+
+=item Returns: Array of SQL Statements
+
+=back
+
+Given a string, returns all the individual SQL statements in that String
+as an Array.
+
+=cut
+
+sub _split_line_into_statements {
+ my ($self, $line) = @_;
+ my $deliminator=qr/;|$/;
+ my $maybe_quoted = qr/
+ "[^"]+"
+ |
+ '[^']+'
+ |
+ .+?(?=$deliminator|.)
+ /x;
+
+ return ($line=~m/$maybe_quoted*?$deliminator/g);
+}
+
+=head2 _normalize_statements_from_lines
+
+ my @statements = $storage->_normalize_statements_from_lines(@lines)
+
+=over
+
+=item Arguments: Array of Strings
+
+=item Returns: Array of Array References
+
+=back
+
+Give an array of lines, group them into whole statements. This is to handle
+how a given statement might have been broken across multiple lines
+
+Returns an array of arrayrefs, where each item is an arrayref of statement
+'chunks'. The idea here is to group statements but preserve the fact that
+an original raw read of a file split statements across multiple lines. This
+is important since many database engines have limitations as to how many
+columns a line can span. Additionally, you may wish to write out the
+statements to a file or storage engine and wish to preserve readability
+by not having such lengthy lines.
+
+=cut
+
+sub _normalize_statements_from_lines {
+ my ($self, @lines) = @_;
+ my @statements;
+ my $statement = [];
+ foreach my $line (@lines) {
+ push @{$statement}, $line;
+ if($line=~m/;$/) {
+ push @statements, $statement;
+ $statement = [];
+ }
+ }
+ return @statements;
+}
+
+ =head2 relname_to_table_alias
+
+ =over 4
+
+ =item Arguments: $relname, $join_count
+
+ =back
+
+ L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
+ queries.
+
+ This hook is to allow specific L<DBIx::Class::Storage> drivers to change the
+ way these aliases are named.
+
+ The default behavior is C<"$relname_$join_count" if $join_count > 1>, otherwise
+ C<"$relname">.
+
+ =cut
+
+ sub relname_to_table_alias {
+ my ($self, $relname, $join_count) = @_;
+
+ my $alias = ($join_count && $join_count > 1 ?
+ join('_', $relname, $join_count) : $relname);
+
+ return $alias;
+ }
+
+=head1 DESTROY
+
+Make sure we properly clean up the object when it goes out of scope.
+
+=cut
+
sub DESTROY {
my $self = shift;
- return if !$self->_dbh;
- $self->_verify_pid;
+
+ $self->_verify_pid if $self->_dbh;
+
+ # some databases need this to stop spewing warnings
+ if (my $dbh = $self->_dbh) {
+ local $@;
+ eval {
+ %{ $dbh->{CachedKids} } = ();
+ $dbh->disconnect;
+ };
+ }
+
$self->_dbh(undef);
}
projects / dbsrgits/DBIx-Class-Historic.git / commitdiff