File::System::Table - A file system implementation for mounting other modules

  use File::System;

  my $root = File::System->new('Table',
      '/'    => [ 'Real', root => '/home/foo' ],
      '/tmp' => [ 'Real', root => '/tmp' ],
      '/bin' => [ 'Real', root => '/bin' ],
  );

  my $file = $root->create('/tmp/dude', 'f');
  my $fh = $file->open('w');
  print $fh "Party on! Excellent!\n";
  close $fh;

package File::System::Table;

use strict;
use warnings;

use base 'File::System::Object';

use Carp;
use File::System;

our $VERSION = '1.15';

sub new {
	my $class = shift;

	$_[0] eq '/'
		or croak "The first mount point given must always be the root (/), but found '$_[0]' instead.";

	my $self = bless { cwd => '/' }, $class;

	while (my ($mp, $fs) = splice @_, 0, 2) {
		$self->mount($mp, $fs);
	}

	return $self;
}

sub mount {
	my $self = shift;
	my $path = $self->normalize_path(shift);
	my $fs   = $self->_init_fs(shift);

	if ($path eq '/') {
		if (defined $self->{mounts}) {
			croak "The root mount point cannot be overridden.";
		} else {
			$self->{cwd_fs} = $self->{mounts}{$path} = $fs;
		}
	} else {
		my $dir = $self->lookup($path);

		defined $dir
			or croak "The mount point '$path' does not exist.";

		$dir->is_container
			or croak "The mount point '$path' is not a container.";

		my @inner = grep /^$path/, keys %{ $self->{mounts} };
		croak "The mount point '$inner[0]' must be unmounted before mount point '$path' may be used."
			if @inner;

		$dir->has_children
			and carp "Mounting on mount point '$path' will hide some files.";

		$self->{mounts}{$path} = $fs;
	}
}

sub unmount {
	my $self = shift;
	my $path = $self->normalize_path(shift);

	$path eq '/'
		and croak "The root mount point cannot be unmounted.";

	defined $self->{mounts}{$path}
		or croak "No file system is mounted at '$path'. Therefore it cannot be unmounted.";

	my @inner = grep /^$path./, keys %{ $self->{mounts} };
	croak "Mount point '$inner[0]' must be unmounted before '$path'"
		if @inner;

	delete $self->{mounts}{$path};
}

sub mounts {
	my $self = shift;
	return keys %{ $self->{mounts} };
}

sub _init_fs {
	my $self = shift;
	my $fs   = shift;

	if (UNIVERSAL::isa($fs, 'File::System::Object')) {
		return $fs;
	} elsif (ref $fs eq 'ARRAY') {
		return File::System->new(@$fs);
	} else {
		croak "File system must be an array reference or an actual File::System::Object. '$fs' is neither of these. See the documentation of File::System::Table for details.";
	}
}

sub _resolve_fs {
	my $self = shift;
	my $path = $self->normalize_path(shift);

	# The mount point we want should be the longest one which matches our
	# given path name.
	my ($mp) = 
		sort { -(length($a) <=> length($b)) }
		grep { $path =~ /^$_/ }
		keys %{ $self->{mounts} };
	
	my $rel_path = substr $path, length($mp);
	$rel_path = '/'.$rel_path unless $rel_path =~ /^\//;

	return ($self->{mounts}{$mp}, $rel_path);
}

sub root {
	my $self = shift;

	return bless {
		cwd    => '/',
		cwd_fs => $self->{mounts}{'/'},
		mounts => $self->{mounts},
	}, ref $self;
}

sub exists {
	my $self = shift;
	my ($fs, $path) = $self->_resolve_fs(shift || $self->path);
	return $fs->exists($path);
}

sub lookup {
	my $self        = shift;
	my $cwd         = $self->normalize_path($_[0]);
	my ($fs, $path) = $self->_resolve_fs(shift);

	my $cwd_fs = $fs->lookup($path);

	return undef unless defined $cwd_fs;

	return bless {
		cwd    => $cwd,
		cwd_fs => $cwd_fs,
		mounts => $self->{mounts},
	}, ref $self;
}

my @delegates = qw/
	is_valid           
	properties         
	settable_properties
	set_property       
	remove             
	has_content        
	is_container       
	is_readable        
	is_seekable        
	is_writable        
	is_appendable      
	open               
	content            
	has_children       
	children_paths     
/;

for my $name (@delegates) {
	eval qq(
#line 287 "File::Sytem::Table ($name)"
sub $name {
		my \$self     = shift;
		return \$self->{cwd_fs}->$name(\@_);
}
);
	die $@ if $@;
}

sub get_property {
	my $self = shift;
	local $_ = shift;

	SWITCH: {
		/^path$/ && do {
			return $self->{cwd};
		};
		/^dirname$/ && do {
			return $self->dirname_of_path($self->{cwd});
		};
		/^basename$/ && do {
			return $self->basename_of_path($self->{cwd});
		};
		DEFAULT: {
			return $self->{cwd_fs}->get_property($_);
		}
	}
}

sub rename {
	my $self = shift;
	my $name = shift;

	grep { $self->{cwd} eq $_ } keys %{ $self->{mounts} }
		and croak "Cannot rename the mount point '$self'";

	$self->{cwd_fs}->rename($name);
	
	$self->{cwd} =~ s#[^/]+$ #$name#x;

	return $self;
}

sub move {
	my $self  = shift;
	my $path  = shift;
	my $force = shift;

	UNIVERSAL::isa($path, 'File::System::Table')
		or croak "Move failed; the '$path' object is not a 'File::System::Table'";

	$self->{cwd_fs}->move($path->{cwd_fs}, $force);
	$self->{cwd} = $self->normalize_path($path->path.'/'.$self->basename);

	return $self;
}

sub copy {
	my $self  = shift;
	my $path  = shift;
	my $force = shift;
	
	UNIVERSAL::isa($path, 'File::System::Table')
		or croak "Copy failed; the '$path' object is not a 'File::System::Table'";

	my $copy = $self->{cwd_fs}->copy($path->{cwd_fs}, $force);
	my $copy_cwd = $self->normalize_path($path->path.'/'.$self->basename);

	return bless {
		cwd_fs => $copy,
		cwd    => $copy_cwd,
		mounts => $self->{mounts},
	}, ref $self;
}
	
sub children {
	my $self = shift;
	return
		map { $self->lookup($_) }
		grep !/^\.\.?$/, $self->{cwd_fs}->children_paths;
}

sub child {
	my $self = shift;
	my $name = shift;

	$self->is_container
		or croak "The child method called on non-container.";

	$name !~ /\//
		or croak "Argument to child must not be a path.";

	return $self->lookup($name);
}

sub is_createable {
	my $self = shift;
	my $path = $self->normalize_path($_[0]);
	my ($fs, $rel_path) = $self->_resolve_fs(shift);
	my $type = shift;

	return $fs->is_creatable($rel_path, $type);
}

sub create {
	my $self = shift;
	my $path = $self->normalize_path($_[0]);
	my ($fs, $rel_path) = $self->_resolve_fs(shift);
	my $type = shift;

	my $obj = $fs->create($rel_path, $type);

	return undef unless defined $obj;

	return bless {
		cwd    => $path,
		cwd_fs => $obj,
		mounts => $self->{mounts},
	}, ref $self;
}

1