[Rt-commit] r5619 - in Scalar-Defer: . inc/Test t
audreyt at bestpractical.com
audreyt at bestpractical.com
Wed Jul 19 21:01:24 EDT 2006
Author: audreyt
Date: Wed Jul 19 21:01:23 2006
New Revision: 5619
Modified:
Scalar-Defer/Changes
Scalar-Defer/inc/Test/Builder.pm
Scalar-Defer/inc/Test/More.pm
Scalar-Defer/lib/Scalar/Defer.pm
Scalar-Defer/t/01-basic.t
Log:
* This be 0.05.
* Calling methods on a deferred value now works correctly.
* Deferred values are now blessed into the "0" package, which means
Scalar::Util::blessed() and ref() will both return false on them.
* The ->force method is now replaced by an exported "force"
function instead.
Modified: Scalar-Defer/Changes
==============================================================================
--- Scalar-Defer/Changes (original)
+++ Scalar-Defer/Changes Wed Jul 19 21:01:23 2006
@@ -1,3 +1,13 @@
+[Changes for 0.05 - 2006-07-19]
+
+* Calling methods on a deferred value now works correctly.
+
+* Deferred values are now blessed into the "0" package, which means
+ Scalar::Util::blessed() and ref() will both return false on them.
+
+* The ->force method is now replaced by an exported "force"
+ function instead.
+
[Changes for 0.04 - 2006-07-19]
* Document the ->force method for getting a normal value out of a
Modified: Scalar-Defer/inc/Test/Builder.pm
==============================================================================
--- Scalar-Defer/inc/Test/Builder.pm (original)
+++ Scalar-Defer/inc/Test/Builder.pm Wed Jul 19 21:01:23 2006
@@ -9,7 +9,7 @@
use strict;
use vars qw($VERSION);
-$VERSION = '0.32';
+$VERSION = '0.33';
$VERSION = eval $VERSION; # make the alpha version come out as a number
# Make Test::Builder thread-safe for ithreads.
Modified: Scalar-Defer/inc/Test/More.pm
==============================================================================
--- Scalar-Defer/inc/Test/More.pm (original)
+++ Scalar-Defer/inc/Test/More.pm Wed Jul 19 21:01:23 2006
@@ -17,7 +17,7 @@
use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
-$VERSION = '0.62';
+$VERSION = '0.64';
$VERSION = eval $VERSION; # make the alpha version come out as a number
use Test::Builder::Module;
@@ -130,6 +130,12 @@
my $class = ref $proto || $proto;
my $tb = Test::More->builder;
+ unless( $class ) {
+ my $ok = $tb->ok( 0, "->can(...)" );
+ $tb->diag(' can_ok() called with empty class or reference');
+ return $ok;
+ }
+
unless( @methods ) {
my $ok = $tb->ok( 0, "$class->can(...)" );
$tb->diag(' can_ok() called with no methods');
@@ -146,7 +152,7 @@
my $name;
$name = @methods == 1 ? "$class->can('$methods[0]')"
: "$class->can(...)";
-
+
my $ok = $tb->ok( !@nok, $name );
$tb->diag(map " $class->can('$_') failed\n", @nok);
@@ -154,7 +160,7 @@
return $ok;
}
-#line 519
+#line 525
sub isa_ok ($$;$) {
my($object, $class, $obj_name) = @_;
@@ -209,7 +215,7 @@
}
-#line 589
+#line 595
sub pass (;$) {
my $tb = Test::More->builder;
@@ -221,7 +227,7 @@
$tb->ok(0, @_);
}
-#line 650
+#line 656
sub use_ok ($;@) {
my($module, @imports) = @_;
@@ -263,7 +269,7 @@
return $ok;
}
-#line 699
+#line 705
sub require_ok ($) {
my($module) = shift;
@@ -306,7 +312,7 @@
$module =~ /^[a-zA-Z]\w*$/;
}
-#line 775
+#line 781
use vars qw(@Data_Stack %Refs_Seen);
my $DNE = bless [], 'Does::Not::Exist';
@@ -407,7 +413,7 @@
return '';
}
-#line 915
+#line 921
sub diag {
my $tb = Test::More->builder;
@@ -416,7 +422,7 @@
}
-#line 984
+#line 990
#'#
sub skip {
@@ -430,6 +436,11 @@
$how_many = 1;
}
+ if( defined $how_many and $how_many =~ /\D/ ) {
+ _carp "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?";
+ $how_many = 1;
+ }
+
for( 1..$how_many ) {
$tb->skip($why);
}
@@ -439,7 +450,7 @@
}
-#line 1066
+#line 1077
sub todo_skip {
my($why, $how_many) = @_;
@@ -460,7 +471,7 @@
last TODO;
}
-#line 1119
+#line 1130
sub BAIL_OUT {
my $reason = shift;
@@ -469,7 +480,7 @@
$tb->BAIL_OUT($reason);
}
-#line 1158
+#line 1169
#'#
sub eq_array {
@@ -593,7 +604,7 @@
}
-#line 1289
+#line 1300
sub eq_hash {
local @Data_Stack;
@@ -626,7 +637,7 @@
return $ok;
}
-#line 1346
+#line 1357
sub eq_set {
my($a1, $a2) = @_;
@@ -652,6 +663,6 @@
);
}
-#line 1534
+#line 1545
1;
Modified: Scalar-Defer/lib/Scalar/Defer.pm
==============================================================================
--- Scalar-Defer/lib/Scalar/Defer.pm (original)
+++ Scalar-Defer/lib/Scalar/Defer.pm Wed Jul 19 21:01:23 2006
@@ -1,28 +1,48 @@
package Scalar::Defer;
-$Scalar::Defer::VERSION = '0.04';
+$Scalar::Defer::VERSION = '0.05';
use 5.006;
use strict;
use warnings;
+use overload ();
use Exporter::Lite;
use Class::InsideOut qw( private register id );
-our @EXPORT = qw( lazy defer );
+our @EXPORT = qw( lazy defer force );
private _defer => my %_defer;
-use overload fallback => 1, map {
- $_ => \&force
-} qw( bool "" 0+ ${} @{} %{} &{} *{} );
+BEGIN {
+ overload::OVERLOAD( 0 => fallback => 1, map {
+ $_ => sub { &{$_defer{ Class::InsideOut::id $_[0] }} }
+ } qw( bool "" 0+ ${} @{} %{} &{} *{} ));
+
+ no strict 'refs';
+ *{"0::AUTOLOAD"} = sub {
+ my $meth = our $AUTOLOAD;
+ my $idx = index($meth, '::');
+ if ($idx >= 0) {
+ $meth = substr($meth, $idx + 2);
+ }
-sub force ($) {
- &{$_defer{ id $_[0] }}
+ unshift @_, force(shift());
+ goto &{$_[0]->can($meth)};
+ };
+
+ foreach my $sym (keys %UNIVERSAL::) {
+ *{"0::$sym"} = sub {
+ unshift @_, force(shift());
+ goto &{$_[0]->can($sym)};
+ };
+ }
+
+ *{"0::DESTROY"} = \&DESTROY;
}
sub defer (&) {
my $cv = shift;
my $obj = register( bless \(my $s), __PACKAGE__ );
$_defer{ id $obj } = $cv;
- return $obj;
+ bless($obj => 0);
}
sub lazy (&) {
@@ -32,7 +52,11 @@
$_defer{ id $obj } = sub {
$forced ? $value : scalar (++$forced, $value = &$cv)
};
- return $obj;
+ bless($obj => 0);
+}
+
+sub force ($) {
+ &{$_defer{ id $_[0] or return $_[0]}}
}
1;
@@ -54,14 +78,15 @@
print "$dv $dv $dv"; # 1 2 3
print "$lv $lv $lv"; # 1 1 1
- my $forced = $dv->force; # force a normal value out of $dv
+ my $forced = force $dv; # force a normal value out of $dv
print "$forced $forced $forced"; # 4 4 4
=head1 DESCRIPTION
This module exports two functions, C<defer> and C<lazy>, for building
-values that are evaluated on demand.
+values that are evaluated on demand. It also exports a C<force> function
+to force evaluation of a deferred value.
=head2 defer {...}
@@ -74,12 +99,17 @@
Like C<defer>, except the value is computed at most once. Subsequent
evaluation will simply use the cached result.
-=head2 $value->force
+=head2 force $value
-Force calculation of a deferred/lazy value and return a normal value.
+Force evaluation of a deferred value to return a normal value.
+If C<$value> was already normal value, then C<force> simply returns it.
=head1 NOTES
+Deferred values are not considered objects (C<ref> on them returns C<0>),
+although you can still call methods on them, in which case the invocant
+is always the forced value.
+
Unlike the C<tie>-based L<Data::Lazy>, this module operates on I<values>,
not I<variables>. Therefore, assigning into C<$dv> and C<$lv> above will
simply replace the value, instead of triggering a C<STORE> method call.
Modified: Scalar-Defer/t/01-basic.t
==============================================================================
--- Scalar-Defer/t/01-basic.t (original)
+++ Scalar-Defer/t/01-basic.t Wed Jul 19 21:01:23 2006
@@ -1,4 +1,4 @@
-use Test::More tests => 7;
+use Test::More tests => 14;
use ok 'Scalar::Defer';
my ($x, $y);
@@ -10,6 +10,20 @@
is($l, 1, "but lazy stays at 1");
isnt($d, $l, "3 != 1");
-my $forced = $d->force;
-is($forced, 4, "->force works");
-is($forced, 4, "->force is stable");
+my $forced = force $d;
+is($forced, 4, 'force($x) works');
+is($forced, 4, 'force($x) is stable');
+is(force $forced, 4, 'force(force($x)) is stable');
+
+$SomeClass::VERSION = 42;
+sub SomeClass::meth { 'meth' };
+sub SomeClass::new { bless(\@_, $_[0]) }
+
+my $obj = defer { SomeClass->new };
+
+ok(!ref($obj), 'ref() returns false for deferred values');
+is(ref(force $obj), 'SomeClass', 'ref() returns true for forced values');
+is($obj->meth, 'meth', 'method call works on deferred objects');
+is($obj->can('meth'), SomeClass->can('meth'), '->can works too');
+ok($obj->isa('SomeClass'), '->isa works too');
+is($obj->VERSION, $SomeClass::VERSION, '->VERSION works too');
More information about the Rt-commit
mailing list