Dispatch-Class-0.02/0000755000175000017500000000000012436353065013232 5ustar maukemaukeDispatch-Class-0.02/README0000644000175000017500000000175612436351465014125 0ustar maukemaukeDispatch-Class Dispatch on the type (class) of an argument 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 Dispatch::Class You can also look for information at: RT, CPAN's request tracker http://rt.cpan.org/NoAuth/Bugs.html?Dist=Dispatch-Class AnnoCPAN, Annotated CPAN documentation http://annocpan.org/dist/Dispatch-Class CPAN Ratings http://cpanratings.perl.org/d/Dispatch-Class MetaCPAN https://metacpan.org/module/Dispatch::Class COPYRIGHT AND LICENCE Copyright (C) 2013, 2014 Lukas Mai This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. Dispatch-Class-0.02/Changes0000644000175000017500000000027612436352520014525 0ustar maukemaukeRevision history for Dispatch-Class 0.02 2014-11-29 - Use Exporter::Tiny instead of Sub::Exporter. 0.01 2014-01-04 First version, released on an unsuspecting world. Dispatch-Class-0.02/lib/0000755000175000017500000000000012436353064013777 5ustar maukemaukeDispatch-Class-0.02/lib/Dispatch/0000755000175000017500000000000012436353064015536 5ustar maukemaukeDispatch-Class-0.02/lib/Dispatch/Class.pm0000644000175000017500000001121612436353035017140 0ustar maukemaukepackage Dispatch::Class; use warnings; use strict; our $VERSION = '0.02'; use Scalar::Util qw(blessed); use parent 'Exporter::Tiny'; our @EXPORT_OK = qw( class_case dispatch ); sub class_case { my @prototable = @_; sub { my ($x) = @_; my $blessed = blessed $x; my $ref = ref $x; my $DOES; my @table = @prototable; while (my ($key, $value) = splice @table, 0, 2) { return $value if !defined $key ? !defined $x : $key eq '*' ? 1 : $key eq ':str' ? !$ref : $key eq $ref ? 1 : $blessed && ($DOES ||= $x->can('DOES') || 'isa', $x->$DOES($key)) ; } () } } sub dispatch { my $chk = &class_case; sub { ($chk->($_[0]) || return)->($_[0]) } } 'ok' __END__ =head1 NAME Dispatch::Class - dispatch on the type (class) of an argument =head1 SYNOPSIS use Dispatch::Class qw( class_case dispatch ); # analyze the class of an object my $analyze = class_case( 'Some::Class' => 1, 'Other::Class' => 2, 'UNIVERSAL' => "???", ); my $foo = $analyze->(Other::Class->new); # 2 my $bar = $analyze->(IO::Handle->new); # "???" my $baz = $analyze->(["not an object"]); # undef # build a dispatcher my $dispatch = dispatch( 'Dog::Tiny' => sub { ... }, # handle objects of the class Dog::Tiny 'Dog' => sub { ... }, 'Mammal' => sub { ... }, 'Tree' => sub { ... }, 'ARRAY' => sub { ... }, # handle array refs ':str' => sub { ... }, # handle non-reference strings '*' => sub { ... }, # handle any value ); # call the appropriate handler, passing $obj as an argument my $result = $dispatch->($obj); =head1 DESCRIPTION This module offers a (mostly) simple way to check the class of an object and handle specific cases specially. =head2 Functions The following functions are available and can be imported on request: =over =item C C takes a list of C pairs and returns a code reference that (when called on an object) will analyze the object's class according to the rules described below and return the corresponding I of the first matching I. Example: my $subref = class_case( KEY1 => VALUE1, KEY2 => VALUE2, ... ); my $value = $subref->($some_object); This will check the class of C<$some_object> against C, C, ... in order and return the corresponding C of the first match. If no key matches, an empty list/undef is returned in list/scalar context, respectively. The following things can be used as keys: =over =item C<*> This will match any value. No actual check is performed. =item C<:str> This special key will match any non-reference. =item C, C, C, ... These values match references of the specified type even if they aren't objects (i.e. not Led|perlfunc/bless>). That is, for unblessed references the string returned by L|perlfunc/ref> is compared with L|perlop/"Equality Operators">. =item CLASS Any other string is interpreted as a class name and matches if the input value is an object for which C<< $obj->isa($CLASS) >> is true. To match any kind of object (blessed value), use the key C<'UNIVERSAL'>. Starting with L Perl supports checking for roles with L|UNIVERSAL/obj-DOES-ROLE->, so C actually uses C<< $obj->DOES($CLASS) >> instead of C. This still returns true for normal base classes but it also accepts roles that have been composed into the object's class. =back =item C This works like C above, but the Is must be code references and get invoked automatically: sub dispatch { my $analyze = class_case @_; sub { my ($obj) = @_; my $handler = $analyze->($obj) or return; $handler->($obj) } } That is, the matching object is passed on to the matched Is and the return value of the inner sub is whatever the handler returns (or the empty list/undef if no I matches). =back This module uses L|Exporter::Tiny>, so you can rename the imported functions at L|perlfunc/use> time. =head1 SEE ALSO L =head1 AUTHOR Lukas Mai, C<< >> =head1 COPYRIGHT & LICENSE Copyright 2013, 2014 Lukas Mai. This program is free software; you can redistribute it and/or modify it under the terms of either: the GNU General Public License as published by the Free Software Foundation; or the Artistic License. See http://dev.perl.org/licenses/ for more information. =cut Dispatch-Class-0.02/META.yml0000644000175000017500000000126112436353064014502 0ustar maukemauke--- abstract: 'dispatch on the type (class) of an argument' author: - 'Lukas Mai ' build_requires: IO::Handle: '0' Test::More: '0' configure_requires: ExtUtils::MakeMaker: '6.48' strict: '0' warnings: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.02, CPAN::Meta::Converter version 2.143240' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Dispatch-Class no_index: directory: - t - inc requires: Exporter::Tiny: '0' Scalar::Util: '0' perl: '5.006000' strict: '0' warnings: '0' resources: repository: git://github.com/mauke/Dispatch-Class.git version: '0.02' Dispatch-Class-0.02/META.json0000644000175000017500000000250712436353065014657 0ustar maukemauke{ "abstract" : "dispatch on the type (class) of an argument", "author" : [ "Lukas Mai " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.02, CPAN::Meta::Converter version 2.143240", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Dispatch-Class", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : {} }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.48", "strict" : "0", "warnings" : "0" } }, "runtime" : { "requires" : { "Exporter::Tiny" : "0", "Scalar::Util" : "0", "perl" : "5.006000", "strict" : "0", "warnings" : "0" } }, "test" : { "requires" : { "IO::Handle" : "0", "Test::More" : "0" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "git://github.com/mauke/Dispatch-Class.git", "web" : "https://github.com/mauke/Dispatch-Class" } }, "version" : "0.02" } Dispatch-Class-0.02/Makefile.PL0000644000175000017500000000373212436352350015205 0ustar maukemaukeuse strict; use warnings; use ExtUtils::MakeMaker; sub merge_key_into { my ($href, $target, $source) = @_; %{$href->{$target}} = (%{$href->{$target}}, %{delete $href->{$source}}); } my %opt = ( NAME => 'Dispatch::Class', AUTHOR => q{Lukas Mai }, VERSION_FROM => 'lib/Dispatch/Class.pm', ABSTRACT_FROM => 'lib/Dispatch/Class.pm', LICENSE => 'perl', PL_FILES => {}, CONFIGURE_REQUIRES => { 'strict' => 0, 'warnings' => 0, 'ExtUtils::MakeMaker' => '6.48', }, BUILD_REQUIRES => {}, TEST_REQUIRES => { 'Test::More' => 0, 'IO::Handle' => 0, }, PREREQ_PM => { 'warnings' => 0, 'strict' => 0, 'Exporter::Tiny' => 0, 'Scalar::Util' => 0, }, MIN_PERL_VERSION => '5.6.0', depend => { Makefile => '$(VERSION_FROM)', }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Dispatch-Class-*' }, META_MERGE => { 'meta-spec' => { version => 2 }, resources => { repository => { url => 'git://github.com/mauke/Dispatch-Class.git', web => 'https://github.com/mauke/Dispatch-Class', type => 'git', }, }, }, ); (my $mm_version = ExtUtils::MakeMaker->VERSION($opt{CONFIGURE_REQUIRES}{'ExtUtils::MakeMaker'})) =~ tr/_//d; if ($mm_version < 6.67_04) { # Why? For the glory of satan, of course! no warnings qw(redefine); *ExtUtils::MM_Any::_add_requirements_to_meta_v1_4 = \&ExtUtils::MM_Any::_add_requirements_to_meta_v2; } if ($mm_version < 6.63_03) { merge_key_into \%opt, 'BUILD_REQUIRES', 'TEST_REQUIRES'; } if ($mm_version < 6.55_01) { merge_key_into \%opt, 'CONFIGURE_REQUIRES', 'BUILD_REQUIRES'; } if ($mm_version < 6.51_03) { merge_key_into \%opt, 'PREREQ_PM', 'CONFIGURE_REQUIRES'; } WriteMakefile %opt; Dispatch-Class-0.02/MANIFEST0000644000175000017500000000037012436353065014363 0ustar maukemaukeChanges Makefile.PL MANIFEST README lib/Dispatch/Class.pm t/00-load.t t/basic.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Dispatch-Class-0.02/t/0000755000175000017500000000000012436353064013474 5ustar maukemaukeDispatch-Class-0.02/t/00-load.t0000644000175000017500000000023312436351345015013 0ustar maukemauke#!perl use Test::More tests => 1; BEGIN { use_ok( 'Dispatch::Class' ); } diag( "Testing Dispatch::Class $Dispatch::Class::VERSION, Perl $], $^X" ); Dispatch-Class-0.02/t/basic.t0000644000175000017500000000317412436351333014744 0ustar maukemauke#!perl use warnings FATAL => 'all'; use strict; use Test::More tests => 17; use Dispatch::Class qw(class_case dispatch); use IO::Handle (); { package DummyClass; sub new { bless {}, $_[0] } sub subclass { my $class = shift; for my $subclass (@_) { no strict 'refs'; push @{$subclass . '::ISA'}, $class; } } } DummyClass->subclass(qw(Some::Class Other::Class)); my $analyze = class_case( 'Some::Class' => 1, 'Other::Class' => 2, 'UNIVERSAL' => "???", ); is $analyze->(Other::Class->new), 2; is $analyze->(IO::Handle->new), "???"; is $analyze->(["not an object"]), undef; is +() = $analyze->(["not an object"]), 0; DummyClass->subclass(qw(Mammal Tree)); Mammal->subclass(qw(Dog Bunny)); Dog->subclass(qw(Dog::Tiny Barky Setter)); Tree->subclass(qw(Barky)); my @trace; my $dispatch = dispatch( map { my $class = $_; $_ => sub { push @trace, $class; return $class, $_[0]; } } qw( Tree Dog::Tiny Dog ARRAY Mammal :str HASH * ) ); my @prep = ( 'Tree' => Tree->new, 'Mammal' => Mammal->new, 'Dog' => Dog->new, 'Mammal' => Bunny->new, 'Dog::Tiny' => Dog::Tiny->new, 'Tree' => Barky->new, 'Dog' => Setter->new, 'ARRAY' => [1, 2, 3], 'HASH' => {A => 'b'}, ':str' => "foo bar", ':str' => 5, '*' => IO::Handle->new, ); my @ks; for (my $i = 0; $i < @prep; $i += 2) { my ($k, $v) = @prep[$i, $i + 1]; my @got = $dispatch->($v); is_deeply \@got, [$k, $v]; push @ks, $k; } is_deeply \@trace, \@ks;