#! /usr/bin/env perl

use strict;
use warnings;

use Data::Dumper;
use Time::Local qw( timelocal_posix timegm_posix );
use Getopt::Long;
Getopt::Long::Configure ("bundling");

use constant SECONDS_IN_DAY => 86400;

my $config = {};

# runs a command, redirecting stderr to stdout (which it ignores)
# then returns 0 and $output on success.
# if error, returns error code and string describing error
sub run {
   my $command = shift;
   my $output = qx/$command 2>&1/;
   if ($? == -1) {
      return (-1,"failed to execute: $!");
   } elsif ($? & 127) {
      return ($?, sprintf "child died with signal %d, %s coredump",
        ($? & 127),  ($? & 128) ? 'with' : 'without' );
   } else {
      return ($? >> 8, sprintf "child exited with value %d", $? >> 8 ) if $? >> 8;
   }
   return (0,$output);
}

sub dateToUnixTime {
   my ( $date, $time ) = @_;
   my ($year,$month,$day) = split( /\D/, $date );
   my ($hour,$minute,$second) = split( /\D/, $time );
   $second = '00' unless $second;
   return timelocal_posix( $second,$minute,$hour,$day,$month-1,$year-1900);
}

sub getSnaps {
   my $config = shift;
   my %snaps;
   my ($error,$output) = &run( 
      # 'H' uses a single tab between fields
      "zfs list -H" . 
      # if they asked for recursion, add the 'r' flag
      ( $config->{'recurse'} ? 'r' : '' ) . 
      # type snap, and the dataset name
      "t snap $config->{dataset}" );
#   die $output;
   my @snaps = split( "\n", $output );
   chomp @snaps;
   while ( my $thisSnap = pop @snaps ) {
      my ($name,$used,$avail,$refer,$mountpoint) = split( "\t", $thisSnap );
      if ( $name =~ m/$config->{'filter'}/ ) {
         my $created = &dateToUnixTime( $1,$2 );
         $snaps{$name}->{'date'} = $created if ( $created < $config->{'pruneBefore'} );
      }
   }
   return \%snaps;
}

sub makeDestroyCommands {
   my @commands;
   
#   die Dumper( @_ ) . "\n";

   while ( my $snap = shift ) {
      push @commands, "zfs destroy $snap";
   }
   return \@commands;
}

sub help {
   my $message = shift;
   print "\n== $message ==\n\n" if $message;
   my $help =  <<"      EOF";
      usage: $0 [options] dataset
         --dataset - Dataset to process. May also be defined with no flags
                     REQUIRED
         --recurse - If set, will recurse through child datasets
                     default: do not recurse
         --ttl     - Time To Live, in days. Anything older will be destroyed
                     default: 90 days
         --filter  - Perl Regular Expression to match snapshots. Non-match are
                     ignored
                     default: matches YYYY.MM.DD.HH.MM where . is any character
         --dryrun  - Do not actually do the destroy. -n is short version
         --verbose - Be verbose (only one level)
   
      Simple script to prune old snapshots. Snapshots must have date/time
      stamp, which must be surrounded by parenthesis in filter.

      Examples:
      $0 storage
         destroy all snapshots older than 90 days (default) in dataset storage

      $0 -r -d 'storage'
         destroy all snapshots older than 90 days in dataset storage and all
         child datasets
   
      $0  -rvt 120 -f 'weekly_(\\d{4}-\\d{2}-\\d{2})_(\\d{2}-\\d{2})' storage
         destroy all snapshots older and 120 days from storage/ and all
         children which have the form weekly_YYYY-MM-DD_HH-MM
      EOF
   $help =~ s/^ {6}//gm;
   print $help;

   exit();
}

# set some defaults
# default time to live, in days. Everything older will be destroyed
$config->{'ttl'} = 90;
# regex to match snapshot names. Default is just YYYY?MM?DD?HH?MM, where ? is aany delimiter
$config->{'filter'} = '(\d{4}.\d{2}.\d{2}).(\d{2}.\d{2})';

GetOptions( $config,
   'dataset|d=s',
   'ttl|t=i',
   'filter|f=s',
   'dryrun|n',
   'recurse|r',
   'verbose|v',
   'help|h'
);

$config->{'dataset'} = @ARGV ? shift : '' unless $config->{'dataset'};

#print Dumper( $config );

&help() if $config->{'help'};
&help( 'No dataset defined')  unless $config->{'dataset'};

$config->{'now'} = time;
printf "Starting prune of ZFS Snapshots at %s\n", scalar localtime( $config->{'now'} ) if $config->{'verbose'};
$config->{'pruneBefore'} = $config->{'now'} - $config->{'ttl'} * SECONDS_IN_DAY;
printf "Pruning before %s \n", scalar localtime($config->{'pruneBefore'}) if $config->{'verbose'};

$config->{'snaps'} = &getSnaps( $config );

#die Dumper( $config->{'snaps'} ) . "\n";

my $commands = &makeDestroyCommands( sort keys %{ $config->{'snaps'} } );

#die Dumper( $commands ) . "\n";

if ( @$commands ) {
   for ( my $i=0; $i < @$commands; $i++ ) {
      print $commands->[$i] . "\n" if $config->{'dryrun'}  || $config->{'verbose'};
      next if $config->{'dryrun'};
      #my ($error,$output) = &run ($commands->[$i]);
      #print "Error running command\n$commands->[$i]\n$output\n" if ( $error );
   }
} else {
   print "No snapshots found to destroy\n" if $config->{'verbose'};
}

printf "Prune completed at %s\n", scalar localtime( time ) if $config->{'verbose'};   

1;