File Coverage

blib/lib/Callback/Frame.pm

Criterion	Covered	Total	%
statement	115	124	92.7
branch	39	46	84.7
condition	4	5	80.0
subroutine	17	19	89.4
pod	0	9	0.0
total	175	203	86.2

package Callback::Frame;

use strict;

our $VERSION = '1.102';

require Exporter;
use base 'Exporter';
our @EXPORT = qw(frame fub frame_try frame_try_void frame_catch frame_local frame_void);

use Scalar::Util;
use Carp qw/croak/;
use Guard;


our $top_of_stack;
our $active_frames = {};


sub frame {
  my ($name, $code, $catcher, $locals, $existing_frame);

  while ((my $k, my $v, @_) = @_) {
    if ($k eq 'name') {
      $name = $v;
    } elsif ($k eq 'code') {
      $code = $v;
    } elsif ($k eq 'catch') {
      $catcher = $v;
    } elsif ($k eq 'local') {
      $locals->{$v} = undef;
    } elsif ($k eq 'existing_frame') {
      $existing_frame = $v;
    } else {
      croak "Unknown frame option: $k";
    }

    croak "value missing for key $k" if !defined $v;
  }

  $name ||= 'ANONYMOUS FRAME';
  my ($package, $filename, $line) = caller;
  ($package, $filename, $line) = caller(1) if $package eq __PACKAGE__; ## if we're called from fub or frame_try
  $name = "$filename:$line - $name";

  defined $code || croak "frame needs a 'code' callback";

  my $existing_top_of_stack;
  if (defined $existing_frame) {
    $existing_top_of_stack = $active_frames->{"$existing_frame"};
    croak "existing_frame isn't a frame" unless $existing_top_of_stack;
    croak "can't install new catcher if using existing_frame" if defined $catcher;
    croak "can't install new local if using existing_frame" if defined $locals;
  }


  my ($ret_cb, $internal_cb);

  $ret_cb = sub {
    return $internal_cb->(@_);
  };

  my $cb_address = "$ret_cb";

  my $new_frame;

  if ($existing_top_of_stack) {
    $new_frame = $existing_top_of_stack;
  } else {
    $new_frame = {
      name => $name,
      down => $top_of_stack,
      guard => guard {
        undef $ret_cb;
        delete $active_frames->{$cb_address};
      },
    };

    $new_frame->{catcher} = $catcher if defined $catcher;
    $new_frame->{locals} = $locals if defined $locals;

    $active_frames->{$cb_address} = $new_frame;
    Scalar::Util::weaken($active_frames->{$cb_address});
  }

  $internal_cb = sub {
    my $orig_error = $@;

    local $top_of_stack = $new_frame;

    my $frame_i = $top_of_stack;

    my $val = eval {
      ## Find applicable local vars

      my $local_refs = {};
      my $temp_copies = {};

      for(; $frame_i; $frame_i = $frame_i->{down}) {
        next unless exists $frame_i->{locals};
        foreach my $k (keys %{$frame_i->{locals}}) {
          next if exists $local_refs->{$k};
          $local_refs->{$k} = \$frame_i->{locals}->{$k};
        }
      }

      ## Backup local vars

      foreach my $var (keys %$local_refs) {
        no strict qw/refs/;
        $temp_copies->{$var} = $$var;
        $$var = ${$local_refs->{$var}};
      }

      ## Install code that will restore local vars

      scope_guard {
        foreach my $var (keys %$local_refs) {
          no strict qw/refs/;
          ${$local_refs->{$var}} = $$var;
          $$var = $temp_copies->{$var};
        }
      };

      ## Actually run the callback

      $@ = $orig_error;

      $code->(@_);
    };

    my $err = $@;

    if ($err) {
      my $trace = generate_trace($top_of_stack, $err);

      for (my $frame_i = $top_of_stack; $frame_i; $frame_i = $frame_i->{down}) {
        next unless exists $frame_i->{catcher};

        my $val = eval {
          $@ = $err;
          $frame_i->{catcher}->($trace);
          1
        };

        return if defined $val && $val == 1;

        $err = $@;
      }

      ## No catcher available: just re-throw error
      die $err;
    }

    return $val;
  };

  my $final_cb = $ret_cb;
  Scalar::Util::weaken($ret_cb);

  return $final_cb;
}


sub fub (&@) {
  my ($code, @args) = @_;

  return frame(code => $code, @args);
}


sub is_frame {
  my $coderef = shift;

  return 0 unless ref $coderef;

  return 1 if exists $active_frames->{$coderef};

  return 0;
}


sub generate_trace {
  my ($frame_pointer, $err) = @_;

  my $err_str = "$err";
  chomp $err_str;
  my $trace = "$err_str\n----- Callback::Frame stack-trace -----\n";

  for (my $frame_i = $frame_pointer; $frame_i; $frame_i = $frame_i->{down}) {
    $trace .= "$frame_i->{name}\n";
  }

  return $trace;
}


sub frame_void (&) {
  my ($block) = @_;

  local $top_of_stack;
  local $active_frames = {};

  $block->();
}

sub frame_try (&;@) {
  my ($try_block, $catch_block) = @_;

  return frame(code => $try_block, catch => $catch_block)->();
}

sub frame_try_void (&;@) {
  my ($try_block, $catch_block) = @_;

  local $top_of_stack;
  local $active_frames = {};

  return frame(code => $try_block, catch => $catch_block)->();
}

sub frame_catch (&) {
  my ($block) = @_;

  croak "Useless bare frame_catch" unless wantarray;

  return $block;
}

sub frame_local ($&) {
  my ($local, $block) = @_;

  return frame(code => $block, local => $local)->();
}


1;


__END__