提醒:本页面将不再更新、维护或者支持,文章、评论所叙述内容存在时效性,涉及技术细节或者软件使用方面不保证能够完全有效可操作,请谨慎参考!

最近整理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
'     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增加了一些特性,我先把最新的代码贴出来供大家参考:

'
' 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。