File Coverage

blib/lib/Paranoid/Glob.pm

Criterion	Covered	Total	%
statement	149	212	70.2
branch	37	50	74.0
condition	6	6	100.0
subroutine	21	30	70.0
pod	17	17	100.0
total	230	315	73.0

# Paranoid::Glob -- Paranoid Glob objects
#
# $Id: lib/Paranoid/Glob.pm, 2.10 2022/03/08 00:01:04 acorliss Exp $
#
# This software is free software.  Similar to Perl, you can redistribute it
# and/or modify it under the terms of either:
#
#   a)     the GNU General Public License
#           as published by the
#          Free Software Foundation ; either version 1
#          , or any later version
#          , or
#   b)     the Artistic License 2.0
#          ,
#
# subject to the following additional term:  No trademark rights to
# "Paranoid" have been or are conveyed under any of the above licenses.
# However, "Paranoid" may be used fairly to describe this unmodified
# software, in good faith, but not as a trademark.
#
# (c) 2005 - 2020, Arthur Corliss ([e-mail])
# (tm) 2008 - 2020, Paranoid Inc. (www.paranoid.com)
#
#####################################################################

#####################################################################
#
# Environment definitions
#
#####################################################################

package Paranoid::Glob;

use 5.008;

use strict;
use warnings;
use vars qw($VERSION);

use Carp;
use Errno qw(:POSIX);
use Fcntl qw(:mode);
use File::Glob qw(bsd_glob);
use Paranoid;
use Paranoid::Debug qw(:all);

($VERSION) = ( q$Revision: 2.10 $ =~ /(\d+(?:\.\d+)+)/s );

#####################################################################
#
# Module code follows
#
#####################################################################

sub _sanitize (\@) {

    # Purpose:  Detaints passed strings
    # Returns:  True if successful, false on any detaint errors
    # Usage:    $rv = _sanitize(@globs);

    my $aref = shift;
    my $rv   = 1;

    # Make sure all glob entries are sane
    foreach (@$aref) {
        if (/^([[:print:]]+)$/s) {
            $_ = $1;
            $_ =~ s#/{2,}#/#sg;
        } else {
            $Paranoid::ERROR =
                pdebug( 'invalid glob entry: %s', PDLEVEL1, $_ );
            $rv = 0;
            last;
        }
    }

    return $rv;
}

sub new {

    # Purpose:  Instantiates a new object of this class
    # Returns:  Object reference if successful, undef otherwise
    # Usage:    $obj = Paranoid::Glob->new(
    #                   globs       => [ qw(/lib/* /sbin/*) ],
    #                   literals    => [ qw(/lib/{sadfe-asda}) ],
    #                   );

    my ( $class, %args ) = splice @_;
    my $self = [];
    my $rv   = 1;

    subPreamble( PDLEVEL1, '%', %args );

    # Validate arguments
    if ( exists $args{globs} ) {
        croak 'Optional key/value pair "globs" not properly defined'
            unless ref $args{globs} eq 'ARRAY';
    }
    if ( exists $args{literals} ) {
        croak 'Optional key/value pair "literals" not properly defined'
            unless ref $args{literals} eq 'ARRAY';
    }

    bless $self, $class;

    # Add any globs or literals if they were passed during inititation
    $rv = $self->addLiterals( @{ $args{literals} } )
        if exists $args{literals};
    if ($rv) {
        $rv = $self->addGlobs( @{ $args{globs} } ) if exists $args{globs};
    }

    if ($rv) {
        $rv = $self;
    } else {
        $rv   = 'undef';
        $self = undef;
    }

    subPostamble( PDLEVEL1, '$', $self );

    return $self;
}

sub addGlobs {

    # Purpose:  Adds more globs to the object that need to be filtered through
    #           the bsd_glob
    # Returns:  True if all globs passed muster, false if not
    # Usage:    $rv = $obj->addGlobs(qw(/etc/* /root/*));

    my ( $self, @globs ) = splice @_;
    my $rv = 1;
    my @tmp;

    subPreamble( PDLEVEL1, '@' );

    # Silently remove undefs and zero strings
    @globs = grep { defined $_ and length $_ } @globs;

    # Make sure all glob entries are sane
    $rv = _sanitize(@globs);

    if ($rv) {

        # Filter them through bsd_glob unless the file exists as named in the
        # literal string
        foreach (@globs) {
            push @tmp, -e $_ ? $_ : bsd_glob($_);
        }

        # Final detaint
        foreach (@tmp) { /^([[:print:]]+)$/s and $_ = $1 }

        pdebug( 'added %d entries', PDLEVEL2, scalar @tmp );

        # Add to ourself
        push @$self, splice @tmp;
    }

    subPostamble( PDLEVEL1, '$', $rv );

    return $rv;
}

sub addLiterals {

    # Purpose:  Adds more globs to the object as literal strings
    # Returns:  True if all globs passed muster, false if not
    # Usage:    $rv = $obj->addLiterals(qw(/etc/* /root/*));

    my ( $self, @globs ) = splice @_;
    my $rv = 1;

    subPreamble( PDLEVEL1, '@' );

    # Silently remove undefs and zero strings
    @globs = grep { defined $_ and length $_ } @globs;

    # Make sure all glob entries are sane
    $rv = _sanitize(@globs);

    push @$self, splice @globs if $rv;

    subPostamble( PDLEVEL1, '$', $rv );

    return $rv;
}

sub consolidate {

    # Purpose:  Removes redundant entries and sorts alphabetically
    # Returns:  True
    # Usage:    $obj->consolidate;

    my ($self) = @_;
    my (%tmp);

    pdebug( 'entering w/%d entries', PDLEVEL1, scalar @$self );
    subPreamble(PDLEVEL1);

    %tmp = map { $_ => 1 } @$self;
    @$self = sort keys %tmp;

    pdebug( 'leaving w/%d entries', PDLEVEL1, scalar @$self );
    subPostamble( PDLEVEL1, '$', 1 );

    return 1;
}

sub exists {

    # Purpose:  Returns a list of the entries that exist on the file system
    # Returns:  List of existing filesystem entries
    # Usage:    @entries = $obj->existing;

    my ($self) = @_;
    my @entries = grep { scalar lstat $_ } @$self;

    subPreamble(PDLEVEL1);
    subPostamble( PDLEVEL1, '@', @entries );

    return @entries;
}

sub readable {

    # Purpose:  Returns a list of the entries that are readable by the
    #           effective user
    # Returns:  List of readable entries
    # Usage:    @entries = $obj->readable;

    my ($self) = @_;
    my @entries = grep { -r $_ } $self->exists;

    subPreamble(PDLEVEL1);
    subPostamble( PDLEVEL1, '@', @entries );

    return @entries;
}

sub writable {

    # Purpose:  Returns a list of the entries that are writable by the
    #           effective user
    # Returns:  List of writable entries
    # Usage:    @entries = $obj->writable;

    my ($self) = @_;
    my @entries = grep { -w $_ } $self->exists;

    subPreamble(PDLEVEL1);
    subPostamble( PDLEVEL1, '@', @entries );

    return @entries;
}

sub executable {

    # Purpose:  Returns a list of the entries that are executable/traversable
    #           by the effective user
    # Returns:  List of executable/traversable entries
    # Usage:    @entries = $obj->executable;

    my ($self) = @_;
    my @entries = grep { -x $_ } $self->exists;

    subPreamble(PDLEVEL1);
    subPostamble( PDLEVEL1, '@', @entries );

    return @entries;
}

sub owned {

    # Purpose:  Returns a list of the entries that are owned by the
    #           effective user
    # Returns:  List of owned entries
    # Usage:    @entries = $obj->owned;

    my ($self) = @_;
    my @entries = grep { -o $_ } $self->exists;

    subPreamble(PDLEVEL1);
    subPostamble( PDLEVEL1, '@', @entries );

    return @entries;
}

sub directories {

    # Purpose:  Returns a list of existing directories
    # Returns:  List of directories
    # Usage:    @dirs = $obj->directories;

    my ($self) = @_;
    my @dirs = grep { -d $_ } $self->exists;

    subPreamble(PDLEVEL1);
    subPostamble( PDLEVEL1, '@', @dirs );

    return @dirs;
}

sub files {

    # Purpose:  Returns a list of existing files
    # Returns:  List of files
    # Usage:    @files = $obj->files;

    my ($self) = @_;
    my @files = grep { -f $_ } $self->exists;

    subPreamble(PDLEVEL1);
    subPostamble( PDLEVEL1, '@', @files );

    return @files;
}

sub symlinks {

    # Purpose:  Returns a list of existing symlinks
    # Returns:  List of symlinks
    # Usage:    @files = $obj->symlinks;

    my ($self) = @_;
    my @symlinks = grep { -l $_ } $self->exists;

    subPreamble(PDLEVEL1);
    subPostamble( PDLEVEL1, '@', @symlinks );

    return @symlinks;
}

sub pipes {

    # Purpose:  Returns a list of existing pipes
    # Returns:  List of pipes
    # Usage:    @files = $obj->pipes;

    my ($self) = @_;
    my @pipes = grep { -p $_ } $self->exists;

    subPreamble(PDLEVEL1);
    subPostamble( PDLEVEL1, '@', @pipes );

    return @pipes;
}

sub sockets {

    # Purpose:  Returns a list of existing sockets
    # Returns:  List of sockets
    # Usage:    @files = $obj->sockets;

    my ($self) = @_;
    my @sockets = grep { -S $_ } $self->exists;

    subPreamble(PDLEVEL1);
    subPostamble( PDLEVEL1, '@', @sockets );

    return @sockets;
}

sub blockDevs {

    # Purpose:  Returns a list of existing block nodes
    # Returns:  List of block devs
    # Usage:    @files = $obj->blockDevs;

    my ($self) = @_;
    my @bdevs = grep { -b $_ } $self->exists;

    subPreamble(PDLEVEL1);
    subPostamble( PDLEVEL1, '@', @bdevs );

    return @bdevs;
}

sub charDevs {

    # Purpose:  Returns a list of existing character nodes
    # Returns:  List of character devs
    # Usage:    @files = $obj->charDevs;

    my ($self) = @_;
    my @cdevs = grep { -c $_ } $self->exists;

    subPreamble(PDLEVEL1);
    subPostamble( PDLEVEL1, '@', @cdevs );

    return @cdevs;
}

sub recurse {

    # Purpose:  Recursively adds all subdirectories and their contents to the
    #           glob.  Passing an optional boolean argument will tell it
    #           whether or not to follow symlinks.  Defaults to not following
    #           symlinks (false).  Another optional boolean argument instructs
    #           this method whether or not to include hidden directories.  In
    #           accordance with the traditional behavior of shell globbing it
    #           defaults to false.
    # Returns:  True if successful, false on any errors (like permission
    #           denied, etc.)
    # Usage:    $rv = $obj->recurse;
    # Usage:    $rv = $obj->recurse(1);
    # Usage:    $rv = $obj->recurse(1, 1);

    my ( $self, $follow, $hidden ) = @_;
    my $rv = 1;
    my ( %seen, @crawl, $lindex, $slindex );

    subPreamble(PDLEVEL1);

    # Define our dirFilter sub, who's sole purpose is to extract a list of
    # directories from the passed list of entries
    my $dirFilter = sub {
        my @entries = @_;
        my ( $entry, @fstat, @dirs );

        # Extract a list of directories from our current contents
        foreach $entry (@entries) {
            @fstat = lstat $entry;
            if (@fstat) {

                # Entry exists
                if ( S_ISDIR( $fstat[2] ) ) {

                    # Filter out sockets, etc.
                    next if $fstat[2] &

                            # Add the directory
                            push @dirs, $entry;

                } elsif ( $follow and S_ISLNK( $fstat[2] ) ) {

                    # Add symlinks pointing to directories if we're set
                    # to follow
                    push @dirs, $entry if -d $entry;
                }

            } else {

                # Report any errors for anything other than ENOENT
                unless ( $! == ENOENT ) {
                    Paranoid::ERROR = pdebug( 'couldn\'t access %s: %s',
                        PDLEVEL1, $entry, $! );
                    $rv = 0;
                }
            }
        }

        return @dirs;
    };

    # Define our addDir sub, whose purpose is to return the contents of the
    # passed directory
    my $addDir = sub {
        my $dir = shift;
        my ( $fh, @contents );

        if ( opendir $fh, $dir ) {

            # Get the list, filtering out '.' & '..'
            foreach ( readdir $fh ) {
                next if m/^\.\.?$/s;
                next if m/^\./s and not $hidden;
                push @contents, "$dir/$_";
            }
            closedir $fh;

        } else {
            Paranoid::ERROR =
                pdebug( 'error opening directory %s: %s', PDLEVEL1, $dir,
                $! );
            $rv = 0;
        }

        return @contents;
    };

    # Consolidate to reduce potential redundancies
    $self->consolidate;

    # Get our initial list of directories to crawl
    @crawl = &$dirFilter(@$self);

    # Start crawling
    $lindex  = 0;
    $slindex = $#$self;
    while ( $lindex <= $#crawl ) {

        # Skip the directory if we've already crawled it
        if ( exists $seen{ $crawl[$lindex] } ) {
            $lindex++;
            next;
        }

        # Add the directory's contents
        push @$self, ( &$addDir( $crawl[$lindex] ) );
        $seen{ $crawl[$lindex] } = 0;
        $lindex++;
        $slindex++;

        # Add any new directories to the crawl list
        push @crawl, ( &$dirFilter( @$self[ $slindex .. $#$self ] ) );
        $slindex = $#$self;
    }

    # Final consolidation
    $self->consolidate;

    subPostamble( PDLEVEL1, '$', $rv );

    return $rv;
}

1;

__END__