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文字は正しく処理されるようになった。