File Coverage

blib/lib/Log/Scrubber.pm

Criterion	Covered	Total	%
statement	212	234	90.6
branch	87	104	83.6
condition	21	30	70.0
subroutine	36	39	92.3
pod	13	13	100.0
total	369	420	87.8

package Log::Scrubber;

# See the bottom of this file for the POD documentation.
# Search for the string '=head'.

require 5.8.8;
use strict;
use warnings;
use Scalar::Util qw{refaddr};
use Carp;
use Clone;
no warnings "redefine"; # We make this a few times
use Exporter;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $SCRUBBER);

@ISA = qw(Exporter);
%EXPORT_TAGS = (
    Carp    => [ qw(scrubber_init) ],
    Syslog  => [ qw(scrubber_init) ],
    all     => [ qw($SCRUBBER scrubber_init scrubber scrubber_enabled
                scrubber_add_scrubber scrubber_remove_scrubber
                scrubber_add_signal scrubber_remove_signal
                scrubber_add_method scrubber_remove_method
                scrubber_add_package scrubber_remove_package
                ) ],
    );

push @{$EXPORT_TAGS{all}}, @{$EXPORT_TAGS{$_}}
for grep { $_ ne 'all' } keys %EXPORT_TAGS;

@EXPORT_OK = @{$EXPORT_TAGS{all}};
@EXPORT = qw(scrubber_init);

$VERSION = '0.17';

###----------------------------------------------------------------###

my $_SDATA = { # will be initialized in import below
    'enabled' => 0,
    'SIG' => {},
    'METHOD' => {},
    };

tie $SCRUBBER, __PACKAGE__;

sub TIESCALAR {
    return bless [], __PACKAGE__;
}

sub FETCH {
    my ($self) = @_;
    $_SDATA;
}

sub STORE {
    my ($self, $val) = @_;
    #print ">>>>Calling STORE with (".(defined($val) ? $val : 'undef').")\n";
    if (! defined $val) {
        $_SDATA = _sdata_copy();
    } elsif (ref($val) eq 'HASH') {
        scrubber_stop();
        $_SDATA = $val;
        scrubber_start() if $_SDATA->{'enabled'};
    } elsif ($val) {
        scrubber_start();
    } else {
        scrubber_stop();
    }
}

###----------------------------------------------------------------###

sub _sdata_copy { # make a non-reference copy
    my ($old_sdata) = @_;
    if ( ! defined $old_sdata ) { $old_sdata = $_SDATA; } # if they didn't specify one, use the current one
    my $new_SDATA = Clone::clone($old_sdata);
    $new_SDATA->{'parent'} = $old_sdata;
    return $new_SDATA;
}

###----------------------------------------------------------------###

sub import {
    my $change;
    for my $i (reverse 1 .. $#_) {
        if ($_[$i] eq ':Carp') {
            scrubber_add_method('croak');
            scrubber_add_method('confess');
            scrubber_add_method('carp');
            scrubber_add_method('cluck');
        } elsif ($_[$i] eq ':Syslog') {
            scrubber_add_method('main::syslog');
        } elsif ($_[$i] =~ /^\+/) {
            scrubber_add_method(substr($_[$i],1,999));
            splice @_, $i, 1, ();
        } elsif ($_[$i] =~ /^(dis|en)able$/) {
            my $val = $1 eq 'dis' ? 0 : 1;
            splice @_, $i, 1, ();
            die 'Cannot both enable and disable $SCRUBBER during import' if defined $change && $change != $val;
            $change = $val;
        }
    }

    scrubber_add_signal('WARN');
    scrubber_add_signal('DIE');
    scrubber_add_method('warnings::warn');
    scrubber_add_method('warnings::warnif');
    if ((! defined $change) || $change) {
        scrubber_start();
    } else {
        scrubber_stop();
    }

    __PACKAGE__->export_to_level(1, @_);
}

###----------------------------------------------------------------###

sub scrubber_enabled { $_SDATA->{'enabled'} ? 1 : 0 }

sub scrubber_start {
    $_SDATA->{'enabled'} = 1;
    _scrubber_enable_signal( keys %{$_SDATA->{'SIG'}} );
    _scrubber_enable_method( keys %{$_SDATA->{'METHOD'}} );
}

sub scrubber_stop  {
    $_SDATA->{'enabled'} = 0;
    _scrubber_disable_signal( keys %{$_SDATA->{'SIG'}} );
    _scrubber_disable_method( keys %{$_SDATA->{'METHOD'}} );
}

###----------------------------------------------------------------###
# This is the core of our protection. Replace
# the data by the value provided

sub _scrubber {
    my $msg = $_[0];

    my @stack = ($msg);
    my @stack_done = ();
    my @data = ();
    my @hashes = ();

    while ( my $sub_msg = pop @stack ) {
        push @stack_done, "$sub_msg";
        if ( ref $sub_msg eq 'ARRAY' ) {
            foreach my $v ( @{$sub_msg} ) {
                if (ref $v) {
                    my $found = 0;
                    foreach (@stack_done) { if ("$v" eq $_) { $found = 1; last; } }
                    push @stack, $v unless $found;
                } else {
                    push @data, \$v;
                }
            }
        } elsif ( ref $sub_msg eq 'HASH' ) {
            push @hashes, $sub_msg;
            foreach my $k ( keys %{$sub_msg} ) {
                if (ref $sub_msg->{$k}) {
                    my $found = 0;
                    foreach (@stack_done) { if ("$sub_msg->{$k}" eq $_) { $found = 1; last; } }
                    push @stack, $sub_msg->{$k} unless $found;
                } else {
                    push @data, \$sub_msg->{$k};
                }
            }
        } elsif (ref $sub_msg) {
            # TODO: currently only ARRAY, HASH and SCALAR are supported
        } else {
            push @data, \$msg;
        }
    }

    foreach my $sub_msg ( @data ) {
        next if ! defined $$sub_msg;
        foreach ( keys %{$_SDATA->{'scrub_data'}}) {
            ref $_SDATA->{'scrub_data'}{$_} eq 'CODE' ? $$sub_msg = $_SDATA->{'scrub_data'}{$_}->($_,$$sub_msg) : $$sub_msg =~ s/$_/$_SDATA->{'scrub_data'}{$_}/g;
        }
    }

    foreach my $hash ( @hashes ) {
        foreach my $k ( keys %$hash ) {
            my $tmp_val = $hash->{$k};
            my $tmp_key = $k;
            foreach ( keys %{$_SDATA->{'scrub_data'}}) {
                ref $_SDATA->{'scrub_data'}{$_} eq 'CODE' ? $tmp_key = $_SDATA->{'scrub_data'}{$_}->($_,$tmp_key) : $tmp_key =~ s/$_/$_SDATA->{'scrub_data'}{$_}/g;
            }
            delete $hash->{$k};
            $hash->{$tmp_key} = $tmp_val;
        }
    }

    return $msg;
}

sub scrubber {
    my $copy = Clone::clone(\@_);
    if ($#$copy == 0) { return _scrubber $$copy[0]; }
    return map { _scrubber $_ } @$copy;
}

###----------------------------------------------------------------###
# Add/Remove text values that will be scrubbed

sub scrubber_remove_scrubber {
    my $x = $_[0];
    if (defined $x) {
        foreach ( keys %$x ) {
            delete $_SDATA->{'scrub_data'}{$_} if $_SDATA->{'scrub_data'}{$_} = $x->{$_};
        }
    }
}

sub scrubber_add_scrubber {
    my $x = $_[0];
    if (defined $x) {
        foreach ( keys %$x ) {
            next if ! defined $_ || $_ eq ''; # scrubbing nothing is VERY bad, ignore empty scrubbers
            $_SDATA->{'scrub_data'}{$_} = $x->{$_};
        }
    }
}

###----------------------------------------------------------------###
# Add/Remove signals (ie DIE and WARN) to the scrubber

sub _scrubber_disable_signal {
    foreach ( @_ ) {
        if (defined $_SDATA->{'SIG'}{$_}{'scrubber'} && defined $SIG{$_} && $SIG{$_} eq $_SDATA->{'SIG'}{$_}{'scrubber'}) {
            $SIG{$_} = $_SDATA->{'SIG'}{$_}{'old'};
            $_SDATA->{'SIG'}{$_}{'old'} = undef;
            $_SDATA->{'SIG'}{$_}{'scrubber'} = undef;
        } elsif ( defined $_SDATA->{'SIG'}{$_}{'old'} ) {
            carp 'Log::Scrubber cannot disable the '.$_.' signal, it has been overridden somewhere else';
        }
    }
}

sub scrubber_remove_signal {
    foreach ( @_ ) {
        _scrubber_disable_signal($_);
        delete $_SDATA->{'SIG'}{$_};
    }
}

sub _signal {
    my $sig_name = shift;
    @_ = scrubber @_;
    if (defined $_SDATA->{'SIG'}{$sig_name}{'old'} && $_SDATA->{'SIG'}{$sig_name}{'old'} ne '') {
        my $code_str1 = refaddr $_SDATA->{'SIG'}{$sig_name}{'old'};
        if (!$_SDATA->{'SIG_USED'}->{$sig_name}->{$code_str1}) {
            local $_SDATA->{'SIG_USED'}->{$sig_name}->{$code_str1} = 1;
            return $_SDATA->{'SIG'}{$sig_name}{'old'}->(@_);
        }
        CORE::warn("Deep recursion detected in Log::Scrubber\n");
    }
    CORE::warn(@_) if $sig_name eq '__WARN__';
    CORE::die(@_) if $sig_name eq '__DIE__';
}

sub _die_signal { _signal('__DIE__',@_); };
sub _warn_signal { _signal('__WARN__',@_); };

sub _scrubber_enable_signal {
    return if ! $_SDATA->{'enabled'};
    foreach ( @_ ) {
        my $sig_name = $_;
        next if defined $SIG{$sig_name} && defined $_SDATA->{'SIG'}{$sig_name}{'scrubber'} && $SIG{$sig_name} eq $_SDATA->{'SIG'}{$sig_name}{'scrubber'};

        $_SDATA->{'SIG'}{$sig_name}{'old'} = $SIG{$sig_name};
        $_SDATA->{'SIG'}{$sig_name}{'scrubber'} = \&_warn_signal if $sig_name eq '__WARN__';
        $_SDATA->{'SIG'}{$sig_name}{'scrubber'} = \&_die_signal if $sig_name eq '__DIE__';

        $SIG{$sig_name} = $_SDATA->{'SIG'}{$sig_name}{'scrubber'};
    }
}

sub scrubber_add_signal {
    foreach ( @_ ) {
        my $sig_name = '';
        if ($_ eq 'WARN') { $sig_name = '__WARN__'; }
        if ($_ eq '__WARN__') { $sig_name = '__WARN__'; }
        if ($_ eq 'DIE') { $sig_name = '__DIE__'; }
        if ($_ eq '__DIE__') { $sig_name = '__DIE__'; }

        next if defined $_SDATA->{'SIG'}{$sig_name};
        $_SDATA->{'SIG'}{$sig_name} = {};
        _scrubber_enable_signal($sig_name);
    }
}

###----------------------------------------------------------------###
# Add/Remove methods to the scrubber

sub _scrubber_disable_method {
    no strict 'refs'; ## no critic
    foreach my $fullname ( @_ ) {
        my $current_method = \&$fullname;
        if (defined $_SDATA->{'METHOD'}{$fullname}{'scrubber'} && defined $current_method && $current_method eq $_SDATA->{'METHOD'}{$fullname}{'scrubber'}) {
            *$fullname = $_SDATA->{'METHOD'}{$fullname}{'old'};
            $_SDATA->{'METHOD'}{$fullname}{'old'} = undef;
            $_SDATA->{'METHOD'}{$fullname}{'scrubber'} = undef;
        } elsif ( defined $_SDATA->{'METHOD'}{$fullname}{'old'} ) {
            carp 'Log::Scrubber cannot disable the '.$fullname.' method, it has been overridden somewhere else';
        }
    }
}

sub scrubber_remove_method {
    foreach my $fullname ( @_ ) {
        _scrubber_disable_method($fullname);
        delete $_SDATA->{'METHOD'}{$fullname};
    }
}

sub _scrubber_enable_method {
    return if ! $_SDATA->{'enabled'};
    no strict 'refs'; ## no critic
    foreach my $fullname ( @_ ) {
        my $r_orig = \&$fullname;

    if ($fullname eq 'warnings::warnif') { $r_orig = \&warnings::warn; }

        if (! defined $r_orig) { croak "Log::Scrubber Cannot scrub $fullname, method does not exist."; }
        $_SDATA->{'METHOD'}{$fullname}{'old'} = $r_orig;
        $_SDATA->{'METHOD'}{$fullname}{'scrubber'} = sub { @_ = scrubber @_; goto $r_orig };
        *$fullname = $_SDATA->{'METHOD'}{$fullname}{'scrubber'};
    }
}

sub scrubber_add_method {
    foreach my $fullname ( @_ ) {
        next if defined $_SDATA->{'METHOD'}{$fullname};
        $_SDATA->{'METHOD'}{$fullname} = {};
        _scrubber_enable_method($fullname);
    }
}

###----------------------------------------------------------------###
# Add/Remove entire packages

sub scrubber_remove_package {
    no strict 'refs'; ## no critic
    foreach my $package ( @_ ) {
        my @methods = grep { defined &{$package.'::'.$_} } keys %{$package.'::'};
        foreach ( @methods ) {
            scrubber_remove_method($_);
        }
    }
}

sub scrubber_add_package {
    no strict 'refs'; ## no critic
    foreach my $package ( @_ ) {
        my @methods = grep { defined &{$package.'::'.$_} } keys %{$package.'::'};
        foreach ( @methods ) {
            scrubber_add_method($package.'::'.$_);
        }
    }
}

###----------------------------------------------------------------###
# Initilize the scrubber.

sub scrubber_init {
    my $x = $_[0];
    scrubber_stop;
    if (defined $x) {
        $_SDATA = _sdata_copy($_SDATA->{'parent'});
        scrubber_add_scrubber(@_);
    }
    scrubber_start();
    return 1;
}

1;

__END__