File Coverage

blib/lib/Package/Watchdog.pm

Criterion	Covered	Total	%
statement	42	48	87.5
branch	3	4	75.0
condition	12	16	75.0
subroutine	10	12	83.3
pod	6	6	100.0
total	73	86	84.8

package Package::Watchdog;
use strict;
use warnings;
use Carp;
use Package::Watchdog::Tracker::Watch;
use Package::Watchdog::Util;

#{{{ POD

=pod

=head1 NAME

Package::Watchdog - Forbid subs in one package from accessing subs in another package, directly or otherwise.

=head1 DESCRIPTION

A watchdog object will 'watch' several packages and subs in their namespaces.
The watchdog has a list of packages and their subs that should be considered
off-limits to the packages being watched. If their is a violation, ie a watched
package sub accesses a forbidden package sub, the watchdog will react. A
watchdog can react by dying, issuing a warning, or running a custom subroutine.

=head1 SYNOPSYS

First we set some example packages:

    {
        # This packages subs will be forbidden
        package My::Package;
        use strict;
        use warnings;
        sub a { 'a' };
        sub b { 'b' };
        sub c { 'c' };

        # The next packages will be watches for violations
        # Note, every one calls a sub in the forbidden package

        package My::WatchA;
        use strict;
        use warnings;
        sub a { My::Package::a() };
        sub b { My::Package::a() };
        sub c { My::Package::a() };
        # ignore for now.
        sub d { My::Package::d() };

        package My::WatchB;
        use strict;
        use warnings;
        sub a { My::Package::a() };
        sub b { My::Package::a() };
        sub c { My::Package::a() };
    }

Now we set up the watchdog:

    $wd = Package::Watchdog->new()
        # All subs in My::WatchA are included in the watch since none are specified
        ->watch( package => 'My::WatchA', name => 'watch a' )
        # Only sub a() in My::WatchB will be included in the watch
        ->watch( package => 'My::WatchB', subs => [ 'a' ], name => 'watch b')
        # A second watcher will be placed on My::WatchA sub a()
        ->watch( package => 'My::WatchA', subs => [ 'a' ], name => 'watch c')
        # All subs will be forbidden if none are listed.
        ->forbid( 'My::Package' );

The subs in My::Package are only forbidden to My::WatchA and My::WatchB, when
called outside those packages My::Package susb still work normally.

The following will all die after a warning:

    My::WatchA::a();
    My::WatchA::b();
    My::WatchA::c();

The following still work:

    My::Package::a();
    My::Package::b();
    My::Package::c();

You can make the watchdog bark, but not bite. If you create the watchdog with
'warn' as a parameter then violations will generate warnings, but will not die.

    my $wd = Package::Watchdog->new( 'warn' );

You can also create a custom reaction to violations.  Please see the custom
reaction section for more information. The original sub will be run after the
custom reaction unless the custom reaction dies.

    # Custom reaction
    my $wd = Package::Watchdog->new( sub { ... } );

You can also provide different reactions for each watch:

    $wd = Package::Watchdog->new()
        ->watch( package => 'My::WatchA', react => 'warn' )
        ->watch( package => 'My::WatchB', react => 'die' )
        ->watch( package => 'My::WatchC', react => sub { ... } );

The watchdog can be killed by calling the kill() method. Alternately it can fall out of scope and be destroyed. The following are all ways to kill the watchdog:

    $wd->kill();
    $wd = undef; #When no other references to the watchdog exist.


    {
        my $wd2 = Package::Watchdog->new();
        # $wd2 is in effect
    }
    # $wd2 is dead.

=head1 CUSTOM REACTIONS

Custom reactions are anonymous subs.

    my $react = sub {
        my %params = @_;
        ... do stuff ...
    };

The custom react sub will be passed the following:

    %params = (
        watch => Package::Watchdog::Tracker::Watch, # The watch that was triggered
        watched => Package::Watchdog::Sub::Watched, # The class that manages the watched sub that was called.
        watched_params => [ Params with which the watched sub was called ],
        forbidden => Package::Watchdog::Sub::Forbidden, # The class that manages the forbidden sub that was called.
        forbidden_params => [ Params with which the forbidden sub was called ],
    );

It is safe to die within your custom reaction. The forbidden sub will run normally unless the custom reaction dies.

=head1 NOTES AND CAVEATS

=over 4

=item Inherited subs

When Package::Watchdog obtains a list of all subs in a package, inherited subs
are not included.

=back

=head1 ACCESSORS

The following accessors methods are automatically generated using
Package::Watchdog::Util::build_accessors(). These are listed purely for
documentation purposes. They are not for use by the user.

=over 4

=item react()

=item watches()

=item forbids()

=item stack()

=back

=head1 METHODS

Unless otherwise specified methods all return the watchdog object and are chainable.

=over 4

=cut

#}}}

our $VERSION = 0.09;

my @ACCESSORS = qw/react watches forbids stack/;
build_accessors( @ACCESSORS );

=item new( $reaction )

Create a new watchdog object.

$reaction must be one of 'die', 'warn', or a coderef (sub { ... })

=cut

sub new {
    my $class = shift;
    my ( $react ) = @_;

    die( "React must be one of 'die', 'warn', or a coderef." )
        if $react && $react ne 'die'
                  && $react ne 'warn'
                  && ( ref $react && ref $react ne 'CODE' );

    my $self = bless(
        {
            react => $react || 'die',
            watches => [],
            forbids => [],
            stack => [],
        },
        $class
    );

    return $self;
}

=item watch( package => $package, subs => [ ... ], react => $react, name => $name )

Start watching the specified subs in the specified package. If subs is omited
or contains '*' then all package subs will be watched.

=cut

sub watch {
    my $self = shift;
    my $watch = Package::Watchdog::Tracker::Watch->new(
        react => $self->react,
        @_,
        stack => $self->stack,
    );
    push @{ $self->watches } => $watch;
    return $self;
}

=item forbid( $package, $subs )

Forbid the specified subs in the specified package. The second argument should
be an arrayref.

=cut

sub forbid {
    my $self = shift;
    my ( $package, $subs ) = @_;
    my $forbid = Package::Watchdog::Tracker::Forbid->new(
        package => $package,
        stack   => $self->stack,
        subs    => $subs || undef,
    );
    push @{ $self->forbids } => $forbid;
    return $self;
}

=item unwatch()

*Unimplemented.*

=cut

sub unwatch {
    my $self = shift;
    die( "Not yet implemented." );
    return $self; #I know pointless atm.
}

=item unforbid()

*Unimplemented.*

=cut

sub unforbid {
    my $self = shift;
    die( "Not yet implemented." );
    return $self; #I know pointless atm.
}

=item kill()

Will make the watchdog inefective, removes all watches and forbids.

=cut

sub kill {
    my $self = shift;

    my %instances = %Package::Watchdog::Sub::INSTANCES;
    for my $class ( keys %instances ) {
        for my $package ( keys %{ $instances{$class}}) {
            for my $sub( keys %{ $instances{$class}{$package}}) {
                my $item = $instances{$class}{$package}{$sub};
                $item->restore() if $item;
            }
        }
    }

    return $self;
}

sub DESTROY {
    shift->kill();
}

1;

__END__