最近整理ASP/VBScript代碼，發現過去的一個ASP實現的MVC框架，可惜是個半成品，效率也成問題，不過發現裡面有些我寫的代碼，感覺還稍稍可以拿出來見人，於是今天作此文以記之。
說是ASP，其實和VBScript也脫不了干系，VBScript語言傳承於Visual Basic，VB的語法靈活度已經不盡如人意了，VBS作為其子集可想而知。神馬反射、自省等先進的技術，微軟在.NET中才引入。作為被拋棄的技術，也不奢望微軟能夠提供支持，於是頑固守舊的程序員只有絞盡腦汁的去模仿實現一些類似的功能。
好吧，我承認很長一段時間我就是頑固守舊派中的一員，今天介紹的就是其中的一項功能，動態創建一個屬性對象，屬性對象姑且這麼稱呼，也就是說動態創建的對象只包含屬性(Properties)。
下面貼出實現代碼供大家參考：
復制代碼 代碼如下:
'
' ASP/VBScript Dynamic Object Generator
' Author: WangYe
' For more information please visit
'
' This code is distributed under the BSD license
'
Const PROPERTY_ACCESS_READONLY = 1
Const PROPERTY_ACCESS_WRITEONLY = -1
Const PROPERTY_ACCESS_ALL = 0
Class DynamicObject
Private m_objProperties
Private m_strName
Private Sub Class_Initialize()
Set m_objProperties = CreateObject("Scripting.Dictionary")
m_strName = "AnonymousObject"
End Sub
Private Sub Class_Terminate()
If Not IsObject(m_objProperties) Then
m_objProperties.RemoveAll
End If
Set m_objProperties = Nothing
End Sub
Public Sub setClassName(strName)
m_strName = strName
End Sub
Public Sub add(key, value, access)
m_objProperties.Add key, Array(value, access)
End Sub
Public Sub setValue(key, value, access)
If m_objProperties.Exists(key) Then
m_objProperties.Item(key)(0) = value
m_objProperties.Item(key)(1) = access
Else
add key,value,access
End If
End Sub
Private Function getReadOnlyCode(strKey)
Dim strPrivateName, strPublicGetName
strPrivateName = "m_var" & strKey
strPublicGetName = "get" & strKey
getReadOnlyCode = _
"Public Function " & strPublicGetName & "() :" & _
strPublicGetName & "=" & strPrivateName & " : " & _
"End Function : Public Property Get " & strKey & _
" : " & strKey & "=" & strPrivateName & " : End Property : "
End Function
Private Function getWriteOnlyCode(strKey)
Dim pstr
Dim strPrivateName, strPublicSetName, strParamName
strPrivateName = "m_var" & strKey
strPublicSetName = "set" & strKey
strParamName = "param" & strKey
getWriteOnlyCode = _
"Public Sub " & strPublicSetName & "(" & strParamName & ") :" & _
strPrivateName & "=" & strParamName & " : " & _
"End Sub : Public Property Let " & strKey & "(" & strParamName & ")" & _
" : " & strPrivateName & "=" & strParamName & " : End Property : "
End Function
Private Function parse()
Dim i, Keys, Items
Keys = m_objProperties.Keys
Items = m_objProperties.Items
Dim init, pstr
init = ""
pstr = ""
parse = "Class " & m_strName & " :" & _
"Private Sub Class_Initialize() : "
Dim strPrivateName
For i = 0 To m_objProperties.Count - 1
strPrivateName = "m_var" & Keys(i)
init = init & strPrivateName & "=""" & _
Replace(CStr(Items(i)(0)), """", """""") & """:"
pstr = pstr & "Private " & strPrivateName & " : "
If CInt(Items(i)(1)) > 0 Then ' ReadOnly
pstr = pstr & getReadOnlyCode(Keys(i))
ElseIf CInt(Items(i)(1)) < 0 Then ' WriteOnly
pstr = pstr & getWriteOnlyCode(Keys(i))
Else ' AccessAll
pstr = pstr & getReadOnlyCode(Keys(i)) & _
getWriteOnlyCode(Keys(i))
End If
Next
parse = parse & init & "End Sub : " & pstr & "End Class"
End Function
Public Function getObject()
Call Execute(parse)
Set getObject = Eval("New " & m_strName)
End Function
Public Sub invokeObject(ByRef obj)
Call Execute(parse)
Set obj = Eval("New " & m_strName)
End Sub
End Class
對於屬性對象分別提供了Property直接訪問模式和set或者get函數訪問模式，當然我還提供了三種權限控制，在add方法中使用，分別是PROPERTY_ACCESS_READONLY（屬性只讀）、PROPERTY_ACCESS_WRITEONLY（屬性只寫）和PROPERTY_ACCESS_ALL（屬性讀寫），你可以像下面這樣使用（一個例子）：
復制代碼 代碼如下:
Dim DynObj
Set DynObj = New DynamicObject
DynObj.add "Name", "WangYe", PROPERTY_ACCESS_READONLY
DynObj.add "HomePage", "http://jb51.net", PROPERTY_ACCESS_READONLY
DynObj.add "Job", "Programmer", PROPERTY_ACCESS_ALL
'
' 如果沒有setClassName，
' 新創建的對象將會自動命名為AnonymousObject
' 但是如果創建多個對象，就必須指定名稱
' 否則就可能引起對象名重復的異常
DynObj.setClassName "User"
Dim User
Set User = DynObj.GetObject()
' 或者 DynObj.invokeObject User
Response.Write User.Name
' Response.Write User.getName()
Response.Write User.HomePage
' Response.Write User.getHomePage()
Response.Write User.Job
' Response.Write User.getJob()
' 改變屬性值
User.Job = "Engineer"
' User.setJob "Engineer"
Response.Write User.getJob()
Set User = Nothing
Set DynObj = Nothing
其原理很簡單，就是通過給定的Key-Value動態生成VBS Class腳本代碼，然後調用Execute執行以便於將這段代碼加入到代碼上下文流中，最後再通過Eval新建這個對象。
好了，就介紹到這裡，今後我可能還會陸續公開一些Classic ASP的相關技巧代碼。
2012年11月7日更新
修復從舊項目移植過來導致的BUG。
修復了一些Bug增加了一些特性，我先把最新的代碼貼出來供大家參考：
復制代碼 代碼如下:'
' ASP/VBScript Dynamic Object Generator
' Author: WangYe
' For more information please visit
'
' This code is distributed under the BSD license
'
' UPDATE:
' 2012/11/7
' 1. Add variable key validator.
' 2. Add hasattr_ property for determine
' if the property exists.
' 3. Add getattr_ property for get property
' value safety.
' 4. Class name can be accessed by ClassName_ property.
' 5. Fixed some issues.
'
Const PROPERTY_ACCESS_READONLY = 1
Const PROPERTY_ACCESS_WRITEONLY = -1
Const PROPERTY_ACCESS_ALL = 0
Class DynamicObject
Private m_objProperties
Private m_strName
Private m_objRegExp
Private Sub Class_Initialize()
Set m_objProperties = CreateObject("Scripting.Dictionary")
Set m_objRegExp = New RegExp
m_objRegExp.IgnoreCase = True
m_objRegExp.Global = False
m_objRegExp.Pattern = "^[a-z][a-z0-9]*$"
m_strName = "AnonymousObject"
m_objProperties.Add "ClassName_", _
Array(m_strName, PROPERTY_ACCESS_READONLY)
End Sub
Private Sub Class_Terminate()
Set m_objRegExp = Nothing
If IsObject(m_objProperties) Then
m_objProperties.RemoveAll
End If
Set m_objProperties = Nothing
End Sub
Public Sub setClassName(strName)
If Not m_objRegExp.Test(strName) Then
' Skipped Invalid Class Name
' Raise
Exit Sub
End If
m_strName = strName
m_objProperties("ClassName_") = _
Array(m_strName, PROPERTY_ACCESS_READONLY)
End Sub
Public Sub add(key, value, access)
If Not m_objRegExp.Test(key) Then
' Skipped Invalid key
' Raise
Exit Sub
End If
If key = "hasattr_" Then key = "hasattr__"
If key = "ClassName_" Then key = "ClassName__"
'Response.Write key
m_objProperties.Add key, Array(value, access)
End Sub
Public Sub setValue(key, value, access)
If m_objProperties.Exists(key) Then
m_objProperties.Item(key)(0) = value
m_objProperties.Item(key)(1) = access
Else
add key,value,access
End If
End Sub
Private Function getReadOnlyCode(strKey)
Dim strPrivateName, strPublicGetName
strPrivateName = "m_var" & strKey
strPublicGetName = "get" & strKey
getReadOnlyCode = _
"Public Function " & strPublicGetName & "() :" & _
strPublicGetName & "=" & strPrivateName & " : " & _
"End Function : Public Property Get " & strKey & _
" : " & strKey & "=" & strPrivateName & _
" : End Property : "
End Function
Private Function getWriteOnlyCode(strKey)
Dim pstr
Dim strPrivateName, strPublicSetName, strParamName
strPrivateName = "m_var" & strKey
strPublicSetName = "set" & strKey
strParamName = "param" & strKey
getWriteOnlyCode = _
"Public Sub " & strPublicSetName & _
"(" & strParamName & ") :" & _
strPrivateName & "=" & strParamName & " : " & _
"End Sub : Public Property Let " & strKey & _
"(" & strParamName & ")" & _
" : " & strPrivateName & "=" & strParamName & _
" : End Property : "
End Function
Private Function parse()
Dim i, Keys, Items
Keys = m_objProperties.Keys
Items = m_objProperties.Items
Dim init, pstr
init = ""
pstr = ""
parse = "Class " & m_strName & " :" & _
"Private Sub Class_Initialize() : "
Dim strPrivateName, strAvailableKeys
For i = 0 To m_objProperties.Count - 1
strPrivateName = "m_var" & Keys(i)
init = init & strPrivateName & "=""" & _
Replace(CStr(Items(i)(0)), """", """""") & """:"
pstr = pstr & "Private " & strPrivateName & " : "
strAvailableKeys = strAvailableKeys & Keys(i) & ","
If CInt(Items(i)(1)) > 0 Then ' ReadOnly
pstr = pstr & getReadOnlyCode(Keys(i))
ElseIf CInt(Items(i)(1)) < 0 Then ' WriteOnly
pstr = pstr & getWriteOnlyCode(Keys(i))
Else ' AccessAll
pstr = pstr & getReadOnlyCode(Keys(i)) & _
getWriteOnlyCode(Keys(i))
End If
Next
init = init & "m_strAvailableKeys = Replace(""," & _
strAvailableKeys & """, "" "", """") : "
Dim hasstmt
hasstmt = "Private m_strAvailableKeys : " & _
"Public Function hasattr_(ByVal key) : " & _
"hasattr_ = CBool(InStr(m_strAvailableKeys," & _
" "","" & key & "","") > 0) : " & _
"End Function : " & _
"Public Function getattr_(ByVal key, ByVal defaultValue) : " & _
"If hasattr_(key) Then : getattr_ = Eval(key) : " & _
"Else : getattr_ = defaultValue : End If : " & _
"End Function : "
parse = parse & init & "End Sub : " & _
hasstmt & pstr & "End Class"
End Function
Public Function getObject()
'Response.Write parse
Call Execute(parse)
Set getObject = Eval("New " & m_strName)
End Function
Public Sub invokeObject(ByRef obj)
Call Execute(parse)
Set obj = Eval("New " & m_strName)
End Sub
End Class
需要注意的幾個新特性：
1. 增加了類名和屬性名驗證措施，防止畸形的類名或者屬性名導致動態生成的代碼出現語法錯誤。不過處理的方式是直接忽略，本來想Raise異常的，但考慮到VBS對異常處理不是很好的，所以采取忽略策略：
' 有效的類名或屬性名必須以字母開頭
復制代碼 代碼如下:Dim DynObj
Set DynObj = New DynamicObject
DynObj.setClassName "1User" ' 此句將被忽略，因為類名不能以數字開始
' 下面這句也會被忽略，因為屬性名不能以特殊符號開始
DynObj.add "%Name", "WangYe", PROPERTY_ACCESS_READONLY
Set DynObj = Nothing
2. 對於動態對象增加了hasattr_方法，該屬性用於檢測此對象是否支持相應的屬性，可以在訪問一個屬性前先確定該對象是否支持此屬性：
復制代碼 代碼如下:
Dim DynObj
Set DynObj = New DynamicObject
DynObj.add "Name", "WangYe", PROPERTY_ACCESS_READONLY
Response.Write DynObj.hasattr_("Name") ' True
Response.Write DynObj.hasattr_("Favor") ' False
Set DynObj = Nothing
3. 對於動態對象增加了getattr_方法，此方法可以安全的獲取指定的屬性值，避免因為對象不存在屬性值導致出錯。方法原型為getattr_(ByVal propertyName, ByVal defaultValue)，參數propertyName指定屬性的名字，defaultValue是當指定屬性不存在是可以返回的默認值，比如下面代碼：
復制代碼 代碼如下:
Dim DynObj
Set DynObj = New DynamicObject
DynObj.add "Name", "WangYe", PROPERTY_ACCESS_READONLY
Response.Write DynObj.getattr_("Name", "N/A") ' WangYe
Response.Write DynObj.getattr_("Favor", "N/A") ' N/A
Set DynObj = Nothing
4. 動態對象的類名可以通過ClassName_屬性或者getClassName_()方法獲取。
2012年11月12日更新
修復雙引號導致構造類錯誤或導致執行任意代碼的Bug。
