File Coverage

blib/lib/Template/Direct/Directory.pm

Criterion	Covered	Total	%
statement	65	172	37.7
branch	28	104	26.9
condition	6	29	20.6
subroutine	14	31	45.1
pod	26	26	100.0
total	139	362	38.4

package Template::Direct::Directory;

=head1 NAME

Template::Direct::Directory - Controls the access to a set directory

=head1 SYNOPSIS

  use Directory;

  my $directory = Template::Direct::Directory->new( '/etc' );

  my $file = $directory->open( 'foo.txt' );

  my $parent = $directory->parent();

  my @children = $directory->list();

  my @results = $directory->search();

=head1 DESCRIPTION

  Loads a directory for use with fileDirectives

=head1 METHODS

=cut

our $VERSION = "3.02";

use overload
    '""'   => \&autoscalar,
	'bool' => \&autobool,
	'eq'   => \&autoeq,
	'ne'   => \&autone;

use strict;
use Carp qw/carp cluck/;
use Template::Direct::Directory::File;

our %Cache;

=head2 I<$class>->new( $dir )

  Create a new Directory object located at $dir.

=cut
sub new
{
	my ($cache, $dir, %p) = @_;
	my $self = bless {}, $cache;

	carp "Directory Error: 'Directory' is a required field" and return if not $dir;
	($self->{'Directory'}) = $self->_clean_path( Directory => $dir, Parents => 1 );

	if(defined($Cache{$self->{'Directory'}})) {
		warn "Using cached Directory $self->{'Directory'}\n" if $ENV{'DIR_DEBUG'};
		return $Cache{$self->{'Directory'}};
	}

	carp "Directory Error: files are not allowed as Directories (please use Directory::File)"
		and return if -f $dir;

	if( $p{'Create'} ) {
		$self->mkpath( $self->{'Directory'} );
	}

	$Cache{$self->path()} = $self if -f $self->path();

	return $self;
}

=head2 I<$dir>->save( $filename, $data, %options )

  Save a file in this directory (quickly)

=cut
sub save
{
	my ($self, $file, $data, %p) = @_;
	my ($path, $isfile, $parent) = $self->_clean_path(%p, File => $file );

	carp "Directory Error: file is a required field when saving" and return if not $path;
	carp "Directory Error: Directories can not be saved" and return if not $isfile;

	if(defined($data)) {
		if(not -d $parent) {
			$parent->mkpath( $parent->path() );
		}
		my $file = Template::Direct::Directory::File->new( $path, Create => 1, %p, Parent => $parent );
		return if(not defined($file));
		$file->save( $data );
		return $file;
	} else {
		carp "Directory Error: No data to save, required Data\n";
	}
	return;
}

=head2 I<$dir>->loadFile( $filename, %options )

  Load a file object child, options include:

    * Create - Create this file if it doesn't exist

=cut
sub loadFile { shift->load( @_, File => 1 ) }

=head2 I<$dir>->loadDir( $directory, %options )

  Load a sub directory, options include:

    * Create - Create this file if it doesn't exist

=cut
sub loadDir { shift->load( @_ ) }

=head2 I<$dir>->load( $path, %options )

  Generic load a file or sub directory object with options:

    * Create     - Create this filename as a directory if it doesn't exist
    * CreateFile - Create this filename as a file if it doesn't exist
	* File       - Force loading as a file object.

=cut
sub load
{
	my ($self, $file, %p) = @_;
	my ($path, $isfile, $parent) = $self->_clean_path( %p, Directory => $file );
	$p{'Create'} = $p{'CreateFile'} if not $p{'Create'};
	return Template::Direct::Directory::File->new( $path, %p, Parent => $parent ) if $isfile;
	return Template::Direct::Directory->new( $path, %p, Parent => $self );
}

=head2 I<$dir>->delete( $filename, %p )

  Delete a file from this directory.

=cut
sub delete
{
	my ($self, $file, %p) = @_;
	my ($path, $isfile, $parent) = $self->_clean_path( %p, Directory => $file );
	if($isfile) {
		my $file = Template::Direct::Directory::File->new( $path, %p, Parent => $parent );
		if($file) {
			return $file->delete();
		}
	} else {
		return $self->prune( $path );
	}

	return;
}

=head2 I<$dir>->_clean_path( %p )

  Takes %p and returns corrected, localised paths.

=cut
sub _clean_path
{
	my ($self, %p) = @_;

	my $path = ($p{'File'} and not $p{'Directory'}) ? $p{'File'} : $p{'Directory'};
	return if not $path;

	if(not $p{'Parents'}) {
		carp "Unable to clean path because Diretory object is involid" and return if not $self->path;
		$path = $self->path.$path;
	}

	#carp "Cleaning path $path ".(-d $path ? 1 : 0)."/".(-f $path ? 1 : 0)."\n";

	if($p{'CreateFile'} or -f $path) {
		$p{'Create'} = 1;
		$p{'File'}   = 1;
	}

    $path = $self->useElements($path, $p{'Elements'}) if $p{'Elements'};

	$path .= "/" if not $p{'File'};
	$path =~ s/([^\/]+)\/\.\.\///g; # No parent directories allowed in children
	warn "Removing Parent $1\n" if $1 and $ENV{'DIR_DEBUG'};
	$path =~ s/\/\.\//\//g; # No current directories allowed
	$path =~ s/\/+/\//g; # Remove double directories.

	if($p{'File'}) {
		my ($dir, $filename) = $path =~ /^(.+)\/([^\/]+)$/;
		my $parent = $dir ? Template::Direct::Directory->new( $dir, Create => $p{'CreatePath'} ) : $self;
		return ($filename, 1, $parent);
	} else {
		return ($path, 0);
	}
}

=head2 I<$dir>->clearCache( %p )

  Clear directory and file objects that are cached.

=cut
sub clearCache
{
	my ($self, %p) = @_;
	my ($file, $isfile, $parent) = $self->_clean_path(%p);

	if($isfile) {
		return delete($parent->{'Cache'}->{$file});
	} elsif($file) {
		my $dir = Template::Direct::Directory->new( $file );
		return $dir->clearCache;
	} else {
		warn "Clearing Cache for ".$self->path."\n" if $ENV{'DIR_DEBUG'};
		$self->{'Cache'} = {};
		return 1;
	}
}

=head2 I<$ir>->clearCaches()

  Clear all directory and file objects that are cached.

=cut
sub clearCaches
{
	my ($self) = @_;
	foreach my $dir (values(%Cache)) {
		$dir->clearCache;
	}
	%Cache = ();
	return;
}

=head2 I<$dir>->fromCache( )

  Was this object loaded from cache (for testing)

=cut
sub fromCache { shift->{'fromCache'} }

=head2 I<$dir>->saveCache( $filename, $data )

  Save a cache for filename with data.

=cut
sub saveCache
{
	my ($self, $filename, $data) = @_;
	if($data) {
		warn "DIR,Cache,save DONE $filename\n" if $ENV{'DIR_DEBUG'};
		$self->{'Cache'}->{$filename} = $data;
	} else {
		warn "DIR,Cache,save FAILED (No Data) $filename\n" if $ENV{'DIR_DEBUG'};
	}
	return 1;
}

=head2 I<$dir>->loadCache( $filename )

  Load a specific cache at filename if it exists.

=cut
sub loadCache
{
	my ($self, $filename) = @_;
	if($self->{'Cache'}->{$filename}) {
		warn "DIR,Cache,load DONE $filename\n" if $ENV{'DIR_DEBUG'};
		$self->{'Cache'}->{$filename}->{'fromCache'} = 1;
		return $self->{'Cache'}->{$filename};
	} else {
		warn "DIR,Cache,load FAILED $filename\n" if $ENV{'DIR_DEBUG'};
		return;
	}
}

=head2 I<$dir>->path( )

  Returns this directories full path.

=cut
sub path
{
	my ($self) = @_;
	return $self->{'Directory'};
}

=head2 I<$dir>->name( )

  Returns this folders name.

=cut
sub name
{
	my ($self) = @_;
	my $path = $self->path();
	($self->{'Name'}) = $path =~ /([^\/]+)\/*$/ if not $self->{'Name'};
	return $self->{'Name'};
}

=head2 I<$dir>->mkpath( $directory )

  Create a directory and all parents from this directory.

=cut
sub mkpath
{
	my ($self, $newdir) = @_;

	my @dirs = split('/', $newdir);
	my $path = $newdir =~ /^\// ? '/' : $self->path;

	foreach my $dir (@dirs)
	{
		if($dir and not -d $path.$dir)
		{
			warn "file: Creating directory '$path$dir'\n" if $ENV{'DIR_DEBUG'};
			if(mkdir($path.$dir))
			{
				$path = $path.$dir."/";
			} else {
				carp "file Error: Could not create directory '$path$dir' ($!)" if $ENV{'DIR_DEBUG'};
				return;
			}
		} else {
			$path = $path.$dir."/";
		}
	}

	return $self;
}

=head2 I<$dir>->prune( $path )

  Removes all empty directories from path to this directory.

=cut
sub prune
{
	my ($self, $path) = @_;

	$path = '' if not $path;
	if($path !~ /^\//) {
		$path = $self->path.$path;
	}

	my @dirs = split('/', $path);
	my $removed = '';

	while(my $dir = pop(@dirs)) {
		if(-d $path) {
			if(rmdir($path)) {
				# Ensure the directory is no longer cached
				delete($Cache{$path});
				# A record of removal route
				$removed = $dir.'/'.$removed;
				# Next path to try and remove
				$path = join('/', @dirs);
			} else {
				last;
			}
		} else {
			carp "file Error: Could not prune directory '$path'";
            return;
		}
	}

	return $removed;
}

=head2 <$class>->useElements( $path, $elements )

  Should parts of the path or filename be replaced by a defined hash? (used by load, save, delete)

=cut
sub useElements
{
	my ($self, $path, $elements) = @_;

	carp "file Error: Filename is a required field\n" and return if not $path;
	$path =~ s/(?{$1} ? $elements->{$1} : "\$".$1 /eg;

	return $path;
}

=head2 I<$dir>->exist( %p )

  Does this directory or child exist.

=cut
sub exist {
	my ($self) = @_;
	return -d $self->path() ? 1 : 0;
}

=head2 <$dir>->parent( )

  Return a new directory object containing the parent directory.

=cut
sub parent
{
	my ($self) = @_;

	if($self->path =~ /^(.+)\/[^\/]+?\/$/)
	{
		my $newpath = $1;
		my $parent = Template::Direct::Directory->new( $newpath );
		return $parent;
	}
	return $self;
}

=head2 I<$dir>->list( %p )

  List all directories and files in this directory, load each as an object.

=cut
sub list
{
	my ($self, %p) = @_;

	my @results;
	opendir( LISTDIR, $self->path ) or return [];
	foreach my $dir (readdir( LISTDIR )) {
		if($dir ne "." and $dir ne "..") {
			push @results, $dir and next if $p{'Text'};
			push @results, $self->load( $dir );
		}
	}
	closedir( LISTDIR );
	return \@results;
}

=head2 I<$dir>->hlist( )

  Return a clean list of filename children.

=cut
sub hlist
{
	my ($self) = @_;
	my %results;
	foreach (@{$self->list}) {
		$results{$_->name} = $_;
	}
	return \%results;
}

=head2 I<$dir>->isfile( )

  Returns false

=cut
sub isfile { 0 }

=head2 I<$dir>->isdir( )

  Returns true

=cut
sub isdir { 1 }

=head1 OVERLOADED

=head2 I<$dir>->autoeq( $cmp )

  Compare directory location string.

=cut
sub autoeq { shift()->path() eq shift(); }

=head2 I<$dir>->autone( $cmp )

  Compare directory location string does not equal.

=cut
sub autone { shift()->path() ne shift(); }

=head2 I<$dir>->autoscalar( $cmp )

  Return path of this directory in string context.

=cut
sub autoscalar
{
    my ($self) = @_;
    return $self->path();
}

=head2 I<$dir>->autobool( $cmp )

  Does this directory exist when used in a boolean context.

=cut
sub autobool
{
    my ($self) = @_;
    my ($package) = caller;
    return $self->exist if $package ne ref($self);
    return $self;
}

=head1 AUTHOR

 Copyright, Martin Owens 2008, AGPL

=cut
1;