compile Subroutine EMAIL_FORMAT( charstr CONV, charstr ANS, charstr BRANCH, charstr RETURN_DATA)
*
* EMAIL_FORMAT is an example of a developer's custom prompt formatting
* routine using the square brackets call.
*
*  It should be placed in square brackets, like this:
*
*                   [EMAIL_FORMAT]
*
* This subroutine should be used as the first and only "Input Validation" in
* a window prompt.  Placed in "Output Format", it properly checks that 
* the string passed in is a valid Email address
*
!
* MrC 3-23-21 Remove 3d Gray color from message and added icon
* mtr 5-31-11 Changes subdomain to allow first chars to be numbers

*  Subroutine declarations

$insert msg_equates
declare function msg

*  Local Equates
*  The STATUS() variable is used to indicated the error condition of the
*  pattern. They are:
EQU VALID$         TO 0    ;* Successful
EQU INVALID_MSG$   TO 1    ;* Bad Data       -   Print error message window
EQU INVALID_CONV$  TO 2    ;* Bad Conversion -          "         "
EQU INVALID_NOMSG$ TO 3    ;* Bad but do not print the error message window

EQU THREEDGRAY$    TO 192

*  Begin Conversion
*
RETURN_DATA = ""

IF ANS NE "" THEN
EMAIL = ANS
ANS = ""

* mtr 1-19-07
email = trim(Email)

STATUS() = VALID$

IF LEN( EMAIL ) THEN
	* Case statement to validate all possible types of Social Security numbers. If
	* a new format is required simply add another case.
	* The fall-through (CASE 1) traps invalid conversions.
	BEGIN CASE
		Case email
			error_flag = ''
			return_data = ''
			* per RFC #822 <http://www.isi.edu/in-notes/rfc822.txt>
			// Valid characters in an "atom"
			exclude_atom = '()<>@,:;\?".[]':char(27)
			exclude_quoted = '"\':char(13)
			atom_chars = ''; *[#33..#255] - ['(', ')', '<', '>', '@', ',', ';', ':', '\', '/', '"', '.', '[', ']', #127]
			quoted_string_chars =  '';* [#0..#255] - ['"', #13, '\']
			For i = 0 To 255
				this_char = char(i)
				If Index(exclude_atom, this_char, 1) ELSE
					If i >=33 then
						atom_chars:=this_char
					end
				end
				If Index(exclude_quoted, this_char, 1) ELSE
					quoted_string_chars:=this_char
				end
			Next i
			
			// Valid characters in a subdomain
			letters = @upper.Case:@lower.case
			letters_digits = letters:'0123456789'
			subdomain_chars = '-':letters_digits
			STATE_BEGIN = 1
			STATE_ATOM = 2
			STATE_QTEXT = 3
			STATE_QCHAR = 4
			STATE_QUOTE = 5
			STATE_LOCAL_PERIOD = 6
			STATE_EXPECTING_SUBDOMAIN= 7
			STATE_SUBDOMAIN = 8
			STATE_HYPHEN = 9
			
			
			State = STATE_BEGIN
			n = Len(email)
			i = 1
			subdomains = 1
			for i = 1 To n
				this_char = email[i, 1]
				Begin case
					Case State = STATE_BEGIN
						if index(atom_chars, this_char, 1) then
							State = STATE_ATOM
						End else
							if this_char = '"' then
								State = STATE_QTEXT
							End else
								error_flag = 1
							end
						end
						
					Case State = STATE_ATOM
						if this_char = '@' then
							State = STATE_EXPECTING_SUBDOMAIN
						End else
							if this_char = '.' then
								State = STATE_LOCAL_PERIOD
							End else
								if index(atom_chars, this_char, 1) else
									error_flag = 1
								end
							end
						end
						
					Case State = STATE_QTEXT
						if this_char = '\' then
							State = STATE_QCHAR
						End else
							if this_char = '"' then
								State := STATE_QUOTE
							End else
								if Index(quoted_string_chars, this_char, 1) else
									error_flag = 1
								end
							end
						end
						
					Case State = STATE_QCHAR
						State = STATE_QTEXT
						
					Case State = STATE_QUOTE
						if this_char = '@' then
							State = STATE_EXPECTING_SUBDOMAIN
						End else
							if this_char = '.' then
								State = STATE_LOCAL_PERIOD
							End else
								error_flag = 1
							end
						end
						
					Case State = STATE_LOCAL_PERIOD
						if index(atom_chars, this_char, 1) then
							State = STATE_ATOM
						End else
							if this_char = '"' then
								State = STATE_QTEXT
							End else
								error_flag = 1
							end
						end
						
					Case State = STATE_EXPECTING_SUBDOMAIN
						* mtr 5-31-11
						*If Index(letters, this_char, 1) Then
						If Index(letters_digits, this_char, 1) then
							State = STATE_SUBDOMAIN
						end else
							error_flag = 1
						end
						
					Case State = STATE_SUBDOMAIN
						if this_char = '.' then
							subdomains += 1
							State = STATE_EXPECTING_SUBDOMAIN
						end else
							if this_char = '-' then
								State = STATE_HYPHEN
							end else
								if index(letters_digits, this_char, 1) else
									error_flag = 1
								end
							end
						end
						
					Case State = STATE_HYPHEN
						if Index(letters_digits, this_char, 1) then
							State = STATE_SUBDOMAIN
						End else
							if this_char # '-' then
								error_flag = 1
							end
						end
						
						
				End case
				
			next i
			
			If error_flag then
				Gosub DisplayError
				STATUS() = INVALID_NOMSG$
			end else
				GoodEmail = (State = STATE_SUBDOMAIN) and (subdomains >= 2)
				If GoodEmail then
					return_data = email
				End else
					Gosub DisplayError
					STATUS() = INVALID_NOMSG$
				end
			end
			
			
			
		CASE 1
			IF CONV = "ICONV" THEN
				gosub DisplayError
			END
			STATUS() = INVALID_NOMSG$
	END CASE
END ELSE
	IF CONV = "ICONV" THEN
		gosub DisplayError
	END
	STATUS() = INVALID_NOMSG$
END
end

RETURN

DisplayError:
msgrec            = ""
msgrec<MCAPTION$> = "Data Validation Error"
msgrec<MTEXT$>    = EMAIL : " is not a valid email address.||Please enter a email address with a name,|an '@' symbol, and a server/domain."
// msgrec<MBKCOLOR$> = THREEDGRAY$:@VM:THREEDGRAY$:@VM:THREEDGRAY$
msgrec<MJUST$>    = 'C'
msgRec<MICON$>    = "!"
result = msg( "", msgrec)
Return

* Source Date: 13:55:58  17 SEP 2004  Build ID: OI*7.1  Level: 7.1