| File: | blib/lib/App/FileSync/Snapshot.pm |
| Coverage: | 85.0% |
| line | stmt | bran | cond | sub | time | code |
|---|---|---|---|---|---|---|
| 1 | package App::FileSync::Snapshot; | |||||
| 2 | ||||||
| 3 | # Daily point-in-time copies of a replica's tree, kept inside the replica root | |||||
| 4 | # under .filesync-snapshots/YYYY-MM-DD. Hard links make an unchanged file | |||||
| 5 | # cost nothing; copies are used where links are not possible. | |||||
| 6 | ||||||
| 7 | 314 314 314 | 1049 258 4269 | use App::FileSync::Platform; | |||
| 8 | ||||||
| 9 | 314 314 314 | 515 235 2582 | use strict; | |||
| 10 | 314 314 314 | 494 228 6387 | use warnings; | |||
| 11 | 314 314 314 | 539 260 788 | use autodie qw(:all); | |||
| 12 | ||||||
| 13 | 314 314 314 | 672277 296 8079 | use File::Path qw(remove_tree); | |||
| 14 | 314 314 314 | 628 270 3049 | use File::Spec; | |||
| 15 | 314 314 314 | 618 260 6247 | use Readonly; | |||
| 16 | 314 314 314 | 617 264 1020 | use Sub::Private { mode => 'enforce' }; | |||
| 17 | 314 314 314 | 31277 271 2837 | use Time::HiRes (); | |||
| 18 | ||||||
| 19 | 314 314 314 | 499 288 5591 | use App::FileSync qw(validate_relpath); | |||
| 20 | 314 314 314 | 559 256 5359 | use App::FileSync::Args qw(named); | |||
| 21 | 314 314 314 | 542 277 17823 | use App::FileSync::Constants qw($MODE_MASK $ROOT_MARKER $SNAPSHOT_DIR $STALE_TEMP_SECONDS $TEMP_PREFIX); | |||
| 22 | 314 314 314 | 637 251 5703 | use App::FileSync::I18N qw(throw os_error); | |||
| 23 | 314 314 314 | 547 276 5581 | use App::FileSync::IO qw(copy_preserving ensure_dir list_dir); | |||
| 24 | ||||||
| 25 | 314 314 314 | 517 252 763 | use version; our $VERSION = version->declare('0.001.1'); | |||
| 26 | ||||||
| 27 | # Kept for compatibility: the snapshot directory's name. | |||||
| 28 | our $DIR_NAME = $SNAPSHOT_DIR; | |||||
| 29 | ||||||
| 30 | # The two ways a snapshot can hold a file. | |||||
| 31 | Readonly my $HARDLINK => 'hardlink'; | |||||
| 32 | Readonly my $COPY => 'copy'; | |||||
| 33 | ||||||
| 34 | # A snapshot date, and an interrupted attempt's directory. | |||||
| 35 | Readonly my $DATE => qr/\A\d{4}-\d{2}-\d{2}\z/; | |||||
| 36 | Readonly my $TEMP_DIR => qr/\A\.tmp-\d+-\d+\z/; | |||||
| 37 | Readonly my $TEMP_FILE => qr/\A\Q$TEMP_PREFIX\E/; | |||||
| 38 | ||||||
| 39 | # Windows has no POSIX permission bits worth restoring on a directory. | |||||
| 40 | Readonly my $HAS_MODES => $^O ne 'MSWin32'; | |||||
| 41 | ||||||
| 42 | # Range for the random part of a temporary snapshot directory's name. | |||||
| 43 | Readonly my $TEMP_RANGE => 1_000_000; | |||||
| 44 | ||||||
| 45 | # Every function takes the replica root and needs it. | |||||
| 46 | my %ROOT = (root => { type => 'string', min => 1 }); | |||||
| 47 | ||||||
| 48 | =encoding utf8 | |||||
| 49 | ||||||
| 50 - 100 | =head1 NAME
App::FileSync::Snapshot - daily snapshots of a replica
=head1 SYNOPSIS
my $made = App::FileSync::Snapshot::create(root => $replica_root);
my $all = App::FileSync::Snapshot::list(root => $replica_root);
App::FileSync::Snapshot::prune(root => $replica_root, keep => 14);
App::FileSync::Snapshot::restore(root => $replica_root, date => '2026-10-22', to => '/tmp/out');
=head1 FUNCTIONS
=head2 snapshot_root
Purpose: where a replica keeps its snapshots.
Args: C<$root>, the replica's sync root.
Returns: F<ROOT/.filesync-snapshots>.
Side Effects: none.
Usage:
my $dir = App::FileSync::Snapshot::snapshot_root($root);
=head3 EXAMPLE
print App::FileSync::Snapshot::snapshot_root('/data/replica'), "\n";
=head3 API SPECIFICATION
=head4 INPUT
[ { name => 'root', type => 'string', min => 1 } ]
=head4 OUTPUT
{ type => 'string', min => 1 }
=head3 MESSAGES
Key Meaning Resolution
snapshot.no_root no root given pass the replica root
=head3 FORMAL SPECIFICATION
snapshot_root(r) = r / ".filesync-snapshots"
=cut | |||||
| 101 | ||||||
| 102 | sub snapshot_root { | |||||
| 103 | 30 | 29 | my ($root) = @_; | |||
| 104 | ||||||
| 105 | 30 | 62 | throw('snapshot.no_root') unless defined $root && length $root; | |||
| 106 | 30 | 97 | return File::Spec->catdir($root, $SNAPSHOT_DIR); | |||
| 107 | } | |||||
| 108 | ||||||
| 109 - 155 | =head2 date_for_epoch
Documented with L</default_mode> below.
=head2 is_date
Documented with L</default_mode> below.
=head2 default_mode
Purpose: snapshot naming and the platform's preferred storage.
Args: C<date_for_epoch($epoch)> (default now); C<is_date($string)>.
Returns: C<YYYY-MM-DD> (UTC); 1 or 0; C<hardlink>, or C<copy> on Windows.
Side Effects: none.
Usage:
my $today = App::FileSync::Snapshot::date_for_epoch();
=head3 EXAMPLE
print App::FileSync::Snapshot::is_date('2026-10-22'), "\n"; # 1
=head3 API SPECIFICATION
=head4 INPUT
[ { name => 'value', type => 'scalar', optional => 1 } ]
=head4 OUTPUT
{ type => 'scalar' }
=head3 MESSAGES
None.
=head3 FORMAL SPECIFICATION
date_for_epoch(e) = yyyy-mm-dd of gmtime(e)
is_date(s) ⇔ s ∈ DIGITⴠ†"-" †DIGIT² †"-" †DIGIT²
default_mode = copy if OS = MSWin32, hardlink otherwise
=cut | |||||
| 156 | ||||||
| 157 | sub date_for_epoch { | |||||
| 158 | 10 | 89796 | my ($epoch) = @_; | |||
| 159 | ||||||
| 160 | 10 | 29 | my @t = gmtime(defined $epoch ? $epoch : time); | |||
| 161 | 10 | 36 | return sprintf('%04d-%02d-%02d', $t[5] + 1900, $t[4] + 1, $t[3]); | |||
| 162 | } | |||||
| 163 | ||||||
| 164 | sub is_date { | |||||
| 165 | 20 | 21 | my ($date) = @_; | |||
| 166 | ||||||
| 167 | 20 | 75 | return (defined $date && $date =~ $DATE) ? 1 : 0; | |||
| 168 | } | |||||
| 169 | ||||||
| 170 | sub default_mode { | |||||
| 171 | 14 | 91580 | return $^O eq 'MSWin32' ? $COPY : $HARDLINK; | |||
| 172 | } | |||||
| 173 | ||||||
| 174 - 240 | =head2 create
Purpose: take today's snapshot of the replica tree.
Args: C<root> (required), optional C<date> (default today, from C<now>), C<now>,
C<mode> (C<hardlink> or C<copy>; default L</default_mode>).
A day is never overwritten: the first snapshot of the day is the state before
that day's first sync, which is the one worth keeping.
Returns: C<{ date, path, created, files, bytes, linked, copied, mode }>;
C<created> is 0 (and the counts 0) when that day already exists.
Side Effects: builds the snapshot in a temporary directory and renames it into
place, so an interrupted run leaves no half snapshot. Removes interrupted
attempts older than an hour. Hard links share storage with the live tree;
a file that cannot be linked (another filesystem) is copied.
Usage:
my $made = App::FileSync::Snapshot::create(root => $root, mode => 'hardlink');
=head3 EXAMPLE
my $made = App::FileSync::Snapshot::create(root => '/data/replica');
print "$made->{files} files in $made->{path}\n" if $made->{created};
=head3 API SPECIFICATION
=head4 INPUT
{
root => { type => 'string', min => 1 },
date => { type => 'string', optional => 1, matches => qr/\A\d{4}-\d{2}-\d{2}\z/ },
now => { type => 'number', optional => 1 },
mode => { type => 'string', optional => 1, memberof => [ 'hardlink', 'copy' ] },
}
=head4 OUTPUT
{ type => 'hashref' }
=head3 MESSAGES
Key Meaning Resolution
snapshot.not_dir the root is not a directory check the replica root
snapshot.bad_date the date is not YYYY-MM-DD fix the argument
snapshot.bad_mode the mode is not hardlink or copy fix snapshot_mode
snapshot.read a directory cannot be read check permissions
snapshot.failed a link, copy or rename failed check permissions and space
=head3 FORMAL SPECIFICATION
ΔFS
let t = snapshot_root / date
t ∈ dom FS ⇒ FS' = FS ∧ created = 0
t ∉ dom FS ⇒ tree'(t) = tree(root) \ reserved ∧ created = 1
=head3 PSEUDOCODE
if today's directory exists: report it and stop
remove interrupted attempts older than an hour
mirror the tree into a fresh temporary directory, linking or copying
rename the temporary directory to the date
on any failure remove the temporary directory and raise
=cut | |||||
| 241 | ||||||
| 242 | sub create { | |||||
| 243 | 16 | 6056 | my $args = named(\@_, { | |||
| 244 | %ROOT, | |||||
| 245 | date => { type => 'string', optional => 1 }, | |||||
| 246 | now => { type => 'number', optional => 1 }, | |||||
| 247 | mode => { type => 'string', optional => 1 }, | |||||
| 248 | }, 'Snapshot::create'); | |||||
| 249 | ||||||
| 250 | 16 | 30 | my $root = $args->{root}; | |||
| 251 | 16 | 91 | throw('snapshot.not_dir', { path => $root }) unless -d $root; | |||
| 252 | ||||||
| 253 | 16 | 56 | my $date = defined $args->{date} ? $args->{date} : date_for_epoch($args->{now}); | |||
| 254 | 16 | 25 | throw('snapshot.bad_date', { date => $date }) unless is_date($date); | |||
| 255 | ||||||
| 256 | 16 | 114 | my $mode = defined $args->{mode} ? $args->{mode} : default_mode(); | |||
| 257 | 16 | 35 | throw('snapshot.bad_mode', { mode => $mode }) unless $mode eq $HARDLINK || $mode eq $COPY; | |||
| 258 | ||||||
| 259 | 16 | 53 | my $dir = snapshot_root($root); | |||
| 260 | 16 | 87 | my $target = File::Spec->catdir($dir, $date); | |||
| 261 | 16 | 35 | my %result = (date => $date, path => $target, mode => $mode); | |||
| 262 | ||||||
| 263 | 16 | 124 | return { %result, created => 0, files => 0, bytes => 0 } if -e $target; | |||
| 264 | ||||||
| 265 | 13 | 536 | ensure_dir($dir); | |||
| 266 | 13 | 27 | _clean_stale_temps($dir); | |||
| 267 | ||||||
| 268 | 13 | 34 | my $temp = File::Spec->catdir($dir, '.tmp-' . $$ . '-' . int(rand($TEMP_RANGE))); | |||
| 269 | 13 | 117 | ensure_dir($temp); | |||
| 270 | ||||||
| 271 | 13 | 35 | my $counts = { files => 0, bytes => 0, linked => 0, copied => 0 }; | |||
| 272 | 13 | 14 | my $ok = eval { | |||
| 273 | 13 | 24 | _mirror($root, $temp, $mode, $counts, 1); | |||
| 274 | 13 | 25 | rename $temp, $target; | |||
| 275 | 13 | 1165 | 1; | |||
| 276 | }; | |||||
| 277 | ||||||
| 278 | 13 | 19 | unless ($ok) { | |||
| 279 | 0 | 0 | my $error = $@; | |||
| 280 | 0 0 | 0 0 | eval { remove_tree($temp) }; | |||
| 281 | # autodie's objects carry the OS reason; catalogued errors pass through. | |||||
| 282 | 0 | 0 | throw('snapshot.failed', { path => $target, error => os_error($error) }) if ref $error; | |||
| 283 | 0 | 0 | die $error; ## no critic (ErrorHandling::RequireCarping) -- rethrow the catalogued error unchanged | |||
| 284 | } | |||||
| 285 | ||||||
| 286 | 13 13 | 17 63 | return { %result, created => 1, %{$counts} }; | |||
| 287 | } | |||||
| 288 | ||||||
| 289 - 327 | =head2 list
Purpose: every snapshot, newest first.
Args: C<root>.
Returns: an arrayref of C<{ date, path, files, bytes }>.
Side Effects: walks every snapshot to count it.
Usage:
for my $snap (@{ App::FileSync::Snapshot::list(root => $root) }) { ... }
=head3 EXAMPLE
printf "%s %d files\n", $_->{date}, $_->{files}
for @{ App::FileSync::Snapshot::list(root => '/data/replica') };
=head3 API SPECIFICATION
=head4 INPUT
{ root => { type => 'string', min => 1 } }
=head4 OUTPUT
{ type => 'arrayref' }
=head3 MESSAGES
Key Meaning Resolution
snapshot.read the snapshot directory is unreadable check permissions
=head3 FORMAL SPECIFICATION
list(r) = sort_desc(date) ⟨ (d, r/S/d, #files(r/S/d), Σ size) | d ∈ children(r/S) ∩ DATE ⟩
=cut | |||||
| 328 | ||||||
| 329 | sub list { | |||||
| 330 | 8 | 979 | my $args = named(\@_, {%ROOT}, 'Snapshot::list'); | |||
| 331 | ||||||
| 332 | 8 | 17 | my $dir = snapshot_root($args->{root}); | |||
| 333 | 8 | 111 | return [] unless -d $dir; | |||
| 334 | ||||||
| 335 | 8 | 20 | my $names = list_dir($dir) or throw('snapshot.read', { path => $dir, error => os_error() }); | |||
| 336 | 8 17 8 | 11 107 10 | my @dates = grep { $_ =~ $DATE && -d File::Spec->catdir($dir, $_) } @{$names}; | |||
| 337 | ||||||
| 338 | my @snapshots = map { | |||||
| 339 | 8 17 | 76 30 | my $path = File::Spec->catdir($dir, $_); | |||
| 340 | 17 | 29 | my $counts = { files => 0, bytes => 0 }; | |||
| 341 | 17 | 26 | _count($path, $counts); | |||
| 342 | 17 17 | 39 46 | { date => $_, path => $path, %{$counts} }; | |||
| 343 | } reverse @dates; | |||||
| 344 | ||||||
| 345 | 8 | 28 | return \@snapshots; | |||
| 346 | } | |||||
| 347 | ||||||
| 348 - 395 | =head2 prune
Purpose: keep the newest snapshots and remove the rest.
Args: C<root>, C<keep> (0 or undef keeps everything), C<dry_run>.
Returns: C<{ removed =E<gt> [dates], kept =E<gt> [dates] }>.
Side Effects: removes old snapshot directories unless C<dry_run>.
Usage:
App::FileSync::Snapshot::prune(root => $root, keep => 14);
=head3 EXAMPLE
my $plan = App::FileSync::Snapshot::prune(root => $root, keep => 7, dry_run => 1);
print "would remove @{ $plan->{removed} }\n";
=head3 API SPECIFICATION
=head4 INPUT
{
root => { type => 'string', min => 1 },
keep => { type => 'integer', min => 0, optional => 1 },
dry_run => { type => 'boolean', optional => 1 },
}
=head4 OUTPUT
{
type => 'hashref',
schema => { removed => { type => 'arrayref' }, kept => { type => 'arrayref' } },
}
=head3 MESSAGES
Key Meaning Resolution
snapshot.remove a snapshot cannot be removed check permissions
=head3 FORMAL SPECIFICATION
let s = list(root) (newest first)
kept = s[1 .. keep] ; removed = s[keep + 1 .. #s] if keep > 0 ∧ #s > keep
kept = s ; removed = ⟨⟩ otherwise
=cut | |||||
| 396 | ||||||
| 397 | sub prune { | |||||
| 398 | 3 | 624 | my $args = named(\@_, { | |||
| 399 | %ROOT, | |||||
| 400 | keep => { type => 'integer', min => 0, optional => 1 }, | |||||
| 401 | dry_run => { type => 'boolean', optional => 1 }, | |||||
| 402 | }, 'Snapshot::prune'); | |||||
| 403 | ||||||
| 404 | 3 | 6 | my $root = $args->{root}; | |||
| 405 | 3 | 4 | my $keep = $args->{keep}; | |||
| 406 | 3 7 3 | 3 10 5 | my @dates = map { $_->{date} } @{ list(root => $root) }; | |||
| 407 | ||||||
| 408 | 3 | 17 | return { removed => [], kept => \@dates } unless $keep && @dates > $keep; | |||
| 409 | ||||||
| 410 | 2 | 4 | my @kept = @dates[ 0 .. $keep - 1 ]; | |||
| 411 | 2 | 5 | my @removed = @dates[ $keep .. $#dates ]; | |||
| 412 | ||||||
| 413 | 2 | 4 | unless ($args->{dry_run}) { | |||
| 414 | 2 | 8 | _remove_snapshot(File::Spec->catdir(snapshot_root($root), $_)) for @removed; | |||
| 415 | } | |||||
| 416 | ||||||
| 417 | 2 | 8 | return { removed => \@removed, kept => \@kept }; | |||
| 418 | } | |||||
| 419 | ||||||
| 420 - 488 | =head2 restore
Purpose: copy a snapshot (or part of one) out.
Args: C<root>, C<date>, C<to> (the destination directory; created if
missing), optional C<paths> (relative paths inside the snapshot; default the
whole tree), C<dry_run>.
Existing destinations are replaced: this is a rollback, not a merge.
Returns: C<{ date, from, to, files, bytes, paths }>.
Side Effects: writes under C<to> unless C<dry_run>.
Usage:
App::FileSync::Snapshot::restore(root => $root, date => $date, to => $root, paths => [ 'notes' ]);
=head3 EXAMPLE
my $done = App::FileSync::Snapshot::restore(
root => '/data/replica', date => '2026-10-22', to => '/tmp/export',
);
print "$done->{files} files restored\n";
=head3 API SPECIFICATION
=head4 INPUT
{
root => { type => 'string', min => 1 },
date => { type => 'string', optional => 1 },
to => { type => 'string', optional => 1 },
paths => { type => 'arrayref', optional => 1 },
dry_run => { type => 'boolean', optional => 1 },
}
=head4 OUTPUT
{ type => 'hashref' }
=head3 MESSAGES
Key Meaning Resolution
snapshot.need_date no date was given pass --date
snapshot.bad_date the date is not YYYY-MM-DD fix it
snapshot.none no snapshot for that date run "filesync snapshot list"
snapshot.need_to no destination was given pass --to
snapshot.to_not_dir the destination is not a directory choose another
snapshot.unsafe a path fails validate_relpath fix the path
snapshot.no_path the snapshot does not hold that path check the spelling
snapshot.not_regular a special file is in the snapshot restore by hand
snapshot.cannot_stat a snapshot entry vanished retry
snapshot.replace the destination cannot be replaced check permissions
=head3 FORMAL SPECIFICATION
ΔFS
pre date ∈ dom snapshots ∧ ∀ p : paths • p ∈ SafePath ∧ p ∈ dom tree(snapshot)
¬dry_run ⇒ ∀ p : paths • tree'(to / p) = tree(snapshot / p)
=head3 PSEUDOCODE
check the date and that the snapshot exists
create the destination
paths := given paths, or every top-level entry of the snapshot
for each path: validate it, then copy it out recursively, replacing what is there
=cut | |||||
| 489 | ||||||
| 490 | sub restore { | |||||
| 491 | 4 | 1301 | my $args = named(\@_, { | |||
| 492 | %ROOT, | |||||
| 493 | date => { type => 'string', optional => 1 }, | |||||
| 494 | to => { type => 'string', optional => 1 }, | |||||
| 495 | paths => { type => 'arrayref', optional => 1 }, | |||||
| 496 | dry_run => { type => 'boolean', optional => 1 }, | |||||
| 497 | }, 'Snapshot::restore'); | |||||
| 498 | ||||||
| 499 | 4 4 | 11 9 | my ($root, $date, $to) = @{$args}{qw(root date to)}; | |||
| 500 | 4 | 22 | throw('snapshot.need_date') unless defined $date && length $date; | |||
| 501 | 4 | 8 | throw('snapshot.bad_date', { date => $date }) unless is_date($date); | |||
| 502 | ||||||
| 503 | 4 | 31 | my $snapshot = File::Spec->catdir(snapshot_root($root), $date); | |||
| 504 | 4 | 41 | throw('snapshot.none', { date => $date, path => snapshot_root($root) }) unless -d $snapshot; | |||
| 505 | ||||||
| 506 | 4 | 14 | throw('snapshot.need_to') unless defined $to && length $to; | |||
| 507 | 4 | 7 | ensure_dir($to); | |||
| 508 | 4 | 12 | throw('snapshot.to_not_dir', { path => $to }) unless -d $to; | |||
| 509 | ||||||
| 510 | 4 4 | 4 11 | my @paths = @{ $args->{paths} || [] }; | |||
| 511 | 4 1 | 5 1 | @paths = @{ list_dir($snapshot) || [] } unless @paths; | |||
| 512 | ||||||
| 513 | 4 | 12 | my $counts = { files => 0, bytes => 0 }; | |||
| 514 | 4 | 7 | for my $rel (@paths) { | |||
| 515 | 6 | 14 | my ($safe, $reason) = validate_relpath($rel); | |||
| 516 | 6 | 10 | throw('snapshot.unsafe', { path => $rel, reason => $reason }) unless $safe; | |||
| 517 | ||||||
| 518 | 6 | 31 | my $from = File::Spec->catfile($snapshot, split m{/}, $rel); | |||
| 519 | 6 | 31 | throw('snapshot.no_path', { date => $date, path => $rel }) unless -e $from || -l $from; | |||
| 520 | ||||||
| 521 | 6 | 24 | _copy_out($from, File::Spec->catfile($to, split m{/}, $rel), $counts, $args->{dry_run}); | |||
| 522 | } | |||||
| 523 | ||||||
| 524 | 4 4 | 5 19 | return { date => $date, from => $snapshot, to => $to, %{$counts}, paths => \@paths }; | |||
| 525 | } | |||||
| 526 | ||||||
| 527 | # _mirror | |||||
| 528 | # Purpose: recreate a tree inside a snapshot, linking or copying files. | |||||
| 529 | # Entry: $dst exists; $at_root is true for the replica root itself, | |||||
| 530 | # where the reserved names live. | |||||
| 531 | # Exit: returns 1. | |||||
| 532 | # Side effects: creates directories and files under $dst; updates $counts. | |||||
| 533 | # Symlinks and special files are not captured, as they are | |||||
| 534 | # not synced either. | |||||
| 535 | sub _mirror :Private { | |||||
| 536 | my ($src, $dst, $mode, $counts, $at_root) = @_; | |||||
| 537 | ||||||
| 538 | my $names = list_dir($src) or throw('snapshot.read', { path => $src, error => os_error() }); | |||||
| 539 | ||||||
| 540 | for my $name (@{$names}) { | |||||
| 541 | # The snapshots, the root marker and temporaries are bookkeeping, not | |||||
| 542 | # content; anything else, even a name starting ".filesync-", is data. | |||||
| 543 | next if $name eq $SNAPSHOT_DIR || $name =~ $TEMP_FILE || ($at_root && $name eq $ROOT_MARKER); | |||||
| 544 | ||||||
| 545 | my $from = File::Spec->catfile($src, $name); | |||||
| 546 | my $to = File::Spec->catfile($dst, $name); | |||||
| 547 | my @stat = Time::HiRes::lstat($from) or next; | |||||
| 548 | ||||||
| 549 | if (-d _) { | |||||
| 550 | ensure_dir($to); | |||||
| 551 | _mirror($from, $to, $mode, $counts, 0); | |||||
| 552 | chmod($stat[2] & $MODE_MASK, $to) if $HAS_MODES; | |||||
| 553 | } elsif (-f _) { | |||||
| 554 | # A link shares the inode, so mode and mtime are already right; | |||||
| 555 | # a copy (or a failed link across filesystems) needs them set. | |||||
| 556 | 314 314 314 | 268682 303 732 | my $linked = $mode eq $HARDLINK && do { no autodie qw(link); link($from, $to) }; | |||
| 557 | copy_preserving($from, $to, \@stat) unless $linked; | |||||
| 558 | $counts->{ $linked ? 'linked' : 'copied' }++; | |||||
| 559 | $counts->{files}++; | |||||
| 560 | $counts->{bytes} += $stat[7]; | |||||
| 561 | } | |||||
| 562 | } | |||||
| 563 | ||||||
| 564 | return 1; | |||||
| 565 | 314 314 314 | 49197 289 4107 | } | |||
| 566 | ||||||
| 567 | # _clean_stale_temps | |||||
| 568 | # Purpose: remove snapshot attempts that died part way. | |||||
| 569 | # Entry: $dir is the snapshot directory. | |||||
| 570 | # Exit: returns 1. | |||||
| 571 | # Side effects: removes .tmp-PID-N directories older than an hour; younger | |||||
| 572 | # ones may belong to a concurrent run. | |||||
| 573 | sub _clean_stale_temps :Private { | |||||
| 574 | my ($dir) = @_; | |||||
| 575 | ||||||
| 576 | my $now = time; | |||||
| 577 | for my $name (grep { $_ =~ $TEMP_DIR } @{ list_dir($dir) || [] }) { | |||||
| 578 | my $path = File::Spec->catdir($dir, $name); | |||||
| 579 | my @stat = Time::HiRes::lstat($path); | |||||
| 580 | next unless @stat && -d _ && $now - $stat[9] >= $STALE_TEMP_SECONDS; | |||||
| 581 | eval { remove_tree($path) }; | |||||
| 582 | } | |||||
| 583 | ||||||
| 584 | return 1; | |||||
| 585 | 314 314 314 | 104845 276 2724 | } | |||
| 586 | ||||||
| 587 | # _count | |||||
| 588 | # Purpose: count the regular files and bytes in a snapshot. | |||||
| 589 | # Entry: $dir exists. | |||||
| 590 | # Exit: returns 1. | |||||
| 591 | # Side effects: adds to $counts->{files} and {bytes}. | |||||
| 592 | sub _count :Private { | |||||
| 593 | my ($dir, $counts) = @_; | |||||
| 594 | ||||||
| 595 | for my $name (@{ list_dir($dir) || [] }) { | |||||
| 596 | my $path = File::Spec->catfile($dir, $name); | |||||
| 597 | my @stat = Time::HiRes::lstat($path) or next; | |||||
| 598 | if (-d _) { | |||||
| 599 | _count($path, $counts); | |||||
| 600 | } elsif (-f _) { | |||||
| 601 | $counts->{files}++; | |||||
| 602 | $counts->{bytes} += $stat[7]; | |||||
| 603 | } | |||||
| 604 | } | |||||
| 605 | ||||||
| 606 | return 1; | |||||
| 607 | 314 314 314 | 100681 263 2564 | } | |||
| 608 | ||||||
| 609 | # _remove_snapshot | |||||
| 610 | # Purpose: delete one snapshot directory. | |||||
| 611 | # Entry: $path is a dated snapshot. | |||||
| 612 | # Exit: returns 1. | |||||
| 613 | # Side effects: removes the tree; raises snapshot.remove with the first | |||||
| 614 | # reason File::Path gave. | |||||
| 615 | sub _remove_snapshot :Private { | |||||
| 616 | my ($path) = @_; | |||||
| 617 | ||||||
| 618 | remove_tree($path, { error => \my $errors }); | |||||
| 619 | if (-e $path) { | |||||
| 620 | my ($first) = map { my ($f, $why) = %{$_}; "$f: $why" } @{ $errors || [] }; | |||||
| 621 | throw('snapshot.remove', { path => $path, error => defined $first ? $first : os_error() }); | |||||
| 622 | } | |||||
| 623 | ||||||
| 624 | return 1; | |||||
| 625 | 314 314 314 | 102292 307 2525 | } | |||
| 626 | ||||||
| 627 | # _copy_out | |||||
| 628 | # Purpose: copy a snapshot entry to its destination, replacing it. | |||||
| 629 | # Entry: $src exists in the snapshot. | |||||
| 630 | # Exit: returns 1. | |||||
| 631 | # Side effects: replaces $dst (unless $dry_run); updates $counts. | |||||
| 632 | sub _copy_out :Private { | |||||
| 633 | my ($src, $dst, $counts, $dry_run) = @_; | |||||
| 634 | ||||||
| 635 | my @stat = Time::HiRes::lstat($src); | |||||
| 636 | throw('snapshot.cannot_stat', { path => $src, error => os_error() }) unless @stat; | |||||
| 637 | ||||||
| 638 | if (-d _) { | |||||
| 639 | ensure_dir($dst) unless $dry_run; | |||||
| 640 | _copy_out(File::Spec->catfile($src, $_), File::Spec->catfile($dst, $_), $counts, $dry_run) | |||||
| 641 | for @{ list_dir($src) || [] }; | |||||
| 642 | ||||||
| 643 | # Directory metadata last: filling it changed its mtime. | |||||
| 644 | unless ($dry_run) { | |||||
| 645 | chmod($stat[2] & $MODE_MASK, $dst) if $HAS_MODES; | |||||
| 646 | utime($stat[9], $stat[9], $dst); | |||||
| 647 | } | |||||
| 648 | return 1; | |||||
| 649 | } | |||||
| 650 | ||||||
| 651 | throw('snapshot.not_regular', { path => $src }) unless -f _; | |||||
| 652 | $counts->{files}++; | |||||
| 653 | $counts->{bytes} += $stat[7]; | |||||
| 654 | return 1 if $dry_run; | |||||
| 655 | ||||||
| 656 | # A rollback replaces whatever is in the way, even a directory. | |||||
| 657 | if (-d $dst && !-l $dst) { | |||||
| 658 | remove_tree($dst); | |||||
| 659 | throw('snapshot.replace', { path => $dst }) if -e $dst; | |||||
| 660 | } elsif (-e $dst || -l $dst) { | |||||
| 661 | eval { unlink $dst; 1 } or throw('snapshot.replace', { path => $dst }); | |||||
| 662 | } | |||||
| 663 | ||||||
| 664 | copy_preserving($src, $dst, \@stat); | |||||
| 665 | return 1; | |||||
| 666 | 314 314 314 | 121460 293 2651 | } | |||
| 667 | ||||||
| 668 | 1; | |||||
| 669 | ||||||