view release on metacpan or  search on metacpan

lib/App/Greple/pw.pm  view on Meta::CPAN

use Getopt::EX::Config qw(config);

my $execution = 0;

# Getopt::EX::Config support
my $config = Getopt::EX::Config->new(
    clear_clipboard => 1,
    clear_string    => 'Hasta la vista.',
    clear_screen    => 1,
    clear_buffer    => 1,
    goto_home       => 0,
    browser         => 'chrome',
    timeout         => 300,
    debug           => 0,
    # PwBlock parameters - direct references to PwBlock config members
    parse_matrix    => \$App::Greple::PwBlock::config->{parse_matrix},
    parse_id        => \$App::Greple::PwBlock::config->{parse_id},
    parse_pw        => \$App::Greple::PwBlock::config->{parse_pw},
    id_keys         => \$App::Greple::PwBlock::config->{id_keys},
    id_chars        => \$App::Greple::PwBlock::config->{id_chars},
    id_color        => \$App::Greple::PwBlock::config->{id_color},
    id_label_color  => \$App::Greple::PwBlock::config->{id_label_color},
    pw_keys         => \$App::Greple::PwBlock::config->{pw_keys},
    pw_chars        => \$App::Greple::PwBlock::config->{pw_chars},
    pw_color        => \$App::Greple::PwBlock::config->{pw_color},
    pw_label_color  => \$App::Greple::PwBlock::config->{pw_label_color},
    pw_blackout     => \$App::Greple::PwBlock::config->{pw_blackout},
);

sub finalize {
    our($mod, $argv) = @_;
    $config->deal_with(
	$argv,
	"clear_clipboard|clear-clipboard!",
	"clear_string|clear-string=s",
	"clear_screen|clear-screen!",
	"clear_buffer|clear-buffer!",
	"goto_home|goto-home!",
	"browser=s",
	"timeout=i",
	"debug!",
	# PwBlock parameters - underscore and hyphen versions
	"parse_matrix|parse-matrix!",
	"parse_id|parse-id!",
	"parse_pw|parse-pw!",
	"id_chars|id-chars=s",
	"id_color|id-color=s",
	"id_label_color|id-label-color=s",
	"pw_chars|pw-chars=s",
	"pw_color|pw-color=s",
	"pw_label_color|pw-label-color=s",
	"pw_blackout|pw-blackout!",
	"id_keys|id-keys=s",
	"pw_keys|pw-keys=s",
    );
    
    # All parameters are automatically managed by Getopt::EX::Config references
}

sub pw_status {
    binmode STDOUT, ":encoding(utf8)";
    for my $key (sort keys %{$config}) {
	my $val = config($key);
	if (defined $val) {
	    print "$key: $val\n";
	} else {
	    print "$key: (default)\n";
	}
    }
}

sub pw_print {
    my %attr = @_;
    my @pass;

    $execution++;

    my $pw = new App::Greple::PwBlock $_;

    print $pw->masked;

    command_loop($pw) or do { pw_epilogue(); exit };

    return '';
}


use constant { CSI => "\e[" };

sub pw_epilogue {
    $execution == 0 and return;
    copy(config('clear_string')) if config('clear_clipboard');
    print STDERR CSI, "H" if config('goto_home');
    print STDERR CSI, "2J" if config('clear_screen');
    print STDERR CSI, "3J" if config('clear_buffer');
}

sub pw_timeout {
    if (config('debug')) {
	warn "pw_timeout() called.\n";
	sleep 1;
    }
    pw_epilogue();
    exit;
}

sub command_loop {
    my $pw = shift;

    open TTY, "/dev/tty" or die;

    require Term::ReadLine;
    my $term = Term::ReadLine->new(__PACKAGE__, *TTY, *STDOUT);

    binmode TTY, ":encoding(utf8)";
    binmode STDOUT, ":encoding(utf8)";

    while ($_ = $term->readline("> ")) {
	if (config('timeout')) {
	    $SIG{ALRM} = \&pw_timeout;
	    alarm config('timeout');
	    warn "Set timeout to ", config('timeout'), " seconds\n" if config('debug');
	}
	/\S/ or next;
	$term->addhistory($_);
	s/\s+\z//;
	$_ = kana2alpha($_);

	if (my $id = $pw->id($_)) {
	    if (copy($id)) {
		printf "ID [%s] was copied to clipboard.\n", $id;
	    }
	    next;
	}
	elsif (my $pass = $pw->pw($_)) {
	    if (copy($pass)) {
		printf "Password [%s] was copied to clipboard.\n", $_;
	    }
	    next;
	}

	if (0) {}
	elsif (/^dump\b/)  { print Dumper $pw }
	elsif (/^N/i) { last }
	elsif (/^P/i) { print $pw->masked }
	elsif (/^Q/i) { return 0 }
	elsif (/^V/i) {
	    s/^.\s*//;
	    my @option = split /\s+/;
	    if (@option == 0) {
		print $pw->orig;
	    } else {
		my @values = map { $pw->any($_) // '[N/A]' } @option;
		print "@values\n";
	    }
	}
	elsif (/^show\b/i) {
	    print $pw->masked;
	}
	elsif (/^orig\b/i) {
	    print $pw->orig;
	}
	##
	## INPUT to browser
	##
	elsif (s/^input\s*//i) {
	    my %field = do {
		map {
		    m{
			( (?: name: | id: )? \w+ )
			(?|
			  \s+ (.*) # '=' がなければ残り全部
			  |
			  = ( \/.+\/ | \w+ (?:,\w+)* )
			)
		    }xg