File Coverage

blib/lib/List/Categorize.pm

Criterion	Covered	Total	%
statement	31	31	100.0
branch	7	8	87.5
condition	4	4	100.0
subroutine	6	6	100.0
pod	1	1	100.0
total	49	50	98.0

package List::Categorize;
#
# ABSTRACT: Categorize list items into a tree of named sublists.
#
# See documentation after __END__ below.
#

use strict;
use warnings;
use 5.006;

## Module Interface

use base 'Exporter';
use Carp qw/croak/;

our $VERSION = '0.04';
our @EXPORT = qw();
our @EXPORT_OK = qw(
    categorize
);
our %EXPORT_TAGS = (
    all => \@EXPORT_OK
);


## Subroutines

sub categorize (&@)
#
# Usage:    %tree = categorize {BLOCK} @LIST
# Returns:  a tree of lists
#
# Creates a tree by running a subroutine for each element in a
# list. That subroutine should return a list of hash keys (the
# "categories") for the current element, each key in the list
# corresponding to the next depth level within the tree. If the
# subroutine returns undef for a list element, that element is not
# placed in the resulting tree.
#
# The resulting tree contains a key for each first-level category, and
# each key refers to a sub-tree for the next-level category,
# etc. until reaching a leaf, which contains a list of the elements
# that correspond to that sequence of categories. If there is only one
# level of categories, the structure is just a hashref of lists of
# elements.
#
{
    # Parameters
    #
    my $coderef = shift;

    # @_ is used directly, in the loop below.

    # This is the tree that will be returned to the caller.
    #
    my %tree = ();

    # Iterate over the provided list, categorizing
    # each element.
    #
    for my $element (@_)
    {
        # Localize $_, then copy the current element into it, so the
        # categorizer subroutine can refer to $_ (in the same way as
        # map, grep, and sort do).
        #
        # Copying the element keeps it from acting as an alias into the
        # @_ list, so the categorizer can modify $_ without damaging the
        # source list.
        #
        local $_ = $element;

        # Execute the categorizer subroutine to determine the categories
        # for this element.
        #
        my @categories = $coderef->();

        # If categories were returned, use them as keys in %tree,
        # and add the current element to the list referenced by
        # those keys.
        #
        # If the categorizer didn't return a value (or returned undef),
        # then leave this element out of %tree entirely.
        #

        my $node = \%tree;
      CATEGORY:
        while (@categories) {
            my $categ = shift @categories;

            # if an undef is encountered, this element will be ignored
            defined $categ or last CATEGORY;

            if (@categories) {
                # other keys remaining, so create or retrieve an intermediate node
                $node = $node->{$categ} ||= {};
                ref $node ne 'ARRAY'
                  or croak "inconsistent use of category '$categ'";
            }
            else {
                # add the element to a leaf
                my $ref = ref $node->{$categ} || '';
                $ref ne 'HASH'
                  or croak "inconsistent use of category '$categ'";
                push @{$node->{$categ}}, $_;
            }
        }
    }

    return %tree;
}


1;

__END__