Declare-Constraints-Simple-0.03/0000755000175000017500000000000010502260174017672 5ustar phaylonphaylon00000000000000Declare-Constraints-Simple-0.03/inc/0000755000175000017500000000000010502260174020443 5ustar phaylonphaylon00000000000000Declare-Constraints-Simple-0.03/inc/Module/0000755000175000017500000000000010502260174021670 5ustar phaylonphaylon00000000000000Declare-Constraints-Simple-0.03/inc/Module/Install.pm0000644000175000017500000001761110502260017023636 0ustar phaylonphaylon00000000000000#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.004; use strict 'vars'; use vars qw{$VERSION}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '0.64'; } # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE"; Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE } # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 and (stat($0))[9] > time ) { die << "END_DIE"; Your installer $0 has a modification time in the future. This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } use Cwd (); use File::Find (); use File::Path (); use FindBin; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # delegate back to parent dirs goto &$code unless $cwd eq $pwd; } $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; unshift @_, ($self, $1); goto &{$self->can('call')} unless uc($1) eq $1; }; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; unless ( -f $self->{file} ) { require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{"$self->{file}"}; delete $INC{"$self->{path}.pm"}; } sub preload { my ($self) = @_; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { my $admin = $self->{admin}; @exts = $admin->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = delete $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { open PKGFILE, "<$subpath.pm" or die "find_extensions: Can't open $subpath.pm: $!"; my $in_pod = 0; while ( ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } close PKGFILE; } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } 1; Declare-Constraints-Simple-0.03/inc/Module/Install/0000755000175000017500000000000010502260174023276 5ustar phaylonphaylon00000000000000Declare-Constraints-Simple-0.03/inc/Module/Install/Makefile.pm0000644000175000017500000001337310502260022025350 0ustar phaylonphaylon00000000000000#line 1 package Module::Install::Makefile; use strict 'vars'; use Module::Install::Base; use ExtUtils::MakeMaker (); use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.64'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing, always use defaults if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } sub makemaker_args { my $self = shift; my $args = ($self->{makemaker_args} ||= {}); %$args = ( %$args, @_ ) if @_; $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{name} = defined $args->{$name} ? join( ' ', $args->{name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join(' ', grep length, $clean->{FILES}, @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join(' ', grep length, $realclean->{FILES}, @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name || $self->determine_NAME($args); $args->{VERSION} = $self->version || $self->determine_VERSION($args); $args->{NAME} =~ s/-/::/g; if ( $self->tests ) { $args->{test} = { TESTS => $self->tests }; } if ($] >= 5.005) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = $self->author; } if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { $args->{NO_META} = 1; } if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } # merge both kinds of requires into prereq_pm my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_, ($self->build_requires, $self->requires) ); # merge both kinds of requires into prereq_pm my $subdirs = ($args->{DIR} ||= []); if ($self->bundles) { foreach my $bundle (@{ $self->bundles }) { my ($file, $dir) = @$bundle; push @$subdirs, $dir if -d $dir; delete $prereq->{$file}; } } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args; if ($self->admin->preop) { $args{dist} = $self->admin->preop; } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; my $makefile = do { local $/; }; close MAKEFILE or die $!; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/("?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 334 Declare-Constraints-Simple-0.03/inc/Module/Install/Metadata.pm0000644000175000017500000001747610502260021025362 0ustar phaylonphaylon00000000000000#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.64'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } my @scalar_keys = qw{ name module_name abstract author version license distribution_type perl_version tests }; my @tuple_keys = qw{ build_requires requires recommends bundles }; sub Meta { shift } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } foreach my $key (@scalar_keys) { *$key = sub { my $self = shift; return $self->{values}{$key} if defined wantarray and !@_; $self->{values}{$key} = shift; return $self; }; } foreach my $key (@tuple_keys) { *$key = sub { my $self = shift; return $self->{values}{$key} unless @_; my @rv; while (@_) { my $module = shift or last; my $version = shift || 0; if ( $module eq 'perl' ) { $version =~ s{^(\d+)\.(\d+)\.(\d+)} {$1 + $2/1_000 + $3/1_000_000}e; $self->perl_version($version); next; } my $rv = [ $module, $version ]; push @rv, $rv; } push @{ $self->{values}{$key} }, @rv; @rv; }; } sub sign { my $self = shift; return $self->{'values'}{'sign'} if defined wantarray and !@_; $self->{'values'}{'sign'} = ( @_ ? $_[0] : 1 ); return $self; } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config, skipping\n"; return $self; } $self->{'values'}{'dynamic_config'} = $_[0] ? 1 : 0; return $self; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die "all_from called with no args without setting name() first"; $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; die "all_from: cannot find $file from $name" unless -e $file; } $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; # The remaining probes read from POD sections; if the file # has an accompanying .pod, use that instead my $pod = $file; if ( $pod =~ s/\.pm$/.pod/i and -e $pod ) { $file = $pod; } $self->author_from($file) unless $self->author; $self->license_from($file) unless $self->license; $self->abstract_from($file) unless $self->abstract; } sub provides { my $self = shift; my $provides = ( $self->{values}{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides(%{ $build->find_dist_packages || {} }); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}{no_index}{$type} }, @_ if $type; return $self->{values}{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML', 0 ); require YAML; my $data = YAML::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { my ( $self, $file ) = @_; require ExtUtils::MM_Unix; $self->version( ExtUtils::MM_Unix->parse_version($file) ); } sub abstract_from { my ( $self, $file ) = @_; require ExtUtils::MM_Unix; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } sub _slurp { my ( $self, $file ) = @_; local *FH; open FH, "< $file" or die "Cannot open $file.pod: $!"; do { local $/; }; } sub perl_version_from { my ( $self, $file ) = @_; if ( $self->_slurp($file) =~ m/ ^ use \s* v? ([\d_\.]+) \s* ; /ixms ) { my $v = $1; $v =~ s{_}{}g; $self->perl_version($1); } else { warn "Cannot determine perl version info from $file\n"; return; } } sub author_from { my ( $self, $file ) = @_; my $content = $self->_slurp($file); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; $author =~ s{E}{<}g; $author =~ s{E}{>}g; $self->author($author); } else { warn "Cannot determine author info from $file\n"; } } sub license_from { my ( $self, $file ) = @_; if ( $self->_slurp($file) =~ m/ =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b (.*?) (=head\\d.*|=cut.*|) \z /ixms ) { my $license_text = $1; my @phrases = ( 'under the same (?:terms|license) as perl itself' => 'perl', 'GNU public license' => 'gpl', 'GNU lesser public license' => 'gpl', 'BSD license' => 'bsd', 'Artistic license' => 'artistic', 'GPL' => 'gpl', 'LGPL' => 'lgpl', 'BSD' => 'bsd', 'Artistic' => 'artistic', ); while ( my ( $pattern, $license ) = splice( @phrases, 0, 2 ) ) { $pattern =~ s{\s+}{\\s+}g; if ( $license_text =~ /\b$pattern\b/i ) { $self->license($license); return 1; } } } warn "Cannot determine license info from $file\n"; return 'unknown'; } 1; Declare-Constraints-Simple-0.03/inc/Module/Install/WriteAll.pm0000644000175000017500000000162410502260021025351 0ustar phaylonphaylon00000000000000#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.64'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_ ); $self->sign(1) if $args{sign}; $self->Meta->write if $args{meta}; $self->admin->WriteAll(%args) if $self->is_admin; if ( $0 =~ /Build.PL$/i ) { $self->Build->write; } else { $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{'PL_FILES'} ) { $self->makemaker_args( PL_FILES => {} ); } if ($args{inline}) { $self->Inline->write; } else { $self->Makefile->write; } } } 1; Declare-Constraints-Simple-0.03/inc/Module/Install/Win32.pm0000644000175000017500000000341610502260022024532 0ustar phaylonphaylon00000000000000#line 1 package Module::Install::Win32; use strict; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.64'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); if (!$rv) { die <<'END_MESSAGE'; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } } 1; Declare-Constraints-Simple-0.03/inc/Module/Install/Fetch.pm0000644000175000017500000000463010502260022024660 0ustar phaylonphaylon00000000000000#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base; use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.64'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Declare-Constraints-Simple-0.03/inc/Module/Install/Base.pm0000644000175000017500000000203510502260021024475 0ustar phaylonphaylon00000000000000#line 1 package Module::Install::Base; $VERSION = '0.64'; # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } ### This is the ONLY module that shouldn't have strict on # use strict; #line 41 sub new { my ($class, %args) = @_; foreach my $method ( qw(call load) ) { *{"$class\::$method"} = sub { shift()->_top->$method(@_); } unless defined &{"$class\::$method"}; } bless( \%args, $class ); } #line 61 sub AUTOLOAD { my $self = shift; local $@; my $autoload = eval { $self->_top->autoload } or return; goto &$autoload; } #line 76 sub _top { $_[0]->{_top} } #line 89 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } sub is_admin { $_[0]->admin->VERSION; } sub DESTROY {} package Module::Install::Base::FakeAdmin; my $Fake; sub new { $Fake ||= bless(\@_, $_[0]) } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 138 Declare-Constraints-Simple-0.03/inc/Module/Install/Can.pm0000644000175000017500000000337410502260022024334 0ustar phaylonphaylon00000000000000#line 1 package Module::Install::Can; use strict; use Module::Install::Base; use Config (); ### This adds a 5.005 Perl version dependency. ### This is a bug and will be fixed. use File::Spec (); use ExtUtils::MakeMaker (); use vars qw{$VERSION $ISCORE @ISA}; BEGIN { $VERSION = '0.64'; $ISCORE = 1; @ISA = qw{Module::Install::Base}; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 157 Declare-Constraints-Simple-0.03/Changes0000644000175000017500000000224610502257465021202 0ustar phaylonphaylon00000000000000 [0.03] - Added ReturnTrue and ReturnFalse - Added CaseValid - Added OnEvenElements and OnOddElements - Catch unknown Constraints - Added OnArrayElements - Minor POD corrections. [0.02] Sun Sep 10 23:22:55 CEST 2006 - Added IsEq scalar constraint. - Added Scope, SetResult and IsValid. - Fixed error in Or. Correct results are returned now. - Fixed error in OnHashKeys. Hash key constraints are now processed in the order they are defined. - Custom libraries are now possible. - Much better constraint POD. - Interior of Message constraint is now in the _with_message sub. - Introduced use D:C:S-Library import for libraries. - Split of the Library into Sub-Libraries. The Library package itself is now just a bundle of all shipped libraries. It's POD serves as docmap for the constraints. - Corrected minor POD typos. - Stack info now escapes [ and ]. - General TODO updates. - Split of the USAGE section into subsections. - Added a Custom constraint to the TODO list. - Forgot to add date to Changes file. /me slaps self. [0.01] Sat Sep 9 18:22:08 CEST 2006 - Initial Release. Declare-Constraints-Simple-0.03/t/0000755000175000017500000000000010502260174020135 5ustar phaylonphaylon00000000000000Declare-Constraints-Simple-0.03/t/23-stacknames.t0000644000175000017500000000303110501243224022666 0ustar phaylonphaylon00000000000000#!/usr/bin/perl use warnings; use strict; use Test::More; use Declare::Constraints::Simple-All; { package FooTest; sub foo { } } my $obj = bless {} => 'FooTest'; my @test_sets = ( [Matches(qr/foo/), 'bar', 'Matches', 'Matches stackname'], [IsDefined, undef, 'IsDefined', 'IsDefined stackname'], [HasMethods(qw(foo bar)), $obj, 'HasMethods[bar]', 'HasMethods stackname'], [IsArrayRef(IsInt), [1,2,undef], 'IsArrayRef[2].IsInt', 'IsArrayRef stackname'], [IsHashRef(-keys => IsInt), {foo => 23}, 'IsHashRef[key foo].IsInt', 'IsHashRef key stackname'], [IsHashRef(-values => IsInt), {foo => 'bar'}, 'IsHashRef[val foo].IsInt', 'IsHashRef val stackname'], [HasAllKeys(qw(foo bar)), {foo => 23}, 'HasAllKeys[bar]', 'HasAllKeys stackname'], [OnHashKeys(foo => IsInt), {foo => 'bar'}, 'OnHashKeys[foo].IsInt', 'OnHashKeys stackname'], [Message('foo', IsInt), 'foobar', 'Message.IsInt', 'Message stackname'], [HasAllKeys(']Woot['), {}, 'HasAllKeys[\]Woot\[]', 'stack info escaped'], ); plan tests => scalar(@test_sets); for (@test_sets) { my ($check, $value, $path, $title) = @$_; my $result = $check->($value); is($result->path, $path, $title); } Declare-Constraints-Simple-0.03/t/00-basics.t0000644000175000017500000000015710500014350021775 0ustar phaylonphaylon00000000000000#!/usr/bin/perl use warnings; use strict; use Test::More tests => 1; use_ok('Declare::Constraints::Simple'); Declare-Constraints-Simple-0.03/t/10-constraints-operators.t0000644000175000017500000000313210502254441025122 0ustar phaylonphaylon00000000000000#!/usr/bin/perl use warnings; use strict; use Test::More; use Declare::Constraints::Simple only => qw(And Or XOr Not Matches IsInt IsTrue); my @test_sets = ( [Not, "foo", 1, 'Not without arg always true'], [Not(IsTrue), 0, 1, 'Not is true'], [Not(Not(IsTrue)), 23, 1, 'Not doubled neutralizes'], [Not(IsTrue), 23, 0, 'Not turns true to false'], [XOr(IsTrue,IsInt), 23, 0, 'XOr false on two true'], [XOr(IsTrue,IsInt,Matches(qr//)), "", 1, 'XOr true on one true'], [XOr(IsTrue,IsInt), "", 0, 'XOr false on two false'], [XOr, 23, 0, 'XOr empty is false'], [Or(IsTrue,IsInt,Matches(qr//)), "", 1, 'Or true on one true'], [Or(IsTrue,IsInt,Matches(qr/x/)), "x", 1, 'Or true on two true'], [Or(IsTrue,IsInt,Matches(qr/x/)), "", 0, 'Or false on all false'], [Or, 23, 0, 'Or empty is false'], [And(IsTrue,IsInt), "foo", 0, 'And one true'], [And(IsTrue,IsInt), 23, 1, 'And both true'], [And(IsTrue,IsInt), "", 0, 'And none true'], [And, 23, 1, 'Or empty is true'], ); plan tests => scalar(@test_sets); for (@test_sets) { my ($check, $value, $expect, $title) = @$_; my $result = $check->($value); is(($result ? 1 : 0), $expect, $title); } Declare-Constraints-Simple-0.03/t/33-complex.t0000644000175000017500000000624010502256576022231 0ustar phaylonphaylon00000000000000#!/usr/bin/perl use warnings; use strict; use Test::More; use Declare::Constraints::Simple-All; my $profile = And( IsHashRef, HasAllKeys( qw(foo bar baz) ), OnHashKeys( foo => IsArrayRef( IsInt ), bar => Message('Definition Error', IsDefined), baz => IsHashRef(-values => Matches(qr/oo/)), boo => CaseValid( IsInt, ReturnTrue, IsArrayRef, And( HasArraySize(4,4), OnEvenElements(IsInt) ), IsHashRef, And( HasAllKeys(qw(ka kb)), OnHashKeys(ka => IsInt, kb => IsDefined) ), ReturnTrue, ReturnFalse('default conseq') ))); our $data = { foo => [1, 2, 3], bar => "Fnord!", baz => { 23 => 'foobar', 5 => 'Foo Fighters', 12 => 'boolean rockz', }, boo => 23, }; my @ret = (ReturnFalse('foo'), ReturnFalse('bar')); my @test_sets = ( [sub { is($ret[0]->(23)->message, 'foo', 'correct false message I'); is($ret[1]->(23)->message, 'bar', 'correct false message II'); }, 2], [sub { $data->{boo} = []; like($profile->($data)->message, qr/4/, 'case valid array fail'); $data->{boo} = [qw(1 foo 2 bar)]; ok($profile->($data), 'case valid array success'); $data->{boo} = {}; like($profile->($data)->message, qr/ka/, 'case valid hash fail key a'); $data->{boo}{ka} = 23; like($profile->($data)->message, qr/kb/, 'case valid hash fail key b'); $data->{boo}{kb} = 'foo'; ok($profile->($data), 'case valid hash success'); $data->{boo} = "foo"; is($profile->($data)->message, 'default conseq', 'case valid default'); $data->{boo} = 23; ok($profile->($data), 'all is well'); }, 7], [sub { push @{$data->{foo}}, 'Hooray'; my $e = $profile->($data); ok(!$e, 'array ref fails'); is($e->path, 'And.OnHashKeys[foo].IsArrayRef[3].IsInt', 'correct path'); pop @{$data->{foo}}; }, 2], [sub { $data->{baz}{42} = 'Not as hot as 23'; my $e = $profile->($data); ok(!$e, 'value match on hoh fails'); is($e->path, 'And.OnHashKeys[baz].IsHashRef[val 42].Matches', 'correct path'); delete $data->{baz}{42}; }, 2], [sub { undef $data->{bar}; my $e = $profile->($data); ok(!$e, 'defined fails'); is($e->path, 'And.OnHashKeys[bar].Message.IsDefined', 'correct path'); is($e->message, 'Definition Error', 'correct message'); $data->{bar} = "Fnord again!"; }, 3], [sub { my $e = $profile->($data); ok($e, 'complex structure passes'); }, 1], ); #@test_sets = ($test_sets[3]); my @counts = map { $_->[1] } @test_sets; my $count; $count += $_ for @counts; plan tests => $count; $_->[0]->() for @test_sets; Declare-Constraints-Simple-0.03/t/99-podcover.t0000644000175000017500000000030010501243224022367 0ustar phaylonphaylon00000000000000use Test::More; eval "use Test::Pod::Coverage 1.00"; plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@; all_pod_coverage_ok({ also_private => [qr([A-Z])] }); Declare-Constraints-Simple-0.03/t/06-constraints-array.t0000644000175000017500000000614110502243435024233 0ustar phaylonphaylon00000000000000#!/usr/bin/perl use warnings; use strict; use Test::More; use Declare::Constraints::Simple Only => qw( HasArraySize OnArrayElements OnEvenElements OnOddElements HasLength IsInt Matches And); my @test_sets = ( [HasArraySize, undef, 0, 'HasArraySize undef'], [HasArraySize, 'foo', 0, 'HasArraySize string'], [HasArraySize, [], 0, 'HasArraySize default empty'], [HasArraySize, [1], 1, 'HasArraySize default one element'], [HasArraySize, [1,2], 1, 'HasArraySize default two elements'], [HasArraySize(2), [1], 0, 'HasArraySize(2) one element'], [HasArraySize(2), [1,2], 1, 'HasArraySize(2) two elements'], [HasArraySize(2), [1,2,3], 1, 'HasArraySize(2) three elements'], [HasArraySize(2,3), [1,2], 1, 'HasArraySize(2,3) two elements'], [HasArraySize(2,3), [1,2,3], 1, 'HasArraySize(2,3) three elements'], [HasArraySize(2,3), [1,2,3,4], 0, 'HasArraySize(2,3) four elements'], [OnArrayElements(0, IsInt, 1, HasLength), [1,'2'], 1, 'OnArrayElements two true'], [OnArrayElements(0, IsInt, 1, HasLength), ['f'], 0, 'OnArrayElements only one and false'], [OnArrayElements(0, IsInt, 1, HasLength), [], 1, 'OnArrayElements true on empty list'], [OnArrayElements(0, IsInt, 1, HasLength), [2], 1, 'OnArrayElements one true'], [OnArrayElements(0, IsInt, 1, HasLength), [undef], 0, 'OnArrayElements undef value'], [OnArrayElements(0, IsInt, 1, HasLength), undef, 0, 'OnArrayElements undef'], [OnArrayElements(0, IsInt, 1, HasLength), "foo", 0, 'OnArrayElements string'], [OnEvenElements(IsInt), undef, 0, 'OnEvenElements undef'], [OnEvenElements(IsInt), "foo", 0, 'OnEvenElements string'], [OnEvenElements(IsInt), [], 1, 'OnEvenElements true on empty'], [OnEvenElements(IsInt), [1..3], 1, 'OnEvenElements true'], [OnEvenElements(IsInt), ['a',1], 0, 'OnEvenElements false, odd true'], [OnEvenElements(IsInt), [1,'a'], 1, 'OnEvenElements true, odd false'], [OnOddElements(IsInt), undef, 0, 'OnOddElements undef'], [OnOddElements(IsInt), "foo", 0, 'OnOddElements string'], [OnOddElements(IsInt), [], 1, 'OnOddElements true on empty'], [OnOddElements(IsInt), [1..3], 1, 'OnOddElements true'], [OnOddElements(IsInt), ['a',1], 1, 'OnOddElements true, odd false'], [OnOddElements(IsInt), [1,'a'], 0, 'OnOddElements false, odd true'], [And(OnEvenElements(IsInt),OnOddElements(Matches(qr/foo/))), [1,"foob"], 1, 'OnOddElements + OnEvenElements true'], [And(OnEvenElements(IsInt),OnOddElements(Matches(qr/foo/))), ["foob",2], 0, 'OnOddElements + OnEvenElements false'], ); plan tests => scalar(@test_sets); for (@test_sets) { my ($check, $value, $expect, $title) = @$_; my $result = $check->($value); is(($result ? 1 : 0), $expect, $title); } Declare-Constraints-Simple-0.03/t/04-constraints-reference.t0000644000175000017500000001146710500277732025065 0ustar phaylonphaylon00000000000000#!/usr/bin/perl use warnings; use strict; use Test::More; use Declare::Constraints::Simple only => qw( IsRefType IsScalarRef IsCodeRef IsArrayRef IsHashRef IsRegex IsInt Matches ); my @test_sets = ( [IsRefType(qw(CODE ARRAY)), [], 1, 'IsRefType array true'], [IsRefType(qw(CODE ARRAY)), sub {}, 1, 'IsRefType code true'], [IsRefType(qw(CODE HASH)), [], 0, 'IsRefType array false'], [IsRefType(qw(CODE ARRAY)), "foo", 0, 'IsRefType no ref'], [IsRefType(qw(CODE ARRAY)), undef, 0, 'IsRefType undef'], [IsRefType(qw(Regexp)), qr/x/, 1, 'IsRefType regex true'], [IsRefType(qw(Foo)), bless({}, 'Foo'), 1, 'IsRefType blessed'], [IsScalarRef, "foo", 0, 'IsScalarRef scalar false'], [IsScalarRef, \"foo", 1, 'IsScalarRef true'], [IsScalarRef, {}, 0, 'IsScalarRef hash ref'], [IsScalarRef, undef, 0, 'IsScalarRef undef'], [IsScalarRef(IsInt), "foo", 0, 'IsScalarRef nested string false'], [IsScalarRef(IsInt), 23, 0, 'IsScalarRef nested number false'], [IsScalarRef(IsInt), \"foo", 0, 'IsScalarRef nested ref false'], [IsScalarRef(IsInt), \"12", 1, 'IsScalarRef nested int true'], [IsScalarRef(IsInt), undef, 0, 'IsScalarRef nested undef'], [IsScalarRef(IsInt), \undef, 0, 'IsScalarRef nested undef ref'], [IsScalarRef(IsInt,Matches(qr/2/)), \"12", 1, 'IsScalarRef nested two both'], [IsScalarRef(IsInt,Matches(qr/2/)), \"33", 0, 'IsScalarRef nested two one false'], [IsScalarRef(IsInt,Matches(qr/2/)), \"foo", 0, 'IsScalarRef nested two both false'], [IsScalarRef(IsInt,Matches(qr/2/)), undef, 0, 'IsScalarRef nested two undef'], [IsScalarRef(IsInt,Matches(qr/2/)), \undef, 0, 'IsScalarRef nested two undef ref'], [IsCodeRef, undef, 0, 'IsCodeRef undef'], [IsCodeRef, [], 0, 'IsCodeRef array ref'], [IsCodeRef, "foo", 0, 'IsCodeRef string'], [IsCodeRef, sub {}, 1, 'IsCodeRef true'], [IsArrayRef, undef, 0, 'IsArrayRef undef'], [IsArrayRef, {}, 0, 'IsArrayRef hash ref'], [IsArrayRef, "foo", 0, 'IsArrayRef string'], [IsArrayRef, [], 1, 'IsArrayRef true'], [IsArrayRef(IsInt), [1..3], 1, 'IsArrayRef of IsInt true'], [IsArrayRef(IsInt), undef, 0, 'IsArrayRef of IsInt undef'], [IsArrayRef(IsInt), [qw(1 2 foo 3)], 0, 'IsArrayRef of IsInt one false'], [IsArrayRef(IsInt), [qw(a b c)], 0, 'IsArrayRef of IsInt all false'], [IsArrayRef(IsArrayRef), [[],[]], 1, 'IsArrayRef of IsArrayRef true'], [IsArrayRef(IsInt), [undef], 0, 'IsArrayRef of IsInt undef in array'], [IsHashRef, undef, 0, 'IsHashRef undef'], [IsHashRef, "foo", 0, 'IsHashRef string'], [IsHashRef, {}, 1, 'IsHashRef true'], [IsHashRef(-values => IsInt), {foo => "bar"}, 0, 'IsHashRef IsInt vals false'], [IsHashRef(-values => IsInt), {foo => 23}, 1, 'IsHashRef IsInt vals true'], [IsHashRef(-values => [IsInt]), {foo => 23}, 1, 'IsHashRef IsInt vals list true'], [IsHashRef(-keys => IsInt), {foo => "bar"}, 0, 'IsHashRef IsInt keys false'], [IsHashRef(-keys => IsInt), {123 => "bar"}, 1, 'IsHashRef IsInt keys true'], [IsHashRef(-keys => [IsInt]), {123 => "bar"}, 1, 'IsHashRef IsInt keys list true'], [IsRegex, undef, 0, 'IsRegex undef'], [IsRegex, "foo", 0, 'IsRegex string'], [IsRegex, [], 0, 'IsRegex array ref'], [IsRegex, qr/foo/, 1, 'IsRegex true'], ); plan tests => scalar(@test_sets); for (@test_sets) { my ($check, $value, $expect, $title) = @$_; my $result = $check->($value); is(($result ? 1 : 0), $expect, $title); } Declare-Constraints-Simple-0.03/t/03-constraints-oo.t0000644000175000017500000000413610501243223023523 0ustar phaylonphaylon00000000000000#!/usr/bin/perl use warnings; use strict; use Test::More; use Declare::Constraints::Simple only => qw(IsA IsClass HasMethods IsObject); { package TestA; sub foo { } sub bar { } package TestB; use base 'TestA'; sub foo { } } my $testA = bless {} => 'TestA'; my $testB = bless {} => 'TestB'; my @test_sets = ( [IsA(qw(TestNone TestA)), $testA, 1, 'IsA multiple true'], [IsA('TestB'), $testA, 0, 'IsA false'], [IsA('TestA'), undef, 0, 'IsA undef'], [IsA(), $testA, 0, 'IsA empty'], [IsA('TestA'), 'TestB', 1, 'IsA class true'], [IsA('TestA'), 'Foo', 0, 'IsA class unknown'], [IsA('TestB'), 'TestA', 0, 'IsA class false'], [IsClass, 'Foo', 0, 'IsClass false'], [IsClass, undef, 0, 'IsClass undef'], [IsClass, 'TestA', 1, 'IsClass true'], [IsObject, undef, 0, 'IsObject undef'], [IsObject, "foo", 0, 'IsObject string'], [IsObject, {}, 0, 'IsObject hash ref'], [IsObject, $testA, 1, 'IsObject true'], [HasMethods(qw(foo)), $testA, 1, 'HasMethods true'], [HasMethods(qw(foo bar)), $testA, 1, 'HasMethods multiple true'], [HasMethods(qw(foo baz)), $testA, 0, 'HasMethods half false'], [HasMethods(qw(baz)), $testA, 0, 'HasMethods all false'], [HasMethods(qw(bar)), $testB, 1, 'HasMethods inherited true'], [HasMethods(), $testB, 1, 'HasMethods no list true'], [HasMethods(), "foo", 0, 'HasMethods no list no class'], [HasMethods(qw(foo)), undef, 0, 'HasMethods undef'], ); plan tests => scalar(@test_sets); for (@test_sets) { my ($check, $value, $expect, $title) = @$_; my $result = $check->($value); is(($result ? 1 : 0), $expect, $title); } Declare-Constraints-Simple-0.03/t/12-general.t0000644000175000017500000000122410502254735022164 0ustar phaylonphaylon00000000000000#!/usr/bin/perl use warnings; use strict; use Test::More; use Declare::Constraints::Simple only => qw(ReturnTrue ReturnFalse); my @test_sets = ( [ReturnTrue, undef, 1, 'ReturnTrue undef'], [ReturnTrue, 12, 1, 'ReturnTrue number'], [ReturnTrue, [], 1, 'ReturnTrue array ref'], [ReturnFalse('x'), undef, 0, 'ReturnFalse undef'], [ReturnFalse('x'), [], 0, 'ReturnFalse array ref'], ); plan tests => scalar(@test_sets); for (@test_sets) { my ($check, $value, $expect, $title) = @$_; my $result = $check->($value); is(($result ? 1 : 0), $expect, $title); } Declare-Constraints-Simple-0.03/t/05-constraints-hash.t0000644000175000017500000000322010500277760024040 0ustar phaylonphaylon00000000000000#!/usr/bin/perl use warnings; use strict; use Test::More; use Declare::Constraints::Simple only => qw(HasAllKeys OnHashKeys Matches IsInt); my @test_sets = ( [HasAllKeys(qw(foo bar)), {foo => 1, baz => 2}, 0, 'HasAllKeys one missing'], [HasAllKeys(qw(foo bar)), {foo => 1, bar => 2}, 1, 'HasAllKeys true'], [HasAllKeys(qw(foo bar)), undef, 0, 'HasAllKeys undef'], [HasAllKeys(qw(foo bar)), [], 0, 'HasAllKeys array ref'], [HasAllKeys(qw(foo bar)), "foo", 0, 'HasAllKeys string'], [ OnHashKeys(foo => IsInt, bar => Matches(qr/x/)), { foo => 12, bar => "fox" }, 1, 'OnHashKeys both true'], [ OnHashKeys(foo => IsInt, bar => Matches(qr/x/)), { foo => 23, bar => 5 }, 0, 'OnHashKeys one false'], [ OnHashKeys(foo => IsInt, bar => Matches(qr/x/)), { foo => 23 }, 1, 'OnHashKeys one missing true'], [ OnHashKeys(foo => IsInt), undef, 0, 'OnHashKeys undef'], [ OnHashKeys(foo => IsInt), [], 0, 'OnHashKeys array ref'], [ OnHashKeys(foo => [IsInt, Matches(qr/3/)]), { foo => 23 }, 1, 'OnHashKeys list true'], [ OnHashKeys(foo => [IsInt, Matches(qr/3/)]), { foo => 5 }, 0, 'OnHashKeys list false'], ); plan tests => scalar(@test_sets); for (@test_sets) { my ($check, $value, $expect, $title) = @$_; my $result = $check->($value); is(($result ? 1 : 0), $expect, $title); } Declare-Constraints-Simple-0.03/t/02-constraints-numerical.t0000644000175000017500000000203510500277627025076 0ustar phaylonphaylon00000000000000#!/usr/bin/perl use warnings; use strict; use Test::More; use Declare::Constraints::Simple only => qw(IsNumber IsInt); my @test_sets = ( [IsNumber, undef, 0, 'IsNumber undef'], [IsNumber, "foo", 0, 'IsNumber string'], [IsNumber, [], 0, 'IsNumber array ref'], [IsNumber, 23, 1, 'IsNumber 23'], [IsNumber, 0xDEAD, 1, 'IsNumber 0xDEAD'], [IsNumber, "23", 1, 'IsNumber "23"'], [IsInt, undef, 0, 'IsInt undef'], [IsInt, "foo", 0, 'IsInt string'], [IsInt, [], 0, 'IsInt array ref'], [IsInt, 23, 1, 'IsInt 23'], [IsInt, -23, 1, 'IsInt -23'], [IsInt, 11.5, 0, 'IsInt float'], [IsInt, 0xDEAD, 1, 'IsInt 0xDEAD (converted)'], [IsInt, "1b2", 0, 'IsInt string between nums'], [IsInt, "b2c", 0, 'IsInt num between strings'], ); plan tests => scalar(@test_sets); for (@test_sets) { my ($check, $value, $expect, $title) = @$_; my $result = $check->($value); is(($result ? 1 : 0), $expect, $title); } Declare-Constraints-Simple-0.03/t/11-libraries.t0000644000175000017500000000251610501243224022515 0ustar phaylonphaylon00000000000000#!/usr/bin/perl use warnings; use strict; use Test::More tests => 6; use Declare::Constraints::Simple; { BEGIN { package TestLibrary; use warnings; use strict; use Declare::Constraints::Simple-Library; use base 'Declare::Constraints::Simple::Library'; constraint Foo => sub { sub { _result(0, 'Foo A') }}; constraint Bar => sub { sub { _result(0, 'Bar A') }}; } package TestLibrary::Tests; use warnings; use strict; BEGIN { TestLibrary->import('-All') } Test::More::ok(IsInt->(12), 'inheritance from default library'); Test::More::is(Foo->(23)->message, 'Foo A', 'custom method'); } { BEGIN { package TestOverride; use warnings; use strict; use Declare::Constraints::Simple-Library; use base 'TestLibrary'; constraint Bar => sub { sub { _result(0, 'Bar B') }}; constraint Baz => sub { sub { _result(0, 'Baz B') }}; } package TestOverride::Tests; use warnings; use strict; BEGIN { TestOverride->import('-All') } Test::More::ok(IsInt->(23), 'inheritance from far away default'); Test::More::is(Foo->(23)->message, 'Foo A', 'inherited constraint'); Test::More::is(Bar->(23)->message, 'Bar B', 'overridden constraint'); Test::More::is(Baz->(23)->message, 'Baz B', 'new constraint'); } 1; Declare-Constraints-Simple-0.03/t/98-pod.t0000644000175000017500000000020110501243224021327 0ustar phaylonphaylon00000000000000use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); Declare-Constraints-Simple-0.03/t/34-scoping.t0000644000175000017500000000556610501243224022220 0ustar phaylonphaylon00000000000000#!/usr/bin/perl use warnings; use strict; use Test::More tests => 13; use Declare::Constraints::Simple-All; my $profile = And( IsHashRef, Scope( 'myscope', OnHashKeys( foo => Or( SetResult( qw(myscope FooInt), IsInt ), IsDefined ), bar => Message( 'Need either correct foo or bar', Or( IsDefined, IsValid( qw(myscope FooInt) ) ))))); my $structure = { foo => 12, bar => undef }; { my $result = $profile->($structure); ok($result->is_valid, 'structure validates initially'); } { local $structure->{foo} = 'twelve'; my $result = $profile->($structure); ok(!$result, 'dependency failed'); is($result->message, 'Need either correct foo or bar', 'correct error message'); is($result->path, 'And.Scope.OnHashKeys[bar].Message.Or.IsValid[myscope:FooInt]', 'correct failure path'); local $structure->{bar} = "Foobar"; my $result2 = $profile->($structure); ok($result2, 'reverse test passes'); } my $constraint = Scope('foo', And( HasAllKeys( qw(cmd data) ), OnHashKeys( cmd => Or( SetResult('foo', 'cmd_a', IsEq('FOO_A')), SetResult('foo', 'cmd_b', IsEq('FOO_B')) ), data => Or( And( IsValid('foo', 'cmd_a'), IsArrayRef( IsInt )), And( IsValid('foo', 'cmd_b'), IsRegex )) ))); my $cmdhash_a = { cmd => 'FOO_A', data => [1 .. 5], }; my $cmdhash_b = { cmd => 'FOO_B', data => qr/foo/, }; { my $result = $constraint->($cmdhash_a); ok($result, 'example cmdhash_a passes'); { local $cmdhash_a->{cmd} = 'FOO_NONE'; my $result = $constraint->($cmdhash_a); ok(!$result, 'unknown command fails'); is($result->path, 'Scope.And.OnHashKeys[cmd].Or.SetResult.IsEq', 'correct path for failing command'); } { local $cmdhash_a->{data}[2] = 'foobar'; my $result = $constraint->($cmdhash_a); ok(!$result, 'wrong data for command a fails'); is($result->path, 'Scope.And.OnHashKeys[data].Or.And.IsValid[foo:cmd_b]', 'correct path for wrong data for cmd a'); } } { my $result = $constraint->($cmdhash_b); ok($result, 'example cmdhash_b passes'); { local $cmdhash_b->{data} = 23; my $result = $constraint->($cmdhash_b); ok(!$result, 'wrong data for command b fails'); is($result->path, 'Scope.And.OnHashKeys[data].Or.And.IsRegex', 'correct path for wrong data for cmd a'); } } Declare-Constraints-Simple-0.03/t/01-constraints-scalar.t0000644000175000017500000000445410500277473024371 0ustar phaylonphaylon00000000000000#!/usr/bin/perl use warnings; use strict; use Test::More; use Declare::Constraints::Simple only => qw(Matches IsDefined HasLength IsOneOf IsTrue); my @test_sets = ( [IsDefined, "foo", 1, 'IsDefined string'], [IsDefined, 23, 1, 'IsDefined number'], [IsDefined, undef, 0, 'IsDefined undef'], [HasLength, undef, 0, 'HasLength undef'], [HasLength, "", 0, 'HasLength empty string'], [HasLength, "n", 1, 'HasLength one char'], [HasLength(2), "n", 0, 'HasLength(2) one char'], [HasLength(2), "nm", 1, 'HasLength(2) two chars'], [HasLength(2,3), "nm", 1, 'HasLength(2,3) two chars'], [HasLength(2,3), "nmo", 1, 'HasLength(2,3) three chars'], [HasLength(2,3), "nmop", 0, 'HasLength(2,3) four chars'], [IsTrue, "foo", 1, 'IsTrue true string'], [IsTrue, "", 0, 'IsTrue false string'], [IsTrue, 1, 1, 'IsTrue true number'], [IsTrue, 0, 0, 'IsTrue false number'], [IsOneOf(qw(a b c)), "a", 1, 'IsOneOf string true'], [IsOneOf(qw(a b c)), "c", 1, 'IsOneOf string true II'], [IsOneOf(qw(a b c)), "n", 0, 'IsOneOf string false'], [IsOneOf(1, undef, 2), 0, 0, 'IsOneOf undef false'], [IsOneOf(1, undef, 2), undef, 1, 'IsOneOf undef true'], [IsOneOf, "foo", 0, 'ISOneOf no list false'], [Matches(qr/oo/), "foob", 1, 'Matches string match'], [Matches(qr/aa/), "boor", 0, 'Matches string no-match'], [Matches(qr/ii/), undef, 0, 'Matches undef no-match'], [Matches(qr/a/,qr/b/), "wubr", 1, 'Matches multiple'], ); my @eval_sets = ( [sub { Matches() }, 'Regexp', 'Matches without args raises error'], [sub { Matches(23) }, 'Regexp', 'Matches with non-regexp arg raises error'], ); plan tests => scalar(@test_sets) + scalar(@eval_sets); for (@test_sets) { my ($check, $value, $expect, $title) = @$_; my $result = $check->($value); is(($result ? 1 : 0), $expect, $title); } for (@eval_sets) { my ($check, $expect, $title) = @$_; eval { $check->() }; like($@, qr/$expect/, $title); } Declare-Constraints-Simple-0.03/MANIFEST0000644000175000017500000000227110502260045021022 0ustar phaylonphaylon00000000000000Changes inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Declare/Constraints/Simple.pm lib/Declare/Constraints/Simple/Library.pm lib/Declare/Constraints/Simple/Library/Array.pm lib/Declare/Constraints/Simple/Library/Base.pm lib/Declare/Constraints/Simple/Library/Exportable.pm lib/Declare/Constraints/Simple/Library/General.pm lib/Declare/Constraints/Simple/Library/Hash.pm lib/Declare/Constraints/Simple/Library/Numerical.pm lib/Declare/Constraints/Simple/Library/OO.pm lib/Declare/Constraints/Simple/Library/Operators.pm lib/Declare/Constraints/Simple/Library/Referencial.pm lib/Declare/Constraints/Simple/Library/Scalar.pm lib/Declare/Constraints/Simple/Result.pm Makefile.PL MANIFEST This list of files META.yml README t/00-basics.t t/01-constraints-scalar.t t/02-constraints-numerical.t t/03-constraints-oo.t t/04-constraints-reference.t t/05-constraints-hash.t t/06-constraints-array.t t/10-constraints-operators.t t/11-libraries.t t/12-general.t t/23-stacknames.t t/33-complex.t t/34-scoping.t t/98-pod.t t/99-podcover.t Declare-Constraints-Simple-0.03/lib/0000755000175000017500000000000010502260174020440 5ustar phaylonphaylon00000000000000Declare-Constraints-Simple-0.03/lib/Declare/0000755000175000017500000000000010502260174021777 5ustar phaylonphaylon00000000000000Declare-Constraints-Simple-0.03/lib/Declare/Constraints/0000755000175000017500000000000010502260174024306 5ustar phaylonphaylon00000000000000Declare-Constraints-Simple-0.03/lib/Declare/Constraints/Simple/0000755000175000017500000000000010502260174025537 5ustar phaylonphaylon00000000000000Declare-Constraints-Simple-0.03/lib/Declare/Constraints/Simple/Library/0000755000175000017500000000000010502260174027143 5ustar phaylonphaylon00000000000000Declare-Constraints-Simple-0.03/lib/Declare/Constraints/Simple/Library/Array.pm0000644000175000017500000000775210502252250030566 0ustar phaylonphaylon00000000000000=head1 NAME Declare::Constraints::Simple::Library::Array - Array Constraints =cut package Declare::Constraints::Simple::Library::Array; use warnings; use strict; use Declare::Constraints::Simple-Library; use Carp::Clan qw(^Declare::Constraints::Simple); =head1 SYNOPSIS # accept a list of pairs my $pairs_validation = IsArrayRef( HasArraySize(2,2) ); # integer => object pairs my $pairs = And( OnEvenElements(IsInt), OnOddElements(IsObject) ); # a three element array my $tri = And( HasArraySize(3,3), OnArrayElements(0, IsInt, 1, IsDefined, 2, IsClass) ); =head1 DESCRIPTION This module contains all constraints that can be applied to array references. =head1 CONSTRAINTS =head2 HasArraySize([$min, [$max]]) With C<$min> defaulting to 1. So a specification of my $profile = HasArraySize; checks for at least one value. To force an exact size of the array, specify the same values for both: my $profile = HasArraySize(3, 3); =cut constraint 'HasArraySize', sub { my ($min, $max) = @_; $min = 1 unless defined $min; return sub { return _false('Undefined Value') unless defined $_[0]; return _false('Not an ArrayRef') unless ref($_[0]) eq 'ARRAY'; return _false("Less than $min Array elements") unless scalar(@{$_[0]}) >= $min; return _true unless $max; return _false("More than $max Array elements") unless scalar(@{$_[0]}) <= $max; return _true; }; }; =head2 OnArrayElements($key => $constraint, $key => $constraint, ...) Applies the the C<$constraint>s to the corresponding C<$key>s if they are present. For required keys see C. =cut constraint 'OnArrayElements', sub { my %keymap = @_; my @keys = sort keys %keymap; for (@keys) { croak "Not an array index: $_" if $_ =~ /\D/; } return sub { return _false('Undefined Value') unless defined $_[0]; return _false('Not an ArrayRef') unless ref($_[0]) eq 'ARRAY'; for my $k (@keys) { last if $k > $#{$_[0]}; my $r = $keymap{$k}->($_[0][$k]); _info($k); return $r unless $r->is_valid; } return _true; } }; =head2 OnEvenElements($constraint) Runs the constraint on all even elements of an array. See also C. =cut constraint 'OnEvenElements', sub { my ($c) = @_; return sub { return _false('Undefined Value') unless defined $_[0]; return _false('Not an ArrayRef') unless ref($_[0]) eq 'ARRAY'; my $p = 0; while ($p <= $#{$_[0]}) { my $r = $c->($_[0][$p]); _info($p); return $r unless $r->is_valid; $p += 2; } return _true; }; }; =head2 OnOddElements($constraint) Runs the constraint on all odd elements of an array. See also C. =cut constraint 'OnOddElements', sub { my ($c) = @_; return sub { return _false('Undefined Value') unless defined $_[0]; return _false('Not an ArrayRef') unless ref($_[0]) eq 'ARRAY'; my $p = 1; while ($p <= $#{$_[0]}) { my $r = $c->($_[0][$p]); _info($p); return $r unless $r->is_valid; $p += 2; } return _true; }; }; =head1 SEE ALSO L, L =head1 AUTHOR Robert 'phaylon' Sedlacek Cphaylon@dunkelheit.atE> =head1 LICENSE AND COPYRIGHT This module is free software, you can redistribute it and/or modify it under the same terms as perl itself. =cut 1; Declare-Constraints-Simple-0.03/lib/Declare/Constraints/Simple/Library/Referencial.pm0000644000175000017500000001170410501243227031722 0ustar phaylonphaylon00000000000000=head1 NAME Declare::Constraints::Simple::Library::Referencial - Ref Constraints =cut package Declare::Constraints::Simple::Library::Referencial; use warnings; use strict; use Declare::Constraints::Simple-Library; =head1 SYNOPSIS # scalar or array references my $scalar_or_array = IsRefType( qw(SCALAR ARRAY) ); # scalar reference my $int_ref = IsScalarRef( IsInt ); # accept mappings of ids to objects with "name" methods my $id_obj_map = IsHashRef( -keys => IsInt, -values => And( IsObject, HasMethods('name') )); # an integer list my $int_list = IsArrayRef( IsInt ); # accept code references my $is_closure = IsCodeRef; # accept a regular expression my $is_regex = IsRegex; =head1 DESCRIPTION This library contains those constraints that can test the validity of references and their types. =head1 CONSTRAINTS =head2 IsRefType(@types) Valid if the value is a reference of a kind in C<@types>. =cut constraint 'IsRefType', sub { my (@types) = @_; return sub { return _false('Undefined Value') unless defined $_[0]; my @match = grep { ref($_[0]) eq $_ } @types; return scalar(@match) ? _true : _false('No matching RefType'); }; }; =head2 IsScalarRef($constraint) This is true if the value is a scalar reference. A possible constraint for the scalar references target value can be passed. E.g. my $test_integer_ref = IsScalarRef(IsInt); =cut constraint 'IsScalarRef', sub { my @vc = @_; return sub { return _false('Undefined Value') unless defined $_[0]; return _false('Not a ScalarRef') unless ref($_[0]) eq 'SCALAR'; return _true unless @vc; my $result = _apply_checks(${$_[0]}, \@vc); return $result unless $result->is_valid; return _true; }; }; =head2 IsArrayRef($constraint) The value is valid if the value is an array reference. The contents of the array can be validated by passing an other C<$constraint> as argument. The stack or path part of C is C where C<$index> is the index of the failing element. =cut constraint 'IsArrayRef', sub { my @vc = @_; return sub { return _false('Undefined Value') unless defined $_[0]; return _false('Not an ArrayRef') unless ref($_[0]) eq 'ARRAY'; for (0 .. $#{$_[0]}) { my $result = _apply_checks($_[0][$_], \@vc, $_); return $result unless $result->is_valid; } return _true; }; }; =head2 IsHashRef(-keys => $constraint, -values => $constraint) True if the value is a hash reference. It can also take two named parameters: C<-keys> can pass a constraint to check the hashes keys, C<-values> does the same for its values. The stack or path part of C looks like C where C<$type> is either C or C depending on what was validated, and C<$key> being the key that didn't pass validation. =cut constraint 'IsHashRef', sub { my %def = @_; return sub { return _false('Undefined Value') unless defined $_[0]; return _false('Not a HashRef') unless ref($_[0]) eq 'HASH'; if (my $c = $def{'-values'}) { for (keys %{$_[0]}) { my $r = _apply_checks($_[0]{$_}, _listify($c), "val $_"); return $r unless $r->is_valid; } } if (my $c = $def{'-keys'}) { for (keys %{$_[0]}) { my $r = _apply_checks($_, _listify($c), "key $_"); return $r unless $r->is_valid; } } return _true; }; }; =head2 IsCodeRef() Code references have to be valid to pass this constraint. =cut constraint 'IsCodeRef', sub { return sub { return _false('Undefined Value') unless defined $_[0]; return _result((ref($_[0]) eq 'CODE'), 'Not a CodeRef'); }; }; =head2 IsRegex() True if the value is a regular expression built with C. B however, that a simple string that could be used like C will not pass this constraint. You can combine multiple constraints with L though. =cut constraint 'IsRegex', sub { return sub { return _false('Undefined Value') unless defined $_[0]; return _result((ref($_[0]) eq 'Regexp'), 'Not a Regular Expression'); }; }; =head1 SEE ALSO L, L =head1 AUTHOR Robert 'phaylon' Sedlacek Cphaylon@dunkelheit.atE> =head1 LICENSE AND COPYRIGHT This module is free software, you can redistribute it and/or modify it under the same terms as perl itself. =cut 1; Declare-Constraints-Simple-0.03/lib/Declare/Constraints/Simple/Library/OO.pm0000644000175000017500000000543010501243227030017 0ustar phaylonphaylon00000000000000=head1 NAME Declare::Constraints::Simple::Library::OO - OO Constraints =cut package Declare::Constraints::Simple::Library::OO; use warnings; use strict; use Declare::Constraints::Simple-Library; use Class::Inspector; use Scalar::Util (); =head1 SYNOPSIS # accept objects or classes my $object_or_class = Or( IsObject, IsClass ); # valid on objects with all methods my $proper_object = And( IsObject, HasMethods( qw(foo bar) )); # validate against date objects my $is_date_object = IsA('DateTime'); =head1 DESCRIPTION This library contains the constraints for validating parameters in an object oriented manner. =head1 CONSTRAINTS =head2 HasMethods(@methods) Returns true if the value is an object or class that C all the specified C<@methods>. The stack or path part of C looks like C where C<$method> is the first found missing method. =cut constraint 'HasMethods', sub { my (@methods) = @_; return sub { return _false('Undefined Value') unless defined $_[0]; return _false('Not a Class or Object') unless Scalar::Util::blessed($_[0]) or Class::Inspector->loaded($_[0]); for (@methods) { unless ($_[0]->can($_)) { _info($_); return _false("Method $_ not implemented"); } } return _true; }; }; =head2 IsA(@classes) Is true if the passed object or class is a subclass of one of the classes mentioned in C<@classes>. =cut constraint 'IsA', sub { my (@classes) = @_; return sub { return _false('Undefined Value') unless defined $_[0]; for (@classes) { return _true if eval { $_[0]->isa($_) }; } return _false('No matching Class'); }; }; =head2 IsClass() Valid if value is a loaded class. =cut constraint 'IsClass', sub { return sub { return _false('Undefined Value') unless defined $_[0]; return _result(Class::Inspector->loaded($_[0]), 'Not a loaded Class'); }; }; =head2 IsObject() True if the value is blessed. =cut constraint 'IsObject', sub { return sub { return _false('Undefined Value') unless defined $_[0]; return _result(Scalar::Util::blessed($_[0]), 'Not an Object'); }; }; =head1 SEE ALSO L, L =head1 AUTHOR Robert 'phaylon' Sedlacek Cphaylon@dunkelheit.atE> =head1 LICENSE AND COPYRIGHT This module is free software, you can redistribute it and/or modify it under the same terms as perl itself. =cut 1; Declare-Constraints-Simple-0.03/lib/Declare/Constraints/Simple/Library/Numerical.pm0000644000175000017500000000263310501243227031423 0ustar phaylonphaylon00000000000000=head1 NAME Declare::Constraints::Simple::Library::Numerical - Numerical Constraints =cut package Declare::Constraints::Simple::Library::Numerical; use warnings; use strict; use Declare::Constraints::Simple-Library; use Scalar::Util (); =head1 SYNOPSIS # test for number-conformity my $looks_like_number = IsNumber; # only integers my $is_int = IsInt; =head1 DESCRIPTIONS This library contains the constraints needed to validate numerical values. =head1 CONSTRAINTS =head2 IsNumber() True if the value is a number according to Ls C. =cut constraint 'IsNumber', sub { return sub { return _false('Undefined Value') unless defined $_[0]; return _result(Scalar::Util::looks_like_number($_[0]), 'Does not look like Number'); }; }; =head2 IsInt() True if the value is an integer. =cut constraint 'IsInt', sub { return sub { return _false('Undefined Value') unless defined $_[0]; return _result(scalar($_[0] =~ /^-?\d+$/), 'Not an Integer'); }; }; =head1 SEE ALSO L, L =head1 AUTHOR Robert 'phaylon' Sedlacek Cphaylon@dunkelheit.atE> =head1 LICENSE AND COPYRIGHT This module is free software, you can redistribute it and/or modify it under the same terms as perl itself. =cut 1; Declare-Constraints-Simple-0.03/lib/Declare/Constraints/Simple/Library/Base.pm0000644000175000017500000001705110501243227030356 0ustar phaylonphaylon00000000000000=head1 NAME Declare::Constraints::Simple::Library::Base - Library Base Class =cut package Declare::Constraints::Simple::Library::Base; use warnings; use strict; use aliased 'Declare::Constraints::Simple::Result'; use Carp::Clan qw(^Declare::Constraints::Simple); our $FAIL_MESSAGE_DEFAULT = 'Validation Error'; our $FAIL_MESSAGE = ''; our $FAIL_INFO; our %SCOPES; use base 'Declare::Constraints::Simple::Library::Exportable'; =head1 SYNOPSIS package My::Constraint::Library; use warnings; use strict; # this installs the base class and helper functions use Declare::Constraints::Simple-Library; # we can also automagically provide other libraries # to the importer use base 'Declare::Constraints::Simple::Library::Numericals'; # with this we define a constraint to check a value # against a serial number regular expression constraint 'SomeSerial', sub { return sub { return _true if $_[0] =~ /\d{3}-\d{3}-\d{4}/; return _false('Not in SomeSerial format'); }; }; 1; =head1 DESCRIPTION This base class contains the common library functionalities. This includes helper functions and install mechanisms. =head1 METHODS =head2 install_into($target) Installs the base classes and helper functions into the C<$target> namespace. The C<%CONSTRAINT_GENERATORS> package variable of that class will be used as storage for it's constraints. =cut sub install_into { my ($class, $target) = @_; { no strict 'refs'; unshift @{$target . '::ISA'}, $class; *{$target . '::' . $_} = $class->can($_) for qw/ constraint _apply_checks _listify _result _false _true _info _with_message _with_scope _set_result _get_result _has_result /; } 1; } =head2 fetch_constraint_declarations() Class method. Returns all constraints registered to the class. =cut sub fetch_constraint_declarations { my ($class) = @_; { no strict 'refs'; no warnings; return keys %{$class . '::CONSTRAINT_GENERATORS'}; } } =head2 fetch_constraint_generator($name) Class method. Returns the constraint generator code reference registered under C<$name>. The call will raise a C if the generator could not be found. =cut sub fetch_constraint_generator { my ($class, $name) = @_; my $generator = do { no strict 'refs'; ${$class . '::CONSTRAINT_GENERATORS'}{$name}; }; croak "Unknown Constraint Generators: $name" unless $generator; return $class->prepare_generator($name, $generator); } =head2 prepare_generator($constraint_name, $generator) Class method. This wraps the C<$generator> in a closure that provides stack and failure-collapsing decisions. =cut sub prepare_generator { my ($class, $constraint, $generator) = @_; return sub { my (@g_args) = @_; my $closure = $generator->(@g_args); return sub { my (@c_args) = @_; local $FAIL_INFO; my $result = $closure->(@c_args); my $info = ''; if ($FAIL_INFO) { $info = $FAIL_INFO; $info =~ s/([\[\]])/\\$1/gsm; $info = "[$info]"; } $result->add_to_stack($constraint . $info) unless $result; return $result; }; }; } =head2 add_constraint_generator($name, $code) Class method. The actual registration method, used by C. =cut sub add_constraint_generator { my ($class, $name, $code) = @_; { no strict 'refs'; ${$class . '::CONSTRAINT_GENERATORS'}{$name} = $code; } 1; } =head1 HELPER FUNCTIONS Note that some of the helper functions are prefixed with C<_>. Although this means they are internal functions, it is ok to call them, as they have a fixed API. They are not distribution internal, but library internal, and only intended to be used from inside constraints. =head2 constraint($name, $code) constraint 'Foo', sub { ... }; This registers a new constraint in the calling library. Note that constraints B return result objects. To do this, you can use the helper functions L<_result($bool, $msg>, L<_true()> and L<_false($msg)>. =cut sub constraint { my ($name, $code) = @_; my $target = scalar(caller); $target->add_constraint_generator($name => $code); 1; } =head2 _result($bool, $msg) Returns a new result object. It's validity flag will depend on the C<$bool> argument. The C<$msg> argument is the error message to use on failure. =cut sub _result { my ($result, $msg) = @_; my $result_obj = Result->new; $result_obj->set_valid($result); $result_obj->set_message( $FAIL_MESSAGE || $msg || $FAIL_MESSAGE_DEFAULT) unless $result_obj->is_valid; return $result_obj; } =head2 _false($msg) Returns a non-valid result object, with it's message set to C<$msg>. =head2 _true() Returns a valid result object. =cut sub _false { _result(0, @_) } sub _true { _result(1, @_) } =head2 _info($info) Sets the current failure info to use in the stack info part. =cut sub _info { $FAIL_INFO = shift } =head2 _apply_checks($value, \@constraints, [$info]) This applies all constraints in the C<\@constraints> array reference to the passed C<$value>. You can optionally specify an C<$info> string to be used in the stack of the newly created non-valid results. =cut sub _apply_checks { my ($value, $checks, $info) = @_; $checks ||= []; $FAIL_INFO = $info if $info; for (@$checks) { my $result = $_->($value); return $result unless $result->is_valid; } return _true; } =head2 _listify($value) Puts C<$value> into an array reference and returns it, if it isn't already one. =cut sub _listify { my ($value) = @_; return (ref($value) eq 'ARRAY' ? $value : [$value]); } =head2 _with_message($msg, $closure, @args) This is the internal version of the general C constraint. It sets the current overriden message to C<$msg> and executes the C<$closure> with C<@args> as arguments. =cut sub _with_message { my ($msg, $closure, @args) = @_; local $FAIL_MESSAGE = $msg; return $closure->(@args); } =head2 _with_scope($scope_name, $constraint, @args) Applies the C<$constraint> to C<@args> in a newly created scope named by C<$scope_name>. =cut sub _with_scope { my ($scope_name, $closure, @args) = @_; local %SCOPES = ($scope_name => {}) unless exists $SCOPES{$scope_name}; return $closure->(@args); } =head2 _set_result($scope, $name, $result) Stores the given C<$result> unter the name C<$name> in C<$scope>. =cut sub _set_result { my ($scope, $name, $result) = @_; $SCOPES{$scope}{result}{$name} = $result; 1; } =head2 _get_result($scope, $name) Returns the result named C<$name> from C<$scope>. =cut sub _get_result { my ($scope, $name) = @_; return $SCOPES{$scope}{result}{$name}; } =head2 _has_result($scope, $name) Returns true only if such a result was registered already. =cut sub _has_result { my ($scope, $name) = @_; return exists $SCOPES{$scope}{result}{$name}; } =head1 SEE ALSO L, L =head1 AUTHOR Robert 'phaylon' Sedlacek Cphaylon@dunkelheit.atE> =head1 LICENSE AND COPYRIGHT This module is free software, you can redistribute it and/or modify it under the same terms as perl itself. =cut 1; Declare-Constraints-Simple-0.03/lib/Declare/Constraints/Simple/Library/Scalar.pm0000644000175000017500000000732410501243227030713 0ustar phaylonphaylon00000000000000=head1 NAME Declare::Constraints::Simple::Library::Scalar - Scalar Constraints =cut package Declare::Constraints::Simple::Library::Scalar; use warnings; use strict; use Declare::Constraints::Simple-Library; use Carp::Clan qw(^Declare::Constraints::Simple); =head1 SYNOPSIS # match one of a set of regexes my $some_regexes = Matches(qr/foo/, qr/bar/); # allow only defined values my $is_defined = IsDefined; # between 5 and 50 chars my $five_to_fifty = HasLength(5, 50); # match against a set of values my $command_constraint = IsOneOf(qw(create update delete)); # check for trueness my $is_true = IsTrue; # simple equality my $is_foo = IsEq('foo'); =head1 DESCRIPTION This library contains all constraints to validate scalar values. =head1 CONSTRAINTS =head2 Matches(@regex) my $c = Matches(qr/foo/, qr/bar/); If one of the parameters matches the expression, this is true. =cut constraint 'Matches', sub { my @rx = @_; croak 'Matches needs at least one Regexp as argument' unless @rx; for (@rx) { croak 'Matches only takes Regexps as arguments' unless ref($_) eq 'Regexp'; } return sub { return _false('Undefined Value') unless defined $_[0]; for (@rx) { return _true if $_[0] =~ /$_/; } return _false('Regex does not match'); }; }; =head2 IsDefined() True if the value is defined. =cut constraint 'IsDefined', sub { return sub { return _result((defined($_[0]) ? 1 : 0), 'Undefined Value'); }; }; =head2 HasLength([$min, [$max]]) Is true if the value has a length above C<$min> (which defaults to 1> and, if supplied, under the value of C<$max>. A simple my $c = HasLength; checks if the value has a length of at least 1. =cut constraint 'HasLength', sub { my ($min, $max) = @_; $min = 1 unless defined $min; $max = 0 unless defined $max; return sub { my ($val) = @_; return _false('Undefined Value') unless defined $val; return _false('Value too short') unless $min <= length($val); return _true unless $max; return _result(((length($val) <= $max) ? 1 : 0), 'Value too long'); }; }; =head2 IsOneOf(@values) True if one of the C<@values> equals the passed value. C values work with this too, so my $c = IsOneOf(1, 2, undef); will return true on an undefined value. =cut constraint 'IsOneOf', sub { my @vals = @_; return sub { for (@vals) { unless (defined $_) { return _true unless defined $_[0]; next; } next unless defined $_[0]; return _true if $_[0] eq $_; } return _false('No Value matches'); }; }; =head2 IsTrue() True if the value evulates to true in boolean context. =cut constraint 'IsTrue', sub { return sub { $_[0] ? _true : _false('Value evaluates to False') }; }; =head2 IsEq($comparator) Valid if the value is C the C<$comparator>. =cut constraint 'IsEq', sub { my ($compare) = @_; return sub { return _result( ($compare eq $_[0]), "'$_[0]' does not equal '$compare'" ); }; }; =head1 SEE ALSO L, L =head1 AUTHOR Robert 'phaylon' Sedlacek Cphaylon@dunkelheit.atE> =head1 LICENSE AND COPYRIGHT This module is free software, you can redistribute it and/or modify it under the same terms as perl itself. =cut 1; Declare-Constraints-Simple-0.03/lib/Declare/Constraints/Simple/Library/Operators.pm0000644000175000017500000001152410502257372031470 0ustar phaylonphaylon00000000000000=head1 NAME Declare::Constraints::Simple::Library::Operators - Operators =cut package Declare::Constraints::Simple::Library::Operators; use warnings; use strict; use Declare::Constraints::Simple-Library; use Carp::Clan qw(^Declare::Constraints::Simple); =head1 SYNOPSIS # all hast to be valid my $and_constraint = And( IsInt, Matches(qr/0$/) ); # at least one has to be valid my $or_constraint = Or( IsInt, HasLength ); # only one can be valid my $xor_constraint = XOr( IsClass, IsObject ); # reverse validity my $not_an_integer = Not( IsInt ); # case valid, validate 'bar' key depending on 'foo' keys value my $struct_prof = And( IsHashRef, CaseValid( OnHashKeys(foo => IsEq("FooArray")), OnHashKeys(bar => IsArrayRef), OnHashKeys(foo => IsEq("FooHash")), OnHashKeys(bar => IsHashRef) )); =head1 DESCRIPTION This module contains the frameworks operators. These constraint like elements act on the validity of passed constraints. =head1 OPERATORS =head2 And(@constraints) Is true if all passed C<@constraints> are true on the value. Returns the result of the first failing constraint. =cut constraint 'And', sub { my @vc = @_; return sub { for (@vc) { my $r = $_->($_[0]); return $r unless $r->is_valid; } return _true; }; }; =head2 Or(@constraints) Is true if at least one of the passed C<@contraints> is true. Returns the last failing constraint's result if false. =cut constraint 'Or', sub { my @vc = @_; return sub { my $last_r; for (0 .. $#vc) { my $v = $vc[$_]; my $r = $v->($_[0]); return _true if $r->is_valid; return $r if $_ == $#vc; } return _false('No constraints'); }; }; =head2 XOr(@constraints) Valid only if a single one of the passed C<@constraints> is valid. Returns the last failing constraint's result if false. =cut constraint 'XOr', sub { my @vc = @_; return sub { my $m = 0; for (@vc) { my $r = $_->($_[0]); $m++ if $r->is_valid; } return _result(($m == 1), sprintf 'Got %d true returns', $m); }; }; =head2 Not($constraint) This is valid if the passed C<$constraint> is false. The main purpose of this operator is to allow the easy reversion of a constraint's trueness. =cut constraint 'Not', sub { my ($c) = @_; croak '\'Not\' only accepts only a constraint as argument' if defined $c and not ref($c) eq 'CODE'; return sub { return _true unless $c; my $r = $c->($_[0]); return _false('Constraint returned true') if $r->is_valid; return _true; }; }; =head2 CaseValid($test, $conseq, $test2, $conseq2, ...) This runs every given C<$test> argument on the value, until it finds one that returns true. If none is found, false is returned. On a true result, howver, the corresponding C<$conseq> constraint is applied to the value and it's result returned. This allows validation depending on other properties of the value: my $flexible = CaseValid( IsArrayRef, And( HasArraySize(1,5), OnArrayElements(0 => IsInt) ), IsHashRef, And( HasHashElements(qw( head tail )), OnHashKeys(head => IsInt) )); Of course, you could model most of it probably with the other operators, but this is a bit more readable. For default cases use C from L as test. =cut constraint 'CaseValid', sub { my @defs = @_; my ($c, @cases); while (my $test = shift @defs) { $c++; croak "CaseValid test nr $c is not a constraint" unless ref($test) eq 'CODE'; my $conseq = shift @defs; croak "CaseValid consequence nr $c is not a constraint" unless ref($test) eq 'CODE'; push @cases, [$test, $conseq]; } return sub { for my $case (@cases) { my ($test, $conseq) = @$case; next unless $test->($_[0])->is_valid; return $conseq->($_[0]); } _false('No matching case'); }; }; =head1 SEE ALSO L, L =head1 AUTHOR Robert 'phaylon' Sedlacek Cphaylon@dunkelheit.atE> =head1 LICENSE AND COPYRIGHT This module is free software, you can redistribute it and/or modify it under the same terms as perl itself. =cut 1; Declare-Constraints-Simple-0.03/lib/Declare/Constraints/Simple/Library/Exportable.pm0000644000175000017500000001036410502241301031601 0ustar phaylonphaylon00000000000000=head1 NAME Declare::Constraints::Simple::Library::Exportable - Export Facilities =cut package Declare::Constraints::Simple::Library::Exportable; use warnings; use strict; use Carp::Clan qw(^Declare::Constraints::Simple); use Class::Inspector; use aliased 'Declare::Constraints::Simple::Library::Base' => 'LibraryBase'; sub Library () { 'Declare::Constraints::Simple::Library' } =head1 DESCRIPTION This contains the constraint export logic of the module. =head1 METHODS =head2 import($flag, @args) use ExportableModule->All; # or use ExportableModule-Only => qw(Constraint1 ...); # or use ExportableModule-Library; Exports the constraints to the calling namespace. This includes all libraries in L, that package itself (providing all default constraints) or L itself as a shortcut. Possible flags are =over =item All Imports all constraints registered in the class and its base classes. =item Only use Declare::Constraints::Simple::Library::Scalar-Only => 'HasLength'; The above line would only import the C constraints from the C default library. Note however, that you could also just have said use Declare::Constraints::Simple-Only => 'HasLength'; as both C<::Simple> and C<::Simple::Library> work on all default libraries. =item Library You can use this to define your own constraint library. For more information, see L. =back =cut sub import { my ($class, $flag, @args) = @_; return unless $flag; my $handle_map = $class->_build_handle_map; my $target = scalar(caller); if ($flag =~ /^-?all$/i) { $class->_export_all($target, $handle_map); } elsif ($flag =~ /^-?only$/i) { $class->_export_these($target, $handle_map, @args); } elsif ($flag =~ /^-?library$/i) { LibraryBase->install_into($target); } 1; } =head2 _build_handle_map() Internal method to build constraint-to-class mappings. =cut sub _build_handle_map { my ($class) = @_; if ($class eq 'Declare::Constraints::Simple') { $class = Library; } if ($class eq Library) { unless (Class::Inspector->loaded(Library)) { require Class::Inspector->filename(Library); } } my (%seen, %handle_map, @walk, %walked); @walk = do { no strict 'refs'; ($class, @{$class . '::ISA'}); }; while (my $w = shift @walk) { next if $walked{$w}; $walked{$w} = 1; if ($w->can('fetch_constraint_declarations')) { my @decl = $w->fetch_constraint_declarations; for my $d (@decl) { next if exists $seen{$d}; $seen{$d} = 1; $handle_map{$d} = $w; } } push @walk, grep { not exists $walked{$_} } do { no strict 'refs' ; @{$w . '::ISA'} }; } return \%handle_map; } =head2 _export_all($target, $handle_map) Internal method. Exports all handles in C<$handle_map> into the C<$target> namespace. =cut sub _export_all { my ($class, $target, $handle_map) = @_; return $class->_export_these($target, $handle_map, keys %$handle_map); } =head2 _export_these($target, $handle_map, @constraints) Internal method. Exports all C<@constraints> from C<$handle_map> into the C<$target> namespace. =cut sub _export_these { my ($class, $target, $handle_map, @decl) = @_; for my $d (@decl) { my $handle = $handle_map->{$d} or croak "Constraint '$d' cannot be found in $class"; my $gen = $handle_map->{$d}->fetch_constraint_generator($d); croak sprintf 'Constraint Generator for $s in %s did not return a closure', $d, $handle_map->{$d} unless ref($gen) eq 'CODE'; { no strict 'refs'; *{$target . '::' . $d} = $gen; } } } =head1 SEE ALSO L, L, L =head1 AUTHOR Robert 'phaylon' Sedlacek Cphaylon@dunkelheit.atE> =head1 LICENSE AND COPYRIGHT This module is free software, you can redistribute it and/or modify it under the same terms as perl itself. =cut 1; Declare-Constraints-Simple-0.03/lib/Declare/Constraints/Simple/Library/Hash.pm0000644000175000017500000000556410501243227030375 0ustar phaylonphaylon00000000000000=head1 NAME Declare::Constraints::Simple::Library::Hash - Hash Constraints =cut package Declare::Constraints::Simple::Library::Hash; use warnings; use strict; use Declare::Constraints::Simple-Library; =head1 SYNOPSIS my $constraint = And( # make sure all keys are present HasAllKeys( qw(foo bar) ), # constraints for the keys OnHashKeys( foo => IsInt, bar => HasLength ) ); =head1 DESCRIPTION This module contains all constraints that can be applied to hash references. =head2 HasAllKeys(@keys) The value has to be a hashref, and contain all keys listed in C<@keys> to pass this constraint. The stack or path part of C is C where C<$key> is the missing key. =cut constraint 'HasAllKeys', sub { my @vk = @_; return sub { return _false('Undefined Value') unless defined $_[0]; return _false('Not a HashRef') unless ref($_[0]) eq 'HASH'; for (@vk) { unless (exists $_[0]{$_}) { _info($_); return _false("No '$_' key present"); } } return _true; }; }; =head2 OnHashKeys(key => $constraint, key => $constraint, ...) This allows you to pass a constraint for each specific key in a hash reference. If a specified key is not in the validated hash reference, the validation for this key is not done. To make a key a requirement, use L above in combination with this, e.g. like: And( HasAllKeys( qw(foo bar baz) ) OnHashKeys( foo => IsInt, bar => Matches(qr/bar/), baz => IsArrayRef( HasLength ))); Also, as you might see, you don't have to check for C validity here. The hash constraints are already doing that by themselves. The stack or path part of C looks like C where C<$key> is the key of the failing value. =cut constraint 'OnHashKeys', sub { my %def = my @def = @_; my @key_order; while (my $key = shift @def) { my $val = shift @def; push @key_order, $key; } return sub { return _false('Undefined Value') unless defined $_[0]; return _false('Not a HashRef') unless ref($_[0]) eq 'HASH'; for (@key_order) { my @vc = @{_listify($def{$_})}; next unless exists $_[0]{$_}; my $r = _apply_checks($_[0]{$_}, \@vc, $_); return $r unless $r->is_valid; } return _true; }; }; =head1 SEE ALSO L, L =head1 AUTHOR Robert 'phaylon' Sedlacek Cphaylon@dunkelheit.atE> =head1 LICENSE AND COPYRIGHT This module is free software, you can redistribute it and/or modify it under the same terms as perl itself. =cut 1; Declare-Constraints-Simple-0.03/lib/Declare/Constraints/Simple/Library/General.pm0000644000175000017500000000662510502256752031076 0ustar phaylonphaylon00000000000000=head1 NAME Declare::Constraints::Simple::Library::General - General Constraints =cut package Declare::Constraints::Simple::Library::General; use warnings; use strict; use Declare::Constraints::Simple-Library; use Carp::Clan qw(^Declare::Constraints::Simple); =head1 SYNOPSIS # custom error messages my $constraint = And( Message( 'You need to specify a Value', IsDefined ), Message( 'The specified Value is not an Int', IsInt )); # build results my $valid = ReturnTrue; my $invalid = ReturnFalse('Just because'); =head1 DESCRIPTION This library is meant to contain those constraints and constraint-like elements that apply generally to the whole framework. =head1 CONSTRAINTS =head2 Message($message, $constraint) Overrides the C set on the result object for failures in C<$constraint>. For example: my $message = 'How hard is it to give me a number?'; my $constraint = Message($message, IsNumber); my $result = $constraint->('duh...'); print $result->message, "\n"; The C constraint overrides the error message returned by it's whole subtree, however, the C specification nearest to the point of failure will win. So while this my $constraint = Message( 'Foo', IsArrayRef( Message( 'Bar', IsInt ))); my $result = $constraint->(['I am not an Integer']); print $result->message; will print C, this my $result = $constraint->('I\'m not even an ArrayRef'); print $result->message; will output C. =cut constraint 'Message', sub { my ($msg, $c) = @_; return sub { return _with_message($msg, $c, @_); }; }; =head2 Scope($name, $constraint) Executes the passed C<$constraint> in a newly generated scope named C<$name>. =cut constraint 'Scope', sub { my ($scope_name, $constraint) = @_; return sub { return _with_scope($scope_name, $constraint, @_); }; }; =head2 SetResult($scope, $name, $constraint) Stores the result ov an evaluation of C<$constraint> in C<$scope> under C<$name>. =cut constraint 'SetResult', sub { my ($scope, $name, $constraint) = @_; return sub { my $result = $constraint->(@_); _set_result($scope, $name, $result); return $result; }; }; =head2 IsValid($scope, $name) Returns a true result if the result C<$name>, which has to have been stored previously in the scope named C<$scope>, was valid. =cut constraint 'IsValid', sub { my ($scope, $name) = @_; return sub { _info("$scope:$name"); return _false unless _has_result($scope, $name); my $result = _get_result($scope, $name); return _result($result, "Value '$name' in scope '$scope' is invalid"); }; }; =head2 ReturnTrue() Returns a true result. =cut constraint 'ReturnTrue', sub { return sub { _true } }; =head2 ReturnFalse($msg) Returns a false result containing C<$msg> as error message. =cut constraint 'ReturnFalse', sub { my $msg = shift; return sub { _false($msg) } }; =head1 SEE ALSO L, L =head1 AUTHOR Robert 'phaylon' Sedlacek Cphaylon@dunkelheit.atE> =head1 LICENSE AND COPYRIGHT This module is free software, you can redistribute it and/or modify it under the same terms as perl itself. =cut 1; Declare-Constraints-Simple-0.03/lib/Declare/Constraints/Simple/Library.pm0000644000175000017500000000475410502257440027515 0ustar phaylonphaylon00000000000000=head1 NAME Declare::Constraints::Simple::Library - Constraint Library Bundle =cut package Declare::Constraints::Simple::Library; use warnings; use strict; use base qw( Declare::Constraints::Simple::Library::General Declare::Constraints::Simple::Library::Scalar Declare::Constraints::Simple::Library::Numerical Declare::Constraints::Simple::Library::OO Declare::Constraints::Simple::Library::Referencial Declare::Constraints::Simple::Library::Hash Declare::Constraints::Simple::Library::Array Declare::Constraints::Simple::Library::Operators ); =head1 DESCRIPTION This module functions as bundle of all default libraries, and as map and/or reference of said ones. =head1 LIBRARIES =over =item L General constraints and constraint-like elements that affect the whole framework. Provides: C, C, C, C, C, C =item L Constraints for scalar value validation. Provides: C, C, C, C, C, C =item L These validate values by their numerical properties. Provides: C, C =item L For validation of values in an object oriented manner. Provides: C, C, C, C =item L These can validate properties by their reference types. Provides: C, C, C, C, C, C =item L These constraints deal with array references and their contents. Provides: C, L, L, L =item L All constraints appliable to hash references as well as their keys and values. Provides: C, C =item L Operators can be used in any place a constraint can be used, as their implementations are similar. Provides: C, C, C, C, C =back =head1 SEE ALSO L =head1 AUTHOR Robert 'phaylon' Sedlacek Cphaylon@dunkelheit.atE> =head1 LICENSE AND COPYRIGHT This module is free software, you can redistribute it and/or modify it under the same terms as perl itself. =cut 1; Declare-Constraints-Simple-0.03/lib/Declare/Constraints/Simple/Result.pm0000644000175000017500000000444710501243227027363 0ustar phaylonphaylon00000000000000=head1 NAME Declare::Constraints::Simple::Result - Validation Result =cut package Declare::Constraints::Simple::Result; use warnings; use strict; use overload bool => \&is_valid, fallback => 1; =head1 SYNOPSIS my $result = $constraint->($value); my $message = $result->message; my $path = $result->path; =head1 DESCRIPTION This represents a result returned by a L constraint. Objects of this kind overload their boolean context, so the value of the L accessor is reflected to it. =cut my %init = ( message => '', valid => 0, ); =head1 METHODS =head2 new() Constructor. As you will mostly just receive result objects, you should never be required to call this yourself. =cut sub new { bless {%init, stack => []} => shift } =head2 set_valid($bool) Sets the results validity flag. =head2 is_valid() Boolean accessor telling if this is a true result or not. =cut sub set_valid { $_[0]->{valid} = $_[1] } sub is_valid { shift->{valid} } =head2 set_message($message) The error message. Useful only on non-valid results. =head2 message() Returns the message of the result object. =cut sub set_message { $_[0]->{message} = $_[1] } sub message { shift->{message} } =head2 add_to_stack($constraint_name) This adds another level at the beginning (!) of the results constraint stack. This is mostly intended to use for the Cmethod in L package. =head2 path([$separator]) Returns a string containing the L contents joined together by the C<$separator> string (defaulting to C<.>). =cut sub add_to_stack { unshift @{shift->{stack}}, shift } sub path { join( ($_[1]||'.'), @{$_[0]->stack} ) } =head2 stack() Returns an array reference containing the results currrent stack. This is a list of the constraints path parts. This is usually just the constraints name. If there's additional info, it is appended to the name like C<[$info]>. =cut sub stack { $_[0]->{stack} } =head1 SEE ALSO L =head1 AUTHOR Robert 'phaylon' Sedlacek Cphaylon@dunkelheit.atE> =head1 LICENSE AND COPYRIGHT This module is free software, you can redistribute it and/or modify it under the same terms as perl itself. =cut 1; Declare-Constraints-Simple-0.03/lib/Declare/Constraints/Simple.pm0000644000175000017500000001541710502257536026115 0ustar phaylonphaylon00000000000000=head1 NAME Declare::Constraints::Simple - Declarative Validation of Data Structures =cut package Declare::Constraints::Simple; use warnings; use strict; use base 'Declare::Constraints::Simple::Library::Exportable'; our $VERSION = 0.03; =head1 SYNOPSIS use Declare::Constraints::Simple-All; my $profile = IsHashRef( -keys => HasLength, -values => IsArrayRef( IsObject )); my $result1 = $profile->(undef); print $result1->message, "\n"; # 'Not a HashRef' my $result2 = $profile->({foo => [23]}); print $result2->message, "\n"; # 'Not an Object' print $result2->path, "\n"; # 'IsHashRef[val foo].IsArrayRef[0].IsObject' =head1 DESCRIPTION The main purpose of this module is to provide an easy way to build a profile to validate a data structure. It does this by giving you a set of declarative keywords in the importing namespace. =head1 USAGE This is just a brief intro. For details read the documents mentioned in L. =head2 Constraint Import use Declare::Constraints::Simple-All; The above command imports all constraint generators in the library into the current namespace. If you want only a selection, use C: use Declare::Constraints::Simple Only => qw(IsInt Matches And); You can find all constraints (and constraint-like generators, like operators. In fact, C above is an operator. They're both implemented equally, so the distinction is a merely philosophical one) documented in the L pod. In that document you will also find the exact parameters for their usage, so this here is just a brief Intro and not a coverage of all possibilities. =head2 Building a Profile You can use these constraints by building a tree that describes what data structure you expect. Every constraint can be used as sub-constraint, as parent, if it accepts other constraints, or stand-alone. If you'd just say my $check = IsInt; print "yes!\n" if $check->(23); it will work too. This also allows predefining tree segments, and nesting them: my $id_to_objects = IsArrayRef(IsObject); Here C<$id_to_objects> would give it's OK on an array reference containing a list of objects. But what if we now decide that we actually want a hashref containing two lists of objects? Behold: my $object_lists = IsHashRef( HasAllKeys( qw(good bad) ), OnHashKeys( good => $id_to_objects, bad => $id_to_objects )); As you can see, constraints like C and C allow you to apply constraints to their keys and values. With this, you can step down in the data structure. =head2 Applying a Profile to a Data Structure Constraints return just code references that can be applied to one value (and only one value) like this: my $result = $object_lists->($value); After this call C<$result> contains a L object. The first think one wants to know is if the validation succeeded: if ($result->is_valid) { ... } This is pretty straight forward. To shorten things the result object also Ls it's Cean context. This means you can alternatively just say if ($result) { ... } However, if the result indicates a invalid data structure, we have a few options to find out what went wrong. There's a human parsable message in the C accessor. You can override these by forcing it to a message in a subtree with the C declaration. The C contains the name of the chain of constraints up to the point of failure. You can use the C accessor for a joined string path representing the stack. =head2 Creating your own Libraries You can declare a package as a library with use Declare::Constraints::Simple-Library; which will install the base class and helper methods to define constraints. For a complete list read the documentation in L. You can use other libraries as base classes to include their constraints in your export possibilities. This means that with a package setup like package MyLibrary; use warnings; use strict; use Declare::Constraints::Simple-Library; use base 'Declare::Constraints::Simple::Library'; constraint 'MyConstraint', sub { return _result(($_[0] >= 12), 'Value too small') }; 1; you can do use MyLibrary-All; and have all constraints, from the default library and yours from above, installed into your requesting namespace. You can override a constraint just by redeclaring it in a subclass. =head2 Scoping Sometimes you want to validate parts of a data structure depending on another part of it. As of version 2.0 you can declare scopes and store results in them. Here is a complete example: my $constraint = Scope('foo', And( HasAllKeys( qw(cmd data) ), OnHashKeys( cmd => Or( SetResult('foo', 'cmd_a', IsEq('FOO_A')), SetResult('foo', 'cmd_b', IsEq('FOO_B')) ), data => Or( And( IsValid('foo', 'cmd_a'), IsArrayRef( IsInt )), And( IsValid('foo', 'cmd_b'), IsRegex )) ))); This profile would accept a hash references with the keys C and C. If C is set to C, then C has to be an array ref of integers. But if C is set to C, a regular expression is expected. =head1 SEE ALSO L, L, L, L =head1 REQUIRES L, L, L, L, L and L (for build). =head1 TODO =over =item * Examples. =item * A list of questions that might come up, together with their answers. =item * A C constraint that takes a code reference. =item * Create stack objects that stringify to the current form, but can hold more data. =item * Give the C constraint the ability to get the generated constraint inserted in the message. A possibility would be to replace __Value__ and __Message__. It might also accept code references, which return strings. =item * Allow the C constraint to accept further constraints. One might like to check, for example, the refaddr of a closure. =item * A C constraint that takes a regex and can apply other constraints to the matches. =item * ??? =item * Profit. =back =head1 INSTALLATION perl Makefile.PL make make test make install For details read L. =head1 AUTHOR Robert 'phaylon' Sedlacek Cphaylon@dunkelheit.atE> =head1 LICENSE AND COPYRIGHT This module is free software, you can redistribute it and/or modify it under the same terms as perl itself. =cut 1; Declare-Constraints-Simple-0.03/META.yml0000644000175000017500000000061210502260022021132 0ustar phaylonphaylon00000000000000abstract: Declarative Validation of Data Structures author: "Robert 'phaylon' Sedlacek " build_requires: Test::More: 0 distribution_type: module generated_by: Module::Install version 0.64 license: perl name: Declare-Constraints-Simple no_index: directory: - inc - t requires: Carp::Clan: 0 Class::Inspector: 0 Scalar::Util: 0 aliased: 0 version: 0.03 Declare-Constraints-Simple-0.03/Makefile.PL0000644000175000017500000000114110501243227021640 0ustar phaylonphaylon00000000000000use inc::Module::Install; use warnings; use strict; name q(Declare-Constraints-Simple); abstract_from q(lib/Declare/Constraints/Simple.pm); version_from q(lib/Declare/Constraints/Simple.pm); author q(Robert 'phaylon' Sedlacek ); license q(perl); requires @$_ for ( ['Class::Inspector' => 0], ['Carp::Clan' => 0], ['Scalar::Util' => 0], ['aliased' => 0] ); build_requires 'Test::More' => 0; WriteAll; 1; Declare-Constraints-Simple-0.03/README0000644000175000017500000001561610502257655020575 0ustar phaylonphaylon00000000000000NAME Declare::Constraints::Simple - Declarative Validation of Data Structures SYNOPSIS use Declare::Constraints::Simple-All; my $profile = IsHashRef( -keys => HasLength, -values => IsArrayRef( IsObject )); my $result1 = $profile->(undef); print $result1->message, "\n"; # 'Not a HashRef' my $result2 = $profile->({foo => [23]}); print $result2->message, "\n"; # 'Not an Object' print $result2->path, "\n"; # 'IsHashRef[val foo].IsArrayRef[0].IsObject' DESCRIPTION The main purpose of this module is to provide an easy way to build a profile to validate a data structure. It does this by giving you a set of declarative keywords in the importing namespace. USAGE This is just a brief intro. For details read the documents mentioned in "SEE ALSO". Constraint Import use Declare::Constraints::Simple-All; The above command imports all constraint generators in the library into the current namespace. If you want only a selection, use "only": use Declare::Constraints::Simple Only => qw(IsInt Matches And); You can find all constraints (and constraint-like generators, like operators. In fact, "And" above is an operator. They're both implemented equally, so the distinction is a merely philosophical one) documented in the Declare::Constraints::Simple::Library pod. In that document you will also find the exact parameters for their usage, so this here is just a brief Intro and not a coverage of all possibilities. Building a Profile You can use these constraints by building a tree that describes what data structure you expect. Every constraint can be used as sub-constraint, as parent, if it accepts other constraints, or stand-alone. If you'd just say my $check = IsInt; print "yes!\n" if $check->(23); it will work too. This also allows predefining tree segments, and nesting them: my $id_to_objects = IsArrayRef(IsObject); Here $id_to_objects would give it's OK on an array reference containing a list of objects. But what if we now decide that we actually want a hashref containing two lists of objects? Behold: my $object_lists = IsHashRef( HasAllKeys( qw(good bad) ), OnHashKeys( good => $id_to_objects, bad => $id_to_objects )); As you can see, constraints like "IsArrayRef" and "IsHashRef" allow you to apply constraints to their keys and values. With this, you can step down in the data structure. Applying a Profile to a Data Structure Constraints return just code references that can be applied to one value (and only one value) like this: my $result = $object_lists->($value); After this call $result contains a Declare::Constraints::Simple::Result object. The first think one wants to know is if the validation succeeded: if ($result->is_valid) { ... } This is pretty straight forward. To shorten things the result object also overloads it's "bool"ean context. This means you can alternatively just say if ($result) { ... } However, if the result indicates a invalid data structure, we have a few options to find out what went wrong. There's a human parsable message in the "message" accessor. You can override these by forcing it to a message in a subtree with the "Message" declaration. The "stack" contains the name of the chain of constraints up to the point of failure. You can use the "path" accessor for a joined string path representing the stack. Creating your own Libraries You can declare a package as a library with use Declare::Constraints::Simple-Library; which will install the base class and helper methods to define constraints. For a complete list read the documentation in Declare::Constraints::Simple::Library::Base. You can use other libraries as base classes to include their constraints in your export possibilities. This means that with a package setup like package MyLibrary; use warnings; use strict; use Declare::Constraints::Simple-Library; use base 'Declare::Constraints::Simple::Library'; constraint 'MyConstraint', sub { return _result(($_[0] >= 12), 'Value too small') }; 1; you can do use MyLibrary-All; and have all constraints, from the default library and yours from above, installed into your requesting namespace. You can override a constraint just by redeclaring it in a subclass. Scoping Sometimes you want to validate parts of a data structure depending on another part of it. As of version 2.0 you can declare scopes and store results in them. Here is a complete example: my $constraint = Scope('foo', And( HasAllKeys( qw(cmd data) ), OnHashKeys( cmd => Or( SetResult('foo', 'cmd_a', IsEq('FOO_A')), SetResult('foo', 'cmd_b', IsEq('FOO_B')) ), data => Or( And( IsValid('foo', 'cmd_a'), IsArrayRef( IsInt )), And( IsValid('foo', 'cmd_b'), IsRegex )) ))); This profile would accept a hash references with the keys "cmd" and "data". If "cmd" is set to "FOO_A", then "data" has to be an array ref of integers. But if "cmd" is set to "FOO_B", a regular expression is expected. SEE ALSO Declare::Constraints::Simple::Library, Declare::Constraints::Simple::Result, Declare::Constraints::Simple::Base, Module::Install REQUIRES Carp::Clan, aliased, Class::Inspector, Scalar::Util, overload and Test::More (for build). TODO * Examples. * A list of questions that might come up, together with their answers. * A "Custom" constraint that takes a code reference. * Create stack objects that stringify to the current form, but can hold more data. * Give the "Message" constraint the ability to get the generated constraint inserted in the message. A possibility would be to replace __Value__ and __Message__. It might also accept code references, which return strings. * Allow the "IsCodeRef" constraint to accept further constraints. One might like to check, for example, the refaddr of a closure. * A "Captures" constraint that takes a regex and can apply other constraints to the matches. * ??? * Profit. INSTALLATION perl Makefile.PL make make test make install For details read Module::Install. AUTHOR Robert 'phaylon' Sedlacek "" LICENSE AND COPYRIGHT This module is free software, you can redistribute it and/or modify it under the same terms as perl itself.