diff options
| -rw-r--r-- | ChangeLog | 9 | ||||
| -rw-r--r-- | generic/tkCanvPs.c | 28 | ||||
| -rw-r--r-- | generic/tkFont.c | 178 | ||||
| -rw-r--r-- | library/mkpsenc.tcl | 191 |
4 files changed, 213 insertions, 193 deletions
@@ -1,3 +1,12 @@ +2010-01-03 Donal K. Fellows <dkf@users.sf.net> + + * generic/tkFont.c (Tk_TextLayoutToPostscript): Simplified the code to + * generic/tkCanvPs.c (TkCanvPostscriptCmd): generate the preamble + * library/mkpsenc.tcl: for PS generation and + also simplify the code to output text following the observation that + it effectively only produces ASCII anyway, even when it might have the + option to do otherwise in theory. + 2010-01-03 Pat Thoyts <patthoyts@users.sourceforge.net> * library/tearoff.tcl: tearoff menus should be transient and use the diff --git a/generic/tkCanvPs.c b/generic/tkCanvPs.c index d397b9a..33bc89d 100644 --- a/generic/tkCanvPs.c +++ b/generic/tkCanvPs.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tkCanvPs.c,v 1.27 2009/05/01 15:04:03 dkf Exp $ + * RCS: @(#) $Id: tkCanvPs.c,v 1.28 2010/01/03 16:24:13 dkf Exp $ */ #include "tkInt.h" @@ -178,7 +178,7 @@ TkCanvPostscriptCmd( Tcl_HashSearch search; Tcl_HashEntry *hPtr; Tcl_DString buffer; - static const char *psenccmd = "::tk::ensure_psenc_is_loaded"; + Tcl_Obj *preambleObj; 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 @@ -186,14 +186,28 @@ TkCanvPostscriptCmd( * only to stop compiler warnings. */ /* - * Initialize the data structure describing Postscript generation, then - * process all the arguments to fill the data structure in. + * Get the generic preamble. We only ever bother with the ASCII encoding; + * the others just make life too complicated and never actually worked as + * such. */ - result = Tcl_EvalEx(interp, psenccmd, -1, TCL_EVAL_GLOBAL); + result = Tcl_Eval(interp, "::tk::ensure_psenc_is_loaded"); if (result != TCL_OK) { return result; } + preambleObj = Tcl_GetVar2Ex(interp, "::tk::ps_preamble", NULL, + TCL_LEAVE_ERR_MSG); + if (preambleObj == NULL) { + return TCL_ERROR; + } + Tcl_IncrRefCount(preambleObj); + Tcl_ResetResult(interp); + + /* + * Initialize the data structure describing Postscript generation, then + * process all the arguments to fill the data structure in. + */ + oldInfoPtr = canvasPtr->psInfo; canvasPtr->psInfo = (Tk_PostscriptInfo) psInfoPtr; psInfo.x = canvasPtr->xOrigin; @@ -460,8 +474,7 @@ TkCanvPostscriptCmd( * Insert the prolog */ - Tcl_AppendResult(interp, Tcl_GetVar(interp, "::tk::ps_preamable", - TCL_GLOBAL_ONLY), NULL); + Tcl_AppendResult(interp, Tcl_GetString(preambleObj), NULL); if (psInfo.chan != NULL) { Tcl_Write(psInfo.chan, Tcl_GetStringResult(interp), -1); @@ -602,6 +615,7 @@ TkCanvPostscriptCmd( } Tcl_DeleteHashTable(&psInfo.fontTable); canvasPtr->psInfo = (Tk_PostscriptInfo) oldInfoPtr; + Tcl_DecrRefCount(preambleObj); return result; } diff --git a/generic/tkFont.c b/generic/tkFont.c index 749f64b..76895e3 100644 --- a/generic/tkFont.c +++ b/generic/tkFont.c @@ -10,13 +10,13 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tkFont.c,v 1.62 2010/01/02 22:52:38 dkf Exp $ + * RCS: @(#) $Id: tkFont.c,v 1.63 2010/01/03 16:24:13 dkf Exp $ */ #include "tkInt.h" #include "tkFont.h" -#define ROUND16(x) ((short)((x) + 0.5)) +#define ROUND16(x) ((short)((x) + 0.5)) /* * The following structure is used to keep track of all the fonts that exist @@ -417,9 +417,8 @@ TkFontPkgFree( TkFontInfo *fiPtr = mainPtr->fontInfoPtr; Tcl_HashEntry *hPtr, *searchPtr; Tcl_HashSearch search; - int fontsLeft; + int fontsLeft = 0; - fontsLeft = 0; for (searchPtr = Tcl_FirstHashEntry(&fiPtr->fontCache, &search); searchPtr != NULL; searchPtr = Tcl_NextHashEntry(&search)) { @@ -440,7 +439,7 @@ TkFontPkgFree( hPtr = Tcl_FirstHashEntry(&fiPtr->namedTable, &search); while (hPtr != NULL) { - ckfree((char *) Tcl_GetHashValue(hPtr)); + ckfree(Tcl_GetHashValue(hPtr)); hPtr = Tcl_NextHashEntry(&search); } Tcl_DeleteHashTable(&fiPtr->namedTable); @@ -476,7 +475,7 @@ Tk_FontObjCmd( { int index; Tk_Window tkwin = clientData; - TkFontInfo *fiPtr; + TkFontInfo *fiPtr = ((TkWindow *) tkwin)->mainPtr->fontInfoPtr; static const char *const optionStrings[] = { "actual", "configure", "create", "delete", "families", "measure", "metrics", "names", @@ -487,8 +486,6 @@ Tk_FontObjCmd( FONT_FAMILIES, FONT_MEASURE, FONT_METRICS, FONT_NAMES }; - fiPtr = ((TkWindow *) tkwin)->mainPtr->fontInfoPtr; - if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg?"); return TCL_ERROR; @@ -640,13 +637,12 @@ Tk_FontObjCmd( return GetAttributeInfoObj(interp, &nfPtr->fa, objPtr); } case FONT_CREATE: { - int skip, i; + int skip = 3, i; const char *name; char buf[16 + TCL_INTEGER_SPACE]; TkFontAttributes fa; Tcl_HashEntry *namedHashPtr; - skip = 3; if (objc < 3) { name = NULL; } else { @@ -701,9 +697,8 @@ Tk_FontObjCmd( return result; } case FONT_FAMILIES: { - int skip; + int skip = TkGetDisplayOf(interp, objc - 2, objv + 2, &tkwin); - skip = TkGetDisplayOf(interp, objc - 2, objv + 2, &tkwin); if (skip < 0) { return TCL_ERROR; } @@ -726,7 +721,8 @@ Tk_FontObjCmd( } } if (objc - skip != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "font ?-displayof window? text"); + Tcl_WrongNumArgs(interp, 2, objv, + "font ?-displayof window? text"); return TCL_ERROR; } tkfont = Tk_AllocFontFromObj(interp, tkwin, objv[2]); @@ -844,9 +840,8 @@ UpdateDependentFonts( Tcl_HashEntry *cacheHashPtr; Tcl_HashSearch search; TkFont *fontPtr; - NamedFont *nfPtr; + NamedFont *nfPtr = Tcl_GetHashValue(namedHashPtr); - nfPtr = Tcl_GetHashValue(namedHashPtr); if (nfPtr->refCount == 0) { /* * Well nobody's using this named font, so don't have to tell any @@ -948,15 +943,12 @@ TkCreateNamedFont( const char *name, /* Name for the new named font. */ TkFontAttributes *faPtr) /* Attributes for the new named font. */ { - TkFontInfo *fiPtr; + TkFontInfo *fiPtr = ((TkWindow *) tkwin)->mainPtr->fontInfoPtr; Tcl_HashEntry *namedHashPtr; int isNew; NamedFont *nfPtr; - fiPtr = ((TkWindow *) tkwin)->mainPtr->fontInfoPtr; - namedHashPtr = Tcl_CreateHashEntry(&fiPtr->namedTable, name, &isNew); - if (!isNew) { nfPtr = Tcl_GetHashValue(namedHashPtr); if (nfPtr->deletePending == 0) { @@ -1005,12 +997,10 @@ TkDeleteNamedFont( Tk_Window tkwin, /* A window associated with interp. */ const char *name) /* Name for the new named font. */ { - TkFontInfo *fiPtr; + TkFontInfo *fiPtr = ((TkWindow *) tkwin)->mainPtr->fontInfoPtr; NamedFont *nfPtr; Tcl_HashEntry *namedHashPtr; - fiPtr = ((TkWindow *) tkwin)->mainPtr->fontInfoPtr; - namedHashPtr = Tcl_FindHashEntry(&fiPtr->namedTable, name); if (namedHashPtr == NULL) { if (interp) { @@ -1061,7 +1051,7 @@ Tk_GetFont( Tk_Font tkfont; Tcl_Obj *strPtr; - strPtr = Tcl_NewStringObj((char *) string, -1); + strPtr = Tcl_NewStringObj(string, -1); Tcl_IncrRefCount(strPtr); tkfont = Tk_AllocFontFromObj(interp, tkwin, strPtr); Tcl_DecrRefCount(strPtr); @@ -1097,19 +1087,17 @@ Tk_AllocFontFromObj( Tcl_Obj *objPtr) /* Object describing font, as: named font, * native format, or parseable string. */ { - TkFontInfo *fiPtr; + TkFontInfo *fiPtr = ((TkWindow *) tkwin)->mainPtr->fontInfoPtr; Tcl_HashEntry *cacheHashPtr, *namedHashPtr; TkFont *fontPtr, *firstFontPtr, *oldFontPtr; int isNew, descent; NamedFont *nfPtr; - fiPtr = ((TkWindow *) tkwin)->mainPtr->fontInfoPtr; if (objPtr->typePtr != &tkFontObjType) { SetFontFromAny(interp, objPtr); } oldFontPtr = objPtr->internalRep.twoPtrValue.ptr1; - if (oldFontPtr != NULL) { if (oldFontPtr->resourceRefCount == 0) { /* @@ -1277,7 +1265,8 @@ Tk_AllocFontFromObj( Tk_Font Tk_GetFontFromObj( - Tk_Window tkwin, /* The window that the font will be used in. */ + Tk_Window tkwin, /* The window that the font will be used + * in. */ Tcl_Obj *objPtr) /* The object from which to get the font. */ { TkFontInfo *fiPtr = ((TkWindow *) tkwin)->mainPtr->fontInfoPtr; @@ -1289,7 +1278,6 @@ Tk_GetFontFromObj( } fontPtr = objPtr->internalRep.twoPtrValue.ptr1; - if (fontPtr != NULL) { if (fontPtr->resourceRefCount == 0) { /* @@ -1393,9 +1381,8 @@ const char * Tk_NameOfFont( Tk_Font tkfont) /* Font whose name is desired. */ { - TkFont *fontPtr; + TkFont *fontPtr = (TkFont *) tkfont; - fontPtr = (TkFont *) tkfont; return fontPtr->cacheHashPtr->key.string; } @@ -1420,13 +1407,12 @@ void Tk_FreeFont( Tk_Font tkfont) /* Font to be released. */ { - TkFont *fontPtr, *prevPtr; + TkFont *fontPtr = (TkFont *) tkfont, *prevPtr; NamedFont *nfPtr; - if (tkfont == NULL) { + if (fontPtr == NULL) { return; } - fontPtr = (TkFont *) tkfont; fontPtr->resourceRefCount--; if (fontPtr->resourceRefCount > 0) { return; @@ -1591,9 +1577,8 @@ Tk_FontId( Tk_Font tkfont) /* Font that is going to be selected into * GC. */ { - TkFont *fontPtr; + TkFont *fontPtr = (TkFont *) tkfont; - fontPtr = (TkFont *) tkfont; return fontPtr->fid; } @@ -1665,13 +1650,12 @@ Tk_PostscriptFontName( * which the name of the Postscript font that * corresponds to tkfont will be appended. */ { - TkFont *fontPtr; + TkFont *fontPtr = (TkFont *) tkfont; Tk_Uid family, weightString, slantString; char *src, *dest; int upper, len; len = Tcl_DStringLength(dsPtr); - fontPtr = (TkFont *) tkfont; /* * Convert the case-insensitive Tk_Font family name to the case-sensitive @@ -1897,11 +1881,9 @@ TkUnderlineCharsInContext( int lastByte) /* Index of first byte after the last * character. */ { - TkFont *fontPtr; + TkFont *fontPtr = (TkFont *) tkfont; int startX, endX; - fontPtr = (TkFont *) tkfont; - TkpMeasureCharsInContext(tkfont, string, numBytes, 0, firstByte, -1, 0, &startX); TkpMeasureCharsInContext(tkfont, string, numBytes, 0, lastByte, -1, 0, @@ -1960,7 +1942,7 @@ Tk_ComputeTextLayout( int *widthPtr, /* Filled with width of string. */ int *heightPtr) /* Filled with height of string. */ { - TkFont *fontPtr; + TkFont *fontPtr = (TkFont *) tkfont; const char *start, *end, *special; int n, y, bytesThisChunk, maxChunks, curLine, layoutHeight; int baseline, height, curX, newX, maxWidth, *lineLengths; @@ -1971,7 +1953,6 @@ Tk_ComputeTextLayout( Tcl_DStringInit(&lineBuffer); - fontPtr = (TkFont *) tkfont; if ((fontPtr == NULL) || (string == NULL)) { if (widthPtr != NULL) { *widthPtr = 0; @@ -2280,7 +2261,8 @@ void Tk_DrawTextLayout( Display *display, /* Display on which to draw. */ Drawable drawable, /* Window or pixmap in which to draw. */ - GC gc, /* Graphics context to use for drawing text. */ + GC gc, /* Graphics context to use for drawing + * text. */ Tk_TextLayout layout, /* Layout information, from a previous call to * Tk_ComputeTextLayout(). */ int x, int y, /* Upper-left hand corner of rectangle in @@ -2337,7 +2319,8 @@ void TkDrawAngledTextLayout( Display *display, /* Display on which to draw. */ Drawable drawable, /* Window or pixmap in which to draw. */ - GC gc, /* Graphics context to use for drawing text. */ + GC gc, /* Graphics context to use for drawing + * text. */ Tk_TextLayout layout, /* Layout information, from a previous call to * Tk_ComputeTextLayout(). */ int x, int y, /* Upper-left hand corner of rectangle in @@ -2454,7 +2437,8 @@ void TkUnderlineAngledTextLayout( Display *display, /* Display on which to draw. */ Drawable drawable, /* Window or pixmap in which to draw. */ - GC gc, /* Graphics context to use for drawing text. */ + GC gc, /* Graphics context to use for drawing + * text. */ Tk_TextLayout layout, /* Layout information, from a previous call to * Tk_ComputeTextLayout(). */ int x, int y, /* Upper-left hand corner of rectangle in @@ -2552,7 +2536,7 @@ Tk_PointToChar( * to the upper-left corner of the text * layout. */ { - TextLayout *layoutPtr; + TextLayout *layoutPtr = (TextLayout *) layout; LayoutChunk *chunkPtr, *lastPtr; TkFont *fontPtr; int i, n, dummy, baseline, pos, numChars; @@ -2570,7 +2554,6 @@ Tk_PointToChar( * Find which line contains the point. */ - layoutPtr = (TextLayout *) layout; fontPtr = (TkFont *) layoutPtr->tkfont; lastPtr = chunkPtr = layoutPtr->chunks; numChars = 0; @@ -2700,7 +2683,7 @@ Tk_CharBbox( * bounding box for the character specified by * index, if non-NULL. */ { - TextLayout *layoutPtr; + TextLayout *layoutPtr = (TextLayout *) layout; LayoutChunk *chunkPtr; int i, x = 0, w; Tk_Font tkfont; @@ -2711,7 +2694,6 @@ Tk_CharBbox( return 0; } - layoutPtr = (TextLayout *) layout; chunkPtr = layoutPtr->chunks; tkfont = layoutPtr->tkfont; fontPtr = (TkFont *) tkfont; @@ -2812,11 +2794,10 @@ Tk_DistanceToTextLayout( * (in pixels). */ { int i, x1, x2, y1, y2, xDiff, yDiff, dist, minDist, ascent, descent; + TextLayout *layoutPtr = (TextLayout *) layout; LayoutChunk *chunkPtr; - TextLayout *layoutPtr; TkFont *fontPtr; - layoutPtr = (TextLayout *) layout; fontPtr = (TkFont *) layoutPtr->tkfont; ascent = fontPtr->fm.ascent; descent = fontPtr->fm.descent; @@ -2900,7 +2881,7 @@ Tk_IntersectTextLayout( * rectangular area, in pixels. */ { int result, i, x1, y1, x2, y2; - TextLayout *layoutPtr; + TextLayout *layoutPtr = (TextLayout *) layout; LayoutChunk *chunkPtr; TkFont *fontPtr; int left, top, right, bottom; @@ -2912,7 +2893,6 @@ Tk_IntersectTextLayout( * and see if they were all inside or all outside. */ - layoutPtr = (TextLayout *) layout; chunkPtr = layoutPtr->chunks; fontPtr = (TkFont *) layoutPtr->tkfont; @@ -3006,9 +2986,7 @@ static inline int sign( double value) { - if (value < 0.0) return -1; - if (value > 0.0) return 1; - return 0; + return (value < 0.0) ? -1 : (value > 0.0) ? 1 : 0; } static inline int @@ -3149,6 +3127,7 @@ TkIntersectAngledTextLayout( for (i=0 ; i<layoutPtr->numChunks ; i++,chunkPtr++) { double cx[4], cy[4]; + if (chunkPtr->start[0] == '\n') { /* * Newline characters are not counted when computing area @@ -3199,6 +3178,7 @@ TkIntersectAngledTextLayout( for (j=0 ; j<4 ; j++) { int k = (j+1) % 4; + if ( SidesIntersect(rx[j],ry[j], rx[k],ry[k], x1,y1, x2,y1) || SidesIntersect(rx[j],ry[j], rx[k],ry[k], x2,y1, x2,y2) || SidesIntersect(rx[j],ry[j], rx[k],ry[k], x2,y2, x1,y2) || @@ -3258,16 +3238,14 @@ Tk_TextLayoutToPostscript( Tcl_Interp *interp, /* Filled with Postscript code. */ Tk_TextLayout layout) /* The layout to be rendered. */ { + TextLayout *layoutPtr = (TextLayout *) layout; #define MAXUSE 128 - char buf[MAXUSE+30], uindex[5] = "\0\0\0\0", one_char[5]; + char buf[MAXUSE+30]; LayoutChunk *chunkPtr; - int i, j, used, c, baseline, charsize; + int i, j, used, baseline, charsize; Tcl_UniChar ch; - const char *p, *last_p, *glyphname; - TextLayout *layoutPtr; - int bytecount=0; + const char *p, *glyphname; - layoutPtr = (TextLayout *) layout; chunkPtr = layoutPtr->chunks; baseline = chunkPtr->y; used = 0; @@ -3291,54 +3269,66 @@ Tk_TextLayoutToPostscript( p = chunkPtr->start; for (j = 0; j < chunkPtr->numDisplayChars; j++) { /* - * INTL: For now we just treat the characters as binary data - * and display the lower byte. Eventually this should be - * revised to handle international postscript fonts. + * INTL: We only handle symbols that have an encoding as a + * flyph from the standard set defined by Adobe. The rest get + * punted. Eventually this should be revised to handle more + * sophsticiated international postscript fonts. */ - last_p = p; - p += (charsize = Tcl_UtfToUniChar(p,&ch)); - Tcl_UtfToExternal(interp, NULL, last_p, charsize, 0, NULL, - one_char, 4, NULL, &bytecount, NULL); - if (bytecount == 1) { - c = UCHAR(one_char[0]); - /* c = UCHAR( ch & 0xFF) */; - if ((c == '(') || (c == ')') || (c == '\\') || (c < 0x20) - || (c >= UCHAR(0x7f))) { - /* - * Tricky point: the "03" is necessary in the sprintf - * below, so that a full three digits of octal are - * always generated. Without the "03", a number - * following this sequence could be interpreted by - * Postscript as part of this sequence. - */ + charsize = Tcl_UtfToUniChar(p, &ch); + p += charsize; - sprintf(buf + used, "\\%03o", c); - used += 4; - } else { - buf[used++] = c; - } + if ((ch == '(') || (ch == ')') || (ch == '\\') + || (ch < 0x20)) { + /* + * Tricky point: the "03" is necessary in the sprintf + * below, so that a full three digits of octal are always + * generated. Without the "03", a number following this + * sequence could be interpreted by Postscript as part of + * this sequence. + */ + + sprintf(buf + used, "\\%03o", ch); + used += 4; + } else if (ch <= 0x7f) { + /* + * Normal ASCII character. + */ + + buf[used++] = ch; } else { + char uindex[5]; + /* - * This character doesn't belong to system character set. - * So, we must use full glyph name. + * This character doesn't belong to the ASCII character + * set, so we use the full glyph name. */ sprintf(uindex, "%04X", ch); /* endianness? */ - glyphname = Tcl_GetVar2(interp,"::tk::psglyphs",uindex,0); + glyphname = Tcl_GetVar2(interp, "::tk::psglyphs", uindex, + 0); if (glyphname) { - if (used > 0 && buf [used-1] == '(') { - --used; + if (used > 0 && buf[used-1] == '(') { + used--; } else { buf[used++] = ')'; } buf[used++] = '/'; - while ((*glyphname) && (used < (MAXUSE+27))) { - buf[used++] = *glyphname++ ; + while ((*glyphname) && (used < MAXUSE+27)) { + buf[used++] = *glyphname++; } buf[used++] = '('; - } + } else { + /* + * No known mapping for the character into the space + * of PostScript glyphs. Ignore it. :-( + */ +#ifdef TK_DEBUG_POSTSCRIPT_OUTPUT + fprintf(stderr, "Warning: no mapping to PostScript " + "glyphs for \\u%04x\n", ch); +#endif + } } if (used >= MAXUSE) { buf[used] = '\0'; diff --git a/library/mkpsenc.tcl b/library/mkpsenc.tcl index 07c5217..e3c5f46 100644 --- a/library/mkpsenc.tcl +++ b/library/mkpsenc.tcl @@ -3,17 +3,19 @@ # This file generates the postscript prolog used by Tk. namespace eval ::tk { - # Creates Postscript encoding vector for given encoding + # Creates Postscript encoding vector for ISO-8859-1 (could theoretically + # handle any 8-bit encoding, but Tk never generates characters outside + # ASCII). # - proc CreatePostscriptEncoding {encoding} { + proc CreatePostscriptEncoding {} { variable psglyphs # Now check for known. Even if it is known, it can be other than we # need. GhostScript seems to be happy with such approach - set result "/CurrentEncoding \[\n" + set result "\[\n" for {set i 0} {$i<256} {incr i 8} { for {set j 0} {$j<8} {incr j} { - set enc [encoding convertfrom $encoding \ - [format %c [expr {$i+$j}]]] + set enc [encoding convertfrom "iso8859-1" \ + [format %c [expr {$i+$j}]]] catch { set hexcode {} set hexcode [format %04X [scan $enc %c]] @@ -26,7 +28,7 @@ namespace eval ::tk { } append result "\n" } - append result "\] def\n" + append result "\]" return $result } @@ -1088,64 +1090,69 @@ namespace eval ::tk { FB4B afii57700 } - proc ps_literal {string} { - variable ps_preamable ;# sic - foreach line [split $string \n] { - set line [string trim $line] - if {$line eq ""} continue - append ps_preamable $line \n + variable ps_preamble {} + + namespace eval ps { + namespace ensemble create + namespace export {[a-z]*} + proc literal {string} { + upvar 0 ::tk::ps_preamble preamble + foreach line [split $string \n] { + set line [string trim $line] + if {$line eq ""} continue + append preamble $line \n + } + return } - return - } - proc ps_variable {name value} { - variable ps_preamable - append ps_preamable "/$name $value def\n" - return - } - proc ps_function {name body} { - variable ps_preamable - append ps_preamable "/$name \{" - foreach line [split $body \n] { - set line [string trim $line] - # Strip blank lines and comments from the bodies of functions - if {$line eq "" } continue - if {[string match {[%#]*} $line]} continue - append ps_preamable $line " " + proc variable {name value} { + upvar 0 ::tk::ps_preamble preamble + append preamble "/$name $value def\n" + return + } + proc function {name body} { + upvar 0 ::tk::ps_preamble preamble + append preamble "/$name \{" + foreach line [split $body \n] { + set line [string trim $line] + # Strip blank lines and comments from the bodies of functions + if {$line eq "" } continue + if {[string match {[%#]*} $line]} continue + append preamble $line " " + } + append preamble "\} bind def\n" + return } - append ps_preamable "\} bind def\n" - return } - # Precalculate entire prolog when this file is loaded (to speed things up) - ps_literal { + ps literal { %%BeginProlog % This is a standard prolog for Postscript generated by Tk's canvas % widget. - % RCS: @(#) $Id: mkpsenc.tcl,v 1.6 2009/05/01 15:21:02 dkf Exp $ + % RCS: @(#) $Id: mkpsenc.tcl,v 1.7 2010/01/03 16:24:13 dkf Exp $ } - ps_literal [CreatePostscriptEncoding [encoding system]] - ps_literal {50 dict begin} + ps variable CurrentEncoding [CreatePostscriptEncoding] + ps literal {50 dict begin} # The definitions below just define all of the variables used in any of - # the procedures here. This is needed for obscure reasons explained on p. - # 716 of the Postscript manual (Section H.2.7, "Initializing Variables," - # in the section on Encapsulated Postscript). - ps_variable baseline 0 - ps_variable stipimage 0 - ps_variable height 0 - ps_variable justify 0 - ps_variable lineLength 0 - ps_variable spacing 0 - ps_variable stipple 0 - ps_variable strings 0 - ps_variable xoffset 0 - ps_variable yoffset 0 - ps_variable tmpstip null - ps_variable baselineSampler "( TXygqPZ)" + # the procedures here. This is needed for obscure reasons explained on + # p. 716 of the Postscript manual (Section H.2.7, "Initializing + # Variables," in the section on Encapsulated Postscript). + ps variable baseline 0 + ps variable stipimage 0 + ps variable height 0 + ps variable justify 0 + ps variable lineLength 0 + ps variable spacing 0 + ps variable stipple 0 + ps variable strings 0 + ps variable xoffset 0 + ps variable yoffset 0 + ps variable tmpstip null + ps variable baselineSampler "( TXygqPZ)" # Put an extra-tall character in; done this way to avoid encoding trouble - ps_literal {baselineSampler 0 196 put} + ps literal {baselineSampler 0 196 put} - ps_function cstringshow { + ps function cstringshow { { dup type /stringtype eq { show } { glyphshow } @@ -1153,12 +1160,13 @@ namespace eval ::tk { } forall } - ps_function cstringwidth { + ps function cstringwidth { 0 exch 0 exch { dup type /stringtype eq { stringwidth } { - currentfont /Encoding get exch 1 exch put (\001) stringwidth + currentfont /Encoding get exch 1 exch put (\001) + stringwidth } ifelse exch 3 1 roll add 3 1 roll add exch @@ -1166,11 +1174,12 @@ namespace eval ::tk { } # font ISOEncode font + # # This procedure changes the encoding of a font from the default # Postscript encoding to current system encoding. It's typically invoked # just before invoking "setfont". The body of this procedure comes from # Section 5.6.1 of the Postscript book. - ps_function ISOEncode { + ps function ISOEncode { dup length dict begin {1 index /FID ne {def} {pop pop} ifelse} forall /Encoding CurrentEncoding def @@ -1188,7 +1197,7 @@ namespace eval ::tk { # assumption of stroking. It's a bit tricky because some Postscript # interpreters get errors during strokepath for dashed lines. If this # happens then turn off dashes and try again. - ps_function StrokeClip { + ps function StrokeClip { {strokepath} stopped { (This Postscript printer gets limitcheck overflows when) = (stippling dashed lines; lines will be printed solid instead.) = @@ -1200,14 +1209,15 @@ namespace eval ::tk { # # The procedure below is used for stippling. Given the optimal size of a # dot in a stipple pattern in the current user coordinate system, compute - # the closest size that is an exact multiple of the device's pixel size. - # This allows stipple patterns to be displayed without aliasing effects. - ps_function EvenPixels { + # the closest size that is an exact multiple of the device's pixel + # size. This allows stipple patterns to be displayed without aliasing + # effects. + ps function EvenPixels { % Compute exact number of device pixels per stipple dot. dup 0 matrix currentmatrix dtransform dup mul exch dup mul add sqrt - % Round to an integer, make sure the number is at least 1, and compute - % user coord distance corresponding to this. + % Round to an integer, make sure the number is at least 1, and + % compute user coord distance corresponding to this. dup round dup 1 lt {pop 1} if exch div mul } @@ -1220,7 +1230,7 @@ namespace eval ::tk { # "width" and "height" give its dimensions. Each stipple dot is assumed to # be about one unit across in the current user coordinate system. This # procedure trashes the graphics state. - ps_function StippleFill { + ps function StippleFill { % The following code is needed to work around a NeWSprint bug. /tmpstip 1 index def % Change the scaling so that one user unit in user coordinates @@ -1256,7 +1266,7 @@ namespace eval ::tk { # # Given a color value already set for output by the caller, adjusts that # value to a grayscale or mono value if requested by the CL variable. - ps_function AdjustColor { + ps function AdjustColor { CL 2 lt { currentgray CL 0 eq { @@ -1273,21 +1283,21 @@ namespace eval ::tk { # arguments must be on the stack: # # x, y - Coordinates at which to draw text. - # strings - An array of strings, one for each line of the text item, in + # strings - An array of strings, one for each line of the text item, in # order from top to bottom. # spacing - Spacing between lines. - # xoffset - Horizontal offset for text bbox relative to x and y: 0 for + # xoffset - Horizontal offset for text bbox relative to x and y: 0 for # nw/w/sw anchor, -0.5 for n/center/s, and -1.0 for ne/e/se. - # yoffset - Vertical offset for text bbox relative to x and y: 0 for + # yoffset - Vertical offset for text bbox relative to x and y: 0 for # nw/n/ne anchor, +0.5 for w/center/e, and +1.0 for sw/s/se. - # justify - 0 for left justification, 0.5 for center, 1 for right justify. - # stipple - Boolean value indicating whether or not text is to be drawn in - # stippled fashion. If text is stippled, procedure StippleText + # justify - 0 for left justification, 0.5 for center, 1 for right justify. + # stipple - Boolean value indicating whether or not text is to be drawn in + # stippled fashion. If text is stippled, function StippleText # must have been defined to call StippleFill in the right way. # # Also, when this procedure is invoked, the color and font must already # have been set for the text. - ps_function DrawText { + ps function DrawText { /stipple exch def /justify exch def /yoffset exch def @@ -1306,16 +1316,17 @@ namespace eval ::tk { pathbbox dup /baseline exch def exch pop exch sub /height exch def pop newpath - % Translate and rotate coordinates first so that the origin is at the - % upper-left corner of the text's bounding box. Remember that angle - % for rotating, and x and y for positioning are still on the stack. + % Translate and rotate coordinates first so that the origin is at + % the upper-left corner of the text's bounding box. Remember that + % angle for rotating, and x and y for positioning are still on the + % stack. translate rotate lineLength xoffset mul strings length 1 sub spacing mul height add yoffset mul translate - % Now use the baseline and justification information to translate so - % that the origin is at the baseline and positioning point for the - % first line of text. + % Now use the baseline and justification information to translate + % so that the origin is at the baseline and positioning point for + % the first line of text. justify lineLength mul baseline neg translate % Iterate over each of the lines to output it. For each line, % compute its width again so it can be properly justified, then @@ -1325,10 +1336,10 @@ namespace eval ::tk { justify neg mul 0 moveto stipple { % The text is stippled, so turn it into a path and print - % by calling StippledText, which in turn calls StippleFill. - % Unfortunately, many Postscript interpreters will get - % overflow errors if we try to do the whole string at - % once, so do it a character at a time. + % by calling StippledText, which in turn calls + % StippleFill. Unfortunately, many Postscript interpreters + % will get overflow errors if we try to do the whole + % string at once, so do it a character at a time. gsave /char (X) def { @@ -1360,13 +1371,13 @@ namespace eval ::tk { } forall } - # Define the "TkPhoto" function variants, which are modified versions of - # the original "transparentimage" function posted by ian@five-d.com (Ian - # Kemmish) to comp.lang.postscript. For a monochrome colorLevel this is a - # slightly different version that uses the imagemask command instead of - # image. + # Define the "TkPhoto" function variants, which are modified versions + # of the original "transparentimage" function posted by ian@five-d.com + # (Ian Kemmish) to comp.lang.postscript. For a monochrome colorLevel + # this is a slightly different version that uses the imagemask command + # instead of image. - ps_function TkPhotoColor { + ps function TkPhotoColor { gsave 32 dict begin /tinteger exch def @@ -1433,7 +1444,7 @@ namespace eval ::tk { end grestore } - ps_function TkPhotoMono { + ps function TkPhotoMono { gsave 32 dict begin /dummyInteger exch def @@ -1471,11 +1482,7 @@ namespace eval ::tk { grestore } - ps_literal %%EndProlog - - rename ps_function {} - rename ps_literal {} - rename ps_variable {} + ps literal %%EndProlog } proc tk::ensure_psenc_is_loaded {} { |