#!/bin/sh
# #######################################################################
#
#  tclCarbonHICommand.tcl
#
#  Critcl wrapper for Mac OS X HICommand Carbon Event 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 tclCarbonHICommand 1.0

namespace eval carbon {

::critcl::tk
::critcl::config I /Library/Frameworks/Tk.framework/Headers

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

::critcl::ccode {
    #define Cursor _Cursor
    #include <Carbon/Carbon.h>

    typedef struct TkWindowPrivate {
        Tk_Window *winPtr;
        CGrafPtr  grafPtr;
    } TkWindowPrivate;
    
    static char *OSErrDesc(OSErr err) {
        static char desc[255];
        if (err == eventNotHandledErr) {
            sprintf(desc, "Carbon Event not handled.", err);
        } else {                        
            sprintf(desc, "OS Error: %d.", err);
        }
        return desc;
    }
}

#---------------------------------------------------------------------------------------------------
#
# carbon::processHICommand commandID toplevel
#
#   this command takes a Carbon HICommand ID (4 char string, c.f. CarbonEvents.h), and either the   
#   name of a toplevel window (for window specific HICommands) or an empty string (for menu specific
#   HICommands) and calls ProcessHICommand() with the resulting HICommandExtended structure.                  
#

#---------------------------------------------------------------------------------------------------
::critcl::cproc processHICommand {Tcl_Interp* ip char* commandID char* toplevel} ok {
    OSErr err;
    HICommandExtended command;
    EventRef event;
        
    memset(&command, 0, sizeof command);
    if (strlen(commandID) != sizeof(UInt32)) {
        Tcl_AppendResult(ip, "Argument commandID needs to be exactly 4 chars long", NULL);
        return TCL_ERROR;
    }
    memcpy(&command.commandID, commandID, sizeof(UInt32));
    if (strlen(toplevel)) {
        Tk_Window tkwin = Tk_NameToWindow(ip,toplevel,Tk_MainWindow(ip));
        if(!tkwin) return TCL_ERROR;
        if(!Tk_IsTopLevel(tkwin)) {
            Tcl_AppendResult(ip, "Window \"", toplevel,
                    "\" is not a toplevel window", NULL);
            return TCL_ERROR;
        }
        command.source.window = GetWindowFromPort(
                ((TkWindowPrivate*)Tk_WindowId(tkwin))->grafPtr);
        command.attributes = kHICommandFromWindow;
    } else {
        err = GetIndMenuItemWithCommandID(NULL, command.commandID, 1, 
                &command.source.menu.menuRef, &command.source.menu.menuItemIndex);
        if ( err != noErr) {
            Tcl_AppendResult(ip, "Could not find menu item corresponding to commandID: ", 
                    OSErrDesc(err), NULL);
        } else {
            command.attributes = kHICommandFromMenu;
        }
    }
    err = ProcessHICommand((HICommand*)&command);
    if ( err != noErr) {
        Tcl_AppendResult(ip, "Could not process command: ", OSErrDesc(err), NULL);
        return TCL_ERROR;
    }
    return TCL_OK;
}

#---------------------------------------------------------------------------------------------------
#
# carbon::enableMenuCommand commandID disable
#
#   this command takes a Carbon HICommand ID (4 char string, c.f. CarbonEvents.h) of a menu specific
#   HICommand, and a flag specifing whether to enable (0) or disable (1) the associated menu item.
#
#---------------------------------------------------------------------------------------------------

::critcl::cproc enableMenuCommand {Tcl_Interp* ip char* commandID int disable} ok {
    MenuCommand command;
    
    if (strlen(commandID) != sizeof(UInt32)) {
        Tcl_AppendResult(ip, "Argument commandID needs to be exactly 4 chars long", NULL);
        return TCL_ERROR;
    }
    memcpy(&command, commandID, sizeof(UInt32));
    if (disable) {
        DisableMenuCommand(NULL, command);
    } else {
        EnableMenuCommand(NULL, command);
    }
    return TCL_OK;
}

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