From: Rafael Kitover Date: Sun, 21 Feb 2010 12:42:10 +0000 (+0000) Subject: Merge 'trunk' into 'run_file_against_storage' X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=674419e7cea37c3358c662445399bca6625f111f;p=dbsrgits%2FDBIx-Class-Historic.git Merge 'trunk' into 'run_file_against_storage' --- 674419e7cea37c3358c662445399bca6625f111f diff --cc lib/DBIx/Class/Storage/DBI.pm index 51afbf0,d56cd44..f97d1c0 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@@ -9,13 -11,14 +11,15 @@@ use Carp::Clan qw/^DBIx::Class/ 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 @@@ -1776,20 -2400,19 +2401,16 @@@ sub deployment_statements 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}; @@@ -1803,10 -2441,36 +2424,9 @@@ 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 @@@ -1887,281 -2534,48 +2490,320 @@@ sub lag_behind_master 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 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 +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 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 uses L names as table aliases in + queries. + + This hook is to allow specific L 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); } diff --cc t/lib/DBICTest.pm index 4e0bee1,8006961..a9d8094 --- a/t/lib/DBICTest.pm +++ b/t/lib/DBICTest.pm @@@ -127,10 -127,19 +127,10 @@@ sub deploy_schema my $args = shift || {}; if ($ENV{"DBICTEST_SQLT_DEPLOY"}) { - $schema->deploy($args); + $schema->deploy($args); } else { - open IN, "t/lib/sqlite.sql"; - my $sql; - { local $/ = undef; $sql = ; } - close IN; - for my $chunk ( split (/;\s*\n+/, $sql) ) { - if ( $chunk =~ / ^ (?! --\s* ) \S /xm ) { # there is some real sql in the chunk - a non-space at the start of the string which is not a comment - $schema->storage->dbh_do(sub { $_[1]->do($chunk) }) or print "Error on SQL: $chunk\n"; - } - } + $schema->storage->run_file_against_storage(qw/t lib sqlite.sql/); } - return; } =head2 populate_schema