mproc_counters.vbs

option explicit
dim mproc
set mproc = new multiprocess
mproc.launch "starter", "run", ""

' main programm section

class starter

    public sub run()
        host.startproc "base", "run", ""
        msgbox "OK to terminate", vbinformation, "starter"
        host.free "counter"
        wscript.sleep 1000
        host.terminate "counter"
        host.free "display"
        wscript.sleep 1000
        host.terminate "display"
        host.free base
        wscript.sleep 1000
        host.terminate base
        host.free host.id
    end sub

end class

class base

    public max

    public sub run()
        dim node, text, n
        host.startproc "iewindow", "", "display"
        for n = 0 to 11
            host.createproc "counter", "run", ""
        next
        max = 100
        host.start("counter")
    end sub

    public sub pushmax
        max = max + 100
    end sub

    public sub counter_oninitialized(source)
        dim node, r, g, b
        randomize
        set node = display.document.createelement("div")
        r = int(rnd*256)
        g = int(rnd*256)
        b = int(rnd*256)
        node.style.backgroundcolor = rgb(r, g, b)
        if (.5 * r) + g + (.25 * b) > 191 then
            node.style.color = "#000"
        else
            node.style.color = "#FFF"
        end if
        node.style.width = 0
        node.style.height = 20
        display.document.getelementbyid("testarea").appendchild(node)
        node.appendchild(display.document.createtextnode("starting"))
        set source.process.tag = node
        set node = nothing
    end sub

end class

class counter

    public tag

    public sub run()
        dim c
        c = 0
        do
            c = c + 1
            do while c > ancestor.max
                ancestor.pushmax
            loop
            tag.innertext = c
            tag.style.width = int(tag.parentnode.offsetwidth * c / ancestor.max)
        loop until host.release
        tag.innertext = "terminated"
    end sub

end class

class iewindow

    public document

    private ieapplication, sweepout

    private sub class_initialize()
        sweepout = false
        set ieapplication = wscript.createobject("internetexplorer.application", "ieobj_")
        with ieapplication
            .menubar = false
            .toolbar = false
            .resizable = true
            .statusbar = false
            .addressbar = false
            .visible = true
            .navigate "about:blank"
        end with
        set document = ieapplication.document
        document.write "<html><head><title>Output</title><style>*{font-family: 'courier new'; font-size: 10pt; color: #000; background-color: #CCC; }</style></head><body><div id='testarea'></div></body>"
        host.assignhandler "ieobj_onquit", 0
    end sub

    public sub ieobj_onquit
        if not sweepout then host.free 0
    end sub

    private sub class_terminate()
        sweepout = true
        on error resume next
        do while typename(document) = "HTMLDocument"
            ieapplication.quit
            wscript.sleep 1
        loop
    end sub

end class

' do not modify service class section

class multiprocess

    public primary, ancestor, parent, process, err
    public names, execs, hosts
    public id, aid, isprimary
    public classname, methodname, aliasname
    public found, lost, active
    public state, permit, release
    private container, signature, wshshell

    public sub launch(startclassname, startmethodname, startaliasname)
        permit = false
        release = false
        executeglobal "dim scene, host, ancestor, process"
        if not isempty(host) then exit sub
        set host = me
        executeglobal "set host.err = err"
        executeglobal "function getroot: set getroot = me: end function"
        set parent = getroot
        isprimary = not wscript.arguments.named.exists("task")
        if isprimary then
            dim sample
            state = 24
            randomize
            signature = ""
            do
                signature = signature & hex(rnd * 16)
            loop while len(signature) < 16
            aid = empty
            id = 0
            found = 0
            lost = 0
            set wshshell = createobject("WScript.Shell")
            set primary = host
            set ancestor = nothing
            set process = nothing
            set scene = parent
            set parent.ancestor = nothing
            set parent.process = nothing
            set hosts = createobject("Scripting.Dictionary")
            set execs = createobject("Scripting.Dictionary")
            set names = createobject("Scripting.Dictionary")
            classname = empty
            methodname = empty
            aliasname = empty
            set hosts(0) = host
            set container = getobject("new:{C08AFD90-F2A1-11D1-8455-00A0C91F3880}")
            container.putproperty signature, parent
            startproc startclassname, startmethodname, startaliasname
            on error resume next
            do
                for each sample in execs.keys
                    if release or active = 0 then exit do
                    if not (execs(sample) is nothing) then
                        if execs(sample).status > 0 then
                            abolish sample
                        end if
                    end if
                    wscript.sleep 1
                next
            loop
            release = true
            state = 28
            scenequit
        else
            dim job
            job = split(wscript.arguments.named("task"), ";")
            signature = cstr(job(0))
            do
                for each container in createobject("Shell.Application").windows
                    if isobject(container.getproperty(signature)) then
                        exit do
                    end if
                next
                wscript.sleep 1
            loop
            aid = clng(job(1))
            id = clng(job(2))
            found = null
            lost = null
            set scene = container.getproperty(signature)
            set primary = scene.host
            set hosts = primary.hosts
            set ancestor = hosts(aid)
            if isresponsive(aid) then
                set parent.ancestor = ancestor.parent.process
            else
                set parent.ancestor = nothing
            end if
            classname = cstr(job(3))
            methodname = cstr(job(4))
            aliasname = cstr(job(5))
            state = 4
            primary.implicate id, aliasname, host
            executeglobal "set process = new " & classname
            executeglobal "set host.process = process"
            executeglobal "set scene." & aliasname & " = process"
            if isresponsive(aid) then
                executeglobal "set host.ancestor.parent." & aliasname & " = process"
            end if
            state = 8
            primary.staff host
            ancestorevent "oninitialized"
            state = 12
            if methodname <> "" then
                do until permit
                    wscript.sleep 10
                loop
                state = 16
                executeglobal "process." & methodname
            end if
            state = 20
            ancestorevent "oncompleted"
            state = 24
            do until release
                wscript.sleep 10
            loop
            state = 28
        end if
    end sub

    public default function startproc(classname, methodname, aliasname)
        set startproc = start(createproc(classname, methodname, aliasname))
    end function

    public function createproc(classname, methodname, aliasname)
        if aliasname = "" then aliasname = classname
        newvar aliasname
        scene.host.newvar aliasname
        createproc = primary.spawn(id, classname, methodname, aliasname)
    end function

    public function spawn(issuer, classname, methodname, aliasname)
        if not release then
            found = found + 1
            spawn = found
            active = found - lost
            names(spawn) = aliasname
            set hosts(spawn) = nothing
            if not hosts.exists(aliasname) then
                hosts.add aliasname, createobject("Scripting.Dictionary")
            end if
            set hosts(aliasname)(spawn) = nothing
            execs.add spawn, wshshell.exec("""" & wscript.fullname & """ """ & wscript.scriptfullname & """ ""/task:" & join(array(signature, issuer, spawn, classname, methodname, aliasname), ";") & """")
        end if
    end function

    public function start(target)
        select case outline(target)
        case "Nothing", "multiprocess"
            do while getstate(target) < 12
                wscript.sleep 10
            loop
            if isresponsive(target) then
                set start = hosts(target).process
                hosts(target).permit = true
            else
                set start = nothing
            end if
        case "Dictionary"
            dim elt
            set start = hosts(target)
            for each elt in start.keys
                do while getstate(elt) < 12
                    wscript.sleep 10
                loop
            next
            for each elt in start.keys
                if isresponsive(elt) then
                    hosts(elt).permit = true
                end if
            next
        case else
            set start = nothing
        end select
    end function

    public sub implicate(id, aliasname, host)
        set hosts(aliasname)(id) = host
        set hosts(id) = host
    end sub

    public sub staff(host)
        set hosts(host.process) = host
    end sub

    public sub abolish(id)
        if hosts.exists(names(id)) then
            hosts(names(id))(id) = empty
        end if
        names(id) = empty
        if isresponsive(id) then
            hosts(hosts(id).process) = empty
        end if
        hosts(id) = empty
        set execs(id) = nothing
        lost = lost + 1
        active = found - lost
    end sub

    private sub ancestorevent(eventname)
        if aid > 0 then
            on error resume next
            executeglobal "ancestor." & aliasname & "_" & eventname & " host.hosts(" & id & ")"
            if err.number = 424 or err.number = 438 then err.clear
        end if
    end sub

    public sub assignhandler(handlername, byval varsqty)
        dim vars
        vars = ""
        if varsqty > 0 then
            do
                vars = vars & "param" & varsqty
                varsqty = varsqty - 1
                if varsqty = 0 then exit do
                vars = vars & ", "
            loop
        end if
        executeglobal "sub " & handlername & "(" & vars & "): process." & handlername & " " & vars & ": end sub"
    end sub

    public sub newvar(varname)
        executecommand "dim " & varname
    end sub

    public sub executecommand(command)
        executeglobal command
    end sub

    public function getstate(target)
        select case outline(target)
        case "multiprocess"
            on error resume next
            getstate = hosts(target).state
            if err.number <> 0 then
                err.clear
                getstate = 64
            end if
        case "Nothing"
            getstate = 1
        case "Dictionary"
            getstate = null
        case empty
            getstate = 0
        case else
            getstate = 64
        end select
    end function

    private function outline(target)
        on error resume next
        if hosts.exists(target) then
            outline = typename(hosts(target))
            if err.number <> 0 then
                err.clear
                outline = "Object"
            end if
        else
            outline = empty
        end if
    end function

    public function isresponsive(target)
        isresponsive = cbool(getstate(target) and 28)
    end function

    public function getid(target)
        on error resume next
        if isobject(target) then
            if isresponsive(target) then
                getid = hosts(target).id
                if err.number = 0 then exit function
                err.clear
            end if
        elseif primary.execs.exists(target) then
            getid = target
            exit function
        end if
        getid = null
    end function

    public function gethost(target)
        on error resume next
        if hosts.exists(target) then
            set gethost = hosts(target)
            if err.number = 0 then exit function
            err.clear
        end if
        set gethost = nothing
    end function

    public sub free(target)
        select case outline(target)
        case "multiprocess"
            on error resume next
            gethost(target).release = true
            err.clear
        case "Dictionary"
            dim elt
            for each elt in gethost(target)
                free(elt)
            next
        end select
    end sub

    public function joint(target, state, timeout)
        dim reftime
        reftime = timer
        select case outline(target)
        case "multiprocess", "Nothing"
            do while getstate(target) < state
                if timeisout(timeout, reftime) then
                    joint = false
                    exit function
                end if
                wscript.sleep 10
            loop
        case "Dictionary"
            dim elt
            for each elt in gethost(target)
                do while getstate(elt) < state
                    if timeisout(timeout, reftime) then
                        joint = false
                        exit function
                    end if
                    wscript.sleep 10
                loop
            next
        end select
        joint = true
    end function

    private function timeisout(timeout, reftime)
        if timeout > 0 then
            dim delta
            delta = timer - reftime
            if delta < 0 then delta = delta + 86400
            if delta > timeout then
                timeisout = true
            end if
        else
            timeisout = false
        end if
    end function

    public sub interrupt(target, timeout)
        select case outline(target)
        case "multiprocess"
            on error resume next
            with gethost(target).parent
                .wscript.timeout = timeout
                .wscript.quit
            end with
            err.clear
        case "Dictionary"
            dim elt
            for each elt in gethost(target)
                interrupt elt, timeout
            next
        end select
    end sub

    public sub kickout(target)
        if primary.execs.exists(target) then
            if getstate(target) < 64 then
                on error resume next
                primary.execs(target).terminate
                err.clear
            end if
        else
            select case outline(target)
            case "multiprocess"
                kickout getid(target)
            case "Dictionary"
                dim elt
                for each elt in gethost(target)
                    kickout(elt)
                next
            end select
        end if
    end sub

    public sub terminate(target)
        interrupt target, 1
        if not joint(target, 64, 2) then kickout target
    end sub

    public sub push(name, value)
        container.putproperty name, value
    end sub

    public function pop(name)
        on error resume next
        if isobject(container.getproperty(name)) then
            set pop = container.getproperty(name)
        else
            pop = container.getproperty(name)
        end if
    end function

    private sub scenequit
        if isprimary then
            dim col, i, status
            col = execs.keys
            for i = ubound(col) to 0 step -1
                interrupt col(i), 1
            next
            wscript.sleep 2000
            on error resume next
            for i = ubound(col) to 0 step -1
                status = execs(col(i)).status
                if err.number = 0 and status = 0 then execs(col(i)).terminate
                err.clear
            next
            container.quit
            createobject("wscript.shell").popup "scenequit", 1, "primary", 64
        end if
    end sub

    private sub class_terminate()
        if state < 28 and isprimary then scenequit
    end sub

end class