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