Dogcows Code - chaz/p5-File-KDBX/blob - t/placeholders.t

   1 #!/usr/bin/env perl
   2
   3 use warnings;
   4 use strict;
   5
   6 use lib 't/lib';
   7 use TestCommon;
   8
   9 use File::KDBX::Entry;
  10 use File::KDBX;
  11 use Test::More;
  12
  13 my $kdbx = File::KDBX->new;
  14
  15 my $entry1 = $kdbx->add_entry(
  16     title       => 'Foo',
  17     username    => 'User {TITLE}',
  18 );
  19 my $entry2 = $kdbx->add_entry(
  20     title       => 'Bar',
  21     username    => sprintf('{REF:U@I:%s}', $entry1->id),
  22     notes       => 'notes {URL}',
  23     url         => 'url {NOTES}',
  24 );
  25 my $entry3 = $kdbx->add_entry(
  26     username    => sprintf('{REF:U@I:%s}', $entry2->id),
  27     password    => 'lyric:%LYRIC%',
  28     notes       => '%MISSING% %% %NOT AVAR% %LYRIC%',
  29 );
  30
  31 is $entry1->expand_username, 'User Foo', 'Basic placeholder expansion';
  32 is $entry2->expand_username, 'User Foo', 'Reference to another entry';
  33 is $entry3->expand_username, 'User Foo', 'Reference to another entry through another';
  34
  35 my $recursive_expected = 'url notes ' x 10 . 'url {NOTES}';
  36 my $recursive;
  37 my $warning = warning { $recursive = $entry2->expand_url };
  38 like $warning, qr/detected deep recursion/i, 'Deep recursion causes a warning'
  39     or diag 'Warnings: ', explain $warning;
  40 is $recursive, $recursive_expected, 'Recursive placeholders resolve to... something';
  41
  42 {
  43     my $entry = File::KDBX::Entry->new(url => 'http://example.com?{EXPLODE}');
  44     is $entry->expand_url, 'http://example.com?{EXPLODE}',
  45         'Unhandled placeholders are not replaced';
  46
  47     local $File::KDBX::PLACEHOLDERS{EXPLODE} = sub { 'boom' };
  48     is $entry->expand_url, 'http://example.com?boom', 'Custom placeholders can be set';
  49
  50     $entry->url('{eXplOde}!!');
  51     is $entry->expand_url, 'boom!!', 'Placeholder tags are match case-insensitively';
  52 }
  53
  54 {
  55     local $ENV{LYRIC} = 'I am the very model of a modern Major-General';
  56     is $entry3->expand_password, "lyric:$ENV{LYRIC}", 'Environment variable placeholders';
  57     is $entry3->expand_notes, qq{%MISSING% %% %NOT AVAR% $ENV{LYRIC}},
  58         'Do not replace things that look like environment variables but are not';
  59 }
  60
  61 {
  62     my $counter = 0;
  63     local $File::KDBX::PLACEHOLDERS{'COUNTER'} = $File::KDBX::PLACEHOLDERS{'COUNTER:'} = sub {
  64         (undef, my $arg) = @_;
  65         return defined $arg ? $arg : ++$counter;
  66     };
  67     my $entry4 = $kdbx->add_entry(
  68         url => '{COUNTER} {USERNAME}',
  69         username => '{COUNTER}x{COUNTER}y{COUNTER:-1}',
  70     );
  71     like $entry4->expand_username, qr/^1x1y-1$/,
  72         'Each unique placeholder is evaluated once';
  73     like $entry4->expand_url, qr/^2 3x3y-1$/,
  74         'Each unique placeholder is evaluated once per string';
  75 }
  76
  77 done_testing;