'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',
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");
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<DBD::mysql>.
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;
},
},
+ ic_file => {
+ req => {
+ 'Path::Class' => '0.18',
+ },
+ pod => {
+ title => 'DBIx::Class::InflateColumn::File (Deprecated)',
+ desc => 'Modules required for the deprecated L<DBIx::Class::InflateColumn::File>',
+ },
+ },
+
ic_dt => {
req => {
'DateTime' => '0.55',
"\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?";
quote_sub perlstring serialize
dbic_internal_try
detected_reinvoked_destructor scope_guard
+ mkdir_p
);
use namespace::clean;
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');
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/]
);
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 });
}
$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
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
# 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
$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;
}
use strict;
use warnings;
use Test::More;
+use Errno ();
use DBIx::Class::_Util 'sigwarn_silencer';
use DBICTest;
# 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 = ();
# 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) {
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/};
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 });
;
END {
- unless ($ENV{DBICTEST_KEEP_VERSIONING_DDL}) {
- $ddl_dir->rmtree;
- }
+ rm_rf $ddl_dir unless $ENV{DBICTEST_KEEP_VERSIONING_DDL};
}
done_testing;
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;
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
}
sub cleanup {
- my ($dir) = @_;
- $ddl_dir->rmtree if -d $ddl_dir;
+ rm_rf $ddl_dir if -d $ddl_dir;
unlink $db_fn;
}
BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
+use DBIx::Class::Optional::Dependencies -skip_all_without => qw( ic_file );
use strict;
use warnings;
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
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;
}
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 };
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";
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 );
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
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 ($@, $!, $?);
}
+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| (?<! / ) $ |/|x
+ if -d $abs_fn;
+
+ ( $abs_fn =~ /(.+)/s )[0]
+
+ } ( $_[0], tmpdir, find_co_root . 't/var' );
+
+ croak(
+ "Path supplied to rm_rf() '$target' is neither within the local nor the "
+ . "global scratch dirs ( '$co_tmp' and '$tmp' ): REFUSING TO `rm -rf` "
+ . 'at random'
+ ) unless (
+ ( index($target, $co_tmp) == 0 and $target ne $co_tmp )
+ or
+ ( index($target, $tmp) == 0 and $target ne $tmp )
+ );
+###
+
+ require File::Path;
+
+ # do not ask for a recent version, use 1.x API calls
+ File::Path::rmtree([ $target ]);
+}
+
+
sub stacktrace {
my $frame = shift;
$frame++;
use File::Spec;
use DBICTest;
-use Path::Class qw/file/;
+use DBICTest::Util 'slurp_bytes';
my $schema = DBICTest->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');
}
END {
- unlink $lfn;
+ unlink $log_fn if $log_fn;
}
open(STDERRCOPY, '>&STDERR');
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};
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' );
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"
+ );
}
}
}
END {
- $var->rmtree;
+ rm_rf $var_dir;
}
done_testing;
use Test::More;
use Test::Warn;
use Test::Exception;
+use Errno ();
use DBICTest;
my $pid = fork();
if( ! defined $pid ) {
-
skip "EAGAIN encountered, your system is likely bogged down: skipping forking test", 1
if $! == Errno::EAGAIN();
+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?
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) {
projects / dbsrgits/DBIx-Class.git / commitdiff