Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

add Data::Thunk::Object

  • Loading branch information...
commit 7d60a0c4c1085ac3ff987ec4cdc4681e09ece1a1 1 parent bb014d8
@nothingmuch authored
Showing with 154 additions and 2 deletions.
  1. +34 −1 lib/Data/Thunk.pm
  2. +78 −0 lib/Data/Thunk/Object.pm
  3. +42 −1 t/01-basic.t
View
35 lib/Data/Thunk.pm
@@ -7,6 +7,7 @@ use warnings;
use Data::Thunk::Code;
use Data::Thunk::ScalarValue;
+use Data::Thunk::Object;
use Scalar::Util qw(blessed);
@@ -14,13 +15,25 @@ use base qw(Exporter);
our $VERSION = "0.01";
-our @EXPORT = our @EXPORT_OK = qw(lazy force);
+our @EXPORT = our @EXPORT_OK = qw(lazy lazy_new lazy_object force);
sub lazy (&) {
my $thunk = shift;
bless { code => $thunk }, "Data::Thunk::Code";
}
+sub lazy_new ($;@) {
+ my ( $class, %args ) = @_;
+ my $constructor = delete $args{constructor} || 'new';
+ my $args = delete $args{args} || [];
+ &lazy_object(sub { $class->$constructor(@$args) }, %args, class => $class);
+}
+
+sub lazy_object (&;@) {
+ my ( $thunk, @args ) = @_;
+ bless { @args, code => $thunk }, "Data::Thunk::Object";
+}
+
my ( $vivify_code, $vivify_scalar ) = ( $Data::Thunk::Code::vivify_code, $Data::Thunk::ScalarValue::vivify_scalar );
sub force ($) {
@@ -131,6 +144,26 @@ become objects don't appear to be as such.
Create a new thunk.
+=item lazy_object { }, %attrs;
+
+Creates a thunk that is expected to be an object.
+
+If the C<class> attribute is provided then C<isa> and C<can> will work as class
+methods without vivifying the object.
+
+Any other attributes in %attrs will be used to shadow method calls. If the keys
+are code references they will be invoked, otherwise they will be simply
+returned as values. This can be useful if some of your object's properties are
+known in advance.
+
+=item lazy_new $class, %args;
+
+A specialization on C<lazy_object> that can call a constructor method based on
+a class for you. The C<constructor> and C<args> arguments (method name or code
+ref, and array reference) will be removed from %args to create the thunk. They
+default to C<new> and an empty array ref by default. Then this function
+delegates to C<lazy_object>.
+
=item force
Vivify the value and return the result.
View
78 lib/Data/Thunk/Object.pm
@@ -0,0 +1,78 @@
+#!/usr/bin/perl
+
+package Data::Thunk::Object;
+use base qw(Data::Thunk::Code);
+
+use strict;
+use warnings;
+
+use UNIVERSAL::ref;
+use Scalar::Util ();
+
+our $get_field = sub {
+ my ( $obj, $field ) = @_;
+
+ my $thunk_class = Scalar::Util::blessed($obj) or return;
+ bless $obj, "Data::Thunk::NoOverload";
+
+ my $exists = exists $obj->{$field};
+ my $value = $obj->{$field};
+
+ bless $obj, $thunk_class;
+
+ # ugly, but it works
+ return ( wantarray
+ ? ( $exists, $value )
+ : $value );
+};
+
+sub ref {
+ my ( $self, @args ) = @_;
+
+ if ( my $class = $self->$get_field("class") ) {
+ return $class;
+ } else {
+ return $self->SUPER::ref(@args);
+ }
+}
+
+
+foreach my $sym (keys %UNIVERSAL::) {
+ next if $sym eq 'ref::';
+ no strict 'refs';
+ *{$sym} = eval "sub {
+ my ( \$self, \@args ) = \@_;
+
+ if ( my \$class = \$self->\$get_field('class') ) {
+ return \$class->$sym(\@args);
+ } else {
+ return \$self->SUPER::$sym(\@args);
+ }
+ }";
+
+ warn $@ if $@;
+}
+
+sub AUTOLOAD {
+ my ( $self, @args ) = @_;
+ my ( $method ) = ( our $AUTOLOAD =~ /([^:]+)$/ );
+
+ if ( $method !~ qr/^(?: class | code )$/ ) {
+ my ( $exists, $value ) = $self->$get_field($method);
+
+ if ( $exists ) {
+ if ( (reftype($value)||'') eq 'CODE' ) {
+ return $self->$value(@args);
+ } else {
+ return $value;
+ }
+ }
+ }
+
+ unshift @_, $method;
+ goto $Data::Thunk::Code::vivify_and_call;
+}
+
+__PACKAGE__
+
+__END__
View
43 t/01-basic.t
@@ -1,6 +1,8 @@
-use Test::More tests => 14;
+use Test::More tests => 35;
use ok 'Data::Thunk';
+use Scalar::Util qw(reftype);
+
my $y = 0;
my $l = lazy { ++$y };
@@ -26,3 +28,42 @@ is(lazy { SomeClass->new }->meth, 'meth', 'method call works on deferred objects
is(lazy { SomeClass->new }->can('meth'), SomeClass->can('meth'), '->can works too');
ok(lazy { SomeClass->new }->isa('SomeClass'), '->isa works too');
is(lazy { SomeClass->new }->VERSION, SomeClass->VERSION, '->VERSION works too');
+
+my $new = 0;
+@OtherClass::ISA = qw(Bar);
+sub Bar::flarp { "flarp" }
+sub OtherClass::new { $new++; bless(\@_, $_[0]) };
+
+is( $new, 0, "new not called" );
+
+my $obj = lazy_new "OtherClass", args => [ "blah" ];
+is( $new, 0, "new not called" );
+
+is( reftype($obj), "HASH", "hash reftype" );
+is( $new, 0, "new not called" );
+
+is( ref($obj), "OtherClass", "reported class" );
+is( $new, 0, "new not called" );
+
+ok( $obj->isa("Bar"), "object isa bar" );
+is( $new, 0, "new not called" );
+
+can_ok( $obj, "flarp" );
+is( $new, 0, "new not called" );
+
+is( $obj->flarp, "flarp", "flarp method" );
+is( $new, 1, "new called once" );
+
+is( reftype($obj), "ARRAY", "hash reftype" );
+is( $new, 1, "new called once" );
+
+is_deeply( $obj, bless([ OtherClass => "blah" ], "OtherClass"), "structure" );
+is( $new, 1, "new called once" );
+
+is( ref($obj), "OtherClass", "reported class" );
+is( $new, 1, "new called once" );
+
+can_ok( $obj, "flarp" );
+ok( $obj->isa("Bar"), "object isa bar" );
+
+is( $new, 1, "new called once" );
Please sign in to comment.
Something went wrong with that request. Please try again.