if {[string equal $tcl_platform(os) Darwin]} {
    if {![catch {package require tclCarbonProcesses}] &&
            [llength [info commands ::carbon::setProcessName]]]} {
        carbon::setProcessName [carbon::getCurrentProcess] {MyApp}
    }
}

#!/bin/sh
# #######################################################################
#
#  tclCarbonProcesses.tcl
#
#  Critcl wrapper for Mac OS X Process Manager services.
#
#  Process this file with 'critcl -pkg' to build a loadable package (or
#  simply source this file if [package require critcl] and a compiler
#  are available at deployment).
#
#
#  Author: Daniel A. Steffen
#  E-mail: <[email protected]>
#    mail: Mathematics Departement
#          Macquarie University NSW 2109 Australia
#     www: <http://www.maths.mq.edu.au/~steffen/ >
#
# RCS: @(#) $Id$
#
# BSD License: c.f. <http://www.opensource.org/licenses/bsd-license >
#
# Copyright (c) 2005-2007, Daniel A. Steffen <[email protected]>
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or
# without modification, are permitted provided that the following
# conditions are met:
#
#   * Redistributions of source code must retain the above
#     copyright notice, this list of conditions and the
#     following disclaimer.
#
#   * Redistributions in binary form must reproduce the above
#     copyright notice, this list of conditions and the following
#     disclaimer in the documentation and/or other materials
#     provided with the distribution.
#
#   * Neither the name of Macquarie University nor the names of its
#     contributors may be used to endorse or promote products derived
#     from this software without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL MACQUARIE
# UNIVERSITY OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
# INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
# BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
# OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
# ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR
# TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
# USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
# DAMAGE.
#
# #######################################################################
# \
exec critcl -pkg "$0" "$@"

package require critcl
if {![::critcl::compiling]} {error "No compiler found"}

#---------------------------------------------------------------------------------------------------

package provide tclCarbonProcesses 1.1

namespace eval carbon {

if {[llength [info commands ::critcl::framework]]]} {
        ::critcl::framework Carbon
} else {
        lappend ::critcl::v::compile -framework Carbon
}

::critcl::ccode {
        #include <Carbon/Carbon.h>
        OSStatus CPSSetProcessName(ProcessSerialNumber *psn, char* name);
        
        static char *OSErrDesc(OSErr err) {
                static char desc[255];
                sprintf(desc, "OS Error: %d.", err);
                return desc;
        }
        
        static void CFKeyVal2TclList(const void *key, const void *value, void *context) {
                const void *a[3] = {key, value, NULL}, **p = a;
                for (p=a; *p; p++) {
                        Tcl_Obj *str = NULL;
                        CFStringRef desc;
                        if (CFGetTypeID(*p) != CFStringGetTypeID()) {
                                desc = CFCopyDescription(*p);
                        } else {
                                desc = CFRetain(*p);
                        }
                        if (desc) {
                                Tcl_DString ds, *dsp = NULL;
                                const char *c = CFStringGetCStringPtr(desc, kCFStringEncodingUTF8);
                                if (!c) {
                                        int len = CFStringGetMaximumSizeForEncoding(
                                                CFStringGetLength(desc), kCFStringEncodingUTF8);
                                        dsp = &ds;
                                        Tcl_DStringInit(dsp);
                                        Tcl_DStringSetLength(dsp, len);
                                        if (CFStringGetCString(desc, Tcl_DStringValue(dsp), 
                                                                len+1, kCFStringEncodingUTF8)) {
                                                        c = Tcl_DStringValue(dsp);
                                                }
                                }
                                if (c) str = Tcl_NewStringObj(c, -1);
                                if (dsp) Tcl_DStringFree(dsp);
                                CFRelease(desc);
                        }
                        if (!str) str = Tcl_NewStringObj("", 0);
                        Tcl_ListObjAppendElement(NULL, (Tcl_Obj*)context, str);
                }
        }
}

#---------------------------------------------------------------------------------------------------
#
# carbon::getCurrentProcess
#
#   this command returns the process serial number of the current process.
#
#---------------------------------------------------------------------------------------------------
::critcl::ccommand getCurrentProcess  {ClientData ip objc objv} {
        OSErr err;
        ProcessSerialNumber psn;
                
        if (objc != 1) {
                Tcl_WrongNumArgs(ip, 1, objv, NULL);
                return TCL_ERROR;
        }
        err = GetCurrentProcess(&psn);
        if (err != noErr) {
                Tcl_AppendResult(ip, "Could not get current process: ", OSErrDesc(err), NULL);
                return TCL_ERROR;
        }
        Tcl_SetObjResult(ip, Tcl_NewWideIntObj(*((Tcl_WideInt*)&psn)));
        return TCL_OK;
}

#---------------------------------------------------------------------------------------------------
#
# carbon::getFrontProcess
#
#   this command returns the process serial number of the front process.
#
#---------------------------------------------------------------------------------------------------
::critcl::ccommand getFrontProcess  {ClientData ip objc objv} {
        OSErr err;
        ProcessSerialNumber psn;
                
        if (objc != 1) {
                Tcl_WrongNumArgs(ip, 1, objv, NULL);
                return TCL_ERROR;
        }
        err = GetFrontProcess(&psn);
        if (err != noErr) {
                Tcl_AppendResult(ip, "Could not get front process: ", OSErrDesc(err), NULL);
                return TCL_ERROR;
        }
        Tcl_SetObjResult(ip, Tcl_NewWideIntObj(*((Tcl_WideInt*)&psn)));
        return TCL_OK;
}

#---------------------------------------------------------------------------------------------------
#
# carbon::getProcesses
#
#   this command returns a list of process serial numbers of all processes.
#
#---------------------------------------------------------------------------------------------------
::critcl::ccommand getProcesses  {ClientData ip objc objv} {
        OSErr err;
        ProcessSerialNumber psn = { 0, kNoProcess };
        Tcl_Obj *listObj;
                
        if (objc != 1) {
                Tcl_WrongNumArgs(ip, 1, objv, NULL);
                return TCL_ERROR;
        }
        listObj = Tcl_NewListObj(0, NULL);
        do {
                err = GetNextProcess(&psn);
                if (err != noErr && err != procNotFound) {
                        Tcl_AppendResult(ip, "Could not get next process: ", OSErrDesc(err), NULL);
                        return TCL_ERROR;
                }
                if ( err == noErr) {
                        Tcl_ListObjAppendElement(ip, listObj, Tcl_NewWideIntObj(*((Tcl_WideInt*)&psn)));
                }
        } while (err == noErr);
        Tcl_SetObjResult(ip, listObj);
        return TCL_OK;
}

#---------------------------------------------------------------------------------------------------
#
# carbon::getProcessInformation psn
#
#   this command returns a list of key-value pairs of process information for the given 
#   process serial number.
#
#---------------------------------------------------------------------------------------------------
::critcl::ccommand getProcessInformation  {ClientData ip objc objv} {
        Tcl_WideInt wideInt;
        CFDictionaryRef dict;
        Tcl_Obj *listObj;
        
        if (objc != 2) {
                Tcl_WrongNumArgs(ip, 1, objv, "psn");
                return TCL_ERROR;
        }
        if (Tcl_GetWideIntFromObj(ip, objv[1], &wideInt) != TCL_OK) {
                return TCL_ERROR;
        }
        dict = ProcessInformationCopyDictionary((ProcessSerialNumber*)&wideInt,
                        kProcessDictionaryIncludeAllInformationMask);
        if (!dict) {
                Tcl_AppendResult(ip, "Could not get process information", NULL);
                return TCL_ERROR;
        }
        listObj = Tcl_NewListObj(0, NULL);
        CFDictionaryApplyFunction(dict, &CFKeyVal2TclList, listObj);
        CFRelease(dict);
        Tcl_SetObjResult(ip, listObj);
        return TCL_OK;
}

#---------------------------------------------------------------------------------------------------
#
# carbon::getProcessForPID pid
#
#   this command returns the process serial number of the process with the given pid.
#
#---------------------------------------------------------------------------------------------------
::critcl::ccommand getProcessForPID  {ClientData ip objc objv} {
        OSErr err;
        pid_t pid;
        ProcessSerialNumber psn;
        
        if (objc != 2) {
                Tcl_WrongNumArgs(ip, 1, objv, "pid");
                return TCL_ERROR;
        }
        if (Tcl_GetIntFromObj(ip, objv[1], &pid) != TCL_OK) {
                return TCL_ERROR;
        }
        err = GetProcessForPID(pid, &psn);
        if (err != noErr) {
                Tcl_AppendResult(ip, "Could not get process for pid: ", OSErrDesc(err), NULL);
                return TCL_ERROR;
        }
        Tcl_SetObjResult(ip, Tcl_NewWideIntObj(*((Tcl_WideInt*)&psn)));
        return TCL_OK;
}

#---------------------------------------------------------------------------------------------------
#
# carbon::setFrontProcess psn ?frontWindowOnly?
#
#   this command activates the process of given process serial number and brings all its windows
#   to the front (or only the frontmost window if the frontWindowOnly flag is set).
#
#---------------------------------------------------------------------------------------------------
::critcl::ccommand setFrontProcess  {ClientData ip objc objv} {
        OSErr err;
        Tcl_WideInt wideInt;
        int frontWindowOnly = 0;
        
        if (objc != 2 && objc != 3) {
                Tcl_WrongNumArgs(ip, 1, objv, "psn ?frontWindowOnly?");
                return TCL_ERROR;
        }
        if (Tcl_GetWideIntFromObj(ip, objv[1], &wideInt) != TCL_OK) {
                return TCL_ERROR;
        }
        if (objc == 3 && Tcl_GetBooleanFromObj(ip, objv[2], &frontWindowOnly) != TCL_OK) {
                return TCL_ERROR;
        }
        err = SetFrontProcessWithOptions((ProcessSerialNumber*)&wideInt, 
                        frontWindowOnly ? kSetFrontProcessFrontWindowOnly : 0);
        if (err != noErr) {
                Tcl_AppendResult(ip, "Could not set front process: ", OSErrDesc(err), NULL);
                return TCL_ERROR;
        }
        return TCL_OK;
}

#---------------------------------------------------------------------------------------------------
#
# carbon::showHideProcess psn visible
#
#   this command shows or hides the process of given process serial number, depending on the
#   visible flag.
#
#---------------------------------------------------------------------------------------------------
::critcl::ccommand showHideProcess  {ClientData ip objc objv} {
        OSErr err;
        Tcl_WideInt wideInt;
        int visible = 0;
        
        if (objc != 3) {
                Tcl_WrongNumArgs(ip, 1, objv, "psn visible");
                return TCL_ERROR;
        }
        if (Tcl_GetWideIntFromObj(ip, objv[1], &wideInt) != TCL_OK) {
                return TCL_ERROR;
        }
        if (Tcl_GetBooleanFromObj(ip, objv[2], &visible) != TCL_OK) {
                return TCL_ERROR;
        }
        err = ShowHideProcess((ProcessSerialNumber*)&wideInt, visible);
        if (err != noErr) {
                Tcl_AppendResult(ip, "Could not showHide process: ", OSErrDesc(err), NULL);
                return TCL_ERROR;
        }
        return TCL_OK;
}

#---------------------------------------------------------------------------------------------------
#
# carbon::setProcessName psn name
#
#   this command sets the application menu name of the given process.
#   Uses undocumented CPS SPI that will likely break post Tiger.
#
#---------------------------------------------------------------------------------------------------
::critcl::ccommand setProcessName  {ClientData ip objc objv} {
        OSErr err;
        Tcl_WideInt wideInt;
        
        if (objc != 3) {
                Tcl_WrongNumArgs(ip, 1, objv, "psn name");
                return TCL_ERROR;
        }
        if (Tcl_GetWideIntFromObj(ip, objv[1], &wideInt) != TCL_OK) {
                return TCL_ERROR;
        }
        err = CPSSetProcessName((ProcessSerialNumber*)&wideInt,
                Tcl_GetString(objv[2]));
        if (err != noErr) {
                Tcl_AppendResult(ip, "CPSSetProcessName failed: ",
                        OSErrDesc(err), NULL);
                return TCL_ERROR;
        }
        return TCL_OK;
}

}
#---------------------------------------------------------------------------------------------------