ASP 高级模板引擎实现类

代码如下:

Class template 

Private c_Char, c_Path, c_FileName, c_Content, c_PageUrl, c_CurrentPage, c_PageStr, ReplacePageStr 
Private TagName 

' *************************************** 
' 设置编码 
' *************************************** 
Public Property Let Char(ByVal Str) 
c_Char = Str 
End Property 
Public Property Get Char 
Char = c_Char 
End Property 

' *************************************** 
' 设置模板文件夹路径 
' *************************************** 
Public Property Let Path(ByVal Str) 
c_Path = Str 
End Property 
Public Property Get Path 
Path = c_Path 
End Property 

' *************************************** 
' 设置模板文件名 
' *************************************** 
Public Property Let FileName(ByVal Str) 
c_FileName = Str 
End Property 
Public Property Get FileName 
FileName = c_FileName 
End Property 

' *************************************** 
' 获得模板文件具体路径 
' *************************************** 
Public Property Get FilePath 
If Len(Path) > 0 Then Path = Replace(Path, "\", "/") 
If Right(Path, 1) <> "/" Then Path = Path & "/" 
FilePath = Path & FileName 
End Property 

' *************************************** 
' 设置分页URL 
' *************************************** 
Public Property Let PageUrl(ByVal Str) 
c_PageUrl = Str 
End Property 
Public Property Get PageUrl 
PageUrl = c_PageUrl 
End Property 

' *************************************** 
' 设置分页 当前页 
' *************************************** 
Public Property Let CurrentPage(ByVal Str) 
c_CurrentPage = Str 
End Property 
Public Property Get CurrentPage 
CurrentPage = c_CurrentPage 
End Property 

' *************************************** 
' 输出内容 
' *************************************** 
Public Property Get Flush 
Response.Write(c_Content) 
End Property 

' *************************************** 
' 类初始化 
' *************************************** 
Private Sub Class_Initialize 
TagName = "pjblog" 
c_Char = "UTF-8" 
ReplacePageStr = Array("", "") 
End Sub 

' *************************************** 
' 过滤冲突字符 
' *************************************** 
Private Function doQuote(ByVal Str) 
doQuote = Replace(Str, Chr(34), """) 
End Function 

' *************************************** 
' 类终结 
' *************************************** 
Private Sub Class_Terminate 
End Sub 

' *************************************** 
' 加载文件方法 
' *************************************** 
Private Function LoadFromFile(ByVal cPath) 
Dim obj 
Set obj = Server.CreateObject("ADODB.Stream") 
With obj 
.Type = 2 
.Mode = 3 
.Open 
.Charset = Char 
.Position = .Size 
.LoadFromFile Server.MapPath(cPath) 
LoadFromFile = .ReadText 
.close 
End With 
Set obj = Nothing 
End Function 

' *********************************************** 
' 获取正则匹配对象 
' *********************************************** 
Public Function GetMatch(ByVal Str, ByVal Rex) 
Dim Reg, Mag 
Set Reg = New RegExp 
With Reg 
.IgnoreCase = True 
.Global = True 
.Pattern = Rex 
Set Mag = .Execute(Str) 
If Mag.Count > 0 Then 
Set GetMatch = Mag 
Else 
Set GetMatch = Server.CreateObject("Scripting.Dictionary") 
End If 
End With 
Set Reg = nothing 
End Function 

' *************************************** 
' 打开文档 
' *************************************** 
Public Sub open 
c_Content = LoadFromFile(FilePath) 
End Sub 

' *************************************** 
' 缓冲执行 
' *************************************** 
Public Sub Buffer 
c_Content = GridView(c_Content) 
Call ExecuteFunction 
End Sub 

' *************************************** 
' GridView 
' *************************************** 
Private Function GridView(ByVal o_Content) 
Dim Matches, SubMatches, SubText 
Dim Attribute, Content 
Set Matches = GetMatch(o_Content, "\<" & TagName & "\:(\d+?)(.+?)\>([\s\S]+?)<\/" & TagName & "\:\1\>") 
If Matches.Count > 0 Then 
For Each SubMatches In Matches 
Attribute = SubMatches.SubMatches(1) ' kocms 
Content = SubMatches.SubMatches(2) ' <Columns>...</Columns> 
SubText = Process(Attribute, Content) ' 返回所有过程执行后的结果 
o_Content = Replace(o_Content, SubMatches.value, "<" & SubText(2) & SubText(0) & ">" & SubText(1) & "</" & SubText(2) & ">", 1, -1, 1) ' 替换标签变量 
Next 
End If 
Set Matches = Nothing 
If Len(ReplacePageStr(0)) > 0 Then ' 判断是否标签变量有值,如果有就替换掉. 
o_Content = Replace(o_Content, ReplacePageStr(0), ReplacePageStr(1), 1, -1, 1) 
ReplacePageStr = Array("", "") ' 替换后清空该数组变量 
End If 
GridView = o_Content 
End Function 

' *************************************** 
' 确定属性 
' *************************************** 
Private Function Process(ByVal Attribute, ByVal Content) 
Dim Matches, SubMatches, Text 
Dim MatchTag, MatchContent 
Dim datasource, Name, Element, page, id 
datasource = "" : Name = "" : Element = "" : page = 0 : id = "" 
Set Matches = GetMatch(Attribute, "\s(.+?)\=\""(.+?)\""") 
If Matches.Count > 0 Then 
For Each SubMatches In Matches 
MatchTag = SubMatches.SubMatches(0) ' 取得属性名 
MatchContent = SubMatches.SubMatches(1) ' 取得属性值 
If Lcase(MatchTag) = "name" Then Name = MatchContent ' 取得name属性值 
If Lcase(MatchTag) = "datasource" Then datasource = MatchContent' 取得datasource属性值 
If Lcase(MatchTag) = "element" Then Element = MatchContent ' 取得element属性值 
If Lcase(MatchTag) = "page" Then page = MatchContent ' 取得page属性值 
If Lcase(MatchTag) = "id" Then id = MatchContent ' 取得id属性值 
Next 
If Len(Name) > 0 And Len(MatchContent) > 0 Then 
Text = Analysis(datasource, Name, Content, page, id) ' 执行解析属性 
If Len(datasource) > 0 Then Attribute = Replace(Attribute, "datasource=""" & datasource & """", "") 
If page > 0 Then Attribute = Replace(Attribute, "page=""" & page & """", "") 
Attribute = Replace(Attribute, "name=""" & Name & """", "", 1, -1, 1) 
Attribute = Replace(Attribute, "element=""" & Element & """", "", 1, -1, 1) 
Process = Array(Attribute, Text, Element) 
Else 
Process = Array(Attribute, "", "div") 
End If 
Else 
Process = Array(Attribute, "", "div") 
End If 
Set Matches = Nothing 
End Function 

' *************************************** 
' 解析 
' *************************************** 
Private Function Analysis(ByVal id, ByVal Name, ByVal Content, ByVal page, ByVal PageID) 
Dim Data 
Select Case Lcase(Name) ' 选择数据源 
Case "loop" Data = DataBind(id, Content, page, PageID) 
Case "for" Data = DataFor(id, Content, page, PageID) 
End Select 
Analysis = Data 
End Function 

' *************************************** 
' 绑定数据源 
' *************************************** 
Private Function DataBind(ByVal id, ByVal Content, ByVal page, ByVal PageID) 
Dim Text, Matches, SubMatches, SubText 
Execute "Text = " & id & "(1)" ' 加载数据源 
Set Matches = GetMatch(Content, "\<Columns\>([\s\S]+)\<\/Columns\>") 
If Matches.Count > 0 Then 
For Each SubMatches In Matches 
SubText = ItemTemplate(SubMatches.SubMatches(0), Text, page, PageID)' 执行模块替换 
Content = Replace(Content, SubMatches.value, SubText, 1, -1, 1) 
Next 
DataBind = Content 
Else 
DataBind = "" 
End If 
Set Matches = Nothing 
End Function 

' *************************************** 
' 匹配模板实例 
' *************************************** 
Private Function ItemTemplate(ByVal TextTag, ByVal Text, ByVal page, ByVal PageID) 
Dim Matches, SubMatches, SubMatchText 
Dim SecMatch, SecSubMatch 
Dim i, TempText 
Dim TextLen, TextLeft, TextRight 
Set Matches = GetMatch(TextTag, "\<ItemTemplate\>([\s\S]+)\<\/ItemTemplate\>") 
If Matches.Count > 0 Then 
For Each SubMatches In Matches 
SubMatchText = SubMatches.SubMatches(0) 
' --------------------------------------------- 
' 循环嵌套开始 
' --------------------------------------------- 
SubMatchText = GridView(SubMatchText) 
' --------------------------------------------- 
' 循环嵌套结束 
' --------------------------------------------- 
If UBound(Text, 1) = 0 Then 
TempText = "" 
Else 
TempText = "" 
' ----------------------------------------------- 
' 开始分页 
' ----------------------------------------------- 
If Len(page) > 0 And page > 0 Then 
If Len(CurrentPage) = 0 Or CurrentPage = 0 Then CurrentPage = 1 
TextLen = UBound(Text, 2) 
TextLeft = (CurrentPage - 1) * page 
TextRight = CurrentPage * page - 1 
If TextLeft < 0 Then TextLeft = 0 
If TextRight > TextLen Then TextRight = TextLen 
c_PageStr = MultiPage(TextLen + 1, page, CurrentPage, PageUrl, "float:right", "", False) 

If Int(Len(c_PageStr)) > 0 Then 
ReplacePageStr = Array("<page:" & Trim(PageID) & "/>", c_PageStr) 
Else 
ReplacePageStr = Array("<page:" & Trim(PageID) & "/>", "") 
End If 
Else 
TextLeft = 0 
TextRight = UBound(Text, 2) 
End If 

For i = TextLeft To TextRight 
TempText = TempText & ItemReSec(i, SubMatchText, Text) ' 加载模板内容 
Next 
End If 
Next 
ItemTemplate = TempText 
Else 
ItemTemplate = "" 
End If 
Set Matches = Nothing 
End Function 

' *************************************** 
' 替换模板字符串 
' *************************************** 
Private Function ItemReSec(ByVal i, ByVal Text, ByVal Arrays) 
Dim Matches, SubMatches 
Set Matches = GetMatch(Text, "\$(\d+?)") 
If Matches.Count > 0 Then 
For Each SubMatches In Matches 
Text = Replace(Text, SubMatches.value, doQuote(Arrays(SubMatches.SubMatches(0), i)), 1, -1, 1) '执行替换 
Next 
ItemReSec = Text 
Else 
ItemReSec = "" 
End If 
Set Matches = Nothing 
End Function 

' *************************************** 
' 全局变量函数 
' *************************************** 
Private Sub ExecuteFunction 
Dim Matches, SubMatches, Text, ExeText 
Set Matches = GetMatch(c_Content, "\<function\:([0-9a-zA-Z_\.]*?)\((.*?)\""(.+?)\""(.*?)\)\/\>") 
If Matches.Count > 0 Then 
For Each SubMatches In Matches 
Text = SubMatches.SubMatches(0) & "(" & SubMatches.SubMatches(1) & """" & SubMatches.SubMatches(2) & """" & SubMatches.SubMatches(3) & ")" 
Execute "ExeText=" & Text 
c_Content = Replace(c_Content, SubMatches.value, ExeText, 1, -1, 1) 
Next 
End If 
Set Matches = Nothing 
End Sub 

' *************************************** 
' 普通替换全局标签 
' *************************************** 
Public Property Let Sets(ByVal t, ByVal s) 
Dim SetMatch, Bstr, SetSubMatch 
Set SetMatch = GetMatch(c_Content, "(\<Set\:([0-9a-zA-Z_\.]*?)\(((.*?)" & t & "(.*?))?\)\/\>)") 
If SetMatch.Count > 0 Then 
For Each SetSubMatch In SetMatch 
Execute "Bstr = " & SetSubMatch.SubMatches(1) & "(" & SetSubMatch.SubMatches(3) & """" & s & """" & SetSubMatch.SubMatches(4) & ")" 
c_Content = Replace(c_Content, SetSubMatch.Value, Bstr, 1, -1, 1) 
Next 
End If 
Set SetMatch = Nothing 
Set SetMatch = GetMatch(c_Content, "(\<Set\:" & t & "\/\>)") 
If SetMatch.Count > 0 Then 
For Each SetSubMatch In SetMatch 
c_Content = Replace(c_Content, SetSubMatch.Value, s, 1, -1, 1) 
Next 
End If 
Set SetMatch = Nothing 
End Property 

End Class