validate.tcl

Go to the documentation of this file.

/* -----------------------------------------------------------------------*/
/*  TITLE:*/
/*     validate.tcl*/
/* */
/*  AUTHOR:*/
/*     Will Duquette*/
/* */
/*  DESCRIPTION:*/
/*     Snit validation types.*/
/* */
/* -----------------------------------------------------------------------*/

namespace ::snit:: { 
    namespace export \
        boolean \
        double \
        enum \
        fpixels \
        integer \
        listtype \
        pixels \
        stringtype \
        window
}

/* -----------------------------------------------------------------------*/
/*  snit::boolean*/

snit::type ::snit::boolean {
    /* -------------------------------------------------------------------*/
    /*  Type Methods*/

    typeret  validate (type value) {
        if {![string is boolean -strict $value]} {
            return -code error \
   "invalid boolean \"$value\", should be one of: 1, 0, true, false, yes, no, on, off"

        }

        return
    }

    /* -------------------------------------------------------------------*/
    /*  Constructor*/

    /*  None needed; no options*/

    /* -------------------------------------------------------------------*/
    /*  Public Methods*/

    ret  validate (type value) {
        $type validate $value
    }
}

/* -----------------------------------------------------------------------*/
/*  snit::double*/

snit::type ::snit::double {
    /* -------------------------------------------------------------------*/
    /*  Options*/

    /*  -min value*/
    /* */
    /*  Minimum value*/

    option -min -default "" -readonly 1

    /*  -max value*/
    /* */
    /*  Maximum value*/

    option -max -default "" -readonly 1

    /* -------------------------------------------------------------------*/
    /*  Type Methods*/

    typeret  validate (type value) {
        if {![string is double -strict $value]} {
            return -code error \
                "invalid value \"$value\", expected double"
        }

        return
    }

    /* -------------------------------------------------------------------*/
    /*  Constructor*/

    constructor {args} {
        /*  FIRST, get the options*/
        $self configurelist $args

        if {"" != $options(-min) && 
            ![string is double -strict $options(-min)]} {
            return -code error \
                "invalid -min: \"$options(-min)\""
        }

        if {"" != $options(-max) && 
            ![string is double -strict $options(-max)]} {
            return -code error \
                "invalid -max: \"$options(-max)\""
        }

        if {"" != $options(-min) &&
            "" != $options(-max) && 
            $options(-max) < $options(-min)} {
            return -code error "-max < -min"
        }
    }

    /* -------------------------------------------------------------------*/
    /*  Public Methods*/

    ret  validate (type value) {
        $type validate $value

        if {("" != $options(-min) && $value < $options(-min))       ||
            ("" != $options(-max) && $value > $options(-max))} {

            set msg "invalid value \"$value\", expected double"

            if {"" != $options(-min) && "" != $options(-max)} {
                append msg " in range $options(-min), $options(-max)"
            } elseif {"" != $options(-min)} {
                append msg " no less than $options(-min)"
            }
        
            return -code error $msg
        }

        return
    }
}

/* -----------------------------------------------------------------------*/
/*  snit::enum*/

snit::type ::snit::enum {
    /* -------------------------------------------------------------------*/
    /*  Options*/

    /*  -values list*/
    /* */
    /*  Valid values for this type*/

    option -values -default {} -readonly 1

    /* -------------------------------------------------------------------*/
    /*  Type Methods*/

    typeret  validate (type value) {
        # No -values specified; it's always valid
        return
    }

    /* -------------------------------------------------------------------*/
    /*  Constructor*/

    constructor {args} {
        $self configurelist $args

        if {[llength $options(-values)] == 0} {
            return -code error \
                "invalid -values: \"\""
        }
    }

    /* -------------------------------------------------------------------*/
    /*  Public Methods*/

    ret  validate (type value) {
        if {[lsearch -exact $options(-values) $value] == -1} {
            return -code error \
    "invalid value \"$value\", should be one of: [join $options(-values) {, }]"
        }
    }
}

/* -----------------------------------------------------------------------*/
/*  snit::fpixels*/

snit::type ::snit::fpixels {
    /* -------------------------------------------------------------------*/
    /*  Options*/

    /*  -min value*/
    /* */
    /*  Minimum value*/

    option -min -default "" -readonly 1

    /*  -max value*/
    /* */
    /*  Maximum value*/

    option -max -default "" -readonly 1

    /* -------------------------------------------------------------------*/
    /*  Instance variables*/

    variable min ""  ;/*  -min, no suffix*/
    variable max ""  ;/*  -max, no suffix*/

    /* -------------------------------------------------------------------*/
    /*  Type Methods*/

    typeret  validate (type value) {
        if {[catch {winfo fpixels . $value} dummy]} {
            return -code error \
                "invalid value \"$value\", expected fpixels"
        }

        return
    }

    /* -------------------------------------------------------------------*/
    /*  Constructor*/

    constructor {args} {
        /*  FIRST, get the options*/
        $self configurelist $args

        if {"" != $options(-min) && 
            [catch {winfo fpixels . $options(-min)} min]} {
            return -code error \
                "invalid -min: \"$options(-min)\""
        }

        if {"" != $options(-max) && 
            [catch {winfo fpixels . $options(-max)} max]} {
            return -code error \
                "invalid -max: \"$options(-max)\""
        }

        if {"" != $min &&
            "" != $max && 
            $max < $min} {
            return -code error "-max < -min"
        }
    }

    /* -------------------------------------------------------------------*/
    /*  Public Methods*/

    ret  validate (type value) {
        $type validate $value
        
        set val [winfo fpixels . $value]

        if {("" != $min && $val < $min) ||
            ("" != $max && $val > $max)} {

            set msg "invalid value \"$value\", expected fpixels"

            if {"" != $min && "" != $max} {
                append msg " in range $options(-min), $options(-max)"
            } elseif {"" != $min} {
                append msg " no less than $options(-min)"
            }
        
            return -code error $msg
        }

        return
    }
}

/* -----------------------------------------------------------------------*/
/*  snit::integer*/

snit::type ::snit::integer {
    /* -------------------------------------------------------------------*/
    /*  Options*/

    /*  -min value*/
    /* */
    /*  Minimum value*/

    option -min -default "" -readonly 1

    /*  -max value*/
    /* */
    /*  Maximum value*/

    option -max -default "" -readonly 1

    /* -------------------------------------------------------------------*/
    /*  Type Methods*/

    typeret  validate (type value) {
        if {![string is integer -strict $value]} {
            return -code error \
                "invalid value \"$value\", expected integer"
        }

        return
    }

    /* -------------------------------------------------------------------*/
    /*  Constructor*/

    constructor {args} {
        /*  FIRST, get the options*/
        $self configurelist $args

        if {"" != $options(-min) && 
            ![string is integer -strict $options(-min)]} {
            return -code error \
                "invalid -min: \"$options(-min)\""
        }

        if {"" != $options(-max) && 
            ![string is integer -strict $options(-max)]} {
            return -code error \
                "invalid -max: \"$options(-max)\""
        }

        if {"" != $options(-min) &&
            "" != $options(-max) && 
            $options(-max) < $options(-min)} {
            return -code error "-max < -min"
        }
    }

    /* -------------------------------------------------------------------*/
    /*  Public Methods*/

    ret  validate (type value) {
        $type validate $value

        if {("" != $options(-min) && $value < $options(-min))       ||
            ("" != $options(-max) && $value > $options(-max))} {

            set msg "invalid value \"$value\", expected integer"

            if {"" != $options(-min) && "" != $options(-max)} {
                append msg " in range $options(-min), $options(-max)"
            } elseif {"" != $options(-min)} {
                append msg " no less than $options(-min)"
            }
        
            return -code error $msg
        }

        return
    }
}

/* -----------------------------------------------------------------------*/
/*  snit::list*/

snit::type ::snit::listtype {
    /* -------------------------------------------------------------------*/
    /*  Options*/

    /*  -type type*/
    /* */
    /*  Specifies a value type*/

    option -type -readonly 1

    /*  -minlen len*/
    /* */
    /*  Minimum list length*/

    option -minlen -readonly 1 -default 0

    /*  -maxlen len*/
    /* */
    /*  Maximum list length*/

    option -maxlen -readonly 1

    /* -------------------------------------------------------------------*/
    /*  Type Methods*/

    typeret  validate (type value) {
        if {[catch {llength $value} result]} {
            return -code error \
                "invalid value \"$value\", expected list"
        }

        return
    }

    /* -------------------------------------------------------------------*/
    /*  Constructor*/
    
    constructor {args} {
        /*  FIRST, get the options*/
        $self configurelist $args

        if {"" != $options(-minlen) && 
            (![string is integer -strict $options(-minlen)] ||
             $options(-minlen) < 0)} {
            return -code error \
                "invalid -minlen: \"$options(-minlen)\""
        }

        if {"" == $options(-minlen)} {
             options = (-minlen) 0
        }

        if {"" != $options(-maxlen) && 
            ![string is integer -strict $options(-maxlen)]} {
            return -code error \
                "invalid -maxlen: \"$options(-maxlen)\""
        }

        if {"" != $options(-maxlen) && 
            $options(-maxlen) < $options(-minlen)} {
            return -code error "-maxlen < -minlen"
        }
    }


    /* -------------------------------------------------------------------*/
    /*  Methods*/

    ret  validate (type value) {
        $type validate $value

        set len [llength $value]

        if {$len < $options(-minlen)} {
            return -code error \
              "value has too few elements; at least $options(-minlen) expected"
        } elseif {"" != $options(-maxlen)} {
            if {$len > $options(-maxlen)} {
                return -code error \
         "value has too many elements; no more than $options(-maxlen) expected"
            }
        }

        # NEXT, check each value
        if {"" != $options(-type)} {
            foreach item $value {
                set cmd $options(-type)
                lappend cmd validate $item
                uplevel \#0 $cmd
            }
        }
    }
}

/* -----------------------------------------------------------------------*/
/*  snit::pixels*/

snit::type ::snit::pixels {
    /* -------------------------------------------------------------------*/
    /*  Options*/

    /*  -min value*/
    /* */
    /*  Minimum value*/

    option -min -default "" -readonly 1

    /*  -max value*/
    /* */
    /*  Maximum value*/

    option -max -default "" -readonly 1

    /* -------------------------------------------------------------------*/
    /*  Instance variables*/

    variable min ""  ;/*  -min, no suffix*/
    variable max ""  ;/*  -max, no suffix*/

    /* -------------------------------------------------------------------*/
    /*  Type Methods*/

    typeret  validate (type value) {
        if {[catch {winfo pixels . $value} dummy]} {
            return -code error \
                "invalid value \"$value\", expected pixels"
        }

        return
    }

    /* -------------------------------------------------------------------*/
    /*  Constructor*/

    constructor {args} {
        /*  FIRST, get the options*/
        $self configurelist $args

        if {"" != $options(-min) && 
            [catch {winfo pixels . $options(-min)} min]} {
            return -code error \
                "invalid -min: \"$options(-min)\""
        }

        if {"" != $options(-max) && 
            [catch {winfo pixels . $options(-max)} max]} {
            return -code error \
                "invalid -max: \"$options(-max)\""
        }

        if {"" != $min &&
            "" != $max && 
            $max < $min} {
            return -code error "-max < -min"
        }
    }

    /* -------------------------------------------------------------------*/
    /*  Public Methods*/

    ret  validate (type value) {
        $type validate $value
        
        set val [winfo pixels . $value]

        if {("" != $min && $val < $min) ||
            ("" != $max && $val > $max)} {

            set msg "invalid value \"$value\", expected pixels"

            if {"" != $min && "" != $max} {
                append msg " in range $options(-min), $options(-max)"
            } elseif {"" != $min} {
                append msg " no less than $options(-min)"
            }
        
            return -code error $msg
        }

        return
    }
}

/* -----------------------------------------------------------------------*/
/*  snit::stringtype*/

snit::type ::snit::stringtype {
    /* -------------------------------------------------------------------*/
    /*  Options*/

    /*  -minlen len*/
    /* */
    /*  Minimum list length*/

    option -minlen -readonly 1 -default 0

    /*  -maxlen len*/
    /* */
    /*  Maximum list length*/

    option -maxlen -readonly 1

    /*  -nocase 0|1*/
    /* */
    /*  globs and regexps are case-insensitive if -nocase 1.*/

    option -nocase -readonly 1 -default 0

    /*  -glob pattern*/
    /* */
    /*  Glob-match pattern, or ""*/

    option -glob -readonly 1

    /*  -regexp regexp*/
    /* */
    /*  Regular expression to match*/
    
    option -regexp -readonly 1
    
    /* -------------------------------------------------------------------*/
    /*  Type Methods*/

    typeret  validate (type value) {
        # By default, any string (hence, any Tcl value) is valid.
        return
    }

    /* -------------------------------------------------------------------*/
    /*  Constructor*/
    
    constructor {args} {
        /*  FIRST, get the options*/
        $self configurelist $args

        /*  NEXT, validate -minlen and -maxlen*/
        if {"" != $options(-minlen) && 
            (![string is integer -strict $options(-minlen)] ||
             $options(-minlen) < 0)} {
            return -code error \
                "invalid -minlen: \"$options(-minlen)\""
        }

        if {"" == $options(-minlen)} {
             options = (-minlen) 0
        }

        if {"" != $options(-maxlen) && 
            ![string is integer -strict $options(-maxlen)]} {
            return -code error \
                "invalid -maxlen: \"$options(-maxlen)\""
        }

        if {"" != $options(-maxlen) && 
            $options(-maxlen) < $options(-minlen)} {
            return -code error "-maxlen < -minlen"
        }

        /*  NEXT, validate -nocase*/
        if {[catch {snit::boolean validate $options(-nocase)} result]} {
            return -code error "invalid -nocase: $result"
        }

        /*  Validate the glob*/
        if {"" != $options(-glob) && 
            [catch {string match $options(-glob) ""} dummy]} {
            return -code error \
                "invalid -glob: \"$options(-glob)\""
        }

        /*  Validate the regexp*/
        if {"" != $options(-regexp) && 
            [catch {regexp $options(-regexp) ""} dummy]} {
            return -code error \
                "invalid -regexp: \"$options(-regexp)\""
        }
    }


    /* -------------------------------------------------------------------*/
    /*  Methods*/

    ret  validate (type value) {
        # Usually we'd call [$type validate $value] here, but
        # as it's a no-op, don't bother.

        # FIRST, validate the length.
        set len [string length $value]

        if {$len < $options(-minlen)} {
            return -code error \
              "too short: at least $options(-minlen) characters expected"
        } elseif {"" != $options(-maxlen)} {
            if {$len > $options(-maxlen)} {
                return -code error \
         "too long: no more than $options(-maxlen) characters expected"
            }
        }

        # NEXT, check the glob match, with or without case.
        if {"" != $options(-glob)} {
            if {$options(-nocase)} {
                set result [string match -nocase $options(-glob) $value]
            } else {
                set result [string match $options(-glob) $value]
            }
            
            if {!$result} {
                return -code error \
                    "invalid value \"$value\""
            }
        }
        
        # NEXT, check regexp match with or without case
        if {"" != $options(-regexp)} {
            if {$options(-nocase)} {
                set result [regexp -nocase -- $options(-regexp) $value]
            } else {
                set result [regexp -- $options(-regexp) $value]
            }
            
            if {!$result} {
                return -code error \
                    "invalid value \"$value\""
            }
        }
    }
}

/* -----------------------------------------------------------------------*/
/*  snit::window*/

snit::type ::snit::window {
    /* -------------------------------------------------------------------*/
    /*  Type Methods*/

    typeret  validate (type value) {
        if {![winfo exists $value]} {
            return -code error \
                "invalid value \"$value\", value is not a window"
        }

        return
    }

    /* -------------------------------------------------------------------*/
    /*  Constructor*/

    /*  None needed; no options*/

    /* -------------------------------------------------------------------*/
    /*  Public Methods*/

    ret  validate (type value) {
        $type validate $value
    }
}