Dogcows Code - chaz/p5-File-KDBX/blob - t/lib/TestCommon.pm

   1 package TestCommon;
   2
   3 use warnings;
   4 use strict;
   5
   6 use Data::Dumper;
   7 use File::KDBX::Constants qw(:magic :kdf);
   8 use File::KDBX::Util qw(can_fork dumper);
   9 use File::Spec;
  10 use FindBin qw($Bin);
  11 use Test::Fatal;
  12 use Test::Deep;
  13
  14 BEGIN {
  15     $Data::Dumper::Deepcopy = 1;
  16     $Data::Dumper::Deparse = 1;
  17     $Data::Dumper::Indent = 1;
  18     $Data::Dumper::Quotekeys = 0;
  19     $Data::Dumper::Sortkeys = 1;
  20     $Data::Dumper::Terse = 1;
  21     $Data::Dumper::Trailingcomma = 1;
  22     $Data::Dumper::Useqq = 1;
  23 }
  24
  25 sub import {
  26     my $self = shift;
  27     my @args = @_;
  28
  29     my $caller = caller;
  30
  31     require Test::Warnings;
  32     my @warnings_flags;
  33     push @warnings_flags, ':no_end_test' if !$ENV{AUTHOR_TESTING} || grep { $_ eq ':no_warnings_test' } @args;
  34     Test::Warnings->import(@warnings_flags);
  35
  36     # Just export a random assortment of things useful for testing.
  37     no strict 'refs';
  38     *{"${caller}::dumper"}      = \&File::KDBX::Util::dumper;
  39
  40     *{"${caller}::exception"}   = \&Test::Fatal::exception;
  41     *{"${caller}::warning"}     = \&Test::Warnings::warning;
  42     *{"${caller}::warnings"}    = \&Test::Warnings::warnings;
  43
  44     *{"${caller}::dump_test_deep_template"}  = \&dump_test_deep_template;
  45     *{"${caller}::ok_magic"}    = \&ok_magic;
  46     *{"${caller}::fast_kdf"}    = \&fast_kdf;
  47     *{"${caller}::can_fork"}    = \&can_fork;
  48     *{"${caller}::testfile"}    = \&testfile;
  49 }
  50
  51 sub testfile {
  52     return File::Spec->catfile($Bin, 'files', @_);
  53 }
  54
  55 sub dump_test_deep_template {
  56     my $struct = shift;
  57
  58     my $str = Dumper $struct;
  59     # booleans: bless( do{\(my $o = 1)}, 'boolean' )
  60     $str =~ s/bless\( do\{\\\(my \$o = ([01])\)\}, 'boolean' \)/bool($1)/gs;
  61     # objects
  62     $str =~ s/bless\(.+?'([^']+)' \)/obj_isa('$1')/gs;
  63     # convert two to four space indentation
  64     $str =~ s/^( +)/' ' x (length($1) * 2)/gme;
  65
  66     open(my $fh, '>>', 'TEST-DEEP-TEMPLATES.pl') or die "open failed: $!";
  67     print $fh $str, "\n";
  68 }
  69
  70 sub ok_magic {
  71     my $kdbx = shift;
  72     my $vers = shift;
  73     my $note = shift;
  74
  75     my $magic = [$kdbx->sig1, $kdbx->sig2, $kdbx->version];
  76     cmp_deeply $magic, [
  77         KDBX_SIG1,
  78         KDBX_SIG2_2,
  79         $vers,
  80     ], $note // 'KDBX magic numbers are correct';
  81 }
  82
  83 sub fast_kdf {
  84     my $uuid = shift // KDF_UUID_AES;
  85     my $params = {
  86         KDF_PARAM_UUID() => $uuid,
  87     };
  88     if ($uuid eq KDF_UUID_AES || $uuid eq KDF_UUID_AES_CHALLENGE_RESPONSE) {
  89         $params->{+KDF_PARAM_AES_ROUNDS} = 17;
  90         $params->{+KDF_PARAM_AES_SEED} = "\1" x 32;
  91     }
  92     else { # Argon2
  93         $params->{+KDF_PARAM_ARGON2_SALT} = "\1" x 32;
  94         $params->{+KDF_PARAM_ARGON2_PARALLELISM} = 1;
  95         $params->{+KDF_PARAM_ARGON2_MEMORY} = 1 << 13;
  96         $params->{+KDF_PARAM_ARGON2_ITERATIONS} = 2;
  97         $params->{+KDF_PARAM_ARGON2_VERSION} = 0x13;
  98     }
  99     return $params;
 100 }
 101 1;