Tie::DiskUsage - Tie disk usage to a hash

Tie-DiskUsage documentation Contained in the Tie-DiskUsage distribution.

Index

Code Index:

NAME

Top

Tie::DiskUsage - Tie disk usage to a hash

SYNOPSIS

Top

 use Tie::DiskUsage;

 tie %usage, 'Tie::DiskUsage', '/var', '-h';
 print $usage{'/var/log'};
 untie %usage;

DESCRIPTION

Top

Tie::DiskUsage ties the disk usage, which is extracted from the output of du(1), to a hash. If the path to perform the du command on is undef, the current working directory will be examined; options to du may be passed at the end of the tie invocation with a string provided per option.

By default, the location of the du command is assumed to be at /usr/bin/du; if du cannot be found there, File::Which will attempt to gather its real location.

The default path to du may be overridden by setting the global $Tie::DiskUsage::DU_BIN (usually not needed due to File::Which's automatic search for du).

BUGS & CAVEATS

Top

Processing output of du(1) requires that each output line is ended by a newline.

SEE ALSO

Top

tie in perlfunc, du(1), Filesys::DiskUsage, Sys::Statistics::Linux

AUTHOR

Top

Steven Schubiger <schubiger@cpan.org>

LICENSE

Top

This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself.

See http://dev.perl.org/licenses/

Tie-DiskUsage documentation Contained in the Tie-DiskUsage distribution. 
package Tie::DiskUsage;

use strict;
use warnings;

use Carp qw(croak);
use Symbol ();
use Tie::Hash ();

our ($VERSION, @ISA, $DU_BIN);

$VERSION = '0.21';
@ISA = qw(Tie::StdHash);

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

sub TIEHASH
{
    my $class = shift;
    return bless _tie(@_), $class;
}
sub UNTIE {}

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

    _validate($path, \@opts);

    return _parse_usage($du, $path, @opts);
}

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) = @_;
    $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;
        $usage{$item} = $size;
    }

    close($pipe);

    return \%usage;
}

1;
__END__