summaryrefslogtreecommitdiffstats
path: root/generic/tkCanvPs.c
diff options
context:
space:
mode:
authorrjohnson <rjohnson>1998-04-01 09:51:44 (GMT)
committerrjohnson <rjohnson>1998-04-01 09:51:44 (GMT)
commit066ea7fd88d49cb456f74da71dbe875e4fc0aabb (patch)
tree8fb30cb152c4dc191be47fa043d2e6f5ea38c7ba /generic/tkCanvPs.c
parent13242623d2ff3ea02ab6a62bfb48a7dbb5c27e22 (diff)
downloadtk-066ea7fd88d49cb456f74da71dbe875e4fc0aabb.zip
tk-066ea7fd88d49cb456f74da71dbe875e4fc0aabb.tar.gz
tk-066ea7fd88d49cb456f74da71dbe875e4fc0aabb.tar.bz2
Initial revision
Diffstat (limited to 'generic/tkCanvPs.c')
-rw-r--r--generic/tkCanvPs.c1163
1 files changed, 1163 insertions, 0 deletions
diff --git a/generic/tkCanvPs.c b/generic/tkCanvPs.c
new file mode 100644
index 0000000..9bad194
--- /dev/null
+++ b/generic/tkCanvPs.c
@@ -0,0 +1,1163 @@
+/*
+ * tkCanvPs.c --
+ *
+ * This module provides Postscript output support for canvases,
+ * including the "postscript" widget command plus a few utility
+ * procedures used for generating Postscript.
+ *
+ * Copyright (c) 1991-1994 The Regents of the University of California.
+ * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tkCanvPs.c 1.57 97/10/28 18:08:39
+ */
+
+#include "tkInt.h"
+#include "tkCanvas.h"
+#include "tkPort.h"
+
+/*
+ * See tkCanvas.h for key data structures used to implement canvases.
+ */
+
+/*
+ * One of the following structures is created to keep track of Postscript
+ * output being generated. It consists mostly of information provided on
+ * the widget command line.
+ */
+
+typedef struct TkPostscriptInfo {
+ int x, y, width, height; /* Area to print, in canvas pixel
+ * coordinates. */
+ int x2, y2; /* x+width and y+height. */
+ char *pageXString; /* String value of "-pagex" option or NULL. */
+ char *pageYString; /* String value of "-pagey" option or NULL. */
+ double pageX, pageY; /* Postscript coordinates (in points)
+ * corresponding to pageXString and
+ * pageYString. Don't forget that y-values
+ * grow upwards for Postscript! */
+ char *pageWidthString; /* Printed width of output. */
+ char *pageHeightString; /* Printed height of output. */
+ double scale; /* Scale factor for conversion: each pixel
+ * maps into this many points. */
+ Tk_Anchor pageAnchor; /* How to anchor bbox on Postscript page. */
+ int rotate; /* Non-zero means output should be rotated
+ * on page (landscape mode). */
+ char *fontVar; /* If non-NULL, gives name of global variable
+ * containing font mapping information.
+ * Malloc'ed. */
+ char *colorVar; /* If non-NULL, give name of global variable
+ * containing color mapping information.
+ * Malloc'ed. */
+ char *colorMode; /* Mode for handling colors: "monochrome",
+ * "gray", or "color". Malloc'ed. */
+ int colorLevel; /* Numeric value corresponding to colorMode:
+ * 0 for mono, 1 for gray, 2 for color. */
+ char *fileName; /* Name of file in which to write Postscript;
+ * NULL means return Postscript info as
+ * result. Malloc'ed. */
+ char *channelName; /* If -channel is specified, the name of
+ * the channel to use. */
+ Tcl_Channel chan; /* Open channel corresponding to fileName. */
+ Tcl_HashTable fontTable; /* Hash table containing names of all font
+ * families used in output. The hash table
+ * values are not used. */
+ int prepass; /* Non-zero means that we're currently in
+ * the pre-pass that collects font information,
+ * so the Postscript generated isn't
+ * relevant. */
+} TkPostscriptInfo;
+
+/*
+ * The table below provides a template that's used to process arguments
+ * to the canvas "postscript" command and fill in TkPostscriptInfo
+ * structures.
+ */
+
+static Tk_ConfigSpec configSpecs[] = {
+ {TK_CONFIG_STRING, "-colormap", (char *) NULL, (char *) NULL,
+ "", Tk_Offset(TkPostscriptInfo, colorVar), 0},
+ {TK_CONFIG_STRING, "-colormode", (char *) NULL, (char *) NULL,
+ "", Tk_Offset(TkPostscriptInfo, colorMode), 0},
+ {TK_CONFIG_STRING, "-file", (char *) NULL, (char *) NULL,
+ "", Tk_Offset(TkPostscriptInfo, fileName), 0},
+ {TK_CONFIG_STRING, "-channel", (char *) NULL, (char *) NULL,
+ "", Tk_Offset(TkPostscriptInfo, channelName), 0},
+ {TK_CONFIG_STRING, "-fontmap", (char *) NULL, (char *) NULL,
+ "", Tk_Offset(TkPostscriptInfo, fontVar), 0},
+ {TK_CONFIG_PIXELS, "-height", (char *) NULL, (char *) NULL,
+ "", Tk_Offset(TkPostscriptInfo, height), 0},
+ {TK_CONFIG_ANCHOR, "-pageanchor", (char *) NULL, (char *) NULL,
+ "", Tk_Offset(TkPostscriptInfo, pageAnchor), 0},
+ {TK_CONFIG_STRING, "-pageheight", (char *) NULL, (char *) NULL,
+ "", Tk_Offset(TkPostscriptInfo, pageHeightString), 0},
+ {TK_CONFIG_STRING, "-pagewidth", (char *) NULL, (char *) NULL,
+ "", Tk_Offset(TkPostscriptInfo, pageWidthString), 0},
+ {TK_CONFIG_STRING, "-pagex", (char *) NULL, (char *) NULL,
+ "", Tk_Offset(TkPostscriptInfo, pageXString), 0},
+ {TK_CONFIG_STRING, "-pagey", (char *) NULL, (char *) NULL,
+ "", Tk_Offset(TkPostscriptInfo, pageYString), 0},
+ {TK_CONFIG_BOOLEAN, "-rotate", (char *) NULL, (char *) NULL,
+ "", Tk_Offset(TkPostscriptInfo, rotate), 0},
+ {TK_CONFIG_PIXELS, "-width", (char *) NULL, (char *) NULL,
+ "", Tk_Offset(TkPostscriptInfo, width), 0},
+ {TK_CONFIG_PIXELS, "-x", (char *) NULL, (char *) NULL,
+ "", Tk_Offset(TkPostscriptInfo, x), 0},
+ {TK_CONFIG_PIXELS, "-y", (char *) NULL, (char *) NULL,
+ "", Tk_Offset(TkPostscriptInfo, y), 0},
+ {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL,
+ (char *) NULL, 0, 0}
+};
+
+/*
+ * Forward declarations for procedures defined later in this file:
+ */
+
+static int GetPostscriptPoints _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, double *doublePtr));
+
+/*
+ *--------------------------------------------------------------
+ *
+ * TkCanvPostscriptCmd --
+ *
+ * This procedure is invoked to process the "postscript" options
+ * of the widget command for canvas widgets. See the user
+ * documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *--------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+int
+TkCanvPostscriptCmd(canvasPtr, interp, argc, argv)
+ TkCanvas *canvasPtr; /* Information about canvas widget. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. Caller has
+ * already parsed this command enough
+ * to know that argv[1] is
+ * "postscript". */
+{
+ TkPostscriptInfo psInfo, *oldInfoPtr;
+ int result;
+ Tk_Item *itemPtr;
+#define STRING_LENGTH 400
+ char string[STRING_LENGTH+1], *p;
+ time_t now;
+ size_t length;
+ int deltaX = 0, deltaY = 0; /* Offset of lower-left corner of
+ * area to be marked up, measured
+ * in canvas units from the positioning
+ * point on the page (reflects
+ * anchor position). Initial values
+ * needed only to stop compiler
+ * warnings. */
+ Tcl_HashSearch search;
+ Tcl_HashEntry *hPtr;
+ Tcl_DString buffer;
+
+ /*
+ *----------------------------------------------------------------
+ * Initialize the data structure describing Postscript generation,
+ * then process all the arguments to fill the data structure in.
+ *----------------------------------------------------------------
+ */
+
+ oldInfoPtr = canvasPtr->psInfoPtr;
+ canvasPtr->psInfoPtr = &psInfo;
+ psInfo.x = canvasPtr->xOrigin;
+ psInfo.y = canvasPtr->yOrigin;
+ psInfo.width = -1;
+ psInfo.height = -1;
+ psInfo.pageXString = NULL;
+ psInfo.pageYString = NULL;
+ psInfo.pageX = 72*4.25;
+ psInfo.pageY = 72*5.5;
+ psInfo.pageWidthString = NULL;
+ psInfo.pageHeightString = NULL;
+ psInfo.scale = 1.0;
+ psInfo.pageAnchor = TK_ANCHOR_CENTER;
+ psInfo.rotate = 0;
+ psInfo.fontVar = NULL;
+ psInfo.colorVar = NULL;
+ psInfo.colorMode = NULL;
+ psInfo.colorLevel = 0;
+ psInfo.fileName = NULL;
+ psInfo.channelName = NULL;
+ psInfo.chan = NULL;
+ psInfo.prepass = 0;
+ Tcl_InitHashTable(&psInfo.fontTable, TCL_STRING_KEYS);
+ result = Tk_ConfigureWidget(canvasPtr->interp, canvasPtr->tkwin,
+ configSpecs, argc-2, argv+2, (char *) &psInfo,
+ TK_CONFIG_ARGV_ONLY);
+ if (result != TCL_OK) {
+ goto cleanup;
+ }
+
+ if (psInfo.width == -1) {
+ psInfo.width = Tk_Width(canvasPtr->tkwin);
+ }
+ if (psInfo.height == -1) {
+ psInfo.height = Tk_Height(canvasPtr->tkwin);
+ }
+ psInfo.x2 = psInfo.x + psInfo.width;
+ psInfo.y2 = psInfo.y + psInfo.height;
+
+ if (psInfo.pageXString != NULL) {
+ if (GetPostscriptPoints(canvasPtr->interp, psInfo.pageXString,
+ &psInfo.pageX) != TCL_OK) {
+ goto cleanup;
+ }
+ }
+ if (psInfo.pageYString != NULL) {
+ if (GetPostscriptPoints(canvasPtr->interp, psInfo.pageYString,
+ &psInfo.pageY) != TCL_OK) {
+ goto cleanup;
+ }
+ }
+ if (psInfo.pageWidthString != NULL) {
+ if (GetPostscriptPoints(canvasPtr->interp, psInfo.pageWidthString,
+ &psInfo.scale) != TCL_OK) {
+ goto cleanup;
+ }
+ psInfo.scale /= psInfo.width;
+ } else if (psInfo.pageHeightString != NULL) {
+ if (GetPostscriptPoints(canvasPtr->interp, psInfo.pageHeightString,
+ &psInfo.scale) != TCL_OK) {
+ goto cleanup;
+ }
+ psInfo.scale /= psInfo.height;
+ } else {
+ psInfo.scale = (72.0/25.4)*WidthMMOfScreen(Tk_Screen(canvasPtr->tkwin));
+ psInfo.scale /= WidthOfScreen(Tk_Screen(canvasPtr->tkwin));
+ }
+ switch (psInfo.pageAnchor) {
+ case TK_ANCHOR_NW:
+ case TK_ANCHOR_W:
+ case TK_ANCHOR_SW:
+ deltaX = 0;
+ break;
+ case TK_ANCHOR_N:
+ case TK_ANCHOR_CENTER:
+ case TK_ANCHOR_S:
+ deltaX = -psInfo.width/2;
+ break;
+ case TK_ANCHOR_NE:
+ case TK_ANCHOR_E:
+ case TK_ANCHOR_SE:
+ deltaX = -psInfo.width;
+ break;
+ }
+ switch (psInfo.pageAnchor) {
+ case TK_ANCHOR_NW:
+ case TK_ANCHOR_N:
+ case TK_ANCHOR_NE:
+ deltaY = - psInfo.height;
+ break;
+ case TK_ANCHOR_W:
+ case TK_ANCHOR_CENTER:
+ case TK_ANCHOR_E:
+ deltaY = -psInfo.height/2;
+ break;
+ case TK_ANCHOR_SW:
+ case TK_ANCHOR_S:
+ case TK_ANCHOR_SE:
+ deltaY = 0;
+ break;
+ }
+
+ if (psInfo.colorMode == NULL) {
+ psInfo.colorLevel = 2;
+ } else {
+ length = strlen(psInfo.colorMode);
+ if (strncmp(psInfo.colorMode, "monochrome", length) == 0) {
+ psInfo.colorLevel = 0;
+ } else if (strncmp(psInfo.colorMode, "gray", length) == 0) {
+ psInfo.colorLevel = 1;
+ } else if (strncmp(psInfo.colorMode, "color", length) == 0) {
+ psInfo.colorLevel = 2;
+ } else {
+ Tcl_AppendResult(canvasPtr->interp, "bad color mode \"",
+ psInfo.colorMode, "\": must be monochrome, ",
+ "gray, or color", (char *) NULL);
+ goto cleanup;
+ }
+ }
+
+ if (psInfo.fileName != NULL) {
+
+ /*
+ * Check that -file and -channel are not both specified.
+ */
+
+ if (psInfo.channelName != NULL) {
+ Tcl_AppendResult(canvasPtr->interp, "can't specify both -file",
+ " and -channel", (char *) NULL);
+ result = TCL_ERROR;
+ goto cleanup;
+ }
+
+ /*
+ * Check that we are not in a safe interpreter. If we are, disallow
+ * the -file specification.
+ */
+
+ if (Tcl_IsSafe(canvasPtr->interp)) {
+ Tcl_AppendResult(canvasPtr->interp, "can't specify -file in a",
+ " safe interpreter", (char *) NULL);
+ result = TCL_ERROR;
+ goto cleanup;
+ }
+
+ p = Tcl_TranslateFileName(canvasPtr->interp, psInfo.fileName, &buffer);
+ if (p == NULL) {
+ goto cleanup;
+ }
+ psInfo.chan = Tcl_OpenFileChannel(canvasPtr->interp, p, "w", 0666);
+ Tcl_DStringFree(&buffer);
+ if (psInfo.chan == NULL) {
+ goto cleanup;
+ }
+ }
+
+ if (psInfo.channelName != NULL) {
+ int mode;
+
+ /*
+ * Check that the channel is found in this interpreter and that it
+ * is open for writing.
+ */
+
+ psInfo.chan = Tcl_GetChannel(canvasPtr->interp, psInfo.channelName,
+ &mode);
+ if (psInfo.chan == (Tcl_Channel) NULL) {
+ result = TCL_ERROR;
+ goto cleanup;
+ }
+ if ((mode & TCL_WRITABLE) == 0) {
+ Tcl_AppendResult(canvasPtr->interp, "channel \"",
+ psInfo.channelName, "\" wasn't opened for writing",
+ (char *) NULL);
+ result = TCL_ERROR;
+ goto cleanup;
+ }
+ }
+
+ /*
+ *--------------------------------------------------------
+ * Make a pre-pass over all of the items, generating Postscript
+ * and then throwing it away. The purpose of this pass is just
+ * to collect information about all the fonts in use, so that
+ * we can output font information in the proper form required
+ * by the Document Structuring Conventions.
+ *--------------------------------------------------------
+ */
+
+ psInfo.prepass = 1;
+ for (itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL;
+ itemPtr = itemPtr->nextPtr) {
+ if ((itemPtr->x1 >= psInfo.x2) || (itemPtr->x2 < psInfo.x)
+ || (itemPtr->y1 >= psInfo.y2) || (itemPtr->y2 < psInfo.y)) {
+ continue;
+ }
+ if (itemPtr->typePtr->postscriptProc == NULL) {
+ continue;
+ }
+ result = (*itemPtr->typePtr->postscriptProc)(canvasPtr->interp,
+ (Tk_Canvas) canvasPtr, itemPtr, 1);
+ Tcl_ResetResult(canvasPtr->interp);
+ if (result != TCL_OK) {
+ /*
+ * An error just occurred. Just skip out of this loop.
+ * There's no need to report the error now; it can be
+ * reported later (errors can happen later that don't
+ * happen now, so we still have to check for errors later
+ * anyway).
+ */
+ break;
+ }
+ }
+ psInfo.prepass = 0;
+
+ /*
+ *--------------------------------------------------------
+ * Generate the header and prolog for the Postscript.
+ *--------------------------------------------------------
+ */
+
+ Tcl_AppendResult(canvasPtr->interp, "%!PS-Adobe-3.0 EPSF-3.0\n",
+ "%%Creator: Tk Canvas Widget\n", (char *) NULL);
+#if !(defined(__WIN32__) || defined(MAC_TCL))
+ if (!Tcl_IsSafe(interp)) {
+ struct passwd *pwPtr = getpwuid(getuid());
+ Tcl_AppendResult(canvasPtr->interp, "%%For: ",
+ (pwPtr != NULL) ? pwPtr->pw_gecos : "Unknown", "\n",
+ (char *) NULL);
+ endpwent();
+ }
+#endif /* __WIN32__ || MAC_TCL */
+ Tcl_AppendResult(canvasPtr->interp, "%%Title: Window ",
+ Tk_PathName(canvasPtr->tkwin), "\n", (char *) NULL);
+ time(&now);
+ Tcl_AppendResult(canvasPtr->interp, "%%CreationDate: ",
+ ctime(&now), (char *) NULL);
+ if (!psInfo.rotate) {
+ sprintf(string, "%d %d %d %d",
+ (int) (psInfo.pageX + psInfo.scale*deltaX),
+ (int) (psInfo.pageY + psInfo.scale*deltaY),
+ (int) (psInfo.pageX + psInfo.scale*(deltaX + psInfo.width)
+ + 1.0),
+ (int) (psInfo.pageY + psInfo.scale*(deltaY + psInfo.height)
+ + 1.0));
+ } else {
+ sprintf(string, "%d %d %d %d",
+ (int) (psInfo.pageX - psInfo.scale*(deltaY + psInfo.height)),
+ (int) (psInfo.pageY + psInfo.scale*deltaX),
+ (int) (psInfo.pageX - psInfo.scale*deltaY + 1.0),
+ (int) (psInfo.pageY + psInfo.scale*(deltaX + psInfo.width)
+ + 1.0));
+ }
+ Tcl_AppendResult(canvasPtr->interp, "%%BoundingBox: ", string,
+ "\n", (char *) NULL);
+ Tcl_AppendResult(canvasPtr->interp, "%%Pages: 1\n",
+ "%%DocumentData: Clean7Bit\n", (char *) NULL);
+ Tcl_AppendResult(canvasPtr->interp, "%%Orientation: ",
+ psInfo.rotate ? "Landscape\n" : "Portrait\n", (char *) NULL);
+ p = "%%DocumentNeededResources: font ";
+ for (hPtr = Tcl_FirstHashEntry(&psInfo.fontTable, &search);
+ hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
+ Tcl_AppendResult(canvasPtr->interp, p,
+ Tcl_GetHashKey(&psInfo.fontTable, hPtr),
+ "\n", (char *) NULL);
+ p = "%%+ font ";
+ }
+ Tcl_AppendResult(canvasPtr->interp, "%%EndComments\n\n", (char *) NULL);
+
+ /*
+ * Read a standard prolog file in a native way and insert it into
+ * the Postscript.
+ */
+
+ if (TkGetNativeProlog(canvasPtr->interp) != TCL_OK) {
+ result = TCL_ERROR;
+ goto cleanup;
+ }
+ if (psInfo.chan != NULL) {
+ Tcl_Write(psInfo.chan, canvasPtr->interp->result, -1);
+ Tcl_ResetResult(canvasPtr->interp);
+ }
+
+ /*
+ *-----------------------------------------------------------
+ * Document setup: set the color level and include fonts.
+ *-----------------------------------------------------------
+ */
+
+ sprintf(string, "/CL %d def\n", psInfo.colorLevel);
+ Tcl_AppendResult(canvasPtr->interp, "%%BeginSetup\n", string,
+ (char *) NULL);
+ for (hPtr = Tcl_FirstHashEntry(&psInfo.fontTable, &search);
+ hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
+ Tcl_AppendResult(canvasPtr->interp, "%%IncludeResource: font ",
+ Tcl_GetHashKey(&psInfo.fontTable, hPtr), "\n", (char *) NULL);
+ }
+ Tcl_AppendResult(canvasPtr->interp, "%%EndSetup\n\n", (char *) NULL);
+
+ /*
+ *-----------------------------------------------------------
+ * Page setup: move to page positioning point, rotate if
+ * needed, set scale factor, offset for proper anchor position,
+ * and set clip region.
+ *-----------------------------------------------------------
+ */
+
+ Tcl_AppendResult(canvasPtr->interp, "%%Page: 1 1\n", "save\n",
+ (char *) NULL);
+ sprintf(string, "%.1f %.1f translate\n", psInfo.pageX, psInfo.pageY);
+ Tcl_AppendResult(canvasPtr->interp, string, (char *) NULL);
+ if (psInfo.rotate) {
+ Tcl_AppendResult(canvasPtr->interp, "90 rotate\n", (char *) NULL);
+ }
+ sprintf(string, "%.4g %.4g scale\n", psInfo.scale, psInfo.scale);
+ Tcl_AppendResult(canvasPtr->interp, string, (char *) NULL);
+ sprintf(string, "%d %d translate\n", deltaX - psInfo.x, deltaY);
+ Tcl_AppendResult(canvasPtr->interp, string, (char *) NULL);
+ sprintf(string, "%d %.15g moveto %d %.15g lineto %d %.15g lineto %d %.15g",
+ psInfo.x, Tk_CanvasPsY((Tk_Canvas) canvasPtr, (double) psInfo.y),
+ psInfo.x2, Tk_CanvasPsY((Tk_Canvas) canvasPtr, (double) psInfo.y),
+ psInfo.x2, Tk_CanvasPsY((Tk_Canvas) canvasPtr, (double) psInfo.y2),
+ psInfo.x, Tk_CanvasPsY((Tk_Canvas) canvasPtr, (double) psInfo.y2));
+ Tcl_AppendResult(canvasPtr->interp, string,
+ " lineto closepath clip newpath\n", (char *) NULL);
+ if (psInfo.chan != NULL) {
+ Tcl_Write(psInfo.chan, canvasPtr->interp->result, -1);
+ Tcl_ResetResult(canvasPtr->interp);
+ }
+
+ /*
+ *---------------------------------------------------------------------
+ * Iterate through all the items, having each relevant one draw itself.
+ * Quit if any of the items returns an error.
+ *---------------------------------------------------------------------
+ */
+
+ result = TCL_OK;
+ for (itemPtr = canvasPtr->firstItemPtr; itemPtr != NULL;
+ itemPtr = itemPtr->nextPtr) {
+ if ((itemPtr->x1 >= psInfo.x2) || (itemPtr->x2 < psInfo.x)
+ || (itemPtr->y1 >= psInfo.y2) || (itemPtr->y2 < psInfo.y)) {
+ continue;
+ }
+ if (itemPtr->typePtr->postscriptProc == NULL) {
+ continue;
+ }
+ Tcl_AppendResult(canvasPtr->interp, "gsave\n", (char *) NULL);
+ result = (*itemPtr->typePtr->postscriptProc)(canvasPtr->interp,
+ (Tk_Canvas) canvasPtr, itemPtr, 0);
+ if (result != TCL_OK) {
+ char msg[100];
+
+ sprintf(msg, "\n (generating Postscript for item %d)",
+ itemPtr->id);
+ Tcl_AddErrorInfo(canvasPtr->interp, msg);
+ goto cleanup;
+ }
+ Tcl_AppendResult(canvasPtr->interp, "grestore\n", (char *) NULL);
+ if (psInfo.chan != NULL) {
+ Tcl_Write(psInfo.chan, canvasPtr->interp->result, -1);
+ Tcl_ResetResult(canvasPtr->interp);
+ }
+ }
+
+ /*
+ *---------------------------------------------------------------------
+ * Output page-end information, such as commands to print the page
+ * and document trailer stuff.
+ *---------------------------------------------------------------------
+ */
+
+ Tcl_AppendResult(canvasPtr->interp, "restore showpage\n\n",
+ "%%Trailer\nend\n%%EOF\n", (char *) NULL);
+ if (psInfo.chan != NULL) {
+ Tcl_Write(psInfo.chan, canvasPtr->interp->result, -1);
+ Tcl_ResetResult(canvasPtr->interp);
+ }
+
+ /*
+ * Clean up psInfo to release malloc'ed stuff.
+ */
+
+ cleanup:
+ if (psInfo.pageXString != NULL) {
+ ckfree(psInfo.pageXString);
+ }
+ if (psInfo.pageYString != NULL) {
+ ckfree(psInfo.pageYString);
+ }
+ if (psInfo.pageWidthString != NULL) {
+ ckfree(psInfo.pageWidthString);
+ }
+ if (psInfo.pageHeightString != NULL) {
+ ckfree(psInfo.pageHeightString);
+ }
+ if (psInfo.fontVar != NULL) {
+ ckfree(psInfo.fontVar);
+ }
+ if (psInfo.colorVar != NULL) {
+ ckfree(psInfo.colorVar);
+ }
+ if (psInfo.colorMode != NULL) {
+ ckfree(psInfo.colorMode);
+ }
+ if (psInfo.fileName != NULL) {
+ ckfree(psInfo.fileName);
+ }
+ if ((psInfo.chan != NULL) && (psInfo.channelName == NULL)) {
+ Tcl_Close(canvasPtr->interp, psInfo.chan);
+ }
+ if (psInfo.channelName != NULL) {
+ ckfree(psInfo.channelName);
+ }
+ Tcl_DeleteHashTable(&psInfo.fontTable);
+ canvasPtr->psInfoPtr = oldInfoPtr;
+ return result;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_CanvasPsColor --
+ *
+ * This procedure is called by individual canvas items when
+ * they want to set a color value for output. Given information
+ * about an X color, this procedure will generate Postscript
+ * commands to set up an appropriate color in Postscript.
+ *
+ * Results:
+ * Returns a standard Tcl return value. If an error occurs
+ * then an error message will be left in interp->result.
+ * If no error occurs, then additional Postscript will be
+ * appended to interp->result.
+ *
+ * Side effects:
+ * None.
+ *
+ *--------------------------------------------------------------
+ */
+
+int
+Tk_CanvasPsColor(interp, canvas, colorPtr)
+ Tcl_Interp *interp; /* Interpreter for returning Postscript
+ * or error message. */
+ Tk_Canvas canvas; /* Information about canvas. */
+ XColor *colorPtr; /* Information about color. */
+{
+ TkCanvas *canvasPtr = (TkCanvas *) canvas;
+ TkPostscriptInfo *psInfoPtr = canvasPtr->psInfoPtr;
+ int tmp;
+ double red, green, blue;
+ char string[200];
+
+ if (psInfoPtr->prepass) {
+ return TCL_OK;
+ }
+
+ /*
+ * If there is a color map defined, then look up the color's name
+ * in the map and use the Postscript commands found there, if there
+ * are any.
+ */
+
+ if (psInfoPtr->colorVar != NULL) {
+ char *cmdString;
+
+ cmdString = Tcl_GetVar2(interp, psInfoPtr->colorVar,
+ Tk_NameOfColor(colorPtr), 0);
+ if (cmdString != NULL) {
+ Tcl_AppendResult(interp, cmdString, "\n", (char *) NULL);
+ return TCL_OK;
+ }
+ }
+
+ /*
+ * No color map entry for this color. Grab the color's intensities
+ * and output Postscript commands for them. Special note: X uses
+ * a range of 0-65535 for intensities, but most displays only use
+ * a range of 0-255, which maps to (0, 256, 512, ... 65280) in the
+ * X scale. This means that there's no way to get perfect white,
+ * since the highest intensity is only 65280 out of 65535. To
+ * work around this problem, rescale the X intensity to a 0-255
+ * scale and use that as the basis for the Postscript colors. This
+ * scheme still won't work if the display only uses 4 bits per color,
+ * but most diplays use at least 8 bits.
+ */
+
+ tmp = colorPtr->red;
+ red = ((double) (tmp >> 8))/255.0;
+ tmp = colorPtr->green;
+ green = ((double) (tmp >> 8))/255.0;
+ tmp = colorPtr->blue;
+ blue = ((double) (tmp >> 8))/255.0;
+ sprintf(string, "%.3f %.3f %.3f setrgbcolor AdjustColor\n",
+ red, green, blue);
+ Tcl_AppendResult(interp, string, (char *) NULL);
+ return TCL_OK;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_CanvasPsFont --
+ *
+ * This procedure is called by individual canvas items when
+ * they want to output text. Given information about an X
+ * font, this procedure will generate Postscript commands
+ * to set up an appropriate font in Postscript.
+ *
+ * Results:
+ * Returns a standard Tcl return value. If an error occurs
+ * then an error message will be left in interp->result.
+ * If no error occurs, then additional Postscript will be
+ * appended to the interp->result.
+ *
+ * Side effects:
+ * The Postscript font name is entered into psInfoPtr->fontTable
+ * if it wasn't already there.
+ *
+ *--------------------------------------------------------------
+ */
+
+int
+Tk_CanvasPsFont(interp, canvas, tkfont)
+ Tcl_Interp *interp; /* Interpreter for returning Postscript
+ * or error message. */
+ Tk_Canvas canvas; /* Information about canvas. */
+ Tk_Font tkfont; /* Information about font in which text
+ * is to be printed. */
+{
+ TkCanvas *canvasPtr = (TkCanvas *) canvas;
+ TkPostscriptInfo *psInfoPtr = canvasPtr->psInfoPtr;
+ char *end;
+ char pointString[20];
+ Tcl_DString ds;
+ int i, points;
+
+ /*
+ * First, look up the font's name in the font map, if there is one.
+ * If there is an entry for this font, it consists of a list
+ * containing font name and size. Use this information.
+ */
+
+ Tcl_DStringInit(&ds);
+
+ if (psInfoPtr->fontVar != NULL) {
+ char *list, **argv;
+ int argc;
+ double size;
+ char *name;
+
+ name = Tk_NameOfFont(tkfont);
+ list = Tcl_GetVar2(interp, psInfoPtr->fontVar, name, 0);
+ if (list != NULL) {
+ if (Tcl_SplitList(interp, list, &argc, &argv) != TCL_OK) {
+ badMapEntry:
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "bad font map entry for \"", name,
+ "\": \"", list, "\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ if (argc != 2) {
+ goto badMapEntry;
+ }
+ size = strtod(argv[1], &end);
+ if ((size <= 0) || (*end != 0)) {
+ goto badMapEntry;
+ }
+
+ Tcl_DStringAppend(&ds, argv[0], -1);
+ points = (int) size;
+
+ ckfree((char *) argv);
+ goto findfont;
+ }
+ }
+
+ points = Tk_PostscriptFontName(tkfont, &ds);
+
+ findfont:
+ sprintf(pointString, "%d", points);
+ Tcl_AppendResult(interp, "/", Tcl_DStringValue(&ds), " findfont ",
+ pointString, " scalefont ", (char *) NULL);
+ if (strncasecmp(Tcl_DStringValue(&ds), "Symbol", 7) != 0) {
+ Tcl_AppendResult(interp, "ISOEncode ", (char *) NULL);
+ }
+ Tcl_AppendResult(interp, "setfont\n", (char *) NULL);
+ Tcl_CreateHashEntry(&psInfoPtr->fontTable, Tcl_DStringValue(&ds), &i);
+ Tcl_DStringFree(&ds);
+
+ return TCL_OK;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_CanvasPsBitmap --
+ *
+ * This procedure is called to output the contents of a
+ * sub-region of a bitmap in proper image data format for
+ * Postscript (i.e. data between angle brackets, one bit
+ * per pixel).
+ *
+ * Results:
+ * Returns a standard Tcl return value. If an error occurs
+ * then an error message will be left in interp->result.
+ * If no error occurs, then additional Postscript will be
+ * appended to interp->result.
+ *
+ * Side effects:
+ * None.
+ *
+ *--------------------------------------------------------------
+ */
+
+int
+Tk_CanvasPsBitmap(interp, canvas, bitmap, startX, startY, width, height)
+ Tcl_Interp *interp; /* Interpreter for returning Postscript
+ * or error message. */
+ Tk_Canvas canvas; /* Information about canvas. */
+ Pixmap bitmap; /* Bitmap for which to generate
+ * Postscript. */
+ int startX, startY; /* Coordinates of upper-left corner
+ * of rectangular region to output. */
+ int width, height; /* Height of rectangular region. */
+{
+ TkCanvas *canvasPtr = (TkCanvas *) canvas;
+ TkPostscriptInfo *psInfoPtr = canvasPtr->psInfoPtr;
+ XImage *imagePtr;
+ int charsInLine, x, y, lastX, lastY, value, mask;
+ unsigned int totalWidth, totalHeight;
+ char string[100];
+ Window dummyRoot;
+ int dummyX, dummyY;
+ unsigned dummyBorderwidth, dummyDepth;
+
+ if (psInfoPtr->prepass) {
+ return TCL_OK;
+ }
+
+ /*
+ * The following call should probably be a call to Tk_SizeOfBitmap
+ * instead, but it seems that we are occasionally invoked by custom
+ * item types that create their own bitmaps without registering them
+ * with Tk. XGetGeometry is a bit slower than Tk_SizeOfBitmap, but
+ * it shouldn't matter here.
+ */
+
+ XGetGeometry(Tk_Display(Tk_CanvasTkwin(canvas)), bitmap, &dummyRoot,
+ (int *) &dummyX, (int *) &dummyY, (unsigned int *) &totalWidth,
+ (unsigned int *) &totalHeight, &dummyBorderwidth, &dummyDepth);
+ imagePtr = XGetImage(Tk_Display(canvasPtr->tkwin), bitmap, 0, 0,
+ totalWidth, totalHeight, 1, XYPixmap);
+ Tcl_AppendResult(interp, "<", (char *) NULL);
+ mask = 0x80;
+ value = 0;
+ charsInLine = 0;
+ lastX = startX + width - 1;
+ lastY = startY + height - 1;
+ for (y = lastY; y >= startY; y--) {
+ for (x = startX; x <= lastX; x++) {
+ if (XGetPixel(imagePtr, x, y)) {
+ value |= mask;
+ }
+ mask >>= 1;
+ if (mask == 0) {
+ sprintf(string, "%02x", value);
+ Tcl_AppendResult(interp, string, (char *) NULL);
+ mask = 0x80;
+ value = 0;
+ charsInLine += 2;
+ if (charsInLine >= 60) {
+ Tcl_AppendResult(interp, "\n", (char *) NULL);
+ charsInLine = 0;
+ }
+ }
+ }
+ if (mask != 0x80) {
+ sprintf(string, "%02x", value);
+ Tcl_AppendResult(interp, string, (char *) NULL);
+ mask = 0x80;
+ value = 0;
+ charsInLine += 2;
+ }
+ }
+ Tcl_AppendResult(interp, ">", (char *) NULL);
+ XDestroyImage(imagePtr);
+ return TCL_OK;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_CanvasPsStipple --
+ *
+ * This procedure is called by individual canvas items when
+ * they have created a path that they'd like to be filled with
+ * a stipple pattern. Given information about an X bitmap,
+ * this procedure will generate Postscript commands to fill
+ * the current clip region using a stipple pattern defined by the
+ * bitmap.
+ *
+ * Results:
+ * Returns a standard Tcl return value. If an error occurs
+ * then an error message will be left in interp->result.
+ * If no error occurs, then additional Postscript will be
+ * appended to interp->result.
+ *
+ * Side effects:
+ * None.
+ *
+ *--------------------------------------------------------------
+ */
+
+int
+Tk_CanvasPsStipple(interp, canvas, bitmap)
+ Tcl_Interp *interp; /* Interpreter for returning Postscript
+ * or error message. */
+ Tk_Canvas canvas; /* Information about canvas. */
+ Pixmap bitmap; /* Bitmap to use for stippling. */
+{
+ TkCanvas *canvasPtr = (TkCanvas *) canvas;
+ TkPostscriptInfo *psInfoPtr = canvasPtr->psInfoPtr;
+ int width, height;
+ char string[100];
+ Window dummyRoot;
+ int dummyX, dummyY;
+ unsigned dummyBorderwidth, dummyDepth;
+
+ if (psInfoPtr->prepass) {
+ return TCL_OK;
+ }
+
+ /*
+ * The following call should probably be a call to Tk_SizeOfBitmap
+ * instead, but it seems that we are occasionally invoked by custom
+ * item types that create their own bitmaps without registering them
+ * with Tk. XGetGeometry is a bit slower than Tk_SizeOfBitmap, but
+ * it shouldn't matter here.
+ */
+
+ XGetGeometry(Tk_Display(Tk_CanvasTkwin(canvas)), bitmap, &dummyRoot,
+ (int *) &dummyX, (int *) &dummyY, (unsigned *) &width,
+ (unsigned *) &height, &dummyBorderwidth, &dummyDepth);
+ sprintf(string, "%d %d ", width, height);
+ Tcl_AppendResult(interp, string, (char *) NULL);
+ if (Tk_CanvasPsBitmap(interp, (Tk_Canvas) canvasPtr, bitmap, 0, 0,
+ width, height) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ Tcl_AppendResult(interp, " StippleFill\n", (char *) NULL);
+ return TCL_OK;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_CanvasPsY --
+ *
+ * Given a y-coordinate in canvas coordinates, this procedure
+ * returns a y-coordinate to use for Postscript output.
+ *
+ * Results:
+ * Returns the Postscript coordinate that corresponds to
+ * "y".
+ *
+ * Side effects:
+ * None.
+ *
+ *--------------------------------------------------------------
+ */
+
+double
+Tk_CanvasPsY(canvas, y)
+ Tk_Canvas canvas; /* Token for canvas on whose behalf
+ * Postscript is being generated. */
+ double y; /* Y-coordinate in canvas coords. */
+{
+ TkPostscriptInfo *psInfoPtr = ((TkCanvas *) canvas)->psInfoPtr;
+
+ return psInfoPtr->y2 - y;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_CanvasPsPath --
+ *
+ * Given an array of points for a path, generate Postscript
+ * commands to create the path.
+ *
+ * Results:
+ * Postscript commands get appended to what's in interp->result.
+ *
+ * Side effects:
+ * None.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+Tk_CanvasPsPath(interp, canvas, coordPtr, numPoints)
+ Tcl_Interp *interp; /* Put generated Postscript in this
+ * interpreter's result field. */
+ Tk_Canvas canvas; /* Canvas on whose behalf Postscript
+ * is being generated. */
+ double *coordPtr; /* Pointer to first in array of
+ * 2*numPoints coordinates giving
+ * points for path. */
+ int numPoints; /* Number of points at *coordPtr. */
+{
+ TkPostscriptInfo *psInfoPtr = ((TkCanvas *) canvas)->psInfoPtr;
+ char buffer[200];
+
+ if (psInfoPtr->prepass) {
+ return;
+ }
+ sprintf(buffer, "%.15g %.15g moveto\n", coordPtr[0],
+ Tk_CanvasPsY(canvas, coordPtr[1]));
+ Tcl_AppendResult(interp, buffer, (char *) NULL);
+ for (numPoints--, coordPtr += 2; numPoints > 0;
+ numPoints--, coordPtr += 2) {
+ sprintf(buffer, "%.15g %.15g lineto\n", coordPtr[0],
+ Tk_CanvasPsY(canvas, coordPtr[1]));
+ Tcl_AppendResult(interp, buffer, (char *) NULL);
+ }
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * GetPostscriptPoints --
+ *
+ * Given a string, returns the number of Postscript points
+ * corresponding to that string.
+ *
+ * Results:
+ * The return value is a standard Tcl return result. If
+ * TCL_OK is returned, then everything went well and the
+ * screen distance is stored at *doublePtr; otherwise
+ * TCL_ERROR is returned and an error message is left in
+ * interp->result.
+ *
+ * Side effects:
+ * None.
+ *
+ *--------------------------------------------------------------
+ */
+
+static int
+GetPostscriptPoints(interp, string, doublePtr)
+ Tcl_Interp *interp; /* Use this for error reporting. */
+ char *string; /* String describing a screen distance. */
+ double *doublePtr; /* Place to store converted result. */
+{
+ char *end;
+ double d;
+
+ d = strtod(string, &end);
+ if (end == string) {
+ error:
+ Tcl_AppendResult(interp, "bad distance \"", string,
+ "\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ while ((*end != '\0') && isspace(UCHAR(*end))) {
+ end++;
+ }
+ switch (*end) {
+ case 'c':
+ d *= 72.0/2.54;
+ end++;
+ break;
+ case 'i':
+ d *= 72.0;
+ end++;
+ break;
+ case 'm':
+ d *= 72.0/25.4;
+ end++;
+ break;
+ case 0:
+ break;
+ case 'p':
+ end++;
+ break;
+ default:
+ goto error;
+ }
+ while ((*end != '\0') && isspace(UCHAR(*end))) {
+ end++;
+ }
+ if (*end != 0) {
+ goto error;
+ }
+ *doublePtr = d;
+ return TCL_OK;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * TkGetProlog --
+ *
+ * Locate and load the postscript prolog.
+ *
+ * Results:
+ * A standard Tcl Result. If everything is OK the prolog
+ * will be located in the result string of the interpreter.
+ *
+ * Side effects:
+ * None.
+ *
+ *--------------------------------------------------------------
+ */
+
+int
+TkGetProlog(interp)
+ Tcl_Interp *interp; /* Places the prolog in the result. */
+{
+ char *libDir;
+ Tcl_Channel chan;
+ Tcl_DString buffer, buffer2;
+ char *prologPathParts[2];
+ int bufferSize;
+ char *prologBuffer;
+
+ libDir = Tcl_GetVar(interp, "tk_library", TCL_GLOBAL_ONLY);
+ if (libDir == NULL) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "couldn't find library directory: ",
+ "tk_library variable doesn't exist", (char *) NULL);
+ return TCL_ERROR;
+ }
+ Tcl_TranslateFileName(interp, libDir, &buffer);
+ prologPathParts[0] = buffer.string;
+ prologPathParts[1] = "prolog.ps";
+ Tcl_DStringInit(&buffer2);
+ Tcl_JoinPath(2, prologPathParts, &buffer2);
+ Tcl_DStringFree(&buffer);
+
+ /*
+ * Compute size of file by seeking to the end of the file. This will
+ * overallocate if we are performing CRLF translation.
+ */
+
+ chan = Tcl_OpenFileChannel(NULL, buffer2.string, "r", 0);
+ if (chan == NULL) {
+ /*
+ * We have to set the error message ourselves because the
+ * interp's result need to be reset.
+ */
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "couldn't open \"",
+ buffer2.string, "\": ", Tcl_PosixError(interp), (char *) NULL);
+ Tcl_DStringFree(&buffer2);
+ return TCL_ERROR;
+ }
+
+ bufferSize = Tcl_Seek(chan, 0L, SEEK_END);
+ (void) Tcl_Seek(chan, 0L, SEEK_SET);
+ if (bufferSize < 0) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "error seeking to end of file \"",
+ buffer2.string, "\": ", Tcl_PosixError(interp), (char *) NULL);
+ Tcl_Close(NULL, chan);
+ Tcl_DStringFree(&buffer2);
+ return TCL_ERROR;
+
+ }
+ prologBuffer = (char *) ckalloc((unsigned) bufferSize+1);
+ bufferSize = Tcl_Read(chan, prologBuffer, bufferSize);
+ Tcl_Close(NULL, chan);
+ if (bufferSize < 0) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "error reading file \"", buffer2.string,
+ "\": ", Tcl_PosixError(interp), (char *) NULL);
+ Tcl_DStringFree(&buffer2);
+ return TCL_ERROR;
+ }
+ Tcl_DStringFree(&buffer2);
+ prologBuffer[bufferSize] = 0;
+ Tcl_AppendResult(interp, prologBuffer, (char *) NULL);
+ ckfree(prologBuffer);
+
+ return TCL_OK;
+}