script.cls

完整的主机服务器, (含代码).程序会监视联结到主机程序上的所有机器.可是设置开启端口,最多用户..非常完整.!

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "script"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Private code$(3000)
Private std$(1000), stn$(1000), ind(1000), inn$(1000)
Private gs(10) ' Gosub Stack
Private tots, toti As Long ' Total number of strings and integers
Private CURRENTSOCK As Integer ' Stores the current socket for subs/funcs which dont have it passed as one of their param

Private Const DB_EXTENDINFO = 0

Private file(10) As Integer ' File access numbers
Private filea(10) As Integer ' File access type

Public Sub Execute(sck As Integer, filename As String, postdata As String)
   'On Error Resume Next
   On Error GoTo Execute_Error
   CURRENTSOCK = sck
   tots = 1: toti = 1
   Dim DESTX%, DESTY%, SRCX%, SRCY%, RECTWIDTH%, RECTHEIGHT%
   Dim rtt$
   Dim p$(100)
   Dim w$(20)
   Dim cf As Integer
   Dim cv As Integer
   Dim dj As Integer
   Dim scr, iq As Boolean
   Dim lc, tx, a, b, SFA As Integer
   Dim ww As Integer
   Dim x As Integer
   Dim rt2 As Integer
   Dim rt3 As Integer
   Dim rt1 As Integer
   Dim h As Integer
   Dim pc As Long
   Dim ptemp$
   Dim cvalue As Integer
   Dim pre_op$
   Dim c_check$
   Dim ik As Integer
   Dim hl$
   Dim cc As Integer
   Dim c0x$
   Dim c2x$
   Dim ISTHISINT As Integer
   Dim StartTimer As Long
   Dim gg As Integer
   Dim xcz As Integer
   Dim IMGQUAL As Integer
   Dim tr1$, tr2$, tr3$
   Dim ts1%, ts2%, ts3%
   Dim INSIDEME%
   Dim ww1%, ww2%, ww3%, ww4%, ww5%, ww6%, ww7%, ww8% ' Database Command Variables
   
   StartTimer = Timer
   
   Erase code$(), std$(), stn$(), ind(), inn$(), gs()
   
   For t = 0 To 10
    If file(t) <> 0 Then Close file(t): filea(t) = 0
   Next t
   
   Erase file(), filea()
   
   ' Load The Script File
   
   dx = FreeFile
   lc = 0
   Open filename For Input As #dx
   Do Until EOF(dx)
      Line Input #1, code$(lc)
      code$(lc) = ReplaceStr(code$(lc), vbTab, "   ")
      lc = lc + 1
   Loop
   Close dx
   
    IMGQUAL = 80

   'Debug.Print postdata$
   
   postdata$ = ReplaceStr(Trim$(ReplaceStr(postdata$, vbCrLf, " ")), "&&", "&")
   
   If Right$(postdata$, 1) <> "&" Then postdata$ = postdata$ & "&"
   a = Len(postdata$)
   For b = 1 To a
      d$ = Mid$(postdata$, b, 1)
      If d$ = "&" And tmp$ <> "" Then
         c = InStr(tmp$, "=")
         If InStr(tmp$, "=") Then
            CreateString RidFormatting(Left$(tmp$, c - 1)), RidFormatting(Right$(tmp$, Len(tmp$) - c))
         End If
         tmp$ = ""
      End If
      If d$ <> "&" Then tmp$ = tmp$ & d$
   Next b
   
   ' Create Strings For Script To Access About Request
   CreateString "referer", sx(sck).Referer
   CreateString "requestip", frmmain.ws(sck).RemoteHostIP
   CreateString "requestport", frmmain.ws(sck).RemotePort
   CreateString "localport", frmmain.ws(sck).LocalPort
   CreateString "localip", frmmain.ws(sck).LocalIP
   
   
   
   ' Begin Parsing
   
   pc = 0
   scr = True
   
   SFA = 0
   If code$(0) = "//" & SERVER_SECURITY_TAG1$ And code$(1) = "//" & SERVER_SECURITY_TAG2$ Then SFA = 1
   
   If SFA = 1 Then CreateString "request", sx(sck).Header
   
   For tt = 0 To lc
      If LTrim$(LCase$(code$(tt))) = "proc main" Then pc = tt + 1: Exit For
   Next tt
   
   Do Until scr = False
      
      DoEvents
      
      If (Timer - StartTimer) > (Longbow.TimeOut / 10) Then scr = False
      
      cl$ = LTrim$(code$(pc))
      
      If Left$(cl$, 2) <> "//" And cl$ <> "" Then
        
         ' Only parse if the line is valid
         Erase w$()
         v$ = LTrim$(code$(pc)): c2 = Len(v$): xc = 0: dd = 0: iq = False
         
        For c1 = 1 To c2
            f$ = Mid$(v$, c1, 1)
            If f$ = "[" And iq = False Then INSIDEME = 1: f$ = ""
            If f$ = "]" And iq = False Then INSIDEME = 0: f$ = ""
            If f$ = "(" And iq = False And INSIDEME = 0 Then dd = dd + 1
            If f$ = ")" And iq = False And INSIDEME = 0 Then dd = dd - 1
            If f$ = " " And iq = False And dd = 0 Then xc = xc + 1
            If f$ = "'" Then iq = Not iq
            If iq = False And dd = 0 Then w$(xc) = w$(xc) & Trim$(f$)
            If iq = False And dd <> 0 Then w$(xc) = w$(xc) & f$
            If iq = True Then w$(xc) = w$(xc) & f$
         Next c1
          
         cmd$ = LCase$(w$(0)): xc = xc + 1
               
               If IsInteger(cmd$) = 1 Then
                  xx$ = ""
                  ww = 0
                  For t = 1 To xc
                     tturn = 1
                     If w$(t) = "+" Or w$(t) = "-" Or w$(t) = "*" Or w$(t) = "/" Then
                        xx$ = w$(t): tturn = 0
                     End If

                     If tturn = 1 Then
                        If xx$ = "+" Then ww = ww + Val(ParseParam(w$(t)))
                        If xx$ = "-" Then ww = ww - Val(ParseParam(w$(t)))
                        If xx$ = "/" Then ww = ww / Val(ParseParam(w$(t)))
                        If xx$ = "*" Then ww = ww * Val(ParseParam(w$(t)))
                        If xx$ = "^" Then ww = ww ^ Val(ParseParam(w$(t)))
                     End If
                     If xx$ = "" Then ww = ww + Val(ParseParam(w$(t)))
                  Next t

                  SetInteger cmd$, ww
               End If
               
               If cmd$ = "dec" Then
                  If IsInteger(w$(1)) = 1 Then
                     f = Val(w$(2))
                     If f = 0 Then f = 1
                     SetInteger w$(1), GetInteger(w$(1)) - f
                  End If
               End If
               
               If cmd$ = "inc" Then
                  If IsInteger(w$(1)) = 1 Then
                     f = Val(w$(2))
                     If f = 0 Then f = 1
                     SetInteger w$(1), GetInteger(w$(1)) + f
                  End If
               End If
               
               If cmd$ = "strtoint" Then
                  If IsString(w$(1)) = 1 Then
                     If IsInteger(w$(2)) = 1 Then
                        SetInteger w$(2), Val(GetString(w$(1)))
                     End If
                  End If
                  GoTo WIPEOUT
               End If
               
               If cmd$ = "inttostr" Then
                  If IsInteger(w$(1)) = 1 Then
                     If IsString(w$(2)) = 1 Then
                        SetString w$(2), Trim$(Str$(GetInteger(w$(1))))
                     End If
                  End If
                  GoTo WIPEOUT
               End If
               
               If cmd$ = "fwrite" Then
                  If file(Val(w$(1))) <> 0 Then
                     Print #file(Val(w$(1))), ParseParam(w$(2))
                  End If
                  GoTo WIPEOUT
               End If
               
'DeleteEntry(databasefilename, fieldname, fielddata As String) As Integer
'GetNumOfDatabaseFields(databasefilename As String) As Integer
'GetFieldNames(databasefilename As String) As String
'GetFieldName(databasefilename As String, fieldnumber) As String
'GetEntry(databasefilename As String, entrynumber As Integer, fieldname As String) As String
'EntryExist(databasefilename As String, fieldname As String, fielddata As String, comparisontype As String) As Integer
'ReplaceEntry(databasefilename As String, findfieldname As String, findfielddata As String, findfieldcomparison As String, changefieldname As String, changefielddata As String) As Integer
'GetEntryNum(databasefilename As String, startent As Integer, fieldname As String, fielddata As String, fieldcomparison As String) As Long
'CreateDatabase(databasefilename As String, numfields As String, fieldnames As String) As Integer
'AddEntry(databasefilename As String, fielddata As String) As Long
               
               If cmd$ = "database" Then
                    ' w$(4) = databasefilename, constant for all subfunctions
                    ' w$(3) = variable
                    w$(2) = ParseParam(w$(2)): ww2 = Val(w$(2))
                    w$(3) = ParseParam(w$(3)): ww3 = Val(w$(3))
                    w$(4) = ParseParam(w$(4)): ww4 = Val(w$(4))
                    w$(5) = ParseParam(w$(5)): ww5 = Val(w$(5))
                    w$(6) = ParseParam(w$(6)): ww6 = Val(w$(6))
                    w$(7) = ParseParam(w$(7)): ww7 = Val(w$(7))
                    w$(8) = ParseParam(w$(8)): ww8 = Val(w$(8))

                    w$(3) = GetDirectory(filename$) & w$(3)
                
                
                If DB_EXTENDINFO = 1 Then
                    WXB sck, "<html><body><pre>"
                    WXB sck, "-- Database Request Extended Information --<br>"
                    WXB sck, "1" & w$(1) & "<br>"
                    WXB sck, "2" & w$(2) & "<br>"
                    WXB sck, "3" & w$(3) & "<br>"
                    WXB sck, "4" & w$(4) & "<br>"
                    WXB sck, "5" & w$(5) & "<br>"
                    WXB sck, "6" & w$(6) & "<br>"
                    WXB sck, "7" & w$(7) & "<br>"
                    WXB sck, "8" & w$(8) & "<br>"
                    WXB sck, "    ---------------</pre>"
                End If
                    ' w$(1) = database command
                    ' w$(2) = database file
                    
                    
                    
                    If InStr(w$(2), "..") Then
                        WXB sck, "Script security prevented this script from being executed"
                        sx(sck).Reqok = True
                        GoTo WIPEOUT
                    End If
                    
                    ' Big wedge of database code :D

                  If DB_EXTENDINFO = 1 Then Debug.Print w$(1)
                    
                    Select Case w$(1)
                        Case "deleteentry"
                            
                            SetInteger w$(2), DeleteEntry(w$(3), w$(4), w$(5))
                        Case "getnumofdbfields"
                            
                            SetInteger w$(2), GetNumOfDatabaseFields(w$(3))
                        Case "getfieldnames"

                            SetString w$(2), GetFieldNames(w$(3))
                        Case "getfieldname"

                            SetString w$(2), GetFieldName(w$(3), ww4)
                        Case "getentry"

                            SetString w$(2), GetEntry(w$(3), ww4, w$(5))
                        Case "entryexist"

                            SetInteger w$(2), EntryExist(w$(3), w$(4), w$(5), w$(6))
                        Case "replaceentry"

                            SetInteger w$(2), ReplaceEntry(w$(3), w$(4), w$(5), w$(6), w$(7), w$(8))
                        Case "getentrynum"

                            SetInteger w$(2), GetEntryNum(w$(3), ww4, w$(5), w$(6), w$(7))
                        Case "createdatabase"

                            SetInteger w$(2), CreateDatabase(w$(3), w$(4), w$(5))
                        Case "addentry"
                            'Debug.Print "w$(3)=" & w$(3)
                            'Debug.Print "w$(4)=" & w$(4)
                            SetInteger w$(2), AddEntry(w$(3), w$(4))
                    End Select
               End If
               
               
               If cmd$ = "fmread" Then
                  ' Multi Param Read
                  If file(Val(w$(1))) <> 0 Then
                     Line Input #file(Val(w$(1))), xtm$
                     Erase p$()
                     df = 0: cv = 1
                     dj = Len(xtm$)
                     For h = 1 To dj
                        hi$ = Mid$(xtm$, h, 1)
                        If hi$ = "," Then
                           hi$ = "": cv = cv + 1
                        End If
                           p$(cv) = p$(cv) + hi$

                     Next h
                    ' Debug.Print cv
                     For h = 1 To cv