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;

}