Object-Result-0.000003/000755 000765 000765 00000000000 12572546633 014017 5ustar00damian000000 000000 Object-Result-0.000003/Changes000644 000765 000765 00000000442 12572546626 015314 0ustar00damian000000 000000 Revision history for Object-Result 0.000001 Sat Apr 12 09:27:33 2014 Initial release. 0.000002 Tue Jul 22 19:28:53 2014 No changes logged 0.000003 Sat Sep 5 21:10:14 2015 Avoided problems testing error messages in non-anglophone locales (Danke, Slaven!) Object-Result-0.000003/lib/000755 000765 000765 00000000000 12572546632 014564 5ustar00damian000000 000000 Object-Result-0.000003/Makefile.PL000644 000765 000765 00000001252 12363616740 015764 0ustar00damian000000 000000 use strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'Object::Result', AUTHOR => 'Damian Conway ', VERSION_FROM => 'lib/Object/Result.pm', ABSTRACT_FROM => 'lib/Object/Result.pm', PL_FILES => {}, LICENSE => 'artistic2', MIN_PERL_VERSION => 5.014, PREREQ_PM => { 'Test::More' => 0, 'Keyword::Simple' => 0, 'PPI' => 0, 'Method::Signatures' => 0, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Object-Result-*' }, ); Object-Result-0.000003/MANIFEST000644 000765 000765 00000000707 12572546633 015154 0ustar00damian000000 000000 Changes lib/Object/Result.pm Makefile.PL MANIFEST README t/00.load.t t/alternative_coercions.t t/coercions.t t/default_coercions.t t/empty_result.t t/exceptions.t t/fail.t t/fail_dollar_at.t t/fail_msg.t t/fail_msg_dollar_bang.t t/named_methods.t t/no_default_coercions.t t/true_false.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Object-Result-0.000003/META.json000644 000765 000765 00000002016 12572546633 015437 0ustar00damian000000 000000 { "abstract" : "Allow subs to build and return objects on-the-fly", "author" : [ "Damian Conway " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.142690", "license" : [ "artistic_2" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Object-Result", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Keyword::Simple" : "0", "Method::Signatures" : "0", "PPI" : "0", "Test::More" : "0", "perl" : "5.014" } } }, "release_status" : "stable", "version" : "0.000003" } Object-Result-0.000003/META.yml000644 000765 000765 00000001136 12572546633 015271 0ustar00damian000000 000000 --- abstract: 'Allow subs to build and return objects on-the-fly' author: - 'Damian Conway ' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.04, CPAN::Meta::Converter version 2.142690' license: artistic_2 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Object-Result no_index: directory: - t - inc requires: Keyword::Simple: '0' Method::Signatures: '0' PPI: '0' Test::More: '0' perl: '5.014' version: '0.000003' Object-Result-0.000003/README000644 000765 000765 00000001572 12572546626 014706 0ustar00damian000000 000000 Object::Result version 0.000003 This module adds a new keyword to Perl: "result" That keyword acts like a "return", but instead of a list of values to return, it takes a single block which specifies the behaviour (i.e. the methods and operator overloading) of an object to be returned. The intention is to make it much less onerous to return clean, properly encapsulated objects...instead of returning lists of values or references to arrays or hashes. INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install DEPENDENCIES * Keyword::Simple * PPI * Method::Signatures COPYRIGHT AND LICENCE Copyright (C) 2014, Damian Conway This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Object-Result-0.000003/t/000755 000765 000765 00000000000 12572546633 014262 5ustar00damian000000 000000 Object-Result-0.000003/t/00.load.t000644 000765 000765 00000000176 12322165345 015576 0ustar00damian000000 000000 use Test::More tests => 1; BEGIN { use_ok( 'Object::Result' ); } diag( "Testing Object::Result $Object::Result::VERSION" ); Object-Result-0.000003/t/alternative_coercions.t000644 000765 000765 00000001467 12354166455 021037 0ustar00damian000000 000000 use 5.014; use Test::More; use Object::Result; my $scalar = 'scalar variable'; my @array = qw< array variable >; $array[12] = 'twelve'; my %hash = qw< hash variable >; sub code { return 'subroutine' } open my $glob_ref, '<', \$scalar; sub get_result { result { { return qr{food?} } { return \$scalar } { return \@array } { return \%hash } { return \&code } { return $glob_ref } }; } my $result = get_result(); is $$result, $scalar => 'Scalar deref'; cmp_ok \@$result, '==', \@array => 'Array deref'; cmp_ok \%$result, '==', \%hash => 'Hash deref'; is $result->(), code(), => 'Code deref'; is readline($result), $scalar => 'Glob_deref'; done_testing(); Object-Result-0.000003/t/coercions.t000644 000765 000765 00000002352 12354166443 016430 0ustar00damian000000 000000 use 5.014; use Test::More; use Object::Result; my $scalar = 'scalar variable'; my @array = qw< array variable >; $array[12] = 'twelve'; my %hash = qw< hash variable >; sub code { return 'subroutine' } open my $glob_ref, '<', \$scalar; sub get_result { result { { return 'STR' } { return 0 } { return 42 } { return 12.34 } { return qr{food?} } { return \$scalar } { return \@array } { return \%hash } { return \&code } { return $glob_ref } }; } my $result = get_result(); is $result, 'STR' => 'String coercion'; ok !$result => 'Boolean coercion'; cmp_ok $result+0, '==', 12.34 => 'Number coercion'; is int($result), 42 => 'Explicit integer coercion'; is $array[$result], 'twelve' => 'Implicit numeric coercion'; is $$result, $scalar => 'Scalar deref'; cmp_ok \@$result, '==', \@array => 'Array deref'; cmp_ok \%$result, '==', \%hash => 'Hash deref'; is $result->(), code(), => 'Code deref'; is readline($result), $scalar => 'Glob_deref'; done_testing(); Object-Result-0.000003/t/default_coercions.t000644 000765 000765 00000003107 12355361417 020132 0ustar00damian000000 000000 use 5.014; use Test::More; use Object::Result; use Carp; sub is_ex (&$$$) { my ($block, $expected_err, $line, $desc) = @_; my $file = (caller 0)[1]; is eval{ $block->(); }, undef() => "$desc (threw exception)"; like $@, qr{\Q$expected_err\E} => "$desc (right error message)"; like $@, qr{at $file line $line} => "$desc (right error location)"; } sub code { return 'subroutine' } sub get_result { result { { return 0 } { return \&code } ($what, $where) { croak "Can't use result of $where as $what" } }; } my $call_desc = 'call to main::get_result() at '.__FILE__.' line '.__LINE__; my $result = get_result(); ok !$result => 'Boolean coercion'; is $result->(), code() => 'Code deref'; is_ex { ${$result} } "Can't use result of $call_desc as " => __LINE__, 'No '; is_ex { \@{$result} } "Can't use result of $call_desc as " => __LINE__, 'No '; is_ex { \%{$result} } "Can't use result of $call_desc as " => __LINE__, 'No '; is_ex { "" =~ $result } "Can't use result of $call_desc as " => __LINE__, 'No '; is_ex { *{$result} } "Can't use result of $call_desc as " => __LINE__, 'No '; is_ex { $result + 1 } "Can't use result of $call_desc as " => __LINE__, 'No '; is_ex { int($result) } "Can't use result of $call_desc as " => __LINE__, 'No '; is_ex { "$result" } "Can't use result of $call_desc as " => __LINE__, 'No '; done_testing(); Object-Result-0.000003/t/empty_result.t000644 000765 000765 00000002451 12355612224 017172 0ustar00damian000000 000000 use 5.014; use Test::More; use Object::Result; use Carp; sub is_ex (&$$$) { my ($block, $expected_err, $line, $desc) = @_; my $file = (caller 0)[1]; is eval{ $block->(); }, undef() => "$desc (threw exception)"; like $@, qr{\Q$expected_err\E} => "$desc (right error message)"; like $@, qr{at $file line $line} => "$desc (right error location)"; } sub code { return 'subroutine' } sub get_result { result { }; } my $CALL_LOC = __FILE__.' line '.__LINE__; my $result = get_result(); ok !$result => 'Boolean coercion'; my $error_msg = "Call to main::get_result() at $CALL_LOC failed\n" . "Failure detected"; is_ex { $result + 1 } $error_msg => __LINE__, 'No '; is_ex { int($result) } $error_msg => __LINE__, 'No '; is_ex { "$result" } $error_msg => __LINE__, 'No '; is_ex { ${$result} } $error_msg => __LINE__, 'No '; is_ex { \@{$result} } $error_msg => __LINE__, 'No '; is_ex { \%{$result} } $error_msg => __LINE__, 'No '; is_ex { $result->() } $error_msg => __LINE__, 'No '; is_ex { "" =~ $result } $error_msg => __LINE__, 'No '; is_ex { *{$result} } $error_msg => __LINE__, 'No '; is_ex { $result->no_such_method(); 1 } $error_msg => __LINE__, 'Non-existent method called'; done_testing(); Object-Result-0.000003/t/exceptions.t000644 000765 000765 00000002631 12355302647 016624 0ustar00damian000000 000000 use 5.014; use Test::More; use Object::Result; sub is_ex (&$$$) { my ($block, $expected_err, $line, $desc) = @_; my $file = (caller 0)[1]; is eval{ $block->(); }, undef() => "$desc (threw exception)"; like $@, qr{\Q$expected_err\E} => "$desc (right error message)"; like $@, qr{at $file line $line} => "$desc (right error location)"; } sub is_wn (&$$$) { my ($block, $expected_warning, $line, $desc) = @_; my $file = (caller 0)[1]; my $warning; local $SIG{__WARN__} = sub { $warning = "@_" }; $block->(); like $warning, qr{\Q$expected_warning\E} => "$desc (right warning message)"; like $warning, qr{at $file line $line} => "$desc (right warning location)"; } use Carp; my $die_warn_line = -1; sub get_result { $die_warn_line = __LINE__ + 1; result { confess { confess 'confessed' } croak { croak 'croaked' } carp { carp 'carped' } die { die 'died' } warn { warn 'warned' } }; } my $result = get_result(); ok $result=> "Boolean coercion"; is_wn { $result->warn } "warned", $die_warn_line => '->warn'; is_wn { $result->carp } "carped", (__LINE__) => '->carp'; is_ex { $result->die } "died", $die_warn_line => '->die'; is_ex { $result->croak } "croaked", $die_warn_line => '->croak'; is_ex { $result->confess } "confessed", (__LINE__) => '->confess'; done_testing(); Object-Result-0.000003/t/fail.t000644 000765 000765 00000002460 12360251767 015360 0ustar00damian000000 000000 use 5.014; use Test::More; use Object::Result; use Carp; sub is_ex (&$$$) { my ($block, $expected_err, $line, $desc) = @_; my $file = (caller 0)[1]; is eval{ $block->(); }, undef() => "$desc (threw exception)"; like $@, qr{\Q$expected_err\E} => "$desc (right error message)"; like $@, qr{at $file line $line} => "$desc (right error location)"; } sub code { return 'subroutine' } sub get_result { result { }; } my $CALL_LOC = __FILE__.' line '.__LINE__; my $result = get_result(); ok !$result => 'Boolean coercion'; my $error_msg = "Call to main::get_result() at $CALL_LOC failed\n" . "Failure detected"; is_ex { $result + 1 } $error_msg => __LINE__, 'No '; is_ex { int($result) } $error_msg => __LINE__, 'No '; is_ex { "$result" } $error_msg => __LINE__, 'No '; is_ex { ${$result} } $error_msg => __LINE__, 'No '; is_ex { \@{$result} } $error_msg => __LINE__, 'No '; is_ex { \%{$result} } $error_msg => __LINE__, 'No '; is_ex { $result->() } $error_msg => __LINE__, 'No '; is_ex { "" =~ $result } $error_msg => __LINE__, 'No '; is_ex { *{$result} } $error_msg => __LINE__, 'No '; is_ex { $result->no_such_method(); 1 } $error_msg => __LINE__, 'Non-existent method called'; done_testing(); Object-Result-0.000003/t/fail_dollar_at.t000644 000765 000765 00000002634 12355612116 017375 0ustar00damian000000 000000 use 5.014; use Test::More; use Object::Result; use Carp; sub is_ex (&$$$) { my ($block, $expected_err, $line, $desc) = @_; my $file = (caller 0)[1]; is eval{ $block->(); }, undef() => "$desc (threw exception)"; like $@, qr{\Q$expected_err\E} => "$desc (right error message)"; like $@, qr{at $file line $line} => "$desc (right error location)"; } sub code { return 'subroutine' } sub get_result { system('kjsadhkashdahsdlh'); eval { die 'Dollar AT' }; result { } } my $CALL_LOC = __FILE__.' line '.__LINE__; my $result = get_result(); ok !$result => 'Boolean coercion'; my $error_msg = "Call to main::get_result() at $CALL_LOC failed because:\n" . " Dollar AT\n" . "Failure detected"; is_ex { $result + 1 } $error_msg => __LINE__, 'No '; is_ex { int($result) } $error_msg => __LINE__, 'No '; is_ex { "$result" } $error_msg => __LINE__, 'No '; is_ex { ${$result} } $error_msg => __LINE__, 'No '; is_ex { \@{$result} } $error_msg => __LINE__, 'No '; is_ex { \%{$result} } $error_msg => __LINE__, 'No '; is_ex { $result->() } $error_msg => __LINE__, 'No '; is_ex { "" =~ $result } $error_msg => __LINE__, 'No '; is_ex { *{$result} } $error_msg => __LINE__, 'No '; is_ex { $result->no_such_method(); 1 } $error_msg => __LINE__, 'Non-existent method called'; done_testing(); Object-Result-0.000003/t/fail_msg.t000644 000765 000765 00000002554 12355612136 016225 0ustar00damian000000 000000 use 5.014; use Test::More; use Object::Result; use Carp; sub is_ex (&$$$) { my ($block, $expected_err, $line, $desc) = @_; my $file = (caller 0)[1]; is eval{ $block->(); }, undef() => "$desc (threw exception)"; like $@, qr{\Q$expected_err\E} => "$desc (right error message)"; like $@, qr{at $file line $line} => "$desc (right error location)"; } sub code { return 'subroutine' } sub get_result { result { {"Bad result"} }; } my $CALL_LOC = __FILE__.' line '.__LINE__; my $result = get_result(); ok !$result => 'Boolean coercion'; my $error_msg = "Call to main::get_result() at $CALL_LOC failed because:\n" . " Bad result\n" . "Failure detected"; is_ex { $result + 1 } $error_msg => __LINE__, 'No '; is_ex { int($result) } $error_msg => __LINE__, 'No '; is_ex { "$result" } $error_msg => __LINE__, 'No '; is_ex { ${$result} } $error_msg => __LINE__, 'No '; is_ex { \@{$result} } $error_msg => __LINE__, 'No '; is_ex { \%{$result} } $error_msg => __LINE__, 'No '; is_ex { $result->() } $error_msg => __LINE__, 'No '; is_ex { "" =~ $result } $error_msg => __LINE__, 'No '; is_ex { *{$result} } $error_msg => __LINE__, 'No '; is_ex { $result->no_such_method(); 1 } $error_msg => __LINE__, 'Non-existent method called'; done_testing(); Object-Result-0.000003/t/fail_msg_dollar_bang.t000644 000765 000765 00000002726 12572546314 020557 0ustar00damian000000 000000 use 5.014; use Test::More; use Object::Result; use Carp; sub is_ex (&$$$) { my ($block, $expected_err, $line, $desc) = @_; my $file = (caller 0)[1]; is eval{ $block->(); }, undef() => "$desc (threw exception)"; if ($ENV{LC_ALL} eq 'C') { like $@, qr{\Q$expected_err\E} => "$desc (right error message)"; } like $@, qr{at $file line $line} => "$desc (right error location)"; } sub code { return 'subroutine' } sub get_result { system('kjsadhkashdahsdlh'); result { {"Bad result: $!"} }; } my $CALL_LOC = __FILE__.' line '.__LINE__; my $result = get_result(); ok !$result => 'Boolean coercion'; my $error_msg = "Call to main::get_result() at $CALL_LOC failed because:\n" . " Bad result: No such file or directory\n" . "Failure detected"; is_ex { $result + 1 } $error_msg => __LINE__, 'No '; is_ex { int($result) } $error_msg => __LINE__, 'No '; is_ex { "$result" } $error_msg => __LINE__, 'No '; is_ex { ${$result} } $error_msg => __LINE__, 'No '; is_ex { \@{$result} } $error_msg => __LINE__, 'No '; is_ex { \%{$result} } $error_msg => __LINE__, 'No '; is_ex { $result->() } $error_msg => __LINE__, 'No '; is_ex { "" =~ $result } $error_msg => __LINE__, 'No '; is_ex { *{$result} } $error_msg => __LINE__, 'No '; is_ex { $result->no_such_method(); 1 } $error_msg => __LINE__, 'Non-existent method called'; done_testing(); Object-Result-0.000003/t/named_methods.t000644 000765 000765 00000003240 12355302533 017241 0ustar00damian000000 000000 use 5.014; use Test::More; use Object::Result; sub is_ex (&$$) { my ($block, $expected_err, $desc) = @_; my ($file, $line) = (caller 0)[1,2]; is eval{ $block->(); }, undef() => "$desc (threw exception)"; like $@, qr{\Q$expected_err\E} => "$desc (right error message)"; like $@, qr{at $file line $line} => "$desc (right error location)"; } sub get_result { result { check { return "checked" } test_it () { return "test" } verify ($word) { return "verified $word" } }; } my $CALL_LOC = __FILE__.' line '.__LINE__; my $result = get_result(); isa_ok $result, 'Object::Result::Object' => 'Correct return type'; ok $result => 'Boolean coercion'; is $result->check, 'checked' => '->check'; is $result->check(), 'checked' => '->check()'; is_ex { $result->check(1) } "In call to Object::Result::Object::check(), was given too many arguments; it expects 0" => '->check(1)'; is $result->test_it, 'test' => '->test_it'; is $result->test_it(), 'test' => '->test_it()'; is_ex { $result->test_it(1) } "In call to Object::Result::Object::test_it(), was given too many arguments; it expects 0" => '->test_it(1)'; is_ex { $result->verify } "In call to Object::Result::Object::verify(), missing required argument \$word" => '->verify'; is_ex { $result->verify() } "In call to Object::Result::Object::verify(), missing required argument \$word" => '->verify()'; is $result->verify('outcome'), 'verified outcome' => '->verify(outcome)'; is_ex { $result->no_such_method(); 1 } qq{Object returned by call to main::get_result() at $CALL_LOC\ndoesn't have method no_such_method()} => 'Non-existent method called'; done_testing(); Object-Result-0.000003/t/no_default_coercions.t000644 000765 000765 00000002550 12355146660 020630 0ustar00damian000000 000000 use 5.014; use Test::More; use Object::Result; use Carp; sub is_ex (&$$$) { my ($block, $expected_err, $line, $desc) = @_; my $file = (caller 0)[1]; is eval{ $block->(); }, undef() => "$desc (threw exception)"; like $@, qr{\Q$expected_err\E} => "$desc (right error message)"; like $@, qr{at $file line $line} => "$desc (right error location)"; } sub code { return 'subroutine' } sub get_result { result { { return 0 } { return \&code } }; } my $CALL_LOC = __FILE__.' line '.__LINE__; my $result = get_result(); ok !$result => 'Boolean coercion'; is $result->(), code() => 'Code deref'; my $error_msg = "Object returned by call to main::get_result() at $CALL_LOC\ncan't be used as "; is_ex { ${$result} } $error_msg . '' => __LINE__, 'No '; is_ex { \@{$result} } $error_msg . '' => __LINE__, 'No '; is_ex { \%{$result} } $error_msg . '' => __LINE__, 'No '; is_ex { "" =~ $result } $error_msg . '' => __LINE__, 'No '; is_ex { *{$result} } $error_msg . '' => __LINE__, 'No '; is_ex { $result + 1 } $error_msg . '' => __LINE__, 'No '; is_ex { int($result) } $error_msg . '' => __LINE__, 'No '; is_ex { "$result" } $error_msg . '' => __LINE__, 'No '; done_testing(); Object-Result-0.000003/t/true_false.t000644 000765 000765 00000000725 12355302722 016570 0ustar00damian000000 000000 use 5.014; use Test::More; use Object::Result; sub get_truth { result { value { 'truth' } }; } sub get_falsity { result { value { 'falsity' } }; } my $truth = get_truth(); ok $truth => 'default is true'; is $truth->value, 'truth' => 'Method works'; my $falsity = get_falsity(); ok !$falsity => ' is false'; is $falsity->value, 'falsity' => 'Method works'; done_testing(); Object-Result-0.000003/lib/Object/000755 000765 000765 00000000000 12572546632 015772 5ustar00damian000000 000000 Object-Result-0.000003/lib/Object/Result.pm000644 000765 000765 00000100136 12572546626 017612 0ustar00damian000000 000000 package Object::Result; use 5.014; use warnings; use autodie; our $VERSION = '0.000003'; use Method::Signatures; use Keyword::Simple; use Hash::Util::FieldHash 'fieldhash'; use PPI; # Storage for all inside-out result objects... fieldhash my %impl_of; # Create the new keyword in the caller scope... method import { Keyword::Simple::define 'result', func ($src_ref) { ${$src_ref} = _inject_result($src_ref); }; } # Remove the keyword upon request... method unimport { Keyword::Simple::undefine 'result'; } # Parse source cleanly and convert new syntax to old... func _inject_result ($src_ref) { state $WS = qr{ (?: \s++ | \# [^\n]*+ \n )*+ }x; # Check for missing argument (i.e. immediate semicolon or end-of-block)... my ($block) = ${$src_ref} =~ m{\A $WS ([;\}]) }xms; # Otherwise parse trailing source and extract top-level structure... my ($doc, $post_block_line_number); if (!$block) { # Convert empty block to block... ${$src_ref} =~ s{\A $WS \{ $WS \} }{ {} }xms; # Extract structure... $doc = PPI::Document->new($src_ref); $doc->index_locations; # First significant element should be a block... $block = $doc->schild(0)->schild(0)->remove; # Determine line number after block replacement... $post_block_line_number = (caller 1)[2] + $block->location->[0] + $block =~ tr/\n// - 1; } # If block, convert to a ctor call)... if (ref($block) && $block->isa("PPI::Structure::Block")) { return _transform_result->($block) . "\n#line $post_block_line_number\n" . $doc; } # Or a syntax error... else { _die_on_invalid_syntax($block); } } func _die_on_invalid_syntax ($block) { state $reclassify = { Word => 'identifier', DashedWord => 'identifier', Magic => 'variable', ArrayIndex => 'array index', Cast => 'operator', Single => 'character string', Double => 'character string', Interpolate => 'character string', Words => 'list constructor', Transliterate => 'transliteration', Match => 'regex match', Substitute => 'regex substitution', Data => 'end of source code', End => 'end of source code', Unknown => 'a syntax error', }; # Classify what we actually got... my $unexpected_construct = ref($block) || 'end of statement'; # Make classification more readable... $unexpected_construct =~ s{.*::}{}; $unexpected_construct = $reclassify->{$unexpected_construct} // $unexpected_construct; $unexpected_construct =~ s{Constructor}{$block =~ /^\{/ ? 'hashref' : 'arrayref' }e; $block =~ s{\n.*}{...}xms; # Report the error... _croak( "Invalid syntax for 'result' statement.\n", "Expected block but found \L$unexpected_construct\E ('$block') instead" ); } # Default behaviour on any use of a object... method _default_fail ($requested_coercion, ...) { my $object_impl = $impl_of{$self}; # Work out what to report... my $call_desc = sprintf( "call to %s() at %s line %s", @{$object_impl->{''}}[3,1,2] ); # Report it... _croak( "Object returned by $call_desc\ncan't be used as $requested_coercion" ); } # Default behaviour for coercion... method _default_bool (...) { return 1; } # This converts the 'result' block back to standard Perl 5... func _transform_result ($block) { # Initialize the ctor args with explicit empty list to allow leading commas thereafter... my $transformed_block = q{()}; # Extract and iterate components insode block... my @tokens = $block->schild(0)->schildren; TOKEN: while (my $token = shift @tokens) { # Consolidate coercions that were parsed as 3 tokens... if ($token eq '<' && @tokens >= 2 && $tokens[1] eq '>') { $token = join(q{}, "$token", splice(@tokens, 0, 2)); } # Classify token and trailing context... my $next_token_type = substr($tokens[0]//q{}, 0, 1); my $token_type = $token =~ / < [^)]* > /x ? 'coercion' : $token->isa('PPI::Token::Word') ? 'named' : 'other'; # Handle ... if ($token eq '') { my $MSG = $next_token_type eq '{' ? 'eval'.shift(@tokens) : q{}; my $CROAK_FAILURE = qq{ Object::Result::_croak_failure(\$self,errmsg=>\$errmsg,msg=>[$MSG]) }; $transformed_block .= q[ , do{ my $errmsg = $@ // $! // @?; my $tested; ] . q[ '' => method (...) { $tested++; 0 }, ] . qq[ '' => method (...) { \$tested++; $CROAK_FAILURE }, ] . qq[ '' => method (...) { \$tested++; $CROAK_FAILURE }, ] . qq[ '' => method (...) { $CROAK_FAILURE if !\$tested }, ] . q[ } ] ; next TOKEN; } # Handle syntax errors... elsif ($token_type ne 'other' && !@tokens) { _croak("Missing definition for $token() method"); } elsif ($token_type ne 'other' && $next_token_type !~ /[(\{]/) { _croak( "Invalid definition for $token() method\n", "Expected parameter list or method block, but found '$next_token_type'" ); } # Handle all coercions (with relaxed default parameter checking)... if ($token_type eq 'coercion') { $transformed_block .= " , '$token' => method "; $transformed_block .= '(...)' if $next_token_type ne '('; } # Handle bareword method names... elsif ($token_type eq 'named') { $transformed_block .= " , $token => method "; } # Pass anything else through unchanged... else { $transformed_block .= $token; } } # The transformed code needs Method::Signatures to function, so prepend it... return "{ use Method::Signatures; return Object::Result::_build_result { $transformed_block } }"; } # This builds type coercion subroutines... func _handler_for (@op_names) { # Convert each operator name to ... @op_names = map {"<$_>"} @op_names; # Each type coercion is a method... return method (...) { @_ = $self; # Find implementation of coercion or else default to normal behaviour... use List::Util 'first'; my $object_impl = $impl_of{$self}; my $op_name = first {exists $object_impl->{$_}} @op_names; # Fall back on handler... if (!defined $op_name) { $op_name = ''; my $call_desc = sprintf( "call to %s() at %s line %s", @{$object_impl->{''}}[3,1,2] ); push @_, $op_names[0], $call_desc; } # Grab the handler (if any)... my $method_impl = $object_impl->{$op_name}; # Fake out any error messages... no strict 'refs'; *{$object_impl->{''}[0].'::__ANON__'} = $op_name; # Execute the implementation of the coercion... goto &{$method_impl}; }; } # Ctor for Object::Result::Object objects... func _build_result ($hash_ref) { # The result object has to know where it was produced and how to fail... $hash_ref->{ '' } = [ caller 1 ]; $hash_ref->{ '' } //= \&_default_fail; $hash_ref->{ '' } //= \&_default_bool; # It's an inside-out object... my $newobj = bless \do{my $scalar}, 'Object::Result::Object'; # So it's internal data is cached inside the module... $impl_of{$newobj} = $hash_ref; # And it just returns an empty blessed scalar... return $newobj; } # Be invisible to carp and croak and lazy about importing them... $Carp::Internal{ (__PACKAGE__) }++; func _croak (@msg) { require Carp; Carp::croak( @msg ); } # Generate exceptions for ... method _croak_failure (:$errmsg, :$msg) { state $TRAILING_AT_LINE = qr{ \s++ at \s++ .+? \s++ line \s++ \d++ [\s\S]*+ \Z }xms; # Skip immediate caller unconditionally require Carp; local $Carp::CarpLevel = 1; # Define message... @$msg = grep { defined } @$msg; # Handle non-strings... if ( @$msg == 1 && ref($msg->[0]) ) { Carp::croak @$msg; } # Clean up message and locator... my $carp_where = Carp::shortmess( '' ); $carp_where =~ s{\A .* \s at \s }{}xms; my $carp_what = @$msg ? join( q{}, @$msg ) : $errmsg; $carp_what =~ s{ $TRAILING_AT_LINE }{}xms; $carp_what =~ s{ \s+ }{ }xms; if (length($carp_what) > 78) { $carp_what =~ s{ (? .{1,73} ) \Z | (? .{1,72} ) \s+ | (? .{1,72} [^\w\s] ) } { ': ' . (exists $+{line} ? "$+{line}\n" : $+{last}) }gexms; $carp_what = ":\n$carp_what\n:"; } elsif (length($carp_what) > 0) { $carp_what = " $carp_what"; } # Handle non-messages... die sprintf( "Call to %s() at %s line %s failed%s\nFailure detected at %s\n", @{$impl_of{$self}{''}}[3,1,2], ($carp_what ? " because:\n$carp_what" : q{}), $carp_where, ); } # The class of all result objects... package Object::Result::Object { use Method::Signatures; # Be invisible to carp and croak... $Carp::Internal{ (__PACKAGE__) }++; # Overload all possible coercions to call the corresponding type converter... use overload ( q{""} => Object::Result::_handler_for(qw[ STR ]), q{bool} => Object::Result::_handler_for(qw[ BOOL ]), q{int} => Object::Result::_handler_for(qw[ INT ]), q{0+} => Object::Result::_handler_for(qw[ NUM ]), q{qr} => Object::Result::_handler_for(qw[ REGEXP REGEXPREF REGEX REGEXREF ]), q{${}} => Object::Result::_handler_for(qw[ SCALAR SCALARREF ]), q{@{}} => Object::Result::_handler_for(qw[ ARRAY ARRAYREF ]), q{%{}} => Object::Result::_handler_for(qw[ HASH HASHREF ]), q{&{}} => Object::Result::_handler_for(qw[ CODE CODEREF SUB SUBREF ]), q{*{}} => Object::Result::_handler_for(qw[ GLOB GLOBREF ]), # With the usual magic autogeneration... fallback => 1, ); # All methods must be autoloaded, since each result object may have different methods... func AUTOLOAD ($self, ...) { # Work out the method name... our $AUTOLOAD; my $method_name = $AUTOLOAD =~ s/.*:://r; # Find the corresponding implementation for the object... my $object_impl = $impl_of{$self}; my $method_impl = $object_impl->{$method_name} // $object_impl->{''}; if (!defined $method_impl) { my $call_desc = sprintf( "call to %s() at %s line %s", @{$object_impl->{''}}[3,1,2] ); Object::Result::_croak( "Object returned by $call_desc\ndoesn't have method $method_name()" ); } # Fake out any internal error messages... no strict 'refs'; *{$object_impl->{''}[0].'::__ANON__'} = $method_name; # Execute the method implementation... goto &{$method_impl}; } # Because we have an AUTOLOAD(), we need this separate... func DESTROY ($self) { my $object_impl = $impl_of{$self}; # Execute destructor, faking out error messages... if (exists $object_impl->{''}) { no strict 'refs'; *{$object_impl->{''}[0].'::__ANON__'} = ''; goto &{$object_impl->{''}}; } } } 1; # Magic true value required at end of module __END__ =head1 NAME Object::Result - Allow subs to build and return objects on-the-fly =head1 VERSION This document describes Object::Result version 0.000003 =head1 SYNOPSIS use Object::Result; sub get_time { # Return an object indicating failure... if (!load Time::HiRes => 'time') { result { } } # Set up some lexical state information... my $time = time(); # Return an object with methods that use that information... result { # Named methods for returned object... timestamp { return scalar localtime($time) } delay (Num $offset) { $time += $offset } # Coercions for returned object... { $self->timestamp; } # String --> timestamp method { time() - $time; } # Number --> age of object { $self < 60; } # True for the first minute } }; # And later... # Get back an object... my $now = get_time(); # Use it (as a string, as an object, as a number)... say "It's $now"; say $now->timestamp; say 'Recent' if $now < 0.1; # Change the object's internal state... $now->delay(50); # Use the object as a (dynamically valued) boolean... while ($now) { sleep 5; say "Are we there yet?"; } =head1 DESCRIPTION This module adds a new keyword to Perl: C That keyword acts like a C, but instead of a list of values to return, it takes a single block which specifies the behaviour (i.e. the methods and operator overloading) of an object to be returned. The intention is to make it much less onerous to return clean, properly encapsulated objects...instead of returning lists of values or references to arrays or hashes. For example, instead of: my ($ID, $name, $uptime, $load, $users, $location, $contact) = get_server_status($server_ID); if ($uptime) { say "$ID ($name) load: $load"; } or: my $server = get_server_status($server_ID); if ($server->{uptime}) { say "$server->{ID} ($server->{name) load: $server->{load}"; } you can arrange the API to be object-based: my $server = get_server_status($server_ID); if ($server->is_up) { say $server->describe, ' load: ', $server->load; } The real advantage is that, inside the module providing C you don't have to define a separate class implementing the objects returned by that subroutine. More importantly, if you have a dozen subroutines returning specialized objects, you don't have to define a dozen separate classes to support them. =head2 RATIONALE I<(Skip straight ahead to L if you already get it...or just don't care why this approach is better.)> Subroutines that return lists of values make client code brittle: it's far too easy to mess up the unpacking: my ($ID, $name, $uptime, $users, $load, $contact, $location) = get_server_status($server_ID); Subroutines that return hash references aren't much better: they do keep all the information together, and eliminate the order dependency of unpacking it, but it's also very easy to misspell a key and thereby create a silent bug: my $server = get_server_status($server_ID); if ($server->{up_time}) { say "$server->{id} ($server->{name) load: $server->{load}"; } Like hashrefs, properly encapsulated objects keep all the returned information together and allow it to be retrieved by name, but they can also provide extra methods to simplify common tasks, and the OO syntax makes it a fatal error to misspell any access attempt: my $server = get_server_status($server_ID); if ($server->up_time) { say $server->describe, ' load: ', $server->lode; } # dies with: "No such method 'lode' at demo.pl line 27" The only downside is that object-based return values are tedious to set up. If you have multiple subroutines in your API, each of them may need to return a unique type of object, which means you have to define as many distinct support classes as you have subroutines. And even with helper modules (such as Moose or Object::InsideOut) that's a substantial amount of extra work: sub get_server_status ($server_ID) { my $status_ref = _acquire_status_somehow_for($server_ID); return GSS::Result->new(status => $status_ref); } # Class implementing result objects for get_server_status()... package GSS::Result { use Moose; has status => (is => 'ro', required => 1); sub ID { my $self = shift; $self->status->{ID} } sub name { my $self = shift; $self->status->{name} } sub uptime { my $self = shift; $self->status->{uptime} } sub load { my $self = shift; $self->status->{load} } sub users { my $self = shift; $self->status->{users} } sub location { my $self = shift; $self->status->{location} } sub contact { my $self = shift; $self->status->{contact} } sub is_up { my $self = shift; $self->uptime > 0 } sub describe { my $self = shift; $self->ID . ' (' . $self->name . ')'; } } The Object::Result module allows you to have your cake (per-subroutine return objects) without requiring quite so much baking (of per-subroutine support clases). =head1 INTERFACE The module lexically inserts a new keyword (C) into any scope when it is loaded. That keyword takes a single block of code containing zero or more method specifications, and builds an object which supplies those methods. The keyword then causes the surrounding subroutine to immediately return that object. =head2 Defining named methods To define a normal named method for the result object, specify its name followed by a block implementing its body. For example, to specify that the result object has two methods: C and C: result { succeeded { return $outcome > 0 } fitness { return $outcome * $sample->{metric} } } Methods may be specifed with parameter lists (which are implemented by the Method::Signatures module): result { succeeded (Num $threshold = 0) { return $outcome > $threshold } fitness { return $outcome * $sample->{metric} } } If not specified with a parameter list, C methods are assumed to take no arguments (which is Method::Signatures' default behaviour). =head1 Data storage for result objects Result methods get their information (e.g. C<$outcome> and C<$sample>) from the lexical variables declared in the surrounding subroutine. For example: sub estimate_fitness ($sample, $environment) { my $outcome = $sample->{metric} < $environment->{max_impact} ? $environment->{fitness_func}->($sample->{max}) : $environment->{max_survivability}; result { succeeded (Num $threshold = 0) { return $outcome > $threshold } fitness { return $outcome * $sample->{metric} } } } In other words, the various methods defined in the C block become closures over the variables inside the surrounding subroutine, and the result object can use those variables as its private storage (i.e. its attributes/fields). For example, the full C subroutine shown earlier in L could be implemented as: sub get_server_status ($server_ID) { my $status_ref = _acquire_status_somehow_for($server_ID); result { ID { $status_ref->{ID} } name { $status_ref->{name} } uptime { $status_ref->{uptime} } load { $status_ref->{load} } users { $status_ref->{users} } location { $status_ref->{location} } contact { $status_ref->{contact} } is_up { $status_ref->{uptime} > 0 } describe { "$status_ref->{ID} ($status_ref->{name})" } } using the lexical C<$status_ref> as the object's attribute storage. Note that methods can also modify this private data, so the result object from C could also support subsequent annotations on the result: sub get_server_status ($server_ID) { my $status_ref = _acquire_status_somehow_for($server_ID); my @annotations; result { # All the methods defined in the previous version, plus... add_note ($msg) { push @annotations, $msg; } get_notes { return @annotations; } } =head2 Coercions Perl allows classes to specify coercive overloadings, so that their objects can then be treated as if they were booleans, strings, numbers, integers, or references to scalars, arrays, hashes, regexes, subroutines, or typeglobs. The C keyword supports this kind of type-coercion too. Coercion methods can be specified by naming the specific type in angle brackets. For example, C could return a result object that is true only if the server is up, and which stringifies to a printable summary of the status, like so: sub get_server_status ($server_ID) { my $status_ref = _acquire_status_somehow_for($server_ID); result { # All the methods defined in the previous version, plus... { return $status_ref->{uptime} > 0; } { return $self->describe . ': ' $self->load; } } Note that, because all methods (named or coercive) are implemented via the Method::Signatures module, they automagically get a C<$self> variable. The following coercions are supported: Treat object as boolean: Treat object as string: Treat object as integer: Treat object as number: Treat object as scalar ref: Treat object as array ref: Treat object as hash ref: Treat object as typeblob ref/filehandle: Treat object as regex: or Treat object as subroutine ref: or In addition, the coercions to reference types can have the suffix C appended to their names (e.g. C<< >>, C<< >>, C<< >>, etc.) Coercion methods take no arguments (except the implicit C<$self>) and are expected to return either a value of the appropriate type, or some other object with a suitable coercion overloading (i.e. the same requirements as for coercions specified via C). By default, if a result object is asked for a particular coercion (apart from boolean; see L<"Boolean coercions">), but did not have that coercion explicitly defined, then the result object immediately throws an exception. See L<"Default coercions"> for a way to change this behaviour. head3 Boolean coercions By default, any result object that has at least one method or coercion defined will evaluate true in a boolean context...as if they all had the following coercion implicitly defined: result { { return 1 } ... } However, as a special case, result objects with no methods at all: result { } always evaluate false (besides having several other useful features; see L<"Result objects for failure signalling">). You can override these default boolean coercion behaviours simply by defining an explicit C<< >> coercion yourself: result { { return defined $outcome } ... } Or, if a result object has other methods, but should nevertheless always evaluate false, you can define that explicitly too: result { { return 0 } ... } Note, however, that in such cases it may be more effective to use a L|"Result objects for failure signalling">. =head3 Default coercions Although "missing" coercions default to throwing an exception, it's also possible to specify that something else should happen when an unimplemented coercion is requested...by using the C<< >> specifier. For example, to convert the normal exception-throwing response into merely warning about an unimplemented coercion: result { # Actual methods and coercions here ($requested_coercion, $obj_origin) { carp "Can't convert result of $obj_origin to $requested_coercion"; } } Or to revert the object to Perl's built-in behaviours (i.e. address-as-integer in a numeric context, C<"REFTYPE=CLASSNAME(0xADDRESS)"> in a string context, etc.) you could specify: result { # Actual methods and coercions here { return $self } } As the first example implies, the C<< >> coercion method is passed two extra arguments apart from the usual C<$self>. The first argument is a string containing the name of the missing coercion that was requested: C<< '' >>, or C<< '' >>, or C<< '' >>, etc. The second argument is a string indicating the origin of the result object being coerced. That second argument is of the form: 'call to __SUBNAME__() at __FILE__ line __LINE__' and may be useful for generating more informative warnings or errors within a C<< >> coercion. =head2 Cleaning up result objects If a result object manages some external resource, you can also set up a destructor for that object, using the C<< >> pseudo-coercion: sub open_output_file ($filename) { open my $fh, '>', $filename or croak $!; result { write (@whatever) { print @whatever; } writeln (@whatever) { say @whatever; } { return not $fh->eof } { return $fh } # Make sure file is flushed before closing... { $fh->flush(); $fh->close(); } } } =head2 Result objects for failure signalling The default behaviour of missing coercions provides an easy way to produce so-called I<"contingent exceptions"> (a.k.a. I<"failure objects">). In particular, a C statement of the form: result { } or its exact equivalent, an "empty" C: result { } returns an object that evaluates false in boolean contexts and throws an exception when used in any other way (i.e. whenever it has a method called on it, or it is used as a string, number, regex, or reference). The result object also throws an exception if it is destroyed without having been tested in a boolean context. That is, the two forms shown above are equivalent to something like: { my $tested_as_boolean = 0; my $error_msg = $@ // $! // $?; result { { $tested_as_boolean++; return 0; } { croak $error_msg; } { croak $error_msg if !$tested_as_boolean; } } } If you want the exceptions to throw something else, you can give the C<< >> specifier a block, which will then be called instead to generate the argument(s) to C<: # Throw a different string as the exception... result { { "Could not load file: $!" } } # Throw an exception object... result { { X::File::NoLoad->new($!) } } I such as these are a useful way of signalling errors, because the client code can test the result object (in which case it evaluates false like a typical C or C<0> or C<""> failure value): my $status = get_server_status(); if ($status) { # 'if' test fails if sub returned failure object say $status; } Or the client code can decide not to bother testing it, in which case it dies when used in any non-boolean way (or not used at all): my $status = get_server_status(); say $status; # Dies here if sub returned failure object Thus the exception-on-failure is contingent: it will be thrown if the object is used in (almost) any way, unless the failure object has been "defused" by testing it for in a boolean context. =head1 DIAGNOSTICS =head2 Compile-time diagnostics =over =item C<"Invalid syntax for 'result' statement. Expected block but found %s"> The C keyword take a single block after it. You put something else there instead. Maybe you just needed a regular C, instead of C? =item C<"Missing definition for %s method"> You declared the name of a method or coercion within the C's block, but didn't give it an implementation (i.e. a block of code for it to execute). =item C<"Invalid definition for %s method. Expected parameter list or method block, but found %s"> You declared the name of a method or coercion within the C's block, so the module next expected to see either a parameter list specification or else a block implementing the method or coercion. It reported the syntax error, because it found something else instead immediately after the method name. =back =head2 Run-time diagnostics =over =item C<"Object returned by %s can't be used as %s"> You tried to coerce a result object returned by C to some other type (a number, a string, a reference, etc.) but the C block didn't explicitly specify that coercion. Add the appropriate coercion specification to the C block. Or, if you just wanted the vanilla Perl behaviours when coercing such result objects, add: { $self } to the C block. =item C<"Call to %s failed: %s Failure detected at %s"> You called a subroutine that returned a I (i.e. a C<< result {} >>). Such I can only be tested for their boolean value. Doing anything else with them (or nothing at all with them) will produce this exception...because that's what C<< >> is supposed to do. =back =head1 CONFIGURATION AND ENVIRONMENT Object::Result requires no configuration files or environment variables. =head1 DEPENDENCIES =over =item Keyword::Simple To install the C keyword. =item PPI To parse the new C-block syntax cleanly. =item Method::Signatures To support signatures on methods declared within a C block. Also used internally within the module's own implementation. =back =head1 INCOMPATIBILITIES None reported. =head1 BUGS AND LIMITATIONS No bugs have been reported. Please report any bugs or feature requests to C, or through the web interface at L. =head1 AUTHOR Damian Conway C<< >> =head1 LICENCE AND COPYRIGHT Copyright (c) 2014, Damian Conway C<< >>. All rights reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. =head1 DISCLAIMER OF WARRANTY BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.