Critcl wrapper for Mac OS X HICommand Carbon Event Manager services, c.f. [
1] for details and [
2] for OS defined
commandIDs.
Part of
CarbonCritLib:
http://rutherglen.ics.mq.edu.au/~steffen/tcltk/carboncritlib/tclCarbonHICommand.tcl
[ DAS 06/10/07 ]#!/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: <steffen@maths.mq.edu.au>
# 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 <das@users.sourceforge.net>
# 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;
}
}
#---------------------------------------------------------------------------------------------------
