/usr/share/perl5/Test2/Tools/Mock.pm is in libtest2-suite-perl 0.000102-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 | package Test2::Tools::Mock;
use strict;
use warnings;
use Carp qw/croak/;
use Scalar::Util qw/blessed reftype weaken/;
use Test2::Util qw/try/;
use Test2::Util::Sub qw/gen_accessor gen_reader gen_writer/;
use Test2::Mock();
use base 'Exporter';
our $VERSION = '0.000102';
our @CARP_NOT = (__PACKAGE__, 'Test2::Mock');
our @EXPORT = qw/mock mocked/;
our @EXPORT_OK = qw{
mock_obj mock_class
mock_do mock_build
mock_accessor mock_accessors
mock_getter mock_getters
mock_setter mock_setters
mock_building
};
my %HANDLERS;
my %MOCKS;
my @BUILD;
sub add_handler {
my $class = shift;
my ($for, $code) = @_;
croak "Must specify a package for the mock handler"
unless $for;
croak "Handlers must be code referneces (got: $code)"
unless $code && ref($code) eq 'CODE';
push @{$HANDLERS{$for}} => $code;
}
sub mock_building {
return unless @BUILD;
return $BUILD[-1];
}
sub mocked {
my $proto = shift;
my $class = blessed($proto) || $proto;
# Check if we have any mocks.
my $set = $MOCKS{$class} || return;
# Remove dead mocks (undef due to weaken)
pop @$set while @$set && !defined($set->[-1]);
# Remove the list if it is empty
delete $MOCKS{$class} unless @$set;
# Return the controls (may be empty list)
return @$set;
}
sub _delegate {
my ($args) = @_;
my $do = __PACKAGE__->can('mock_do');
my $obj = __PACKAGE__->can('mock_obj');
my $class = __PACKAGE__->can('mock_class');
my $build = __PACKAGE__->can('mock_build');
return $obj unless @$args;
my ($proto, $arg1) = @$args;
return $obj if ref($proto) && !blessed($proto);
if (blessed($proto)) {
return $class unless $proto->isa('Test2::Mock');
return $build if $arg1 && ref($arg1) && reftype($arg1) eq 'CODE';
}
return $class if $proto =~ m/(?:::|')/;
return $class if $proto =~ m/^_*[A-Z]/;
return $do if Test2::Mock->can($proto);
if (my $sub = __PACKAGE__->can("mock_$proto")) {
shift @$args;
return $sub;
}
return undef;
}
sub mock {
croak "undef is not a valid first argument to mock()"
if @_ && !defined($_[0]);
my $sub = _delegate(\@_);
croak "'$_[0]' does not look like a package name, and is not a valid control method"
unless $sub;
$sub->(@_);
}
sub mock_build {
my ($control, $sub) = @_;
croak "mock_build requires a Test2::Mock object as its first argument"
unless $control && blessed($control) && $control->isa('Test2::Mock');
croak "mock_build requires a coderef as its second argument"
unless $sub && ref($sub) && reftype($sub) eq 'CODE';
push @BUILD => $control;
my ($ok, $err) = &try($sub);
pop @BUILD;
die $err unless $ok;
}
sub mock_do {
my ($meth, @args) = @_;
croak "Not currently building a mock"
unless @BUILD;
my $build = $BUILD[-1];
croak "'$meth' is not a valid action for mock_do()"
if $meth =~ m/^_/ || !$build->can($meth);
$build->$meth(@args);
}
sub mock_obj {
my ($proto) = @_;
if ($proto && ref($proto) && reftype($proto) ne 'CODE') {
shift @_;
}
else {
$proto = {};
}
my $class = _generate_class();
my $control;
if (@_ == 1 && reftype($_[0]) eq 'CODE') {
my $orig = shift @_;
$control = mock_class(
$class,
sub {
my $c = mock_building;
# We want to do these BEFORE anything that the sub may do.
$c->block_load(1);
$c->purge_on_destroy(1);
$c->autoload(1);
$orig->(@_);
},
);
}
else {
$control = mock_class(
$class,
# Do these before anything the user specified.
block_load => 1,
purge_on_destroy => 1,
autoload => 1,
@_,
);
}
my $new = bless($proto, $control->class);
# We need to ensure there is a reference to the control object, and we want
# it to go away with the object.
$new->{'~~MOCK~CONTROL~~'} = $control;
return $new;
}
sub _generate_class {
my $prefix = __PACKAGE__;
for (1 .. 100) {
my $postfix = join '', map { chr(rand(26) + 65) } 1 .. 32;
my $class = $prefix . '::__TEMP__::' . $postfix;
my $file = $class;
$file =~ s{::}{/}g;
$file .= '.pm';
next if $INC{$file};
my $stash = do { no strict 'refs'; \%{"${class}\::"} };
next if keys %$stash;
return $class;
}
croak "Could not generate a unique class name after 100 attempts";
}
sub mock_class {
my $proto = shift;
my $class = blessed($proto) || $proto;
my @args = @_;
my $void = !defined(wantarray);
my $callback = sub {
my ($parent) = reverse mocked($class);
my $control;
if (@args == 1 && ref($args[0]) && reftype($args[0]) eq 'CODE') {
$control = Test2::Mock->new(class => $class);
mock_build($control, @args);
}
else {
$control = Test2::Mock->new(class => $class, @args);
}
if ($parent) {
$control->{parent} = $parent;
weaken($parent->{child} = $control);
}
$MOCKS{$class} ||= [];
push @{$MOCKS{$class}} => $control;
weaken($MOCKS{$class}->[-1]);
return $control;
};
return $callback->() unless $void;
my $level = 0;
my $caller;
while (my @call = caller($level++)) {
next if $call[0] eq __PACKAGE__;
$caller = \@call;
last;
}
my $handled;
for my $handler (@{$HANDLERS{$caller->[0]}}) {
$handled++ if $handler->(
class => $class,
caller => $caller,
builder => $callback,
args => \@args,
);
}
croak "mock_class should not be called in a void context without a registered handler"
unless $handled;
}
sub mock_accessors {
return map {( $_ => gen_accessor($_) )} @_;
}
sub mock_accessor {
my ($field) = @_;
return gen_accessor($field);
}
sub mock_getters {
my ($prefix, @list) = @_;
return map {( "$prefix$_" => gen_reader($_) )} @list;
}
sub mock_getter {
my ($field) = @_;
return gen_reader($field);
}
sub mock_setters {
my ($prefix, @list) = @_;
return map {( "$prefix$_" => gen_writer($_) )} @list;
}
sub mock_setter {
my ($field) = @_;
return gen_writer($field);
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Tools::Mock - Class/Instance mocking for Test2.
=head1 DESCRIPTION
Mocking is often an essential part of testing. This library covers some of the
most common mocking needs. This plugin is heavily influenced by L<Mock::Quick>,
but with an improved API. This plugin is also intended to play well with other
plugins in ways L<Mock::Quick> would be unable to.
=head1 SYNOPSIS
my $mock = mock 'Some::Class' => (
add => [
new_method => sub { ... },
],
override => [
replace_method => sub { ... },
],
);
Some::Class->new_method(); # Calls the newly injected method
Some::Class->replace_method(); # Calls our replacement method.
$mock->override(...) # Override some more
$mock = undef; # Undoes all the mocking, restoring all original methods.
my $simple_mock = mock {} => (
add => [
is_active => sub { ... }
]
);
$simple_mock->is_active(); # Calls our newly mocked method.
=head1 EXPORTS
=head2 DEFAULT
=over 4
=item mock
This is a one-stop shop function that delegates to one of the other methods
depending on how it is used. If you are not comfortable with a function that
has a lot of potential behaviors, you can use one of the other functions
directly.
=item $mock = mocked($object)
=item $mock = mocked($class)
Check if an object or class is mocked. If it is mocked the C<$mock> object
(L<Test2::Mock>) will be returned.
=item $mock = mock $class => ( ... );
=item $mock = mock $instance => ( ... )
=item $mock = mock 'class', $class => ( ... )
These forms delegate to C<mock_class()> to mock a package. The third form is to
be explicit about what type of mocking you want.
=item $obj = mock()
=item $obj = mock { ... }
=item $obj = mock 'obj', ...;
These forms delegate to C<mock_obj()> to create instances of anonymous packages
where methods are vivified into existence as needed.
=item mock $mock => sub { ... }
=item mock $method => ( ... )
These forms go together, the first form will set C<$mock> as the current mock
build, then run the sub. Within the sub you can declare mock specifications
using the second form. The first form delegates to C<mock_build()>.
The second form calls the specified method on the current build. This second
form delegates to C<mock_do()>.
=back
=head2 BY REQUEST
=head3 DEFINING MOCKS
=over 4
=item $obj = mock_obj( ... )
=item $obj = mock_obj { ... } => ( ... )
=item $obj = mock_obj sub { ... }
=item $obj = mock_obj { ... } => sub { ... }
This method lets you quickly generate a blessed object. The object will be an
instance of a randomly generated package name. Methods will vivify as
read/write accessors as needed.
Arguments can be any method available to L<Test2::Mock> followed by an
argument. If the very first argument is a hashref then it will be blessed as
your new object.
If you provide a coderef instead of key/value pairs, the coderef will be run to
build the mock. (See the L</"BUILDING MOCKS"> section).
=item $mock = mock_class $class => ( ... )
=item $mock = mock_class $instance => ( ... )
=item $mock = mock_class ... => sub { ... }
This will create a new instance of L<Test2::Mock> to control the package
specified. If you give it a blessed reference it will use the class of the
instance.
Arguments can be any method available to L<Test2::Mock> followed by an
argument. If the very first argument is a hashref then it will be blessed as
your new object.
If you provide a coderef instead of key/value pairs, the coderef will be run to
build the mock. (See the L</"BUILDING MOCKS"> section).
=back
=head3 BUILDING MOCKS
=over 4
=item mock_build $mock => sub { ... }
Set C<$mock> as the current build, then run the specified code. C<$mock> will
no longer be the current build when the sub is complete.
=item $mock = mock_building()
Get the current building C<$mock> object.
=item mock_do $method => $args
Run the specified method on the currently building object.
=back
=head3 METHOD GENERATORS
=over 4
=item $sub = mock_accessor $field
Generate a read/write accessor for the specified field. This will generate a sub like the following:
$sub = sub {
my $self = shift;
($self->{$field}) = @_ if @_;
return $self->{$field};
};
=item $sub = mock_getter $field
Generate a read only accessor for the specified field. This will generate a sub like the following:
$sub = sub {
my $self = shift;
return $self->{$field};
};
=item $sub = mock_setter $field
Generate a write accessor for the specified field. This will generate a sub like the following:
$sub = sub {
my $self = shift;
($self->{$field}) = @_;
};
=item %pairs = mock_accessors(qw/name1 name2 name3/)
Generates several read/write accessors at once, returns key/value pairs where
the key is the field name, and the value is the coderef.
=item %pairs = mock_getters(qw/name1 name2 name3/)
Generates several read only accessors at once, returns key/value pairs where
the key is the field name, and the value is the coderef.
=item %pairs = mock_setters(qw/name1 name2 name3/)
Generates several write accessors at once, returns key/value pairs where the
key is the field name, and the value is the coderef.
=back
=head1 MOCK CONTROL OBJECTS
my $mock = mock(...);
Mock objects are instances of L<Test2::Mock>. See it for their methods.
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2017 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://dev.perl.org/licenses/>
=cut
|