File Coverage

blib/lib/List/Object.pm

Criterion	Covered	Total	%
statement	173	188	92.0
branch	44	56	78.5
condition	9	12	75.0
subroutine	32	35	91.4
pod	24	27	88.8
total	282	318	88.6

package List::Object;
use 5.008003;
use strict;
use warnings;

# $Id$
# $Name$

use Carp;
#use Data::Dumper;

require Exporter;

our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use List::Object ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
our %EXPORT_TAGS = ( 'all' => [ qw(

) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(

);

our $VERSION = '0.01';

my %types = (
    ''  => '',
    '$' => 'SCALAR',
    '@' => 'ARRAY',
    '%' => 'HASH',
);

my %rev_types = map { ($types{$_}, $_) } (keys %types);

#print "HELLO!!!!\n";

###################################################################
sub new
{   #
    my $class = CORE::shift;
    my @args  = @_;
    my $this  = {};

    bless $this, $class;
    $this->_init(@args);
    return $this;
}

###################################################################
sub _init
{   #
    my $this = CORE::shift;
    my %args = @_;
    $this->{_type} = defined $args{type} ? $args{type} : '%';
    $this->{_allow_undef} = defined $args{allow_undef} ? $args{allow_undef} : '0';

    if (defined $args{list})
    {   #
       $this->_valid_type(@{$args{list}});
       $this->{_array} = $args{list};
    }
    else
    {
        $this->{_array} = [];
    }
    $this->rewind();
}

###################################################################
sub _valid_type
{   #
    return 1 if defined  $List::Object::Loose  && $List::Object::Loose == 1;
    # done a second time to suppress the
    # 'used only once: possible typo' perl warning

    my $this = shift;
    my @check_list = @_;

    my $valid = 1;
    my $undef = 0;
    for my $c (@check_list)
    {
        if (! $this->{_allow_undef} && ! defined $c)
        {   #
           $undef = 1;
           last;
        }

        my $ref_type = ref $c;

        if (defined $c)
        {
            # are we and object (not a HASH, ARRAY, or SCALAR reftype?);
            if (exists $rev_types{$ref_type})
            {
                unless (ref $c eq $types{$this->{_type}})
                {
                    $valid = 0;
                    last;
                }

            }
            else
            {   #
                unless ($c->isa($this->{_type}))
                {   #
                    $valid = 0;
                    last;
                }
            }
        }

    }

    croak(__PACKAGE__ . " undef items not allows in list. ") if $undef && ! $this->{_allow_undef};
    croak(__PACKAGE__ . " item is not valid ref type of '@{[$this->{_type}]}'") unless $valid;
    return 1;
}

# decrement the iterator location by one
# if the iterator is non-zero, and the
# list has been shortened below where
# the index is at;
###################################################################
sub _fix_index
{   #
    croak "method not implemented";
    my $this = shift;
    my $changed_index =  shift;
}

###################################################################
sub has_next
{   #
    return $_[0]->{_index} < @{$_[0]->{_array}} - 1;
}

###################################################################
sub next
{   #
    my $this = shift;
    croak "index out of range" if $this->{_index} >= @{$this->{_array}} - 1;
    $this->_valid_type($this->{_array}->[$this->{_index}]);
    return $this->{_array}->[++$this->{_index}];
}

###################################################################
sub rewind
{   #
    $_[0]->{_index} = 0;
    return 1;
}

###################################################################
sub shift
{   #
    $_[0]->_valid_type($_[0]->{_array}->[$_[0]->{_index}]);
    $_[0]->rewind();

    shift @{$_[0]->{_array}};
}

###################################################################
sub push
{   #
    my $this = CORE::shift;
    my @pushed = @_;
    $this->_valid_type(@pushed);
    $this->rewind();
    CORE::push @{$this->{_array}}, @pushed;
}

###################################################################
sub pop
{   #
    my $this = CORE::shift;
    $this->rewind();
    $this->_valid_type($this->{_array}->[$this->{_index}]);
    CORE::pop @{$this->{_array}};
}


###################################################################
sub unshift
{   #
    my $this = CORE::shift;
    my @unshifted = @_;
    $this->rewind();
    $this->_valid_type(@unshifted);
    CORE::unshift @{$this->{_array}}, @unshifted;
}

###################################################################
sub splice
{   #
    my $this = CORE::shift;

    $this->rewind();
    my $offset = 0;
    my $length = 0;
    my @list = ();

    $offset = CORE::shift if @_;
    $length = CORE::shift if @_;
    @list = @_ if @_;
    $this->_valid_type(@list);
    splice @{$this->{_array}}, $offset, $length, @list;
}

###################################################################
sub join
{   #
    my $this = CORE::shift;
    my $join = '';

    if ($this->{_type} eq '')
    {   #
        $join = CORE::shift if @_;
        return CORE::join $join, @{$this->{_array}};
    }
    elsif($this->{_type} eq '$')
    {   #
        $join = CORE::shift if @_;
        return CORE::join $join, map { $$_} @{$this->{_array}};
    }
    else
    {   #
        carp("Can't join non-scalar ref types, returning empty string.");
        return '';

    }
}

###################################################################
sub count
{   #
    my $this = CORE::shift;
    return scalar @{$this->{_array}};
}

###################################################################
sub clear
{   #

    $_[0]->{_array} = [];
    return 1;
}

###################################################################
sub get
{   #
    my $this    = CORE::shift;
    my $index   = CORE::shift;
    croak "index out of range" if $index >= $this->count();
    $this->_valid_type($this->{_array}->[$index]);
    return $this->{_array}->[$index];
}

###################################################################
sub set
{   #
    my $this    = CORE::shift;
    my $index   = CORE::shift;
    my $item    = CORE::shift;
    croak "index out of range" if $index >= $this->count();
    $this->_valid_type($item);
    $this->{_array}->[$index] = $item;
}

###################################################################
sub add
{   #
    my $this = CORE::shift;
    $this->_valid_type(@_);
    return $this->push(@_);
}


###################################################################
sub remove
{   #
    my $this = CORE::shift;
    my $index = CORE::shift;
    my $rm_item = $this->splice($index, 1);
    $this->_valid_type($rm_item);
    $this->rewind();
    return $rm_item;
}


###################################################################
sub first
{   #
    my $this = CORE::shift;
    $this->_valid_type($this->{_array}->[0]);
    return $this->{_array}->[0];
}

###################################################################
sub last
{   #
    my $this = CORE::shift;
    $this->_valid_type($this->{_array}->[$this->count() - 1]);
    return $this->{_array}->[$this->count() - 1];
}

###################################################################
sub peek
{   #
    my $this = CORE::shift;

    $this->_valid_type($this->{_array}->[$this->{_index}]);
    return $this->{_array}->[$this->{_index}];
}

###################################################################
sub type
{   #
    return $_[0]->{_type};
}

###################################################################
sub allow_undef
{   #
    return $_[0]->{_allow_undef};

}

###################################################################
sub array
{   #
    my $this = CORE::shift;
    return @{$this->{_array}};
}

###################################################################
sub reverse
{   #
    my $this = CORE::shift;
    $this->rewind();
    $this->{_array} =  [reverse @{$this->{_array}}] ;
}

###################################################################
sub sort
{   #
    my $this = CORE::shift;
    if ($this->{_type} eq '')
    {   #
        $this->rewind();
        $this->{_array} = [sort @{$this->{_array}}];
    }
    elsif($this->{_type} eq '$')
    {   #
       # look how nested this is!!!
       $this->{_array} = [map {\$_} (sort (map {$$_} @{$this->{_array}})) ]
    }
    else
    {
        carp "Can't sort non-scalar ref types. Nothing done.";
    }
}

###################################################################
sub sort_by
{   #
    my $this         = CORE::shift;
    my $sort_by      = CORE::shift;

    $this->rewind();

    my $type = $this->{_type};

    my $sort_sub = sub {    #
        my $av = CORE::shift;
        my $bv = CORE::shift;

        if ($av =~ /^[\d\.]+$/ && $bv =~ /^[\d\.]+$/)
        {
            return $av <=> $bv;
        }
        else
        {   #
            return $av cmp $bv;
        }
    };

    if (! defined $types{$type})
    {
        # sort list of objects method
        $this->_error() unless $type->can($sort_by);
        $this->{_array} = [ sort { &$sort_sub($a->$sort_by(), $b->$sort_by()) } @{$this->{_array}}];
    }
    elsif ($type eq '%')
    {
        $this->{_array} = [ sort { &$sort_sub($a->{$sort_by}, $b->{$sort_by}) } @{$this->{_array}}];
    }
    elsif ($type eq '@')
    {
        $this->{_array} = [ sort { &$sort_sub($a->[$sort_by], $b->[$sort_by]) } @{$this->{_array}}];
    }
    else
    {   #
        # for lists of scalars and scalar refs, fall back to sort;
        carp "Can't sory_by() on scalars and scalar refs, Falling back to sort()";
        $this->sort();
    }
}

###################################################################
sub unique_by
{   #
    croak "method not implemented";
    my $this = CORE::shift;
    my $type = $this->{_type};
    my $method = CORE::shift;

}

###################################################################
sub filter_by
{   #
    croak "method not implemented";
    my $this = CORE::shift;
}

1;
__END__