view release on metacpan or  search on metacpan

t/03-setup.t  view on Meta::CPAN

$re_output .=
    $re_main_box .					# 5
    '(?:' . $re_modify_features . '){2}';		# 1, 2

push @input, qw(0 6);		# .. -> user box
$re_output .=
    $re_modify_features .				# 0
    $re_main_box;					# 6

push @input,
    qw(2 2 1 1 0 2 2 0),	# add 1st user found
    qw(2 2 1 1 0 2 2 0),	# same again
    qw(2 2 1 1 0 2 1 0);	# same again, but cancel
$re_output .=
    '(?:' .
    $re_list_users . $re_select .			# 2
    $re_select_mp . $re_select .			# 2
    $re_select_user_dialogue . $re_select .		# 1
    '(?:' . $re_select_user_list . '){2}' .		# 1, 0
    $re_select_user_dialogue . $re_select .		# 2
    $re_select_cancel_ok_buttons . $re_select .		# 2
    $re_select_mp . $re_select .			# 0
    '){3}';						# same again
push @input,
    qw(2 1 0),			# try removing without selection
    qw(1 1 0 2 1 0);		# remove 2nd of the 2
$re_output .=
    $re_list_users . $re_select .			# 2
    '(?:' . $re_select_mp . $re_select . '){2}' .	# 1, 0
    $re_list_users . $re_select .			# 1
    '1-2/2\s++' . '(?:<[12]>   ' . $re_user . '\s++){2}' .
    $re_select_listbox .				# 1
    '1-2/2\s++' . '(?:<[12]> [ *] ' . $re_user . '\s++){2}' .
    $re_select_listbox .				# 0
    $re_list_users . $re_select .			# 2
    '(?:' . $re_select_mp . $re_select . '){2}';	# 1, 0

push @input, qw(0 9);		# leave user box, save and quit
$re_output .=
    $re_list_users . $re_select .			# 0
    $re_main_box . '$';					# 9

output_like
{   _call_with_stdin(\@input, sub { App::LXC::Container::setup("test"); });   }
    qr{$re_output}ms,
    qr{$re_error_to_small\s+$re_bad_interpreter},
    'modifying everything printed expected output';

my @big_stat = (scalar(@input), length($re_output));

#########################################################################
# now check configuration created by above monster-test:
check_config_against_regexp
    ('tt-CNF-test.master', '3rd',
     qr{^network=1\nx11=1\naudio=1\nusers=$re_user$}m);
check_config_against_regexp
    ('tt-MNT-test.mounts', '3rd',
     qr{\A\#\ mounts\ for\ container\ test$
	.*/t/tmp/usr/bin/2something$
	.*/t/tmp/usr/bin/2something\s+create=file,rw\s+tmpfs$
	.*/t/tmp/usr/bin/2something\s+create=file,rw,bind$}msx);
check_config_against_regexp
    ('tt-NOT-test.filter', '3rd',
     qr{^/var/log\s+empty\n
	.*/t/tmp/usr/bin/2something\s+copy\n
	.*/t/tmp/usr/bin/2something\s+nomerge\n
	.*/t/tmp/usr/bin/2something\s+ignore\n}mx);
check_config_against_regexp
    ('tt-PKG-test.packages', '3rd',
     qr{\A# package list for container test\n.*^chromium\n\Z}ms);

#########################################################################
# 4th round: read modified configuration again:

@input = qw(1 7);
$re_output =
    $re_main_window .
    $re_main_box .
    '$';
output_like
{   _call_with_stdin(\@input, sub { App::LXC::Container::setup("test"); });   }
    qr{$re_output}ms,
    qr{$re_error_to_small},
    'reading modified configuration again did not cause any errors';

#########################################################################
# simulate invalid configuration entries and other fatal errors:
eval {   App::LXC::Container::Setup::_mark2filter('XX /bad-entry');   };
like($@,
     qr/^INTERNAL ERROR [^:]+: bad mark 'XX' in _mark2filter$re_msg_tail/,
     'bad filter entry fails');

eval {   App::LXC::Container::Setup::_mark2mount('YY /bad-entry');   };
like($@,
     qr/^INTERNAL ERROR [^:]+: bad mark 'YY' in _mark2mount$re_msg_tail/,
     'bad mount entry fails');

eval {   App::LXC::Container::Setup::_modify_entry(1,2,3, 1,2);   };
like($@,
     qr/^INTERNAL ERROR [^:]+: uneven list in _modify_entry$re_msg_tail/,
     'short parameter list for _modify_entry fails');
eval {   App::LXC::Container::Setup::_modify_entry(1,2,3, 1,2,3,4,5);   };
like($@,
     qr/^INTERNAL ERROR [^:]+: uneven list in _modify_entry$re_msg_tail/,
     'uneven parameter list for _modify_entry fails');

my $dummy_obj = {name => 'not-accessible'};
sub test_not_accessible($)
{
    my ($file) = @_;
    my $short_path = '/lxc/conf/' . $file;
    _remove_file($short_path);
    _setup_file($short_path);
    _chmod(0, $short_path);
    my $re = "can't open '" . LXC_LINK . '/conf/' . $file . "'" . ': .*'
	. $re_msg_tail_eval;
    (my $func = $file) =~ s/^.*\.//;
    $func = 'App::LXC::Container::Setup::_parse_' . $func . '($dummy_obj);';
    eval "$func";
    like($@, qr/^$re$/,
	 'reading non-accessible configuration file ' . $file . ' fails');
}
test_not_accessible('ne-NOT-not-accessible.filter');
test_not_accessible('ne-CNF-not-accessible.master');
test_not_accessible('ne-MNT-not-accessible.mounts');
test_not_accessible('ne-PKG-not-accessible.packages');

$dummy_obj = {name => 'bad'};
sub test_bad_config($@)
{
    my $file = shift;
    my $short_path = '/lxc/conf/' . $file;
    _remove_file($short_path);
    _setup_file($short_path, @_);
    my $re = "ignoring unknown configuration item in '" . LXC_LINK .
	'/conf/' . $file . "'" . ', line 1' . $re_msg_tail_eval;
    (my $func = $file) =~ s/^.*\.//;
    $func = 'App::LXC::Container::Setup::_parse_' . $func . '($dummy_obj);';
    output_like
    {	eval "$func";   }
    qr{^$}, qr/^$re$/,
    'reading bad configuration file ' . $file . ' fails';
}
test_bad_config('bd-NOT-bad.filter', 'bad entry');
test_bad_config('bd-CNF-bad.master', 'bad entry');
test_bad_config('bd-MNT-bad.mounts', 'bad-entry ');
test_bad_config('bd-PKG-bad.packages', 'bad entry');

#########################################################################
# simulate some more valid configuration entries:
like(App::LXC::Container::Setup::_mark2mount('RW /dev/disk'),
     qr{^/dev/disk\s+create=dir,rw,bind,optional$},
     'valid optional device directory');
like(App::LXC::Container::Setup::_mark2mount('RW /dev/somedevice'),
     qr{^/dev/somedevice\s+create=file,rw,bind,optional$},
     'valid optional device file');
like(App::LXC::Container::Setup::_mark2mount('OV /'),
     qr{^/\s+create=dir,rw\s+tmpfs$},
     'valid temporary directory');

#########################################################################
# run tests with other maximum screen sizes:
sub test_other_screen_size($$)
{
    my ($w, $h) = @_;
    my %dummy_obj = (MAIN_UI => UI::Various::Main->new(),
		     name => 'x', packages => [], mounts => [], filter => [],
		     network => 0, x11 => 0, audio => 0, users => []);
    # Unfortunately we need to access UI::Various internal structure here to
    # modify the maximum size of the virtual screen:
    $dummy_obj{MAIN_UI}{max_width} = $w;
    $dummy_obj{MAIN_UI}{max_height} = $h;
    return bless \%dummy_obj, 'App::LXC::Container::Setup';
};
output_like
{
    my $dummy_obj = test_other_screen_size(12, 99);
    App::LXC::Container::Setup::_create_main_window($dummy_obj);
}
    qr{^$}, qr{^$re_error_to_small},
    'narrow window causes error';
output_like
{
    my $dummy_obj = test_other_screen_size(99, 24);
    App::LXC::Container::Setup::_create_main_window($dummy_obj);
}
    qr{^$}, qr{^$re_error_to_small},
    'low window causes error';
output_like
{
    my $dummy_obj = test_other_screen_size(99, 99);
    App::LXC::Container::Setup::_create_main_window($dummy_obj);
}
    qr{^$}, qr{^$},
    'large enough window removed error';

#########################################################################
# special tests for library dependencies (ldd):
package Dummy::UI
{
    require Exporter;
    our @ISA = qw(Exporter);
    sub new($) { my $self = {}; bless $self, 'Dummy::UI'; }
    sub add($@) { shift; print "ADD2UI\t", join(',', @_), "\n"; }
};
sub test_ldd_dummy_object(@)
{
    my $dummy_ui = Dummy::UI->new();
    App::LXC::Container::Setup::__add_library_packages_internal_code
	    ($dummy_ui, @_);
}
stdout_like
{   test_ldd_dummy_object('/bin/ls');   }
    qr{^ADD2UI\s+libc6(?::amd64|:i386)?$},
    'test for existing library dependencies';