From: Peter Rabbitson Date: Mon, 11 May 2015 10:39:39 +0000 (+0200) Subject: Get rid of Path::Class ( that *does* feel good ) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class.git;a=commitdiff_plain;h=e48635f7178f8527ec3cc230f1cf869e8876dc39 Get rid of Path::Class ( that *does* feel good ) This was a rather long journey (I've been meaning to do this since ~2013). As everything else it turned out more complex than I anticipated. Notably due to having to implement from semi-scratch things that a dev should usually never worry about >:( Just look at the amount of stuff one can't reasonably trust these days (pay attention to the comments): git show 5d54c117 | perl -ne 'print if 155..304' | less git show 358a3aa7 | perl -ne 'print if 407..453' | less There is a tangible difference in the smoke times due to a leaner set of deps (though not as big as one would hope... yet). Sample timings as follows: for n in $(seq 26); do dbic_trv_diffable() { perl -0777 -n -E ' print ( map { "$ENV{cur}: $_\n" } map { split /\r?\n/, $_ } $_ =~ /(^TRAVIS_PERL_VERSION.+)/m, $_ =~ / \QSetting environment variables\E .+? (?:\r?\n)+ (.+?) (?: \r?\n){2} /xms, $_ =~ /(^.*Configuration phase seems to have taken.*)/m, ); say ( $_ =~ /(^[^\n]*?List of loadable modules .+?)^[^\n]*?List of loadable modules/ms ); ' } x=$((112987257 + $n)) &&\ y=$((113113497 + $n)) &&\ echo -e "$x => $y\n========\n" &&\ diff -U0 \ <( wget -qO- s3.amazonaws.com/archive.travis-ci.org/jobs/$x/log.txt | \ cur=$x dbic_trv_diffable )\ <( wget -qO- s3.amazonaws.com/archive.travis-ci.org/jobs/$y/log.txt | \ cur=$y dbic_trv_diffable ) done | less P.S. The above is hideous, yes, but you can run it in your terminal *directly* --- diff --git a/Makefile.PL b/Makefile.PL index c6b5273..0bf82f3 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -65,7 +65,6 @@ my $runtime_requires = { 'MRO::Compat' => '0.12', 'Module::Find' => '0.07', 'namespace::clean' => '0.24', - 'Path::Class' => '0.18', 'Scope::Guard' => '0.03', 'SQL::Abstract' => '1.81', 'Try::Tiny' => '0.07', diff --git a/examples/Schema/insertdb.pl b/examples/Schema/insertdb.pl index ae919b3..4fb22fa 100755 --- a/examples/Schema/insertdb.pl +++ b/examples/Schema/insertdb.pl @@ -4,9 +4,9 @@ use strict; use warnings; use MyApp::Schema; +use DBIx::Class::_Util 'parent_dir'; -use Path::Class 'file'; -my $db_fn = file($INC{'MyApp/Schema.pm'})->dir->parent->file('db/example.db'); +my $db_fn = parent_dir( $INC{'MyApp/Schema.pm'} ) . '../db/example.db'; my $schema = MyApp::Schema->connect("dbi:SQLite:$db_fn"); diff --git a/examples/Schema/testdb.pl b/examples/Schema/testdb.pl index 32cbd6d..0149bc2 100755 --- a/examples/Schema/testdb.pl +++ b/examples/Schema/testdb.pl @@ -4,9 +4,9 @@ use warnings; use strict; use MyApp::Schema; +use DBIx::Class::_Util 'parent_dir'; -use Path::Class 'file'; -my $db_fn = file($INC{'MyApp/Schema.pm'})->dir->parent->file('db/example.db'); +my $db_fn = parent_dir( $INC{'MyApp/Schema.pm'} ) . '../db/example.db'; # for other DSNs, e.g. MySql, see the perldoc for the relevant dbd # driver, e.g perldoc L. diff --git a/lib/DBIx/Class/InflateColumn/File.pm b/lib/DBIx/Class/InflateColumn/File.pm index b983985..08a1a31 100644 --- a/lib/DBIx/Class/InflateColumn/File.pm +++ b/lib/DBIx/Class/InflateColumn/File.pm @@ -2,9 +2,17 @@ package DBIx::Class::InflateColumn::File; use strict; use warnings; + +# check deps +BEGIN { + require DBIx::Class::Optional::Dependencies; + if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('ic_file') ) { + die "The following extra modules are required for DBIx::Class::InflateColumn::File: $missing\n"; + } +} + use base 'DBIx::Class'; use File::Copy; -use Path::Class; use DBIx::Class::Carp; use namespace::clean; diff --git a/lib/DBIx/Class/Optional/Dependencies.pm b/lib/DBIx/Class/Optional/Dependencies.pm index 786828a..7b447ef 100644 --- a/lib/DBIx/Class/Optional/Dependencies.pm +++ b/lib/DBIx/Class/Optional/Dependencies.pm @@ -144,6 +144,16 @@ my $dbic_reqs = { }, }, + ic_file => { + req => { + 'Path::Class' => '0.18', + }, + pod => { + title => 'DBIx::Class::InflateColumn::File (Deprecated)', + desc => 'Modules required for the deprecated L', + }, + }, + ic_dt => { req => { 'DateTime' => '0.55', @@ -1206,16 +1216,12 @@ sub _gen_pod { "\n\n---------------------------------------------------------------------\n" ; - # do not ask for a recent version, use 1.x API calls - # this *may* execute on a smoker with old perl or whatnot - require File::Path; - (my $modfn = __PACKAGE__ . '.pm') =~ s|::|/|g; (my $podfn = "$pod_dir/$modfn") =~ s/\.pm$/\.pod/; - (my $dir = $podfn) =~ s|/[^/]+$||; - File::Path::mkpath([$dir]); + require DBIx::Class::_Util; + DBIx::Class::_Util::mkdir_p( DBIx::Class::_Util::parent_dir( $podfn ) ); my $sqltver = $class->req_list_for('deploy')->{'SQL::Translator'} or die "Hrmm? No sqlt dep?"; diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 54dff81..25ed0b5 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -17,6 +17,7 @@ use DBIx::Class::_Util qw( quote_sub perlstring serialize dbic_internal_try detected_reinvoked_destructor scope_guard + mkdir_p ); use namespace::clean; @@ -2937,20 +2938,13 @@ them. sub create_ddl_dir { my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_; - unless ($dir) { + if (!$dir) { carp "No directory given, using ./\n"; $dir = './'; - } else { - -d $dir - or - (require File::Path and File::Path::mkpath (["$dir"])) # mkpath does not like objects (i.e. Path::Class::Dir) - or - $self->throw_exception( - "Failed to create '$dir': " . ($! || $@ || 'error unknown') - ); } - - $self->throw_exception ("Directory '$dir' does not exist\n") unless(-d $dir); + else { + mkdir_p( $dir ) unless -d $dir; + } $databases ||= ['MySQL', 'SQLite', 'PostgreSQL']; $databases = [ $databases ] if(ref($databases) ne 'ARRAY'); diff --git a/maint/gen_sqlite_schema_files b/maint/gen_sqlite_schema_files index a3793d3..0ac70ec 100755 --- a/maint/gen_sqlite_schema_files +++ b/maint/gen_sqlite_schema_files @@ -4,8 +4,8 @@ use strict; use warnings; use Module::Runtime 'use_module'; +use DBIx::Class::_Util qw(mkdir_p parent_dir); use SQL::Translator; -use Path::Class 'file'; use Getopt::Long; my $getopt = Getopt::Long::Parser->new( config => [qw/gnu_getopt bundling_override no_ignore_case/] @@ -34,7 +34,7 @@ my $schema = use_module( $args->{'schema-class'}[0] )->connect( ); if ($args->{'deploy-to'}) { - file($args->{'deploy-to'}[0])->dir->mkpath; + mkdir_p parent_dir $args->{'deploy-to'}[0]; $schema->deploy({ add_drop_table => 1 }); } @@ -43,10 +43,9 @@ if ($args->{'ddl-out'}[0] eq '-') { $ddl_fh = *STDOUT; } else { - my $fn = file($args->{'ddl-out'}[0]); - $fn->dir->mkpath; - open $ddl_fh, '>', $fn - or die "Unable to open $fn: $!\n"; + mkdir_p parent_dir $args->{'ddl-out'}[0]; + open $ddl_fh, '>', $args->{'ddl-out'}[0] + or die "Unable to open $args->{'ddl-out'}[0]: $!\n"; } binmode $ddl_fh; # avoid win32 \n crapfest diff --git a/maint/travis-ci_scripts/30_before_script.bash b/maint/travis-ci_scripts/30_before_script.bash index 3da762a..d5f3cd0 100755 --- a/maint/travis-ci_scripts/30_before_script.bash +++ b/maint/travis-ci_scripts/30_before_script.bash @@ -37,12 +37,9 @@ if [[ "$POISON_ENV" = "true" ]] ; then if [[ "$CLEANTEST" = "true" ]]; then # Clone and P::S::XS are both bugs - # File::Spec can go away as soon as I dump Path::Class - # File::Path is there because of RT#107392 (sigh) # List::Util can be excised after that as well (need to make my own max() routine for older perls) installdeps Sub::Name Clone Package::Stash::XS \ - $( perl -MFile::Spec\ 3.26 -e1 &>/dev/null || echo "File::Path File::Spec" ) \ $( perl -MList::Util\ 1.16 -e1 &>/dev/null || echo "List::Util" ) mkdir -p "$HOME/bin" # this is already in $PATH, just doesn't exist @@ -86,14 +83,11 @@ else # do the preinstall in several passes to minimize amount of cross-deps installing # multiple times, and to avoid module re-architecture breaking another install - # (e.g. once Carp is upgraded there's no more Carp::Heavy, - # while a File::Path upgrade may cause a parallel EUMM run to fail) + # (e.g. once Carp is upgraded there's no more Carp::Heavy) # - parallel_installdeps_notest File::Path parallel_installdeps_notest Carp parallel_installdeps_notest Module::Build - parallel_installdeps_notest File::Spec Module::Runtime - parallel_installdeps_notest Test::Exception Encode::Locale Test::Fatal + parallel_installdeps_notest Test::Exception Encode::Locale Test::Fatal Module::Runtime parallel_installdeps_notest Test::Warn B::Hooks::EndOfScope Test::Differences HTTP::Status parallel_installdeps_notest Test::Pod::Coverage Test::EOL Devel::GlobalDestruction Sub::Name MRO::Compat Class::XSAccessor URI::Escape HTML::Entities parallel_installdeps_notest YAML LWP Class::Trigger DateTime::Format::Builder Class::Accessor::Grouped Package::Variant diff --git a/script/dbicadmin b/script/dbicadmin index bdd618c..414b582 100755 --- a/script/dbicadmin +++ b/script/dbicadmin @@ -71,21 +71,21 @@ if(defined (my $fn = $opts->{documentation_as_pod}) ) { $usage->synopsis($synopsis_text); $usage->short_description($short_description); + my $fh; if ($fn) { - require File::Spec; - require File::Path; - my $dir = File::Spec->catpath( (File::Spec->splitpath($fn))[0,1] ); - File::Path::mkpath([$dir]); + require DBIx::Class::_Util; + DBIx::Class::_Util::mkdir_p( DBIx::Class::_Util::parent_dir( $fn ) ); + open( $fh, '>', $fn ) or die "Unable to open $fn: $!\n"; + } + else { + $fh = \*STDOUT; } - local *STDOUT if $fn; - open (STDOUT, '>', $fn) or die "Unable to open $fn: $!\n" if $fn; - - print STDOUT "\n"; - print STDOUT $usage->pod; - print STDOUT "\n"; + print $fh "\n"; + print $fh $usage->pod; + print $fh "\n"; - close STDOUT if $fn; + close $fh if $fn; exit 0; } diff --git a/t/51threadnodb.t b/t/51threadnodb.t index 4e242f5..30e8aec 100644 --- a/t/51threadnodb.t +++ b/t/51threadnodb.t @@ -17,6 +17,7 @@ use threads; use strict; use warnings; use Test::More; +use Errno (); use DBIx::Class::_Util 'sigwarn_silencer'; use DBICTest; diff --git a/t/52leaks.t b/t/52leaks.t index 6298c98..ca588ce 100644 --- a/t/52leaks.t +++ b/t/52leaks.t @@ -103,10 +103,8 @@ if ( !$ENV{DBICTEST_VIA_REPLICATED} and !DBICTest::RunMode->is_plain ) { # this loads the DT armada $has_dt = DBIx::Class::Optional::Dependencies->req_ok_for([qw( test_rdbms_sqlite ic_dt )]); - require Errno; require DBI; require DBD::SQLite; - require FileHandle; require Moo; %$weak_registry = (); @@ -443,8 +441,8 @@ for my $addr (keys %$weak_registry) { # T::B 2.0 has result objects and other fancyness delete $weak_registry->{$addr}; } - elsif ($names =~ /^Class::Struct/m) { - # remove this when Path::Class is gone, what a crock of shit + # remove this when IO::Dir is gone from SQLT + elsif ($INC{"IO/Dir.pm"} and $names =~ /^Class::Struct::Tie_ISA/m) { delete $weak_registry->{$addr}; } elsif ($names =~ /^Hash::Merge/m) { diff --git a/t/94versioning.t b/t/94versioning.t index c3751b2..ab9d261 100644 --- a/t/94versioning.t +++ b/t/94versioning.t @@ -8,13 +8,11 @@ use Test::More; use Test::Warn; use Test::Exception; -use Path::Class; -use File::Copy; use Time::HiRes qw/time sleep/; - use DBICTest; -use DBIx::Class::_Util 'sigwarn_silencer'; +use DBIx::Class::_Util qw( sigwarn_silencer mkdir_p ); +use DBICTest::Util 'rm_rf'; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/}; @@ -31,15 +29,15 @@ use_ok('DBICVersion_v1'); my $version_table_name = 'dbix_class_schema_versions'; my $old_table_name = 'SchemaVersions'; -my $ddl_dir = dir(qw/t var/, "versioning_ddl-$$"); -$ddl_dir->mkpath unless -d $ddl_dir; +my $ddl_dir = "t/var/versioning_ddl-$$"; +mkdir_p $ddl_dir unless -d $ddl_dir; my $fn = { - v1 => $ddl_dir->file ('DBICVersion-Schema-1.0-MySQL.sql'), - v2 => $ddl_dir->file ('DBICVersion-Schema-2.0-MySQL.sql'), - v3 => $ddl_dir->file ('DBICVersion-Schema-3.0-MySQL.sql'), - trans_v12 => $ddl_dir->file ('DBICVersion-Schema-1.0-2.0-MySQL.sql'), - trans_v23 => $ddl_dir->file ('DBICVersion-Schema-2.0-3.0-MySQL.sql'), + v1 => "$ddl_dir/DBICVersion-Schema-1.0-MySQL.sql", + v2 => "$ddl_dir/DBICVersion-Schema-2.0-MySQL.sql", + v3 => "$ddl_dir/DBICVersion-Schema-3.0-MySQL.sql", + trans_v12 => "$ddl_dir/DBICVersion-Schema-1.0-2.0-MySQL.sql", + trans_v23 => "$ddl_dir/DBICVersion-Schema-2.0-3.0-MySQL.sql", }; my $schema_v1 = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_version => 1 }); @@ -284,9 +282,7 @@ is ; END { - unless ($ENV{DBICTEST_KEEP_VERSIONING_DDL}) { - $ddl_dir->rmtree; - } + rm_rf $ddl_dir unless $ENV{DBICTEST_KEEP_VERSIONING_DDL}; } done_testing; diff --git a/t/admin/02ddl.t b/t/admin/02ddl.t index 84a7381..bb354ac 100644 --- a/t/admin/02ddl.t +++ b/t/admin/02ddl.t @@ -8,11 +8,9 @@ use Test::More; use Test::Exception; use Test::Warn; -use Path::Class; - - use DBICTest; use DBIx::Class::_Util 'sigwarn_silencer'; +use DBICTest::Util 'rm_rf'; use DBIx::Class::Admin; @@ -26,7 +24,7 @@ my @connect_info = ( undef, { on_connect_do => 'PRAGMA synchronous = OFF' }, ); -my $ddl_dir = dir(qw/t var/, "admin_ddl-$$"); +my $ddl_dir = "t/var/admin_ddl-$$"; { # create the schema @@ -116,8 +114,7 @@ is($admin->schema->get_db_version, "4.0", 'db thinks its version 4.0'); } sub cleanup { - my ($dir) = @_; - $ddl_dir->rmtree if -d $ddl_dir; + rm_rf $ddl_dir if -d $ddl_dir; unlink $db_fn; } diff --git a/t/inflate/file_column.t b/t/inflate/file_column.t index 9c5203d..453adee 100644 --- a/t/inflate/file_column.t +++ b/t/inflate/file_column.t @@ -1,4 +1,5 @@ BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } +use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_file ); use strict; use warnings; diff --git a/t/lib/ANFANG.pm b/t/lib/ANFANG.pm index d66322a..70106d1 100644 --- a/t/lib/ANFANG.pm +++ b/t/lib/ANFANG.pm @@ -123,6 +123,13 @@ BEGIN { use lib 't/lib'; +# everything expects this to be there +! -d 't/var' and ( + mkdir 't/var' + or + die "Unable to create 't/var': $!\n" +); + # Back in ab340f7f ribasushi stupidly introduced a "did you check your deps" # verification tied very tightly to Module::Install. The check went away, and # so eventually will M::I, but bisecting can bring all of this back from the diff --git a/t/lib/DBICTest.pm b/t/lib/DBICTest.pm index 762abac..d09a9dc 100644 --- a/t/lib/DBICTest.pm +++ b/t/lib/DBICTest.pm @@ -27,14 +27,13 @@ BEGIN { use DBICTest::Util qw( - local_umask tmpdir await_flock + local_umask slurp_bytes tmpdir await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS PEEPEENESS ); use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/; use DBICTest::Schema; use DBIx::Class::_Util qw( detected_reinvoked_destructor scope_guard ); use Carp; -use Path::Class::File (); use Fcntl qw/:DEFAULT :flock/; use Config; @@ -152,36 +151,21 @@ sub import { } END { - # referencing here delays destruction even more - if ($global_lock_fh) { - DEBUG_TEST_CONCURRENCY_LOCKS > 1 - and dbg "Release @{[ $global_exclusive_lock ? 'EXCLUSIVE' : 'SHARED' ]} global lock (END)"; - 1; - } -} - -{ - my $dir = Path::Class::File->new(__FILE__)->dir->parent->subdir('var'); - $dir->mkpath unless -d "$dir"; - $dir = "$dir"; - - sub _sqlite_dbfilename { - my $holder = $ENV{DBICTEST_LOCK_HOLDER} || $$; - $holder = $$ if $holder == -1; + # referencing here delays destruction even more + if ($global_lock_fh) { + DEBUG_TEST_CONCURRENCY_LOCKS > 1 + and dbg "Release @{[ $global_exclusive_lock ? 'EXCLUSIVE' : 'SHARED' ]} global lock (END)"; + 1; + } - # useful for missing cleanup debugging - #if ( $holder == $$) { - # my $x = $0; - # $x =~ s/\//#/g; - # $holder .= "-$x"; - #} + _cleanup_dbfile(); +} - return "$dir/DBIxClass-$holder.db"; - } +sub _sqlite_dbfilename { + my $holder = $ENV{DBICTEST_LOCK_HOLDER} || $$; + $holder = $$ if $holder == -1; - END { - _cleanup_dbfile(); - } + return "t/var/DBIxClass-$holder.db"; } $SIG{INT} = sub { _cleanup_dbfile(); exit 1 }; @@ -439,9 +423,7 @@ sub deploy_schema { if ($ENV{"DBICTEST_SQLT_DEPLOY"}) { $schema->deploy($args); } else { - my $filename = Path::Class::File->new(__FILE__)->dir - ->file('sqlite.sql')->stringify; - my $sql = do { local (@ARGV, $/) = $filename ; <> }; + my $sql = slurp_bytes( 't/lib/sqlite.sql' ); 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"; diff --git a/t/lib/DBICTest/BaseSchema.pm b/t/lib/DBICTest/BaseSchema.pm index ac3cf8c..0214933 100644 --- a/t/lib/DBICTest/BaseSchema.pm +++ b/t/lib/DBICTest/BaseSchema.pm @@ -6,6 +6,7 @@ use warnings; use base qw(DBICTest::Base DBIx::Class::Schema); use Fcntl qw(:DEFAULT :seek :flock); +use IO::Handle (); use DBIx::Class::_Util 'scope_guard'; use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry); use DBICTest::Util qw( local_umask tmpdir await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS ); diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index 5911f9a..5d54c11 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -30,13 +30,13 @@ use constant { use Config; use Carp qw(cluck confess croak); use Fcntl qw( :DEFAULT :flock ); -use Scalar::Util qw(blessed refaddr); +use Scalar::Util qw( blessed refaddr openhandle ); use DBIx::Class::_Util qw( scope_guard parent_dir mkdir_p ); use base 'Exporter'; our @EXPORT_OK = qw( dbg stacktrace - local_umask tmpdir find_co_root + local_umask slurp_bytes tmpdir find_co_root rm_rf visit_namespaces PEEPEENESS check_customcond_args await_flock DEBUG_TEST_CONCURRENCY_LOCKS @@ -102,7 +102,7 @@ sub local_umask ($) { if ! defined wantarray; my $old_umask = umask($_[0]); - die "Setting umask failed: $!" unless defined $old_umask; + croak "Setting umask failed: $!" unless defined $old_umask; scope_guard(sub { local ($@, $!, $?); @@ -246,6 +246,62 @@ EOE } +sub slurp_bytes ($) { + croak "Expecting a file name, not a filehandle" if openhandle $_[0]; + croak "'$_[0]' is not a readable filename" unless -f $_[0] && -r $_[0]; + open my $fh, '<:raw', $_[0] or croak "Unable to open '$_[0]': $!"; + local $/ unless wantarray; + <$fh>; +} + + +sub rm_rf ($) { + croak "No valid argument supplied to rm_rf()" unless length "$_[0]"; + + return unless -e $_[0]; + +### I do not trust myself - check for subsuming ( the right way ) +### Avoid things like https://rt.cpan.org/Ticket/Display.html?id=111637 + require Cwd; + + my ($target, $tmp, $co_tmp) = map { + + my $abs_fn = Cwd::abs_path("$_"); + + if ( $^O eq 'MSWin32' and length $abs_fn ) { + + # sometimes we can get a short/longname mix, normalize everything to longnames + $abs_fn = Win32::GetLongPathName($abs_fn); + + # Fixup for unixy (as opposed to native) slashes + $abs_fn =~ s|\\|/|g; + } + + $abs_fn =~ s| (?init_schema(); -my $lfn = file("t/var/sql-$$.log"); -unlink $lfn or die $! - if -e $lfn; +my $log_fn = "t/var/sql-$$.log"; +unlink $log_fn or die $! if -e $log_fn; # make sure we are testing the vanilla debugger and not ::PrettyPrint require DBIx::Class::Storage::Statistics; $schema->storage->debugobj(DBIx::Class::Storage::Statistics->new); ok ( $schema->storage->debug(1), 'debug' ); -$schema->storage->debugfh($lfn->openw); -$schema->storage->debugfh->autoflush(1); -$schema->resultset('CD')->count; +{ + open my $dbgfh, '>', $log_fn or die $!; + $schema->storage->debugfh($dbgfh); + $schema->storage->debugfh->autoflush(1); + $schema->resultset('CD')->count; + $schema->storage->debugfh(undef); +} -my @loglines = $lfn->slurp; +my @loglines = slurp_bytes $log_fn; is (@loglines, 1, 'one line of log'); like($loglines[0], qr/^SELECT COUNT/, 'File log via debugfh success'); -$schema->storage->debugfh(undef); { - local $ENV{DBIC_TRACE} = "=$lfn"; - unlink $lfn; + local $ENV{DBIC_TRACE} = "=$log_fn"; + unlink $log_fn; $schema->resultset('CD')->count; my $schema2 = DBICTest->init_schema(no_deploy => 1); $schema2->storage->_do_query('SELECT 1'); # _do_query() logs via standard mechanisms - my @loglines = $lfn->slurp; + my @loglines = slurp_bytes $log_fn; is(@loglines, 2, '2 lines of log'); like($loglines[0], qr/^SELECT COUNT/, 'Env log from schema1 success'); like($loglines[1], qr/^SELECT 1:/, 'Env log from schema2 success'); @@ -60,7 +62,7 @@ $schema->storage->debugfh(undef); } END { - unlink $lfn; + unlink $log_fn if $log_fn; } open(STDERRCOPY, '>&STDERR'); diff --git a/t/storage/deploy.t b/t/storage/deploy.t index 64c2438..eb31775 100644 --- a/t/storage/deploy.t +++ b/t/storage/deploy.t @@ -6,10 +6,10 @@ use warnings; use Test::More; use Test::Exception; -use Path::Class qw/dir/; - use DBICTest; +use DBICTest::Util qw( slurp_bytes rm_rf ); +use DBIx::Class::_Util 'mkdir_p'; local $ENV{DBI_DSN}; @@ -29,11 +29,11 @@ lives_ok( sub { my $schema = DBICTest->init_schema( quote_names => 1 ); -my $var = dir ("t/var/ddl_dir-$$"); -$var->mkpath unless -d $var; +my $var_dir = "t/var/ddl_dir-$$/"; +mkdir_p $var_dir unless -d $var_dir; -my $test_dir_1 = $var->subdir ('test1', 'foo', 'bar' ); -$test_dir_1->rmtree if -d $test_dir_1; +my $test_dir_1 = $var_dir . 'test1/foo/bar'; +rm_rf $test_dir_1 if -d $test_dir_1; $schema->create_ddl_dir( [qw(SQLite MySQL)], 1, $test_dir_1 ); ok( -d $test_dir_1, 'create_ddl_dir did a make_path on its target dir' ); @@ -50,16 +50,24 @@ for ( my $type = $_->[0]; my $q = quotemeta($_->[1]); - for my $f (map { $test_dir_1->file("DBICTest-Schema-${_}-$type.sql") } qw(1 2) ) { - like scalar $f->slurp, qr/CREATE TABLE ${q}track${q}/, "Proper quoting in $f"; + for my $f (map { $test_dir_1 . "/DBICTest-Schema-${_}-$type.sql" } qw(1 2) ) { + like ( + scalar slurp_bytes $f, + qr/CREATE TABLE ${q}track${q}/, + "Proper quoting in $f" + ); } { local $TODO = 'SQLT::Producer::MySQL has no knowledge of the mythical beast of quoting...' if $type eq 'MySQL'; - my $f = $test_dir_1->file("DBICTest-Schema-1-2-$type.sql"); - like scalar $f->slurp, qr/DROP TABLE ${q}bindtype_test${q}/, "Proper quoting in diff $f"; + my $f = $test_dir_1 . "/DBICTest-Schema-1-2-$type.sql"; + like ( + scalar slurp_bytes $f, + qr/DROP TABLE ${q}bindtype_test${q}/, + "Proper quoting in diff $f" + ); } } @@ -69,7 +77,7 @@ for ( } END { - $var->rmtree; + rm_rf $var_dir; } done_testing; diff --git a/t/storage/txn.t b/t/storage/txn.t index 9a462bf..382727c 100644 --- a/t/storage/txn.t +++ b/t/storage/txn.t @@ -6,6 +6,7 @@ use warnings; use Test::More; use Test::Warn; use Test::Exception; +use Errno (); use DBICTest; @@ -215,7 +216,6 @@ sub _test_forking_action { my $pid = fork(); if( ! defined $pid ) { - skip "EAGAIN encountered, your system is likely bogged down: skipping forking test", 1 if $! == Errno::EAGAIN(); diff --git a/xt/dist/postdistdir/pod_footers.t b/xt/dist/postdistdir/pod_footers.t index 9882b52..4b14ded 100644 --- a/xt/dist/postdistdir/pod_footers.t +++ b/xt/dist/postdistdir/pod_footers.t @@ -1,9 +1,15 @@ +BEGIN { $ENV{DBICTEST_ANFANG_DEFANG} = 1 } + use warnings; use strict; use Test::More; use File::Find; +use lib 't/lib'; +use DBICTest; # for the lock +use DBICTest::Util 'slurp_bytes'; + my $boilerplate_headings = q{ =head1 FURTHER QUESTIONS? @@ -24,7 +30,7 @@ find({ return unless -f $fn; return unless $fn =~ / \. (?: pm | pod ) $ /ix; - my $data = do { local (@ARGV, $/) = $fn; <> }; + my $data = slurp_bytes $fn; if ($data !~ /^=head1 NAME/m) {