VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form Form1 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Form1"
   ClientHeight    =   5820
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   9315
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5820
   ScaleWidth      =   9315
   StartUpPosition =   2  'CenterScreen
   Begin VB.CommandButton Command3 
      Caption         =   "Command3"
      Height          =   495
      Left            =   6480
      TabIndex        =   6
      Top             =   120
      Width           =   2415
   End
   Begin VB.ListBox List1 
      Height          =   840
      Left            =   120
      TabIndex        =   4
      Top             =   3720
      Width           =   9015
   End
   Begin VB.TextBox Text1 
      Height          =   1695
      Left            =   120
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   2
      Text            =   "ServeurForm1.frx":0000
      Top             =   840
      Width           =   9015
   End
   Begin MSWinsockLib.Winsock Winsock1 
      Left            =   120
      Top             =   120
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin VB.Label Label2 
      Caption         =   "Label2"
      Height          =   615
      Left            =   120
      TabIndex        =   5
      Top             =   4680
      Width           =   9015
   End
   Begin VB.Label Label1 
      Caption         =   "Label1"
      Height          =   975
      Left            =   120
      TabIndex        =   0
      Top             =   2640
      Width           =   8895
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim sBase As String
Dim sOutput As String
Dim lPointer As Long

Private Sub Command3_Click()
	On Error GoTo ErrHandler
	
	Winsock1.Protocol = sckTCPProtocol
	Winsock1.LocalPort = 5555
	Winsock1.Listen
	
	Exit Sub

ErrHandler:
	MsgBox Err.Description, vbCritical, "Err #" & Err.Number
	End
End Sub


Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
	Winsock1.Close
End Sub

Private Sub Winsock1_Close()
	If Winsock1.State <> sckClosed Then
	  Winsock1.Close
	  DoEvents
	  Winsock1.Listen
	End If
End Sub

Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
	If Winsock1.State <> sckClosed Then
	  'tell Winsock to stop listening for connections
	  Winsock1.Close
	End If
	Winsock1.Accept requestID
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
	On Error GoTo ErrHandler
	
	Dim sInput As String
	Dim iPos As Integer
	Dim sLocation As String
	Dim lWait As Long
	Dim lDB As Long
	Dim sErr As String * 256
	Dim lResult As Long
	Dim lRows As Long
	Dim lCols As Long
	Dim vResults() As Variant
	Dim i, j As Integer
	Dim sResult As String
	Dim sCommand As String
	Dim sSQLiteResult As String
	
	Winsock1.GetData sInput, vbString, bytesTotal
    
	'Ignore HTTP header, and get body
	iPos = InStr(sInput, vbCrLf + vbCrLf)
	sInput = Mid$(sInput, iPos + 2)
	
	lDB = PSVBUTLS_OpenDB(sLocation, 0, sErr)
	If lDB = 0 Then
	    Err.Raise vbObjectError, , "Failed opening DB : " & sErr
	End If
	
	lWait = TimeToQuit(10)
	Do
		lResult = PSVBUTLS_ExecuteDB(lDB, sInput, lRows, lCols, vResults, sErr, False)
		PSVBUTLS_CloseDB (lDB)
		Select Case lResult
			Case SQLITE_OK
				sSQLiteResult = "OK"
				'================== Extract fields + rows, and generation reply
				'SELECT
				'vbTextCompare = ignore case
				If InStr(1, sInput, "SELECT", vbTextCompare) Then
				    'Check if array empty
				    'If empty, UBound(vResults, 1) -> CRASH!
				    If (Not vResults) = -1 Then
				        sResult = ""
				    Else
				    		'Array filled -> format as CSV
				        'field<TAB>field<CRLF>field<TAB>field<CRLF>
				        sResult = ""
				        For i = 0 To UBound(vResults, 1)
				            For j = LBound(vResults, 2) To UBound(vResults, 2)
				                sResult = sResult + vResults(i, j) + vbTab
				            Next j
				            'Remove tailing vbTab
				            sResult = Left(sResult, Len(sResult) - 1)
				            sResult = sResult + vbCrLf
				        Next i
				    End If
				'INSERT, UPDATE, etc.
				Else
				    'sResult = "Nothing to see here" & vbCrLf
				End If
				
				Exit Do
			Case SQLITE_BUSY
				'Wait
				'    'Sleep between 100 and 1000ms
				'    Sleep (Int((1000 - 100 + 1) * Rnd + 100))
			Case Else
				sSQLiteResult = "NOK"
				Exit Do
		End Select
		DoEvents
	Loop While lWait > Timer

	'================== Send HTTP header + body
	sOutput = "HTTP/1.1 200 OK" + vbCrLf
	sOutput = sOutput + "Connection: Close" + vbCrLf
	sOutput = sOutput + "SQLiteResult: " + sSQLiteResult + vbCrLf
	sOutput = sOutput + "Content-Length: " + CStr(Len(sResult)) + vbCrLf
	sOutput = sOutput + "Content-Type: text/html" + vbCrLf + vbCrLf
	sOutput = sOutput + sResult
	
	If Winsock1.State = sckConnected Then
		Winsock1.SendData sOutput
		'Async : transmission ends in SendComplete()
	End If
	
	Exit Sub
    
ErrHandler:
	MsgBox Err.Description, vbCritical, App.EXEName & "/In DataArrival : " & "Err #" & Err.Number
	PSVBUTLS_CloseDB (lDB)
	End

End Sub

Private Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
	Dim nFileNum As Integer
	
	Label1.Caption = "Err socket " & Number & ": " & Description
	nFileNum = FreeFile
	Open App.Path & "\err.txt" For Append As nFileNum
	Print #nFileNum, "Err socket " & Number & ": " & Description
	Close (nFileNum)
	
	Winsock1.Close ' close the erraneous connection
	DoEvents
	Winsock1.Listen ' listen again
End Sub

Private Sub Winsock1_SendComplete()
	On Error GoTo ErrHandler
	Winsock1.Close
	DoEvents
	Winsock1.Listen
	Exit Sub
	ErrHandler:
	MsgBox Err.Description, vbCritical, App.EXEName & "/In SendComplete : " & "Err #" & Err.Number

End Sub

Private Sub Winsock1_SendProgress(ByVal bytesSent As Long, ByVal bytesRemaining As Long)
	Label1.Caption = "Sent = " & bytesSent & ", Remaining = " & bytesRemaining
End Sub