解析原生ASP代码的模板引擎(完善版)
前两天发布过一篇介绍刚写的ASP原生代码解析生成静态的类，由于代码写有匆忙，其中很多细节都没有斟酌。这两天又作了些完善，现在发布新版本出来，希望给大家有些用处。
原文地址:将ASP原生代码编译生成静态类
使用范例代码：
'计算起始时间
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)
下面是新版本的类原码:
'+++++++++++++++++++++++++++++++++++
'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.ＣreateObject("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)
If IsArray(obj) Then
Dim i
For i=0 To UBound(obj)
If InStr(obj(i),":")<1 Then
If obj(i)&""<>"" Then obj(i) = Server.MapPath(obj(i))
End If
Next
CheckTruePath = obj
Else
obj = obj&""
If InStr(obj,":")>0 Then
CheckTruePath = obj
Else
If obj<>"" Then CheckTruePath = Server.MapPath(obj)
End If
End If
End Function
'编译文件
Public Sub Compile(File)
'读取文件内容
strHtml = ReadFile(File)
If strHtml="" Then
Exit Sub
End If
'非全局模式下防止call调用了直接输出的函数输出内容被遗漏
If GlobalMode = False Then
AddOutFun "Call"
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
'在全局执行，如果在库函数中使用了定义的全局变量，要这样运行
ＥxecuteGlobal "Dim "& FuncStr & vbCrLf & strHtml & vbCrLf
strHtml = Eval(FuncStr)
Else
'过滤类
strHtml = FilterClass(strHtml)
'过滤Sub
strHtml = FilterSub(strHtml)
'过滤Function
strHtml = FilterFunction(strHtml)
strHtml = RestoreString( strHtml, 0)
'用一个函数包装执行，如果结构严谨，库函数中没有使用全局变量，用这种方式最好
ＥxecuteGlobal "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,"")
'清理多余的空格
' i = InStr(strHtml,Chr(32) & Chr(32))
' While i>0
' strHtml = Replace(strHtml,Chr(32) & Chr(32),Chr(32))
' i = InStr(strHtml,Chr(32) & Chr(32))
' Wend
'清理多余的空行
' i = InStr(strHtml,vbCrLf & vbCrLf)
' While i>0
' strHtml = Replace(strHtml,vbCrLf & vbCrLf,vbCrLf)
' i = InStr(strHtml,vbCrLf & vbCrLf)
' Wend
End Sub
'执行预包含文件,忽略asp标签外的所有内容
Private Function Require(File)
Dim html, absPath
html = ReadFile(File)
absPath = Mid(File,Len(Server.MapPath("/")))
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
ＥxecuteGlobal Join(arrHtml,vbCrLf)
End If
End Function
Private Sub GlobalParam
ＥxecuteGlobal "Dim "& ParamStr & vbCrLf
Ｅxecute "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").Ｅxecute(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").Ｅxecute(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)
'直接执行类代码，没有处理类内部的属性，函数等功能的输出，尽量事先处理好
ＥxecuteGlobal 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").Ｅxecute(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)
ＥxecuteGlobal 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").Ｅxecute(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)
ＥxecuteGlobal FunctionStr
LastIndex = Match.FirstIndex+Match.Length+1
Next
oHtml = oHtml & Mid(html, lastIndex)
FilterFunction = oHtml
Else
FilterFunction = html
End If
End Function
End Class
下载地址:解析原生ASP代码的模板引擎(完善版)
豫公网安备 41112102000155号