File Coverage

blib/lib/Sub/Chain/Group.pm

Criterion	Covered	Total	%
statement	142	144	98.6
branch	53	60	88.3
condition	28	31	90.3
subroutine	21	21	100.0
pod	10	10	100.0
total	254	266	95.4

# vim: set ts=2 sts=2 sw=2 expandtab smarttab:
#
# This file is part of Sub-Chain-Group
#
# This software is copyright (c) 2010 by Randy Stauner.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
use strict;
use warnings;

package Sub::Chain::Group;
{
  $Sub::Chain::Group::VERSION = '0.013';
}
# git description: v0.012-8-ge16d2b1

BEGIN {
  $Sub::Chain::Group::AUTHORITY = 'cpan:RWSTAUNER';
}
# ABSTRACT: Group chains of subs by field name

use Carp qw(croak carp);

# this seems a little dirty, but it's not appropriate to put it in Sub::Chain
use Sub::Chain;
{
  no warnings 'once';
push(@Sub::Chain::CARP_NOT, __PACKAGE__);
}

use Set::DynamicGroups ();
use Module::Load ();


sub new {
  my $class = shift;
  my %opts = ref $_[0] ? %{$_[0]} : @_;

  my $self = {
    chain_class => delete $opts{chain_class} || 'Sub::Chain',
    chain_args  => delete $opts{chain_args}  || {},
    fields => {},
    groups => Set::DynamicGroups->new(),
    queue  => [],
    hooks  => {},
    hook_as_hash  => delete $opts{hook_as_hash},
    warn_no_field => 'single',
  };

  foreach my $enum (
    [warn_no_field => qw(never single always)],
  ){
    my ($key, @vals) = @$enum;
    if( my $val = delete $opts{ $key } ){
      croak qq['$key' cannot be set to '$val'; must be one of: ] . join(', ', @vals)
        unless grep { $val eq $_ } @vals;
      $self->{ $key } = $val;
    }
  }

  Module::Load::load($self->{chain_class});

  # TODO: warn about remaining unused options?

  bless $self, $class;
}


sub append {
  my ($self, $sub) = (shift, shift);
  my %opts = ref $_[0] ? %{$_[0]} : @_;

  CORE::push(@{ $self->{queue} ||= [] },
    [$sub, $self->_normalize_spec(\%opts)]);

  return $self;
}


sub call {
  my ($self) = shift;

  $self->dequeue
    if $self->{queue};

  my $out;
  my $opts = {multi => 1};
  my $ref = ref $_[0];

  my ($before, $after) = @{ $self->{hooks} }{qw( before after )};

  if( $ref eq 'HASH' ){
    my $in = { %{ $_[0] } };
    $in = $before->call($in)  if $before;
    $out = {};
    while( my ($key, $value) = each %$in ){
      $out->{$key} = $self->_call_one($key, $value, $opts);
    }
    $out = $after->call($out) if $after;
  }
  elsif( $ref eq 'ARRAY' ){
    my $fields = [ @{ $_[0] } ];
    my $values = [ @{ $_[1] } ];
    $values = $self->_call_hook($before, $values, $fields) if $before;
    $out = [];
    foreach my $i ( 0 .. @$fields - 1 ){
      CORE::push(@$out,
        $self->_call_one($fields->[$i], $values->[$i], $opts));
    }
    $out = $self->_call_hook($after, $out, $fields) if $after;
  }
  else {
    my ($key, $val) = @_;
    $val = $self->_call_hook($before, $val, $key) if $before;
    $out = $self->_call_one($key, $val);
    $out = $self->_call_hook($after,  $out, $key) if $after;
  }

  return $out;
}

sub _call_hook {
  my ($self, $chain, $values, $fields) = @_;

  if( $self->{hook_as_hash} ){
    if( ref($fields) eq 'ARRAY' ){
      my $hash = {};
      @$hash{ @$fields } = @$values;
      $hash = $chain->call($hash);
      $values = [ @$hash{ @$fields } ];
    }
    else {
      my $hash = { $fields => $values };
      $hash = $chain->call($hash);
      $values = $hash->{ $fields };
    }
  }
  else {
    $values = $chain->call($values, $fields);
  }

  return $values;
}

sub _call_one {
  my ($self, $field, $value, $opts) = @_;
  return $value
    unless my $chain = $self->chain($field, $opts);
  return $chain->call($value);
}


sub chain {
  my ($self, $name, $opts) = @_;
  $opts ||= {};

  $self->dequeue
    if $self->{queue};

  if( my $chain = $self->{fields}{$name} ){
    return $chain;
  }

  carp("No subs chained for '$name'")
    if $self->{warn_no_field} eq 'always'
      || ($self->{warn_no_field} eq 'single' && !$opts->{multi});

  return;
}


sub dequeue {
  my ($self) = @_;

  return unless my $queue = $self->{queue};
  my $dequeued = ($self->{dequeued} ||= []);

  # shift items off the queue until they've all been processed
  while( my $item = shift @$queue ){
    # save this item in case we need to reprocess the whole queue later
    CORE::push(@$dequeued, $item);

    my ($sub, $opts) = @$item;
    my @chain_args = ($sub, @$opts{qw(args opts)});

    foreach my $hook ( @{ $opts->{hooks} || [] } ){
      ($self->{hooks}->{ $hook } ||= $self->new_sub_chain())
        ->append(@chain_args);
    }

    my $fields = $opts->{fields} || [];
    # keep fields unique
    my %seen = map { $_ => 1 } @$fields;
    # add unique fields from groups (if there are any)
    if( my $groups = $opts->{groups} ){
      CORE::push(@$fields, grep { !$seen{$_}++ }
        map { @$_ } values %{ $self->{groups}->groups(@$groups) }
      );
    }

    foreach my $field ( @$fields ){
      ($self->{fields}->{$field} ||= $self->new_sub_chain())
        ->append(@chain_args);
    }
  }
  # let 'queue' return false so we can do simple 'if queue' checks
  delete $self->{queue};

  # what would be a good return value?
  return;
}


sub fields {
  my ($self) = shift;
  $self->{groups}->add_items(@_);
  $self->reprocess_queue
    if $self->{dequeued};
  return $self;
}


sub group {
  my ($self) = shift;
  croak("group() takes argument pairs.  Did you mean groups()?")
    if !@_;

  $self->{groups}->add(@_);
  $self->reprocess_queue
    if $self->{dequeued};
  return $self;
}


sub groups {
  my ($self) = shift;
  croak("groups() takes no arguments.  Did you mean group()?")
    if @_;

  return $self->{groups};
}


sub new_sub_chain {
  my ($self) = @_;
  return $self->{chain_class}->new($self->{chain_args});
}

sub _normalize_spec {
  my ($self, $opts) = @_;

  # Don't alter \%opts.  Limit %norm to desired keys.
  my %norm;
  my %aliases = (
    arguments => 'args',
    options   => 'opts',
    field     => 'fields',
    group     => 'groups',
    hook      => 'hooks',
  );

  while( my ($alias, $name) = each %aliases ){
    # store the alias in the actual key
    # overwrite with actual key if specified
    foreach my $key ( $alias, $name ){
      $norm{$name} = $opts->{$key}
        if exists  $opts->{$key};
    }
  }

  # allow a single string and convert it to an arrayref
  foreach my $type ( qw(fields groups hooks) ){
    $norm{$type} = [$norm{$type}]
      if exists($norm{$type}) && !ref($norm{$type});
  }

  # simplify code later by initializing these to refs
  $norm{args} ||= [];
  $norm{opts} ||= {};

  return \%norm;
}


sub reprocess_queue {
  my ($self) = @_;
  return unless my $dequeued = delete $self->{dequeued};

  # reset the queue and the stacks so that it will all be rebuilt
  $self->{queue}  = [@$dequeued, @{ $self->{queue} || [] } ];
  $self->{fields} = {};
  $self->{hooks}  = {};
  # but don't actually rebuild it until necessary
}

1;

# NOTE: Synopsis tested in t/synopsis.t

__END__