Browse files

initial commit

  • Loading branch information...
0 parents commit 48de330a10816ccd79c9331f821282254170d92d @tobyink committed Mar 24, 2013
Showing with 484 additions and 0 deletions.
  1. +2 −0 Makefile.PL
  2. +32 −0 examples/lib1.pl
  3. +117 −0 lib/Type/Library.pm
  4. +50 −0 lib/Type/Library/Util.pm
  5. +160 −0 lib/Type/Tiny.pm
  6. +6 −0 meta/changes.pret
  7. +19 −0 meta/doap.pret
  8. +8 −0 meta/makefile.pret
  9. +8 −0 meta/people.pret
  10. +30 −0 t/01basic.t
  11. +5 −0 xt/01pod.t
  12. +18 −0 xt/02pod_coverage.t
  13. +2 −0 xt/03meta_uptodate.config
  14. +5 −0 xt/03meta_uptodate.t
  15. +2 −0 xt/04eol.t
  16. +2 −0 xt/05tabs.t
  17. +18 −0 xt/06versions.t
2 Makefile.PL
@@ -0,0 +1,2 @@
+use inc::Module::Package 'RDF:tobyink 0.012';
+
32 examples/lib1.pl
@@ -0,0 +1,32 @@
+use strict;
+use warnings;
+
+BEGIN {
+ package Local::TypeLib; no thanks;
+
+ use Type::Library::Util;
+ use Data::Dumper;
+ use Scalar::Util "looks_like_number";
+
+ use base "Type::Library";
+
+ declare "String",
+ where { not ref $_ };
+
+ declare "Number",
+ as "String",
+ where { looks_like_number $_ };
+
+ declare "Integer",
+ as "Number",
+ where { $_ eq int($_) };
+};
+
+{
+ package Foo;
+ use Moose;
+ use Local::TypeLib -moose, qw(Integer);
+ has fff => (is => "ro", isa => Integer);
+}
+
+Foo->new(fff => 5.1);
117 lib/Type/Library.pm
@@ -0,0 +1,117 @@
+package Type::Library;
+
+use 5.008003;
+use strict;
+use warnings;
+
+BEGIN {
+ $Type::Tiny::AUTHORITY = 'cpan:TOBYINK';
+ $Type::Tiny::VERSION = '0.001';
+}
+
+use Scalar::Util qw< blessed >;
+use Type::Tiny;
+
+sub _confess ($;@) {
+ require Carp;
+ @_ = sprintf($_[0], @_[1..$#_]) if @_ > 1;
+ goto \&Carp::confess;
+}
+
+sub import
+{
+ my $meta = shift->meta;
+ my ($opts, @exports) = $meta->_process_tags(@_);
+ $opts->{caller} = caller;
+ $meta->_export($_, $opts) for @exports;
+}
+
+sub _process_tags
+{
+ my $meta = shift; # private; no need for ->meta
+ my ($opts, @exports) = ({});
+
+ for my $arg (@_)
+ {
+ if ($arg =~ /^[:-]moose$/i)
+ { $opts->{moose} = 1 }
+ elsif ($arg =~ /^[:-]all$/i)
+ { push @exports, map { $_, "is_$_", "to_$_" } $meta->type_names }
+ elsif ($arg =~ /^\+(.+)$/i)
+ { push @exports, map { $_, "is_$_", "to_$_" } $1 }
+ else
+ { push @exports, $arg }
+ }
+
+ return ($opts, @exports);
+}
+
+sub _export
+{
+ my $meta = shift; # private; no need for ->meta
+ my ($subname, $opts) = @_;
+ my $class = blessed($meta);
+
+ no strict "refs";
+ if ($subname =~ /^(is|to)_/ and my $coderef = $class->can($subname))
+ {
+ *{join("::", $opts->{caller}, $subname)} = $coderef;
+ return;
+ }
+
+ if (my $type = $meta->get_type($subname))
+ {
+ *{join("::", $opts->{caller}, $subname)} =
+ $opts->{moose} ? sub (;$) { $type->as_moose(@_) } : sub (;$) { @_ ? $type->with_params(@_) : $type };
+ return;
+ }
+
+ _confess "'%s' is not exported by '%s'", $subname, $class;
+}
+
+sub meta
+{
+ no strict "refs";
+ no warnings "once";
+ return $_[0] if blessed $_[0];
+ ${"$_[0]\::META"} ||= bless {}, $_[0];
+}
+
+sub add_type
+{
+ my $meta = shift->meta;
+ my $type = blessed($_[0]) ? $_[0] : ref($_[0]) ? "Type::Tiny"->new($_[0]) : "Type::Tiny"->new(@_);
+ my $name = $type->name;
+
+ $meta->{types} ||= {};
+ _confess 'type %s already exists in this library', $name if exists $meta->{types}{$name};
+ $meta->{types}{$name} = $type;
+
+ no strict "refs";
+ my $class = blessed($meta);
+ *{"$class\::$name" } = sub (;$) { $type };
+ *{"$class\::is_$name"} = sub { $type->check($_[0]) };
+ *{"$class\::to_$name"} = sub { $type->coerce($_[0]) };
+ return $type;
+}
+
+sub get_type
+{
+ my $meta = shift->meta;
+ $meta->{types}{$_[0]};
+}
+
+sub has_type
+{
+ my $meta = shift->meta;
+ exists $meta->{types}{$_[0]};
+}
+
+sub type_names
+{
+ my $meta = shift->meta;
+ keys %{ $meta->{types} };
+}
+
+1;
+
50 lib/Type/Library/Util.pm
@@ -0,0 +1,50 @@
+package Type::Library::Util;
+
+use 5.008001;
+use strict;
+use warnings;
+
+sub _confess ($;@) {
+ require Carp;
+ @_ = sprintf($_[0], @_[1..$#_]) if @_ > 1;
+ goto \&Carp::confess;
+}
+
+use Scalar::Util qw< blessed >;
+use Type::Library;
+use Type::Tiny;
+
+use Exporter qw< import >;
+our @EXPORT = qw< declare as where message >;
+
+sub as ($;@)
+{
+ parent => @_;
+}
+
+sub where (&)
+{
+ constraint => $_[0];
+}
+
+sub message (&)
+{
+ message => $_[0];
+}
+
+sub declare
+{
+ my $caller = caller->meta;
+ my ($name, %opts) = @_;
+ $opts{name} = $name;
+
+ if (defined $opts{parent} and not blessed $opts{parent})
+ {
+ $opts{parent} = $caller->get_type($opts{parent})
+ or _confess "could not find parent type";
+ }
+
+ $caller->add_type(%opts);
+}
+
+1;
160 lib/Type/Tiny.pm
@@ -0,0 +1,160 @@
+package Type::Tiny;
+
+use 5.008001;
+use strict;
+use warnings;
+
+BEGIN {
+ $Type::Tiny::AUTHORITY = 'cpan:TOBYINK';
+ $Type::Tiny::VERSION = '0.001';
+}
+
+use Scalar::Util qw< blessed >;
+
+sub _confess ($;@) {
+ require Carp;
+ @_ = sprintf($_[0], @_[1..$#_]) if @_ > 1;
+ goto \&Carp::confess;
+}
+
+use overload
+ q("") => sub { $_[0]->name },
+ q(bool) => sub { 1 },
+ q(&{}) => sub { my $t = shift; sub { $t->assert_valid(@_) } },
+ fallback => 1,
+;
+
+my @attributes = qw<
+ name parent constraint coercion message inlined
+>;
+
+sub new
+{
+ my $class = shift;
+ my %params = (@_==1) ? %{$_[0]} : @_;
+ my $self = bless {} => $class;
+ exists($params{$_}) && $self->${\"_set_$_"}(delete $params{$_}) for @attributes; # self-documenting ;-)
+ _confess 'unknown parameters (%s) passed to constructor for %s', join(q[, ], sort keys %params), $class if keys %params;
+ $self->BUILD;
+ return $self;
+}
+
+sub BUILD
+{
+ my $self = shift;
+
+ my $name;
+ defined($name = $self->name)
+ ? $self->_set_message(sub { sprintf 'value "%s" did not pass type constraint "%s"', $_[0], $name })
+ : $self->_set_message(sub { sprintf 'value "%s" did not pass type constraint', $_[0] })
+ unless $self->has_message;
+}
+
+sub _set_parent
+{
+ my $self = shift;
+ my ($parent) = @_;
+ _confess "parent must be an instance of %s", __PACKAGE__
+ unless blessed($parent) && $parent->isa(__PACKAGE__);
+ $self->{parent} = $parent;
+}
+
+for my $attr (@attributes)
+{
+ eval "sub $attr { \$_[0]{'$attr'} }"
+ unless __PACKAGE__->can("$attr");
+ eval "sub _set_$attr { \$_[0]{'$attr'} = \$_[1] }"
+ unless __PACKAGE__->can("_set_$attr");
+ eval "sub has_$attr { exists \$_[0]{'$attr'} }"
+ unless __PACKAGE__->can("has_$attr");
+ eval "sub _assert_$attr { return \$_[0]{'$attr'} if exists \$_[0]{'$attr'}; _confess '%s is not defined', '$attr'; }"
+ unless __PACKAGE__->can("_assert_$attr");
+}
+
+sub check
+{
+ my $self = shift;
+ return if $self->has_parent && !$self->parent->check($_[0]);
+ local $_ = $_[0];
+ return !!1 if $self->constraint->($_[0]);
+ return;
+}
+
+sub validate
+{
+ my $self = shift;
+ return undef if $self->check($_[0]);
+ return $self->message->($_[0]);
+}
+
+sub assert_valid
+{
+ my $self = shift;
+ return !!1 if $self->check($_[0]);
+ _confess $self->message->($_[0]);
+}
+
+sub coerce
+{
+ ...;
+}
+
+sub assert_coerce
+{
+ ...;
+}
+
+sub as_moose
+{
+ my $self = shift;
+
+ my %options = (name => $self->name);
+ $options{parent} = $self->parent->as_moose if $self->has_parent;
+ $options{constraint} = $self->constraint if $self->has_constraint;
+ $options{message} = $self->message if $self->has_message;
+ # ... coerce
+
+ require Moose::Meta::TypeConstraint;
+ return "Moose::Meta::TypeConstraint"->new(%options);
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding utf-8
+
+=head1 NAME
+
+Type::Tiny - tiny, yet Moo(se)-compatible type constraint
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=head1 BUGS
+
+Please report any bugs to
+L<http://rt.cpan.org/Dist/Display.html?Queue=Type-Tiny>.
+
+=head1 SEE ALSO
+
+=head1 AUTHOR
+
+Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
+
+=head1 COPYRIGHT AND LICENCE
+
+This software is copyright (c) 2013 by Toby Inkster.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=head1 DISCLAIMER OF WARRANTIES
+
+THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+
6 meta/changes.pret
@@ -0,0 +1,6 @@
+# This file acts as the project's changelog.
+
+`Type-Tiny 0.001 cpan:TOBYINK`
+ issued 2013-03-23;
+ label "Initial release".
+
19 meta/doap.pret
@@ -0,0 +1,19 @@
+# This file contains general metadata about the project.
+
+@prefix : <http://usefulinc.com/ns/doap#>.
+
+`Type-Tiny`
+ :programming-language "Perl" ;
+ :shortdesc "tiny, yet Moo(se)-compatible type constraint";
+ :homepage <https://metacpan.org/release/Type-Tiny>;
+ :download-page <https://metacpan.org/release/Type-Tiny>;
+ :bug-database <http://rt.cpan.org/Dist/Display.html?Queue=Type-Tiny>;
+# :repository [ a :HgRepository; :browse <https://bitbucket.org/tobyink/p5-type-tiny> ];
+ :created 2013-03-23;
+ :license <http://dev.perl.org/licenses/>;
+ :maintainer cpan:TOBYINK;
+ :developer cpan:TOBYINK.
+
+<http://dev.perl.org/licenses/>
+ dc:title "the same terms as the perl 5 programming language system itself".
+
8 meta/makefile.pret
@@ -0,0 +1,8 @@
+# This file provides instructions for packaging.
+
+`Type-Tiny`
+ perl_version_from m`Type::Tiny`;
+ version_from m`Type::Tiny`;
+ readme_from m`Type::Tiny` ;
+ .
+
8 meta/people.pret
@@ -0,0 +1,8 @@
+# This file contains data about the project developers.
+
+@prefix : <http://xmlns.com/foaf/0.1/>.
+
+cpan:TOBYINK
+ :name "Toby Inkster";
+ :mbox <mailto:tobyink@cpan.org>.
+
30 t/01basic.t
@@ -0,0 +1,30 @@
+=pod
+
+=encoding utf-8
+
+=head1 PURPOSE
+
+Test that Type::Tiny compiles.
+
+=head1 AUTHOR
+
+Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
+
+=head1 COPYRIGHT AND LICENCE
+
+This software is copyright (c) 2013 by Toby Inkster.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+
+=cut
+
+use strict;
+use warnings;
+use Test::More;
+
+use_ok('Type::Tiny');
+
+done_testing;
+
5 xt/01pod.t
@@ -0,0 +1,5 @@
+use Test::More;
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+all_pod_files_ok();
+
18 xt/02pod_coverage.t
@@ -0,0 +1,18 @@
+use XT::Util;
+use Test::More;
+use Test::Pod::Coverage;
+
+plan skip_all => __CONFIG__->{skip_all}
+ if __CONFIG__->{skip_all};
+
+if ( __CONFIG__->{modules} )
+{
+ my @modules = @{ __CONFIG__->{modules} };
+ pod_coverage_ok($_, "$_ is covered") for @modules;
+ done_testing(scalar @modules);
+}
+else
+{
+ all_pod_coverage_ok();
+}
+
2 xt/03meta_uptodate.config
@@ -0,0 +1,2 @@
+{"package":"Type-Tiny"}
+
5 xt/03meta_uptodate.t
@@ -0,0 +1,5 @@
+use XT::Util;
+use Test::More tests => 1;
+use Test::RDF::DOAP::Version;
+doap_version_ok(__CONFIG__->{package}, __CONFIG__->{version_from});
+
2 xt/04eol.t
@@ -0,0 +1,2 @@
+use Test::EOL;
+all_perl_files_ok();
2 xt/05tabs.t
@@ -0,0 +1,2 @@
+use Test::Tabs;
+all_perl_files_ok();
18 xt/06versions.t
@@ -0,0 +1,18 @@
+use XT::Util;
+use Test::More;
+use Test::HasVersion;
+
+plan skip_all => __CONFIG__->{skip_all}
+ if __CONFIG__->{skip_all};
+
+if ( __CONFIG__->{modules} )
+{
+ my @modules = @{ __CONFIG__->{modules} };
+ pm_version_ok($_, "$_ is covered") for @modules;
+ done_testing(scalar @modules);
+}
+else
+{
+ all_pm_version_ok();
+}
+

0 comments on commit 48de330

Please sign in to comment.