t/op/smartkve.t

   1 #!./perl
   2
   3 BEGIN {
   4     chdir 't' if -d 't';
   5     @INC = '../lib';
   6     require './test.pl';
   7 }
   8 use strict;
   9 use warnings;
  10 no warnings 'deprecated';
  11 use vars qw($data $array $values $hash $errpat);
  12
  13 plan 'no_plan';
  14
  15 sub j { join(":",@_) }
  16
  17 BEGIN { # in BEGIN for "use constant ..." later
  18   $array = [ qw(pi e i) ];
  19   $values = [ 3.14, 2.72, -1 ];
  20   $hash  = { pi => 3.14, e => 2.72, i => -1 } ;
  21   $data = {
  22     hash => { %$hash },
  23     array => [ @$array ],
  24   };
  25 }
  26
  27 package Foo;
  28 sub new {
  29   my $self = {
  30     hash => {%{$main::hash} },
  31     array => [@{$main::array}]
  32   };
  33   bless $self, shift;
  34 }
  35 sub hash { no overloading; $_[0]->{hash} };
  36 sub array { no overloading; $_[0]->{array} };
  37
  38 package Foo::Overload::Array;
  39 sub new { return bless [ qw/foo bar/ ], shift }
  40 use overload '@{}' => sub { $main::array }, fallback => 1;
  41
  42 package Foo::Overload::Hash;
  43 sub new { return bless { qw/foo bar/ }, shift }
  44 use overload '%{}' => sub { $main::hash }, fallback => 1;
  45
  46 package Foo::Overload::Both;
  47 sub new { return bless { qw/foo bar/ }, shift }
  48 use overload  '%{}' => sub { $main::hash },
  49               '@{}' => sub { $main::array }, fallback => 1;
  50
  51 package Foo::Overload::HashOnArray;
  52 sub new { return bless [ qw/foo bar/ ], shift }
  53 use overload '%{}' => sub { $main::hash }, fallback => 1;
  54
  55 package Foo::Overload::ArrayOnHash;
  56 sub new { return bless { qw/foo bar/ }, shift }
  57 use overload '@{}' => sub { $main::array }, fallback => 1;
  58
  59 package main;
  60
  61 use constant CONST_HASH => { %$hash };
  62 use constant CONST_ARRAY => [ @$array ];
  63
  64 my %a_hash = %$hash;
  65 my @an_array = @$array;
  66 sub hash_sub { return \%a_hash; }
  67 sub array_sub { return \@an_array; }
  68
  69 my $obj = Foo->new;
  70
  71 my ($empty, $h_expect, $a_expect, @tmp, @tmp2, $k, $v);
  72
  73 # Keys -- void
  74
  75 keys $hash;             pass('Void: keys $hash;');
  76 keys $data->{hash};     pass('Void: keys $data->{hash};');
  77 keys CONST_HASH;        pass('Void: keys CONST_HASH;');
  78 keys CONST_HASH();      pass('Void: keys CONST_HASH();');
  79 keys hash_sub();        pass('Void: keys hash_sub();');
  80 keys hash_sub;          pass('Void: keys hash_sub;');
  81 keys $obj->hash;        pass('Void: keys $obj->hash;');
  82 keys $array;            pass('Void: keys $array;');
  83 keys $data->{array};    pass('Void: keys $data->{array};');
  84 keys CONST_ARRAY;       pass('Void: keys CONST_ARRAY;');
  85 keys CONST_ARRAY();     pass('Void: keys CONST_ARRAY();');
  86 keys array_sub;         pass('Void: keys array_sub;');
  87 keys array_sub();       pass('Void: keys array_sub();');
  88 keys $obj->array;       pass('Void: keys $obj->array;');
  89
  90 # Keys -- scalar
  91
  92 is(keys $hash           ,3, 'Scalar: keys $hash');
  93 is(keys $data->{hash}   ,3, 'Scalar: keys $data->{hash}');
  94 is(keys CONST_HASH      ,3, 'Scalar: keys CONST_HASH');
  95 is(keys CONST_HASH()    ,3, 'Scalar: keys CONST_HASH()');
  96 is(keys hash_sub        ,3, 'Scalar: keys hash_sub');
  97 is(keys hash_sub()      ,3, 'Scalar: keys hash_sub()');
  98 is(keys $obj->hash      ,3, 'Scalar: keys $obj->hash');
  99 is(keys $array          ,3, 'Scalar: keys $array');
 100 is(keys $data->{array}  ,3, 'Scalar: keys $data->{array}');
 101 is(keys CONST_ARRAY     ,3, 'Scalar: keys CONST_ARRAY');
 102 is(keys CONST_ARRAY()   ,3, 'Scalar: keys CONST_ARRAY()');
 103 is(keys array_sub       ,3, 'Scalar: keys array_sub');
 104 is(keys array_sub()     ,3, 'Scalar: keys array_sub()');
 105 is(keys $obj->array     ,3, 'Scalar: keys $obj->array');
 106
 107 # Keys -- list
 108
 109 $h_expect = j(keys %$hash);
 110 $a_expect = j(keys @$array);
 111
 112 is(j(keys $hash)                ,$h_expect, 'List: keys $hash');
 113 is(j(keys $data->{hash})        ,$h_expect, 'List: keys $data->{hash}');
 114 is(j(keys CONST_HASH)           ,$h_expect, 'List: keys CONST_HASH');
 115 is(j(keys CONST_HASH())         ,$h_expect, 'List: keys CONST_HASH()');
 116 is(j(keys hash_sub)             ,$h_expect, 'List: keys hash_sub');
 117 is(j(keys hash_sub())           ,$h_expect, 'List: keys hash_sub()');
 118 is(j(keys $obj->hash)           ,$h_expect, 'List: keys $obj->hash');
 119 is(j(keys $array)               ,$a_expect, 'List: keys $array');
 120 is(j(keys $data->{array})       ,$a_expect, 'List: keys $data->{array}');
 121 is(j(keys CONST_ARRAY)          ,$a_expect, 'List: keys CONST_ARRAY');
 122 is(j(keys CONST_ARRAY())        ,$a_expect, 'List: keys CONST_ARRAY()');
 123 is(j(keys array_sub)            ,$a_expect, 'List: keys array_sub');
 124 is(j(keys array_sub())          ,$a_expect, 'List: keys array_sub()');
 125 is(j(keys $obj->array)          ,$a_expect, 'List: keys $obj->array');
 126
 127 # Keys -- vivification
 128 undef $empty;
 129 eval { keys $empty->{hash} };
 130 ok(defined $empty,
 131   'Vivify: $empty (after keys $empty->{hash}) is HASHREF');
 132 ok(!defined $empty->{hash}      ,   'Vivify: $empty->{hash} is undef');
 133
 134 # Keys -- lvalue
 135 $_{foo} = "bar";
 136 keys \%_ = 65;
 137 is scalar %_, '1/128', 'keys $hashref as lvalue';
 138 eval 'keys \@_ = 65';
 139 like $@, qr/Can't modify keys on reference in scalar assignment/,
 140   'keys $arrayref as lvalue dies';
 141
 142 # Keys -- errors
 143 $errpat = qr/
 144  (?-x:Type of argument to keys on reference must be unblessed hashref or)
 145  (?-x: arrayref)
 146 /x;
 147
 148 eval "keys undef";
 149 ok($@ =~ $errpat,
 150   'Errors: keys undef throws error'
 151 );
 152
 153 undef $empty;
 154 eval q"keys $empty";
 155 ok($@ =~ $errpat,
 156   'Errors: keys $undef throws error'
 157 );
 158
 159 is($empty, undef, 'keys $undef does not vivify $undef');
 160
 161 eval "keys 3";
 162 ok($@ =~ qr/Type of arg 1 to keys must be hash/,
 163   'Errors: keys CONSTANT throws error'
 164 );
 165
 166 eval "keys qr/foo/";
 167 ok($@ =~ $errpat,
 168   'Errors: keys qr/foo/ throws error'
 169 );
 170
 171 eval "keys $hash qw/fo bar/";
 172 ok($@ =~ qr/syntax error/,
 173   'Errors: keys $hash, @stuff throws error'
 174 ) or print "# Got: $@";
 175
 176 # Values -- void
 177
 178 values $hash;             pass('Void: values $hash;');
 179 values $data->{hash};     pass('Void: values $data->{hash};');
 180 values CONST_HASH;        pass('Void: values CONST_HASH;');
 181 values CONST_HASH();      pass('Void: values CONST_HASH();');
 182 values hash_sub();        pass('Void: values hash_sub();');
 183 values hash_sub;          pass('Void: values hash_sub;');
 184 values $obj->hash;        pass('Void: values $obj->hash;');
 185 values $array;            pass('Void: values $array;');
 186 values $data->{array};    pass('Void: values $data->{array};');
 187 values CONST_ARRAY;       pass('Void: values CONST_ARRAY;');
 188 values CONST_ARRAY();     pass('Void: values CONST_ARRAY();');
 189 values array_sub;         pass('Void: values array_sub;');
 190 values array_sub();       pass('Void: values array_sub();');
 191 values $obj->array;       pass('Void: values $obj->array;');
 192
 193 # Values -- scalar
 194
 195 is(values $hash           ,3, 'Scalar: values $hash');
 196 is(values $data->{hash}   ,3, 'Scalar: values $data->{hash}');
 197 is(values CONST_HASH      ,3, 'Scalar: values CONST_HASH');
 198 is(values CONST_HASH()    ,3, 'Scalar: values CONST_HASH()');
 199 is(values hash_sub        ,3, 'Scalar: values hash_sub');
 200 is(values hash_sub()      ,3, 'Scalar: values hash_sub()');
 201 is(values $obj->hash      ,3, 'Scalar: values $obj->hash');
 202 is(values $array          ,3, 'Scalar: values $array');
 203 is(values $data->{array}  ,3, 'Scalar: values $data->{array}');
 204 is(values CONST_ARRAY     ,3, 'Scalar: values CONST_ARRAY');
 205 is(values CONST_ARRAY()   ,3, 'Scalar: values CONST_ARRAY()');
 206 is(values array_sub       ,3, 'Scalar: values array_sub');
 207 is(values array_sub()     ,3, 'Scalar: values array_sub()');
 208 is(values $obj->array     ,3, 'Scalar: values $obj->array');
 209
 210 # Values -- list
 211
 212 $h_expect = j(values %$hash);
 213 $a_expect = j(values @$array);
 214
 215 is(j(values $hash)                ,$h_expect, 'List: values $hash');
 216 is(j(values $data->{hash})        ,$h_expect, 'List: values $data->{hash}');
 217 is(j(values CONST_HASH)           ,$h_expect, 'List: values CONST_HASH');
 218 is(j(values CONST_HASH())         ,$h_expect, 'List: values CONST_HASH()');
 219 is(j(values hash_sub)             ,$h_expect, 'List: values hash_sub');
 220 is(j(values hash_sub())           ,$h_expect, 'List: values hash_sub()');
 221 is(j(values $obj->hash)           ,$h_expect, 'List: values $obj->hash');
 222 is(j(values $array)               ,$a_expect, 'List: values $array');
 223 is(j(values $data->{array})       ,$a_expect, 'List: values $data->{array}');
 224 is(j(values CONST_ARRAY)          ,$a_expect, 'List: values CONST_ARRAY');
 225 is(j(values CONST_ARRAY())        ,$a_expect, 'List: values CONST_ARRAY()');
 226 is(j(values array_sub)            ,$a_expect, 'List: values array_sub');
 227 is(j(values array_sub())          ,$a_expect, 'List: values array_sub()');
 228 is(j(values $obj->array)          ,$a_expect, 'List: values $obj->array');
 229
 230 # Values -- vivification
 231 undef $empty;
 232 eval { values $empty->{hash} };
 233 ok(defined $empty,
 234   'Vivify: $empty (after values $empty->{hash}) is HASHREF');
 235 ok(!defined $empty->{hash}      ,   'Vivify: $empty->{hash} is undef');
 236
 237 # Values -- errors
 238 $errpat = qr/
 239  (?-x:Type of argument to values on reference must be unblessed hashref or)
 240  (?-x: arrayref)
 241 /x;
 242
 243 eval "values undef";
 244 ok($@ =~ $errpat,
 245   'Errors: values undef throws error'
 246 );
 247
 248 undef $empty;
 249 eval q"values $empty";
 250 ok($@ =~ $errpat,
 251   'Errors: values $undef throws error'
 252 );
 253
 254 is($empty, undef, 'values $undef does not vivify $undef');
 255
 256 eval "values 3";
 257 ok($@ =~ qr/Type of arg 1 to values must be hash/,
 258   'Errors: values CONSTANT throws error'
 259 );
 260
 261 eval "values qr/foo/";
 262 ok($@ =~ $errpat,
 263   'Errors: values qr/foo/ throws error'
 264 );
 265
 266 eval "values $hash qw/fo bar/";
 267 ok($@ =~ qr/syntax error/,
 268   'Errors: values $hash, @stuff throws error'
 269 ) or print "# Got: $@";
 270
 271 # Each -- void
 272
 273 each $hash;             pass('Void: each $hash');
 274 each $data->{hash};     pass('Void: each $data->{hash}');
 275 each CONST_HASH;        pass('Void: each CONST_HASH');
 276 each CONST_HASH();      pass('Void: each CONST_HASH()');
 277 each hash_sub();        pass('Void: each hash_sub()');
 278 each hash_sub;          pass('Void: each hash_sub');
 279 each $obj->hash;        pass('Void: each $obj->hash');
 280 each $array;            pass('Void: each $array');
 281 each $data->{array};    pass('Void: each $data->{array}');
 282 each CONST_ARRAY;       pass('Void: each CONST_ARRAY');
 283 each CONST_ARRAY();     pass('Void: each CONST_ARRAY()');
 284 each array_sub;         pass('Void: each array_sub');
 285 each array_sub();       pass('Void: each array_sub()');
 286 each $obj->array;       pass('Void: each $obj->array');
 287
 288 # Reset iterators
 289
 290 keys $hash;
 291 keys $data->{hash};
 292 keys CONST_HASH;
 293 keys CONST_HASH();
 294 keys hash_sub();
 295 keys hash_sub;
 296 keys $obj->hash;
 297 keys $array;
 298 keys $data->{array};
 299 keys CONST_ARRAY;
 300 keys CONST_ARRAY();
 301 keys array_sub;
 302 keys array_sub();
 303 keys $obj->array;
 304
 305 # Each -- scalar
 306
 307 @tmp=(); while(defined( $k = each $hash)) {push @tmp,$k}; is(j(@tmp),j(keys $hash), 'Scalar: each $hash');
 308 @tmp=(); while(defined( $k = each $data->{hash})){push @tmp,$k}; is(j(@tmp),j(keys $data->{hash}), 'Scalar: each $data->{hash}');
 309 @tmp=(); while(defined( $k = each CONST_HASH)){push @tmp,$k}; is(j(@tmp),j(keys CONST_HASH), 'Scalar: each CONST_HASH');
 310 @tmp=(); while(defined( $k = each CONST_HASH())){push @tmp,$k}; is(j(@tmp),j(keys CONST_HASH()), 'Scalar: each CONST_HASH()');
 311 @tmp=(); while(defined( $k = each hash_sub())){push @tmp,$k}; is(j(@tmp),j(keys hash_sub()), 'Scalar: each hash_sub()');
 312 @tmp=(); while(defined( $k = each hash_sub)){push @tmp,$k}; is(j(@tmp),j(keys hash_sub), 'Scalar: each hash_sub');
 313 @tmp=(); while(defined( $k = each $obj->hash)){push @tmp,$k}; is(j(@tmp),j(keys $obj->hash), 'Scalar: each $obj->hash');
 314 @tmp=(); while(defined( $k = each $array)){push @tmp,$k}; is(j(@tmp),j(keys $array), 'Scalar: each $array');
 315 @tmp=(); while(defined( $k = each $data->{array})){push @tmp,$k}; is(j(@tmp),j(keys $data->{array}), 'Scalar: each $data->{array}');
 316 @tmp=(); while(defined( $k = each CONST_ARRAY)){push @tmp,$k}; is(j(@tmp),j(keys CONST_ARRAY), 'Scalar: each CONST_ARRAY');
 317 @tmp=(); while(defined( $k = each CONST_ARRAY())){push @tmp,$k}; is(j(@tmp),j(keys CONST_ARRAY()), 'Scalar: each CONST_ARRAY()');
 318 @tmp=(); while(defined( $k = each array_sub)){push @tmp,$k}; is(j(@tmp),j(keys array_sub), 'Scalar: each array_sub');
 319 @tmp=(); while(defined( $k = each array_sub())){push @tmp,$k}; is(j(@tmp),j(keys array_sub()), 'Scalar: each array_sub()');
 320 @tmp=(); while(defined( $k = each $obj->array)){push @tmp,$k}; is(j(@tmp),j(keys $obj->array), 'Scalar: each $obj->array');
 321
 322 # Each -- list
 323
 324 @tmp=@tmp2=(); while(($k,$v) = each $hash) {push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $hash, values $hash), 'List: each $hash');
 325 @tmp=@tmp2=(); while(($k,$v) = each $data->{hash}){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $data->{hash}, values $data->{hash}), 'List: each $data->{hash}');
 326 @tmp=@tmp2=(); while(($k,$v) = each CONST_HASH){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys CONST_HASH, values CONST_HASH), 'List: each CONST_HASH');
 327 @tmp=@tmp2=(); while(($k,$v) = each CONST_HASH()){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys CONST_HASH(), values CONST_HASH()), 'List: each CONST_HASH()');
 328 @tmp=@tmp2=(); while(($k,$v) = each hash_sub()){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys hash_sub(), values hash_sub()), 'List: each hash_sub()');
 329 @tmp=@tmp2=(); while(($k,$v) = each hash_sub){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys hash_sub, values hash_sub), 'List: each hash_sub');
 330 @tmp=@tmp2=(); while(($k,$v) = each $obj->hash){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $obj->hash, values $obj->hash), 'List: each $obj->hash');
 331 @tmp=@tmp2=(); while(($k,$v) = each $array){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $array, values $array), 'List: each $array');
 332 @tmp=@tmp2=(); while(($k,$v) = each $data->{array}){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $data->{array}, values $data->{array}), 'List: each $data->{array}');
 333 @tmp=@tmp2=(); while(($k,$v) = each CONST_ARRAY){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys CONST_ARRAY, values CONST_ARRAY), 'List: each CONST_ARRAY');
 334 @tmp=@tmp2=(); while(($k,$v) = each CONST_ARRAY()){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys CONST_ARRAY(), values CONST_ARRAY()), 'List: each CONST_ARRAY()');
 335 @tmp=@tmp2=(); while(($k,$v) = each array_sub){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys array_sub, values array_sub), 'List: each array_sub');
 336 @tmp=@tmp2=(); while(($k,$v) = each array_sub()){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys array_sub(), values array_sub()), 'List: each array_sub()');
 337 @tmp=@tmp2=(); while(($k,$v) = each $obj->array){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $obj->array, values $obj->array), 'List: each $obj->array');
 338
 339 # Each -- vivification
 340 undef $empty;
 341 eval { each $empty->{hash} };
 342 ok(defined $empty,
 343   'Vivify: $empty (after each $empty->{hash}) is HASHREF');
 344 ok(!defined $empty->{hash}      ,   'Vivify: $empty->{hash} is undef');
 345
 346 # Each -- errors
 347 $errpat = qr/
 348  (?-x:Type of argument to each on reference must be unblessed hashref or)
 349  (?-x: arrayref)
 350 /x;
 351
 352 eval "each undef";
 353 ok($@ =~ $errpat,
 354   'Errors: each undef throws error'
 355 );
 356
 357 undef $empty;
 358 eval q"each $empty";
 359 ok($@ =~ $errpat,
 360   'Errors: each $undef throws error'
 361 );
 362
 363 is($empty, undef, 'each $undef does not vivify $undef');
 364
 365 eval "each 3";
 366 ok($@ =~ qr/Type of arg 1 to each must be hash/,
 367   'Errors: each CONSTANT throws error'
 368 );
 369
 370 eval "each qr/foo/";
 371 ok($@ =~ $errpat,
 372   'Errors: each qr/foo/ throws error'
 373 );
 374
 375 eval "each $hash qw/foo bar/";
 376 ok($@ =~ qr/syntax error/,
 377   'Errors: each $hash, @stuff throws error'
 378 ) or print "# Got: $@";
 379
 380 # Overloaded objects
 381 my $over_a = Foo::Overload::Array->new;
 382 my $over_h = Foo::Overload::Hash->new;
 383 my $over_b = Foo::Overload::Both->new;
 384 my $over_h_a = Foo::Overload::HashOnArray->new;
 385 my $over_a_h = Foo::Overload::ArrayOnHash->new;
 386
 387 {
 388   my $warn = '';
 389   local $SIG{__WARN__} = sub { $warn = shift };
 390
 391   $errpat = qr/
 392    (?-x:Type of argument to keys on reference must be unblessed hashref or)
 393    (?-x: arrayref)
 394   /x;
 395
 396   eval { keys $over_a };
 397   like($@, $errpat, "Overload: array dereference");
 398   is($warn, '', "no warning issued"); $warn = '';
 399
 400   eval { keys $over_h };
 401   like($@, $errpat, "Overload: hash dereference");
 402   is($warn, '', "no warning issued"); $warn = '';
 403
 404   eval { keys $over_b };
 405   like($@, $errpat, "Overload: ambiguous dereference (both)");
 406   is($warn, '', "no warning issued"); $warn = '';
 407
 408   eval { keys $over_h_a };
 409   like($@, $errpat, "Overload: ambiguous dereference");
 410   is($warn, '', "no warning issued"); $warn = '';
 411
 412   eval { keys $over_a_h };
 413   like($@, $errpat, "Overload: ambiguous dereference");
 414   is($warn, '', "no warning issued"); $warn = '';
 415 }