Gecko [ edgpens.lpkmn.gov.my ]

Name	Size	Permission
.mad-root	0 B	-rw-rw-rw-
Array.pm	7.98 KB	-rw-rw-rw-
Bag.pm	5.41 KB	-rw-rw-rw-
Base.pm	5.6 KB	-rw-rw-rw-
Bool.pm	1.82 KB	-rw-rw-rw-
Custom.pm	3.11 KB	-rw-rw-rw-
DeepRef.pm	1.94 KB	-rw-rw-rw-
Delta.pm	13.15 KB	-rw-rw-rw-
Event.pm	1.32 KB	-rw-rw-rw-
EventMeta.pm	1.62 KB	-rw-rw-rw-
Float.pm	3.98 KB	-rw-rw-rw-
Hash.pm	5.75 KB	-rw-rw-rw-
Meta.pm	2.85 KB	-rw-rw-rw-
Negatable.pm	2.2 KB	-rw-rw-rw-
Number.pm	2.56 KB	-rw-rw-rw-
Object.pm	6.08 KB	-rw-rw-rw-
OrderedSubset.pm	3.39 KB	-rw-rw-rw-
Pattern.pm	1.67 KB	-rw-rw-rw-
Ref.pm	1.92 KB	-rw-rw-rw-
Regex.pm	1.52 KB	-rw-rw-rw-
Scalar.pm	2 KB	-rw-rw-rw-
Set.pm	2.91 KB	-rw-rw-rw-
String.pm	1.79 KB	-rw-rw-rw-
Undef.pm	1.27 KB	-rw-rw-rw-
Wildcard.pm	1.13 KB	-rw-rw-rw-

Code Editor : Bag.pm

package Test2::Compare::Bag;
use strict;
use warnings;

use base 'Test2::Compare::Base';

our $VERSION = '0.000130';

use Test2::Util::HashBase qw/ending meta items for_each/;

use Carp qw/croak confess/;
use Scalar::Util qw/reftype looks_like_number/;

sub init {
    my $self = shift;

$self->{+ITEMS}    ||= [];
    $self->{+FOR_EACH} ||= [];

$self->SUPER::init();
}

sub name { '<BAG>' }

sub meta_class  { 'Test2::Compare::Meta' }

sub verify {
    my $self = shift;
    my %params = @_;

return 0 unless $params{exists};
    my $got = $params{got} || return 0;
    return 0 unless ref($got);
    return 0 unless reftype($got) eq 'ARRAY';
    return 1;
}

sub add_prop {
    my $self = shift;
    $self->{+META} = $self->meta_class->new unless defined $self->{+META};
    $self->{+META}->add_prop(@_);
}

sub add_item {
    my $self = shift;
    my $check = pop;
    my ($idx) = @_;

push @{$self->{+ITEMS}}, $check;
}

sub add_for_each {
    my $self = shift;
    push @{$self->{+FOR_EACH}} => @_;
}

sub deltas {
    my $self = shift;
    my %params = @_;
    my ($got, $convert, $seen) = @params{qw/got convert seen/};

my @deltas;
    my $state = 0;
    my @items = @{$self->{+ITEMS}};
    my @for_each = @{$self->{+FOR_EACH}};

# Make a copy that we can munge as needed.
    my @list = @$got;
    my %unmatched = map { $_ => $list[$_] } 0..$#list;

my $meta     = $self->{+META};
    push @deltas => $meta->deltas(%params) if defined $meta;

while (@items) {
        my $item = shift @items;

my $check = $convert->($item);

my $match = 0;
        for my $idx (0..$#list) {
            next unless exists $unmatched{$idx};
            my $val = $list[$idx];
            my $deltas = $check->run(
                id      => [ARRAY => $idx],
                convert => $convert,
                seen    => $seen,
                exists  => 1,
                got     => $val,
            );

unless ($deltas) {
                $match++;
                delete $unmatched{$idx};
                last;
            }
        }
        unless ($match) {
            push @deltas => $self->delta_class->new(
                dne      => 'got',
                verified => undef,
                id       => [ARRAY => '*'],
                got      => undef,
                check    => $check,
            );
        }
    }

if (@for_each) {
        my @checks = map { $convert->($_) } @for_each;

for my $idx (0..$#list) {
            # All items are matched if we have conditions for all items
            delete $unmatched{$idx};

my $val = $list[$idx];

for my $check (@checks) {
                push @deltas => $check->run(
                    id      => [ARRAY => $idx],
                    convert => $convert,
                    seen    => $seen,
                    exists  => 1,
                    got     => $val,
                );
            }
        }
    }

# if elements are left over, and ending is true, we have a problem!
    if($self->{+ENDING} && keys %unmatched) {
        for my $idx (sort keys %unmatched) {
            my $elem = $list[$idx];
            push @deltas => $self->delta_class->new(
                dne      => 'check',
                verified => undef,
                id       => [ARRAY => $idx],
                got      => $elem,
                check    => undef,

$self->{+ENDING} eq 'implicit' ? (note => 'implicit end') : (),
            );
        }
    }

return @deltas;
}

__END__

=pod

=encoding UTF-8

=head1 NAME

Test2::Compare::Bag - Internal representation of a bag comparison.

=head1 DESCRIPTION

This module is an internal representation of a bag for comparison purposes.

=head1 METHODS

=over 4

=item $bool = $arr->ending

=item $arr->set_ending($bool)

Set this to true if you would like to fail when the array being validated has
more items than the check. That is, if you check for 4 items but the array has
5 values, it will fail and list that unmatched item in the array as
unexpected. If set to false then it is assumed you do not care about extra
items.

=item $arrayref = $arr->items()

Returns the arrayref of values to be checked in the array.

=item $arr->set_items($arrayref)

Accepts an arrayref.

B<Note:> that there is no validation when using C<set_items>, it is better to
use the C<add_item> interface.

=item $name = $arr->name()

Always returns the string C<< "<BAG>" >>.

=item $bool = $arr->verify(got => $got, exists => $bool)

Check if C<$got> is an array reference or not.

=item $arr->add_item($item)

Push an item onto the list of values to be checked.

=item @deltas = $arr->deltas(got => $got, convert => \&convert, seen => \%seen)

Find the differences between the expected bag values and those in the C<$got>
arrayref.

=back

=head1 SOURCE

The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=item Gianni Ceccarelli E<lt>dakkar@thenautilus.netE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=item Gianni Ceccarelli E<lt>dakkar@thenautilus.netE<gt>

=back

=head1 COPYRIGHT

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See F<http://dev.perl.org/licenses/>

=cut

${this.title}

Code Editor : Bag.pm