#!/usr/bin/perl -T

# IceVault - An external password manager for firefox
# Copyright © 2015 Guilhem Moulin <guilhem@fripost.org>
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or (at
# your option) any later version.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

use strict;
use warnings;

our $VERSION = '0.1';
my $NAME = 'icevault';
use Getopt::Long qw/:config posix_default no_ignore_case gnu_compat
                            bundling auto_version/;
use Encode qw/decode_utf8 encode_utf8/;
use I18N::Langinfo ();
use List::Util qw/all any first min none/;


# Clean up PATH, and set TMPDIR to a ramdisk's mountpoint if possible
$ENV{PATH} = join ':', qw{/usr/local/bin /usr/bin /bin};
$ENV{TMPDIR} //= first { -d } qw{/dev/shm /run/shm /var/run/shm /tmp};
delete @ENV{qw/IFS CDPATH ENV BASH_ENV/};

my $LANGINFO = I18N::Langinfo::langinfo(I18N::Langinfo::CODESET());
my $LOCALE = Encode::find_encoding $LANGINFO;
my (%CONFIG, @GIT, @GPG);
my $SOCKET;


#######################################################################
# Utilities

# myprintf [FILEHANDLE,] FORMAT, LIST
# Like printf, but allows locale-dependent markup.
sub myprintf($@) {
    my $fh = ref $_[0] eq 'GLOB' ? shift : \*STDOUT;
    my $format = shift;
    $LANGINFO =~ /^utf-?8$/aai ? $format =~ s/C<%s>/\N{U+2018}%s\N{U+2019}/g
                               : $format =~ s/C<%s>/'%s'/g;
    $format =~ s/I<%s>/%s/g;
    $format =~ s/B<%s>/%s/g;
    die "Illegal markup '$1' in message:\n", $format if $format =~ /([A-Z])<%s>/;
    printf $fh map {$LOCALE->encode($_)} ($format, @_);
}

# error FORMAT, LIST
sub error($@) {
    myprintf \*STDERR, shift."\n", @_;
    exit 1;
}

# warning FORMAT, LIST
sub warning($@) {
    myprintf \*STDERR, shift."\n", @_;
}

sub mysystem(@) {
    system {$_[0]} @_;
    error "C<%s> exited with value %d", $_[0], ($? >> 8) if $? and $? != -1;
}

# grepIdx BLOCK LIST
# Evaluates the BLOCK for each element of LIST (locally setting $_ to
# each element) and returns the list value consisting of the index of
# those elements for which the expression evaluated to true.
sub grepIdx(&@) {
    my ($code, @list) = @_;
    my @ret;
    for (my $i = 0; $i <= $#list; $i++) {
        local $_ = $list[$i];
        push @ret, $i if $code->();
    }
    return @ret;
}

# firstIdx BLOCK LIST
# Evaluates the BLOCK for each element of LIST (locally setting $_ to
# each element) and returns the first index of those elements for which
# the expression evaluated to true.  Or undef if the expression never
# evaluates to true.
sub firstIdx(&@) {
    my ($code, @list) = @_;
    for (my $i = 0; $i <= $#list; $i++) {
        local $_ = $list[$i];
        return $i if $code->();
    }
    return;
}

sub groupByName(@) {
    my @fields = @_;
    my %indices;
    for (my $i = 0; $i <= $#fields; $i++) {
        push @{$indices{$fields[$i]->{name}}}, $i;
    }
    return %indices;
}

sub delete($$) {
    my ($x, $l) = @_;
    @$l = grep { $_ ne $x } @$l;
}


#######################################################################

# Load and validate the given configuration file
sub loadConfig() {
    my $XDG_CONFIG_HOME = $ENV{XDG_CONFIG_HOME} // "$ENV{HOME}/.config";
    my $XDG_DATA_HOME   = $ENV{XDG_DATA_HOME} // "$ENV{HOME}/.local/share";

    # load config
    my $configFile = "$XDG_CONFIG_HOME/icevault";
    error "Missing configuration file C<%s>", $configFile unless -f $configFile;
    open my $CONFIG, '<', $configFile or error "Can't open C<%s>: %s", $configFile, $!;
    while (<$CONFIG>) {
        chomp;
        s/#.*//;         # ignore comments
        next if /^\s*$/; # ignore empty and blank lines
        /^([-\@a-zA-Z0-9.]+)\s*=\s*(\p{Graph}\p{Print}*)/ or error "Can't parse config line: C<%s>", $_;
        $CONFIG{$1} //= $2;
    }
    close $CONFIG;

    # set config defaults and validate
    $CONFIG{store} //= 'icevault';
    $CONFIG{store} =~ s#\A~/#$ENV{HOME}#;
    $CONFIG{store} = "$XDG_DATA_HOME/$CONFIG{store}" unless $CONFIG{store} =~ /\A\//;
    $CONFIG{store} =~ /\A(\/\p{Print}+)\z/ or error "Insecure C<%s>", $CONFIG{store};
    $CONFIG{store} = $1; # untaint $CONFIG{store}

    $CONFIG{template} //= '%s/%h/%i.gpg';
    error "C<%s> must contain %%s, %%h and %%i placeholders", 'template'
        unless $CONFIG{template} =~ /%s/ and $CONFIG{template} =~ /%h/ and $CONFIG{template} =~ /%i/;

    $CONFIG{'git-dir'} //= '.git';
    $CONFIG{'git-dir'} =~ s#\A~/#$ENV{HOME}#;
    $CONFIG{'git-dir'} = "$CONFIG{store}/$CONFIG{'git-dir'}" unless $CONFIG{'git-dir'} =~ /\A\//;
    $CONFIG{'git-dir'} =~ /\A(\/\p{Print}+)\z/ or error "Insecure C<%s>", $CONFIG{'git-dir'};
    $CONFIG{'git-dir'} = $1; # untaint $CONFIG{'git-dir'}

    $CONFIG{socket} //= 'socket';
    $CONFIG{socket} =~ s#\A~/#$ENV{HOME}#;

    error "Missing mandatory option C<%s> in configuration file", 'keyid' unless defined $CONFIG{keyid};
    $CONFIG{keyid} = [ map { /^((?:0x)?\p{AHex}{16}|\p{AHex}{40})$/
                                or error "C<%s> is not a 64-bits key ID or fingerprint", $_;
                             $1 }
                           split /,/, $CONFIG{keyid} ];

    $CONFIG{'max-password-length'} //= 32;
    error "C<%s> must be a positive integer", 'max-password-length'
        unless $CONFIG{'max-password-length'} =~ /\A\d+\z/ and $CONFIG{'max-password-length'} > 0;

    $CONFIG{pwgen} //= 'pwgen -s -cyn %d';
    $CONFIG{pwgen} =~ s#\A~/#$ENV{HOME}#;
    error "Insecure C<%s>", $CONFIG{pwgen} unless $CONFIG{pwgen} =~ /\A([-_\@a-zA-Z0-9\.%\/= ]+)\z/;
    $CONFIG{pwgen} = $1;

    $CONFIG{gpg} //= qw/gpg --quiet/;
    $CONFIG{gpg} =~ s#\A~/#$ENV{HOME}#;
    error "Insecure C<%s>", $CONFIG{gpg} unless $CONFIG{gpg} =~ /\A([-_\@a-zA-Z0-9\.%\/= ]+)\z/;
    $CONFIG{gpg} = $1;

    @GIT = ('git', '--work-tree='.$CONFIG{store}, '--git-dir='.$CONFIG{'git-dir'});
    @GPG = split / /, $CONFIG{gpg};
}

# Connect to the given socket and assign the IO::Socket object to
# $SOCKET.  If  the socket path is relative, prepend the default Firefox
# profile (or the first profile found if there is no default profile).
# Returns "scheme://hostname:port" (the ":port" part is optional)
sub connect($) {
    my $sockname = shift;

    if ($sockname !~ /^\//) { # relative path
        my $ffdir = "$ENV{HOME}/.mozilla/firefox";
        opendir my $dh, $ffdir or error "Can't open directory C<%s>: %s", $ffdir, $!;
        my $profile;
        while (readdir $dh) {
            next if $_ eq '.' or $_ eq '..';
            next unless -d "$ffdir/$_";
            if (/\.default$/) { # default profile takes precedence
                $profile = $_;
                last;
            }
            $profile //= $_;
        }
        closedir $dh;
        error "No Firefox profile found under C<%s>", $ffdir unless defined $profile;
        $sockname = "$$ffdir/$profile/$sockname";
    }
    myprintf \*STDERR, "Using socket C<%s>\n", $sockname if $CONFIG{debug};
    $sockname =~ /\A(\/\p{Print}+)\z/ or error "Insecure C<%s>", $sockname; # untaint $sockname
    $sockname = $1;

    require 'IO/Socket/UNIX.pm';
    $SOCKET = IO::Socket::UNIX->new( Type => IO::Socket::UNIX::SOCK_STREAM(), Peer => $sockname )
        or error "Can't connect to socket C<%s>: %s", $sockname, $!;

    # get the URI greeting; don't perform domain validation (it's done
    # by the browser), but ensure that it doesn't contain non-graphical
    # chars, : or /
    require 'JSON.pm';
    my $uri = getResponse();
    $uri =~ s/\A([A-Za-z0-9-]+:\/\/[^\P{Graph}:\/]+(?::\d+)?)(?:\/.*)?\z/$1/
        or error "Invalid URI C<%s>", $uri;

    my $scheme = $uri =~ s/:\/\/.*//r;
    warning "Warning: Insecure (%s://) connection! Form values can be stolen", $scheme
        unless $scheme eq 'https';

    return lc $uri;
}

# Read a response line on the socket, and return the decoded scalar or
# object.
sub getResponse() {
    my $buf = $SOCKET->getline;
    chomp $buf;
    myprintf \*STDERR, "S: %s\n", decode_utf8 $buf if $CONFIG{debug};
    my ($code, $msg) = split / /, $buf, 2;
    # allow $msg to be decoded to a string
    $msg = JSON->new->utf8->allow_nonref->decode($msg) if defined $msg;
    if ($code eq 'OK') {
        return $msg;
    }
    elsif ($code eq 'BYE') {
        # terminates the connection
        $SOCKET->close;
        undef $SOCKET;
    }
    elsif ($code eq 'ERROR') {
        error "Server said: C<%s>", 'ERROR ' . decode_utf8 $msg;
    }
    else {
        error "Unexpected response from server: C<%s>", decode_utf8 $msg;
    }
}

# Send the given UTF8 string (with a linefeed appended) on to the
# socket, flush the handle, then return the server response.
sub sendCommand(@) {
    my $command = join(' ',@_);
    myprintf \*STDERR, "C: %s\n", Encode::decode_utf8 $command if $CONFIG{debug};
    $command .= "\n";
    for (my $offset = 0; $offset < length $command;) {
        $offset += $SOCKET->syswrite($command, length($command) - $offset, $offset);
    }
    $SOCKET->flush;
    getResponse();
}


# Glob over all form templates.  Note that the output needs to be
# $LOCALE-decode'ed.
sub myglob(;$$$) {
    my ($s, $h, $i) = @_;
    my $store = $CONFIG{store};
    my $template = $CONFIG{template};
    require 'File/Glob.pm';

    s/([\\\[\]\{\}\*\?\~])/\\$1/g foreach ($store, $template);
    $template =~ s{\%(.)}{ $1 eq '%' ? '%' :
                           $1 eq 's' ? $s // '*' :
                           $1 eq 'h' ? $h // '*' :
                           $1 eq 'i' ? $i // '*' :
                           die "Invalid placeholder %$1" }ge;

    my $glob = "$store/$template";
    myprintf \*STDERR, "Using glob pattern C<%s>\n", $glob if $CONFIG{debug};
    return File::Glob::bsd_glob($glob);
}

# Find identities matching a given prefix
sub matches($) {
    my $prefix = shift;

    my ($s, $h, $i);
    if (!defined $prefix) {
    } elsif ($prefix =~ /\A([A-Za-z0-9-]+):\/\/([^\P{Graph}:\/]+(?::\d+)?)\/([^\P{Print}\/]*)\z/) {
        ($s, $h, $i) = ($1, $2, ($3 eq '' ? undef : $3));
    } elsif ($prefix =~ /\A([A-Za-z0-9-]+):\/\/([^\P{Graph}\/]*)\z/) {
        ($s, $h, $i) = ($1, ($2 eq '' ? undef : $2), undef);
    } elsif ($prefix =~ /\A([A-Za-z0-9-]*)(:\/?)?\z/) {
        ($s, $h, $i) = ($1, undef, undef);
    } else {
        error "Invalid identity prefix C<%s>", $prefix;
    }

    s/([\\\[\]\{\}\*\?\~])/\\$1/g foreach grep defined, ($s, $h, $i); # escape meta chars

    my @matches = myglob($s,$h,$i);
    error "No matches for identity prefix C<%s>", $prefix unless @matches;
    error "No such identity C<%s>", $prefix if defined $i and ! -f $matches[0];
    return @matches;
}

# Redact passwords, unless $CONFIG{'show-passwords'} is set.
sub safeValue($;$) {
    my $field = shift;
    my $value = shift // $field->{value};
    return ($field->{type} eq 'password' and !$CONFIG{'show-passwords'}) ?
           ('x' x length $value) : $value;
}

# Send a FILL command with the given form index and field values.
sub fill($$@) {
    my $idx = shift;
    my $form = shift;
    my @fill = @_;

    return if none {defined} @fill; # noop
    for (my $i = 0; $i <= $#fill; $i++) {
        myprintf "Filling field C<%s>, value C<%s>\n",
                 $form->{fields}->[$i]->{name},
                 safeValue($form->{fields}->[$i], $fill[$i])
            if defined $fill[$i];
    }

    sendCommand('FILL', $idx, JSON::encode_json(\@fill));
}

# Parse a scheme://hostname(:port)?/identity, and return the associated
# file.
sub identity2File($) {
    my $id = shift;
    $id =~ /\A([A-Za-z0-9-]+):\/\/([^\P{Graph}:\/]+(?::\d+)?)\/([^\P{Print}\/]+)\z/
        or error "Invalid identity C<%s>", $id;
    my ($s, $h, $i) = ($1, $2, $3);

    my $template = $LOCALE->encode($CONFIG{template});
    $template =~ s{\%(.)}{ $1 eq '%' ? '%' :
                           $1 eq 's' ? $s :
                           $1 eq 'h' ? $h :
                           $1 eq 'i' ? $i :
                           die "Invalid placeholder %$1" }ge;
    return "$CONFIG{store}/$template";
}

# Parse a filename as a scheme://hostname(:port)?/identity.
sub file2Identity($) {
    my $filename = shift;
    my $store = $CONFIG{store};
    my $template = $CONFIG{template};

    $template =~ s/(\%.)([^\%]*)\z/$1.quotemeta($2)/e;
    $template =~ s{(.*?)\%(.)}{$2 eq '%' ? '%' :
                               $2 eq 's' ? quotemeta($1).'(?<s>[A-Za-z0-9-]+)' :
                               $2 eq 'h' ? quotemeta($1).'(?<h>[^\P{Graph}:\/]+(?::\d+)?)' :
                               $2 eq 'i' ? quotemeta($1).'(?<i>[^\P{Print}\/]+)' :
                               die "Invalid placeholder %$1"}ge;
    my $pattern = qr/\A\Q$store\/\E$template\z/;
    myprintf \*STDERR, "Using regexp C<%s>\n", "$pattern" if $CONFIG{debug};
    $filename =~ $pattern or die;
    return "$+{s}://$+{h}/$+{i}";
}

# Decrypt the given identity file.  In scalar context, return the
# YAML-parsed form; in list context, return the list of the forked PID
# and its standard output; in void context, must be given a file handle
# (closed afterwards) where to dump the (unparsed) decrypted content.
open my $NULL, '<', '/dev/null';
sub loadIdentityFile($;$) {
    my ($filename, $fh) = @_;
    myprintf \*STDERR, "Decrypting identity file C<%s>\n", $filename if $CONFIG{debug};

    require 'IPC/Open2.pm';
    my $pid = IPC::Open2::open2( (defined wantarray ? $fh : ">&".$fh->fileno)
                               , "<&".fileno($NULL)
                               , @GPG, qw/-o - --decrypt --/, $filename)
                or error "Can't fork: %s", $!;
    return ($pid, $fh) if wantarray;
    my $str = do { local $/ = undef; <$fh> } if defined wantarray;
    waitpid $pid, 0;
    error "C<%s> exited with value %d", $GPG[0], ($? >> 8) if $? and $? != -1;
    close $fh;

    return unless defined wantarray;

    # the cleartext's charset is always UTF8
    require 'YAML/Tiny.pm'; # XXX use Tiny::YAML instead?
    return YAML::Tiny::Load(decode_utf8 $str) if defined wantarray;
}

# Encrypt a form into the given filename.   If $form is a HASH
# reference, its YAML-formatted (and UTF8-encoded) content is encrypted;
# if $form is a GLOB reference, the file handle is duped, given as input
# to gpg(1), and closed afterwards.
sub saveIdentityFile($$) {
    my ($form, $filename) = @_;
    myprintf \*STDERR, "Saving identity file C<%s>\n", $filename if $CONFIG{debug};

    require 'File/Copy.pm';
    require 'File/Path.pm';
    require 'File/Temp.pm';
    require 'IPC/Open2.pm';

    if (ref $form eq 'HASH') {
        require 'YAML/Tiny.pm'; # XXX use Tiny::YAML instead?
        $form->{fields} = [ grep defined, @{$form->{fields}} ]; # remove undefined fields
        $form = encode_utf8(YAML::Tiny::Dump($form)); # dump the form as UTF8
    }

    # don't encrypt directly into the destination file so we don't
    # end up with a messed up file if something goes wrong
    my $infh = "<&".fileno($form) if ref $form eq 'GLOB';
    my $outfh = File::Temp->new(SUFFIX => '.gpg', UNLINK => 0, TMPDIR => 1) or die;
    my $pid = IPC::Open2::open2( ">&".$outfh->fileno, $infh
                               , @GPG, qw/-o - --no-encrypt-to/
                               , (map {('--recipient', $_)} @{$CONFIG{keyid}})
                               , '--encrypt' )
                or error "Can't fork: %s", $!;
    print $infh $form unless ref $form;
    close $infh;
    waitpid $pid, 0;
    error "C<%s> exited with value %d", $GPG[0], ($? >> 8) if $? and $? != -1;
    $outfh->close;

    my $parent_dir = $filename =~ s/\/[^\/]+$//r;
    File::Path::make_path($parent_dir) unless -d $parent_dir; # create parent directories recursively
    unless (File::Copy::move($outfh->filename, $filename)) {
        my $r = $!;
        unlink $outfh->filename or error "Can't unlink C<%s>: %s", $outfh->filename, $!;
        error "Can't move C<%s> to C<%s>: %s", $outfh->filename, $filename, $r;
    }
}

# Copy the given filename to a new destination, and reencrypt it the
# file.  The filenames may be identical since 'saveIdentityFile' uses a
# temporary destination.
sub copyIdentityFile($$) {
    my ($oldname, $newname) = @_;

    my ($pid, $fh) = loadIdentityFile $oldname;
    saveIdentityFile($fh, $newname);

    waitpid $pid, 0;
    error "C<%s> exited with value %d", $GPG[0], ($? >> 8) if $? and $? != -1;
    close $fh;
}

# Get the visible form list from the server, and croak if it's empty.
sub getForms() {
    my $forms = sendCommand 'GETFORMS';
    error "No (visible) form found" unless @$forms;
    return @$forms;
}

# Guess which form is to be filled:
# * If $myform is defined, consider only the forms with matching action / base
#   URI; and if there is a single match take it
# * If one of the considered forms has a password field and a (possibly
#   different) non-empty field, take the first one found.
# * Otherwise (if all forms with a password field are empty), and if
#   there is a form with a password field, take the first one found.
# * Otherwise (if no form has a password field), and if there
#   is a non-empty form, take the first one found.
# * Otherwise (if all forms are empty), take the first form in the list.
sub findForm($@) {
    my $myform = shift;
    my @forms = @_;

    if (defined $myform) {
        # ignore forms with non-matching action
        @forms = map { $_->{action} =~ /\A\Q$myform->{baseURI}\E(?:\/.*)?\z/ ? $_ : undef } @forms;
        my @formIdx = grepIdx { defined $_ } @forms;
        error "No form found with action matching known base URI C<%s>", $myform->{baseURI}
            unless @formIdx;
        return $formIdx[0] if $#formIdx == 0; # single match
    }

    my @formIdx = grepIdx { defined $_ and any {$_->{type} eq 'password'} @{$_->{fields}} } @forms;
    my $idx = first { any {$_->{value} ne ''} @{$forms[$_]->{fields}} } @formIdx; # first non-empty form with a password
    $idx //= $formIdx[0]; # first form with a password
    $idx //= firstIdx { defined $_ and any {$_->{value} ne ''} @{$_->{fields}} } @forms; # first non-empty form
    $idx //= 0 if @forms; # first form
    error 'Dunno which form to '. (defined $myform ? 'fill' : 'import') unless defined $idx;
    return $idx;
}

# For a page with two or three passwords, try to guess from their value
# which are the old and new/confirm fields.  Returns a list of indices
# (old, new, confirm).
sub guessPasswordPage(@) {
    my ($pw0, $pw1, $pw2) = @_;
    my ($idx0, $idx1, $idx2);

    if (!defined $pw2) {
        if ($pw0->{value} eq $pw1->{value}) {
            ($idx0, $idx1, $idx2) = (undef, 0, 1)
        }
    }
    else {
        if ($pw1->{value} eq $pw2->{value}) {
            ($idx0, $idx1, $idx2) = (0, 1, 2);
        }
        elsif ($pw0->{value} eq $pw1->{value}) {
            ($idx0, $idx1, $idx2) = (2, 0, 1);
        }
        elsif ($pw0->{value} eq $pw2->{value}) {
            ($idx0, $idx1, $idx2) = (1, 0, 2);
        }
    }
    return ($idx0, $idx1, $idx2);
}

# Generate a (single) random password for the given fields, with the
# maximum possible length.
sub pwgen(@) {
    my @fields = @_;
    return unless @fields;
    my $pwgen = $CONFIG{pwgen};

    # see how long the password is allowed to be
    my $l = $CONFIG{'max-password-length'};
    $l = min (map { my $x = $1 if defined $_->{maxLength} and $_->{maxLength} =~ /^(\d+)$/;
                    (defined $x and $x > 0 and $x < $l) ?  $x : $l } @fields);
    $pwgen =~ s/%d/$l/g;
    myprintf "Generating $l-char long random value for field".($#fields > 0 ? '(s) ' : ' ')
             .join(',', map {'C<%s>'} @fields)."\n",
            map {$_->{name}} @fields;

    my @pw = `$pwgen`;
    error "Can't exec C<%s>: %s", $pwgen, $! unless @pw;
    chomp $pw[$#pw]; # remove the last \n, but keep the others
    $_->{value} = join ('', @pw) foreach @fields;
}

# Prompt a question with an optional defaut response.
sub prompt($;$) {
    my ($prompt, $default) = @_;
    $prompt .= " [$default]" if defined $default;
    print $LOCALE->encode($prompt), " ";

    my $r = <STDIN>;
    die "\n" unless defined $r;
    chomp $r;
    return ($r eq '' and defined $default) ? $default : $LOCALE->decode($r);
}

# Prompt a Yes/No question.
sub promptYN($;$@) {
    my $prompt = shift;
    my $default = shift // 0;
    my @args = @_;

    while (1) {
        myprintf "$prompt [".($default ? 'Y/n' : 'y/N')."] ", @args;
        my $r = <STDIN>;
        die "\n" unless defined $r;
        chomp $r;

        if (lc $r eq 'y' or lc $r eq 'yes' or ($r eq '' and $default)) {
            return 1
        }
        elsif (lc $r eq 'n' or lc $r eq 'no' or ($r eq '' and !$default)) {
            return 0
        }
        myprintf \*STDERR, "Answer: C<%s> or C<%s>\n", 'y', 'n';
    }
}

# Get the SHA-256 digest of the given file.
sub sha256_file($) {
    my $filename = shift;

    require 'Digest.pm';
    my $sha256 = Digest->new('SHA-256');
    open my $fh, '<', $filename or error "Can't open C<%s>: %s", $filename, $!;
    $sha256->addfile($fh);
    close $fh;
    return $sha256->digest;
}

# Add the given @filenames to the index and if there are any staged
# changes for these files, commit them with the given message.
sub commit($@) {
    my $msg = shift;
    my @filenames = @_;

    return unless -d $CONFIG{'git-dir'} and @filenames;
    mysystem @GIT, 'add', @filenames;

    # check if there are any staged changes on @filenames
    system {$GIT[0]} @GIT, 'diff', '--quiet', '--staged', '--', @filenames;
    return unless $?; # exit value 0: nothing staged
    error "C<%s> exited with value %d", $GIT[0], ($? >> 8) if $? and $? != -1 and $? != 256;

    $msg =~ /\A(\p{Print}*)\z/ or error "Insecure C<%s>", $msg;
    $msg = $1; # untaint $msg
    mysystem @GIT, 'commit', '-m', $msg, '--', @filenames;
}

# List all identites matching the given prefixes, along with their
# filename
sub list(@) {
    my @args = @_;

    my @matches;
    if (!@args) {
        @matches = map { my $file = $LOCALE->decode($_); { filename => $file, id => file2Identity $file } }
                       myglob(undef, undef, undef);
        unless ($CONFIG{recursive}) {
            $_->{id} =~ s/:\/\/.*// foreach @matches; # keep the scheme only
        }
    }
    else {
        foreach my $prefix (@args) {
            my @matches1 = map { my $file = $LOCALE->decode($_); { filename => $file, id => file2Identity $file } }
                               matches($prefix);
            if ($CONFIG{recursive}) {
                # don't remove suffix
            } elsif ($prefix =~ /\A[A-Za-z0-9-]+:\/\/[^\P{Graph}:\/]+(?::\d+)?\/[^\P{Print}\/]+\z/) {
                @matches1 = grep { $_->{id} =~ /\A\Q$prefix\E\z/ } @matches1;
            } elsif ($prefix =~ /\A([A-Za-z0-9-]+:\/\/[^\P{Graph}\/]+)\/?\z/) {
                my $x = $1;
                @matches1 = grep defined, map { $_->{id} !~ s/\A\Q$x\E\/// ? undef : $_ } @matches1;
            } elsif ($prefix =~ /\A([A-Za-z0-9-]+)(:\/{0,2})?\z/) {
                my $x = $1;
                @matches1 = grep defined, map { $_->{id} !~ s/\A\Q$x\E:\/\/// ? undef :
                                                $_->{id} !~ s/\/[^\P{Print}\/]+\z// ? undef : $_ } @matches1;
            } else {
                @matches1 = ();
            }
            error "No such identity C<%s>", $prefix unless @matches1;
            push @matches, @matches1;
        }
    }
    map { $_->{filename} =~ /\A(\/\p{Print}+)\z/ or error "Insecure C<%s>", $_->{filename};
          $_->{filename} = $1; $_; # untaint $_->{filename}
        } @matches;
}


#######################################################################

unless (@ARGV) {
    print STDERR "Usage: $NAME [COMMAND] [OPTION ...] [ARG ...]\n";
    error "Missing command.  Try C<%s> or consult the manpage for more information.", "$NAME --help";
}

my @USAGE = (
    fill => "[-f, --force] [-p, --show-passwords] [-s, --socket=PATH] scheme://hostname/identity",
    clip => "scheme://hostname/identity",
    cp => "[-f, --force] scheme://hostname/identity1 scheme://hostname/identity2",
    dump => "[-p, --show-passwords] scheme://hostname/identity",
    edit => "scheme://hostname/identity",
    git => "GIT-COMMAND [GIT-ARG ...]",
    import => "[-f, --force] [-s, --socket=PATH] [identity]",
    ls => "[-0, --zero] [-r, --recursive] [scheme://[hostname/[identity]] ...]",
    mv => "[-f, --force] scheme://hostname/identity1 scheme://hostname/identity2",
    reencrypt => "[scheme://[hostname/[identity]] ...]",
    rm => "[-f, --force] [-r, --recursive] scheme://[hostname/[identity]] ...",
);

if ($ARGV[0] eq '--help' or $ARGV[0] eq '-h') {
    my $default_cmd = shift @USAGE;
    my $default_usage = shift @USAGE;
    print "Usage: $NAME [$default_cmd] $default_usage\n";
    while (@USAGE) {
        my $cmd = shift @USAGE;
        my $usage = shift @USAGE;
        print "  or: $NAME $cmd $usage\n";
    }
    myprintf "Try C<%s> or consult the manpage for more information.\n", "$NAME COMMAND --help";
    exit 0;
}

@ARGV = map { $LOCALE->decode($_) } @ARGV;
my $COMMAND = ($ARGV[0] =~ /\A[A-Za-z0-9-]+:\/\//aa or $ARGV[0] =~ /\A--?[^-]/) ? 'fill' : shift;

# Print $COMMAND usage (detailed if --help)
sub usage(@) {
    my @opts = @_;
    my %usage = @USAGE;
    print "$NAME $COMMAND $usage{$COMMAND} \n";
    if ($CONFIG{help}) {
        if (@opts) {
            print "Options:\n";
            while (@opts) {
                shift @opts;
                print "  ".shift(@opts)."\n";
            }
        }
        printf "Consult the manpage for more information.\n";
        exit 0;
    } else {
        myprintf "Try C<%s> or consult the manpage for more information.\n", "$NAME $COMMAND --help";
        exit 1;
    }
}

# Get options, load and validate config
sub getopts(%) {
    my @opts = @_;
    my %opts = @opts;
    usage(@opts) unless GetOptions(\%CONFIG, qw/debug help|h/, keys %opts) and !$CONFIG{help};
    loadConfig();
}


#######################################################################
# Process the commands

if ($COMMAND eq '_complete') {
    # used internaly for auto-completion
    GetOptions(\%CONFIG, qw/zero|0/) or die;
    loadConfig();
    die unless $#ARGV == 0;

    $CONFIG{recursive} = 1;
    my @matches = grep defined,
                  map { $_->{id} =~ /\A\Q$ARGV[0]\E/ ? $_->{id} : undef}
                      list( $ARGV[0] =~ /\A(.*\/)/ ? $1 : $ARGV[0] =~ /\A([A-Za-z0-9-]+):\z/ ? "$1://" : () );

    # find the longest common prefix to determine the depth level of completion
    $matches[0] =~ /\A([A-Za-z0-9-]+):\/\/([^\P{Graph}:\/]+(?::\d+)?)\// or die;
    my ($s, $h) = ($1, $2);

    if (all { /\A\Q$s\E:\/\/\Q$h\E\// } @matches) { # common host: list all ids
    } elsif (all { /\A\Q$s\E:\/\// } @matches) { # common scheme: list only hosts
        s#/[^\P{Print}\/]+\z#/# foreach @matches;
    } else { # no common scheme: list only schemes
        s#://[^\P{Graph}\/]+/[^\P{Print}\/]+\z#://# foreach @matches;
    }
    my %matches = map {($_ => 1)} grep defined, @matches;

    my $delim = $CONFIG{zero} ? "\0" : "\n";
    print $LOCALE->encode($_), $delim foreach sort keys %matches;
    exit;
}

elsif ($COMMAND eq '_geturi') {
    # used internaly for auto-completion
    GetOptions(\%CONFIG, qw/socket|s=s/) or die;
    loadConfig();
    die if @ARGV;
    print $LOCALE->encode( &connect($CONFIG{socket}) ), "\n";
    sendCommand 'QUIT';
    exit;
}

elsif ($COMMAND eq 'import') {
    getopts( 'force|f' =>    "-f, --force      \tOverwrite preexisting identity"
           , 'socket|s=s' => "-s, --socket=PATH\tSpecifiy the path to the Icevault socket"
    );
    usage() unless $#ARGV < 1;

    my $uri = &connect($CONFIG{socket});
    myprintf "Importing HTML form from URI C<%s>\n", $uri;

    my @forms = getForms();
    my $formIdx = findForm undef, @forms;
    my $form = $forms[$formIdx];
    my @fill = map {undef} (0 .. $#{$form->{fields}});

    if (defined $form->{action}) {
        $form->{baseURI} = delete $form->{action};
        # perform minimal validation on the action URI (ensure that it
        # doesn't contain non-graphical chars, " or /)
        $form->{baseURI} =~ s/\A([A-Za-z0-9-]+:\/\/[^\P{Graph}:\/]+(?::\d+)?)(?:\/.*)?\z/$1/
            or error "Invalid form action: C<%s>", $form->{baseURI};
        my $scheme = $uri =~ s/:\/\/.*//r;
        warning "Warning! Form action scheme C<%s> doesn't match the URI's", $scheme
            unless $uri =~ /\A\Q$scheme\E:\/\//;
    }

    my $id = shift;
    unless (defined $id) {
        # no identity was provided from command line: try to use the
        # last non-empty text field before the first password, and
        # fallback to the first non-empty text field altogether
        my $pwIdx = firstIdx { $_->{type} eq 'password' } @{$form->{fields}};
        my $idx = first { $form->{fields}->[$_]->{value} ne '' and
                          ($form->{fields}->[$_]->{type} eq 'text' or $form->{fields}->[$_]->{type} eq 'email')
                        } reverse (0 .. $pwIdx-1)
            if defined $pwIdx;
        $idx //= firstIdx { $_->{value} ne '' and ($_->{type} eq 'text' or $_->{type} eq 'email') } @{$form->{fields}};
        $id = $form->{fields}->[$idx]->{value} if defined $idx;
        while (1) {
            # ask for confirmation
            my $r = prompt 'Identity name?', $id;
            if ($r !~ /\A[^\P{Print}\/]+\z/) {
                myprintf \*STDERR, "Invalid identity: C<%s>\n", $r;
            }
            elsif (-e identity2File "$uri/$r" and !$CONFIG{force}) {
                myprintf \*STDERR, "Identity C<%s> already exists\n", "$uri/$r";
            }
            else {
                $id = $r;
                last;
            }
        }
    }

    my $filename = identity2File "$uri/$id";
    error "Identity C<%s> already exists", "$uri/$id" if -e $filename and !$CONFIG{force};

    my @passIdx = grepIdx { $_->{type} eq 'password' } @{$form->{fields}};
    my @dontsave;
    if ($#passIdx == 0) { # single password in the form
        if ($form->{fields}->[$passIdx[0]]->{value} eq '') {
            exit 1 unless promptYN "Empty password for field C<%s>. Generate and continue?", 0,
                                   $form->{fields}->[$passIdx[0]]->{name};
            pwgen $form->{fields}->[$passIdx[0]];
            $fill[$passIdx[0]] = $form->{fields}->[$passIdx[0]]->{value};
        }
    }
    elsif ($#passIdx < 3) { # 2 or 3 passwords in the form
        my ($idx0, $idx1, $idx2) = map {defined $_ ? $passIdx[$_] : undef}
                                       guessPasswordPage(@{$form->{fields}}[@passIdx]);
        my ($pw0, $pw1, $pw2) = map {defined $_ ? $form->{fields}->[$_] : undef}
                                    ($idx0, $idx1, $idx2);

        if (defined $idx1 and defined $idx2) {
            # it can also be a password changing page when !defined
            # $pw0, but it doesn't matter here as all values are the
            # same
            print STDERR "Assuming a ".(defined $pw0 ? 'password changing' : 'signup')." page\n";
            if ($pw1->{value} eq '') { # generate a password for the two fields
                pwgen ($pw1, $pw2);
                $fill[$_] = $form->{fields}->[$_]->{value} foreach ($idx1, $idx2);
            }

            if (defined $pw0) {
                # keep only the first field, but use the second field's value
                $pw0->{value} = $pw1->{value};
                push @dontsave, $idx1, $idx2;
            } else {
                # keep only the first field
                push @dontsave, $idx2;
            }

        }
    }
    elsif ($#passIdx >= 3) {
        print STDERR "Assuming all ".scalar(@passIdx)." passwords are independent\n";
        foreach my $i (@passIdx) {
            next unless $form->{fields}->[$i]->{value} eq '';
            pwgen $form->{fields}->[$i];
            $fill[$i] = $form->{fields}->[$i]->{value};
        }
    }

    fill $formIdx, $form, @fill;
    sendCommand 'QUIT';

    undef @{$form->{fields}}[@dontsave] if @dontsave; # remove the field we don't want to save
    myprintf "Saving identity C<%s>\n", "$uri/$id";
    saveIdentityFile $form, $filename;
    commit "Add new identity $uri/$id", $filename;
}

elsif ($COMMAND eq 'fill') {
    getopts( 'force|f' =>            "-f, --force         \tDon't ask before updating the form"
           , 'show-passwords|p=s' => "-p, --show-passwords\tDon't redact passwords"
           , 'socket|s=s' =>         "-s, --socket=PATH   \tSpecifiy the path to the Icevault socket"
    );
    usage() unless $#ARGV == 0;

    my $id = shift;
    my $filename = identity2File $id;
    error "No such identity C<%s>", $id unless -f $filename;

    my $uri = &connect($CONFIG{socket});
    error "Possible phishing attempt! (URI C<%s> doesn't match identity.) Aborting.", $uri
        unless $id =~ /\A\Q$uri\E(?:\/.*)\z/;

    # get the list of forms and load the known form from disk
    my @forms = getForms();
    my $myform = loadIdentityFile $filename;
    my $formIdx = findForm $myform, @forms;
    my $form = $forms[$formIdx];
    my @fill = map {undef} (0 .. $#{$form->{fields}});

    # map each field name to the list of its indices; this allows
    # multivalued names
    my %fields = groupByName @{$form->{fields}};
    my %myfields = groupByName @{$myform->{fields}};
    my $changed = 0;

    my @mypassIdx = grepIdx { $_->{type} eq 'password' } @{$myform->{fields}};
    my @passIdx = grepIdx { $_->{type} eq 'password' } @{$form->{fields}};
    if ($#mypassIdx == 0 and $#passIdx == 0 and
        $#{$myfields{$myform->{fields}->[$mypassIdx[0]]->{name}}} == 0 and
        $#{$fields{$form->{fields}->[$passIdx[0]]->{name}}} == 0) {
        # there is a single password on both the know form and that we
        # want to fill, and both field names are unique in these forms:
        # assume this is the password to be filled regardless of the
        # name

        my $mypass = $myform->{fields}->[$mypassIdx[0]];
        my $pass = $form->{fields}->[$passIdx[0]];
        delete $myfields{$mypass->{name}}; # don't process these names later
        delete $fields{$pass->{name}};

        if ($mypass->{name} ne $pass->{name}) { # use the new name
            myprintf "Renaming field C<%s> as C<%s>\n",
                               $mypass->{name}, $pass->{name};
            $mypass->{name} = $pass->{name};
            $changed = 1;
        }

        if ($pass->{value} eq '' or $CONFIG{force}) { # fill the password with the known value
            $fill[$passIdx[0]] = $mypass->{value};
        }
        elsif ($mypass->{value} ne $pass->{value}) { # update the password
            myprintf "Updating field C<%s> to C<%s> (former value: C<%s>)\n",
                     $mypass->{name}, safeValue($pass), safeValue($mypass);
            $mypass->{value} = $pass->{value};
            $changed = 1;
        }
    }
    elsif ($#mypassIdx == 0 and $#passIdx > 0 and $#passIdx < 3) {
        # there is a single known password, but two or three fields to
        # fill: probably a password changing page
        my $mypass = $myform->{fields}->[$mypassIdx[0]];
        my ($idx0, $idx1, $idx2) = map {defined $_ ? $passIdx[$_] : undef}
                                       guessPasswordPage(@{$form->{fields}}[@passIdx]);
        my ($pw0, $pw1, $pw2) = map {defined $_ ? $form->{fields}->[$_] : undef}
                                    ($idx0, $idx1, $idx2);

        if (defined $pw1 and defined $pw2) {
            print STDERR "Assuming a password changing page\n";
            if ($pw1->{value} eq '') {
                pwgen ($pw1, $pw2);
                $fill[$_] = $form->{fields}->[$_]->{value} foreach ($idx1, $idx2);
            }

            # fill the first password field with the known value
            $fill[$idx0] = $mypass->{value} if defined $idx0 and $pw0->{value} eq '';

            if ($mypass->{value} ne $pw1->{value}) {
                # update the known password with the new value
                $mypass->{value} = $pw1->{value};
                $changed = 1;
            }

            # don't process these fields later
            &delete($mypassIdx[0], $myfields{$mypass->{name}});
            &delete($_, $fields{$form->{fields}->[$_]->{name}}) foreach grep defined, ($idx0, $idx1, $idx2);
        }
    }

    # walk through each names in both %myfields and %fields, and fill
    # the values in the order they are found
    foreach my $name (keys %myfields) {
        next unless exists $fields{$name};
        while (@{$myfields{$name}} and @{$fields{$name}}) {
            my $myidx = shift @{$myfields{$name}};
            my $idx = shift @{$fields{$name}};
            next unless defined $myidx and defined $idx; # was taken care of before
            if (($form->{fields}->[$idx]->{value} eq '' or $CONFIG{force})
                    and $myform->{fields}->[$myidx]->{value} ne '') {
                # fill with the known value
                $fill[$idx] = $myform->{fields}->[$myidx]->{value};
            }
            elsif ($myform->{fields}->[$myidx]->{value} ne $form->{fields}->[$idx]->{value}) {
                # update the known value with that found in the page
                myprintf "Updating field C<%s> to C<%s> (former value: C<%s>)\n",
                         $myform->{fields}->[$myidx]->{name},
                         safeValue($form->{fields}->[$idx]),
                         safeValue($myform->{fields}->[$myidx]);
                $myform->{fields}->[$myidx]->{value} = $form->{fields}->[$idx]->{value};
                $changed = 1;
            }
        }
    }
    # add the fields that were found in the page, but not in our form
    foreach my $name (keys %fields) {
        my @fieldIdx = grep defined, @{$fields{$name}};
        my $i;
        for ($i = $#fieldIdx; $i >= 0; $i--) {
            last unless $form->{fields}->[$i]->{value} eq '';
        }
        # don't store empty values (unless a later value is non-empty,
        # to preserve the order)
        @fieldIdx = @fieldIdx[(0 .. $i)] if $i >= 0;
        next unless @fieldIdx and $i >= 0;
        myprintf "Adding field C<%s>, value".($#fieldIdx > 0 ? '(s) ' : ' ').
                  join(',', map {'C<%s>'} @fieldIdx)."\n",
                 $name, map {safeValue $form->{fields}->[$_]} @fieldIdx;
        push @{$myform->{fields}}, @{$form->{fields}}[@fieldIdx];
        $changed = 1;
    }
    foreach my $name (keys %myfields) {
        my @fieldIdx = grep defined, @{$myfields{$name}};
        next unless @fieldIdx;
        myprintf "Deleting field C<%s>, value".($#fieldIdx > 0 ? '(s) ' : ' ').
                  join(',', map {'C<%s>'} @fieldIdx)."\n",
                 $name, map {safeValue $myform->{fields}->[$_]} @fieldIdx;
        undef $myform->{fields}->[$_] foreach @fieldIdx;
        $changed = 1;
    }

    fill $formIdx, $form, @fill;
    sendCommand 'QUIT';

    if ($changed) {
        my $r = promptYN "Save changes?", 0;
        saveIdentityFile ($myform, $filename) if $r;
        commit "Save imported changes for $id", $filename;
    }
}

elsif ($COMMAND eq 'dump') {
    getopts('show-passwords|p=s' => "-p, --show-passwords\tDon't redact passwords");
    usage() unless $#ARGV == 0;

    my $id = shift;
    my $filename = identity2File $id;
    error "No such identity C<%s>", $id unless -f $filename;

    my $form = loadIdentityFile $filename;
    $_->{value} = safeValue($_) foreach @{$form->{fields}}; # redact the passwords

    my $str = YAML::Tiny::Dump($form);
    print STDOUT (defined $LOCALE ? $LOCALE->encode($str) : $str)
}

elsif ($COMMAND eq 'edit') {
    getopts();
    usage() unless $#ARGV == 0;

    my $id = shift;
    my $filename = identity2File $id;
    error "No such identity C<%s>", $id unless -f $filename;
    require 'File/Temp.pm';

    error "C<%s> is not set", '$EDITOR' unless defined $ENV{EDITOR};
    my $EDITOR = $ENV{EDITOR} // 'editor';
    $EDITOR =~ /\A(\p{Print}+)\z/ or error "Insecure C<%s>", "\$EDITOR";
    $EDITOR = $1; # untaint $EDITOR

    my $fh = File::Temp->new(SUFFIX => '.yaml', UNLINK => 0, TMPDIR => 1) or die;
    END { unlink $fh->filename if defined $fh; } # never leave cleartext lying around
    loadIdentityFile $filename, $fh;

    my $h = sha256_file $fh->filename;
    while (1) {
        mysystem $EDITOR, $fh->filename;
        error "C<%s> exited with value %d", $EDITOR, ($? >> 8) if $? and $? != -1;
        my $h2 = sha256_file $fh->filename;

        my $fh2;
        unless ($h eq $h2) {
            require 'YAML/Tiny.pm'; # XXX use Tiny::YAML instead?
            eval { my $str = YAML::Tiny::LoadFile($fh->filename) };
            if ($@ eq '') {
                open $fh2, '<', $fh->filename or error "Can't open C<%s>: %s", $fh->filename, $!;
            } else {
                print STDERR $@;
                my $r = promptYN "Not a valid YAML file! Reedit?", 1;
                next if $r;
            }
        }

        unlink $fh->filename or error "Can't unlink C<%s>: %s", $fh->filename, $!;
        if ($h eq $h2) {
            print "No modification made\n";
        } elsif (defined $fh2) {
            myprintf "Saving user changes for identity C<%s>\n", $id;
            saveIdentityFile($fh2, $filename); # use the FH we opened before unlinking
            commit "Save manual (using $EDITOR) changes for $id", $filename;
        } else {
            print "Aborting\n";
            exit 1;
        }
        last;
    }
}

elsif ($COMMAND eq 'clip') {
    getopts();
    usage() unless $#ARGV == 0;

    my $id = shift;
    my $filename = identity2File $id;
    error "No such identity C<%s>", $id unless -f $filename;

    my $form = loadIdentityFile $filename;
    my $pw = first { $_->{type} eq 'password' } @{$form->{fields}};
    error "No password found in C<%s>", $id unless defined $pw;

    my $pid = open my $fh, '|-', qw/xclip -loop 1 -selection clipboard/
        or error "Can't fork: %s", $!;
    print $fh encode_utf8($pw->{value});
    close $fh;
    waitpid $pid, 0;
    error "C<%s> exited with value %d", 'xclip', ($? >> 8) if $? and $? != -1;
    exit 0;
}

elsif ($COMMAND eq 'ls') {
    getopts( 'zero|0'      => "-0, --zero     \tUse NUL instead of newline as line delimiter"
           , 'recursive|r' => "-r, --recursive\tList identities recursively"
    );

    my $delim = $CONFIG{zero} ? "\0" : "\n";
    my %matches = map {($_->{id} => 1)} list(@ARGV);
    print $LOCALE->encode($_), $delim foreach sort keys %matches;
}

elsif ($COMMAND eq 'git') {
    getopts();
    usage() unless @ARGV;

    unless (-d $CONFIG{store}) {
        require 'File/Path.pm';
        File::Path::make_path($CONFIG{store});
        myprintf "Created directory C<%s>\n", $CONFIG{store};
    }

    for (my $i = 0; $i <= $#ARGV; $i++) {
        $ARGV[$i] =~ /\A(\p{print}*)\z/ or die;
        $ARGV[$i] = $1;
    }
    exec {$GIT[0]} @GIT, @ARGV;
}

elsif ($COMMAND eq 'reencrypt') {
    getopts();

    my @matches = @ARGV ? map {matches($_)} @ARGV : myglob(undef, undef, undef);
    error "No such identity C<%s>", $_ foreach grep { ! -f $_ } @matches;

    my @filenames;
    foreach my $filename (@matches) {
        $filename = $LOCALE->decode($filename);
        my $id = file2Identity($filename);
        myprintf "Reencrypting C<%s>\n", $id;

        $filename =~ /\A(\/\p{Print}+)\z/ or error "Insecure C<%s>", $filename;
        $filename = $1; # untaint $filename

        copyIdentityFile $filename, $filename;
        push @filenames, { filename => $filename, id => $id };
    }

    commit( "Reencryption.".$filenames[0]->{id}.(scalar @filenames > 1 ? ' ...' : '')
          , map {$_->{filename}} @filenames );
}

elsif ($COMMAND eq 'cp' or $COMMAND eq 'mv') {
    getopts('force|f' => "-f, --force\tOverwrite preexisting destination");
    usage() if $#ARGV != 1;
    my $source = shift;
    my $target = shift;

    my $sourceFilename = identity2File($source);
    $sourceFilename =~ /\A(\/\p{Print}+)\z/ or error "Insecure C<%s>", $sourceFilename;
    $sourceFilename = $1; # untaint $sourceFilename

    my $targetFilename = identity2File($target);
    $targetFilename =~ /\A(\/\p{Print}+)\z/ or error "Insecure C<%s>", $targetFilename;
    $targetFilename = $1; # untaint $target

    error "Source and destination are the same identity C<%s>", $source if $source eq $target;
    error "No such identity C<%s>", $source unless -f $sourceFilename;
    exit 1 if -f $targetFilename and !$CONFIG{force} and !promptYN "Overwrite C<%s>?", 0, $target;

    copyIdentityFile $sourceFilename, $targetFilename;
    my @filenames = $targetFilename;
    if ($COMMAND eq 'mv') {
        unlink $sourceFilename or error "Can't unlink C<%s>: %s", $sourceFilename, $!;
        push @filenames, $sourceFilename;
    }
    commit(($COMMAND eq 'cp' ? 'copy' : 'move')." $source to $target", @filenames);
}

elsif ($COMMAND eq 'rm') {
    getopts( 'force|f'     => "-f, --force    \tNever prompt"
           , 'recursive|r' => "-r, --recursive\tList identities recursively"
    );

    my @matches = list(@ARGV);
    my @deleted;
    foreach my $m (@matches) {
        error "Use C<%s> for recursive deletion", '-r' unless
            $m->{id} =~ /\A[A-Za-z0-9-]+:\/\/[^\P{Graph}:\/]+(?::\d+)?\/[^\P{Print}\/]+\z/;

        if ($CONFIG{force} or promptYN "Really delete C<%s>?", 0, $m->{id}) {
            unlink $m->{filename} or warning "Can't unlink C<%s>: %s", $m->{filename}, $!;
            push @deleted, $m;
        }
    }
    exit 1 unless @deleted; # nothing to do
    commit( "Remove ".$deleted[0]->{id}.(scalar @deleted > 1 ? ' ...' : ''), map {$_->{filename}} @deleted );

    foreach (@deleted) {
        # try to delete empty parent directories
        my $filename = $_->{filename} =~ s/\/[^\/]+$//r;
        rmdir $filename and rmdir $filename =~ s/\/[^\/]+$//r;
    }
}

else {
    print STDERR "Usage: $NAME [COMMAND] [OPTION ...] [ARG ...]\n";
    error "Unknown command C<%s>.  Try C<%s> or consult the manpage for more information.", $COMMAND, "$NAME --help";
}