asp XmlCache缓存类

<%
Class XmlCache

     Private xmlDoc'//内部xml对象
     Private isLoaded'//是否已经加载xml文档

     Private xFile'//加载进来的xml文件(包括路径)
     Private xTitle
     Private xCreator
     Private xDateCreated
     Private xLastUpdate
     Private xDescription
     Private xEncoding

     Private itemTemp'//保存item节点的xml摸板

     Public   IsAutoUpdate'//当在内存中修改xml时是否自动更新到该xml文件,默认是否False

     Private Sub Class_Initialize()
         Set xmlDoc=getXmlObj()
     xTitle=""
     xCreator=""
     xDateCreated=Now()
     xLastUpdate=Now()
     xDescription=""
     xEncoding="GB2312"
     isLoaded=False
     IsAutoUpdate=False
     'itemTemp=vbcrlf&vbcrlf
     itemTemp=itemTemp&"         <Item>"&vbcrlf
     itemTemp=itemTemp&"             <Key>{key}</Key>"&vbcrlf
     itemTemp=itemTemp&"             <CreatedTime>{createdtime}</CreatedTime>"&vbcrlf
     itemTemp=itemTemp&"             <Expires>{expires}</Expires>"&vbcrlf
     itemTemp=itemTemp&"             <Value>"&vbcrlf
     itemTemp=itemTemp&"             <![CDATA[{value}]]>"&vbcrlf
     itemTemp=itemTemp&"             </Value>"&vbcrlf
     itemTemp=itemTemp&"         </Item>"&vbcrlf
     End Sub
     Private Sub Class_Terminate()
         Set xmlDoc=Nothing
     End Sub

     '返回整个xml文档内容，只读
     Public Property Get Xml
         Xml=xmlDoc.Xml
     End Property

     '//Title节点
     Public Property Get Title
         On Error Resume Next
         If isLoaded Then
         xTitle=xmlDoc.selectSingleNode("/XmlCache/Title").Text
     End If
     If Err Then showErr "节点/XmlCache/Title不存在"
         Title=xTitle
     End Property
     Public Property Let Title(v)
         xTitle=v
     On Error Resume Next
         If isLoaded Then
         xmlDoc.selectSingleNode("/XmlCache/Title").Text=xTitle
     End If
     If Err Then showErr "节点/XmlCache/Title不存在"
     End Property

     '//Creator节点
     Public Property Get Creator
         On Error Resume Next
         If isLoaded Then
         xCreator=xmlDoc.selectSingleNode("/XmlCache/Creator").Text
     End If
     If Err Then showErr "节点/XmlCache/Creator不存在"
     Creator=xCreator
     End Property
     Public Property Let Creator(v)
         xCreator=v
     On Error Resume Next
         If isLoaded Then
         xmlDoc.selectSingleNode("/XmlCache/Creator").Text=xCreator
     End If
     If Err Then showErr "节点/XmlCache/Creator不存在"
     End Property

     '//DateCreated节点
     Public Property Get DateCreated
         On Error Resume Next
         If isLoaded Then
         xDateCreated=xmlDoc.selectSingleNode("/XmlCache/DateCreated").Text
     End If
     If Err Then showErr "节点/XmlCache/DateCreated不存在"
         DateCreated=xDateCreated
     End Property
     Public Property Let DateCreated(v)
         xDateCreatede=v
     On Error Resume Next
         If isLoaded Then
         xmlDoc.selectSingleNode("/XmlCache/DateCreated").Text=xDateCreated
     End If
     If Err Then showErr "节点/XmlCache/DateCreated不存在"
     End Property

     '//LastUpdate节点
     Public Property Get LastUpdate
         On Error Resume Next
         If isLoaded Then
         xLastUpdate=xmlDoc.selectSingleNode("/XmlCache/LastUpdate").Text
     End If
     If Err Then showErr "节点/XmlCache/LastUpdate不存在"
         LastUpdate=xLastUpdate
     End Property
     Public Property Let LastUpdate(v)
         xLastUpdate=v
     On Error Resume Next
         If isLoaded Then
         xmlDoc.selectSingleNode("/XmlCache/LastUpdate").Text=xLastUpdate
     End If
     If Err Then showErr "节点/XmlCache/LastUpdate不存在"
     End Property

     '//Description节点
     Public Property Get Description
         On Error Resume Next
         If isLoaded Then
         xDescription=xmlDoc.selectSingleNode("/XmlCache/Description").Text
     End If
     If Err Then showErr "节点/XmlCache/Description不存在"
         Description=xDescription
     End Property
     Public Property Let Description(v)
         xDescription=v
     On Error Resume Next
         If isLoaded Then
         xmlDoc.selectSingleNode("/XmlCache/Description").Text=xDescription
     End If
     If Err Then showErr "节点/XmlCache/Description不存在"
     End Property

     '//Encoding
     Public Property Get Encoding
         On Error Resume Next
         If isLoaded Then
         xEncoding=xmlDoc.selectSingleNode("/XmlCache/Encoding").Text
     End If
     If Err Then showErr "节点/XmlCache/Encoding不存在"
         Encoding=xEncoding
     End Property
     Public Property Let Encoding(v)
         xEncoding=v
     On Error Resume Next
         If isLoaded Then
         xmlDoc.selectSingleNode("/XmlCache/Encoding").Text=xEncoding
     End If
     If Err Then showErr "节点/XmlCache/Encoding不存在"
     End Property

     '//Item节点,设置或返回该缓存的值,可读写
     '//如果该值不存在则返回null值
     Public Default Property Get Item(key)
         Dim itemObj,k
     key=LCase(key)
     Set itemObj=xmlDoc.selectSingleNode("/XmlCache/Items/Item")
     For Each k In itemObj
         If k.childNodes.item(0).text=key Then
             Item=k.childNodes.item(3).text'缓存值
         Set itemObj=Nothing
         Exit Property
         End If
     Next
     Item=Null
     Set itemObj=Nothing
     End Property
     Public Property Let Item(key,v)
         Dim itemObj,k
     key=LCase(key)
     Set itemObj=xmlDoc.selectSingleNode("/XmlCache/Items/Item")
     On Error Resume Next
     For Each k In itemObj
         If k.childNodes.item(0).text=key Then
             k.childNodes.item(3).text=v'缓存值
         If Err Then
             showErr"缓存值不是有效的字符串"
             Set itemObj=Nothing
             Exit Property
         End If
         Set itemObj=Nothing
         Call Save()
         Exit Property
         End If
     Next
     Item=Null
     Set itemObj=Nothing
     Call Save()
     End Property

     '//某个缓存的所有属性：名称，创建时间，过期时间截，值
     '//如果不存在则返回一个空值的数组
     Public Property Get ItemInfo(key)
         Dim itemObj,infoArr(3),i
     key=LCase(key)
     Set itemObj=xmlDoc.getElementsByTagName("Item")
     For i=0 To itemObj.length-1
         If itemObj.item(i).childNodes.item(0).text=key Then
             infoArr(0)=itemObj.item(i).childNodes.item(0).text'缓存名称
         infoArr(1)=itemObj.item(i).childNodes.item(1).text'创建时间
         infoArr(2)=itemObj.item(i).childNodes.item(2).text'过期时间截
         infoArr(3)=itemObj.item(i).childNodes.item(3).text'缓存值
         End If
     Next
     Set itemObj=Nothing
     ItemInfo=infoArr
     End Property

     '//返回所有的缓存名称，组成一个数组,只读
     Public Property Get Keys()
         Dim keyObj,keyArr,i
     Set keyObj=xmlDoc.getElementsByTagName("Key")
     keyArr=Array()
     Redim keyArr(keyObj.length-1)
     For i=0 To keyObj.length-1
         keyArr(i)=keyObj.item(i).text
     Next
     Keys=keyArr
     Erase keyArr
     Set keyObj=Nothing
     End Property

     '//返回所有缓存的数组,只读
     Public Property Get Items()
         Dim itemArr,itemInfoArr,itemObj,i
     Set itemObj=xmlDoc.getElementsByTagName("Item")
     itemArr=Array()
     ReDim itemArr(itemObj.length-1,3)
     For i=0 To itemObj.length-1
         itemArr(i,0)=itemObj.item(i).childNodes.item(0).text'缓存名称
         itemArr(i,1)=itemObj.item(i).childNodes.item(1).text'创建时间
         itemArr(i,2)=itemObj.item(i).childNodes.item(2).text'过期时间截
         itemArr(i,3)=itemObj.item(i).childNodes.item(3).text'缓存值
     Next
     Set itemObj=Nothing
     Items=itemArr
     Erase itemArr
     End Property

     '//缓存个数,只读
     Public Property Get Count
         Count=xmlDoc.getElementsByTagName("Item").Length
     End Property
    
     '/------------------------------------------------------

     '//加载一份xml文档
     Public Sub Load(xmlFile)
         On Error Resume Next
     xmlDoc.Load(xmlFile)
     xFile=xmlFile
     If Err Then showErr "加载xml文档失败,Load(xmlFile),xmlfile:"&xmlFile
     isLoaded=True
     End Sub

     '//创建一份xml文档
     Public Sub Create(xmlFile)
         Dim xmlText,newXmlDoc
     If xEncoding="" Then xEncoding="GB2312"
     xDateCreated=Now()
     xLastUpdate=Now()
     xmlText="<?xml version=""1.0"" encoding="""&Encoding&"""?>"&vbcrlf
     xmlText=xmlText&"<XmlCache>"&vbcrlf
     xmlText=xmlText&"     <Title>"&Title&"</Title>"&vbcrlf
     xmlText=xmlText&"     <Creator>"&Creator&"</Creator>"&vbcrlf
     xmlText=xmlText&"     <DateCreated>"&CreatedTime&"</DateCreated>"&vbcrlf
     xmlText=xmlText&"     <LastUpdate>"&LastUpdate&"</LastUpdate>"&vbcrlf
     xmlText=xmlText&"     <Description>"&Description&"</Description>"&vbcrlf
     xmlText=xmlText&"     <Encoding>"&Encoding&"</Encoding>"&vbcrlf
     xmlText=xmlText&"     <Items>"&vbcrlf
     xmlText=xmlText&"     </Items>"&vbcrlf
     xmlText=xmlText&"</XmlCache>"&vbcrlf

     Set newXmlDoc=getXmlObj()
     On Error Resume Next
     newXmlDoc.LoadXml(xmlText)
     newXmlDoc.Save xmlFile
     If Err Then showErr "创建xml文档失败,Create(xmlFile),xmlfile:"&xmlFile
     Set newXmlDoc=Nothing
     End Sub

     '//保存一份xml文档
     Public Sub Save()
         On Error Resume Next
         xmlDoc.Save xFile
     If Err Then showErr "保存xml文档失败,Save(),xmlfile:"&xmlFile
     End Sub

     '//保存一份xml文档，文件名为xmlFile(全路径)
     Public Sub SaveAs(xmlFile)
         On Error Resume Next
         xmlDoc.Save xmlFile
     If Err Then showErr "保存xml文档失败,SaveAs(xmlFile),xmlfile:"&xmlFile
     End Sub

     '//删除xml文档
     Public Sub DeleteFile()
     End Sub

     '//检查缓存xml文档是否存在某个key,返回true或false
     '//检查一个缓存是否存在
     Public Function Exists(key)
     Dim itemObj,k
     key=LCase(key)
     Set itemObj=xmlDoc.selectNodes("/XmlCache/Items/Item/Key")
     For Each k In itemObj
         If k.text=key Then Exists=True:Exit Function
     Next
     Exits=Flase
     End Function

     '//添加一个缓存,失败返回false(比如：已经存在该key),成功返回true
     Public Sub Add(key,value)
         If key="" Then showErr"添加缓存失败,Add(key,value),key不能为空":Exit Sub
     If Exists(key) Then showErr"添加缓存失败,Add(key,value),该key已经存在":Exit Sub

         Dim itemsObj,itemObj,temp
     key=LCase(key)
     Set itemsObj=xmlDoc.documentElement.getElementsByTagName("Items")
     If   itemsObj.length>0 Then
         temp=itemTemp
         temp=Replace(temp,"{key}",key):temp=Replace(temp,"{value}",value)
         temp=Replace(temp,"{createdtime}",Now()):temp=Replace(temp,"{expires}",60*20)
         Set itemObj=getXmlObj()
         itemObj.loadXml(temp)
         Set itemObj=itemObj.documentElement.cloneNode(true)'//复制节点
         itemsObj.item(0).appendChild itemObj
         Call Save()
         Set itemObj=Nothing
     Else
         showErr "添加缓存失败,Add(key,value),/XmlCache/Items节点不存在"
     End If
     Set ItemObj =Nothing
     Set itemsObj=Nothing
     End Sub

     '//添加一个缓存，包括名称，值，过期时间
     Public Sub AddFull(key,value,s)
         If key="" Then showErr"添加缓存失败,AddFull(key,value,s),key不能为空":Exit Sub
     If Not IsNumeric(s) Then showErr"添加缓存失败,AddFull(key,value,s),过期时间截s只能为数字":Exit Sub
     If Exists(key) Then showErr"添加缓存失败,AddFull(key,value,s),该key已经存在":Exit Sub
         Dim itemsObj,temp,xmlText,L
     key=LCase(key)
     Set itemsObj=xmlDoc.documentElement.getElementsByTagName("Items")
     If   itemsObj.length>0 Then
         temp=itemTemp
         temp=Replace(temp,"{key}",key):temp=Replace(temp,"{value}",value)
         temp=Replace(temp,"{createdtime}",Now()):temp=Replace(temp,"{expires}",s)
         Set itemObj=getXmlObj()
         itemObj.loadXml(temp)
         Set itemObj=itemObj.documentElement.cloneNode(true)'//复制节点
         itemsObj.item(0).appendChild itemObj
         Call Save()
         Set itemObj=Nothing
     Else
         showErr "添加缓存失败,AddFull(key,value,s),/XmlCache/Items节点不存在"
     End If
     Set itemsObj=Nothing
     End Sub

     '//更新一个缓存值,如果缓存存在并更新成功返回True,否则返回False
     Public Function Update(key,value)
         Dim nodeItems,valueItems,i
     key=LCase(key)
     Set nodeItems=xmlDoc.getElementsByTagName("Key")
     Set valueItems =xmlDoc.getElementsByTagName("Value")
     On Error Resume Next
     For i = 0 To nodeItems.length - 1
         If nodeItems(i).text=key Then
             valueItems(i).text=value
         If Err Then
             showErr "更新缓存失败,Update(key,value),Value节点不存在"
             Update=False
             Exit Function
         End If
             Update=True
         Call xUpdate()
         Exit Function
         End If
     Next
     Set nodeItems=Nothing
     Set valueItems=Nothing
     Update=False
     End Function

     '//更新一个缓存的过期时间,如果缓存存在并更新成功返回True,否则返回False
     Public Function UpdateExpires(key,s)
         If Not IsNumeric(s) Then
         showErr"更新缓存错误,UpdateTimeOut(key,s),过期时间截s只能为数字"
         UpdateExpires=False
         Exit Function
     End If
         Dim nodeItems,expiresItems,i
     key=LCase(key)
     Set nodeItems=xmlDoc.getElementsByTagName("Key")
     Set expiresItems=xmlDoc.getElementsByTagName("Expires")
     On Error Resume Next
     For i = 0 To nodeItems.length - 1
         If nodeItems(i).text=key Then
             expiresItems(i).text=s
         If Err Then
             showErr "更新缓存失败,UpdateTimeOut(key,value),Expires节点不存在"
             UpdateExpires=False
             Exit Function
         End If
             UpdateExpires=True
         Call xUpdate()
         Exit Function
         End If
     Next
     Set nodeItems=Nothing
     Set expiresItems=Nothing
     UpdateExpires=False
     End Function

     '//检查一个缓存是否已经过期,是返回True,否返回False
     Public Function CheckExpires(key)
         Dim keyObj,createdObj,expiresObj,i,s1,s2,s3
     Set keyObj=xmlDoc.getElementsByTagName("Key")
     Set createdObj=xmlDoc.getElementsByTagName("CreatedTime")
     Set expiresObj=xmlDoc.getElementsByTagName("Expires")
    
     For i=0 To keyObj.length-1
         s1=keyObj.item(i).text
         s2=createdObj.item(i).text
         s3=expiresObj.item(i).text
         If s1=key And IsDate(s2) And IsNumeric(s3) Then
             If DateDiff("s",s1,Now())>CDbl(s2) Then
             CheckExpires=True
             Set keyObj=Nothing
             Set createdObj=Nothing
                 Set expiresObj=Nothing
             Exit Function
         End If
         End If
     Next
     Set keyObj=Nothing
     Set createdObj=Nothing
     Set expiresObj=Nothing
     CheckExpires=False
     End Function

     '//Remove(key)删除一个缓存,如果该缓存名称存在而且成功删除则返回True否则返回False
     Public Function Remove(key)
         Dim keyObj,k
     key=LCase(key)
     Set keyObj=xmlDoc.getElementsByTagName("Key")
     For Each k In keyObj
         If k.text=key Then
         k.parentNode.parentNode.removeChild(k.parentNode)
         Remove=True
         Set keyObj=Nothing
         Exit Function
         End If
     Next
     Remove=False
     Set keyObj=Nothing
     Call xUpdate()'//重新保存到文件
     End Function

     '//删除所有缓存,返回True或False
     Public Function RemoveAll()
         Dim itemsObj
     Set itemsObj=xmlDoc.getElementsByTagName("Items")
     If itemsObj.length=1 Then
         itemsObj(0).text=""
         RemoveAll=True
     Else
         RemoveAll=False
     End If
     Set itemsObj=Nothing
     Call xUpdate()'//重新保存到文件
     End Function

     '//删除所有过期的缓存,返回True或False(表示没有过期的缓存)                    
     Public Function DeleteAll()
         Dim createdObj,expiresObj,isHave,i
     isHave=False'//是否有过期的缓存
     Set createdObj=xmlDoc.getElementsByTagName("CreatedTime")
     Set expiresObj=xmlDoc.getElementsByTagName("Expires")
    
     For i=0 To expiresObj.length-1
         If IsDate(createdObj.item(i).text) And IsNumeric(expiresObj.item(i).text) Then
             If DateDiff("s",createdObj.item(i).text,Now())>CDbl(expiresObj.item(i).text) Then
             createdObj.item(i).parentNode.parentNode.removeChild(createdObj.item(i).parentNode)
             isHave=True
         End If
         End If
     Next
     Set createdObj=Nothing
     Set expiresObj=Nothing
     DeleteAll=isHave
     Call xUpdate()'//重新保存到文件
     End Function

     '//显示错误
     Private Sub showErr(info)
         If Err Then info=info&","&Err.Description
         Response.Write info
     Err.Clear
     Response.End
     End Sub

     '//取得xml对象
     Private Function getXmlObj()
         On Error Resume Next
         Set getXmlObj=Server.CreateObject("Microsoft.XMLDOM")
     If Err Then showErr "创建xml对象失败"
     End Function

     '//更新一份xml文档
     Private Sub xUpdate()
         If IsAutoUpdate Then Call Save()
     End Sub

     '------------------------------------------------------/
End Class

%>

♡ 点赞 0

☆ 收藏 0

留言区（共0条）