Agent-TCLI
view release on metacpan or search on metacpan
lib/Agent/TCLI/Testee.pm view on Meta::CPAN
=item * expected - the response desired
=item * name - a name to identify the test in the output
=back
Thus the complete test looks like:
$testee->is_code("status", 200,"status ok");
The ok and not_ok tests check if the response code falls within a range of
values indicating success or failure, repsectively. One does not need to supply
an expected response code value with these tests.
$testee->ok("status","status ok");
There are times when a single request may elicit multiple responses. One can use
a blank request to add tests for additional responses to the prior request. One cannot
test both the code and the body on the same response. One can test the code of
the first response and the body of the second. All additional tests must
immediately follow the original populated request.
lib/Agent/TCLI/Testee.pm view on Meta::CPAN
B<is_*> and B<like_*> tests are greedy by default. That is they use up and expect
a response for every test. Other tests (not yet available), such as
B<response_time> (coming soon) are not greedy and act on the next response
received while still allowing other tests to execute on the same response. It
might be useful to have no greedy versions of B<is_*> and B<like_*> but the
exact syntax to do so has not been worked out yet.
=head3 Response Codes
The response codes that come back in a response are modeled after HTTP Status
codes. For most cases, the ok / is_success and not_ok / is_error codes will
suffice for testing.
There are some existing packages, most notably
Agent::TCLI::Package::Tail, which have commands that may take a while to return
results after the command is accepted. These packages will return a 100
(Continue, or in SIP, Trying) to indicate that the request was received and
acted upon, but the result is not yet determined. One may explictly test for
a 100 response, but if one does not, it is silently ignored.
TCLI response codes will maintain compatibility
lib/Agent/TCLI/Testee.pm view on Meta::CPAN
sub are_successes {
my $self = shift;
# Must sneak an extra param in there so do_test will check codes correctly
$self->last_request(
$self->test_master->build_test($self, 'are_success-code',
$_[0], 1, '', $_[1])
);
return( $self->last_request);
}
=item not_ok / is_error
not_ok ( 'some request', <test_name> );
B<not_ok> makes a request of the testee and passes if the response
has a code indicating failure. B<not_ok> is really just an alias for B<is_error>
and they can be used interchangably. If the test fails, the response body
will be output with the diagnostics.
=cut
sub is_error {
my $self = shift;
# Must sneak an extra param in there so do_test will check codes correctly
$self->last_request(
$self->test_master->build_test($self, 'is_error-code',
$_[0], 1, '', $_[1])
);
return( $self->last_request);
}
*not_ok = \&is_error;
#=item do / is_trying
#
# do ( 'some request', <timeout>, <test_name> );
#
#Some commands, such as setting a tail or watch, will not return response
#with content immediately. These may however return a response with a
#seies 100 code for Trying. B<do> makes a request of the testee and passes
#if a Trying response is received within the timeout in seconds.
#B<do> is really just an alias for B<is_trying>
lib/Agent/TCLI/Transport/Base.pm view on Meta::CPAN
);
# only one should match on id and we get 0 on non id match,
# so we'll just add through the whole loop of authorized peers
# and add up the total.
foreach my $pid ( @{$peers[$$self]} )
{
# user not_authorized returns something when not authorized.
my $check = $pid->not_authorized ( {
id => $id,
protocol => $protocol,
auth => $auth,
} );
$self->Verbose("not_authorized: Checked peer ".$pid->id." got ($check)",3);
if ( !$check )
{
# Set authorized to last matched user
$authorized = $pid;
}
} #end foreach peer
$self->Verbose("authorized: ".$id." auth check got ".
$authorized->id()." \n",1);
lib/Agent/TCLI/User.pm view on Meta::CPAN
sub get_domain {
my $self = shift;
my $id = $id[$$self];
return ( $self->_set_err( { 'method' => 'get_domain',
'rebuke' => 'Domain not found in user id'} )
) unless ( $id =~ /(\w+)@([-.\w]+)/ );
return ($2);
} # End get_domain
=item not_authorized ( { parameters (see usage) } )
Returns 0 if user is authorized, 'Not found' if user is not a match, and a message
if a match, but the protocol and/or auth do not match.
Checks id and optional parameters and returns false if matched. This method
will automatically strip off Jabber resource before matching user. It is
usually used as a passthrough while looping through an array/hash of
users in some other object.
It has optional parameters protocol and auth which must be supplied as
regular expression. The default is to use a regexp of any, which means
that the value must be defined in the user in order to match.
By returning false for authorization, one can check the reason why
a true value was returned for unauthorized, or just ignore it.
Usage:
not_authorized ( { id => value, # user id. Will strip off resource
protocol => qr(jabber), # optional regex for protocol
auth => qr(master|writer), # option regex for auth
} );
=cut
sub not_authorized {
my $self = shift;
# Check if incorrect args are sent and set defaults for optionals
my $args_ref = validate_with ( params => \@_,
spec => {
id => { type => &Params::Validate::SCALAR },
protocol =>
{ optional => 1, default => qr(.*), # default .* means any, simplifies matching if not set
callbacks =>
{ 'is a valid regex' => sub { ref ( $_[0] ) eq 'Regexp' } }
},
auth =>
{ optional => 1, default => qr(.*), # default .* means any, simplifies matching if not set
callbacks =>
{ 'is a valid regex' => sub { ref ( $_[0] ) eq 'Regexp' } }
},
},
# on_fail => sub { $self->_set_err( { 'method' => 'not_authorized',
# 'rebuke' => shift } )
# },
);
# strip off /.* - jabber resource or something like it if there
$args_ref->{'id'} =~ s|/.*||;
# Not using OIO lvalues.
my $protocol = $protocol[$$self];
my $auth = $auth[$$self];
lib/Agent/TCLI/User.pm view on Meta::CPAN
if ( $auth !~ /$args_ref->{'auth'}/ )
{
$txt .= "Inadequate authorization. $auth !~ ".$args_ref->{'auth'}.". \n";
}
}
else
{
$txt = "This is not me.";
}
$self->Verbose("not_authorized: for ".$args_ref->{'id'}." returning '".$txt."'");
return $txt;
} # End not_authorized
1;
#__END__
=back
=head3 INHERITED METHODS
This module is an Object::InsideOut object that inherits from Agent::TCLI::Base. It
inherits methods from both. Please refer to their documentation for more
details.
t/TCLI.Package.Tail.t view on Meta::CPAN
$t->ok( 'log "'.$function.' 3 test pass"');
$t->ok( 'log "'.$function.' 4 test pass"');
$verbose = 0;
$test_master->done(31, "finish testing $function" );
$verbose = 0;
$function = "match_times fail";
$t->ok( 'clear lines');
$t->not_ok('test add like="test fail" name="test fail" match_times=5 max_lines=5', "failed test fail $function");
$t->ok( 'log "52 test "');
$t->ok( 'log "53 test fail"');
$t->ok( 'log "54 test fail"');
$t->ok( 'log "55 test fail"');
$t->ok( 'log "56 test fail"');
$test_master->done(31, "finish testing $function" );
#$verbose = 3;
# Must clear out the lines still in the cache from the prior fail.
$t->ok('clear lines');
t/TCLI.Package.Tail.t view on Meta::CPAN
$t->ok( 'test add like="test pass" name="test pass"', "added test pass $function");
$t->ok( 'log "'.$function.' 1 test 2pass"'); # 1 0
$t->ok( 'log "'.$function.' 2 test pass"'); # 1
$test_master->done(31, "finish testing $function" );
#$verbose = 0;
# fail should not suck up line
$function = "simultaneously with fail in between";
$t->ok( 'clear lines');
$t->ok( 'test add like="test pass" name="test pass"',"passed test pass $function");
$t->not_ok( 'test add like="test fail" name="test fail" max_lines=1 ',"failed test fail $function");
$t->ok('test add like="test 2pass" name="test 2pass" ', "passed test 2pass $function");
$t->ok( 'log "'.$function.' 1 test pass"'); # 1 0 0
$t->ok( 'log "'.$function.' 2 test 2pass"'); # 1 1
$test_master->done(31, "finish testing $function" );
#$t->ok('show active');
#print $test_master->get_responses('',5);
#$t->ok('show test_queue');
#print $t->get_responses('',5);
t/TCLI.Package.Tail.t view on Meta::CPAN
$t->ok( 'log "'.$function.' 13 test"'); # 9
$t->ok( 'log "'.$function.' 14 test 2pass"'); # !
$test_master->done(31, "finish testing $function" );
#$verbose = 0;
$function = "max_lines simultaneously one failing";
# failing one should not change pass2
$t->ok('clear lines');
$t->ok( 'test add like="test pass" name="test pass" match_times=4 max_lines=10', "passed test pass $function");
$t->not_ok( 'test add like="test fail" name="test fail" match_times=5 max_lines=10', "failed test fail $function");
$t->ok( 'test add like="test 2pass" name="test 2pass" match_times=5 max_lines=10 ', "passed test 2pass $function");
# numbers are lines seen by each test in order.
$t->ok( 'log "'.$function.' 1 test 2pass"'); # 1 1 1
$t->ok( 'log "'.$function.' 2 test pass"'); # 2 1 1
$t->ok( 'log "'.$function.' 3 test pass"'); # 3 1 1
$t->ok( 'log "'.$function.' 4 test pass"'); # 4 1 1
$t->ok( 'log "'.$function.' 5 test 2pass"'); # 5 2 2
$t->ok( 'log "'.$function.' 6 test 2pass"'); # 6 3 3
$t->ok( 'log "'.$function.' 7 test fail"'); # 7 4 3
$t->ok( 'log "'.$function.' 8 test fail"'); # 8 5 4
t/TCLI.Package.Tail.t view on Meta::CPAN
$t->ok( 'log "'.$function.' 2 test pass"'); # 2 1 1
$t->ok( 'log "'.$function.' 3 test pass"'); # 3 1 1
$t->ok( 'log "'.$function.' 4 test pass"'); # 4 1 1
$t->ok( 'log "'.$function.' 5 test 2pass"'); # 5 2 2
$t->ok( 'log "'.$function.' 6 test 2pass"'); # 6 3 3
$t->ok( 'log "'.$function.' 7 test fail"'); # 7 4 3
$t->ok( 'log "'.$function.' 8 test fail"'); # 8 5 4
$t->ok( 'log "'.$function.' 9 test"'); # 9 6 5
$t->ok( 'test add like="test pass" name="test pass" match_times=4 max_lines=10 ', "passed test pass $function");
$t->not_ok( 'test add like="test fail" name="test fail" match_times=5 max_lines=10 ', "failed test fail $function");
$t->ok( 'test add like="test 2pass" name="test 2pass" match_times=5 max_lines=10 ', "passed test 2pass $function");
$t->ok( 'log "'.$function.' 10 test pass"'); # ! 7 6
$t->ok( 'log "'.$function.' 11 test fail"'); # 8 6
$t->ok( 'log "'.$function.' 12 test 2pass"'); # 9 7
$t->ok( 'log "'.$function.' 13 test fail"'); # ! 7
$t->ok( 'log "'.$function.' 14 test"'); # 8
$t->ok( 'log "'.$function.' 15 test"'); # 9
$t->ok( 'log "'.$function.' 16 test 2pass"'); # !
$test_master->done(31, "finish testing $function" );
$verbose = 0;
$function = "cache working";
# Must clear out the lines still in the cache from the prior tests
$t->ok('clear lines');
$verbose = 0;
$t->not_ok( 'test add like="test fail" name="test fail" match_times=5 ',"failed test fail $function");
$t->ok( 'log "150 test pass"');
$t->ok( 'log "151 test fail"');
$t->ok( 'log "152 test fail"');
$t->ok( 'log "153 test fail"');
$t->ok( 'log "154 test fail"');
$t->ok( 'log "155 test pass"');
$t->ok( 'log "156 test"');
$t->ok( 'log "157 test"');
$t->ok( 'log "158 test"');
$t->ok( 'log "159 test"');
t/TCLI.Package.Tail.t view on Meta::CPAN
$t->ok( 'log "176 test"');
$t->ok( 'log "177 test"');
$t->ok( 'log "178 test"');
$t->ok( 'log "179 test"');
$test_master->done(31, "finish testing $function" );
# It should not matter that we have extra lines in the queue for this test
# ttl no max_lines
$function = "ttl, max_lines off";
$t->ok( 'test add like="test pass" name="test pass" max_lines=0 ttl=2',"passed test pass $function");
$t->not_ok( 'test add like="test fail" name="test fail" max_lines=0 ttl=2', "failed test fail $function");
$t->ok( 'log "'.$function.' 1 test"');
$t->ok( 'log "'.$function.' 2 test"');
$t->ok( 'log "'.$function.' 3 test"');
$t->ok( 'log "'.$function.' 4 test"');
$t->ok( 'log "'.$function.' 5 test"');
$t->ok( 'log "'.$function.' 6 test"');
$t->ok( 'log "'.$function.' 7 test"');
$t->ok( 'log "'.$function.' 8 test pass"');
$t->ok( 'log "'.$function.' 9 test"');
$t->ok( 'log "'.$function.' 10 test"');
t/TCLI.User.t view on Meta::CPAN
# Test name get methods
is($user1->get_name,'user1','$user1->get_name from init');
is($user2->get_name,'user2','$user2->get_name from id set');
# Test domain get methods
is($user1->get_domain,'example.com','$user1->get_domain from init');
is($user2->get_domain,'example.com','$user2->get_domain from id set');
# user is authorized
#not_authorized ( { id => value, # user id. Will strip off resource
# protocol => qr(jabber), # optional regex for protocol
# auth => qr(master|writer), # option regex for auth
# } );
ok( !$user1->not_authorized(
{ id => 'user1@example.com', # user id. Will strip off resource
auth => qr(read only), # option regex for auth
}), 'user1 not_authorized no protocol' );
ok( !$user1->not_authorized(
{ id => 'user1@example.com', # user id. Will strip off resource
protocol => qr(jabber), # optional regex for protocol
}), 'user1 not_authorized no auth' );
my @auths = (
{ id => 'user1@example.com', # user id. Will strip off resource
protocol => qr(jabber), # optional regex for protocol
auth => qr(read only), # option regex for auth
user1 => '',
user2 => 'This is not me',
msg => 'user1 exact',
},
{ id => 'user1@example.com/resource', # user id. Will strip off resource
t/TCLI.User.t view on Meta::CPAN
protocol => qr(jabber), # optional regex for protocol
auth => qr(master), # option regex for auth
user1 => 'This is not me',
user2 => 'Improper protocol',
msg => 'user1 not user2',
},
);
foreach my $hash ( @auths ) {
like( $user1->not_authorized(
{ id => $hash->{'id'}, # user id. Will strip off resource
protocol => $hash->{'protocol'}, # optional regex for protocol
auth => $hash->{'auth'}, # option regex for auth
}), qr($hash->{'user1'}) , 'user1 not_auth against '.$hash->{'msg'} );
like( $user2->not_authorized(
{ id => $hash->{'id'}, # user id. Will strip off resource
protocol => $hash->{'protocol'}, # optional regex for protocol
auth => $hash->{'auth'}, # option regex for auth
}), qr($hash->{'user2'}), 'user2 not_auth against '.$hash->{'msg'} );
} #end foreach auths
# This crashes. Apparently Params::Validate on fail doesn't capture it.
#ok( $user1->not_authorized(
# { id => 'user1@example.com', # user id. Will strip off resource
# protocol => qr(jabber), # optional regex for protocol
# auth => qr(read only), # option regex for auth
# msg => 'user1',
# }), 'user1 exact but with extra param' );
( run in 0.366 second using v1.01-cache-2.11-cpan-0a987023a57 )