File Coverage

blib/lib/Hash/Type.pm

Criterion	Covered	Total	%
statement	119	121	98.3
branch	41	54	75.9
condition	4	6	66.6
subroutine	21	21	100.0
pod	6	6	100.0
total	191	208	91.8

package Hash::Type;

use strict;
use warnings;
use Carp;
use Scalar::Util qw/blessed/;
use List::Util   qw/max/;

our $VERSION = "2.00";

our $reserved_keys_field = "\0HTkeys\0"; # special reserved hash entry

#----------------------------------------------------------------------
# constructor
#----------------------------------------------------------------------
sub new { # this is a polymorphic 'new', creating either Hash::Type instances
          # from this class, or tied hashes from one of those instance
  my $obj_or_class = shift;

  if (ref($obj_or_class)) {
    # create a new tied hash from the Hash::Type instance
    my %h;
    tie %h, $obj_or_class , @_;
    return \%h;
  }
  else {
    # create a new Hash::Type instance
    my $self = {$reserved_keys_field => []};
    bless $self, $obj_or_class;
    $self->add(@_);  # add indices for fields given in @_
    return $self;
  }
}



#----------------------------------------------------------------------
# tied hash implementation
#----------------------------------------------------------------------
sub TIEHASH  { bless [@_], __PACKAGE__                                     }
sub STORE    { my $index = $_[0]->[0]{$_[1]} or
		 croak "can't STORE, key '$_[1]' was never added "
                     . "to this Hash::Type";
	       $_[0]->[$index] = $_[2];                                    }

# FETCH : must be an lvalue because it may be used in $h{field} =~ s/.../../;
# And since lvalues cannot use "return" (cf. L), we
# must write it with nested ternary ifs -- not nice to read :-(
sub FETCH : lvalue {
  my $index = $_[0]->[0]{$_[1]};
  $index ? $_[0]->[$index]
         : $_[1] eq 'Hash::Type' ? $_[0]->[0]
                                 : undef;
}

sub FIRSTKEY { $_[0]->[0]{$reserved_keys_field}[0];                        }
sub NEXTKEY  { my ($h, $last_key) = @_;
               my $index_last = $h->[0]{$last_key};        # index on base 1..
               $h->[0]{$reserved_keys_field}[$index_last]; # .. used on base 0!
             }
sub EXISTS   { exists $_[0]->[0]{$_[1]}                                    }
sub DELETE   { croak "DELETE is forbidden on hash tied to " . __PACKAGE__  }
sub CLEAR    { delete @{$_[0]}[1 .. $#{$_[0]}]                             }

#----------------------------------------------------------------------
# Object-oriented methods for dealing with names and values
#----------------------------------------------------------------------
sub add {
  my $self = shift;
  my $max  = @{$self->{$reserved_keys_field}};
  my $ix   = $max;
 NAME:
  foreach my $name (@_) {
    next NAME if exists $self->{$name};
    $self->{$name} = ++$ix;
    push @{$self->{$reserved_keys_field}}, $name;
  }

  # return the number of added names
  return $ix - $max;
}

sub names {
  my ($self) = @_;
  return @{$self->{$reserved_keys_field}};
}

sub values {
  my ($self, $tied_hash) = @_;
  my $tied = tied %$tied_hash;
  return @{$tied}[1 .. @{$self->{$reserved_keys_field}}];
}

sub each {
  my ($self, $tied_hash) = @_;
  my $tied = tied %$tied_hash;
  my $index = 0;
  my $max   = @{$self->{$reserved_keys_field}};
  return sub {
    $index += 1;
    return $index <= $max ? ($self->{$reserved_keys_field}[$index-1],
                             $tied->[$index])
                          : ();
    };
}

#----------------------------------------------------------------------
# compiling comparison functions
#----------------------------------------------------------------------
sub cmp {
  my $self = shift;

  @_ or croak "cmp : no cmp args";

  if (@_ == 1) {
    # parse first syntax, where all comparison fiels are in one string
    my @fields = split /,/, shift @_;
    foreach (@fields) {
      m[^\s*(\S.*?)\s*(?::([^:]+))?$] or croak "bad cmp op : $_";
      push @_, $1, $2; # feed back to @_ as arguments to second syntax
    }
  }

  # parse second syntax (pairs of field_name => comparison_instruction)

  # $a and $b are different in each package, so we must refer to the caller's
  my $caller = caller;
  my ($a, $b) = ("\$${caller}::a", "\$${caller}::b");

  my @cmp;         # holds code for each comparison to perform
  my @caller_sub;  # references to comparison subs given by caller
                   # (must copy them from @_ into a lexical variable
                   #  in order to build a proper closure)
  my $regex;       # used only for date comparisons, see below

  for (my $i = 0; $i < @_; $i += 2) {
    my $ix = $self->{$_[$i]} or croak "can't do cmp on absent field : $_[$i]";

    if (ref $_[$i+1] eq 'CODE') { # ref. to cmp function supplied by caller
      push @caller_sub, $_[$i+1];
      push @cmp, "do {local ($a, $b) = (tied(%$a)->[$ix], tied(%$b)->[$ix]);".
	             "&{\$caller_sub[$#caller_sub]}}";
    }
    else { # builtin comparison operator
      my ($sign, $op) = ("", "cmp");
      my $str;
      if (defined $_[$i+1]) {
	($sign, $op) = ($_[$i+1] =~ /^\s*([-+]?)\s*(.+)/);
      }

      for ($op) {
	/^(alpha|cmp)\s*$/   and do {$str = "%s cmp %s"; last};
	/^(num|<=>)\s*$/     and do {$str = "%s <=> %s"; last};
	/^d(\W+)m(\W+)y\s*$/ and do {$regex=qr{(\d+)\Q$1\E(\d+)\Q$2\E(\d+)};
				     $str = "_date_cmp(\$regex, 0, 1, 2, %s, %s)";
				     last};
	/^m(\W+)d(\W+)y\s*$/ and do {$regex=qr{(\d+)\Q$1\E(\d+)\Q$2\E(\d+)};
				     $str = "_date_cmp(\$regex, 1, 0, 2, %s, %s)";
				     last};
	/^y(\W+)m(\W+)d\s*$/ and do {$regex=qr{(\d+)\Q$1\E(\d+)\Q$2\E(\d+)};
				     $str = "_date_cmp(\$regex, 2, 1, 0, %s, %s)";
				     last};
	croak "bad operator for Hash::Type::cmp : $_[$i+1]";
      }
      $str = sprintf("$sign($str)", "tied(%$a)->[$ix]", "tied(%$b)->[$ix]");
      push @cmp, $str;
    }
  }

  local $@;
  my $sub = eval "sub {" . join(" || ", @cmp) . "}"
    or croak $@;
  return $sub;
}


sub _date_cmp {
  my ($regex, $d, $m, $y, $date1, $date2) = @_;

  return  0 if not $date1 and not $date2;
  return  1 if not $date1;  # null date is treated as bigger than any other
  return -1 if not $date2;

  for my $date ($date1, $date2) {
    $date =~ s[<.*?>][]g;   # remove any markup
    $date =~ tr/{}[]()//d;  # remove any {}[]() chars
  };

  my @d1 = ($date1 =~ $regex) or croak "invalid date '$date1' for regex $regex";
  my @d2 = ($date2 =~ $regex) or croak "invalid date '$date2' for regex $regex";

  $d1[$y] += ($d1[$y] < 33) ? 2000 : 1900 if $d1[$y] < 100;
  $d2[$y] += ($d2[$y] < 33) ? 2000 : 1900 if $d2[$y] < 100;

  return ($d1[$y]<=>$d2[$y]) || ($d1[$m]<=>$d2[$m]) || ($d1[$d]<=>$d2[$d]);
}


1;

__END__