view release on metacpan or  search on metacpan

t/TCLI.Control.Interactive.t  view on Meta::CPAN

#!/usr/bin/env perl
# $Id: TCLI.Control.Interactive.t 62 2007-05-03 15:55:17Z hacker $

use warnings;
use strict;
use Test::More tests => 49;
#use Test::More qw(no_plan);


# 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',

t/TCLI.Control.Interactive.t  view on Meta::CPAN

	        		},
	        	},
    	    'help' 		=> 'test1.1.y is a test command',
        	'usage'		=> 'test 1.1.1',
        	'topic'		=> 'testing',
        	'call_style'=> 'session',
        	'command'	=> 'base',
	        'handler'	=> 'establish_context',
			'verbose'		=> \$verbose,
			'do_verbose'	=> sub { diag( @_ ) },
		),
		Agent::TCLI::Command->new(
	        'name'		=> 'test1.2.1',
	        'contexts'	=> {
	        	'test1'	=> {
		        	'test1.1' => 'test1.2.1',
		        	'test1.2' => 'test1.2.1',
	    	    	'test1.3' => 'test1.2.1',
	        		},
	        	},
    	    'help' 		=> 'test1.2.1 is a test command',
        	'usage'		=> 'test 1.2.1',
        	'topic'		=> 'testing',
        	'call_style'=> 'session',
        	'command'	=> 'base',
	        'handler'	=> 'establish_context',
			'verbose'		=> \$verbose,
			'do_verbose'	=> sub { diag( @_ ) },
		),

);

my $test_master = Agent::TCLI::Transport::Test->new({
    'control_options'	=> {
	     'packages' 	=> [ $test_base, ],
    },

	'verbose'		=> \$verbose,
	'do_verbose'	=> sub { diag( @_ ) },
	});

my $t = Agent::TCLI::Testee->new(
	'test_master'	=> $test_master,
	'addressee'		=> 'self',
);

# From here on out, verbose is either on or off because these are queued events.
#$verbose = 3;
is($test_base->name,'base', '$test_base->name ');

# are we in the right place?
$t->like_body('show name',qr(base));

#$verbose = 0;
# general tests
$t->ok('status');
$t->ok('hi');
$t->like_body('echo this',qr(this) );
$t->like_body('echo that is not this',qr(that is not this) );
$t->is_body( 'context','Context: ROOT','verify root context');
$t->ok('debug_request');
$t->ok('exit');
$t->ok('root');
$t->ok('Verbose');

#help tests
$t->is_code( 'help',200, 'help');
$t->is_code( '/',200, 'root context');
$t->is_body( 'context','Context: ROOT','verify root context');
$t->is_code( 'test1',200, 'test1 context');
$t->is_body( 'context','Context: test1','verify test1 context');
$t->like_body( 'help',qr(test1.1.*?test1.2.*?test1.3)s, "help");
$t->like_body( 'help test1.1',qr(test1.x is a test command)s, "help test1.1");
$t->is_code( 'test1.1',200, 'test1.1 context');
$t->is_body( 'context','Context: test1 test1.1','verify test1.1 context');
$t->like_body( 'help',qr(show.*?test1.1.1.*?test1.2.1)s, "help");
$t->like_body( 'help',qr(global.*?exit.*?help)s, "help with globals");
$t->like_body( 'help globals',qr(global.*?exit.*?help)s, "help globals in context");
$t->like_body( 'exit',qr(Context now: test1),"exit ok" );
$t->is_body( 'exit','Context now: ROOT', 'exit Context now: root');
$t->like_body( 'help globals',qr(global.*?exit.*?help)s, "help globals at root");

#manual tests

#$verbose = 2;
#
$t->is_code( 'manual manual',200, 'manual');
$t->is_code( '/',200, 'root context');
$t->is_body( 'context','Context: ROOT','verify root context');
$t->is_code( 'test1',200, 'test1 context');
$t->is_body( 'context','Context: test1','verify test1 context');
$t->like_body( 'manual test1.1',qr(testing TLCI)s, "manual test1.1");
$t->is_code( 'test1.1',200, 'test1.1 context');
$t->is_body( 'context','Context: test1 test1.1','verify test1.1 context');
$t->like_body( 'manual test1.1.1',qr(help for command)s, "manual gives help when not defined");
$t->like_body( 'manual manual',qr(manual command provides detailed)s, "manual for global in context");
$t->like_body( 'exit',qr(Context now: test1),"exit ok" );
$t->is_body( 'exit','Context now: ROOT', 'exit Context now: root');
$test_master->done;

# Control tests
$t->ok('Control show user');
is($t->get_param('id','',1),'test-master@localhost', 'test user check');
$t->ok('Control show auth');
is($t->get_param('auth','',1),'master', 'test auth check');
$t->ok('Control show local_address');
is($t->get_param('address','',1),'127.0.0.1', 'test local_address check');


$test_master->run;