view release on metacpan or  search on metacpan

lib/ASNMTAP/PseudoHash.pm  view on Meta::CPAN

# = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =

use constant NO_SUCH_FIELD => 'No such pseudohash field "%s"';
use constant NO_SUCH_INDEX => 'Bad index while coercing array into hash';

# SET ASNMTAP::PseudoHash VARIABLES - - - - - - - - - - - - - - - - - - -

our $FixedKeys = 1;

# Constructor & initialisation  - - - - - - - - - - - - - - - - - - - - -

unless ( $] < 5.010000 ) {
  eval {
    use overload (
      '%{}'  => sub { $$Obj = $_[0]; return $Proxy },
      '""'   => sub { overload::AddrRef($_[0]) },
      '0+'   => sub { no warnings;
                      my $str = overload::AddrRef($_[0]);
                      hex(substr($str, index($str, '(') + 1, -1));
                    },
      'bool' => sub { 1 },
      'cmp'  => sub { "$_[0]" cmp "$_[1]" },
      '<=>'  => sub { "$_[0]" cmp "$_[1]" }, # for completeness' sake
      'fallback' => 1,
    );

    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

    INIT {
      no strict 'refs';

      my $class = __PACKAGE__;
      tie %{$Proxy}, $class;
  
      *{'fields::phash'} = sub { $class->new(@_); } unless defined $_[0];
    }

    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

    sub FETCH {
      my ($self, $key) = @_;

      $self = $$$self;
      my $index = ( ( defined $self->[0]{$key} and $self->[0]{$key} >= 1 ) ? $self->[0]{$key} : ( defined $self->[0]{$key} ? _cluck(NO_SUCH_INDEX) : ( $FixedKeys ? _cluck(NO_SUCH_FIELD, $key) : @$self ) ) );
      return $self->[ $index ];
    }

    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

    sub STORE {
      my ($self, $key, $value) = @_;

      $self = $$$self;
      my $index = ( ( defined $self->[0]{$key} and $self->[0]{$key} >= 1 ) ? $self->[0]{$key} : ( defined $self->[0]{$key} ? _cluck(NO_SUCH_INDEX) : ( $FixedKeys ? _cluck(NO_SUCH_FIELD, $key) : @$self ) ) );
      return $self->[ $index ] = $value;
    }

    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

    sub TIEHASH {
      bless \$Obj => shift;
    }

    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

    sub FIRSTKEY {
      scalar keys %{$${$_[0]}->[0]};
      each %{$${$_[0]}->[0]};
    }

    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

    sub NEXTKEY {
      each %{$${$_[0]}->[0]};
    }

    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

    sub EXISTS {
      exists $${$_[0]}->[0]{$_[1]};
    }

    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

    sub DELETE {
      delete $${$_[0]}->[0]{$_[1]};
    }

    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

    sub CLEAR {
      @{$${$_[0]}} = ();
    }

    # Utility methods - - - - - - - - - - - - - - - - - - - - - - - - - -

    sub _cluck {
      require Carp;
      Carp::cluck(sprintf(shift, @_));
    }

    # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  }
}

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

1;

# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

__END__

=head1 NAME

ASNMTAP::PseudoHash is a Perl module that emulates Pseudo-Hash behaviour via overload used by ASNMTAP and ASNMTAP-based applications and plugins.

=head1 SEE ALSO

ASNMTAP::Asnmtap::Applications, ASNMTAP::Asnmtap::Applications::CGI, ASNMTAP::Asnmtap::Applications::Collector, ASNMTAP::Asnmtap::Applications::Display