- my ($code, $found) = @{ $self->find_hook($hook, $step) };
- if (! $code) {
- croak "Could not find a method named ${step}_${hook} or ${hook}";
- } elsif (! UNIVERSAL::isa($code, 'CODE')) {
- croak "Value for $hook ($found) is not a code ref ($code)";
- }
-
- ### record history
- my $hist = {
- step => $step,
- meth => $hook,
- found => $found,
- time => time,
- };
-
- push @{ $self->history }, $hist;
-
- $hist->{'level'} = $self->{'_level'};
- local $self->{'_level'} = 1 + ($self->{'_level'} || 0);
-
- $hist->{'elapsed'} = time - $hist->{'time'};
-
- my $resp = $self->$code($step, @_);
-
- $hist->{'elapsed'} = time - $hist->{'time'};
- $hist->{'response'} = $resp;
-
- return $resp;
-}
-
-sub history {
- return shift->{'history'} ||= [];
-}
-
-sub dump_history {
- my $self = shift;
- my $all = shift || 0;
- my $hist = $self->history;
- my $dump = [];
- push @$dump, sprintf("Elapsed: %.5f", time - $self->{'_time'});
-
- ### show terse - yet informative info
- foreach my $row (@$hist) {
- if (! ref($row)
- || ref($row) ne 'HASH'
- || ! exists $row->{'elapsed'}) {
- push @$dump, $row;
- } else {
- my $note = (' ' x ($row->{'level'} || 0))
- . join(' - ', $row->{'step'}, $row->{'meth'}, $row->{'found'}, sprintf('%.5f', $row->{'elapsed'}));
- my $resp = $row->{'response'};
- if (ref($resp) eq 'HASH' && ! scalar keys %$resp) {
- $note .= ' - {}';
- } elsif (ref($resp) eq 'ARRAY' && ! @$resp) {
- $note .= ' - []';
- } elsif (! ref $resp || ! $all) {
- my $max = $self->{'history_max'} || 30;
- if (length($resp) > $max) {
- $resp = substr($resp, 0, $max);
- $resp =~ s/\n.+//s;
- $resp = "$resp ...";
- }
- $note .= " - $resp";
- } else {
- $note = [$note, $resp];
- }
-
- push @$dump, $note;
- }
- }
-
- return $dump;
-}
-
-###----------------------------------------------------------------###
-### utility methods to allow for storing separate steps in other modules
-
-sub allow_morph {
- my $self = shift;
- return $self->{'allow_morph'} ? 1 : 0;
-}
-
-sub allow_nested_morph {
- my $self = shift;
- return $self->{'allow_nested_morph'} ? 1 : 0;
-}
-
-sub morph {
- my $self = shift;
- my $step = shift || return;
- my $allow = $self->allow_morph($step) || return;
-
- ### place to store the lineage
- my $lin = $self->{'__morph_lineage'} ||= [];
- my $cur = ref $self; # what are we currently
- push @$lin, $cur; # store so subsequent unmorph calls can do the right thing
-
- my $hist = {
- step => $step,
- meth => 'morph',
- found => 'morph',
- time => time,
- elapsed => 0,
- response => 0
- };
- push @{ $self->history }, $hist;
-
- if (ref($allow) && ! $allow->{$step}) { # hash - but no step - record for unbless
- $hist->{'found'} .= " (not allowed to morph to that step)";
- return 0;
- }
-
- ### make sure we haven't already been reblessed
- if ($#$lin != 0 # is this the second morph call
- && (! ($allow = $self->allow_nested_morph($step)) # not true
- || (ref($allow) && ! $allow->{$step}) # hash - but no step
- )) {
- $hist->{'found'} .= $allow ? " (not allowed to nested_morph to that step)" : " (nested_morph disabled)";
- return 0; # just return - don't die so that we can morph early