Subversion Repositories or1k

/* tclwinfont.c -- Tcl routine to let the user choose a font on Windows.
   Copyright (C) 1997 Cygnus Solutions.
   Written by Ian Lance Taylor <ian@cygnus.com>.
 
   This file provides a Tcl command which may be used to let the user
   select a font on Windows.  */
 
#ifdef _WIN32
 
#include <windows.h>
 
#include <tcl.h>
#include <tk.h>
 
#include "guitcl.h"
 
/* FIXME: We need to dig into the Tk window implementation internals
   to convert a Tk Windows to an HWND.  */
 
#include <tkWinInt.h>
 
/* FIXME: We grovel around in the Tk internal font structures.  */
 
#include <tkInt.h>
#include <tkFont.h>
 
/* This file defines a single Tcl command.
 
   ide_win_choose_font OPTIONS
       Choose a font on Windows.  This opens a modal dialog box to
       permit the user to choose a font.  This returns a string naming
       the new font, or the empty string if the user did not choose a
       font.
 
       Supported options:
           -default FONT
	       FONT is the name of a font to use to initialize the
	       default choice in the dialog box.
           -parent WINDOW
	       Set the parent window of the dialog box.  The dialog
	       box is modal with respect to this window.  The default
	       is the main window.
 
   FIXME: The current implementation only supports choosing a screen
   font.  To permit choosing printer fonts, we would need to have a
   device context for the printer.
 
   */
 
/* Implement the ide_win_choose_font procedure.  */
 
static int
win_choose_font (ClientData cd, Tcl_Interp *interp, int argc, char **argv)
{
  char *deffont;
  Tk_Window parent;
  int i, oldMode;
  CHOOSEFONT cf;
  LOGFONT lf;
  HDC hdc;
  HFONT hfont;
  char facebuf[LF_FACESIZE];
  TEXTMETRIC tm;
  int pointsize;
  char *s;
  Tcl_DString resultStr;             /* used to translate result in UTF8 in Tcl/Tk8.1 */
  deffont = NULL;
  parent = Tk_MainWindow (interp);
 
  for (i = 1; i < argc; i += 2)
    {
      if (i + 1 >= argc)
	{
	  Tcl_ResetResult (interp);
	  Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
				  "value for \"", argv[i], "\" missing",
				  (char *) NULL);
	  return TCL_ERROR;
	}
 
      if (strcmp (argv[i], "-default") == 0)
	deffont = argv[i + 1];
      else if (strcmp (argv[i], "-parent") == 0)
	{
	  parent = Tk_NameToWindow (interp, argv[i + 1],
				    Tk_MainWindow (interp));
	  if (parent == NULL)
	    return TCL_ERROR;
	}
      else
	{
	  Tcl_ResetResult (interp);
	  Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
				  "unknown option \"", argv[i], "\"",
				  (char *) NULL);
	  return TCL_ERROR;
	}
    }
 
  memset (&cf, 0, sizeof (CHOOSEFONT));
  cf.lStructSize = sizeof (CHOOSEFONT);
 
  if (Tk_WindowId (parent) == None)
    Tk_MakeWindowExist (parent);
  cf.hwndOwner = Tk_GetHWND (Tk_WindowId (parent));
 
  cf.lpLogFont = &lf;
  cf.Flags = CF_SCREENFONTS | CF_FORCEFONTEXIST;
 
  memset (&lf, 0, sizeof (LOGFONT));
 
  if (deffont != NULL)
    {
      Tk_Font tkfont;
      const TkFontAttributes *fa;
 
      tkfont = Tk_GetFont (interp, parent, deffont);
      if (tkfont == NULL)
	return TCL_ERROR;
 
      cf.Flags |= CF_INITTOLOGFONTSTRUCT;
 
      /* In order to initialize LOGFONT, we need to extract the real
	 font attributes from the Tk internal font information.  */
      fa = &((TkFont *) tkfont)->fa;
 
      /* This code is taken from TkpGetFontFromAttributes.  It
         converts a TkFontAttributes structure into a LOGFONT
         structure.  */
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
      lf.lfHeight = - fa->size;
#else
      lf.lfHeight = - fa->pointsize;
#endif
      if (lf.lfHeight < 0)
	lf.lfHeight = MulDiv (lf.lfHeight,
			      254 * WidthOfScreen (Tk_Screen (parent)),
			      720 * WidthMMOfScreen (Tk_Screen (parent)));
      lf.lfWeight = fa->weight == TK_FW_NORMAL ? FW_NORMAL : FW_BOLD;
      lf.lfItalic = fa->slant;
      lf.lfUnderline = fa->underline;
      lf.lfStrikeOut = fa->overstrike;
      lf.lfCharSet = DEFAULT_CHARSET;
      lf.lfOutPrecision = OUT_DEFAULT_PRECIS;
      lf.lfClipPrecision = CLIP_DEFAULT_PRECIS;
      lf.lfQuality = DEFAULT_QUALITY;
      lf.lfPitchAndFamily = DEFAULT_PITCH | FF_DONTCARE;
      if (fa->family == NULL)
	lf.lfFaceName[0] = '\0';
      else
	strncpy (lf.lfFaceName, fa->family, sizeof (lf.lfFaceName));
 
      Tk_FreeFont (tkfont);
    }
 
  oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
  if (! ChooseFont (&cf))
    {
      DWORD code;
 
      code = CommDlgExtendedError ();
      if (code == 0)
	{
	  /* The user pressed cancel.  */
	  Tcl_ResetResult (interp);
	  return TCL_OK;
	}
      else
	{
	  char buf[200];
 
	  sprintf (buf, "Windows common dialog error 0x%lx", (unsigned long) code);
	  Tcl_ResetResult (interp);
          #if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
            Tcl_ExternalToUtfDString(NULL, buf, -1, &resultStr);
          #else
            Tcl_InitDString(&resultStr);
            Tcl_DStingAppend(&resultStr, buf, -1);
          #endif
	  Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
				  Tcl_DStringValue(&resultStr),
				  (char *) NULL);
          Tcl_DStringFree(&resultStr);
	  return TCL_ERROR;
	}
    }
  Tcl_SetServiceMode(oldMode);
  /* We now have a LOGFONT structure.  We store it into a device
     context, and then extract enough information to build a Tk font
     specification.  With luck, when Tk interprets the font
     specification it will wind up with the font that the user expects
     to see.  Some of this code is taken from AllocFont.  */
 
  hfont = CreateFontIndirect (&lf);
  if (hfont == NULL)
    {
      /* This should be impossible.  */
      #if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
        Tcl_ExternalToUtfDString(NULL, "CreateFontIndirect failed on chosen font", -1, &resultStr);
      #else
        Tcl_InitDString(&resultStr);
        Tcl_DStingAppend(&resultStr, "CreateFontIndirect failed on chosen font", -1);
      #endif
      Tcl_SetResult (interp, Tcl_DStringValue(&resultStr), TCL_STATIC);
      Tcl_DStringFree(&resultStr);
      return TCL_ERROR;
    }
 
  hdc = GetDC (cf.hwndOwner);
  hfont = SelectObject (hdc, hfont);
  GetTextFace (hdc, sizeof (facebuf), facebuf);
  GetTextMetrics (hdc, &tm);
 
  Tcl_ResetResult (interp);
 
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
  Tcl_ExternalToUtfDString(NULL, facebuf, -1, &resultStr);
#else
  Tcl_InitDString(&resultStr);
  Tcl_DStingAppend(&resultStr,facebuf,-1);
#endif
 
  if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
				Tcl_NewStringObj (Tcl_DStringValue(&resultStr), -1)) != TCL_OK) {
    Tcl_DStringFree(&resultStr);
    return TCL_ERROR;
  }
 
  Tcl_DStringFree(&resultStr);
 
  pointsize = MulDiv (tm.tmHeight - tm.tmInternalLeading,
		      720 * WidthMMOfScreen (Tk_Screen (parent)),
		      254 * WidthOfScreen (Tk_Screen (parent)));
 
  if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
				Tcl_NewIntObj (pointsize)) != TCL_OK) {
     return TCL_ERROR;
  }
 
   if (tm.tmWeight > FW_MEDIUM)
    s = "bold";
  else
    s = "normal";
 
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
  Tcl_ExternalToUtfDString(NULL, s, -1, &resultStr);
#else
  Tcl_InitDString(&resultStr);
  Tcl_DStingAppend(&resultStr, s, -1);
#endif
 
  if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
				Tcl_NewStringObj (Tcl_DStringValue(&resultStr), -1)) != TCL_OK) {
    Tcl_DStringFree(&resultStr);
    return TCL_ERROR;
  }
 
  Tcl_DStringFree(&resultStr);
 
  if (tm.tmItalic)
    s = "italic";
  else
    s = "roman";
 
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
  Tcl_ExternalToUtfDString(NULL, s, -1, &resultStr);
#else
  Tcl_InitDString(&resultStr);
  Tcl_DStingAppend(&resultStr, s, -1);
#endif
 
  if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
				Tcl_NewStringObj (Tcl_DStringValue(&resultStr), -1)) != TCL_OK) {
    Tcl_DStringFree(&resultStr);
    return TCL_ERROR;
  }
  Tcl_DStringFree(&resultStr);
 
  if (tm.tmUnderlined)
    {
      #if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
        Tcl_ExternalToUtfDString(NULL, "underline", -1, &resultStr);
      #else
        Tcl_InitDString(&resultStr);
        Tcl_DStingAppend(&resultStr,"underline",-1);
      #endif
      if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
				    Tcl_NewStringObj (Tcl_DStringValue(&resultStr), -1))
	  != TCL_OK) {
        Tcl_DStringFree(&resultStr);
	return TCL_ERROR;
      }
      Tcl_DStringFree(&resultStr);
    }
 
  if (tm.tmStruckOut)
    {
      #if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
        Tcl_ExternalToUtfDString(NULL, "overstrike", -1, &resultStr);
      #else
        Tcl_InitDString(&resultStr);
        Tcl_DStingAppend(&resultStr, "overstrike", -1);
      #endif
      if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
				    Tcl_NewStringObj (Tcl_DStringValue(&resultStr), -1))
	  != TCL_OK) {
        Tcl_DStringFree(&resultStr);
	return TCL_ERROR;
      }
      Tcl_DStringFree(&resultStr);
    }
 
  hfont = SelectObject (hdc, hfont);
  ReleaseDC (cf.hwndOwner, hdc);
  DeleteObject (hfont);
 
  return TCL_OK;
}
 
/* Create the Tcl command.  */
 
int
ide_create_win_choose_font_command (Tcl_Interp *interp)
{
  if (Tcl_CreateCommand (interp, "ide_win_choose_font", win_choose_font,
			 NULL, NULL) == NULL)
    return TCL_ERROR;
  return TCL_OK;
}
 
#endif /* _WIN32 */