一个ASP创建动态对象的工厂类（类似PHP的stdClass）

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