Commit | Line | Data |
d4567ecb |
1 | #----------------------------------------------------------------------- |
2 | # TITLE: |
3 | # validate.tcl |
4 | # |
5 | # AUTHOR: |
6 | # Will Duquette |
7 | # |
8 | # DESCRIPTION: |
9 | # Snit validation types. |
10 | # |
11 | #----------------------------------------------------------------------- |
12 | |
13 | namespace eval ::snit:: { |
14 | namespace export \ |
15 | boolean \ |
16 | double \ |
17 | enum \ |
18 | fpixels \ |
19 | integer \ |
20 | listtype \ |
21 | pixels \ |
22 | stringtype \ |
23 | window |
24 | } |
25 | |
26 | #----------------------------------------------------------------------- |
27 | # snit::boolean |
28 | |
29 | snit::type ::snit::boolean { |
30 | #------------------------------------------------------------------- |
31 | # Type Methods |
32 | |
33 | typemethod validate {value} { |
34 | if {![string is boolean -strict $value]} { |
35 | return -code error -errorcode INVALID \ |
36 | "invalid boolean \"$value\", should be one of: 1, 0, true, false, yes, no, on, off" |
37 | |
38 | } |
39 | |
40 | return $value |
41 | } |
42 | |
43 | #------------------------------------------------------------------- |
44 | # Constructor |
45 | |
46 | # None needed; no options |
47 | |
48 | #------------------------------------------------------------------- |
49 | # Public Methods |
50 | |
51 | method validate {value} { |
52 | $type validate $value |
53 | } |
54 | } |
55 | |
56 | #----------------------------------------------------------------------- |
57 | # snit::double |
58 | |
59 | snit::type ::snit::double { |
60 | #------------------------------------------------------------------- |
61 | # Options |
62 | |
63 | # -min value |
64 | # |
65 | # Minimum value |
66 | |
67 | option -min -default "" -readonly 1 |
68 | |
69 | # -max value |
70 | # |
71 | # Maximum value |
72 | |
73 | option -max -default "" -readonly 1 |
74 | |
75 | #------------------------------------------------------------------- |
76 | # Type Methods |
77 | |
78 | typemethod validate {value} { |
79 | if {![string is double -strict $value]} { |
80 | return -code error -errorcode INVALID \ |
81 | "invalid value \"$value\", expected double" |
82 | } |
83 | |
84 | return $value |
85 | } |
86 | |
87 | #------------------------------------------------------------------- |
88 | # Constructor |
89 | |
90 | constructor {args} { |
91 | # FIRST, get the options |
92 | $self configurelist $args |
93 | |
94 | if {"" != $options(-min) && |
95 | ![string is double -strict $options(-min)]} { |
96 | return -code error \ |
97 | "invalid -min: \"$options(-min)\"" |
98 | } |
99 | |
100 | if {"" != $options(-max) && |
101 | ![string is double -strict $options(-max)]} { |
102 | return -code error \ |
103 | "invalid -max: \"$options(-max)\"" |
104 | } |
105 | |
106 | if {"" != $options(-min) && |
107 | "" != $options(-max) && |
108 | $options(-max) < $options(-min)} { |
109 | return -code error "-max < -min" |
110 | } |
111 | } |
112 | |
113 | #------------------------------------------------------------------- |
114 | # Public Methods |
115 | |
116 | # Fixed method for the snit::double type. |
117 | # WHD, 6/7/2010. |
118 | method validate {value} { |
119 | $type validate $value |
120 | |
121 | if {("" != $options(-min) && $value < $options(-min)) || |
122 | ("" != $options(-max) && $value > $options(-max))} { |
123 | |
124 | set msg "invalid value \"$value\", expected double" |
125 | |
126 | if {"" != $options(-min) && "" != $options(-max)} { |
127 | append msg " in range $options(-min), $options(-max)" |
128 | } elseif {"" != $options(-min)} { |
129 | append msg " no less than $options(-min)" |
130 | } elseif {"" != $options(-max)} { |
131 | append msg " no greater than $options(-max)" |
132 | } |
133 | |
134 | return -code error -errorcode INVALID $msg |
135 | } |
136 | |
137 | return $value |
138 | } |
139 | } |
140 | |
141 | #----------------------------------------------------------------------- |
142 | # snit::enum |
143 | |
144 | snit::type ::snit::enum { |
145 | #------------------------------------------------------------------- |
146 | # Options |
147 | |
148 | # -values list |
149 | # |
150 | # Valid values for this type |
151 | |
152 | option -values -default {} -readonly 1 |
153 | |
154 | #------------------------------------------------------------------- |
155 | # Type Methods |
156 | |
157 | typemethod validate {value} { |
158 | # No -values specified; it's always valid |
159 | return $value |
160 | } |
161 | |
162 | #------------------------------------------------------------------- |
163 | # Constructor |
164 | |
165 | constructor {args} { |
166 | $self configurelist $args |
167 | |
168 | if {[llength $options(-values)] == 0} { |
169 | return -code error \ |
170 | "invalid -values: \"\"" |
171 | } |
172 | } |
173 | |
174 | #------------------------------------------------------------------- |
175 | # Public Methods |
176 | |
177 | method validate {value} { |
178 | if {[lsearch -exact $options(-values) $value] == -1} { |
179 | return -code error -errorcode INVALID \ |
180 | "invalid value \"$value\", should be one of: [join $options(-values) {, }]" |
181 | } |
182 | |
183 | return $value |
184 | } |
185 | } |
186 | |
187 | #----------------------------------------------------------------------- |
188 | # snit::fpixels |
189 | |
190 | snit::type ::snit::fpixels { |
191 | #------------------------------------------------------------------- |
192 | # Options |
193 | |
194 | # -min value |
195 | # |
196 | # Minimum value |
197 | |
198 | option -min -default "" -readonly 1 |
199 | |
200 | # -max value |
201 | # |
202 | # Maximum value |
203 | |
204 | option -max -default "" -readonly 1 |
205 | |
206 | #------------------------------------------------------------------- |
207 | # Instance variables |
208 | |
209 | variable min "" ;# -min, no suffix |
210 | variable max "" ;# -max, no suffix |
211 | |
212 | #------------------------------------------------------------------- |
213 | # Type Methods |
214 | |
215 | typemethod validate {value} { |
216 | if {[catch {winfo fpixels . $value} dummy]} { |
217 | return -code error -errorcode INVALID \ |
218 | "invalid value \"$value\", expected fpixels" |
219 | } |
220 | |
221 | return $value |
222 | } |
223 | |
224 | #------------------------------------------------------------------- |
225 | # Constructor |
226 | |
227 | constructor {args} { |
228 | # FIRST, get the options |
229 | $self configurelist $args |
230 | |
231 | if {"" != $options(-min) && |
232 | [catch {winfo fpixels . $options(-min)} min]} { |
233 | return -code error \ |
234 | "invalid -min: \"$options(-min)\"" |
235 | } |
236 | |
237 | if {"" != $options(-max) && |
238 | [catch {winfo fpixels . $options(-max)} max]} { |
239 | return -code error \ |
240 | "invalid -max: \"$options(-max)\"" |
241 | } |
242 | |
243 | if {"" != $min && |
244 | "" != $max && |
245 | $max < $min} { |
246 | return -code error "-max < -min" |
247 | } |
248 | } |
249 | |
250 | #------------------------------------------------------------------- |
251 | # Public Methods |
252 | |
253 | method validate {value} { |
254 | $type validate $value |
255 | |
256 | set val [winfo fpixels . $value] |
257 | |
258 | if {("" != $min && $val < $min) || |
259 | ("" != $max && $val > $max)} { |
260 | |
261 | set msg "invalid value \"$value\", expected fpixels" |
262 | |
263 | if {"" != $min && "" != $max} { |
264 | append msg " in range $options(-min), $options(-max)" |
265 | } elseif {"" != $min} { |
266 | append msg " no less than $options(-min)" |
267 | } |
268 | |
269 | return -code error -errorcode INVALID $msg |
270 | } |
271 | |
272 | return $value |
273 | } |
274 | } |
275 | |
276 | #----------------------------------------------------------------------- |
277 | # snit::integer |
278 | |
279 | snit::type ::snit::integer { |
280 | #------------------------------------------------------------------- |
281 | # Options |
282 | |
283 | # -min value |
284 | # |
285 | # Minimum value |
286 | |
287 | option -min -default "" -readonly 1 |
288 | |
289 | # -max value |
290 | # |
291 | # Maximum value |
292 | |
293 | option -max -default "" -readonly 1 |
294 | |
295 | #------------------------------------------------------------------- |
296 | # Type Methods |
297 | |
298 | typemethod validate {value} { |
299 | if {![string is integer -strict $value]} { |
300 | return -code error -errorcode INVALID \ |
301 | "invalid value \"$value\", expected integer" |
302 | } |
303 | |
304 | return $value |
305 | } |
306 | |
307 | #------------------------------------------------------------------- |
308 | # Constructor |
309 | |
310 | constructor {args} { |
311 | # FIRST, get the options |
312 | $self configurelist $args |
313 | |
314 | if {"" != $options(-min) && |
315 | ![string is integer -strict $options(-min)]} { |
316 | return -code error \ |
317 | "invalid -min: \"$options(-min)\"" |
318 | } |
319 | |
320 | if {"" != $options(-max) && |
321 | ![string is integer -strict $options(-max)]} { |
322 | return -code error \ |
323 | "invalid -max: \"$options(-max)\"" |
324 | } |
325 | |
326 | if {"" != $options(-min) && |
327 | "" != $options(-max) && |
328 | $options(-max) < $options(-min)} { |
329 | return -code error "-max < -min" |
330 | } |
331 | } |
332 | |
333 | #------------------------------------------------------------------- |
334 | # Public Methods |
335 | |
336 | method validate {value} { |
337 | $type validate $value |
338 | |
339 | if {("" != $options(-min) && $value < $options(-min)) || |
340 | ("" != $options(-max) && $value > $options(-max))} { |
341 | |
342 | set msg "invalid value \"$value\", expected integer" |
343 | |
344 | if {"" != $options(-min) && "" != $options(-max)} { |
345 | append msg " in range $options(-min), $options(-max)" |
346 | } elseif {"" != $options(-min)} { |
347 | append msg " no less than $options(-min)" |
348 | } |
349 | |
350 | return -code error -errorcode INVALID $msg |
351 | } |
352 | |
353 | return $value |
354 | } |
355 | } |
356 | |
357 | #----------------------------------------------------------------------- |
358 | # snit::list |
359 | |
360 | snit::type ::snit::listtype { |
361 | #------------------------------------------------------------------- |
362 | # Options |
363 | |
364 | # -type type |
365 | # |
366 | # Specifies a value type |
367 | |
368 | option -type -readonly 1 |
369 | |
370 | # -minlen len |
371 | # |
372 | # Minimum list length |
373 | |
374 | option -minlen -readonly 1 -default 0 |
375 | |
376 | # -maxlen len |
377 | # |
378 | # Maximum list length |
379 | |
380 | option -maxlen -readonly 1 |
381 | |
382 | #------------------------------------------------------------------- |
383 | # Type Methods |
384 | |
385 | typemethod validate {value} { |
386 | if {[catch {llength $value} result]} { |
387 | return -code error -errorcode INVALID \ |
388 | "invalid value \"$value\", expected list" |
389 | } |
390 | |
391 | return $value |
392 | } |
393 | |
394 | #------------------------------------------------------------------- |
395 | # Constructor |
396 | |
397 | constructor {args} { |
398 | # FIRST, get the options |
399 | $self configurelist $args |
400 | |
401 | if {"" != $options(-minlen) && |
402 | (![string is integer -strict $options(-minlen)] || |
403 | $options(-minlen) < 0)} { |
404 | return -code error \ |
405 | "invalid -minlen: \"$options(-minlen)\"" |
406 | } |
407 | |
408 | if {"" == $options(-minlen)} { |
409 | set options(-minlen) 0 |
410 | } |
411 | |
412 | if {"" != $options(-maxlen) && |
413 | ![string is integer -strict $options(-maxlen)]} { |
414 | return -code error \ |
415 | "invalid -maxlen: \"$options(-maxlen)\"" |
416 | } |
417 | |
418 | if {"" != $options(-maxlen) && |
419 | $options(-maxlen) < $options(-minlen)} { |
420 | return -code error "-maxlen < -minlen" |
421 | } |
422 | } |
423 | |
424 | |
425 | #------------------------------------------------------------------- |
426 | # Methods |
427 | |
428 | method validate {value} { |
429 | $type validate $value |
430 | |
431 | set len [llength $value] |
432 | |
433 | if {$len < $options(-minlen)} { |
434 | return -code error -errorcode INVALID \ |
435 | "value has too few elements; at least $options(-minlen) expected" |
436 | } elseif {"" != $options(-maxlen)} { |
437 | if {$len > $options(-maxlen)} { |
438 | return -code error -errorcode INVALID \ |
439 | "value has too many elements; no more than $options(-maxlen) expected" |
440 | } |
441 | } |
442 | |
443 | # NEXT, check each value |
444 | if {"" != $options(-type)} { |
445 | foreach item $value { |
446 | set cmd $options(-type) |
447 | lappend cmd validate $item |
448 | uplevel \#0 $cmd |
449 | } |
450 | } |
451 | |
452 | return $value |
453 | } |
454 | } |
455 | |
456 | #----------------------------------------------------------------------- |
457 | # snit::pixels |
458 | |
459 | snit::type ::snit::pixels { |
460 | #------------------------------------------------------------------- |
461 | # Options |
462 | |
463 | # -min value |
464 | # |
465 | # Minimum value |
466 | |
467 | option -min -default "" -readonly 1 |
468 | |
469 | # -max value |
470 | # |
471 | # Maximum value |
472 | |
473 | option -max -default "" -readonly 1 |
474 | |
475 | #------------------------------------------------------------------- |
476 | # Instance variables |
477 | |
478 | variable min "" ;# -min, no suffix |
479 | variable max "" ;# -max, no suffix |
480 | |
481 | #------------------------------------------------------------------- |
482 | # Type Methods |
483 | |
484 | typemethod validate {value} { |
485 | if {[catch {winfo pixels . $value} dummy]} { |
486 | return -code error -errorcode INVALID \ |
487 | "invalid value \"$value\", expected pixels" |
488 | } |
489 | |
490 | return $value |
491 | } |
492 | |
493 | #------------------------------------------------------------------- |
494 | # Constructor |
495 | |
496 | constructor {args} { |
497 | # FIRST, get the options |
498 | $self configurelist $args |
499 | |
500 | if {"" != $options(-min) && |
501 | [catch {winfo pixels . $options(-min)} min]} { |
502 | return -code error \ |
503 | "invalid -min: \"$options(-min)\"" |
504 | } |
505 | |
506 | if {"" != $options(-max) && |
507 | [catch {winfo pixels . $options(-max)} max]} { |
508 | return -code error \ |
509 | "invalid -max: \"$options(-max)\"" |
510 | } |
511 | |
512 | if {"" != $min && |
513 | "" != $max && |
514 | $max < $min} { |
515 | return -code error "-max < -min" |
516 | } |
517 | } |
518 | |
519 | #------------------------------------------------------------------- |
520 | # Public Methods |
521 | |
522 | method validate {value} { |
523 | $type validate $value |
524 | |
525 | set val [winfo pixels . $value] |
526 | |
527 | if {("" != $min && $val < $min) || |
528 | ("" != $max && $val > $max)} { |
529 | |
530 | set msg "invalid value \"$value\", expected pixels" |
531 | |
532 | if {"" != $min && "" != $max} { |
533 | append msg " in range $options(-min), $options(-max)" |
534 | } elseif {"" != $min} { |
535 | append msg " no less than $options(-min)" |
536 | } |
537 | |
538 | return -code error -errorcode INVALID $msg |
539 | } |
540 | |
541 | return $value |
542 | } |
543 | } |
544 | |
545 | #----------------------------------------------------------------------- |
546 | # snit::stringtype |
547 | |
548 | snit::type ::snit::stringtype { |
549 | #------------------------------------------------------------------- |
550 | # Options |
551 | |
552 | # -minlen len |
553 | # |
554 | # Minimum list length |
555 | |
556 | option -minlen -readonly 1 -default 0 |
557 | |
558 | # -maxlen len |
559 | # |
560 | # Maximum list length |
561 | |
562 | option -maxlen -readonly 1 |
563 | |
564 | # -nocase 0|1 |
565 | # |
566 | # globs and regexps are case-insensitive if -nocase 1. |
567 | |
568 | option -nocase -readonly 1 -default 0 |
569 | |
570 | # -glob pattern |
571 | # |
572 | # Glob-match pattern, or "" |
573 | |
574 | option -glob -readonly 1 |
575 | |
576 | # -regexp regexp |
577 | # |
578 | # Regular expression to match |
579 | |
580 | option -regexp -readonly 1 |
581 | |
582 | #------------------------------------------------------------------- |
583 | # Type Methods |
584 | |
585 | typemethod validate {value} { |
586 | # By default, any string (hence, any Tcl value) is valid. |
587 | return $value |
588 | } |
589 | |
590 | #------------------------------------------------------------------- |
591 | # Constructor |
592 | |
593 | constructor {args} { |
594 | # FIRST, get the options |
595 | $self configurelist $args |
596 | |
597 | # NEXT, validate -minlen and -maxlen |
598 | if {"" != $options(-minlen) && |
599 | (![string is integer -strict $options(-minlen)] || |
600 | $options(-minlen) < 0)} { |
601 | return -code error \ |
602 | "invalid -minlen: \"$options(-minlen)\"" |
603 | } |
604 | |
605 | if {"" == $options(-minlen)} { |
606 | set options(-minlen) 0 |
607 | } |
608 | |
609 | if {"" != $options(-maxlen) && |
610 | ![string is integer -strict $options(-maxlen)]} { |
611 | return -code error \ |
612 | "invalid -maxlen: \"$options(-maxlen)\"" |
613 | } |
614 | |
615 | if {"" != $options(-maxlen) && |
616 | $options(-maxlen) < $options(-minlen)} { |
617 | return -code error "-maxlen < -minlen" |
618 | } |
619 | |
620 | # NEXT, validate -nocase |
621 | if {[catch {snit::boolean validate $options(-nocase)} result]} { |
622 | return -code error "invalid -nocase: $result" |
623 | } |
624 | |
625 | # Validate the glob |
626 | if {"" != $options(-glob) && |
627 | [catch {string match $options(-glob) ""} dummy]} { |
628 | return -code error \ |
629 | "invalid -glob: \"$options(-glob)\"" |
630 | } |
631 | |
632 | # Validate the regexp |
633 | if {"" != $options(-regexp) && |
634 | [catch {regexp $options(-regexp) ""} dummy]} { |
635 | return -code error \ |
636 | "invalid -regexp: \"$options(-regexp)\"" |
637 | } |
638 | } |
639 | |
640 | |
641 | #------------------------------------------------------------------- |
642 | # Methods |
643 | |
644 | method validate {value} { |
645 | # Usually we'd call [$type validate $value] here, but |
646 | # as it's a no-op, don't bother. |
647 | |
648 | # FIRST, validate the length. |
649 | set len [string length $value] |
650 | |
651 | if {$len < $options(-minlen)} { |
652 | return -code error -errorcode INVALID \ |
653 | "too short: at least $options(-minlen) characters expected" |
654 | } elseif {"" != $options(-maxlen)} { |
655 | if {$len > $options(-maxlen)} { |
656 | return -code error -errorcode INVALID \ |
657 | "too long: no more than $options(-maxlen) characters expected" |
658 | } |
659 | } |
660 | |
661 | # NEXT, check the glob match, with or without case. |
662 | if {"" != $options(-glob)} { |
663 | if {$options(-nocase)} { |
664 | set result [string match -nocase $options(-glob) $value] |
665 | } else { |
666 | set result [string match $options(-glob) $value] |
667 | } |
668 | |
669 | if {!$result} { |
670 | return -code error -errorcode INVALID \ |
671 | "invalid value \"$value\"" |
672 | } |
673 | } |
674 | |
675 | # NEXT, check regexp match with or without case |
676 | if {"" != $options(-regexp)} { |
677 | if {$options(-nocase)} { |
678 | set result [regexp -nocase -- $options(-regexp) $value] |
679 | } else { |
680 | set result [regexp -- $options(-regexp) $value] |
681 | } |
682 | |
683 | if {!$result} { |
684 | return -code error -errorcode INVALID \ |
685 | "invalid value \"$value\"" |
686 | } |
687 | } |
688 | |
689 | return $value |
690 | } |
691 | } |
692 | |
693 | #----------------------------------------------------------------------- |
694 | # snit::window |
695 | |
696 | snit::type ::snit::window { |
697 | #------------------------------------------------------------------- |
698 | # Type Methods |
699 | |
700 | typemethod validate {value} { |
701 | if {![winfo exists $value]} { |
702 | return -code error -errorcode INVALID \ |
703 | "invalid value \"$value\", value is not a window" |
704 | } |
705 | |
706 | return $value |
707 | } |
708 | |
709 | #------------------------------------------------------------------- |
710 | # Constructor |
711 | |
712 | # None needed; no options |
713 | |
714 | #------------------------------------------------------------------- |
715 | # Public Methods |
716 | |
717 | method validate {value} { |
718 | $type validate $value |
719 | } |
720 | } |