文章说明.txt

xml缓存类试用版用于ASP

		Set f = Nothing
		Set fso = Nothing 
	End Function 


	Rem 判断xml缓存是否到期
	Private Function isXmlCacheExpired(file,seconds)
		Dim filelasttime
		filelasttime = FSOGetFileLastModifiedTime(file)
		If DateAdd("s",seconds,filelasttime) < Now Then
			isXmlCacheExpired = True 
		Else
			isXmlCacheExpired = False
		End If 
	End Function

	Rem 文件是否存在
	Private Function FSOExistsFile(file)
		Dim fso
		Set fso = Server.CreateObject("Scripting.FileSystemObject")
		If fso.FileExists(file) Then
			FSOExistsFile = true
		Else
			FSOExistsFile = false
		End If 
		Set fso = nothing
	End Function 
	

	Rem 生成详细数据的xml
	Private Function CreateContentXmlFile(xmlfile,Rs)
		Dim xmlcontent
		xmlcontent = "<?xml version=""1.0"" encoding=""gb2312""?>" & vbnewline
		xmlcontent = xmlcontent & "<root>" & vbnewline
		
		Dim field
		For Each field In rs.Fields
			xmlcontent = xmlcontent & "<"&field.name&">"
			Dim value
			value = field.value
			If TypeName(value) = "String" Then 
				xmlcontent = xmlcontent & "<![CDATA[" & Trim(value) & "]]>"
			Else
				xmlcontent = xmlcontent &  Trim(value) 
			End If 
			xmlcontent = xmlcontent & "</"&field.name&">" & vbnewline
		Next 
		rs.close
		Set rs = Nothing 
		xmlcontent = xmlcontent & "</root>" & vbnewline
		
		Dim folderpath
		folderpath = Trim(left(xmlfile,InstrRev(xmlfile,"\")-1))
		Call CreateDIR(folderpath&"") '创建文件夹
		WriteStringToXMLFile xmlfile,xmlcontent	
	End Function 


	Rem 生成列表的xml
	Private Function CreateListAndSearchXMLFile(xmlfile,TotalRec,Rs,sPagesize)
		Dim xmlcontent
		xmlcontent = ""
		xmlcontent = xmlcontent & "<?xml version=""1.0"" encoding=""gb2312""?>" & vbnewline
		xmlcontent = xmlcontent & " <root>" & vbnewline
		xmlcontent = xmlcontent & "  <totalrec>" & TotalRec & "</totalrec>" & vbnewline

		Dim k
		k = 0
		Dim field
		While Not rs.eof and k<sPagesize
			xmlcontent = xmlcontent & "  <item "
			For Each field In rs.Fields
				xmlcontent = xmlcontent & field.name & "=""" & XMLStringEnCode(field.value) & """ "
			Next 
			xmlcontent = xmlcontent &  "></item>" & vbnewline
			rs.movenext
			k=k+1
		Wend 
		rs.close
		Set rs = Nothing 
		xmlcontent = xmlcontent & " </root>" & vbnewline
		Dim folderpath
		folderpath = Trim(left(xmlfile,InstrRev(xmlfile,"\")-1))
		Call CreateDIR(folderpath&"") '创建文件夹
		WriteStringToXMLFile xmlfile,xmlcontent
	End Function 

	Rem xml转义字符
	Private Function XMLStringEnCode(str)
		If str&"" = "" Then XMLStringEnCode="":Exit Function
		str = Replace(str,"<","&lt;")
		str = Replace(str,">","&gt;")
		str = Replace(str,"'","&apos;")
		str = Replace(str,"""","&quot;")
		str = Replace(str,"&","&amp;")
		XMLStringEnCode = str
	End Function 
	Rem 写文件
	Private Sub WriteStringToXMLFile(filename,str)
		'On Error Resume Next 
		Dim fs,ts
		Set fs= createobject("scripting.filesystemobject")
		If Not IsObject(fs) Then Exit Sub 		
		Set ts=fs.OpenTextFile(filename,2,True)
		ts.writeline(str)
		ts.close
		Set ts=Nothing
		Set fs=Nothing
	End Sub 


	Rem 创建文件夹
	Private function CreateDIR(byval LocalPath)
		On  Error  Resume  Next 
		Dim i,FileObject,patharr,path_level,pathtmp,cpath
		LocalPath = Replace(LocalPath,"\","/")
		Set  FileObject = server.createobject("Scripting.FileSystemObject")
		patharr = Split(LocalPath,"/")
		path_level = UBound (patharr)
		For  i = 0 To  path_level
			If  i=0 Then  
				pathtmp=patharr(0) & "/" 
			Else  
				pathtmp = pathtmp & patharr(i) & "/"
			End If 
			cpath = left(pathtmp,len(pathtmp)-1)
			If  Not  FileObject.FolderExists(cpath) Then 
				'Response.write cpath
				FileObject.CreateFolder cpath
			End  If 
		Next 
		Set  FileObject = Nothing 
		If  err.number<>0 Then 
			CreateDIR = False 
			err.Clear
		Else 
			CreateDIR = True 
		End  If 
	End  Function 
End Class 
%>


此类包含两种缓存方式：一种是基于列表方式的，如按照某个类别显示信息、搜索某个关键词进行显示；另外一种是详细页面的缓存，如显示具体的某篇文章。
此类与具体的业务逻辑无关，只负责xml数据的读取和存储，判断是否缓存过期决定是否需要更新缓存。按照三层构架模式的话，它处于数据访问层。


调用这个类的代码：
Business.asp
<%
Rem xml数据缓存类业务逻辑层代码
'--------------------------------------------------
'转载的时候请保留版权信息
'作者:walkman
'网址:手机主题 http://www.shouji138.com
'版本:ver1.0
'欢迎各位交流进步
'--------------------------------------------------

Rem 根据classid取列表数据
Function GetListarr(classid,curpage,PageSize,CachePageNum,ByRef RecordCount)
	openConn
	Dim sql
	sql = "select thmid,thmname,picfileurl,win_theme.adddate from win_theme where  win_theme.ClassID="&classid&" order by thmid desc"
	Dim cache
	Set cache = new XmlCacheCls
	cache.PageSize = PageSize			  '每页N条记录
	cache.CachePageNum = CachePageNum		  '一个xml文件缓存M页的数据量
	cache.XmlFile = Server.Mappath("xmlcache/classxml/list_"&classid&".xml")
	cache.Sql = sql
	cache.CurPage = curpage
	cache.CacheType = 1
	Set cache.Conn = conn	
	cache.ReadData
	Dim SqlArr
	SQLArr = cache.SQLArr
	RecordCount = cache.RecordCount
	Set cache = Nothing 
	GetListarr = SqlArr
End Function 


Rem 根据classid生成xml缓存
Function CreateListxml(classid,curpage,PageSize,CachePageNum,CacheTime)
	Dim sql
	sql = "select thmid,thmname,picfileurl,win_theme.adddate from win_theme where  win_theme.ClassID="&classid&" order by thmid desc"
	Dim cache
	Set cache = new XmlCacheCls
	cache.CacheTime = CacheTime '缓存时间
	cache.PageSize = PageSize			  '每页N条记录
	cache.CachePageNum = CachePageNum		  '一个xml文件缓存M页的数据量
	cache.XmlFile = Server.Mappath("xmlcache/classxml/list_"&classid&".xml")
	cache.Sql = sql
	cache.CurPage = curpage
	cache.CacheType = 1
	Set cache.Conn = conn
	cache.WriteDataToXml
	Set cache = Nothing 
End Function 


Rem 根据keyword取列表数据
Function GetSearcharr(keyword,curpage,PageSize,CachePageNum,ByRef RecordCount)
	openConn
	Dim sql
	Dim sqlkey
	sqlkey = Replace(keyword,"'","")
	sql = "select thmid,thmname,picfileurl,win_theme.adddate from win_theme where  ThmName like '%"&sqlkey&"%' or ThmRange  like '%"&sqlkey&"%' or ThmInstro  like '%"&sqlkey&"%'  order by thmid desc"
	Dim cache
	Set cache = new XmlCacheCls
	cache.PageSize = PageSize			  '每页N条记录
	cache.CachePageNum = CachePageNum		  '一个xml文件缓存M页的数据量
	cache.XmlFile = Server.Mappath("xmlcache/searchxml/list_"&Server.URlEncode(Replace(keyword,"'",""))&".xml")
	cache.Sql = sql
	cache.CurPage = curpage
	cache.CacheType = 1
	Set cache.Conn = conn	
	cache.ReadData
	Dim SqlArr
	SQLArr = cache.SQLArr
	RecordCount = cache.RecordCount
	Set cache = Nothing 
	GetSearcharr = SqlArr
End Function 



Rem 根据keyword生成xml缓存
Function CreateSearchxml(keyword,curpage,PageSize,CachePageNum,CacheTime)
	Dim sql
	Dim sqlkey
	sqlkey = Replace(keyword,"'","")
	sql = "select thmid,thmname,picfileurl,win_theme.adddate from win_theme where  ThmName like '%"&sqlkey&"%' or ThmRange  like '%"&sqlkey&"%' or ThmInstro  like '%"&sqlkey&"%'  order by thmid desc"
	Dim cache
	Set cache = new XmlCacheCls
	cache.CacheTime = CacheTime '缓存时间
	cache.PageSize = PageSize			  '每页N条记录
	cache.CachePageNum = CachePageNum		  '一个xml文件缓存M页的数据量
	cache.XmlFile =  Server.Mappath("xmlcache/searchxml/list_"&Server.URlEncode(Replace(keyword,"'",""))&".xml")
	cache.Sql = sql
	cache.CurPage = curpage
	cache.CacheType = 1
	Set cache.Conn = conn
	cache.WriteDataToXml
	Set cache = Nothing 
End Function 

Rem 根据classid取列表数据
Function GetDetailarr(thmid)
	openConn
	Dim sql
	sql = "select a.thmid,a.thmname,a.classid,b.classname,a.picfileurl,a.thmver,a.thmsize,a.thminstro,a.thmrange,a.thmfileurl,a.adddate from win_theme a,Win_Classify b where a.classid=b.classid and  a.thmid="&thmid&""
	Dim thmidmod
	thmidmod = thmid Mod 100
	
	Dim cache
	Set cache = new XmlCacheCls
	cache.XmlFile = Server.Mappath("xmlcache/detailxml/"&thmidmod&"/"&thmid&".xml")
	cache.Sql = sql
	cache.CacheType = 2
	Set cache.Conn = conn	
	cache.ReadData
	Dim SqlArr
	SQLArr = cache.SQLArr
	Set cache = Nothing 
	GetDetailarr = SqlArr
End Function 

Rem 根据keyword生成xml缓存
Function CreateDetailxml(thmid,CacheTime)
	Dim sql
	sql = "select a.thmid,a.thmname,a.classid,b.classname,a.picfileurl,a.thmver,a.thmsize,a.thminstro,a.thmrange,a.thmfileurl,a.adddate from win_theme a,Win_Classify b where a.classid=b.classid and  a.thmid="&thmid&""
	Dim thmidmod
	thmidmod = thmid Mod 100
	Dim cache
	Set cache = new XmlCacheCls
	cache.CacheTime = CacheTime '缓存时间
	cache.XmlFile =  Server.Mappath("xmlcache/detailxml/"&thmidmod&"/"&thmid&".xml")
	cache.Sql = sql
	cache.CacheType = 2
	Set cache.Conn = conn
	cache.WriteDataToXml
	Set cache = Nothing 
End Function


Rem 检测动态数组是否已分配
Function   ismalloc(a)
	On   Error Resume Next 
	Dim   i   
	i   =   UBound(a)
	If Err Then 
	ismalloc = False 
	Else
	ismalloc   =   True   
	End If  
End   Function  



Function showData(SQLArr)

	If Not  ismalloc(SQLArr) Then Exit Function 
	Dim i,k
	Dim num
	num = 0
	i = UBound(SQLArr,1)
	k = UBound(SQLArr,2)
	Dim m,n
	For m = 0 To k
		num = num+1
	%>	
 <ul class="listbox" onMouseOver="overtb(this)" onMouseOut="outtb(this)">
<li>
<a title="<%=SQLArr(1,m)%>" href="detail.asp?id=<%=SQLArr(0,m)%>" target="_blank">
  <img height="140" alt="<%=SQLArr(1,m)%>" src="http://www.shouji138.com<%=SQLArr(2,m)%>" width="107" border="0"></a>
</li>
<li class="green bold">
<a title="<%=SQLArr(1,m)%>" href="detail.asp?id=<%=SQLArr(0,m)%>" target="_blank">
<%=walkgottopic(Trim(SQLArr(1,m)),18)%></a>
</li>
 <li><%=DateValue(SQLArr(3,m))%></li>
 </ul>
	<%
	next
End Function 

%>

这个文件是业务逻辑层代码，负责根据不同的业务逻辑来实现xml数据的读取和写入，并提供接口方法给web表现层调用。

具体的调用代码：
list.asp
只显示相关代码。
<%
。。。。。。
Dim classid
classid = Request("classid")
If classid = "" Or (Not IsNumeric(classid)) Then Response.write "参数错误！":Response.End()
classid = CLng(classid)

Dim sPagesize,TotalPage,CurPage,TotalRec,CachePageNum
sPagesize = 20
CachePageNum = 10
CurPage = Trim(Request("page"))
IF CurPage="" Or (Not IsNumeric(CurPage)) Then
  CurPage=1
Else
  CurPage=Clng(CurPage)
End IF
Dim myarr

myarr = GetListarr(classid,CurPage,sPagesize,CachePageNum,TotalRec)

'总页数
TotalPage = int(clng(TotalRec)/sPagesize*-1)*-1

If Clng(TotalRec)>0 Then	
	showData myarr
End If 
................
%>
最后在页面最底部调用一个asp的script语句来更新xml缓存。
<script type="text/javascript" src="setcache.asp?action=list&curpage=<%=curpage%>&classid=<%=classid%>"></script>


setcache.asp
相关代码
<%
openconn
Dim action 
action = Trim(Request("action"))&""

Dim curpage
curpage = Request("curpage")

Dim classid
Dim keyword
Dim thmid
If action = "list" Then
	classid = Request("classid")
	If classid="" Or (Not IsNumeric(classid)) Or curpage="" Or (Not IsNumeric(curpage)) Then
	Else
		CreateListxml CLng(classid),CLng(curpage),20,10,60 * 60 * 2  '创建分类的xml
	End If 
ElseIf action = "search" Then
	keyword = Trim(Request("keyword"))
	If keyword=""  Then
	Else
		CreateSearchxml keyword,CLng(curpage),20,10,60 * 60 * 2  '创建搜索的xml
	End If 
ElseIf action = "detail" Then
	thmid = Request("id")
	If thmid="" Or (Not IsNumeric(thmid))  Then
	Else
		CreateDetailxml CLng(thmid),60 * 60 * 2  '创建详情的xml
	End If 
End If 
Call Closeconn
Response.write " "
Response.End 

%>
至此，核心代码都分享出来了，实践证明，通过这样的方式，我的138手机主题网的服务器的CPU占用率和内存占用率明显下降，访问速度也明显提高，从以前的需要几秒甚至10多秒，到现在只需要10几毫秒。
为了方便大家理解其中的代码，我特地做了一个demo，供同行学习交流。地址：http://www.shouji138.com/aspnet2/demo
此例程的完整下载包：http://www.shouji138.com/aspnet2/demo/xmlcachedemo.rar
本人QQ:441003232 欢迎大家交流共同进步。
也可以访问本人的小站：手机主题:http://www.shouji138.com