From e9d6911ac3a87a087746d04d850c64f2f6efa9b8 Mon Sep 17 00:00:00 2001
From: Guilhem Moulin <guilhem@fripost.org>
Date: Tue, 17 Mar 2015 00:10:29 +0100
Subject: Icevault client

---
 icevault | 723 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 723 insertions(+)
 create mode 100755 icevault

(limited to 'icevault')

diff --git a/icevault b/icevault
new file mode 100755
index 0000000..71ecfb8
--- /dev/null
+++ b/icevault
@@ -0,0 +1,723 @@
+#!/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';
+use Getopt::Long qw/:config posix_default no_ignore_case gnu_compat
+                            bundling auto_help auto_version/;
+use Digest ();
+use Encode qw/decode_utf8 encode_utf8/;
+use File::Copy 'move';
+use File::Path 'make_path';
+use File::Temp ();
+use I18N::Langinfo ();
+use IO::Socket::UNIX 'SOCK_STREAM';
+use IPC::Open2 'open2';
+use JSON qw/decode_json encode_json/;
+use List::Util qw/all any first min none/;
+use YAML::Tiny (); # XXX use Tiny::YAML instead?
+
+
+# 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;
+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;
+    chomp $format;
+    $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."\n", @_);
+}
+
+# error FORMAT, LIST
+sub error($@) {
+    myprintf \*STDERR, shift, @_;
+    exit 1;
+}
+
+# warning FORMAT, LIST
+sub warning($@) {
+    myprintf \*STDERR, shift, @_;
+}
+
+# Print usage and exit.
+sub usage($) {
+    my $rv = shift;
+    print STDERR "Usage: $0 [OPTIONS] [fill] scheme://hostname/identity\n"
+                ."   or: $0 [OPTIONS] insert [identity]\n"
+                ."   or: $0 [OPTIONS] dump identity\n";
+    myprintf \*STDERR, 'Try C<%s> for more information.', "$0 --help";
+    exit $rv;
+}
+
+# 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 undef;
+}
+
+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 the given configuration file
+sub loadConfig($) {
+    my $configFile = shift;
+    error "Configuration file C<%s> doesn't exist", $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
+        /^([-\@\w.]+)(?:\s*=\s*)(\p{print}*)/ or error "Can't parse config line: C<%s>", $_;
+        if ($2 eq '') {
+            delete $CONFIG{$1};
+        } else {
+            $CONFIG{$1} = $2;
+        }
+    }
+    close $CONFIG;
+}
+
+# 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>", $sockname if $CONFIG{debug};
+    }
+
+    $SOCKET = IO::Socket::UNIX::->new( Type => 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 /
+    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", 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", 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();
+}
+
+# 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>",
+                 $form->{fields}->[$i]->{name},
+                 safeValue($form->{fields}->[$i], $fill[$i])
+            if defined $fill[$i];
+    }
+
+    sendCommand('FILL', $idx, encode_json \@fill);
+}
+
+# Parse a scheme://hostname(:port)?/identity, and return the associated
+# file.
+sub getIdentityFile($) {
+    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 $file = $CONFIG{store};
+    $file =~ s/%s/$s/g;
+    $file =~ s/%h/$h/g;
+    $file =~ s/%i/$i/g;
+    return $file;
+}
+
+# Decrypt the given identity file and return the YAML-parsed form.
+sub loadIdentityFile($) {
+    my $file = shift;
+    myprintf \*STDERR, "Decrypting identity file C<%s>", $file if $CONFIG{debug};
+
+    my $pid = open my $fh, '-|', $CONFIG{gpg}, qw/-o - --decrypt --/, $file
+        or error "Can't fork: %s", $!;
+    my $str = do { local $/ = undef; <$fh> };
+    waitpid $pid, 0;
+    error "C<%s> exited with value %d", $CONFIG{gpg}, ($? >> 8) if $?;
+    close $fh;
+
+    # the cleartext's charset is always UTF8
+    return YAML::Tiny::Load(decode_utf8 $str);
+}
+
+# Dump and encrypt a form into the given filename.
+sub saveIdentityFile($$) {
+    my ($form, $file) = @_;
+    $form->{fields} = [ grep defined, @{$form->{fields}} ]; # remove undefined fields
+    myprintf \*STDERR, "Saving identity file C<%s>", $file if $CONFIG{debug};
+
+    # don't encrypt directly into the destination $file so we don't
+    # end up with a messed up $file if something goes wrong
+    my $outfh = File::Temp::->new(SUFFIX => '.gpg', UNLINK => 0, TMPDIR => 1);
+    my $pid = open2 ">&".$outfh->fileno, my $infh,
+                    $CONFIG{gpg}, qw/-o - --no-encrypt-to --recipient/, $CONFIG{keyid}, '--encrypt'
+        or error "Can't fork: %s", $!;
+    print $infh encode_utf8(YAML::Tiny::Dump $form); # dump the form as UTF8
+    close $infh;
+    waitpid $pid, 0;
+    error "C<%s> exited with value %d", $CONFIG{gpg}, ($? >> 8) if $?;
+    $outfh->close;
+
+    my $parent_dir = $file =~ s/\/[^\/]+$//r;
+    make_path $parent_dir unless -d $parent_dir; # create parent directories recursively
+    move $outfh->filename, $file or error "Can't move C<%s>: %s", $outfh->filename, $!;
+
+    # TODO: git add $file; git commit
+}
+
+# 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: take the first form with a password
+# field if there are any, otherwise the first non-empty form.  If the
+# first argument is defined, only consider forms with a matching base
+# URI.
+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 $idx = firstIdx { defined $_ and any {$_->{type} eq 'password'} @{$_->{fields}} } @forms;
+    $idx  //= firstIdx { defined $_ and any {$_->{value} ne ''} @{$_->{fields}} } @forms;
+    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{'pw-maxlength'};
+    $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),
+            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;
+
+    while (1) {
+        print $LOCALE->encode($prompt), " [", ($default ? 'Y/n' : 'y/N'), "] ";
+        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>", 'y', 'n';
+    }
+}
+
+# Get the SHA-256 digest of the given file.
+sub sha256_file($) {
+    my $filename = shift;
+    
+    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;
+}
+
+
+#######################################################################
+
+# Load configuration
+my $XDG_CONFIG_HOME = $ENV{XDG_CONFIG_HOME} // "$ENV{HOME}/.config";
+my $XDG_DATA_HOME   = $ENV{XDG_DATA_HOME}   // "$ENV{HOME}/.data";
+loadConfig "$XDG_CONFIG_HOME/icevault";
+
+# Override options from command line
+GetOptions(\%CONFIG, qw/debug show-passwords|p socket|s=s/) or usage(1);
+
+# Default options
+$CONFIG{gpg} //= 'gpg';
+$CONFIG{socket} //= 'S.IceVault';
+$CONFIG{store} //= "$XDG_DATA_HOME/icevault/%s/%h/%i.gpg";
+$CONFIG{pwgen} //= 'pwgen -s -cyn %d';
+$CONFIG{'pw-maxlength'} //= 32;
+$CONFIG{keyid} // error "Missing keyid in configuration file";
+
+usage(1) unless @ARGV;
+@ARGV = map { $LOCALE->decode($_) } @ARGV;
+my $command = $ARGV[0] =~ /\A[A-Za-z0-9-]+:\/\//aa ? 'fill' : shift;
+
+# Process the commands
+if ($command eq 'insert') {
+    usage(1) unless $#ARGV < 1;
+    my $uri = &connect($CONFIG{socket});
+    myprintf "Importing HTML form from URI C<%s>", $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')
+                        } ($pwIdx-1 .. 0)
+            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>", $r;
+            }
+            elsif (-e getIdentityFile "$uri/$r") {
+                myprintf \*STDERR, "Identity C<%s> already exists", "$uri/$r";
+            }
+            else {
+                $id = $r;
+                last;
+            }
+        }
+    }
+
+    my $file = getIdentityFile "$uri/$id";
+    error "Identity C<%s> already exists", "$uri/$id" if -e $file;
+
+    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 '') {
+            warning "Warning! Empty password for field C<%s>", $form->{fields}->[$passIdx[0]]->{name};
+            exit 1 unless promptYN "Continue?";
+        }
+    }
+    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 ".($#passIdx+1)." 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>", "$uri/$id";
+    saveIdentityFile $form, $file;
+}
+
+elsif ($command eq 'fill') {
+    usage(1) unless $#ARGV == 0;
+    my $id = shift;
+    my $file = getIdentityFile $id;
+    error "No such identity C<%s>", $id unless -f $file;
+
+    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 $file;
+    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>",
+                               $mypass->{name}, $pass->{name};
+            $mypass->{name} = $pass->{name};
+            $changed = 1;
+        }
+
+        if ($pass->{value} eq '') { # 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>)",
+                     $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 '' 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>)",
+                         $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),
+                 $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),
+                 $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, $file) if $r;
+    }
+}
+
+elsif ($command eq 'dump') {
+    usage(1) unless $#ARGV == 0;
+    my $id = shift;
+    my $file = getIdentityFile $id;
+    error "No such identity C<%s>", $id unless -f $file;
+
+    my $form = loadIdentityFile $file;
+    $_->{value} = safeValue($_) foreach @{$form->{fields}}; # redact the passwords
+
+    print STDOUT (defined $LOCALE ? $LOCALE->encode(YAML::Tiny::Dump $form) : YAML::Tiny::Dump $form);
+}
+
+else {
+    myprintf "Unknown command: C<%s>", $command;
+    usage(1);
+}
-- 
cgit v1.2.3