Agent-TCLI
view release on metacpan or search on metacpan
t/TCLI.Control.t view on Meta::CPAN
#!/usr/bin/env perl
# $Id: TCLI.Control.t 62 2007-05-03 15:55:17Z hacker $
use warnings;
use strict;
use Test::More tests => 402;
# TASK Test suite is not complete. Need more testing for catching errors.
use Getopt::Lucid qw(:all);
sub VERBOSE () { 0 }
my ($opt, $verbose, $poe_td, $poe_te);
eval {$opt = Getopt::Lucid->getopt([
Counter("poe_debug|d"),
Counter("poe_event|e"),
Counter("verbose|v"),
Switch("blib|b"),
])};
if($@) {die "ERROR: $@";}
if ($opt->get_blib)
{
use lib 'blib/lib';
}
$verbose = $opt->get_verbose ? $opt->get_verbose : VERBOSE;
# xmpp username/password to log in with
$poe_td = $opt->get_poe_debug;
$poe_te = $opt->get_poe_event;
sub POE::Kernel::TRACE_DEFAULT () { $poe_td }
sub POE::Kernel::TRACE_EVENTS () { $poe_te }
use Agent::TCLI::Transport::Test;
use Agent::TCLI::Testee;
use POE;
BEGIN {
use_ok('Agent::TCLI::Control');
use_ok('Agent::TCLI::Command');
use_ok('Agent::TCLI::User');
}
sub Init {
my @obj_cmds = (
Agent::TCLI::Command->new(
'name' => 'meganat',
'contexts' => {'ROOT' => 'meganat'},
'help' => 'sets up outbound NAT table from a predefined address block',
'usage' => 'meganat add target=target.example.com',
'topic' => 'attack prep',
'call_style'=> 'session',
'command' => 'tcli-pf',
'handler' => 'establish_context',
),
Agent::TCLI::Command->new(
'name' => 'noreset',
'contexts' => {'ROOT' => 'noreset'},
'help' => 'sets up outbound filters to block TCP RESETS to target',
'usage' => 'noreset add target=target.example.com',
'topic' => 'attack prep',
'call_style'=> 'session',
'command' => 'tcli-pf',
'handler' => 'establish_context',
),
Agent::TCLI::Command->new(
'name' => 'add',
'contexts' => {
'meganat' => 'add',
'noresets' => 'add',
},
'help' => 'adds an address block to a table',
'usage' => 'add target=target.example.com',
'topic' => 'attack prep',
'call_style'=> 'session',
'command' => 'tcli-pf',
'handler' => 'change_table',
),
Agent::TCLI::Command->new(
'name' => 'delete',
'contexts' => {
'meganat' => 'delete',
'noresets' => 'delete',
},
'help' => 'removes an address block from a table',
'usage' => 'delete target=target.example.com',
'topic' => 'attack prep',
'call_style'=> 'session',
'command' => 'tcli-pf',
'handler' => 'change_table',
),
Agent::TCLI::Command->new(
'name' => 'test_all',
'contexts' => {'ROOT' => 'test_all'},
'help' => 'under test_all is one handler for everything',
'usage' => 'test_all anything',
'topic' => 'all',
'call_style'=> 'session',
'command' => 'test_all',
'handler' => 'establish_context',
),
Agent::TCLI::Command->new(
'name' => 'all',
'contexts' => {'test_all' => 'ALL'},
'help' => 'anything in context test_all',
'usage' => 'anything',
'topic' => 'all',
'call_style'=> 'session',
'command' => 'test_all',
'handler' => 'all',
),
Agent::TCLI::Command->new(
'name' => 'tshow',
'contexts' => {
'meganat' => 'tshow',
'noresets' => 'tshow',
'test1' => {
'GROUP' => 'tshow',
'test1.1' => {
'test1.1.1' => 'tshow',
'test1.1.2' => 'tshow',
'test1.1.3' => 'tshow',
},
'test1.2' => {
'GROUP' => 'tshow',
},
'test1.3' => {
'GROUP' => 'tshow',
},
},
},
'help' => 'shows tables',
'usage' => 'show',
'topic' => 'attack prep',
'call_style'=> 'session',
'command' => 'tcli-pf',
'handler' => 'show',
),
Agent::TCLI::Command->new(
'name' => 'test1',
'contexts' => {'ROOT' => 'test1'},
'help' => 'test1 help',
'usage' => 'test1 test1.1 test 1.1.1',
'topic' => 'testing',
'call_style'=> 'session',
'command' => 'tcli-test',
'handler' => 'establish_context',
),
Agent::TCLI::Command->new(
'name' => 'test1.1',
'contexts' => {
'test1' => ['test1.1','test1.2','test1.3',],
},
'help' => 'test1.1 help',
'usage' => 'test1.1 test 1.1.1',
'topic' => 'testing',
'call_style'=> 'session',
'command' => 'tcli-test',
'handler' => 'establish_context',
),
Agent::TCLI::Command->new(
'name' => 'test1.1.1',
'contexts' => {
'test1' => {
'test1.1' => ['test1.1.1','test1.1.2','test1.1.3'],
'test1.2' => ['test1.1.1','test1.1.2','test1.1.3'],
'test1.3' => ['test1.1.1','test1.1.2','test1.1.3'],
},
},
'help' => 'test1.1.1 help',
'usage' => 'test 1.1.1',
'topic' => 'testing',
'call_style'=> 'session',
'command' => 'tcli-test',
'handler' => 'establish_context',
),
);
my @dc = (
{ #echo
name => 'echo',
help => 'Return what was said.',
usage => 'echo <something> or /echo ...',
topic => 'general',
command => 'pre-loaded',
contexts => ['UNIVERSAL'],
call_style => 'state',
handler => 'general'
},
{
name => 'Hi',
help => 'Greetings',
usage => 'Hi',
topic => 'Greetings',
command => 'pre-loaded',
contexts => ['ROOT'],
call_style => 'state',
handler => 'general'
},
{
name => 'Hello',
help => 'Greetings',
usage => 'Hello',
topic => 'Greetings',
command => 'pre-loaded',
contexts => ['ROOT'],
call_style => 'state',
handler => 'general'
},
{
name => 'hello',
help => 'Greetings',
usage => 'hello',
topic => 'Greetings',
command => 'pre-loaded',
contexts => ['ROOT'],
call_style => 'state',
handler => 'general'
},
{
name => 'hi',
help => 'Greetings',
usage => 'hi',
topic => 'Greetings',
command => 'pre-loaded',
contexts => ['ROOT'],
call_style => 'state',
handler => 'general'
},
{
name => 'context',
help => "displays the current context",
usage => 'context or /context',
topic => 'general',
command => 'pre-loaded',
contexts => ['ROOT'],
call_style => 'state',
handler => 'general'
},
{
'name' => 'help',
'help' => 'Display help about available commands',
'usage' => 'help [ command ] or /help',
'topic' => 'general',
'command' => 'pre-loaded',
'contexts' => ['UNIVERSAL'],
'call_style' => 'state',
'handler' => 'help'
},
{
'help' => 'Display general CLI control status',
'usage' => 'status or /status',
'topic' => 'general',
'name' => 'status',
'command' => 'pre-loaded',
'contexts' => ['UNIVERSAL'],
'call_style' => 'state',
'handler' => 'general'
},
{
'name' => 'ROOT',
'help' => "restore root context, use '/command' for a one time switch",
'usage' => '/ ',
'topic' => 'general',
'command' => 'pre-loaded',
'contexts' => ['UNIVERSAL'],
'call_style' => 'state',
'handler' => 'exit',
},
{
name => 'load',
help => 'Load a new control package',
usage => 'load < PACKAGE >',
topic => 'admin',
command => sub {return ("load is currently diabled")}, #\&load,
call_style => 'sub',
},
{
'name' => 'listcmd',
'help' => 'Dump the registered commands in their contexts',
'usage' => 'listcmd (<context>)',
'topic' => 'admin',
'command' => 'pre-loaded',
'contexts' => ['UNIVERSAL'],
'call_style' => 'state',
'handler' => 'listcmd',
},
{
'name' => 'dumpcmd',
'help' => 'Dump the registered command hash information',
'usage' => 'dumpcmd <cmd>',
'topic' => 'admin',
'command' => 'pre-loaded',
'contexts' => ['UNIVERSAL'],
'call_style' => 'state',
'handler' => 'dumpcmd',
},
{
'name' => 'nothing',
'help' => 'Nothing is as it seems',
'usage' => 'nothing',
'topic' => 'general',
'command' => sub {return ("You said nothing, try 'help'")},
'call_style' => 'sub',
},
{
'name' => 'exit',
'help' => "exit the current context, returning to previous context",
'usage' => 'exit or /exit',
'topic' => 'general',
'command' => 'pre-loaded',
'contexts' => ['UNIVERSAL'],
'call_style' => 'state',
'handler' => 'exit',
},
);
return(@obj_cmds);
}
# put in sub so I could fold it in eclipse
my (@obj_cmds) = Init();
use Agent::TCLI::Package::Base;
my $test1 = Agent::TCLI::Control->new(
'context' => 'ROOT',
'id' => 'test_control_1',
'verbose' => \$verbose,
# Overide normal verbose output by using diag instead of print
'do_verbose' => sub { diag( @_ ) },
);
my $test2 = Agent::TCLI::Control->new(
'id' => 'test_control_2',
'verbose' => \$verbose,
'do_verbose' => sub { diag( @_ ) },
);
# Test context methods
is($test1->print_context,'ROOT', '$test1->print_context from init args');
$test1->pop_context();
is($test1->print_context,'ROOT', '$test1->print_context after Popping /');
is($test1->depth_context,0, '$test1->depth_context for /');
ok($test1->push_context('test'),'$test1 push context onto / ');
is($test1->depth_context,1, '$test1->depth_context for test ');
is($test1->print_context,'test', '$test1->print_context test');
$test1->pop_context();
is($test1->print_context,'ROOT', '$test1->print_context after Popping test');
is($test1->depth_context,0, '$test1->depth_context for /');
ok($test2->context(['test']),'set $test2->context( ) ');
is_deeply($test2->context,['test'], '$test2->context accessor from Set');
is($test2->depth_context,1, '$test2->depth_context for (test)');
$test2->push_context('two');
is($test2->print_context,'test two', '$test2->print_context Pushed two');
is($test2->depth_context,2, '$test2->depth_context for (test two)');
$test2->push_context('three');
is($test2->print_context,'test two three', '$test2->context accessor Pushed three');
is($test2->depth_context,3, '$test2->depth_context for (test two three)');
$test2->pop_context();
is($test2->print_context,'test two', '$test2->context accessor Popped three');
is($test2->depth_context,2, '$test2->depth_context for (test two) again');
my (@cmds, @bad_cmds);
foreach my $cmd ( @obj_cmds )
{
ok($test1->RegisterCommand( $cmd ),'Register Cmd '.$cmd->name );
push( @cmds, [$cmd->name, $cmd->contexts, '', ] );
( run in 0.507 second using v1.01-cache-2.11-cpan-0bb4e1dffa6 )