ASP/VBScript动态创建属性对象的工厂类(DynamicObject)

!本文可能 超过1年没有更新,今后内容也许不会被维护或者支持,部分内容可能具有时效性,涉及技术细节或者软件使用方面,本人不保证相应的兼容和可操作性。

最近整理ASP/VBScript代码,发现过去的一个ASP实现的MVC框架,可惜是个半成品,效率也成问题,不过发现里面有些我写的代码,感觉还稍稍可以拿出来见人,于是今天作此文以记之。

说是ASP,其实和VBScript也脱不了干系,VBScript语言传承于Visual Basic,VB的语法灵活度已经不尽如人意了,VBS作为其子集可想而知。神马反射、自省等先进的技术,微软在.NET中才引入。作为被抛弃的技术,也不奢望微软能够提供支持,于是顽固守旧的程序员只有绞尽脑汁的去模仿实现一些类似的功能。

好吧,我承认很长一段时间我就是顽固守旧派中的一员,今天介绍的就是其中的一项功能,动态创建一个属性对象,属性对象姑且这么称呼,也就是说动态创建的对象只包含属性(Properties)。

下面贴出实现代码供大家参考:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
'
' ASP/VBScript Dynamic Object Generator
' Author: WangYe
' For more information please visit
'     http://wangye.org/
' 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://wangye.org", 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增加了一些特性,我先把最新的代码贴出来供大家参考:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
'
' ASP/VBScript Dynamic Object Generator
' Author: WangYe
' For more information please visit
'     http://wangye.org/
' 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。

若无特别说明,本网站文章均为原创,原则上这些文章不允许转载,但是如果阁下是出于研究学习目的可以转载到阁下的个人博客或者主页,转载遵循创作共同性“署名-非商业性使用-相同方式共享”原则,请转载时注明作者出处谢绝商业性、非署名、采集站、垃圾站或者纯粹为了流量的转载。谢谢合作!
请稍后...

发表评论

电子邮件地址不会被公开。 必填项已用*标注

*