asp磁盘缓存技术使用的代码


            这一种方法适合，访问相对集中在同样内容页面的网站，会自动生成缓存文件(相当于读取静态页面，但会增大文件)。如果访问不集中会造成服务器同时读取文件当机。 



注意：系统需要FSO权限、XMLHTTP权限 



系统包括两个文件，其实可以合并为一个。之所以分为两个是因为部分杀毒软件会因为里边含有FSO、XMLHTTP操作而被认为是脚本木马。 



调用时，需要在ASP页面的最上边包含主文件，然后在下边写下以下代码 







<% 

Set MyCatch=new CatchFile 

MyCatch.Overdue=60*5    '修改过期时间设置为5个小时 

if MyCatch.CatchNow(Rev) then 

    response.write MyCatch.CatchData 

    response.end 

end if 

set MyCatch=nothing 

%>



复制代码 代码如下:

主包含文件：FileCatch.asp 

<!--#include file="FileCatch-Inc.asp"--> 

<% 

'---- 本文件用于签入原始文件，实现对页面的文件Catch 

'---- 1、如果文件请求为POST方式，则取消此功能 

'---- 2、文件的请求不能包含系统的识别关键字 

'---- 3、作者 何直群 (www.wozhai.com) 

Class CatchFile 

        Public Overdue,Mark,CFolder,CFile '定义系统参数 

        Private ScriptName,ScriptPath,ServerHost '定义服务器/页面参数变量 

        Public CatchData        '输出的数据

        Private Sub Class_Initialize        '初始化函数 

                '获得服务器及脚本数据 

                ScriptName=Request.Servervariables("Script_Name") '识别出当前脚本的虚拟地址 

                ScriptPath=GetScriptPath(false)        '识别出脚本的完整GET地址 

                ServerHost=Request.Servervariables("Server_Name") '识别出当前服务器的地址

                '初始化系统参数 

                Overdue=30        '默认30分钟过期 

                Mark="NoCatch"        '无Catch请求参数为 NoCatch 

                CFolder=GetCFolder        '定义默认的Catch文件保存目录 

                CFile=Server.URLEncode(ScriptPath)&".txt"        '将脚本路径转化为文件路径

                CatchData="" 

        end Sub

        Private Function GetCFolder 

                dim FSO,CFolder 

                Set FSO=CreateObject("Scripting.FileSystemObject")        '设置FSO对象 

                CFolder=Server.MapPath("/")&"/FileCatch/" 

                if not FSO.FolderExists(CFolder) then 

                        fso.CreateFolder(CFolder) 

                end if 

                if Month(Now())<10 then 

                        CFolder=CFolder&"/0"&Month(Now()) 

                else 

                        CFolder=CFolder&Month(Now()) 

                end if 

                if Day(Now())<10 then 

                        CFolder=CFolder&"0"&Day(Now()) 

                else 

                        CFolder=CFolder&Day(Now()) 

                end if 

                CFolder=CFolder&"/" 

                if not FSO.FolderExists(CFolder) then 

                        fso.CreateFolder(CFolder) 

                end if 

                GetCFolder=CFolder 

                set fso=nothing 

        End Function

        Private Function bytes2BSTR(vIn)        '转换编码的函数 

                dim StrReturn,ThisCharCode,i,NextCharCode 

                strReturn = "" 

                For i = 1 To LenB(vIn) 

                        ThisCharCode = AscB(MidB(vIn,i,1)) 

                        If ThisCharCode < &H80 Then 

                                strReturn = strReturn & Chr(ThisCharCode) 

                        Else 

                                NextCharCode = AscB(MidB(vIn,i+1,1)) 

                                strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode)) 

                                i = i + 1 

                        End If 

                Next 

                bytes2BSTR = strReturn 

        End Function

        Public Function CatchNow(Rev)        '用户指定开始处理Catch操作 

                if UCase(request.Servervariables("Request_Method"))="POST" then 

                '当是POST方法，不可使用文件Catch 

                        Rev="使用POST方法请求页面，不可以使用文件Catch功能" 

                        CatchNow=false 

                else 

                        if request.Querystring(Mark)<>"" then 

                        '如果指定参数不为空，表示请求不可以使用Catch 

                                Rev="请求拒绝使用Catch功能" 

                                CatchNow=false 

                        else 

                                CatchNow=GetCatchData(Rev) 

                        end if 

                end if 

        End Function

        Private Function GetCatchData(Rev)        '读取Catch数据 

                Dim FSO,IsBuildCatch 

                Set FSO=CreateObject("Scripting.FileSystemObject")        '设置FSO对象，访问CatchFile

                If FSO.FileExists(CFolder&CFile) Then 

                        Dim File,LastCatch 

                        Set File=FSO.GetFile(CFolder&CFile)        '定义CatchFile文件对象 

                        LastCatch=CDate(File.DateLastModified) 

                        if DateDiff("n",LastCatch,Now())>Overdue then 

                        '如果超过了Catch时间 

                                IsBuildCatch=true 

                        else 

                                IsBuildCatch=false 

                        end if 

                        Set File=Nothing 

                else 

                        IsBuildCatch=true 

                End if

                If IsBuildCatch then 

                        GetCatchData=BuildCatch(Rev)        '如果需要创建Catch,则创建Catch文件，同时设置Catch的数据 

                else 

                        GetCatchData=ReadCatch(Rev)        '如果不需要创建Catch，则直接读取Catch数据 

                End if

                Set FSO=nothing 

        End Function

        Private Function GetScriptPath(IsGet)        '创建一个包含所有请求数据的地址 

                dim Key,Fir 

                GetScriptPath=ScriptName 

                Fir=true 

                for Each key in Request.QueryString 

                        If Fir then 

                                GetScriptPath=GetScriptPath&"?" 

                                Fir=false 

                        else 

                                GetScriptPath=GetScriptPath&"&" 

                        end if 

                        GetScriptPath=GetScriptPath&Server.URLEncode(Key)&"="&Server.URLEncode(Request.QueryString(Key)) 

                Next 

                if IsGet then 

                        If Fir then 

                                GetScriptPath=GetScriptPath&"?" 

                                Fir=false 

                        else 

                                GetScriptPath=GetScriptPath&"&" 

                        end if 

                        GetScriptPath=GetScriptPath&Server.URLEncode(Mark)&"=yes" 

                end if 

        End Function

        '创建Catch文件 

        Private Function BuildCatch(Rev) 

                Dim HTTP,Url,OutCome 

                Set HTTP=CreateObject("Microsoft.XMLHTTP") 

'                On Error Resume Next 

'                response.write ServerHost&GetScriptPath(true) 

                HTTP.Open "get","http://"&ServerHost&GetScriptPath(true),False 

                HTTP.Send

                if Err.number=0 then 

                        CatchData=bytes2BSTR(HTTP.responseBody) 

                        BuildCatch=True 

                else 

                        Rev="创建发生错误："&Err.Description 

                        BuildCatch=False 

                        Err.clear 

                end if

                Call WriteCatch

                set HTTP=nothing 

        End Function

        Private Function ReadCatch(Rev) 

                ReadCatch=IReadCatch(CFolder&CFile,CatchData,Rev) 

        End Function

        Private Sub WriteCatch 

                Dim FSO,TSO 

                Set FSO=CreateObject("Scripting.FileSystemObject")        '设置FSO对象，访问CatchFile 

                set TSO=FSO.CreateTextFile(CFolder&CFile,true) 

                TSO.Write(CatchData) 

                Set TSO=Nothing 

                Set FSO=Nothing 

        End Sub 

End Class 

%>   



文件二:FileCatch-Inc.asp

复制代码 代码如下:

<% 

Function IReadCatch(File,Data,Rev) 

        Dim FSO,TSO 

        Set FSO=CreateObject("Scripting.FileSystemObject")        '设置FSO对象，访问CatchFile 

'        on error resume next 

        set TSO=FSO.OpenTextFile(File,1,false) 

        Data=TSO.ReadAll 

        if Err.number<>0 then 

                Rev="读取发生错误："&Err.Description 

                ReadCatch=False 

                Err.clear 

        else 

                IReadCatch=True 

        end if 

        Set TSO=Nothing 

        Set FSO=Nothing 

End Function 

%> 



asp硬盘缓存代码2





<%@LANGUAGE="VBSCRIPT" CODEPAGE="65001"%>

<% Response.CodePage=65001%> 

<% Response.Charset="UTF-8" %> 



<%

'该程序通过使用ASP的FSO功能，减少数据库的读取。经测试，可以减少90%的服务器负荷。页面访问速度基本与静态页面相当。

'使用方法：将该文件放在网站里，然后在需要引用的文件的“第一行”用include引用即可。



'=======================参数区=============================



DirName="cachenew\" '静态文件保存的目录，结尾应带"\"。无须手动建立，程序会自动建立。

'TimeDelay=10   '更新的时间间隔，单位为分钟，如1440分钟为1天。生成的静态文件在该间隔之后会被删除。

TimeDelay=300

'======================主程序区============================



foxrax=Request("foxrax")

if foxrax="" then

 FileName=Server.URLEncode(GetStr())&".txt"

 FileName=DirName&FileName

 if tesfold(DirName)=false then'如果不存在文件夹则创建

 createfold(Server.MapPath(".")&"\"&DirName)

 end if 

 

 if ReportFileStatus(Server.MapPath(".")&"\"&FileName)=true then'如果存在生成的静态文件,则直接读取文件

 Set FSO=CreateObject("Scripting.FileSystemObject")

 Dim Files,LatCatch

 Set Files=FSO.GetFile(Server.MapPath(FileName))    '定义CatchFile文件对象

    LastCatch=CDate(Files.DateLastModified)



 If DateDiff("n",LastCatch,Now())>TimeDelay Then'超过

  List=getHTTPPage(GetUrl())

  WriteFile(FileName)

 Else

  List=ReadFile(FileName)

 End If

 Set FSO = nothing

 Response.Write(List)

 Response.End()

 

 else

 List=getHTTPPage(GetUrl())

 WriteFile(FileName)

 end if

 

 

end if





'========================函数区============================



'获取当前页面url

Function GetStr()

 'On Error Resume Next 

 Dim strTemps 

 strTemps = strTemps & Request.ServerVariables("URL") 

 If Trim(Request.QueryString) <> "" Then 

 strTemps = strTemps & "?" & Trim(Request.QueryString) 

 else

 strTemps = strTemps 

 end if

 GetStr = strTemps 

End Function



'获取缓存页面url

Function GetUrl() 

On Error Resume Next 

Dim strTemp 

If LCase(Request.ServerVariables("HTTPS")) = "off" Then 

 strTemp = "http://"

Else 

 strTemp = "http://"

End If 

strTemp = strTemp & Request.ServerVariables("SERVER_NAME") 

If Request.ServerVariables("SERVER_PORT") <> 80 Then 

 strTemp = strTemp & ":" & Request.ServerVariables("SERVER_PORT") 

end if

strTemp = strTemp & Request.ServerVariables("URL") 

If Trim(Request.QueryString) <> "" Then 

 strTemp = strTemp & "?" & Trim(Request.QueryString) & "&foxrax=foxrax"

else

 strTemp = strTemp & "?" & "foxrax=foxrax"

end if

GetUrl = strTemp 

End Function





'抓取页面

Function getHTTPPage(url)

 Set Mail1 = Server.CreateObject("CDO.Message")

 Mail1.CreateMHTMLBody URL,31

 AA=Mail1.HTMLBody

 Set Mail1 = Nothing

 getHTTPPage=AA

 'Set Retrieval = Server.CreateObject("Microsoft.Xmlhttp") 

 'Retrieval.Open "GET",url,false,"",""

 'Retrieval.Send

 'getHTTPPage = Retrieval.ResponseBody 

 'Set Retrieval = Nothing 

End Function



Sub WriteFile(filePath)

  On Error Resume Next 

    dim stm

    set stm=Server.CreateObject("adodb.stream") 

    stm.Type=2 'adTypeText，文本数据

    stm.Mode=3 'adModeReadWrite,读取写入，此参数用2则报错

    stm.Charset="utf-8"

    stm.Open 

    stm.WriteText list 

    stm.SaveToFile Server.MapPath(filePath),2 'adSaveCreateOverWrite，文件存在则覆盖

    stm.Flush 

    stm.Close 

    set stm=nothing 

End Sub



 



Function ReadFile(filePath)

    dim stm

    set stm=Server.CreateObject("adodb.stream") 

    stm.Type=1 'adTypeBinary，按二进制数据读入

    stm.Mode=3 'adModeReadWrite ,这里只能用3用其他会出错

    stm.Open 

    stm.LoadFromFile Server.MapPath(filePath)

    stm.Position=0 '把指针移回起点

    stm.Type=2 '文本数据

    stm.Charset="utf-8"

    ReadFile = stm.ReadText

    stm.Close 

    set stm=nothing 

End Function





'读取文件

'Public Function ReadFile( xVar )

 'xVar = Server.Mappath(xVar)

 'Set Sys = Server.CreateObject("Scripting.FileSystemObject") 

 'If Sys.FileExists( xVar ) Then 

 'Set Txt = Sys.OpenTextFile( xVar, 1,false) 

 'msg = Txt.ReadAll

 'Txt.Close 

 'Response.Write("yes")

 'Else

 'msg = "no"

 'End If 

 'Set Sys = Nothing

 'ReadFile = msg

'End Function



'检测文件是否存在

Function ReportFileStatus(FileName)

 set fso = server.createobject("scripting.filesystemobject")

 if fso.fileexists(FileName) = true then

   ReportFileStatus=true

   else

   ReportFileStatus=false

 end if 

 set fso=nothing

end function



'检测目录是否存在

function tesfold(foname) 

  set fs=createobject("scripting.filesystemobject")

  filepathjm=server.mappath(foname)

  if fs.folderexists(filepathjm) then

   tesfold=True

  else

   tesfold= False

  end if

  set fs=nothing

end function



 '建立目录

sub createfold(foname) 

  set fs=createobject("scripting.filesystemobject")

  fs.createfolder(foname)

  set fs=nothing

end sub



'删除文件

function del_file(path)   'path，文件路径包含文件名

set objfso = server.createobject("scripting.FileSystemObject")

'path=Server.MapPath(path)

if objfso.FileExists(path) then   '若存在则删除

 objfso.DeleteFile(path)     '删除文件

else

 'response.write "<script language='Javascript'>alert('文件不存在')</script>"

end if 

set objfso = nothing

end function 

%>