Subversion Repositories zfs_utils

#!/usr/bin/env perl

# Simplified BSD License (FreeBSD License)

#

# Copyright (c) 2025, Daily Data Inc.

# All rights reserved.

#

# Redistribution and use in source and binary forms, with or without

# modification, are permitted provided that the following conditions are met:

#

# 1. Redistributions of source code must retain the above copyright notice, this

#    list of conditions and the following disclaimer.

#

# 2. Redistributions in binary form must reproduce the above copyright notice,

#    this list of conditions and the following disclaimer in the documentation

#    and/or other materials provided with the distribution.

#

# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"

# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE

# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE

# DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE

# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL

# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR

# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER

# CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,

# OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

# cleanSnaps - detect and remove old ZFS snapshots named like YYYY-MM-DD-<N><d|w|m>

# Usage: cleanSnaps [-f] [-v] [-t <shift>] [-V] [-h]

#   -f  actually destroy snapshots (use with care)

#   -v  verbose

#   -t  time shift, simulate running at a different time. Examples:

#       -t 2m   (run as if 2 months ago)

#       -t -4w  (run as if 4 weeks earlier)

#       -t +3d  (run as if 3 days in the future)

#   -V  show version and exit

#   -h  show this help and exit

#

# Author: R. W. Rodlico <rodo@dailydata.net>

# Created: December 2025

#

# Revision History:

# Version: 1.0 RWR 2025-12-18

# Initial release with time-shift simulation and snapshot retention logic

#

# Version: 1.1 RWR 2025-12-18

# Added --unmatched/-u flag to clean snapshots that don't match the retention pattern regex

# When --unmatched is used, ONLY unmatched snapshots are removed (normal retention logic is skipped)

use strict;

use warnings;

our $VERSION = '1.1';

use Getopt::Long qw(GetOptions);

use Time::Piece;

# Allow short option bundling (e.g. -fv) and accept long names

Getopt::Long::Configure('bundling');

my %opts;

GetOptions(\%opts,

    'force|f',        # force (actually perform destroys)

    'verbose|v',      # verbose

    'help|h',         # help

    'version|V',      # version

    'timeshift|t=s',  # time shift string (alias -t)

    'unmatched|u',    # clean snapshots that don't match the pattern

) or die "Error parsing command line options\n";

# Normalize options: default behaviour is dry-run unless --force is specified.

my $FORCE     = (defined $opts{'force'} || defined $opts{'f'}) ? 1 : 0;

my $VERBOSE   = (defined $opts{'verbose'} || defined $opts{'v'}) ? 1 : 0;

my $UNMATCHED = (defined $opts{'unmatched'} || defined $opts{'u'}) ? 1 : 0;

my $timeshift = defined $opts{'timeshift'} ? $opts{'timeshift'} : $opts{'t'};

my $ZFS_CMD = $ENV{ZFS_CMD} // 'zfs';

sub logmsg { print @_, "\n" if $VERBOSE }

# show version and exit

if ($opts{'version'} || $opts{'V'}) {

    print "cleanSnaps version $VERSION\n";

    exit 0;

}

# show help and exit

if ($opts{'help'} || $opts{'h'}) {

    print "Usage: cleanSnaps [--force|-f] [--verbose|-v] [--timeshift|-t <shift>] [--unmatched|-u] [--version|-V] [--help|-h] [pool]\n";

    print "  --force, -f         actually destroy snapshots (default: dry-run)\n";

    print "  --verbose, -v       verbose logging\n";

    print "  --timeshift, -t     time shift, simulate running at a previous time (examples: 2m, -4w, +3d)\n";

    print "  --unmatched, -u     ONLY clean snapshots that don't match the retention pattern (skips normal retention)\n";

    print "  --version, -V       show version and exit\n";

    print "  --help, -h          show this help and exit\n";

    exit 0;

}

# compute simulated "now" if the user requested a time shift

# allows us to keep or remove snapshots as if we were running at a different time

# giving retention decisions less stringent on, say, backup systems

my $now = time();

if (defined $timeshift && $timeshift =~ /^(?:([+-]?)(\d+)([smhdwy]))$/i) {

    my ($sign, $num, $unit) = ($1, $2, lc $3);

    # default behavior: no leading sign => treat as negative (simulate running in the past)

    $sign = '-' unless defined $sign && $sign ne '';

    my %unit_secs = (

        s => 1,

        m => 30 * 86400,   # months approximated as 30 days to match snapshot 'm' semantics

        h => 3600,

        d => 86400,

        w => 7 * 86400,

        y => 365 * 86400,

    );

    if (!exists $unit_secs{$unit}) {

        die "Invalid time unit '$unit' in -t option; use s,m,h,d,w,y\n";

    }

    my $shift_seconds = $num * $unit_secs{$unit};

    $shift_seconds = -$shift_seconds if $sign eq '-';

    $now += $shift_seconds;

    my $ts_display = defined $timeshift ? $timeshift : $opts{t};

    logmsg("Simulating current time with shift $ts_display; adjusted now -> " . scalar(localtime($now)) );

}

my @candidates; # this will hold the candidates for removal

# Optional command-line parameter: pool name to process (only snapshots from this pool will be considered)

my $pool = shift @ARGV;

if ($pool) {

    logmsg("Filtering snapshots to pool: $pool");

}

# if a pool name was given, limit zfs list to that pool and do a recursive list

# recursion is done by default if no pool given

my $command = $ZFS_CMD . ' list -H -o name -t snapshot' . ($pool ? " -r $pool" : '');

open my $fh, '-|', $command or die "Failed to run $ZFS_CMD: $!";

while (my $snap = <$fh>) {

    chomp $snap;

    next unless defined $snap && $snap =~ /\S/;

    unless ($snap =~ /@/) {

        logmsg("skipping invalid snapshot name: $snap");

        next;

    }

    my ($dataset, $snapname) = split /@/, $snap, 2;

    # match an optional prefix, a date or date-time stamp, optional text, then TTL

    # Examples matched:

    #   pool@snapname-2025-12-01-3d

    #   pool@prefix_2025-12-01T12:30:00_foo_3h

    #   pool@2025-12-01_foo_2w

    # allow time separators of ':' or '.' and optional underscore or space before time

    unless ($snapname =~ m/.*?(\d{4}-\d{2}-\d{2}(?:[T _]\d{2}[:\.]\d{2}(?:[:\.]\d{2})?)?)(?:.*?)(\d+)([smhdwy])$/) {

        logmsg("snapshot does not match ...<date/time>...<N><s|m|h|d|w|y>: $snap");

        # if --unmatched flag is set, mark this snapshot for removal

        if ($UNMATCHED) {

            push @candidates, $snap;

            logmsg("marked for removal (unmatched pattern): $snap") if $VERBOSE;

        }

        next;

    }

    # If --unmatched flag is set, skip normal retention processing for matched snapshots

    if ($UNMATCHED) {

        logmsg("skipping retention check (matched pattern): $snap") if $VERBOSE;

        next;

    }

    my ($snap_date, $num, $unit) = ($1, $2, $3);

    # parse snapshot date/time using Time::Piece; accept several common formats

    my $snap_epoch;

    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',

    );

    # try to parse using each format until one works

    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;

    }

    # didn't parse successfully, show message and skip

    unless ($parsed) {

        logmsg("failed to parse date/time '$snap_date' for $snap");

        # if --unmatched flag is set, mark this snapshot for removal (pattern matched but date parsing failed)

        if ($UNMATCHED) {

            push @candidates, $snap;

            logmsg("marked for removal (date parse failed): $snap") if $VERBOSE;

        }

        next;

    }

    # compute retention in seconds according to unit (s,m,h,d,w,m,y)

    my $retention_seconds;

    if ($unit eq 's') { $retention_seconds = $num }

    elsif ($unit eq 'm') { $retention_seconds = $num * 30 * 86400 }   # months ~= 30 days

    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 { logmsg("unknown unit $unit for $snap"); next }

   # determine if snapshot is older than retention period

    my $age = $now - $snap_epoch;

    if ($age > $retention_seconds) { # ready for removal

        push @candidates, $snap;

    } else { # keep

        my $age_days = $age / 86400;

        my $ret_days = $retention_seconds / 86400;

        logmsg("keep: $snap (age " . sprintf("%.2f", $age_days) . "d <= " . sprintf("%.2f", $ret_days) . "d)");

    }

}

close $fh;

if (!@candidates) {

    print "No snapshots to remove.\n";

    exit 0;

}

printf "Snapshots to remove (%d):\n", scalar @candidates;

for my $s (@candidates) { printf "  %s\n", $s }

if (!$FORCE) {

    print "\nDry-run: no snapshots were destroyed. Use -f to actually remove them.\n";

    exit 0;

}

# actual removal. If any fail, report error but continue to remove rest

my $failed = 0;

for my $s (@candidates) {

    printf "Destroying: %s\n", $s;

    my $rc = system($ZFS_CMD, 'destroy', $s);

    if ($rc != 0) {

        printf STDERR "Failed to destroy %s\n", $s;

        $failed = 1;

    }

}

if ($failed) {

    print STDERR "One or more destroys failed.\n";

    exit 1;

}

print "Done.\n";