btrbk/btrbk

#!/usr/bin/perl -T

=head1 NAME

btrbk - backup tool for btrfs volumes

=head1 SYNOPSIS

    btrbk --help

=head1 DESCRIPTION

Backup tool for btrfs subvolumes, taking advantage of btrfs specific
send-receive mechanism, allowing incremental backups at file-system
level.

The full btrbk documentation is available at L<http://www.digint.ch/btrbk>.

=head1 AUTHOR

Axel Burri <axel@tty0.ch>

=head1 COPYRIGHT AND LICENSE

Copyright (c) 2014-2015 Axel Burri. All rights reserved.

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 <http://www.gnu.org/licenses/>.

=cut

use strict;
use warnings FATAL => qw( all );

use Carp qw(confess);
use Date::Calc qw(Today Delta_Days Day_of_Week);
use Getopt::Std;
use Data::Dumper;

our $VERSION       = "0.11-dev";
our $AUTHOR        = 'Axel Burri <axel@tty0.ch>';
our $PROJECT_HOME  = '<http://www.digint.ch/btrbk>';

my $version_info   = "btrbk command line client, version $VERSION";

my @config_src = ("/etc/btrbk.conf", "/etc/btrbk/btrbk.conf");

my %day_of_week_map = ( monday => 1, tuesday => 2, wednesday => 3, thursday => 4, friday => 5, saturday => 6, sunday => 7 );

my %config_options = (
  # NOTE: the parser always maps "no" to undef
  # NOTE: keys "volume", "subvolume" and "target" are hardcoded
  snapshot_dir              => { default => undef,    accept_file => { relative => 1 }, append_trailing_slash => 1 },
  receive_log               => { default => undef,    accept => [ "sidecar", "no" ], accept_file => { absolute => 1 } },
  incremental               => { default => "yes",    accept => [ "yes", "no", "strict" ] },
  snapshot_create_always    => { default => undef,    accept => [ "yes", "no" ] },
  preserve_day_of_week      => { default => "sunday", accept => [ (keys %day_of_week_map) ] },
  snapshot_preserve_daily   => { default => "all",    accept => [ "all" ], accept_numeric => 1  },
  snapshot_preserve_weekly  => { default => 0,        accept => [ "all" ], accept_numeric => 1  },
  snapshot_preserve_monthly => { default => "all",    accept => [ "all" ], accept_numeric => 1  },
  target_preserve_daily     => { default => "all",    accept => [ "all" ], accept_numeric => 1  },
  target_preserve_weekly    => { default => 0,        accept => [ "all" ], accept_numeric => 1  },
  target_preserve_monthly   => { default => "all",    accept => [ "all" ], accept_numeric => 1  },
  btrfs_commit_delete       => { default => undef,    accept => [ "after", "each", "no" ] },
  ssh_identity              => { default => undef,    accept_file => { absolute => 1 } },
  ssh_user                  => { default => "root",   accept_regexp => qr/^[a-z_][a-z0-9_-]*$/ },
 );

my @config_target_types = qw(send-receive);

my %vol_info;
my %uuid_info;

my $dryrun;
my $loglevel = 1;

my $ip_addr_match = qr/(([0-9]|[1-9][0-9]|1[0-9]{2}|2[0-4][0-9]|25[0-5])\.){3}([0-9]|[1-9][0-9]|1[0-9]{2}|2[0-4][0-9]|25[0-5])/;
my $host_name_match = qr/(([a-zA-Z0-9]|[a-zA-Z0-9][a-zA-Z0-9\-]*[a-zA-Z0-9])\.)*([A-Za-z0-9]|[A-Za-z0-9][A-Za-z0-9\-]*[A-Za-z0-9])/;
my $file_match = qr/[0-9a-zA-Z_\-\.\/]+/;

$SIG{__DIE__} = sub {
  print STDERR "\nERROR: process died unexpectedly (btrbk v$VERSION)";
  print STDERR "\nPlease contact the author: $AUTHOR\n\n";
  print STDERR "Stack Trace:\n----------------------------------------\n";
  Carp::confess @_;
};

sub VERSION_MESSAGE
{
  print STDERR $version_info . "\n\n";
}

sub HELP_MESSAGE
{
  print STDERR "usage: btrbk [options] <command>\n";
  print STDERR "\n";
  print STDERR "options:\n";
  print STDERR "   --help      display this help message\n";
  print STDERR "   --version   display version information\n";
  print STDERR "   -c FILE     specify configuration file\n";
  print STDERR "   -p          preserve all backups (do not delete any old targets)\n";
  print STDERR "   -v          be verbose (set loglevel=info)\n";
  print STDERR "   -q          be quiet (do not print summary at end of \"run\" command)\n";
  print STDERR "   -l LEVEL    set loglevel (warn, info, debug, trace)\n";
  print STDERR "\n";
  print STDERR "commands:\n";
  print STDERR "   run         perform backup operations as defined in configuration\n";
  print STDERR "   dryrun      don't run btrfs commands, just show what would be executed\n";
  print STDERR "   info        print useful filesystem information\n";
  print STDERR "   tree        shows backup tree\n";
  print STDERR "   origin <subvol>   print origin information for subvolume\n";
  print STDERR "   diff <from> <to>  shows new files since subvolume <from> for subvolume <to>\n";
  print STDERR "\n";
  print STDERR "For additional information, see $PROJECT_HOME\n";
}

sub TRACE { my $t = shift; print STDOUT "... $t\n" if($loglevel >= 4);  }
sub DEBUG { my $t = shift; print STDOUT "$t\n" if($loglevel >= 3);  }
sub INFO  { my $t = shift; print STDOUT "$t\n" if($loglevel >= 2);  }
sub WARN  { my $t = shift; print STDOUT "WARNING: $t\n" if($loglevel >= 1);  }
sub ERROR { my $t = shift; print STDOUT "ERROR: $t\n";  }


sub run_cmd($;$)
{
  my $cmd = shift || die;
  my $non_destructive = shift;
  my $ret = "";
  $cmd =~ s/^\s+//;
  $cmd =~ s/\s+$//;
  if($non_destructive || (not $dryrun)) {
    DEBUG "### $cmd";
    $ret = `$cmd`;
    chomp($ret);
    TRACE "Command output:\n$ret";
    if($?) {
      WARN "Command execution failed (exitcode=$?): \"$cmd\"";
      return undef;
    }
    else {
      DEBUG "Command execution successful";
    }
  }
  else {
    DEBUG "### (dryrun) $cmd";
  }
  return $ret;
}


sub subvol($$)
{
  my $root = shift || die;
  my $vol = shift || die;
  if($vol_info{$root} && $vol_info{$root}->{$vol}) {
    return $vol_info{$root}->{$vol};
  }
  return undef;
}


sub get_rsh($$)
{
  my $url = shift // die;
  my $config = shift;
  if($config && ($url =~ /^ssh:\/\/(\S+?)(\/\S+)$/)) {
    my ($ssh_host, $file) = ($1, $2);
    my $ssh_user     = config_key($config, "ssh_user");
    my $ssh_identity = config_key($config, "ssh_identity");
    my $ssh_options = "";
    if($ssh_identity) {
      $ssh_options .= " -i $ssh_identity";
    }
    else {
      WARN "No SSH identity provided (option ssh_identity is not set) for: $url";
    }
    my $rsh = "/usr/bin/ssh $ssh_options " . $ssh_user . '@' . $ssh_host;
    return ($rsh, $file);
  }
  return ("", $url);
}


sub config_key($$)
{
  my $node = shift || die;
  my $key = shift || die;
  TRACE "config_key: context=$node->{CONTEXT}, key=$key";
  while(not exists($node->{$key})) {
    return undef unless($node->{PARENT});
    $node = $node->{PARENT};
  }
  TRACE "config_key: found value=" . ($node->{$key} // "<undef>");
  return $node->{$key};
}


sub check_file($$$$)
{
  my $file = shift;
  my $accept = shift;
  my $key = shift;  # only for error text
  my $config_file = shift;  # only for error text

  if($accept->{ssh} && ($file =~ /^ssh:\/\//)) {
    unless($file =~ /^ssh:\/\/($ip_addr_match|$host_name_match)\/$file_match$/) {
      ERROR "Ambiguous ssh url for option \"$key\" in \"$config_file\" line $.: $file";
      return undef;
    }
  }
  elsif($file =~ /^$file_match$/) {
    if($accept->{absolute}) {
      unless($file =~ /^\//) {
        ERROR "Only absolute files allowed for option \"$key\" in \"$config_file\" line $.: $file";
        return undef;
      }
    }
    elsif($accept->{relative}) {
      if($file =~ /^\//) {
        ERROR "Only relative files allowed for option \"$key\" in \"$config_file\" line $.: $file";
        return undef;
      }
    }
    else {
      die("accept_type must contain either 'relative' or 'absolute'");
    }
  }
  else {
    ERROR "Ambiguous file for option \"$key\" in \"$config_file\" line $.: $file";
    return undef;
  }
  return $file;
}


sub parse_config(@)
{
  my @config_files = @_;
  my $file = undef;
  foreach(@config_files) {
    TRACE "config: checking for file: $_";
    if(-r "$_") {
      $file = $_;
      last;
    }
  }
  unless($file) {
    ERROR "Configuration file not found: " . join(', ', @config_files);
    return undef;
  }

  my $root = { CONTEXT => "root", SRC_FILE => $file };
  my $cur = $root;
  # set defaults
  foreach (keys %config_options) {
    $root->{$_} = $config_options{$_}->{default};
  }

  DEBUG "config: parsing file: $file";
  open(FILE, '<', $file) or die $!;
  while (<FILE>) {
    chomp;
    next if /^\s*#/; # ignore comments
    next if /^\s*$/; # ignore empty lines
    TRACE "config: parsing line $. with context=$cur->{CONTEXT}: \"$_\"";
    if(/^(\s*)([a-zA-Z_]+)\s+(.*)$/)
    {
      my ($indent, $key, $value) = (length($1), lc($2), $3);
      $value =~ s/\s*$//;
      # NOTE: we do not perform checks on indentation!

      if($key eq "volume")
      {
        $cur = $root;
        DEBUG "config: context forced to: $cur->{CONTEXT}";

        # be very strict about file options, for security sake
        return undef unless(check_file($value, { absolute => 1, ssh => 1 }, $key, $file));
        $value =~ s/\/+$//;   # remove trailing slash
        $value =~ s/^\/+/\//; # sanitize leading slash
        DEBUG "config: adding volume \"$value\" to root context";
        my $volume = { CONTEXT => "volume",
                       PARENT => $cur,
                       sroot => $value,
                      };
        $cur->{VOLUME} //= [];
        push(@{$cur->{VOLUME}}, $volume);
        $cur = $volume;
      }
      elsif($key eq "subvolume")
      {
        while($cur->{CONTEXT} ne "volume") {
          if(($cur->{CONTEXT} eq "root") || (not $cur->{PARENT})) {
            ERROR "subvolume keyword outside volume context, in \"$file\" line $.";
            return undef;
          }
          $cur = $cur->{PARENT} || die;
          DEBUG "config: context changed to: $cur->{CONTEXT}";
        }
        # be very strict about file options, for security sake
        return undef unless(check_file($value, { relative => 1 }, $key, $file));
        $value =~ s/\/+$//;    # remove trailing slash
        $value =~ s/^\/+//;    # remove leading slash
        if($value =~ /\//) {
          ERROR "subvolume contains slashes: \"$value\" in \"$file\" line $.";
          return undef;
        }

        DEBUG "config: adding subvolume \"$value\" to volume context: $cur->{sroot}";
        my $subvolume = { CONTEXT => "subvolume",
                          PARENT => $cur,
                          svol => $value,
                         };
        $cur->{SUBVOLUME} //= [];
        push(@{$cur->{SUBVOLUME}}, $subvolume);
        $cur = $subvolume;
      }
      elsif($key eq "target")
      {
        if($cur->{CONTEXT} eq "target") {
          $cur = $cur->{PARENT} || die;
          DEBUG "config: context changed to: $cur->{CONTEXT}";
        }
        if($cur->{CONTEXT} ne "subvolume") {
          ERROR "target keyword outside subvolume context, in \"$file\" line $.";
          return undef;
        }
        if($value =~ /^(\S+)\s+(\S+)$/)
        {
          my ($target_type, $droot) = ($1, $2);
          unless(grep(/^$target_type$/, @config_target_types)) {
            ERROR "unknown target type \"$target_type\" in \"$file\" line $.";
            return undef;
          }
          # be very strict about file options, for security sake
          return undef unless(check_file($droot, { absolute => 1, ssh => 1 }, $key, $file));

          $droot =~ s/\/+$//;   # remove trailing slash
          $droot =~ s/^\/+/\//; # sanitize leading slash
          DEBUG "config: adding target \"$droot\" (type=$target_type) to subvolume context: $cur->{PARENT}->{sroot}/$cur->{svol}";
          my $target = { CONTEXT => "target",
                         PARENT => $cur,
                         target_type => $target_type,
                         droot => $droot,
                       };
          $cur->{TARGET} //= [];
          push(@{$cur->{TARGET}}, $target);
          $cur = $target;
        }
        else
        {
          ERROR "Ambiguous target configuration, in \"$file\" line $.";
          return undef;
        }
      }
      elsif(grep(/^$key$/, keys %config_options))  # accept only keys listed in %config_options
      {
        if(grep(/^$value$/, @{$config_options{$key}->{accept}})) {
          TRACE "option \"$key=$value\" found in accept list";
        }
        elsif($config_options{$key}->{accept_numeric} && ($value =~ /^[0-9]+$/)) {
          TRACE "option \"$key=$value\" is numeric, accepted";
        }
        elsif($config_options{$key}->{accept_file})
        {
          # be very strict about file options, for security sake
          return undef unless(check_file($value, $config_options{$key}->{accept_file}, $key, $file));

          TRACE "option \"$key=$value\" is a valid file, accepted";
          $value =~ s/\/+$//;   # remove trailing slash
          $value =~ s/^\/+/\//; # sanitize leading slash
          if($config_options{$key}->{append_trailing_slash}) {
            TRACE "append_trailing_slash is specified for option \"$key\", adding trailing slash";
            $value .= '/';
          }
        }
        elsif($config_options{$key}->{accept_regexp}) {
          my $match = $config_options{$key}->{accept_regexp};
          if($value =~ m/$match/) {
            TRACE "option \"$key=$value\" matched regexp, accepted";
          }
          else {
            ERROR "Value \"$value\" failed input validation for option \"$key\" in \"$file\" line $.";
            return undef;
          }
        }
        else
        {
          ERROR "Unsupported value \"$value\" for option \"$key\" in \"$file\" line $.";
          return undef;
        }
        DEBUG "config: adding option \"$key=$value\" to $cur->{CONTEXT} context";
        $value = undef if($value eq "no");  # we don't want to check for "no" all the time
        $cur->{$key} = $value;
      }
      else
      {
        ERROR "Unknown option \"$key\" in \"$file\" line $.";
        return undef;
      }

      TRACE "line processed: new context=$cur->{CONTEXT}";
    }
    else
    {
      ERROR "Parse error in \"$file\" line $.";
      return undef;
    }
  }

  TRACE(Data::Dumper->Dump([$root], ["config_root"]));
  return $root;
}


sub btr_filesystem_show_all_local()
{
  return run_cmd("/sbin/btrfs filesystem show", 1);
}


sub btr_filesystem_show($;$)
{
  my $vol = shift || die;
  my $config = shift;
  my ($rsh, $real_vol) = get_rsh($vol, $config);
  my $ret = run_cmd("$rsh /sbin/btrfs filesystem show $real_vol", 1);
  return $ret;
}


sub btr_filesystem_df($;$)
{
  my $vol = shift || die;
  my $config = shift;
  my ($rsh, $real_vol) = get_rsh($vol, $config);
  my $ret = run_cmd("$rsh /sbin/btrfs filesystem df $real_vol", 1);
  return $ret;
}


sub btr_filesystem_usage($;$)
{
  my $vol = shift || die;
  my $config = shift;
  my ($rsh, $real_vol) = get_rsh($vol, $config);
  my $ret = run_cmd("$rsh /sbin/btrfs filesystem usage $real_vol", 1);
  return $ret;
}


sub btr_subvolume_detail($;$)
{
  my $vol = shift || die;
  my $config = shift;
  my ($rsh, $real_vol) = get_rsh($vol, $config);
  my $ret = run_cmd("$rsh /sbin/btrfs subvolume show $real_vol 2>/dev/null", 1);
  if($ret)
  {
    if($ret eq "$real_vol is btrfs root") {
      DEBUG "found btrfs root: $vol";
      return { id => 5, is_root => 1 };
    }
    elsif($ret =~ /^$real_vol/) {
      TRACE "btr_detail: found btrfs subvolume: $vol";
      my %trans = (
        name          => "Name",
        uuid          => "uuid",
        parent_uuid   => "Parent uuid",
        creation_time => "Creation time",
        id            => "Object ID",
        gen           => "Generation \\(Gen\\)",
        cgen          => "Gen at creation",
        parent_id     => "Parent",
        top_level     => "Top Level",
        flags         => "Flags",
       );
      my %detail;
      foreach (keys %trans) {
        if($ret =~ /^\s+$trans{$_}:\s+(.*)$/m) {
          $detail{$_} = $1;
        } else {
          WARN "Failed to parse subvolume detail \"$trans{$_}\": $ret";
        }
      }
      DEBUG "parsed " . scalar(keys %detail) . " subvolume detail items: $vol";
      TRACE "btr_detail for $vol: " . Dumper \%detail;
      return \%detail;
    }
  }
  WARN "Failed to fetch subvolume detail for: $vol";
  return undef;
}


sub btr_subvolume_list($;$@)
{
  my $vol = shift || die;
  my $config = shift;
  my %opts = @_;
  my $filter_option = "-a";
  $filter_option = "-o" if($opts{subvol_only});
  my ($rsh, $real_vol) = get_rsh($vol, $config);
  my $ret = run_cmd("$rsh /sbin/btrfs subvolume list $filter_option -c -u -q -R $real_vol", 1);
  unless(defined($ret)) {
    WARN "Failed to fetch btrfs subvolume list for: $vol";
    return undef;
  }
  my @nodes;
  foreach (split(/\n/, $ret))
  {
    # ID <ID> top level <ID> path <path> where path is the relative path
    # of the subvolume to the top level subvolume. The subvolume?s ID may
    # be used by the subvolume set-default command, or at mount time via
    # the subvolid= option. If -p is given, then parent <ID> is added to
    # the output between ID and top level. The parent?s ID may be used at
    # mount time via the subvolrootid= option.
    die("Failed to parse line: \"$_\"") unless(/^ID ([0-9]+) gen ([0-9]+) cgen ([0-9]+) top level ([0-9]+) parent_uuid ([0-9a-z-]+) received_uuid ([0-9a-z-]+) uuid ([0-9a-z-]+) path (.+)$/);
    push @nodes, { id            => $1,
                   gen           => $2,
                   cgen          => $3,
                   top_level     => $4,
                   parent_uuid   => $5, # note: parent_uuid="-" if no parent
                   received_uuid => $6,
                   uuid          => $7,
                   path          => $8
                  };
    # $node{parent_uuid} = undef if($node{parent_uuid} eq '-');
  }
  DEBUG "found " . scalar(@nodes) . " subvolumes in: $vol";
  return \@nodes;
}


sub btr_subvolume_find_new($$;$)
{
  my $vol = shift || die;
  my $lastgen = shift // die;
  my $config = shift;
  my ($rsh, $real_vol) = get_rsh($vol, $config);
  my $ret = run_cmd("$rsh /sbin/btrfs subvolume find-new $real_vol $lastgen");
  unless(defined($ret)) {
    ERROR "Failed to fetch modified files for: $vol";
    return undef;
  }

  my %files;
  my $parse_errors = 0;
  my $transid_marker;
  foreach (split(/\n/, $ret))
  {
    if(/^inode \S+ file offset (\S+) len (\S+) disk start \S+ offset \S+ gen (\S+) flags (\S+) (.+)$/) {
      my $file_offset = $1;
      my $len         = $2;
      my $gen         = $3;
      my $flags       = $4;
      my $name        = $5;
      $files{$name}->{len} += $len;
      $files{$name}->{new} = 1 if($file_offset == 0);
      $files{$name}->{gen}->{$gen} = 1;  # count the generations
      if($flags eq "COMPRESS") {
        $files{$name}->{flags}->{compress} = 1;
      }
      elsif($flags eq "COMPRESS|INLINE") {
        $files{$name}->{flags}->{compress} = 1;
        $files{$name}->{flags}->{inline} = 1;
      }
      elsif($flags eq "INLINE") {
        $files{$name}->{flags}->{inline} = 1;
      }
      elsif($flags eq "NONE") {
      }
      else {
        WARN "unparsed flags: $flags";
      }
    }
    elsif(/^transid marker was (\S+)$/) {
      $transid_marker = $1;
    }
    else {
      $parse_errors++;
    }
  }

  return { files => \%files,
           transid_marker => $transid_marker,
           parse_errors => $parse_errors,
          };
}


sub btr_tree($;$)
{
  my $vol = shift || die;
  my $config = shift;
  my %tree;
  my %id;
  my $subvol_list = btr_subvolume_list($vol, $config, subvol_only => 0);
  return undef unless(ref($subvol_list) eq "ARRAY");
  foreach my $node (@$subvol_list)
  {
    TRACE "btr_tree: processing subvolid=$node->{id}";

    $id{$node->{id}} = $node;
    $uuid_info{$node->{uuid}} = $node;

    if($node->{top_level} == 5)
    {
      # man btrfs-subvolume:
      #   Also every btrfs filesystem has a default subvolume as its initially
      #   top-level subvolume, whose subvolume id is 5(FS_TREE).

      $tree{$node->{id}} = $node;
    }
    else
    {
      # set SUBVOLUME / TOP_LEVEL node
      die unless exists($id{$node->{top_level}});
      die if exists($id{$node->{top_level}}->{SUBVOLUME}->{$node->{id}});
      $id{$node->{top_level}}->{SUBVOLUME}->{$node->{id}} = $node;
      $node->{TOP_LEVEL} = $id{$node->{top_level}};
    }
  }
  # set PARENT node
  foreach (values %id){
    $_->{PARENT} = $uuid_info{$_->{parent_uuid}} if($_->{parent_uuid} ne "-");
  }
  return \%tree;
}


sub btr_subtree($;$)
{
  my $vol = shift || die;
  my $config = shift;
  my $detail = btr_subvolume_detail($vol, $config);
  unless($detail) {
    WARN "Failed to build btrfs subtree for volume: $vol";
    return undef;
  }

  my $volname = $detail->{name} || "";
  my %tree;
  my $subvol_list = btr_subvolume_list($vol, $config, subvol_only => 1);
  return undef unless(ref($subvol_list) eq "ARRAY");
  foreach my $node (@$subvol_list)
  {
    TRACE "btr_subtree: processing subvolid=$node->{id}";

    # set FS_PATH
    TRACE "btr_subtree: original path: $node->{path}";
    my $path =  $node->{path};
    if($volname) {
      # strip leading volume name
      unless($path =~ s/^$volname\///) {
        # if $vol is a sub-subvolume, strip whole prefix
        unless($path =~ s/.+\/$volname\///) {
          die("ambiguous btrfs subvolume info line");
        }
      }
      TRACE "btr_subtree: removed \"$&\" prefix of subvolume path: $path";
    }
    $node->{SUBVOL_PATH} = $path;
    TRACE "btr_subtree: set SUBVOL_PATH: $node->{SUBVOL_PATH}";

    $node->{FS_PATH} =  $vol . "/" . $path;
    TRACE "btr_subtree: set FS_PATH: $node->{FS_PATH}";

    $tree{$node->{SUBVOL_PATH}} = $node;
    $uuid_info{$node->{uuid}} = $node;
  }
  return \%tree;
}


# returns $target, or undef on error
sub btrfs_snapshot($$;$)
{
  my $src = shift || die;
  my $target = shift || die;
  my $config = shift;
  my ($rsh, $real_src) = get_rsh($src, $config);
  my (undef, $real_target) = get_rsh($target, $config);
  DEBUG "[btrfs] snapshot (ro):";
  DEBUG "[btrfs]   source: $src";
  DEBUG "[btrfs]   target: $target";
  INFO ">>> $target";
  my $ret = run_cmd("$rsh /sbin/btrfs subvolume snapshot -r $real_src $real_target");
  ERROR "Failed to create btrfs subvolume snapshot: $src -> $target" unless(defined($ret));
  return defined($ret) ? $target : undef;
}


sub btrfs_subvolume_delete($@)
{
  my $config = shift;
  my @targets = @_;
  return 0 unless(scalar(@targets));
  my @real_targets;
  my $rsh;
  foreach (@targets) {
    my ($r, $t) = get_rsh($_, $config);
    die if($rsh && ($rsh ne $r)); # make sure all targets share same ssh host
    $rsh = $r;
    push(@real_targets, $t);
  }
  die if(scalar(@targets) != scalar(@real_targets));
  my $commit_delete = config_key($config, "btrfs_commit_delete");
  DEBUG "[btrfs] delete" . ($commit_delete ? " (commit-$commit_delete):" : ":");
  DEBUG "[btrfs]   subvolume: $_" foreach(@targets);
  my $options = "";
  $options = "--commit-after " if($commit_delete eq "after");
  $options = "--commit-each "  if($commit_delete eq "each");
  my $ret = run_cmd("$rsh /sbin/btrfs subvolume delete $options" . join(' ', @real_targets));
  ERROR "Failed to delete btrfs subvolumes: " . join(' ', @targets) unless(defined($ret));
  return defined($ret) ? scalar(@targets) : undef;
}


sub btrfs_send_receive($$$$;$)
{
  my $src = shift || die;
  my $target = shift || die;
  my $parent = shift // "";
  my $changelog = shift // "";
  my $config = shift;
  my ($rsh_src, $real_src) = get_rsh($src, $config);
  my ($rsh_target, $real_target) = get_rsh($target, $config);
  my (undef, $real_parent) = get_rsh($parent, $config);
  my $now = localtime;

  my $src_name = $src;
  $src_name =~ s/^.*\///;
  INFO ">>> $target/$src_name";

  my @info;
  push @info, "[btrfs] send/receive" . ($parent ? " (incremental)" : " (complete)") . ":";
  push @info, "[btrfs]   source: $src";
  push @info, "[btrfs]   parent: $parent" if($parent);
  push @info, "[btrfs]   target: $target";
  push @info, "[btrfs]   log   : $changelog" if($changelog);
  DEBUG $_ foreach(@info);

  my $parent_option = $real_parent ? "-p $real_parent" : "";
  my $receive_option = "";
  $receive_option = "-v" if($changelog || ($loglevel >= 2));
  $receive_option = "-v -v" if($real_parent && $changelog);
  my $cmd = "$rsh_src /sbin/btrfs send $parent_option $real_src | $rsh_target /sbin/btrfs receive $receive_option $real_target/ 2>&1";
  my $ret = run_cmd($cmd);
  unless(defined($ret)) {
    ERROR "Failed to send/receive btrfs subvolume: $src " . ($real_parent ? "[$real_parent]" : "") . " -> $target";
    return undef;
  }
  if($changelog && (not $dryrun))
  {
    INFO "Writing btrfs-diff changelog: $changelog";
    if(open(LOGFILE, '>>', $changelog)) {
      print LOGFILE "<<< START btrfs_send_receive: $now >>>\n";
      print LOGFILE "$_\n" foreach(@info);
      print LOGFILE "[btrfs]   cmd   : $cmd\n";
      print LOGFILE "[btrfs]   cmd output:\n" . $ret;
      print LOGFILE "\n<<< END btrfs_send_receive: $now >>>\n";
      close(LOGFILE);
    }
    else {
      WARN "Failed to open changelog file: $!";
    }
  }
  return 1;
}


sub get_children($$)
{
  my $sroot = shift || die;
  my $svol = shift || die;
  my $svol_href = subvol($sroot, $svol);
  die("subvolume info not present: $sroot/$svol") unless($svol_href);
  DEBUG "Getting snapshot children of: $sroot/$svol";
  my @ret;
  foreach (values %{$vol_info{$sroot}}) {
    next unless($_->{parent_uuid} eq $svol_href->{uuid});
    DEBUG "Found snapshot child: $_->{SUBVOL_PATH}";
    push(@ret, $_);
  }
  return @ret;
}


sub get_receive_targets_by_uuid($$)
{
  my $droot = shift || die;
  my $uuid = shift || die;
  die("root subvolume info not present: $droot") unless($vol_info{$droot});
  die("subvolume info not present: $uuid") unless($uuid_info{$uuid});
  DEBUG "Getting receive targets in \"$droot/\" for: $uuid_info{$uuid}->{FS_PATH}";
  my @ret;
  foreach (values %{$vol_info{$droot}}) {
    next unless($_->{received_uuid} eq $uuid);
    DEBUG "Found receive target: $_->{SUBVOL_PATH}";
    push(@ret, $_);
  }
  return @ret;
}


sub get_latest_common($$$)
{
  my $sroot = shift || die;
  my $svol = shift || die;
  my $droot = shift || die;

  die("source subvolume info not present: $sroot") unless($vol_info{$sroot});
  die("target subvolume info not present: $droot") unless($vol_info{$droot});

  # sort children of svol descending by generation
  foreach my $child (sort { $b->{gen} <=> $a->{gen} } get_children($sroot, $svol)) {
    TRACE "get_latest_common: checking source snapshot: $child->{SUBVOL_PATH}";
    foreach (get_receive_targets_by_uuid($droot, $child->{uuid})) {
      TRACE "get_latest_common: found receive target: $_->{FS_PATH}";
      DEBUG("Latest common snapshots for: $sroot/$svol: src=$child->{FS_PATH}  target=$_->{FS_PATH}");
      return ($child, $_);
    }
    TRACE "get_latest_common: no matching targets found for: $child->{FS_PATH}";
  }
  DEBUG("No common snapshots for \"$sroot/$svol\" found in src=$sroot/  target=$droot/");
  return (undef, undef);
}


sub origin_tree
{
  my $prefix = shift;
  my $uuid = shift;
  my $lines = shift;
  my $node = $uuid_info{$uuid};
  unless($node) {
    push(@$lines, ["$prefix<orphaned>", $uuid]);
    return 0;
  }
  push(@$lines, ["$prefix$node->{FS_PATH}", $uuid]);
  $prefix =~ s/./ /g;
#  $prefix =~ s/^ /\|/g;
  if($node->{received_uuid} ne '-') {
    origin_tree("${prefix}^---", $node->{received_uuid}, $lines);
  }
  if($node->{parent_uuid} ne '-') {
    origin_tree("${prefix}", $node->{parent_uuid}, $lines);
  }
}


sub schedule_deletion(@)
{
  my %args = @_;
  my $schedule             = $args{schedule}             || die;
  my @today                = @{$args{today}};
  my $preserve_day_of_week = $args{preserve_day_of_week} || die;
  my $preserve_daily       = $args{preserve_daily}       // die;
  my $preserve_weekly      = $args{preserve_weekly}      // die;
  my $preserve_monthly     = $args{preserve_monthly}     // die;

  INFO "Filter scheme: preserving all within $preserve_daily days";
  INFO "Filter scheme: preserving first in week (starting on $preserve_day_of_week), for $preserve_weekly weeks";
  INFO "Filter scheme: preserving last weekly of month, for $preserve_monthly months";

  # first, do our calendar calculations
  # note: our week starts on $preserve_day_of_week
  my $delta_days_to_eow_from_today = $day_of_week_map{$preserve_day_of_week} - Day_of_Week(@today) - 1;
  $delta_days_to_eow_from_today = $delta_days_to_eow_from_today + 7 if($delta_days_to_eow_from_today < 0);
  DEBUG "last day before next $preserve_day_of_week is in $delta_days_to_eow_from_today days";
  foreach my $href (@$schedule)
  {
    my @date = @{$href->{date}};
    my $delta_days = Delta_Days(@date, @today);
    my $delta_days_to_eow = $delta_days + $delta_days_to_eow_from_today;
    {
      use integer; # do integer arithmetics
      $href->{delta_days}   = $delta_days;
      $href->{delta_weeks}  = $delta_days_to_eow / 7;
      $href->{err_days}     = 6 - ( $delta_days_to_eow % 7 );
      $href->{delta_months} = ($today[0] - $date[0]) * 12 + ($today[1] - $date[1]);
      $href->{month}        = "$date[0]-$date[1]";
    }
  }

  # filter daily, weekly, monthly
  my %first_in_delta_weeks;
  my %last_weekly_in_delta_months;
  foreach my $href (sort { $a->{sort} cmp $b->{sort} } @$schedule) {
    if($preserve_daily && (($preserve_daily eq "all") || ($href->{delta_days} <= $preserve_daily))) {
      $href->{preserve} ||= "preserved daily: $href->{delta_days} days ago";
    }
    $first_in_delta_weeks{$href->{delta_weeks}} //= $href;
  }
  foreach (reverse sort keys %first_in_delta_weeks) {
    my $href = $first_in_delta_weeks{$_} || die;
    if($preserve_weekly && (($preserve_weekly eq "all") || ($href->{delta_weeks} <= $preserve_weekly))) {
      $href->{preserve} ||= "preserved weekly: $href->{delta_weeks} weeks ago, " . ($href->{err_days} ? "+$href->{err_days} days after " : "on ") . "$preserve_day_of_week";
    }
    $last_weekly_in_delta_months{$href->{delta_months}} = $href;
  }
  foreach (reverse sort keys %last_weekly_in_delta_months) {
    my $href = $last_weekly_in_delta_months{$_} || die;
    if($preserve_monthly && (($preserve_monthly eq "all") || ($href->{delta_months} <= $preserve_monthly))) {
      $href->{preserve} ||= "preserved monthly: " . ($href->{err_days} ? "$href->{err_days} days after " : "") . "last $preserve_day_of_week of month $href->{month} (age: $href->{delta_months} months)";
    }
  }

  # assemble results
  my @delete;
  foreach my $href (sort { $a->{sort} cmp $b->{sort} } @$schedule)
  {
    if($href->{preserve}) {
      INFO "=== $href->{sort}: $href->{preserve}";
    }
    else {
      INFO "<<< $href->{sort}";
      push(@delete, $href->{name});
    }
  }
  return @delete;
}


MAIN:
{
  $ENV{PATH} = '';
  $Getopt::Std::STANDARD_HELP_VERSION = 1;
  $Data::Dumper::Sortkeys = 1;
  my $start_time = time;
  my @today = Today();

  my %opts;
  unless(getopts('hc:vql:p', \%opts)) {
    VERSION_MESSAGE();
    HELP_MESSAGE(0);
    exit 1;
  }
  my $command = shift @ARGV;

  # assign command line options
  $loglevel = $opts{l} || "";
  if   (lc($loglevel) eq "warn")  { $loglevel = 1; }
  elsif(lc($loglevel) eq "info")  { $loglevel = 2; }
  elsif(lc($loglevel) eq "debug") { $loglevel = 3; }
  elsif(lc($loglevel) eq "trace") { $loglevel = 4; }
  elsif($loglevel =~ /^[0-9]+$/) { ; }
  else {
    $loglevel = $opts{v} ? 2 : 1;
  }
  @config_src = ( $opts{c} ) if($opts{c});
  my $quiet = $opts{q};
  my $preserve_backups = $opts{p};

  # check command line options
  if($opts{h} || (not $command)) {
    VERSION_MESSAGE();
    HELP_MESSAGE(0);
    exit 0;
  }

  my ($action_run, $action_info, $action_tree, $action_diff, $action_origin);
  if(($command eq "run") || ($command eq "dryrun")) {
    $action_run = 1;
    $dryrun = 1 if($command eq "dryrun");
  }
  elsif ($command eq "info") {
    $action_info = 1;
  }
  elsif ($command eq "tree") {
    $action_tree = 1;
  }
  elsif ($command eq "diff") {
    $action_diff = 1;
  }
  elsif ($command eq "origin") {
    $action_origin = 1;
  }
  else {
    ERROR "Unrecognized command: $command";
    HELP_MESSAGE(0);
    exit 1;
  }

  INFO "$version_info  (" . localtime($start_time) . ")";

  if($action_diff)
  {
    #
    # print snapshot diff
    #
    my $src_vol    = shift @ARGV;
    my $target_vol = shift @ARGV;
    unless($src_vol && $target_vol) {
      ERROR "Missing subvolume argument for \"diff\" command";
      HELP_MESSAGE(0);
      exit 1;
    }
    # untaint arguments
    unless($src_vol =~ /^($file_match)$/) {
      ERROR "bad argument: not a file: $src_vol";
      exit 1;
    }
    $src_vol = $1;
    unless($target_vol =~ /^($file_match)$/) {
      ERROR "bad argument: not a file: $target_vol";
      exit 1;
    }
    $target_vol = $1;

    my $src_detail = btr_subvolume_detail($src_vol);
    unless($src_detail) { exit 1; }
    if($src_detail->{is_root})  { ERROR "subvolume at \"$src_vol\" is btrfs root!"; exit 1; }
    unless($src_detail->{cgen}) { ERROR "subvolume at \"$src_vol\" does not provide cgen"; exit 1; }
#    if($src_detail->{parent_uuid} eq "-") { ERROR "subvolume at \"$src_vol\" has no parent, aborting."; exit 1; }

    my $target_detail = btr_subvolume_detail($target_vol);
    unless($target_detail) { exit 1; }
    unless($src_detail->{cgen}) { ERROR "subvolume at \"$src_vol\" does not provide cgen"; exit 1; }
#    if($src_detail->{parent_uuid} eq "-") { ERROR "subvolume at \"$src_vol\" has no parent, aborting."; exit 1; }

    my $info = btr_tree($src_vol);
    my $src = $uuid_info{$src_detail->{uuid}} || die;
    my $target = $uuid_info{$target_detail->{uuid}};
    unless($target) { ERROR "target subvolume is not on the same btrfs filesystem!"; exit 1; }

    my $lastgen;

    # check if given src and target share same parent
    if(ref($src->{PARENT}) && ($src->{PARENT}->{uuid} eq $target->{uuid})) {
      DEBUG "target subvolume is direct parent of source subvolume";
    }
    elsif(ref($src->{PARENT}) && ref($target->{PARENT}) && ($src->{PARENT}->{uuid} eq $target->{PARENT}->{uuid})) {
      DEBUG "target subvolume and source subvolume share same parent";
    }
    else {
      # TODO: this rule only applies to snapshots. find a way to distinguish snapshots from received backups
      # ERROR "subvolumes \"$target_vol\" and \"$src_vol\" do not share the same parents";
      # exit 1;
    }

    # NOTE: in some cases "cgen" differs from "gen", even for read-only snapshots (observed: gen=cgen+1)
    $lastgen = $src->{cgen} + 1;

    # dump files, sorted and unique
    my $ret = btr_subvolume_find_new($target_vol, $lastgen);
    exit 1 unless(ref($ret));

    print "--------------------------------------------------------------------------------\n";
    print "Showing changed files for subvolume:\n  $target->{path}  (gen=$target->{gen})\n";
    print "\nStarting at creation generation from subvolume:\n  $src->{path}  (cgen=$src->{cgen})\n";
    print "\nThis will show all files modified within generation range: [$lastgen..$target->{gen}]\n";
    print "Newest file generation (transid marker) was: $ret->{transid_marker}\n";
    print "Parse errors: $ret->{parse_errors}\n" if($ret->{parse_errors});
    print "\nLegend: <flags> <count> <size> <filename>\n";
    print "  +..     file accessed at offset 0 (at least once)\n";
    print "  .c.     flags COMPRESS or COMPRESS|INLINE set (at least once)\n";
    print "  ..i     flags INLINE or COMPRESS|INLINE set (at least once)\n";
    print "  <count> file was modified in <count> generations\n";
    print "  <size>  file was modified for a total of <size> bytes\n";
    print "--------------------------------------------------------------------------------\n";
    my $files = $ret->{files};

    # calculate the character offsets
    my $len_charlen = 0;
    my $gen_charlen = 0;
    foreach (values %$files) {
      my $len = length($_->{len});
      my $gen = length(scalar(keys(%{$_->{gen}})));
      $len_charlen = $len if($len > $len_charlen);
      $gen_charlen = $gen if($gen > $gen_charlen);
    }

    # finally print the output
    foreach my $name (sort keys %$files) {
      print ($files->{$name}->{new}               ? '+' : '.');
      print ($files->{$name}->{flags}->{compress} ? 'c' : '.');
      print ($files->{$name}->{flags}->{inline}   ? 'i' : '.');

      # make nice table
      my $gens = scalar(keys(%{$files->{$name}->{gen}}));
      my $len = $files->{$name}->{len};
      print "  " . (' ' x ($gen_charlen - length($gens))) .  $gens;
      print "  " . (' ' x ($len_charlen - length($len))) .  $len;

      print "  $name\n";
    }

    exit 0;
  }


  #
  # parse config file
  #
  my $config = parse_config(@config_src);
  unless($config) {
    ERROR "Failed to parse configuration file";
    exit 1;
  }
  unless(ref($config->{VOLUME}) eq "ARRAY") {
    ERROR "No volumes defined in configuration file";
    exit 1;
  }



  if($action_info)
  {
    #
    # print filesystem information
    #
    print "================================================================================\n";
    print "Filesystem information ($version_info)\n\n";
    print "    Date:   " . localtime($start_time) . "\n";
    print "    Config: $config->{SRC_FILE}\n";
    print "================================================================================\n";

    # print "\n--------------------------------------------------------------------------------\n";
    # print "All local btrfs filesystems\n";
    # print "--------------------------------------------------------------------------------\n";
    # print (btr_filesystem_show_all_local() // "");
    # print "\n";

    my %processed;
    foreach my $config_vol (@{$config->{VOLUME}})
    {
      my $sroot = $config_vol->{sroot} || die;
      unless($processed{$sroot})
      {
        print "\n--------------------------------------------------------------------------------\n";
        print "Source volume: $sroot\n";
        print "--------------------------------------------------------------------------------\n";
        # print (btr_filesystem_show($sroot, $config_vol) // "");
        # print "\n\n";
        print (btr_filesystem_usage($sroot, $config_vol) // "");
        print "\n";
        $processed{$sroot} = 1;
      }
    }

    foreach my $config_vol (@{$config->{VOLUME}}) {
      my $sroot = $config_vol->{sroot} || die;
      foreach my $config_subvol (@{$config_vol->{SUBVOLUME}}) {
        foreach my $config_target (@{$config_subvol->{TARGET}})
        {
          my $droot = $config_target->{droot} || die;
          unless($processed{$droot})
          {
            print "\n--------------------------------------------------------------------------------\n";
            print "Target volume: $droot\n";
            print "               ^--- $sroot\n";
            print "--------------------------------------------------------------------------------\n";
            print (btr_filesystem_usage($droot, $config_target) // "");
            print "\n";
            $processed{$droot} = 1;
          }
        }
      }
    }
    exit 0;
  }

  #
  # fill vol_info hash, basic checks on configuration
  #
  foreach my $config_vol (@{$config->{VOLUME}})
  {
    my $sroot = $config_vol->{sroot} || die;
    $vol_info{$sroot} //= btr_subtree($sroot, $config_vol);
    foreach my $config_subvol (@{$config_vol->{SUBVOLUME}})
    {
      my $svol = $config_subvol->{svol} || die;
      unless(subvol($sroot, $svol)) {
        $config_subvol->{ABORTED} = "Subvolume \"$svol\" not present in btrfs subvolume list for \"$sroot\"";
        WARN "Skipping subvolume section: $config_subvol->{ABORTED}";
        next;
      }
      foreach my $config_target (@{$config_subvol->{TARGET}})
      {
        my $droot = $config_target->{droot} || die;
        $vol_info{$droot} //= btr_subtree($droot, $config_target);
        unless($vol_info{$droot}) {
          $config_target->{ABORTED} = "Failed to read btrfs subvolume list for \"$droot\"";
          WARN "Skipping target: $config_target->{ABORTED}";
          next;
        }
      }
    }
  }
  TRACE(Data::Dumper->Dump([\%vol_info], ["vol_info"]));


  if($action_origin)
  {
    #
    # print origin information
    #
    my $subvol = shift @ARGV;
    my $dump_uuid = 0;
    unless($subvol) {
      ERROR "Missing subvolume argument for \"origin\" command";
      HELP_MESSAGE(0);
      exit 1;
    }
    $subvol =~ s/\/+$//;   # remove trailing slash
    my $uuid;
    foreach(values %uuid_info) {
      if($_->{FS_PATH} eq $subvol) {
        $uuid = $_->{uuid};
        last;
      }
    }
    unless($uuid) {
      ERROR "Not a configured backup target: $subvol";
      exit 1;
    }
    my $lines = [];
    origin_tree("", $uuid, $lines);

    print "--------------------------------------------------------------------------------\n";
    print "Origin Tree\n\n";
    print "    ^---    : received from subvolume\n";
    print "    newline : parent subvolume\n";
    print "    orphaned: subvolume uuid could not be resolved (probably deleted)\n";
    print "--------------------------------------------------------------------------------\n";

    my $len = 0;
    if($dump_uuid) {
      $len = (length($_->[0]) > $len ? length($_->[0]) : $len) foreach(@$lines);
    }
    foreach(@$lines) {
      print "$_->[0]";
      print ' ' x ($len - length($_->[0]) + 4) . "$_->[1]" if($dump_uuid);
      print "\n";
    }
  }


  if($action_tree)
  {
    #
    # print snapshot tree
    #
    foreach my $config_vol (@{$config->{VOLUME}})
    {
      my $sroot = $config_vol->{sroot} || die;
      print "$sroot\n";
      next unless $vol_info{$sroot};
      foreach my $config_subvol (@{$config_vol->{SUBVOLUME}})
      {
        my $svol = $config_subvol->{svol} || die;
        print "|-- $svol\n";
        my $sroot_uuid;
        foreach (values %{$vol_info{$sroot}}) {
          if($_->{FS_PATH} eq "$sroot/$svol") {
            die if $sroot_uuid;
            $sroot_uuid = $_->{uuid};
          }
        }
        die unless $sroot_uuid;
        foreach (sort { $a->{SUBVOL_PATH} cmp $b->{SUBVOL_PATH} } (values %{$vol_info{$sroot}}))
        {
          next unless($_->{parent_uuid} eq $sroot_uuid);
          # next unless($_->{SUBVOL_PATH} =~ /^$snapdir/);  # don't print non-btrbk snapshots
          print "|   ^-- $_->{SUBVOL_PATH}\n";
          my $snapshot = $_->{FS_PATH};
          $snapshot =~ s/^.*\///;
          foreach my $config_target (@{$config_subvol->{TARGET}})
          {
            my $droot = $config_target->{droot} || die;
            next unless $vol_info{$droot};
            my $match = "$droot/$snapshot";
            foreach (sort { $a->{FS_PATH} cmp $b->{FS_PATH} } (values %{$vol_info{$droot}})) {
              # TODO: also print the backups which do not have corresponding snapshot anymore
              print "|   |   |== $_->{FS_PATH}\n" if($_->{FS_PATH} eq $match);
            }
          }
        }
      }
      print "\n";
    }
  }


  if($action_run)
  {
    #
    # create snapshots
    #
    my $timestamp = sprintf("%04d%02d%02d", @today);
    my %snapshot_cache;
    foreach my $config_vol (@{$config->{VOLUME}})
    {
      next if($config_vol->{ABORTED});
      my $sroot = $config_vol->{sroot} || die;
      foreach my $config_subvol (@{$config_vol->{SUBVOLUME}})
      {
        next if($config_subvol->{ABORTED});
        my $svol = $config_subvol->{svol} || die;
        my $snapdir = config_key($config_subvol, "snapshot_dir") || "";
        my $snapshot;
        my $snapshot_name;
        if($snapshot_cache{"$sroot/$svol"})
        {
          $snapshot      = $snapshot_cache{"$sroot/$svol"}->{file};
          $snapshot_name = $snapshot_cache{"$sroot/$svol"}->{name};
        }
        else
        {
          # find new snapshot name
          my $postfix_counter = -1;
          my $postfix;
          do {
            $postfix_counter++;
            $postfix = '.' . $timestamp . ($postfix_counter ? "_$postfix_counter" : "");
            TRACE "Testing source snapshot name: $snapdir$svol$postfix";
          } while(subvol($sroot, "$snapdir$svol$postfix")); # NOTE: $snapdir always has trailing slash!
          $snapshot      = "$sroot/$snapdir$svol$postfix";
          $snapshot_name = "$svol$postfix";
        }

        my $create_snapshot = config_key($config_subvol, "snapshot_create_always");
        foreach my $config_target (@{$config_subvol->{TARGET}})
        {
          next if($config_target->{ABORTED});
          my $droot = $config_target->{droot} || die;
          if(subvol($droot, $snapshot_name)) {
            $config_target->{ABORTED} = "Snapshot already exists at destination: $droot/$snapshot_name";
            WARN "Skipping target: $config_target->{ABORTED}";
            next;
          }
          if($config_target->{target_type} eq "send-receive") {
            $create_snapshot = 1;
          }
        }
        unless($create_snapshot) {
          $config_subvol->{ABORTED} = "No targets defined for subvolume: $sroot/$svol";
          WARN "Skipping subvolume section: $config_subvol->{ABORTED}";
          next;
        }

        # make snapshot of svol, if not already created by another job
        unless($snapshot_cache{"$sroot/$svol"})
        {
          INFO "Creating subvolume snapshot for: $sroot/$svol";

          unless(btrfs_snapshot("$sroot/$svol", $snapshot, $config_subvol)) {
            $config_subvol->{ABORTED} = "Failed to create snapshot, skipping subvolume: $sroot/$svol";
            WARN "Skipping subvolume section: $config_subvol->{ABORTED}";
          }
          $snapshot_cache{"$sroot/$svol"} = { name => $snapshot_name,
                                              file => $snapshot };
        }
        $config_subvol->{snapshot}      = $snapshot;
        $config_subvol->{snapshot_name} = $snapshot_name;
      }
    }

    #
    # create backups
    #
    foreach my $config_vol (@{$config->{VOLUME}})
    {
      next if($config_vol->{ABORTED});
      my $sroot = $config_vol->{sroot} || die;
      foreach my $config_subvol (@{$config_vol->{SUBVOLUME}})
      {
        next if($config_subvol->{ABORTED});
        my $svol          = $config_subvol->{svol}          || die;
        my $snapshot      = $config_subvol->{snapshot}      || die;
        my $snapshot_name = $config_subvol->{snapshot_name} || die;

        foreach my $config_target (@{$config_subvol->{TARGET}})
        {
          next if($config_target->{ABORTED});
          my $droot       = $config_target->{droot}       || die;
          my $target_type = $config_target->{target_type} || die;

          my $success = 0;
          if($target_type eq "send-receive")
          {
            INFO "Creating subvolume backup ($target_type) for: $sroot/$svol";
            INFO "Using previously created snapshot: $snapshot";

            my $receive_log = config_key($config_target, "receive_log");
            if($receive_log && ($receive_log eq "sidecar")) {
              # log to sidecar of destination snapshot
              $receive_log = "$droot/$snapshot_name.btrbk.log";
            }

            my $incremental = config_key($config_target, "incremental");
            if($incremental)
            {
              my ($latest_common_src, $latest_common_target) = get_latest_common($sroot, $svol, $droot);
              if($latest_common_src && $latest_common_target) {
                my $parent_snap = $latest_common_src->{FS_PATH};
                INFO "Incremental from parent snapshot: $parent_snap";
                $success = btrfs_send_receive($snapshot, $droot, $parent_snap, $receive_log, $config_target);
              }
              elsif($incremental ne "strict") {
                INFO "No common parent subvolume present, creating full backup";
                $config_target->{subvol_non_incremental} = 1;
                $success = btrfs_send_receive($snapshot, $droot, undef, $receive_log, $config_target);
              }
              else {
                WARN "Backup to $droot failed: no common parent subvolume found, and option \"incremental\" is set to \"strict\"";
              }
            }
            else {
              INFO "Creating full backup (option \"incremental\" is not set)";
              $config_target->{subvol_non_incremental} = 1;
              $success = btrfs_send_receive($snapshot, $droot, undef, $receive_log, $config_target);
            }
          }
          else {
            ERROR "Unknown target type \"$target_type\", skipping: $sroot/$svol";
          }
          if($success) {
            $config_target->{subvol_created} = "$droot/$snapshot_name";
          }
          else {
            $config_target->{ABORTED} = "btrfs send/receive command failed";
          }
        }
      }
    }


    #
    # remove backups following a preserve daily/weekly/monthly scheme
    #
    if($preserve_backups) {
      INFO "Preserving all backups (option \"-p\" present)";
    }
    else
    {
      foreach my $config_vol (@{$config->{VOLUME}})
      {
        next if($config_vol->{ABORTED});
        my $sroot = $config_vol->{sroot} || die;
        foreach my $config_subvol (@{$config_vol->{SUBVOLUME}})
        {
          next if($config_subvol->{ABORTED});
          my $svol = $config_subvol->{svol} || die;
          my $snapdir = config_key($config_subvol, "snapshot_dir") || "";
          my $target_aborted = 0;
          foreach my $config_target (@{$config_subvol->{TARGET}})
          {
            if($config_target->{ABORTED}) {
              $target_aborted = 1;
              next;
            }
            my $droot = $config_target->{droot} || die;

            #
            # delete backups
            #
            INFO "Cleaning backups of subvolume \"$sroot/$svol\": $droot/$svol.*";
            my @schedule;
            foreach my $vol (keys %{$vol_info{$droot}}) {
              if($vol =~ /^$svol\.([0-9]{4})([0-9]{2})([0-9]{2})/) {
                push(@schedule, { name => "$droot/$vol", sort => $vol, date => [ $1, $2, $3 ] });
              }
            }
            my @delete = schedule_deletion(
              schedule             => \@schedule,
              today                => \@today,
              preserve_day_of_week => config_key($config_target, "preserve_day_of_week"),
              preserve_daily       => config_key($config_target, "target_preserve_daily"),
              preserve_weekly      => config_key($config_target, "target_preserve_weekly"),
              preserve_monthly     => config_key($config_target, "target_preserve_monthly"),
             );
            my $ret = btrfs_subvolume_delete($config_target, @delete);
            if(defined($ret)) {
              INFO "Deleted $ret subvolumes in: $droot/$svol.*";
              $config_target->{subvol_deleted} = \@delete;
            }
            else {
              $config_target->{ABORTED} = "btrfs subvolume delete command failed";
              $target_aborted = 1;
            }
            $config_target->{schedule} = \@schedule;
          }

          #
          # delete snapshots
          #
          if($target_aborted) {
            WARN "Skipping cleanup of snapshots for subvolume \"$sroot/$svol\", as at least one target aborted earlier";
            next;
          }
          INFO "Cleaning snapshots: $sroot/$snapdir$svol.*";
          my @schedule;
          foreach my $vol (keys %{$vol_info{$sroot}}) {
            if($vol =~ /^$snapdir$svol\.([0-9]{4})([0-9]{2})([0-9]{2})/) {
              push(@schedule, { name => "$sroot/$vol", sort => $vol, date => [ $1, $2, $3 ] });
            }
          }
          my @delete = schedule_deletion(
            schedule             => \@schedule,
            today                => \@today,
            preserve_day_of_week => config_key($config_subvol, "preserve_day_of_week"),
            preserve_daily       => config_key($config_subvol, "snapshot_preserve_daily"),
            preserve_weekly      => config_key($config_subvol, "snapshot_preserve_weekly"),
            preserve_monthly     => config_key($config_subvol, "snapshot_preserve_monthly"),
           );
          my $ret = btrfs_subvolume_delete($config_subvol, @delete);
          if(defined($ret)) {
            INFO "Deleted $ret subvolumes in: $sroot/$snapdir$svol.*";
            $config_subvol->{subvol_deleted} = \@delete;
          }
          else {
            $config_subvol->{ABORTED} = "btrfs subvolume delete command failed";
          }
          $config_subvol->{schedule} = \@schedule;
        }
      }
    }

    my $time_elapsed = time - $start_time;
    INFO "Completed within: ${time_elapsed}s  (" . localtime(time) . ")";

    #
    # print summary
    #
    unless($quiet)
    {
      my $err_count = 0;
      print "--------------------------------------------------------------------------------\n";
      print "Backup Summary ($version_info)\n\n";
      print "    Date:   " . localtime($start_time) . "\n";
      print "    Config: $config->{SRC_FILE}\n";
      print "--------------------------------------------------------------------------------";
      foreach my $config_vol (@{$config->{VOLUME}})
      {
        if($config_vol->{ABORTED}) {
          print "!!! $config_vol->{sroot}: ABORTED: $config_vol->{ABORTED}\n";
          $err_count++;
        }
        foreach my $config_subvol (@{$config_vol->{SUBVOLUME}})
        {
          print "\n$config_vol->{sroot}/$config_subvol->{svol}\n";
          if($config_subvol->{ABORTED}) {
            print "!!! Subvolume \"$config_subvol->{svol}\" aborted: $config_subvol->{ABORTED}\n";
            $err_count++;
          }
          # if($config_subvol->{schedule}) {
          #   foreach (sort { $a->{sort} cmp $b->{sort} } @{$config_subvol->{schedule}}) {
          #     print(($_->{preserve} ? "===" : "---") . " $_->{name}\n");
          #   }
          # }
          print "+++ $config_subvol->{snapshot}\n" if($config_subvol->{snapshot});
          if($config_subvol->{subvol_deleted}) {
            print "--- $_\n" foreach(sort { $b cmp $a} @{$config_subvol->{subvol_deleted}});
          }
          foreach my $config_target (@{$config_subvol->{TARGET}})
          {
            if($config_target->{ABORTED}) {
              print "!!! Target \"$config_target->{droot}\" aborted: $config_target->{ABORTED}\n";
              $err_count++;
            }
            # if($config_target->{schedule}) {
            #   foreach (sort { $a->{sort} cmp $b->{sort} } @{$config_target->{schedule}}) {
            #     print(($_->{preserve} ? "===" : "---") . " $_->{name}\n");
            #   }
            # }
            my $create_mode = ($config_target->{subvol_non_incremental} ? "***" : ">>>");
            print "$create_mode $config_target->{subvol_created}\n" if($config_target->{subvol_created});
            if($config_target->{subvol_deleted}) {
              print "--- $_\n" foreach(sort { $b cmp $a} @{$config_target->{subvol_deleted}});
            }
          }
        }
      }
      if($err_count) {
        print "\nNOTE: Some errors occurred, which may result in missing backups!\n";
        print "Please check warning and error messages above.\n";
      }
      if($dryrun) {
        print "\nNOTE: Dryrun was active, none of the operations above were actually executed!\n";
      }
    }
  }
}


1;