mproc_letters.vbs

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

' main programm section

class base

    private index, letters

    private sub class_initialize()
        letters = "abcdefghi jklmnopqr stuvwxyz "
        index = 0
    end sub

    public sub run()
        dim i
        host.startproc "outputwindow", "", "console"
        console "Start"
        host.startproc "packing", "run", ""
        for i = 1 to len(letters)
            host.createproc "typing", "run", ""
        next
        host.start("typing")
        host.startproc "proctrace", "", "tracing"
        msgbox "OK to terminate", vbinformation, "base"
        host.free "typing"
        host.joint "typing", 64, 0
        host.free packing
        host.joint packing, 64, 0
        host.free tracing
        host.joint tracing, 64, 0
        host.free console
        host.joint console, 64, 0
        host.free host.id
    end sub

    public sub typing_oninitialized(source)
        index = index + 1
        source.process.token = mid(letters, index, 1)
        console "Loaded [" & source.process.token & "]"
    end sub

end class

class packing

    private buffer, console

    private sub class_initialize()
        buffer = ""
        set console = scene.console
    end sub

    public sub push(token)
        buffer = buffer & token
    end sub

    public sub run
        dim pack, i, output
        do until host.release
            pack = split(buffer, " ")
            if ubound(pack) >= 3 then
                output = ""
                for i = 0 to 2
                    output = output & pack(i) & " "
                next
                buffer = right(buffer, len(buffer) - len(output))
                console  "[" & output & "]"
            end if
            wscript.sleep 100
        loop
    end sub

end class

class typing

    public token
    private packing, console

    private sub class_initialize()
        set packing = scene.packing
        set console = scene.console
    end sub

    public sub run
        do until host.release
            packing.push token
            wscript.sleep 500
        loop
    end sub

    private sub class_terminate()
        on error resume next
        console "Terminated [" & token & "]"
    end sub

end class

class proctrace

    private process_start_sink, process_stop_sink, console

    private sub class_initialize()
        set console = scene.console
        host.assignhandler "process_start_onobjectready", 2
        host.assignhandler "process_stop_onobjectready", 2
        set process_start_sink = wscript.createobject("WbemScripting.SWbemSink", "process_start_")
        set process_stop_sink = wscript.createobject("WbemScripting.SWbemSink", "process_stop_")
        with getobject("winmgmts:\\.\root\CIMV2")
            .execnotificationqueryasync process_start_sink, "SELECT * FROM __InstanceCreationEvent WITHIN 1 WHERE TargetInstance ISA 'Win32_Process'"
            .execnotificationqueryasync process_stop_sink, "SELECT * FROM __InstanceDeletionEvent WITHIN 1 WHERE TargetInstance ISA 'Win32_Process'"
        end with
        console "Process tracing start"
    end sub

    public sub process_start_onobjectready(receivedevent, asynccontext)
        message receivedevent, "Started"
    end sub

    public sub process_stop_onobjectready(receivedevent, asynccontext)
        message receivedevent, "Stopped"
    end sub

    private function message(receivedevent, action)
        console now() & " " & action & " " & receivedevent.targetinstance.name & " (" & receivedevent.targetinstance.processid & "|" & receivedevent.targetinstance.parentprocessid & ")"
    end function

    private sub class_terminate()
        on error resume next
        process_start_sink.cancel
        process_stop_sink.cancel
        console "Process tracing stop"
    end sub

end class

class outputwindow

    private cscriptmode, ieapplication, iedocument, scenewscript, sweepout

    private sub class_initialize()
        sweepout = false
        cscriptmode = (instr(1, wscript.fullname, "cscript.exe") > 0)
        if cscriptmode then
            set scenewscript = scene.wscript
        else
            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 iedocument = ieapplication.document
            iedocument.write "<html><head><title>Output</title><style>*{font-family: 'courier new'; font-size: 10pt; color: #000; background-color: #FFF; }</style></head><body></body>"
            host.assignhandler "ieobj_onquit", 0
        end if
    end sub

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

    public default sub writeln(text)
        if cscriptmode then
            scenewscript.echo text
        else
            on error resume next
            iedocument.write text & "<br>"
            err.clear
        end if
    end sub

    private sub class_terminate()
        sweepout = true
        on error resume next
        do while typename(iedocument) = "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