basis/validators/validators.factor

   1 ! Copyright (C) 2006, 2010 Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs classes continuations hashtables kernel
   4 make math math.functions math.parser math.ranges namespaces
   5 quotations regexp sequences sets unicode.case unicode.categories
   6 words xmode.catalog ;
   7 IN: validators
   8
   9 : v-checkbox ( str -- ? )
  10     >lower "on" = ;
  11
  12 : v-default ( str def -- str/def )
  13     [ drop empty? not ] most ;
  14
  15 : v-required ( str -- str )
  16     dup empty? [ "required" throw ] when ;
  17
  18 : v-optional ( str quot -- result )
  19     over empty? [ 2drop f ] [ call ] if ; inline
  20
  21 : v-min-length ( str n -- str )
  22     over length over < [
  23         [ "must be at least " % # " characters" % ] "" make
  24         throw
  25     ] [
  26         drop
  27     ] if ;
  28
  29 : v-max-length ( str n -- str )
  30     over length over > [
  31         [ "must be no more than " % # " characters" % ] "" make
  32         throw
  33     ] [
  34         drop
  35     ] if ;
  36
  37 : v-number ( str -- n )
  38     dup string>number [ ] [ "must be a number" throw ] ?if ;
  39
  40 : v-integer ( str -- n )
  41     v-number dup integer? [ "must be an integer" throw ] unless ;
  42
  43 : v-min-value ( x n -- x )
  44     2dup < [
  45         [ "must be at least " % # ] "" make throw
  46     ] [
  47         drop
  48     ] if ;
  49
  50 : v-max-value ( x n -- x )
  51     2dup > [
  52         [ "must be no more than " % # ] "" make throw
  53     ] [
  54         drop
  55     ] if ;
  56
  57 : v-regexp ( str what regexp -- str )
  58     3dup nip matches?
  59     [ 2drop ] [ drop "invalid " prepend throw ] if ;
  60
  61 : v-email ( str -- str )
  62     ! From http://www.regular-expressions.info/email.html
  63     320 v-max-length
  64     "e-mail"
  65     R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i
  66     v-regexp ;
  67
  68 : v-url ( str -- str )
  69     "URL" R' (?:ftp|http|https)://\S+' v-regexp ;
  70
  71 : v-captcha ( str -- str )
  72     dup empty? [ "must remain blank" throw ] unless ;
  73
  74 : v-one-line ( str -- str )
  75     v-required
  76     dup "\r\n" intersects?
  77     [ "must be a single line" throw ] when ;
  78
  79 : v-one-word ( str -- str )
  80     v-required
  81     dup [ alpha? ] all?
  82     [ "must be a single word" throw ] unless ;
  83
  84 : v-username ( str -- str )
  85     2 v-min-length 16 v-max-length v-one-word ;
  86
  87 : v-password ( str -- str )
  88     6 v-min-length 40 v-max-length v-one-line ;
  89
  90 : v-mode ( str -- str )
  91     dup mode-names member? [
  92         "not a valid syntax mode" throw
  93     ] unless ;
  94
  95 : luhn? ( str -- ? )
  96     string>digits <reversed>
  97     [ odd? [ 2 * 10 /mod + ] when ] map-index
  98     sum 10 divisor? ;
  99
 100 : v-credit-card ( str -- n )
 101     "- " without
 102     dup CHAR: 0 CHAR: 9 [a,b] diff empty? [
 103         13 v-min-length
 104         16 v-max-length
 105         dup luhn? [ string>number ] [
 106             "card number check failed" throw
 107         ] if
 108     ] [
 109         "invalid credit card number format" throw
 110     ] if ;