vbscriptでJSONをparse

json2.jsのjson_parse.jsを参考にJSONをvbcriptでparseする関数を作成してみた。

Class Json2Vbs
    Private at, ch, escapee, text
    
    Private Sub Error(m)
        Err.Raise vbObject + 1, "json2vbs", m
    End Sub
    
    Private Function nextCh(c)
        If c & "" <> "" Then
            If c <> ch Then
                Error "Expected '" & c & "' instead of '" & ch & "'"
            End If
        End If
        
        ch = Mid(text, 1 + at, 1)
        at = at + 1
        nextCh = ch
    End Function
    
    Private Function number()
        Dim num, str
        str = ""
        
        If ch = "-" Then
            str = "-"
            nextCh "-"
        End If
        Do While ch >= "0" And ch <= "9"
            str = str & ch
            nextCh ""
        Loop
        If ch = "." Then
            str = str & "."
            nextCh ""
            Do While ch >= "0" And ch <= "9"
                str = str & ch
                nextCh ""
            Loop
        End If
        
        num = str - 0
        number = num
    End Function
    
    Private Function stringVal()
        Dim hex, i, str, uffff
        str = ""
        
        If ch = """" Then
            Do While nextCh("") <> ""
                If ch = """" Then
                    nextCh ""
                    stringVal = str
                    Exit Function
                End If
                If ch = "\" Then
                    nextCh ""
                    If ch = "u" Then
                        uffff = 0
                        For i = 0 To 4 - 1
                            hex = parseChrHexNum(nextCh(""))
                            uffff = uffff * 16 + hex
                        Next
                        str = str & fromUnicode(uffff)
                    ElseIf escapee.Exists(ch) Then
                        str = str & escapee(ch)
                    Else
                        Exit Do
                    End If
                Else
                    str = str & ch
                End If
            Loop
        End If
        Error "Bad string"
    End Function
    
    Private Function parseChrHexNum(hexCh)
        If hexCh >= "0" And hexCh <= "9" Then
            parseChrHexNum = hexCh - 0
            Exit Function
        End If
        parseChrHexNum = Asc(UCase(hexCh)) - &H41 + 10
    End Function
    
    Private Function fromUnicode(uffff)
        fromUnicode = ChrW(uffff)
    End Function
    
    Private Sub White()
        Do While ch <> "" And ch <= " "
            nextCh ""
        Loop
    End Sub
    
    Private Function Word()
        Select Case ch
            Case "t"
                nextCh "t"
                nextCh "r"
                nextCh "u"
                nextCh "e"
                Word = True
                Exit Function
            Case "f"
                nextCh "f"
                nextCh "a"
                nextCh "l"
                nextCh "s"
                nextCh "e"
                Word = False
                Exit Function
        End Select
        Error "Unexpected '" & ch & "' at:" & at
    End Function
    
    Private Function WordNull()
        Select Case ch
            Case "n"
                nextCh "n"
                nextCh "u"
                nextCh "l"
                nextCh "l"
                Set WordNull = Nothing
                Exit Function
        End Select
        Error "Unexpected '" & ch & "' at:" & at
    End Function
    
    
    Private Function ArrayVal()
        Dim arrVal, idx, val, isObj
        Set arrVal = CreateCollection()
        idx = 0
        
        If ch = "[" Then
            nextCh "["
            White
            If ch = "]" Then
                nextCh "]"
                Set ArrayVal = arrVal
                Exit Function
            End If
            
            Do While ch <> ""
                isObj = getVal(val)
                If isObj Then
                    Set arrVal(idx) = val
                Else
                    arrVal(idx) = val
                End If
                idx = idx + 1
                White
                
                If ch = "]" Then
                    nextCh "]"
                    Set ArrayVal = arrVal
                    Exit Function
                End If
                nextCh ","
                White
            Loop
        End If
        Error "Bad Array"
    End Function
    
    Private Function getObject()
        Dim key, obj
        Dim isObj, val
        Set obj = CreateCollection()
        
        If ch = "{" Then
            nextCh "{"
            White
            If ch = "}" Then
                nextCh "}"
                Set getObject = obj
                Exit Function
            End If
        End If
        
        Do While ch <> ""
            key = stringVal()
            White
            nextCh ":"
            isObj = getVal(val)
            obj.Add key, val
            White
            If ch = "}" Then
                nextCh "}"
                Set getObject = obj
                Exit Function
            End If
            nextCh ","
            White
        Loop
        Error "Bad Object"
    End Function
    
    Private Function getVal(val)
        Dim isObj
        White
        Select Case ch
            Case "{"
                isObj = True
                Set val = getObject()
                getVal = isObj
                Exit Function
            Case "["
                isObj = True
                Set val = ArrayVal()
                getVal = isObj
                Exit Function
            Case """"
                isObj = False
                val = stringVal()
                getVal = isObj
                Exit Function
            Case "-"
                isObj = False
                val = number()
                getVal = isObj
                Exit Function
            Case Else
                If ch >= "0" And ch <= "9" Then
                    isObj = False
                    val = number()
                ElseIf ch = "n" Then
                    isObj = True
                    Set val = WordNull()
                Else
                    isObj = False
                    val = Word()
                End If
                getVal = isObj
                Exit Function
        End Select
    End Function
    
    Private Sub ParseInit()
        at = 0
        ch = ""
        Set escapee = CreateCollection()
        escapee("""") = """"
        escapee("\") = "\"
        escapee("/") = "/"
        escapee("b") = Chr(&H8) ' backspace
        escapee("f") = Chr(&HC) ' form feed
        escapee("n") = Chr(&HA) ' line feed
        escapee("r") = Chr(&HD) ' carriage return
        escapee("t") = Chr(&H9) ' tab
        text = ""
        
    End Sub
    
    Public Function Parse(str)
        ParseInit
        
        text = str
        at = 0
        ch = " "
        
        Dim isObj, val
        isObj = getVal(val)
        If Not isObj Then
            Error "not object or array"
        End If
        White
        
        If ch <> "" Then
            Error "Syntax Error"
        End If
        
        Set Parse = val
    End Function
    
    Function CreateCollection()
        Set CreateCollection = WScript.CreateObject("Scripting.Dictionary")
    End Function
End Class

Class Vbs2Json
    Public Function ToJsonString(obj, options)
        Dim s, s1
        Dim ary()
        Dim vKey
        Dim col
        Dim vVarType
        Dim isArray
        Dim iMaxIdx
        Dim i
        Dim vKeys
        Dim sCr
        Dim formatting
        
        formatting = True
        
        If formatting Then
            sCr = Chr(13) & Chr(10)
        Else
            sCr = ""
        End If
        
        Set col = obj

        isArray = False
        If col.Count = 0 Then
            ToJsonString = "[]"
            Exit Function
        Else
            vKeys = col.Keys
            vVarType = VarType(vKeys(0))
            If vVarType = 2 Then        ' Integer
                isArray = True
            ElseIf vVarType = 3 Then    ' Long
                isArray = True
            End If
        End If
        
        If isArray Then
            iMaxIdx = -1
            For Each vKey In col
                If iMaxIdx < vKey Then
                    iMaxIdx = vKey
                End If
            Next
            Redim ary(iMaxIdx)
            
            For Each vKey In col
                If VarType(col(vKey)) = 9 Then    'Object
                    Set ary(vKey) = col(vKey)
                Else
                    ary(vKey) = col(vKey)
                End If
            Next
            
            s1 = ""
            For i = 0 To iMaxIdx
                If VarType(ary(i)) <> 9 Then 'vbObject
                    s1 = s1 & "," & FormatJsonValue(ary(i)) & ""
                Else
                    s1 = s1 & "," & sCr & ToJsonString(ary(i), options) & ""
                End If
            Next
            s = "[" & Mid(s1, 2) & "]" & sCr
        Else
            s1 = ""
            For Each vKey in col
                If VarType(col(vKey)) <> 9 Then 'vbObject
                    s1 = s1 & ",""" & vKey & """:" & FormatJsonValue(col(vKey)) & ""
                Else
                    s1 = s1 & "," & sCr & """" & vKey & """:" & sCr & ToJsonString(col(vKey), options) & ""
                End If
            Next
            s = "{" & Mid(s1, 2) & "}" & sCr
        End If

        ToJsonString  = s
    End Function
    
    Function FormatJsonValue(v)
        Dim s
        Select Case VarType(v)
            Case 2, 3, 4, 5 'vbInteger, vbLong, vbSingle, vbDouble
                s = v & ""
            Case 11 'Boolean
                If v Then
                    s = "true"
                Else
                    s = "false"
                End If
            Case Else
                s = """" & EscapeJsonValue(v) & """"
        End Select
        FormatJsonValue = s
    End Function
    
    Function EscapeJsonValue(v)
        Dim s
        If v & "" = "" Then
            s = ""
        Else
            s = Replace(v, "\"     , "\\")
            s = Replace(s, vbCrLf  , "\n")
            s = Replace(s, vbCr    , "\n")
            s = Replace(s, vbLf    , "\n")
            s = Replace(s, """"    , "\""")
            s = Replace(s, "/"     , "\/")
            s = Replace(s, Chr(&H8), "\b")
            s = Replace(s, Chr(&HC), "\f")
            s = Replace(s, Chr(&H9), "\t")
            s = Replace(s, Chr(&HB), "\u000b")
            
            s = Replace(s, "'"     , "\u0027")
            
            s = Replace(s, "&"     , "\u0026")
            s = Replace(s, "<"     , "\u003c")
            s = Replace(s, ">"     , "\u003e")
        End If
        EscapeJsonValue = s
    End Function
    
End Class

とりあえず作成してみたが、正しく動作するか検証が必要。

2016/01/19追記

いろいろとバグがあったので修正。 とりあえず、unicode、escape文字は正しく処理されるようになった。