Subversion Repositories zfs_utils

#!/usr/bin/env perl
use strict;
use warnings;
use File::Temp qw(tempdir);
use File::Spec;
use Cwd qw(abs_path);
use File::Basename qw(dirname);
use Time::Piece;

my $td = tempdir(CLEANUP => 1);

# location of the cleanSnaps script (this test lives in the same directory as the test file)
my $here = dirname(abs_path(__FILE__));
my $clean = File::Spec->catfile($here, 'cleanSnaps');
unless (-e $clean) {
    die "Could not find cleanSnaps at $clean";
}

# If a snapshot list filename was provided on the command line, use that file as the
# source of snapshot names. Otherwise, create a fake zfs-list script with sample names.
my $snaplist_file = shift @ARGV;
my $fake;
if ($snaplist_file && -e $snaplist_file) {
    $fake = File::Spec->catfile($td, 'fake_zfs_list.sh');
    open my $fh, '>', $fake or die $!;
    print $fh "#!/bin/sh\ncat \"$snaplist_file\"\n";
    close $fh;
    chmod 0755, $fake;
} else {
    $fake = File::Spec->catfile($td, 'fake_zfs_list.sh');
    open my $fh, '>', $fake or die $!;
    print $fh <<'EOF';
#!/bin/sh
cat <<'SNAPS'
pool/fs@2025-01-01-3d
pool/fs@2025-12-10-3d
pool/fs@2025-12-14-2d
pool/fs@2025-11-01-snap-4w
pool/fs@2025-12-01_foo_1m
pool/fs@badname
pool/fs@2025-12-01T12:00:00_1h
pool/fs@prefix_2025-12-01 13:00:00_2h
SNAPS
EOF
    close $fh;
    chmod 0755, $fake;
}

# Run cleanSnaps in dry-run verbose mode with the fake ZFS command
local %ENV = %ENV;
$ENV{ZFS_CMD} = $fake;

# execute and capture output (use perl from the environment if available)
my $out;
if ($ENV{PERL}) {
    $out = qx{$ENV{PERL} -I. "$clean" -v 2>&1};
} else {
    $out = qx{perl -I. "$clean" -v 2>&1};
}

print "=== cleanSnaps output ===\n$out\n";

my @lines = split /\n/, $out;
my @removed = map { s/^\s+//; $_ } grep { /^\s+\S+@/ } @lines;

my %removed = map { $_ => 1 } @removed;

# Compute expected removals using the same rules as cleanSnaps so the test is
# robust against clock/time differences. Read the sample snapshot list by
# executing the fake zfs list script and parse each snapshot name.
my $snap_output = qx{$fake};
my @snap_lines = split /\n/, $snap_output;

my @fmts = (
    '%Y-%m-%d %H:%M:%S',
    '%Y-%m-%dT%H:%M:%S',
    '%Y-%m-%d %H:%M',
    '%Y-%m-%d_%H.%M.%S',
    '%Y-%m-%d_%H.%M',
    '%Y-%m-%d',
);

sub parse_and_should_remove {
    my ($snap, $now) = @_;
    # expect full snapshot name like pool/fs@name
    return 0 unless $snap =~ /@/;
    my (undef, $snapname) = split /@/, $snap, 2;
    return 0 unless $snapname =~ m/.*?(\d{4}-\d{2}-\d{2}(?:[T _]\d{2}[:\.]\d{2}(?:[:\.]\d{2})?)?)(?:.*?)(\d+)([smhdwy])$/;
    my ($snap_date, $num, $unit) = ($1, $2, $3);
    # parse date/time
    my $snap_epoch;
    my $parsed = 0;
    for my $fmt (@fmts) {
        eval {
            my $tp = Time::Piece->strptime($snap_date, $fmt);
            $snap_epoch = $tp->epoch;
            $parsed = 1;
            1;
        };
        last if $parsed;
    }
    return 0 unless $parsed;
    my $retention_seconds;
    if ($unit eq 's') { $retention_seconds = $num }
    elsif ($unit eq 'm') { $retention_seconds = $num * 30 * 86400 }
    elsif ($unit eq 'h') { $retention_seconds = $num * 3600 }
    elsif ($unit eq 'd') { $retention_seconds = $num * 86400 }
    elsif ($unit eq 'w') { $retention_seconds = $num * 7 * 86400 }
    elsif ($unit eq 'y') { $retention_seconds = $num * 365 * 86400 }
    else { return 0 }
    my $age = $now - $snap_epoch;
    return $age > $retention_seconds ? 1 : 0;
}

my $now = time();
my %expected_removed;
for my $line (@snap_lines) {
    next unless $line =~ /@/;
    my $should = parse_and_should_remove($line, $now);
    $expected_removed{$line} = $should if $should;
}

my $ok = 1;
for my $snap (keys %expected_removed) {
    unless ($removed{$snap}) {
        print "FAIL: expected $snap to be marked for removal\n";
        $ok = 0;
    }
}
for my $line (@snap_lines) {
    next unless $line =~ /@/;
    unless ($expected_removed{$line}) {
        if ($removed{$line}) {
            print "FAIL: expected $line to be kept but it was marked for removal\n";
            $ok = 0;
        }
    }
}

if ($ok) {
    print "TEST PASS\n";
    exit 0;
} else {
    print "TEST FAIL\n";
    exit 1;
}