0.01

[gitmo/Moose.git] / lib / Moose / Util / TypeConstraints.pm

package Moose::Util::TypeConstraints;

use strict;
use warnings;

use Sub::Name    'subname';
use Scalar::Util 'blessed';

our $VERSION = '0.01';

sub import {
	shift;
	my $pkg = shift || caller();
	return if $pkg eq ':no_export';
	no strict 'refs';
	foreach my $export (qw(
		type subtype as where
		)) {
		*{"${pkg}::${export}"} = \&{"${export}"};
	}
	
	foreach my $constraint (qw(
		Any 
		Value Ref
		Str Int
		ScalarRef ArrayRef HashRef CodeRef RegexpRef
		Object
		)) {
		*{"${pkg}::${constraint}"} = \&{"${constraint}"};
	}	
	
}

my %TYPES;

# might need this later
#sub find_type_constraint { $TYPES{$_[0]} }

sub type ($$) {
	my ($name, $check) = @_;
	my $pkg = caller();
	my $full_name = "${pkg}::${name}";
	no strict 'refs';
	*{$full_name} = $TYPES{$name} = subname $full_name => sub { 
		return $TYPES{$name} unless defined $_[0];
		local $_ = $_[0];
		return undef unless $check->($_[0]);
		$_[0];
	};
}

sub subtype ($$;$) {
	my ($name, $parent, $check) = @_;
	if (defined $check) {
		my $pkg = caller();
		my $full_name = "${pkg}::${name}";		
		no strict 'refs';
		$parent = $TYPES{$parent} unless $parent && ref($parent) eq 'CODE';
		*{$full_name} = $TYPES{$name} = subname $full_name => sub { 
			return $TYPES{$name} unless defined $_[0];			
			local $_ = $_[0];
			return undef unless defined $parent->($_[0]) && $check->($_[0]);
			$_[0];
		};	
	}
	else {
		($parent, $check) = ($name, $parent);
		$parent = $TYPES{$parent} unless $parent && ref($parent) eq 'CODE';		
		return subname((caller() . '::__anon_subtype__') => sub { 
			return $TYPES{$name} unless defined $_[0];			
			local $_ = $_[0];
			return undef unless defined $parent->($_[0]) && $check->($_[0]);
			$_[0];
		});		
	}
}

sub as    ($) { $_[0] }
sub where (&) { $_[0] }

# define some basic types

type Any => where { 1 };

type Value => where { !ref($_) };
type Ref   => where {  ref($_) };

subtype Int => as Value => where {  Scalar::Util::looks_like_number($_) };
subtype Str => as Value => where { !Scalar::Util::looks_like_number($_) };

subtype ScalarRef => as Ref => where { ref($_) eq 'SCALAR' };	
subtype ArrayRef  => as Ref => where { ref($_) eq 'ARRAY'  };
subtype HashRef   => as Ref => where { ref($_) eq 'HASH'   };	
subtype CodeRef   => as Ref => where { ref($_) eq 'CODE'   };
subtype RegexpRef => as Ref => where { ref($_) eq 'Regexp' };	

# NOTE: 
# blessed(qr/.../) returns true,.. how odd
subtype Object => as Ref => where { blessed($_) && blessed($_) ne 'Regexp' };

1;

__END__

=pod

=head1 NAME

Moose::Util::TypeConstraints - Type constraint system for Moose

=head1 SYNOPSIS

  use Moose::Util::TypeConstraints;

  type Num => where { Scalar::Util::looks_like_number($_) };
  
  subtype Natural 
      => as Num 
      => where { $_ > 0 };
  
  subtype NaturalLessThanTen 
      => as Natural
      => where { $_ < 10 };

=head1 DESCRIPTION

This module provides Moose with the ability to create type contraints 
to be are used in both attribute definitions and for method argument 
validation. 

This is B<NOT> a type system for Perl 5.

The type and subtype constraints are basically functions which will 
validate their first argument. If called with no arguments, they will 
return themselves (this is syntactic sugar for Moose attributes).

This module also provides a simple hierarchy for Perl 5 types, this 
could probably use some work, but it works for me at the moment.

  Any
      Value
          Int
          Str
      Ref
          ScalarRef
          ArrayRef
          HashRef
          CodeRef
          RegexpRef
          Object	

Suggestions for improvement are welcome.	
    
=head1 FUNCTIONS

=head2 Type Constraint Constructors

=over 4

=item B<type>

=item B<subtype>

=item B<as>

=item B<where>

=back

=head2 Built-in Type Constraints

=over 4

=item B<Any>

=item B<Value>

=item B<Int>

=item B<Str>

=item B<Ref>

=item B<ArrayRef>

=item B<CodeRef>

=item B<HashRef>

=item B<RegexpRef>

=item B<ScalarRef>

=item B<Object>

=back

=head1 BUGS

All complex software has bugs lurking in it, and this module is no 
exception. If you find a bug please either email me, or add the bug
to cpan-RT.

=head1 AUTHOR

Stevan Little E<lt>stevan@iinteractive.comE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright 2006 by Infinity Interactive, Inc.

L<http://www.iinteractive.com>

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. 

=cut