File Coverage

blib/lib/Module/Use.pm

Criterion	Covered	Total	%
statement	16	76	21.0
branch	1	34	2.9
condition	1	9	11.1
subroutine	6	12	50.0
pod	0	2	0.0
total	24	133	18.0

package Module::Use;

require 5.005;
use Tie::Hash;
#use Tie::StdHash;
use Carp;
use strict;
use vars qw($VERSION %noargs %counts %config $_object @ISA);

@ISA = qw(Tie::StdHash);

$VERSION = 0.05_01;

@noargs{
    qw(Counting)
}  = ( );

sub FETCH {
    $counts{$_[1]}++ if defined $_[0] -> {$_[1]};
    warn "Fetching $_[1]\n";
    $_[0] -> {$_[1]};
}

sub STORE {
    $counts{$_[1]}++;
    warn "Storing $_[1]\n";
    $_[0] -> {$_[1]} = $_[2];
}

sub import {
    my($self, @config) = @_;

    croak "@{[ref $self]} not intended to be instanced" if ref $self;

    my $op;
    while(@config) {
        $op = shift @config;
        if(exists $noargs{$op}) {
	    $config{$op} = 1;
	} else {
	    $config{$op} = shift @config;
	}
    }

    # load logging module - defines Module::Use::log
    if(defined $config{Logger}) {
	eval qq{require Module::Use::$config{Logger}};
        croak "Unable to load logger: $@" if $@;
    }

    if($ENV{'MOD_PERL'}) {
        $config{log_at_end} = 0;
    } else {
        $config{log_at_end} = 1;
    }

    if($config{"Counting"}) {
      tie %INC, $self;

      $_object = tied %INC;
    } else {
      $_object = bless { }, $self;
    }

    my($modules) = $_object -> query_modules();
    eval "require $_" for @{$modules};
}

sub query_modules {
    my($self) = shift;

    return unless $self -> can('_query_modules');

    my $hash = $self -> _query_modules();

    my @keys = keys %{$hash};
    my $total = 0;

    local($_);  # JIC

    $total += $hash->{$_} for @keys;

    my $p = 0;
    if($self -> {Percentage}) {
        $p = $self -> {Percentage} * $total / 100.;
    }
    if($self -> {Count}) {
        if($p < $self -> {Count}) {
            $p = $self -> {Count};
        }
    }

    my $l;
    if($self -> {Limit}) {
        $l = $self -> {Limit};
    } else {
        $l = scalar(@keys);
    }

    @keys = sort { $hash->{$a} <=> $hash->{$b} } @keys;

    $#keys = $l-1 if $l;


    @keys = grep { $hash->{$_} > $p } @keys if $p;   # could do a binary search at this point

    @keys = map s{\.pm$}{}, map s{/}{::}, @keys;

    return \@keys;
}

sub _process_INC {
    if($config{"Counting"}) {
        return grep {    $_ !~ m{^Module/Use(/|\.pm)?}
                      && $_ !~ m{^[a-z/]}
                    } keys %counts;
    } else {
	return grep {    $_ !~ m{^Module/Use(/|\.pm)?}
			      && $_ !~ m{^[a-z/]}
                    } keys %INC;
    }
}

sub handler {
    no strict qw(subs);

    $_object -> log(_process_INC()) if $_object -> can("log");
    return Apache::Constants::OK;
}

END {
    # now log %INC
    $_object -> log(_process_INC()) if $config{log_at_end} && $_object -> can("log");
}

1;

__END__