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 1 (retention logic) PASS\n";

} else {

    print "TEST 1 (retention logic) FAIL\n";

    exit 1;

}

# TEST 2: Test the --unmatched flag

print "\n=== Testing --unmatched flag ===\n";

# Run cleanSnaps with --unmatched flag to remove snapshots that don't match the pattern

my $out_unmatched;

if ($ENV{PERL}) {

    $out_unmatched = qx{$ENV{PERL} -I. "$clean" -v -u 2>&1};

} else {

    $out_unmatched = qx{perl -I. "$clean" -v -u 2>&1};

}

print "=== cleanSnaps --unmatched output ===\n$out_unmatched\n";

my @lines_unmatched = split /\n/, $out_unmatched;

my @removed_unmatched = map { s/^\s+//; $_ } grep { /^\s+\S+@/ } @lines_unmatched;

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

# Expected: ONLY pool/fs@badname should be marked for removal (doesn't match pattern)

# All other snapshots that match the pattern should be SKIPPED (not removed)

my $ok2 = 1;

if ($removed_unmatched{'pool/fs@badname'}) {

    print "PASS: pool/fs\@badname marked for removal with --unmatched flag\n";

} else {

    print "FAIL: pool/fs\@badname should be marked for removal with --unmatched flag\n";

    $ok2 = 0;

}

# Verify that matched snapshots are NOT removed when --unmatched is used

my @matched_snaps = grep { $_ ne 'pool/fs@badname' } @snap_lines;

for my $snap (@matched_snaps) {

    next unless $snap =~ /@/;

    if ($removed_unmatched{$snap}) {

        print "FAIL: $snap should NOT be removed with --unmatched flag (only unmatched should be removed)\n";

        $ok2 = 0;

    }

}

# Count should be exactly 1 (only the unmatched snapshot)

my $unmatched_count = scalar(@removed_unmatched);

if ($unmatched_count != 1) {

    print "FAIL: Expected exactly 1 snapshot to be removed with --unmatched flag, got $unmatched_count\n";

    $ok2 = 0;

} else {

    print "PASS: Exactly 1 unmatched snapshot marked for removal (normal retention skipped)\n";

}

if ($ok2) {

    print "TEST 2 (--unmatched flag) PASS\n";

} else {

    print "TEST 2 (--unmatched flag) FAIL\n";

    exit 1;

}

# TEST 3: Test --version flag

print "\n=== Testing --version flag ===\n";

my $version_out;

if ($ENV{PERL}) {

    $version_out = qx{$ENV{PERL} -I. "$clean" --version 2>&1};

} else {

    $version_out = qx{perl -I. "$clean" --version 2>&1};

}

print "=== cleanSnaps --version output ===\n$version_out\n";

if ($version_out =~ /cleanSnaps version \d+\.\d+/) {

    print "TEST 3 (--version flag) PASS\n";

} else {

    print "TEST 3 (--version flag) FAIL\n";

    exit 1;

}

print "\n=== All tests PASSED ===\n";

exit 0;