sys/src/cmd/postscript/grabit/grabit.ps

   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