Coverage report: /home/ellis/comp/core/lib/cli/terminfo.lisp

KindCoveredAll%
expression01674 0.0
branch0156 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; terminfo.lisp --- Lisp Terminfo
2
 
3
 ;; 
4
 
5
 ;; Copyright 2001 Paul Foley (mycroft@actrix.gen.nz)
6
 ;;
7
 ;; Permission is hereby granted, free of charge, to any person obtaining
8
 ;; a copy of this Software to deal in the Software without restriction,
9
 ;; including without limitation the rights to use, copy, modify, merge,
10
 ;; publish, distribute, sublicense, and/or sell copies of the Software,
11
 ;; and to permit persons to whom the Software is furnished to do so,
12
 ;; provided that the above copyright notice and this permission notice
13
 ;; are included in all copies or substantial portions of the Software.
14
 ;;
15
 ;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
16
 ;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
17
 ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
18
 ;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
19
 ;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20
 ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
21
 ;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
22
 ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
23
 ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
24
 ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
25
 ;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
26
 ;; DAMAGE.
27
 (in-package :cli/terminfo)
28
 
29
 (defvar *terminfo-directories* '("/etc/terminfo/"
30
                                  "/lib/terminfo/"
31
                                  "/usr/share/terminfo/"
32
                                  "/usr/share/misc/terminfo/")
33
   "Known locations of terminfo databases.")
34
 
35
 (defvar *terminfo* nil
36
   "The global terminfo structure used as a default variable
37
 for all commands with an optional terminfo parameter.  This 
38
 is set any time set-terminal is called.")
39
 
40
 (eval-when (:compile-toplevel :load-toplevel :execute)
41
   (defvar *capabilities* (make-hash-table :size 494)))
42
 
43
 (flet ((required-argument ()
44
          (error "A required argument was not supplied.")))
45
   (defstruct (terminfo
46
                (:print-function
47
                 (lambda (object stream depth)
48
                   (declare (ignore depth))
49
                   (print-unreadable-object (object stream :type t :identity t)
50
                     (format stream "~A" (first (terminfo-names object)))))))
51
     (number-format (required-argument) :type (member :16-bit :32-bit))
52
     (names (required-argument) :type list :read-only t)
53
     (booleans (required-argument) :type (simple-array (member t nil) (*)))
54
     (numbers (required-argument) :type (simple-array (signed-byte 32) (*)))
55
     (strings (required-argument) :type (simple-array t (*)))))
56
 
57
 (defun %capability (name terminfo)
58
   (let ((whatsit (gethash name *capabilities*)))
59
     (when (null whatsit)
60
       (error "Terminfo capability ~S doesn't exist." name))
61
     (if (or (null terminfo) (>= (cdr whatsit)
62
                                 (length (funcall (car whatsit) terminfo))))
63
         nil #| default |#
64
         (let ((value (aref (funcall (car whatsit) terminfo) (cdr whatsit))))
65
           (if (and (numberp value) (minusp value))
66
               nil
67
               value)))))
68
 
69
 (declaim (inline capability))
70
 (defun capability (name &optional (terminfo *terminfo*))
71
   "Return the contents of the terminfo database for the given parameter.
72
 Returns nil for undefined capabilities."
73
   (%capability name terminfo))
74
 
75
 (define-compiler-macro capability (&whole form
76
                                    name &optional (terminfo '*terminfo*))
77
   (if (not (keywordp name))
78
       form
79
       (let ((value (gensym))
80
             (tmp (gensym)))
81
         (unless (gethash name *capabilities*)
82
           (warn "Terminfo capability ~S doesn't exist." name))
83
         `(let ((,value (load-time-value (cons nil nil)))
84
                (,tmp ,terminfo))
85
            (if (eq (car ,value) ,tmp)
86
                (cdr ,value)
87
                (setf (car ,value) ,tmp
88
                      (cdr ,value) (%capability ,name ,tmp)))))))
89
 
90
 (defun capabilities (&optional (terminfo *terminfo*))
91
   "Return a list of capabilities for terminfo that are not nil."
92
   (let (result)
93
     (maphash
94
      (lambda (key value)
95
        (declare (ignore value))
96
        (when (capability key terminfo)
97
          (push key result)))
98
      *capabilities*)
99
     result))
100
 
101
 (defmacro defcap (name type index &optional docstring)
102
   "Along with defining the capability information:
103
 name 
104
 type: boolean integer or string
105
 index
106
 defcap automaticlly defines and exports a symbol-macro
107
 that calls the capability from *terminfo*."
108
   (let ((thing (ecase type              ; indicates the accessor into the terminfo structure
109
                  (boolean 'terminfo-booleans)
110
                  (integer 'terminfo-numbers)
111
                  (string 'terminfo-strings)))
112
         (symbol (intern (string name) "KEYWORD")))
113
     `(progn
114
        (eval-when (:compile-toplevel)
115
          ;; Mark capability as valid for the compiler-macro; needed when
116
          ;; compiling TPUTS.  If there's already a value present, leave
117
          ;; it alone, else just put any non-NIL value there; it'll get
118
          ;; fixed up when the file is loaded.
119
          (setf (gethash ,symbol *capabilities*)
120
                (gethash ,symbol *capabilities* t)))
121
        (setf (gethash ,symbol *capabilities*) (cons #',thing ,index))
122
        (define-symbol-macro ,name (capability ,symbol *terminfo*))
123
        ,(when docstring
124
           `(setf (documentation ',name 'variable) ,docstring))
125
        (export ',name "TERMINFO"))))
126
 
127
 (defcap auto-left-margin boolean 0)
128
 (defcap auto-right-margin boolean 1)
129
 (defcap no-esc-ctlc boolean 2)
130
 (defcap ceol-standout-glitch boolean 3)
131
 (defcap eat-newline-glitch boolean 4)
132
 (defcap erase-overstrike boolean 5)
133
 (defcap generic-type boolean 6)
134
 (defcap hard-copy boolean 7)
135
 (defcap has-meta-key boolean 8)
136
 (defcap has-status-line boolean 9)
137
 (defcap insert-null-glitch boolean 10)
138
 (defcap memory-above boolean 11)
139
 (defcap memory-below boolean 12)
140
 (defcap move-insert-mode boolean 13)
141
 (defcap move-standout-mode boolean 14)
142
 (defcap over-strike boolean 15)
143
 (defcap status-line-esc-ok boolean 16)
144
 (defcap dest-tabs-magic-smso boolean 17)
145
 (defcap tilde-glitch boolean 18)
146
 (defcap transparent-underline boolean 19)
147
 (defcap xon-xoff boolean 20)
148
 (defcap needs-xon-xoff boolean 21)
149
 (defcap prtr-silent boolean 22)
150
 (defcap hard-cursor boolean 23)
151
 (defcap non-rev-rmcup boolean 24)
152
 (defcap no-pad-char boolean 25)
153
 (defcap non-dest-scroll-region boolean 26)
154
 (defcap can-change boolean 27)
155
 (defcap back-color-erase boolean 28)
156
 (defcap hue-lightness-saturation boolean 29)
157
 (defcap col-addr-glitch boolean 30)
158
 (defcap cr-cancels-micro-mode boolean 31)
159
 (defcap has-print-wheel boolean 32)
160
 (defcap row-addr-glitch boolean 33)
161
 (defcap semi-auto-right-margin boolean 34)
162
 (defcap cpi-changes-res boolean 35)
163
 (defcap lpi-changes-res boolean 36)
164
 (defcap %columns integer 0)
165
 (defcap init-tabs integer 1)
166
 (defcap %lines integer 2)
167
 (defcap lines-of-memory integer 3)
168
 (defcap magic-cookie-glitch integer 4)
169
 (defcap padding-baud-rate integer 5)
170
 (defcap virtual-terminal integer 6)
171
 (defcap width-status-line integer 7)
172
 (defcap num-labels integer 8)
173
 (defcap label-height integer 9)
174
 (defcap label-width integer 10)
175
 (defcap max-attributes integer 11)
176
 (defcap maximum-windows integer 12)
177
 (defcap max-colors integer 13)
178
 (defcap max-pairs integer 14)
179
 (defcap no-color-video integer 15)
180
 (defcap buffer-capacity integer 16)
181
 (defcap dot-vert-spacing integer 17)
182
 (defcap dot-horz-spacing integer 18)
183
 (defcap max-micro-address integer 19)
184
 (defcap max-micro-jump integer 20)
185
 (defcap micro-col-size integer 21)
186
 (defcap micro-line-size integer 22)
187
 (defcap number-of-pins integer 23)
188
 (defcap output-res-char integer 24)
189
 (defcap output-res-line integer 25)
190
 (defcap output-res-horz-inch integer 26)
191
 (defcap output-res-vert-inch integer 27)
192
 (defcap print-rate integer 28)
193
 (defcap wide-char-size integer 29)
194
 (defcap buttons integer 30)
195
 (defcap bit-image-entwining integer 31)
196
 (defcap bit-image-type integer 32)
197
 
198
 (defcap back-tab string 0)
199
 (defcap bell string 1)
200
 (defcap carriage-return string 2)
201
 (defcap change-scroll-region string 3)
202
 (defcap clear-all-tabs string 4)
203
 (defcap clear-screen string 5)
204
 (defcap clr-eol string 6)
205
 (defcap clr-eos string 7)
206
 (defcap column-address string 8)
207
 (defcap command-character string 9)
208
 (defcap cursor-address string 10)
209
 (defcap cursor-down string 11)
210
 (defcap cursor-home string 12)
211
 (defcap cursor-invisible string 13)
212
 (defcap cursor-left string 14)
213
 (defcap cursor-mem-address string 15)
214
 (defcap cursor-normal string 16)
215
 (defcap cursor-right string 17)
216
 (defcap cursor-to-ll string 18)
217
 (defcap cursor-up string 19)
218
 (defcap cursor-visible string 20)
219
 (defcap delete-character string 21)
220
 (defcap delete-line string 22)
221
 (defcap dis-status-line string 23)
222
 (defcap down-half-line string 24)
223
 (defcap enter-alt-charset-mode string 25)
224
 (defcap enter-blink-mode string 26)
225
 (defcap enter-bold-mode string 27)
226
 (defcap enter-ca-mode string 28)
227
 (defcap enter-delete-mode string 29)
228
 (defcap enter-dim-mode string 30)
229
 (defcap enter-insert-mode string 31)
230
 (defcap enter-secure-mode string 32)
231
 (defcap enter-protected-mode string 33)
232
 (defcap enter-reverse-mode string 34)
233
 (defcap enter-standout-mode string 35)
234
 (defcap enter-underline-mode string 36)
235
 (defcap erase-chars string 37)
236
 (defcap exit-alt-charset-mode string 38)
237
 (defcap exit-attribute-mode string 39)
238
 (defcap exit-ca-mode string 40)
239
 (defcap exit-delete-mode string 41)
240
 (defcap exit-insert-mode string 42)
241
 (defcap exit-standout-mode string 43)
242
 (defcap exit-underline-mode string 44)
243
 (defcap flash-screen string 45)
244
 (defcap form-feed string 46)
245
 (defcap from-status-line string 47)
246
 (defcap init-1string string 48)
247
 (defcap init-2string string 49)
248
 (defcap init-3string string 50)
249
 (defcap init-file string 51)
250
 (defcap insert-character string 52)
251
 (defcap insert-line string 53)
252
 (defcap insert-padding string 54)
253
 (defcap key-backspace string 55)
254
 (defcap key-catab string 56)
255
 (defcap key-clear string 57)
256
 (defcap key-ctab string 58)
257
 (defcap key-dc string 59)
258
 (defcap key-dl string 60)
259
 (defcap key-down string 61)
260
 (defcap key-eic string 62)
261
 (defcap key-eol string 63)
262
 (defcap key-eos string 64)
263
 (defcap key-f0 string 65)
264
 (defcap key-f1 string 66)
265
 (defcap key-f10 string 67)
266
 (defcap key-f2 string 68)
267
 (defcap key-f3 string 69)
268
 (defcap key-f4 string 70)
269
 (defcap key-f5 string 71)
270
 (defcap key-f6 string 72)
271
 (defcap key-f7 string 73)
272
 (defcap key-f8 string 74)
273
 (defcap key-f9 string 75)
274
 (defcap key-home string 76)
275
 (defcap key-ic string 77)
276
 (defcap key-il string 78)
277
 (defcap key-left string 79)
278
 (defcap key-ll string 80)
279
 (defcap key-npage string 81)
280
 (defcap key-ppage string 82)
281
 (defcap key-right string 83)
282
 (defcap key-sf string 84)
283
 (defcap key-sr string 85)
284
 (defcap key-stab string 86)
285
 (defcap key-up string 87)
286
 (defcap keypad-local string 88)
287
 (defcap keypad-xmit string 89)
288
 (defcap lab-f0 string 90)
289
 (defcap lab-f1 string 91)
290
 (defcap lab-f10 string 92)
291
 (defcap lab-f2 string 93)
292
 (defcap lab-f3 string 94)
293
 (defcap lab-f4 string 95)
294
 (defcap lab-f5 string 96)
295
 (defcap lab-f6 string 97)
296
 (defcap lab-f7 string 98)
297
 (defcap lab-f8 string 99)
298
 (defcap lab-f9 string 100)
299
 (defcap meta-off string 101)
300
 (defcap meta-on string 102)
301
 (defcap newline string 103)
302
 (defcap pad-char string 104)
303
 (defcap parm-dch string 105)
304
 (defcap parm-delete-line string 106)
305
 (defcap parm-down-cursor string 107)
306
 (defcap parm-ich string 108)
307
 (defcap parm-index string 109)
308
 (defcap parm-insert-line string 110)
309
 (defcap parm-left-cursor string 111)
310
 (defcap parm-right-cursor string 112)
311
 (defcap parm-rindex string 113)
312
 (defcap parm-up-cursor string 114)
313
 (defcap pkey-key string 115)
314
 (defcap pkey-local string 116)
315
 (defcap pkey-xmit string 117)
316
 (defcap print-screen string 118)
317
 (defcap prtr-off string 119)
318
 (defcap prtr-on string 120)
319
 (defcap repeat-char string 121)
320
 (defcap reset-1string string 122)
321
 (defcap reset-2string string 123)
322
 (defcap reset-3string string 124)
323
 (defcap reset-file string 125)
324
 (defcap restore-cursor string 126)
325
 (defcap row-address string 127)
326
 (defcap save-cursor string 128)
327
 (defcap scroll-forward string 129)
328
 (defcap scroll-reverse string 130)
329
 (defcap set-attributes string 131)
330
 (defcap set-tab string 132)
331
 (defcap set-window string 133)
332
 (defcap tab string 134)
333
 (defcap to-status-line string 135)
334
 (defcap underline-char string 136)
335
 (defcap up-half-line string 137)
336
 (defcap init-prog string 138)
337
 (defcap key-a1 string 139)
338
 (defcap key-a3 string 140)
339
 (defcap key-b2 string 141)
340
 (defcap key-c1 string 142)
341
 (defcap key-c3 string 143)
342
 (defcap prtr-non string 144)
343
 (defcap char-padding string 145)
344
 (defcap acs-chars string 146)
345
 (defcap plab-norm string 147)
346
 (defcap key-btab string 148)
347
 (defcap enter-xon-mode string 149)
348
 (defcap exit-xon-mode string 150)
349
 (defcap enter-am-mode string 151)
350
 (defcap exit-am-mode string 152)
351
 (defcap xon-character string 153)
352
 (defcap xoff-character string 154)
353
 (defcap ena-acs string 155)
354
 (defcap label-on string 156)
355
 (defcap label-off string 157)
356
 (defcap key-beg string 158)
357
 (defcap key-cancel string 159)
358
 (defcap key-close string 160)
359
 (defcap key-command string 161)
360
 (defcap key-copy string 162)
361
 (defcap key-create string 163)
362
 (defcap key-end string 164)
363
 (defcap key-enter string 165)
364
 (defcap key-exit string 166)
365
 (defcap key-find string 167)
366
 (defcap key-help string 168)
367
 (defcap key-mark string 169)
368
 (defcap key-message string 170)
369
 (defcap key-move string 171)
370
 (defcap key-next string 172)
371
 (defcap key-open string 173)
372
 (defcap key-options string 174)
373
 (defcap key-previous string 175)
374
 (defcap key-print string 176)
375
 (defcap key-redo string 177)
376
 (defcap key-reference string 178)
377
 (defcap key-refresh string 179)
378
 (defcap key-replace string 180)
379
 (defcap key-restart string 181)
380
 (defcap key-resume string 182)
381
 (defcap key-save string 183)
382
 (defcap key-suspend string 184)
383
 (defcap key-undo string 185)
384
 (defcap key-sbeg string 186)
385
 (defcap key-scancel string 187)
386
 (defcap key-scommand string 188)
387
 (defcap key-scopy string 189)
388
 (defcap key-screate string 190)
389
 (defcap key-sdc string 191)
390
 (defcap key-sdl string 192)
391
 (defcap key-select string 193)
392
 (defcap key-send string 194)
393
 (defcap key-seol string 195)
394
 (defcap key-sexit string 196)
395
 (defcap key-sfind string 197)
396
 (defcap key-shelp string 198)
397
 (defcap key-shome string 199)
398
 (defcap key-sic string 200)
399
 (defcap key-sleft string 201)
400
 (defcap key-smessage string 202)
401
 (defcap key-smove string 203)
402
 (defcap key-snext string 204)
403
 (defcap key-soptions string 205)
404
 (defcap key-sprevious string 206)
405
 (defcap key-sprint string 207)
406
 (defcap key-sredo string 208)
407
 (defcap key-sreplace string 209)
408
 (defcap key-sright string 210)
409
 (defcap key-srsume string 211)
410
 (defcap key-ssave string 212)
411
 (defcap key-ssuspend string 213)
412
 (defcap key-sundo string 214)
413
 (defcap req-for-input string 215)
414
 (defcap key-f11 string 216)
415
 (defcap key-f12 string 217)
416
 (defcap key-f13 string 218)
417
 (defcap key-f14 string 219)
418
 (defcap key-f15 string 220)
419
 (defcap key-f16 string 221)
420
 (defcap key-f17 string 222)
421
 (defcap key-f18 string 223)
422
 (defcap key-f19 string 224)
423
 (defcap key-f20 string 225)
424
 (defcap key-f21 string 226)
425
 (defcap key-f22 string 227)
426
 (defcap key-f23 string 228)
427
 (defcap key-f24 string 229)
428
 (defcap key-f25 string 230)
429
 (defcap key-f26 string 231)
430
 (defcap key-f27 string 232)
431
 (defcap key-f28 string 233)
432
 (defcap key-f29 string 234)
433
 (defcap key-f30 string 235)
434
 (defcap key-f31 string 236)
435
 (defcap key-f32 string 237)
436
 (defcap key-f33 string 238)
437
 (defcap key-f34 string 239)
438
 (defcap key-f35 string 240)
439
 (defcap key-f36 string 241)
440
 (defcap key-f37 string 242)
441
 (defcap key-f38 string 243)
442
 (defcap key-f39 string 244)
443
 (defcap key-f40 string 245)
444
 (defcap key-f41 string 246)
445
 (defcap key-f42 string 247)
446
 (defcap key-f43 string 248)
447
 (defcap key-f44 string 249)
448
 (defcap key-f45 string 250)
449
 (defcap key-f46 string 251)
450
 (defcap key-f47 string 252)
451
 (defcap key-f48 string 253)
452
 (defcap key-f49 string 254)
453
 (defcap key-f50 string 255)
454
 (defcap key-f51 string 256)
455
 (defcap key-f52 string 257)
456
 (defcap key-f53 string 258)
457
 (defcap key-f54 string 259)
458
 (defcap key-f55 string 260)
459
 (defcap key-f56 string 261)
460
 (defcap key-f57 string 262)
461
 (defcap key-f58 string 263)
462
 (defcap key-f59 string 264)
463
 (defcap key-f60 string 265)
464
 (defcap key-f61 string 266)
465
 (defcap key-f62 string 267)
466
 (defcap key-f63 string 268)
467
 (defcap clr-bol string 269)
468
 (defcap clear-margins string 270)
469
 (defcap set-left-margin string 271)
470
 (defcap set-right-margin string 272)
471
 (defcap label-format string 273)
472
 (defcap set-clock string 274)
473
 (defcap display-clock string 275)
474
 (defcap remove-clock string 276)
475
 (defcap create-window string 277)
476
 (defcap goto-window string 278)
477
 (defcap hangup string 279)
478
 (defcap dial-phone string 280)
479
 (defcap quick-dial string 281)
480
 (defcap tone string 282)
481
 (defcap pulse string 283)
482
 (defcap flash-hook string 284)
483
 (defcap fixed-pause string 285)
484
 (defcap wait-tone string 286)
485
 (defcap user0 string 287)
486
 (defcap user1 string 288)
487
 (defcap user2 string 289)
488
 (defcap user3 string 290)
489
 (defcap user4 string 291)
490
 (defcap user5 string 292)
491
 (defcap user6 string 293)
492
 (defcap user7 string 294)
493
 (defcap user8 string 295)
494
 (defcap user9 string 296)
495
 (defcap orig-pair string 297)
496
 (defcap orig-colors string 298)
497
 (defcap initialize-color string 299)
498
 (defcap initialize-pair string 300)
499
 (defcap set-color-pair string 301)
500
 (defcap set-foreground string 302)
501
 (defcap set-background string 303)
502
 (defcap change-char-pitch string 304)
503
 (defcap change-line-pitch string 305)
504
 (defcap change-res-horz string 306)
505
 (defcap change-res-vert string 307)
506
 (defcap define-char string 308)
507
 (defcap enter-doublewide-mode string 309)
508
 (defcap enter-draft-quality string 310)
509
 (defcap enter-italics-mode string 311)
510
 (defcap enter-leftward-mode string 312)
511
 (defcap enter-micro-mode string 313)
512
 (defcap enter-near-letter-quality string 314)
513
 (defcap enter-normal-quality string 315)
514
 (defcap enter-shadow-mode string 316)
515
 (defcap enter-subscript-mode string 317)
516
 (defcap enter-superscript-mode string 318)
517
 (defcap enter-upward-mode string 319)
518
 (defcap exit-doublewide-mode string 320)
519
 (defcap exit-italics-mode string 321)
520
 (defcap exit-leftward-mode string 322)
521
 (defcap exit-micro-mode string 323)
522
 (defcap exit-shadow-mode string 324)
523
 (defcap exit-subscript-mode string 325)
524
 (defcap exit-superscript-mode string 326)
525
 (defcap exit-upward-mode string 327)
526
 (defcap micro-column-address string 328)
527
 (defcap micro-down string 329)
528
 (defcap micro-left string 330)
529
 (defcap micro-right string 331)
530
 (defcap micro-row-address string 332)
531
 (defcap micro-up string 333)
532
 (defcap order-of-pins string 334)
533
 (defcap parm-down-micro string 335)
534
 (defcap parm-left-micro string 336)
535
 (defcap parm-right-micro string 337)
536
 (defcap parm-up-micro string 338)
537
 (defcap select-char-set string 339)
538
 (defcap set-bottom-margin string 340)
539
 (defcap set-bottom-margin-parm string 341)
540
 (defcap set-left-margin-parm string 342)
541
 (defcap set-right-margin-parm string 343)
542
 (defcap set-top-margin string 344)
543
 (defcap set-top-margin-parm string 345)
544
 (defcap start-bit-image string 346)
545
 (defcap start-char-set-def string 347)
546
 (defcap stop-bit-image string 348)
547
 (defcap stop-char-set-def string 349)
548
 (defcap subscript-characters string 350)
549
 (defcap superscript-characters string 351)
550
 (defcap these-cause-cr string 352)
551
 (defcap zero-motion string 353)
552
 (defcap char-set-names string 354)
553
 (defcap key-mouse string 355)
554
 (defcap mouse-info string 356)
555
 (defcap req-mouse-pos string 357)
556
 (defcap get-mouse string 358)
557
 (defcap set-a-foreground string 359)
558
 (defcap set-a-background string 360)
559
 (defcap pkey-plab string 361)
560
 (defcap device-type string 362)
561
 (defcap code-set-init string 363)
562
 (defcap set0-des-seq string 364)
563
 (defcap set1-des-seq string 365)
564
 (defcap set2-des-seq string 366)
565
 (defcap set3-des-seq string 367)
566
 (defcap set-lr-margin string 368)
567
 (defcap set-tb-margin string 369)
568
 (defcap bit-image-repeat string 370)
569
 (defcap bit-image-newline string 371)
570
 (defcap bit-image-carriage-return string 372)
571
 (defcap color-names string 373)
572
 (defcap define-bit-image-region string 374)
573
 (defcap end-bit-image-region string 375)
574
 (defcap set-color-band string 376)
575
 (defcap set-page-length string 377)
576
 (defcap display-pc-char string 378)
577
 (defcap enter-pc-charset-mode string 379)
578
 (defcap exit-pc-charset-mode string 380)
579
 (defcap enter-scancode-mode string 381)
580
 (defcap exit-scancode-mode string 382)
581
 (defcap pc-term-options string 383)
582
 (defcap scancode-escape string 384)
583
 (defcap alt-scancode-esc string 385)
584
 (defcap enter-horizontal-hl-mode string 386)
585
 (defcap enter-left-hl-mode string 387)
586
 (defcap enter-low-hl-mode string 388)
587
 (defcap enter-right-hl-mode string 389)
588
 (defcap enter-top-hl-mode string 390)
589
 (defcap enter-vertical-hl-mode string 391)
590
 (defcap set-a-attributes string 392)
591
 (defcap set-pglen-inch string 393)
592
 
593
 (progn
594
   (defcap termcap-init2 string 394)
595
   (defcap termcap-reset string 395)
596
   (defcap magic-cookie-glitch-ul integer 33)
597
   (defcap backspaces-with-bs boolean 37)
598
   (defcap crt-no-scrolling boolean 38)
599
   (defcap no-correctly-working-cr boolean 39)
600
   (defcap carriage-return-delay integer 34)
601
   (defcap new-line-delay integer 35)
602
   (defcap linefeed-if-not-lf string 396)
603
   (defcap backspace-if-not-bs string 397)
604
   (defcap gnu-has-meta-key boolean 40)
605
   (defcap linefeed-is-newline boolean 41)
606
   (defcap backspace-delay integer 36)
607
   (defcap horizontal-tab-delay integer 37)
608
   (defcap number-of-function-keys integer 38)
609
   (defcap other-non-function-keys string 398)
610
   (defcap arrow-key-map string 399)
611
   (defcap has-hardware-tabs boolean 42)
612
   (defcap return-does-clr-eol boolean 43)
613
   (defcap acs-ulcorner string 400)
614
   (defcap acs-llcorner string 401)
615
   (defcap acs-urcorner string 402)
616
   (defcap acs-lrcorner string 403)
617
   (defcap acs-ltee string 404)
618
   (defcap acs-rtee string 405)
619
   (defcap acs-btee string 406)
620
   (defcap acs-ttee string 407)
621
   (defcap acs-hline string 408)
622
   (defcap acs-vline string 409)
623
   (defcap acs-plus string 410)
624
   (defcap memory-lock string 411)
625
   (defcap memory-unlock string 412)
626
   (defcap box-chars-1 string 413))
627
 
628
 (defconstant +16-bit-magic+ #o432)
629
 (defconstant +32-bit-magic+ #o1036
630
   "Per the term(5) man page, 32-bit magic
631
 should be #o542, however, everyone 
632
 apparently used 542 (#o1036) in practice.")
633
 
634
 (defun read-short (stream)
635
   (let ((n (+ (read-byte stream)
636
               (ash (read-byte stream) 8))))
637
     (if (> n  #x7FFF)
638
         (- n #x10000)
639
         n)))
640
 
641
 (defun read-int (stream)
642
   (let ((n (+ (read-byte stream)
643
               (ash (read-byte stream) 8)
644
               (ash (read-byte stream) 16)
645
               (ash (read-byte stream) 24))))
646
     (if (> n  #x7FFFFFFF)
647
         (- n #x100000000)
648
         n)))
649
 
650
 (defun read-string (stream)
651
   (do ((c (read-byte stream) (read-byte stream))
652
        (s '()))
653
       ((zerop c) (coerce (nreverse s) 'string))
654
     (push (code-char c) s)))
655
 
656
 (defun load-terminfo (name)
657
   (let ((name (concatenate 'string #-darwin (string (char name 0))
658
                            #+darwin (format nil "~X" (char-code (char name 0)))
659
                            "/" name))
660
         (number-format nil))
661
     (dolist (path (list* (merge-pathnames
662
                           (make-pathname :directory '(:relative ".terminfo"))
663
                           (user-homedir-pathname))
664
                          *terminfo-directories*))
665
       (with-open-file (stream (merge-pathnames name path)
666
                               :direction :input
667
                               :element-type '(unsigned-byte 8)
668
                               :if-does-not-exist nil)
669
         (when stream
670
           (flet ((read-number (stream)
671
                    (ecase number-format
672
                      (:16-bit (read-short stream))
673
                      (:32-bit (read-int stream)))))
674
             (let ((magic (read-short stream)))
675
               (cond
676
                 ((= magic +16-bit-magic+) (setf number-format :16-bit))
677
                 ((= magic +32-bit-magic+) (setf number-format :32-bit))
678
                 (t (error "Invalid file format #o~o (~A)" magic magic))))
679
             (let* ((sznames (read-short stream))
680
                    (szbooleans (read-short stream))
681
                    (sznumbers (read-short stream))
682
                    (szstrings (read-short stream))
683
                    (szstringtable (read-short stream))
684
                    (names (let ((string (read-string stream)))
685
                             (loop for i = 0 then (1+ j)
686
                                   as j = (position #\| string :start i)
687
                                   collect (subseq string i j) while j)))
688
                    (booleans (make-array szbooleans
689
                                          :element-type '(or t nil)
690
                                          :initial-element nil))
691
                    (numbers (make-array sznumbers
692
                                         :element-type '(signed-byte 32)
693
                                         :initial-element -1))
694
                    (strings (make-array szstrings
695
                                         :element-type '(signed-byte 16)
696
                                         :initial-element -1))
697
                    (stringtable (make-string szstringtable))
698
                    (count 0))
699
               (dotimes (i szbooleans)
700
                 (setf (aref booleans i) (not (zerop (read-byte stream)))))
701
               (when (oddp (+ sznames szbooleans))
702
                 (read-byte stream))
703
               (dotimes (i sznumbers)
704
                 (setf (aref numbers i) (read-number stream)))
705
               (dotimes (i szstrings)
706
                 (unless (minusp (setf (aref strings i) (read-short stream)))
707
                   (incf count)))
708
               (dotimes (i szstringtable)
709
                 (setf (char stringtable i) (code-char (read-byte stream))))
710
               (let ((xtrings (make-array szstrings :initial-element nil)))
711
                 (dotimes (i szstrings)
712
                   (unless (minusp (aref strings i))
713
                     (setf (aref xtrings i)
714
                           (subseq stringtable (aref strings i)
715
                                   (position #\Null stringtable
716
                                             :start (aref strings i))))))
717
                 (setq strings xtrings))
718
               (return (make-terminfo :number-format number-format
719
                                      :names names :booleans booleans
720
                                      :numbers numbers :strings strings)))))))))
721
 
722
 (defun xform (value format flags width precision)
723
   (let ((temp (make-array 8 :element-type 'character :fill-pointer 0
724
                           :adjustable t)))
725
     (flet ((shift (n c sign)
726
              (let ((len (length temp)) (s 0))
727
                (when (and sign (> len 0) (char= (char temp 0) #\-))
728
                  (setq len (1- len) s 1))
729
                (when (> (+ len n s) (array-dimension temp 0))
730
                  (adjust-array temp (+ len n 5)))
731
                (incf (fill-pointer temp) n)
732
                (replace temp temp
733
                         :start1 (+ n s) :start2 s :end2 (+ s len))
734
                (fill temp c :start s :end (+ n s)))))
735
       (format temp (ecase format
736
                      (#\d "~D") (#\o "~O") (#\x "~(~X~)") (#\X "~:@(~X~)")
737
                      (#\s "~A"))
738
               value)
739
       (when (position format "doxX")
740
         (let ((len (length temp)))
741
           (when (minusp value) (decf len))
742
           (when (< len precision) (shift (- precision len) #\0 t)))
743
         (when (logbitp 0 flags)
744
           (case format
745
             (#\o (unless (char= (char temp (if (minusp value) 1 0)) #\0)
746
                    (shift 1 #\0 t)))
747
             (#\x (shift 1 #\x t) (shift 1 #\0 t))
748
             (#\X (shift 1 #\X t) (shift 1 #\0 t))))
749
         (unless (minusp value)
750
           (cond ((logbitp 1 flags) (shift 1 #\+ nil))
751
                 ((logbitp 2 flags) (shift 1 #\Space nil)))))
752
       (when (and (eql format #\s) (> precision 0) (> (length temp) precision))
753
         (setf (fill-pointer temp) precision))
754
       (when (< (length temp) width)
755
         (if (logbitp 3 flags)
756
             (shift (- width (length temp)) #\Space nil)
757
             (dotimes (i (- width (length temp)))
758
               (vector-push-extend #\Space temp))))
759
       temp)))
760
 
761
 (defun skip-forward (stream flag)
762
   (do ((level 0) (c (read-char stream nil) (read-char stream nil)))
763
       ((null c))
764
     (when (char= c #\%)
765
       (setq c (read-char stream))
766
       (cond ((char= c #\?) (incf level))
767
             ((char= c #\;) (when (minusp (decf level)) (return t)))
768
             ((and flag (char= c #\e) (= level 0)) (return t))))))
769
 
770
 (defun tparm (string &rest args)
771
   "Return the string representing the command and arguments."
772
   (when (null string) (return-from tparm ""))
773
   (with-output-to-string (out)
774
     (with-input-from-string (in string)
775
       (do ((stack '()) (flags 0) (width 0) (precision 0) (number 0)
776
            (dvars (make-array 26 :element-type '(unsigned-byte 8)
777
                               :initial-element 0))
778
            (svars (load-time-value
779
                    (make-array 26 :element-type '(unsigned-byte 8)
780
                                :initial-element 0)))
781
            (c (read-char in nil) (read-char in nil)))
782
           ((null c))
783
         (cond ((char= c #\%)
784
                (setq c (read-char in) flags 0 width 0 precision 0)
785
                (tagbody
786
                 state0
787
                   (case c
788
                     (#\% (princ c out) (go terminal))
789
                     (#\: (setq c (read-char in)) (go state2))
790
                     (#\+ (go state1))
791
                     (#\- (go state1))
792
                     (#\# (go state2))
793
                     (#\Space (go state2))
794
                     ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) (go state3))
795
                     (#\d (go state5))
796
                     (#\o (go state6))
797
                     ((#\X #\x) (go state7))
798
                     (#\s (go state8))
799
                     (#\c (princ (code-char (pop stack)) out) (go terminal))
800
                     (#\p (go state9))
801
                     (#\P (go state10))
802
                     (#\g (go state11))
803
                     (#\' (go state12))
804
                     (#\{ (go state13))
805
                     (#\l (push (length (pop stack)) stack) (go terminal))
806
                     (#\* (push (* (pop stack) (pop stack)) stack)
807
                          (go terminal))
808
                     (#\/ (push (let ((n (pop stack))) (truncate (pop stack) n)) stack)
809
                          (go terminal))
810
                     (#\m (push (let ((n (pop stack))) (mod (pop stack) n))
811
                                stack)
812
                          (go terminal))
813
                     (#\& (push (logand (pop stack) (pop stack)) stack)
814
                          (go terminal))
815
                     (#\| (push (logior (pop stack) (pop stack)) stack)
816
                          (go terminal))
817
                     (#\^ (push (logxor (pop stack) (pop stack)) stack)
818
                          (go terminal))
819
                     (#\= (push (if (= (pop stack) (pop stack)) 1 0) stack)
820
                          (go terminal))
821
                     (#\> (push (if (<= (pop stack) (pop stack)) 1 0) stack)
822
                          (go terminal))
823
                     (#\< (push (if (>= (pop stack) (pop stack)) 1 0) stack)
824
                          (go terminal))
825
                     (#\A (push (if (or (zerop (pop stack))
826
                                        (zerop (pop stack)))
827
                                    0
828
                                    1)
829
                                stack)
830
                          (go terminal))
831
                     (#\O (push (if (and (zerop (pop stack))
832
                                         (zerop (pop stack)))
833
                                    0
834
                                    1)
835
                                stack)
836
                          (go terminal))
837
                     (#\! (push (if (zerop (pop stack)) 1 0) stack)
838
                          (go terminal))
839
                     (#\~ (push (logand #xFF (lognot (pop stack))) stack)
840
                          (go terminal))
841
                     (#\i (when args
842
                            (incf (first args))
843
                            (when (cdr args)
844
                              (incf (second args))))
845
                          (go terminal))
846
                     (#\? (go state14))
847
                     (#\t (go state15))
848
                     (#\e (go state16))
849
                     (#\; (go state17))
850
                     (otherwise (error "Unknown %-control character: ~C" c)))
851
                 state1
852
                   (let ((next (peek-char nil in nil)))
853
                     (when (position next "0123456789# +-doXxs")
854
                       (go state2)))
855
                   (if (char= c #\+)
856
                       (push (+ (pop stack) (pop stack)) stack)
857
                       (push (let ((n (pop stack))) (- (pop stack) n)) stack))
858
                   (go terminal)
859
                 state2
860
                   (case c
861
                     (#\# (setf flags (logior flags 1)))
862
                     (#\+ (setf flags (logior flags 2)))
863
                     (#\Space (setf flags (logior flags 4)))
864
                     (#\- (setf flags (logior flags 8)))
865
                     ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
866
                      (go state3))
867
                     (t (go blah)))
868
                   (setf c (read-char in))
869
                   (go state2)
870
                 state3
871
                   (setf width (digit-char-p c))
872
                 state3-loop
873
                   (setf c (read-char in))
874
                   (case c
875
                     ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
876
                      (setf width (+ (* width 10) (digit-char-p c)))
877
                      (go state3-loop))
878
                     (#\. (setf c (read-char in)) (go state4)))
879
                   (go blah)
880
                 state4
881
                   (setf precision (digit-char-p c))
882
                 state4-loop
883
                   (setf c (read-char in))
884
                   (case c
885
                     ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
886
                      (setf precision (+ (* precision 10) (digit-char-p c)))
887
                      (go state4-loop)))
888
                   (go blah)
889
                 blah
890
                   (case c
891
                     (#\d (go state5))
892
                     (#\o (go state6))
893
                     ((#\X #\x) (go state7))
894
                     (#\s (go state8))
895
                     (otherwise (error "Unknown %-control character: ~C" c)))
896
                 state5
897
                 state6
898
                 state7
899
                 state8
900
                   (princ (xform (pop stack) c flags width precision) out)
901
                   (go terminal)
902
                 state9
903
                   (let* ((i (digit-char-p (read-char in)))
904
                          (a (nth (1- i) args)))
905
                     (etypecase a
906
                       (character (push (char-code a) stack))
907
                       (integer (push a stack))
908
                       (string (push a stack))))
909
                   (go terminal)
910
                 state10
911
                   (let ((var (read-char in)))
912
                     (cond ((char<= #\a var #\z)
913
                            (setf (aref dvars (- (char-code var)
914
                                                 (char-code #\a)))
915
                                  (pop stack)))
916
                           ((char<= #\A var #\Z)
917
                            (setf (aref svars (- (char-code var)
918
                                                 (char-code #\A)))
919
                                  (pop stack)))
920
                           (t (error "Illegal variable name: ~C" var))))
921
                   (go terminal)
922
                 state11
923
                   (let ((var (read-char in)))
924
                     (cond ((char<= #\a var #\z)
925
                            (push (aref dvars (- (char-code var)
926
                                                 (char-code #\a)))
927
                                  stack))
928
                           ((char<= #\A var #\Z)
929
                            (push (aref svars (- (char-code var)
930
                                                 (char-code #\A)))
931
                                  stack))
932
                           (t (error "Illegal variable name: ~C" var))))
933
                   (go terminal)
934
                 state12
935
                   (push (char-code (read-char in)) stack)
936
                   (unless (char= (read-char in) #\')
937
                     (error "Invalid character constant"))
938
                   (go terminal)
939
                 state13
940
                   (setq number 0)
941
                 state13-loop
942
                   (setq c (read-char in))
943
                   (let ((n (digit-char-p c)))
944
                     (cond (n (setq number (+ (* 10 number) n))
945
                              (go state13-loop))
946
                           ((char= c #\})
947
                            (push number stack)
948
                            (go terminal))))
949
                   (error "Invalid integer constant")
950
                 state14
951
                   (go terminal)
952
                 state15
953
                   (when (/= (pop stack) 0)
954
                     (go terminal))
955
                   (skip-forward in t)
956
                   (go terminal)
957
                 state16
958
                   (skip-forward in nil)
959
                 state17
960
                 terminal
961
                   #| that's all, folks |#))
962
               (t (princ c out)))))))
963
 
964
 (defgeneric stream-fileno (stream)
965
   (:method ((stream stream))
966
     nil)
967
   (:method ((stream sb-sys:fd-stream))
968
     (sb-sys:fd-stream-fd stream))
969
   (:method ((stream two-way-stream))
970
     (stream-fileno (two-way-stream-output-stream stream)))
971
   (:method ((stream synonym-stream))
972
     (stream-fileno (symbol-value (synonym-stream-symbol stream))))
973
   (:method ((stream echo-stream))
974
     (stream-fileno (echo-stream-output-stream stream)))
975
   (:method ((stream broadcast-stream))
976
     (stream-fileno (first (broadcast-stream-streams stream))))
977
   #+sb-simple-streams
978
   (:method ((stream sb-simple-streams:simple-stream))
979
     (let ((fd (sb-simple-streams:stream-output-handle stream)))
980
       (if (or (null fd) (integerp fd)) fd (sb-sys::fd-stream-fd fd))))
981
   )
982
 
983
 (defun terminal-size (&optional (stream *standard-output*))
984
   (declare (type stream stream))
985
   (sb-alien:with-alien ((winsz winsize))
986
     (if (zerop (sb-posix:ioctl (sb-sys:fd-stream-fd stream) +TIOCGWINSZ+ (sb-alien:cast winsz (* t))))
987
         (values (sb-alien:slot winsz 'std/os::row)
988
                 (sb-alien:slot winsz 'std/os::col))
989
         (values nil nil))))
990
 
991
 (defstruct padding time force line-multiplier)
992
 
993
 (defun decode-padding (string &optional (junk-allowed nil))
994
   "Decode padding from string.
995
 
996
 Return the values of
997
 - padding time in milliseconds (could have a tenth)
998
 - whether or not to force the padding
999
 - whether or not to multiply by the lines affected
1000
 - end of padding #\> index into string
1001
 e.g. \"<10.5*/>\"   =>   (values (make-padding 10.5 T T) 7)
1002
 
1003
 Setting junk-allowed to t will decode a padding string
1004
 that does not start with #\<.
1005
 e.g. \"<10.5/>\"   => (values (make-padding 10.5 T NIL) 7)"
1006
   (declare (type string string))
1007
   (unless (find #\> string)
1008
     (error "Invalid padding specification"))
1009
   (do ((start (if junk-allowed
1010
                   (1+ (position #\< string))
1011
                   1))
1012
        (time 0)
1013
        (pad-end)
1014
        (force)
1015
        (line-multiplier))
1016
       (pad-end
1017
        (values (make-padding :time time :force force :line-multiplier line-multiplier) pad-end))
1018
     (let ((c (elt string start)))
1019
       (cond
1020
         ((and (char= c #\*)
1021
               (not line-multiplier))
1022
          (setf line-multiplier t
1023
                start (1+ start)))
1024
         ((and (char= c #\/)
1025
               (not force))
1026
          (setf force t
1027
                start (1+ start)))
1028
         ((char= c #\>)
1029
          (setf pad-end (1+ start)))
1030
         ((and (digit-char-p (elt string start))
1031
               (zerop time))
1032
          (let* ((end (position-if-not #'digit-char-p string :start start))
1033
                 (ms (parse-integer string :start start :end end)))
1034
            (if (char= (elt string end) #\.)
1035
                (setf time (+ ms (* 0.1 (digit-char-p
1036
                                         (elt string (1+ end)))))
1037
                      start (+ end 2))
1038
                (setf time ms
1039
                      start end))))
1040
         (t (error "Invalid padding specification"))))))
1041
 
1042
 (defun strings-and-delays (string)
1043
   "Decompose the command string and delays into a list of
1044
 strings and delay time padding structs.
1045
 
1046
 The delay time entries are lists of the delay in milliseconds,
1047
 t or nil for / which indicates a delay time that needs to be forced,
1048
 and t or nil for * which indicates a multiplier for lines affected."
1049
   (declare (type string string))
1050
   (do ((strings-and-delays ())
1051
        (start 0)
1052
        (length (length string)))
1053
       ((>= start length) (nreverse strings-and-delays))
1054
     (let ((found (search "$<" string :start2 start)))
1055
       (if found
1056
           (progn
1057
             (when (/= found start)
1058
               (push (subseq string start found)
1059
                     strings-and-delays)
1060
               (setf start found))
1061
             (multiple-value-bind
1062
                   (padding end)
1063
                 (decode-padding (subseq string (1+ found)))
1064
               (push padding strings-and-delays)
1065
               (incf start (1+ end))))
1066
           (return (append (nreverse strings-and-delays)
1067
                           (list (subseq string start))))))))
1068
 ;; TI> (ti::strings-and-delays "A{3}$<10.5*>B{2}")
1069
 ;; ("A{3}" #S(PADDING :TIME 10.5 :FORCE NIL :LINE-MULTIPLIER T) "B{2}")
1070
 ;; TI> (ti::strings-and-delays "A{3}$<10.5*>B{2}$<5>c")
1071
 ;; ("A{3}" #S(PADDING :TIME 10.5 :FORCE NIL :LINE-MULTIPLIER T) "B{2}"
1072
 ;;  #S(PADDING :TIME 5 :FORCE NIL :LINE-MULTIPLIER NIL) "c")
1073
 ;; TI> (ti::strings-and-delays "A{3}$<10.5*>B{2}$<5/>c")
1074
 ;; ("A{3}" #S(PADDING :TIME 10.5 :FORCE NIL :LINE-MULTIPLIER T) "B{2}"
1075
 ;;  #S(PADDING :TIME 5 :FORCE T :LINE-MULTIPLIER NIL) "c")
1076
 ;; TI> (ti::strings-and-delays "A{3}")
1077
 ;; ("A{3}")
1078
 
1079
 (defun print-padding (padding &key
1080
                                 stream
1081
                                 baud-rate (affected-lines 1)
1082
                                 (terminfo *terminfo*))
1083
   "Print a padding definition to the stream depending
1084
 on the capability of the terminfo data. 
1085
 
1086
 If stream is nil, the padding characters or delay time
1087
 in ms will be returned.  If a stream is provided, the
1088
 padding characters will be written, or the function will
1089
 sleep for the specified time."
1090
   (declare (type padding padding))
1091
   ;; Decide whether to apply padding:
1092
   (when (or (padding-force padding)
1093
             ;; TODO: capability doesn't indicate activation...
1094
             (not (capability :xon-xoff terminfo)))
1095
     (when (let ((pb (capability :padding-baud-rate terminfo)))
1096
             (and baud-rate (or (null pb) (> baud-rate pb))))
1097
       (cond ((capability :no-pad-char terminfo)
1098
              (if stream
1099
                  (progn (finish-output stream)
1100
                         (sleep (* (padding-time padding) 0.001 affected-lines)))
1101
                  (* (padding-time padding) affected-lines)))
1102
             (t
1103
              (let ((tmp (capability :pad-char terminfo))
1104
                    (null-count (ceiling (* baud-rate (padding-time padding) 1000 affected-lines) 100000)))
1105
                (let ((pad (or (and tmp (schar tmp 0))
1106
                               #\Null)))
1107
                  (if stream
1108
                      (dotimes (i null-count)
1109
                        (princ pad stream))
1110
                      (make-string null-count :initial-element pad)))))))))
1111
 
1112
 (defmacro tputs (string &rest args)
1113
   "Given a string and its arguments, compose the appropriate command 
1114
 for the terminfo terminal and put it into the stream, or return
1115
 a list of strings and delay times when stream is nil.
1116
 Keyword arguments are passed on to the executing function, and include:
1117
  (terminfo *terminfo*)
1118
  (stream *terminal-io*)
1119
  baud-rate
1120
  (affected-lines 1))
1121
 "
1122
     ;; There's got to be a better way...
1123
   (let ((args (subseq args 0 (position-if #'keywordp args)))
1124
         (keywords (member-if #'keywordp args)))
1125
     `(%tputs ,(if args `(tparm ,string ,@args)
1126
                   string)
1127
              ,@keywords)))
1128
 
1129
 (defun %tputs (string &key
1130
                         (terminfo *terminfo*)
1131
                         (stream *terminal-io*)
1132
                         baud-rate
1133
                         (affected-lines 1))
1134
   "Print the control string to an output stream.  If stream is nil,
1135
 a list of strings and delay times is returned.
1136
 String must already have been operated upon by tparm if necessary."
1137
   (declare (type fixnum affected-lines))
1138
   (when string
1139
     (let ((strings-and-delays (strings-and-delays string))
1140
           (result ()))
1141
       (dolist (item strings-and-delays (and (not stream) (nreverse result)))
1142
         (let ((printed
1143
                (typecase item
1144
                  (padding (print-padding item :baud-rate baud-rate :stream stream :terminfo terminfo :affected-lines affected-lines))
1145
                  (string (if stream (princ item stream) item)))))
1146
           (unless stream
1147
             (push printed result)))))))
1148
 
1149
 (defun set-terminal (&optional name)
1150
   "Load the terminfo database specified, or defined per 
1151
 the TERM environment variable."
1152
   (setf *terminfo* (load-terminfo (or name
1153
                                       #+SBCL
1154
                                       (sb-ext:posix-getenv "TERM")
1155
                                       "dumb"))))