File Coverage

blib/lib/XML/ExtOn/TieAttrs.pm

Criterion	Covered	Total	%
statement	116	116	100.0
branch	18	22	81.8
condition	11	13	84.6
subroutine	20	20	100.0
pod	1	5	20.0
total	166	176	94.3

package XML::ExtOn::TieAttrs;

=head1 NAME

 XML::ExtOn::TieAttrs

=head1 SYNOPSIS

   use XML::ExtOn::TieAttrs;
   tie %hasha, 'XML::ExtOn::TieAttrs', \%hash1, default=>;

=head1 DESCRIPTION



=cut

use strict;
use warnings;
use strict;
use Carp;
use Data::Dumper;
require Tie::Hash;
@XML::ExtOn::TieAttrs::ISA     = qw(Tie::StdHash);
$XML::ExtOn::TieAttrs::VERSION = '0.01';

sub attr_from_sax2 {
    my $sax_attr = shift || {};
    my %res = ();
    while ( my ( $key, $value ) = each %$sax_attr ) {
        my ( $prefix, $name, $ns_uri ) =
          @{$value}{qw/ Prefix LocalName NamespaceURI/};
        $prefix = '' unless defined $prefix;
        $ns_uri = '' unless defined $ns_uri;
        $res{qq/{$ns_uri}$name/} = {%$value};
    }
    return \%res;
}

my $attrs = {
    __temp_array => [],
    _orig_hash   => {},
    _default     => undef,
    _template    => {},

};

### install get/set accessors for this object.
for my $key ( keys %$attrs ) {
    no strict 'refs';
    *{ __PACKAGE__ . "::$key" } = sub {
        my $self = shift;
        $self->{$key} = $_[0] if @_;
        return $self->{$key};
      }
}

=head2 new

   tie %hasha, 'XML::ExtOn::TieAttrs', \%hash1, default=>;

=cut

sub new {
    my $class = shift;
    $class = ref $class if ref $class;
    my $orig_hash = shift || {};
    my %props     = @_;
    my $self      = bless( \%props, $class );
    $self->_orig_hash($orig_hash);

    #set filters by
    my $field_name = $props{by}    || 'Name';
    my $value      = $props{value} || '';
    $self->_default( [ $field_name, $value ] );

    #setup template
    $self->_template( $props{template} || {} );
    return $self;
}

sub get_by_filter {
    my $self        = shift;
    my $flocal_name = shift;
    my $ahash       = $self->_orig_hash;
    my %res         = ();
    my ( $field_name, $value ) = @{ $self->_default() };
    my $i = -1;
    foreach my $val (@$ahash) {
        $i++;
        next unless defined( $val->{$field_name} );
        next unless $val->{$field_name} eq $value;
        next if defined $flocal_name && $val->{LocalName} ne $flocal_name;
        $res{$i} = $val;
    }
    return \%res;
}

sub create_attr {
    my $self     = shift;
    my $key      = shift;
    my %template =
      ( %{ $self->_template() }, @{ $self->_default() }, LocalName => $key );
    my $prefix     = $template{Prefix};
    my $local_name = $template{LocalName};
    $template{Name} = $prefix ? "$prefix:$local_name" : $local_name;
    return attr_from_sax2( { 1 => \%template } );
}

sub DELETE {
    my ( $self, $key )   = @_;
    my ( $fkey, $fhash ) = %{ $self->get_by_filter($key) };
    return unless $fhash;
    my $val   = $fhash->{Value};
    my $ahash = $self->_orig_hash;
    delete $ahash->[$fkey];
    @{$ahash} = grep { defined } @{$ahash};
    return $val;
}

sub STORE {
    my ( $self, $key, $val ) = @_;
#    warn " store: $key, $val ";
    my ( $pkey, $fhash ) = %{ $self->get_by_filter($key) };
    if ($fhash) {
        $fhash->{Value} = $val;
    }
    else {
        my $new_add_to_hash = $self->create_attr($key);
        my $ahash           = $self->_orig_hash;
        while ( my ( $pkey, $pval ) = each %$new_add_to_hash ) {
        push @{$ahash}, $pval;
        }
        $self->STORE( $key, $val );
    }
    return $val;
}

sub FETCH {
    my ( $self, $key ) = @_;
    my $res;
    my ( $pkey, $pval ) = %{ $self->get_by_filter($key) };
    $res = $pval->{Value} if $pval;
    return $res;
}

sub GetKeys {
    my $self = shift;
    return [ map { $_->{LocalName} } values %{ $self->get_by_filter } ];
}

sub TIEHASH {    #shift;
    return &new(@_);
}

sub FIRSTKEY {
    my ($self) = @_;
    $self->__temp_array( [ sort { $a cmp $b } @{ $self->GetKeys() } ] );
    shift( @{ $self->__temp_array() } );
}

sub NEXTKEY {
    my ( $self, $key ) = @_;
    shift( @{ $self->__temp_array() } );
}

sub EXISTS {
    my ( $self, $key )  = @_;
    my ( $pkey, $pval ) = %{ $self->get_by_filter($key) };
    return defined $pval;
}

sub CLEAR {
    my $self = shift;
    foreach my $key ( @{ $self->GetKeys } ) {
        $self->DELETE($key);
    }
}

1;
__END__