view release on metacpan or  search on metacpan

t/02-init.t  view on Meta::CPAN

		_call_with_stdin
		(\@input,
		 sub {
		     App::LXC::Container::Setup' .
		     ($call_new
		      ? '->new("dummy");'
		      : '::_init_config_dir($dummy_obj);') .
		'});');
}

sub check_config_file($$$&$)
{
    my ($name, $file, $size, $src_func, $re_content) = @_;
    ok(-f $file, $name . ' exist');
    ok(-s $file > $size, $name . ' is not empty');
    if ($src_func)
    {
	my @content = &$src_func();
	local $_ =
	    App::LXC::Container::Setup::_create_or_compare($file, @content);
	is($_, 0, $name . ' is deterministic');
	like(join("\n", @content), qr/^.*$re_content.*$/ms,
	     $name . ' has been created correctly');
    }
    else
    {
	open my $in, '<', $file  or  die "can't open $file: $!";
	local $_ = join("\n", <$in>);
	close $in;
	like($_, qr/^.*$re_content.*$/, $name . ' has been created correctly');
    }
}

#########################################################################
# regular expression parts for tests:
my $re_dialog_main =
    '^========== select or enter (configuration|LXC root) directory\n' .
    '^\s+select or enter (configuration|LXC root) directory\n' .
    '^<1>\s+\[ \.\. \][^<]+' .
    '^<2>[^<]+ \[ Quit \]\s+\[ OK \][^<]+' .
     '^<0> leave dialogue\s+^----- enter number to choose next step: [^<]+';
my $re_dialog_fs =
    '<1>\s+' .
    '^<\*> [^<]+' .
    '^<2>   [^<]+' .
    '^<3>[^<]+' .
    '^<0> leave box\s+^----- enter number to choose next step: [^<]+';
my $re_dialog_value =
    '^old value:\s+^new value\?[^<]+';
my $re_dialog_buttons =
    '^<1> \[ Quit \][^<]+'.
    '^<2> \[ OK \][^<]+' .
    '^<0> leave box\s+^----- enter number to choose next step: [^<]+';

#########################################################################
# identical parts of messages:
my $re_msg_tail = qr/ at $0 line \d{2,}\.?$/;

#########################################################################
# failing and aborted tests of _init_config_dir:
chmod 0555, FAIL_PATH  or  die "can't chmod 0555 ", FAIL_PATH;
$_ = fail_in_sub_perl(HOME_PATH, FAIL_PATH, '2 2 2 2', 1);
like($_,
     qr{^aborting after the following error\(s\):\nPermission denied at }m,
     'bad configuration directory should fail');
$_ = fail_in_sub_perl(HOME_PATH, FAIL_PATH, '2 1 2 2', 0);
like($_,
     qr{$re_dialog_main$re_dialog_buttons}ms,
     'aborting initialisation 1 looks correct');
ok(! -d HOME_PATH . '/conf', 'conf does not yet exist');
$_ = fail_in_sub_perl(HOME_PATH, FAIL_PATH, '2 2 2 1', 0);
like($_,
     qr{$re_dialog_main$re_dialog_buttons}ms,
     'aborting initialisation 2 looks correct');
ok(! -d HOME_PATH . '/conf', 'conf still does not yet exist');
$_ = fail_in_sub_perl(FAIL_PATH, HOME_PATH, '2 2 2 2', 0);
like($_,
     qr{^can't link '.*/t/tmp/fail/.lxc-configuration' to '.*/t/tmp/home': Permission denied at }m,
     'unwritable home directory should fail');
ok(-d HOME_PATH . '/conf', 'conf got created regardless of error');

eval {   App::LXC::Container::Setup::new('wrong-call', 'dummy');   };
like($@,
     qr{^bad call to App::LXC::Container::Setup->new.*$re_msg_tail},
     'bad call of App::LXC::Container::Setup->new fails');

#########################################################################
# tests of _init_config_dir:

# on smokers (no STDIN from TTY) we only use mockup (except for 'ls' and 'ldd'):
-t STDIN  and  $ENV{PATH} = T_PATH . '/mockup:' . $ENV{PATH};

# We must find the real ldd, not the one in mockup for setup/data tests:
chmod 0644, T_PATH . '/mockup/ldd'
    or  die "can't chmod 0644 ", T_PATH . '/mockup/ldd';

my $re_dialog = join('',
		     $re_dialog_main,
		     $re_dialog_fs,
		     $re_dialog_value,
		     $re_dialog_fs,
		     $re_dialog_main,
		     $re_dialog_buttons,
		     $re_dialog_main,
		     $re_dialog_buttons
		    );

my @input = qw(1 3 lxc 0 2 2 2 2);
my $dummy_obj = { MAIN_UI => UI::Various::Main->new() };
$dummy_obj = bless $dummy_obj, "App::LXC::Container::Setup";
stdout_like
{   _call_with_stdin
	(\@input,
	 sub { App::LXC::Container::Setup::_init_config_dir($dummy_obj); });
}
    qr{$re_dialog}ms,
    'initialisation of configuration directory did not fail';

my $root_dir = TMP_PATH . '/lxc';
is(-d  $root_dir . '/conf', 1, 'configuration directories exist');
is(-l  HOME_PATH . '/.lxc-configuration', 1,
   'symbolic link to configuration directory exists');
check_config_file('network list',
		  $root_dir . '/.networks.lst',
		  70,
		  \&App::LXC::Container::Data::initial_network_list,
		  '1 is the LXC bridge');
check_config_file('LXC root file-system',
		  $root_dir . '/.root_fs',
		  12,
		  undef,
		  '^/var/lib/lxc\n$');
check_config_file('default network configuration',
		  $root_dir . '/conf/10-NET-default.conf',
		  200,
		  \&App::LXC::Container::Data::content_network_default,
		  '^lxc\.net\.0\.ipv4\.address = ');
check_config_file('default device configuration',
		  $root_dir . '/conf/20-DEV-default.conf',
		  120,
		  \&App::LXC::Container::Data::content_device_default,
		  '^lxc\.mount\.auto =( cgroup:ro| proc:mixed| sys:ro){3}$');
check_config_file('minimal default package configuration',
		  $root_dir . '/conf/30-PKG-default.packages',
		  160,
		  \&App::LXC::Container::Data::content_default_packages,
		  '^libc\b');
check_config_file('minimal network package configuration',
		  $root_dir . '/conf/31-PKG-network.packages',
		  100,
		  \&App::LXC::Container::Data::content_network_packages,
		  '^iproute2\b');
check_config_file('minimal default mount configuration',
		  $root_dir . '/conf/40-MNT-default.mounts',
		  300,