t/autohashUtil.pm - metacpan.org

package autohashUtil;
use lib qw(t);
use strict;
use Carp;
use List::MoreUtils qw(uniq);
#use Test::More qw/no_plan/;
use Test::More;
use Test::Deep;
use Exporter();
use Hash::AutoHash;

our @ISA=qw(Exporter);
our @EXPORT=qw(as_bool ordinal report _report
	       cmp_types cmp_autohash _cmp_autohash keys_obj values_obj each_obj
	       @KEYS @UNDEFS @VALUES_SV @VALUES_MV $VERBOSE
	       is_autohash is_hash is_object is_self is_tie 
	       is_autohash_hash is_autohash_object is_autohash_self is_autohash_tie
	       test_special_keys 
	       test_class_methods @COMMON_SPECIAL_KEYS
	       $autohash %hash %tie $object);

# globals used in all tests
our($autohash,%hash,%tie,$object);
our $VERBOSE=0;
our @KEYS=qw(key0 key1 key2);
our @UNDEFS=(undef) x @KEYS;
our @VALUES_SV=([undef,undef,undef],
		[undef,'value11','value21'],
		[undef,'value12','value22'],
		[undef,'value13','value23'],);
our @VALUES_MV=([undef,undef,undef],
		[undef,['value11'],['value21']],
		[undef,[qw(value11 value12)],[qw(value21 value22)]],
		[undef,[qw(value11 value12 value13)],[qw(value21 value22 value23)]]);

# sub report (*\@\@) {
#   my($label,$ok,$fail)=@_;
#   unless (@$fail) {
#     pass($label) if $VERBOSE;
#     return 1;
#   }
#   fail($label);
#   diag(scalar(@$ok)." cases have correct values: @$ok");
#   diag(scalar(@$fail)." cases have wrong values: @$fail");
# }

sub _report (*\@\@) {
  my($label,$ok,$fail)=@_;
  unless (@$fail) {
    pass($label) if $VERBOSE;
    return 1;
  }
  fail($label);
  diag(scalar(@$ok)." cases have correct values: @$ok");
  diag(scalar(@$fail)." cases have wrong values: @$fail");
  return 0;
}
sub report (*\@\@) {
  my($label,$ok,$fail)=@_;
  my $pass=_report($label,@$ok,@$fail);
  pass($_[0]) if $pass && !$VERBOSE; # print if all tests passed and tests didn't print passes
  $pass;
}

sub as_bool {$_[0]? 1: undef;}
sub ordinal {
  my $i=shift;
  return 'initial' unless $i--;
  return '1st' unless $i--;
  return '2nd' unless $i--;
  return '3rd' unless $i--;
  return $i.'-th';
}

# test type of $autohash, whatever $autohash is tied to, %hash, $object, whatever %hash is tied to
sub cmp_types {
  my($label,$correct_tied,$correct_object,$correct_tiedhash)=@_;
  my $correct_autohash='Hash::AutoHash';
  my $correct_hash='HASH';
  my(@ok,@fail);
  my $actual_autohash=ref $autohash;
  my $actual_tied=ref tied %$autohash;
  my $actual_hash=ref \%hash;
  my $actual_object=ref $object;
  my $actual_tiedhash=ref tied %hash;
  $actual_autohash eq $correct_autohash? push(@ok,'autohash'): push(@fail,'autohash');
  $actual_tied eq $correct_tied? push(@ok,'tied'): push(@fail,'tied');
  $actual_hash eq $correct_hash? push(@ok,'hash'): push(@fail,'hash');
  $actual_object eq $correct_object? push(@ok,'object'): push(@fail,'object');
  $actual_tiedhash eq $correct_tiedhash? push(@ok,'tiedhash'): push(@fail,'tiedhash');
  $label.=': types';
  pass($label),return unless @fail;
  fail($label);
  diag(scalar(@ok)." items have correct types: @ok");
  diag(scalar(@fail)." items have wrong types: @fail");
}
# test contents of wrapper and external hash or object
# NG 09-07-29: generalize to allow any actual autohash or correct value
sub cmp_autohash {
  my $pass=_cmp_autohash(@_);
  my $label=$_[0];
  pass($_[0]) if $pass && !$VERBOSE; # print if all tests passed and tests didn't print passes
  $pass;
}
# _cmp_autohash does the work but does not print passes
sub _cmp_autohash {
  my($label,$values,$actual,$correct,$ok_hash,$ok_object,$hash,$obj);
  if ('ARRAY' eq ref $_[1]) {	# old form
    ($label,$values,$ok_hash,$ok_object)=@_;
    my @values=@$values;

    # NG 09-07-29: added computation of %correct. added _cmp_contents.
    #              changed othered to use %correct
    $actual=$autohash;
    %$correct=map {defined($values[$_])? ($KEYS[$_]=>$values[$_]): ()} 0..$#values;
    $hash=\%hash;
    $obj=$object;
  } else {
    ($label,$actual,$correct,$ok_hash,$ok_object,$hash,$obj)=@_;
  }
  my $pass=1;			# assume success
  $pass&&=_cmp_contents($label,$actual,$correct);
  $pass&&=_cmp_autohash_methods($label,$actual,$correct);
  $pass&&=_cmp_autohash_hash($label,$actual,$correct);
  $pass&&=_cmp_hash($label,$ok_hash,$hash,$correct);
  $pass&&=_cmp_object($label,$ok_object,$obj,$correct);
  $pass;
#     _cmp_autohash_methods($label,@values);
#     _cmp_autohash_hash($label,@values);
#     _cmp_hash($label,$ok_hash,@values);
#     _cmp_object($label,$ok_object,@values);
#   } else {			# new form
#     ($label,$actual,$correct,$ok_hash,$ok_object,$hash,$object)=@_;
#     %correct=%$correct;
#     _cmp_contents($label,$actual,%correct);
#     _cmp_autohash_methods($label,$actual,%correct);
#     _cmp_autohash_hash($label,$actual,%correct);
#     _cmp_hash($label,$ok_hash,$hash,%correct);
#     _cmp_object($label,$ok_object,$object,%correct);
#   }
}
# NG 09-07-29: added _cmp_contents
sub _cmp_contents {
  my($label,$actual,$correct)=@_;
  $label.=' contents';
  my %actual=%$actual;
  return 1 if !$VERBOSE && eq_deeply(\%actual,$correct);
  # else let cmp_deeply print its results
  cmp_deeply(\%actual,$correct,$label);
}

sub _cmp_autohash_methods {
  my($label,$actual,$correct)=@_;
  $label.=' via methods';
  my(@ok,@fail);
  for my $key (keys %$correct) {
    my $actual_val=$actual->$key;
    my $correct_val=$correct->{$key};
    eq_deeply($actual_val,$correct_val)? push(@ok,$key): push(@fail,$key);
  }
  _report($label,@ok,@fail);
}
sub _cmp_autohash_hash {
  my($label,$actual,$correct)=@_;
  $label.=' as hash';
  my(@ok,@fail);
  for my $key (keys %$correct) {
    my $actual_val=$actual->{$key};
    my $correct_val=$correct->{$key};
    eq_deeply($actual_val,$correct_val)? push(@ok,$key): push(@fail,$key);
  }
  _report($label,@ok,@fail);
}
sub _cmp_hash {
  my($label,$ok_hash,$actual,$correct)=@_;
  my %actual=defined $actual? %$actual: ();
  $label.=' external hash';
  unless ($ok_hash) {		# %actual (aka %hash) should be empty
    $label.=' empty';
    fail($label), return if %actual;
    pass($label) if $VERBOSE;
    return 1;
  }
  my(@ok,@fail);
  for my $key (keys %$correct) {
    my $actual_val=$actual{$key};
    my $correct_val=$correct->{$key};
    eq_deeply($actual_val,$correct_val)? push(@ok,$key): push(@fail,$key);
  }
  _report($label,@ok,@fail);
}
sub _cmp_object {
  my($label,$ok_object,$actual,$correct)=@_;
  $label.=' tied object';
  unless ($ok_object) {		# $object should be undef
    $label.=' empty';
    fail($label), return if defined $object;
    pass($label) if $VERBOSE;
    return 1;
  }  
  my(@ok,@fail);
  for my $key (keys %$correct) {
    my $actual_val=$actual->FETCH($key);
    my $correct_val=$correct->{$key};
    eq_deeply($actual_val,$correct_val)? push(@ok,$key): push(@fail,$key);
  }
  _report($label,@ok,@fail);
}
# sub _cmp_autohash_methods {
#   my($label,@values)=@_;
#   $label.=' via methods';
#   my(@ok,@fail);
#   for my $key (@KEYS) {
#     my $actual=$autohash->$key;
#     my $correct=shift @values;
#     eq_deeply($actual,$correct)? push(@ok,$key): push(@fail,$key);
#   }
#   report($label,@ok,@fail);
# }
# sub _cmp_autohash_hash {
#   my($label,@values)=@_;
#   $label.=' as hash';
#   my(@ok,@fail);
#   for my $key (@KEYS) {
#     my $value=shift @values;
#     eq_deeply($autohash->{$key},$value)? push(@ok,$key): push(@fail,$key);
#   }
#   report($label,@ok,@fail);
# }
# sub _cmp_hash {
#   my($label,$ok_hash,@values)=@_;
#   $label.=' external hash';
#   unless ($ok_hash) {		# %hash should be empty
#     ok(!%hash,"$label empty");
#     return;
#   }
#   my(@ok,@fail);
#   for my $key (@KEYS) {
#     my $value=shift @values;
#     eq_deeply($hash{$key},$value)? push(@ok,$key): push(@fail,$key);
#   }
#   report($label,@ok,@fail);
# }
# sub _cmp_object {
#   my($label,$ok_object,@values)=@_;
#   $label.=' external object';
#   unless ($ok_object) {		# $object should be undef
#     is($object,undef,"$label empty");
#     return;
#   }  
#   my(@ok,@fail);
#   for my $key (@KEYS) {
#     my $actual=$object->FETCH($key);
#     my $correct=shift @values;
#     eq_deeply($actual,$correct)? push(@ok,$key): push(@fail,$key);
#   }
#   report($label,@ok,@fail);
# }
sub keys_obj {			# based on code from now-obsolete version of Hash
  my $obj=@_? shift: $object;
  my($key,$value)=$obj->FIRSTKEY() or return ();
  my @keys=($key);
  while(($key,$value)=$obj->NEXTKEY()) {
    push(@keys,$key);
  }
  @keys;
}
sub values_obj {			# based on code from now-obsolete version of Hash
  my $obj=@_? shift: $object;
  my($key,$value)=$obj->FIRSTKEY() or return ();
  my @values=($value);
  while(($key,$value)=$obj->NEXTKEY()) {
    push(@values,$value);
  }
  @values;
}
my $each;			# controls iterator
sub each_obj {
  my $obj=@_? shift: $object;
  if (wantarray) {
    my @result=!$each? $object->FIRSTKEY(): $object->NEXTKEY();
    $each=scalar @result;
    return @result;
  } else {
    my $result=!$each? $object->FIRSTKEY(): $object->NEXTKEY();
    return $each=$result;
  }
}
# sub is_object (*@) {
#   my($label,@values)=@_;
#   my(@ok,@fail);
#   for my $key (@KEYS) {
#     my $value=shift @values;
#     eq_deeply($object->FETCH($key),$value)? push(@ok,$key): push(@fail,$key);
#   }
#   $label.=": object";
#   report($label,@ok,@fail);
# }
# sub is_self (*@) {
#   my($label,@values)=@_;
#   my(@ok,@fail);
#   for my $key (@KEYS) {
#     my $value=shift @values;
#     eq_deeply($autohash->{$key},$value)? push(@ok,$key): push(@fail,$key);
#   }
#   $label.=": self";
#   report($label,@ok,@fail);
# }
# sub is_tie (*@) {
#   my($label,@values)=@_;
#   my(@ok,@fail);
#   for my $key (@KEYS) {
#     my $value=shift @values;
#     eq_deeply($tie{$key},$value)? push(@ok,$key): push(@fail,$key);
#   }
#   $label.=": tie";
#   report($label,@ok,@fail);
# }
# sub is_autohash_hash (*@) {
#   my($label,@values)=@_;
#   is_autohash($label,@values);
#   is_hash($label,@values);
# }
# sub is_autohash_object (*@) {
#   my($label,@values)=@_;
#   is_autohash($label,@values);
#   is_object($label,@values);
#   is_tie($label,@values);
# }
# sub is_autohash_self (*@) {
#   my($label,@values)=@_;
#   is_autohash($label,@values);
#   is_self($label,@values);
# }
# sub is_autohash_tie (*@) {
#   my($label,@values)=@_;
#   is_autohash($label,@values);
#   is_tie($label,@values);
# }

# NG 12-09-02: no longer possible to override methods inheritted from UNIVERSAL
# used by xxx.020.special_keys.t for many (probably all) subclasses 
our @COMMON_SPECIAL_KEYS=qw(import new AUTOLOAD DESTROY);
our @FORMER_SPECIAL_KEYS=qw(can isa DOES VERSION);

sub test_special_keys {
  my($autohash,$repeat,$fixer,$case)=@_;
  my $class=ref $autohash;
  defined($repeat) or $repeat=1;
  defined($fixer) or $fixer=sub {$_[0]};
  my $label=length($case)? "$class $case special keys": "$class special keys";
  my @keys;
  {
    no strict 'refs';
    @keys=uniq(@COMMON_SPECIAL_KEYS,
	       # qw(import new can isa DOES VERSION AUTOLOAD DESTROY),
	       @Hash::AutoHash::EXPORT_OK,@{$class.'::EXPORT_OK'});  
  }
  my(@ok,@fail);
  for my $key (@keys) {
    my $value="value_$key";
    for(my $i=0; $i<$repeat; $i++) {$autohash->$key($value);} # set value
    my $actual=$autohash->$key;	# get value
    my $correct=&$fixer($value);
    eq_deeply($actual,$correct)? push(@ok,$key): push(@fail,$key);
    # $actual eq $correct? push(@ok,$key): push(@fail,$key);
  }
  # like '_report'
#  my $label="$class special keys";
#   pass("$label. keys=@keys"),return unless @fail;
  pass($label),return unless @fail;
  fail($label);
  diag(scalar(@ok)." keys have correct values: @ok");
  diag(scalar(@fail)." keys have wrong values: @fail");
}

# # used for Child, Grandchild tests.  not for main special_keys test
# sub test_subclass_special_keys (*) {
#   my($class)=@_;
#   my @keys;
#   {
#     no strict 'refs';
#     @keys=uniq(@COMMON_SPECIAL_KEYS,
# 	       # qw(import new can isa DOES VERSION AUTOLOAD DESTROY),
# 	       @Hash::AutoHash::EXPORT_OK,@{$class.'::EXPORT_OK'});  
#   }
#   $autohash=new $class;
#   my(@ok,@fail);
#   for my $key (@keys) {
#     my $value="value_$key";
#     $autohash->$key($value);	# set value
#     my $actual=$autohash->$key;	# get value
#     my $correct=$value;
#     # eq_deeply($actual,$correct)? push(@ok,$key): push(@fail,$key);
#     $actual eq $correct? push(@ok,$key): push(@fail,$key);
#   }
#   # like '_report'
#   my $label="$class special keys";
# #   pass("$label. keys=@keys"),return unless @fail;
#   pass($label),return unless @fail;
#   fail($label);
#   diag(scalar(@ok)." keys have correct values: @ok");
#   diag(scalar(@fail)." keys have wrong values: @fail");
# }
# used by xxx.020.class_methods.t for many (probably all) subclasses 
sub test_class_methods {
  my $class=shift;
  my $import=@_? shift: undef;	# an importable function
  # It's kinda silly to test new and import, since we'd have failed miserably long ago
  #   if these were broken :) Included here for completeness.
  $autohash=new $class;
  ok($autohash,'new');
  is(ref $autohash,$class,"new returned $class object - sanity check");

  if ($import) {
    eval {import $class ($import)};
    ok(!$@,'import: success');
  }
  eval {import $class qw(import);};
  ok($@=~/not exported/,'import: not exported');
  eval {import $class qw(not_defined);};
  ok($@=~/not exported/,'import: not defined');

  my $can=can $class('can');
  is(ref $can,'CODE','can: can');
  my $can=can $class('not_defined');
  ok(!$can,'can: can\'t');

  if ($class ne 'Hash::AutoHash') {
    my $isa=$class->isa($class);
    is($isa,1,"isa: is $class");
  }
  my $isa=$class->isa('Hash::AutoHash');
  is($isa,1,'isa: is Hash::AutoHash');
  my $isa=$class->isa('UNIVERSAL');
  is($isa,1,'isa: is UNIVERSAL');
  my $isa=$class->isa('not_defined');
  ok(!$isa,'isa: isn\'t');

  # Test DOES in perls > 5.10. 
  # Note: $^V returns real string in perls > 5.10, and v-string in earlier perls
  #   regexp below fails in earlier perls. this is okay
  my($perl_main,$perl_minor)=$^V=~/^v(\d+)\.(\d+)/; # perl version
  if ($perl_main==5 && $perl_minor>=10) {
    my $does=DOES $class('Hash::AutoHash');
    is($does,1,'DOES: is Hash::AutoHash');
    my $does=DOES $class('UNIVERSAL');
    is($does,1,'DOES: is UNIVERSAL');
    my $does=DOES $class('not_defined');
    ok(!$does,'DOES: doesn\'t');
  }

  my $version=VERSION $class;
  my $correct=eval "\$$class"."::VERSION";
  is($version,$correct,'VERSION');

  my @imports=eval "\@$class"."::EXPORT_OK";
  import $class (@imports);
  pass('import all functions');
}

1;
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)