Code-a-holic: May 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."