File Coverage

blib/lib/Carp/Growl.pm

Criterion	Covered	Total	%
statement	135	137	98.5
branch	35	42	83.3
condition	3	3	100.0
subroutine	25	25	100.0
pod			n/a
total	198	207	95.6

package Carp::Growl;

use warnings;
use strict;
use Carp;

use version; our $VERSION = '0.0.10';

use Growl::Any;

my $build_warnmess;

my $DEFAULT_FUNCS = +{};

BEGIN {
    $build_warnmess = sub {
        my ( $func, @args ) = @_;
        my ( $pkg, $file, $line ) = caller(1);
        my $self;
        unless (@args) {
            unshift @args,
                ( $func eq 'warn' ? "Warning: something's wrong" : "Died" );
        }
        $self = join( $", @args );
        unless ( $self =~ s/\n \z//msx ) {
            $self .= " at $file line $line.";
        }
        $self;
    };
}

if ( $] < 5.016000 ) {
    @{$DEFAULT_FUNCS}{qw/warn die/} = (
        sub { CORE::warn( $build_warnmess->( 'warn', @_ ), $/ ); },
        sub { CORE::die( $build_warnmess->( 'die', @_ ), $/ ); },
    );
}
else {
    $DEFAULT_FUNCS->{warn} = \&CORE::warn;
    $DEFAULT_FUNCS->{die}  = \&CORE::die;
}

my $g = Growl::Any->new( appname => __PACKAGE__, events => [qw/warn die/] );

our @CARP_NOT;

my $KEEP     = {};
my $imported = 0;

my $AVAILABLE_IMPORT_ARGS = [qw/global/];

my $validate_args = sub {
    my %bads;
    for my $good (@$AVAILABLE_IMPORT_ARGS) {
        $bads{$_}++ for grep { $_ ne $good } @_;
    }
    keys %bads;
};
for my $f (qw/carp croak/) {
    no strict 'refs';
    $DEFAULT_FUNCS->{$f} = *{ 'Carp::' . $f }{CODE};
}
my $BUILD_FUNC_ARGS = +{
    warn  => { event => 'warn', title => 'WARNING', },
    die   => { event => 'die',  title => 'FATAL', },
    carp  => { event => 'warn', title => 'WARNING', },
    croak => { event => 'die',  title => 'FATAL', },
};

sub _build_func {
    my $func = shift;
    if ( ( $func eq 'warn' || $func eq 'die' ) ) {
        return sub {
            $g->notify(
                $BUILD_FUNC_ARGS->{$func}->{event},    # event
                $BUILD_FUNC_ARGS->{$func}->{title},    # title
                $build_warnmess->( $func, @_ ),        # message
                undef,                                 # icon
                )
                if defined $^S;
            goto &{ $DEFAULT_FUNCS->{$func} };
        };
    }
    else {
        return sub {
            no strict 'refs';
#            if ( caller eq 'main' ) {
#                local *{'main::CARP_NOT'};
#                push @{ *{'main::CARP_NOT'} }, __PACKAGE__;
#            }
            my $msg = Carp::shortmess(@_);
            chomp $msg;
            $g->notify(
                $BUILD_FUNC_ARGS->{$func}->{event},    # event
                $BUILD_FUNC_ARGS->{$func}->{title},    # title
                $msg,                                  # message
                undef,                                 # icon
                )
                if defined $^S;
            goto &{ $DEFAULT_FUNCS->{$func} };
        };
    }
}

##~~~~~  IMPORT  ~~~~~##

sub import {
    my $self = shift;
    my @args = @_;
    if (@args) {
        my @bads = $validate_args->(@args);
        CORE::die 'Illegal args: "'
            . join( '", "', @bads )
            . '" for import()'
            if @bads;
        $imported = 2;
        goto &_global_import if grep { $_ eq 'global' } @args;
    }
    else {
        $imported = 1;
    }
    goto &_local_import;
}

sub _local_import {
    my $args = @_ ? \@_ : [ keys %$BUILD_FUNC_ARGS ];
    my $pkg = caller();
    no strict 'refs';
    for my $func ( keys %$BUILD_FUNC_ARGS ) {
        $KEEP->{$pkg}->{$func} = \&{ *{ $pkg . '::' . $func } }
            if defined *{ $pkg . '::' . $func }{CODE};
    }
    for my $func (@$args) {
        no warnings 'redefine';
        *{ $pkg . '::' . $func } = _build_func($func);
    }
    push @CARP_NOT, $pkg if $pkg ne 'main';
}

sub _global_import {
    no strict 'refs';
    no warnings 'redefine';
    my $pkg = caller;
    for my $func (qw/warn die/) {
        $KEEP->{'CORE::GLOBAL'}->{$func} = \&{ *{ 'CORE::GLOBAL::' . $func } }
            if defined *{ 'CORE::GLOBAL::' . $func }{CODE};
        *{ 'CORE::GLOBAL::' . $func } = _build_func($func);
        $KEEP->{$pkg}->{$func} = \&{ *{ $pkg . '::' . $func } }
            if defined *{ $pkg . '::' . $func }{CODE};
        undef &{ *{ $pkg . '::' . $func } }
            if defined *{ $pkg . '::' . $func }{CODE};
    }
    push @Carp::CARP_NOT, __PACKAGE__;
    @_ = qw/carp croak/;
    goto &_local_import;
}

##~~~~~  UNIMPORT  ~~~~~##

sub unimport {
    my $self = shift;
    my @args = @_;
    CORE::die 'Illegal args: "' . join( '", "', @args ) . '" for unimport()'
        if @args;
    $imported = 0;
    goto &_global_unimport;
}

sub _local_unimport {
    my $args = @_ ? \@_ : [ keys %$BUILD_FUNC_ARGS ];
    my ($pkg) = caller();
    no strict 'refs';
    no warnings 'redefine';
    for my $func (@$args) {
        if ( $KEEP->{$pkg}->{$func} ) {
            *{ $pkg . '::' . $func } = $KEEP->{$pkg}->{$func};
        }
        else {
            undef &{ *{ $pkg . '::' . $func } }
                if defined *{ $pkg . '::' . $func }{CODE};
        }
        @{ *{ $pkg . '::CARP_NOT' } }
            = grep { $_ ne __PACKAGE__ } @{ *{ $pkg . '::CARP_NOT' } };
    }
}

sub _global_unimport {
    no strict 'refs';
    no warnings 'redefine';
    for my $func (qw/warn die/) {
        if ( $KEEP->{'CORE::GLOBAL'}->{$func} ) {
            *{ 'CORE::GLOBAL::' . $func } = $KEEP->{'CORE::GLOBAL'}->{$func};
        }
        elsif ( defined *{ 'CORE::GLOBAL::' . $func }{CODE} ) {
            undef &{ *{ 'CORE::GLOBAL::' . $func } };
        }
    }
#    @_ = qw/carp croak/;
    goto &_local_unimport;
}

1;    # Magic true value required at end of module
__END__