view release on metacpan or  search on metacpan

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

    }
    else
    {	fail($name . ' has correct content after ' . $nr . ' run');   }
}

#########################################################################
# identical parts of messages:
my $re_msg_tail = qr/ at $0 line \d{2,}\.?$/;
my $re_msg_tail_m = qr/ at $0 line \d{2,}\.?$/m;
my $re_msg_tail_eval = qr/ at \(eval \d+\)(?:\[$0:\d{2,}\])? line \d+\.?$/;

# initial clean-up, only needed for re-run:
_remove_file('/lxc/conf/' . $_) foreach('tt-CNF-test.master',
					'tt-MNT-test.mounts',
					'tt-NOT-test.filter',
					'tt-PKG-test.packages');

#########################################################################
# failing tests:

_remove_link(LXC_LINK);
_setup_dir('/home/.lxc-configuration');
$_ = fail_in_sub_perl(1);
like($_,
     qr{t/tmp/home/.lxc-configuration is not a symbolic link at -e line \d\.$}m,
     'bad configuration link should fail');
$_ = fail_in_sub_perl(2);
my $re = 'INTERNAL ERROR [^:]+: directory missing '
    . 'in _save_configuration at -e line \d\.';
like($_, qr/^$re$/m,
     'missing configuration directory should fail on save');
_remove_dir(LXC_LINK);
_setup_link(LXC_LINK, CONF_ROOT);

eval {   App::LXC::Container::setup('bad-name!');   };
like($@,
     qr/^The name of the container may only contain word char.*!$re_msg_tail/,
     'bad container name fails');
App::LXC::Container::Texts::debug(0);			# manual reset!

eval {
    App::LXC::Container::Setup::_write_to('t/tmp/not-existing-dir/file', '');
};
like($@,
     qr{^can't open 't/tmp/not-existing-dir/file': .*$re_msg_tail},
     'bad file name fails');

#########################################################################
# simple writing tests:

my $abs_test_file = HOME_PATH . '/write.tst';
my $test_file = '/home/write.tst';
output_like
{   App::LXC::Container::Setup::_write_to($abs_test_file, '42');   }
    qr{^$}, qr{^$},
    '1st writing test did not fail';
output_like
{   App::LXC::Container::Setup::_write_to($abs_test_file, '47');   }
    qr{^$}, qr{^$},
    '2nd writing test did not fail';
_chmod(0444, $test_file);
output_like
{   App::LXC::Container::Setup::_write_to($abs_test_file, '0');   }
    qr{^$}, qr{^using existing protected .*/t/tmp/home/write.tst$re_msg_tail},
    '3rd writing test produced warning';
my $output = '';
if (-f $abs_test_file)
{
    open my $in, '<', $abs_test_file
	or  die "can't open ", $abs_test_file, ': ', $!;
    $output = join('', <$in>);
    close $in;
}
is($output, "47\n", 'writing test produced expected output');
_remove_file($test_file);

#########################################################################
# regular expression parts for tests (hangs without possessive matching):
my $re_div = '----------\s++';
my $re_buttons_mp = '\[ - \]\s++\[ \+ \]\s++';
my $re_buttons_map = '\[ - \]\s++\[ \* \]\s++\[ \+ \]\s++';
my $re_buttons_mapp = '\[ - \]\s++\[ \* \]\s++\[ \+ \]\s++\[ \+\+ \]\s++';
my $re_listbox_head = '(?:<1> ++)?(?:0|[1-9][0-9]*-[1-9][0-9]*)/\d+\s++';
my $re_list_buttons_mp = $re_listbox_head . '[^[]*+' . $re_buttons_mp;
my $re_list_buttons_map = $re_listbox_head . '[^[]*+' . $re_buttons_map;
my $re_list_buttons_mapp = $re_listbox_head . '[^[]*+' . $re_buttons_mapp;
my $re_list_packages = 'packages\s++' . $re_list_buttons_mapp;
my $re_list_files = 'files\s++' . $re_list_buttons_map;
my $re_list_filter = 'filter\s++' . $re_list_buttons_map;
my $re_radio = '(?:<[1*]>\s++)?\([o ]\) ';
my $re_network =
    'network\s++' .
    $re_radio . 'none\s++' .
    $re_radio . 'local\s++' .
    $re_radio . 'full\s++' .
    $re_div;
my $re_features =
    'features\s++' .
    '\[[ X]\] X11\s++' .
    '\[[ X]\] audio\s++' .
    $re_div;
my $re_list_users = 'users\s++' . $re_list_buttons_mp;
my $re_main_buttons =
    '(?:<7> )?\[ Quit \]\s++' .
    '(?:<8> )?\[ Help \]\s++' .
    '(?:<9> )?\[ OK \]\s++';
my $re_select =
    '^<0> leave (box|dialogue|window)\s++' .
    '^----- enter number to choose next step: \d++\s++';
my $re_select_mp = '<1> \[ - \]\s++<2> \[ \+ \]\s++';
my $re_select_map = '<1> \[ - \]\s++<2> \[ \* \]\s++<3> \[ \+ \]\s++';
my $re_select_mapp =
    '<1> \[ - \]\s++<2> \[ \* \]\s++<3> \[ \+ \]\s++<4> \[ \+\+ \]\s++';
my $re_select_listbox =
    '^< ?0> ++leave listbox\s++' .
    '^enter selection(?: \(\+/- scrolls\))?: \d++\s++';
my $re_select_radio =
    '^enter selection \(0 to cancel\): \d++\s++';

my $re_window_content =
    '<1>\s++' .

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

    ('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';

_setup_file('/usr/bin/3ls');
_setup_link(TMP_PATH . '/usr/libbad.so.0', '/usr/non-existing-dir/libbad.so');
chmod 0755, T_PATH . '/mockup/ldd'
    or  die "can't chmod 0755 ", T_PATH . '/mockup/ldd';

stdout_like
{   test_ldd_dummy_object(TMP_PATH . '/usr/bin/3ls');   }
    qr{^$},
    'ldd test with bad symbolic link';

stdout_like
{   test_ldd_dummy_object('/nowhere/to/be/found');   }
    qr{^$},
    'test for non-existing library dependencies';
_remove_link(TMP_PATH . '/usr/libbad.so.0');

chmod 0644, T_PATH . '/mockup/ldd'
    or  die "can't chmod 0644 ", T_PATH . '/mockup/ldd';

#########################################################################
# final statistics:
diag('big test statistic: ', $big_stat[0],
     ' inputs checked against a regular expression of size ', $big_stat[1]);