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

时间:2021-10-30 02:08:24

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

注意:系统需要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 = "https://"
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 
%>