home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / tcl / tk3.3b1 / tkCanvPs.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-06-16  |  37.6 KB  |  1,187 lines
  1. /* 
  2.  * tkCanvPs.c --
  3.  *
  4.  *    This module provides Postscript output support for canvases,
  5.  *    including the "postscript" widget command plus a few utility
  6.  *    procedures used for generating Postscript.
  7.  *
  8.  * Copyright (c) 1991-1993 The Regents of the University of California.
  9.  * All rights reserved.
  10.  *
  11.  * Permission is hereby granted, without written agreement and without
  12.  * license or royalty fees, to use, copy, modify, and distribute this
  13.  * software and its documentation for any purpose, provided that the
  14.  * above copyright notice and the following two paragraphs appear in
  15.  * all copies of this software.
  16.  * 
  17.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  18.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  19.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  20.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  21.  *
  22.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  23.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  24.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  25.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  26.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  27.  */
  28.  
  29. #ifndef lint
  30. static char rcsid[] = "$Header: /user6/ouster/wish/RCS/tkCanvPs.c,v 1.16 93/06/16 17:16:48 ouster Exp $ SPRITE (Berkeley)";
  31. #endif
  32.  
  33. #include <stdio.h>
  34. #include "tkInt.h"
  35. #include "tkCanvas.h"
  36. #include "tkConfig.h"
  37.  
  38. /*
  39.  * See tkCanvas.h for key data structures used to implement canvases.
  40.  */
  41.  
  42. /*
  43.  * One of the following structures is created to keep track of Postscript
  44.  * output being generated.  It consists mostly of information provided on
  45.  * the widget command line.
  46.  */
  47.  
  48. typedef struct PostscriptInfo {
  49.     int x, y, width, height;    /* Area to print, in canvas pixel
  50.                  * coordinates. */
  51.     int x2, y2;            /* x+width and y+height. */
  52.     char *pageXString;        /* String value of "-pagex" option or NULL. */
  53.     char *pageYString;        /* String value of "-pagey" option or NULL. */
  54.     double pageX, pageY;    /* Postscript coordinates (in points)
  55.                  * corresponding to pageXString and
  56.                  * pageYString. Don't forget that y-values
  57.                  * grow upwards for Postscript! */
  58.     char *pageWidthString;    /* Printed width of output. */
  59.     char *pageHeightString;    /* Printed height of output. */
  60.     double scale;        /* Scale factor for conversion: each pixel
  61.                  * maps into this many points. */
  62.     Tk_Anchor pageAnchor;    /* How to anchor bbox on Postscript page. */
  63.     int rotate;            /* Non-zero means output should be rotated
  64.                  * on page (landscape mode). */
  65.     char *fontVar;        /* If non-NULL, gives name of global variable
  66.                  * containing font mapping information.
  67.                  * Malloc'ed. */
  68.     char *colorVar;        /* If non-NULL, give name of global variable
  69.                  * containing color mapping information.
  70.                  * Malloc'ed. */
  71.     char *colorMode;        /* Mode for handling colors:  "monochrome",
  72.                  * "gray", or "color".  Malloc'ed. */
  73.     int colorLevel;        /* Numeric value corresponding to colorMode:
  74.                  * 0 for mono, 1 for gray, 2 for color. */
  75.     char *fileName;        /* Name of file in which to write Postscript;
  76.                  * NULL means return Postscript info as
  77.                  * result. Malloc'ed. */
  78.     FILE *f;            /* Open file corresponding to fileName. */
  79.     Tcl_HashTable fontTable;    /* Hash table containing names of all font
  80.                  * families used in output.  The hash table
  81.                  * values are not used. */
  82.     int prepass;        /* Non-zero means that we're currently in
  83.                  * the pre-pass that collects font information,
  84.                  * so the Postscript generated isn't
  85.                  * relevant. */
  86. } PostscriptInfo;
  87.  
  88. /*
  89.  * The table below provides a template that's used to process arguments
  90.  * to the canvas "postscript" command and fill in PostscriptInfo
  91.  * structures.
  92.  */
  93.  
  94. static Tk_ConfigSpec configSpecs[] = {
  95.     {TK_CONFIG_STRING, "-colormap", (char *) NULL, (char *) NULL,
  96.     "", Tk_Offset(PostscriptInfo, colorVar), 0},
  97.     {TK_CONFIG_STRING, "-colormode", (char *) NULL, (char *) NULL,
  98.     "", Tk_Offset(PostscriptInfo, colorMode), 0},
  99.     {TK_CONFIG_STRING, "-file", (char *) NULL, (char *) NULL,
  100.     "", Tk_Offset(PostscriptInfo, fileName), 0},
  101.     {TK_CONFIG_STRING, "-fontmap", (char *) NULL, (char *) NULL,
  102.     "", Tk_Offset(PostscriptInfo, fontVar), 0},
  103.     {TK_CONFIG_PIXELS, "-height", (char *) NULL, (char *) NULL,
  104.     "", Tk_Offset(PostscriptInfo, height), 0},
  105.     {TK_CONFIG_ANCHOR, "-pageanchor", (char *) NULL, (char *) NULL,
  106.     "", Tk_Offset(PostscriptInfo, pageAnchor), 0},
  107.     {TK_CONFIG_STRING, "-pageheight", (char *) NULL, (char *) NULL,
  108.     "", Tk_Offset(PostscriptInfo, pageHeightString), 0},
  109.     {TK_CONFIG_STRING, "-pagewidth", (char *) NULL, (char *) NULL,
  110.     "", Tk_Offset(PostscriptInfo, pageWidthString), 0},
  111.     {TK_CONFIG_STRING, "-pagex", (char *) NULL, (char *) NULL,
  112.     "", Tk_Offset(PostscriptInfo, pageXString), 0},
  113.     {TK_CONFIG_STRING, "-pagey", (char *) NULL, (char *) NULL,
  114.     "", Tk_Offset(PostscriptInfo, pageYString), 0},
  115.     {TK_CONFIG_BOOLEAN, "-rotate", (char *) NULL, (char *) NULL,
  116.     "", Tk_Offset(PostscriptInfo, rotate), 0},
  117.     {TK_CONFIG_PIXELS, "-width", (char *) NULL, (char *) NULL,
  118.     "", Tk_Offset(PostscriptInfo, width), 0},
  119.     {TK_CONFIG_PIXELS, "-x", (char *) NULL, (char *) NULL,
  120.     "", Tk_Offset(PostscriptInfo, x), 0},
  121.     {TK_CONFIG_PIXELS, "-y", (char *) NULL, (char *) NULL,
  122.     "", Tk_Offset(PostscriptInfo, y), 0},
  123.     {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL,
  124.     (char *) NULL, 0, 0}
  125. };
  126.  
  127. /*
  128.  * Forward declarations for procedures defined later in this file:
  129.  */
  130.  
  131. static int        CaseCmp _ANSI_ARGS_((char *s1, char *s2, int length));
  132. static int        GetPostscriptPoints _ANSI_ARGS_((Tcl_Interp *interp,
  133.                 char *string, double *doublePtr));
  134.  
  135. /*
  136.  *--------------------------------------------------------------
  137.  *
  138.  * TkCanvPostscriptCmd --
  139.  *
  140.  *    This procedure is invoked to process the "postscript" options
  141.  *    of the widget command for canvas widgets. See the user
  142.  *    documentation for details on what it does.
  143.  *
  144.  * Results:
  145.  *    A standard Tcl result.
  146.  *
  147.  * Side effects:
  148.  *    See the user documentation.
  149.  *
  150.  *--------------------------------------------------------------
  151.  */
  152.  
  153.     /* ARGSUSED */
  154. int
  155. TkCanvPostscriptCmd(canvasPtr, interp, argc, argv)
  156.     register Tk_Canvas *canvasPtr;    /* Information about canvas widget. */
  157.     Tcl_Interp *interp;            /* Current interpreter. */
  158.     int argc;                /* Number of arguments. */
  159.     char **argv;            /* Argument strings.  Caller has
  160.                      * already parsed this command enough
  161.                      * to know that argv[1] is
  162.                      * "postscript". */
  163. {
  164.     PostscriptInfo psInfo;
  165.     int result = TCL_ERROR;
  166.     register Tk_Item *itemPtr;
  167. #define STRING_LENGTH 400
  168.     char string[STRING_LENGTH+1], *p;
  169.     time_t now;
  170.     struct passwd *pwPtr;
  171.     FILE *f;
  172.     int length;
  173.     int deltaX = 0, deltaY = 0;        /* Offset of lower-left corner of
  174.                      * area to be marked up, measured
  175.                      * in canvas units from the positioning
  176.                      * point on the page (reflects
  177.                      * anchor position).  Initial values
  178.                      * needed only to stop compiler
  179.                      * warnings. */
  180.     Tcl_HashSearch search;
  181.     Tcl_HashEntry *hPtr;
  182.     Tcl_DString buffer;
  183.     char *libDir;
  184.  
  185.     /*
  186.      *----------------------------------------------------------------
  187.      * Initialize the data structure describing Postscript generation,
  188.      * then process all the arguments to fill the data structure in.
  189.      *----------------------------------------------------------------
  190.      */
  191.  
  192.     psInfo.x = canvasPtr->xOrigin;
  193.     psInfo.y = canvasPtr->yOrigin;
  194.     psInfo.width = -1;
  195.     psInfo.height = -1;
  196.     psInfo.pageXString = NULL;
  197.     psInfo.pageYString = NULL;
  198.     psInfo.pageX = 72*4.25;
  199.     psInfo.pageY = 72*5.5;
  200.     psInfo.pageWidthString = NULL;
  201.     psInfo.pageHeightString = NULL;
  202.     psInfo.pageAnchor = TK_ANCHOR_CENTER;
  203.     psInfo.rotate = 0;
  204.     psInfo.fontVar = NULL;
  205.     psInfo.colorVar = NULL;
  206.     psInfo.colorMode = NULL;
  207.     psInfo.fileName = NULL;
  208.     psInfo.f = NULL;
  209.     psInfo.prepass = 0;
  210.     Tcl_InitHashTable(&psInfo.fontTable, TCL_STRING_KEYS);
  211.     result = Tk_ConfigureWidget(canvasPtr->interp, canvasPtr->tkwin,
  212.         configSpecs, argc-2, argv+2, (char *) &psInfo,
  213.         TK_CONFIG_ARGV_ONLY);
  214.     if (result != TCL_OK) {
  215.     goto cleanup;
  216.     }
  217.  
  218.     if (psInfo.width == -1) {
  219.     psInfo.width = Tk_Width(canvasPtr->tkwin);
  220.     }
  221.     if (psInfo.height == -1) {
  222.     psInfo.height = Tk_Height(canvasPtr->tkwin);
  223.     }
  224.     psInfo.x2 = psInfo.x + psInfo.width;
  225.     psInfo.y2 = psInfo.y + psInfo.height;
  226.  
  227.     if (psInfo.pageXString != NULL) {
  228.     if (GetPostscriptPoints(canvasPtr->interp, psInfo.pageXString,
  229.         &psInfo.pageX) != TCL_OK) {
  230.         goto cleanup;
  231.     }
  232.     }
  233.     if (psInfo.pageYString != NULL) {
  234.     if (GetPostscriptPoints(canvasPtr->interp, psInfo.pageYString,
  235.         &psInfo.pageY) != TCL_OK) {
  236.         goto cleanup;
  237.     }
  238.     }
  239.     if (psInfo.pageWidthString != NULL) {
  240.     if (GetPostscriptPoints(canvasPtr->interp, psInfo.pageWidthString,
  241.         &psInfo.scale) != TCL_OK) {
  242.         goto cleanup;
  243.     }
  244.     psInfo.scale /= psInfo.width;
  245.     } else if (psInfo.pageHeightString != NULL) {
  246.     if (GetPostscriptPoints(canvasPtr->interp, psInfo.pageHeightString,
  247.         &psInfo.scale) != TCL_OK) {
  248.         goto cleanup;
  249.     }
  250.     psInfo.scale /= psInfo.height;
  251.     } else {
  252.     psInfo.scale = (72.0/25.4)*WidthMMOfScreen(Tk_Screen(canvasPtr->tkwin));
  253.     psInfo.scale /= WidthOfScreen(Tk_Screen(canvasPtr->tkwin));
  254.     }
  255.     switch (psInfo.pageAnchor) {
  256.     case TK_ANCHOR_NW:
  257.     case TK_ANCHOR_W:
  258.     case TK_ANCHOR_SW:
  259.         deltaX = 0;
  260.         break;
  261.     case TK_ANCHOR_N:
  262.     case TK_ANCHOR_CENTER:
  263.     case TK_ANCHOR_S:
  264.         deltaX = -psInfo.width/2;
  265.         break;
  266.     case TK_ANCHOR_NE:
  267.     case TK_ANCHOR_E:
  268.     case TK_ANCHOR_SE:
  269.         deltaX = -psInfo.width;
  270.         break;
  271.     }
  272.     switch (psInfo.pageAnchor) {
  273.     case TK_ANCHOR_NW:
  274.     case TK_ANCHOR_N:
  275.     case TK_ANCHOR_NE:
  276.         deltaY = - psInfo.height;
  277.         break;
  278.     case TK_ANCHOR_W:
  279.     case TK_ANCHOR_CENTER:
  280.     case TK_ANCHOR_E:
  281.         deltaY = -psInfo.height/2;
  282.         break;
  283.     case TK_ANCHOR_SW:
  284.     case TK_ANCHOR_S:
  285.     case TK_ANCHOR_SE:
  286.         deltaY = 0;
  287.         break;
  288.     }
  289.  
  290.     if (psInfo.colorMode == NULL) {
  291.     psInfo.colorLevel = 2;
  292.     } else {
  293.     length = strlen(psInfo.colorMode);
  294.     if (strncmp(psInfo.colorMode, "monochrome", length) == 0) {
  295.         psInfo.colorLevel = 0;
  296.     } else if (strncmp(psInfo.colorMode, "gray", length) == 0) {
  297.         psInfo.colorLevel = 1;
  298.     } else if (strncmp(psInfo.colorMode, "color", length) == 0) {
  299.         psInfo.colorLevel = 2;
  300.     } else {
  301.         Tcl_AppendResult(canvasPtr->interp, "bad color mode \"",
  302.             psInfo.colorMode, "\": must be monochrome, ",
  303.             "gray, or color", (char *) NULL);
  304.         goto cleanup;
  305.     }
  306.     }
  307.  
  308.     if (psInfo.fileName != NULL) {
  309.     p = Tcl_TildeSubst(canvasPtr->interp, psInfo.fileName, &buffer);
  310.     if (p == NULL) {
  311.         goto cleanup;
  312.     }
  313.     psInfo.f = fopen(p, "w");
  314.     Tcl_DStringFree(&buffer);
  315.     if (psInfo.f == NULL) {
  316.         Tcl_AppendResult(canvasPtr->interp, "couldn't write file \"",
  317.             psInfo.fileName, "\": ",
  318.             Tcl_PosixError(canvasPtr->interp), (char *) NULL);
  319.         goto cleanup;
  320.     }
  321.     }
  322.  
  323.     /*
  324.      *--------------------------------------------------------
  325.      * Make a pre-pass over all of the items, generating Postscript
  326.      * and then throwing it away.  The purpose of this pass is just
  327.      * to collect information about all the fonts in use, so that
  328.      * we can output font information in the proper form required
  329.      * by the Document Structuring Conventions.
  330.      *--------------------------------------------------------
  331.      */
  332.  
  333.     psInfo.prepass = 1;
  334.     for (itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL;
  335.         itemPtr = itemPtr->nextPtr) {
  336.     if ((itemPtr->x1 >= psInfo.x2) || (itemPtr->x2 < psInfo.x)
  337.         || (itemPtr->y1 >= psInfo.y2) || (itemPtr->y2 < psInfo.y)) {
  338.         continue;
  339.     }
  340.     if (itemPtr->typePtr->postscriptProc == NULL) {
  341.         continue;
  342.     }
  343.     result = (*itemPtr->typePtr->postscriptProc)(canvasPtr, itemPtr,
  344.         (Tk_PostscriptInfo *) &psInfo);
  345.     Tcl_ResetResult(canvasPtr->interp);
  346.     if (result != TCL_OK) {
  347.         /*
  348.          * An error just occurred.  Just skip out of this loop.
  349.          * There's no need to report the error now;  it can be
  350.          * reported later (errors can happen later that don't
  351.          * happen now, so we still have to check for errors later
  352.          * anyway).
  353.          */
  354.         break;
  355.     }
  356.     }
  357.     psInfo.prepass = 0;
  358.  
  359.     /*
  360.      *--------------------------------------------------------
  361.      * Generate the header and prolog for the Postscript.
  362.      *--------------------------------------------------------
  363.      */
  364.  
  365.     Tcl_AppendResult(canvasPtr->interp, "%!PS-Adobe-3.0 EPSF-3.0\n",
  366.         "%%Creator: Tk Canvas Widget\n", (char *) NULL);
  367.     pwPtr = getpwuid(getuid());
  368.     Tcl_AppendResult(canvasPtr->interp, "%%For: ",
  369.         (pwPtr != NULL) ? pwPtr->pw_gecos : "Unknown", "\n",
  370.         (char *) NULL);
  371.     endpwent();
  372.     Tcl_AppendResult(canvasPtr->interp, "%%Title: Window ",
  373.         Tk_PathName(canvasPtr->tkwin), "\n", (char *) NULL);
  374.     time(&now);
  375.     Tcl_AppendResult(canvasPtr->interp, "%%CreationDate: ",
  376.         ctime(&now), (char *) NULL);
  377.     if (!psInfo.rotate) {
  378.     sprintf(string, "%d %d %d %d",
  379.         (int) (psInfo.pageX + psInfo.scale*deltaX),
  380.         (int) (psInfo.pageY + psInfo.scale*deltaY),
  381.         (int) (psInfo.pageX + psInfo.scale*(deltaX + psInfo.width)
  382.             + 1.0),
  383.         (int) (psInfo.pageY + psInfo.scale*(deltaY + psInfo.height)
  384.             + 1.0));
  385.     } else {
  386.     sprintf(string, "%d %d %d %d",
  387.         (int) (psInfo.pageX - psInfo.scale*(deltaY + psInfo.height)),
  388.         (int) (psInfo.pageY + psInfo.scale*deltaX),
  389.         (int) (psInfo.pageX - psInfo.scale*deltaY + 1.0),
  390.         (int) (psInfo.pageY + psInfo.scale*(deltaX + psInfo.width)
  391.             + 1.0));
  392.     }
  393.     Tcl_AppendResult(canvasPtr->interp, "%%BoundingBox: ", string,
  394.         "\n", (char *) NULL);
  395.     Tcl_AppendResult(canvasPtr->interp, "%%Pages: 1\n", 
  396.         "%%DocumentData: Clean7Bit\n", (char *) NULL);
  397.     Tcl_AppendResult(canvasPtr->interp, "%%Orientation: ",
  398.         psInfo.rotate ? "Landscape\n" : "Portrait\n", (char *) NULL);
  399.     p = "%%DocumentNeededResources: font ";
  400.     for (hPtr = Tcl_FirstHashEntry(&psInfo.fontTable, &search);
  401.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  402.     Tcl_AppendResult(canvasPtr->interp, p,
  403.         Tcl_GetHashKey(&psInfo.fontTable, hPtr),
  404.         "\n", (char *) NULL);
  405.     p = "%%+ font ";
  406.     }
  407.     Tcl_AppendResult(canvasPtr->interp, "%%EndComments\n\n", (char *) NULL);
  408.  
  409.     /*
  410.      * Read a standard prolog file from disk and insert it into
  411.      * the Postscript.
  412.      */
  413.  
  414.     libDir = Tcl_GetVar(canvasPtr->interp, "tk_library", TCL_GLOBAL_ONLY);
  415.     if (libDir == NULL) {
  416.     Tcl_ResetResult(canvasPtr->interp);
  417.     Tcl_AppendResult(canvasPtr->interp, "couldn't find library directory: ",
  418.         "tk_library variable doesn't exist", (char *) NULL);
  419.     goto cleanup;
  420.     }
  421.     sprintf(string, "%.350s/prolog.ps", libDir);
  422.     f = fopen(string, "r");
  423.     if (f == NULL) {
  424.     Tcl_ResetResult(canvasPtr->interp);
  425.     Tcl_AppendResult(canvasPtr->interp, "couldn't open prolog file \"",
  426.         string, "\": ", Tcl_PosixError(canvasPtr->interp),
  427.         (char *) NULL);
  428.     goto cleanup;
  429.     }
  430.     while (fgets(string, STRING_LENGTH, f) != NULL) {
  431.     Tcl_AppendResult(canvasPtr->interp, string, (char *) NULL);
  432.     }
  433.     if (ferror(f)) {
  434.     fclose(f);
  435.     Tcl_ResetResult(canvasPtr->interp);
  436.     Tcl_AppendResult(canvasPtr->interp, "error reading prolog file \"",
  437.         string, "\": ",
  438.         Tcl_PosixError(canvasPtr->interp), (char *) NULL);
  439.     goto cleanup;
  440.     }
  441.     fclose(f);
  442.     if (psInfo.f != NULL) {
  443.     fputs(canvasPtr->interp->result, psInfo.f);
  444.     Tcl_ResetResult(canvasPtr->interp);
  445.     }
  446.  
  447.     /*
  448.      *-----------------------------------------------------------
  449.      * Document setup:  set the color level and include fonts.
  450.      *-----------------------------------------------------------
  451.      */
  452.  
  453.     sprintf(string, "/CL %d def\n", psInfo.colorLevel);
  454.     Tcl_AppendResult(canvasPtr->interp, "%%BeginSetup\n", string,
  455.         (char *) NULL);
  456.     for (hPtr = Tcl_FirstHashEntry(&psInfo.fontTable, &search);
  457.         hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
  458.     Tcl_AppendResult(canvasPtr->interp, "%%IncludeResource: font ",
  459.         Tcl_GetHashKey(&psInfo.fontTable, hPtr), "\n", (char *) NULL);
  460.     }
  461.     Tcl_AppendResult(canvasPtr->interp, "%%EndSetup\n\n", (char *) NULL);
  462.  
  463.     /*
  464.      *-----------------------------------------------------------
  465.      * Page setup:  move to page positioning point, rotate if
  466.      * needed, set scale factor, offset for proper anchor position,
  467.      * and set clip region.
  468.      *-----------------------------------------------------------
  469.      */
  470.  
  471.     Tcl_AppendResult(canvasPtr->interp, "%%Page: 1 1\n", "save\n",
  472.         (char *) NULL);
  473.     sprintf(string, "%.1f %.1f translate\n", psInfo.pageX, psInfo.pageY);
  474.     Tcl_AppendResult(canvasPtr->interp, string, (char *) NULL);
  475.     if (psInfo.rotate) {
  476.     Tcl_AppendResult(canvasPtr->interp, "90 rotate\n", (char *) NULL);
  477.     }
  478.     sprintf(string, "%.4g %.4g scale\n", psInfo.scale, psInfo.scale);
  479.     Tcl_AppendResult(canvasPtr->interp, string, (char *) NULL);
  480.     sprintf(string, "%d %d translate\n", deltaX - psInfo.x, deltaY);
  481.     Tcl_AppendResult(canvasPtr->interp, string, (char *) NULL);
  482.     sprintf(string, "%d %.15g moveto %d %.15g lineto %d %.15g lineto %d %.15g",
  483.         psInfo.x,
  484.         TkCanvPsY((Tk_PostscriptInfo *) &psInfo, (double) psInfo.y),
  485.         psInfo.x2,
  486.         TkCanvPsY((Tk_PostscriptInfo *) &psInfo, (double) psInfo.y),
  487.         psInfo.x2,
  488.         TkCanvPsY((Tk_PostscriptInfo *) &psInfo, (double) psInfo.y2),
  489.         psInfo.x,
  490.         TkCanvPsY((Tk_PostscriptInfo *) &psInfo, (double) psInfo.y2));
  491.     Tcl_AppendResult(canvasPtr->interp, string,
  492.     " lineto closepath clip newpath\n", (char *) NULL);
  493.     if (psInfo.f != NULL) {
  494.     fputs(canvasPtr->interp->result, psInfo.f);
  495.     Tcl_ResetResult(canvasPtr->interp);
  496.     }
  497.  
  498.     /*
  499.      *---------------------------------------------------------------------
  500.      * Iterate through all the items, having each relevant one draw itself.
  501.      * Quit if any of the items returns an error.
  502.      *---------------------------------------------------------------------
  503.      */
  504.  
  505.     result = TCL_OK;
  506.     for (itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL;
  507.         itemPtr = itemPtr->nextPtr) {
  508.     if ((itemPtr->x1 >= psInfo.x2) || (itemPtr->x2 < psInfo.x)
  509.         || (itemPtr->y1 >= psInfo.y2) || (itemPtr->y2 < psInfo.y)) {
  510.         continue;
  511.     }
  512.     if (itemPtr->typePtr->postscriptProc == NULL) {
  513.         continue;
  514.     }
  515.     Tcl_AppendResult(canvasPtr->interp, "gsave\n", (char *) NULL);
  516.     result = (*itemPtr->typePtr->postscriptProc)(canvasPtr, itemPtr,
  517.         (Tk_PostscriptInfo *) &psInfo);
  518.     if (result != TCL_OK) {
  519.         char msg[100];
  520.  
  521.         sprintf(msg, "\n    (generating Postscript for item %d)",
  522.             itemPtr->id);
  523.         Tcl_AddErrorInfo(canvasPtr->interp, msg);
  524.         goto cleanup;
  525.     }
  526.     Tcl_AppendResult(canvasPtr->interp, "grestore\n", (char *) NULL);
  527.     if (psInfo.f != NULL) {
  528.         fputs(canvasPtr->interp->result, psInfo.f);
  529.         Tcl_ResetResult(canvasPtr->interp);
  530.     }
  531.     }
  532.  
  533.     /*
  534.      *---------------------------------------------------------------------
  535.      * Output page-end information, such as commands to print the page
  536.      * and document trailer stuff.
  537.      *---------------------------------------------------------------------
  538.      */
  539.  
  540.     Tcl_AppendResult(canvasPtr->interp, "restore showpage\n\n",
  541.         "%%Trailer\nend\n%%EOF\n", (char *) NULL);
  542.     if (psInfo.f != NULL) {
  543.     fputs(canvasPtr->interp->result, psInfo.f);
  544.     Tcl_ResetResult(canvasPtr->interp);
  545.     }
  546.  
  547.     /*
  548.      * Clean up psInfo to release malloc'ed stuff.
  549.      */
  550.  
  551.     cleanup:
  552.     if (psInfo.pageXString != NULL) {
  553.     ckfree(psInfo.pageXString);
  554.     }
  555.     if (psInfo.pageYString != NULL) {
  556.     ckfree(psInfo.pageYString);
  557.     }
  558.     if (psInfo.pageWidthString != NULL) {
  559.     ckfree(psInfo.pageWidthString);
  560.     }
  561.     if (psInfo.pageHeightString != NULL) {
  562.     ckfree(psInfo.pageHeightString);
  563.     }
  564.     if (psInfo.fontVar != NULL) {
  565.     ckfree(psInfo.fontVar);
  566.     }
  567.     if (psInfo.colorVar != NULL) {
  568.     ckfree(psInfo.colorVar);
  569.     }
  570.     if (psInfo.colorMode != NULL) {
  571.     ckfree(psInfo.colorMode);
  572.     }
  573.     if (psInfo.fileName != NULL) {
  574.     ckfree(psInfo.fileName);
  575.     }
  576.     if (psInfo.f != NULL) {
  577.     fclose(psInfo.f);
  578.     }
  579.     Tcl_DeleteHashTable(&psInfo.fontTable);
  580.     return result;
  581. }
  582.  
  583. /*
  584.  *--------------------------------------------------------------
  585.  *
  586.  * TkCanvPsColor --
  587.  *
  588.  *    This procedure is called by individual canvas items when
  589.  *    they want to set a color value for output.  Given information
  590.  *    about an X color, this procedure will generate Postscript
  591.  *    commands to set up an appropriate color in Postscript.
  592.  *
  593.  * Results:
  594.  *    Returns a standard Tcl return value.  If an error occurs
  595.  *    then an error message will be left in canvasPtr->interp->result.
  596.  *    If no error occurs, then additional Postscript will be
  597.  *    appended to canvasPtr->interp->result.
  598.  *
  599.  * Side effects:
  600.  *    None.
  601.  *
  602.  *--------------------------------------------------------------
  603.  */
  604.  
  605. int
  606. TkCanvPsColor(canvasPtr, handle, colorPtr)
  607.     Tk_Canvas *canvasPtr;        /* Information about canvas. */
  608.     Tk_PostscriptInfo *handle;        /* Information about Postscript being
  609.                      * generated. */
  610.     XColor *colorPtr;            /* Information about color. */
  611. {
  612.     PostscriptInfo *psInfoPtr = (PostscriptInfo *) handle;
  613.     double red, green, blue;
  614.     char string[200];
  615.  
  616.     if (psInfoPtr->prepass) {
  617.     return TCL_OK;
  618.     }
  619.  
  620.     /*
  621.      * If there is a color map defined, then look up the color's name
  622.      * in the map and use the Postscript commands found there, if there
  623.      * are any.
  624.      */
  625.  
  626.     if (psInfoPtr->colorVar != NULL) {
  627.     char *cmdString;
  628.  
  629.     cmdString = Tcl_GetVar2(canvasPtr->interp, psInfoPtr->colorVar,
  630.         Tk_NameOfColor(colorPtr), 0);
  631.     if (cmdString != NULL) {
  632.         Tcl_AppendResult(canvasPtr->interp, cmdString, "\n",
  633.             (char *) NULL);
  634.         return TCL_OK;
  635.     }
  636.     }
  637.  
  638.     /*
  639.      * No color map entry for this color.  Grab the color's intensities
  640.      * and output Postscript commands for them.
  641.      */
  642.  
  643.     red = colorPtr->red/65535.0;
  644.     green = colorPtr->green/65535.0;
  645.     blue = colorPtr->blue/65535.0;
  646.     sprintf(string, "%.3f %.3f %.3f setrgbcolor AdjustColor\n",
  647.         red, green, blue);
  648.     Tcl_AppendResult(canvasPtr->interp, string, (char *) NULL);
  649.     return TCL_OK;
  650. }
  651.  
  652. /*
  653.  *--------------------------------------------------------------
  654.  *
  655.  * TkCanvPsFont --
  656.  *
  657.  *    This procedure is called by individual canvas items when
  658.  *    they want to output text.  Given information about an X
  659.  *    font, this procedure will generate Postscript commands
  660.  *    to set up an appropriate font in Postscript.
  661.  *
  662.  * Results:
  663.  *    Returns a standard Tcl return value.  If an error occurs
  664.  *    then an error message will be left in canvasPtr->interp->result.
  665.  *    If no error occurs, then additional Postscript will be
  666.  *    appended to the canvasPtr->interp->result.
  667.  *
  668.  * Side effects:
  669.  *    The Postscript font name is entered into psInfoPtr->fontTable
  670.  *    if it wasn't already there.
  671.  *
  672.  *--------------------------------------------------------------
  673.  */
  674.  
  675. int
  676. TkCanvPsFont(canvasPtr, handle, fontStructPtr)
  677.     register Tk_Canvas *canvasPtr;    /* Information about canvas. */
  678.     Tk_PostscriptInfo *handle;        /* Information about Postscript being
  679.                      * generated. */
  680.     XFontStruct *fontStructPtr;        /* Information about font in which text
  681.                      * is to be printed. */
  682. {
  683.     PostscriptInfo *psInfoPtr = (PostscriptInfo *) handle;
  684.     char *name, *end, *weightString, *slantString;
  685. #define TOTAL_FIELDS    8
  686. #define FAMILY_FIELD    1
  687. #define WEIGHT_FIELD    2
  688. #define SLANT_FIELD    3
  689. #define SIZE_FIELD    7
  690.     char *fieldPtrs[TOTAL_FIELDS];
  691. #define MAX_NAME_SIZE 100
  692.     char fontName[MAX_NAME_SIZE+50], pointString[20];
  693.     int i, c, weightSize, nameSize, points;
  694.     register char *p;
  695.  
  696.     name = Tk_NameOfFontStruct(fontStructPtr);
  697.  
  698.     /*
  699.      * First, look up the font's name in the font map, if there is one.
  700.      * If there is an entry for this font, it consists of a list
  701.      * containing font name and size.  Use this information.
  702.      */
  703.  
  704.     if (psInfoPtr->fontVar != NULL) {
  705.     char *list, **argv;
  706.     int argc;
  707.     double size;
  708.  
  709.     list = Tcl_GetVar2(canvasPtr->interp, psInfoPtr->fontVar,
  710.         name, 0);
  711.     if (list != NULL) {
  712.         if (Tcl_SplitList(canvasPtr->interp, list, &argc, &argv)
  713.             != TCL_OK) {
  714.         badMapEntry:
  715.         Tcl_ResetResult(canvasPtr->interp);
  716.         Tcl_AppendResult(canvasPtr->interp,
  717.             "bad font map entry for \"", name,
  718.             "\": \"", list, "\"", (char *) NULL);
  719.         return TCL_ERROR;
  720.         }
  721.         if (argc != 2) {
  722.         goto badMapEntry;
  723.         }
  724.         size = strtod(argv[1], &end);
  725.         if ((size <= 0) || (*end != 0)) {
  726.         goto badMapEntry;
  727.         }
  728.         sprintf(pointString, "%.15g", size);
  729.         Tcl_AppendResult(canvasPtr->interp, "/", argv[0], " findfont ",
  730.             pointString, " scalefont setfont\n", (char *) NULL);
  731.         Tcl_CreateHashEntry(&psInfoPtr->fontTable, argv[0], &i);
  732.         ckfree((char *) argv);
  733.         return TCL_OK;
  734.     }
  735.     }
  736.  
  737.     /*
  738.      * Not in the font map.  Try to parse the name to get four fields:
  739.      * family name, weight, slant, and point size.  To do this, split the
  740.      * font name up into fields, storing pointers to the first character
  741.      * of each field in fieldPtrs.
  742.      */
  743.  
  744.     if (name[0] != '-') {
  745.     goto error;
  746.     }
  747.     for (p =  name+1, i = 0; i < TOTAL_FIELDS; i++) {
  748.     fieldPtrs[i] = p;
  749.     while (*p != '-') {
  750.         if (*p == 0) {
  751.         goto error;
  752.         }
  753.         p++;
  754.     }
  755.     p++;
  756.     }
  757.  
  758.     /*
  759.      * Use the information from the X font name to make a guess at a
  760.      * Postscript font name of the form "<family>-<weight><slant>" where
  761.      * <weight> and <slant> may be omitted and if both are omitted then
  762.      * the dash is also omitted.  Postscript is very picky about font names,
  763.      * so there are several heuristics in the code below (e.g. don't
  764.      * include a "Roman" slant except for "Times" font, and make sure
  765.      * that the first letter of each field is capitalized but no other
  766.      * letters are in caps).
  767.      */
  768.  
  769.     nameSize = fieldPtrs[FAMILY_FIELD+1] - 1 - fieldPtrs[FAMILY_FIELD];
  770.     if ((nameSize == 0) || (nameSize > MAX_NAME_SIZE)) {
  771.     goto error;
  772.     }
  773.     strncpy(fontName, fieldPtrs[FAMILY_FIELD], nameSize);
  774.     if (islower(fontName[0])) {
  775.     fontName[0] = toupper(fontName[0]);
  776.     }
  777.     for (p = fontName+1, i = nameSize-1; i > 0; p++, i--) {
  778.     if (isupper(*p)) {
  779.         *p = tolower(*p);
  780.     }
  781.     }
  782.     *p = 0;
  783.     weightSize = fieldPtrs[WEIGHT_FIELD+1] - 1 - fieldPtrs[WEIGHT_FIELD];
  784.     if (weightSize == 0) {
  785.     goto error;
  786.     }
  787.     if (CaseCmp(fieldPtrs[WEIGHT_FIELD], "medium", weightSize) == 0) {
  788.     weightString = "";
  789.     } else if (CaseCmp(fieldPtrs[WEIGHT_FIELD], "bold", weightSize) == 0) {
  790.     weightString = "Bold";
  791.     } else {
  792.     goto error;
  793.     }
  794.     if (fieldPtrs[SLANT_FIELD+1] != (fieldPtrs[SLANT_FIELD] + 2)) {
  795.     goto error;
  796.     }
  797.     c = fieldPtrs[SLANT_FIELD][0];
  798.     if ((c == 'r') || (c == 'R')) {
  799.     slantString = "";
  800.     if ((weightString[0] == 0) && (nameSize == 5)
  801.         && (strncmp(fontName, "Times", 5) == 0)) {
  802.         slantString = "Roman";
  803.     }
  804.     } else if ((c == 'i') || (c == 'I')) {
  805.     slantString = "Italic";
  806.     } else if ((c == 'o') || (c == 'O')) {
  807.     slantString = "Oblique";
  808.     } else {
  809.     goto error;
  810.     }
  811.     if ((weightString[0] != 0) || (slantString[0] != 0)) {
  812.     sprintf(p, "-%s%s", weightString, slantString);
  813.     }
  814.     points = strtoul(fieldPtrs[SIZE_FIELD], &end, 0);
  815.     if (points == 0) {
  816.     goto error;
  817.     }
  818.     sprintf(pointString, "%.15g", ((double) points)/10.0);
  819.     Tcl_AppendResult(canvasPtr->interp, "/", fontName, " findfont ",
  820.         pointString, " scalefont setfont\n", (char *) NULL);
  821.     Tcl_CreateHashEntry(&psInfoPtr->fontTable, fontName, &i);
  822.     return TCL_OK;
  823.  
  824.     error:
  825.     Tcl_ResetResult(canvasPtr->interp);
  826.     Tcl_AppendResult(canvasPtr->interp, "couldn't translate font name \"",
  827.         name, "\" to Postscript", (char *) NULL);
  828.     return TCL_ERROR;
  829. }
  830.  
  831. /*
  832.  *--------------------------------------------------------------
  833.  *
  834.  * TkCanvPsBitmap --
  835.  *
  836.  *    This procedure is called to output the contents of a
  837.  *    bitmap in proper image data format for Postscript (i.e.
  838.  *    data between angle brackets, one bit per pixel).
  839.  *
  840.  * Results:
  841.  *    Returns a standard Tcl return value.  If an error occurs
  842.  *    then an error message will be left in canvasPtr->interp->result.
  843.  *    If no error occurs, then additional Postscript will be
  844.  *    appended to canvasPtr->interp->result.
  845.  *
  846.  * Side effects:
  847.  *    None.
  848.  *
  849.  *--------------------------------------------------------------
  850.  */
  851.  
  852. int
  853. TkCanvPsBitmap(canvasPtr, handle, bitmap)
  854.     Tk_Canvas *canvasPtr;        /* Information about canvas. */
  855.     Tk_PostscriptInfo *handle;        /* Information about Postscript being
  856.                      * generated. */
  857.     Pixmap bitmap;            /* Bitmap to use for stippling. */
  858. {
  859.     PostscriptInfo *psInfoPtr = (PostscriptInfo *) handle;
  860.     unsigned int width, height;
  861.     XImage *imagePtr;
  862.     int charsInLine, x, y, value, mask;
  863.     char string[100];
  864.  
  865.     if (psInfoPtr->prepass) {
  866.     return TCL_OK;
  867.     }
  868.  
  869.     Tk_SizeOfBitmap(canvasPtr->display, bitmap, &width, &height);
  870.     imagePtr = XGetImage(Tk_Display(canvasPtr->tkwin), bitmap, 0, 0,
  871.         width, height, 1, XYPixmap);
  872.     Tcl_AppendResult(canvasPtr->interp, "<", (char *) NULL);
  873.     mask = 0x80;
  874.     value = 0;
  875.     charsInLine = 0;
  876.     for (y = 1; y <= height; y++) {
  877.     for (x = 0; x < width; x++) {
  878.         if (XGetPixel(imagePtr, x, height-y)) {
  879.         value |= mask;
  880.         }
  881.         mask >>= 1;
  882.         if (mask == 0) {
  883.         sprintf(string, "%02x", value);
  884.         Tcl_AppendResult(canvasPtr->interp, string, (char *) NULL);
  885.         mask = 0x80;
  886.         value = 0;
  887.         charsInLine += 2;
  888.         if (charsInLine >= 60) {
  889.             Tcl_AppendResult(canvasPtr->interp, "\n", (char *) NULL);
  890.             charsInLine = 0;
  891.         }
  892.         }
  893.     }
  894.     if (mask != 0x80) {
  895.         sprintf(string, "%02x", value);
  896.         Tcl_AppendResult(canvasPtr->interp, string, (char *) NULL);
  897.         mask = 0x80;
  898.         value = 0;
  899.         charsInLine += 2;
  900.     }
  901.     }
  902.     Tcl_AppendResult(canvasPtr->interp, ">", (char *) NULL);
  903.     XDestroyImage(imagePtr);
  904.     return TCL_OK;
  905. }
  906.  
  907. /*
  908.  *--------------------------------------------------------------
  909.  *
  910.  * TkCanvPsStipple --
  911.  *
  912.  *    This procedure is called by individual canvas items when
  913.  *    they have created a path that they'd like to be filled with
  914.  *    a stipple pattern.  Given information about an X bitmap,
  915.  *    this procedure will generate Postscript commands to fill
  916.  *    the current path using a stipple pattern defined by the
  917.  *    bitmap.
  918.  *
  919.  * Results:
  920.  *    Returns a standard Tcl return value.  If an error occurs
  921.  *    then an error message will be left in canvasPtr->interp->result.
  922.  *    If no error occurs, then additional Postscript will be
  923.  *    appended to canvasPtr->interp->result.
  924.  *
  925.  * Side effects:
  926.  *    None.
  927.  *
  928.  *--------------------------------------------------------------
  929.  */
  930.  
  931. int
  932. TkCanvPsStipple(canvasPtr, handle, bitmap, filled)
  933.     Tk_Canvas *canvasPtr;        /* Information about canvas. */
  934.     Tk_PostscriptInfo *handle;        /* Information about Postscript being
  935.                      * generated. */
  936.     Pixmap bitmap;            /* Bitmap to use for stippling. */
  937.     int filled;                /* Non-zero means the area defined by
  938.                      * the path should be filled with the
  939.                      * stipple pattern;  zero means the
  940.                      * path should be stroked in the
  941.                      * stipple pattern. */
  942. {
  943.     PostscriptInfo *psInfoPtr = (PostscriptInfo *) handle;
  944.     unsigned int width, height;
  945.     char string[100];
  946.  
  947.     if (psInfoPtr->prepass) {
  948.     return TCL_OK;
  949.     }
  950.  
  951.     Tk_SizeOfBitmap(canvasPtr->display, bitmap, &width, &height);
  952.     sprintf(string, "%d %d ", width, height);
  953.     Tcl_AppendResult(canvasPtr->interp, string, (char *) NULL);
  954.     if (TkCanvPsBitmap(canvasPtr, handle, bitmap) != TCL_OK) {
  955.     return TCL_ERROR;
  956.     }
  957.     Tcl_AppendResult(canvasPtr->interp, filled ? " true" : " false",
  958.         " StippleFill\n", (char *) NULL);
  959.     return TCL_OK;
  960. }
  961.  
  962. /*
  963.  *--------------------------------------------------------------
  964.  *
  965.  * TkCanvPsY --
  966.  *
  967.  *    Given a y-coordinate in canvas coordinates, this procedure
  968.  *    returns a y-coordinate to use for Postscript output.
  969.  *
  970.  * Results:
  971.  *    Returns the Postscript coordinate that corresponds to
  972.  *    "y".
  973.  *
  974.  * Side effects:
  975.  *    None.
  976.  *
  977.  *--------------------------------------------------------------
  978.  */
  979.  
  980. double
  981. TkCanvPsY(handle, y)
  982.     Tk_PostscriptInfo *handle;        /* Information about Postscript being
  983.                      * generated. */
  984.     double y;                /* Y-coordinate in canvas coords. */
  985. {
  986.     PostscriptInfo *psInfoPtr = (PostscriptInfo *) handle;
  987.     return psInfoPtr->y2 - y;
  988. }
  989.  
  990. /*
  991.  *--------------------------------------------------------------
  992.  *
  993.  * TkCanvPsPath --
  994.  *
  995.  *    Given an array of points for a path, generate Postscript
  996.  *    commands to create the path.
  997.  *
  998.  * Results:
  999.  *    Postscript commands get appended to what's in interp->result.
  1000.  *
  1001.  * Side effects:
  1002.  *    None.
  1003.  *
  1004.  *--------------------------------------------------------------
  1005.  */
  1006.  
  1007. void
  1008. TkCanvPsPath(interp, coordPtr, numPoints, handle)
  1009.     Tcl_Interp *interp;            /* Put generated Postscript in this
  1010.                      * interpreter's result field. */
  1011.     register double *coordPtr;        /* Pointer to first in array of
  1012.                      * 2*numPoints coordinates giving
  1013.                      * points for path. */
  1014.     int numPoints;            /* Number of points at *coordPtr. */
  1015.     Tk_PostscriptInfo *handle;        /* Information about the Postscript;
  1016.                      * must be passed back to Postscript
  1017.                      * utility procedures. */
  1018. {
  1019.     PostscriptInfo *psInfoPtr = (PostscriptInfo *) handle;
  1020.     char buffer[200];
  1021.  
  1022.     if (psInfoPtr->prepass) {
  1023.     return;
  1024.     }
  1025.     sprintf(buffer, "%.15g %.15g moveto\n", coordPtr[0],
  1026.         TkCanvPsY(handle, coordPtr[1]));
  1027.     Tcl_AppendResult(interp, buffer, (char *) NULL);
  1028.     for (numPoints--, coordPtr += 2; numPoints > 0;
  1029.         numPoints--, coordPtr += 2) {
  1030.     sprintf(buffer, "%.15g %.15g lineto\n", coordPtr[0],
  1031.         TkCanvPsY(handle, coordPtr[1]));
  1032.     Tcl_AppendResult(interp, buffer, (char *) NULL);
  1033.     }
  1034. }
  1035.  
  1036. /*
  1037.  *--------------------------------------------------------------
  1038.  *
  1039.  * GetPostscriptPoints --
  1040.  *
  1041.  *    Given a string, returns the number of Postscript points
  1042.  *    corresponding to that string.
  1043.  *
  1044.  * Results:
  1045.  *    The return value is a standard Tcl return result.  If
  1046.  *    TCL_OK is returned, then everything went well and the
  1047.  *    screen distance is stored at *doublePtr;  otherwise
  1048.  *    TCL_ERROR is returned and an error message is left in
  1049.  *    interp->result.
  1050.  *
  1051.  * Side effects:
  1052.  *    None.
  1053.  *
  1054.  *--------------------------------------------------------------
  1055.  */
  1056.  
  1057. static int
  1058. GetPostscriptPoints(interp, string, doublePtr)
  1059.     Tcl_Interp *interp;        /* Use this for error reporting. */
  1060.     char *string;        /* String describing a screen distance. */
  1061.     double *doublePtr;        /* Place to store converted result. */
  1062. {
  1063.     char *end;
  1064.     double d;
  1065.  
  1066.     d = strtod(string, &end);
  1067.     if (end == string) {
  1068.     error:
  1069.     Tcl_AppendResult(interp, "bad distance \"", string,
  1070.         "\"", (char *) NULL);
  1071.     return TCL_ERROR;
  1072.     }
  1073.     while ((*end != '\0') && isspace(*end)) {
  1074.     end++;
  1075.     }
  1076.     switch (*end) {
  1077.     case 'c':
  1078.         d *= 72.0/2.54;
  1079.         end++;
  1080.         break;
  1081.     case 'i':
  1082.         d *= 72.0;
  1083.         end++;
  1084.         break;
  1085.     case 'm':
  1086.         d *= 72.0/25.4;
  1087.         end++;
  1088.         break;
  1089.     case 0:
  1090.     case 'p':
  1091.         end++;
  1092.         break;
  1093.     default:
  1094.         goto error;
  1095.     }
  1096.     while ((*end != '\0') && isspace(*end)) {
  1097.     end++;
  1098.     }
  1099.     if (*end != 0) {
  1100.     goto error;
  1101.     }
  1102.     *doublePtr = d;
  1103.     return TCL_OK;
  1104. }
  1105.  
  1106. /*
  1107.  *----------------------------------------------------------------------
  1108.  *
  1109.  * CaseCmp --
  1110.  *
  1111.  *    Compares two strings, ignoring case differences.
  1112.  *
  1113.  * Results:
  1114.  *    Compares up to length chars of s1 and s2, returning -1, 0, or 1
  1115.  *    if s1 is lexicographically less than, equal to, or greater
  1116.  *    than s2 over those characters.
  1117.  *
  1118.  * Side effects:
  1119.  *    None.
  1120.  *
  1121.  *----------------------------------------------------------------------
  1122.  */
  1123.  
  1124. static int
  1125. CaseCmp(s1, s2, length)
  1126.     char *s1;            /* First string. */
  1127.     char *s2;            /* Second string. */
  1128.     int length;            /* Maximum number of characters to compare
  1129.                  * (stop earlier if the end of either string
  1130.                  * is reached). */
  1131. {
  1132.     register unsigned char u1, u2;
  1133.  
  1134.     /*
  1135.      * This array is designed for mapping upper and lower case letter
  1136.      * together for a case independent comparison.  The mappings are
  1137.      * based upon ASCII character sequences.
  1138.      */
  1139.  
  1140.     static unsigned char charmap[] = {
  1141.         '\000', '\001', '\002', '\003', '\004', '\005', '\006', '\007',
  1142.         '\010', '\011', '\012', '\013', '\014', '\015', '\016', '\017',
  1143.         '\020', '\021', '\022', '\023', '\024', '\025', '\026', '\027',
  1144.         '\030', '\031', '\032', '\033', '\034', '\035', '\036', '\037',
  1145.         '\040', '\041', '\042', '\043', '\044', '\045', '\046', '\047',
  1146.         '\050', '\051', '\052', '\053', '\054', '\055', '\056', '\057',
  1147.         '\060', '\061', '\062', '\063', '\064', '\065', '\066', '\067',
  1148.         '\070', '\071', '\072', '\073', '\074', '\075', '\076', '\077',
  1149.         '\100', '\141', '\142', '\143', '\144', '\145', '\146', '\147',
  1150.         '\150', '\151', '\152', '\153', '\154', '\155', '\156', '\157',
  1151.         '\160', '\161', '\162', '\163', '\164', '\165', '\166', '\167',
  1152.         '\170', '\171', '\172', '\133', '\134', '\135', '\136', '\137',
  1153.         '\140', '\141', '\142', '\143', '\144', '\145', '\146', '\147',
  1154.         '\150', '\151', '\152', '\153', '\154', '\155', '\156', '\157',
  1155.         '\160', '\161', '\162', '\163', '\164', '\165', '\166', '\167',
  1156.         '\170', '\171', '\172', '\173', '\174', '\175', '\176', '\177',
  1157.         '\200', '\201', '\202', '\203', '\204', '\205', '\206', '\207',
  1158.         '\210', '\211', '\212', '\213', '\214', '\215', '\216', '\217',
  1159.         '\220', '\221', '\222', '\223', '\224', '\225', '\226', '\227',
  1160.         '\230', '\231', '\232', '\233', '\234', '\235', '\236', '\237',
  1161.         '\240', '\241', '\242', '\243', '\244', '\245', '\246', '\247',
  1162.         '\250', '\251', '\252', '\253', '\254', '\255', '\256', '\257',
  1163.         '\260', '\261', '\262', '\263', '\264', '\265', '\266', '\267',
  1164.         '\270', '\271', '\272', '\273', '\274', '\275', '\276', '\277',
  1165.         '\300', '\341', '\342', '\343', '\344', '\345', '\346', '\347',
  1166.         '\350', '\351', '\352', '\353', '\354', '\355', '\356', '\357',
  1167.         '\360', '\361', '\362', '\363', '\364', '\365', '\366', '\367',
  1168.         '\370', '\371', '\372', '\333', '\334', '\335', '\336', '\337',
  1169.         '\340', '\341', '\342', '\343', '\344', '\345', '\346', '\347',
  1170.         '\350', '\351', '\352', '\353', '\354', '\355', '\356', '\357',
  1171.         '\360', '\361', '\362', '\363', '\364', '\365', '\366', '\367',
  1172.         '\370', '\371', '\372', '\373', '\374', '\375', '\376', '\377',
  1173.     };
  1174.  
  1175.     for (; length != 0; length--, s1++, s2++) {
  1176.     u1 = (unsigned char) *s1;
  1177.     u2 = (unsigned char) *s2;
  1178.     if (charmap[u1] != charmap[u2]) {
  1179.         return charmap[u1] - charmap[u2];
  1180.     }
  1181.     if (u1 == '\0') {
  1182.         return 0;
  1183.     }
  1184.     }
  1185.     return 0;
  1186. }
  1187.