1# -*- mode: perl; -*- 2 3use strict; 4use warnings; 5 6use Test::More tests => 54713; 7 8############################################################################### 9# Read and load configuration file and backend library. 10 11use Config::Tiny (); 12 13my $config_file = 'xt/author/lib.ini'; 14my $config = Config::Tiny -> read('xt/author/lib.ini') 15 or die Config::Tiny -> errstr(); 16 17# Read the library to test. 18 19our $LIB = $config->{_}->{lib}; 20 21die "No library defined in file '$config_file'" 22 unless defined $LIB; 23die "Invalid library name '$LIB' in file '$config_file'" 24 unless $LIB =~ /^[A-Za-z]\w*(::\w+)*\z/; 25 26# Read the reference type(s) the library uses. 27 28our $REF = $config->{_}->{ref}; 29 30die "No reference type defined in file '$config_file'" 31 unless defined $REF; 32die "Invalid reference type '$REF' in file '$config_file'" 33 unless $REF =~ /^[A-Za-z]\w*(::\w+)*\z/; 34 35# Load the library. 36 37eval "require $LIB"; 38die $@ if $@; 39 40############################################################################### 41 42my $scalar_util_ok = eval { require Scalar::Util; }; 43Scalar::Util -> import('refaddr') if $scalar_util_ok; 44 45diag "Skipping some tests since Scalar::Util is not installed." 46 unless $scalar_util_ok; 47 48can_ok($LIB, '_rsft'); 49 50my @data; 51 52# Small numbers. 53 54for (my $x = 0; $x <= 100 ; ++ $x) { 55 for (my $n = 0; $n <= 5 ; ++ $n) { 56 for (my $b = 2; $b <= 16 ; ++ $b) { 57 my $y = int($x / ($b ** $n)); 58 push @data, [ $x, $n, $b, $y ]; 59 } 60 } 61} 62 63# Add data in data file. 64 65(my $datafile = $0) =~ s/\.t/.dat/; 66open DATAFILE, $datafile or die "$datafile: can't open file for reading: $!"; 67while (<DATAFILE>) { 68 s/\s+\z//; 69 next if /^#/ || ! /\S/; 70 push @data, [ split /:/ ]; 71} 72close DATAFILE or die "$datafile: can't close file after reading: $!"; 73 74# List context. 75 76for (my $i = 0 ; $i <= $#data ; ++ $i) { 77 my ($in0, $in1, $in2, $out0) = @{ $data[$i] }; 78 79 my ($x, $y, @got); 80 81 my $test = qq|\$x = $LIB->_new("$in0"); | 82 . qq|\$y = $LIB->_new("$in1"); | 83 . qq|\@got = $LIB->_rsft(\$x, \$y, $in2);|; 84 85 diag("\n$test\n\n") if $ENV{AUTHOR_DEBUGGING}; 86 87 eval $test; 88 is($@, "", "'$test' gives emtpy \$\@"); 89 90 subtest "_rsft() in list context: $test", sub { 91 plan tests => 8; 92 93 cmp_ok(scalar @got, '==', 1, 94 "'$test' gives one output arg"); 95 96 is(ref($got[0]), $REF, 97 "'$test' output arg is a $REF"); 98 99 is($LIB->_check($got[0]), 0, 100 "'$test' output is valid"); 101 102 is($LIB->_str($got[0]), $out0, 103 "'$test' output arg has the right value"); 104 105 SKIP: { 106 skip "Scalar::Util not available", 1 unless $scalar_util_ok; 107 108 isnt(refaddr($got[0]), refaddr($y), 109 "'$test' output arg is not the second input arg"); 110 } 111 112 is(ref($x), $REF, 113 "'$test' first input arg is still a $REF"); 114 115 is(ref($y), $REF, 116 "'$test' second input arg is still a $REF"); 117 118 is($LIB->_str($y), $in1, 119 "'$test' second input arg is unmodified"); 120 }; 121} 122 123# Scalar context. 124 125for (my $i = 0 ; $i <= $#data ; ++ $i) { 126 my ($in0, $in1, $in2, $out0) = @{ $data[$i] }; 127 128 my ($x, $y, $got); 129 130 my $test = qq|\$x = $LIB->_new("$in0"); | 131 . qq|\$y = $LIB->_new("$in1"); | 132 . qq|\$got = $LIB->_rsft(\$x, \$y, $in2);|; 133 134 diag("\n$test\n\n") if $ENV{AUTHOR_DEBUGGING}; 135 136 eval $test; 137 is($@, "", "'$test' gives emtpy \$\@"); 138 139 subtest "_rsft() in scalar context: $test", sub { 140 plan tests => 7; 141 142 is(ref($got), $REF, 143 "'$test' output arg is a $REF"); 144 145 is($LIB->_check($got), 0, 146 "'$test' output is valid"); 147 148 is($LIB->_str($got), $out0, 149 "'$test' output arg has the right value"); 150 151 SKIP: { 152 skip "Scalar::Util not available", 1 unless $scalar_util_ok; 153 154 isnt(refaddr($got), refaddr($y), 155 "'$test' output arg is not the second input arg"); 156 } 157 158 is(ref($x), $REF, 159 "'$test' first input arg is still a $REF"); 160 161 is(ref($y), $REF, 162 "'$test' second input arg is still a $REF"); 163 164 is($LIB->_str($y), $in1, 165 "'$test' second input arg is unmodified"); 166 }; 167} 168