File Coverage

blib/lib/DataStore/CAS/FS/Exporter.pm

Criterion	Covered	Total	%
statement	63	125	50.4
branch	22	128	17.1
condition	2	36	5.5
subroutine	14	27	51.8
pod	3	6	50.0
total	104	322	32.3

package DataStore::CAS::FS::Exporter;
use 5.008;
use Moo;
use Try::Tiny;
use Carp;
use File::Spec::Functions 'catfile', 'catdir', 'splitpath', 'catpath';
use Fcntl ':mode';

our $VERSION= '0.011000';

# ABSTRACT: Copy files from DataStore::CAS::FS to real filesystem.


our %_flag_defaults;
BEGIN {
	%_flag_defaults= (
		die_on_unsupported    => 1,
		die_on_creation_error => 1,
		die_on_metadata_error => 1,
		utf8_filenames        => 1,
	);
	for (keys %_flag_defaults) {
		eval "sub $_ { \$_[0]{flags}{$_}= \$_[1] if \@_ > 1; \$_[0]{flags}{$_} }; 1" or die $@
	}
}
sub _flag_defaults {
	\%_flag_defaults;
}

has flags => ( is => 'rw', default => sub { {} } );
has unix_user_cache => ( is => 'rw', default => sub { {} } );
has unix_group_cache => ( is => 'rw', default => sub { {} } );


sub BUILD {
	my ($self, $args)= @_;
	my $flags= $self->flags;
	my $defaults= $self->_flag_defaults;
	for (keys %$defaults) {
		$flags->{$_}= delete $args->{$_}
			if exists $args->{$_};
		$flags->{$_}= $_flag_defaults{$_}
			unless defined $flags->{$_};
	}
	defined $defaults->{$_} || croak "Unknown flag: '$_'"
		for keys %$flags;
	$self->can($_) || croak "Unknown attribute: '$_'"
		for keys %$args;
}

sub export_tree {
	my ($self, $virt_path, $real_path)= @_;

	$virt_path->isa('DataStore::CAS::FS::Path')
		or croak "Virtual path must be an instance of DataStore::CAS::FS::Path";

	-e $real_path
		and croak "The destination path must not already exist";
	if (utf8::is_utf8($real_path)) {
		$self->utf8_filenames? utf8::encode($real_path) : utf8::downgrade($real_path);
	}
	$self->_extract_recursive($virt_path, $real_path);
	1;
}

sub _extract_recursive {
	my ($self, $src, $real_path)= @_;
	my $dirent= $src->dirent;
	my $dest_fh= $self->_create_dirent($dirent, $real_path);
	if ($dirent->type eq 'file') {
		# Copy file
		if (!defined $dirent->ref) {
			warn "File \"".$dirent->name."\" was not stored.  Exporting as empty file.\n";
		} elsif ($dirent->ref ne $src->filesystem->hash_of_null) {
			my $err;
			try {
				my $src_fh= $src->open;
				my ($buf, $got);
				while ($got= read($src_fh, $buf, 1024*1024)) {
					(print $dest_fh $buf) or die "write: $!\n";
				}
				defined $got or die "read: $!\n";
				close $src_fh or die "close: $!\n";
				close $dest_fh or die "close: $!\n";
			} catch {
				chomp( $err= "$_" );
			};
			$self->_handle_creation_error("copy to \"$real_path\": $err")
				if defined $err;
		}
	} elsif ($dirent->type eq 'dir') {
		for ($src->readdir) {
			my $sysname= "$_";
			$self->utf8_filenames? utf8::encode($sysname) : utf8::downgrade($sysname)
				if utf8::is_utf8($sysname);
			$self->_extract_recursive($src->path($_), File::Spec->catdir($real_path, $sysname))
		}
	}
	$self->_apply_metadata($dirent, $real_path);
}

sub _create_dirent {
	my ($self, $entry, $path)= @_;
	my $t= $entry->type;
	if ($t eq 'file') {
		open(my $dest_fh, '>:raw', $path)
			or $self->_handle_creation_error("open($path): $!");
		return $dest_fh;
	} elsif ($t eq 'dir') {
		mkdir $path
			or $self->_handle_creation_error("mkdir($path): $!");
	} elsif ($t eq 'symlink') {
		symlink $entry->ref, $path
			or $self->_handle_creation_error("symlink($path): $!");
	} elsif ($t eq 'blockdev' || $t eq 'chardev') {
		my ($major, $minor)= split /,/, $entry->ref;
		defined $major && length $major && defined $minor && length $minor
			or die "mknod($path): Invalid device notation \"".$entry->ref."\"\n";
		$self->_mknod($self, $path, $entry, $major, $minor);
	} elsif ($t eq 'pipe') {
		$self->_mknod($self, $path, $entry, 0, 0);
	} elsif ($t eq 'socket') {
		require Socket;
		my $sock;
		socket($sock, Socket::PF_UNIX(), Socket::SOCK_STREAM(), 0)
			&& bind($sock, sockaddr_un($path))
			or $self->_handle_creation_error("socket/bind($path): $!");
	} else {
		$self->_handle_creation_error("Unsupported directory entry type \"$t\" for $path");
	}
	return undef;
}

sub _apply_metadata {
	my ($self, $entry, $path)= @_;
	if (defined (my $mode= $entry->unix_mode)) {
		chmod($mode & ~Fcntl::S_IFMT(), $path)
			or $self->_handle_metadata_error("chmod($path): $!");
	}

	my ($uid, $gid)= ($entry->unix_uid, $entry->unix_gid);
	if (defined (my $u= $entry->unix_user)) {
		my $cache= $self->unix_user_cache;
		exists $cache->{$u}? (defined $cache->{$u} and ($uid= $cache->{$u}))
			: defined( $cache->{$u}= getgrnam($u) )? $uid= $cache->{$u}
			: $self->_handle_metadata_error("Can't resolve username '$u'");
	}
	if (defined (my $g= $entry->unix_group)) {
		my $cache= $self->unix_group_cache;
		exists $cache->{$g}? (defined $cache->{$g} and ($gid= $cache->{$g}))
			: defined( $cache->{$g}= getgrnam($g) )? $gid= $cache->{$g}
			: $self->_handle_metadata_error("Can't resolve username '$g'");
	}
	chown( (defined $uid? $uid : -1), (defined $gid? $gid : -1), $path )
		|| $self->_handle_metadata_error("chown($uid, $gid, $path): $!")
		if defined $uid || defined $gid;

	my $mtime= $entry->modify_ts;
	if (defined $mtime) {
		my $atime= $entry->access_ts;
		defined $atime or $atime= $mtime;
		utime($atime, $mtime, $path)
			or $self->_handle_metadata_error("utime($atime, $mtime, $path): $!");
	}
}

sub _handle_metadata_error {
	my ($self, $msg)= @_;
	die $msg."\n" if $self->{flags}{die_on_metadata_error};
	warn $msg."\n";
}

sub _handle_creation_error {
	my ($self, $msg)= @_;
	die $msg."\n" if $self->{flags}{die_on_creation_error};
	warn $msg."\n";
}

sub _mknod {
	my $fn= (try { require Unix::Mknod; 1; } catch { undef })? \&_mknod_perl
		: (`mknod --version` && $? == 0)? \&_mknod_system
		: \&_mknod_unsupported;
	no warnings 'redefine';
	*_mknod= $fn;
	goto $fn;
}

sub _mknod_perl {
	my ($self, $path, $entry, $major, $minor)= @_;
	my $mode= ($entry->type eq 'blockdev')? S_IFBLK|0600
		: ($entry->type eq 'chardev')? S_IFCHR|0600
		: ($entry->type eq 'pipe')? S_IFIFO|0600
		: die "Unsupported type ".$entry->type;
	0 == Unix::Mknod::mknod($path, $mode, Unix::Mknod::makedev($major, $minor))
		or $self->_handle_creation_error("mknod($path, $mode, ".Unix::Mknod::makedev($major, $minor)."): $!");
}

sub _mknod_system {
	my ($self, $path, $dirent, $major, $minor)= @_;
	if ($dirent->type eq 'pipe') {
		system('mkfifo', $path) == 0 || die "exec(mkfifo, $path): $!\n";
		$? == 0 || $self->_handle_creation_error("mkfifo($path) exited ".($? & 127? "on signal ".($? & 127) : "with ".($? >> 8)));
	} else {
		my $t= $dirent->type eq 'blockdev'? 'b' : 'c';
		system('mknod', $path, $t, $major, $minor) == 0 or die "exec(mknod, $path, $t, $major, $minor): $!\n";
		$? == 0 || $self->_handle_creation_error("mknod($path) exited ".($? & 127? "on signal ".($? & 127) : "with ".($? >> 8)));
	}
}

sub _mknod_unsupported {
	my ($self, $path)= @_;
	$self->die_on_unsupported?
		die "mknod($path): Module Unix::Mknod is not installed and mknod(1) is not in the PATH\n"
		: warn "Skipping mknod($path)\n";
}

1;

__END__