File Coverage

blib/lib/Types/SQL.pm
Criterion Covered Total %
statement 47 51 92.1
branch 8 12 66.6
condition 2 2 100.0
subroutine 14 16 87.5
pod n/a
total 71 81 87.6


line stmt bran cond sub pod time code
1             package Types::SQL;
2              
3 9     9   856355 use v5.10;
  9         94  
4              
5 9     9   40 use strict;
  9         12  
  9         183  
6 9     9   33 use warnings;
  9         16  
  9         419  
7              
8             use Type::Library
9 9         162 -base,
10 9     9   3221 -declare => qw/ BigInt Char Integer Numeric Serial SmallInt Text Varchar /;
  9         177161  
11              
12 9     9   18261 use Ref::Util qw/ is_arrayref /;
  9         12847  
  9         673  
13 9     9   3416 use Type::Utils 0.44 -all;
  9         33551  
  9         63  
14 9     9   29253 use Types::Standard -types;
  9         344454  
  9         83  
15 9     9   38586 use PerlX::Maybe qw/ maybe /;
  9         18382  
  9         35  
16              
17 9     9   3772 use namespace::autoclean;
  9         131424  
  9         33  
18              
19             # RECOMMEND PREREQ: PerlX::Maybe::XS
20             # RECOMMEND PREREQ: Ref::Util::XS
21             # RECOMMEND PREREQ: Type::Tiny::XS
22              
23             # ABSTRACT: a library of SQL types
24              
25             our $VERSION = 'v0.6.0';
26              
27              
28             our $Blob = _generate_type(
29             name => 'Blob',
30             parent => Str,
31             dbic_column_info => sub {
32             my ($self) = @_;
33             return (
34             is_numeric => 0,
35             data_type => 'blob',
36             );
37             },
38             );
39              
40              
41             our $Text = _generate_type(
42             name => 'Text',
43             parent => Str,
44             dbic_column_info => sub {
45             my ($self) = @_;
46             return (
47             is_numeric => 0,
48             data_type => 'text',
49             );
50             },
51             );
52              
53              
54             our $Varchar = _generate_type(
55             name => 'Varchar',
56             parent => $Text,
57             constraint_generator => \&_size_constraint_generator,
58             dbic_column_info => sub {
59             my ( $self, $size ) = @_;
60             my $parent = $self->parent->my_methods->{dbic_column_info};
61             return (
62             $parent->( $self->parent, $size // $self->type_parameter ),
63             data_type => 'varchar',
64             maybe size => $size // $self->type_parameter,
65             );
66             },
67             );
68              
69              
70             our $Char = _generate_type(
71             name => 'Char',
72             parent => $Text,
73             constraint_generator => \&_size_constraint_generator,
74             dbic_column_info => sub {
75             my ( $self, $size ) = @_;
76             my $parent = $self->parent->my_methods->{dbic_column_info};
77             return (
78             $parent->( $self->parent, $size // $self->type_parameter // 1 ),
79             data_type => 'char',
80             size => $size // $self->type_parameter // 1,
81             );
82             },
83             );
84              
85              
86             our $Integer = _generate_type(
87             name => 'Integer',
88             parent => Int,
89             constraint_generator => \&_size_constraint_generator,
90             dbic_column_info => sub {
91             my ( $self, $size ) = @_;
92             return (
93             data_type => 'integer',
94             is_numeric => 1,
95             maybe size => $size // $self->type_parameter,
96             );
97             },
98             );
99              
100              
101             declare SmallInt, as Integer[5];
102             declare BigInt, as Integer[19];
103              
104              
105             our $Serial = _generate_type(
106             name => 'Serial',
107             parent => $Integer,
108             constraint_generator => \&_size_constraint_generator,
109             dbic_column_info => sub {
110             my ( $self, $size ) = @_;
111             my $parent = $self->parent->my_methods->{dbic_column_info};
112             return (
113             $parent->( $self->parent, $size // $self->type_parameter ),
114             data_type => 'serial',
115             is_auto_increment => 1,
116             );
117             },
118             );
119              
120              
121             our $Numeric = _generate_type(
122             name => 'Numeric',
123             parent => Num,
124             constraint_generator => \&_size_range_constraint_generator,
125             dbic_column_info => sub {
126             my ( $self, $size ) = @_;
127             return (
128             data_type => 'numeric',
129             is_numeric => 1,
130             maybe size => $size // $self->parameters,
131             );
132             },
133             );
134              
135             sub _size_constraint_generator {
136 29 50   29   26839 if (@_) {
137 29         64 my ($size) = @_;
138 29 100       213 die "Size must be a positive integer" unless $size =~ /^[1-9]\d*$/;
139 25         532 my $re = qr/^0*\d{1,$size}$/;
140 25     10   171 return sub { $_ =~ $re };
  10         7625  
141             }
142             else {
143 0     0   0 return sub { $_ =~ /^\d+$/ };
  0         0  
144             }
145             }
146              
147             sub _size_range_constraint_generator {
148 3 50   3   6497 if (@_) {
149 3         7 my ( $prec, $scale ) = @_;
150 3   100     10 $scale //= 0;
151              
152 3 100       21 die "Precision must be a positive integer" unless $prec =~ /^[1-9]\d*$/;
153 2 50       8 die "Scale must be a positive integer" unless $scale =~ /^\d+$/;
154              
155 2         4 my $left = $prec - $scale;
156 2 50       5 die "Scale must be less than the precision" if ( $left < 0 );
157              
158 2         79 my $re = qr/^0*\d{0,$left}([.]\d{0,$scale}0*)?$/;
159 2     9   18 return sub { $_ =~ $re };
  9         4649  
160             }
161             else {
162 0     0   0 return sub { $_ =~ /^\d+$/ };
  0         0  
163             }
164             }
165              
166             sub _generate_type {
167 63     63   376 my %args = @_;
168              
169             $args{my_methods} =
170 63         244 { maybe dbic_column_info => delete $args{dbic_column_info}, };
171              
172 63         357 my $type = Type::Tiny->new(%args);
173 63         5887 __PACKAGE__->meta->add_type($type);
174 63         28952 return $type;
175             }
176              
177              
178             __PACKAGE__->meta->make_immutable;
179              
180             __END__