dtRdr::Callbacks::Book - the callbacks object for books

  use dtRdr::Callbacks::Book;

  YourClass->callback->set_foo_sub(sub {...});

  YourClass->get_callbacks->foo($args);

  use dtRdr::Callbacks::Book (); # suppress import()
  my $callbacks = dtRdr::Callbacks::Book->new();
  $callbacks->set_core_link_sub(sub {"foo://" . $_[0]});

  # later ...

  my $link = $callback->core_link($book, 'dr_note_link.png');

  my $callbacks = dtRdr::Callbacks::Book->new();

  my $all_callbacks = $callback->aggregate($and1, $and2, $and3);

  my $link = $callbacks->core_link($item);

  $uri = $callbacks->img_src_rewrite($uri, $book);

  $callbacks->annotation_created($anno);

  $callbacks->annotation_changed($anno);

  $callbacks->annotation_deleted($anno);

  dtRdr::Callbacks::Book->define('name', sub {...});

  $callbacks->has($name);

  use dtRdr::Callbacks::Book;

  dtRdr::Callbacks::Book->install_in($class);

package dtRdr::Callbacks::Book;
$VERSION = eval{require version}?version::qv($_):$_ for(0.10.1);

use warnings;
use strict;
use Carp;

use Class::Accessor::Classy;
rw 'aggregated';
no  Class::Accessor::Classy;

my %defaults; # holds default subs for undeclared stuff

sub new {
  my $package = shift;
  my $class = ref($package) || $package;
  my $self = {};
  bless($self, $class);
  return($self);
} # end subroutine new definition
########################################################################

sub aggregate {
  my $self = shift;
  my @others = @_;
  my @list = (reverse(@others), $self);
  my @keys = do {
    my %all = map({$_ => 1} grep(/_sub$/, map({keys(%$_)} @list)));
    keys(%all);
  };
  my $aggregated = $self->new;
  foreach my $key (@keys) {
    foreach my $item (@list) {
      next unless(exists($item->{$key}));
      my $ref = $item->{$key};
      $ref or next;
      # subrefs just smash, but arrays need to accumulate
      if(ref($ref) eq 'ARRAY') {
        # careful not to grow any existing references
        my $current = $aggregated->{$key} || [];
        $ref = [@$current, @$ref];
      }
      $aggregated->{$key} = $ref;
    }
  }
  $aggregated->{aggregated} = 1;
  return($aggregated);
} # end subroutine aggregate definition
########################################################################

$defaults{core_link} = sub {
  my ($item) = @_;
  return('dr://CORE/' . $item);
};
########################################################################

$defaults{img_src_rewrite} = sub {
  my ($src, $book) = @_;
  return($src);
};
########################################################################

$defaults{annotation_created} = undef;
########################################################################

$defaults{annotation_changed} = undef;
########################################################################

$defaults{annotation_deleted} = undef;
########################################################################

########################################################################
# DO NOT ATTEMPT TO DEFINE ANY DEFAULTS BELOW HERE
########################################################################

########################################################################
# build and install them and their accessors
foreach my $key (keys(%defaults)) {
  __PACKAGE__->define($key, $defaults{$key});
}
########################################################################

sub define {
  my $package = shift;
  my ($title, $def_subref) = @_;
  my $subname = $title . '_sub';
  my $installer = sub {
    my ($name, $sub) = @_;
    no strict 'refs';
    *{$package . '::' . $name} = $sub;
  };
  if(ref($def_subref) eq 'ARRAY') {
    die "not here yet";
    # $subname .= 's';
    # also, define the append_foo_subs($sub1, $sub2, $sub3); method
  }
  elsif((not defined($def_subref)) or (ref($def_subref) eq 'CODE')) {
    use Class::Accessor::Classy;
    rw $subname;
    no  Class::Accessor::Classy;
    my $getter = 'get_' . $subname;
    my $setter = 'set_' . $subname;
    my $setsub = sub {
      my $self = shift;
      my ($subref) = @_;
      $self->aggregated
        and croak("cannot set on an aggregated callback object");
      $self->$getter() and
        croak("attempt to redefine '$title' callback");
      my $super_setter = 'SUPER::' . $setter;
      $self->$super_setter($subref);
    }; # setsub
    $installer->($setter, $setsub);
    # no need for a getsub here
    my $dosub = sub {
      my $self = shift;
      my $subref = $self->$getter || $def_subref;
      $subref or return;
      return($subref->(@_));
    };
    $installer->($title, $dosub);
  }
  else {
    croak("unsupported reference type '$def_subref'");
  }
} # end subroutine define definition
########################################################################

sub has {
  my $self = shift;
  my ($name) = @_;
  my $look = $name . '_sub';
  return(defined($self->$look)) if($self->can($look));
  # or it is plural
  $look .= 's';
  $self->can($look) or
    croak("'$name' is not a defined callback title");
  my $list = $self->$look || [];
  return(scalar(@$list) > 0);
} # end subroutine has definition
########################################################################

sub import {
  my $package = shift;
  my $caller = caller();
  $package->install_in($caller);
} # end subroutine import definition
########################################################################

sub install_in {
  my $package = shift;
  my ($dest_class) = @_;

  {
    no strict 'refs';
    if(defined(&{$dest_class . '::get_callbacks'})) {
      # XXX now what?
      # I guess, do nothing IFF they have both.
      defined(&{$dest_class . 'callback'}) or
        croak(
          "cannot install in '$dest_class' because ",
          "get_callbacks() is defined, but missing callback() is ",
          "going to break everything"
        );
      return;
    }
  }
  my $object = $package->new;

  my $get_callbacks = sub {
    my $class = shift;
    my $class_isa = do { no strict 'refs'; \@{"${class}::ISA"}; };
    my @callback_objs;
    my %no_dupes;
    foreach my $base (@$class_isa) {
      # We'll get a duplicate if we're just inheriting the base class's
      # get_callbacks method, so we get the subref and compare.
      if(my $check = $base->can('get_callbacks')) {
        # XXX I don't know what this does in a diamond, maybe NEXT.pm?
        # but we only go one deep because get_callbacks goes the next
        # level deep
        $no_dupes{$check} and next;
        $no_dupes{$check} = 1;
        my $obj = $base->get_callbacks;
        push(@callback_objs, $obj);
      }
    }
    return($object->aggregate(@callback_objs));
  }; # end $get_callbacks closure def
  {
    no strict 'refs';
    # install the aggregator
    *{$dest_class . '::get_callbacks'} = $get_callbacks;
    # and the accessor
    *{$dest_class . '::callback'} = sub {$object};
  }
} # end subroutine install_in definition
########################################################################

# vi:ts=2:sw=2:et:sta
1;