/usr/share/perl5/Mock/Quick/Object.pm is in libmock-quick-perl 1.108-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 | package Mock::Quick::Object;
use strict;
use warnings;
use Mock::Quick::Util;
use Mock::Quick::Object::Control;
use Carp ();
use Scalar::Util ();
our $AUTOLOAD;
class_meth new => sub {
my $class = shift;
my %proto = @_;
return bless \%proto, $class;
};
sub AUTOLOAD {
# Do not shift this, we need it when we use goto &$sub
my ($self) = @_;
my ( $package, $sub ) = ( $AUTOLOAD =~ m/^(.+)::([^:]+)$/ );
$AUTOLOAD = undef;
Carp::croak "Can't locate object method \"$sub\" via package \"$package\""
unless Scalar::Util::blessed( $self );
my $code = $self->can( $sub );
Carp::croak "Can't locate object method \"$sub\" in this instance"
unless $code;
goto &$code;
};
alt_meth can => (
class => sub { no warnings 'misc'; goto &UNIVERSAL::can },
obj => sub {
my ( $self, $name ) = @_;
my $control = Mock::Quick::Object::Control->new( $self );
return if $control->strict && !exists $self->{$name};
my $sub;
{
no warnings 'misc';
$sub = UNIVERSAL::can( $self, $name );
}
$sub ||= sub {
unshift @_ => ( shift( @_ ), $name );
goto &call;
};
inject( Scalar::Util::blessed( $self ), $name, $sub );
return $sub;
},
);
# http://perldoc.perl.org/perlobj.html#Default-UNIVERSAL-methods
# DOES is equivalent to isa by default
sub isa { no warnings 'misc'; goto &UNIVERSAL::isa }
sub DOES { goto &isa }
sub VERSION { no warnings 'misc'; goto &UNIVERSAL::VERSION }
obj_meth DESTROY => sub {
my $self = shift;
Mock::Quick::Object::Control->new( $self )->_clean;
unshift @_ => ( $self, 'DESTROY' );
goto &call;
};
purge_util();
1;
__END__
=head1 NAME
Mock::Quick::Object - Object mocking for Mock::Quick
=head1 DESCRIPTION
Provides object mocking. See L<Mock::Quick> for a better interface.
=head1 SYNOPSIS
use Mock::Quick::Object;
use Mock::Quick::Method;
my $obj = Mock::Quick::Object->new(
foo => 'bar', # define attribute
do_it => qmeth { ... }, # define method
...
);
is( $obj->foo, 'bar' );
$obj->foo( 'baz' );
is( $obj->foo, 'baz' );
$obj->do_it();
# define the new attribute automatically
$obj->bar( 'xxx' );
# define a new method on the fly
$obj->baz( Mock::Quick::Method->new( sub { ... });
# remove an attribute or method
$obj->baz( \$Mock::Quick::Util::CLEAR );
=head1 AUTHORS
Chad Granum L<exodist7@gmail.com>
=head1 COPYRIGHT
Copyright (C) 2011 Chad Granum
Mock-Quick is free software; Standard perl licence.
Mock-Quick is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE. See the license for more details.
|