Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

I said advanced...

  • Loading branch information...
commit af78cda38f6f23f93979032b9d0f5839a9b4a002 1 parent 75687e0
@kberov authored
Showing with 153 additions and 0 deletions.
  1. +97 −0 t/lib/My.pm
  2. +25 −0 t/lib/My/Groups.pm
  3. +18 −0 t/pod-coverage.t
  4. +13 −0 t/pod.t
View
97 t/lib/My.pm
@@ -0,0 +1,97 @@
+use 5.010;
+use strict;
+use warnings;
+use utf8;
+
+use DBIx::Simple::Class;
+{
+
+ package My; #our schema
+ use base qw(DBIx::Simple::Class);
+ sub namespace {__PACKAGE__}
+}
+
+{
+
+ package My::User;
+ use base qw(My);
+
+ sub TABLE {'users'}
+ sub COLUMNS { [qw(id group_id login_name login_password disabled)] }
+ sub WHERE { {disabled => 1} }
+
+ #See Params::Check
+ my $_CHECKS = {
+ id => {allow => qr/^\d+$/x},
+ group_id => {allow => qr/^\d+$/x, default => 1},
+ disabled => {
+ default => 1,
+ allow => sub {
+ return $_[0] =~ /^[01]$/x;
+ }
+ },
+ login_name => {allow => qr/^\p{IsAlnum}{4,12}$/x},
+ login_password => {
+ required => 1,
+ allow => sub { $_[0] =~ /^[\w\W]{8,20}$/x; }
+ }
+
+ #...
+ };
+ sub CHECKS {$_CHECKS}
+
+ sub id {
+ my ($self, $value) = @_;
+ if (defined $value) { #setting value
+ $self->{data}{id} = $self->_check(id => $value);
+
+ #make it chainable
+ return $self;
+ }
+ $self->{data}{id} //= $self->CHECKS->{id}{default}; #getting value
+ }
+}
+{
+
+ package My::Group;
+ use base qw(My);
+
+ use constant TABLE => 'groups';
+ use constant COLUMNS => [qw(id group_name foo-bar data)];
+ use constant WHERE => {};
+
+ #See Params::Check
+ use constant CHECKS => {};
+}
+
+{
+
+ package My::Collision;
+ use base qw(My);
+
+ use constant TABLE => 'collision';
+ use constant COLUMNS => [qw(id data)];
+ use constant WHERE => {};
+ use constant ALIASES => {data => 'column_data'};
+
+ #CHECKS are on columns
+ use constant CHECKS => {
+ id => {allow => qr/^\d+$/x},
+ data => {default => '',} #that's ok
+ };
+}
+
+{
+
+ package My::SiteUser;
+ use base qw(My::User);
+ my $_CHECKS = My::User->CHECKS;
+ $_CHECKS->{group_id}{default} = 3;
+ sub CHECKS {$_CHECKS}
+ sub WHERE { {disabled => 0, group_id => $_CHECKS->{group_id}{default}} }
+
+ #merge with parent $SQL
+ __PACKAGE__->SQL(GUEST_USER => 'SELECT * FROM users WHERE login_name = \'guest\'');
+}
+
+1;
View
25 t/lib/My/Groups.pm
@@ -0,0 +1,25 @@
+use strict;
+use warnings;
+use utf8;
+
+package My::Groups;
+use base qw (My);
+sub TABLE {'my groups'} #problem
+sub COLUMNS { ['id', 'group', 'is\' enabled'] } #problem
+
+sub ALIASES {
+ { 'is\' enabled' => 'is_enabled', }
+}
+
+sub WHERE { {'is enabled' => 1} }
+
+sub CHECKS {
+ {
+ 'is\' enabled' => {allow => qr/^[01]$/},
+ id => {allow => qr/^\d+$/x},
+ group => {required => 1, allow => qr/^\w+$/}
+ }
+}
+__PACKAGE__->QUOTE_IDENTIFIERS(1); #no problem now
+__PACKAGE__->BUILD; #dbix/dbh must be connected now
+
View
18 t/pod-coverage.t
@@ -0,0 +1,18 @@
+use strict;
+use warnings;
+use Test::More;
+
+# Ensure a recent version of Test::Pod::Coverage
+my $min_tpc = 1.08;
+eval "use Test::Pod::Coverage $min_tpc";
+plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage"
+ if $@;
+
+# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version,
+# but older versions don't recognize some common documentation styles
+my $min_pc = 0.18;
+eval "use Pod::Coverage $min_pc";
+plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage"
+ if $@;
+
+all_pod_coverage_ok();
View
13 t/pod.t
@@ -0,0 +1,13 @@
+#!perl -T
+
+use strict;
+use warnings;
+use Test::More;
+
+# Ensure a recent version of Test::Pod
+my $min_tp = 1.22;
+eval "use Test::Pod";
+plan skip_all => "Test::Pod $min_tp required for testing POD"
+ if $@ || $Test::Pod::VERSION < $min_tp;
+
+all_pod_files_ok();
Please sign in to comment.
Something went wrong with that request. Please try again.