File Coverage

blib/lib/Array/IntSpan/Fields.pm

Criterion	Covered	Total	%
statement	91	99	91.9
branch	13	20	65.0
condition	5	11	45.4
subroutine	16	19	84.2
pod	4	10	40.0
total	129	159	81.1

#
# This file is part of Array-IntSpan
#
# This software is Copyright (c) 2014 by Dominique Dumont.
#
# This is free software, licensed under:
#
#   The Artistic License 1.0
#
##########################################################################
#
# Array::IntSpan::Fields - IntSpan array using integer fields as indices
#
# Author: Dominique Dumont
##########################################################################
# Copyright 2003 Dominique Dumont.  All rights reserved.
#
# This file is distributed under the Artistic License. See
# http://www.ActiveState.com/corporate/artistic_license.htm or
# the license that comes with your perl distribution.
#
# For comments, questions, bugs or general interest, feel free to
# contact Dominique Dumont [e-mail]
##########################################################################

# $Author$
# $Date$
# $Name$
# $Revision$

use strict;
use warnings;

package Array::IntSpan::Fields;

our $VERSION = '2.002';

use Array::IntSpan;
use Carp ;

use overload
  # this emulate the usage of Intspan
  '@{}' => sub { return shift->{range} ;} ,
  # fallback on default behavior for all other operators
  fallback => 1 ;

sub new
  {
    my $proto = shift ;
    my $class = ref($proto) || $proto;
    my $format = shift ;

    if (ref $format)
      {
        # in fact the user want a regular IntSpan
        return Array::IntSpan->new($format,@_);
      }

    my @temp = @_ ;
    my $self = {};
    bless $self, $class;
    $self->set_format($format) ;

    foreach my $i (@temp)
      {
        $i->[0] = $self->field_to_int($i->[0]);
        $i->[1] = $self->field_to_int($i->[1]);
      }

    $self->{range}= Array::IntSpan->new(@temp) ;

    return $self;
  }

sub set_format
  {
    my ($self,$format) = @_ ;
    croak "Unexpected format : $format" unless
      $format =~ /^[\d\.]+$/ ;

    $self->{format} = $format ;

    my @array = split /\./, $self->{format} ;
    # store nb of bit and corresponding bit mask
    $self->{fields} = [map { [$_, (1<<$_) -1 ]} @array ] ;
  }

sub int_to_field
  {
    my $self = shift ;
    my @all_int =  @_ ;
    my @result ;

    foreach my $int (@all_int)
      {
        my @res ;
        foreach my $f (reverse @{$self->{fields}})
          {
            unshift @res, ($f->[0] < 32 ? ($int & $f->[1]) : $int ) ;
            $int >>= $f->[0] ;
          }
        push @result, join('.',@res) ;
      }

    return wantarray ? @result : $result[0];
  }

sub field_to_int
  {
    my $self = shift ;

    my @all_field = @_;
    my @result ;

    foreach my $field (@all_field)
      {
        my $f = $self->{fields};
        my @array = split /\./,$field ;

        croak "Expected ",scalar @$f,
          " fields for format $self->{format}, got ",
            scalar @array," in '$field'\n" unless @array == @$f ;

        my $res = 0 ;

        my $i =0 ;

        while ($i <= $#array)
          {
            my $shift = $f->[$i][0] ;
            croak "Field value $array[$i] too great. ",
              "Max is $f->[$i][1] (bit width is $shift)"
                if $shift<32 and $array[$i] >> $shift ;

            $res = ($res << $shift) + $array[$i++] ;
          }
        #print "field_to_int: changed $field to $res for format $self->{format}\n";
        push @result, $res ;
      }

    return wantarray ? @result : $result[0];
  }

sub get_range
  {
    my ($self,$s_field,$e_field) = splice @_,0,3 ;
    my ($s, $e) = $self->field_to_int($s_field,$e_field) ;
    my @newcb = $self->adapt_range_in_cb(@_) ;

    my $got = $self->{range}->get_range($s,$e,@newcb) ;

    my $ret = bless {range => $got }, ref($self) ;
    $ret->set_format($self->{format}) ;
    return $ret ;
  }

sub lookup
  {
    my $self = shift;
    my @keys = $self->field_to_int(@_);
    $self->{range}->lookup(@keys) ;
  }

sub clear
  {
    my $self = shift;
    @{$self->{range}} = () ;
  }

sub consolidate
  {
    my ($self,$s_field,$e_field) = splice @_,0,3 ;
    my ($s, $e) = $self->field_to_int($s_field,$e_field)
      if defined $s_field and defined $e_field;
    my @newcb = $self->adapt_range_in_cb(@_) if @_;

    return $self->{range}->consolidate($s,$e,@newcb) ;
  }


foreach my $method (qw/set_range set_consolidate_range/)
  {
    no strict 'refs' ;
    *$method = sub
      {
        my ($self,$s_field,$e_field,$value) = splice @_,0,4 ;
        my ($s, $e) = $self->field_to_int($s_field,$e_field) ;
        my @newcb = $self->adapt_range_in_cb(@_) ;

        return $self->{range}->$method ($s, $e, $value, @newcb);
      };
  }

sub adapt_range_in_cb
  {
    my $self = shift;

    # the callbacks will be called with ($start, $end,$payload) or
    # ($start,$end)
    my @callbacks = @_ ;

    return map
      {
        my $old_cb = $_; # required for closure to work
        defined $old_cb ?
          sub
            {
              my ($s_int,$e_int,$value) = @_ ;
              my ($s,$e) = $self->int_to_field($s_int,$e_int) ;
              $old_cb->($s,$e,$value);
            }
              : undef ;
      } @callbacks ;
  }

sub get_element
  {
    my ($self,$idx) = @_;
    my $elt = $self->{range}[$idx] || return () ;
    my ($s_int,$e_int,$value) = @$elt ;
    my ($s,$e) = $self->int_to_field($s_int,$e_int) ;

    return ($s,$e, $value) ;
  }

1;

__END__