File Coverage

blib/lib/MongoDBx/Tiny/Attributes.pm
Criterion Covered Total %
statement 9 114 7.8
branch 0 64 0.0
condition 0 17 0.0
subroutine 3 40 7.5
pod 18 18 100.0
total 30 253 11.8


line stmt bran cond sub pod time code
1             package MongoDBx::Tiny::Attributes;
2 1     1   7 use strict;
  1         2  
  1         151  
3              
4             =head1 NAME
5              
6             MongoDBx::Tiny::Attributes - offering field attributes
7              
8             =head1 SYNOPSIS
9              
10             package My::Data::Foo;
11              
12             use MongoDBx::Tiny::Document;
13              
14             COLLECTION_NAME 'foo';
15              
16             ESSENTIAL q/code/;
17             FIELD 'code', INT, LENGTH(10), DEFAULT('0'), REQUIRED;
18             FIELD 'name', STR, LENGTH(30), DEFAULT('noname');
19              
20             # you can also define customized one.
21            
22             FIELD 'some', &SOME_ATTRIBUTE;
23             sub SOME_ATTRIBUTE {
24             name => 'SOME_ATTRIBUTE',
25             callback => sub {
26             my $target = shift;
27             return MongoDBx::Tiny::Attributes::OK;
28             },
29             }
30              
31             =cut
32              
33             our @ISA = qw/Exporter/;
34             our @EXPORT = qw/INT UINT HEX STR ENUM DATETIME TIMESTAMP SCALAR REF ARRAY HASH REGEX
35             LENGTH NOT_NULL OID DEFAULT REQUIRED
36             NOW READ_ONLY OK FAIL
37             /;
38              
39 1     1   6 use constant OK => 1;
  1         3  
  1         66  
40 1     1   7 use constant FAIL => 0;
  1         2  
  1         2428  
41              
42             =head2 callback arguments
43              
44             callback = sub {
45             my $target = shift;
46             my $tiny = shift;
47             my $opt = shift; # state => 'insert|update'
48             return FAIL, { message => 'error' };
49             return OK, { target => $target }; # override target if you want
50             }
51              
52             =cut
53              
54             =head1 ATTRIBUTES
55              
56             =cut
57              
58             =head2 LENGTH
59              
60             LENGTH(255)
61              
62             =cut
63              
64             sub LENGTH {
65 0     0 1   my $max = pop;
66 0           my $min = pop;
67              
68             return {
69             name => 'LENGTH',
70             callback => sub {
71 0     0     my $target = shift;
72 0 0         return OK unless defined $target;
73 0 0         if (ref $target eq 'ARRAY') {
74 0 0 0       if ( @$target > $max || (defined $min && @$target < $min) ) {
      0        
75 0           return FAIL, { message => 'invalid' };
76             }
77             }else{
78 0 0 0       if ( length($target) > $max || ( defined $min && length($target) < $min ) ) {
      0        
79 0           return FAIL, { message => 'invalid' };
80             }
81             }
82 0           return OK;
83             },
84 0           };
85             }
86              
87             =head2 INT
88              
89             =cut
90              
91             sub INT {
92             return {
93             name => 'INT',
94             callback => sub {
95 0     0     my $target = shift;
96 0 0         return OK unless defined $target;
97 0 0         return FAIL,{ message => 'invalid' } unless $target =~ /\A[+-]?[0-9]+\z/;
98 0           return OK;
99             },
100             }
101 0     0 1   }
102              
103             =head2 UINT
104              
105             =cut
106              
107             sub UINT {
108             return {
109             name => 'UINT',
110             callback => sub {
111 0     0     my $target = shift;
112 0 0         return OK unless defined $target;
113 0 0         return FAIL,{ message => 'invalid' } if $target =~ /[^0-9]/;
114 0           return OK;
115             },
116             }
117 0     0 1   }
118              
119             =head2 HEX
120              
121             =cut
122              
123             sub HEX {
124             return {
125             name => 'HEX',
126             callback => sub {
127 0     0     my $target = shift;
128 0 0         return OK unless defined $target;
129 0 0         return FAIL,{ message => 'invalid' } unless $target =~ m/^[a-f\d]+$/;
130 0           return OK;
131             },
132 0     0 1   };
133             }
134              
135             =head2 STR
136              
137             =cut
138              
139             sub STR {
140             return {
141             name => 'STR',
142             callback => sub {
143 0     0     my $target = shift;
144 0 0         return OK unless defined $target;
145 0 0         return FAIL,{ message => 'invalid' } if ref $target;
146 0           return OK;
147             },
148             }
149 0     0 1   }
150              
151             =head2 ENUM
152              
153             ENUM('on','off')
154              
155             =cut
156              
157             sub ENUM {
158 0     0 1   my @list = @_;
159             return {
160             name => 'ENUM',
161             callback => sub {
162 0     0     my $target = shift;
163 0 0         return OK unless defined $target;
164 0           my $message = sprintf "%s is available", join ",", @list;
165 0 0         return FAIL,{ message => $message } unless (grep { $target eq $_ } @list);
  0            
166 0           return OK;
167             },
168             }
169 0           }
170              
171             =head2 REF
172              
173             =cut
174              
175             sub REF {
176 0     0 1   my $type = shift;
177             return {
178             name => 'REF',
179             callback => sub {
180 0     0     my $target = shift;
181 0 0         return OK unless defined $target;
182 0 0         return FAIL unless ref $target eq $type;
183 0           return OK;
184             },
185             }
186 0           }
187              
188             =head2 HASH
189              
190             =cut
191              
192             sub HASH {
193             return {
194             name => 'HASH',
195             callback => sub {
196 0     0     my $target = shift;
197 0 0         return OK unless defined $target;
198 0 0         return FAIL unless ref $target eq 'HASH';
199 0           return OK;
200             },
201             }
202 0     0 1   }
203              
204             =head2 ARRAY
205              
206             =cut
207              
208             sub ARRAY {
209             return {
210             name => 'ARRAY',
211             callback => sub {
212 0     0     my $target = shift;
213 0 0         return OK unless defined $target;
214 0 0         return FAIL unless ref $target eq 'ARRAY';
215 0           return OK;
216             },
217             }
218 0     0 1   }
219              
220             =head2 DATETIME
221              
222             =cut
223              
224             sub DATETIME {
225             # xxx
226             return {
227             name => 'DATETIME',
228             callback => sub {
229 0     0     my $target = shift;
230 0 0         if ($target) {
231 0 0         return FAIL,{ message => 'not DateTime object' } unless (ref $target) eq 'DateTime';
232             }
233 0           return OK;
234             }
235             }
236 0     0 1   }
237              
238             =head2 TIMESTAMP
239              
240             =cut
241              
242             sub TIMESTAMP {
243             # xxx
244             return {
245             name => 'TIMESTAMP',
246             callback => sub {
247 0     0     my $target = shift;
248 0           return OK;
249             }
250             }
251 0     0 1   }
252              
253             =head2 REGEX
254              
255             REGEX('\d+')
256              
257             =cut
258              
259             sub REGEX {
260 0     0 1   my $regex = shift;
261              
262             return {
263             name => 'REGEX',
264             callback => sub {
265 0     0     my $target = shift;
266 0 0         return OK unless defined $target;
267 0 0         return FAIL, { message => 'not match' } unless $target =~ /${regex}/;
268 0           return OK;
269             },
270             }
271 0           }
272              
273              
274             =head2 NOT_NULL
275              
276             =cut
277              
278             sub NOT_NULL {
279             return {
280             name => 'NOT_NULL',
281             callback => sub {
282 0     0     my $target = shift;
283 0 0         return FAIL,{ message => 'undefined' } unless defined $target;
284 0           return OK;
285             },
286             }
287 0     0 1   }
288              
289             =head2 OID
290              
291             =cut
292              
293             sub OID {
294             return {
295             name => 'OID',
296             callback => sub {
297 0     0     my $target = shift;
298              
299 0 0         return OK unless defined $target;
300 0 0         unless (ref $target eq 'MongoDB::OID') {
301 0 0         if( $target =~ /\A[a-fA-F\d]{24}\z/) {
302 0           $target = MongoDB::OID->new(value => $target);
303 0           return OK,{ target => $target };
304             }else{
305 0           return FAIL,{ message => 'invalid' };
306             }
307             }
308 0           return OK, { target => $target };
309             },
310             }
311 0     0 1   }
312              
313             =head2 DEFAULT
314              
315             DEFAULT("foo")
316             DEFAULT([])
317              
318             =cut
319              
320             sub DEFAULT {
321 0     0 1   my $default = shift;
322             return {
323             name => 'DEFAULT',
324             callback => sub {
325 0     0     my $target = shift;
326 0 0 0       return OK,{ target => $target } if (defined $target && $target ne '');
327 0 0         if (ref $default eq 'CODE') {
328 0           return OK,{ target => $default->($target) };
329             } else {
330 0           return OK,{ target => $default };
331             }
332             },
333             }
334 0           }
335              
336             =head2 REQUIRED
337              
338             =cut
339              
340             sub REQUIRED {
341             return {
342             name => 'REQUIRED',
343 0     0     callback => sub { return OK },
344             }
345 0     0 1   }
346              
347             =head2 NOW
348              
349             DEFAULT(NOW('Asia/Tokyo')
350              
351             =cut
352              
353             sub NOW {
354             # for DEFAULT
355 0   0 0 1   my $time_zone = shift || 'local';
356 0 0         if ($time_zone eq 'timestamp') {
357 0           require MongoDB::Timestamp;
358 0     0     return sub { MongoDB::Timestamp->new(sec => time, inc => 1) };
  0            
359             } else {
360 0           require DateTime;
361 0     0     return sub { DateTime->now(time_zone => $time_zone) };
  0            
362             }
363             }
364              
365             =head2 READ_ONLY
366              
367             =cut
368              
369             sub READ_ONLY {
370             return {
371             name => 'READ_ONLY',
372             callback => sub {
373 0     0     my $target = shift;
374 0           my $tiny = shift;
375 0           my $opt = shift; # state => 'insert|update'
376 0 0         return FAIL, if ($opt->{state} eq 'update');
377 0           return OK;
378             }
379             }
380 0     0 1   }
381              
382             1;
383              
384             =head1 AUTHOR
385              
386             Naoto ISHIKAWA, C<< <toona at seesaa.co.jp> >>
387              
388             Kouji Tominaga, C<< <tominaga at seesaa.co.jp> >>
389              
390             =head1 LICENSE AND COPYRIGHT
391              
392             Copyright 2013 Naoto ISHIKAWA.
393              
394             This program is free software; you can redistribute it and/or modify it
395             under the terms of either: the GNU General Public License as published
396             by the Free Software Foundation; or the Artistic License.
397              
398             See http://dev.perl.org/licenses/ for more information.
399              
400              
401             =cut