$set sourceformat(variable) program-id. valemail. * Email validation - see RFC 822, 2822, 5322, 3696 * Format of email address: * * left-hand-side@right-hand-side * * Left hand side: * * [a-zA-Z0-9._- and assorted other chars]* (at least 1) * * . may not be first or last character, nor may there be two * successive dots * * Can include comments * Parts of the string can be quoted * Escaped @ ( \@ ) and spaces are ignored * * Right hand side: * * [a-zA-Z0-9] ( .[a-zA-Z0-9] ) * * Can include comments * * Used to be that you couldn't just have a TLD, now I think * you can have so don't insist on at least 2 domain levels * on the RHS special-names. class valid-lhs is "a" through "z" "A" through "Z" "0" through "9" "!" "#" "$" "%" "&" "'" "*" "+" "-" "/" "=" "?" "^" "_" "`" "." "{" "}" "|" "~" class valid-rhs is "a" through "z" "A" through "Z" "0" through "9" "-". working-storage section. 01 ws-email-addr pic x(1000). 01 ws-temp pic x(1000). 01 ws-dom-tbl. 03 ws-dom pic x(255) occurs 10 times. 01 ws-lhs pic x(1000). 01 ws-rhs pic x(1000). 01 ws-email-ptr pic 9(4) comp. 01 ws-email-len pic 9(4) comp. 01 ws-lhs-len pic 9(4) comp. 01 ws-char-ptr pic 9(4) comp. 01 ws-dom-ptr pic 9(4) comp. 01 ws-dom-cnt pic 9(4) comp. 01 ws-left-bracket-cnt pic 9(4) comp. 01 ws-last-left-bracket pic 9(4) comp. 01 ws-first-right-bracket pic 9(4) comp. 01 ws-quoted-ind pic x. 88 quoted value "Y" false "N". 01 ws-numeric-dom-ind pic x. 88 numeric-dom value "Y" false "N". linkage section. *copy "l-valemail.cpy". 01 ls-valemail-params. 03 ls-email-addr pic x(1000). 03 ls-email-err-msg pic x(80). 03 ls-email-valid-ind pic x. 88 email-valid value "Y" false "N". procedure division using ls-valemail-params. a-control section. set email-valid to true move spaces to ls-email-err-msg if ls-email-addr = spaces move "No email address supplied" to ls-email-err-msg set email-valid to false goback end-if * Theoretically, leading spaces means it's invalid but I'd * rather let that through perform varying ws-email-ptr from 1 by 1 until ls-email-addr(ws-email-ptr:1) not = space end-perform move ls-email-addr(ws-email-ptr:) to ws-email-addr perform varying ws-email-len from length ws-email-addr by -1 until ws-email-addr(ws-email-len:1) not = space end-perform * Remove comments from email address * Note - comments are nested so need removing from innermost out if ws-email-addr(1:1) = "(" or ws-email-addr(ws-email-len:1) = ")" move "Comments must be embedded in email address" to ls-email-err-msg set email-valid to false goback end-if move zero to ws-left-bracket-cnt ws-first-right-bracket ws-last-left-bracket perform with test after until ws-left-bracket-cnt = zero perform varying ws-email-ptr from 1 by 1 until ws-email-ptr > ws-email-len evaluate ws-email-addr(ws-email-ptr:1) when "(" add 1 to ws-left-bracket-cnt move ws-email-ptr to ws-last-left-bracket * don't treat successive comments as nested move zero to ws-first-right-bracket when ")" if ws-first-right-bracket = zero move ws-email-ptr to ws-first-right-bracket end-if end-evaluate end-perform if ws-left-bracket-cnt not zero move ws-email-addr(ws-first-right-bracket + 1:) to ws-temp move ws-temp to ws-email-addr(ws-last-left-bracket:) subtract 1 from ws-left-bracket-cnt end-if end-perform * Despace quoted strings and get rid of escaped @ and spaces * in email address set quoted to false perform varying ws-email-ptr from 1 by 1 until ws-email-ptr > ws-email-len or (ws-email-addr(ws-email-ptr:1) = "@" and not quoted) evaluate ws-email-addr(ws-email-ptr:1) when '"' if quoted set quoted to false else set quoted to true end-if * remove the quote character move ws-email-addr(ws-email-ptr + 1:) to ws-temp move ws-temp to ws-email-addr(ws-email-ptr:) * cater for "" subtract 1 from ws-email-ptr when space if quoted move ws-email-addr(ws-email-ptr + 1:) to ws-temp move ws-temp to ws-email-addr(ws-email-ptr:) * cater for multiple spaces subtract 1 from ws-email-ptr end-if when "\" if quoted and (ws-email-addr(ws-email-ptr + 1:1) = "@" or space or '"') move ws-email-addr(ws-email-ptr + 2:) to ws-temp move ws-temp to ws-email-addr(ws-email-ptr:) * check the character we've just moved in subtract 1 from ws-email-ptr end-if end-evaluate end-perform if quoted move "'" & '"' & "' imbalance" to ls-email-err-msg set email-valid to false goback end-if perform varying ws-char-ptr from 1 by 1 until ws-char-ptr > ws-email-len or ws-email-addr(ws-char-ptr:1) = "@" end-perform if ws-char-ptr > ws-email-len move "Missing '@'" to ls-email-err-msg set email-valid to false goback end-if compute ws-lhs-len = ws-char-ptr - 1 move ws-email-addr(1:ws-lhs-len) to ws-lhs move ws-email-addr(ws-char-ptr + 1:) to ws-rhs if ws-lhs = spaces move "First part of the address missing" to ls-email-err-msg set email-valid to false goback end-if if ws-rhs = spaces move "Second part of the address missing" to ls-email-err-msg set email-valid to false goback end-if * Check LHS for valid characters - note that this is quite * a range of characters, not just the limited range that can * be present in a domain name if ws-lhs(1:1) = "." or ws-lhs(ws-lhs-len:1) = "." move "'.' may not be first or last character" to ls-email-err-msg set email-valid to false goback end-if perform varying ws-char-ptr from 1 by 1 until ws-lhs(ws-char-ptr:1) = space if ws-lhs(ws-char-ptr:1) not valid-lhs string "Invalid character '" ws-lhs(ws-char-ptr:1) "' in first part" delimited by size into ls-email-err-msg set email-valid to false goback end-if if ws-lhs(ws-char-ptr:1) = "." and ws-lhs(ws-char-ptr + 1:1) = "." move "Two dots in succession in first part" to ls-email-err-msg set email-valid to false goback end-if end-perform initialize ws-dom-tbl unstring ws-rhs delimited by "." into ws-dom(1) ws-dom(2) ws-dom(3) ws-dom(4) ws-dom(5) ws-dom(6) ws-dom(7) ws-dom(8) ws-dom(9) ws-dom(10) compute ws-dom-cnt = length ws-dom-tbl / length ws-dom perform varying ws-dom-cnt from ws-dom-cnt by -1 until ws-dom(ws-dom-cnt) not = spaces end-perform if ws-dom(1)(1:1) = "[" perform b1-validate-ip-address else perform b3-validate-normal-domain end-if goback . b1-validate-ip-address section. * IP address must be enclosed in [] * There must be four parts to it, split by "." * Each part must be numeric, values zero to 255 * And this needs looking at for IPv6 if ws-dom-cnt not = 4 move "IP address in second part must have 4 components" to ls-email-err-msg set email-valid to false exit section end-if perform varying ws-char-ptr from 2 by 1 until ws-dom(4)(ws-char-ptr:1) = space or "]" end-perform if ws-dom(4)(ws-char-ptr:1) not = "]" move "IP address must be terminated by ']'" to ls-email-err-msg set email-valid to false exit section end-if move space to ws-dom(4)(ws-char-ptr:1) move ws-dom(1)(2:) to ws-temp move ws-temp to ws-dom(1) perform varying ws-dom-ptr from 1 by 1 until ws-dom-ptr > ws-dom-cnt set numeric-dom to true perform varying ws-char-ptr from 1 by 1 until ws-dom(ws-dom-ptr)(ws-char-ptr:1) = space or ws-char-ptr > 3 if ws-dom(ws-dom-ptr)(ws-char-ptr:1) not numeric set numeric-dom to false end-if end-perform if (ws-char-ptr > 3 and ws-dom(ws-dom-ptr)(ws-char-ptr:1) not = space) or not numeric-dom or function numval(ws-dom(ws-dom-ptr)) > 255 move "Invalid format for IP address" to ls-email-err-msg set email-valid to false exit section end-if end-perform . b3-validate-normal-domain section. perform varying ws-dom-ptr from 1 by 1 until ws-dom-ptr > ws-dom-cnt if ws-dom(ws-dom-ptr) = spaces move "Two full stops in succession in second part" to ls-email-err-msg set email-valid to false exit section end-if if ws-dom(ws-dom-ptr)(1:1) = "-" move "Part of second part starts with '-'" to ls-email-err-msg set email-valid to false exit section end-if set numeric-dom to true perform varying ws-char-ptr from 1 by 1 until ws-dom(ws-dom-ptr)(ws-char-ptr:1) = space if ws-dom(ws-dom-ptr)(ws-char-ptr:1) not valid-rhs string "Invalid character '" ws-dom(ws-dom-ptr)(ws-char-ptr:1) "' in second part" delimited by size into ls-email-err-msg set email-valid to false exit section end-if if ws-dom(ws-dom-ptr)(ws-char-ptr:1) not numeric set numeric-dom to false end-if end-perform if numeric-dom and ws-dom-ptr = ws-dom-cnt move "Top level domain is all numeric" to ls-email-err-msg set email-valid to false exit section end-if end-perform . end program valemail.