sampleFile - OpenGrok cross reference for /sampleFile

1' The MIT License (MIT) 2' 3' Copyright (c) 2016 Tim Hall 4' 5' Permission is hereby granted, free of charge, to any person obtaining a copy 6' of this software and associated documentation files (the "Software"), to deal 7' in the Software without restriction, including without limitation the rights 8' to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9' copies of the Software, and to permit persons to whom the Software is 10' furnished to do so, subject to the following conditions: 11' 12' The above copyright notice and this permission notice shall be included in all 13' copies or substantial portions of the Software. 14' 15' THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16' IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17' FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18' AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19' LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20' OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21' SOFTWARE. 22 23 VERSION 1.0 CLASS 24 BEGIN 25 MultiUse = -1 'True 26END 27 Attribute VB_Name = "WebResponse" 28 Attribute VB_GlobalNameSpace = False 29 Attribute VB_Creatable = False 30 Attribute VB_PredeclaredId = False 31 Attribute VB_Exposed = True 32'' 33' WebResponse v4.1.3 34' (c) Tim Hall - https://github.com/VBA-tools/VBA-Web 35' 36' Wrapper for http/cURL responses that includes parsed Data based on WebRequest.ResponseFormat. 37' 38' Usage: 39' ```VB.net 40' Dim Response As WebResponse 41' Set Response = Client.Execute(Request) 42' 43' If Response.StatusCode = WebStatusCode.Ok Then 44' ' Response.Headers, Response.Cookies 45' ' Response.Data -> Parsed Response.Content based on Request.ResponseFormat 46' ' Response.Body -> Raw response bytes 47' Else 48' Debug.Print "Error: " & Response.StatusCode & " - " & Response.Content 49' End If 50' ``` 51' 52' Errors: 53' 11030 / 80042b16 / -2147210474 - Error creating from http 54' 11031 / 80042b17 / -2147210473 - Error creating from cURL 55' 11032 / 80042b18 / -2147210472 - Error extracting headers 56' 57' @class WebResponse 58' @author tim.hall.engr@gmail.com 59' @license MIT (http://www.opensource.org/licenses/mit-license.php) 60'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ' 61Option Explicit 62 63Private web_CrLf As String 64 65' --------------------------------------------- ' 66' Properties 67' --------------------------------------------- ' 68 69'' 70' Status code that the server returned (e.g. 200). 71' 72' @property StatusCode 73' @type WebStatusCode 74'' 75Public StatusCode As WebStatusCode 76 77'' 78' Status string that the server returned (e.g. `404 -> "Not Found"`) 79' 80' @property StatusDescription 81' @type String 82'' 83Public StatusDescription As String 84 85'' 86' Content string that the server returned. 87' 88' @property Content 89' @type String 90'' 91Public Content As String 92 93'' 94' Raw bytes for the response. 95' 96' @property Body 97' @type Byte() 98'' 99Public Body As Variant 100 101'' 102' Parsed `Content` or `Body` based on the `WebRequest.ResponseFormat`. 103' 104' @property Data 105' @type Dictionary|Collection 106'' 107Public Data As Object 108 109'' 110' Headers that were included with the response. 111' (`Collection` of `KeyValue`) 112' 113' @property Headers 114' @type Collection 115'' 116Public Headers As Collection 117 118'' 119' Cookies that were included with the response. 120' (`Collection` of `KeyValue`) 121' 122' @property Cookies 123' @type Collection 124'' 125Public Cookies As Collection 126 127' ============================================= ' 128' Public Methods 129' ============================================= ' 130 131'' 132' Helper for updating the response with the given updated response values. 133' Useful for `ByRef` cases to update response in place. 134' 135' @method Update 136' @param Updated {WebResponse} Updated `WebResponse` to pull updated values from 137'' 138Public Sub Update(Updated As WebResponse) 139 Me.StatusCode = Updated.StatusCode 140 Me.StatusDescription = Updated.StatusDescription 141 Me.Content = Updated.Content 142 Me.Body = Updated.Body 143 Set Me.Headers = Updated.Headers 144 Set Me.Cookies = Updated.Cookies 145 Set Me.Data = Updated.Data 146End Sub 147 148'' 149' Create response from http 150' 151' @internal 152' @method CreateFromHttp 153' @param {WebClient} Client 154' @param {WebRequest} Request 155' @param {WinHttpRequest} Http 156' @throws 11030 / 80042b16 / -2147210474 - Error creating from http 157'' 158Public Sub CreateFromHttp(Client As WebClient, Request As WebRequest, Http As Object) 159 On Error GoTo web_ErrorHandling 160 161 Me.StatusCode = Http.Status 162 Me.StatusDescription = Http.StatusText 163 Me.Content = Http.ResponseText 164 Me.Body = Http.ResponseBody 165 166 web_LoadValues Http.GetAllResponseHeaders, Me.Content, Me.Body, Request 167 168 Exit Sub 169 170 web_ErrorHandling: 171 172 Dim web_ErrorDescription As String 173 web_ErrorDescription = "An error occurred while creating response from http" & vbNewLine & _ 174 Err.Number & VBA.IIf(Err.Number < 0, " (" & VBA.LCase$(VBA.Hex$(Err.Number)) & ")", "") & ": " & Err.Description 175 176 WebHelpers.LogError web_ErrorDescription, "WebResponse.CreateFromHttp", 11030 + vbObjectError 177 Err.Raise 11030 + vbObjectError, "WebResponse.CreateFromHttp", web_ErrorDescription 178End Sub 179 180'' 181' Create response from cURL 182' 183' @internal 184' @method CreateFromCurl 185' @param {WebClient} Client 186' @param {WebRequest} Request 187' @param {String} Result 188' @throws 11031 / 80042b17 / -2147210473 - Error creating from cURL 189'' 190Public Sub CreateFromCurl(Client As WebClient, Request As WebRequest, Result As String) 191 On Error GoTo web_ErrorHandling 192 193 Dim web_Lines() As String 194 195 web_Lines = VBA.Split(Result, web_CrLf) 196 197 Me.StatusCode = web_ExtractStatusFromCurlResponse(web_Lines) 198 Me.StatusDescription = web_ExtractStatusTextFromCurlResponse(web_Lines) 199 Me.Content = web_ExtractResponseTextFromCurlResponse(web_Lines) 200 Me.Body = WebHelpers.StringToAnsiBytes(Me.Content) 201 202 web_LoadValues web_ExtractHeadersFromCurlResponse(web_Lines), Me.Content, Me.Body, Request 203 204 Exit Sub 205 206 web_ErrorHandling: 207 208 Dim web_ErrorDescription As String 209 web_ErrorDescription = "An error occurred while creating response from cURL" & vbNewLine & _ 210 Err.Number & VBA.IIf(Err.Number < 0, " (" & VBA.LCase$(VBA.Hex$(Err.Number)) & ")", "") & ": " & Err.Description 211 212 WebHelpers.LogError web_ErrorDescription, "WebResponse.CreateFromCurl", 11031 + vbObjectError 213 Err.Raise 11031 + vbObjectError, "WebResponse.CreateFromCurl", web_ErrorDescription 214End Sub 215 216'' 217' Extract headers from response headers 218' 219' @internal 220' @method ExtractHeaders 221' @param {String} ResponseHeaders 222' @return {Collection} Headers 223' @throws 11032 / 80042b18 / -2147210472 - Error extracting headers 224'' 225Public Function ExtractHeaders(ResponseHeaders As String) As Collection 226 On Error GoTo web_ErrorHandling 227 228 Dim web_Lines As Variant 229 Dim web_i As Integer 230 Dim web_Headers As New Collection 231 Dim web_Header As Dictionary 232 Dim web_ColonPosition As Long 233 Dim web_Multiline As Boolean 234 235 web_Lines = VBA.Split(ResponseHeaders, web_CrLf) 236 237 For web_i = LBound(web_Lines) To (UBound(web_Lines) + 1) 238 If web_i > UBound(web_Lines) Then 239 web_Headers.Add web_Header 240 ElseIf web_Lines(web_i) <> "" Then 241 web_ColonPosition = VBA.InStr(1, web_Lines(web_i), ":") 242 If web_ColonPosition = 0 And Not web_Header Is Nothing Then 243 ' Assume part of multi-line header 244 web_Multiline = True 245 ElseIf web_Multiline Then 246 ' Close out multi-line string 247 web_Multiline = False 248 web_Headers.Add web_Header 249 ElseIf Not web_Header Is Nothing Then 250 ' Add previous header 251 web_Headers.Add web_Header 252 End If 253 254 If Not web_Multiline Then 255 Set web_Header = WebHelpers.CreateKeyValue( _ 256 Key:=VBA.Trim(VBA.Mid$(web_Lines(web_i), 1, web_ColonPosition - 1)), _ 257 Value:=VBA.Trim(VBA.Mid$(web_Lines(web_i), web_ColonPosition + 1, VBA.Len(web_Lines(web_i)))) _ 258 ) 259 Else 260 web_Header("Value") = web_Header("Value") & web_CrLf & web_Lines(web_i) 261 End If 262 End If 263 Next web_i 264 265 Set ExtractHeaders = web_Headers 266 Exit Function 267 268 web_ErrorHandling: 269 270 Dim web_ErrorDescription As String 271 web_ErrorDescription = "An error occurred while extracting headers" & vbNewLine & _ 272 Err.Number & VBA.IIf(Err.Number < 0, " (" & VBA.LCase$(VBA.Hex$(Err.Number)) & ")", "") & ": " & Err.Description 273 274 WebHelpers.LogError web_ErrorDescription, "WebResponse.CreateFromCurl", 11032 + vbObjectError 275 Err.Raise 11032 + vbObjectError, "WebResponse.CreateFromCurl", web_ErrorDescription 276End Function 277 278'' 279' Extract cookies from response headers 280' 281' @internal 282' @method ExtractCookies 283' @param {Collection} Headers 284' @return {Collection} Cookies 285'' 286Public Function ExtractCookies(Headers As Collection) As Collection 287 Dim web_Header As Dictionary 288 Dim web_Cookie As String 289 Dim web_Key As String 290 Dim web_Value As String 291 Dim web_Cookies As New Collection 292 293 For Each web_Header In Headers 294 If web_Header("Key") = "Set-Cookie" Then 295 web_Cookie = web_Header("Value") 296 If VBA.InStr(1, web_Cookie, "=") > 0 Then 297 web_Key = VBA.Mid$(web_Cookie, 1, VBA.InStr(1, web_Cookie, "=") - 1) 298 web_Value = VBA.Mid$(web_Cookie, VBA.InStr(1, web_Cookie, "=") + 1, VBA.Len(web_Cookie)) 299 300 ' Ignore text after semi-colon 301 If VBA.InStr(1, web_Value, ";") > 0 Then 302 web_Value = VBA.Mid$(web_Value, 1, VBA.InStr(1, web_Value, ";") - 1) 303 End If 304 305 ' Ignore surrounding quotes 306 If VBA.Left$(web_Value, 1) = """" Then 307 web_Value = VBA.Mid$(web_Value, 2, VBA.Len(web_Value) - 2) 308 End If 309 310 web_Cookies.Add WebHelpers.CreateKeyValue(web_Key, WebHelpers.UrlDecode(web_Value, PlusAsSpace:=False, EncodingMode:=UrlEncodingMode.CookieUrlEncoding)) 311 Else 312 WebHelpers.LogWarning _ 313 "Unrecognized cookie format: " & web_Cookie, "WebResponse.ExtractCookies" 314 End If 315 End If 316 Next web_Header 317 318 Set ExtractCookies = web_Cookies 319End Function 320 321' ============================================= ' 322' Private Functions 323' ============================================= ' 324 325Private Sub web_LoadValues(web_Headers As String, web_Content As String, web_Body As Variant, web_Request As WebRequest) 326 ' Convert content to data by format 327 If web_Request.ResponseFormat <> WebFormat.PlainText Then 328 On Error Resume Next 329 Set Me.Data = _ 330 WebHelpers.ParseByFormat(web_Content, web_Request.ResponseFormat, web_Request.CustomResponseFormat, web_Body) 331 332 If Err.Number <> 0 Then 333 WebHelpers.LogError Err.Description, Err.Source, Err.Number 334 Err.Clear 335 End If 336 On Error GoTo 0 337 End If 338 339 ' Extract headers 340 Set Me.Headers = ExtractHeaders(web_Headers) 341 342 ' Extract cookies 343 Set Me.Cookies = ExtractCookies(Me.Headers) 344End Sub 345 346Private Function web_ExtractStatusFromCurlResponse(web_CurlResponseLines() As String) As Long 347 Dim web_StatusLineParts() As String 348 349 web_StatusLineParts = VBA.Split(web_CurlResponseLines(web_FindStatusLine(web_CurlResponseLines)), " ") 350 web_ExtractStatusFromCurlResponse = VBA.CLng(web_StatusLineParts(1)) 351End Function 352 353Private Function web_ExtractStatusTextFromCurlResponse(web_CurlResponseLines() As String) As String 354 Dim web_StatusLineParts() As String 355 Dim web_i As Long 356 Dim web_StatusText As String 357 358 web_StatusLineParts = VBA.Split(web_CurlResponseLines(web_FindStatusLine(web_CurlResponseLines)), " ", 3) 359 web_ExtractStatusTextFromCurlResponse = web_StatusLineParts(2) 360End Function 361 362Private Function web_ExtractHeadersFromCurlResponse(web_CurlResponseLines() As String) As String 363 Dim web_StatusLineIndex As Long 364 Dim web_BlankLineIndex As Long 365 Dim web_HeaderLines() As String 366 Dim web_WriteIndex As Long 367 Dim web_ReadIndex As Long 368 369 ' Find status line and blank line before body 370 web_StatusLineIndex = web_FindStatusLine(web_CurlResponseLines) 371 web_BlankLineIndex = web_FindBlankLine(web_CurlResponseLines) 372 373 ' Extract headers string 374 ReDim web_HeaderLines(0 To web_BlankLineIndex - 2 - web_StatusLineIndex) 375 376 web_WriteIndex = 0 377 For web_ReadIndex = (web_StatusLineIndex + 1) To web_BlankLineIndex - 1 378 web_HeaderLines(web_WriteIndex) = web_CurlResponseLines(web_ReadIndex) 379 web_WriteIndex = web_WriteIndex + 1 380 Next web_ReadIndex 381 382 web_ExtractHeadersFromCurlResponse = VBA.Join$(web_HeaderLines, web_CrLf) 383End Function 384 385Private Function web_ExtractResponseTextFromCurlResponse(web_CurlResponseLines() As String) As String 386 Dim web_BlankLineIndex As Long 387 Dim web_BodyLines() As String 388 Dim web_WriteIndex As Long 389 Dim web_ReadIndex As Long 390 391 ' Find blank line before body 392 web_BlankLineIndex = web_FindBlankLine(web_CurlResponseLines) 393 394 ' Extract body string 395 ReDim web_BodyLines(0 To UBound(web_CurlResponseLines) - web_BlankLineIndex - 1) 396 397 web_WriteIndex = 0 398 For web_ReadIndex = web_BlankLineIndex + 1 To UBound(web_CurlResponseLines) 399 web_BodyLines(web_WriteIndex) = web_CurlResponseLines(web_ReadIndex) 400 web_WriteIndex = web_WriteIndex + 1 401 Next web_ReadIndex 402 403 web_ExtractResponseTextFromCurlResponse = VBA.Join$(web_BodyLines, web_CrLf) 404End Function 405 406Private Function web_FindStatusLine(web_CurlResponseLines() As String) As Long 407 ' Special case for cURL: 100 Continue is included before final status code 408 ' -> ignore 100 and find final status code (next non-100 status code) 409 For web_FindStatusLine = LBound(web_CurlResponseLines) To UBound(web_CurlResponseLines) 410 If VBA.Trim$(web_CurlResponseLines(web_FindStatusLine)) <> "" Then 411 If VBA.Split(web_CurlResponseLines(web_FindStatusLine), " ")(1) <> "100" Then 412 Exit Function 413 End If 414 End If 415 Next web_FindStatusLine 416End Function 417 418Private Function web_FindBlankLine(web_CurlResponseLines() As String) As Long 419 For web_FindBlankLine = (web_FindStatusLine(web_CurlResponseLines) + 1) To UBound(web_CurlResponseLines) 420 If VBA.Trim$(web_CurlResponseLines(web_FindBlankLine)) = "" Then 421 Exit Function 422 End If 423 Next web_FindBlankLine 424End Function 425 426Private Sub Class_Initialize() 427 web_CrLf = VBA.Chr$(&HA) & VBA.Chr$(&o12) 428 429 Set Headers = New Collection 430 Set Cookies = New Collection 431End Sub 432 433Private Sub Test_strings() 434 Dim foo1() As String 435 Set foo1 = " testing 436 1-2-3" 437End Sub 438