编译原生ASP代码生成静态类实现

注:原文发表在本人博客[url=http://www.shirne.com/?cid=16&id=164]解析原生ASP代码的模板引擎(完善版)[/url]
但上面的代码并非最终修正版,这里类原码是最终修正版

'+++++++++++++++++++++++++++++++++++
'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)