grabit.ps (12401B)
1 % 2 % Dump a PostScript object, occasionally in a form that can be sent back 3 % through the interpreter. Similiar to Adobe's == procedure, but output 4 % is usually easier to read. No binding so operators like rcheck and exec 5 % can be conviently redefined. 6 % 7 8 /GrabitDict 100 dict dup begin 9 10 /recursive true def 11 /scratchstring 200 string def 12 /slowdown 100 def 13 14 /column 0 def 15 /lastcolumn 80 def 16 /level 0 def 17 /multiline 100 array def 18 /nextname 0 def 19 /arraylength 0 def 20 /lengthonly false def 21 22 /GrabitSetup { 23 counttomark {OmitNames exch true put} repeat pop 24 0 0 moveto % for hardcopy output 25 } def 26 27 /OmitNames 30 dict def % ignore these names 28 /OtherDicts 200 dict def % unrecognized dictionaries 29 30 % 31 % All strings returned to the host go through Print. First pass through an 32 % array has lengthonly set to true. 33 % 34 35 /Print { 36 dup type /stringtype ne {scratchstring cvs} if 37 lengthonly { 38 length arraylength add /arraylength exch def 39 }{ 40 dup length column add /column exch def 41 print flush 42 slowdown {1 pop} repeat 43 } ifelse 44 } def 45 46 /Indent {level {( ) Print} repeat} def 47 /Newline {(\n) Print lengthonly not {/column 0 def} if} def 48 49 /NextLevel {/level level 1 add def multiline level 0 put} def 50 /LastLevel {/level level 1 sub def} def 51 52 % 53 % Make a unique name for each unrecognized dictionary and remember the name 54 % and dictionary in OtherDicts. 55 % 56 57 /Register { 58 dup type /dicttype eq { 59 /nextname nextname 1 add def 60 dup (UnknownDict ) dup 61 (UnknownDict) length nextname ( ) cvs putinterval 62 0 (UnknownDict) length nextname ( ) cvs length add getinterval cvn 63 exch OtherDicts 3 1 roll put 64 } if 65 } def 66 67 % 68 % Replace array or dictionary values by known names. Lookups are in the 69 % standard PostScript dictionaries and in OtherDicts. If found replace 70 % the value by the name and make it executable so nametype omits the 71 % leading /. 72 % 73 74 /Replace { 75 false 76 1 index type /dicttype eq {pop true} if 77 1 index type /arraytype eq 2 index xcheck not and {pop true} if 78 { 79 false 80 [userdict systemdict statusdict serverdict OtherDicts] { 81 { 82 3 index eq 83 {exch pop exch pop cvx true exit} 84 {pop} 85 ifelse 86 } forall 87 dup {exit} if 88 } forall 89 pop 90 } if 91 } def 92 93 % 94 % Simple type handlers. In some cases (e.g. savetype) what's returned can't 95 % be sent back through the interpreter. 96 % 97 98 /booleantype {{(true )}{(false )} ifelse Print} def 99 /marktype {pop (mark ) Print} def 100 /nulltype {pop (null ) Print} def 101 /integertype {Print ( ) Print} def 102 /realtype {Print ( ) Print} def 103 /filetype {pop (-file- ) Print} def 104 /fonttype {pop (-fontID- ) Print} def 105 /savetype {pop (-saveobj- ) Print} def 106 107 % 108 % Special formatting for operators is enabled if the flag in multiline 109 % (for the current level) is set to 1. In that case each operator, after 110 % being printed, is looked up in OperatorDict. If found the value is used 111 % as an index into the OperatorProcs array and the object at that index 112 % is retrieved and executed. Currently only used to choose the operators 113 % that end a line. 114 % 115 116 /operatortype { 117 dup Print ( ) Print 118 multiline level get 1 eq { 119 scratchstring cvs cvn dup OperatorDict exch known { 120 OperatorDict exch get 121 OperatorProcs exch get exec 122 }{ 123 pop 124 column lastcolumn gt {Newline Indent} if 125 } ifelse 126 }{pop} ifelse 127 } def 128 129 % 130 % Executable names are passed to operatortype. Non-executable names get a 131 % leading /. 132 % 133 134 /nametype { 135 dup xcheck { 136 operatortype 137 }{ 138 (/) Print Print ( ) Print 139 } ifelse 140 } def 141 142 % 143 % Arrays are processed in two passes. The first computes the length of the 144 % string returned to the host without any special formatting. If it extends 145 % past the last column special formatting is enabled by setting a flag in 146 % array multiline. Arrays are processed in a for loop so the last element 147 % easily recognized. At that point special fortmatting is disabled. 148 % 149 150 /packedarraytype {arraytype} def 151 152 /arraytype { 153 NextLevel 154 lengthonly not { 155 /lengthonly true def 156 /arraylength 0 def 157 dup dup type exec 158 arraylength 20 gt arraylength column add lastcolumn gt and { 159 multiline level 1 put 160 } if 161 /lengthonly false def 162 } if 163 164 dup rcheck not { 165 (-array- ) Print pop 166 }{ 167 dup xcheck {({)}{([)} ifelse Print 168 multiline level get 0 ne {Newline Indent}{( ) Print} ifelse 169 0 1 2 index length 1 sub { 170 2 copy exch length 1 sub eq multiline level get 1 eq and { 171 multiline level 2 put 172 } if 173 2 copy get exch pop 174 dup type /dicttype eq { 175 Replace 176 dup type /dicttype eq { 177 dup Register Replace 178 recursive { 179 2 copy cvlit 180 /def load 3 1 roll 181 count 3 roll 182 } if 183 exch pop 184 } if 185 } if 186 dup type exec 187 dup xcheck not multiline level get 1 eq and { 188 0 index type /arraytype eq 189 1 index type /packedarray eq or 190 1 index type /stringtype eq or {Newline Indent} if 191 } if 192 } for 193 multiline level get 0 ne {Newline LastLevel Indent NextLevel} if 194 xcheck {(} )}{(] )} ifelse Print 195 } ifelse 196 LastLevel 197 } def 198 199 % 200 % Dictionary handler. Try to replace the value by a name before processing 201 % the dictionary. 202 % 203 204 /dicttype { 205 dup 206 rcheck not { 207 (-dictionary- ) Print pop 208 }{ 209 dup maxlength Print ( dict dup begin) Print Newline 210 NextLevel 211 { 212 1 index OmitNames exch known { 213 pop pop 214 }{ 215 Indent 216 Replace % arrays and dicts by known names 217 Register % new dictionaries in OtherDicts 218 exch 219 cvlit dup type exec % key first - force a / 220 dup type exec % then the value 221 (def) Print Newline 222 } ifelse 223 } forall 224 LastLevel 225 Indent 226 (end ) Print 227 } ifelse 228 } def 229 230 % 231 % Strings containing characters not in AsciiDict are returned in hex. All 232 % others are ASCII strings and use AsciiDict for character mapping. 233 % 234 235 /onecharstring ( ) def 236 /twocharstring ( ) def 237 238 /stringtype { 239 dup 240 rcheck not { 241 (-string- ) Print 242 }{ 243 /hexit false def 244 dup { 245 onecharstring 0 3 -1 roll put 246 AsciiDict onecharstring cvn known not { 247 /hexit true def exit 248 } if 249 } forall 250 251 hexit {(<)}{(\()} ifelse Print 252 0 1 2 index length 1 sub { 253 2 copy 1 getinterval exch pop 254 hexit { 255 0 get /n exch def 256 n -4 bitshift 16#F and 16 twocharstring cvrs pop 257 n 16#F and twocharstring 1 1 getinterval 16 exch cvrs pop 258 twocharstring 259 }{cvn AsciiDict exch get} ifelse 260 Print 261 column lastcolumn gt { 262 hexit not {(\\) Print} if 263 Newline 264 } if 265 } for 266 hexit {(> )}{(\) )} ifelse Print 267 } ifelse 268 pop 269 } def 270 271 % 272 % ASCII characters and replacement strings. Ensures the returned string will 273 % reproduce the original when passed through the scanner. Strings containing 274 % characters not in this list should be returned as hex strings. 275 % 276 277 /AsciiDict 128 dict dup begin 278 (\n) cvn (\\n) def 279 (\r) cvn (\\r) def 280 (\t) cvn (\\t) def 281 (\b) cvn (\\b) def 282 (\f) cvn (\\f) def 283 ( ) cvn ( ) def 284 (!) cvn (!) def 285 (") cvn (") def 286 (#) cvn (#) def 287 ($) cvn ($) def 288 (%) cvn (\\%) def 289 (&) cvn (&) def 290 (') cvn (') def 291 (\() cvn (\\\() def 292 (\)) cvn (\\\)) def 293 (*) cvn (*) def 294 (+) cvn (+) def 295 (,) cvn (,) def 296 (-) cvn (-) def 297 (.) cvn (.) def 298 (/) cvn (/) def 299 (0) cvn (0) def 300 (1) cvn (1) def 301 (2) cvn (2) def 302 (3) cvn (3) def 303 (4) cvn (4) def 304 (5) cvn (5) def 305 (6) cvn (6) def 306 (7) cvn (7) def 307 (8) cvn (8) def 308 (9) cvn (9) def 309 (:) cvn (:) def 310 (;) cvn (;) def 311 (<) cvn (<) def 312 (=) cvn (=) def 313 (>) cvn (>) def 314 (?) cvn (?) def 315 (@) cvn (@) def 316 (A) cvn (A) def 317 (B) cvn (B) def 318 (C) cvn (C) def 319 (D) cvn (D) def 320 (E) cvn (E) def 321 (F) cvn (F) def 322 (G) cvn (G) def 323 (H) cvn (H) def 324 (I) cvn (I) def 325 (J) cvn (J) def 326 (K) cvn (K) def 327 (L) cvn (L) def 328 (M) cvn (M) def 329 (N) cvn (N) def 330 (O) cvn (O) def 331 (P) cvn (P) def 332 (Q) cvn (Q) def 333 (R) cvn (R) def 334 (S) cvn (S) def 335 (T) cvn (T) def 336 (U) cvn (U) def 337 (V) cvn (V) def 338 (W) cvn (W) def 339 (X) cvn (X) def 340 (Y) cvn (Y) def 341 (Z) cvn (Z) def 342 ([) cvn ([) def 343 (\\) cvn (\\\\) def 344 (]) cvn (]) def 345 (^) cvn (^) def 346 (_) cvn (_) def 347 (`) cvn (`) def 348 (a) cvn (a) def 349 (b) cvn (b) def 350 (c) cvn (c) def 351 (d) cvn (d) def 352 (e) cvn (e) def 353 (f) cvn (f) def 354 (g) cvn (g) def 355 (h) cvn (h) def 356 (i) cvn (i) def 357 (j) cvn (j) def 358 (k) cvn (k) def 359 (l) cvn (l) def 360 (m) cvn (m) def 361 (n) cvn (n) def 362 (o) cvn (o) def 363 (p) cvn (p) def 364 (q) cvn (q) def 365 (r) cvn (r) def 366 (s) cvn (s) def 367 (t) cvn (t) def 368 (u) cvn (u) def 369 (v) cvn (v) def 370 (w) cvn (w) def 371 (x) cvn (x) def 372 (y) cvn (y) def 373 (z) cvn (z) def 374 ({) cvn ({) def 375 (|) cvn (|) def 376 (}) cvn (}) def 377 (~) cvn (~) def 378 end def 379 380 % 381 % OperatorDict can help format procedure listings. The value assigned to each 382 % name is used as an index into the OperatorProcs array. The procedure at that 383 % index is fetched and executed after the named operator is printed. What's in 384 % OperatorDict is a matter of taste rather than correctness. The default list 385 % represents our choice of which of Adobe's operators should end a line. 386 % 387 388 /OperatorProcs [{} {Newline Indent}] def 389 390 /OperatorDict 250 dict def 391 392 OperatorDict /arc 1 put 393 OperatorDict /arcn 1 put 394 OperatorDict /ashow 1 put 395 OperatorDict /awidthshow 1 put 396 OperatorDict /banddevice 1 put 397 OperatorDict /begin 1 put 398 OperatorDict /charpath 1 put 399 OperatorDict /clear 1 put 400 OperatorDict /cleardictstack 1 put 401 OperatorDict /cleartomark 1 put 402 OperatorDict /clip 1 put 403 OperatorDict /clippath 1 put 404 OperatorDict /closefile 1 put 405 OperatorDict /closepath 1 put 406 OperatorDict /concat 1 put 407 OperatorDict /copypage 1 put 408 OperatorDict /curveto 1 put 409 OperatorDict /def 1 put 410 OperatorDict /end 1 put 411 OperatorDict /eoclip 1 put 412 OperatorDict /eofill 1 put 413 OperatorDict /erasepage 1 put 414 OperatorDict /exec 1 put 415 OperatorDict /exit 1 put 416 OperatorDict /fill 1 put 417 OperatorDict /flattenpath 1 put 418 OperatorDict /flush 1 put 419 OperatorDict /flushfile 1 put 420 OperatorDict /for 1 put 421 OperatorDict /forall 1 put 422 OperatorDict /framedevice 1 put 423 OperatorDict /grestore 1 put 424 OperatorDict /grestoreall 1 put 425 OperatorDict /gsave 1 put 426 OperatorDict /handleerror 1 put 427 OperatorDict /if 1 put 428 OperatorDict /ifelse 1 put 429 OperatorDict /image 1 put 430 OperatorDict /imagemask 1 put 431 OperatorDict /initclip 1 put 432 OperatorDict /initgraphics 1 put 433 OperatorDict /initmatrix 1 put 434 OperatorDict /kshow 1 put 435 OperatorDict /lineto 1 put 436 OperatorDict /loop 1 put 437 OperatorDict /moveto 1 put 438 OperatorDict /newpath 1 put 439 OperatorDict /nulldevice 1 put 440 OperatorDict /pathforall 1 put 441 OperatorDict /print 1 put 442 OperatorDict /prompt 1 put 443 OperatorDict /put 1 put 444 OperatorDict /putinterval 1 put 445 OperatorDict /quit 1 put 446 OperatorDict /rcurveto 1 put 447 OperatorDict /renderbands 1 put 448 OperatorDict /repeat 1 put 449 OperatorDict /resetfile 1 put 450 OperatorDict /restore 1 put 451 OperatorDict /reversepath 1 put 452 OperatorDict /rlineto 1 put 453 OperatorDict /rmoveto 1 put 454 OperatorDict /rotate 1 put 455 OperatorDict /run 1 put 456 OperatorDict /scale 1 put 457 OperatorDict /setcachedevice 1 put 458 OperatorDict /setcachelimit 1 put 459 OperatorDict /setcacheparams 1 put 460 OperatorDict /setcharwidth 1 put 461 OperatorDict /setdash 1 put 462 OperatorDict /setdefaulttimeouts 1 put 463 OperatorDict /setdostartpage 1 put 464 OperatorDict /seteescratch 1 put 465 OperatorDict /setflat 1 put 466 OperatorDict /setfont 1 put 467 OperatorDict /setgray 1 put 468 OperatorDict /sethsbcolor 1 put 469 OperatorDict /setidlefonts 1 put 470 OperatorDict /setjobtimeout 1 put 471 OperatorDict /setlinecap 1 put 472 OperatorDict /setlinejoin 1 put 473 OperatorDict /setlinewidth 1 put 474 OperatorDict /setmargins 1 put 475 OperatorDict /setmatrix 1 put 476 OperatorDict /setmiterlimit 1 put 477 OperatorDict /setpacking 1 put 478 OperatorDict /setpagetype 1 put 479 OperatorDict /setprintname 1 put 480 OperatorDict /setrgbcolor 1 put 481 OperatorDict /setsccbatch 1 put 482 OperatorDict /setsccinteractive 1 put 483 OperatorDict /setscreen 1 put 484 OperatorDict /settransfer 1 put 485 OperatorDict /show 1 put 486 OperatorDict /showpage 1 put 487 OperatorDict /start 1 put 488 OperatorDict /stop 1 put 489 OperatorDict /store 1 put 490 OperatorDict /stroke 1 put 491 OperatorDict /strokepath 1 put 492 OperatorDict /translate 1 put 493 OperatorDict /widthshow 1 put 494 OperatorDict /write 1 put 495 OperatorDict /writehexstring 1 put 496 OperatorDict /writestring 1 put 497 498 end def 499 500 % 501 % Put an object on the stack and call Grabit. Output continues until stack 502 % is empty. For example, 503 % 504 % /letter load Grabit 505 % 506 % prints a listing of the letter procedure. 507 % 508 509 /Grabit { 510 /saveobj save def 511 GrabitDict begin 512 { 513 count 0 eq {exit} if 514 count {dup type exec} repeat 515 (\n) print flush 516 } loop 517 end 518 currentpoint % for hardcopy output 519 saveobj restore 520 moveto 521 } def 522