ref: a2c0e55e6885fde0d135831a77d227bc933d89e7
dir: /sys/src/cmd/postscript/grabit/grabit.ps/
% % Dump a PostScript object, occasionally in a form that can be sent back % through the interpreter. Similiar to Adobe's == procedure, but output % is usually easier to read. No binding so operators like rcheck and exec % can be conviently redefined. % /GrabitDict 100 dict dup begin /recursive true def /scratchstring 200 string def /slowdown 100 def /column 0 def /lastcolumn 80 def /level 0 def /multiline 100 array def /nextname 0 def /arraylength 0 def /lengthonly false def /GrabitSetup { counttomark {OmitNames exch true put} repeat pop 0 0 moveto % for hardcopy output } def /OmitNames 30 dict def % ignore these names /OtherDicts 200 dict def % unrecognized dictionaries % % All strings returned to the host go through Print. First pass through an % array has lengthonly set to true. % /Print { dup type /stringtype ne {scratchstring cvs} if lengthonly { length arraylength add /arraylength exch def }{ dup length column add /column exch def print flush slowdown {1 pop} repeat } ifelse } def /Indent {level {( ) Print} repeat} def /Newline {(\n) Print lengthonly not {/column 0 def} if} def /NextLevel {/level level 1 add def multiline level 0 put} def /LastLevel {/level level 1 sub def} def % % Make a unique name for each unrecognized dictionary and remember the name % and dictionary in OtherDicts. % /Register { dup type /dicttype eq { /nextname nextname 1 add def dup (UnknownDict ) dup (UnknownDict) length nextname ( ) cvs putinterval 0 (UnknownDict) length nextname ( ) cvs length add getinterval cvn exch OtherDicts 3 1 roll put } if } def % % Replace array or dictionary values by known names. Lookups are in the % standard PostScript dictionaries and in OtherDicts. If found replace % the value by the name and make it executable so nametype omits the % leading /. % /Replace { false 1 index type /dicttype eq {pop true} if 1 index type /arraytype eq 2 index xcheck not and {pop true} if { false [userdict systemdict statusdict serverdict OtherDicts] { { 3 index eq {exch pop exch pop cvx true exit} {pop} ifelse } forall dup {exit} if } forall pop } if } def % % Simple type handlers. In some cases (e.g. savetype) what's returned can't % be sent back through the interpreter. % /booleantype {{(true )}{(false )} ifelse Print} def /marktype {pop (mark ) Print} def /nulltype {pop (null ) Print} def /integertype {Print ( ) Print} def /realtype {Print ( ) Print} def /filetype {pop (-file- ) Print} def /fonttype {pop (-fontID- ) Print} def /savetype {pop (-saveobj- ) Print} def % % Special formatting for operators is enabled if the flag in multiline % (for the current level) is set to 1. In that case each operator, after % being printed, is looked up in OperatorDict. If found the value is used % as an index into the OperatorProcs array and the object at that index % is retrieved and executed. Currently only used to choose the operators % that end a line. % /operatortype { dup Print ( ) Print multiline level get 1 eq { scratchstring cvs cvn dup OperatorDict exch known { OperatorDict exch get OperatorProcs exch get exec }{ pop column lastcolumn gt {Newline Indent} if } ifelse }{pop} ifelse } def % % Executable names are passed to operatortype. Non-executable names get a % leading /. % /nametype { dup xcheck { operatortype }{ (/) Print Print ( ) Print } ifelse } def % % Arrays are processed in two passes. The first computes the length of the % string returned to the host without any special formatting. If it extends % past the last column special formatting is enabled by setting a flag in % array multiline. Arrays are processed in a for loop so the last element % easily recognized. At that point special fortmatting is disabled. % /packedarraytype {arraytype} def /arraytype { NextLevel lengthonly not { /lengthonly true def /arraylength 0 def dup dup type exec arraylength 20 gt arraylength column add lastcolumn gt and { multiline level 1 put } if /lengthonly false def } if dup rcheck not { (-array- ) Print pop }{ dup xcheck {({)}{([)} ifelse Print multiline level get 0 ne {Newline Indent}{( ) Print} ifelse 0 1 2 index length 1 sub { 2 copy exch length 1 sub eq multiline level get 1 eq and { multiline level 2 put } if 2 copy get exch pop dup type /dicttype eq { Replace dup type /dicttype eq { dup Register Replace recursive { 2 copy cvlit /def load 3 1 roll count 3 roll } if exch pop } if } if dup type exec dup xcheck not multiline level get 1 eq and { 0 index type /arraytype eq 1 index type /packedarray eq or 1 index type /stringtype eq or {Newline Indent} if } if } for multiline level get 0 ne {Newline LastLevel Indent NextLevel} if xcheck {(} )}{(] )} ifelse Print } ifelse LastLevel } def % % Dictionary handler. Try to replace the value by a name before processing % the dictionary. % /dicttype { dup rcheck not { (-dictionary- ) Print pop }{ dup maxlength Print ( dict dup begin) Print Newline NextLevel { 1 index OmitNames exch known { pop pop }{ Indent Replace % arrays and dicts by known names Register % new dictionaries in OtherDicts exch cvlit dup type exec % key first - force a / dup type exec % then the value (def) Print Newline } ifelse } forall LastLevel Indent (end ) Print } ifelse } def % % Strings containing characters not in AsciiDict are returned in hex. All % others are ASCII strings and use AsciiDict for character mapping. % /onecharstring ( ) def /twocharstring ( ) def /stringtype { dup rcheck not { (-string- ) Print }{ /hexit false def dup { onecharstring 0 3 -1 roll put AsciiDict onecharstring cvn known not { /hexit true def exit } if } forall hexit {(<)}{(\()} ifelse Print 0 1 2 index length 1 sub { 2 copy 1 getinterval exch pop hexit { 0 get /n exch def n -4 bitshift 16#F and 16 twocharstring cvrs pop n 16#F and twocharstring 1 1 getinterval 16 exch cvrs pop twocharstring }{cvn AsciiDict exch get} ifelse Print column lastcolumn gt { hexit not {(\\) Print} if Newline } if } for hexit {(> )}{(\) )} ifelse Print } ifelse pop } def % % ASCII characters and replacement strings. Ensures the returned string will % reproduce the original when passed through the scanner. Strings containing % characters not in this list should be returned as hex strings. % /AsciiDict 128 dict dup begin (\n) cvn (\\n) def (\r) cvn (\\r) def (\t) cvn (\\t) def (\b) cvn (\\b) def (\f) cvn (\\f) def ( ) cvn ( ) def (!) cvn (!) def (") cvn (") def (#) cvn (#) def ($) cvn ($) def (%) cvn (\\%) def (&) cvn (&) def (') cvn (') def (\() cvn (\\\() def (\)) cvn (\\\)) def (*) cvn (*) def (+) cvn (+) def (,) cvn (,) def (-) cvn (-) def (.) cvn (.) def (/) cvn (/) def (0) cvn (0) def (1) cvn (1) def (2) cvn (2) def (3) cvn (3) def (4) cvn (4) def (5) cvn (5) def (6) cvn (6) def (7) cvn (7) def (8) cvn (8) def (9) cvn (9) def (:) cvn (:) def (;) cvn (;) def (<) cvn (<) def (=) cvn (=) def (>) cvn (>) def (?) cvn (?) def (@) cvn (@) def (A) cvn (A) def (B) cvn (B) def (C) cvn (C) def (D) cvn (D) def (E) cvn (E) def (F) cvn (F) def (G) cvn (G) def (H) cvn (H) def (I) cvn (I) def (J) cvn (J) def (K) cvn (K) def (L) cvn (L) def (M) cvn (M) def (N) cvn (N) def (O) cvn (O) def (P) cvn (P) def (Q) cvn (Q) def (R) cvn (R) def (S) cvn (S) def (T) cvn (T) def (U) cvn (U) def (V) cvn (V) def (W) cvn (W) def (X) cvn (X) def (Y) cvn (Y) def (Z) cvn (Z) def ([) cvn ([) def (\\) cvn (\\\\) def (]) cvn (]) def (^) cvn (^) def (_) cvn (_) def (`) cvn (`) def (a) cvn (a) def (b) cvn (b) def (c) cvn (c) def (d) cvn (d) def (e) cvn (e) def (f) cvn (f) def (g) cvn (g) def (h) cvn (h) def (i) cvn (i) def (j) cvn (j) def (k) cvn (k) def (l) cvn (l) def (m) cvn (m) def (n) cvn (n) def (o) cvn (o) def (p) cvn (p) def (q) cvn (q) def (r) cvn (r) def (s) cvn (s) def (t) cvn (t) def (u) cvn (u) def (v) cvn (v) def (w) cvn (w) def (x) cvn (x) def (y) cvn (y) def (z) cvn (z) def ({) cvn ({) def (|) cvn (|) def (}) cvn (}) def (~) cvn (~) def end def % % OperatorDict can help format procedure listings. The value assigned to each % name is used as an index into the OperatorProcs array. The procedure at that % index is fetched and executed after the named operator is printed. What's in % OperatorDict is a matter of taste rather than correctness. The default list % represents our choice of which of Adobe's operators should end a line. % /OperatorProcs [{} {Newline Indent}] def /OperatorDict 250 dict def OperatorDict /arc 1 put OperatorDict /arcn 1 put OperatorDict /ashow 1 put OperatorDict /awidthshow 1 put OperatorDict /banddevice 1 put OperatorDict /begin 1 put OperatorDict /charpath 1 put OperatorDict /clear 1 put OperatorDict /cleardictstack 1 put OperatorDict /cleartomark 1 put OperatorDict /clip 1 put OperatorDict /clippath 1 put OperatorDict /closefile 1 put OperatorDict /closepath 1 put OperatorDict /concat 1 put OperatorDict /copypage 1 put OperatorDict /curveto 1 put OperatorDict /def 1 put OperatorDict /end 1 put OperatorDict /eoclip 1 put OperatorDict /eofill 1 put OperatorDict /erasepage 1 put OperatorDict /exec 1 put OperatorDict /exit 1 put OperatorDict /fill 1 put OperatorDict /flattenpath 1 put OperatorDict /flush 1 put OperatorDict /flushfile 1 put OperatorDict /for 1 put OperatorDict /forall 1 put OperatorDict /framedevice 1 put OperatorDict /grestore 1 put OperatorDict /grestoreall 1 put OperatorDict /gsave 1 put OperatorDict /handleerror 1 put OperatorDict /if 1 put OperatorDict /ifelse 1 put OperatorDict /image 1 put OperatorDict /imagemask 1 put OperatorDict /initclip 1 put OperatorDict /initgraphics 1 put OperatorDict /initmatrix 1 put OperatorDict /kshow 1 put OperatorDict /lineto 1 put OperatorDict /loop 1 put OperatorDict /moveto 1 put OperatorDict /newpath 1 put OperatorDict /nulldevice 1 put OperatorDict /pathforall 1 put OperatorDict /print 1 put OperatorDict /prompt 1 put OperatorDict /put 1 put OperatorDict /putinterval 1 put OperatorDict /quit 1 put OperatorDict /rcurveto 1 put OperatorDict /renderbands 1 put OperatorDict /repeat 1 put OperatorDict /resetfile 1 put OperatorDict /restore 1 put OperatorDict /reversepath 1 put OperatorDict /rlineto 1 put OperatorDict /rmoveto 1 put OperatorDict /rotate 1 put OperatorDict /run 1 put OperatorDict /scale 1 put OperatorDict /setcachedevice 1 put OperatorDict /setcachelimit 1 put OperatorDict /setcacheparams 1 put OperatorDict /setcharwidth 1 put OperatorDict /setdash 1 put OperatorDict /setdefaulttimeouts 1 put OperatorDict /setdostartpage 1 put OperatorDict /seteescratch 1 put OperatorDict /setflat 1 put OperatorDict /setfont 1 put OperatorDict /setgray 1 put OperatorDict /sethsbcolor 1 put OperatorDict /setidlefonts 1 put OperatorDict /setjobtimeout 1 put OperatorDict /setlinecap 1 put OperatorDict /setlinejoin 1 put OperatorDict /setlinewidth 1 put OperatorDict /setmargins 1 put OperatorDict /setmatrix 1 put OperatorDict /setmiterlimit 1 put OperatorDict /setpacking 1 put OperatorDict /setpagetype 1 put OperatorDict /setprintname 1 put OperatorDict /setrgbcolor 1 put OperatorDict /setsccbatch 1 put OperatorDict /setsccinteractive 1 put OperatorDict /setscreen 1 put OperatorDict /settransfer 1 put OperatorDict /show 1 put OperatorDict /showpage 1 put OperatorDict /start 1 put OperatorDict /stop 1 put OperatorDict /store 1 put OperatorDict /stroke 1 put OperatorDict /strokepath 1 put OperatorDict /translate 1 put OperatorDict /widthshow 1 put OperatorDict /write 1 put OperatorDict /writehexstring 1 put OperatorDict /writestring 1 put end def % % Put an object on the stack and call Grabit. Output continues until stack % is empty. For example, % % /letter load Grabit % % prints a listing of the letter procedure. % /Grabit { /saveobj save def GrabitDict begin { count 0 eq {exit} if count {dup type exec} repeat (\n) print flush } loop end currentpoint % for hardcopy output saveobj restore moveto } def