1package Mock::Quick::Class; 2use strict; 3use warnings; 4 5use Mock::Quick::Util; 6use Scalar::Util qw/blessed weaken/; 7use Carp qw/croak confess carp/; 8 9our @CARP_NOT = ('Mock::Quick', 'Mock::Quick::Object'); 10our $ANON = 'AAAAAAAAAA'; 11 12sub package { shift->{'-package'} } 13sub inc { shift->{'-inc'} } 14sub is_takeover { shift->{'-takeover'} } 15sub is_implement { shift->{'-implement'}} 16 17sub metrics { 18 my $self = shift; 19 $self->{'-metrics'} ||= {}; 20 return $self->{'-metrics'}; 21} 22 23sub takeover { 24 my $class = shift; 25 my ( $proto, %params ) = @_; 26 my $package = blessed( $proto ) || $proto; 27 28 my $self = bless( { -package => $package, -takeover => 1 }, $class ); 29 30 for my $key ( keys %params ) { 31 croak "param '$key' is not valid in a takeover" 32 if $key =~ m/^-/; 33 $self->override( $key => $params{$key} ); 34 } 35 36 $self->inject_meta(); 37 38 return $self; 39} 40 41sub implement { 42 my $class = shift; 43 my ( $package, %params ) = @_; 44 my $caller = delete $params{'-caller'} || [caller()]; 45 46 my $inc = $package; 47 $inc =~ s|::|/|g; 48 $inc .= '.pm'; 49 50 croak "$package has already been loaded, cannot implement it." 51 if $INC{$inc}; 52 53 $INC{$inc} = $caller->[1]; 54 55 my $self = bless( 56 { -package => $package, -implement => 1, -inc => $inc }, 57 $class 58 ); 59 60 $self->inject_meta(); 61 62 $self->_configure( %params ); 63 64 return $self; 65} 66 67alt_meth new => ( 68 obj => sub { my $self = shift; $self->package->new(@_) }, 69 class => sub { 70 my $class = shift; 71 my %params = @_; 72 73 croak "You cannot combine '-takeover' and '-implement' arguments" 74 if $params{'-takeover'} && $params{'-implement'}; 75 76 return $class->takeover( delete( $params{'-takeover'} ), %params ) 77 if $params{'-takeover'}; 78 79 return $class->implement( delete( $params{'-implement'} ), %params ) 80 if $params{'-implement'}; 81 82 my $package = __PACKAGE__ . "::__ANON__::" . $ANON++; 83 84 my $self = bless( { %params, -package => $package }, $class ); 85 86 $self->inject_meta(); 87 88 $self->_configure( %params ); 89 90 return $self; 91 } 92); 93 94sub inject_meta { 95 my $self = shift; 96 my $weak_self = $self; 97 weaken $weak_self; 98 inject( $self->package, 'MQ_CONTROL', sub { $weak_self } ); 99} 100 101sub _configure { 102 my $self = shift; 103 my %params = @_; 104 my $package = $self->package; 105 my $metrics = $self->metrics; 106 107 for my $key ( keys %params ) { 108 my $value = $params{$key}; 109 110 if ( $key =~ m/^-/ ) { 111 $self->_configure_pair( $key, $value ); 112 } 113 elsif( _is_sub_ref( $value )) { 114 inject( $package, $key, sub { $metrics->{$key}++; $value->(@_) }); 115 } 116 else { 117 inject( $package, $key, sub { $metrics->{$key}++; $value }); 118 } 119 } 120} 121 122sub _configure_pair { 123 my $control = shift; 124 my ( $param, $value ) = @_; 125 my $package = $control->package; 126 my $metrics = $control->metrics; 127 128 if ( $param eq '-subclass' ) { 129 $value = [ $value ] unless ref $value eq 'ARRAY'; 130 no strict 'refs'; 131 push @{"$package\::ISA"} => @$value; 132 } 133 elsif ( $param eq '-attributes' ) { 134 $value = [ $value ] unless ref $value eq 'ARRAY'; 135 for my $attr ( @$value ) { 136 inject( $package, $attr, sub { 137 my $self = shift; 138 139 croak "$attr() called on class '$self' instead of an instance" 140 unless blessed( $self ); 141 142 $metrics->{$attr}++; 143 ( $self->{$attr} ) = @_ if @_; 144 return $self->{$attr}; 145 }); 146 } 147 } 148 elsif ( $param eq '-with_new' ) { 149 inject( $package, 'new', sub { 150 my $class = shift; 151 croak "Expected hash, received reference to hash" 152 if @_ == 1 and ref $_[0] eq 'HASH'; 153 my %proto = @_; 154 $metrics->{new}++; 155 156 croak "new() cannot be called on an instance" 157 if blessed( $class ); 158 159 return bless( \%proto, $class ); 160 }); 161 } 162} 163 164sub _is_sub_ref { 165 my $in = shift; 166 my $type = ref $in; 167 my $class = blessed( $in ); 168 169 return 1 if $type && $type eq 'CODE'; 170 return 1 if $class && $class->isa( 'Mock::Quick::Method' ); 171 return 0; 172} 173 174sub override { 175 my $self = shift; 176 my $package = $self->package; 177 my %pairs = @_; 178 my @originals; 179 my $metrics = $self->metrics; 180 181 for my $name ( keys %pairs ) { 182 my $orig_value = $pairs{$name}; 183 184 carp "Overriding non-existent method '$name'" 185 if $self->is_takeover && !$package->can($name); 186 187 my $real_value = _is_sub_ref( $orig_value ) 188 ? sub { $metrics->{$name}++; return $orig_value->(@_) } 189 : sub { $metrics->{$name}++; return $orig_value }; 190 191 my $original = $self->original( $name ); 192 inject( $package, $name, $real_value ); 193 194 push @originals, $original; 195 } 196 197 return @originals; 198} 199 200sub original { 201 my $self = shift; 202 my ( $name ) = @_; 203 unless ( exists $self->{$name} ) { 204 $self->{$name} = $self->package->can( $name ) || undef; 205 } 206 return $self->{$name}; 207} 208 209sub restore { 210 my $self = shift; 211 212 for my $name ( @_ ) { 213 my $original = $self->original($name); 214 delete $self->metrics->{$name}; 215 216 if ( $original ) { 217 my $sub = _is_sub_ref( $original ) ? $original : sub { $original }; 218 inject( $self->package, $name, $sub ); 219 } 220 else { 221 $self->_clear( $name ); 222 } 223 } 224} 225 226sub _clear { 227 my $self = shift; 228 my ( $name ) = @_; 229 my $package = $self->package; 230 no strict 'refs'; 231 my $ref = \%{"$package\::"}; 232 delete $ref->{ $name }; 233} 234 235sub undefine { 236 my $self = shift; 237 my $package = $self->package; 238 croak "Refusing to undefine a class that was taken over." 239 if $self->is_takeover; 240 no strict 'refs'; 241 undef( *{"$package\::"} ); 242 delete $INC{$self->inc} if $self->is_implement; 243} 244 245sub DESTROY { 246 my $self = shift; 247 return $self->undefine unless $self->is_takeover; 248 249 my $package = $self->package; 250 251 { 252 no strict 'refs'; 253 no warnings 'redefine'; 254 255 my $ref = \%{"$package\::"}; 256 delete $ref->{MQ_CONTROL}; 257 } 258 259 for my $sub ( keys %{$self} ) { 260 next if $sub =~ m/^-/; 261 $self->restore( $sub ); 262 } 263} 264 265purge_util(); 266 2671; 268 269__END__ 270 271=head1 NAME 272 273Mock::Quick::Class - Class mocking for Mock::Quick 274 275=head1 DESCRIPTION 276 277Provides class mocking for L<Mock::Quick> 278 279=head1 SYNOPSIS 280 281=head2 IMPLEMENT A CLASS 282 283This will implement a class at the namespace provided via the -implement 284argument. The class must not already be loaded. Once complete the real class 285will be prevented from loading until you call undefine() on the control object. 286 287 use Mock::Quick::Class; 288 289 my $control = Mock::Quick::Class->new( 290 -implement => 'My::Package', 291 292 # Insert a generic new() method (blessed hash) 293 -with_new => 1, 294 295 # Inheritance 296 -subclass => 'Some::Class', 297 # Can also do 298 -subclass => [ 'Class::A', 'Class::B' ], 299 300 # generic get/set attribute methods. 301 -attributes => [ qw/a b c d/ ], 302 303 # Method that simply returns a value. 304 simple => 'value', 305 306 # Custom method. 307 method => sub { ... }, 308 ); 309 310 my $obj = $control->package->new; 311 # OR 312 my $obj = My::Package->new; 313 314 # Override a method 315 $control->override( foo => sub { ... }); 316 317 # Restore it to the original 318 $control->restore( 'foo' ); 319 320 # Remove the namespace we created, which would allow the real thing to load 321 # in a require or use statement. 322 $control->undefine(); 323 324You can also use the 'implement' method instead of new: 325 326 use Mock::Quick::Class; 327 328 my $control = Mock::Quick::Class->implement( 329 'Some::Package', 330 %args 331 ); 332 333=head2 ANONYMOUS MOCKED CLASS 334 335This is if you just need to generate a class where the package name does not 336matter. This is done when the -takeover and -implement arguments are both 337omitted. 338 339 use Mock::Quick::Class; 340 341 my $control = Mock::Quick::Class->new( 342 # Insert a generic new() method (blessed hash) 343 -with_new => 1, 344 345 # Inheritance 346 -subclass => 'Some::Class', 347 # Can also do 348 -subclass => [ 'Class::A', 'Class::B' ], 349 350 # generic get/set attribute methods. 351 -attributes => [ qw/a b c d/ ], 352 353 # Method that simply returns a value. 354 simple => 'value', 355 356 # Custom method. 357 method => sub { ... }, 358 ); 359 360 my $obj = $control->package->new; 361 362 # Override a method 363 $control->override( foo => sub { ... }); 364 365 # Restore it to the original 366 $control->restore( 'foo' ); 367 368 # Remove the anonymous namespace we created. 369 $control->undefine(); 370 371=head2 TAKING OVER EXISTING/LOADED CLASSES 372 373 use Mock::Quick::Class; 374 375 my $control = Mock::Quick::Class->takeover( 'Some::Package' ); 376 377 # Override a method 378 $control->override( foo => sub { ... }); 379 380 # Restore it to the original 381 $control->restore( 'foo' ); 382 383 # Destroy the control object and completely restore the original class 384 # Some::Package. 385 $control = undef; 386 387You can also do this through new() 388 389 use Mock::Quick::Class; 390 391 my $control = Mock::Quick::Class->new( 392 -takeover => 'Some::Package', 393 %overrides 394 ); 395 396=head1 ACCESSING THE CONTROL OBJECY 397 398While the control object exists, it can be accessed via 399C<YOUR::PACKAGE->MQ_CONTROL()>. It is important to note that this method will 400disappear whenever the control object you track falls out of scope. 401 402Example (taken from Class.t): 403 404 $obj = $CLASS->new( -takeover => 'Baz' ); 405 $obj->override( 'foo', sub { 406 my $class = shift; 407 return "PREFIX: " . $class->MQ_CONTROL->original( 'foo' )->(); 408 }); 409 410 is( Baz->foo, "PREFIX: foo", "Override and accessed original through MQ_CONTROL" ); 411 $obj = undef; 412 413 is( Baz->foo, 'foo', 'original' ); 414 ok( !Baz->can('MQ_CONTROL'), "Removed control" ); 415 416=head1 METHODS 417 418=over 4 419 420=item $package = $obj->package() 421 422Get the name of the package controlled by this object. 423 424=item $bool = $obj->is_takeover() 425 426Check if the control object was created to takeover an existing class. 427 428=item $bool = $obj->is_implement() 429 430Check if the control object was created to implement a class. 431 432=item $data = $obj->metrics() 433 434Returns a hash where keys are method names, and values are the number of times 435the method has been called. When a method is altered or removed the key is 436deleted. 437 438=item $obj->override( name => sub { ... }) 439 440Override a method. 441 442=item $obj->original( $name ); 443 444Get the original method (coderef). Note: The first time this is called it find 445and remembers the value of package->can( $name ). This means that if you modify 446or replace the method without using Mock::Quick before this is called, it will 447have the updated method, not the true original. 448 449The override() method will call this first to ensure the original method is 450cached and available for restore(). Once a value is set it is never replaced or 451cleared. 452 453=item $obj->restore( $name ) 454 455Restore a method (Resets metrics) 456 457=item $obj->undefine() 458 459Undefine the package controlled by the control. 460 461=back 462 463=head1 AUTHORS 464 465=over 4 466 467=item Chad Granum L<exodist7@gmail.com> 468 469=item Glen Hinkle L<glen@empireenterprises.com> 470 471=back 472 473=head1 COPYRIGHT 474 475Copyright (C) 2011 Chad Granum 476 477Mock-Quick is free software; Standard perl licence. 478 479Mock-Quick is distributed in the hope that it will be useful, but WITHOUT ANY 480WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A 481PARTICULAR PURPOSE. See the license for more details. 482