view release on metacpan or  search on metacpan

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

	pattern => make_pattern(split /\s+/, config('id_keys')),
	chars => config('id_chars'),
	start_label => '0',
	label_format => '[%s]',
	color => config('id_color'),
	label_color => config('id_label_color'),
	blackout => 0,
	);
}		   

sub parse_pw {
    shift->parse_xx(
	hash => 'pw',
	pattern => make_pattern({IGNORE => [ 'URL' ]}, split /\s+/, config('pw_keys')),
	chars => config('pw_chars'),
	start_label => 'a',
	label_format => '[%s]',
	color => config('pw_color'),
	label_color => config('pw_label_color'),
	blackout => config('pw_blackout'),
	);
}		   

sub parse_xx {
    my $obj = shift;
    my %opt = @_;
    my %hash;
    $obj->{$opt{hash}} = \%hash;

    my $label_id = $opt{start_label};
    my $chars = qr/$opt{chars}/;
    $obj->{masked} =~ s{ (?!.*\e) $opt{pattern} }{
	local $_ = $1;
	s{ (?| ()    (https?://[^\s{}|\\\^\[\]\`]+)	# URL
	     | ([(]) ([^)]+)(\))	# ( text )
	     | ()    ($chars+) )	#   text
	}{
	    my($pre, $match, $post) = ($1, $2, $3 // '');
	    $hash{$label_id} = $match;
	    my $label = sprintf $opt{label_format}, $label_id++;
	    if ($opt{blackout}) {
		if ($opt{blackout} > 1) {
		    $match = 'x' x $opt{blackout};
		} else {
		    my $char = $opt{blackout_char} // 'x';
		    $match =~ s/./$char/g;
		}
	    }
	    $label = colorize($opt{label_color}, $label) if $opt{label_color};
	    $match = colorize($opt{color}, $match) if $opt{color};
	    $pre . $label . $match . $post;
	}xge;
	$_;
    }igex;

    $obj;
}

sub parse_matrix {
    my $obj = shift;
    my @area = guess_matrix_area($obj->{masked});
    my %matrix;
    $obj->{matrix} = \%matrix;

    for my $area (@area) {
	my $start = $area->[0];
	my $len = $area->[1] - $start;
	my $matrix = substr($obj->{masked}, $start, $len);
	$matrix =~ s{ \b (?<index>\d) \W+ \K (?<chars>.*) $}{
	    my $index = $+{index};
	    my $chars = $+{chars};
	    my $col = 'A';
	    $chars =~ s{(\S+)}{
		my $cell = $1;
		$matrix{$col}{$index} = $cell;
		$col++;
		$cell =~ s/./x/g;
		colorize('D;R', $cell);
	    }ge;
	    $chars;
	}xmge;
	substr($obj->{masked}, $start, $len) = $matrix;
	last; # process 1st segment only
    }

    $obj;
}
    
sub guess_matrix_area {
    my $text   = shift;
    my @text   = $text =~ /(.*\n|.+\z)/g;
    my @length = map { length } @text;
    my @words  = map { [ /(\w+)/g ] } @text;
    my @one    = map { [ grep { length == 1 } @$_ ] } @words;
    my @two    = map { [ grep { length == 2 } @$_ ] } @words;
    my @more   = map { [ grep { length >= 3 } @$_ ] } @words;
    my $series = 5;

    map  { [ sum(@length[0 .. $_->[0]]) - $length[$->[0]],
	     sum(@length[0 .. $_->[1]]) ] }
    sort { $b->[1] - $b->[0] <=> $a->[1] - $a->[0] }
    grep { $_->[0] + $series - 1 <= $_->[1] }
    map  { defined $_ ? ref $_ ? @$_ : [$_, $_] : () }
    reduce {
	my $r = ref $a eq 'ARRAY' ? $a : [ [$a, $a] ];
	my $l = $r->[-1][1];
	if ($l + 1 == $b
	    and @{$one[$l]} == @{$one[$b]}
	    and @{$two[$l]} == @{$two[$b]}
	    ) {
	    $r->[-1][1] = $b;
	} else {
	    push @$r, [ $b, $b ];
	}
	$r;
    }
    grep { $one[$_][0] =~ /\d/ }
    grep { @{$one[$_]} >= 10 || @{$two[$_]} >= 5 and @{$more[$_]} == 0 }
    0 .. $#text;
}

1;

=encoding utf-8

=head1 NAME

App::Greple::PwBlock - Password and ID information block parser for greple

=head1 SYNOPSIS

    use App::Greple::PwBlock;
    
    # Create a new PwBlock object
    my $pb = App::Greple::PwBlock->new($text);
    
    # Access parsed information
    my $id = $pb->id('0');      # Get ID by label
    my $pw = $pb->pw('a');      # Get password by label
    my $cell = $pb->cell('A', 0); # Get matrix cell value
    
    # Configuration
    use App::Greple::PwBlock qw(config);
    config('id_keys', 'LOGIN EMAIL USER ACCOUNT');
    config('pw_blackout', 0);

=head1 DESCRIPTION

B<App::Greple::PwBlock> is a specialized parser for extracting and managing