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.17.0-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 }, deprecated => "removed" },
  incremental               => { default => "yes",    accept => [ "yes", "no", "strict" ] },
  snapshot_create_always    => { default => undef,    accept => [ "yes", "no" ] },
  resume_missing            => { default => "yes",    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_-]*$/ },
  btrfs_progs_compat        => { default => undef,    accept => [ "yes", "no" ] },
 );

my @config_target_types = qw(send-receive);

my %vol_detail;
my %vol_info;  # !!! TODO: rename
my %uuid_info;
my %uuid_fs_map;
my %vol_btrfs_progs_compat;  # hacky, maps all subvolumes without received_uuid information

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_@\-\.\/]+/;  # note: ubuntu uses '@' in the subvolume layout: <https://help.ubuntu.com/community/btrfs>
my $ssh_prefix_match = qr/ssh:\/\/($ip_addr_match|$host_name_match)/;


$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 the 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($?) {
      my $exitcode= $? >> 8;
      my $signal = $? & 127;
      WARN "Command execution failed (exitcode=$exitcode" . ($signal ? ", signal=$signal" : "") . "): \"$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}->{node};
  }
  return undef;
}


sub vinfo($;$)
{
  my $url = shift // die;
  my $config = shift;
  if($vol_detail{$url}) {
    DEBUG "vinfo cache hit: $url";
    return $vol_detail{$url};
  }

  my $detail = btr_subvolume_detail($url, $config);

  unless($detail) {
    $vol_detail{$url} = { ABORTED => "Failed to fetch subvolume detail for: $url" };
    return undef;
  }

  $vol_detail{$url} = $detail;
  DEBUG "vinfo updated for: $url";
  TRACE(Data::Dumper->Dump([$detail], ["vinfo{$url}"]));

  return $detail;
}


sub get_rsh($$)
{
  my $url = shift // die;
  my $config = shift;
  if($config && ($url =~ /^ssh:\/\/(\S+?)(\/\S+)$/)) {
    my ($ssh_host, $path) = ($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, $path);
  }
  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 // die;
  my $accept = shift || die;
  my $key = shift;  # only for error text
  my $config_file = shift;  # only for error text

  if($accept->{ssh} && ($file =~ /^ssh:\/\//)) {
    unless($file =~ /^$ssh_prefix_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 1;
}


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;

        if($config_options{$key}->{deprecated}) {
          WARN "Found deprecated configuration option \"$key\" in \"$file\" line $.";
        }
      }
      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 $url = shift || die;
  my $config = shift;
  my ($rsh, $path) = get_rsh($url, $config);
  my $ret = run_cmd("$rsh /sbin/btrfs filesystem show $path", 1);
  return $ret;
}


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


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


sub btr_subvolume_detail($;$)
{
  my $url = shift || die;
  my $config = shift;
  my ($rsh, $path) = get_rsh($url, $config);
  my $ret = run_cmd("$rsh /sbin/btrfs subvolume show $path 2>/dev/null", 1);
  if($ret)
  {
    my $fs_path;
    if($ret =~ /^($file_match)/) {
      $fs_path = $1;
      DEBUG "Real path for subvolume \"$url\" is: $fs_path" if($fs_path ne $path);
      return undef unless(check_file($fs_path, { absolute => 1 }));
    }
    else {
      $fs_path = $path;
      WARN "No real path provided by \"btrfs subvolume show\" for subvolume \"$url\", using: $path";
    }
    my %detail = ( FS_PATH  => $fs_path,
                   URL      => $url,
                  );

    if($ret eq "$fs_path is btrfs root") {
      DEBUG "found btrfs root: $url";
      $detail{id}      = 5;
      $detail{is_root} = 1;
    }
    elsif($ret =~ /^$fs_path/) {
      TRACE "btr_detail: found btrfs subvolume: $url";
      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",
       );
      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: $url";
      TRACE "btr_detail for $url: " . Dumper \%detail;
    }
    return \%detail;
  }
  WARN "Failed to fetch subvolume detail for: $url";
  return undef;
}


sub btr_subvolume_list($;$@)
{
  my $url = shift || die;
  my $config = shift;
  my %opts = @_;
  my $btrfs_progs_compat = config_key($config, "btrfs_progs_compat");
  my $filter_option = "-a";
  $filter_option = "-o" if($opts{subvol_only});
  my $display_options = "-c -u -q";
  $display_options .= " -R" unless($btrfs_progs_compat);
  my ($rsh, $real_vol) = get_rsh($url, $config);
  my $ret = run_cmd("$rsh /sbin/btrfs subvolume list $filter_option $display_options $real_vol", 1);
  unless(defined($ret)) {
    WARN "Failed to fetch btrfs subvolume list for: $url";
    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.

    # NOTE: btrfs-progs prior to v1.17 do not support the -R flag
    my %node;
    if($btrfs_progs_compat) {
      die("Failed to parse line: \"$_\"") unless(/^ID ([0-9]+) gen ([0-9]+) cgen ([0-9]+) top level ([0-9]+) parent_uuid ([0-9a-z-]+) uuid ([0-9a-z-]+) path (.+)$/);
      %node = (
        id            => $1,
        gen           => $2,
        cgen          => $3,
        top_level     => $4,
        parent_uuid   => $5, # note: parent_uuid="-" if no parent
        # received_uuid => $6,
        uuid          => $6,
        path          => $7  # btrfs path, NOT filesystem path
     );
    } else {
      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 (.+)$/);
      %node = (
      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  # btrfs path, NOT filesystem path
     );
    }

    # NOTE: "btrfs subvolume list <path>" prints <FS_TREE> prefix only if
    # the subvolume is reachable within <path>. (as of btrfs-progs-3.18.2)
    #
    # NOTE: Be prepared for this to change in btrfs-progs!
    $node{path} =~ s/^<FS_TREE>\///;     # remove "<FS_TREE>/" portion from "path".

    push @nodes, \%node;
    # $node{parent_uuid} = undef if($node{parent_uuid} eq '-');
  }
  DEBUG "parsed " . scalar(@nodes) . " total subvolumes for filesystem at: $url";
  return \@nodes;
}


sub btr_subvolume_find_new($$;$)
{
  my $url = shift || die;
  my $lastgen = shift // die;
  my $config = shift;
  my ($rsh, $real_vol) = get_rsh($url, $config);
  my $ret = run_cmd("$rsh /sbin/btrfs subvolume find-new $real_vol $lastgen");
  unless(defined($ret)) {
    ERROR "Failed to fetch modified files for: $url";
    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 $url = shift || die;
  my $config = shift;
  my %tree;
  my %id;
  my $subvol_list = btr_subvolume_list($url, $config, subvol_only => 0);
  return undef unless(ref($subvol_list) eq "ARRAY");

  TRACE "btr_tree: processing subvolume list of: $url";

  foreach my $node (@$subvol_list)
  {
    $id{$node->{id}} = $node;
    $uuid_info{$node->{uuid}} = $node;

    my $rel_path = $node->{path};
    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 SUBTREE / PARENT node
      die unless exists($id{$node->{top_level}});
      my $parent = $id{$node->{top_level}};

      die if exists($parent->{SUBTREE}->{$node->{id}});
      $parent->{SUBTREE}->{$node->{id}} = $node;
      $node->{PARENT} = $parent;

      # "path" always starts with set REL_PATH
      die unless($rel_path =~ s/^$parent->{path}\///);
    }
    $node->{REL_PATH} = $rel_path;  # relative to {PARENT}->{path}
  }

  # set PARENT node
  foreach (values %id){
    $_->{PARENT} = $uuid_info{$_->{parent_uuid}} if($_->{parent_uuid} ne "-");
  }
  return \%tree;
}


sub _subtree_list
{
  my $tree = shift;
  my $list = shift;
  my $prefix = shift;

  return $list unless $tree;  # silent ignore empty subtrees

  foreach(values %$tree) {
    my $path = $prefix . $_->{REL_PATH};
    push(@$list, { SUBVOL_PATH => $path,
                   node    => $_,
                 });

    # recurse into SUBTREE
    _subtree_list($_->{SUBTREE}, $list, $path . '/');
  }
  return $list;
}



# returns hash of:
#   SUBVOL_PATH  relative path to URL
#   URL          absolute path
#   node         href to tree node
#
# returns an empty hash if the subvolume at $url exists, but contains no subvolumes
# returns undef if the subvolume at $url does not exists
sub btr_fs_info($;$)
{
  my $url = shift || die;
  my $config = shift;
  my $detail = vinfo($url, $config);
  return undef unless($detail);

  my $tree = btr_tree($url, $config);
  my $tree_root;
  if($detail->{is_root}) {
    $tree_root = $tree;
  }
  else {
    die unless $uuid_info{$detail->{uuid}};
    $uuid_fs_map{$detail->{uuid}}->{$url} = 1;
    $tree_root = $uuid_info{$detail->{uuid}}->{SUBTREE};
    unless($tree_root) {
      DEBUG "No subvolumes found in: $url";
      return {};
    }
  }

  # recurse into $tree_root, returns list of href: { URL, node }
  my $list = _subtree_list($tree_root, [], "");

  # return a hash of relative subvolume path
  my %ret;
  foreach(@$list) {
    my $subvol_path = $_->{SUBVOL_PATH};
    die if exists $ret{$subvol_path};
    $_->{URL} = $url . '/' . $subvol_path;
    $uuid_fs_map{$_->{node}->{uuid}}->{$url . '/' . $subvol_path} = 1;
    $ret{$subvol_path} = $_;
  }
  $vol_btrfs_progs_compat{$url} = config_key($config, "btrfs_progs_compat");  # missing received_uuid in node{}

  return \%ret;
}


# 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 $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";

  DEBUG "[btrfs] send/receive" . ($parent ? " (incremental)" : " (complete)") . ":";
  DEBUG "[btrfs]   source: $src";
  DEBUG "[btrfs]   parent: $parent" if($parent);
  DEBUG "[btrfs]   target: $target";

  my $parent_option = $real_parent ? "-p $real_parent" : "";
  my $receive_option = "";
  $receive_option = "-v" if($loglevel >= 3);

  my $cmd = "$rsh_src /sbin/btrfs send $parent_option $real_src | $rsh_target /sbin/btrfs receive $receive_option $real_target/";
  my $ret = run_cmd($cmd);
  unless(defined($ret)) {
    ERROR "Failed to send/receive btrfs subvolume: $src " . ($real_parent ? "[$real_parent]" : "") . " -> $target";
    return undef;
  }
  return 1;
}


# sets $config->{ABORTED} on failure
# sets $config->{subvol_received}
sub macro_send_receive($@)
{
  my $config = shift || die;
  my %info = @_;
  my $incremental = config_key($config, "incremental");

  INFO "Receiving from snapshot: $info{src}";

  # add info to $config->{subvol_received}
  my $src_name = $info{src};
  $src_name =~ s/^.*\///;
  $info{received_name} = "$info{target}/$src_name";
  $config->{subvol_received} //= [];
  push(@{$config->{subvol_received}}, \%info);

  if($incremental)
  {
    # create backup from latest common
    if($info{parent}) {
      INFO "Incremental from parent snapshot: $info{parent}";
    }
    elsif($incremental ne "strict") {
      INFO "No common parent subvolume present, creating full backup";
    }
    else {
      WARN "Backup to $info{target} failed: no common parent subvolume found, and option \"incremental\" is set to \"strict\"";
      $info{ERROR} = 1;
      $config->{ABORTED} = "No common parent subvolume found, and option \"incremental\" is set to \"strict\"";
      return undef;
    }
  }
  else {
    INFO "Option \"incremental\" is not set, creating full backup";
    delete $info{parent};
  }

  if(btrfs_send_receive($info{src}, $info{target}, $info{parent}, $config)) {
    return 1;
  } else {
    $info{ERROR} = 1;
    $config->{ABORTED} = "btrfs send/receive command failed";
    return undef;
  }
}


sub get_date_tag($)
{
  my $name = shift;
  $name =~ s/_([0-9]+)$//;
  my $postfix_counter = $1 // 0;
  my $date = undef;
  if($name =~ /\.([0-9]{4})([0-9]{2})([0-9]{2})$/) {
    $date = [ $1, $2, $3 ];
  }
  return ($date, $postfix_counter);
}


sub get_snapshot_children($$)
{
  my $sroot = shift || die;
  my $svol = shift // die;
  my $svol_node = subvol($sroot, $svol);
  die("subvolume info not present: $sroot/$svol") unless($svol_node);
  my @ret;
  foreach (values %{$vol_info{$sroot}}) {
    next unless($_->{node}->{parent_uuid} eq $svol_node->{uuid});
    TRACE "get_snapshot_children: found: $_->{URL}";
    push(@ret, $_);
  }
  DEBUG "Found " . scalar(@ret) . " snapshot children of: $sroot/$svol";
  return @ret;
}


sub get_receive_targets($$)
{
  my $droot = shift || die;
  my $src_href = shift || die;
  die("root subvolume info not present: $droot") unless($vol_info{$droot});
  my @ret;

  if($vol_btrfs_progs_compat{$droot})
  {
    # guess matches by subvolume name (node->received_uuid is not available if BTRFS_PROGS_COMPAT is set)
    DEBUG "Fallback to compatibility mode (get_receive_targets)";
    my $src_name = $src_href->{node}->{REL_PATH};
    $src_name =~ s/^.*\///; # strip path
    foreach my $target (values %{$vol_info{$droot}}) {
      my $target_name = $target->{node}->{REL_PATH};
      $target_name =~ s/^.*\///; # strip path
      if($target_name eq $src_name) {
        TRACE "get_receive_targets: by-name: Found receive target: $target->{SUBVOL_PATH}";
        push(@ret, $target);
      }
    }
  }
  else
  {
    # find matches by comparing uuid / received_uuid
    my $uuid = $src_href->{node}->{uuid};
    die("subvolume info not present: $uuid") unless($uuid_info{$uuid});
    foreach (values %{$vol_info{$droot}}) {
      next unless($_->{node}->{received_uuid} eq $uuid);
      TRACE "get_receive_targets: by-uuid: Found receive target: $_->{SUBVOL_PATH}";
      push(@ret, $_);
    }
  }
  DEBUG "Found " . scalar(@ret) . " receive targets in \"$droot/\" for: $src_href->{URL}";
  return @ret;
}


sub get_latest_common($$$;$)
{
  my $sroot = shift || die;
  my $svol = shift // die;
  my $droot = shift || die;
  my $threshold_gen = shift;  # skip all snapshot children with generation >= $threshold_gen

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

  my $debug_src = "$sroot/$svol";
  $debug_src .= "@" . $threshold_gen if($threshold_gen);

  # sort children of svol descending by generation
  foreach my $child (sort { $b->{node}->{gen} <=> $a->{node}->{gen} } get_snapshot_children($sroot, $svol)) {
    TRACE "get_latest_common: checking source snapshot: $child->{SUBVOL_PATH}";
    if($threshold_gen && ($child->{node}->{gen} >= $threshold_gen)) {
      TRACE "get_latest_common: skipped gen=$child->{node}->{gen} >= $threshold_gen: $child->{SUBVOL_PATH}";
      next;
    }

    if($child->{RECEIVE_TARGET_PRESENT} && ($child->{RECEIVE_TARGET_PRESENT} eq $droot)) {
      # little hack to keep track of previously received subvolumes
      DEBUG("Latest common snapshots for: $debug_src: src=$child->{URL}  target=<previously received>");
      return ($child, undef);
    }

    foreach (get_receive_targets($droot, $child)) {
      TRACE "get_latest_common: found receive target: $_->{URL}";
      DEBUG("Latest common snapshots for: $debug_src: src=$child->{URL}  target=$_->{URL}");
      return ($child, $_);
    }
    TRACE "get_latest_common: no matching targets found for: $child->{URL}";
  }
  DEBUG("No common snapshots for \"$debug_src\" 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;
  }
  if($uuid_fs_map{$uuid}) {
    foreach(keys %{$uuid_fs_map{$uuid}}) {
      push(@$lines, ["$prefix$_", $uuid]);
    }
  } else {
    push(@$lines, ["$prefix<BTRFS_ROOT>/$node->{path}", $uuid]);
  }

  $prefix =~ s/./ /g;
  if($node->{received_uuid}) {
    if($node->{received_uuid} ne '-') {
      _origin_tree("${prefix}^---", $node->{received_uuid}, $lines);
    }
  } else {
    push(@$lines,  ["$prefix^---<missing_received_uuid>", $uuid]);  # printed if "btrfs_progs_compat" is set
  }
  if($node->{parent_uuid} ne '-') {
    _origin_tree("${prefix}", $node->{parent_uuid}, $lines);
  }
}


sub schedule(@)
{
  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;
  my $log_verbose          = $args{log_verbose};

  if($log_verbose) {
    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";
  }

  # sort the schedule, ascending by date
  my @sorted_schedule = sort { ($a->{date}->[0] <=> $b->{date}->[0]) ||
                               ($a->{date}->[1] <=> $b->{date}->[1]) ||
                               ($a->{date}->[2] <=> $b->{date}->[2]) ||
                               ($a->{date_ext}  <=> $a->{date_ext})
                             } @$schedule;

  # 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);
  TRACE "last day before next $preserve_day_of_week is in $delta_days_to_eow_from_today days";
  foreach my $href (@sorted_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 (@sorted_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;
  my @preserve;
  foreach my $href (@sorted_schedule)
  {
    if($href->{preserve}) {
      INFO "=== $href->{name}: $href->{preserve}" if($href->{name});
      push(@preserve, $href->{value});
    }
    else {
      INFO "<<< $href->{name}" if($href->{name});
      push(@delete, $href->{value});
    }
  }
  DEBUG "Preserving " . @preserve . "/" . @$schedule . " items" unless($log_verbose);
  return (\@preserve, \@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);
  my @subvol_args;
  my ($args_expected_min, $args_expected_max) = (0, 0);
  if(($command eq "run") || ($command eq "dryrun")) {
    $action_run = 1;
    $dryrun = 1 if($command eq "dryrun");
    $args_expected_min = 0;
    $args_expected_max = 9999;
    @subvol_args = @ARGV;
  }
  elsif ($command eq "info") {
    $action_info = 1;
  }
  elsif ($command eq "tree") {
    $action_tree = 1;
  }
  elsif ($command eq "diff") {
    $action_diff = 1;
    $args_expected_min = $args_expected_max = 2;
    @subvol_args = @ARGV;
  }
  elsif ($command eq "origin") {
    $action_origin = 1;
    $args_expected_min = $args_expected_max = 1;
    @subvol_args = @ARGV;
  }
  else {
    ERROR "Unrecognized command: $command";
    HELP_MESSAGE(0);
    exit 1;
  }
  if(($args_expected_min > scalar(@ARGV)) || ($args_expected_max < scalar(@ARGV))) {
    ERROR "Incorrect number of arguments";
    HELP_MESSAGE(0);
    exit 1;
  }

  # input validation
  foreach (@subvol_args) {
    s/\/+$//;   # remove trailing slash
    unless(/^(($ssh_prefix_match)?\/$file_match)$/) {  # matches ssh statement or absolute file
      ERROR "Bad argument: not a subvolume declaration: $_";
      HELP_MESSAGE(0);
      exit 1;
    }
    $_ = $1; # untaint argument
  }


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

  if($action_diff)
  {
    #
    # print snapshot diff
    #
    my $src_vol    = $subvol_args[0] || die;
    my $target_vol = $subvol_args[1] || die;
    # FIXME: allow ssh:// src/dest (does not work since the configuration is not yet read).

    my $src_detail = vinfo($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 = vinfo($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
  #
  my $subvol_filter_count = undef;
  foreach my $config_vol (@{$config->{VOLUME}})
  {
    my $sroot = $config_vol->{sroot} || die;
    foreach my $config_subvol (@{$config_vol->{SUBVOLUME}})
    {
      my $svol = $config_subvol->{svol} // die;
      vinfo($sroot, $config_vol);
      vinfo("$sroot/$svol", $config_vol);

      # filter subvolumes matching command line arguments
      if($action_run && scalar(@subvol_args)) {
        $subvol_filter_count //= 0;
        if(grep(/^$sroot\/$svol$/, @subvol_args)) {
          $subvol_filter_count++;
        }
        else {
          DEBUG "No match on subvolume command line argument, skipping: $sroot/$svol";
          $config_subvol->{ABORTED} = "No match on subvolume command line arguments";
          $config_subvol->{ABORTED_NOERR} = 1;
          next;
        }
      }

      $vol_info{$sroot} //= btr_fs_info($sroot, $config_vol);
      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;
        vinfo($droot, $config_target);
        $vol_info{$droot} //= btr_fs_info($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;
        }
      }
    }
  }
  if(defined($subvol_filter_count) && ($subvol_filter_count == 0)) {
    ERROR "Subvolume command line arguments do not match any volume/subvolume declaration from configuration file, aborting.";
    exit 1;
  }
  TRACE(Data::Dumper->Dump([\%vol_info], ["vol_info"]));


  if($action_origin)
  {
    #
    # print origin information
    #
    my $subvol = $subvol_args[0] || die;
    my $dump_uuid = 0;

    my $detail = vinfo($subvol);
    exit 1 unless($detail);

    if($detail->{is_root}) {
      ERROR "Subvolume is btrfs root: $subvol\n";
      exit 1;
    }
    my $uuid = $detail->{uuid} || die;
    my $node = $uuid_info{$uuid};

    unless($node) {
      DEBUG "Subvolume not parsed yet, fetching info: $subvol";
      vinfo($subvol);
      $vol_info{$subvol} //= btr_fs_info($subvol);
      $node = $uuid_info{$uuid} || die;
    }

    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";
    }
    exit 0;
  }


  if($action_tree)
  {
    #
    # print snapshot tree
    #
    # TODO: reverse tree: print all backups from $droot and their corresponding source snapshots
    foreach my $config_vol (@{$config->{VOLUME}})
    {
      my %droot_compat;
      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";
        unless($vol_info{$sroot}->{$svol}) {
          print "    !!! error: no subvolume \"$svol\" found in \"$sroot\"\n";
          next;
        }

        my $sroot_uuid = $vol_info{$sroot}->{$svol}->{node}->{uuid} || die;
        foreach my $snapshot (sort { $a->{SUBVOL_PATH} cmp $b->{SUBVOL_PATH} } (values %{$vol_info{$sroot}}))
        {
          next unless($snapshot->{node}->{parent_uuid} eq $sroot_uuid);
          # next unless($snapshot->{SUBVOL_PATH} =~ /^$snapdir/);  # don't print non-btrbk snapshots
          print "|   ^-- $snapshot->{SUBVOL_PATH}\n";
          foreach my $config_target (@{$config_subvol->{TARGET}})
          {
            my $droot = $config_target->{droot} || die;
            next unless $vol_info{$droot};
            $droot_compat{$droot} = 1 if($vol_btrfs_progs_compat{$droot});
            foreach (sort { $a->{SUBVOL_PATH} cmp $b->{SUBVOL_PATH} } get_receive_targets($droot, $snapshot)) {
              print "|   |   ^== $_->{URL}\n";
            }
          }
        }
      }
      if(keys %droot_compat) {
        print "\nNOTE: Received subvolumes (backups) are guessed by subvolume name for targets:\n";
        print "      - " . join("\n      - ", (sort keys %droot_compat));
      }
      print "\n";
    }
    exit 0;
  }


  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 unique snapshot name
          my @lookup = keys %{$vol_info{$sroot}};
          @lookup = grep s/^$snapdir// , @lookup;
          foreach (@{$config_subvol->{TARGET}}){
            push(@lookup, keys %{$vol_info{$_->{droot}}});
          }
          @lookup = grep /^$svol\.$timestamp(_[0-9]+)?$/ ,@lookup;
          TRACE "Present snapshot names for \"$sroot/$svol\": " . join(', ', @lookup);
          @lookup = map { /_([0-9]+)$/ ? $1 : 0 } @lookup;
          @lookup = sort { $b <=> $a } @lookup;
          my $postfix_counter = $lookup[0] // -1;
          $postfix_counter++;

          $snapshot_name = $svol . '.' . $timestamp . ($postfix_counter ? "_$postfix_counter" : "");
          $snapshot = "$sroot/$snapdir$snapshot_name";
        }

        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} = "Subvolume 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;

        my $snapdir = config_key($config_subvol, "snapshot_dir") || "";

        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;

          if($target_type eq "send-receive")
          {
            if(config_key($config_target, "receive_log")) {
              WARN "Ignoring deprecated option \"receive_log\" for target: $droot"
            }

            # resume missing backups (resume_missing)
            if(config_key($config_target, "resume_missing"))
            {
              INFO "Checking for missing backups of subvolume \"$sroot/$svol\" in: $droot/";
              my @schedule;
              my $found_missing = 0;

              # sort children of svol ascending by generation
              foreach my $child (get_snapshot_children($sroot, $svol))
              {
                if(scalar get_receive_targets($droot, $child)) {
                  DEBUG "Found matching receive target, skipping: $child->{URL}";
                }
                else {
                  DEBUG "No matching receive targets found, adding resume candidate: $child->{URL}";

                  # check if the target would be preserved
                  my ($date, $date_ext) = get_date_tag($child->{SUBVOL_PATH});
                  next unless($date && ($child->{SUBVOL_PATH} =~ /^$snapdir$svol\./));
                  push(@schedule, { value => $child, date => $date, date_ext => $date_ext }),
                }
              }

              if(scalar @schedule)
              {
                DEBUG "Checking schedule for resume candidates";
                # add all present backups to schedule, with no value
                # these are needed for correct results of schedule()
                foreach my $vol (keys %{$vol_info{$droot}}) {
                  my ($date, $date_ext) = get_date_tag($vol);
                  next unless($date && ($vol =~ s/^$svol\.//));  # use only the date suffix for sorting
                  push(@schedule, { value => undef, date => $date, date_ext => $date_ext });
                }

                my ($preserve, undef) = schedule(
                  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 @resume = grep defined, @$preserve;   # remove entries with no value from list (target subvolumes)

                foreach my $child (sort { $a->{node}->{gen} <=> $b->{node}->{gen} } @resume) {
                  INFO "Resuming subvolume backup (send-receive) for: $child->{URL}";
                  $found_missing++;
                  my ($latest_common_src, $latest_common_target) = get_latest_common($sroot, $svol, $droot, $child->{node}->{gen});
                  if(macro_send_receive($config_target,
                                        src    => $child->{URL},
                                        target => $droot,
                                        parent => $latest_common_src ? $latest_common_src->{URL} : undef,
                                        resume => 1,     # propagated to $config_target->{subvol_received}
                                       ))
                  {
                    # tag the source snapshot, so that get_latest_common() above can make use of the newly received subvolume
                    $child->{RECEIVE_TARGET_PRESENT} = $droot;
                  }
                  else {
                    # note: ABORTED flag is already set by macro_send_receive()
                    ERROR("Error while resuming backups, aborting");
                    last;
                  }
                }
              }

              if($found_missing) {
                INFO "Resumed $found_missing backups";
              } else {
                INFO "No missing backups found";
              }
            }

            # skip creation if resume_missing failed
            next if($config_target->{ABORTED});

            # finally receive the previously created snapshot
            INFO "Creating subvolume backup (send-receive) for: $sroot/$svol";
            my ($latest_common_src, $latest_common_target) = get_latest_common($sroot, $svol, $droot);
            macro_send_receive($config_target,
                               src    => $snapshot,
                               target => $droot,
                               parent => $latest_common_src ? $latest_common_src->{URL} : undef,
                              );
          }
          else {
            ERROR "Unknown target type \"$target_type\", skipping: $sroot/$svol";
            $config_target->{ABORTED} = "Unknown target type \"$target_type\"";
          }
        }
      }
    }


    #
    # 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}}) {
              my ($date, $date_ext) = get_date_tag($vol);
              next unless($date && ($vol =~ /^$svol\./));
              push(@schedule, { value => "$droot/$vol", name => $vol, date => $date, date_ext => $date_ext });
            }
            my (undef, $delete) = schedule(
              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"),
              log_verbose          => 1,
             );
            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;
            }
          }

          #
          # 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}}) {
            my ($date, $date_ext) = get_date_tag($vol);
            next unless($date && ($vol =~ /^$snapdir$svol\./));
            push(@schedule, { value => "$sroot/$vol", name => $vol, date => $date, date_ext => $date_ext });
          }
          my (undef, $delete) = schedule(
            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"),
            log_verbose          => 1,
           );
          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";
          }
        }
      }
    }

    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 "\nLegend:\n";
      print "    +++  created subvolume (source snapshot)\n";
      print "    ---  deleted subvolume\n";
      print "    ***  received subvolume (non-incremental)\n";
      print "    >>>  received subvolume (incremental)\n";
      # print "    %>>  received subvolume (incremental, resume_missing)\n";
      print "--------------------------------------------------------------------------------";
      foreach my $config_vol (@{$config->{VOLUME}})
      {
        if($config_vol->{ABORTED}) {
          print "!!! $config_vol->{sroot}: ABORTED: $config_vol->{ABORTED}\n";
          $err_count++ unless($config_vol->{ABORTED_NOERR});
        }
        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++ unless($config_subvol->{ABORTED_NOERR});
          }
          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}})
          {
            foreach(@{$config_target->{subvol_received} // []}) {
              my $create_mode = "***";
              $create_mode = ">>>" if($_->{parent});
              # substr($create_mode, 0, 1, '%') if($_->{resume});
              $create_mode = "!!!" if($_->{ERROR});
              print "$create_mode $_->{received_name}\n";
            }

            if($config_target->{subvol_deleted}) {
              print "--- $_\n" foreach(sort { $b cmp $a} @{$config_target->{subvol_deleted}});
            }

            if($config_target->{ABORTED}) {
              print "!!! Target \"$config_target->{droot}\" aborted: $config_target->{ABORTED}\n";
              $err_count++ unless($config_target->{ABORTED_NOERR});
            }
          }
        }
      }
      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($preserve_backups) {
        print "\nNOTE: Preserved all backups (option -p present)\n";
      }
      if($dryrun) {
        print "\nNOTE: Dryrun was active, none of the operations above were actually executed!\n";
      }
    }
  }
}


1;