File Coverage

blib/lib/App/tmclean.pm
Criterion Covered Total %
statement 26 102 25.4
branch 0 28 0.0
condition 0 14 0.0
subroutine 9 21 42.8
pod 0 10 0.0
total 35 175 20.0


line stmt bran cond sub pod time code
1             package App::tmclean;
2 1     1   709 use 5.010;
  1         3  
3 1     1   5 use warnings;
  1         2  
  1         32  
4              
5 1     1   426 use version 0.77; our $VERSION = version->declare("v0.0.3");
  1         1897  
  1         7  
6              
7 1     1   797 use Getopt::Long qw/GetOptions :config posix_default no_ignore_case bundling auto_help/;
  1         10193  
  1         5  
8 1     1   877 use Pod::Usage qw/pod2usage/;
  1         48122  
  1         100  
9             use Class::Accessor::Lite (
10 1         8 new => 1,
11             ro => [qw/before days dry_run/],
12 1     1   543 );
  1         1147  
13 1     1   621 use HTTP::Date qw/str2time/;
  1         4278  
  1         57  
14 1     1   516 use Time::Piece ();
  1         6877  
  1         27  
15 1     1   6 use Time::Seconds ();
  1         3  
  1         1129  
16              
17             sub logf {
18 0     0 0   my $msg = shift;
19 0           $msg = sprintf($msg, @_);
20 0           my $prefix = '[tmclean]' . Time::Piece->localtime->strftime('[%Y-%m-%d %H:%M:%S] ');
21 0 0         $msg .= "\n" if $msg !~ /\n$/;
22 0           print STDERR $prefix . $msg;
23             }
24              
25             sub new_with_options {
26 0     0 0   my ($class, @argv) = @_;
27              
28 0           my ($opt) = $class->parse_options(@argv);
29 0           $class->new($opt);
30             }
31              
32             sub parse_options {
33 0     0 0   my ($class, @argv) = @_;
34              
35 0           local @ARGV = @argv;
36 0 0         GetOptions(\my %opt, qw/
37             days=i
38             before=s
39             dry-run
40             /) or pod2usage(2);
41              
42 0           $opt{dry_run} = delete $opt{'dry-run'};
43 0           return (\%opt, \@ARGV);
44             }
45              
46             sub run {
47 0     0 0   my $self = shift;
48              
49 0 0 0       if (!$self->dry_run && $ENV{USER} ne 'root') {
50 0           die "tmutil requires root privileges\n";
51             }
52 0           $self->cmd(qw/tmutil stopbackup/);
53 0           $self->cmd(qw/tmutil disable/); # need sudo
54              
55 0           my @targets = $self->backups2delete;
56 0 0         unless (@targets) {
57 0           logf 'no deletion targets found';
58 0           return 0;
59             }
60 0           my $mount_point = $self->mount_point;
61              
62 0           logf "following backups to be deleted:\n %s", join("\n ", @targets);
63 0           for my $bak (@targets) {
64 0           $self->cmd(qw/tmutil delete/, $bak); # need sudo
65             }
66 0           my $dev_name = dev_name($targets[0]);
67 0           $self->cmd(qw/hdiutil detach/, $dev_name);
68              
69 0           my $sparsebundle_path = sprintf '%s/%s.sparsebundle', $mount_point, $self->machine_name;
70 0           $self->cmd(qw/hdiutil compact/, $sparsebundle_path); # need sudo
71 0           $self->cmd(qw/tmutil enable/); # need sudo
72             }
73              
74             sub backups2delete {
75 0     0 0   my $self = shift;
76 0           my @backups = `tmutil listbackups`;
77 0 0         if ($? != 0) {
78 0           die "failed to execute `tmutil listbackups`: $?\n";
79             }
80             # e.g. /Volumes/Time Machine Backup/Backups.backupdb/$machine/2018-01-07-033608
81             return grep {
82 0           chomp;
  0            
83 0           my @paths = split m!/!, $_;
84 0           my $backup_date = eval { Time::Piece->strptime($paths[-1], '%Y-%m-%d-%H%M%S') };
  0            
85 0 0         $backup_date && $self->before_tp > $backup_date;
86             } @backups;
87             }
88              
89             sub mount_point {
90 0     0 0   my $self = shift;
91              
92             $self->{mount_point} ||= sub {
93 0     0     my @lines = `tmutil destinationinfo`;
94 0 0         if ($? != 0) {
95 0           die "failed to execute `tmutil destinationinfo`: $?\n";
96             }
97 0           for my $line (@lines) {
98 0           chomp $line;
99 0           my ($key, $val) = split /\s+:\s+/, $line, 2;
100 0 0         if ($key eq 'Mount Point') {
101 0           return $val;
102             }
103             }
104 0           die "no mount points found\n";
105 0   0       }->();
106             }
107              
108             sub dev_name {
109 0     0 0   my $path = shift;
110 0           my @paths = split m!/!, $path;
111 0           join '/', @paths[0..2];
112             }
113              
114             sub machine_name {
115 0     0 0   my $self = shift;
116              
117 0   0       $self->{machine_name} ||= do {
118 0           chomp(my $hostname = `hostname`);
119 0 0         if ($? != 0) {
120 0           die "failed to execute `hostname`: $?\n";
121             }
122 0           $hostname =~ s/\.local$//;
123 0           $hostname;
124             };
125             }
126              
127             sub before_tp {
128 0     0 0   my $self = shift;
129              
130             $self->{before_tp} ||= sub {
131 0 0   0     if ($self->before) {
132 0           my $time = str2time $self->before; # str2time parses the time as localtime
133 0 0         die "unrecognized date format @{[$self->before]}" unless $time;
  0            
134 0           return Time::Piece->localtime($time);
135             }
136 0   0       my $days = $self->days || 366;
137 0           return Time::Piece->localtime() - Time::Seconds::ONE_DAY() * $days;
138 0   0       }->();
139             }
140              
141             sub cmd {
142 0     0 0   my ($self, @command) = @_;
143              
144 0           my $cmd_str = join(' ', @command);
145 0 0         logf 'execute%s: `%s`', $self->dry_run ? '(dry-run)' : '', $cmd_str;
146 0 0         if (!$self->dry_run) {
147 0 0         !system(@command) or die "failed to execute command: $cmd_str: $?\n";
148             }
149             }
150              
151             1;
152             __END__