package t::Utils;
use strict;
use warnings;
use t::Utils::IgnoreWarn;
use Params::Validate qw(:all);
use parent qw(Exporter);
our @EXPORT = qw(
ignore_warn rebuild_tfiles xsystem xfork slurp local_ubic
);
use Carp;
use Cwd;
sub import {
my $class = shift;
if ($ENV{PERL5LIB}) {
$ENV{PERL5LIB} = getcwd()."/lib:".$ENV{PERL5LIB};
}
else {
$ENV{PERL5LIB} = getcwd()."/lib";
}
delete $ENV{$_} for grep { /^UBIC/ } %ENV; # in case user uses env to configure local ubic instance
__PACKAGE__->export_to_level(1, @_);
}
sub rebuild_tfiles {
system('rm -rf tfiles') and die "Can't remove tfiles";
mkdir 'tfiles' or die "Can't create tfiles: $!";
}
sub xsystem {
local $! = local $? = 0;
return if system(@_) == 0;
my @msg;
if ($!) {
push @msg, "error ".int($!)." '$!'";
}
if ($? > 0) {
push @msg, "kill by signal ".($? & 127) if ($? & 127);
push @msg, "core dumped" if ($? & 128);
push @msg, "exit code ".($? >> 8) if $? >> 8;
}
die join ", ", @msg;
}
sub xfork {
my $pid = fork;
croak "fork failed: $!" unless defined $pid;
return $pid;
}
sub slurp {
my $file = shift;
open my $fh, '<', $file or die "Can't open $file: $!";
return do { local $/; <$fh> };
}
our $local_ubic;
sub local_ubic {
my $params = validate(@_, {
service_dirs => { type => ARRAYREF, default => ['t/service/common', 'etc/ubic/service'] },
default_user => {
type => SCALAR,
default => $ENV{LOGNAME} || $ENV{USERNAME} || scalar getpwuid($>),
},
});
xsystem('mkdir tfiles/service');
for my $dir (@{ $params->{service_dirs} }) {
xsystem('cp', '-r', '--', glob("$dir/*"), 'tfiles/service/');
}
require Ubic;
Ubic->set_data_dir('tfiles/ubic');
Ubic->set_service_dir('tfiles/service');
Ubic->set_default_user($params->{default_user});
}
1;