File Coverage

blib/lib/Tie/DiskUsage.pm

Criterion	Covered	Total	%
statement	66	70	94.2
branch	10	16	62.5
condition	10	15	66.6
subroutine	14	16	87.5
pod			n/a
total	100	117	85.4

package Tie::DiskUsage;

use strict;
use warnings;

use Carp qw(croak);
use Symbol ();

our ($VERSION, $DU_BIN);

$VERSION = '0.23';

$DU_BIN = '/usr/bin/du';

sub TIEHASH
{
    my $class = shift;

    my $du = _locate_du();
    my $path = shift @_;
    my @opts = @_;

    _validate($path, \@opts);

    return bless { du => $du, path => $path, opts => \@opts }, $class;
}

sub EXISTS
{
    my $self = shift;
    my ($key) = @_;

    my $usage = _parse_usage($self->{du}, $self->{path}, $self->{opts}, $key);

    return exists $usage->{$key};
}

sub FETCH
{
    my $self = shift;
    my ($key) = @_;

    my $usage = _parse_usage($self->{du}, $self->{path}, $self->{opts}, $key);

    return $usage->{$key};
}

sub FIRSTKEY
{
    my $self = shift;

    my $usage = _parse_usage($self->{du}, $self->{path}, $self->{opts}, undef);

    my @keys = sort keys %$usage;
    my $key = shift @keys;
    delete $self->{'keys'};
    $self->{'keys'} = [ @keys ];

    return $key;
}

sub NEXTKEY
{
    my $self = shift;

    return shift @{$self->{'keys'}};
}

sub SCALAR
{
    my $self = shift;

    my $usage = _parse_usage($self->{du}, $self->{path}, $self->{opts}, undef);

    return scalar %$usage;
}

sub UNTIE {}

*CLEAR = *DELETE = *STORE = sub { croak 'Tied hash is read-only' };

sub _validate
{
    my ($path, $opts) = @_;

    @$opts = map { (defined && length) ? $_ : () } @$opts;

    my %errors = (
        not_exists => 'an existing path',
        not_option => 'options to be short or long',
    );
    my $error = sub { "tie() requires $_[0]" };

    my $valid_opt = qr{
        ^(?:
              -\w           (?:(?:   \ +?)\S+)? # short
           | --\w{2}[-\w]*? (?:(?:\=|\ +?)\S+)? # long
         )$
    }ix;

    croak $error->($errors{not_exists})
      if defined $path && !-e $path;

    croak $error->($errors{not_option})
      if @$opts && grep !/$valid_opt/, @$opts;
}

sub _locate_du
{
    if (!-e $DU_BIN) {
        my $du_which = do { require File::Which; File::Which::which('du') };
        croak "Cannot locate du: $!" unless defined $du_which;

        return $du_which;
    }
    else {
        croak "Cannot run `$DU_BIN': Not executable" unless -x $DU_BIN;

        return $DU_BIN;
    }
}

sub _parse_usage
{
    my ($du, $path, $opts, $key) = @_;
    $path ||= do { require Cwd; Cwd::getcwd() };

    my $pipe = Symbol::gensym();
    open($pipe, "$du @$opts $path |") or exit(1);

    my %usage;
    while (my $line = <$pipe>) {
        my ($size, $item) = $line =~ /^(.+?) \s+? (.+)$/x;
        # optimisation for EXISTS/FETCH
        next if defined $key && $key ne $item;
        $usage{$item} = $size;
    }

    close($pipe);

    return \%usage;
}

1;
__END__