archie/tk4.2/generic/tkCanvPs.c
2024-05-27 16:40:40 +02:00

1191 lines
37 KiB
C
Raw Permalink Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

/*
* 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.50 96/10/02 15:42:41
*/
#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. */
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, "-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 = TCL_ERROR;
Tk_Item *itemPtr;
#define STRING_LENGTH 400
char string[STRING_LENGTH+1], *p;
time_t now;
#if !(defined(__WIN32__) || defined(MAC_TCL))
struct passwd *pwPtr;
#endif /* __WIN32__ || MAC_TCL */
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.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) {
p = Tcl_TranslateFileName(canvasPtr->interp, psInfo.fileName, &buffer);
if (p == NULL) {
goto cleanup;
}
psInfo.chan = Tcl_OpenFileChannel(canvasPtr->interp, p, "w", 0);
Tcl_DStringFree(&buffer);
if (psInfo.chan == NULL) {
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))
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) {
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) {
Tcl_Close(canvasPtr->interp, psInfo.chan);
}
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, fontStructPtr)
Tcl_Interp *interp; /* Interpreter for returning Postscript
* or error message. */
Tk_Canvas canvas; /* Information about canvas. */
XFontStruct *fontStructPtr; /* Information about font in which text
* is to be printed. */
{
TkCanvas *canvasPtr = (TkCanvas *) canvas;
TkPostscriptInfo *psInfoPtr = canvasPtr->psInfoPtr;
char *name, *end, *weightString, *slantString;
#define TOTAL_FIELDS 8
#define FAMILY_FIELD 1
#define WEIGHT_FIELD 2
#define SLANT_FIELD 3
#define SIZE_FIELD 7
char *fieldPtrs[TOTAL_FIELDS];
#define MAX_NAME_SIZE 100
char fontName[MAX_NAME_SIZE+50], pointString[20];
int i, c, weightSize, nameSize, points;
char *p;
name = Tk_NameOfFontStruct(fontStructPtr);
/*
* 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.
*/
if (psInfoPtr->fontVar != NULL) {
char *list, **argv;
int argc;
double size;
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;
}
sprintf(pointString, "%.15g", size);
Tcl_AppendResult(interp, "/", argv[0], " findfont ",
pointString, " scalefont ", (char *) NULL);
if (strncasecmp(argv[0], "Symbol", 7) != 0) {
Tcl_AppendResult(interp, "ISOEncode ", (char *) NULL);
}
Tcl_AppendResult(interp, "setfont\n", (char *) NULL);
Tcl_CreateHashEntry(&psInfoPtr->fontTable, argv[0], &i);
ckfree((char *) argv);
return TCL_OK;
}
}
/*
* Not in the font map. Try to parse the name to get four fields:
* family name, weight, slant, and point size. To do this, split the
* font name up into fields, storing pointers to the first character
* of each field in fieldPtrs.
*/
if (name[0] != '-') {
goto error;
}
for (p = name+1, i = 0; i < TOTAL_FIELDS; i++) {
fieldPtrs[i] = p;
while (*p != '-') {
if (*p == 0) {
goto error;
}
p++;
}
p++;
}
/*
* Use the information from the X font name to make a guess at a
* Postscript font name of the form "<family>-<weight><slant>" where
* <weight> and <slant> may be omitted and if both are omitted then
* the dash is also omitted. Postscript is very picky about font names,
* so there are several heuristics in the code below (e.g. don't
* include a "Roman" slant except for "Times" font, and make sure
* that the first letter of each field is capitalized but no other
* letters are in caps).
*/
nameSize = fieldPtrs[FAMILY_FIELD+1] - 1 - fieldPtrs[FAMILY_FIELD];
if ((nameSize == 0) || (nameSize > MAX_NAME_SIZE)) {
goto error;
}
strncpy(fontName, fieldPtrs[FAMILY_FIELD], (size_t) nameSize);
if (islower(UCHAR(fontName[0]))) {
fontName[0] = toupper(UCHAR(fontName[0]));
}
for (p = fontName+1, i = nameSize-1; i > 0; p++, i--) {
if (isupper(UCHAR(*p))) {
*p = tolower(UCHAR(*p));
}
}
*p = 0;
weightSize = fieldPtrs[WEIGHT_FIELD+1] - 1 - fieldPtrs[WEIGHT_FIELD];
if (weightSize == 0) {
goto error;
}
if (strncasecmp(fieldPtrs[WEIGHT_FIELD], "medium",
(size_t) weightSize) == 0) {
weightString = "";
} else if (strncasecmp(fieldPtrs[WEIGHT_FIELD], "bold",
(size_t) weightSize) == 0) {
weightString = "Bold";
} else {
goto error;
}
if (fieldPtrs[SLANT_FIELD+1] != (fieldPtrs[SLANT_FIELD] + 2)) {
goto error;
}
c = fieldPtrs[SLANT_FIELD][0];
if ((c == 'r') || (c == 'R')) {
slantString = "";
if ((weightString[0] == 0) && (nameSize == 5)
&& (strncmp(fontName, "Times", 5) == 0)) {
slantString = "Roman";
}
} else if ((c == 'i') || (c == 'I')) {
slantString = "Italic";
} else if ((c == 'o') || (c == 'O')) {
slantString = "Oblique";
} else {
goto error;
}
if ((weightString[0] != 0) || (slantString[0] != 0)) {
sprintf(p, "-%s%s", weightString, slantString);
}
points = strtoul(fieldPtrs[SIZE_FIELD], &end, 0);
if (points == 0) {
goto error;
}
sprintf(pointString, "%.15g", ((double) points)/10.0);
Tcl_AppendResult(interp, "/", fontName, " findfont ",
pointString, " scalefont ", (char *) NULL);
if (strcmp(fontName, "Symbol") != 0) {
Tcl_AppendResult(interp, "ISOEncode ", (char *) NULL);
}
Tcl_AppendResult(interp, "setfont\n", (char *) NULL);
Tcl_CreateHashEntry(&psInfoPtr->fontTable, fontName, &i);
return TCL_OK;
error:
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "couldn't translate font name \"",
name, "\" to Postscript", (char *) NULL);
return TCL_ERROR;
}
/*
*--------------------------------------------------------------
*
* 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(interp, buffer2.string, "r", 0);
if (chan == 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_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_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_SetResult(interp, prologBuffer, TCL_DYNAMIC);
return TCL_OK;
}