view release on metacpan or  search on metacpan

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

    ## determine a new namespace for our voodoo doll
    my $dollNum = scalar( keys( %dolls ) );
    my $dollClass = "Acme::Voodoo::Doll_$dollNum";

    ## go through our target namespace and copy non subroutines
    ## into our Acme::Voodoo::Doll_X namespace
    while  ( ($k,$v) = each %{ "${targetClass}::" } ) {
	if ( !defined(&{$v}) ) { ${ "${dollClass}::" }{ $k } = $v; }
    }

    ## create an instance of our target class, and stash it away
    my $instance = &{ "${targetClass}::new" }( @args );
    $dolls{ $dollClass } = $instance;

    ## create the appropriate type of reference
    my $ref;
    if ( $instance =~ /HASH/ ) { $ref = {}; }
    elsif ( $instance =~ /ARRAY/ ) { $ref = []; }
    elsif ( $instance =~ /GLOB/ ) { 
	croak "glob objects are currently resistant to our voodoo spells!"; 
    }
    $doll = bless $ref, $dollClass;

    ## make our voodoo doll namespace inherit the AUTLOADER
    ## from the Acme::Voodoo namespace so we can trap method calls
    push( @{ "${dollClass}::ISA" }, 'Acme::Voodoo' );

    return( $doll );

}

=head2 pins()

Pass this function your voodoo doll and you'll get back a list of pins you 
can use on your doll.

    my @pins = $doll->pins();

=cut 

sub pins {
    my $doll = shift;
    my $dollClass = ref( $dolls{ ref($doll) } );
    my @methods = ();
    return( () ) if !$dollClass;

    no strict;
    while ( my($k,$v) = each( %{ "${dollClass}::" } ) ) {
	push( @methods, $k ) if defined &{ $v };
    }

    return( @methods );
}

=head2 zombie()

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 =~ /.*::(.*)$/ );