basis/validators/validators.factor

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