Advertisement
Guest User

Untitled

a guest
Jul 13th, 2012
465
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. '/// JSON Parser for VK API
  2. '/// by EverybodyLies
  3. '/// mailto:sungik108@yandex.ru
  4.  
  5. Const c_separator As String = "." 'tag.tag.tag
  6. Const c_numValue As String = "!" 'value = "!12345"
  7. Const c_strValue As String = "~" 'value = "~string"
  8. Const c_valueOnly As String = "^" '[value,{... // tag(^)=value
  9.  
  10. Const c_container1_open As String = "{"
  11. Const c_container1_close As String = "}"
  12. Const c_container2_open As String = "["
  13. Const c_container2_close As String = "]"
  14.  
  15. Private i_container1_opened As Long, i_container2_opened As Long
  16. '\\\
  17. '0) {...} // [...] // [*,...]
  18. '1) "tag":numeric_value,...
  19. '2) "tag":"value",...
  20. '3) "tag":{"tag1":value,"tag2":"value",...}
  21. '4) "tag":[{param1},{param2},...]
  22. '5) "tag":[param,{param1},{param2},...]
  23. '///
  24.  
  25. Function Parse(ByRef post As String, ByRef tag As Collection, ByRef value As Collection, Optional ByVal ParseOneBlock As Boolean = False) As Long
  26. '\\\
  27. Dim tmp As String, res As Long
  28. '///
  29. On Error GoTo ParseError
  30. '\\\\\
  31. Do While Len(post) > 0
  32.         'MsgBox post
  33.    Rem \\ detect "{" and "}"
  34.     Select Case Left$(post, 1)
  35.     Case "," '#
  36.        post = Right$(post, Len(post) - 1)
  37.     Case "{" '#
  38.        post = Right$(post, Len(post) - 1)
  39.         i_container1_opened = i_container1_opened + 1
  40.             tag.add c_container1_open
  41.             value.add c_container1_open
  42.     Case "}" '#
  43.        'If ParseOneBlock And i_container1_opened = 0 And i_container2_opened = 0 Then
  44.        '    Exit Do
  45.        'Else
  46.            post = Right$(post, Len(post) - 1)
  47.             i_container1_opened = i_container1_opened - 1
  48.                 tag.add c_container1_close
  49.                 value.add c_container1_close
  50.             If i_container1_open = 0 And i_container2_open = 0 Then Exit Do
  51.         'End If
  52.    Case "[" '#
  53.        post = Right$(post, Len(post) - 1)
  54.         i_container2_opened = i_container2_opened + 1
  55.             tag.add c_container2_open
  56.             value.add c_container2_open
  57.     Case "]" '#
  58.        'If ParseOneBlock And i_container1_opened = 0 And i_container2_opened = 0 Then
  59.        '    Exit Do
  60.        'Else
  61.            post = Right$(post, Len(post) - 1)
  62.             i_container2_closed = i_container2_closed - 1
  63.                 tag.add c_container2_close
  64.                 value.add c_container2_close
  65.             If i_container2_opened = 0 And i_container1_opened = 0 Then Exit Do
  66.         'End If
  67.    Case Else '#
  68.    '\\\ tags, values, syntax
  69.        res = ParseTagAndValue(post, tag, value)
  70.  
  71.         If res <> 0 Then 'error
  72.            Parse = res
  73.             Exit Function
  74.         End If
  75.     '///
  76.    End Select
  77. Loop
  78. '/////
  79. Exit Function
  80. ParseError:
  81. Parse = Err.Number
  82. End Function
  83.  
  84. Private Function ParseTagAndValue(ByRef post As String, ByRef tag As Collection, ByRef value As Collection) As Long
  85. Dim t As String, v As String, err_num As Long, tmp As String, res As Long, i As Long, i2 As Long
  86. Dim multivalue_type As Boolean, end_line_type As Boolean
  87.  
  88. On Error GoTo ParseError
  89.  
  90. If Left$(post, 1) = Chr(34) Then 'ok
  91. '\\\
  92.    t = getTag(post, err_num)
  93.     If t = "" Or err_num <> 0 Then 'error
  94.        If err_num <> 0 Then ParseTagAndValue = err_num Else ParseTagAndValue = -1
  95.     Else 'ok
  96.        Rem \\ get value type
  97.         Select Case Left$(post, 1)
  98.         Case "{" 'multivalue #1
  99.            multivalue_type = True
  100.             GoTo multivalue2
  101.         Case "[" 'multivalue #2
  102. multivalue2:
  103.             '\\\
  104.            If multivalue_type = False Then
  105.                 tag.add c_container2_open
  106.                 value.add c_container2_open
  107.             End If
  108.             post = Right$(post, Len(post) - 1)
  109.            
  110.             Dim JsonParser2 As New clsJson
  111.             Dim new_tag As New Collection, new_value As New Collection
  112.             res = JsonParser2.Parse(post, new_tag, new_value, True)
  113.             If res = 0 Then 'ok
  114.                For i = 1 To new_tag.count
  115.                     tag.add t & c_separator & new_tag.Item(i)
  116.                     value.add new_value.Item(i)
  117.                 Next
  118.             Else 'error
  119.                ParseTagAndValue = res
  120.                 Exit Function
  121.             End If
  122.             '///
  123.        Case Else 'value
  124.            '\\\
  125.            v = getValue(post, err_num) ', tag, value)
  126.            If err_num = 0 Then
  127.                 tag.add t
  128.                 value.add v
  129.             Else
  130.                 ParseTagAndValue = err_num
  131.                 Exit Function
  132.             End If
  133.             '///
  134.        End Select
  135.  
  136.         If Left$(post, 1) = "," Then post = Right$(post, Len(post) - 1)
  137.        
  138.     End If
  139. '///
  140. Else '[value_only,... or error
  141. '\\\
  142.    i = InStr(1, post, ",")
  143.     i2 = InStr(1, post, "]")
  144.     If i2 < i And i > 0 Then i = i2
  145.     If i = 0 And i2 > 0 Then i = i2: end_line_type = True
  146.  
  147.     If i > 0 Then
  148.         v = Mid$(post, 1, i - 1)
  149.             c_container2_closed = c_container2_closed - 1
  150.             tag.add c_valueOnly
  151.             value.add v
  152.            
  153.         If end_line_type Then
  154.             tag.add c_container2_close
  155.             value.add c_container2_close
  156.         End If
  157.        
  158.         post = Right$(post, Len(post) - Len(v) - 1)
  159.         If Left$(post, 1) = "," Then post = Right$(post, Len(post) - 1)
  160.     Else
  161.         ParseTagAndValue = -2
  162.     End If
  163. '///
  164. End If
  165.  
  166. Exit Function
  167. ParseError:
  168. ParseTagAndValue = Err.Number
  169. End Function
  170.  
  171. Private Function getTag(ByRef string_ As String, ByRef err_num As Long) As String
  172. Dim i As Integer
  173.  
  174. On Error GoTo ParseError
  175. err_num = 0
  176.  
  177. Rem // "tag":value,...
  178. i = InStr(1, string_, ":")
  179. getTag = Mid$(string_, 2, i - 3)
  180. Rem // delete tag from string_
  181. string_ = Right$(string_, Len(string_) - Len(getTag) - 3)
  182.  
  183. Exit Function
  184. ParseError:
  185. err_num = Err.Number
  186. End Function
  187.  
  188. Private Function getValue(ByRef string_ As String, ByRef err_num As Long) As String ', tag As Collection, value As Collection) As String
  189. Dim a As Long, tmpi As Long, tmp As String
  190. '\\
  191. On Error GoTo ParseError
  192. err_num = 0
  193. '//
  194. Select Case Left$(string_, 1) 'first char of value
  195. Case "-" ' - number value redirect
  196.    GoTo num_value
  197. Case "+" ' - number value redirect
  198.    GoTo num_value
  199. Case "0" To "9"
  200. num_value:
  201. '\\\' number value \\\ "," Or "}"
  202.    tmpi = InStr(1, string_, ",") ' ...value,
  203.    a = InStr(1, string_, "}") ' ...value}
  204.    If a = 0 And tmpi = 0 Then 'error
  205.        err_num = -4
  206.     Else 'ok
  207.        If a < tmpi And a > 0 Then tmpi = a
  208.         If tmpi = 0 And a > 0 Then tmpi = a
  209.         'else tmpi = tmpi
  210.        a = InStr(1, string_, "]") ' ...value]
  211.        If a > 0 Then
  212.             If a < tmpi And a > 0 Then tmpi = a
  213.             If tmpi = 0 And a > 0 Then tmpi = a
  214.             'else tmpi = tmpi
  215.            getValue = c_numValue & Mid$(string_, 1, tmpi - 1)
  216.             string_ = Right$(string_, Len(string_) - (Len(getValue) - 1)) ' - 1)
  217.        End If
  218.     End If
  219. '///
  220. Case Chr(34)
  221. '\\\' string value \\\ Chr(34)
  222.    tmpi = InStr(2, string_, Chr(34))
  223.     If tmpi > 0 Then 'ok
  224.        If tmpi = 2 Then getValue = c_strValue Else getValue = c_strValue & Mid$(string_, 2, tmpi - 2)
  225.         string_ = Right$(string_, Len(string_) - (Len(getValue) - 1) - 2)
  226.     Else 'error
  227.        err_num = -5
  228.     End If
  229. '///
  230. Case Else 'unknown value, error
  231.    'WTF?! (o_0)
  232.    err_num = -6
  233. End Select
  234.  
  235. Exit Function
  236. ParseError:
  237. err_num = Err.Number
  238. End Function
  239.  
  240. '/// The End of JsonParser. 14:07, 13 July 2012. bugfix #3
  241. Const c_strValue As String =
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement