From: John Napiorkowski Date: Mon, 8 Jun 2009 21:08:42 +0000 (+0000) Subject: more details in the AuthorCheck.pm to help newcomers understand why they are being... X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c49ae47d36807527a70d8fd264750aa372892bd0;p=dbsrgits%2FDBIx-Class-Historic.git more details in the AuthorCheck.pm to help newcomers understand why they are being threatened --- diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 7be8aab..a8be5d0 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -9,6 +9,7 @@ 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 qw/blessed weaken/; use List::Util(); @@ -1826,6 +1827,147 @@ sub lag_behind_master { return; } +=head2 run_file_against_storage (Path::Class::File|String|@Strings) + +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_from_fh($fh); + my @statements = $self->_normalize_statements_from_lines(join(' ', @lines)); + return $self->txn_do(sub { + my @return; + foreach my $statement (@statements) { + push @return, $self->_execute_single_statement(@$statement); + } + return @return; + }); +} + +=head2 _execute_single_statement ($String|@Strings) + +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) = @_; + $storage->debugobj->query_start("Doing: $statement") + if $storage->debug; + $dbh->do($statement) + || $schema->throw_exception("Can't execute line: $statement, Error: ". $dbh->errstr); + $storage->debugobj->query_end("Done: $statement") + if $storage->debug; + }, $self, $statement); + } else { + $self->debugobj("No commands to do!") + if $self->debug; + return; + } +} + +=head2 _normalize_fh_from_args (Path::Class::File|String|@Strings) + +Given some args, return a $filehandle that is an open read filehandle object +based on the args. Accepts a L object or arguments suitable +for constructing one. + +Returns a filehandle whose end of line characters have been normalized to the +running platform. + +=cut + +sub _normalize_fh_from_args { + my ($self, @args) = @_; + my $file = Path::Class::File->new(@args); + open(my $fh, "<:raw:eol(NATIVE)", $file) || + $self->throw_exception("Can't open file '$file'. Error: $!"); + return $fh; +} + +=head2 _normalize_lines_from_fh ($filehandle) + +Given a $filehandle, will return an array of normalized lines statement that we +can group into statements. 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. + +=cut + +sub _normalize_lines_from_fh { + my ($self, $fh) = @_; + + my $deliminator=qr{;|.$}; + my $quote=qr{'|"}; + my $quoted=qr{$quote.+?$quote}; + my $block=qr{$quoted|.}; + my $comment = qr{--}; + + my @lines; + foreach my $line (<$fh>) { + chomp $line; + ## 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 = ($line=~m/$block*?$deliminator/xg); + ## 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/$deliminator \s*?$comment.*?$//x; ## trim off ending comments + $_=~s/^\s*//g; ## trim leading whitespace + $_=~s/\s*$//g; ## trim ending whitespace + $_ + } @parts; + push @lines, @parts; + } + } + return @lines; +} + +=head2 _normalize_statements_from_lines (@lines) + +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. + +=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; +} + sub DESTROY { my $self = shift; return if !$self->_dbh; diff --git a/t/lib/DBICTest/AuthorCheck.pm b/t/lib/DBICTest/AuthorCheck.pm index 4d2a6f6..475c1ec 100644 --- a/t/lib/DBICTest/AuthorCheck.pm +++ b/t/lib/DBICTest/AuthorCheck.pm @@ -34,14 +34,22 @@ sub _check_author_makefile { ); return unless $mf_pl_mtime; # something went wrong during co_root detection ? + + my @reasons; + + if(not -d $root->subdir ('inc')) { + push @reasons, "Missing inc directory"; + } + + if(not $mf_mtime) { + push @reasons, "Missing Makefile"; + } - if ( - not -d $root->subdir ('inc') - or - not $mf_mtime - or - $mf_mtime < $mf_pl_mtime - ) { + if($mf_mtime < $mf_pl_mtime) { + push @reasons, "Makefile.PL is newer than Makefile"; + } + + if (@reasons) { print STDERR <<'EOE'; @@ -71,10 +79,14 @@ entirely. The DBIC team - - EOE + print STDERR "Reasons you received this message:\n\n"; + foreach my $reason (@reasons) { + print STDERR "\t* $reason\n"; + } + print STDERR "\n\n"; + exit 1; } }