EMail validator

Let you know if an e-mail is well formed.

Very simple, no need to rename any variable nor register any ActiveX.

'   FileName:   EMailValidatorCLS.vbs
'   Author:     Branimir Petrovic
'   Date:       3 December 2001
'   Version:    1.0
'
'   Description:
'
'   The "EMailValidatorCLS.vbs" inspired by, but IS NOT
'   FULLY RFC2822 COMPLIANT validator!!!
'   "Close enough for most purposes" would be the motto.
'
'
'   Notes:
'
'   To some extent class tends to be "overly permissive" rather
'   than "overly restrictive" with few notable exceptions:
'   - no RFC2822 compliant comments accepted,
'       (RFC2822 labels them as 'comment' in ABNF notation)
'   - no blank (in RFC822 sense permissive) primitive tokens allowed,
'       (RFC2822 labels these as 'FWS' and 'WSP' in ABNF notation)
'
'
'   Not As Important Notes :
'
'   1.) RFC 2822 (Internet Message Format April 2001) 
'           obsoletes 
'       RFC 822 
'       (Standard for the format of ARPA Internet Messages August 1982) 
'       
'       For actual details on specs, see:
'           http://rfc.net/rfc2822.html
'               and
'           http://rfc.net/rfc1034.html
'
'   2.) See regex for RFC822 regex-only compliant e-mail validation:
'           http://www.foad.org/~abigail/Perl/url3.regex
'       to get a hint on why bother "cutting corners".
'       (in other words - why this watered down solution)
'
'   3.) Fresh listing of top level domain names can be obtained at:
'           http://www.iana.com/domain-names.htm
'       (should there be a need to extend functionality and properly
'        validate top level domain part of the e-mail address)
'
' ////////////////////////////////////////////////////////////////////
Option Explicit
If ((WScript.ScriptName)="EMailValidatorCLS.vbs") Then Demo_EMailValidatorCLS()

' ////////////////////////////////////////////////////////////////////

' ====================== CLASS =======================================
Class EMailValidatorCLS
' Versioning:   1.0                 3 December 2001
'
'   Methods:
'       isValidEMail(sEMailAddr)    True when address pattern is OK
'       isValidHostName(sFQDN)      True when host name is OK
'       isValidIP(sIP)              True when IP address is OK


    '   =====   Public Methods =======================================
    Function isValidEmail(sEmail)
    '   Returtns true for all valid patterns like:
    '
    '       *@qz.to
    '       Chilly.Willy@[123.22.33.1:25]
    '       [email protected]
    '       "Merry Chimp"@quite.happy.pl
    '       [email protected]
    '
    '   and many other funny looking but otherwise valid e-mail patterns.
    '
    '   These "corners" will be cut in the checking process:
    '
    '   - Only the whole local part may be quoted. If it is - method 
    '     will not not bother looking/checking inside the quoted part.
    '     As a result - some stuff explicitly forbiden by RFC2822 might
    '     (and I promiss ya - will) slip by unchallenged.
    '
    '   - Does not accept (as per older - RFC822 valid) space
    '     delimited and/or commented expressions like:
    '
    '           Muhammed.(I am the greatest) Ali @(the)Vegas.WBA
    '
    '           This very thingy after implicit "de-fancy-ing" should
    '           pass as valid RFC822 pattern: [email protected]
    '           See the RFC822 for explanation.
    '
    '   - Top lavel domains are not checked against the list of valid
    '     top level domains.(http://www.iana.com/domain-names.htm)

        isValidEmail = False

        If TypeName("str")<>TypeName(sEmail) Then   
            Exit Function                               '   >>>
        End If

        Dim sAry, nSlices
        sAry = Split(sEmail, "@")
        nSlices = UBound(sAry) + 1

        If nSlices<>2 Then Exit Function                '   >>>

        If NOT isQuoted(sAry(0)) Then
            If haveIllegalLocPartContents(sAry(0)) Then 
                Exit Function                           '   >>>
            End If
        End If

        ' If we got to this point, then the local part is OK meaning:
        '   - local part is quoted thus not looked into,
        '       OR
        '   - local part contains no offending characters.

        If NOT isDomainLiteral(sAry(1)) Then
            isValidEmail = isValidHostName(sAry(1))
            Exit Function                               '   >>>
        End If

        isValidEmail = isValidIP( Mid(sAry(1), 2, Len(sAry(1))-2) )
    End Function

    '   =====
    Function isValidHostName(sFQDN)
    '   Returns true if passed string is valid Fully Qualified Domain Name
    '   
    '   As per RFC 1034 (Page 11):
    '   ...
    '   The labels must follow the rules for ARPANET host names.  They must
    '   start with a letter, end with a letter or digit, and have as interior
    '   characters only letters, digits, and hyphen.  There are also some
    '   restrictions on the length.  Labels must be 63 characters or less...

        isValidHostName = False
        If TypeName("str")<>TypeName(sFQDN) Then    
            Exit Function                               '   >>>
        End If

        If Len(sFQDN)>255 Then Exit Function            '   >>>

        Dim sAry, nSlices, nI, oRegX_1, oRegX_2, oRegX_3
        sAry = Split(sFQDN, ".")
        nSlices = UBound(sAry) + 1

        If nSlices<2 Then Exit Function                 '   >>>
        
        Const WRONG_HOST_PATRN_1 = "(^[^a-zA-Z])|([^a-zA-Z0-9]$)"
        Const WRONG_HOST_PATRN_2 = "[^a-zA-Z0-9-]"
        Const WRONG_HOST_PATRN_3 = "[^a-zA-Z]"
        Set oRegX_1 = new RegExp
        Set oRegX_2 = new RegExp
        Set oRegX_3 = new RegExp
        oRegX_1.Pattern = WRONG_HOST_PATRN_1
        oRegX_2.Pattern = WRONG_HOST_PATRN_2
        oRegX_3.Pattern = WRONG_HOST_PATRN_3

        For nI=0 To nSlices-1
            If Len(sAry(nI))>63 OR sAry(nI)="" Then 
                Exit Function                           '   >>>
            End If

            If nI = nSlices-1 Then
                If Len(sAry(nI))<2 Then Exit Function   '   >>>
                If oRegX_3.Test(sAry(nI)) Then Exit Function'   >>>
            End If

            If ( oRegX_1.Test(sAry(nI)) OR oRegX_2.Test(sAry(nI)) ) Then
                Exit Function                           '   >>>
            End If
        Next

        isValidHostName = True
    End Function

    '   =====
    Function isValidIP(sIP)
    '   Will return true if passed string - "IP [:portNo]" is OK

        isValidIP = False
        If TypeName("str")<>TypeName(sIP) Then  
            Exit Function                               '   >>>
        End If

        Dim sTmpIP, oRegX, sAry, nSlices
        Const IP_PART = "(\d+)"
        Set oRegX = new RegExp
        oRegX.Pattern = IP_PART
        oRegX.Global = True
        Set sAry = oRegX.Execute(sIP)
        nSlices = sAry.Count

        Select Case nSlices
            Case 4
                If (    (sAry(0)>0) AND (sAry(0)<255)_
                    AND (sAry(1)<=255)_
                    AND (sAry(2)<=255)_
                    AND (sAry(3)<=255)      ) Then

                    sTmpIP = sAry(0) & "." & sAry(1) & "." &_
                            sAry(2) & "." & sAry(3)

                    If (sTmpIP=sIP) Then
                        isValidIP = True
                        Exit Function                   '   >>>
                    End If
                End If
            Case 5
                If (    (sAry(0)>0) AND (sAry(0)<255)_
                    AND (sAry(1)<=255)_
                    AND (sAry(2)<=255)_
                    AND (sAry(3)<=255)_
                    AND (sAry(4)>0) AND (sAry(4)<65535)     ) Then

                    sTmpIP = sAry(0) & "." & sAry(1) & "." &_
                            sAry(2) & "." & sAry(3) & ":" & sAry(4)

                    If (sTmpIP=sIP) Then
                        isValidIP = True
                        Exit Function                   '   >>>
                    End If
                End If
            Case Else
                Exit Function                           '   >>>
        End Select

    End Function

    '   -----   Private Functions ------------------------------------
    '   Next three functions can be re-worked as one that accepts
    '   string for validation and pattern, but having them as three
    '   separate entities, each with its own and suitable name
    '   makes for much easier code reading.
    Private Function isQuoted(sStr)
        Const QUOTED = "^"".+""$"
        Dim oRegX
        Set oRegX = new RegExp
        oRegX.Pattern = QUOTED
        isQuoted = oRegX.Test(sStr)
    End Function
    '   ---
    Private Function haveIllegalLocPartContents(sStr) 
        Const ILLEGAL_CHARS = "["" @<>\[\]\(\):;,]"
        Dim oRegX
        Set oRegX = new RegExp
        oRegX.Pattern = ILLEGAL_CHARS
        haveIllegalLocPartContents = oRegX.Test(sStr)
    End Function
    '   ---
    Private Function isDomainLiteral(sStr)
        Const DOM_LITERAL = "^\[.+\]$"
        Dim oRegX
        Set oRegX = new RegExp
        oRegX.Pattern = DOM_LITERAL
        isDomainLiteral = oRegX.Test(sStr)
    End Function
    '   --------------------------------------------------------------

End Class
' ====================== END OF CLASS ================================

Function Demo_EMailValidatorCLS()
    Dim oVal, sMsg
    Const sMail_1 = "*@qz.to"
    Const sMail_2 = "Chilly.Willy@[123.22.33.1:25]"
    Const sMail_3 = "[email protected]"
    Const sMail_4 = """Merry Chimp""@quite.happy.pl"
    Const sMail_5 = "[email protected]"

    Set oVal = new EMailValidatorCLS

    sMsg = "oVal.isValidEmail(" & sMail_1 & ") -> " &_
            oVal.isValidEmail(sMail_1) & vbCrLf
    sMsg = sMsg & "oVal.isValidEmail(" & sMail_2 & ") -> " &_
                oVal.isValidEmail(sMail_2) & vbCrLf
    sMsg = sMsg & "oVal.isValidEmail(" & sMail_3 & ") -> " &_
                oVal.isValidEmail(sMail_3) & vbCrLf
    sMsg = sMsg & "oVal.isValidEmail(" & sMail_4 & ") -> " &_
                oVal.isValidEmail(sMail_4) & vbCrLf
    sMsg = sMsg & "oVal.isValidEmail(" & sMail_5 & ") -> " &_
                oVal.isValidEmail(sMail_5) & vbCrLf

    WScript.Echo(sMsg)
End Function