root/1.8.2/trunk/test/testatree.pl

use PennMUSH;
use MUSHConnection;
use TestHarness;

$| = 1;

$mush = PennMUSH->new();
# print "MUSH on port ".$mush->{PORT}."\n";
# sleep(30);
$god = $mush->loginGod();

# First, the basic tests enforcing tree-nature of the attributes.
# Attrs may not start or end in `
test("atree.basic.1", $god, "&foo` me=baz", "not a very good name");
test("atree.basic.2", $god, "&`bar me=baz", "not a very good name");
# Not even if there's a preexisting branch
test("atree.basic.3", $god, "&foo me=baz", "Set");
test("atree.basic.4", $god, "&foo` me=baz", "not a very good name");
# You may not have two ` in a row
test("atree.basic.5", $god, "&foo``bar me=baz", "not a very good name");
# Make a small tree
test("atree.basic.6", $god, "&foo me=baz", "Set");
test("atree.basic.7", $god, "&foo`bar me=baz", "Set");
test("atree.basic.8", $god, "&foo`bar`baz me=baz", "Set");
# Cannot clear branches with leaves until the leaves are cleared
test("atree.basic.9", $god, "&foo me", "!Cleared");
test("atree.basic.10", $god, "&foo`bar me", "!Cleared");
test("atree.basic.11", $god, "&foo`bar`baz me", "Cleared");
test("atree.basic.12", $god, "&foo`bar me", "Cleared");
test("atree.basic.13", $god, "&foo me", "Cleared");
# You can wipe, though.
test("atree.basic.14", $god, "&foo me=baz", "Set");
test("atree.basic.15", $god, "&foo`bar me=baz", "Set");
test("atree.basic.16", $god, "&foo`bar`baz me=baz", "Set");
test("atree.basic.17", $god, '@wipe me/foo', "wiped");

# Branch permissions
# May make a leaf without supporting branch
test("atree.branch.1", $god, "&foo`bar me=baz", "!You must set FOO first");
# And it must make the branch
test("atree.branch.2", $god, "think hasattr(me, foo)", "1");
# Another child should not wipe the previous values
test("atree.branch.3", $god, "&foo`bar`baz me=baz", "!You must set FOO first");
test("atree.branch.4", $god, "think get(me/foo`bar)", "baz");
# Clean up again
test("atree.branch.5", $god, '@wipe me/foo', "wiped");

# Wildcard attribute matching
# Rebuild a tree
test("atree.matching.1", $god, "&foo me=baz", "Set");
test("atree.matching.2", $god, "&foo`bar me=baz", "Set");
test("atree.matching.3", $god, "&foo`baz me=baz", "Set");
test("atree.matching.4", $god, "&foo`bar`baz me=baz", "Set");
# Examine should show a ` attribute flag for foo, foo`bar, but not foo`bar`baz
test("atree.matching.5", $god, "examine me/foo", 'FOO \[.*`\]');
test("atree.matching.6", $god, "examine me/foo`bar", 'FOO`BAR \[.*`\]');
test("atree.matching.7", $god, "examine me/foo`bar`baz", 'FOO`BAR`BAZ \[[^`]*\]');
# Examine doesn't show recursively, by default
test("atree.matching.8", $god, "examine me", ['FOO \[.*`\]', '!FOO`BAR']);
# But it will if you ask for it
test("atree.matching.9", $god, "examine me/**",
     ['FOO \[.*`\]', 'FOO`BAR \[', 'FOO`BAR`BAZ \[[^`]+\]']);
# If you ask for an attribute, you don't get its children
test('atree.matching.10', $god, 'examine me/FOO',
     ['FOO \[.*`\]', '!FOO`BAR \[', '!FOO`BAR`BAZ \[[^`]+\]']);
# You have to ask for the children
test('atree.matching.11', $god, 'examine me/FOO`',
     ['!FOO \[.*`\]', 'FOO`BAR \[', 'FOO`BAZ \[', '!FOO`BAR`BAZ \[[^`]+\]']);
test('atree.matching.12', $god, 'examine me/FOO`BAR`',
     ['!FOO \[.*`\]', '!FOO`BAR \[', '!FOO`BAZ \[', 'FOO`BAR`BAZ \[[^`]+\]']);
test('atree.matching.13', $god, 'examine me/FOO`*',
     ['!FOO \[.*`\]', 'FOO`BAR \[', 'FOO`BAZ \[', '!FOO`BAR`BAZ \[[^`]+\]']);
# A single * doesn't match `
test('atree.matching.14', $god, 'examine me/FOO*Z',
     ['!FOO \[.*`\]', '!FOO`BAR \[', '!FOO`BAZ \[', '!FOO`BAR`BAZ \[[^`]+\]']);
# A double * does match `
test('atree.matching.15', $god, 'examine me/FOO**Z',
     ['!FOO \[.*`\]', '!FOO`BAR \[', 'FOO`BAZ \[', 'FOO`BAR`BAZ \[[^`]+\]']);
# @decompile gets everything by default
test('atree.matching.16', $god, '@decompile me',
     ['&FOO ', '&FOO`BAR ', '&FOO`BAR`BAZ ']);
# But only the top layer if you say so
test('atree.matching.17', $god, '@decompile me/*',
     ['&FOO ', '!&FOO`BAR ', '!&FOO`BAR`BAZ ']);
# lattr() works like examine, only top by default
test('atree.matching.18', $god, 'think lattr(me)',
     ['\bFOO\b', '!\bFOO`BAR\b', '!\bFOO`BAR`BAZ\b']);
test('atree.matching.19', $god, 'think lattr(me/**)',
     ['\bFOO\b', '\bFOO`BAR\b', '\bFOO`BAR`BAZ\b']);
test("atree.matching.20", $god, 'think flags(me/foo)', '`');

# Permissions checks
# Need a mortal for this...
test('atree.perms.1', $god, '@pcreate Mortal=mortal', 'created');
$mortal = $mush->login("Mortal", "mortal");
# Build a tree from different places...
test('atree.perms.2', $god, '&foo mortal=baz', 'Set');
test('atree.perms.3', $god, '&foo`bar mortal=baz', 'Set');
test('atree.perms.4', $mortal, '@decompile me', ['&FOO ', '&FOO`BAR ']);
test('atree.perms.5', $mortal, '&foo`bar me=baz', 'Set');
test('atree.perms.6', $mortal, '&foo`bar`baz me=baz', 'Set');
# Start flipping perms...
test('atree.perms.7', $god, '@set mortal/foo`bar=wiz', 'set');
test('atree.perms.8', $mortal, '@decompile me',
     ['&FOO ', '&FOO`BAR ', '&FOO`BAR`BAZ ']);
# Cannot overwrite wiz-only as mortal, or make stuff under it
test('atree.perms.9', $mortal, '&foo`bar me=baz', '!Set');
test('atree.perms.10', $mortal, '&foo`bar`baz me=baz', '!Set');
test('atree.perms.11', $mortal, '&foo`bar`qux me=baz', '!Set');
# Cannot see under mortal_dark as mortal
test('atree.perms.12', $god, '@set mortal/foo`bar=mortal_dark', 'set');
test('atree.perms.13', $mortal, '@decompile me',
     ['&FOO ', '!&FOO`BAR ', '!&FOO`BAR`BAZ ', '!&FOO`BAR`QUX ']);
# Still can't write there (still wiz-only)
test('atree.perms.14', $mortal, '&foo`bar me=baz', '!Set');
test('atree.perms.15', $mortal, '&foo`bar`baz me=baz', '!Set');
test('atree.perms.16', $mortal, '&foo`bar`qux me=baz', '!Set');
# Turn off wiz-only, but still can't see it...
test('atree.perms.17', $god, '@set mortal/foo`bar=!wiz', 'reset');
test('atree.perms.18', $mortal, '@decompile me',
     ['&FOO ', '!&FOO`BAR ', '!&FOO`BAR`BAZ ', '!&FOO`BAR`QUX ']);
# But you can write there again...
test('atree.perms.19', $mortal, '&foo`bar me=baz', 'Set');
test('atree.perms.20', $mortal, '&foo`bar`baz me=baz', 'Set');
test('atree.perms.21', $mortal, '&foo`bar`qux me=baz', 'Set');

# Parenting and ancestry
test('atree.parent.1', $mortal, '@create ancestor', 'Created');
test('atree.parent.2', $mortal, '@create parent', 'Created');
test('atree.parent.3', $mortal, '@create child', 'Created');
test('atree.parent.4', $mortal, 'drop child', '.');
test('atree.parent.5', $mortal, 'drop parent', '.');
test('atree.parent.6', $mortal, 'drop ancestor', '.');
test('atree.parent.7', $mortal, '@parent child=parent', 'Parent changed');
test('atree.parent.8', $god,
     '@config/set ancestor_thing=[after(num(ancestor),#)]', 'set');
# Can we see stuff from the ancestor?
test('atree.parent.9', $mortal, '&foo ancestor=urk', 'Set');
test('atree.parent.10', $mortal, '&foo`bar ancestor=urk', 'Set');
test('atree.parent.11', $mortal, '&foo`bar`baz ancestor=urk', 'Set');
test('atree.parent.12', $mortal, 'think get(child/foo)', 'urk');
test('atree.parent.13', $mortal, 'think get(child/foo`bar)', 'urk');
# Can we see stuff from the parent?
test('atree.parent.14', $mortal, '&foo parent=wibble', 'Set');
test('atree.parent.15', $mortal, '&foo`bar parent=gleep', 'Set');
test('atree.parent.16', $mortal, 'think get(child/foo)', 'wibble');
test('atree.parent.17', $mortal, 'think get(child/foo`bar)', 'gleep');
test('atree.parent.18', $mortal, '&foo`bar`baz child=boom', 'Set');
test('atree.parent.19', $mortal, 'think -[get(child/foo)]-', '--');
test('atree.parent.20', $mortal, 'think -[get(child/foo`bar)]-', '--');
test('atree.parent.21', $mortal, '@wipe child/foo', 'wiped');
# Setting no_inherit puts it back to the ancestor
test('atree.parent.22', $mortal, '@set parent/foo=no_inherit', 'set');
test('atree.parent.23', $mortal, 'think get(child/foo)', '!wibble');
test('atree.parent.24', $god, 'think get(child/foo`bar)', '!gleep');
test('atree.parent.25', $god, 'think get(child/foo)', 'urk');
test('atree.parent.26', $god, 'think get(child/foo`bar)', 'urk');

# Mix permissions and parents
# If parent is inheritable again, and mortal_dark,
# then we can't see the ancestor through it
test('atree.parentperms.1', $mortal, '@set parent/foo=!no_inherit', 'set');
test('atree.parentperms.2', $god, '@set parent/foo`bar=mortal_dark', 'set');
test('atree.parentperms.3', $mortal, 'think get(child/foo`bar`baz)', '!urk');
# We can't see it, either
test('atree.parentperms.4', $mortal, 'think get(child/foo`bar)', '!gleep');
test('atree.parentperms.5', $mortal, '@set parent/foo=no_inherit', 'set');
# no_inherit trumps mortal_dark
test('atree.parentperms.6', $mortal, 'think get(child/foo`bar`baz)', 'urk');
test('atree.parentperms.7', $mortal, 'think get(child/foo`bar)', 'urk');
test('atree.parentperms.8', $god, '@set parent/foo=mortal_dark', 'set');
test('atree.parentperms.9', $mortal, 'think get(child/foo`bar)', 'urk');

# Command checks
# Need explicit grandparent, because ancestors aren't checked for commands
test('atree.command.1', $mortal, '@create grand', []);
test('atree.command.2', $mortal, 'drop grand', []);
test('atree.command.3', $mortal, '@parent parent=grand', []);
test('atree.command.4', $mortal, '&bar grand=$bar:say Grand Bar', 'Set');
test('atree.command.5', $mortal, '&bar`baz grand=$bar`baz:say Grand Baz', []);
test('atree.command.6', $mortal, '&bar parent=$bar:say Parent Bar', 'Set');
test('atree.command.7', $mortal, '&bar`baz parent=$bar`baz:say Parent Baz', []);
test('atree.command.8', $mortal, '@set child=!no_command', 'set');
# Do commands work from parent?
test('atree.command.9', $god, 'bar', '!Bar');
test('atree.command.10', $god, undef, 'Parent Bar');
test('atree.command.11', $god, 'bar`baz', []);
test('atree.command.12', $god, undef, 'Parent Baz');
# Child should block parent
test('atree.command.13', $mortal, '&bar child=$bar:say Child!', 'Set');
test('atree.command.14', $god, 'bar', '!Bar');
test('atree.command.15', $god, undef, ['!Bar', 'Child']);
# Child no_command blocks parent branch, too
test('atree.command.16', $mortal, '@set child/bar=no_command', 'set');
test('atree.command.17', $god, 'bar`baz', '!Baz');
test('atree.command.18', $god, undef, '!Baz');
# Parent no_command not masked by child not no_command...
test('atree.command.19', $mortal, '@set child/bar=!no_command', 'set');
test('atree.command.20', $mortal, '@set parent/bar=no_command', 'set');
test('atree.command.21', $god, 'bar`baz', '!Baz');
test('atree.command.22', $god, undef, '!Baz');
# no_command can be on the leaf, too
test('atree.command.23', $mortal, '@set parent/bar=!no_command', 'set');
test('atree.command.24', $mortal, '@set parent/bar`baz=no_command', 'set');
test('atree.command.25', $god, 'bar`baz', '!Baz');
test('atree.command.26', $god, undef, '!Baz');
# no_inherit trumps no_command
test('atree.command.27', $mortal, '@set parent/bar=no_inherit', 'set');
test('atree.command.28', $mortal, '@set parent/bar`baz=no_command', 'set');
test('atree.command.29', $god, 'bar`baz', '!Baz');
test('atree.command.30', $god, undef, 'Grand Baz');
test('atree.command.31', $mortal, '@set parent/bar=no_command', 'set');
test('atree.command.32', $mortal, '&bar child', []);
test('atree.command.33', $god, 'bar', '!Baz');
test('atree.command.34', $god, undef, 'Grand Bar');

# Test for the child recognition bugs:
test('atree.sortorder.1', $mortal, '&abc grand=$abc:say Grand ABC', 'Set');
test('atree.sortorder.2', $mortal, '&abcd grand=$abcd:say Grand D', 'Set');
test('atree.sortorder.3', $mortal, '&abc`xyz grand=$abc`xyz:say Grand XYZ', []);
test('atree.sortorder.4', $mortal, '&abc parent=$abc:say Parent ABC', 'Set');
test('atree.sortorder.5', $mortal, '&abcd parent=$abcd:say Parent D', 'Set');
test('atree.sortorder.6', $mortal, '&abc`xyz parent=$abc`xyz:say Parent XYZ', []);
test("atree.sortorder.7", $god, 'examine parent', 'ABC \[.*`\]');
test("atree.sortorder.8", $god, '&abc parent', '!Cleared');
test('atree.sortorder.9', $mortal, '@set child=!no_command', 'set');
# Do commands work from parent?
test('atree.sortorder.10', $god, 'abc', '!ABC');
test('atree.sortorder.11', $god, undef, 'Parent ABC');
test('atree.sortorder.12', $god, 'abc`xyz', []);
test('atree.sortorder.13', $god, undef, 'Parent XYZ');
# Child should block parent
test('atree.sortorder.14', $mortal, '&abc child=$abc:say Child!', 'Set');
test('atree.sortorder.15', $god, 'abc', '!ABC');
test('atree.sortorder.16', $god, undef, ['!ABC', 'Child']);
# Child no_command blocks parent branch, too
test('atree.sortorder.17', $mortal, '@set child/abc=no_command', 'set');
test('atree.sortorder.18', $god, 'abc`xyz', '!XYZ');
test('atree.sortorder.19', $god, undef, '!XYZ');
# Parent no_command not masked by child not no_command...
test('atree.sortorder.20', $mortal, '@set child/abc=!no_command', 'set');
test('atree.sortorder.21', $mortal, '@set parent/abc=no_command', 'set');
test('atree.sortorder.22', $god, 'abc`xyz', '!XYZ');
test('atree.sortorder.23', $god, undef, '!XYZ');
# no_command can be on the leaf, too
test('atree.sortorder.24', $mortal, '@set parent/abc=!no_command', 'set');
test('atree.sortorder.25', $mortal, '@set parent/abc`xyz=no_command', 'set');
test('atree.sortorder.26', $god, 'abc`xyz', '!XYZ');
test('atree.sortorder.27', $god, undef, '!XYZ');
# no_inherit trumps no_command
test('atree.sortorder.28', $mortal, '@set parent/abc=no_inherit', 'set');
test('atree.sortorder.29', $mortal, '@set parent/abc`xyz=no_command', 'set');
test('atree.sortorder.30', $god, 'abc`xyz', '!XYZ');
test('atree.sortorder.31', $god, undef, 'Grand XYZ');
test('atree.sortorder.32', $mortal, '@set parent/abc=no_command', 'set');
test('atree.sortorder.33', $mortal, '&abc child', []);
test('atree.sortorder.34', $god, 'abc', '!XYZ');
test('atree.sortorder.35', $god, undef, 'Grand ABC');
# wipe check
test("atree.sortorder.36", $god, '@wipe parent', 'wiped');
test("atree.sortorder.37", $god, '@wipe grand/abc', []);
test("atree.sortorder.38", $god, 'examine grand/**', '!ABC\b');