File Coverage

blib/lib/Process/Results.pm

Criterion	Covered	Total	%
statement	100	113	88.5
branch	29	46	63.0
condition	5	11	45.4
subroutine	23	24	95.8
pod	11	20	55.0
total	168	214	78.5

package Process::Results;
use strict;
use Carp 'croak';
use B;
use JSON::Tiny;

# debug tools
# use Debug::ShowStuff ':all';
# use Debug::ShowStuff::ShowVar;

# version
our $VERSION = '0.1';

# config
my $tab = "\t";


#------------------------------------------------------------------------------
# pod
#

=head1 NAME

Process::Results - standardized structure for returning results of a process

=head1 SYNOPSIS

 use Process::Results;

 my $results = Process::Results->new();

 some_subroutine(results=>$results) {
    ...
 }

 if ($results->success) {}
 else {}

 much more...

=head1 OVERVIEW

Getting the details about the results of a subroutine call can be challenging.
It's easy enough for a subroutine to indicate if it succeeded or not, or to
simply die or croak. Communicating more detail, however, can get complicated.
What was the cause of the failure? What was the input value that caused it?
Maybe there were B problems, any of which could have independently
caused a failure.

Furthermore, it's not just failures that need communicating. Maybe there were
results of the process that need to be communicated back to the caller, in
addition to the success or failure of the operation.

Process::Results provides a standardized way for caller and subroutine to
communicate complex details of an operation. A Process::Results object is
passed into the subroutine call, which can then store results information in
the object. The sub doesn't even have to return the object because the caller
still has a reference to it.

Keep in mind that a process doesn't have to return the results object, so your
sub can still return success, failure, or some other value without the caller
having to check the Results object. In many cases, a successful process doesn't
need to provide any details - it's only on failure that details are needed.

At its simplest, a Results object is just an empty hash. By default, an empty
hash indicates success, which can be checked with the success method:

 $results->success()

If you prefer, you can check for failure, which just returns the opposite of
success():

 $results->failure()

If you prefer that the results object defaults to false, just add a 'success'
option when creating the new object:

 $results = Process::Results->new(success=>0);
 $results->success(); # returns false

In a more complex situation, the results object might contain one or more
messages in the errors array. Such an object would look like this:

 {
   errors => [
      { id=>'file-open-error', path=>'/tmp/output.txt' },
      { id=>'missing-param', param_name=>'email' },
   ]
 }

The presence of any elements in C means that the process failed, so
C<$results-Esuccess()> returns false. A complete explanation of the
structure of a results object is in the next section.

=head2 Structure

A complete structure of a results object looks like this:

 {
   success => 0,
   errors => [
      { id=>'file-open-error', path=>'/tmp/output.txt' },
      { id=>'missing-param', param_name=>'email' },
   ],
   warnings => [
      # more messages here
   ],
   notes => [
      # more messages here
   ],
   details => {
      # a hash that can contain anything you want
   }
 }

The C and C properties are redundant: the presence of any
errors indicates failure. If both properties are present, C overrides
C.

Errors indicate that the process failed. Warnings do not indicate a failure,
but do indicate that something went wrong. Notes are simply information about
the process and don't mean anything was wrong at all.

=head2 Message objects

Each message is a hash reference. Each message object must have the C
property. Other properties can provide details about the message, for example
a problematic input param. You can create message objects with the
C, C, and C methods:

 $results->error('file-not-found');
 $results->warning('very-long-loop');
 $results->warning('new-id');

More on those details below.

=head1 METHODS

=cut

#
# pod
#------------------------------------------------------------------------------


#------------------------------------------------------------------------------
# new
#

=head2 new()

Cnew()> creates a new Process::Results object. By default,
the object is an empty hash.

 my $results = Process::Results->new(); # returns empty, blessed hashref

B

=over

=item * success

The C option sets an explicit success or failure for the new object.
By default, you might want your results object to fail by default. In that case
you could do the following:

 $results = Process::Results->new(success=>0);

 # stuff happens, but nothing affects the results object

 $results->success(); # returns false

=item * json

You can pass in a json string which will be parsed and used to populate the new
object. For example:

 $results = Process::Results->new(json=>'{"errors":[{"id":"no-file"}]}');

produces this structure:

 {
   errors => [
      {
         id => "no-file"
      }
   ]
 }

=item * results

C can return an existing results object if the C option is
sent. This option is handy when you want to ensure that your subroutine has a
results object regardless of whether or not one was passed in. For example,
consider the following sub:

 sub mysub {
   my ($param, %opts) = @_;
   my $results = Process::Results->new(results=>$opts{'results'});

   # [do stuff]
 }

In that example, the caller can send in a results object with the options hash.
If it does so, that result object is used. If no such option is sent, the sub
has a new results object to use.

If the C object is sent, all other options are ignored.

=back

=cut

sub new {
	my ($class, %opts) = @_;
	my ($results);

	# TESTING
	# println subname(); ##i

	# if another results object was sent in options, return that
	if ( $opts{'results'} ) {
		if (UNIVERSAL::isa $opts{'results'}, 'Process::Results') {
			return $opts{'results'};
		}
	}

	# if json was sent, parse it
	if ( $opts{'json'} ) {
		$results = JSON::Tiny::decode_json($opts{'json'});
	}

	# else just create empty hashref
	else {
		$results = {};
	}

	# set explicit success if it was sent
	if (exists $opts{'success'}) {
		$results->{'success'} = $opts{'success'}? 1 : 0;
	}

	# bless object
	$results = bless($results, $class);

	# return
	return $results;
}
#
# new
#------------------------------------------------------------------------------


#------------------------------------------------------------------------------
# messages
#

=head2 error(), warning(), note()

Each of these methods creates a message object (which is just a hashref) for
their respective category.  The single required param is an id for the message.
The id can be any defined string that you want. For example, the following code
creates an error object with the id "do-not-find-file".

 $results->error('do-not-find-file');

That code creates a message object, stored in the C array, with the
following structure:

 {
   'id' => 'do-not-find-file'
 }

A message object can hold any other properties you want. Those properties
should give the details of the message. Those properties can be set with
additional params to the method call.  So, for example, the following code
sets an error with the id "do-not-find-file", along with indicating the path
that does not have the file:

 $results->error('do-not-find-file', path=>$file_path);

which would result in an object like this:

 {
   'id' => 'do-not-find-file',
   'path' => '/tmp/data.txt'
 }

The message method returns the message object, so if you prefer you can set
those properties directly in the message object, like this:

 $msg = $results->error('do-not-find-file');
 $msg->{'path'} = $file_path;

=cut

sub message {
	my ($results, $type, $id, %opts) = @_;
	my ($msg);

	# TESTING
	# println subname(); ##i

	# ensure resutls object has message type
	$results->{$type} ||= [];

	# build message object
	$msg = { id=>$id, %opts };

	# add to array
	push @{$results->{$type}}, $msg;

	# return message
	return $msg;
}

sub error   { return shift->message('errors', @_) }
sub warning { return shift->message('warnings', @_) }
sub note    { return shift->message('notes', @_) }
#
# messages
#------------------------------------------------------------------------------


#------------------------------------------------------------------------------
# success
#

=head2 success()

C<$results-Esuccess()> returns true or false to indicate the success state of
the process. Success is determined in one of two ways: if the C
property is defined, then the boolean value of that property is returned.
Else, if there are any messages in the C array, then false is returned,
else true is returned. C always returns either 1 or 0.

Here are some examples of some results objects and what C returns:

 # empty hash returns true
 {}

 # defined, false value of the success property returns false
 { 'success'=>0 }

 # errors array with at least one message returns false
 {
   'errors'=>[
      {'id'=>'do-not-find-file'}
   ],
 }

 # If there is a conflict between explicit success and the errors array, then
 # the explicit success is returned. That's confusing, so try to avoid that.
 {
   'success'=>1,
   'errors'=>[
      {'id'=>'do-not-find-file'}
   ],
 }

=cut

sub success {
	my ($results) = @_;

	# if success has been explcitly defined, use that
	if (defined $results->{'success'}) {
		return $results->{'success'} ? 1 : 0;
	}

	# else calculate success from errors array
	else {
		my $errs = $results->{'errors'};

		if ( $errs && UNIVERSAL::isa($errs, 'ARRAY')) {
			if (@$errs)
				{ return 0 }
			else
				{ return 1 }
		}
		else {
			return 1;
		}
	}
}
#
# success
#------------------------------------------------------------------------------


#------------------------------------------------------------------------------
# failure
#

=head2 failure()

C<$results-Efailure()> simply returns the boolean opposite of
C<$results-Esuccess()>. C<$results-Efailure()> always returns 1 or 0.

=cut

sub failure {
	return $_[0]->success ? 0 : 1;
}
#
# failure
#------------------------------------------------------------------------------


#------------------------------------------------------------------------------
# succeed, fail
#

=head2 succeed(), fail()

C<$results-Esucceed()> and C<$results-Efail()> explicitly set the
success state of the results object. All they do is set the C
property to 1 (C) or 0 (C).

=cut

sub succeed {
	$_[0]->{'success'} = 1;
}

sub fail {
	$_[0]->{'success'} = 0;
}

#
# succeed, fail
#------------------------------------------------------------------------------


#------------------------------------------------------------------------------
# unsucceed, unfail
#

=head2 unsucceed(), unfail()

C<$results-Eunsucceed()> and C<$results-Eunfail()> do the same thing:
delete the C proeperty.

=cut

sub unsucceed {
	delete $_[0]->{'success'};
}

sub unfail {
	delete $_[0]->{'success'};
}

#
# succeed, fail
#------------------------------------------------------------------------------


#------------------------------------------------------------------------------
# json
#

=head2 json()

C<$results-Ejson()> returns a JSON representation of the results object.
That's all, it takes no params, it just returns a JSON string.

OK, one minor thing to note is that the C property is set to the JSON
value of C or C. Other then that, nothing complicated.

=cut

sub json {
	my ($results) = @_;
	my ($success, %calc);

	# make a copy of the object
	%calc = %$results;

	# set success property
	if (defined $calc{'success'}) {
		$calc{'success'} =
			$calc{'success'} ?
			JSON::Tiny::true() :
			JSON::Tiny::false();
	}

	# return
	return to_json(\%calc);
}
#
# json
#------------------------------------------------------------------------------


#------------------------------------------------------------------------------
# to_json
# private method
#
sub to_json {
	my ($object) = @_;
	my ($json);

	# TESTING
	# println subname(); ##i

	# intialize string
	$$json = '';

	# output object
	to_json_object($object, 0, $json);

	# return
	return $$json;
}
#
# to_json
#------------------------------------------------------------------------------



#------------------------------------------------------------------------------
# to_json_object
# private method
#
sub to_json_object {
	my ($object, $depth, $json) = @_;

	# TESTING
	# println subname(); ##i

	# hash
	if ( UNIVERSAL::isa $object, 'HASH' ) {
		to_json_hash($object, $depth, $json);
	}

	# array
	elsif ( UNIVERSAL::isa $object, 'ARRAY' ) {
		to_json_array($object, $depth, $json);
	}

	# JSON::Tiny::_Bool
	elsif ( UNIVERSAL::isa $object, 'JSON::Tiny::_Bool' ) {
		if ( $object )
			{ $$json .= 'true' }
		else
			{ $$json .= 'false' }
	}

	# other unknown object
	elsif (ref $object) {
		croak 'unknown-object-type: unable to parse object type ' . ref($object);
	}

	# else scalar
	else {
		$$json .= json_quote($object);
	}
}
#
# to_json_object
#------------------------------------------------------------------------------


#------------------------------------------------------------------------------
# to_json_hash
# private method
#
sub to_json_hash {
	my ($hash, $depth, $json) = @_;
	my (@keys, $depth_local);

	# TESTING
	# println subname(); ##i

	# indent
	$depth_local = $depth+1;

	# begin hash
	$$json .= "{\n";

	# array of keys to output
	@keys = hash_keys($hash);

	# loop through keys
	for (my $idx=0; $idx < @keys; $idx++) {
		my $key = $keys[$idx];

		# output key
		$$json .= ($tab x $depth_local) . json_quote($key) . ' : ';

		# output value
		to_json_object($hash->{$key}, $depth_local, $json);

		# add comma if this isn't the last element
		if ($idx < (@keys-1))
			{ $$json .= ',' }

		# close key
		$$json .= "\n";
	}

	# end hash
	$$json .= ($tab x $depth) . "}";
}
#
# to_json_hash
#------------------------------------------------------------------------------


#------------------------------------------------------------------------------
# hash_keys
# private method
#
our @first_keys = (
	'success',
	'success-explicit',
);

sub hash_keys {
	my ($hash) = @_;
	my (%all, @rv);

	# TESTING
	# println subname(); ##i

	# build hash of keys
	@all{keys %$hash} = ();

	# first keys
	foreach my $first (@first_keys) {
		if ( exists $all{$first} ) {
			delete $all{$first};
			push @rv, $first;
		}
	}

	# append rest of keys to @keys
	push @rv, keys(%all);

	# return
	return @rv;
}
#
# hash_keys
#------------------------------------------------------------------------------



#------------------------------------------------------------------------------
# to_json_array
# private method
#
sub to_json_array {
	my ($array, $depth, $json) = @_;
	my ($depth_local);

	# TESTING
	# println subname(); ##i

	# indent
	$depth_local = $depth+1;

	# begin array
	# $$json .= ($tab x $depth) . "[\n";
	$$json .= "[\n";

	# loop through elements
	for (my $idx=0; $idx < @$array; $idx++) {
		# indent
		$$json .= ($tab x $depth_local);

		# output value
		to_json_object($array->[$idx], $depth_local, $json);

		# add comma if this isn't the last element
		if ($idx < (@$array-1))
			{ $$json .= ',' }

		# close key
		$$json .= "\n";
	}

	# end array
	$$json .= ($tab x $depth) . "]";
}
#
# to_json_array
#------------------------------------------------------------------------------


#------------------------------------------------------------------------------
# json_quote
# private method
#
sub json_quote {
	my ($val) = @_;

	# if it's undef, return null
	if (! defined $val)
		{ return 'null' }

	# if it's a number, return as is
	if ( is_number($val) )
		{ return $val }

	# else return quoted
	return encode_string($val);
}
#
# json_quote
#------------------------------------------------------------------------------


#------------------------------------------------------------------------------
# encode_string
# private method
# This code is copied rote from JSON::Tiny.
#
my %ESCAPE = (
	'"'     => '"',
	'\\'    => '\\',
	'/'     => '/',
	'b'     => "\x08",
	'f'     => "\x0c",
	'n'     => "\x0a",
	'r'     => "\x0d",
	't'     => "\x09",
	'u2028' => "\x{2028}",
	'u2029' => "\x{2029}"
);

my %REVERSE = map { $ESCAPE{$_} => "\\$_" } keys %ESCAPE;

sub encode_string {
	my $str = shift;
	$str =~ s!([\x00-\x1f\x{2028}\x{2029}\\"/])!$REVERSE{$1}!gs;
	return "\"$str\"";
}
#
# encode_string
#------------------------------------------------------------------------------



#------------------------------------------------------------------------------
# is_number
# private method
# This code is copied rote from JSON::Tiny.
#
sub is_number {
	my ($value) = @_;

	# return true if number
	return 1
		if B::svref_2object(\$value)->FLAGS & (B::SVp_IOK | B::SVp_NOK)
		&& 0 + $value eq $value
		&& $value * 0 == 0;

	# else return false
	return 0;
}
#
# is_number
#------------------------------------------------------------------------------

# return
1;

__END__