view release on metacpan or  search on metacpan

lib/Acme/Voodoo.pm  view on Meta::CPAN

A method to turn your object into a zombie. The next method call on the object
will cause your program to go into limbo for an unpredictable amount of time. 
When it wakes up, it will do what you asked it to do, and will feel fine from 
then on, having no memory of what happened. If you know how long you want
your target to go to sleep for, pass the number of seconds in.

=cut 

sub zombie {
    my ( $self, $sleep ) = @_;
    $zombies{ ref($self) } = 1;
    $dreamTime = $sleep if $sleep;
    return(1);
}

=head2 kill()

When you kill your doll the next time someone calls a method on it it will 
cause your program to die a horrible and painful death.

    $doll->kill();
    $doll->method();	    ## arrrrrggggghhhh!! 

=cut

sub kill {
    my $self = shift;
    $deads{ ref($self) } = 1;
    return( 1 );
}

=head1 AUTHOR

Ed Summers, E<lt>ehs@pobox.comE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2002 by Ed Summers

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. Just be sure not to use it for
anything important.

=cut

sub AUTOLOAD { 

    my ($doll,@args) = @_;
    our $AUTOLOAD;

    ## if we're dead, then we're gonna die
    croak( "arrrghgghg, an evil curse has struck me down!\n" )
	if $deads{ ref($doll) };

    ## if we are a zombie, go to sleep for a random amount of time
    ## and then wake up remembering nothing
    if ( $zombies{ ref($doll) } ) {
	print STDERR "I feel as if I'm walking into a strange dream\n";
	sleep( $dreamTime || int( rand(100) ) * 10 );
	$zombies{ ref($doll) } = undef;
    }

    ## strip namespace off of method
    my ($method) = ( $AUTOLOAD =~ /.*::(.*)$/ );

    ## our real object
    my $object = $dolls{ ref($doll) };
    my $class = ref( $object );
    
    no strict;
    return( undef ) if $method eq 'DESTROY';

    ## call the method on the real object, with the right args
    ## note: we will return the return value of our method call
    &{ "${class}::${method}" }( $object, @args );

}

## no more voodoo

1;