Mercurial > hg > mhoward > dotfiles / file revision

#!/usr/bin/env perl
use 5.014;
use warnings;
use strict;
use Time::Piece;
use Path::Tiny;
use Getopt::Long::Descriptive;

sub main {
  my ($opt, $usage) = describe_options(
    'archive-dir %o <directory> ...',
    ['dest|d=s' => "destination path"],
    ['subdir'   => hidden => {
      one_of => [
        ['year|y'  => 'file by year'],
        ['month|m' => 'file by month'],
      ],
      default => 'year',
      }
    ],
    ['age|a=i' => "minimum age in days for archival", {default => 60}],
    ['files|f' => "operate on plain files only"],
    ['yes|Y'   => "actually move stuff"],
    ['help|h'  => "print usage message and exit", {shortcircuit => 1}],
  );
  print($usage->text), exit if $opt->help || !@ARGV;

  archive_dir($opt, $_) for @ARGV;
}

sub archive_dir {
  my $opt     = shift;
  my $dir     = path(shift);
  my $destdir = path($opt->dest // '.');
     $destdir = $dir->child($destdir) if $destdir->is_relative;
  my $destfmt = ($opt->subdir eq 'month') ? '%Y-%m' : '%Y';
  my $nowish  = time;
  my $age     = $opt->age * 24 * 60 * 60;

  my @work;

  for my $child ($dir->children) {
    next if $child->is_dir && (
      $opt->files || $child eq $destdir || $child =~ /^(?:\d{4}|\d\d)$/
    );
    next if $opt->files && $child->basename =~ /^\./;

    my $mtime = $child->stat->mtime;
    next unless ($nowish - $mtime) >= $age;

    my $dest = $destdir->child(localtime($mtime)->strftime($destfmt));
    push @work, [$dest, $child];
  }

  my $lastdest = '';
  for my $work (sort {$a->[0] cmp $b->[0]} @work) {
    my ($dest, $child) = @$work;

    say $lastdest = $dest
      if $dest ne $lastdest;

    say "\t$child";

    next unless $opt->yes;
    $dest->mkpath;
    $child->move($dest . '/' . $child->relative($dir));
  }
}

main();