memory

来自「WAPmo手机网站管理平台是一款创建与管理维护WAP网站的的软件产品」· 代码 · 共 221 行

Private MyDB, objCmd
Private clsHash
Private strTableName
Private strMemName
Private strMemID
Private strIPAddr
Private strRnd, lngStamp
Private lngExpires
Private blnInit, blnModify
Private lngTimeout
Private lngTimeDiff

Private Sub Class_Initialize()
    Set MyDB = Nothing
    Set clsHash = Server.CreateObject(PROGID_HASH)
    strMemName = "MID"
    strMemID = Request.Cookies(strMemName)
    If strMemID = "" Then
        strMemID = Request.QueryString(strMemName)
        If strMemID <> "" Then
            Response.Cookies(strMemName) = strMemID
        End If
    End If
    strIPAddr = Request.ServerVariables("REMOTE_ADDR")
    lngExpires = 0
    lngTimeout = 20
    lngTimeDiff = 5
    blnInit = False
    blnModify = False
End Sub

Private Sub Class_Terminate()
    If blnModify = True Then
        If clsHash.Count < 0 Then
            Call Abandon
        ElseIf lngExpires < 0 Then
            Call Abandon
        Else
            Call SaveMemory
        End If
    End If
    Call Clear
    Set objCmd = Nothing
    Set clsHash = Nothing
    Set MyDB = Nothing
End Sub

Public Property  Let Implement(ByVal clsImpl)
    Set MyDB = clsImpl
End Property

Public Property Let Table(ByVal strName)
    strTableName = strName
End Property

Private Sub Check()
    If blnInit Then Exit Sub
    blnInit = True
    Set objCmd = vbsre.mocom.util.Command.newInstance()
    objCmd.Implement = MyDB
    objCmd.Table = strTableName
    If strMemID = "" Then
        Call MakeNewMemory
    ElseIf Not CheckMemory() Then
        Call MakeNewMemory
    ElseIf Not ValidMemory() Then
        Call Abandon
        Call MakeNewMemory
    End If
End Sub

Public Property Let Expires(ByVal lngMin)
    Call Check
    If lngMin < 0 Then
        Call Abandon
    Else
        lngExpires = lngMin
        Response.Cookies(strMemName).Expires = DateAdd("n", lngExpires, Now())
    End If
End Property

Public Property Let Path(ByVal strPath)
    Call Check
    Response.Cookies(strMemName).Path = strPath
End Property

Public Property Let Timeout(ByVal lngMin)
    Call Check
    lngTimeout = lngMin
End Property

Public Default Property Get Item(ByVal strKey)
    Call Check
    Item = clsHash(LCase(strKey))
End Property

Public Property Let Item(ByVal strKey, ByVal vtValue)
    Call Check
    clsHash(LCase(strKey)) = vtValue
    blnModify = True
End Property

Public Property Get Keys()
    Call Check
    Keys = clsHash.Keys
End Property

Public Property Get Items()
    Call Check
    Items = clsHash.Items
End Property

Public Property Get MemoryID()
    Call Check
    MemoryID = strMemID
End Property

Private Sub MakeNewMemory()
    lngStamp = GetTime(Now())
    strRnd = GetRandom(MEMORY_LENGTH)
    strMemID = Hex(lngStamp) & strRnd
    Response.Cookies(strMemName) = strMemID
End Sub

Private Function CheckMemory()
    CheckMemory = False
    If Len(strMemID) <> MEMORY_LENGTH + 8 Then Exit Function
    lngStamp = atol("&H" & Mid(strMemID, 1, 8))
    strRnd = Mid(strMemID, 9)
    If lngStamp <= 0 Or lngStamp >= GetTime(Now()) Then Exit Function
    CheckMemory = reg_test("[a-zA-Z0-9]{24}", "", strRnd)
End Function

Private Function ValidMemory()
    Dim lngTime, lngLastVisit
    Dim strSQL
    Dim blnRet
    objCmd.CommandType = "SELECT"
    objCmd.Where = "MEMID='" & SafeString(strMemID) & "'"
    If Not objCmd.Exec Then
        blnRet = True
    ElseIf objCmd("inip") <> strIPAddr Then
        blnRet = False
    ElseIf objCmd("memory") = "" Then
        blnRet = False
    Else
        If objCmd("outime") = 0 Then
            lngLastVisit = objCmd("intime")
        Else
            lngLastVisit = objCmd("outime")
        End If
        lngTime = GetTime(Now())
        HashAdd clsHash, objCmd("memory"), "|"
        lngExpires = objCmd("expires")
        If objCmd("timeout") > 0 Then lngTimeout = objCmd("timeout")
        If lngExpires > 0 And lngTime - lngLastVisit > MToSEC(lngExpires) Then
            blnRet = False
        ElseIf lngExpires = 0 And lngTime - lngLastVisit > MToSEC(lngTimeout) Then
            blnRet = False
        Else
            blnRet = True
        End If
        If blnRet And lngTime - lngLastVisit > MToSEC(lngTimeDiff) Then
            blnModify = True
            If lngExpires > 0 Then
                Response.Cookies(strMemName) = strMemID
                Response.Cookies(strMemName).Expires = DateAdd("n", lngExpires, Now())
            End If
        End If
    End If
    ValidMemory = blnRet
End Function

Private Sub SaveMemory()
    If objCmd("memid") = "" Then
        objCmd.CommandType = "INSERT"
        objCmd.Add "memid", strMemID
        objCmd.Add "memory", HashString(clsHash, "|")
        objCmd.Add "expires", lngExpires
        objCmd.Add "timeout", lngTimeout
        objCmd.Add "inip", strIPAddr
        objCmd.Add "intime", GetTime(Now())
        objCmd.Exec
    Else
        objCmd.CommandType = "UPDATE"
        objCmd.Where = "memid='" & SafeString(strMemID) & "'"
        objCmd.Add "memory", HashString(clsHash, "|")
        objCmd.Add "expires", lngExpires
        objCmd.Add "timeout", lngTimeout
        objCmd.Add "outime", GetTime(Now())
        objCmd.Exec
    End If
End Sub

Public Sub Abandon()
    Call Check
    Dim strSQL
    strSQL = "DELETE FROM $(Table) WHERE MEMID='$(MemID)'"
    strSQL = Replace(strSQL, "$(Table)", strTableName)
    strSQL = Replace(strSQL, "$(MemID)", strMemID)
    MyDB.Exec strSQL
    clsHash.RemoveAll
    objCmd.Clear
End Sub

Private Sub Clear()
    Dim strName, strSQL
    Dim dtmNow
    strName = "Memory.Timestamp"
    dtmNow = Now()
    If IsEmpty(GetCache(strName)) Then
        SetCache strName, dtmNow
    ElseIf DateDiff("d", GetCache(strName), dtmNow) > 1 Then
        strSQL = "DELETE FROM $(Table) WHERE OUTIME<$(Timeval)-EXPIRES*60"
        strSQL = Replace(strSQL, "$(Table)", strTableName)
        strSQL = Replace(strSQL, "$(Timeval)", GetTime(dtmNow))
        MyDB.Exec strSQL
        SetCache strName, dtmNow
    End If
End Sub