package ZnapZend::ZFS;
use Mojo::Base -base;
use Mojo::Exception;
use Mojo::IOLoop::ForkCall;
use Data::Dumper;
use inheritLevels;
### attributes ###
has debug => sub { 0 };
has noaction => sub { 0 };
has nodestroy => sub { 1 };
has oracleMode => sub { 0 };
has recvu => sub { 0 };
has compressed => sub { 0 };
has sendRaw => sub { 0 };
has skipIntermediates => sub { 0 };
has forbidDestRollback => sub { 0 };
has lowmemRecurse => sub { 0 };
has zfsGetType => sub { 0 };
has rootExec => sub { q{} };
has sendDelay => sub { 3 };
has connectTimeout => sub { 30 };
has propertyPrefix => sub { q{org.znapzend} };
has sshCmdArray => sub { [qw(ssh),
qw(-o batchMode=yes -o), 'ConnectTimeout=' . shift->connectTimeout] };
has mbufferParam => sub { [qw(-q -s 256k -W 600 -m)] }; #don't remove the -m as the buffer size will be added
has scrubInProgress => sub { qr/scrub in progress/ };
has zLog => sub {
my $stack = "";
for (my $i = 0; my @r = caller($i); $i++) { $stack .= "$r[1]:$r[2] $r[3]\n"; }
Mojo::Exception->throw('ZFS::zLog must be specified at creation time!' . "\n$stack");
};
has priv => sub { my $self = shift; [$self->rootExec ? split(/ /, $self->rootExec) : ()] };
### private functions ###
my $splitHostDataSet = sub {
return ($_[0] =~ /^(?:([^:\/]+):)?([^:]+|[^:@]+\@.+)$/);
};
my $splitDataSetSnapshot = sub {
return ($_[0] =~ /^([^\@]+)\@([^\@]+)$/);
};
my $shellQuote = sub {
my @return;
for my $group (@_){
my @args = @$group;
for (@args){
s/'/'"'"'/g;
}
push @return, join ' ', map {/^[-\/@=_0-9a-z]+$/i ? $_ : qq{'$_'}} @args;
}
return join '|', @return;
};
### private methods ###
my $buildRemoteRefArray = sub {
my $self = shift;
my $remote = shift;
if ($remote){
return [@{$self->sshCmdArray}, $remote, $shellQuote->(@_)];
}
return @_;
};
my $buildRemote = sub {
my $self = shift;
my @list = $self->$buildRemoteRefArray(@_);
return @{$list[0]};
};
my $scrubZpool = sub {
my $self = shift;
my $startstop = shift;
my $zpool = shift;
my $remote;
($remote, $zpool) = $splitHostDataSet->($zpool);
my @cmd = (@{$self->priv}, ($startstop ? qw(zpool scrub) : qw(zpool scrub -s)));
my @ssh = $self->$buildRemote($remote, [@cmd, $zpool]);
print STDERR '# ' . ($self->noaction ? "WOULD # " : "" ) . join(' ', @ssh) . "\n" if $self->debug;
system(@ssh) && Mojo::Exception->throw('ERROR: cannot '
. ($startstop ? 'start' : 'stop') . " scrub on $zpool") if !$self->noaction;
return 1;
};
### public methods ###
sub dataSetExists {
# Note: Despite the "dataset" in the name, this routine only asks about
# the "live datasets" (filesystem,volume) and not snapshots which are
# also a type of dataset in ZFS terminology. See snapshotExists() below.
my $self = shift;
my $dataSet = shift;
my $remote;
#just in case if someone asks to check '';
return 0 if !$dataSet;
($remote, $dataSet) = $splitHostDataSet->($dataSet);
my @ssh = $self->$buildRemote($remote, [@{$self->priv}, qw(zfs list -H -o name -t), 'filesystem,volume', $dataSet]);
print STDERR '# ' . join(' ', @ssh) . "\n" if $self->debug;
open my $dataSets, '-|', @ssh
or Mojo::Exception->throw('ERROR: cannot get datasets'
. ($remote ? " on $remote" : ''));
my @dataSets = <$dataSets>;
chomp(@dataSets);
return grep { $dataSet eq $_ } @dataSets;
}
sub snapshotExists {
my $self = shift;
# Note: this is a fully qualified name of dataset@snapshot ZFS object,
# not just the snapname. May also be with remote destination ID.
my $snapshot = shift;
my $quiet = shift; # Maybe we expect it to not be there?
if (!defined($quiet)) { $quiet = 0; }
my $quietStr = ( $quiet ? '2>/dev/null' : '');
my $remote;
#just in case if someone asks to check '';
return 0 if !$snapshot;
($remote, $snapshot) = $splitHostDataSet->($snapshot);
my @ssh = $self->$buildRemote($remote,
[@{$self->priv}, qw(zfs list -H -o name -t snapshot), $snapshot]);
print STDERR '# ' . join(' ', @ssh, $quietStr) . "\n" if $self->debug;
# FIXME : Find a way to really use $quietStr here safely... backticks?
open my $snapshots, '-|', @ssh
or Mojo::Exception->throw('ERROR: cannot get snapshots'
. ($remote ? " on $remote" : ''));
my @snapshots = <$snapshots>;
chomp(@snapshots);
return grep { $snapshot eq $_ } @snapshots;
}
sub listDataSets {
# Note: Despite the "dataset" in the name, this routine only asks about
# the "live datasets" (filesystem,volume) and not snapshots which are
# also a type of dataset in ZFS terminology. See listSnapshots() below.
my $self = shift;
my $remote = shift;
my $rootDataSets = shift; # May be not passed, or may be a string, or an array of strings
my $recurse = shift; # May be not passed => undef
my @ssh = $self->$buildRemote($remote, [@{$self->priv}, qw(zfs list -H -o name -t), 'filesystem,volume']);
# By default this lists all fs/vol datasets in the system
# Optionally we can ask for specific rootDataSets possibly with children
if (defined ($rootDataSets) && $rootDataSets) {
my @useRDS;
if ( (ref($rootDataSets) eq 'ARRAY') ) {
if (scalar(@$rootDataSets) > 0) {
push (@useRDS, @$rootDataSets);
}
} else {
# Assume string
if ($rootDataSets ne "") {
push (@useRDS, ($rootDataSets));
}
}
if (scalar(@useRDS) > 0) {
if (defined ($recurse) && $recurse) {
push (@ssh, qw(-r));
}
push(@ssh, @useRDS);
}
}
print STDERR '# ' . join(' ', @ssh) . "\n" if $self->debug;
open my $dataSets, '-|', @ssh
or Mojo::Exception->throw('ERROR: cannot get datasets'
. ($remote ? " on $remote" : ''));
my @dataSets = <$dataSets>;
chomp(@dataSets);
return \@dataSets;
}
sub listSnapshots {
my $self = shift;
my $dataSet = shift;
my $snapshotFilter = shift // qr/.*/;
my $lastSnapshotToSee = shift // undef; # Stop creation-ordered listing after registering this snapshot name - if there is one in the filtered selection
if (defined($lastSnapshotToSee)) {
if ($lastSnapshotToSee eq "") { $lastSnapshotToSee = undef; }
else { $lastSnapshotToSee =~ s/^.*\@// ; }
}
my $remote;
my @snapshots;
($remote, $dataSet) = $splitHostDataSet->($dataSet);
my @ssh = $self->$buildRemote($remote,
[@{$self->priv}, qw(zfs list -H -o name -t snapshot -s creation -d 1), $dataSet]);
print STDERR '# ' . join(' ', @ssh) . "\n" if $self->debug;
open my $snapshots, '-|', @ssh
or Mojo::Exception->throw("ERROR: cannot get snapshots on $dataSet");
while (my $snap = <$snapshots>){
chomp $snap;
if (defined($lastSnapshotToSee)) {
if ($snap =~ /^\Q$dataSet\E\@$lastSnapshotToSee$/) {
# Only add this name to list if it matches $snapshotFilter ...
push @snapshots, $snap if $snap =~ /^\Q$dataSet\E\@$snapshotFilter$/;
# ...but still stop iterating
$self->zLog->debug("listSnapshots() : for dataSet='$dataSet' snapshotFilter='$snapshotFilter' lastSnapshotToSee='$lastSnapshotToSee' matched '$snap' and stopping the iteration");
last;
}
}
next if $snap !~ /^\Q$dataSet\E\@$snapshotFilter$/;
push @snapshots, $snap;
}
@snapshots = map { ($remote ? "$remote:" : '') . $_ } @snapshots;
return \@snapshots;
}
sub extractSnapshotNames {
# Routines like listSnapshots() operate with fully qualified
# "dataset@snapname" strings as returned by ZFS. For some data
# matching we need to compare just the "snapname" lists.
my $self = shift;
my $array = shift; # Note: call with extractSnapshotNames(\@arrVarName) !
my @ret;
if (ref($array) eq 'ARRAY') {
if (scalar(@$array)) {
for (@$array) {
/\@(.+)$/ and push @ret, $1;
}
}
} else {
# return \@ret if (!$array);
# eval { return \@ret if ($array == 1); };
# String or unprocessed whitespace separated series?
#print STDERR "=== extractSnapshotNames:\n\tGOT '" . ref($array) . "', will recurse: " . Dumper($array) if $self->debug;
if ($array =~ m/\s+/) {
my @tmp = split(/\s+/, $array);
#print STDERR "=== extractSnapshotNames:\n\tTMP: " . Dumper(\@tmp) if $self->debug;
return $self->extractSnapshotNames(\@tmp);
}
return $self->extractSnapshotNames( [$array] );
}
#print STDERR "=== extractSnapshotNames:\n\tGOT '" . ref($array) . "': " . Dumper($array) . "\tMADE: " . Dumper(\@ret) if $self->debug;
return \@ret;
}
### Works:
# $self->zZfs->extractSnapshotNames( [ 'dsa@test1', 'dsa@test2', 'dsa@test3' ] );
# $self->zZfs->extractSnapshotNames('ds@test1 ds@test2
# ds@test3');
### Does not work;
# $self->zZfs->extractSnapshotNames( qw(dsq@test1 dsq@test2 dsq@test3) );
sub createDataSet {
my $self = shift;
my $dataSet = shift;
my $remote;
#just in case if someone asks to check '';
return 0 if !$dataSet;
($remote, $dataSet) = $splitHostDataSet->($dataSet);
my @ssh = $self->$buildRemote($remote,
[@{$self->priv}, qw(zfs create -p), $dataSet]);
print STDERR '# ' . ($self->noaction ? "WOULD # " : "" ) . join(' ', @ssh) . "\n" if $self->debug;
#return if 'noaction' or dataset creation successful
return 1 if $self->noaction || !system(@ssh);
#check if dataset already exists and therefore creation failed
return 0 if $self->dataSetExists($dataSet);
#creation failed and dataset does not exist, throw an exception
Mojo::Exception->throw("ERROR: cannot create dataSet $dataSet");
}
sub listSubDataSets {
my $self = shift;
my $hostAndDataSet = shift;
my @dataSets;
my ($remote, $dataSet) = $splitHostDataSet->($hostAndDataSet);
my @ssh = $self->$buildRemote($remote, [@{$self->priv}, qw(zfs list -H -r -o name -t), 'filesystem,volume', $dataSet]);
print STDERR '# ' . join(' ', @ssh) . "\n" if $self->debug;
open my $dataSets, '-|', @ssh
or Mojo::Exception->throw("ERROR: cannot get sub datasets on $dataSet");
while (my $task = <$dataSets>){
chomp $task;
next if $task !~ /^\Q$dataSet\E/;
push @dataSets, $task;
}
my @subDataSets = map { ($remote ? "$remote:" : '') . $_ } @dataSets;
return \@subDataSets;
}
sub createSnapshot {
my $self = shift;
my $hostAndDataSet = shift;
my @recursive = $_[0] ? ('-r') : ();
my ($remote, $dataSet) = $splitHostDataSet->($hostAndDataSet);
my @ssh = $self->$buildRemote($remote, [@{$self->priv}, qw(zfs snapshot), @recursive, $dataSet]);
print STDERR '# ' . ($self->noaction ? "WOULD # " : "" ) . join(' ', @ssh) . "\n" if $self->debug;
#return if 'noaction' or snapshot creation successful
return 1 if $self->noaction || !system(@ssh);
#check if snapshot already exists and therefore creation failed
return 0 if $self->snapshotExists($dataSet);
#creation failed and snapshot does not exist, throw an exception
Mojo::Exception->throw("ERROR: cannot create snapshot $dataSet");
}
sub destroySnapshots {
# known limitation: snapshots from subdatasets have to be
# destroyed individually on some ZFS implementations
my $self = shift;
my @toDestroy = ref($_[0]) eq "ARRAY" ? @{$_[0]} : ($_[0]);
my %toDestroy;
my ($remote, $dataSet, $snapshot);
my @recursive = $_[1] ? ('-r') : ();
#oracleMode: destroy each snapshot individually
if ($self->oracleMode){
my $destroyError = '';
for my $task (@toDestroy){
my ($remote, $dataSetPathAndSnap) = $splitHostDataSet->($task);
my ($dataSet, $snapshot) = $splitDataSetSnapshot->($dataSetPathAndSnap);
my @ssh = $self->$buildRemote($remote, [@{$self->priv}, qw(zfs destroy), @recursive, "$dataSet\@$snapshot"]);
print STDERR '# ' . (($self->noaction || $self->nodestroy) ? "WOULD # " : "") . join(' ', @ssh) . "\n" if $self->debug;
system(@ssh) and $destroyError .= "ERROR: cannot destroy snapshot $dataSet\@$snapshot\n"
if !($self->noaction || $self->nodestroy);
}
#remove trailing \n
chomp $destroyError;
Mojo::Exception->throw($destroyError) if $destroyError ne '';
return 1;
}
#combinedDestroy
for my $task (@toDestroy){
my ($remote, $dataSetPathAndSnap) = $splitHostDataSet->($task);
my ($dataSet, $snapshot) = $splitDataSetSnapshot->($dataSetPathAndSnap);
#tag local snapshots as 'local' so we have a key to build the hash
$remote = $remote || 'local';
exists $toDestroy{$remote} or $toDestroy{$remote} = [];
push @{$toDestroy{$remote}}, scalar @{$toDestroy{$remote}} ? $snapshot : "$dataSet\@$snapshot" ;
}
for $remote (keys %toDestroy){
#check if remote is flaged as 'local'.
my @ssh = $self->$buildRemote($remote ne 'local'
? $remote : undef, [@{$self->priv}, qw(zfs destroy), @recursive, join(',', @{$toDestroy{$remote}})]);
print STDERR '# ' . (($self->noaction || $self->nodestroy) ? "WOULD # " : "") . join(' ', @ssh) . "\n" if $self->debug;
system(@ssh) && Mojo::Exception->throw("ERROR: cannot destroy snapshot(s) $toDestroy[0]")
if !($self->noaction || $self->nodestroy);
}
return 1;
}
sub lastAndCommonSnapshots {
my $self = shift;
my $srcDataSet = shift;
my $dstDataSet = shift;
my $snapshotFilter = shift // qr/.*/;
my $lastSnapshotToSee = shift // undef; # Stop creation-ordered listing after registering this snapshot name - if there is one in the filtered selection
if (defined($lastSnapshotToSee)) {
if ($lastSnapshotToSee eq "") { $lastSnapshotToSee = undef; }
else { $lastSnapshotToSee =~ s/^.*\@// ; }
}
my $srcSnapshots = $self->listSnapshots($srcDataSet, $snapshotFilter, $lastSnapshotToSee);
my $dstSnapshots = $self->listSnapshots($dstDataSet, $snapshotFilter, $lastSnapshotToSee);
return (undef, undef, undef) if !scalar @$srcSnapshots;
# For default operations, snapshot name is the time-based pattern
my ($i, $snapName);
for ($i = $#{$srcSnapshots}; $i >= 0; $i--){
($snapName) = ${$srcSnapshots}[$i] =~ /^\Q$srcDataSet\E\@($snapshotFilter)/;
last if grep { /\@$snapName$/ } @$dstSnapshots;
}
### print STDERR "LASTCOMMON: i=$i snapName=$snapName\nSRC: " . Dumper($srcSnapshots) . "DST: ". Dumper($dstSnapshots) . "LastToSee: " . Dumper($lastSnapshotToSee) if $self->debug;
# returns: ($lastSrcSnapshotName, $lastCommonSnapshotName, $dstSnapCount)
return (
${$srcSnapshots}[-1],
( ($i >= 0 && grep { /\@$snapName$/ } @$dstSnapshots) ? ${$srcSnapshots}[$i] : undef),
scalar @$dstSnapshots
);
}
sub mostRecentCommonSnapshot {
# This is similar to lastAndCommonSnapshots() above, but considers not only
# the "live" information from a currently accessible destination, but as a
# fallback also the saved last-known-synced snapshot name.
my $self = shift;
my $srcDataSet = shift;
my $dstDataSet = shift;
my $dstName = shift; # name of the znapzend policy => property prefix
my $snapshotFilter = shift;
if (!defined($snapshotFilter) || !$snapshotFilter) {
$snapshotFilter = qr/.*/;
}
# We can recurse from sendRecvCleanup() when looking for protected children
# while preparing for a recursive cleanup of root backed-up source dataset.
# NOTE that it is then up to zfs command to either return only data for the
# snapshot named in the argument, or also same-named snapshots in children
# of the dataset this is a snapshot of, so this flag may be effectively
# ignored by OS.
my $recurse = shift; # May be not passed => undef
if (!defined($recurse)) {
$recurse = 0;
}
# We do not have callers for the "inherit" argument at this time.
# However we can have users replicating partial trees inheriting a policy.
# Current call stack for sendRecvCleanup (primary user of this routine)
# does not provide info whether this mode is used, so to be safer about
# deletion of "protected" last-known-synced snapshots, we consider both
# local and inherited values of the dst_X_synced flag, if present.
# See definition of recognized $inherit values for this context in
# getSnapshotProperties() code and struct inheritLevels.
my $inherit = shift; # May be not passed => undef
if (!defined($inherit)) {
# We leave defined but invalid values of $inherit to
# getSnapshotProperties() to figure out and complain,
# but for this routine's purposes set a specific default.
$inherit = new inheritLevels;
$inherit->zfs_local(1);
$inherit->zfs_inherit(1);
$inherit->snapshot_recurse_parent(1);
}
my ($lastSnapshot, $lastCommonSnapshot, $dstSnapCount);
### DEBUG: Uncomment next line to enforce going through getSnapshotProperties() below
#if(0)
{
local $@;
eval {
local $SIG{__DIE__};
($lastSnapshot, $lastCommonSnapshot, $dstSnapCount) = ($self->lastAndCommonSnapshots($srcDataSet, $dstDataSet, $snapshotFilter))[1];
};
if ($@){
if (blessed $@ && $@->isa('Mojo::Exception')){
$self->zLog->warn($@->message);
}
else{
$self->zLog->warn($@);
}
}
}
if (not $lastCommonSnapshot){
my $dstSyncedPropname = $dstName . '_synced';
my @dstSyncedProps = [$dstSyncedPropname, $dstName];
my $srcSnapshots = $self->listSnapshots($srcDataSet, $snapshotFilter);
my $i;
# Go from newest snapshot down in history and find the first one
# to have a "non-false" value (e.g. "1") in its $dstName . '_synced'
for ($i = $#{$srcSnapshots}; $i >= 0; $i--){
my $snapshot = ${$srcSnapshots}[$i];
my $properties = $self->getSnapshotProperties($snapshot, $recurse, $inherit, @dstSyncedProps);
if ($properties->{$dstName} and ($properties->{$dstName} eq $dstDataSet) and $properties->{$dstSyncedPropname}){
$lastCommonSnapshot = $snapshot;
last;
}
}
}
return $lastCommonSnapshot;
}
sub sendRecvSnapshots {
my $self = shift;
my $srcDataSet = shift;
my $dstDataSet = shift;
my $dstName = shift; # name of the znapzend policy => property prefix
my $mbuffer = shift;
my $mbufferSize = shift;
my $snapFilter = shift // qr/.*/;
# Limit creation-ordered listing after registering this snapshot name,
# (there may exist newer snapshots that would be not seen and replicated).
# For practical purposes, this can be used with --since=X mode to ensure
# that "X" exists on destination if it does not yet (note that if there
# are newer snapshots on destination, they would be removed to allow
# receiving "X", unless --forbidDestRollback is requested, in this case).
my $lastSnapshotToSee = shift // undef; # Stop creation-ordered listing after registering this snapshot name - if there is one in the filtered selection
if (defined($lastSnapshotToSee)) {
if ($lastSnapshotToSee eq "") { $lastSnapshotToSee = undef; }
else { $lastSnapshotToSee =~ s/^.*\@// ; }
}
# In certain cases, callers can set this argument to explicitly
# forbid (0), allow (1) or enforce if needed (2) a rollback of dest.
my $allowDestRollback = shift // undef;
if (!defined($allowDestRollback)) { $allowDestRollback = (!$self->sendRaw && !$self->forbidDestRollback) ; }
my @recvOpt = $self->recvu ? qw(-u) : ();
push @recvOpt, '-F' if $allowDestRollback;
my $incrOpt = $self->skipIntermediates ? '-i' : '-I';
my @sendOpt = $self->compressed ? qw(-Lce) : ();
push @sendOpt, '-w' if $self->sendRaw;
my $remote;
my $mbufferPort;
my $dstDataSetPath;
($remote, $dstDataSetPath) = $splitHostDataSet->($dstDataSet);
# As seen through filter:
# * Last existing snapshot on source,
# * Last common snapshot between source and this destination,
# * Overall count of snapshots on destination.
my ($lastSnapshot, $lastCommon, $dstSnapCount)
= $self->lastAndCommonSnapshots($srcDataSet, $dstDataSet, $snapFilter, $lastSnapshotToSee);
if (defined($lastSnapshotToSee)) {
$self->zLog->debug("sendRecvSnapshots() : " .
"for srcDataSet='$srcDataSet' srcDataSet='$srcDataSet' " .
"snapFilter='$snapFilter' lastSnapshotToSee='$lastSnapshotToSee' ".
"GOT: lastSnapshot='$lastSnapshot' " .
"lastCommon=" . ($lastCommon ? "'$lastCommon'" : "undef") . " " .
"dstSnapCount='$dstSnapCount'"
);
}
# We would set these source snapshot properties to mark that
# this snapshot has been delivered to destination, to keep the
# newest such snapshot if destination is unreachable currently.
my %snapshotSynced = (
$dstName, $dstDataSet,
$dstName . '_synced', 1
);
#nothing to do if no snapshot exists on source or if last common snapshot is last snapshot on source
return 1 if !$lastSnapshot;
if (defined $lastCommon && ($lastSnapshot eq $lastCommon)){
$self->setSnapshotProperties($lastCommon, \%snapshotSynced);
return 1;
}
#check if snapshots exist on destination if there is no common snapshot
#as this will cause zfs send/recv to fail
if (!$lastCommon and $dstSnapCount) {
if ($allowDestRollback == 2) {
# Asked to enforce if needed... is needed now
$self->zLog->warn('WARNING: snapshot(s) exist on destination, but '
. 'no common found on source and destination: was requested '
. 'to clean up destination ' . $dstDataSet . ' (i.e. destroy '
. 'existing snapshots that match the znapzend filter)');
# TOTHINK: Maybe a "zfs rollback" to the oldest dst snapshot
# and then removing it in one act is better for performance?
# Can be destructive for man-named snapshots (if any) though...
$self->destroySnapshots ($self->listSnapshots($dstDataSet, $snapFilter, undef));
# If there are any manually created snapshots, with names not
# matched by filter, `zfs recv -F` below would likely fail.
# Still it is up to admins/users then to clean what they made,
# we only mutilate automatically what we made automatically.
# Reevaluate what is there now and look at all snapshots,
# e.g. the manually named snapshots may be common to src
# and dst, to have a starting point for such resync
($lastSnapshot, $lastCommon, $dstSnapCount)
= $self->lastAndCommonSnapshots($srcDataSet, $dstDataSet, qr/.*/, $lastSnapshotToSee);
my $dstSnapCountAll = scalar($self->listSnapshots($dstDataSet, qr/.*/, undef));
# We do not throw/error here because snapshots may help sync
$self->zLog->warn('ERROR: some snapshot(s) not covered '
. 'by znapzend filter still exist on destination: '
. 'this should be judged and fixed by the sysadmin '
. '(i.e. destroy manually named snapshots); '
. 'the zfs send+receive would likely fail below!'
) if (!$lastCommon && $dstSnapCountAll>0);
} else {
Mojo::Exception->throw('ERROR: snapshot(s) exist on destination, but '
. 'no common found on source and destination: clean up destination '
. $dstDataSet . ' (i.e. destroy existing snapshots)');
}
}
($mbuffer, $mbufferPort) = split /:/, $mbuffer, 2;
my @cmd;
if ($lastCommon){
@cmd = ([@{$self->priv}, 'zfs', 'send', @sendOpt, $incrOpt, $lastCommon, $lastSnapshot]);
}
else{
@cmd = ([@{$self->priv}, 'zfs', 'send', @sendOpt, $lastSnapshot]);
}
#if mbuffer port is set, run in 'network mode'
if ($remote && $mbufferPort && $mbuffer ne 'off'){
my $recvPid;
my @recvCmd = $self->$buildRemoteRefArray($remote, [$mbuffer, @{$self->mbufferParam},
$mbufferSize, '-4', '-I', $mbufferPort], [@{$self->priv}, 'zfs', 'recv', @recvOpt, $dstDataSetPath]);
my $cmd = $shellQuote->(@recvCmd);
my $fc = Mojo::IOLoop::ForkCall->new;
$fc->run(
#receive worker fork
sub {
my $cmd = shift;
my $debug = shift;
my $noaction = shift;
print STDERR "# " . ($self->noaction ? "WOULD # " : "" ) . "$cmd\n" if $debug;
system($cmd)
&& Mojo::Exception->throw('ERROR: executing receive process') if !$noaction;
},
#arguments
[$cmd, $self->debug, $self->noaction],
#callback
sub {
my ($fc, $err) = @_;
$self->zLog->debug("receive process on $remote done ($recvPid)");
Mojo::Exception->throw($err) if $err;
}
);
#spawn event
$fc->on(
spawn => sub {
my ($fc, $pid) = @_;
$recvPid = $pid;
$remote =~ s/^[^@]+\@//; #remove username if given
$self->zLog->debug("receive process on $remote spawned ($pid)");
push @cmd, [$mbuffer, @{$self->mbufferParam}, $mbufferSize,
'-O', "$remote:$mbufferPort"];
$cmd = $shellQuote->(@cmd);
print STDERR "# " . ($self->noaction ? "WOULD # " : "" ) . "$cmd\n" if $self->debug;
return if $self->noaction;
my $retryCounter = int($self->connectTimeout / $self->sendDelay) + 1;
while ($retryCounter--){
#wait so remote mbuffer has enough time to start listening
sleep $self->sendDelay;
system($cmd) || last;
}
$retryCounter <= 0 && Mojo::Exception->throw("ERROR: cannot send snapshots to $dstDataSet"
. ($remote ? " on $remote" : ''));
}
);
#error event
$fc->on(
error => sub {
my ($fc, $err) = @_;
die $err;
}
);
#start forkcall event loop
$fc->ioloop->start if !$fc->ioloop->is_running;
}
else {
my @mbCmd = $mbuffer ne 'off' ? ([$mbuffer, @{$self->mbufferParam}, $mbufferSize]) : () ;
my $recvCmd = [@{$self->priv}, 'zfs', 'recv' , @recvOpt, $dstDataSetPath];
push @cmd, $self->$buildRemoteRefArray($remote, @mbCmd, $recvCmd);
my $cmd = $shellQuote->(@cmd);
print STDERR "# " . ($self->noaction ? "WOULD # " : "" ) . "$cmd\n" if $self->debug;
system($cmd) && Mojo::Exception->throw("ERROR: cannot send snapshots to $dstDataSetPath"
. ($remote ? " on $remote" : '')) if !$self->noaction;
}
$self->setSnapshotProperties($lastSnapshot, \%snapshotSynced);
return 1;
}
sub filterPropertyNames {
# This routine is a helper for getXproperties to allow easy passing of
# specific properties we are interested to `zfs get`, to optimize some
# code around that. As an input it can get either:
# * string that would be passed through as is (after some sanitization);
# * array of strings that would be concatenated into a comma-separated
# string with our name-space propertyPrefix (e.g. "org.znapzend:...")
# prepended if needed;
# * undef for defaulting to 'all'
# Returns a string safe to pass into `zfs get`
my $self = shift;
my $propnames = shift;
my $propertyPrefix = $self->propertyPrefix;
if ($propnames) {
if (ref($propnames) eq 'ARRAY') {
if (scalar(@$propnames) > 0) {
my $propstring = '';
for my $propname (@$propnames) {
next if !defined($propname);
chomp $propname;
if ($propname eq '') {
$self->zLog->warn("=== filterPropertyNames(): got an empty propname in array");
next;
}
if ($propname eq 'all') {
# TOTHINK: Note that this short-circuiting "as is"
# forbids a scenario where we would fetch all zfs
# properties to cache them, and then iterate looking
# that all specific names have been discovered.
# If such needs arise, redefine this here and in
# callers checking for 'all' to also handle split(',').
$self->zLog->warn("=== filterPropertyNames(): got an 'all' propname in array, any filtering will be moot");
return 'all';
}
if ( $propname =~ /^$propertyPrefix\:/ ) {
1; # no-op, all good, use as is
} elsif ( $propname =~ /:/ ) {
$self->zLog->warn("=== filterPropertyNames(): got a propname not from our namespace: $propname");
} else {
$propname = $propertyPrefix . ':' . $propname;
}
if ($propstring eq '') {
$propstring = $propname;
} else {
$propstring .= ',' . $propname;
}
}
$propnames = $propstring;
$propnames =~ s/[\s]+//g;
} else {
# Got an array, but it was empty
$propnames = undef; # default below
}
} else {
# Assume string, pass verbatim; strip whitespaces for safety
$propnames =~ s/[\s]+//g ;
}
}
if ( !(defined($propnames)) || !($propnames) || ($propnames eq '') ) {
$propnames = 'all';
}
return $propnames;
}
sub getDataSetProperties {
# This routine finds properties of datasets (filesystem, volume) that
# are name-spaced with our propertyPrefix (e.g. "org.znapzend:...")
my $self = shift;
my $dataSet = shift;
my $recurse = shift; # May be not passed => undef
my $inherit = shift; # May be not passed => undef
my @propertyList;
my $propertyPrefix = $self->propertyPrefix;
my @list;
$self->zLog->debug("=== getDataSetProperties():\n"
. "\trecurse=" . Dumper($recurse)
. "\tinherit=" . Dumper($inherit)
. "\tDS=" . Dumper($dataSet)
. "\tlowmemRecurse=" . $self->lowmemRecurse
) if $self->debug;
if (!defined($recurse)) {
$recurse = 0;
}
if (!defined($inherit)) {
$inherit = 0;
}
# Note: Before the recursive and multiple dataset support we either
# used the provided dataSet name "as is" trusting it exists (failed
# later if not), or called listDataSets() to list everything on the
# system from `zfs` (also ensuring stuff exists). So we still do.
# Before the recursive the @list must have had individual dataset
# names, passed directly, or subsequently recursively listed above,
# to assign into the discovered list elements. So no recursion was
# needed in the logic below. Now we recurse by default to call `zfs`
# as rarely as we can and so complete faster. However, on systems
# with too many datasets this can exhaust the memory available to
# the process, and/or time out. To defend against this, we optionally
# can fall back to a big list of individual dataset names found by
# recursive listDataSets() invocations instead.
#
# If both recurse and inherit are specified, behavior depends on
# the dataset(s) whose name is passed. If the dataset has a local
# or inherited-from-local backup plan, the recursion stops here.
# If it has no plan (e.g. pool root dataset), we should recurse and
# report all children with a "local" backup plan (ignore inherit).
# Note that listDataSets(), optionally used below for either full
# or selective listing of datasets seen by the system, does not
# have a say in this dilemma ("zfs list" does not care about the
# "source" of a property, only "zfs get" used in this routine does).
#
if (defined($dataSet) && $dataSet) {
if (ref($dataSet) eq 'ARRAY') {
$self->zLog->debug("=== getDataSetProperties(): Is array...") if $self->debug;
if ($self->lowmemRecurse && $recurse) {
my $listds = $self->listDataSets(undef, $dataSet, $recurse);
if (scalar(@{$listds}) == 0) {
$self->zLog->debug("=== getDataSetProperties(): Failed to get data from listDataSets()") if $self->debug;
return \@propertyList;
}
push (@list, @{$listds});
$recurse = 0;
$inherit = 0;
} else {
if ( (scalar(@$dataSet) > 0) && (defined(@$dataSet[0])) ) {
push (@list, @$dataSet);
} else {
$self->zLog->debug("=== getDataSetProperties(): skip array context: value(s) inside undef...") if $self->debug;
}
}
} else {
# Assume a string, per usual invocation
$self->zLog->debug("=== getDataSetProperties(): Is string...") if $self->debug;
if ($self->lowmemRecurse && $recurse) {
my $listds = $self->listDataSets(undef, $dataSet, $recurse);
if (scalar(@{$listds}) == 0) {
$self->zLog->debug("=== getDataSetProperties(): Failed to get data from listDataSets()") if $self->debug;
return \@propertyList;
}
push (@list, @{$listds});
$recurse = 0;
$inherit = 0;
} else {
if ($dataSet ne '') {
push (@list, ($dataSet));
} else {
$self->zLog->debug("=== getDataSetProperties(): skip string context: value inside is empty...") if $self->debug;
}
}
}
} else {
$self->zLog->debug("=== getDataSetProperties(): no dataSet argument passed") if $self->debug;
}
if (scalar(@list) == 0) {
$self->zLog->debug("=== getDataSetProperties(): List all local datasets on the system...") if $self->debug;
my $listds = $self->listDataSets();
if (scalar(@{$listds}) == 0) {
$self->zLog->debug("=== getDataSetProperties(): Failed to get data from listDataSets()") if $self->debug;
return \@propertyList;
}
push (@list, @{$listds});
$recurse = 0;
$inherit = 0;
}
# Iterate every dataset pathname found above, e.g.:
# * (no args/empty/undef arg) all filesystem/volume datasets on all locally
# imported pools, and now recurse==0 and inherit==0 is enforced
# * (with args and with recursion originally, but lowmemRecurse enabled)
# one or more filesystem/volume named datasets and their children found
# via zfs list, and now recurse==0 and inherit==0 is enforced
# * (finally) one or more named datasets from args, with recursion and
# inheritance settings to be processed below
# Depending on inherit (and each dataset referenced in $listElem), pick
# either datasets that have a backup plan in their arguments with a
# "local" source, or those that have one inherited from a local (stop
# at a topmost such then).
# TODO/FIXME: There may be no support for new backup plan definitions
# inside a tree that has one above, and/or good grounds for conflicts.
my %cachedInheritance; # Cache datasets that we know to define znapzend attrs (if inherit mode is used)
for my $listElem (@list){
$self->zLog->debug("=== getDataSetProperties(): Looking under '$listElem' with "
. "zfsGetType='" . $self->zfsGetType . "', "
. "'$recurse' recursion mode and '$inherit' inheritance mode")
if $self->debug;
my %properties;
# TODO : support "inherit-from-local" mode
my @cmd = (@{$self->priv}, qw(zfs get -H));
if ($recurse) {
push (@cmd, qw(-r));
}
if ($inherit) {
push (@cmd, qw(-s), 'local,inherited');
} else {
push (@cmd, qw(-s local));
}
if ($self->zfsGetType) {
push (@cmd, qw(-t), 'filesystem,volume');
}
push (@cmd, qw(-o), 'name,property,value,source', 'all', $listElem);
print STDERR '# ' . join(' ', @cmd) . "\n" if $self->debug;
# Really a rare event, not to confuse with just
# getting no properties or bad zfs CLI args
open my $props, '-|', @cmd or Mojo::Exception->throw("ERROR: could not execute zfs to get properties from $listElem");
# NOTE: Code below assumes that the listing groups all items of one dataset together
my $prev_srcds = "";
my $prevSkipped_srcds = "";
while (my $prop = <$props>){
chomp $prop;
if ( (!$self->zfsGetType) && ($prop =~ /^\S+@\S+\s/) ) {
# Filter away snapshot properties ASAP
#$self->zLog->debug("=== getDataSetProperties(): SKIP: '$prop' "
# . "because it is a snapshot property") if $self->debug;
next;
}
# NOTE: This regex assumes the dataset names do not have trailing whitespaces
my ($srcds, $key, $value, $sourcetype, $tail) = $prop =~ /^(.+)\s+\Q$propertyPrefix\E:(\S+)\s+(.+)\s+(local|inherited from )(.*)$/ or next; ### |received|default|-
# If we are here, the property name (key) is under $propertyPrefix
# namespace. So this dataset has at least one "interesting" prop...
# Check if we have inherit mode and should spend time
# and memory about cached data (selective trimming)
if ($inherit && $sourcetype ne 'local') {
# We should trim (non-local) descendants of a listed dataset
# so as to not define the whole world as if having explicit
# backup plans configured
if (defined($cachedInheritance{"$srcds\tattr:source"})) {
# We've already seen a line of this and decided to skip it
if ($prevSkipped_srcds ne $srcds && $self->debug) {
$self->zLog->debug("=== getDataSetProperties(): SKIP: '$srcds' "
. "because it is already skipped");
}
$prevSkipped_srcds = $srcds;
next;
}
my $srcdsParent = $srcds;
$srcdsParent =~ s,/[^/]+$,,; # chop off the tail (if any - none on root datasets)
if (defined($cachedInheritance{"$srcdsParent\tattr:source"})) {
if ($prevSkipped_srcds ne $srcds && $self->debug) {
# Even if we recurse+inherit, we do not need to return
# dozens of backup configurations, one for each child.
# The backup activity would recurse from the topmost.
$self->zLog->debug("=== getDataSetProperties(): SKIP: '$srcds' "
. "because parent config '$srcdsParent' is already listed ("
. $cachedInheritance{"$srcdsParent\tattr:source"} .")");
}
$cachedInheritance{"$srcds\tattr:source"} = "${sourcetype}${tail}";
$prevSkipped_srcds = $srcds;
# TODO/THINK: Do we assume that a configured dataset has ALL fields
# "local" via e.g. znapzendzetup, or if in case of recursion we can
# have a mix of inherited and local? Sounds probable for "enabled"
# property at least. Maybe we should not chop this away right here,
# but do a smarter analysis below in SAVE/SAVE-LAST blocks instead.
%properties = ();
next;
}
}
$self->zLog->debug("=== getDataSetProperties(): FOUND: '$srcds' => '$key' == '$value' (source: '${sourcetype}${tail}')") if $self->debug;
if ($srcds ne $prev_srcds) {
if (%properties && $prev_srcds ne ""){
# place source dataset on list, too. so we know where the properties are from...
$self->zLog->debug("=== getDataSetProperties(): SAVE: '$prev_srcds'") if $self->debug;
$properties{src} = $prev_srcds;
# Note: replacing %properties completely proved hard,
# it just pushed references to same object for many
# really-found datasets. So we make unique copies and
# push them instead.
my %newProps = %properties;
push @propertyList, \%newProps;
%properties = ();
if ($inherit) {
# We've just had a successful save of 1+ attrs we chose
# to keep, so should trim descendants above.
# TODO: Track somehow else? We effectively save the
# source of last seen property here, but are really
# interested if this dataset is end of tree walk
# (as far as non-local attrs go)...
# TODO! Even worse, we now check the new line's source
# type and tail, not the prev-dataset's ones. It doesn't
# matter much at the moment, as we now only care about it
# being set, but can matter after TODO/THINK note above.
$cachedInheritance{"$prev_srcds\tattr:source"} = "${sourcetype}${tail}";
}
}
$prev_srcds = $srcds;
}
# We are okay to use this dataset if:
# * sourcetype == local (any inheritance value)
# * sourcetype == inherited* and the tail names a dataset whose value for the property is local (and inheritance is allowed)
# A bit of optimization (speed vs mem tradeoff) is to cache seen
# property sources (as magic int values); do not bother if not in
# inheritance mode at all.
my $inheritKey = "$srcds\t$key"; # TODO: lowmemInherit => "$srcds" ?
if ($inherit) {
if (!defined($cachedInheritance{$inheritKey})) {
if ($sourcetype eq 'local') {
# this DS defines this property
$cachedInheritance{$inheritKey} = 1;
} else {
# inherited from something... technically there are other
# categories too (default, received) but we only care to
# not run "zfs get" in vain for known misses
$cachedInheritance{$inheritKey} = 2;
}
}
}
if ($sourcetype eq 'local') {
$properties{$key} = $value;
} else {
# Not a local...
# print STDERR "NAL: '$inherit' && '$sourcetype' eq 'inherited from ' && '$tail' ne ''\n" if $self->debug;
if ($inherit && $sourcetype eq 'inherited from ' && $tail ne '') {
my $tail_inheritKey = "$tail\t$key"; # TODO: lowmemInherit => "$tail" ?
if (!defined($cachedInheritance{$tail_inheritKey})) {
# Call zfs get for $tail, fetch all interesting attrs while at it
$self->zLog->debug("=== getDataSetProperties(): "
. "Looking for '$key' under inheritance source "
. "'$tail' to see if it is local there")
if $self->debug;
my @inh_cmd = (@{$self->priv}, qw(zfs get -H -s local));
if ($self->zfsGetType) {
push (@inh_cmd, qw(-t), 'filesystem,volume');
}
# TODO: here and in mock t/zfs, reduce to "-o name,property,source"
# or even "-o property,source" when zfsGetType is enabled
push (@inh_cmd, qw(-o), 'name,property,value,source',
'all', $tail);
print STDERR '## ' . join(' ', @inh_cmd) . "\n" if $self->debug;
open my $inh_props, '-|', @inh_cmd or Mojo::Exception->throw("ERROR: could not execute zfs to get properties from $tail");
while (my $inh_prop = <$inh_props>){
chomp $inh_prop;
if ( (!$self->zfsGetType) && ($inh_prop =~ /^\S+@\S+\s/) ) {
# Filter away snapshot properties ASAP
#$self->zLog->debug("=== getDataSetProperties(): SKIP: inherited '$inh_prop' "
# . "because it is a snapshot property") if $self->debug;
next;
}
my ($inh_srcds, $inh_key, $inh_value, $inh_sourcetype, $inh_tail) =
$inh_prop =~ /^(.+)\s+\Q$propertyPrefix\E:(\S+)\s+(.+)\s+(local|inherited from |received|default|-)(.*)$/
or next;
$self->zLog->debug("=== getDataSetProperties(): FOUND ORIGIN: '$inh_srcds' => '$inh_key' == '$inh_value' (source: '${inh_sourcetype}${inh_tail}')") if $self->debug;
my $inh_inheritKey = "$inh_srcds\t$inh_key"; # TODO: lowmemInherit => "$inh_srcds" ?
if ($inh_sourcetype eq 'local') {
# this DS defines this property
$cachedInheritance{$inh_inheritKey} = 1;
} else {
# inherited from something... technically there are other
# categories too (default, received) but we only care to
# not run "zfs get" in vain for known misses
$cachedInheritance{$inh_inheritKey} = 2;
}
}
# } else {
# print STDERR "NAL: '$tail_inheritKey' already defined: " . $cachedInheritance{$tail_inheritKey} . "\n" if $self->debug;
}
if (defined($cachedInheritance{$tail_inheritKey}) && 1 == $cachedInheritance{$tail_inheritKey}) {
# This property comes from a local source
if ( $key =~ /^dst_[^_]+$/ ) {
# Rewrite destination dataset name shifted same as
# this inherited source ($srcds) compared to its
# ancestor which the config is inherited from ($tail
# in the currently active sanity-checked conditions).
if ($srcds =~ /^$tail\/(.+)$/) {
$self->zLog->debug("=== getDataSetProperties(): Shifting destination name in config for dataset '$srcds' with configuration inherited from '$tail' : after '$value' will append '/$1'") if $self->debug;
$properties{$key} = $value . "/" . $1;
} else {
# Abort if we can not decide well (better sadly
# safe than very-sorry). Not sure if we can get
# here... maybe by some zfs clones and promotion?
die "The dataset '$srcds' with configuration inherited from '$tail' does not have the latter as ancestor, can't decide how to shift the destination dataset names";
}
} else {
$properties{$key} = $value;
}
}
} else {
# See some other $props...
next;
}
}
}
if (%properties){
# place source dataset on list, too. so we know where the properties are from...
# the last-used dataset is prev_srcds
$self->zLog->debug("=== getDataSetProperties(): SAVE LAST: '$prev_srcds'") if $self->debug;
$properties{src} = $prev_srcds;
my %newProps = %properties;
push @propertyList, \%newProps;
}
}
$self->zLog->debug("=== getDataSetProperties():\n\tCollected: " . Dumper(@propertyList) ) if $self->debug;
return \@propertyList;
}
sub setDataSetProperties {
my $self = shift;
my $dataSet = shift;
my $properties = shift;
my $propertyPrefix = $self->propertyPrefix;
return 0 if !$self->dataSetExists($dataSet);
for my $prop (keys %$properties){
#don't save source dataset as we know the source from the property location
#also don't save destination validity flags as they are evaluated 'on demand'
next if $prop eq 'src' || $prop =~ /^dst_[^_]+_valid$/;
next if !defined($prop);
next if !defined($properties->{$prop});
my @cmd = (@{$self->priv}, qw(zfs set), "$propertyPrefix:$prop=$properties->{$prop}", $dataSet);
print STDERR '# ' . ($self->noaction ? "WOULD # " : "" ) . join(' ', @cmd) . "\n" if $self->debug;
system(@cmd)
&& Mojo::Exception->throw("ERROR: could not set property $prop on $dataSet") if !$self->noaction;
}
return 1;
}
sub deleteDataSetProperties {
my $self = shift;
my $dataSet = shift;
my $propertyPrefix = $self->propertyPrefix;
return 0 if !$self->dataSetExists($dataSet);
my $properties = $self->getDataSetProperties($dataSet);
return 0 if !$properties->[0];
for my $prop (keys %{$properties->[0]}){
my @cmd = (@{$self->priv}, qw(zfs inherit), "$propertyPrefix:$prop", $dataSet);
print STDERR '# ' . ($self->noaction ? "WOULD # " : "" ) . join(' ', @cmd) . "\n" if $self->debug;
system(@cmd)
&& Mojo::Exception->throw("ERROR: could not reset property $prop on $dataSet") if !$self->noaction;
}
return 1;
}
sub getSnapshotProperties {
# This routine finds properties of snapshots that are name-spaced with
# our propertyPrefix (e.g. "org.znapzend:...")
# Note: this code originated as a clone of getDataSetProperties() but
# that routine grew a lot since then to support recursive, inherited,
# lowmem and other optional scenarios, and considering dataSet arg as
# an array of names. Some of those traits may get ported here at least
# for consistency, where they make sense for ZFS snapshot dataset type.
my $self = shift;
my $snapshot = shift;
# NOTE that it is then up to zfs command to either return only data for the
# snapshot named in the argument, or also same-named snapshots in children
# of the dataset this is a snapshot of, so this flag may be effectively
# ignored by OS, or even actively rejected.
# TODO: Make magic like for inherit below, to drill into same-named
# snapshots of datasets that are children of one that $snapshot is a
# zfs snapshot of.
my $recurse = shift; # May be not passed => undef
# NOTE that some versions of zfs do not inherit values from same-named
# snapshot of a parent dataset, but only from a "real" dataset higher
# in the data hierarchy, so the "-s inherit" argument may be effectively
# ignored by OS for the purposes of *such* inheritance. Reasonable modes
# of sourcing properties include:
# 0 = only local
# 1 = local + inherit as defined by zfs
# 2 = local + recurse into parent that has same snapname
# 3 = local + inherit as defined by zfs + recurse into parent
# See struct inheritLevels for reusable definitions.
my $inherit = shift; # May be not passed => undef => will make a new inheritLevels instance below
# Limit the request to `zfs get` to only pick out certain properties
# and save time not-processing stuff the caller will ignore?..
my $propnames = shift; # May be not passed => undef
$propnames = $self->filterPropertyNames($propnames); # Returns a string to pass into `zfs get`
$self->zLog->debug("=== getSnapshotProperties():\n"
. "\trecurse=" . Dumper($recurse)
. "\tinherit=" . Dumper($inherit)
. "\tsnapshot=" . Dumper($snapshot)
. "\tpropnames=" . Dumper($propnames)
# . "\tlowmemRecurse=" . $self->lowmemRecurse
) if $self->debug;
if (!defined($recurse)) {
$recurse = 0;
}
if (!defined($inherit)) {
$inherit = new inheritLevels;
$inherit->zfs_local(1);
} else {
# Data type check
if ( ! $inherit->isa('inheritLevels') ) {
$self->zLog->warn("getSnapshotProperties(): inherit argument is not an instance of struct inheritLevels");
my $newInherit = new inheritLevels;
if (!$newInherit->reset($inherit)) {
# caller DID set something, so set a default... local_zfsinherit
$newInherit->zfs_local(1);
$newInherit->zfs_inherit(1);
}
$inherit = $newInherit;
}
}
my $inhMode = $inherit->getInhMode();
my %properties;
my %propertiesInherited;
my $propertyPrefix = $self->propertyPrefix;
my @cmd = (@{$self->priv}, qw(zfs get -H));
if ($recurse) {
push (@cmd, qw(-r));
}
if ($inhMode ne '') {
push (@cmd, qw(-s), $inhMode);
}
if ($self->zfsGetType) {
push (@cmd, qw(-t snapshot));
}
push (@cmd, qw(-o), 'property,value,source', $propnames, $snapshot);
print STDERR '# ' . join(' ', @cmd) . "\n" if $self->debug;
open my $props, '-|', @cmd or Mojo::Exception->throw('ERROR: could not get zfs properties of ' . $snapshot);
while (my $prop = <$props>){
chomp $prop;
my ($key, $value, $sourcetype, $tail) = $prop =~ /^\Q$propertyPrefix\E:(\S+)\s+(.+)\s+(local|inherited from |received|default|-)(.*)$/ or next;
if ($inherit->zfs_inherit and $inherit->snapshot_recurse_parent and $sourcetype =~ /inherited from/) {
# If we are not doing "snapshot_recurse_parent" then either it
# is okay to put all values into one bucket initially, or we
# run on a system where "zfs get" does the snapshot property
# inheritance the way we need it to here, so manual iteration
# is not needed (TODO: Make it a user selectable feature).
# This also impacts the precedence of values set in a snapshot
# or its recursed same-named snapshots of parent dataset(s)
# over values that "zfs get" reports as "inherited" (lowest prio).
# Note we should not have any hits here if zfs_inherit mode
# is not enabled in the first place, so we filter by that too.
$propertiesInherited{$key} = $value;
} else {
$properties{$key} = $value;
}
}
my $numProps = keys %properties;
if ($self->debug) {
if ($numProps > 0) {
$self->zLog->debug("=== getSnapshotProperties(): GOT '$inhMode' properties of $snapshot : " .Dumper(\%properties) );
}
}
if ($inherit->snapshot_recurse_parent) {
# For the context we have, inheriting means that we recursively go
# up through parent datasets that have same-named snapshots as this
# one, and check if these snapshots have locally defined properties.
# The value defined nearest to current snapshot is most preferred,
# so we do not check those "parent snapshots" for what they could
# have inherited from "real datasets" => will recurse with mode "2".
# TOTHINK: Is there a loophole for properties defined by some higher
# level "real" datasets vs. redefinitions in nearer-level snapshots?
# Perhaps we should first iterate for properties locally defined in
# a same-named snapshot at some layer of the zfs tree, and only then
# append what the current (top) target inherits into spots not yet
# known?
# First check if we SHOULD recurse, or if from this dataset we have
# got all the data we were looking for? Probably it is only useful
# for getting one named property, or if several are named at once
# by code elsewhere, but still...
if ( ($propnames ne 'all') && ($numProps > 0) ) {
# Note that here we only check for our name-spaced properties!
my @wantedPropnames = grep { /^$propertyPrefix:/ } split(',', $propnames);
for (@wantedPropnames) {
s/^$propertyPrefix:// ;
}
# we want to see uniq items, if someone listed same thing twice:
my %seenPropnames = map{$_ => 0} @wantedPropnames;
@wantedPropnames = keys %seenPropnames;
$self->zLog->debug("=== getSnapshotProperties(): check wantedPropnames: " .
Dumper(@wantedPropnames) . " vs collected properties: " .
Dumper(keys %properties)
) if $self->debug;
if (scalar(@wantedPropnames) == $numProps) {
# We look for certain property names, and we have the same
# amount of items in %properties hash, let's dig deeper...
### `use v5.10.1;` or newer for ~~ smartmatch operator
### Still warns about experimental perl feature in 5.22...
#if ($] >= 5.010001) {
# if (@wantedPropnames ~~ \%properties) {
# $inherit->reset('zfs_local');
# }
#} else {
# Old ways...
my $uniqHits = 0;
for my $key (keys %properties) {
if (defined($seenPropnames{$key})) {
if ($seenPropnames{$key} == 0) {
$uniqHits++;
}
$seenPropnames{$key}++;
}
}
if ($uniqHits == $numProps) {
$inherit->reset('zfs_local');
}
#}
}
}
if (!$inherit->snapshot_recurse_parent) {
$self->zLog->debug("=== getSnapshotProperties(): Stopping recursion after $snapshot, we have all the properties we needed") if $self->debug;
}
}
if ($inherit->snapshot_recurse_parent) {
my $parentSnapshot = $snapshot;
$parentSnapshot =~ s/^(.*)\/[^\/]+(\@.*)$/$1$2/;
#$self->zLog->debug("=== getSnapshotProperties(): consider iterating from $snapshot up to $parentSnapshot") if $self->debug;
if ($parentSnapshot ne $snapshot) {
# Check quietly
if ($self->snapshotExists($parentSnapshot, 1)) {
# Go up to root of the pool, without recursing into other children
# of the parent datasets/snapshots, and without inheriting stuff
# that is not locally defined properties of a parent (or its parent).
my $inherit_local_recurseparent = new inheritLevels;
$inherit_local_recurseparent->snapshot_recurse_parent(1);
$inherit_local_recurseparent->zfs_local(1);
my $parentProperties = $self->getSnapshotProperties($parentSnapshot, 0, $inherit_local_recurseparent, $propnames);
my $numParentProps = keys %$parentProperties;
if ($numParentProps > 0) {
# Merge hash arrays, use existing values as overrides in
# case of same-name conflict:
$self->zLog->debug("=== getSnapshotProperties(): Merging two property lists from '$parentSnapshot' and '$snapshot' :\n" .
"\t" . Dumper(\%$parentProperties) .
"\t" . Dumper(\%properties)
) if $self->debug;
%properties = (%$parentProperties, %properties);
$self->zLog->debug("=== getSnapshotProperties(): Merging returned one property list : " .
Dumper(\%properties) ) if $self->debug;
}
} else {
$self->zLog->debug("=== getSnapshotProperties(): Stopping recursion after $snapshot, a $parentSnapshot does not exist") if $self->debug;
}
} # else Got to root, and it was inspected above
}
my $numPropertiesInherited = keys %propertiesInherited;
if ($numPropertiesInherited > 0) {
$self->zLog->debug("=== getSnapshotProperties(): Merging two property lists - collected from '$snapshot' and same-named snapshots of parent datasets, and what ZFS claims as inherited from ancestors :\n" .
"\t" . Dumper(\%properties) .
"\t" . Dumper(\%propertiesInherited)
) if $self->debug;
# Inherited values have lower priority than those local to snapshot or its parents
%properties = (%propertiesInherited, %properties);
$self->zLog->debug("=== getSnapshotProperties(): Merging returned one property list : " .
Dumper(\%properties) ) if $self->debug;
}
return \%properties;
}
sub setSnapshotProperties {
my $self = shift;
my $snapshot = shift;
my $properties = shift;
my $propertyPrefix = $self->propertyPrefix;
return 0 if !$self->snapshotExists($snapshot);
for my $prop (keys %$properties){
my @cmd = (@{$self->priv}, qw(zfs set), "$propertyPrefix:$prop=$properties->{$prop}", $snapshot);
print STDERR '# ' . ($self->noaction ? "WOULD # " : "" ) . join(' ', @cmd) . "\n" if $self->debug;
system(@cmd)
&& Mojo::Exception->throw("ERROR: could not set property $prop on $snapshot") if !$self->noaction;
}
return 1;
}
sub deleteBackupDestination {
my $self = shift;
my $dataSet = shift;
my $dst = $self->propertyPrefix . ':' . $_[0];
return 0 if !$self->dataSetExists($dataSet);
my @cmd = (@{$self->priv}, qw(zfs inherit), $dst, $dataSet);
print STDERR '# ' . ($self->noaction ? "WOULD # " : "" ) . join(' ', @cmd) . "\n" if $self->debug;
system(@cmd)
&& Mojo::Exception->throw("ERROR: could not reset property on $dataSet") if !$self->noaction;
@cmd = (@{$self->priv}, qw(zfs inherit), $dst . '_plan', $dataSet);
print STDERR '# ' . ($self->noaction ? "WOULD # " : "" ) . join(' ', @cmd) . "\n" if $self->debug;
system(@cmd)
&& Mojo::Exception->throw("ERROR: could not reset property on $dataSet") if !$self->noaction;
return 1;
}
sub fileExistsAndExec {
my $self = shift;
my $filePath = shift;
my $remote;
($remote, $filePath) = $splitHostDataSet->($filePath);
my @ssh = $self->$buildRemote($remote, [@{$self->priv}, qw(test -x), $filePath]);
print STDERR '# ' . join(' ', @ssh) . "\n" if $self->debug;
return !system(@ssh);
}
sub listPools {
my $self = shift;
my $remote = shift;
my @ssh = $self->$buildRemote($remote, [@{$self->priv}, qw(zpool list -H -o name)]);
print STDERR '# ' . join(' ', @ssh) . "\n" if $self->debug;
open my $zPools, '-|', @ssh
or Mojo::Exception->throw('ERROR: cannot get zpools' . ($remote ? " on $remote" : ''));
my @zPools = <$zPools>;
chomp(@zPools);
return \@zPools;
}
sub startScrub {
my $self = shift;
#zpool is second argument
return $self->$scrubZpool(1, @_);
}
sub stopScrub {
my $self = shift;
#zpool is second argument
return $self->$scrubZpool(0, @_);
}
sub zpoolStatus {
my $self = shift;
my $zpool = shift;
my $remote;
($remote, $zpool) = $splitHostDataSet->($zpool);
my @ssh = $self->$buildRemote($remote,
[@{$self->priv}, qw(env LC_MESSAGES=C LC_DATE=C zpool status -v), $zpool]);
print STDERR '# ' . join(' ', @ssh) . "\n" if $self->debug;
open my $zpoolStatus, '-|', @ssh or Mojo::Exception->throw("ERROR: cannot get status of $zpool");
my @status = <$zpoolStatus>;
chomp(@status);
return \@status;
}
sub scrubActive {
my $self = shift;
#zpool is second argument
my $scrubProgress = $self->scrubInProgress;
return grep { /$scrubProgress/ } @{$self->zpoolStatus(@_)};
}
sub usedBySnapshots {
my $self = shift;
my $dataSet = shift;
my $remote;
return 0 if !$dataSet;
($remote, $dataSet) = $splitHostDataSet->($dataSet);
my @ssh = $self->$buildRemote($remote,
[@{$self->priv}, qw(zfs get -H -o value usedbysnapshots), $dataSet]);
print STDERR '# ' . join(' ', @ssh) . "\n" if $self->debug;
open my $prop, '-|', @ssh
or Mojo::Exception->throw("ERROR: cannot get usedbysnapshot property of $dataSet");
my $usedBySnap = <$prop>;
chomp $usedBySnap if $usedBySnap;
return $usedBySnap // 0;
}
1;
__END__
=head1 NAME
ZnapZend::ZFS - zfs control object
=head1 SYNOPSIS
use ZnapZend::ZFS;
...
my $zfs = ZnapZend::ZFS->new(debug=>0, noaction=>0);
...
=head1 DESCRIPTION
this object makes zfs snapshot functionality easier to use
=head1 ATTRIBUTES
=head2 debug
print debug information to STDERR
=head2 noaction
do a dry run. no changes to the filesystem will be performed
=head2 nodestroy
runs does all changes to the filesystem *except* destroy
=head1 METHODS
=head2 dataSetExists
checks if the dataset exists on localhost or a remote host
=head2 snapshotExists
checks if the snapshot exists on localhost or a remote host
=head2 createDataSet
creates a dataset on localhost or a remote host
=head2 listDataSets
lists datasets on (remote-)host
=head2 listSnapshots
returns a list of all snapshots of the dataset
=head2 extractSnapshotNames
returns a list of all snapnames (tags after the "@" character) extracted
from provided array of "dataset@snapshot" values
=head2 listSubDataSets
returns a list of all subdataset including the dataset itself
=head2 createSnapshot
creates a snapshot on localhost or a remote host, optionally recursively
=head2 destroySnapshots
destroys a single snapshot or a list of snapshots on localhost or a remote host, optionally recursively
=head2 lastAndCommonSnapshots
lists the last snapshot on source and the last common snapshot an source and destination and the number of snapshots found on the destination host
=head2 mostRecentCommonSnapshot
gets the name of the most recent common snapshot between source and destination, first by trying to get the actual snapshots, then by checking the dst_*_synced property on each source snapshot if the destination is offline
=head2 sendRecvSnapshots
sends snapshots to a different destination on localhost or a remote host
=head2 getDataSetProperties
gets dataset (filesystem, volume) properties name-spaced with propertyPrefix
=head2 setDataSetProperties
sets dataset (filesystem, volume) properties name-spaced with propertyPrefix
=head2 deleteDataSetProperties
deletes dataset (filesystem, volume) properties name-spaced with propertyPrefix
by inheriting the value from parent (or un-defining the property if no parent
has it)
=head2 getSnapshotProperties
gets snapshot properties name-spaced with propertyPrefix
=head2 setSnapshotProperties
sets snapshot properties name-spaced with propertyPrefix
=head2 deleteBackupDestination
remove a backup destination from a backup plan
=head2 fileExistsAndExec
checks if a file exists and has the executable flag set on localhost or a remote host
=head2 listPools
lists zpools on localhost or a remote host
=head2 startScrub
starts scrub on a zpool
=head2 stopScrub
stops scrub on a zpool
=head2 zpoolStatus
returns status info of a zpool
=head2 scrubActive
returns whether scrub is active on zpool or not
=head2 usedBySnapshots
returns the amount of storage space used by snapshots of a specific dataset
=head1 COPYRIGHT
Copyright (c) 2014 by OETIKER+PARTNER AG. All rights reserved.
=head1 LICENSE
This program is free software: you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the Free
Software Foundation, either version 3 of the License, or (at your option)
any later version.
This program is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
more details.
You should have received a copy of the GNU General Public License along with
this program. If not, see L.
=head1 AUTHOR
Stobi@oetiker.chE>,
Shadfl@cpan.orgE>
=head1 HISTORY
2014-06-29 had Flexible snapshot time format
2014-06-10 had localtime implementation
2014-06-02 had zpool functionality added
2014-06-01 had Multi destination backup
2014-05-30 had Initial Version
=cut