编译原生ASP代码生成静态类实现 博客分类: ASP ASP模板引擎生成静态
程序员文章站
2024-03-21 21:56:52
...
注:原文发表在本人博客解析原生ASP代码的模板引擎(完善版)
但上面的代码并非最终修正版,这里类原码是最终修正版
测试文件:
但上面的代码并非最终修正版,这里类原码是最终修正版
'+++++++++++++++++++++++++++++++++++ 'ASP编译类 '可按设定直接将ASP文件编译运行返回结果 '在原生ASP中用来生成静态文件,而不采用获取Http页面的方法 'shirne@126.com 'http://www.shirne.com '+++++++++++++++++++++++++++++++++++ Class xCompile Private Includes '预包含文件 Private Ignores '忽略的包含文件 Private OutFun '输出函数 Private strHtml '最终的HTML字符串 Private Params '参数,仅支持QueryString参数,生成静态不建议使用其它参数 Private FuncStr '定义的全局函数名 Private ParamStr Private Classes '已加载的类列表,ASP中类不能重复加载 Private Prepared Private arrStr '提取出的字符串数组 Private arrStrLength Private StrRep '占位符 Private EndRep Private ClearRep '值:True/False 'True:将在全局模式下执行代码,注意变量与当前文件的变量定义冲突 'False:将把最终代码封装进函数执行,注意其它函数体内不能使用全局变量 Public GlobalMode Private Sub Class_Initialize OutFun = Array("Response.Write") FuncStr = "Outer__Html__Str" ParamStr= "In_Param_Str" Set Classes=Server.CreateObject("Scripting.Dictionary") Classes.CompareMode=1 Set Params=new xDictionary Params.Init Request.QueryString Prepared = -1 GlobalMode = True arrStr = Split(Empty) arrStrLength = UBound(arrStr) StrRep = Chr(1) '字符串占位 EndRep = Chr(3) '结束动作占位 ClearRep=Chr(2) '清除占位 End Sub Private Sub Class_Terminate Classes.RemoveAll Set Classes= Nothing Set Params = Nothing End Sub Public Default Property Get Html Html = strHtml End Property '主要动作是处理预包含文件 Public Property Get Prepare If IsArray(Includes) Then Dim i,L:L=UBound(Includes) If Prepared>=L Then Exit Property For i=Prepared+1 To L Require Includes(i) Next Prepared = L End If End Property '添加/获取参数 Public Property Let Param(key, val) Params.Replace key,val End Property Public Property Get Param(key) Param = Params(key) End Property '添加预包含文件 Public Sub AddInclude( File) Includes = Merge(Includes,CheckTruePath(File)) End Sub '添加忽略文件 Public Sub AddIgnore( File) Ignores = Merge(Ignores,CheckTruePath(File)) End Sub '添加输出函数 Public Sub AddOutFun( Fun) OutFun = Merge(OutFun,Fun) End Sub '保存 Public Sub SaveTo( path) WriteFile path, strHtml End Sub '检查是否磁盘路径,返回磁盘路径,可接收数组 Private Function CheckTruePath( obj) Dim Fso Set Fso=Server.CreateObject("Scripting.FileSystemObject") If IsArray(obj) Then Dim i For i=0 To UBound(obj) If InStr(obj(i),":")<1 Then If obj(i)&""<>"" Then obj(i) = Fso.GetAbsolutePathName(Server.MapPath(obj(i))) End If Next CheckTruePath = obj Else obj = obj&"" If InStr(obj,":")>0 Then CheckTruePath = obj Else If obj<>"" Then CheckTruePath = Fso.GetAbsolutePathName(Server.MapPath(obj)) End If End If End Function '编译文件 Public Sub Compile(File) '读取文件内容 strHtml = ReadFile(File) If strHtml="" Then Exit Sub End If '包含文件 strHtml = Include(strHtml,File) '去除页面指令 strHtml = RegReplace("<%@[^>]+%\>",strHtml,"") '整理换行符 strHtml = Replace(strHtml,Chr(13)&Chr(10),Chr(13)) strHtml = Replace(strHtml,Chr(10),Chr(13)) strHtml = Replace(strHtml,Chr(13),vbCrLf) Dim arrHtml, i, j, k, l i = InStr(strHtml,"<%") If i>0 Then '存在ASP标签,则逐个解析 ReDim arrHtml(0) j = 0 k = 1 Do Until i<1 l = InStr(i+1,strHtml,"%\>") If l<1 Then Err.Raise 7,"ASP语法错误,不正确的闭合标签" ReDim Preserve arrHtml(j+1) arrHtml(j) = FuncStr &" = "& FuncStr &" &"""& StrRep &"""" PutString EscapeHtml(Mid(strHtml,k,i-k)) arrHtml(j+1)=Mid(strHtml,i+2,l-i-2) If Left(arrHtml(j+1),1)="=" Then arrHtml(j+1) = FuncStr &" = "& FuncStr &" &"& EscapeAsp(Mid(arrHtml(j+1),2)) Else arrHtml(j+1) = EscapeAsp(arrHtml(j+1)) End If j = j + 2 k = l + 2 i = InStr(l+1,strHtml,"<%") Loop '最后的html内容 ReDim Preserve arrHtml(j) arrHtml(j) = FuncStr &" = "& FuncStr &" &"""& StrRep &"""" PutString EscapeHtml(Mid(strHtml,l+2)) strHtml = Join(arrHtml,vbCrLf) '执行预包含文件 PrePare If GlobalMode Then strHtml = RestoreString( strHtml, 0) '传递参数到全局 Call GlobalParam '在全局执行,如果在库函数中使用了定义的全局变量,要这样运行 ExecuteGlobal "Dim "& FuncStr & vbCrLf & strHtml & vbCrLf strHtml = Eval(FuncStr) Else '过滤类 strHtml = FilterClass(strHtml) '过滤Sub strHtml = FilterSub(strHtml) '过滤Function strHtml = FilterFunction(strHtml) strHtml = RestoreString( strHtml, 0) '用一个函数包装执行,如果结构严谨,库函数中没有使用全局变量,用这种方式最好 ExecuteGlobal "Function "& FuncStr &"("& ParamStr &")" & vbCrLf & strHtml & vbCrLf &"End Function" strHtml = Eval(FuncStr&"(Params)") End If i = InStr(strHtml, EndRep) j = InStr(strHtml, ClearRep) If (i<j Or j<0) And i>0 Then 'Response.End在前 strHtml = Mid(strHtml, 1, i-1) ElseIf j>0 Then 'Response.Clear在前 If i>0 Then '隐含条件 i>j strHtml = Mid(strHtml, j+1, i-j-1) Else strHtml = Mid(strHtml, j+1) End If End If End If End Sub '清理处理后的内容 Sub Clear Dim i '去除前后空白字符 strHtml = xTrim(strHtml,Chr(32)&Chr(9)&Chr(10)&Chr(13)) '清除注释 strHtml = RegReplace("<!--[\s\S]*?-->",strHtml,"") '清除空行 strHtml = RegExpReplace("^\s*$","gm",strHtml,"") End Sub '执行预包含文件,忽略asp标签外的所有内容 Private Function Require(File) Dim html, absPath html = ReadFile(File) absPath = Mid(File,Len(Server.MapPath(ROOT & "/"))+1) html = Include(html,absPath) Dim arrHtml, i, j, k, l i = InStr(html,"<%") If i>0 Then '存在ASP标签,则逐个解析,否则忽略该文件 ReDim arrHtml(0) j = 0 k = 1 Do Until i<1 l = InStr(i+1,html,"%\>") If l<1 Then Err.Raise 7,"ASP语法错误,不正确的闭合标签" ReDim Preserve arrHtml(j+1) arrHtml(j) = "" '忽略所有非asp内容 arrHtml(j+1)=Mid(html,i+2,l-i-2) j = j + 2 k = l + 2 i = InStr(l+1,html,"<%") Loop ExecuteGlobal Join(arrHtml,vbCrLf) End If End Function Private Sub GlobalParam ExecuteGlobal "Dim "& ParamStr & vbCrLf Execute "Set "& ParamStr &"= Params" End Sub '将html代码替换成VBS字符串 Private Function EscapeHtml( html) If InStr(html,"""")>0 Then html = Replace(html,"""","""""") If InStr(html,vbCrLf)>0 Then html = Replace(html,vbCrLf,"""& vbCrLf &""") EscapeHtml = html 'Replace(html,Chr(0),"") End Function '重新编码ASP代码,替换输出函数,替换参数 Private Function EscapeAsp( html) Dim i '去除注释,以免影响下面替换 html = FilterComment(html) For i=0 To UBound(OutFun) '先替换带括号的,这里不够严谨,没有判断括号嵌套的情况 '其实后面带不带括号都可以看作一个整体,所以下面一个替换就好了 'If InStr(1,html,OutFun(i)&"(", 1)>0 Then ' html = RegReplace("\b"& OutFun(i) &"\(([^()]+?)\)",html,FuncStr &" = "& FuncStr &" & $1") 'End If If InStr(1,html,OutFun(i),1)>0 Then html = RegReplace("\b"& OutFun(i) &"\b",html,FuncStr &" = "& FuncStr &" &") End If Next If InStr(1,html,"Request.QueryString(",1)>0 Then html = RegReplace("\bRequest\.QueryString\(",html,ParamStr &"(") End If If InStr(1,html,"Response.End",1)>0 Then html = RegReplace("\bResponse\.End(\(\s*\))?",html,FuncStr &" = "& FuncStr &" &"""& EndRep &"""") End If If InStr(1,html,"Response.Clear",1)>0 Then html = RegReplace("\bResponse\.Clear(\(\s*\))?",html,FuncStr &" = "& FuncStr &" &"""& ClearRep &"""") End If EscapeAsp = html End Function '恢复ASP代码中的字符串 Private Function RestoreString(html, j) Dim i, iEnd, oHtml iEnd = 1 i=InStr(html,StrRep) Do Until i<1 '略过已恢复的 Do While IsEmpty(arrStr(j)) j = j + 1 If j>arrStrLength Then Exit Do Loop oHtml = oHtml & Mid(html, iEnd, i-iEnd) & arrStr(j) '已恢复的设为空 arrStr(j) = Empty iEnd = i + 1 i = InStr(iEnd, html, strRep) j = j + 1 If j>arrStrLength Then Exit Do Loop If iEnd>0 Then oHtml = oHtml & Mid(html, iEnd) RestoreString = oHtml End Function '包含入文件 Private Function Include(html,ByVal path) Dim Matches,Match,iHtml, iPath, oHtml, lastIndex Dim iStart, iEnd Set Matches=REObject("<!--\s*#include\s+(file|virtual)=""([^*?<>=:""|]+)""\s*-->","gi").Execute(html) If Matches.Count>0 Then lastIndex = 1 iStart = 1 iEnd = 1 For Each Match In Matches '存在asp标签,且asp结束标签在Match.FirstIndex之前,则查找下一组asp标签 '直到不存在asp标签或结束标签在Match.FirstIndex之后 '保证当前匹配到的包含语法不在asp标签内部 Do Until iStart<1 Or Match.FirstIndex<iEnd iStart = InStr(iEnd, html, "<%") If iStart>0 Then iEnd = InStr(iStart,html,"%\>") Loop If iStart<1 Or Match.FirstIndex<iStart Then oHtml = oHtml & Mid(html,lastIndex,Match.FirstIndex+1-lastIndex) If StrComp(Match.SubMatches(0),"file",1)=0 Then iPath = getDir(path) & Match.SubMatches(1) ElseIf StrComp(Match.SubMatches(0),"virtual",1)=0 Then iPath = Match.SubMatches(1) Else iPath = "" End If If CheckNeedInclude(iPath) Then iHtml = ReadFile(iPath) iHtml = Include(iHtml,iPath) oHtml = oHtml & iHtml End If Else oHtml = oHtml & Mid(html, lastIndex,Match.FirstIndex+Match.Length+1 - lastIndex) End If lastIndex = Match.FirstIndex+Match.Length+1 Next oHtml = oHtml & Mid(html, lastIndex) Include = oHtml Else Include = html End If End Function '检查是否需要包含 Private Function CheckNeedInclude(ByVal path) CheckNeedInclude = True If path="" Then CheckNeedInclude = False:Exit Function path = CheckTruePath(path) Dim i '先检查预包含文件 If IsArray(Includes) Then For i=0 To UBound(Includes) If StrComp(Includes(i),path,1)=0 Then CheckNeedInclude = False Exit Function End If Next End If '再检查忽略含文件 If IsArray(Ignores) Then For i=0 To UBound(Ignores) If StrComp(Ignores(i),path,1)=0 Then CheckNeedInclude = False Exit Function End If Next End If End Function '移除注释,并提取字符串 Private Function FilterComment( html) Dim intStart, intEnd, intQuot, intPos, ohtml, L L = Len(html) intPos = 1 Do While intPos < L And intPos>0 intQuot=InStr(intPos,html,"'") intStart=Instr(intPos,html,"""") If (intQuot<intStart Or intStart<1) And intQuot>0 Then '是注释 ohtml = ohtml & Mid(html,intPos,intQuot-intPos) '找出注释结尾 intPos = InStr(intQuot,html,vbCrLf) ElseIf (intQuot>intStart Or intQuot<1) And intStart>0 Then '跳过字符串的动作 intEnd=InStr(intStart+1,html,"""") Do While intEnd<L If Mid(html,intEnd+1,1)<>"""" Then Exit Do intEnd=InStr(intEnd+2,html,"""") If intEnd<1 Then Err.Raise 7,"ASP语法错误,未结束的字符串" End If Loop '提取ASP代码 ohtml = ohtml & Mid(html,intPos,intStart-intPos+1) If intEnd - intPos > 1 Then '提取字符串 PutString Mid(html,intStart+1,intEnd-intStart-1) ohtml = ohtml & StrRep &"""" '字符串占位 Else '空字符串无需提取 ohtml = ohtml & """" End If intPos = intEnd+1 Else '没有字符串,没有注释 Exit Do End If Loop If intPos>0 Then ohtml = ohtml & Mid(html,intPos) FilterComment = ohtml End Function Private Sub PutString( str) arrStrLength = arrStrLength + 1 ReDim Preserve arrStr(arrStrLength) arrStr(arrStrLength) = str End Sub Private Function getIndex(html, iPos,ByVal i,ByVal j) i = InStr(i + 1, html, strRep) Do Until i<1 Or i>iPos i = InStr(i+1, html, strRep) j = j + 1 If j>arrStrLength Then Exit Do Do While IsEmpty(arrStr(j)) j = j + 1 If j>arrStrLength Then Exit Do Loop Loop getIndex = j End Function '移除类,并尝试在全局执行移除的类 Private Function FilterClass( html) Dim Matches,Match,ClassName,oHtml,LastIndex, ClassStr, iStart Set Matches=REObject("\bClass\s+([\w\d\_]+)\b[\s\S]+?\bEnd\s+Class\b","ig").Execute(html) If Matches.Count>0 Then iStart = 0 LastIndex = 1 For Each Match In Matches oHtml = oHtml & Mid(html,LastIndex,Match.FirstIndex+1-LastIndex) ClassName = Match.SubMatches(0) If Classes.Exists(ClassName)=False Then ClassStr = Match.Value iStart = getIndex(html,Match.FirstIndex,LastIndex-1,iStart) ClassStr = RestoreString(ClassStr, iStart) '直接执行类代码,没有处理类内部的属性,函数等功能的输出,尽量事先处理好 ExecuteGlobal ClassStr Classes.Add ClassName,1 End If LastIndex = Match.FirstIndex+Match.Length+1 Next oHtml = oHtml & Mid(html, LastIndex) FilterClass = oHtml Else FilterClass = html End If End Function '移除Sub,并尝试将Sub转换为Function在全局执行 Private Function FilterSub( html) Dim Matches,Match,SubName,SubStr,oHtml,LastIndex, iStart Set Matches=REObject("\bSub\s+([\w\d\_]+)\b[\s\S]+?\bEnd\s+Sub\b","ig").Execute(html) If Matches.Count>0 Then iStart = 0 LastIndex = 1 For Each Match In Matches oHtml = oHtml & Mid(html,LastIndex,Match.FirstIndex+1-LastIndex) SubName = Match.SubMatches(0) '将Sub替换成Function SubStr = RegReplace("\bSub\b",Match.Value,"Function") SubStr = RegReplace("\b"& FuncStr &"\b",SubStr,SubName) iStart = getIndex(html,Match.FirstIndex,LastIndex-1,iStart) SubStr = RestoreString(SubStr, iStart) ExecuteGlobal SubStr LastIndex = Match.FirstIndex+Match.Length+1 Next oHtml = oHtml & Mid(html, lastIndex) FilterSub = oHtml Else FilterSub = html End If End Function '移除函数,并尝试在全局执行移除的函数 Private Function FilterFunction( html) Dim Matches,Match,FunctionName,FunctionStr,oHtml,LastIndex, iStart Set Matches=REObject("\bFunction\s+([\w\d\_]+)\b[\s\S]+?\bEnd\s+Function\b","ig").Execute(html) If Matches.Count>0 Then iStart = 0 LastIndex = 1 For Each Match In Matches oHtml = oHtml & Mid(html,LastIndex,Match.FirstIndex+1-LastIndex) FunctionName = Match.SubMatches(0) FunctionStr = RegReplace("\b"& FuncStr &"\b",Match.Value,FunctionName) iStart = getIndex(html,Match.FirstIndex,LastIndex-1,iStart) FunctionStr = RestoreString(FunctionStr, iStart) ExecuteGlobal FunctionStr LastIndex = Match.FirstIndex+Match.Length+1 Next oHtml = oHtml & Mid(html, lastIndex) FilterFunction = oHtml Else FilterFunction = html End If End Function End Class
测试文件:
'计算起始时间 Dim StartTime StartTime = Timer '生成对象 Dim C Set C=New xCompile '//这个文件会被预先运行,文件路径写法不重要,比较时是按实际磁盘路径比较的 C.AddInclude "TestFunctions.asp" '//ASP中调用到这个函数的地方会被替换成字符串连接 C.AddOutFun "Echo" C.Param("param")="这是传过去的参数" '//设置是否以全局模式执行 C.GlobalMode = False '//编译文件 C.Compile "Test.asp" C.Clear '//保存编译后的文件到内容 C.SaveTo "index.html" '//输出编译后的内容 Response.Write C '输出执行时间 Response.Write CCur(Timer-StartTime)