From: hdp Date: Tue, 29 Jan 2008 13:11:01 +0000 (+0000) Subject: import 0.001 X-Git-Tag: 0.003~5 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=644682682772cbb1724ee6cabfeee4b8a66bd457;p=gitmo%2FMooseX-InsideOut.git import 0.001 --- diff --git a/Changes b/Changes new file mode 100644 index 0000000..5a77371 --- /dev/null +++ b/Changes @@ -0,0 +1,5 @@ +Revision history for MooseX-InsideOut + +0.001 Thu, 24 Jan 2008 13:17:54 -0500 + + * first release; thanks to stevan and mst for help diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..b15f723 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,30 @@ +Changes +MANIFEST +Makefile.PL +README +t/lib/InsideOut/SubHash.pm +t/lib/InsideOut/BaseMoose.pm +t/lib/InsideOut/SubIO.pm +t/lib/InsideOut/BaseArray.pm +t/lib/InsideOut/BaseHash.pm +t/lib/InsideOut/BaseIO.pm +t/lib/InsideOut/SubMoose.pm +t/lib/InsideOut/SubArray.pm +t/pod.t +t/sub.t +t/00-load.t +t/pod-coverage.t +lib/MooseX/InsideOut/Meta/Class.pm +lib/MooseX/InsideOut/Meta/Instance.pm +lib/MooseX/InsideOut.pm +inc/Module/Install/Can.pm +inc/Module/Install/Base.pm +inc/Module/Install/Win32.pm +inc/Module/Install/WriteAll.pm +inc/Module/Install/AutoInstall.pm +inc/Module/Install/Makefile.pm +inc/Module/Install/Fetch.pm +inc/Module/Install/Include.pm +inc/Module/Install/Metadata.pm +inc/Module/Install.pm +inc/Module/AutoInstall.pm diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..4ff0bcd --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,16 @@ +use inc::Module::Install; + +name 'MooseX-InsideOut'; +all_from 'lib/MooseX/InsideOut.pm'; +author 'Hans Dieter Pearcey '; + +build_requires 'Test::More'; + +requires 'Moose' => '0.35'; +requires 'Hash::Util::FieldHash::Compat' => 0; +requires 'Task::Weaken' => 0; + +auto_install; + +WriteAll; + diff --git a/README b/README new file mode 100644 index 0000000..ea967cb --- /dev/null +++ b/README @@ -0,0 +1,40 @@ +MooseX-InsideOut + +INSTALLATION + +To install this module, run the following commands: + + perl Makefile.PL + make + make test + make install + +SUPPORT AND DOCUMENTATION + +After installing, you can find documentation for this module with the +perldoc command. + + perldoc MooseX::InsideOut + +You can also look for information at: + + RT, CPAN's request tracker + http://rt.cpan.org/NoAuth/Bugs.html?Dist=MooseX-InsideOut + + AnnoCPAN, Annotated CPAN documentation + http://annocpan.org/dist/MooseX-InsideOut + + CPAN Ratings + http://cpanratings.perl.org/d/MooseX-InsideOut + + Search CPAN + http://search.cpan.org/dist/MooseX-InsideOut + + +COPYRIGHT AND LICENCE + +Copyright (C) 2008 Hans Dieter Pearcey + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + diff --git a/lib/MooseX/InsideOut.pm b/lib/MooseX/InsideOut.pm new file mode 100644 index 0000000..4b54e13 --- /dev/null +++ b/lib/MooseX/InsideOut.pm @@ -0,0 +1,114 @@ +use strict; +use warnings; + +package MooseX::InsideOut; + +use metaclass 'MooseX::InsideOut::Meta::Class'; +use Moose; + +1; +__END__ + +=head1 NAME + +MooseX::InsideOut - inside-out objects with Moose + +=head1 VERSION + +Version 0.001 + +=cut + +our $VERSION = '0.001'; + +=head1 SYNOPSIS + + package My::Object; + + use Moose; + extends 'MooseX::InsideOut'; + + # ... normal Moose functionality + # or ... + + package My::Subclass; + + use metaclass 'MooseX::InsideOut::Meta::Class'; + use Moose; + extends 'Some::Other::Class; + +=head1 DESCRIPTION + +MooseX::InsideOut provides a metaclass and an instance metaclass for inside-out +objects. + +You can use MooseX::InsideOut as a normal base class, as in the first example +in the L. + +You can also use the metaclass C directly, as +in the second example. This is most useful when extending a non-Moose class, +whose internals you either don't want to care about or aren't hash-based. + +=head1 TODO + +=over + +=item * dumping (for debugging purposes) + +=item * serialization (for e.g. storable) + +=item * (your suggestions here) + +=back + +=head1 AUTHOR + +Hans Dieter Pearcey, C<< >> + +=head1 BUGS + +Please report any bugs or feature requests to C, or through +the web interface at L. I will be notified, and then you'll +automatically be notified of progress on your bug as I make changes. + +=head1 SUPPORT + +You can find documentation for this module with the perldoc command. + + perldoc MooseX::InsideOut + + +You can also look for information at: + +=over 4 + +=item * RT: CPAN's request tracker + +L + +=item * AnnoCPAN: Annotated CPAN documentation + +L + +=item * CPAN Ratings + +L + +=item * Search CPAN + +L + +=back + + +=head1 ACKNOWLEDGEMENTS + + +=head1 COPYRIGHT & LICENSE + +Copyright 2008 Hans Dieter Pearcey. + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut diff --git a/lib/MooseX/InsideOut/Meta/Class.pm b/lib/MooseX/InsideOut/Meta/Class.pm new file mode 100644 index 0000000..e5984d3 --- /dev/null +++ b/lib/MooseX/InsideOut/Meta/Class.pm @@ -0,0 +1,35 @@ +use strict; +use warnings; + +package MooseX::InsideOut::Meta::Class; + +# need to load this before loading Moose and using it as a metaclass, because +# of circularity +use MooseX::InsideOut::Meta::Instance; +use Moose; +extends 'Moose::Meta::Class'; + +sub initialize { + my $class = shift; + my $pkg = shift; + $class->SUPER::initialize( + $pkg, + instance_metaclass => 'MooseX::InsideOut::Meta::Instance', + @_, + ); +} + +# this seems like it should be part of Moose::Meta::Class +sub construct_instance { + my ($class, %params) = @_; + my $meta_instance = $class->get_meta_instance; + my $instance = $params{'__INSTANCE__'} + || $meta_instance->create_instance(); + foreach my $attr ($class->compute_all_applicable_attributes()) { + my $meta_instance = $attr->associated_class->get_meta_instance; + $attr->initialize_instance_slot($meta_instance, $instance, \%params); + } + return $instance; +} + +1; diff --git a/lib/MooseX/InsideOut/Meta/Instance.pm b/lib/MooseX/InsideOut/Meta/Instance.pm new file mode 100644 index 0000000..e722809 --- /dev/null +++ b/lib/MooseX/InsideOut/Meta/Instance.pm @@ -0,0 +1,89 @@ +use strict; +use warnings; + +package MooseX::InsideOut::Meta::Instance; + +use Moose; +extends 'Moose::Meta::Instance'; + +use Hash::Util::FieldHash::Compat qw(fieldhash); +use Scalar::Util qw(refaddr weaken); + +# don't touch this or I beat you +# this is only a package variable for inlinability +fieldhash our %__attr; + +sub create_instance { + my ($self) = @_; + + #my $instance = \(my $dummy); + my $instance = $self->SUPER::create_instance; + + $__attr{refaddr $instance} = {}; + return bless $instance => $self->associated_metaclass->name; +} + +sub get_slot_value { + my ($self, $instance, $slot_name) = @_; + + return $__attr{refaddr $instance}->{$slot_name}; +} + +sub set_slot_value { + my ($self, $instance, $slot_name, $value) = @_; + + return $__attr{refaddr $instance}->{$slot_name} = $value; +} + +sub deinitialize_slot { + my ($self, $instance, $slot_name) = @_; + + return delete $__attr{refaddr $instance}->{$slot_name}; +} + +sub is_slot_initialized { + my ($self, $instance, $slot_name) = @_; + + return exists $__attr{refaddr $instance}->{$slot_name}; +} + +sub weaken_slot_value { + my ($self, $instance, $slot_name) = @_; + + weaken $__attr{refaddr $instance}->{$slot_name}; +} + +sub inline_create_instance { + my ($self, $class_variable) = @_; + return join '', + #'my $instance = \(my $dummy);', + # hardcoding superclass -- can't think of a good way to avoid that + 'my $instance = Moose::Meta::Instance->create_instance;', + sprintf( + '$%s::__attr{%s} = {};', + __PACKAGE__, + 'Scalar::Util::refaddr($instance)', + ), + sprintf( + 'bless $instance => %s;', + $class_variable, + ), + ; +} + +sub inline_slot_access { + my ($self, $instance, $slot_name) = @_; + return sprintf '$%s::__attr{%s}->{%s}', + __PACKAGE__, + 'Scalar::Util::refaddr ' . $instance, + $slot_name, + ; +} + +sub __dump { + my ($class, $instance) = @_; + require Data::Dumper; + return Data::Dumper::Dumper($__attr{refaddr $instance}); +} + +1; diff --git a/t/00-load.t b/t/00-load.t new file mode 100644 index 0000000..7fae638 --- /dev/null +++ b/t/00-load.t @@ -0,0 +1,9 @@ +#!perl -T + +use Test::More tests => 1; + +BEGIN { + use_ok( 'MooseX::InsideOut' ); +} + +diag( "Testing MooseX::InsideOut $MooseX::InsideOut::VERSION, Perl $], $^X" ); diff --git a/t/lib/InsideOut/BaseArray.pm b/t/lib/InsideOut/BaseArray.pm new file mode 100644 index 0000000..33098e4 --- /dev/null +++ b/t/lib/InsideOut/BaseArray.pm @@ -0,0 +1,22 @@ +use strict; +use warnings; + +package InsideOut::BaseArray; + +use constant FOO => 0; + +sub new { + my $class = shift; + my %p = @_; + my $self = bless [] => $class; + $self->[FOO] = $p{base_foo}; + return $self; +} + +sub base_foo { + my $self = shift; + if (@_) { $self->[FOO] = shift } + return $self->[FOO]; +} + +1; diff --git a/t/lib/InsideOut/BaseHash.pm b/t/lib/InsideOut/BaseHash.pm new file mode 100644 index 0000000..fa7abe5 --- /dev/null +++ b/t/lib/InsideOut/BaseHash.pm @@ -0,0 +1,17 @@ +use strict; +use warnings; + +package InsideOut::BaseHash; + +sub new { + my $class = shift; + bless {@_} => $class; +} + +sub base_foo { + my $self = shift; + $self->{base_foo} = shift if @_; + return $self->{base_foo}; +} + +1; diff --git a/t/lib/InsideOut/BaseIO.pm b/t/lib/InsideOut/BaseIO.pm new file mode 100644 index 0000000..23311cc --- /dev/null +++ b/t/lib/InsideOut/BaseIO.pm @@ -0,0 +1,13 @@ +use strict; +use warnings; + +package InsideOut::BaseIO; + +use Moose; +extends 'MooseX::InsideOut'; + +has base_foo => ( + is => 'rw', +); + +1; diff --git a/t/lib/InsideOut/BaseMoose.pm b/t/lib/InsideOut/BaseMoose.pm new file mode 100644 index 0000000..54b5636 --- /dev/null +++ b/t/lib/InsideOut/BaseMoose.pm @@ -0,0 +1,10 @@ +use strict; +use warnings; + +package InsideOut::BaseMoose; + +use Moose; + +has base_foo => ( is => 'rw' ); + +1; diff --git a/t/lib/InsideOut/SubArray.pm b/t/lib/InsideOut/SubArray.pm new file mode 100644 index 0000000..b2a68e8 --- /dev/null +++ b/t/lib/InsideOut/SubArray.pm @@ -0,0 +1,13 @@ +use strict; +use warnings; + +package InsideOut::SubArray; + +use metaclass 'MooseX::InsideOut::Meta::Class'; +use Moose; +extends 'InsideOut::BaseArray'; + +has sub_foo => ( is => 'rw' ); + +1; + diff --git a/t/lib/InsideOut/SubHash.pm b/t/lib/InsideOut/SubHash.pm new file mode 100644 index 0000000..8ceb3ad --- /dev/null +++ b/t/lib/InsideOut/SubHash.pm @@ -0,0 +1,12 @@ +use strict; +use warnings; + +package InsideOut::SubHash; + +use metaclass 'MooseX::InsideOut::Meta::Class'; +use Moose; +extends 'InsideOut::BaseHash'; + +has sub_foo => ( is => 'rw' ); + +1; diff --git a/t/lib/InsideOut/SubIO.pm b/t/lib/InsideOut/SubIO.pm new file mode 100644 index 0000000..0d74e80 --- /dev/null +++ b/t/lib/InsideOut/SubIO.pm @@ -0,0 +1,12 @@ +use strict; +use warnings; + +package InsideOut::SubIO; + +use metaclass 'MooseX::InsideOut::Meta::Class'; +use Moose; +extends 'InsideOut::BaseIO'; + +has sub_foo => ( is => 'rw' ); + +1; diff --git a/t/lib/InsideOut/SubMoose.pm b/t/lib/InsideOut/SubMoose.pm new file mode 100644 index 0000000..34e959a --- /dev/null +++ b/t/lib/InsideOut/SubMoose.pm @@ -0,0 +1,13 @@ +use strict; +use warnings; + +package InsideOut::SubMoose; + +use metaclass 'MooseX::InsideOut::Meta::Class'; +use Moose; +extends 'InsideOut::BaseMoose'; + +has sub_foo => ( is => 'rw' ); + +1; + diff --git a/t/pod-coverage.t b/t/pod-coverage.t new file mode 100644 index 0000000..9124c55 --- /dev/null +++ b/t/pod-coverage.t @@ -0,0 +1,21 @@ +use strict; +use warnings; +use Test::More; + +plan skip_all => "set \$ENV{TEST_POD} to test POD coverage" + unless $ENV{TEST_POD}; + +# Ensure a recent version of Test::Pod::Coverage +my $min_tpc = 1.08; +eval "use Test::Pod::Coverage $min_tpc"; +plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" + if $@; + +# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, +# but older versions don't recognize some common documentation styles +my $min_pc = 0.18; +eval "use Pod::Coverage $min_pc"; +plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" + if $@; + +all_pod_coverage_ok(); diff --git a/t/pod.t b/t/pod.t new file mode 100644 index 0000000..ee8b18a --- /dev/null +++ b/t/pod.t @@ -0,0 +1,12 @@ +#!perl -T + +use strict; +use warnings; +use Test::More; + +# Ensure a recent version of Test::Pod +my $min_tp = 1.22; +eval "use Test::Pod $min_tp"; +plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; + +all_pod_files_ok(); diff --git a/t/sub.t b/t/sub.t new file mode 100644 index 0000000..db19df9 --- /dev/null +++ b/t/sub.t @@ -0,0 +1,47 @@ +use strict; +use warnings; +use Test::More tests => 28; + +use lib 't/lib'; +my @classes = qw(IO Array Hash Moose); + +my %TODO = ( +# Moose => "don't clobber superclass' meta's create_instance", +); + +for my $c (@classes) { + my $base = "InsideOut::Base$c"; + my $sub = "InsideOut::Sub$c"; + eval "require $base;1" or die $@; + eval "require $sub;1" or die $@; + + my $obj = eval { $sub->new(base_foo => 17) }; + is($@, "", "$c: no errors creating object"); + + { + local $TODO = $TODO{$c} if exists $TODO{$c}; + + my $get = eval { $obj->base_foo }; + is($@, "", "$c: no errors getting attribute"); + is($get, 17, "$c: base_foo is 17"); + + my $set_base = eval { + $obj->base_foo(18); + $obj->base_foo; + }; + is($@, "", "$c: no errors setting base class attribute"); + is($set_base, 18, "$c: base_foo is 18"); + } + + my $set_sub = eval { + $obj->sub_foo(23); + $obj->sub_foo; + }; + is($@, "", "$c: no errors setting attribute"); + is($set_sub, 23, "$c: sub_foo is 23"); + +# diag MooseX::InsideOut::Meta::Instance->__dump($obj); +# use Data::Dumper; +# diag Dumper($obj); + +}