summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl0/lib/qd.pl
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl0/lib/qd.pl')
-rwxr-xr-xMaster/tlpkg/tlperl0/lib/qd.pl898
1 files changed, 898 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl0/lib/qd.pl b/Master/tlpkg/tlperl0/lib/qd.pl
new file mode 100755
index 00000000000..aafc8777a20
--- /dev/null
+++ b/Master/tlpkg/tlperl0/lib/qd.pl
@@ -0,0 +1,898 @@
+#!/usr/local/bin/perl
+
+# $Id: qd.pl,v 1.1.1.1 2001/12/06 23:25:48 lstein Exp $
+
+# This is a package of routines that let you create Macintosh
+# PICT files from within perl. It implements a subset of Quickdraw
+# drawing commands, primarily those related to line drawing, rectangles,
+# ovals, polygons, and text. Flagrantly absent are: regions and the
+# snazzy color transfer modes. Regions are absent because they were
+# more trouble than I had time for, and the transfer modes because I
+# never use them. (The latter shouldn't be too hard to add.) Also
+# missing are the pixmap commands. If you want to do pixmaps, you
+# should be using the ppm utilities.
+
+# A QUICK TUTORIAL ON QUICKDRAW
+#
+# Quickdraw is not Postscript. You cannot write routines in it or get
+# (any useful) information out of it. Quickdraw pictures are a series of
+# drawing commands, concatenated together in a binary format.
+#
+# A Macintosh picture consists of a header describing the size of the
+# picture and its bounding rectangle, followed by a series of drawing
+# commands, followed by a termination code. This perl library is
+# modeled closely on the way that you would draw a picture on the Mac.
+# First you open the picture with the &qd'OpenPicture() command. This
+# initializes some data structures. Then you call a series of drawing
+# subroutines, such as &qd'TextFont(), &qd'MoveTo(), &qd'DrawString().
+# These routines append their data to the growing (but still private)
+# picture. You then close the picture with &qd'ClosePicture. This
+# returns a scalar variable containing the binary picture data.
+
+# RECTANGLES
+#
+# To open a picture you need to define a rectangle that will serve as
+# its frame and will define its drawing area. The rectangle is (of
+# course) a binary structure. The following utilities allow you to
+# create and manipulate rectangles:
+#
+# &qd'SetRect(*myRect,left,top,right,bottom); # Set the sides of $myRect
+# &qd'OffsetRect(*myRect,deltaH,deltaV); # Shift the rectangle as indicated
+# &qd'InsetRect(*myRect,deltaH,deltaV); # Shrink rectangle by size indicated
+
+
+# OPENING A PICTURE
+#
+# Pass a previously-defined rectangle to the routine OpenPicture. Only one picture
+# may be open at a time. The rectangle defines the drawing area in pixels.
+# A printer page is 8.5 x 11 inches, at 72 pixels per inch = 612 x 792 pixels.
+#
+# &qd'OpenPicture($myRect);
+#
+# You will next very likely want to set the clipping rectangle to the same rectangle
+# you used to open the picture with. Clipping rectangles limit quickdraw's drawing
+# to the area within the rectangle. Even if you don't use clipping, however, it's a
+# good idea to define the rectangle because some drawing programs behave eratically
+# when displaying unclipped pictures.
+#
+# You then issue drawing commands. When you're done you can get the picture data with
+# something like $pictData = &qd'ClosePicture;
+
+#
+# SETTING THE FOREGROUND AND BACKGROUND COLORS
+#
+# The foreground color is the color of the ink when a "frame" or "paint" command
+# is given. The background color is the color of the erased area when an "erase"
+# command is given. The defaults are black and white. The colors can be changed
+# in either of two ways:
+#
+# 1. The "old" 8-color system: black, white, red, green, blue, cyan, magenta, yellow
+# Call the routines &qd'FgColor() and &qd'BgColor() with one of the constants
+# $qd'REDCOLOR,$qd'GREENCOLOR, etc. This gives you a limited number of highly
+# satured colors.
+#
+# 2. The new 24-bit color system. Call the routines &qd'RGBForeColor() and
+# &qd'RGBBackColor(), passing the routines the red, green and blue components
+# of the color. These components are two-byte unsigned integers, so you can choose
+# any value between 0x000 and 0xFFFF. Higher is darker, so:
+# (0x0000,0x0000,0x0000) = BLACK
+# (0xFFFFF,0xFFFF,0xFFFF) = WHITE
+# (0xFFFFF,0x0000,0x0000) = PURE RED
+# etc.
+
+
+# SETTING THE PATTERN
+#
+# Like colors, the drawing commands use the current pattern, a 32 row x 32 column
+# bit array that defines the pattern of the "ink".
+# The default pattern is $qd'BLACK, which is solid black. The only
+# other pattern I've defined is $qd'GRAY, which is a 50% checkerboard. You
+# might want to define others.
+#
+# The current pattern is set using &qd'PenPat($myPattern).
+
+
+# LINE DRAWING
+#
+# Quickdraw has the concept of the "current point" of the pen. Generally
+# you move the pen to a point and then start drawing. The next time you draw,
+# the pen will be wherever the last drawing command left it. In addition, the
+# pen has a width, a pattern and a color. In the below descriptions,
+# h=horizontal, v=vertical
+#
+# &qd'MoveTo(h,v) # Move to indicated coordinates (0,0 is upper left of picture)
+# &qd'LineTo(h,v) # Draw from current position to indicated position
+# &qd'Line(dh,dv) # Draw a line dh pixels horizontally, dv pixels vertically,
+# starting at current position
+# &qd'PenSize(h,v) # Set the size of the pen to h pixels wide, v pixels high
+
+
+# PEN SCALING
+#
+# The original quickdraw was incapable of drawing at higher than the screen resolution,
+# so even if the PenSize is set to (1,1) the lines will appear chunky when printed out
+# on the laserwriter (which has four times the resolution of the screen). Call
+# &qd'Scale(1,4) to fix this problem by shrinking the pen down to a quarter of its
+# (1,1) size.
+#
+# &qd'Scale(numerator,denominator) # Scale the pen by the fraction numerator/denominator
+
+
+# TEXT
+#
+# &qd'TextFont(fontCode) # Set the current font to indicated code. Currently
+# defined fonts are $qd'TIMES, $qd'NEWCENTURYSCHOOLBK,
+# $qd'SYMBOL, $qd'HELVETICA, and $qd'COURIER.
+#
+# &qd'TextSize(size) # Set the current font size (in points). 12 point is typical
+#
+# &qd'TextFace(attributes) # Set one or more font style attributes. Currently defined
+# are $qd'PLAIN, $qd'BOLD, $qd'ITALIC, $qd'UNDERLINE, and
+# can be used in combination:
+# &qd'TextFace($qd'BOLD + $qd'ITALIC);
+#
+# &qd'DrawString(string) # Draw the indicated text. It will be drawn from the
+# current pen location. Word wrap is NOT supported.
+# Rotated text is NOT supported.
+#
+# &qd'TextWidth(string) # This will return an approximate width for the string
+# when it is printed in the current size, font and face.
+# Unfortunately, since perl has no access to the Macintosh
+# font description tables, the number returned by this
+# routine will be wildly inaccurate at best.
+# However, if you have X11R5 bdf fonts installed, we look
+# in the directory $qd'X11FONTS in order to find a bdf metrics
+# font to use. This will give you extremely accurate measurements.
+# Please set this variable to whatever is correct for your local
+# system. To add more fonts, put them in your bdf font directory
+# and update the %qd'font_metric_files array at the bottom of this
+# file. It maps a key consisting of the Quickdraw font number,
+# font size, and font style (0 for plain, 1 for italic, 2 for bold,
+# 3 for both) to the appropriate bdf file.
+
+# RECTANGLES
+#
+# Draw rectangles using the routines:
+# &qd'FrameRect($myRect); # Draw wire-frame rectangle
+# &qd'PaintRect($myRect); # Fill rectangle with current foreground
+# color and pattern
+# &qd'EraseRect($myRect); # Erase the rectangle (fill with bg color)
+# &qd'InvertRect($myRect); # Invert black and white in rectangle
+
+
+# OVALS
+#
+# Draw ovals using the routines:
+# &qd'FrameOval($myRect); # Draw wire-frame oval
+# &qd'PaintOval($myRect); # Fill oval with current foreground
+# color and pattern
+# &qd'EraseOval($myRect); # Erase the oval (fill with bg color)
+# &qd'InvertOval($myRect); # Invert black and white in oval
+# &qd'FillOval($myRect,$pat); # Fill with specified pattern
+#
+
+# ROUND RECTANGLES
+#
+# Draw round-cornered rectangles with these routines. They each take an oval radius
+# to determine the amount of curvature. Values of 10-20 are typical.
+# &qd'FrameRoundRect($myRect,$ovalWidth,$ovalHeight); # wire-frame outline
+# &qd'PaintRoundRect($myRect,$ovalWidth,$ovalHeight); # fill with current foreground
+# &qd'EraseRoundRect($myRect,$ovalWidth,$ovalHeight); # erase
+# &qd'InvertRoundRect($myRect,$ovalWidth,$ovalHeight);# invert
+# &qd'FillRoundRect($myRect,$ovalWidth,$ovalHeight,$pat); # fill with specified pattern
+
+# ARCS
+# Draw an arc subtending the specified rectangle. Angles are in degrees and
+# start pointing northward and get larger clockwise:
+# e.g. PaintArc($r,45,90) gives you a pie wedge from 2 o'clock to 5 o'clock
+# &qd'FrameArc($rect,$startAngle,$arcAngle); # wire-frame the arc
+# &qd'PaintArc($rect,$startAngle,$arcAngle); # fill with current foreground
+# &qd'EraseArc($rect,$startAngle,$arcAngle); # erase arc
+# &qd'InvertArc($rect,$startAngle,$arcAngle); # flip white and black
+# &qd'FillArc($rect,,$startAngle,$arcAngle,$pat); # fill with specified pattern
+
+# POLYGONS
+# Calling OpenPoly returns the name of a variable in which a growing
+# polygon structure will be stored. Once a polygon is opened, all drawing
+# commands cease to have an effect on the picture. Instead, all MoveTo,
+# LineTo and Line commands accumulate polygon vertices into the data structure.
+# Call ClosePoly to stop recording drawing commands. The polygon can now
+# be moved, scaled, drawn, filled and erased as many times as wished. Call
+# KillPoly to release the memory taken up by the polygon
+# $polygon = &qd'OpenPoly; # begin recording drawing commands
+# &qd'ClosePoly($polygon); # stop recording drawing commands
+# &qd'FramePoly($polygon); # wire-frame the polygon
+# &qd'PaintPoly($polygon); # fill with current foreground
+# &qd'ErasePoly($polygon); # erase polygon
+# &qd'FillPoly($polygon,$pat); # fill polygon with pattern
+# &qd'OffsetPoly($polygon,$dh,$dv); # translate poly by dh horizontally, dv vertically
+# &qd'MapPoly($polygon,$srcRect,$destRect); # map polygon from coordinate system defined by
+ # source rectangle to that defined by destination
+ # rectangle (moving or resizing it as needed)
+
+# PRINTING OUT THE PICTURE IN A FORM THAT THE MACINTOSH CAN READ
+#
+# The Mac expects its picture files to begin with 512 bytes of "application specific"
+# data. By default the picture data that you get will be proceeded by 512 bytes of
+# 0's. If you want something else, or if you just want the picture data, set the
+# package variable $qd'PICTHEADER to whatever you desire before calling ClosePicture.
+# In order for the picture data to be readable on the Macintosh, the file type must
+# be set to 'PICT'. A number of UNIX utilities, including mcvert and BinHex allow
+# you to do this. Or you can use the picttoppm utility (part of the netppm suite of
+# graphics tools) to translate the file into any format you desire.
+
+# A WORKING EXAMPLE
+# require "qd.pl";
+# &qd'SetRect(*myRect,0,0,500,500); # Define a 500 pixel square
+# &qd'OpenPicture($myRect); # Begin defining the picture
+# &qd'ClipRect($myRect); # Always a good idea
+# &qd'MoveTo(5,5); # Move the pen to a starting point
+# &qd'LineTo(400,400); # A diagonal line
+# &qd'TextFont($qd'COURIER); # Set the font
+# &qd'MoveTo(50,20); # Move the pen to a new starting point
+# &qd'DrawString("Hello there!"); # Friendly greeting
+# &qd'SetRect(*myRect,80,80,250,250); # New rectangle
+# &qd'RGBForeColor(0x0000,0x0000,0xFFFF); # Set the color to blue
+# &qd'PaintRect($myRect); # Fill rectangle with that color
+# $data = &qd'ClosePicture; # Close picture and retrieve data
+
+# # Pipe through binhex, setting the creator type to JVWR for JPEG Viewer
+# # Note: BinHex is available at <ftp://genome.wi.mit.edu/software/util/BinHex>
+# open (BINHEX "| BinHex -t PICT -c JVWR -n 'An Example'");
+# print BINHEX $data;
+# close BINHEX;
+
+# # Turn it into a GIF file, using the ppm utilities
+# open (GIF, "| picttoppm | ppmtogif -transparent white");
+# print GIF $data;
+# close GIF;
+
+
+# MISCELLANEOUS NOTES
+# NOTE: For some reason the various FILL routines don't work as
+# advertised. They are simulated by a PnPat followed by a paint
+
+# --------------------------------------------------------------------
+# Quickdraw-like functions -- now using PICT2
+# --------------------------------------------------------------------
+{
+package qd;
+
+# Directory to look in to find font metric definitions -- change this
+# for your installation
+$X11FONTS = '/usr/local/X11R5/X11/fonts/bdf';
+
+# Apple quickdraw constants
+$TIMES = 20;
+$HELVETICA = 21;
+$COURIER = 22;
+$SYMBOL = 23;
+$NEWCENTURYSCHOOLBK = 34;
+
+$PLAIN = 0;
+$BOLD = 1;
+$ITALIC = 2;
+$UNDERLINE = 4;
+
+# Some minimal patterns -- define your own if you like
+$GRAY = pack ('n4',0xAA55,0xAA55,0xAA55,0xAA55);
+$DKGRAY = pack ('n4',0xDD77,0xDD77,0xDD77,0xDD77);
+$LTGRAY = pack ('n4',0x8822,0x8822,0x8822,0x8822);
+$WHITE = pack('n4',0x0000,0x0000,0x0000,0x0000);
+$BLACK = pack ('n4',0xFFFF,0xFFFF,0xFFFF,0xFFFF);
+
+# absolute colors to be used with FgColor/BgColor
+# (for better control, use RGBFgColor/RGBBgColor)
+$BLACKCOLOR = 33;
+$WHITECOLOR = 30;
+$REDCOLOR = 209;
+$GREENCOLOR = 329;
+$BLUECOLOR = 389;
+$CYANCOLOR = 269;
+$MAGENTACOLOR = 149;
+$YELLOWCOLOR = 89;
+
+# This defines the header used at the beginning of PICT files:
+$PICTHEADER = "\0" x 512;
+
+# These are phoney font metrics which we use when no font metrics files are
+# around to help us out.
+$fudgefactor = 0.55;
+$ITALICEXTRA = 0.05;
+$BOLDEXTRA = 0.08;
+
+# Initial starting values
+$textFont = $HELVETICA;
+$textSize = 12;
+$textFace = $PLAIN;
+$rgbfgcolor = pack('n*',0xFFFF,0xFFFF,0xFFFF);
+$rgbbgcolor = pack('n*',0,0,0);
+$fgcolor = $BLACKCOLOR;
+$bgcolor = $WHITECOLOR;
+$polySave = undef;
+
+$_PnPattern = $BLACK;
+$_polyName = "polygon000";
+
+sub OpenPicture { # begin a picture
+ local($rect) = @_;
+ $currH = $currV = 0; # current pen position
+ $pict = $PICTHEADER; # the header
+ $pict .= pack('n',0); # size int (placeholder)
+ $pict .= $rect; # pict frame
+ $pict .= pack('n',0x0011); # Type 2 picture
+ $pict .= pack('n',0x02FF); # version number
+ $pict .= pack('nC24',0x0C00,0); # reserved header opcode + 24 bytes of reserved data
+ # initialize the font and size
+ &TextFont($textFont);
+ &TextSize($textSize);
+ &TextFace($textFace);
+}
+
+sub ClosePicture { # close pict and return it
+ $pict .= pack ('n',0x00FF); # end of pict code
+ substr($pict,512,2) = pack('n',length($pict) - 512); # fill in length
+ return $pict;
+}
+
+sub ClipRect {
+ local($rect) = @_;
+ $pict .= pack('nn',0x0001,0x0A) . $rect;
+}
+
+sub PenPat {
+ local($newpat) = @_;
+ return unless $newpat ne $_PnPattern;
+ $_PnPattern = $newpat;
+ $pict .= pack('n',0x0009) . $_PnPattern;
+}
+
+sub RGBForeColor {
+ local($rgb) = pack('n3',@_);
+ return unless $rgb ne $rgbfgcolor;
+ $rgbfgcolor = $rgb;
+ $pict .= pack('n',0x001A) . $rgbfgcolor;
+}
+
+sub RGBBackColor {
+ local($rgb) = pack('n3',@_);
+ return unless $rgb ne $rgbbgcolor;
+ $rgbbgcolor = $rgb;
+ $pict .= pack('n',0x001B) . $rgbbgcolor;
+}
+
+sub FgColor {
+ local($color) = @_;
+ return unless $color != $fgcolor;
+ $fgcolor = $color;
+ $pict .= pack('nL',0x000E,$color);
+}
+
+sub BgColor {
+ local($color) = @_;
+ return unless $color != $bgcolor;
+ $bgcolor = $color;
+ $pict .= pack('nL',0x000F,$color);
+}
+
+sub TextFont {
+ local($font) = @_;
+ $textFont = $font;
+ $pict .= pack('nn',0x0003,$font);
+}
+
+sub TextSize {
+ local($size) = @_;
+ $textSize = $size;
+ $pict .= pack('nn',0x000D,$size);
+}
+
+sub PenSize {
+ local($h,$v) = @_;
+ $pict .= pack('nnn',0x0007,$v,$h);
+}
+
+sub TextFace {
+ return if $textFace == @_[0];
+ $textFace = @_[0];
+ $pict .= pack ('nCC',0x0004,$textFace,0); # (zero added to pad to word)
+}
+
+sub DrawString {
+ local($text) = @_;
+ $text .= "\0" x ((length($text) + 1) % 2); # pad text to an odd length
+ $pict .= pack('nnnC',0x0028,$currV,$currH,length($text)) . $text;
+}
+
+# RECTANGLE MANIPULATION ROUTINES. Note that
+# the rectangles are passed by NAME rather than by value,
+# in accordance with the MacOS way of doing things.
+sub SetRect {
+ local(*r,$h1,$v1,$h2,$v2) = @_;
+ $r = pack ('n4',$v1,$h1,$v2,$h2);
+}
+
+sub OffsetRect {
+ local(*r,$x,$y) = @_;
+ local($v1,$h1,$v2,$h2) = unpack('n4',$r);
+ $h1 += $x; $h2 += $x;
+ $v1 += $y; $v2 += $y;
+ $r = pack ('n4',$v1,$h1,$v2,$h2);
+}
+
+sub InsetRect {
+ local(*r,$x,$y) = @_;
+ local($v1,$h1,$v2,$h2) = unpack('n4',$r);
+ $h1 -= int($x/2); $h2 -= int($x/2);
+ $v1 -= int($y/2); $v2 -= int($y/2);
+ $r = pack ('n4',$v1,$h1,$v2,$h2);
+}
+
+# A few utility routine to translate between perl
+# arrays and rectangles.
+
+# four-element perl array to quickdraw rect structure
+sub a2r {
+ local($top,$left,$bottom,$right) = @_;
+ return pack('n4',$top,$left,$bottom,$right);
+}
+
+# rectangle to four-element perl array
+sub r2a {
+ local($rect) = @_;
+ return unpack('n4',$rect);
+}
+
+# associative array in which the keys are 'top','left','bottom','right'
+# to quickdraw rect structure
+sub aa2r {
+ local(%r) = @_;
+ return pack('n4',$r{'top'},$r{'left'},$r{'bottom'},$r{'right'});
+}
+
+# quickdraw rect structure to associative array
+sub r2aa {
+ local($r) = @_;
+ local(%r);
+ ($r{'top'},$r{'left'},$r{'bottom'},$r{'right'}) = unpack('n4',$r);
+ return %r;
+}
+
+# LINE DRAWING ROUTINES
+sub MoveTo {
+ ($currH,$currV) = @_;
+}
+
+sub Move {
+ local($dh,$dv) = @_;
+ $currH += $dh;
+ $currV += $dv;
+}
+
+sub LineTo {
+ local($h,$v) = @_;
+ # Special handling for polygons
+ if (defined(@polySave)) {
+ &_addVertex(*polySave,$h,$v)
+ } else {
+ $pict .= pack('nn4',0x0020,$currV,$currH,$v,$h);
+ }
+ ($currH,$currV) = ($h,$v);
+}
+
+sub Line {
+ local($dh,$dv) = @_;
+ # Special handling for polygons
+ if (defined(@polySave)) {
+ &_addVertex(*polySave,$h,$v);
+ } else {
+ $pict .= pack('nn4',0x0020,$currV,$currH,$currV+$dv,$currH+$dh);
+ }
+ ($currH,$currV) = ($currH+$dh,$currV+$dv);
+}
+
+sub Scale { #use picComment to set laserwriter line scaling
+ local($numerator,$denominator)= @_;
+ $pict .= pack('nnnn2',0x00A1,182,4,$numerator,$denominator);
+}
+
+
+# Rectangles
+sub FrameRect {
+ local($rect) = @_;
+ $pict .= pack('n',0x0030) . $rect;
+}
+
+sub PaintRect {
+ local($rect) = @_;
+ $pict .= pack('n',0x0031) . $rect;
+}
+
+sub EraseRect {
+ local($rect) = @_;
+ $pict .= pack('n',0x0032) . $rect;
+}
+
+sub InvertRect {
+ local($rect) = @_;
+ $pict .= pack('n',0x0033) . $rect;
+}
+
+sub FillRect {
+ local($rect,$pattern) = @_;
+ local($oldpat) = $_PnPattern;
+ &PenPat($pattern);
+ &PaintRect($rect);
+ &PenPat($oldpat);
+}
+
+# Ovals
+sub FrameOval {
+ local($rect) = @_;
+ $pict .= pack('n',0x0050) . $rect;
+}
+
+sub PaintOval {
+ local($rect) = @_;
+ $pict .= pack('n',0x0051) . $rect;
+}
+
+sub EraseOval {
+ local($rect) = @_;
+ $pict .= pack('n',0x0052) . $rect;
+}
+
+sub InvertOval {
+ local($rect) = @_;
+ $pict .= pack('n',0x0053) . $rect;
+}
+
+sub FillOval {
+ local($rect,$pattern) = @_;
+ local($oldpat) = $_PnPattern;
+ &PenPat($pattern);
+ &PaintOval($rect);
+ &PenPat($oldpat);
+}
+
+# Arcs
+sub FrameArc {
+ local($rect,$startAngle,$arcAngle) = @_;
+ $pict .= pack('n',0x0060) . $rect;
+ $pict .= pack('nn',$startAngle,$arcAngle);
+}
+
+sub PaintArc {
+ local($rect,$startAngle,$arcAngle) = @_;
+ $pict .= pack('n',0x0061) . $rect;
+ $pict .= pack('nn',$startAngle,$arcAngle);
+}
+
+sub EraseArc {
+ local($rect,$startAngle,$arcAngle) = @_;
+ $pict .= pack('n',0x0062) . $rect;
+ $pict .= pack('nn',$startAngle,$arcAngle);
+}
+
+sub InvertArc {
+ local($rect,$startAngle,$arcAngle) = @_;
+ $pict .= pack('n',0x0063) . $rect;
+ $pict .= pack('nn',$startAngle,$arcAngle);
+}
+
+sub FillArc {
+ local($rect,$startAngle,$arcAngle,$pattern) = @_;
+ local($oldpat) = $_PnPattern;
+ &PenPat($pattern);
+ &PaintArc($rect,$startAngle,$arcAngle);
+ &PenPat($oldpat);
+}
+
+# Round rects
+sub FrameRoundRect {
+ local($rect,$ovalWidth,$ovalHeight) = @_;
+ unless ($_roundRectCurvature eq "$ovalWidth $ovalHeight") {
+ $pict .= pack('nn2',0x000B,$ovalHeight,$ovalWidth);
+ $_roundRectCurvature = "$ovalWidth $ovalHeight";
+ }
+ $pict .= pack('n',0x0040) . $rect;
+}
+
+sub PaintRoundRect {
+ local($rect,$ovalWidth,$ovalHeight) = @_;
+ unless ($_roundRectCurvature eq "$ovalWidth $ovalHeight") {
+ $pict .= pack('nn2',0x000B,$ovalHeight,$ovalWidth);
+ $_roundRectCurvature = "$ovalWidth $ovalHeight";
+ }
+ $pict .= pack('n',0x0041) . $rect;
+}
+
+sub EraseRoundRect {
+ local($rect,$ovalWidth,$ovalHeight) = @_;
+ unless ($_roundRectCurvature eq "$ovalWidth $ovalHeight") {
+ $pict .= pack('nn2',0x000B,$ovalHeight,$ovalWidth);
+ $_roundRectCurvature = "$ovalWidth $ovalHeight";
+ }
+ $pict .= pack('n',0x0042) . $rect;
+}
+
+sub InvertRoundRect {
+ local($rect,$ovalWidth,$ovalHeight) = @_;
+ unless ($_roundRectCurvature eq "$ovalWidth $ovalHeight") {
+ $pict .= pack('nn2',0x000B,$ovalHeight,$ovalWidth);
+ $_roundRectCurvature = "$ovalWidth $ovalHeight";
+ }
+ $pict .= pack('n',0x0043) . $rect;
+}
+
+sub FillRoundRect {
+ local($rect,$ovalWidth,$ovalHeight,$pattern) = @_;
+ local($oldpat) = $_PnPattern;
+ &PenPat($pattern);
+ &PaintRoundRect($rect,$ovalWidth,$ovalHeight);
+ &PenPat($oldpat);
+}
+
+# Polygons -- you are only allowed to create one polygon at a time.
+# You will be returned a "handle" which contains the growing polygon
+# structure. The "handle" is actually the NAME of the scalar
+sub OpenPoly {
+ $_polyName++;
+ undef $polySave; # close one if it was already defined
+ *polySave = $_polyName;
+ @polySave = (10,0,0,0,0); # initialize it to empty size and rectangle
+ return $_polyName;
+}
+
+sub ClosePoly {
+ *polySave = 'scratch';
+ undef @polySave;
+}
+
+# Kill the poly -- really a no-op in perl
+sub KillPoly {
+ local(*poly) = @_;
+ undef @poly;
+}
+
+# Polygon drawing
+sub FramePoly {
+ local(*poly) = @_;
+ return unless @poly;
+ $pict .= pack('n*',0x0070,@poly);
+}
+
+sub PaintPoly {
+ local(*poly) = @_;
+ return unless @poly;
+ $pict .= pack('n*',0x0071,@poly);
+}
+
+sub ErasePoly {
+ local(*poly) = @_;
+ return unless @poly;
+ $pict .= pack('n*',0x0072,@poly);
+}
+
+sub InvertPoly {
+ local(*poly) = @_;
+ return unless @poly;
+ $pict .= pack('n*',0x0073,@poly);
+}
+
+sub FillPoly {
+ local(*poly,$pattern) = @_;
+ return unless @poly;
+ local($oldpat) = $_PnPattern;
+ &PenPat($pattern);
+ &PaintPoly(*poly);
+ &PenPat($oldpat);
+}
+
+sub OffsetPoly {
+ local(*poly,$dh,$dv) = @_;
+ return unless @poly;
+ local($size,@vertices) = @poly;
+ local($i);
+ for ($i=0;$i<@vertices;$i+=2) {
+ $vertices[$i] += $dv;
+ $vertices[$i+1] += $dh;
+ }
+ @poly = ($size,@vertices);
+}
+
+sub MapPoly {
+ local(*poly,$srcRect,$destRect) = @_;
+ return unless @poly;
+ local($size,@vertices) = @poly;
+ local(@src) = unpack('n4',$srcRect);
+ local(@dest) = unpack('n4',$destRect);
+ local($factorV) = ($dest[2]-$dest[0])/($src[2]-$src[0]);
+ local($factorH) = ($dest[3]-$dest[1])/($src[3]-$src[1]);
+ for ($i=0;$i<@vertices;$i+=2) {
+ $vertices[$i] = int($dest[0] + ($vertices[$i] - $src[0]) * $factorV);
+ $vertices[$i+1] = int($dest[1] + ($vertices[$i+1] - $src[1]) * $factorH);
+ }
+ @poly = ($size,@vertices);
+}
+
+# A utility routine to add a vertex to the growing polygon structure
+# We need to grow both the size of the polygon and increase the bounding
+# rectangle. A special case occurs when we add the first vertex:
+# we store both the current position
+sub _addVertex {
+ local(*polygon,$h,$v) = @_;
+ local($size,$top,$left,$bottom,$right,@vertices) = @polygon;
+ # Special case for empty vertices -- add the current point
+ unless (@vertices) {
+ push(@vertices,$currV,$currH);
+ $size += 4;
+ $top = $bottom = $currV;
+ $left = $right = $currH;
+ }
+
+ # IM V1 implies that all vertices are stored relative to
+ # the first point -- I don't know if this is really the case
+ push (@vertices,$v,$h);
+
+ $size += 4;
+ $top = $v if $v < $top;
+ $bottom = $v if $v > $bottom;
+ $left = $h if $h < $left;
+ $right = $h if $h > $right;
+ @polygon=($size,$top,$left,$bottom,$right,@vertices);
+}
+
+# We try to get the metrics from an X11 bdf font file, if possible.
+sub TextWidth {
+ local($text) = @_;
+
+ # See if we can derive the character widths from a metrics file
+ local($face) = 0xFB & $textFace; # underlining don't count
+ local($metric_name) = &_getFontMetrics($textFont,$textSize,$face);
+ if ($metric_name && (*metrics = $metric_name) && defined(%metrics)) {
+ local($length);
+ foreach (split('',$text)) {
+ $length += $metrics{ord($_)};
+ }
+ return $length;
+ } else { # we get here if we don't have any metrics - make it up
+ local($extra);
+ $extra += $ITALICEXTRA if vec($textFace,$ITALIC,1);
+ $extra += $BOLDEXTRA if vec($textFace,$BOLD,1);
+ return length($text) * $textSize * ($fudgefactor+$extra);
+ }
+}
+
+# Utility routine to read text widths out of bdf files. We create a metrics
+# array on the fly. The names of the metrics files are stored in an array
+# called _metricsArrays. We return the name of the array, or undef if inapplicable.
+sub _getFontMetrics {
+ local($font,$size,$face) = @_;
+ local($key) = "$font $size $face";
+ return $_metricsArrays{$key} if $_metricsArrays{$key};
+
+ # If we get here, we don't have a metrics array to return. See if we can
+ # construct one from a bdf file.
+
+ # Don't bother unless this font is defined.
+ return undef unless $font_metric_files{$key};
+
+ # Don't bother if we tried before and failed
+ return undef if $_failed_metric{$key};
+
+ # Try to open up the bdf file. Remember if we fail
+ unless (open(BDF,"$font_metric_files{$key}")) {
+ $_failed_metric_files{$key}++;
+ return undef;
+ }
+
+ # Wow! We're golden. Create a new metrics array
+ $next_metric++; # bump up the name
+ local(*metrics) = $next_metric; local($char);
+ while (<BDF>) {
+ next unless /^STARTCHAR/../^ENDCHAR/;
+ if (/^ENCODING\s+(\d+)/) { $char = $1; }
+ elsif (/^DWIDTH\s+(\d+)/) { $metrics{$char}=$1; }
+ }
+ close(BDF);
+
+ # Remember the name of the metrics array and return it
+ return $_metricsArrays{$key} = $next_metric;
+}
+
+# Ugly stuff that I want to hide at the bottom
+
+# For the purposes of mapping from quickdraw fonts to X11fonts, we define
+# the following dictionary:
+%font_metric_files = (
+ "22 8 1","$X11FONTS/courB08.bdf",
+ "22 10 1","$X11FONTS/courB10.bdf",
+ "22 12 1","$X11FONTS/courB12.bdf",
+ "22 14 1","$X11FONTS/courB14.bdf",
+ "22 18 1","$X11FONTS/courB18.bdf",
+ "22 24 1","$X11FONTS/courB24.bdf",
+ "22 8 2","$X11FONTS/courO08.bdf",
+ "22 10 2","$X11FONTS/courO10.bdf",
+ "22 12 2","$X11FONTS/courO12.bdf",
+ "22 14 2","$X11FONTS/courO14.bdf",
+ "22 18 2","$X11FONTS/courO18.bdf",
+ "22 24 2","$X11FONTS/courO24.bdf",
+ "22 8 0","$X11FONTS/courR08.bdf",
+ "22 10 0","$X11FONTS/courR10.bdf",
+ "22 12 0","$X11FONTS/courR12.bdf",
+ "22 14 0","$X11FONTS/courR14.bdf",
+ "22 18 0","$X11FONTS/courR18.bdf",
+ "22 24 0","$X11FONTS/courR24.bdf",
+ "21 8 1","$X11FONTS/helvB08.bdf",
+ "21 10 1","$X11FONTS/helvB10.bdf",
+ "21 12 1","$X11FONTS/helvB12.bdf",
+ "21 14 1","$X11FONTS/helvB14.bdf",
+ "21 18 1","$X11FONTS/helvB18.bdf",
+ "21 24 1","$X11FONTS/helvB24.bdf",
+ "21 8 2","$X11FONTS/helvO08.bdf",
+ "21 10 2","$X11FONTS/helvO10.bdf",
+ "21 12 2","$X11FONTS/helvO12.bdf",
+ "21 14 2","$X11FONTS/helvO14.bdf",
+ "21 18 2","$X11FONTS/helvO18.bdf",
+ "21 24 2","$X11FONTS/helvO24.bdf",
+ "21 8 0","$X11FONTS/helvR08.bdf",
+ "21 10 0","$X11FONTS/helvR10.bdf",
+ "21 12 0","$X11FONTS/helvR12.bdf",
+ "21 14 0","$X11FONTS/helvR14.bdf",
+ "21 18 0","$X11FONTS/helvR18.bdf",
+ "21 24 0","$X11FONTS/helvR24.bdf",
+ "20 8 1","$X11FONTS/timB08.bdf",
+ "20 10 1","$X11FONTS/timB10.bdf",
+ "20 12 1","$X11FONTS/timB12.bdf",
+ "20 14 1","$X11FONTS/timB14.bdf",
+ "20 18 1","$X11FONTS/timB18.bdf",
+ "20 24 1","$X11FONTS/timB24.bdf",
+ "20 8 3","$X11FONTS/timBI08.bdf",
+ "20 10 3","$X11FONTS/timBI10.bdf",
+ "20 12 3","$X11FONTS/timBI12.bdf",
+ "20 14 3","$X11FONTS/timBI14.bdf",
+ "20 18 3","$X11FONTS/timBI18.bdf",
+ "20 24 3","$X11FONTS/timBI24.bdf",
+ "20 8 2","$X11FONTS/timI08.bdf",
+ "20 10 2","$X11FONTS/timI10.bdf",
+ "20 12 2","$X11FONTS/timI12.bdf",
+ "20 14 2","$X11FONTS/timI14.bdf",
+ "20 18 2","$X11FONTS/timI18.bdf",
+ "20 24 2","$X11FONTS/timI24.bdf",
+ "20 8 0","$X11FONTS/timR08.bdf",
+ "20 10 0","$X11FONTS/timR10.bdf",
+ "20 12 0","$X11FONTS/timR12.bdf",
+ "20 14 0","$X11FONTS/timR14.bdf",
+ "20 18 0","$X11FONTS/timR18.bdf",
+ "20 24 0","$X11FONTS/timR24.bdf",
+ "34 8 1","$X11FONTS/ncenB08.bdf",
+ "34 10 1","$X11FONTS/ncenB10.bdf",
+ "34 12 1","$X11FONTS/ncenB12.bdf",
+ "34 14 1","$X11FONTS/ncenB14.bdf",
+ "34 18 1","$X11FONTS/ncenB18.bdf",
+ "34 24 1","$X11FONTS/ncenB24.bdf",
+ "34 8 3","$X11FONTS/ncenBI08.bdf",
+ "34 10 3","$X11FONTS/ncenBI10.bdf",
+ "34 12 3","$X11FONTS/ncenBI12.bdf",
+ "34 14 3","$X11FONTS/ncenBI14.bdf",
+ "34 18 3","$X11FONTS/ncenBI18.bdf",
+ "34 24 3","$X11FONTS/ncenBI24.bdf",
+ "34 8 2","$X11FONTS/ncenI08.bdf",
+ "34 10 2","$X11FONTS/ncenI10.bdf",
+ "34 12 2","$X11FONTS/ncenI12.bdf",
+ "34 14 2","$X11FONTS/ncenI14.bdf",
+ "34 18 2","$X11FONTS/ncenI18.bdf",
+ "34 24 2","$X11FONTS/ncenI24.bdf",
+ "34 8 0","$X11FONTS/ncenR08.bdf",
+ "34 10 0","$X11FONTS/ncenR10.bdf",
+ "34 12 0","$X11FONTS/ncenR12.bdf",
+ "34 14 0","$X11FONTS/ncenR14.bdf",
+ "34 18 0","$X11FONTS/ncenR18.bdf",
+ "34 24 0","$X11FONTS/ncenR24.bdf"
+ );
+$next_metric = "metrics0000"; # name of our metrics arrays - dynamically allocated
+
+1;
+} #end of package qd
+