Code-a-holic: BOOST

Showing posts with label BOOST. Show all posts

Tuesday, June 10, 2008

[VBScript] StandardLibrary.zip

For those interested, who haven't been able to download it recently, here's the latest iteration of StandardLibrary.vbs. Now it's called stdlib.vbs and can be obtained from my boost account at the Perth Linux Users Group.

There have been a few changes, mostly additional functions and the odd tweak in favour of better functionality.

Significant in the additions are a few functions for sending emails: Blat, BlatAttachment, ErrorEmail, ErrorEmailApp, RedemptionSend and ThunderbirdSend. If I remember correctly, ErrorEmail has been around for a while, but is included here for completeness sake.

Function Blat( sTo, sSubj, sText )
    Const TIMEOUT_LIMIT = 60000
    Const TIMEOUT_SLICE = 500
    Const BLAT_CMD = "c:\bin\Blat.exe [1] -to [2] -subject [3] -server mail.quux.foo.com -f bar@baz.quux -u foo@bar.baz -pw xxxx -unicode"
    Dim nTimeout
    Dim bTimedOut
    Dim oExec
    Dim sCmd
    Dim sFolder
    Dim sName
    Dim sPath
    Dim sSave
    Dim sResult
    Dim aResult
    Dim bResult
    Dim bDontCare
    
    sFolder = oFSO.GetSpecialFolder( TEMPORARY_FOLDER )
    sName = oFSO.GetTempName
    sPath = oFSO.BuildPath( sFolder, sName) 
    WriteFileU sPath, sText, WF_CREATE

    sCmd = Subst( BLAT_CMD, Array( DQ( sPath ), sTo, DQ( sSubj ) ))
    bTimedOut = False
    nTimeout = TIMEOUT_LIMIT
    Set oExec = oShell.Exec( sCmd )
    bDontCare = SetPriority( "blat.exe", REALTIME_PRIORITY )
    Do While oExec.Status = 0
        Doze TIMEOUT_SLICE
        nTimeout = nTimeout - TIMEOUT_SLICE
        If nTimeout < 1 Then
            bTimedOut = True
            Exit Do
        End If
    Loop
    sResult = oExec.StdOut.ReadAll
    aResult = Split( sResult, vbCRLF )
    If bTimedOut Or Left( aResult( 2 ), 6 ) = "Error:" Then
        bResult = False
    Else
        bResult = True
    End If  
    Blat = Array( bResult, sResult )    
End Function

Function BlatAttachment( sTo, sSubj, sText, aAttachments )
    Const TIMEOUT_LIMIT = 30000
    Const TIMEOUT_SLICE = 500
    Const BLAT_CMD = "c:\bin\Blat.exe [1] -to [2] -subject [3] -server mail.quux.foo.com -f bar@baz.quux -u foo@bar.baz -pw xxxx -unicode"

    Dim nTimeout
    Dim bTimedOut
    Dim oExec
    Dim sCmd
    Dim sFolder
    Dim sName
    Dim sPath
    Dim sSave
    Dim sResult
    Dim aResult
    Dim bResult
    Dim bDontCare
    
    sFolder = oFSO.GetSpecialFolder( TEMPORARY_FOLDER )
    sName = oFSO.GetTempName
    sPath = oFSO.BuildPath( sFolder, sName) 
    WriteFileU sPath, sText, WF_CREATE
    
    sCmd = Subst( BLAT_CMD, Array( DQ( sPath ), sTo, DQ( sSubj ) ))
    bTimedOut = False
    nTimeout = TIMEOUT_LIMIT
    Set oExec = oShell.Exec( sCmd )
    bDontCare = SetPriority( "blat.exe", REALTIME_PRIORITY )
    Do While oExec.Status = 0
        Doze TIMEOUT_SLICE
        nTimeout = nTimeout - TIMEOUT_SLICE
        If nTimeout < 1 Then
            bTimedOut = True
            Exit Do
        End If
    Loop
    sResult = oExec.StdOut.ReadAll
    aResult = Split( sResult, vbCRLF )
    If bTimedOut Or Left( aResult( 2 ), 6 ) = "Error:" Then
        bResult = False
    Else
        bResult = True
    End If  
    Blat = Array( bResult, sResult )    
End Function

Const SLICE = 1024

Sub ErrorEmail( vTo, sSubj, sText )
    Dim sCC
    Dim sTo
    If IsArray( vTo ) Then
        sTo = Escape( vTo( 0 ) )
        sCC = Escape( vTo( 1 ) )
    Else
        sTo = Escape( vTo )
    End If
    
    sSubj= Escape( sSubj )
    sText = Escape( sText )
    
    If IsArray( vTo ) Then
        sCmd = Subst( "mailto:[1]?subject=[3]&cc=[2]&body=[4]", Array( sTo, sCC, sSubj, sText ) )
    Else
        sCmd = Subst( "mailto:[1]?subject=[2]&body=[3]", Array( sTo, sSubj, sText ) )
    End If
    '~ MsgBox sCmd
    On Error Resume Next
    oShell.Run sCmd ', 0, True
    If Err.Number <> 0 Then
        document.parentwindow.clipboardData.SetData "text", UnEscape( sText )
        MsgBox "Windows didn't like the size of message. I've put it on the clipboard"
        sCmd = Subst( "mailto:[1]?subject=[2]", Array( sTo, sSubj ) )
        oShell.Run sCmd, 0, True
        HTASleep 5000
    End If
End Sub

Sub ErrorEmailApp( cApp, vTo, sSubj, sText )
    Dim sCC
    Dim sTo
    If IsArray( vTo ) Then
        sTo = Escape( vTo( 0 ) )
        sCC = Escape( vTo( 1 ) )
    Else
        sTo = Escape( vTo )
    End If
    
 IF cApp <> "" Then cApp = DQ( cApp ) & " "
 
    sSubj= Escape( sSubj )
    sText = Escape( sText )
    
    If IsArray( vTo ) Then
        sCmd = Subst( "mailto:[1]?subject=[3]&cc=[2]&body=[4]", Array( sTo, sCC, sSubj, sText ) )
    Else
        sCmd = Subst( "mailto:[1]?subject=[2]&body=[3]", Array( sTo, sSubj, sText ) )
    End If
    On Error Resume Next
    oShell.Run cApp & sCmd ', 0, True
    If Err.Number <> 0 Then
        document.parentwindow.clipboardData.SetData "text", UnEscape( sText )
        MsgBox "Windows didn't like the size of message. I've put it on the clipboard"
        sCmd = Subst( "mailto:[1]?subject=[2]", Array( sTo, sSubj ) )
        oShell.Run cApp & sCmd, 0, True
        HTASleep 5000
    End If
End Sub

Function RedemptionSend( aRecipients, sSubject, sBody )
  dim oSafeItem
  Dim oItem 
  Dim oApplication
  Dim oNameSpace
  Dim sRecip
  
  set oSafeItem = CreateObject("Redemption.SafeMailItem") 'Create an instance of Redemption.SafeMailItem 
  set oApplication = CreateObject("Outlook.Application")
  set oItem = oApplication.CreateItem(0) 'Create a new message
  oSafeItem.Item = oItem 'set Item property
  For Each sRecip In aRecipients
    If sRecip <> "" Then
      oSafeItem.Recipients.Add sRecip
      oSafeItem.Recipients.ResolveAll
    End If
  Next
  oSafeItem.Subject = sSubject 
  oSafeItem.Body = sBody
  oSafeItem.Send
End Function

Function ThunderbirdSend( aRecipients, sSubject, sBody, aAttachments )
    'thunderbird.exe -compose "to='foo@nowhere.net,foo@foo.de',subject=cool page,attachment=file:///c:/temp/foode.txt" 
    Dim sRecip
    Dim sApp
  Dim sCmd
    sRecip = "'" & Join( aRecipients, "," ) & "'"
    Dim sAttItem
    Dim sAttach
    For Each sAttItem in aAttachments
        If sAttItem <> "" Then
            sAttItem = Replace(sAttItem, "\", "/" )
            sAttach = sAttach & "attachment='file:///" & sAttItem & "',"
        End If
    Next
    If Right( sAttach, 1 ) = "," Then
        sAttach = Left( sAttach, Len( sAttach ) - 1 )
    End If
    sApp = "C:\Program Files\Mozilla Thunderbird\thunderbird.exe"
    sCmd = Subst( " -compose ""to=[1],subject=[2],body=[3],[4]""", Array( sRecip, sSubject, sBody, sAttach ))
    oShell.Run DQ( sApp ) & sCmd, 0, False
    HTASleep 5000
End Function

A while back Derek Parnell wrote a replacement for Euphoria's print function which would show the structure of arrays. ShowStructure and a support routine AsString make this available to the VBScript programmer. By the way, in case you haven't heard, Euphoria is now open-source!

function ShowStructure( vToShow )
    dim nCounter
    dim sResult
    dim nArraySize
    sResult = ""

    if isarray( vToShow ) then
        nArraySize = ubound( vToShow )
        If nArraySize >= 0 Then
            for nCounter = 0 to nArraySize - 1
                sResult = sResult & ShowStructure( vToShow( nCounter ) ) & ","
            next
            sResult = "{" & sResult & ShowStructure( vToShow( nArraySize ) ) & "}"
        Else
            sResult = "{}"
        End If
    else
        sResult = AsString( vToShow )
    end if
    ShowStructure = sResult
end function

Function AsString( x )
    Dim sResult
    If TypeName( x ) = "Null" Then
        sResult = "Null"
    Else
        sResult = CStr( x )
    End If
    AsString = sResult
End Function

The output, then, from code such as this:

a = Array(1,Array(2,3,Array("moo")))
wscript.echo showstructure(a)

would be

{1,{2,3,{moo}}}

which maybe leads on toward data serialisation ...

There've been some additions to the file handling space, with the addition of routines to read and write unicode files (ReadFileU, WriteFileU, ReadFirstLineU and its ANSI equivalent, ReadFirstLine.)

Logging has been worked on. It's something I'm unlikely to be totally happy with, but there's now a SetLog and a ClearLog as well as the standard Log (and, given the possibility of confusion with the logarithm system, maybe I should change it to Trace (oh man, how many scripts that would break!))

What else? Well, BuildTree builds a directory tree. FirstLineOf returns the first vbNewLine-delimited line from a string (useful where you've used ReadFile or ReadFileU to inhale an entire file.) LastLineOf does what FirstLineOf does but for the end of the file, and NthLineOf gets you the ... nth ... line.

I've actually forgotten what I wrote UpToAndAfter for, but it's included anyway.

IsOnLine uses the ResolveIP function with the IP address 198.182.196.48 (which points somewhere on linux.org) to see if you are still on line.

SetPriority uses the same code as used in BOOST to set process priority.

StrInArray finds a string in an array of strings, with optional case sensitivity.

StringMap scans a string for the presence of items in one array and swaps them for the equivalently indexed elements in the second array. If the second array is a string, they get swapped for that string.

Doze wraps WSCript.Sleep and HTASleep, so that it can be used in .VBS files and .HTA files.

ModalThing2 shows a modal dialog (only works in .HTA files)

And, finally, SoundMessage:

Sub SoundMessage( sSoundFile, sMessage )
    Dim sCommand
    Dim sFullname
    sCommand = "sndrec32 /play /close " & DQ( sSoundFile )
    oShell.Run sCommand, 0, False
    Doze 1000
    Msgbox sMessage
End Sub

Obviously, if you see something that needs to be fixed, fix it. And tell me to fix it so that it can be fixed in the distribution and your name can be added to the list of contributors.

© Copyright Bruce M. Axtens, 2008

[Visual BASIC 6] BOOST (v3)

BOOST got another look-in recently. I had been using it exclusively to do "realtime" and "kill". This particular time I tried to do an "abovenormal" -- instead it did a "kill".

In the process of finding and fixing that bug, I replaced the Collection mechanism with the augmented Collection supplied by the "Class Builder" add-in.

The source code is essentially the same as before but with a few changes. First the SysVars and Var classes. (The comments are predominantly those supplied by the add-in.)

First, SysVars.cls:

'local variable to hold collection
Private mCol As Collection

Public Function Add(key As String, Optional sKey As String) As Var
    Dim objNewMember As Var
    'create a new object
    Set objNewMember = New Var

    'set the properties passed into the method
    objNewMember.Value = key
    objNewMember.key = sKey
    If Len(sKey) = 0 Then
        mCol.Add objNewMember
    Else
        mCol.Add objNewMember, sKey
    End If

    'return the object created
    Set Define = objNewMember
    Set objNewMember = Nothing

End Function

Public Property Get Item(vntIndexKey As Variant) As Var
    'used when referencing an element in the collection
    'vntIndexKey contains either the Index or Key to the collection,
    'this is why it is declared as a Variant
    'Syntax: Set foo = x.Item(xyz) or Set foo = x.Item(5)
    Set Item = mCol(vntIndexKey)
End Property

Public Function Exists(vntIndexKey As Variant) As Boolean
    Dim V As Var
    On Error Resume Next
    Set V = mCol(vntIndexKey)
    Exists = (Err.Number = 0)
End Function

Public Function Count() As Long
    'used when retrieving the number of elements in the
    'collection. Syntax: Debug.Print x.Count
    Count = mCol.Count
End Function


Public Sub Remove(vntIndexKey As Variant)
    'used when removing an element from the collection
    'vntIndexKey contains either the Index or Key, which is why
    'it is declared as a Variant
    'Syntax: x.Remove(xyz)


    mCol.Remove vntIndexKey
End Sub

Public Sub Modify(sValue As String, sKey As String)
    Dim V As Var
    'Set V = New Var
    Set V = mCol.Item(sKey)
    V.Value = sValue
    'mCol.Remove sKey
    'Add sValue, sKey
End Sub

Public Property Get NewEnum() As IUnknown
    'this property allows you to enumerate
    'this collection with the For...Each syntax
    Set NewEnum = mCol.[_NewEnum]
End Property


Private Sub Class_Initialize()
    'creates the collection when this class is created
    Set mCol = New Collection
End Sub


Private Sub Class_Terminate()
    'destroys collection when this class is terminated
    Set mCol = Nothing
End Sub

Next, Vars.cls (it's tiny but it could hold so much more):

Public key As Variant
Public Value As Variant

Now the main module. The first thing that is different here, is that nLevel is now a Long. Integer doesn't handle the ABOVENORMAL_PRIORITY value without complaint.

Next change is removing the reference to Collection, changing it to SysVars and setting up the values.

The benefit of using SysVars and that approach to the Collection object is that we now have an .Exists method, so we now have a tidier way of setting nLevel and trapping invalid settings thereof.

Sub Main()
    
    Dim sLevel As String
    Dim nLevel As Long
    Dim sProcess As String
    Dim sCommand As String
    Dim nInstances As Integer
    
    Dim cPrio As New SysVars
    
    cPrio.Add KILL_PROCESS, "kill"
    cPrio.Add LOW_PRIORITY, "low"
    cPrio.Add BELOWNORMAL_PRIORITY, "belownormal"
    cPrio.Add NORMAL_PRIORITY, "normal"
    cPrio.Add ABOVENORMAL_PRIORITY, "abovenormal"
    cPrio.Add HIGH_PRIORITY, "high"
    cPrio.Add REALTIME_PRIORITY, "realtime"
    
    cPrio.Add KILL_PROCESS, "0"
    cPrio.Add LOW_PRIORITY, "1"
    cPrio.Add BELOWNORMAL_PRIORITY, "2"
    cPrio.Add NORMAL_PRIORITY, "3"
    cPrio.Add ABOVENORMAL_PRIORITY, "4"
    cPrio.Add HIGH_PRIORITY, "5"
    cPrio.Add REALTIME_PRIORITY, "6"
    
    Dim aArgs As Variant
    
    If Command() = "" Then
        Syntax
        End
    End If
    
    aArgs = GetCommandLine(2)
    sProcess = aArgs(0)
    sLevel = aArgs(1)
    
    If sProcess = "" Or sLevel = "" Then
        Syntax
        End
    End If
    
    If cPrio.Exists(sLevel) Then
        nLevel = Val(cPrio.Item(sLevel).Value)
    Else
        ConsoleWrite "Invalid selection of runlevel." & vbNewLine
        Syntax
        End
    End If
    
    If nLevel = 0 Then
        nInstances = KillProcess(sProcess)
        If nInstances = 0 Then
            ConsoleWrite "No instances of " & sProcess & " found to kill" & vbNewLine
        Else
            ConsoleWrite nInstances & " " & IIf(nInstances > 1, "instances", "instance") & " of " & sProcess & " killed." & vbNewLine
        End If
    Else
        ConsoleWrite sProcess & IIf(SetPriority(sProcess, nLevel), _
            " boosted", " NOT boosted") & _
            " to priority " & sLevel & " (" & nLevel & ")." & vbNewLine
    End If

End Sub

All the other routines are as before.

I haven't gotten around to extending this tool to do stuff to remote computers. It's not hard; killing a process on another machine means another value for sComputer in KillProcess, and, of course, the relevant privilege level.

© Copyright Bruce M. Axtens, 2008

Thursday, December 20, 2007

[Visual BASIC 6] BOOST (v2)

I revisited BOOST this week. A friend had pointed out to me some time back that /P: and /L: were a bit of a pain when one wanted to speed something up quickly, or kill it quickly. So this version changes the command line handling.

This version also demonstrates how to kill a process. In fact it kills every process of the same name. I wish I'd had this a couple of years ago when I was doing stuff with Excel -- I'd end up with multiple Excel sessions which I would then have to kill off one-by-one through the Task Manager. (I eventually ended up installing Cygwin so that I could script the process.)

If you remember the original VBScript of BOOST and the first VB6 version, you'll see some similarities.

I've given up on using setsubsys in favour of using VBAdvance (which is now freeware) to handle the compile-to-console-app process. I'm still compressing the app using UPX.

First a few constants and the declarations, found on vb.mvps.org, for doing console I/O.

Option Explicit

Const KILL_PROCESS = 0             '0
Const LOW_PRIORITY = 64            '1
Const BELOWNORMAL_PRIORITY = 16384 '2
Const NORMAL_PRIORITY = 32         '3
Const ABOVENORMAL_PRIORITY = 32768 '4
Const HIGH_PRIORITY = 256          '5
Const REALTIME_PRIORITY = 128      '6

Private Declare Function GetStdOutHandle Lib "kernel32" _
        Alias "GetStdHandle" _
       (Optional ByVal HandleType As Long = -11) As Long

Private Declare Function WriteFile Lib "kernel32" _
       (ByVal hFile As Long, _
        ByVal lpBuffer As String, _
        ByVal cToWrite As Long, _
        ByRef cWritten As Long, _
        Optional ByVal lpOverlapped As Long) As Long

'To keep things simple, wrap these two APIs in a single helper function like so:

Private Function ConsoleWrite(sText As String) As Long
    WriteFile GetStdOutHandle, ByVal sText, Len(sText), ConsoleWrite
End Function

Next, a few supporting functions. First off the rank, is an invocation syntax display. Notice that priority can now be specified either by a number (0 to kill, 1-6 for low to realtime) or by name (kill, low, belownormal, normal, abovenormal, high, realtime).

Sub Syntax()
    ConsoleWrite ("Syntax:" & vbNewLine & _
        vbTab & "Boost {processname} {runlevel}" & vbNewLine & _
        "Run level as number:" & vbNewLine & _
            vbTab & "0 = KILL_PROCESS" & vbNewLine & _
            vbTab & "1 = LOW_PRIORITY" & vbNewLine & _
            vbTab & "2 = BELOWNORMAL_PRIORITY" & vbNewLine & _
            vbTab & "3 = NORMAL_PRIORITY" & vbNewLine & _
            vbTab & "4 = ABOVENORMAL_PRIORITY" & vbNewLine & _
            vbTab & "5 = HIGH_PRIORITY" & vbNewLine & _
            vbTab & "6 = REALTIME_PRIORITY" & vbNewLine & vbNewLine & vbNewLine & _
                    "Run level as text:" & vbNewLine & _
            vbTab & "kill = KILL_PROCESS" & vbNewLine & _
            vbTab & "low = LOW_PRIORITY" & vbNewLine & _
            vbTab & "belownormal = BELOWNORMAL_PRIORITY" & vbNewLine & _
            vbTab & "normal = NORMAL_PRIORITY" & vbNewLine & _
            vbTab & "abovenormal = ABOVENORMAL_PRIORITY" & vbNewLine & _
            vbTab & "high = HIGH_PRIORITY" & vbNewLine & _
            vbTab & "realtime = REALTIME_PRIORITY" & vbNewLine)
    
End Sub

Second, the command line parser. This splits on space and tab and is based on code found at microsoft.public.vb.winapi

Function GetCommandLine(Optional MaxArgs) As Variant
   'Declare variables.
   Dim C As String
   Dim CmdLine As String
   Dim CmdLnLen As Integer
   Dim InArg As Boolean
   Dim i As Integer
   Dim NumArgs As Integer
   Dim ArgArray As Variant
   'See if MaxArgs was provided.
   If IsMissing(MaxArgs) Then MaxArgs = 10
   'Make array of the correct size.
   ReDim ArgArray(MaxArgs - 1)
   NumArgs = 0: InArg = False
   'Get command line arguments.
   CmdLine = Command()
   CmdLnLen = Len(CmdLine)
   'Go thru command line one character
   'at a time.
   For i = 1 To CmdLnLen
      C = Mid(CmdLine, i, 1)
      'Test for space or tab.
      If (C <> " " And C <> vbTab) Then
         'Neither space nor tab.
         'Test if already in argument.
         If Not InArg Then
         'New argument begins.
         'Test for too many arguments.
            If NumArgs = MaxArgs Then Exit For
            NumArgs = NumArgs + 1
            InArg = True
         End If
         'Concatenate character to current argument.
         ArgArray(NumArgs - 1) = ArgArray(NumArgs - 1) & C
      Else
         'Found a space or tab.
         'Set InArg flag to False.
         InArg = False
      End If
   Next i
   'Resize array just enough to hold arguments.
   ReDim Preserve ArgArray(NumArgs - 1)
   'Return Array in Function name.
   GetCommandLine = ArgArray '()
End Function

Third, the two routines which wrap the WMI functions to set priority and to kill process. The latter was found at tek-tips. If I remember correctly, the places in each routine where it says

sComputer = "."

could, in fact, have some other computer's name. If you had sufficient privilege you could be tweaking or killing a process on someone else's machine.

Function SetPriority(sProcess As String, nPriority As Integer) As Boolean
    Dim sComputer As String
    Dim oWMIService As Object
    Dim cProcesses As Object
    Dim oProcess As Object
    Dim bDone As Boolean
    
    bDone = False
    sComputer = "."
    Set oWMIService = GetObject("winmgmts:\\" & sComputer & "\root\cimv2")

    On Error Resume Next
    Set cProcesses = oWMIService.ExecQuery _
        ("Select * from Win32_Process Where Name = '" & sProcess & "'")
    For Each oProcess In cProcesses
        oProcess.SetPriority (nPriority)
        If Err.Number <> 0 Then
            GoTo DoNext
        End If
        bDone = True
DoNext:
    Next
    On Error GoTo 0
    SetPriority = bDone
End Function

Function KillProcess(sProcess As String) As Integer
    Dim oWMIService As Object
    Dim sComputer As String
    Dim oProcess As Object
    Dim nDone As Integer
    
    nDone = 0
    sComputer = "." 'this computer
    Set oWMIService = GetObject("winmgmts:")

    For Each oProcess In oWMIService.InstancesOf("Win32_process")
        If LCase(oProcess.Name) = LCase(sProcess) Then
            oProcess.Terminate
            nDone = nDone + 1
        End If
    Next
    KillProcess = nDone
End Function

Finally, the Main subroutine. Notice the additions to the priorities collection. Note also the change in the way the command line is handled.

Because there's no .Exists method on Collections, the .Item call is wrapped in an 'On Error' so that a non-existent item situation is caught appropriately.

Sub Main()
    
    Dim sLevel As String
    Dim nLevel As Integer
    Dim sProcess As String
    Dim sCommand As String
    Dim nInstances As Integer
    
    Dim dPriorities As New Collection
        
    dPriorities.Add Item:=KILL_PROCESS, Key:="kill"
    dPriorities.Add Item:=LOW_PRIORITY, Key:="low"
    dPriorities.Add Item:=BELOWNORMAL_PRIORITY, Key:="belownormal"
    dPriorities.Add Item:=NORMAL_PRIORITY, Key:="normal"
    dPriorities.Add Item:=ABOVENORMAL_PRIORITY, Key:="abovenormal"
    dPriorities.Add Item:=HIGH_PRIORITY, Key:="high"
    dPriorities.Add Item:=REALTIME_PRIORITY, Key:="realtime"
    
    dPriorities.Add Item:=KILL_PROCESS, Key:="0"
    dPriorities.Add Item:=LOW_PRIORITY, Key:="1"
    dPriorities.Add Item:=BELOWNORMAL_PRIORITY, Key:="2"
    dPriorities.Add Item:=NORMAL_PRIORITY, Key:="3"
    dPriorities.Add Item:=ABOVENORMAL_PRIORITY, Key:="4"
    dPriorities.Add Item:=HIGH_PRIORITY, Key:="5"
    dPriorities.Add Item:=REALTIME_PRIORITY, Key:="6"
    
    Dim aArgs As Variant
    
    If Command() = "" Then
        Syntax
        End
    End If
    
    aArgs = GetCommandLine(2)
    sProcess = aArgs(0)
    sLevel = aArgs(1)
    
    If sProcess = "" Or sLevel = "" Then
        Syntax
        End
    End If

    On Error Resume Next
    nLevel = dPriorities.Item(sLevel)
    If Err.Number = 5 Then
        ConsoleWrite "Invalid selection of runlevel." & vbNewLine
        Syntax
        End
    End If
    On Error GoTo 0
    If nLevel = 0 Then
        nInstances = KillProcess(sProcess)
        If nInstances = 0 Then
            ConsoleWrite "No instances of " & sProcess & " found to kill" & vbNewLine
        Else
            ConsoleWrite nInstances & " " & IIf(nInstances > 1, "instances", "instance") & " of " & sProcess & " killed." & vbNewLine
        End If
    Else
        ConsoleWrite sProcess & IIf(SetPriority(sProcess, nLevel), _
            " boosted", " NOT boosted") & _
            " to priority " & sLevel & " (" & nLevel & ")." & vbNewLine
    End If

End Sub

What's next with this thing? I suppose one could explore the possibility of influencing the lives of applications on other computers:

BOOST Skype.exe kill /C:GUEST_01

There's also the fact that the commandline parser doesn't properly handle double-quoted names. If an .exe had a space it its name, you wouldn't be able use BOOST on it.

Finally, here's a short batch file (killall.bat) I use for killing applications en masse. It was originally designed to get around the 'typing the /P and /L' issue, but I'm so used to using it now ...

 @echo off
:loop
if %1@==@ goto done
c:\bin\boost %1 kill
shift
goto loop
:done

An example invocation:

killall excel.exe outlook.exe

© Copyright Bruce M. Axtens, 2007

Monday, May 07, 2007

[Visual Basic 6] Boost again, but as a binary

As nice as the VBScript version of BOOST is, some people prefer a compiled binary. So, here's the VB6 version.

But first, credit where credit is due:
* Ultimate Packer for eXecutables which compresses binaries;
* Euphoria programming language website for the SETSUBSYS tool which I use to turn a GUI applications into a console ones;
* Experts Exchange for their ParseCommandLineValue function; and
* vb.mvps.org for their sample on how to make console applications

Okay, now to the code. The algorithm is very similar to the VBScript project, but there are some new things.

First the constants:

Option Explicit

Const LOW_PRIORITY = 64            '1
Const BELOWNORMAL_PRIORITY = 16384 '2
Const NORMAL_PRIORITY = 32         '3
Const ABOVENORMAL_PRIORITY = 32768 '4
Const HIGH_PRIORITY = 256          '5
Const REALTIME_PRIORITY = 128      '6

Here are two functions vital to making the application function appropriately in a command line environment. The first discovers the handle for StdOut. The second writes to a file handle, in this case the handle for StdOut.

After the function declarations is a user-defined wrapper. Interesting how the output of the WriteFile function is transmitted to the return value of the wrapper (the last argument in the call is the name of the wrapper function -- I'd never seen that before.)

'http://vb.mvps.org/samples/project.asp?id=console

Private Declare Function GetStdOutHandle Lib "kernel32" _
        Alias "GetStdHandle" _
       (Optional ByVal HandleType As Long = -11) As Long

Private Declare Function WriteFile Lib "kernel32" _
       (ByVal hFile As Long, _
        ByVal lpBuffer As String, _
        ByVal cToWrite As Long, _
        ByRef cWritten As Long, _
        Optional ByVal lpOverlapped As Long) As Long

'To keep things simple, wrap these two APIs in a single helper function like so:

Private Function ConsoleWrite(sText As String) As Long
    WriteFile GetStdOutHandle, ByVal sText, Len(sText), ConsoleWrite
End Function

This is the SetPriority function pulled straight out of the VBScript project. Notice I haven't even been polite enough to VB6 to specify sProcess As String and nPriority As Integer. I haven't typed any of the variables local to the function either. It doesn't matter: VB6 types them all as Variant and takes care of my carelessness (and I have put them in since.)

Function SetPriority(sProcess, nPriority)
    Dim sComputer
    Dim oWMIService
    Dim cProcesses
    Dim oProcess
    Dim bDone
   
    bDone = False
    sComputer = "."
    Set oWMIService = GetObject("winmgmts:\\" & sComputer & "\root\cimv2")

    Set cProcesses = oWMIService.ExecQuery _
        ("Select * from Win32_Process Where Name = '" & sProcess & "'")
    For Each oProcess In cProcesses
        oProcess.SetPriority (nPriority)
        bDone = True
    Next
    SetPriority = bDone
End Function

Next comes the Experts Exchange code for parsing the command line.

'http://www.experts-exchange.com/Programming/Programming_Languages/Q_20832956.html#9992009

Public Function ParseCommandLineValue(ByVal sCommandLine As String, ByVal sKey As String) As String
Dim lPosFrom As Integer
Dim lPosLen As Integer
Dim sValue As String
  
    'Initialize
    ParseCommandLineValue = ""
  
    If Trim(sKey) = "" Then
        Err.Raise vbObjectError, "Invalid key"
    End If
  
    'Get Datasource
    lPosFrom = InStr(1, sCommandLine, sKey, vbTextCompare)
    If lPosFrom > 0 Then
        'Find the position of the Value after length of the Key
        lPosFrom = lPosFrom + Len(sKey)
      
        'Get value
        sValue = Mid(sCommandLine, lPosFrom)  'till end
      
        'Find where next value starts
        lPosLen = InStr(lPosFrom, sCommandLine, "/")
        If lPosLen > 0 Then
            'last value of the command line
            lPosLen = lPosLen - lPosFrom
        Else
            'more values after this one
            lPosLen = Len(sValue)
        End If
      
        'Return
        sValue = Mid(sCommandLine, lPosFrom, lPosLen)
        ParseCommandLineValue = sValue
    End If

End Function

Now the Main. For ease of access to the relevant values for the SetPriority function, I've used a Collection. I could have used VBScript's Dictionary (by adding a reference to SCRRUN.DLL in the Projects menu) but the Collection works well enough.

Sub Main()
    'http://vb.mvps.org/samples/project.asp?id=console
    Dim sLevel As String
    Dim nLevel As Integer
    Dim sProcess As String
    Dim sCommand As String
   
    Dim cPriorities As New Collection
   
    cPriorities.Add LOW_PRIORITY, "1"
    cPriorities.Add BELOWNORMAL_PRIORITY, "2"
    cPriorities.Add NORMAL_PRIORITY, "3"
    cPriorities.Add ABOVENORMAL_PRIORITY, "4"
    cPriorities.Add HIGH_PRIORITY, "5"
    cPriorities.Add REALTIME_PRIORITY, "6"

Now we parse the commandline and output a message about syntax if things aren't correctly specified there.

    sCommand = Command()
    sProcess = Trim(ParseCommandLineValue(sCommand, "/process:"))
    sLevel = Trim(ParseCommandLineValue(sCommand, "/level:"))

    If sProcess = "" Or sLevel = "" Then
        ConsoleWrite ("Syntax:" & vbNewLine & _
        vbTab & "Boost /process:{processname} /level:{runlevel}" & vbNewLine & _
        "Run levels:" & vbNewLine & _
            vbTab & "1 = LOW_PRIORITY" & vbNewLine & _
            vbTab & "2 = BELOWNORMAL_PRIORITY" & vbNewLine & _
            vbTab & "3 = NORMAL_PRIORITY" & vbNewLine & _
            vbTab & "4 = ABOVENORMAL_PRIORITY" & vbNewLine & _
            vbTab & "5 = HIGH_PRIORITY" & vbNewLine & _
            vbTab & "6 = REALTIME_PRIORITY" & vbNewLine)
        End
    End If

Assuming that the commandline is okay, we then attempt to figure out the runlevel value from the user-supplied specification, and show an appropriate error if it doesn't make sense.

    On Error Resume Next
    nLevel = cPriorities.Item(sLevel)
    If Err.Number = 5 Then
        ConsoleWrite ("Invalid selection of runlevel.")
        End
    End If
    On Error GoTo 0

And, finally, where it is all made to happen. If everything's set up right and there is in fact a process running that matches what's stored in sProcess, then it gets boosted and the user is informed. If there's no match, the message says that the process wasn't boosted.

    ConsoleWrite (sProcess & IIF(SetPriority(sProcess, nLevel), _
        " boosted", " not boosted") & " to priority " & sLevel & _
        " (" & nLevel & ").")
End Sub

Having compiled the code to an .EXE, I used the setsubsys tool to change the binary from a GUI app to a console app

setsubsys boost.exe /C

I also compressed it using UPX,

upx -9 boost.exe

taking a 24576 byte application and leaving me with an 8192 byte one.

If anyone's interested in downloading the BOOST binary (which now contains a KILL_PROCESS 'level'), please leave a comment to that effect and I'll put up a download link.

By the way, if you think my code sucks, say so. Critiques are always welcome. King Solomon said, "The wise person accepts instructions." and also "Better is open rebuke than hidden love."

Friday, March 16, 2007

[VBScript] Boost - changing process priority using WMI

I have little sh script on my iBook which changes the priority of a given process so that the OS services it more frequently, giving the impression of faster execution. Below is a re-implementation in VBScript of a similar tool for Windows. First a few constants and the arrays that handle the commandline options.

Option Explicit

Const LOW_PRIORITY = 64 '1
Const BELOWNORMAL_PRIORITY = 16384 '2
Const NORMAL_PRIORITY = 32 '3
Const ABOVENORMAL_PRIORITY = 32768 '4
Const HIGH_PRIORITY = 256 '5
Const REALTIME_PRIORITY = 128 '6

Dim aNames
Dim aValues

aNames = Array( "LOW", "BELOWNORMAL", "NORMAL", "ABOVENORMAL", "HIGH", "REALTIME" )
aValues = Array( LOW_PRIORITY, BELOWNORMAL_PRIORITY, NORMAL_PRIORITY, ABOVENORMAL_PRIORITY, HIGH_PRIORITY, REALTIME_PRIORITY )

Next, the real meat of this tool: the Windows Management Interface (WMI) call which takes a string and a numeric defining the process name and the priority level.

Function SetPriority( sProcess, nPriority )
    Dim sComputer
    Dim oWMIService
    Dim cProcesses
    Dim oProcess
    Dim bDone
    
    bDone = False
    sComputer = "."
    Set oWMIService = GetObject("winmgmts:\\" & sComputer & "\root\cimv2")

    Set cProcesses = oWMIService.ExecQuery _
        ("Select * from Win32_Process Where Name = '" & sProcess & "'")
    For Each oProcess in cProcesses
        oProcess.SetPriority( nPriority )
        bDone = True        
    Next
    SetPriority = bDone
End Function

Next a few less inspiring routines: IIF (available in VB but not in VBScript), ArrayOffset, and HelpText.

Function IIF( bCondition, vTrue, vFalse )
    Dim vResult
    If bCondition = True Then
        vResult = vTrue
    Else
        vResult = vFalse
    End If
    IIF = vResult
End Function

Function ArrayOffset( sItem, aList )
    Dim i
    Dim u
    Dim nResult
    nResult = -1
    For i = 0 To UBound( aList )
        If sItem = aList( i ) Then
            nResult = i
            Exit For
        End If
    Next
    ArrayOffset = nResult
End Function

Sub HelpText
    WScript.Echo "Syntax:"
    WScript.Echo vbTab & "Boost {appName} /L:{priority}"
    WScript.Echo vbTab & "priority: LOW | BELOWNORMAL | NORMAL | ABOVENORMAL | HIGH | REALTIME"
    WScript.Echo 
    WScript.Echo vbTab & "E.g. boost cscript.exe /l:realtime"
End Sub

Finally the main routine, which uses Named and Unnamed Arguments to handle command line parameters. The name of the process is pulled out of the command line using an Unnamed Argument, and the text representation of the priority is pulled out using a Named Argument ("L"). If the priority is acceptable the name and priority are passed to the SetPriority routine.

If WScript.Arguments.Unnamed.Count = 0 Or WScript.Arguments.Named.Count = 0 Then
    HelpText
    WScript.Quit
End If

Dim sApp, sPrio, nOffs

sApp = WScript.Arguments( 0 ) 
sPrio = WScript.Arguments.Named.Item("L")
nOffs = ArrayOffset( UCase( sPrio ), aNames ) 
If nOffs = -1 Then
    WScript.Echo "The",sPrio,"priority cannot be assigned to",sApp
    HelpText
Else
    WScript.Echo sApp, _
        IIF( SetPriority( sApp, aValues( nOffs ) ), _
            "boosted to " & aNames( nOffs ) & " priority", _
            "not boosted" ) 
End If

A further refinement of this tool might be to provide for one other possibility for /L: 'KILL' or 'TERMINATE'. By way of comparison here's the original sh script.

#!/bin/sh
ps axxw | grep $1 | grep -v grep | grep -v boost 
sudo renice -20 `ps axww | grep $1 | grep -v grep | grep -v boost | awk '{print $1}'`