r50102 - in /branches/upstream/libmoosex-types-varianttable-perl: ./ current/ current/lib/ current/lib/Moose/ current/lib/Moose/Meta/ current/lib/Moose/Meta/Method/ current/lib/MooseX/ current/lib/MooseX/Types/ current/lib/MooseX/Types/VariantTable/ current/t/
jawnsy-guest at users.alioth.debian.org
jawnsy-guest at users.alioth.debian.org
Sun Jan 3 23:50:02 UTC 2010
Author: jawnsy-guest
Date: Sun Jan 3 23:49:47 2010
New Revision: 50102
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=50102
Log:
[svn-inject] Installing original source of libmoosex-types-varianttable-perl
Added:
branches/upstream/libmoosex-types-varianttable-perl/
branches/upstream/libmoosex-types-varianttable-perl/current/
branches/upstream/libmoosex-types-varianttable-perl/current/Changes
branches/upstream/libmoosex-types-varianttable-perl/current/MANIFEST
branches/upstream/libmoosex-types-varianttable-perl/current/MANIFEST.SKIP
branches/upstream/libmoosex-types-varianttable-perl/current/META.yml
branches/upstream/libmoosex-types-varianttable-perl/current/Makefile.PL
branches/upstream/libmoosex-types-varianttable-perl/current/README
branches/upstream/libmoosex-types-varianttable-perl/current/SIGNATURE
branches/upstream/libmoosex-types-varianttable-perl/current/lib/
branches/upstream/libmoosex-types-varianttable-perl/current/lib/Moose/
branches/upstream/libmoosex-types-varianttable-perl/current/lib/Moose/Meta/
branches/upstream/libmoosex-types-varianttable-perl/current/lib/Moose/Meta/Method/
branches/upstream/libmoosex-types-varianttable-perl/current/lib/Moose/Meta/Method/VariantTable.pm
branches/upstream/libmoosex-types-varianttable-perl/current/lib/MooseX/
branches/upstream/libmoosex-types-varianttable-perl/current/lib/MooseX/Types/
branches/upstream/libmoosex-types-varianttable-perl/current/lib/MooseX/Types/VariantTable/
branches/upstream/libmoosex-types-varianttable-perl/current/lib/MooseX/Types/VariantTable.pm
branches/upstream/libmoosex-types-varianttable-perl/current/lib/MooseX/Types/VariantTable/Declare.pm
branches/upstream/libmoosex-types-varianttable-perl/current/t/
branches/upstream/libmoosex-types-varianttable-perl/current/t/basic.t
branches/upstream/libmoosex-types-varianttable-perl/current/t/structured.t
branches/upstream/libmoosex-types-varianttable-perl/current/t/sugar.t
Added: branches/upstream/libmoosex-types-varianttable-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-types-varianttable-perl/current/Changes?rev=50102&op=file
==============================================================================
--- branches/upstream/libmoosex-types-varianttable-perl/current/Changes (added)
+++ branches/upstream/libmoosex-types-varianttable-perl/current/Changes Sun Jan 3 23:49:47 2010
@@ -1,0 +1,12 @@
+0.03 Mon, 28 Sep 2009 17:54:35 +0200
+ - Implement ambigious_match_callback as a way for users to hook into what
+ happens on ambigious matches.
+
+0.02
+ - Use MooseX::Clone, not some half assed clone routine
+ - Types are sorted topologically now. All variants in a single slot
+ are tried for a match, and if the result is ambiguous an error is
+ thrown. This matches Perl 6's behavior for multi method dispatch.
+
+0.01
+ - Initial release
Added: branches/upstream/libmoosex-types-varianttable-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-types-varianttable-perl/current/MANIFEST?rev=50102&op=file
==============================================================================
--- branches/upstream/libmoosex-types-varianttable-perl/current/MANIFEST (added)
+++ branches/upstream/libmoosex-types-varianttable-perl/current/MANIFEST Sun Jan 3 23:49:47 2010
@@ -1,0 +1,13 @@
+Changes
+lib/Moose/Meta/Method/VariantTable.pm
+lib/MooseX/Types/VariantTable.pm
+lib/MooseX/Types/VariantTable/Declare.pm
+Makefile.PL
+MANIFEST This list of files
+MANIFEST.SKIP
+README
+t/basic.t
+t/structured.t
+t/sugar.t
+META.yml Module meta-data (added by MakeMaker)
+SIGNATURE Public-key signature (added by MakeMaker)
Added: branches/upstream/libmoosex-types-varianttable-perl/current/MANIFEST.SKIP
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-types-varianttable-perl/current/MANIFEST.SKIP?rev=50102&op=file
==============================================================================
--- branches/upstream/libmoosex-types-varianttable-perl/current/MANIFEST.SKIP (added)
+++ branches/upstream/libmoosex-types-varianttable-perl/current/MANIFEST.SKIP Sun Jan 3 23:49:47 2010
@@ -1,0 +1,39 @@
+# Avoid version control files.
+\bRCS\b
+\bCVS\b
+\bSCCS\b
+,v$
+\B\.svn\b
+\b_darcs\b
+\B\.git
+
+# Avoid Makemaker generated and utility files.
+\bMANIFEST\.bak
+\bMakefile$
+\bblib/
+\bMakeMaker-\d
+\bpm_to_blib\.ts$
+\bpm_to_blib$
+\bblibdirs\.ts$ # 6.18 through 6.25 generated this
+
+# Avoid Module::Build generated and utility files.
+\bBuild$
+\b_build/
+
+# Avoid temp and backup files.
+~$
+\.old$
+\#$
+\b\.#
+\.bak$
+
+# Avoid Devel::Cover files.
+\bcover_db\b
+
+### DEFAULT MANIFEST.SKIP ENDS HERE ####
+
+\.DS_Store$
+\.sw.$
+(\w+-)*(\w+)-\d\.\d+(?:\.tar\.gz)?$
+
+\.t\.log$
Added: branches/upstream/libmoosex-types-varianttable-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-types-varianttable-perl/current/META.yml?rev=50102&op=file
==============================================================================
--- branches/upstream/libmoosex-types-varianttable-perl/current/META.yml (added)
+++ branches/upstream/libmoosex-types-varianttable-perl/current/META.yml Sun Jan 3 23:49:47 2010
@@ -1,0 +1,26 @@
+--- #YAML:1.0
+name: MooseX-Types-VariantTable
+version: 0.03
+abstract: ~
+author: []
+license: unknown
+distribution_type: module
+configure_requires:
+ ExtUtils::MakeMaker: 0
+build_requires:
+ ExtUtils::MakeMaker: 0
+requires:
+ Moose: 0.75
+ MooseX::Clone: 0.03
+ MooseX::Types::Structured: 0.12
+ Sub::Exporter: 0
+ Test::Exception: 0
+ Test::use::ok: 0
+no_index:
+ directory:
+ - t
+ - inc
+generated_by: ExtUtils::MakeMaker version 6.55_02
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
Added: branches/upstream/libmoosex-types-varianttable-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-types-varianttable-perl/current/Makefile.PL?rev=50102&op=file
==============================================================================
--- branches/upstream/libmoosex-types-varianttable-perl/current/Makefile.PL (added)
+++ branches/upstream/libmoosex-types-varianttable-perl/current/Makefile.PL Sun Jan 3 23:49:47 2010
@@ -1,0 +1,22 @@
+#!/usr/bin/perl -w
+
+use strict;
+
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'MooseX::Types::VariantTable',
+ VERSION_FROM => 'lib/MooseX/Types/VariantTable.pm',
+ INSTALLDIRS => 'site',
+ SIGN => 1,
+ PL_FILES => { },
+ PREREQ_PM => {
+ 'Test::use::ok' => 0,
+ 'Test::Exception' => 0,
+ 'Sub::Exporter' => 0,
+ 'Moose' => '0.75', # for Class tc to sort properly it needs a fixed is_subtype_of, Num as subtype of Str
+ 'MooseX::Types::Structured' => '0.12',
+ 'MooseX::Clone' => '0.03', # Copy
+ },
+);
+
Added: branches/upstream/libmoosex-types-varianttable-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-types-varianttable-perl/current/README?rev=50102&op=file
==============================================================================
--- branches/upstream/libmoosex-types-varianttable-perl/current/README (added)
+++ branches/upstream/libmoosex-types-varianttable-perl/current/README Sun Jan 3 23:49:47 2010
@@ -1,0 +1,87 @@
+NAME
+ MooseX::Types::VariantTable - Type constraint based variant table
+
+SYNOPSIS
+ # see also MooseX::Types::VariantTable::Declare for a way to
+ # declare variant table based methods
+
+ use MooseX::Types::VariantTable;
+
+ my $dispatch_table = MooseX::Types::VariantTable->new(
+ variants => [
+ { type => "Foo", value => \&foo_handler },
+ { type => "Bar", value => \&bar_handler },
+ { type => "Item", value => \&fallback },
+ ],
+ );
+
+ # look up the correct handler for $thingy based on the type constraints it passes
+ my $entry = $dispatch_table->find_variant($thingy);
+
+ # or use the 'dispatch' convenience method if the entries are code refs
+ $dispatch_table->dispatch( $thingy, @args );
+
+DESCRIPTION
+ This object implements a simple dispatch table based on Moose type
+ constraints.
+
+ Subtypes will be checked before their parents, meaning that the order of
+ the declaration does not matter.
+
+ This object is used internally by Moose::Meta::Method::VariantTable and
+ MooseX::Types::VariantTable::Declare to provide primitive multi sub
+ support.
+
+ATTRIBUTES
+ ambigious_match_callback
+ A code reference that'll be executed when find_variant found more than
+ one matching variant for a value. It defaults to something that simply
+ croaks with an error message like this:
+
+ Ambiguous match %s
+
+ where %s contains a list of stringified types that matched.
+
+METHODS
+ new
+ add_variant $type, $value
+ Registers $type, such that $value will be returned by "find_variant"
+ for items passing $type.
+
+ Subtyping is respected in the table.
+
+ find_variant $value
+ Returns the registered value for the most specific type that $value
+ passes.
+
+ dispatch $value, @args
+ A convenience method for when the registered values are code
+ references.
+
+ Calls "find_variant" and if the result is a code reference, it will
+ "goto" this code reference with the value and any additional
+ arguments.
+
+ has_type $type
+ Returns true if an entry for $type is registered.
+
+ has_parent $type
+ Returns true if a parent type of $type is registered.
+
+TODO
+ The meta method composes in multiple inheritence but not yet with roles
+ due to extensibility issues with the role application code.
+
+ When Moose::Meta::Role can pluggably merge methods variant table methods
+ can gain role composition.
+
+AUTHOR
+ Yuval Kogman <nothingmuch at woobling.org>
+
+ Florian Ragwitz <rafl at debian.org>
+
+COPYRIGHT
+ Copyright (c) 2008 Yuval Kogman. All rights reserved
+ This program is free software; you can redistribute
+ it and/or modify it under the same terms as Perl itself.
+
Added: branches/upstream/libmoosex-types-varianttable-perl/current/SIGNATURE
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-types-varianttable-perl/current/SIGNATURE?rev=50102&op=file
==============================================================================
--- branches/upstream/libmoosex-types-varianttable-perl/current/SIGNATURE (added)
+++ branches/upstream/libmoosex-types-varianttable-perl/current/SIGNATURE Sun Jan 3 23:49:47 2010
@@ -1,0 +1,35 @@
+This file contains message digests of all files listed in MANIFEST,
+signed via the Module::Signature module, version 0.55.
+
+To verify the content in this distribution, first make sure you have
+Module::Signature installed, then type:
+
+ % cpansign -v
+
+It will check each file's integrity, as well as the signature's
+validity. If "==> Signature verified OK! <==" is not displayed,
+the distribution may already have been compromised, and you should
+not run its Makefile.PL or Build.PL.
+
+-----BEGIN PGP SIGNED MESSAGE-----
+Hash: SHA1
+
+SHA1 ca2e7971567f9344c3b9b5cb521e0e40fbd83feb Changes
+SHA1 477d09028ce240b11ab7ed1933b0be464a70e7b7 MANIFEST
+SHA1 6de0c394f8ca013f6cbf28292d652979109e9b87 MANIFEST.SKIP
+SHA1 e30330f114fa4c2d5c0452be737e1f0e03babd13 META.yml
+SHA1 4725cff57368d4c9e0592820484e52d0e94df008 Makefile.PL
+SHA1 8ff3ec2277ab61d9c89423e95f6fa9796dabd1cb README
+SHA1 2e49ec8ab2161aadc7ef70ade552a9382d0705c4 lib/Moose/Meta/Method/VariantTable.pm
+SHA1 718232c9ab6e4749a507f1b22d25bd29a877f784 lib/MooseX/Types/VariantTable.pm
+SHA1 151474b7c6709d243405b09c47b98b9cdc55d994 lib/MooseX/Types/VariantTable/Declare.pm
+SHA1 6b23dc57cc9f59f18194fe6d9b9e1b465e889011 t/basic.t
+SHA1 d892988be83dc9817486b716ed09469ce46ca1c6 t/structured.t
+SHA1 39107eaf4d6407727f4cdbed69c2eab380131157 t/sugar.t
+-----BEGIN PGP SIGNATURE-----
+Version: GnuPG v1.4.9 (GNU/Linux)
+
+iEYEARECAAYFAkrA3V8ACgkQdC8qQo5jWl7EvgCeKUOGSZVPLf/mimbqdeSCWvm1
+8msAnRhYLKK/6/UNg8rsd+JXDatdCZgq
+=d0U0
+-----END PGP SIGNATURE-----
Added: branches/upstream/libmoosex-types-varianttable-perl/current/lib/Moose/Meta/Method/VariantTable.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-types-varianttable-perl/current/lib/Moose/Meta/Method/VariantTable.pm?rev=50102&op=file
==============================================================================
--- branches/upstream/libmoosex-types-varianttable-perl/current/lib/Moose/Meta/Method/VariantTable.pm (added)
+++ branches/upstream/libmoosex-types-varianttable-perl/current/lib/Moose/Meta/Method/VariantTable.pm Sun Jan 3 23:49:47 2010
@@ -1,0 +1,102 @@
+#!/usr/bin/perl
+
+package Moose::Meta::Method::VariantTable;
+use Moose;
+
+extends qw(Moose::Object Moose::Meta::Method);
+
+use MooseX::Types::VariantTable;
+
+use Carp qw(croak);
+use Sub::Name qw(subname);
+
+has _variant_table => (
+ isa => "MooseX::Types::VariantTable",
+ is => "ro",
+ default => sub { MooseX::Types::VariantTable->new },
+ handles => qr/^(?: \w+_variant$ | has_ )/x,
+);
+
+has class => (
+ isa => "Class::MOP::Class",
+ is => "ro",
+);
+
+has name => (
+ isa => "Str",
+ is => "ro",
+);
+
+has full_name => (
+ isa => "Str",
+ is => "ro",
+ lazy => 1,
+ default => sub {
+ my $self = shift;
+ join "::", $self->class->name, $self->name;
+ },
+);
+
+has super => (
+ isa => "Maybe[Class::MOP::Method]",
+ is => "ro",
+ lazy_build => 1,
+);
+
+sub _build_super {
+ my $self = shift;
+
+ $self->class->find_next_method_by_name($self->name);
+}
+
+has body => (
+ isa => "CodeRef",
+ is => "ro",
+ lazy => 1,
+ builder => "initialize_body",
+);
+
+sub merge {
+ my ( $self, @others ) = @_;
+
+ return ( ref $self )->new(
+ _variant_table => $self->_variant_table->merge(map { $_->_variant_table } @others),
+ );
+}
+
+sub initialize_body {
+ my $self = shift;
+
+ my $variant_table = $self->_variant_table;
+
+ my $super = $self->super;
+ my $super_body = $super && $super->body;
+
+ my $name = $self->name;
+
+ return subname $self->full_name, sub {
+ my ( $self, $value, @args ) = @_;
+
+ if ( my ( $result, $type ) = $variant_table->find_variant($value) ) {
+ my $method = (ref($result)||'') eq 'CODE'
+ ? $result
+ : $self->can($result);
+
+ goto $method;
+ } else {
+ return $self->next::method($value, @args);
+ }
+
+ my $dump = eval { require Devel::PartialDump; 1 }
+ ? \&Devel::PartialDump::dump
+ : sub { return join $", map { overload::StrVal($_) } @_ };
+
+ croak "No variant of method '$name' found for ", $dump->($value, @args);
+ };
+}
+
+
+__PACKAGE__
+
+__END__
+
Added: branches/upstream/libmoosex-types-varianttable-perl/current/lib/MooseX/Types/VariantTable.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-types-varianttable-perl/current/lib/MooseX/Types/VariantTable.pm?rev=50102&op=file
==============================================================================
--- branches/upstream/libmoosex-types-varianttable-perl/current/lib/MooseX/Types/VariantTable.pm (added)
+++ branches/upstream/libmoosex-types-varianttable-perl/current/lib/MooseX/Types/VariantTable.pm Sun Jan 3 23:49:47 2010
@@ -1,0 +1,327 @@
+#!/usr/bin/perl
+
+package MooseX::Types::VariantTable;
+use Moose;
+
+use Hash::Util::FieldHash::Compat qw(idhash);
+use Scalar::Util qw(refaddr);
+
+use Moose::Util::TypeConstraints;
+
+use namespace::clean -except => 'meta';
+
+with qw(MooseX::Clone);
+
+use Carp qw(croak);
+
+our $VERSION = "0.03";
+
+has _sorted_variants => (
+ traits => [qw(NoClone)],
+ #isa => "ArrayRef[ArrayRef[HashRef]]",
+ is => "ro",
+ lazy_build => 1,
+);
+
+has variants => (
+ traits => [qw(Copy)],
+ isa => "ArrayRef[HashRef]",
+ is => "rw",
+ init_arg => undef,
+ default => sub { [] },
+ trigger => sub { $_[0]->_clear_sorted_variants },
+);
+
+has ambigious_match_callback => (
+ is => 'ro',
+ isa => 'CodeRef',
+ default => sub {
+ sub {
+ my ($self, $value, @matches) = @_;
+ croak "Ambiguous match " . join(", ", map { $_->{type} } @matches);
+ };
+ },
+);
+
+sub BUILD {
+ my ( $self, $params ) = @_;
+
+ if ( my $variants = $params->{variants} ) {
+ foreach my $variant ( @$variants ) {
+ $self->add_variant( @{ $variant }{qw(type value)} );
+ }
+ }
+}
+
+sub merge {
+ my ( @selves ) = @_; # our @selves reads better =/
+
+ my $self = $selves[0];
+
+ return ( ref $self )->new(
+ variants => [ map { @{ $_->variants } } @selves ],
+ );
+}
+
+sub has_type {
+ my ( $self, $type_or_name ) = @_;
+
+ my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name)
+ or croak "No such type constraint: $type_or_name";
+
+ foreach my $existing_type ( map { $_->{type} } @{ $self->variants } ) {
+ return 1 if $type->equals($existing_type);
+ }
+
+ return;
+}
+
+sub has_parent {
+ my ( $self, $type_or_name ) = @_;
+
+ my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name)
+ or croak "No such type constraint: $type_or_name";
+
+ foreach my $existing_type ( map { $_->{type} } @{ $self->variants } ) {
+ return 1 if $type->is_subtype_of($existing_type);
+ }
+
+ return;
+}
+
+sub add_variant {
+ my ( $self, $type_or_name, $value ) = @_;
+
+ croak "Duplicate variant entry for $type_or_name"
+ if $self->has_type($type_or_name);
+
+ my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name)
+ or croak "No such type constraint: $type_or_name";
+
+ my $entry = { type => $type, value => $value };
+
+ push @{ $self->variants }, $entry;
+
+ $self->_clear_sorted_variants;
+
+ return;
+}
+
+sub remove_variant {
+ my ( $self, $type_or_name, $value ) = @_;
+
+ my $type = Moose::Util::TypeConstraints::find_type_constraint($type_or_name)
+ or croak "No such type constraint: $type_or_name";
+
+ my $list = $self->variants;
+
+ @$list = grep { not $_->{type}->equals($type) } @$list;
+
+ $self->_clear_sorted_variants;
+
+ return;
+}
+
+sub _build__sorted_variants {
+ my $self = shift;
+
+ my @entries = @{ $self->variants };
+
+ idhash my %out;
+
+ foreach my $entry ( @entries ) {
+ $out{$entry} = [];
+ foreach my $other ( @entries ) {
+ next if refaddr($entry) == refaddr($other);
+
+ if ( $other->{type}->is_subtype_of($entry->{type}) ) {
+ push @{ $out{$entry} }, $other;
+ }
+ }
+ }
+
+ my @sorted;
+
+ while ( keys %out ) {
+ my @slot;
+
+ foreach my $entry ( @entries ) {
+ if ( $out{$entry} and not @{ $out{$entry} } ) {
+ push @slot, $entry;
+ delete $out{$entry};
+ }
+ }
+
+ idhash my %filter;
+ @filter{@slot} = ();
+
+ foreach my $entry ( @entries ) {
+ if ( my $out = $out{$entry} ) {
+ @$out = grep { not exists $filter{$_} } @$out;
+ }
+ }
+
+ push @sorted, \@slot;
+ }
+
+ return \@sorted;
+}
+
+sub find_variant {
+ my ( $self, @args ) = @_;
+
+ if ( my $entry = $self->_find_variant(@args) ) {
+ if ( wantarray ) {
+ return @{ $entry }{qw(value type)};
+ } else {
+ return $entry->{value};
+ }
+ }
+
+ return;
+}
+
+sub _find_variant {
+ my ( $self, $value ) = @_;
+
+ foreach my $slot ( @{ $self->_sorted_variants } ) {
+ my @matches;
+ foreach my $entry ( @$slot ) {
+ if ( $entry->{type}->check($value) ) {
+ push @matches, $entry;
+ }
+ }
+ if ( @matches == 1 ) {
+ return $matches[0];
+ } elsif ( @matches > 1 ) {
+ $self->ambigious_match_callback->($self, $value, @matches);
+ }
+ }
+
+ return;
+}
+
+sub dispatch {
+ my $self = shift;
+ my $value = $_[0];
+
+ if ( my $result = $self->find_variant($value) ) {
+ if ( (ref($result)||'') eq 'CODE' ) {
+ goto &$result;
+ } else {
+ return $result;
+ }
+ }
+
+ return;
+}
+
+__PACKAGE__
+
+__END__
+
+=pod
+
+=head1 NAME
+
+MooseX::Types::VariantTable - Type constraint based variant table
+
+=head1 SYNOPSIS
+
+ # see also MooseX::Types::VariantTable::Declare for a way to
+ # declare variant table based methods
+
+ use MooseX::Types::VariantTable;
+
+ my $dispatch_table = MooseX::Types::VariantTable->new(
+ variants => [
+ { type => "Foo", value => \&foo_handler },
+ { type => "Bar", value => \&bar_handler },
+ { type => "Item", value => \&fallback },
+ ],
+ );
+
+ # look up the correct handler for $thingy based on the type constraints it passes
+ my $entry = $dispatch_table->find_variant($thingy);
+
+ # or use the 'dispatch' convenience method if the entries are code refs
+ $dispatch_table->dispatch( $thingy, @args );
+
+=head1 DESCRIPTION
+
+This object implements a simple dispatch table based on L<Moose> type constraints.
+
+Subtypes will be checked before their parents, meaning that the order of the
+declaration does not matter.
+
+This object is used internally by L<Moose::Meta::Method::VariantTable> and
+L<MooseX::Types::VariantTable::Declare> to provide primitive multi
+sub support.
+
+=head1 ATTRIBUTES
+
+=head2 ambigious_match_callback
+
+A code reference that'll be executed when find_variant found more than one
+matching variant for a value. It defaults to something that simply croaks with
+an error message like this:
+
+ Ambiguous match %s
+
+where %s contains a list of stringified types that matched.
+
+=head1 METHODS
+
+=over 4
+
+=item new
+
+=item add_variant $type, $value
+
+Registers C<$type>, such that C<$value> will be returned by C<find_variant> for
+items passing $type.
+
+Subtyping is respected in the table.
+
+=item find_variant $value
+
+Returns the registered value for the most specific type that C<$value> passes.
+
+=item dispatch $value, @args
+
+A convenience method for when the registered values are code references.
+
+Calls C<find_variant> and if the result is a code reference, it will C<goto>
+this code reference with the value and any additional arguments.
+
+=item has_type $type
+
+Returns true if an entry for C<$type> is registered.
+
+=item has_parent $type
+
+Returns true if a parent type of C<$type> is registered.
+
+=back
+
+=head1 TODO
+
+The meta method composes in multiple inheritence but not yet with roles due to
+extensibility issues with the role application code.
+
+When L<Moose::Meta::Role> can pluggably merge methods variant table methods can
+gain role composition.
+
+=head1 AUTHOR
+
+Yuval Kogman E<lt>nothingmuch at woobling.orgE<gt>
+
+Florian Ragwitz E<lt>rafl at debian.orgE<gt>
+
+=head1 COPYRIGHT
+
+ Copyright (c) 2008 Yuval Kogman. All rights reserved
+ This program is free software; you can redistribute
+ it and/or modify it under the same terms as Perl itself.
+
+=cut
Added: branches/upstream/libmoosex-types-varianttable-perl/current/lib/MooseX/Types/VariantTable/Declare.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-types-varianttable-perl/current/lib/MooseX/Types/VariantTable/Declare.pm?rev=50102&op=file
==============================================================================
--- branches/upstream/libmoosex-types-varianttable-perl/current/lib/MooseX/Types/VariantTable/Declare.pm (added)
+++ branches/upstream/libmoosex-types-varianttable-perl/current/lib/MooseX/Types/VariantTable/Declare.pm Sun Jan 3 23:49:47 2010
@@ -1,0 +1,120 @@
+#!/usr/bin/perl
+
+package MooseX::Types::VariantTable::Declare;
+
+use strict;
+use warnings;
+
+use Carp qw(croak);
+
+use Sub::Exporter -setup => {
+ exports => [qw(variant_method)],
+ groups => {
+ default => [qw(variant_method)],
+ },
+};
+
+use Moose::Meta::Method::VariantTable;
+
+sub variant_method ($$$) {
+ my ( $name, $type, $body ) = @_;
+
+ my $class = caller;
+
+ my $meta = $class->meta;
+
+ my $meta_method = $class->meta->get_method($name);
+
+ unless ( $meta_method ) {
+ $meta_method = Moose::Meta::Method::VariantTable->new(
+ name => $name,
+ class => $meta,
+ );
+
+ $meta->add_method( $name => $meta_method );
+ }
+
+ if ( $meta_method->isa("Moose::Meta::Method::VariantTable") ) {
+ $meta_method->add_variant( $type, $body );
+ } else {
+ croak "Method '$name' is already defined";
+ }
+
+ return $meta_method->body;
+}
+
+__PACKAGE__
+
+__END__
+
+=pod
+
+=head1 NAME
+
+MooseX::Types::VariantTable::Declare - Declarative sugar for
+L<MooseX::Types::VariantTable> based methods.
+
+=head1 SYNOPSIS
+
+ package Awesome;
+ use Moose;
+
+ variant_method dance => Item => sub {
+ # Item is the least derived type in the hierarchy,
+ # every other type subtypes it
+ # this is in effect a fallback
+ return "fallback";
+ };
+
+ # a more specific type
+ variant_method dance => Ballerina => sub {
+ my ( $self, $ballerina, @args ) = @_;
+
+ $ballerina; # a value that passed the TC named "Ballerina"
+
+ return "pretty!";
+ };
+
+ # also works with objects
+ variant_method dance => $type_object => sub { ... };
+
+=head1 DESCRIPTION
+
+This module provides declarative sugar for defining
+L<Moose::Meta::Method::VariantTable> methods in your L<Moose> classes and
+roles.
+
+These methods have some semantics:
+
+=head2 Declaration
+
+The order of the declarations do not matter in most cases.
+
+It is the type hierarchy that defines the order in which the constraints are
+checked and items dispatched.
+
+However, in the case that two constraints without an explicit relationship
+between them (one is a subtype of the other) both accept the same value, the
+one that was declared earlier will win. There is no way around this issue, so
+be careful what types you use especially when mixing variants form many
+different sources.
+
+Adding the same type to a variant table twice is an error.
+
+=head2 Inheritence
+
+When dispatching all of the subclass's variants will be tried before the
+superclass.
+
+This allows shadowing of types from the superclass even using broader types.
+
+=head2 Roles
+
+... are currently broken.
+
+Don't use variant table methods in a role, unless that's the only definition,
+because in the future variant table merging will happen at role composition
+time in a role composition like way, so your code will not continue to work the
+same.
+
+=back
Added: branches/upstream/libmoosex-types-varianttable-perl/current/t/basic.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-types-varianttable-perl/current/t/basic.t?rev=50102&op=file
==============================================================================
--- branches/upstream/libmoosex-types-varianttable-perl/current/t/basic.t (added)
+++ branches/upstream/libmoosex-types-varianttable-perl/current/t/basic.t Sun Jan 3 23:49:47 2010
@@ -1,0 +1,91 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+
+use ok 'MooseX::Types::VariantTable';
+use Test::Exception;
+
+use Moose::Util::TypeConstraints;
+
+{
+ package Bar;
+ use Moose;
+
+ package Foo;
+ use Moose;
+
+ extends qw(Bar);
+
+ package Gorch;
+ use Moose;
+
+ extends qw(Bar);
+
+ package Blah;
+ use Moose;
+
+ extends qw(Foo);
+
+ package Oink;
+ use Moose;
+}
+
+my %types = ( Foo => "a foo", Bar => "a bar", Item => "any", ArrayRef => "array ref" );
+
+BEGIN {
+ if ( eval { require Math::Combinatorics } ) {
+ Math::Combinatorics->import("permute");
+ } else {
+ *permute = sub {
+ # not quite, but close enough
+ return ( [ @_ ], [ reverse @_ ], [ sort @_ ], [ reverse sort @_ ] );
+ };
+ }
+}
+
+foreach my $keys ( permute keys %types ) {
+
+ my $v = MooseX::Types::VariantTable->new;
+
+ foreach my $key ( @$keys ) {
+ $v->add_variant( $key => $types{$key} );
+ }
+
+ is( $v->find_variant( Foo->new ), "a foo", "foo object" );
+ is( $v->find_variant( Bar->new ), "a bar", "bar object" );
+ is( $v->find_variant( Gorch->new ), "a bar", "bar subclass" );
+ is( $v->find_variant( Blah->new ), "a foo", "foo subclass" );
+ is( $v->find_variant( Oink->new ), "any", "fallback to Item" );
+ is( $v->find_variant( [] ), "array ref", "simple tc" );
+ is( $v->find_variant( undef ), "any", "fallback to Item" );
+}
+
+my $v = MooseX::Types::VariantTable->new(
+ variants => [
+ { type => "Foo", value => "a foo" },
+ { type => "Bar", value => "a bar" },
+ ],
+);
+
+is( $v->find_variant( Foo->new ), "a foo", "Foo object" );
+is( $v->find_variant( Bar->new ), "a bar", "bar object" );
+
+ok( $v->has_type("Foo"), "has a foo variant" );
+ok( $v->has_parent("Foo"), "has a foo parent variant" );
+
+$v->remove_variant("Foo");
+
+is( $v->find_variant( Foo->new ), "a bar", "foo variant removed" );
+is( $v->find_variant( Bar->new ), "a bar", "bar object" );
+
+ok( !$v->has_type("Foo"), "no longer has a foo variant" );
+ok( $v->has_parent("Foo"), "has a foo parent variant" );
+
+ok( !$v->has_type("ArrayRef"), "no ArrayRef variant" );
+ok( !$v->has_parent("ArrayRef"), "no ArrayRef parent variant" );
+is( $v->find_variant([]), undef, "nothing found" );
+
+throws_ok { $v->add_variant(Bar => "something else") } qr/duplicate/i;
Added: branches/upstream/libmoosex-types-varianttable-perl/current/t/structured.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-types-varianttable-perl/current/t/structured.t?rev=50102&op=file
==============================================================================
--- branches/upstream/libmoosex-types-varianttable-perl/current/t/structured.t (added)
+++ branches/upstream/libmoosex-types-varianttable-perl/current/t/structured.t Sun Jan 3 23:49:47 2010
@@ -1,0 +1,87 @@
+use strict;
+use warnings;
+use Test::More;
+use Test::Exception;
+use MooseX::Types::VariantTable;
+use Moose::Util::TypeConstraints;
+
+BEGIN {
+ eval q[
+ use MooseX::Types::Structured;
+ use MooseX::Types::Moose;
+ 1;
+ ] or plan skip_all => 'requires MooseX::Types and MooseX::Types::Structured';
+}
+
+use MooseX::Types::Structured qw/Tuple Dict/;
+use MooseX::Types::Moose qw/Num Int Str Item/;
+
+plan tests => 16;
+
+{
+ my $t = MooseX::Types::VariantTable->new;
+ $t->add_variant( Num => 'Num' );
+ $t->add_variant( Str => 'Str' );
+
+ is($t->find_variant(21), 'Num');
+ is($t->find_variant('hey'), 'Str');
+}
+
+{
+ my $t = MooseX::Types::VariantTable->new;
+ $t->add_variant( Tuple[Tuple[Num], Dict[]] => 'Num' );
+ $t->add_variant( Tuple[Tuple[Str], Dict[]] => 'Str' );
+
+ is($t->find_variant([[21], {}]), 'Num');
+ is($t->find_variant([['hey'], {}]), 'Str');
+}
+
+{
+ package Paper;
+ use Moose;
+
+ package Scissors;
+ use Moose;
+
+ package Stone;
+ use Moose;
+}
+
+{
+ my $t = MooseX::Types::VariantTable->new;
+ $t->add_variant( Tuple[Tuple[ class_type('Paper'), class_type('Paper') ], Dict[]] => 0 );
+ $t->add_variant( Tuple[Tuple[ class_type('Stone'), class_type('Stone') ], Dict[]] => 0 );
+ $t->add_variant( Tuple[Tuple[ class_type('Scissors'), class_type('Scissors') ], Dict[]] => 0 );
+ $t->add_variant( Tuple[Tuple[ class_type('Paper'), class_type('Stone') ], Dict[]] => 1 );
+ $t->add_variant( Tuple[Tuple[ class_type('Scissors'), class_type('Paper') ], Dict[]] => 1 );
+ $t->add_variant( Tuple[Tuple[ class_type('Stone'), class_type('Scissors') ], Dict[]] => 1 );
+ $t->add_variant( Tuple[Tuple[ Item, Item ], Dict[]] => -1);
+
+ is( $t->find_variant([[ Paper->new, Scissors->new ], {}]), -1 );
+ is( $t->find_variant([[ Paper->new, Stone->new ], {}]), 1 );
+ is( $t->find_variant([[ Stone->new, Stone->new ], {}]), 0 );
+ is( $t->find_variant([[ Paper->new, Paper->new ], {}]), 0 );
+ is( $t->find_variant([[ Stone->new, Paper->new ], {}]), -1 );
+ is( $t->find_variant([[ Paper->new, Stone->new ], {}]), 1 );
+}
+
+{
+ my $t = MooseX::Types::VariantTable->new;
+ $t->add_variant( Tuple[Tuple[ Int, Num ], Dict[]] => 'first' );
+ $t->add_variant( Tuple[Tuple[ Num, Int ], Dict[]] => 'second' );
+
+ dies_ok { $t->find_variant([[ 42, 23 ], {}]) };
+
+ is($t->find_variant([[ 42, 23.3 ], {}]), 'first');
+ is($t->find_variant([[ 42.2, 23 ], {}]), 'second');
+}
+
+{
+ my $t = MooseX::Types::VariantTable->new;
+ $t->add_variant( Tuple[Tuple[ Int ], Dict[foo => Int]] => 'first' );
+ $t->add_variant( Tuple[Tuple[ Int ], Dict[ ]] => 'second' );
+
+ is($t->find_variant([[ 23 ], { foo => 42 }]), 'first');
+ is($t->find_variant([[ 42 ], { }]), 'second');
+ ok(!$t->find_variant([[ 23 ], { foo => 'bar' }]));
+}
Added: branches/upstream/libmoosex-types-varianttable-perl/current/t/sugar.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libmoosex-types-varianttable-perl/current/t/sugar.t?rev=50102&op=file
==============================================================================
--- branches/upstream/libmoosex-types-varianttable-perl/current/t/sugar.t (added)
+++ branches/upstream/libmoosex-types-varianttable-perl/current/t/sugar.t Sun Jan 3 23:49:47 2010
@@ -1,0 +1,64 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+
+{
+ package Gorch;
+ use Moose;
+
+ package Bar;
+ use Moose;
+
+ extends qw(Gorch);
+
+ package Baz;
+ use Moose;
+
+ extends qw(Gorch);
+
+ package Foo;
+ use Moose;
+ use MooseX::Types::VariantTable::Declare;
+
+ variant_method foo => Gorch => sub { "gorch" };
+ variant_method foo => Bar => sub { "bar" };
+ variant_method foo => Item => sub { "any" };
+
+ package Oink;
+ use Moose;
+
+ extends qw(Foo);
+
+ MooseX::Types::VariantTable::Declare::variant_method( foo => Baz => sub { "baz" } );
+}
+
+my $bar = Bar->new;
+my $gorch = Gorch->new;
+my $baz = Baz->new;
+
+my $foo = Foo->new;
+my $oink = Oink->new;
+
+can_ok( $foo, "foo" );
+
+is( $foo->foo($gorch), "gorch", "variant table method on $gorch" );
+is( $foo->foo($bar), "bar", "... on $bar" );
+is( $foo->foo([]), "any", "... on array ref" );
+
+is( $oink->foo($baz), "baz", "additional variant in subclass" );
+is( $oink->foo($gorch), "gorch", "inherited variant in subclass" );
+is( $oink->foo($bar), "bar", "inherited variant in subclass" );
+
+$foo->meta->get_method("foo")->remove_variant("Bar");
+
+is( $foo->foo($gorch), "gorch", "$gorch" );
+is( $foo->foo($bar), "gorch", "$bar is now gorch because it's variant was removed" );
+
+is( $foo->foo($baz), "gorch", "$baz is gorch" );
+
+is( $oink->foo($bar), "gorch", "removal from superclass propagated" );
+
+# TODO roles
More information about the Pkg-perl-cvs-commits
mailing list