utilities.el 14.1 KB
Newer Older
1
2
3
4
5
6
7
8
;;;;; -*- emacs-lisp -*-
;;;;; $Id$
;;;;; Copyright (C) 1996  Lysator Academic Computer Association.
;;;;;
;;;;; This file is part of the LysKOM server.
;;;;; 
;;;;; LysKOM is free software; you can redistribute it and/or modify it
;;;;; under the terms of the GNU General Public License as published by 
9
;;;;; the Free Software Foundation; either version 2, or (at your option) 
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
;;;;; any later version.
;;;;; 
;;;;; LysKOM is distributed in the hope that it will be useful, but WITHOUT
;;;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;;;;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
;;;;; for more details.
;;;;; 
;;;;; You should have received a copy of the GNU General Public License
;;;;; along with LysKOM; see the file COPYING.  If not, write to
;;;;; Lysator, c/o ISY, Linkoping University, S-581 83 Linkoping, SWEDEN,
;;;;; or the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, 
;;;;; MA 02139, USA.
;;;;;
;;;;; Please mail bug reports to bug-lyskom@lysator.liu.se. 
;;;;;
;;;; ================================================================
;;;; ================================================================
;;;;
28
;;;; File: utilities.el
29
30
31
32
33
34
35
36
37
38
39
;;;;
;;;; This file contains general lisp utility functions and
;;;; lyskom-specific utility functions (such as date formatting and
;;;; minibuffer reading)
;;;;


(setq lyskom-clientversion-long
      (concat lyskom-clientversion-long
	      "$Id$\n"))

David Byers's avatar
David Byers committed
40
41
42
43
44
45
46
47
48
49
50
51
52
;;;
;;; Need Per Abrahamsens widget and custom packages There should be a
;;; better way of doing this, but I'll be darned if I know how. The
;;; various files need to be loaded in a very specific order.
;;;

(require 'custom)
(require 'widget)
(require 'wid-edit)
(require 'wid-browse)
(require 'cus-edit)
(require 'cus-face)

53
54
55
56
57
58
59
60
61
62
63
64
65
66

;;;
;;; Lisp utility functions
;;;

(defsubst listify-vector (vector)
  "Turn VECTOR into a list"
  (append vector nil))

(defun reverse-assoc (key cache)
  "Same as assoc, but searches on last element in a list"
  (reverse (assoc key (mapcar (function reverse) cache))))


67
68
69
70
71
72
(defun nfirst (n list)
  "Return a list of the N first elements of LIST."
  (if (or (<= n 0) (not list))
      nil
    (cons (car list) (nfirst (1- n) (cdr list)))))

73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
;;;
;;; +++ FIXME: If cl.el can be guaranteed, this is pointless.
;;;

(defun lyskom-butlast (x &optional n)
  "Returns a copy of LIST with the last N elements removed."
  (if (and n (<= n 0)) x
    (lyskom-nbutlast (copy-sequence x) n)))

(defun lyskom-nbutlast (x &optional n)
  "Modifies LIST to remove the last N elements."
  (let ((m (length x)))
    (or n (setq n 1))
    (and (< n m)
	 (progn
	   (if (> n 0) (setcdr (nthcdr (- (1- m) n) x) nil))
	   x))))
90

91
92
93
94
95
96
(defun skip-first-zeros (list)
  (while (and list (zerop (car list)))
    (setq list (cdr list)))
  list)


97
98
99
100
101
102
(defun filter-list (test list)
  (cond ((null list) '())
	((apply test (car list) nil)
	 (cons (car list) (filter-list test (cdr list))))
	(t (filter-list test (cdr list)))))

103
104
105
106
107
108
109
;;;============================================================
;;;
;;; Utility functions.
;;;
;;; These should be shared in LysKOM
;;;

110
(lyskom-provide-function copy-tree (l)
111
112
113
114
115
  "Recursively copy the list L"
  (cond ((atom l) l)
        (t (cons (copy-tree (car l))
                 (copy-tree (cdr l))))))

David Byers's avatar
David Byers committed
116
117
118
119
120
(lyskom-provide-function functionp (obj)
  "Returns t if OBJ is a function, nil otherwise."
  (cond
   ((symbolp obj) (fboundp obj))
   ((subrp obj))
121
   ((byte-code-function-p obj))
David Byers's avatar
David Byers committed
122
123
124
   ((consp obj)
    (if (eq (car obj) 'lambda) (listp (car (cdr obj)))))
   (t nil)))
125
126
127
128
129
130
131
132
133
134
135
136


(defun regexpp (re)
  "Return non-nil if RE looks like a valid regexp."
  (let ((result t))
    (save-match-data
      (condition-case nil
          (string-match re "")
        (error (setq result nil))))
    result))


137
138
139
140
141
142
143
144
145
(defun mapcar2 (fn seq1 seq2)
  (let (result)
    (while (and seq1 seq2)
      (setq result (cons (funcall fn (car seq1) (car seq2)) result))
      (setq seq1 (cdr seq1)
            seq2 (cdr seq2)))
    (nreverse result)))


146
147
148
149
150
151
152
(defun lyskom-maxint ()
  (let ((n 1) (l nil))
    (while (> n 0)
      (setq l (cons n l))
      (setq n (* 2 n)))
    (apply '+ l)))

153
154
155
156
157
(defun lyskom-emacs-version ()
  (cond ((string-match "^XEmacs" (emacs-version)) 'xemacs)
	(t 'emacs)))


David Byers's avatar
David Byers committed
158
159
(defvar lyskom-apo-timeout 0
  "Current millisecond timeout value for accept-process-output")
160

David Byers's avatar
David Byers committed
161
162
(defvar lyskom-apo-timeout-index 0
  "Index in lyskom-apo-timeout-vector-max where last timeout is")
163

David Byers's avatar
David Byers committed
164
165
166
(defconst lyskom-apo-timeout-vector
  [0 1000 1000 2000 3000 5000 8000 13000 21000 34000 55000 89000 144000 233000 377000 610000]
  "Vector of timeout values (usecs) for accept-process-output")
167

David Byers's avatar
David Byers committed
168
169
(defconst lyskom-apo-timeout-vector-max (1- (length lyskom-apo-timeout-vector))
  "Maximum index in lyskom-apo-timeout-vector")
170

David Byers's avatar
David Byers committed
171
172
173
174
175
176
(defsubst lyskom-next-apo-timeout ()
  (if (< lyskom-apo-timeout-index lyskom-apo-timeout-vector-max)
      (setq lyskom-apo-timeout
            (aref lyskom-apo-timeout-vector
                  (setq lyskom-apo-timeout-index
                        (1+ lyskom-apo-timeout-index))))))
177

David Byers's avatar
David Byers committed
178
179
180
(defsubst lyskom-reset-apo-timeout ()
  (setq lyskom-apo-timeout-index -1)
  (setq lyskom-apo-timeout 0))
181

David Byers's avatar
David Byers committed
182
183
184
185
(defsubst lyskom-accept-process-output ()
  "Call accept-process-output with the correct timeout values."
  (lyskom-next-apo-timeout)
  (accept-process-output nil 0 lyskom-apo-timeout))
186
187


188
189
190
191
;;;
;;; LysKOM utility functions
;;;

David Byers's avatar
David Byers committed
192
193
194
195
196
197
198
199
200
201
;;;
;;; WARNING!
;;;
;;; The following variable is *important* if you fuck it up in any
;;; way, the functions used to read conference names won't work. So if
;;; you change it, try to work one character at a time, and when
;;; you're done, run through the mappings of all 256 characters to
;;; make sure they look OK.
;;;

202
(defvar lyskom-default-collate-table
David Byers's avatar
David Byers committed
203
204
  "\000\001\002\003\004\005\006\007\010\011\012\013\014\015\016\017\020\021\022\023\024\025\026\027\030\031\032\033\034\035\036\037 !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]~\200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217\220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237!AAAA[]ACEEEEIIIINOOOO\\OUUUYYAAAA[]ACEEEEIIIINOOOO\\OUUUYY"
  "String mapping lowercase to uppercase and equivalents to each others.")
205
206
207
208
209



(defsubst lyskom-unicase-char (c)
  "Smash case and diacritical marks on c." 
David Byers's avatar
David Byers committed
210
  (aref lyskom-collate-table (char-to-int c)))
211
212
213

(defun lyskom-unicase (s)
  "Smash case and diacritical marks of all chars in s." 
214
  (lyskom-save-excursion
David Byers's avatar
X    
David Byers committed
215
   (set-buffer lyskom-buffer)
216
217
218
219
220
221
   (let ((l (length s))
	 (s2 (copy-sequence s)))
     (while (> l 0)
       (setq l (1- l))
       (aset s2 l (lyskom-unicase-char (aref s2 l))))
     s2)))
David Byers's avatar
David Byers committed
222

David Byers's avatar
X    
David Byers committed
223
224
225
226
227
228
229
230
231
232
233
(defun lyskom-string-assoc (key list)
  "Return non-nil if KEY is the same string as the car of an element of LIST.
The value is actually the element of LIST whose car equals KEY."
  (let ((s (downcase key))
        (result nil))
    (while list
      (when (string= s (downcase (car (car list))))
        (setq result (car list))
        (setq list nil))
      (setq list (cdr list)))
    result))
David Byers's avatar
David Byers committed
234

David Byers's avatar
X    
David Byers committed
235
236
(defun lyskom-set-default (sym val)
  "Set the value of SYM in the LysKOM buffer to VAL."
David Byers's avatar
David Byers committed
237
  (save-excursion
David Byers's avatar
X    
David Byers committed
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
    (set-buffer (or (and (boundp 'lyskom-buffer)
                         (bufferp lyskom-buffer)
                         (buffer-live-p lyskom-buffer)
                         lyskom-buffer)
                    (current-buffer)))
    (set sym val)))

(defun lyskom-default-value (sym)
  "Get the value of SYM in the LysKOM buffer"
  (save-excursion
    (set-buffer (or (and (boundp 'lyskom-buffer)
                         (bufferp lyskom-buffer)
                         (buffer-live-p lyskom-buffer)
                         lyskom-buffer)
                    (current-buffer)))
David Byers's avatar
David Byers committed
253
254
    (symbol-value sym)))

David Byers's avatar
X    
David Byers committed
255
256
(defun lyskom-default-value-safe (sym)
  "Get the value of SYM in the LysKOM buffer"
David Byers's avatar
David Byers committed
257
  (save-excursion
David Byers's avatar
X    
David Byers committed
258
259
260
261
262
263
    (set-buffer (or (and (boundp 'lyskom-buffer)
                         (bufferp lyskom-buffer)
                         (buffer-live-p lyskom-buffer)
                         lyskom-buffer)
                    (current-buffer)))
    (and (boundp sym) (symbol-value sym))))
264

David Byers's avatar
David Byers committed
265

266
267
268
269
270
271
272
273
274
275
276
;;; ======================================================================
;;; Display device management
;;;


;;; Definition of some useful functions from XEmacs

(lyskom-provide-function console-type (&optional console)
  (or window-system 'tty))

(lyskom-provide-function device-class (&optional device)
David Kågedal's avatar
David Kågedal committed
277
278
279
280
281
282
283
  (condition-case nil
      (if (x-display-grayscale-p)
	  (if (x-display-color-p)
	      'color
	    'grayscale)
	'mono)
    (error 'mono)))
284
285
286
287
288
289
290
291
292
293
294
295
296


(lyskom-provide-function frame-property (frame property &optional default)
  (or (cdr (assq property (frame-parameters frame)))
      default))


;;; XEmacs doesn't seem to have a background-mode frame property

(defun lyskom-background-mode ()
  (frame-property (selected-frame) 'background-mode 'light))


David Byers's avatar
X    
David Byers committed
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
;;; ======================================================================
;;; LysKOM Hooks
;;;

(defun lyskom-run-hook-with-args (hook &rest args)
  "Run HOOK with the specified arguments ARGS in the LysKOM buffer.
See run-hook-with-args for detailed information."
  (save-excursion (set-buffer (or (and (boundp 'lyskom-buffer)
                                       lyskom-buffer)
                                  (current-buffer)))
                  (apply 'run-hook-with-args hook args)))
                              

(defun lyskom-add-hook (hook function &optional append)
  "Add to the value of HOOK the function FUNCTION in the LysKOM buffer.
If optional APPEND is non-nil, add at the end of HOOK."
  (save-excursion (set-buffer (or (and (boundp 'lyskom-buffer)
                                       lyskom-buffer)
                                  (current-buffer)))
                  (add-hook hook function append t)))

(defun lyskom-remove-hook (hook function)
  "From the value of HOOK remove the function FUNCTION in the LysKOM buffer."
  (save-excursion (set-buffer (or (and (boundp 'lyskom-buffer)
                                       lyskom-buffer)
                                  (current-buffer)))
                  (remove-hook hook function t)))




;;; ======================================================================
;;; Printing
;;;
;;; XEmacs princ does not insert text properties. This function is based
;;; on the C code for princ. It only works on strings
;;;

(defun lyskom-princ (string &optional stream)
  "Similar to princ but will only print a string. Does not lose text properties
under XEmacs."
  (let ((old-point nil)
        (start-point nil)
        (old-buffer (current-buffer)))
    (unwind-protect
        (progn
          (cond ((bufferp stream) (set-buffer stream))
                ((markerp stream) 
                 (setq old-point (point))
                 (set-buffer (marker-buffer stream))
                 (goto-char stream)
                 (setq start-point (point))))

          (insert string))
      (cond ((markerp stream) 
             (set-marker stream (point))
             (if (>= old-point start-point)
                 (goto-char (+ old-point (- (point) start-point)))
               (goto-char old-point))))
      (set-buffer old-buffer))))


359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
;;; ======================================================================
;;; Faces
;;;

(defun lyskom-set-face-foreground (face color)
  (condition-case nil
      (set-face-foreground face color)
    (error nil)))

(defun lyskom-set-face-background (face color)
  (condition-case nil
      (set-face-background face color)
    (error nil)))


David Kågedal's avatar
David Kågedal committed
374
(defun lyskom-set-face-scheme (scheme)
375
376
377
  "Set the LysKOM color and face scheme to SCHEME. Valid schemes are listed
in lyskom-face-schemes."
  (let ((tmp (assoc scheme lyskom-face-schemes)))
David Byers's avatar
David Byers committed
378
379
    ;; This test is NOT good, but now it's better...
    (if (and tmp (or (not (eq (console-type) 'tty))
380
		     (not (eq (device-class) 'mono))))
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
        (progn
          (mapcar 
           (function
            (lambda (spec)
	      (copy-face (or (elt spec 1) 'default) (elt spec 0))
              (if (elt spec 2)
                  (lyskom-set-face-foreground (elt spec 0) (elt spec 2)))
              (if (elt spec 3)
                  (lyskom-set-face-background (elt spec 0) (elt spec 3)))))
	   (cdr tmp))))))


(defun lyskom-face-resource (face-name attr type)
  (if (eq (lyskom-emacs-version) 'xemacs)
      ;; XEmac style
      (let ((val (x-get-resource (concat face-name ".attribute" attr)
				 (concat "Face.Attribute" attr)
				 type)))
	(cond ((eq type 'string) val)
	      ((and (eq type 'boolean) val) (if (car val) 'on 'off))
	      (t val)))
    ;; Emacs style
    (let ((val (x-get-resource (concat face-name ".attribute" attr)
			       (concat "Face.Attribute" attr))))
      (cond ((eq type 'string) val)
	    ((and val
		  (eq type 'boolean)
		  (member (downcase val) '("on" "true"))) 'on)
	    ((and val (eq type 'boolean)) 'off)
	    (t val)))))


David Byers's avatar
X    
David Byers committed
413
(defun lyskom-modify-face (what face)
David Byers's avatar
David Byers committed
414
  (condition-case nil
David Byers's avatar
X    
David Byers committed
415
416
417
418
      (funcall (intern (concat "make-face-" (symbol-name what)))
               face)
    (error nil)))

419
420
421
422
423
424
425
(defun lyskom-setup-faces ()
  "Initalize the faces in the LysKOM client.
This sets the face scheme according to `kom-default-face-scheme', and
also reads the proper X resources."
  (unless kom-default-face-scheme
    (setq kom-default-face-scheme
	  (condition-case nil
David Kågedal's avatar
David Kågedal committed
426
	      (cond ((eq (device-class) 'mono) 'monochrome)
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
		    ((eq (lyskom-background-mode) 'dark)
		     'inverse)
		    (t 'default))
	    (error 'default))))  
  (lyskom-set-face-scheme kom-default-face-scheme)
  (if (eq (console-type) 'x)
      (mapcar
       (function
	(lambda (face)
	  (let* ((face-name (symbol-name face))
		 (fg (lyskom-face-resource face-name "Foreground" 'string))
		 (bg (lyskom-face-resource face-name "Background" 'string))
		 (bl (lyskom-face-resource face-name "Bold" 'boolean))
		 (it (lyskom-face-resource face-name "Italic" 'boolean))
		 (ul (lyskom-face-resource face-name "Underline" 'boolean)))
	    (if fg (set-face-foreground face fg))
	    (if bg (set-face-background face bg))
David Byers's avatar
X    
David Byers committed
444
445
446
447
	    (if (eq bl 'on) (lyskom-modify-face 'bold face))
	    (if (eq bl 'off) (lyskom-modify-face 'unbold face))
	    (if (eq it 'on) (lyskom-modify-face 'italic face))
	    (if (eq it 'off) (lyskom-modify-face 'unitalic face))
448
449
	    (if ul (set-face-underline-p face (eq ul 'on))))))
       lyskom-faces)))