Tie::Mounted - Tie a mounted node to an array

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

Index

Code Index:

NAME

Top

Tie::Mounted - Tie a mounted node to an array

SYNOPSIS

Top

 use Tie::Mounted;

 tie @files, 'Tie::Mounted', '/backup', '-v';
 print $files[-1];
 untie @files;

DESCRIPTION

Top

This module ties files (and directories) of a mount point to an array by invoking the system commands mount and umount; mount is invoked when a former attempt to tie an array is being committed, umount when a tied array is to be untied. Suitability is therefore limited and suggests a rarely used node (such as /backup, for example).

The mandatory parameter consists of the node (or: mount point) to be mounted (/backup - as declared in /etc/fstab); optional options to mount may be subsequently passed (-v). Device names and mount options (-a,-A,-d) will be discarded in regard of system security.

Default paths to mount and umount may be overriden by setting accordingly either $Tie::Mounted::MOUNT_BIN or $Tie::Mounted::UMOUNT_BIN. If either of them doesn't exist at the predefined path, a which() will be performed to determine the actual path.

If $Tie::Mounted::NO_FILES is set to a true value, a bogus array with zero files will be tied.

BUGS & CAVEATS

Top

Security

Tie::Mounted has by default set $APPROVE to an untrue value in order to allow all nodes to be passed. If $APPROVE is set to a true value, @NODES has to contain the nodes that are considered ``approved"; both variables are lexically scoped and adjustable within _private(). If in approval mode and a node is passed that is considered unapproved, Tie::Mounted will throw an exception.

Such ``security" is rather trivial; instead it is recommended to adjust filesystem permissions to prevent malicious use.

Portability

Tie::Mounted is Linux/UNIX centered (due to the fstab file & the mount/umount binaries requirements) and will most likely won't work on other platforms.

Miscellanea

The tied array is read-only.

Files within the tied array are statically tied.

Lacking tests

Tests that test the base functionality are completely missing due to an environment that most likely can't be adequately simulated.

SEE ALSO

Top

tie in perlfunc, fstab(5), mount(8), umount(8)

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://www.perl.com/perl/misc/Artistic.html

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

use strict;
use warnings;
use base qw(Tie::Array);

use Carp qw(croak);
use File::Which ();
use IO::File ();
use Symbol qw(gensym);

our ($VERSION, $FSTAB, $MOUNT_BIN, $UMOUNT_BIN, $NO_FILES);

$VERSION = '0.18';
$FSTAB = '/etc/fstab';
$MOUNT_BIN  = '/sbin/mount';
$UMOUNT_BIN = '/sbin/umount';

sub _private
{
    my $APPROVE = 0;
    my @NODES   = qw(    );

    return eval do { $_[0] };
}

{
    sub TIEARRAY
    {
        my $class = shift;

        _gather_paths();
        _validate_node($_[0]);

        return bless &_tie, $class;
    }

    sub FETCHSIZE { $#{$_[0]} }           # FETCHSIZE, FETCH: Due to the node,
    sub FETCH     { $_[0]->[++$_[1]] }    # which is being kept hideously, accordingly
                                          # subtract (FETCHSIZE) or add (FETCH) 1.
    *STORESIZE = *STORE =
      sub { croak 'Tied array is read-only' };

    sub UNTIE { _approve('umount', $_[0]->[0]) }
}

sub _gather_paths
{
    my $which_bin = sub
    {
        my ($target_var_name, $target) = @_;

        no strict 'refs';
        unless (-e ${$target_var_name} && -x _) {
            eval { require File::Basename };
            die $@ if $@;
            my $which = File::Which::which($target);
            defined $which
              ? ${$target_var_name} = $which
              : croak "Can't locate '", File::Basename::basename(${$target_var_name}), "': $!";
        }
    };

    $which_bin->('MOUNT_BIN', 'mount');
    $which_bin->('UMOUNT_BIN', 'umount');
}

sub _validate_node
{
    my ($node) = @_;

    my $fh = IO::File->new("<$FSTAB") or die "Can't open $FSTAB for reading: $!";
    my $fstabs = do { local $/; <$fh> };
    $fh->close;

    !$node
      ? croak 'No node supplied'
      : !-d $node
        ? croak "$node doesn't exist in $FSTAB"
        : $fstabs =~ /^\#.*$node/m
          ? croak "$node is enlisted as disabled in $FSTAB"
          : $fstabs !~ /$node/s
            ? croak "$node is not enlisted in $FSTAB"
            : '';
}

sub _tie
{
    my $node = shift;
    my @args = split /\s+/, $_[0];

    _approve('mount', $node, grep !/^-[aAd]$/o, @args);

    my $items = $NO_FILES ? [] : _read_dir($node);

    # Invisible node at index 0
    unshift @$items, $node;

    return $items;
}

sub _approve
{
    my ($sub, $node) = (shift, @_);

    if (_private('$APPROVE')) {
        croak "Attempt to $sub unapproved node"
          unless (grep { $node eq $_ } _private('@NODES'));
    }

    no strict 'refs';
    &{"_$sub"};
}

sub _mount
{
    my $node = shift;

    unless (_is_mounted($node)) {
        my $cmd = "$MOUNT_BIN @_ $node";
        system($cmd) == 0 or exit(1);
    }
}

sub _is_mounted
{
    my ($node) = @_;

    my $pipe = gensym();

    open($pipe, "$MOUNT_BIN |")
      or die "Can't init pipe to $MOUNT_BIN: $!";

    my $retval = (grep /$node/, <$pipe>) ? 1 : 0;

    close($pipe);

    return $retval;
}

sub _read_dir
{
    my ($node) = @_;

    my $dh = gensym();

    opendir($dh, $node)
      or die "Can't open directory $node: $!";

    my @items = grep !/^(?:\.|\.\.)$/, sort readdir($dh);

    closedir($dh);

    return \@items;
}

sub _umount
{
    my ($node) = @_;

    my $cmd = "$UMOUNT_BIN $node";
    system($cmd) == 0 or exit(1);
}

1;
__END__