#
# Copyright (c) 2000-2003 Rob Quince
# Author: Rob Quince
# EMail : robq@fiendish-demon-co-uk
#
# Permission is hereby granted, without written agreement and without
# license or royalty fees, to use, copy, modify, and distribute this
# software and its documentation for any purpose, provided that the
# above copyright notice and the following two paragraphs appear in all
# copies of this software and that no charge is made for the software.
#
# IN NO EVENT SHALL THE AUTHOR BE LIABLE TO ANY PARTY FOR DIRECT,
# INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE
# AUTHOR HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
# THE AUTHOR SPECIFICALLY DISCLAIMS ANY WARRANTIES, INCLUDING, BUT
# NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
# FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER
# IS ON AN "AS IS" BASIS, AND THE AUTHOR HAS NO OBLIGATION TO PROVIDE
# MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
#

package DirWalk;

use strict;

use POSIX qw(:sys_stat_h);

use constant FILESYS_DEV	=> 0;
use constant INODE		=> 1;
use constant TYPE_MODE		=> 2;
use constant N_LINKS		=> 3;
use constant UID		=> 4;
use constant GID		=> 5;
use constant FILE_DEV		=> 6;
use constant SIZE		=> 7;
use constant ATIME		=> 8;
use constant MTIME		=> 9;
use constant CTIME		=> 10;
use constant PREF_BLKSIZE	=> 11;
use constant BLOCKS		=> 12;

$DirWalk::VERSION = '$Revision: #1 $';

sub _dieOnError;
sub _warnOnError;
sub _printOnError;
sub _silentOnError;

=head1 NAME

DirWalk - directory tree walker

=head1 SYNOPSIS

 use DirWalk;
 my $walker = DirWalk->new( 'somedir' );
 $walker->walk( DIRFUNC => \&dirfunc,
                FILEFUNC => \&filefunc,
                USERVALUE => $val
 );

 sub dirfunc  { print "Val: $_[0] Dir: $_[1] (Mode: $_[2])\n"; }
 sub filefunc { print "Val: $_[0] Dir: $_[1] File: $_[2] (Mode: $_[3])\n"; }

=head1 AUTHOR

 Rob Quince (robq@fiendish-demon-co-uk)

=head1 DESCRIPTION

This package provides a top-down or a depth first tree walking
capability. A user provided function is called for each directory
and file found in the tree.

=head1 METHODS

=over 4

=item new( 'directory' )

The object constructor for the package.

=item walk( %options )

Walks the tree associated with the calling DirWalk object
calling the directory and file functions passed in the options
hash to perform actions on the directories and files found. The
references to the desired methods to call are passed as the values
to the C<DIRFUNC> and C<FILEFUNC> options.

The walk can either be top-down if C<DEPTHFIRST> option is a false
value or not specified, or deepest first if C<DEPTHFIRST> option
is a true value. The C<USERVALUE> option is a scalar (or ref of
course) that is passed to each of the called functions as the
first argument, thus an object or other useful value can be passed.

For each directory level, top-down walking first calls the given
directory function, then, for each file, the file function, starting
at the top-most directory, working its way down and across the
tree.

Deepest-first walking traverses down to the lowest level of
each sub-directory found in the top-most directory at the outset,
then, for each file, calls the file function. The directory function
is called prior to exiting each level.

=back

=cut

###################################################

sub new {
	my $proto   = shift;
	my $class   = ref $proto || $proto;
	my $dirname = shift;

	my $self  = {
		DIRNAME  => $dirname,
		MAXDEPTH => -1,
		ON_ERROR => \&_dieOnError,
	};

	$self = bless( $self, $class );

	return undef unless ( -d $dirname );
	return undef unless ( -r $dirname );

	return $self;
}

###################################################

sub setDieOnError {
	my $self = shift;
	$self->{ ON_ERROR } = \&_dieOnError;
}

###################################################

sub setWarnOnError {
	my $self = shift;
	$self->{ ON_ERROR } = \&_warnOnError;
}

###################################################

sub setPrintOnError {
	my $self = shift;
	$self->{ ON_ERROR } = \&_printOnError;
}

###################################################

sub setSilentOnError {
	my $self = shift;
	$self->{ ON_ERROR } = \&_silentOnError;
}

###################################################

sub walk {
	my $self    = shift;
	my %options = @_;

	$self->{ FILEFUNC   } = $options{ FILEFUNC   };
	$self->{ DIRFUNC    } = $options{ DIRFUNC    };
	$self->{ DEPTHFIRST } = $options{ DEPTHFIRST };
	$self->{ USERVALUE  } = $options{ USERVALUE  };

	# Use the default value of -1 unless an override
	# has been specified

	if ( exists $options{ MAXDEPTH } ) {
		$self->{ MAXDEPTH } = $options{ MAXDEPTH };
	}

	$self->{ CURDEPTH } = $self->{ MAXDEPTH };

	# Start at the top ...
	return $self->_walk( $self->{ DIRNAME } );
}

###################################################

sub _walk {
	my $self    = shift;
	my $dirname = shift;

	my $dirfunc = $self->{ DIRFUNC };
	my @details = stat( $dirname );

	my ( $dirs, $files ) = $self->_readDir( $dirname );

	return 0 unless ( defined $dirs && defined $files );

	if ( $self->{ DEPTHFIRST } ) {
		if ( $self->{ CURDEPTH }-- ) {
			return 0 unless ( $self->_doDirs( $dirname, $dirs ) );
		}

		return 0 unless ( $self->_doFiles( $dirname, $files ) );
		if ( defined $dirfunc ) {
			unless ( &$dirfunc( $self->{ USERVALUE }, $dirname, $details[ TYPE_MODE ] ) ) {
				$self->_error( "DirWalk::_walk: directory function failed in '$dirname'\n" );
				return 0;
			}
		}
	} else {
		if ( defined $dirfunc ) {
			unless ( &$dirfunc( $self->{ USERVALUE }, $dirname, $details[ TYPE_MODE ] ) ) {
				$self->_error( "DirWalk::_walk: directory function failed in '$dirname'\n" );
				return 0;
			}
		}
		return 0 unless ( $self->_doFiles( $dirname, $files ) );

		if ( $self->{ CURDEPTH }-- ) {
			return 0 unless ( $self->_doDirs( $dirname, $dirs ) );
		}
	}

	return 1;
}

###################################################

sub _doFiles {
	my $self    = shift;
	my $dirname = shift;
	my $files   = shift;

	my $filefunc = $self->{ FILEFUNC };

	foreach my $file ( @$files ) {
		my @details = stat( "$dirname/$file" );
		unless ( @details ) {
			$self->_error( "DirWalk::_doFiles: unable to stat file '$dirname/$file' ($!)\n" );
			next;
		}
		if ( defined $filefunc ) {
			unless ( &$filefunc( $self->{ USERVALUE }, $dirname, $file, $details[ TYPE_MODE ] ) ) {
				$self->_error( "DirWalk::_doFiles: file function failed for '$dirname/$file'\n" );
				return 0;
			}
		}
	}

	return 1;
}

###################################################

sub _doDirs {
	my $self    = shift;
	my $dirname = shift;
	my $dirs    = shift;

	foreach my $dir ( @$dirs ) {
		return 0 unless ( $self->_walk( "$dirname/$dir" ) );
	}

	return 1;
}

###################################################

sub _readDir {
	my $self    = shift;
	my $dirname = shift;
	my @dirs;
	my @files;

	unless ( opendir( DIR, $dirname ) ) {
		$self->_error( "DirWalk::_readDir: cannot open directory '$dirname' ($!)\n" );
		return ();
	}

	my @allfiles = readdir( DIR );
	closedir( DIR );

	foreach my $file ( @allfiles ) {
		my @details = stat( "$dirname/$file" );

		unless ( @details ) {
			$self->_error( "DirWalk::_readDir: unable to stat file '$dirname/$file' ($!)\n" );
			next;
		}

		if ( S_ISDIR( $details[ TYPE_MODE ] ) ) {
			push @dirs, $file unless $file =~ /^\./;
		} else {
			push @files, $file;
		}
	}

	return ( \@dirs, \@files );
}

###################################################

sub file_mode {
	my $self     = shift;
	my $filename = shift;

	return ( stat( $filename ) )[ TYPE_MODE ];
}

###################################################

sub _dir_func {
	my $uservalue = shift;
	my $dirname   = shift;
	my $mode      = shift;
	print "Directory $dirname contains:\n";
}

###################################################

sub _file_func {
	my $uservalue = shift;
	my $dirname   = shift;
	my $file      = shift;
	my $mode      = shift;
	print "\t$dirname/$file\n";
}

###################################################

sub _dieOnError {
	my $self = shift;
	my $err  = shift;
	die $err;
}

###################################################

sub _warnOnError {
	my $self = shift;
	my $err  = shift;
	warn $err;
}

###################################################

sub _printOnError {
	my $self = shift;
	my $err  = shift;
	print STDERR $err;
}

###################################################

sub _silentOnError {
	my $self = shift;
	my $err  = shift;
}

###################################################

sub _error {
	my $self    = shift;
	my $errMsg  = shift;
	my $errFunc = $self->{ ON_ERROR };

	$self->$errFunc( $errMsg );
}

1;

__END__