#!/usr/bin/perl
### sfn-move.perl  -*- Perl -*-
## Move .rsync-backup files under sfn/ directories as appropriate.

### Ivan Shmakov, 2020, 2021

## To the extent possible under law, the author(s) have dedicated
## all copyright and related and neighboring rights to this software
## to the public domain worldwide.  This software is distributed
## without any warranty.

## You should have received a copy of the CC0 Public Domain Dedication
## along with this software.  If not, see
## <http://creativecommons.org/publicdomain/zero/1.0/>.

### History:

## 0.8  2021-01-17 19:25Z
##      Fixed: do not remove the slash before (?:\.rsync-)?backup/,
##      if any.

## 0.7  2020-10-16 08:32:13Z
##      (sfn.xCiMQVmuDyUWUgD9aDTkDh1--m_1NbzY5uWZqApWLb0.perl)
##      Fixed: disallow trailing control codes in the sfn. references
##      as well.  Fixed 0-9_- (was: 0-9-_) in a Base64 range RE.
##      No longer require Data::Dump, which was not used anyway.)

## 0.6  2020-10-15 12:27:08Z
##      (sfn.RIlDIoL0le1kGESFxF069nmB1tirUQaBN3tz7qv7v_0.perl)
##      Create target directory before rename when splits are in use
##      and one is missing.

## 0.5  2020-10-15 12:17:10Z
##      (sfn.qz8RWAzgk-QpgpmazLMdzx0nJmdvOH7QhFYgRa78mPM.perl)
##      (infer_split_position): Fixed: return the correct value
##      determined (was: 1.)

## 0.4  2020-10-15 12:07:43Z
##      (sfn.dUQb1kreBB-GQd1LPK9GoAt7PO3FnWUbKgElK-fUYyo.perl)
##      Fixed: disallow trailing punctuation in the sfn. references
##      found (were: only ][(){} disallowed; a regression introduced
##      in 0.2, which made such references end up ending on ", >, etc.
##      in practice, thus breaking matching.)

## 0.3  2020-10-15 11:57:26Z
##      (sfn.7jr0a03k7aSXXoiWO1-fdEf34hf0JPpuI3u5PeTgHzc.perl)
##      New -d, --directory= options.  The default is now to rename
##      backups to sfn.SHA.SUFFIX; use --directory=sfn to get the
##      previous behavior.
##      (@dirs, %dir_split): New variables.
##      (infer_split_position): New function, relying on IO::Dir.

## 0.2  2020-07-16 16:40:47Z
##      (sfn.yLjlFmmedVyEsOOW8qsEV60MqlYgK7MFPyb_spY6WQk.perl)
##      New --[no-]dry-run, --[no-]debug and -h, --help options.
##      Retrieve all sfn. references (were: just href= ones), thus
##      allowing support for non-HTML documents.  Use Getopt::Long.
##      Remove all (?:\.rsync-)?backup and \.~[0-9]+~ components from
##      filenames when looking for the current version (was: one of each.)
##      Fixed reference handling (were: references not loaded, suffix
##      not extracted, test inverted.)
##      ($usage, $example): New variables.
##      ($progname): Removed (now unused) variable.

## 0.1  2020-02-20 05:30:10Z
##      (sfn.kW2KaaGGSfQyn2KTk8NvCmnKkvAjpmXoK7oyVoPVsdw.perl)
##      Initial revision.

### Code:
use common::sense;
use English qw (-no_match_vars);

require Digest::SHA;
# require Encode;
require Getopt::Long;
require IO::Dir;
require IO::File;
# require List::Util;
# require POSIX;

our ($usage, $example) = (qq {Usage:
    \$ ${0} [-n|--[no-]debug] [--[no-]dry-run] [--] FILE...
    \$ ${0} -h|--help
}, qq {Example:

\$ ${0} -n -- sfn-move.perl.~[34]~ 
Warning: nGlS5LS76YTAs8jEv00M7w3gfRpmW-PYLRb7YP2gOiI.perl: unreferenced (sfn-move.perl.~3~); ignored
I: kW2KaaGGSfQyn2KTk8NvCmnKkvAjpmXoK7oyVoPVsdw from devel/scripts/sfn-move.perl.~4~
\$ 
});

Getopt::Long::Configure (qw (gnu_getopt));

our ($debug_p, $dry_run_p, @dirs)
    = (0, 0);

my %cmdline_options =  (q (debug!)      => \$debug_p,
                        q (d|directory=s)   => \@dirs,
                        q (n|dry-run!)  => \$dry_run_p,
                        q (h|help)
                        => sub { print ($usage, "\n", $example); exit (0); });

my $parsable_p
    = Getopt::Long::GetOptions (%cmdline_options)
    or die ("Cannot parse command line arguments");

unless (@ARGV > 0) {
    print STDERR ($usage);
    ## .
    exit (1);
}

our $dev_fd_prefix
    = ($ENV{"DEVFDPREFIX"} // "/dev/fd/");

sub dev_fd {
    my ($fn) = @_;
    our ($dev_fd_prefix);
    my $l
        = length ($dev_fd_prefix);
    ## .
    (substr ($fn, 0, $l) eq $dev_fd_prefix
     ? substr ($fn, $l) : undef);
}

sub open_file {
    my ($fn, $mode) = @_;
    die ()
        if (index ($mode, ">") > 0);
    ## .
    return \*STDIN
        if ($fn eq "-");

    $mode
        //= "<";
    my $fd
        = ("GLOB" eq ref ($fn) ? $fn->fileno () : dev_fd ($fn));
    ## .
    (defined ($fd)
     ? IO::File->new_from_fd ($fd, $mode)
     : IO::File->new ($fn, $mode));
}

our %dir_split;

sub infer_split_position {
    my ($d) = @_;

    ## NB: we never invalidate the cache; neither ensure absolute filenames
    our %dir_split;

    ## .
    return $dir_split{$d}
        if (exists ($dir_split{$d}));

    ## .
    my $h
        = IO::Dir->new ($d)
        or return;

    local $_;
    my %seen;
    while (defined (($_ = $h->read ()))) {
        ## Base64 alphabet, URI variant, inverted for a test
        next
            if (m {[^A-Za-z0-9_-]}  || ! -d ($d . "/" . $_));
        @seen{(length ())}
            = ();
    }
    $h->close ();

    ## .
    return 0
        unless (keys (%seen) > 0);
    return (($dir_split{$d} = do { my @k = keys (%seen); $k[0]; }))
        if (1 == keys (%seen));

    warn ("Warning: ", $d, ": Inconsistent split points? ",
          join (", ", sort { $a <=> $b; } (keys (%seen))),
          "; directory ignored");

    ## .
    return;
}

my $d0
    = Digest::SHA->new (256)
    or die ();
my %xref;
my %seen;
foreach my $fn (@ARGV) {
    my $fh
        = open_file ($fn)
        or die ($fn, ": Cannot open file: ", $!);
    $fh->binmode ()
        or die ($fn, ": ", $!);

    ## NB: non-greedy (.*?) matches are used below
    my $g
        = ($fn =~ s {(^|/)(?:\.(?:rsync-)?backup/)|\.~[0-9]+~$}{${1}}rg);
    unless (exists ($seen{$g})) {
        my $gh
            = open_file ($g);
        unless ($gh and $gh->binmode ()) {
            warn ("Warning: ", $g, ": ", $!, "; ignored");
            next;
        };

        my @refs;
        while (<$gh>) {
            push   (@refs, m {
                        \b sfn\. (\S{43} \S* [^[:blank:][:punct:][:cntrl:]])
                    }gx);
        }
        $gh->close ();
        warn ("D: ", $g, ": references: ", join (", ", @refs)) if ($debug_p);
        @xref{(@refs)}
            = ();
        @seen{($g)}
            = ();
    };

    my $d
        = $d0->clone ()->reset ();
    $d->addfile ($fh)
        or die ();
    my $b64
        = $d->b64digest ();
    my $b64u
        = ($b64 =~ tr {+/} {-_}r);
    my ($s)
        = ($fn =~ m { .* (\.[^.~]+) }x);
    my $h1
        = $b64u . $s;
    unless (exists ($xref{$h1})) {
        warn ("Warning: ", $g, " (", $h1, "): unreferenced; ignored");
        next;
    }

    ## Find a suitable prefix to move the file to
    my $g_dir
        = ($g =~ s {/+[^/]+$}{}r);
    my ($split, $prefix);
    if (@dirs <= 0) {
        $prefix
            = ($g_dir . "sfn.");
    } else {
        foreach my $e (@dirs) {
            $e  = ($g_dir . "/" . $e)
                unless (($e =~ m {^/}));
            $e  =~ s {/+$}{};
            warn ("D: ", $e, ": Checking directory") if ($debug_p);
            next
                unless (-d $e);
            my $s
                = infer_split_position ($e);
            next
                unless (defined ($s));

            warn ("D: ", $e, ": Split position: ", $s) if ($debug_p);
            ($split, $prefix)
                = ($s > 0 ? $s : undef, $e . "/");
            last;
        }
    }

    unless (defined ($prefix)) {
        warn ("Warning: ", $g,
              " (", $h1, "): no suitable prefix found; ignored");
        next;
    }

    substr ($h1, $split, 0, "/")
        if (defined ($split));

    my $h
        = ($prefix . $h1);
    if (-l $h || -e $h) {
        warn ("Warning: ", $h, ": already exists; ignored");
        next;
    }
    warn ("D: ", $h, " from ", $fn) if ($debug_p);
    if (! $dry_run_p) {
        if (defined ($split)) {
            my $e
                = ($h =~ s {/+[^/]+$}{}r);
            unless (-d $e) {
                mkdir ($e)
                    or warn ("Warning: ", $e, ": Cannot create: ", $!);
            }
        }
        rename ($fn, $h);
    } elsif (! $debug_p) {
        warn ("I: ", $h, " from ", $fn, "\n");
    }
}

### Emacs trailer
## Local variables:
## coding: us-ascii
## fill-column: 72
## indent-tabs-mode: nil
## ispell-local-dictionary: "american"
## End:
### sfn-move.perl ends here