最近整理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。