File Coverage

blib/lib/Venus/Try.pm

Criterion	Covered	Total	%
statement	115	116	99.1
branch	33	36	91.6
condition	7	11	63.6
subroutine	27	27	100.0
pod	15	17	88.2
total	197	207	95.1

package Venus::Try;

use 5.018;

use strict;
use warnings;

use Venus::Class 'attr', 'base';

base 'Venus::Kind::Utility';

use Scalar::Util ();

# ATTRIBUTES

attr 'invocant';
attr 'arguments';
attr 'on_try';
attr 'on_catch';
attr 'on_default';
attr 'on_finally';

# BUILDERS

sub build_arg {
  my ($self, $data) = @_;

  return {
    on_try => $data,
  };
}

sub build_self {
  my ($self, $data) = @_;

  $self->on_catch([]) if !defined $self->on_catch;

  return $self;
}

# METHODS

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

  $self->on_default(sub{(@_)});

  return $self;
}

sub call {
  my ($self, $callback) = @_;

  $self->on_try($self->callback($callback));

  return $self;
}

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

  if (not(UNIVERSAL::isa($callback, 'CODE'))) {
    my $method;
    my $invocant = $self->invocant;

    if (defined($invocant)) {
      $method = $invocant->can($callback);
    }
    else {
      $method = $self->can($callback);
    }

    if (!$method) {
      $self->throw('error_on_callback', {
        invocant => $invocant,
        callback => $callback,
      });
    }

    $callback = sub {goto $method};
  }

  return $callback;
}

sub catch {
  my ($self, $package, $callback) = @_;

  $callback ||= sub{(@_)};

  push @{$self->on_catch}, [$package, $self->callback($callback)];

  return $self;
}

sub default {
  my ($self, $callback) = @_;

  $self->on_default($self->callback($callback));

  return $self;
}

sub error {
  my ($self, $variable) = @_;

  if ($variable) {
    $self->on_default(sub{($$variable) = @_})
  }
  else {
    $self->catch('Venus::Error');
  }

  return $self;
}

sub execute {
  my ($self, $callback, @args) = @_;

  unshift @args, @{$self->arguments}
    if $self->arguments && @{$self->arguments};

  unshift @args, $self->invocant
    if defined($self->invocant);

  return wantarray ? ($callback->(@args)) : $callback->(@args);
}

sub finally {
  my ($self, $callback) = @_;

  $self->on_finally($self->callback($callback));

  return $self;
}

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

  $self->on_default(sub{(undef)});

  return $self;
}

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

  $self->on_catch([]);

  return $self;
}

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

  $self->on_default(undef);

  return $self;
}

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

  $self->on_finally(undef);

  return $self;
}

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

  $self->on_try(undef);

  return $self;
}

sub result {
  my ($self, @args) = @_;

  my $dollarat = $@;
  my @returned;

  # try
  my $error = do {
    local $@;
    eval {
      my $tryer = $self->on_try;
      @returned = ($self->execute($tryer, @args));
    };
    $@;
  };

  # catch
  if ($error) {
    my $caught = $error;
    my $catchers = $self->on_catch;
    my $default = $self->on_default;

    for my $catcher (@$catchers) {
      if (UNIVERSAL::isa($caught, $catcher->[0])) {
        @returned = ($catcher->[1]->($caught));
        last;
      }
    }

    # catchall
    if(!@returned) {
      if ($default) {
        @returned = ($default->($caught))
      }
    }

    # uncaught
    if(!@returned) {
      if (Scalar::Util::blessed($caught)) {
        die $caught;
      }
      else {
        if (UNIVERSAL::isa($caught, 'Venus::Error')) {
          $caught->throw;
        }
        else {
          require Venus::Error;
          Venus::Error->throw($caught);
        }
      }
    }
  }

  # finally
  if (my $finally = $self->on_finally) {
    $self->execute($finally, @args);
  }

  $@ = $dollarat;

  return wantarray ? (@returned) : $returned[0];
}

# ERRORS

sub error_on_callback {
  my ($self, $data) = @_;

  my $callback = $data->{callback};
  my $invocant = $data->{invocant};

  my $message = sprintf(
    qq(Can't locate object method "%s" on package "%s"), ($callback,
      $invocant ? (ref($invocant) || $invocant) : (ref($self) || $self))
  );

  my $stash = {
    invocant => $invocant,
    callback => $callback,
  };

  my $result = {
    name => 'on.callback',
    raise => true,
    stash => $stash,
    message => $message,
  };

  return $result;
}

1;



=head1 NAME

Venus::Try - Try Class

=cut

=head1 ABSTRACT

Try Class for Perl 5

=cut

=head1 SYNOPSIS

  package main;

  use Venus::Try;

  my $try = Venus::Try->new;

  $try->call(sub {
    my (@args) = @_;

    # try something

    return time;
  });

  $try->catch('Example::Error', sub {
    my ($caught) = @_;

    # caught an error (exception)

    return;
  });

  $try->default(sub {
    my ($caught) = @_;

    # catch the uncaught

    return;
  });

  $try->finally(sub {
    my (@args) = @_;

    # always run after try/catch

    return;
  });

  my @args;

  my $result = $try->result(@args);

=cut

=head1 DESCRIPTION

This package provides an object-oriented interface for performing complex
try/catch operations.

=cut

=head1 ATTRIBUTES

This package has the following attributes:

=cut

=head2 invocant

  invocant(Object)

This attribute is read-only, accepts C<(Object)> values, and is optional.

=cut

=head2 arguments

  arguments(ArrayRef)

This attribute is read-only, accepts C<(ArrayRef)> values, and is optional.

=cut

=head2 on_try

  on_try(CodeRef)

This attribute is read-write, accepts C<(CodeRef)> values, and is optional.

=cut

=head2 on_catch

  on_catch(ArrayRef[CodeRef])

This attribute is read-write, accepts C<(ArrayRef[CodeRef])> values, is optional, and defaults to C<[]>.

=cut

=head2 on_default

  on_default(CodeRef)

This attribute is read-write, accepts C<(CodeRef)> values, and is optional.

=cut

=head2 on_finally

  on_finally(CodeRef)

This attribute is read-write, accepts C<(CodeRef)> values, and is optional.

=cut

=head1 INHERITS

This package inherits behaviors from:

L

=cut

=head1 METHODS

This package provides the following methods:

=cut

=head2 any

  any() (Venus::Try)

The any method registers a default C condition that returns whatever
value was encoutered on error and returns it as a result.

I>

=over 4

=item any example 1

  package main;

  use Venus::Try;

  my $try = Venus::Try->new;

  $try->call(sub {
    die 'Oops!';
  });

  my $any = $try->any;

  # bless({ on_catch => ... }, "Venus::Try")

=back

=over 4

=item any example 2

  package main;

  use Venus::Try;

  my $try = Venus::Try->new;

  $try->call(sub {
    die $try;
  });

  my $any = $try->any;

  # bless({ on_catch => ... }, "Venus::Try")

=back

=cut

=head2 call

  call(string | coderef $method) (Venus::Try)

The call method takes a method name or coderef, registers it as the tryable
routine, and returns the object. When invoked, the callback will received an
C if one was provided to the constructor, the default C if
any were provided to the constructor, and whatever arguments were provided by
the invocant.




I>

=over 4

=item call example 1

  package main;

  use Venus::Try;

  my $try = Venus::Try->new;

  my $call = $try->call(sub {
    my (@args) = @_;

    return [@args];
  });

  # bless({ on_catch => ... }, "Venus::Try")

=back

=cut

=head2 callback

  callback(string | coderef $method) (coderef)

The callback method takes a method name or coderef, and returns a coderef for
registration. If a coderef is provided this method is mostly a passthrough.

I>

=over 4

=item callback example 1

  package main;

  use Venus::Try;

  my $try = Venus::Try->new;

  my $callback = $try->callback(sub {
    my (@args) = @_;

    return [@args];
  });

  # sub { ... }

=back

=over 4

=item callback example 2

  package Example1;

  sub new {
    bless {};
  }

  sub test {
    my (@args) = @_;

    return [@args];
  }

  package main;

  use Venus::Try;

  my $try = Venus::Try->new(
    invocant => Example1->new,
  );

  my $callback = $try->callback('test');

  # sub { ... }

=back

=over 4

=item callback example 3

  package main;

  use Venus::Try;

  my $try = Venus::Try->new;

  my $callback = $try->callback('missing_method');

  # Exception! (isa Venus::Try::Error) (see error_on_callback)

=back

=cut

=head2 catch

  catch(string $isa, string | coderef $method) (Venus::Try)

The catch method takes a package or ref name, and when triggered checks whether
the captured exception is of the type specified and if so executes the given
callback. If no callback is provided the exception is captured in a L
operation and returned as a result.

I>

=over 4

=item catch example 1

  package main;

  use Venus::Try;

  my $try = Venus::Try->new;

  $try->call(sub {
    my (@args) = @_;

    die $try;
  });

  my $catch = $try->catch('Venus::Try', sub {
    my (@args) = @_;

    return [@args];
  });

  # bless({ on_catch => ... }, "Venus::Try")

=back

=over 4

=item catch example 2

  package main;

  use Venus::Try;

  my $try = Venus::Try->new;

  $try->call(sub {
    my (@args) = @_;

    $try->throw->error;
  });

  my $catch = $try->catch('Venus::Try::Error', sub {

    return (@_);
  });

  # bless({ on_catch => ... }, "Venus::Try")

=back

=over 4

=item catch example 3

  package main;

  use Venus::Try;

  my $try = Venus::Try->new;

  $try->call(sub {

    $try->throw->error;
  });

  my $catch = $try->catch('Venus::Try::Error');

  # bless({ on_catch => ... }, "Venus::Try")

=back

=cut

=head2 default

  default(string | coderef $method) (Venus::Try)

The default method takes a method name or coderef and is triggered if no
C conditions match the exception thrown.

I>

=over 4

=item default example 1

  package main;

  use Venus::Try;

  my $try = Venus::Try->new;

  $try->call(sub {
    my (@args) = @_;

    die $try;
  });

  my $default = $try->default(sub {
    my (@args) = @_;

    return [@args];
  });

  # bless({ on_catch => ... }, "Venus::Try")

=back

=cut

=head2 error

  error(Ref $variable) (Venus::Try)

The error method takes a scalar reference and assigns any uncaught exceptions
to it during execution. If no variable is provided a L operation will
be registered to capture all L exceptions.

I>

=over 4

=item error example 1

  package main;

  use Venus::Try;

  my $try = Venus::Try->new;

  $try->call(sub {
    my (@args) = @_;

    die $try;
  });

  my $error = $try->error(\my $object);

  # bless({ on_catch => ... }, "Venus::Try")

=back

=over 4

=item error example 2

  package main;

  use Venus::Try;

  my $try = Venus::Try->new;

  $try->call(sub {
    my (@args) = @_;

    $try->throw->error;
  });

  my $error = $try->error;

  # bless({ on_catch => ... }, "Venus::Try")

=back

=cut

=head2 execute

  execute(coderef $code, any @args) (any)

The execute method takes a coderef and executes it with any given arguments.
When invoked, the callback will received an C if one was provided to
the constructor, the default C if any were provided to the
constructor, and whatever arguments were passed directly to this method. This
method can return a list of values in list-context.

I>

=over 4

=item execute example 1

  package Example2;

  sub new {
    bless {};
  }

  package main;

  use Venus::Try;

  my $try = Venus::Try->new(
    invocant => Example2->new,
    arguments => [1,2,3],
  );

  my $execute = $try->execute(sub {
    my (@args) = @_;

    return [@args];
  });

  # [bless({}, "Example2"), 1, 2, 3]

=back

=cut

=head2 finally

  finally(string | coderef $method) (Venus::Try)

The finally method takes a package or ref name and always executes the callback
after a try/catch operation. The return value is ignored. When invoked, the
callback will received an C if one was provided to the constructor,
the default C if any were provided to the constructor, and whatever
arguments were provided by the invocant.

I>

=over 4

=item finally example 1

  package Example3;

  sub new {
    bless {};
  }

  package main;

  use Venus::Try;

  my $try = Venus::Try->new(
    invocant => Example3->new,
    arguments => [1,2,3],
  );

  $try->call(sub {
    my (@args) = @_;

    return $try;
  });

  my $finally = $try->finally(sub {
    my (@args) = @_;

    $try->{args} = [@args];
  });

  # bless({ on_catch => ... }, "Venus::Try")

=back

=cut

=head2 maybe

  maybe() (Venus::Try)

The maybe method registers a default C condition that returns falsy,
i.e. an undefined value, if an exception is encountered.

I>

=over 4

=item maybe example 1

  package main;

  use Venus::Try;

  my $try = Venus::Try->new;

  $try->call(sub {
    my (@args) = @_;

    die $try;
  });

  my $maybe = $try->maybe;

  # bless({ on_catch => ... }, "Venus::Try")

=back

=cut

=head2 no_catch

  no_catch() (Venus::Try)

The no_catch method removes any configured catch conditions and returns the
object.

I>

=over 4

=item no_catch example 1

  package main;

  use Venus::Try;

  my $try = Venus::Try->new;

  $try->call(sub {
    my (@args) = @_;

    die $try;
  });

  $try->catch('Venus::Try', sub {
    my (@args) = @_;

    return [@args];
  });


  my $no_catch = $try->no_catch;

  # bless({ on_catch => ... }, "Venus::Try")

=back

=cut

=head2 no_default

  no_default() (Venus::Try)

The no_default method removes any configured default condition and returns the
object.

I>

=over 4

=item no_default example 1

  package main;

  use Venus::Try;

  my $try = Venus::Try->new;

  $try->call(sub {
    my (@args) = @_;

    die $try;
  });

  my $default = $try->default(sub {
    my (@args) = @_;

    return [@args];
  });

  my $no_default = $try->no_default;

  # bless({ on_catch => ... }, "Venus::Try")

=back

=cut

=head2 no_finally

  no_finally() (Venus::Try)

The no_finally method removes any configured finally condition and returns the
object.

I>

=over 4

=item no_finally example 1

  package Example4;

  sub new {
    bless {};
  }

  package main;

  use Venus::Try;

  my $try = Venus::Try->new(
    invocant => Example4->new,
    arguments => [1,2,3],
  );

  $try->call(sub {
    my (@args) = @_;

    return $try;
  });

  $try->finally(sub {
    my (@args) = @_;

    $try->{args} = [@args];
  });

  my $no_finally = $try->no_finally;

  # bless({ on_catch => ... }, "Venus::Try")

=back

=cut

=head2 no_try

  no_try() (Venus::Try)

The no_try method removes any configured C operation and returns the
object.

I>

=over 4

=item no_try example 1

  package main;

  use Venus::Try;

  my $try = Venus::Try->new;

  $try->call(sub {
    my (@args) = @_;

    return [@args];
  });

  my $no_try = $try->no_try;

  # bless({ on_catch => ... }, "Venus::Try")

=back

=cut

=head2 result

  result(any @args) (any)

The result method executes the try/catch/default/finally logic and returns
either 1) the return value from the successfully tried operation 2) the return
value from the successfully matched catch condition if an exception was thrown
3) the return value from the default catch condition if an exception was thrown
and no catch condition matched. When invoked, the C and C
callbacks will received an C if one was provided to the constructor,
the default C if any were provided to the constructor, and whatever
arguments were passed directly to this method. This method can return a list of
values in list-context.

I>

=over 4

=item result example 1

  package main;

  use Venus::Try;

  my $try = Venus::Try->new;

  $try->call(sub {
    my (@args) = @_;

    return [@args];
  });

  my $result = $try->result;

  # []

=back

=over 4

=item result example 2

  package main;

  use Venus::Try;

  my $try = Venus::Try->new;

  $try->call(sub {
    my (@args) = @_;

    return [@args];
  });

  my $result = $try->result(1..5);

  # [1..5]

=back

=over 4

=item result example 3

  package main;

  use Venus::Try;

  my $try = Venus::Try->new;

  $try->call(sub {die});

  my $result = $try->result;

  # Exception! Venus::Error

=back

=cut

=head1 ERRORS

This package may raise the following errors:

=cut

=over 4

=item error: C

This package may raise an error_on_callback exception.

B

  # given: synopsis;

  my $input = {
    invocant => 'Example',
    callback => 'execute',
  };

  my $error = $try->throw('error_on_callback', $input)->catch('error');

  # my $name = $error->name;

  # "on_callback"

  # my $message = $error->render;

  # "Can't locate object method \"execute\" on package \"Example\""

=back

=head1 AUTHORS

Awncorp, C

=cut

=head1 LICENSE

Copyright (C) 2000, Awncorp, C.

This program is free software, you can redistribute it and/or modify it under
the terms of the Apache license version 2.0.

=cut