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