basis/validators/validators.factor

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