#! /usr/bin/perl -w

use strict;
use utf8;

my $usage_msg = <<\EoF;
Computes a sub-password for giving to a remote site.

Usage:
  passe-partout site userID [options]

Arguments:

The <site> argument should be minimally sufficient for uniqueness,
i.e.  like "amazon.com" or "ebay.com" (rather than 'www.amazon.com' or
'signin.ebay.com' or anything fancy like a URL).

Automatic site name-finding:  You can use "==" in place of the site
argument and we will compute a two-component site name
(e.g. gnome.org) automagically, by reading the firefox URL.  Use "==="
if you want a three-component name (e.g. bugzilla.gnome.org).  The
"==" feature requires your firefox to be visiting the page in
question.  For offline use, you have to spell out the site on the
command line.

The <userID> argument should be the login handle that goes along with
the password we are about to generate.  Many sites use your email
address as your login handle.  On sites that ask for both a login name
and an email, you will have to fill out some of that by hand; this
program is not smart enough to figure out all the possibilities.

Options:  The main options are:
  -length nn      # the length of sub-password [default 30]
  -help           # print this message (and immediately exit)
  -init           # initial setup for a new online account
  -old            # first half of a password change
  -renew          # second half of a password change
  -show           # print the sub-password (and userID etc.) on the terminal.
  -clip           # copy the sub-password to both:
                  #  -- the X 'primary selection' (paste with middle-mouse)
                  #  -- the X 'clipboard' (paste with ^V)
  -dry-run        # do not autofill firefox forms (often used with -show)
  -first          # use the first plausible ID field
                  # and the first password field on the form;
                  # useful for sites that unwisely put the login fields and
                  # the new-user registration fields on the same HTML form.
  -require @1     # useful if the password must contain one number and
                  #   one special character
  -spice /path/fn # the file from which to read the spice (useful
                  #   with -renew when switching from old to new spice)

Option-names can be abbreviated as much as you dare.

We prompt for the master password.  The sub-password depends on the
site name, on the userID, on the master password, and on whatever is
in the spice file (default: ~/misc/pw_spice.dat).

Strategy: We want to use a different password for each remote site.

Strategy: We make it easy to do the right thing, and hard to do the
wrong thing.

Feature: We don't want to make you remember all those passwords.

Feature: We don't want to make you write down all those passwords.
Instead, we compute them on the fly.  Writing them down would be a
security risk, coming and going: The bad guys would get in if the list
got captured, you would be locked out if the list got lost.

Hint: It is often convenient to write down the command you used to
generate the sub-password for each site, for example:
    # at http://login.vendor.com/cgi-bin/validate/
    passe-partout == me@isp.net -l 20
This is incomparably more secure than writing down the password
itself.

Feature: By using browser automation, we make it next to impossible to
send any given password to the wrong site.

Feature: We try to make it so that the password never appears on the
screen.  You don't need to manually cut-and-paste it into the browser.
We fill it into the browser form for you.

Feature: We support setting up a new online account.  In -init mode,
we expect the browser to have 1 userID field and two password fields.

Feature: We support changing an online password.  Use -old mode for
the first half of a password change.  It expects to see zero or one
userID fields (which it ignores), and exactly one old password field.

Meanwhile, use -renew mode for the second half of a password change.
It expects to see zero or one userID fields (which it ignores), and
exactly two new password fields.

Advanced feature: You are free to have more than one master password.
You probably don't want one per site, because they get hard to
remember if they are too numerous.  However, you might /group/ the
sites, and use one master password for financial sites, one for
medical sites, et cetera.  Similarly you can have more than one spice
file, if you are so inclined.

Recommendation: You should set the sub-password length to the maximum
the site will allow.  Alas, many sites will not accept more than 12
characters.  I cannot imagine any explanation for this, other than
aggressive stupidity.  Some sites accept much longer passwords.

Recommendation: The contents of pw_spice.dat should be something you
can reconstruct from memory, in case the disk where it's stored
crashes ... or in case you are traveling.  It has the advantage that
you don't need to type it in every time.  It's not as good as what
cryptographers call "salt" (which would be different for every
password) but it's better than nothing.  It greatly slows down
dictionary attacks against your master password.

About the name: Passe-partout is French for master key, literally a
"go-everywhere" key.  We allow you to go everywhere with just one key,
namely your master key ... but it's even better than that, because
(unlike a conventional master key) nobody gets to see your key.  All
they get to see are the sub-keys.

Also: I am aware that there exists a publishing app called
passepartout; note that the name of this app is hyphenated while the
other is not.

Limitations: This is a work in progress.  It is meant to be a
prototype, a proof of principle, and a stopgap -- not a magnum opus.
In the long run, we really should be using something else, presumably
some sort of zero-knowledge authentication such as SRP or something
like that.  However, alas, that would require the online sites to have
a clue, so I don't expect it to happen anytime soon.  In the meantime,
so long as the sites only understand passwords, passe-partout is
vastly safer than using the same password everywhere, vastly safer
than trying to remember N different passwords, and vastly safer than
writing them down, and more convenient.

Also note that if your browser can't be trusted, it could steal all
the sub-passwords one by one.  Also if your hardware and/or operating
system can't be trusted, they could easily steal your master password.
So you should not expect this approach to resist serious attack.  It
is intended to improve convenience while defending against the most
common mistakes.

Installation notes:

1) You may have to use the command
  cpan WWW::Mechanize::Firefox
to install the needed perl library on your machine.  This particular
library is big and gnarly.

2) I assume you are clever enough to install this without the .pl
extension becoming part of the command name.  Rename or symlink or
whatever.

Unsupported and ill-undocumented options, for experts only,
mostly for debugging:
  -echo        # prints stars when entering the password;
               #  if used twice, provide char-by-char information
               #  if used thrice, prints the final password
  -barf        # dumps all <form> entities (and their children)
  -verbo       # increase the verbosity
  -clearpw     # crazy: allow sending password in the clear
  -compat 1    # means allow non-alphanumeric chars to possibly occur
               #   in the sub_password;
               #   probably you want -require '...' instead
EoF

use URI::URL;           # to parse site-name from browser URL
use Digest::SHA;        # to combine the various inputs
use Symbol;
use Term::ReadKey;      # for reading the master pw from the console
## use WWW::Mechanize::Firefox;
use POSIX;

use Xclip;              # instead of Clipboard
use Crypt::CBC;         # depends on Crypt::OpenSSL::AES
use JSON::MaybeXS;
use Clone 'clone';
use Data::Structure::Util qw(unbless);
use Scalar::Util qw(reftype blessed);
### use utils;              # TEMPORARY for dumpobj
use Data::Dumper;
use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK F_GETFD F_SETFD FD_CLOEXEC);

#xx use Clipboard;      # tries to be platform-independent, but
                        # alas is not smart about primary selection
                        #    (paste with middle-mouse)
                        # versus actual /clipboard/ selection
                        #    (paste with ^V)
# http://stackoverflow.com/questions/37139149/perl-copy-to-clipboard-not-working-with-clipboard-module

my $verbosity = 0;
my $clip_mode = 0;


# Get the name or ID of an html element.
# We prefer the ID to the name,
# since I've seen cases where the name was non-unique.
#
# The returned ID (and not the name) will have a "#" at
# the front, in accordance with $mech conventions.
#
# Returns undef if neither ID nor name available.
sub gethandle{
  my ($elem) = @_;
  my $id = $elem->{id};
  if (defined $id && $id ne ''){
    return '#' . $id;
  }
  my $name = $elem->{name};
  if (defined $name && $name ne '') {
    return $name;
  }
  return undef;
}

# Returns reference to pair: [oldness, newness]
#
sub old_new_pw{
  my ($elem) = @_;
  my $newness = 0;
  my $oldness = 0;
  my $handle = gethandle($elem);
  my $ph = $elem->__attr('placeholder') || 'ph??';

  $handle =~ s/placeholder/placehXXder/i;       # so we don't get fooled by substring "old"

  if ($handle =~ m'old'i
    || $handle =~ m'current'i
    || $handle =~ m'PasswordLogin'i
    || $handle =~ m'opass$'i         # used by ebay.com
    || $handle eq '#pass'         # used by ebay.com
  ) {
    $oldness++;
    $newness--;
  }

  if ($handle =~ m'^#[0-9]+$') {        # ebay disgusting
    if ($ph eq 'Password') {
      $oldness += 3;
      $newness += 3;
    }
  }

  if ($handle =~ m'new'i
#  arpnetworks uses same ID for pw-change and for ordinary-login,
#  but doesn't require old pw for pw-change:
##-- probably not needed anymore:    || $handle =~ m'account_password'i
    || $handle =~ m'confirm'i
    || $handle =~ m'clientPw[12]'i   # used by abebooks.com
    || $handle =~ m'retype'i         # used by en.wikipedia.org
    || $handle =~ m'verify'i         # used by namesilo.com
    || $handle =~ m'[nr]pass$'i      # used by ebay.com
    ) {
      $newness++;
      $oldness--;
  }
  if ($handle =~ m'password.answer'i) {
    $newness -= 3;  $oldness -= 3;   # probably a security question
  }
  return [$oldness, $newness];
}

# Returns reference to pair: [oldness, newness]
#
sub old_new_id{
  my ($elem, $extra) = @_;
  my $newness = $extra || 0;
  my $oldness = $extra || 0;
  my $handle = gethandle($elem);
  my $tab = $elem->{tabindex}   || -99;                 # fails, very annoying
  $tab = $elem->__attr('tabindex') || -98;
  my $ph = $elem->{placeholder} || 'ph?';               # works
  $ph = $elem->__attr('placeholder') || 'ph??';         # works
  my $class = $elem->{class}   || 'cl?';                # fails, very annoying
  $class = $elem->__attr('class') || 'cl??';
  my $ac = $elem->__attr('autocorrect') || 'ac??';      # fails
  my $size = $elem->__attr('size') || 'size??';         # works
  if (0) {
    my %foo = $elem;
    for my $thing (keys %foo) {
      my %bar = $foo{$thing};
      for my $key (keys %bar) {
        my $val = $bar{$key};
        print STDERR "mmmmmm ($thing) $handle: '$key' => '$val'  \n";
      }
    }
  }
  if (0) {
    print STDERR "xxxxxx $handle ... $ph ... $tab ... $class ... $ac ... $size\n";
    print STDERR "zzzzzz $handle ", join(' ', keys %$elem), "\n";
  ##  print STDERR "zzzzzz $handle ", join(' | ', $elem), "\n";
    print STDERR "zzz=== $handle  %$elem  \n";

  # a perl hash with zero size and no keys, but lots of values???????
    print STDERR "zzznnn $handle ", 0+(%$elem), "\n";
    print STDERR "zzzkkk $handle ", join('|', $elem->__keys()), "\n";
    print STDERR "zzzvvv $handle ", join("\nvvv  ", $elem->__values()), "\n";
  }

  $handle =~ s/placeholder/placehXXder/i;       # so we don't get fooled by substring "old"

  if ( $handle =~ m'login'i
    || $handle =~ m'userid'i      # match to substring
    || $handle =~ m'^user$'i      # match to entire string ...
                  # ... not using eq, because we want to be case-insensitive.
    || $handle =~ m'name'i
    || $handle =~ m'clientpin$'i  # used by abebooks.com
  ) {
## could be old or new:
    $oldness += 2;
    $newness += 2;
  }

  if ($handle =~ m'^#[0-9]+$') {        # ebay disgusting
    if ($ph eq 'Email or username') {
      $oldness += 3;
      $newness += 3;
    }
  }

  if ( $handle =~ m'email'i
     ) {
## could be old or new:
    $oldness += 1;              # acceptable, but not optimal
    $newness += 1;              # acceptable, but not optimal
  }

  if ($handle =~ m'old'i
    || $handle =~ m'current'i
  ) {
    $oldness++;
    $newness--;
  }

## things we don't like:
  if ( $handle =~ m'captcha'i
    || $handle =~ m'userid_otp'i        # ebay
    || $handle =~ m'first.name'i
    || $handle =~ m'firstname'i
    || $handle =~ m'password'i
    || $handle =~ m'passwd'i
    || $handle =~ m'dummy'i
    || $handle =~ m'last.name'i
    || $handle =~ m'lastname'i
    || $handle =~ m'real.name'i
  ) {
    $oldness -= 100;
    $newness -= 100;
  }

  ### print STDERR "old_new_id returns $oldness, $newness\n";
  return [$oldness, $newness];
}

# returns reference to list
# returns [] if none of sufficient quality,
# or if ambiguity as to who the winner(s) should be
sub vet_list{
  my ($moniker, $listx, $index, $need, $first_mode) = @_;
  my %list = %$listx;
  my @rslt = ();
  my @rest = ();
  my $lo_win;             # key to lowest-ranked winner
  for my $key (sort {${$list{$b}}[$index] <=>
                     ${$list{$a}}[$index]} keys %list) {
    if (@rslt < $need) {
      push @rslt, $key;
      $lo_win = $key;
    } else {
      push @rest, $key;
    }
    if ($verbosity) {
      print STDERR " vetting $moniker>> '$key' : (${$list{$key}}[0]",
      ", ${$list{$key}}[1])[$index]\n";
    }
  }
  if ($verbosity) {
    print STDERR " vetted: $moniker:> rslt: ", join('|', @rslt), "\n";
    print STDERR " vetted: $moniker:> rest: ", join('|', @rest), "\n";
  }

# We could have checked this earlier, but it is better
# to wait until the verbose messages have gone out:
  if (@rslt < $need) {
    if ($verbosity) {
      my $nn = 0+@rslt;
      print STDERR " vet: not enough rslts ($nn) to meet the need ($need) on this form\n";
    }
    return [];
  }

  my $quality = ${$list{$lo_win}}[$index];
  if ($quality < 0) {
    if ($verbosity) {
      print STDERR " vet: not enough quality ($quality)\n";
    }

    return [];               ## bad quality
  }
  if (@rest) {
    my $hi_lose = $rest[0];
    my $compare = ${$list{$hi_lose}}[$index];
    if (!$first_mode && $compare == $quality) {  # ambiguity
      if ($verbosity) {
        print STDERR " vet: no clear winner; quality $quality\n";
      }
      return [];
    }
  }
#xx  print "normal return\n";
  return [@rslt];
}

sub wallet::generate{
  my $self = shift;
  my ($spfn, $site, $userID, $pwlen,
    $compat, $required) = @_;

  my $password = $self->{pwgen}->need;

# read the spice file
  my $inch = Symbol::gensym;
  my $spice = '';
  if (! open ($inch, '<', $spfn)) {
    die "Could not open spice file '$spfn'\n";
  } else {
    local $/ = undef;   ## sneaky way to read the entire file at once
    $spice = <$inch>;
  }

# do the cryptological krunching of all the ingredients:
  my $sha = Digest::SHA->new(256);
  $sha->add($spice);
  $sha->add($site);
  $sha->add($userID);
  $sha->add($password);

  my $hex  = $sha->clone->hexdigest;
  my $hash = $sha->b64digest;
  if ($compat == 1) {
    ;
  } else {
    $hash =~ s/[^a-z0-9]//gi;    ## remove non-alphanumeric chars
  }

  my $rslt = substr($hash, 0, $pwlen);
  my $where = floor(($pwlen*6+3)/4);
  for my $ch (split('', $required)) {
    my $str = substr($hex, $where, 2);   # 8 bits
    $where += 2;
    my $val = hex($str);
    my $index = $val % $pwlen;
    ##--- print "Required char: $str -> $val -> $index\n";
    substr($rslt, $index, 1) = $ch;
  }
  return $rslt;
}

sub wallet::get{
  my $self = shift;
  my @args = @_;
  my ($spfn, $site, $userID, $pwlen,
        $compat, $required) = @args;
  $self->need;
  my $key = $site . '|' . $userID;
  if (exists $self->{pw}->{$key}) {
    return $self->{pw}->{$key};
  } else {
    print STDERR "Calculating....\n";
    my $pw = $self->generate(@_);
    $self->set($site, $userID, $pw);
    return $pw;
  }
}

sub bindle::get{
  my $self = shift;
  my @args = @_;
  my ($spfn, $site, $userID, $pwlen,
        $compat, $required) = @args;
  $self->need;
  for my $row (@{$self->{toot}}) {
    if (defined $userID && $row->{userID} eq $userID){
      return $row->{pw};
    }
    if (defined $site && $row->{site} =~ m/$site/i){
      return $row->{pw};
    }
  }
  print STDERR "Calculating....\n";
  my $pw = $self->generate(@_);
  $self->set($site, $userID, $pw);
  return $pw;
}

sub bindle::generate {
  return wallet::generate(@_);
}

sub bindle::set {
  my $self = shift;
  my ($site, $userID, $pw) = @_;
  $self->need;
  if (! defined $site) {
    print STDERR "Need a site\n";
    return !!0;
  }
  if (! defined $userID) {
    print STDERR "Need a userID\n";
    return !!0;
  }
  if (! defined $pw) {
    my $subgen = bless {}, 'password';
    $pw = $subgen->need(prompt => 'Site pw: ');
  }
  push @{$self->{toot}},
          toot->new($site, $userID, $pw);
  $self->save;
  return 1;
}


# Process one form.
# Return a list of password fields,
# and a list of email fields.
# If there aren't email fields, instead return
# text fields that could plausibly be used as userID fields.
# Return forms that have the "right number"
# of each kind of field.
# If the form doesn't look right, return undef.
sub doform{
  my ($form, $mech, $userID, $role, $first_mode) = @_;
  my %pwlist = ();
  my %idlist = ();

  if ($verbosity) {
    my $formname = gethandle($form) || '???';
    print STDERR "doform called for: $formname ============\n";
  }

# note the "." in the search target;
# search the tree /relative/ to the $form
  my @todo = $mech->xpath('.//input', all => 1, node => $form);
  ##?? print "total input elements: ", 0+@todo, "\n";
  elmer: for my $elem (@todo) {        # loop over all input fields on this form
    if (!defined $elem) {
      print STDERR "WTF?\n";      # can happen if you ask xpath for "any" instead of "all"
    } else {
# if no type specified, it defaults to 'text'
# (happens on e.g. wikipedia.org)
      my $elemtype = $elem->{type} || 'text';
      my $handle = gethandle($elem);         # get either name or #id
      my $xhandle = $handle || '????';
      if ($verbosity) {
        print STDERR "elemtype: $elemtype  handle: $xhandle\n";
      }
      if ($elemtype eq 'submit' || $elemtype eq 'image') {
        next elmer;     # we don't care about those
      }
      if (!$verbosity && !defined $handle) {
        print STDERR "?No handle for input field; type: $elemtype\n";
      }
# a password field, relatively easy to interpret:
      if ($elemtype eq 'password') {
        if (defined $handle) {
          $pwlist{$handle} = old_new_pw($elem);
        }
      }
# email field is even easier to interpret:
      elsif ($elemtype eq 'email') {
        #xx print STDERR "email handle: $handle\n";
        if (defined $handle) {
          $idlist{$handle} = old_new_id($elem, 100);
        }
      }
# skeptically examine text fields, in case we never find any email fields:
      elsif ($elemtype eq 'text') {
        if (defined $handle) {
          $idlist{$handle} = old_new_id($elem, 0);
        }
      }
    }
  }  # end loop over all input fields.

  if ($verbosity) {
    print STDERR "ID:  "; barfout([keys %idlist]);
    print STDERR "pwlist:  "; barfout([keys %pwlist]);
  }

# the following are all the same, except for the number of
# expected / required fields of each type

  if ($role eq 'init') {
    my $pwx = vet_list('pwi', \%pwlist, 1, 2, $first_mode);
    my $idx = vet_list('idi', \%idlist, 1, 1, $first_mode);
    my $subcount = 0;    # doesn't count things with the substring 'again'
    for my $id (@$idx) {
      if ($id !~ m'again'i) {
        $subcount++;
      }
    }
    if ((@$idx == 1 || $subcount == 1) && @$pwx == 2) {
      return [$form, $idx, $pwx];
    }
    if ($verbosity) {
      print STDERR "** init unhappy: idx: ", 0+@$idx,
        "  subcount: ", $subcount,
        "  pwx: ", 0+@$pwx, "\n";
    }
    return undef;
  }
  if ($role eq 'old') {
    my $pwx = vet_list('pwo', \%pwlist, 0, 1, $first_mode);
    my $idx = vet_list('ido', \%idlist, 0, 1, $first_mode);
    if (@$idx <= 1 && @$pwx == 1) {
      return [$form, $idx, $pwx];
    }
    return undef;
  }
  if ($role eq 'renew') {
    my $pwx = vet_list('pwr', \%pwlist, 1, 2, $first_mode);
    my $idx = vet_list('idr', \%idlist, 1, 1, $first_mode);
    if (@$idx <= 1 && @$pwx == 2) {
      return [$form, $idx, $pwx];
    }
    return undef;
  }
  if ($role eq 'login') {
    my $pwx = vet_list('pwl', \%pwlist, 0, 1, $first_mode);
    my $idx = vet_list('idl', \%idlist, 0, 1, $first_mode);
    if (@$idx == 1 && @$pwx == 1) {
      return [$form, $idx, $pwx];
    }
    if ($first_mode) {
      if (@$idx > 0 && @$pwx > 0) {
        my @bestid = @$idx[0..0];
        my @pw = @$pwx[0..0];
        return [$form, \@bestid, \@pw];
      }
    }
    return undef;
  }
  die "Unhandled case; should never happen\n";
  return undef;
}

sub readpw{
  my ($echo) = @_;
  my $key;
  my $badflag = 0;
  my $password = "";

# Start reading the keys
  ReadMode(4); # raw mode
  my $escaping = 0;
  getter: while( ($key = ReadKey(0)) ne "\n" ) {
      my $orkey = ord($key);
      if (0) {}
      elsif($key eq "\cC") {
        $badflag++;
        print STDERR "^C";
        last getter;
      }
      elsif ($escaping > 1 && $orkey >=64) {
        $escaping = 0;
        next getter;
      }
      elsif ($escaping) {
        if ($key eq '[') {  ##']'##
# start of escape-square-bracket sequence:
          $escaping++;
        }
# sequences end with a letter or high-code symbol
        elsif ($orkey >= 64) {
          $escaping = 0;
        }
        next getter;
      }
# don't ask me why, but \c? is the BACKSPACE key
      elsif($key eq "\cH" || $key eq "\c?") {
          if (length($password)) {
            chop($password);      # remove last key
            if ($echo) {
               # erase one star from the screen;  that is:
               # backspace over the star, print a blank over it,
               # the backspace over the blank
              print STDERR "\b \b" x ($echo >=2 ? 5 : 1);
            }
          }
      }
      elsif($key eq "\cU") {
        if ($echo) {
          print STDERR "\b \b" x (($echo >=2 ? 5 : 1) * length($password));
        }
        $password = '';
      }
      elsif($key eq "\e"){              # start of an escape sequence
        $escaping = 1;
      }
      elsif($orkey < 32) {              # Ignore other control characters
        print STDERR "Ignoring $orkey\n";
      }
      else {
        $password = $password.$key;
        if ($echo >= 2) {
          printf STDERR ("0x%02x*", $orkey);
        }
        elsif ($echo) {
          print STDERR '*';
        }
      }
  }
  ReadMode(0);          # reset terminal mode
  print STDERR "\n";
  if ($badflag){
     exit;
  }
  if ($echo >= 3) {
    print "$password <<<<<<\n";
  }
  return $password;
}

sub wallet::save {
  my $self = shift;

  my $cipher = Crypt::CBC->new(
        -key    => $self->{pwgen}->need,
        -cipher => "Crypt::OpenSSL::AES"
  );

  my $json = JSON::MaybeXS->new(utf8 => 1);

  my $flat = clone($self);
  delete $flat->{pwgen};
  delete $flat->{fn};
  unbless $flat;
  my $plaintext = $json->encode($flat);
##  print "$plaintext <<<<plaintext\n";
  my $encrypted = $cipher->encrypt('wallet:' . $plaintext);

  my $fh = gensym;
  if (1) {
    open ($fh, '>:raw', $self->{fn})
      || die "Cannot open wallet '$self->{fn}' for writing\n";

    print $fh $encrypted;
    close $fh;
  }
}

sub wallet::create {
  my $self = shift;

  my %contents = (
    version => 1,
    salt => 123234234,
    pw => {
      'example.org|nickname@gmail.com' => 'sesame',
    },
  );

  %$self = (%$self, %contents);
  $self->save;
}

sub wallet::need {
  my $self = shift;
  my $dump = shift;
  my $fh = gensym;
  open ($fh, '<:raw', $self->{fn})
    || die "Cannot open wallet '$self->{fn}' for reading;"
         . " consider -create.\n";

  my $cipher = Crypt::CBC->new(
        -key    => $self->{pwgen}->need,
        -cipher => "Crypt::OpenSSL::AES"
  );

  my $json = JSON::MaybeXS->new(utf8 => 1);
  local $/ = undef;
  my $input = <$fh>;
  my $decrypted = $cipher->decrypt($input);
  if ($dump) {
    print "$decrypted\n";
  }
  $decrypted =~ s/^wallet://
        || die "Bad password (or bad pw.wallet)\n";
  my $tmp = $json->decode($decrypted);
  %$self = (%$tmp, %$self);
  return $self;
}

# returns the password string
sub password::get {
  my $self = shift;
  my %args = @_;
  my $prompt = $args{prompt} || 'Master passphrase: ';
  print STDERR $prompt;
  $self->{pw} = readpw($self->{echo} || 0);
  return $self->{pw};
}

# same as above, but only asks for it if needed
sub password::need {
  my $self = shift;
  if ($self->{pw}) {
    return $self->{pw};
  }
  return $self->get(@_);
}

sub wallet::set {
  my $self = shift;
  my ($site, $userID, $pw) = @_;
  $self->need;
  if (! defined $pw) {
    my $subgen = bless {}, 'password';
    $pw = $subgen->need(prompt => 'Site pw: ');
  }
  my $key = $site . '|' . $userID;
  $self->{pw}->{$key} = $pw;
  $self->save;
  return 0;
}

sub bindle::unset {
  my $self = shift;
  my ($site, $userID) = @_;
  $site ||= '--not def--';
  $userID ||= '--not def--';
  $self->need;
  my @list = @{$self->{toot}};
  my $found;
  rower: for (my $ii = 0; $ii < @list; $ii++){
    if ($list[$ii]->{userID} eq $userID){
      $found = $ii;
      last rower;
    }
    if ($list[$ii]->{site} =~ m/$site/i){
      $found = $ii;
      last rower;
    }
  }
  if (! $found) {
    print STDERR "No match for site: '$site' or userID: '$userID'\n";
    return undef;
  }
  splice @{$self->{toot}}, $found, 1;
  for my $toot (@{$self->{toot}}) {
    print $toot->pretty, "\n";
  }
  $self->save;
}

my $showfmt = "%20s | %-20s => %s";

sub toot::new {
  my $prior = shift;
  my $class = blessed $prior || $prior;
  my $self = bless {}, $class;
  $self->{site} = shift;
  $self->{userID} = shift;
  $self->{pw} = shift;
  return $self;
}

sub toot::pretty {
  my $self = shift;
  sprintf($showfmt, $self->{userID}, $self->{site}, $self->{pw});
}

my $info = <<\EoF;

Also: pinentry-program /usr/bin/pinentry-tty

According to
https://wiki.archlinux.org/index.php/GnuPG#Unattended_passphrase with
gnupg version 2.1.0 and higher, you need to do additional steps to
support --passphrase-fd

    First, edit the gpg-agent configuration to allow loopback pinentry mode: ~/.gnupg/gpg-agent.conf

    allow-loopback-pinentry

    Restart the gpg-agent process if it is running to let the change take effect.

    Second, either the application needs to be updated to include a commandline parameter to use loopback mode like so:

    $ gpg --pinentry-mode loopback ...

The perl-module alternatives are no good:

# "use GPG"  is no good because:
# (a) it ignores the password, and pops up a separate password-grabber;
# (b) it treats the gpg progress message as an error message
#       even though error status is not set
# (c) it writes a file that uses an "old" format, apparently
EoF

sub bindle::inner_need {
  my $self = shift;
  my $use_pw = shift;

  my $pwread = gensym;
  my $pwwrite = gensym;
  pipe $pwread, $pwwrite
     || die "gpg pw pipe failed\n";

  $pwwrite->autoflush(1);
  my $r = fileno($pwread);
  my $w = fileno($pwwrite);

  my $eread = gensym;
  my $ewrite = gensym;
  pipe $eread, $ewrite
     || die "gpg pw e-pipe failed\n";
  my $ew = fileno($ewrite);

  my @handles = ($pwread, $pwwrite, $eread, $ewrite);
  for my $fh (@handles) {
    my $flags = fcntl( $fh, F_GETFD, 0 )
        or die "fcntl F_GETFD: $!";
    fcntl( $fh, F_SETFD, $flags & ~FD_CLOEXEC )
        or die "fcntl F_SETFD: $!";
  }

  if ($use_pw) {
    my $pw = $self->{pwgen}->need;
    print $pwwrite $pw, "\n";
  }
  close $pwwrite;
  my $dataread = gensym;
  my $cmd  = "2>&$ew gpg --quiet --pinentry-mode loopback ";
     $cmd .= " --batch --passphrase-fd $r ";
     $cmd .= " --decrypt $self->{fn}";
  open ($dataread, '-|', $cmd)
        || die "Could not open gpg pipe from '$self->{fn}'\n";

  local $/ = undef;
  my $decrypted = <$dataread>;
  close $ewrite;                # must close this before reading;
                                # otherwise the read waits forever
  my $emsg = <$eread>;
  map {close $_} @handles;      # don't waste filehandles
  if (! close $dataread) {
    if ((! $use_pw) && $emsg =~ m'No secret key'i) {
      return undef;     # not an error
    }
    print STDERR "Decode failed; the command was:\n";
    print STDERR "   :; $cmd\n";
    print STDERR "and the error message was:\n";
    print STDERR "   $emsg";
    return undef;
  }
  return $decrypted;
}

sub bindle::need {
  my $self = shift;
  my $dump = shift;
  my $decrypted = $self->inner_need(0);
  if (! defined $decrypted) {
    ## print STDERR "I noticed\n";
    $decrypted = $self->inner_need(1);
  }
  if (! defined $decrypted) {
    # STILL not defined.  Oops;
    return undef;
  }
  if ($dump) {
    print "$decrypted\n";
    print "======================\n";
  }
  my $json = JSON::MaybeXS->new(utf8 => 1);
  my $tmp = $json->decode($decrypted);
  for my $toot (@$tmp){
    bless $toot, 'toot';
  }
  $self->{toot} = $tmp;
  return $self;
}

sub bindle::save {
  my $self = shift;

  my $json = JSON::MaybeXS->new(utf8 => 1);
  my $flat = clone($self->{toot});
  unbless $flat;        # works recursively
  my $plaintext = $json->encode($flat);
##  print "$plaintext <<<<plaintext\n";

  my $ofn = $self->{fn};
# There is apparently no way to get gpg to overwrite
# an existing output file.  So we work around it:
  if (-e $ofn) {
    rename $ofn, "$ofn~";
  }

  my $datawrite = gensym;
  my $cmd  = "gpg --quiet --recipient $self->{gpgID}";
     $cmd .= " --batch ";
     $cmd .= " --encrypt --output $ofn";
  open ($datawrite, '|-', $cmd)
        || die "Could not open gpg pipe to '$self->{fn}'\n";
  print $datawrite $plaintext;
  close $datawrite
        || die "Problem closing pipe";
}

sub interactive_loop {
  my ($wallet) = shift;
  my @arglist = @ARGV; @ARGV = ();
  my $pwgen = bless {}, 'password';

  my $bindle = bless {
    fn => $ENV{'HOME'} . '/misc/pwallet.gpg',
    pwgen => $pwgen,
    gpgID => '1042DB2AA89446151A604A36F3BD4858217335ED',
  }, 'bindle';

  my $userID;                   # the userID as given to the remote site
  my $argsite;
  liner: for (;;) {
    print STDOUT 'pp> ';
    my $cmdline;
    if (!($cmdline = <>)){
      print STDERR "\n";
      last liner;
    }

    chomp $cmdline;
    $cmdline =~ s/pp>//;
    $cmdline =~ s/^[ \t]*:[^;]*;//;
    $cmdline =~ s/^[ \t]*//;
    $cmdline =~ s/^#.*//;
    $cmdline =~ s/[ \t]+#.*//;
    my @cmds = split(' ', $cmdline);
    next liner if ! @cmds;
    my $verb = shift @cmds;
    if ($verb =~ m'^wall') {
      $wallet->need();
      for my $key (sort keys %{$wallet->{pw}}) {
        my ($site, $nick) = split('[|]', $key, 2);
        printf($showfmt . "\n", $site, $nick, $wallet->{pw}->{$key});
      }
    }
    elsif ($verb =~ m'^conv'i) {
      $wallet->need();
      $bindle->{toot} = [];
      for my $key (sort keys %{$wallet->{pw}}) {
        my ($site, $nick) = split('[|]', $key, 2);
        push @{$bindle->{toot}},
          toot->new($site, $nick, $wallet->{pw}->{$key});
      }
      $bindle->{pwgen} = $wallet->{pwgen};
    }
    elsif ($verb =~ m'^bindle'i) {
      for my $toot (@{$bindle->{toot}}) {
        print $toot->pretty, "\n";
      }
    }
    elsif ($verb =~ m'^passe-partout'i) {
      my $spfn = $ENV{'HOME'} . '/misc/pw_spice.dat';
      my $required = '';
      my $pwlen = 30;               # default length of computed sub-password
      my $compat = 0;
      $argsite = shift @cmds;
      $userID = shift @cmds;
      print "argsite: $argsite  userID: $userID\n";
      my $pw = $bindle->get($spfn, $argsite,
         $userID, $pwlen, $compat, $required);
    }
    elsif ($verb =~ m'^user'i) {
      $userID = shift @cmds;
    }
    elsif ($verb eq 'site') {
      $argsite = shift @cmds;
    }
    elsif ($verb =~ m'^set') {
      $bindle->set($argsite, $userID);
    }
    elsif ($verb =~ m'^unset') {
      $bindle->unset($argsite, $userID);
    }
    elsif ($verb =~ m'^save') {
      $bindle->save;
    }
    elsif ($verb =~ m'^load') {
      $bindle->need(shift @cmds);
    }
    elsif ($verb =~ m'^pass') {
      $bindle->{pwgen}->get;
    }
    else {
      print STDERR "Unrecognized '$verb'\n";
    }
  }
  exit;
}

main: {
  my $pwgen = bless {}, 'password';
  my $wallet = bless {
    fn => $ENV{'HOME'} . '/misc/pw.wallet',
    pwgen => $pwgen,
  }, 'wallet';
  my $mech;                     # handle for talking to firefox

  my $spfn = $ENV{'HOME'} . '/misc/pw_spice.dat';
  my $show = 0;                 # output pw to terminal
  my $clearpw = 0;                 # allow crazy stuff
#... style = enum{init          # set up new online account
#...              login,        # regular day-to-day signin
#...              old,          # first half of password change
#...              renew         # second half of password change
#...              }
  my $role = 'login';
  my $required = '';
  my $pwlen = 30;               # default length of computed sub-password
  my $compat = 0;
  my $userID;                   # the userID as given to the remote site
  my $argsite;
# Autofill used to be the default, but not anymore,
#  since WWW::Mechanize::Firefox is so very broken.
  my $dryrun = 1;
  my $barf = 0;
  my $first_mode = 0;
  my $previsiting = '???.???';
  my $pagetitle = '? ? ?';
  my $OKnone;
  arger: while (@ARGV) {
    my $arg = shift @ARGV;
    $arg =~ s'^--'-';           # tolerate needless double dash
    if (0) {}
## look for longer args first, so -r (renew) doesn't stomp on -req
    elsif ($arg =~ m'^-clear') {
      $clearpw++;
    }
    elsif ($arg =~ m'^-req') {
      $required = shift @ARGV;
    }
    elsif ($arg =~ m'^-spi') {
      $spfn = shift @ARGV;
    }
    elsif ($arg =~ m'^-clip') {
      $clip_mode++;
    }
    elsif ($arg =~ m'^-comp') {
      $compat = 0 + shift @ARGV;
    }
    elsif ($arg =~ m'^-int') {
      interactive_loop($wallet);
    }
    elsif ($arg =~ m'^-show') {
      $show++;
    }
    elsif ($arg =~ m'^-create') {
      $wallet->create;
      $OKnone++;
    }
    elsif ($arg =~ m'^-b') {
      $barf++;
    }
    elsif ($arg =~ m'^-d') {
      $dryrun++;
    }
    elsif ($arg =~ m'^-e') {
      $pwgen->{echo}++;
    }
    elsif ($arg =~ m'^-f') {
      $first_mode++;
    }
    elsif ($arg =~ m'^-h') {
      print $usage_msg;
      exit;
    }
    elsif ($arg =~ m'^-l') {
      $pwlen = 0 + shift @ARGV;
    }
    elsif ($arg =~ m'^-i') {
      $role = 'init';
    }
    elsif ($arg =~ m'^-o') {
      $role = 'old';
    }
    elsif ($arg =~ m'^-r') {
      $role = 'renew';
    }
    elsif ($arg =~ m'^-v') {
      $verbosity++;
    }
    elsif ($arg =~ m'^-') {
      die "Unrecognized option: '$arg'\n";
    }

# process args that are not options (no leading dash)
    elsif (!defined $argsite) {    # first non-hyphenated arg is the site
      $argsite = $arg;
    }
    elsif (!defined $userID) {
      $userID = $arg;           # second is the userID
    }
    elsif ($arg =~ m'^#') {
      last arger;
    }
    else {
      die "Extraneous verbiage: '$arg'\n";
    }
  }  # end of loop over arguments;

  # Now do a little post-processing of the arguments.
  # $argsite remains unchanged, just as it appeared on the cmd line
  # whereas $site gets heavily processed

  my $site = $argsite;
  if (!defined $site) {
    $site = '';
  }

  $site =~ s/^[.]//;            ## remove leading dot
  $site =~ s/[.]$//;            ## remove trailing dot

  if (!defined $userID) {
    exit 0 if $OKnone;
    die "userID required;  for instructions, consider:\n"
        . ":; passe-partout -h\n";
    exit 1;
  }

  my %scheme_ok = map {$_ => 1} qw(http https file);
  if (!$dryrun || $barf || $site =~ m'^=') {
    eval {
      $mech = WWW::Mechanize::Firefox->new(tab => 'current');
    };
    if ($@) {
      print "dryrun: $dryrun  barf: $barf  site: $site\n";
      print STDERR "Unable to set up firefox mechanization;\n";
      print STDERR "suggest Menu -> Tools -> MozRepl -> Start;\n";
      die "msg was:  $@\n";
    }
    my $base = $mech->base();
    my $url = new URI::URL($base);
    my $scheme = lc($url->scheme);
    if (! exists $scheme_ok{$scheme}) {
      die "Cannot handle URI scheme '$scheme'\n";
    }

    $pagetitle = $mech->title;
    $pagetitle =~  s/[^\x00-\x7f]/?/g;
    $previsiting = $url->host;
    $previsiting =~  s/[^\x00-\x7f]/?/g;
    if ($scheme !~ m'^https$'i && !$dryrun && !$clearpw) {
      die "Do you really want to send a password in the clear?\n",
          "... on page '$pagetitle'\n",
          "... at $previsiting.\n";
    }
    my $visiting = $previsiting;
    my @stuff = split('[.]', $previsiting);
    my $nv = 0+@stuff;          # total number of components in name
    my $skip;
    if ($site =~ m'^=') {
      $skip = $nv - length($site);
      if ($skip < 0) {
        die "Arg '$argsite' is too long,"
             . " or actual site name '$previsiting' is too short\n";
      }
      $visiting = join('.', @stuff[$skip .. $nv-1]);
      $site = $visiting;
    } else {
      my @argstuff = split('[.]', $site);
      $skip = $nv - @argstuff;
      if ($skip < 0) {
        $skip = 0;
      }
      $visiting = join('.', @stuff[$skip .. $nv-1]);
    }
    if ($visiting ne $site) {
      die "Site name mismatch: firefox: '$visiting'  cmdline: '$argsite'\n";
    }
  }

  my $subpw;

  if (!$dryrun) {
    my @todo = $mech->xpath('//form', all => 1);
    my $nf = 0+@todo;
    if ($verbosity) {
      print STDERR "xpath found $nf forms on page\n",
        "   $pagetitle\n",
        "   at $previsiting\n";
    }
    my @goodforms = ();
    for my $form (@todo) {
    if ($verbosity) {
      print STDERR "FORM: ";
    }

##xx      barfout($form);
      my $form = doform ($form, $mech, $userID, $role, $first_mode);
      if ($form) {
        push @goodforms, $form;
      }
    }
    # see how many good forms we found:
    my $nforms = 0+@goodforms;
    if ($nforms == 0 || $nforms != 1 && !$first_mode) {
      print STDERR "Hmmmm, it looks like there are $nforms forms to be filled out\n",
        "    for the role of '$role'\n",
        "    on page $pagetitle\n",
        "    at $previsiting.\n";
    }
# compute subpw here normally;
# also compute it later in case of -dry -show or -dry -clip
    if ($nforms && !defined $subpw) {
      $subpw = $wallet->get($spfn, $site,
        $userID, $pwlen, $compat, $required);
    }

# The main payoff:  fill in the fields in the browser:
    for my $doit (@goodforms) {
      if ($role eq 'old' || $role eq 'renew') {
        for my $elem (@{$doit->[2]}) {
          $mech->field( $elem => $subpw );
        }
        # ignore userID fields, if any
      } else {          # the ordinary_login or init; not old or renew
        #notused# my $form = $doit->[0];
        for my $elem (@{$doit->[1]}) {
          my $rslt;
          $rslt = $mech->field( $elem => $userID);
          #xxx print STDERR "Set '$elem' to '$userID' result $rslt\n";
        }
        for my $elem (@{$doit->[2]}) {
          my $rslt;
          $rslt = $mech->field( $elem => $subpw );
          #xxx print STDERR "Set '$elem' to '$subpw' result $rslt\n";
        }
      }
    }
  }

  if ($barf) {
    print STDERR "base: ", $mech->base(), "\n\n";    # about:blank
    print STDERR "doc: ", $mech->document(), "\n\n";
    print STDERR "title: ", $mech->title(), "\n\n";
    my @todo = $mech->xpath('//form', all => 1);
    for my $elem (@todo) {
      if (!defined $elem) {
        print STDERR "WTF?\n";      # can happen if you specify "any" instead of "all"
      } else {
        barfout($elem)
      }
    }
  }

# last but not least, print sub-passwd etc. on console, if requested
  if ($show || $clip_mode) {
    if (!defined $subpw) {
      $subpw = $wallet->get($spfn, $site,
          $userID, $pwlen, $compat, $required);
    }
  }
  if ($show) {
    printf($showfmt, $site, $userID, $subpw);
  }
  if ($clip_mode) {
    Xclip::copy2($subpw);
  }
}

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

sub barfout{
  my ($thing, $depth, $junk) = @_;
  my $q = '"';
  if (!defined $depth) {
    $depth = 0;
  }
  my $type = ref($thing);
  ##xx print STDERR "Depth: $depth  type: $type\n";
  my $prefix = '  ' x $depth;
  if ($depth == 0) {
    if ($type eq 'ARRAY') {
      my $size = 0+@$thing;
      print STDERR "<$type> [$size]\n";
    } elsif ($type eq 'HASH') {
      my $size = 0 + keys %$thing;
      print STDERR "<$type> [$size]\n";
    } else {
      print STDERR $prefix, "=$thing\n";
    }
  } else {
    # assume name has already been printed
  }
## some type of object:
  if ($type =~ m'::') {
    my $attrstring = '';
    for my $attr ('entity', 'id',  'name', 'type', 'class',
            'title', 'method', 'size', 'maxlength') {
      my $avalue = $thing->{$attr};
      if (defined $avalue && $avalue ne '') {
        $attrstring .= "  $attr=$q$avalue$q";
      }
    }
    if ($attrstring ne '') {
      print STDERR "$prefix$attrstring\n";
    }
    print STDERR $prefix, "{\n";
    my @keylist = keys %$thing;
    for my $key (@keylist) {
      my $value = $thing->{$key};
      print STDERR $prefix, "  ", $key, " => ", $value, "\n";
      barfout($value, 1+$depth);
    }
    print STDERR $prefix, "}\n";
  }
  elsif ($type eq 'ARRAY') {
    my $n = 0+@$thing;
    print STDERR $prefix, "   (", join(", ", @$thing), ")\n";
  }
  elsif ($type eq 'HASH') {
    my $n = 0+(keys %$thing);
    print STDERR $prefix, "   {", join(", ", (keys %$thing)), "}\n";
  }

  else {
    print STDERR $prefix, "  [$type] $thing\n";
  }
}

#xxxx ## another way to dump things, including /methods/ of objects:
#xxxx ## http://www.perlmonks.org/?node_id=884054
#xxxx
#xxxx use Data::Dumper;
#xxxx
#xxxx sub barfout{
#xxxx   my ($thing) = @_;
#xxxx ##  Dumper( \%{ref ($thing)."::" }) ;
#xxxx   print Dumper( $thing ) ;
#xxxx }