Mercurial > emacs
comparison lisp/facemenu.el @ 13923:35e379a3952e
(facemenu-read-color, list-colors-display)
(facemenu-get-face): Treat all non-nil window-system values alike.
(facemenu-color-equal): Special case for MSDOS.
author | Richard M. Stallman <rms@gnu.org> |
---|---|
date | Tue, 02 Jan 1996 23:04:06 +0000 |
parents | fcfb5f397b49 |
children | e16dc69d909a |
comparison
equal
deleted
inserted
replaced
13922:5636ed4243ec | 13923:35e379a3952e |
---|---|
236 "Keymap for face-changing commands. | 236 "Keymap for face-changing commands. |
237 `Facemenu-update' fills in the keymap according to the bindings | 237 `Facemenu-update' fills in the keymap according to the bindings |
238 requested in `facemenu-keybindings'.") | 238 requested in `facemenu-keybindings'.") |
239 (defalias 'facemenu-keymap facemenu-keymap) | 239 (defalias 'facemenu-keymap facemenu-keymap) |
240 | 240 |
241 | |
242 (defvar facemenu-add-face-function nil | |
243 "Function called at beginning of text to change or `nil'. | |
244 This function is passed the FACE to set and END of text to change, and must | |
245 return a string which is inserted. It may set `facemenu-end-add-face'.") | |
246 | |
247 (defvar facemenu-end-add-face nil | |
248 "String to insert or function called at end of text to change or `nil'. | |
249 This function is passed the FACE to set, and must return a string which is | |
250 inserted.") | |
251 | |
252 (defvar facemenu-remove-face-function nil | |
253 "When non-`nil' function called to remove faces. | |
254 This function is passed the START and END of text to change. | |
255 May also be `t' meaning to use `facemenu-add-face-function'.") | |
256 | |
241 ;;; Internal Variables | 257 ;;; Internal Variables |
242 | 258 |
243 (defvar facemenu-color-alist nil | 259 (defvar facemenu-color-alist nil |
244 ;; Don't initialize here; that doesn't work if preloaded. | 260 ;; Don't initialize here; that doesn't work if preloaded. |
245 "Alist of colors, used for completion. | 261 "Alist of colors, used for completion. |
278 (facemenu-add-new-face face) | 294 (facemenu-add-new-face face) |
279 (if (and mark-active (not current-prefix-arg)) | 295 (if (and mark-active (not current-prefix-arg)) |
280 (let ((start (or start (region-beginning))) | 296 (let ((start (or start (region-beginning))) |
281 (end (or end (region-end)))) | 297 (end (or end (region-end)))) |
282 (facemenu-add-face face start end)) | 298 (facemenu-add-face face start end)) |
283 (facemenu-self-insert-face face))) | 299 (facemenu-add-face face))) |
284 | 300 |
285 ;;;###autoload | 301 ;;;###autoload |
286 (defun facemenu-set-foreground (color &optional start end) | 302 (defun facemenu-set-foreground (color &optional start end) |
287 "Set the foreground color of the region or next character typed. | 303 "Set the foreground color of the region or next character typed. |
288 The color is prompted for. A face named `fg:color' is used \(or created). | 304 The color is prompted for. A face named `fg:color' is used \(or created). |
331 (region-end)))) | 347 (region-end)))) |
332 (barf-if-buffer-read-only) | 348 (barf-if-buffer-read-only) |
333 (facemenu-get-face face) | 349 (facemenu-get-face face) |
334 (if start | 350 (if start |
335 (facemenu-add-face face start end) | 351 (facemenu-add-face face start end) |
336 (facemenu-self-insert-face face))) | 352 (facemenu-add-face face))) |
337 | |
338 (defun facemenu-self-insert-face (face) | |
339 (setq self-insert-face (if (eq last-command self-insert-face-command) | |
340 (cons face (if (listp self-insert-face) | |
341 self-insert-face | |
342 (list self-insert-face))) | |
343 face) | |
344 self-insert-face-command this-command)) | |
345 | 353 |
346 ;;;###autoload | 354 ;;;###autoload |
347 (defun facemenu-set-invisible (start end) | 355 (defun facemenu-set-invisible (start end) |
348 "Make the region invisible. | 356 "Make the region invisible. |
349 This sets the `invisible' text property; it can be undone with | 357 This sets the `invisible' text property; it can be undone with |
394 | 402 |
395 ;;;###autoload | 403 ;;;###autoload |
396 (defun list-text-properties-at (p) | 404 (defun list-text-properties-at (p) |
397 "Pop up a buffer listing text-properties at LOCATION." | 405 "Pop up a buffer listing text-properties at LOCATION." |
398 (interactive "d") | 406 (interactive "d") |
399 (let ((props (text-properties-at p))) | 407 (let ((props (text-properties-at p)) |
408 str) | |
400 (if (null props) | 409 (if (null props) |
401 (message "None") | 410 (message "None") |
402 (with-output-to-temp-buffer "*Text Properties*" | 411 (if (and (not (cdr (cdr props))) |
403 (princ (format "Text properties at %d:\n\n" p)) | 412 (< (length (setq str (format "Text property at %d: %s %S" |
404 (while props | 413 p (car props) (car (cdr props))))) |
405 (princ (format "%-20s %S\n" | 414 (frame-width))) |
406 (car props) (car (cdr props)))) | 415 (message str) |
407 (setq props (cdr (cdr props)))))))) | 416 (with-output-to-temp-buffer "*Text Properties*" |
417 (princ (format "Text properties at %d:\n\n" p)) | |
418 (while props | |
419 (princ (format "%-20s %S\n" | |
420 (car props) (car (cdr props)))) | |
421 (setq props (cdr (cdr props))))))))) | |
408 | 422 |
409 ;;;###autoload | 423 ;;;###autoload |
410 (defun facemenu-read-color (&optional prompt) | 424 (defun facemenu-read-color (&optional prompt) |
411 "Read a color using the minibuffer." | 425 "Read a color using the minibuffer." |
412 (let ((col (completing-read (or prompt "Color: ") | 426 (let ((col (completing-read (or prompt "Color: ") |
413 (or facemenu-color-alist | 427 (or facemenu-color-alist |
414 (if (or (eq window-system 'x) (eq window-system 'win32)) | 428 (if window-system |
415 (mapcar 'list (x-defined-colors)))) | 429 (mapcar 'list (x-defined-colors)))) |
416 nil t))) | 430 nil t))) |
417 (if (equal "" col) | 431 (if (equal "" col) |
418 nil | 432 nil |
419 col))) | 433 col))) |
423 "Display names of defined colors, and show what they look like. | 437 "Display names of defined colors, and show what they look like. |
424 If the optional argument LIST is non-nil, it should be a list of | 438 If the optional argument LIST is non-nil, it should be a list of |
425 colors to display. Otherwise, this command computes a list | 439 colors to display. Otherwise, this command computes a list |
426 of colors that the current display can handle." | 440 of colors that the current display can handle." |
427 (interactive) | 441 (interactive) |
428 (if (and (null list) (or (eq window-system 'x) (eq window-system 'win32))) | 442 (if (and (null list) window-system) |
429 (progn | 443 (progn |
430 (setq list (x-defined-colors)) | 444 (setq list (x-defined-colors)) |
431 ;; Delete duplicate colors. | 445 ;; Delete duplicate colors. |
432 (let ((l list)) | 446 (let ((l list)) |
433 (while (cdr l) | 447 (while (cdr l) |
459 This function queries the window-system server to find out what the | 473 This function queries the window-system server to find out what the |
460 color names mean. It returns nil if the colors differ or if it can't | 474 color names mean. It returns nil if the colors differ or if it can't |
461 determine the correct answer." | 475 determine the correct answer." |
462 (cond ((equal a b) t) | 476 (cond ((equal a b) t) |
463 ((and (or (eq window-system 'x) (eq window-system 'win32)) | 477 ((and (or (eq window-system 'x) (eq window-system 'win32)) |
464 (equal (x-color-values a) (x-color-values b)))))) | 478 (equal (x-color-values a) (x-color-values b)))) |
465 | 479 ((eq window-system 'pc) |
466 (defun facemenu-add-face (face start end) | 480 (and (x-color-defined-p a) (x-color-defined-p b) |
481 (eq (msdos-color-translate a) (msdos-color-translate b)))))) | |
482 | |
483 (defun facemenu-add-face (face &optional start end) | |
467 "Add FACE to text between START and END. | 484 "Add FACE to text between START and END. |
468 For each section of that region that has a different face property, FACE will | 485 If START is `nil' or START to END is empty, add FACE to next typed character |
469 be consed onto it, and other faces that are completely hidden by that will be | 486 instead. For each section of that region that has a different face property, |
470 removed from the list. | 487 FACE will be consed onto it, and other faces that are completely hidden by |
488 that will be removed from the list. | |
489 If `facemenu-add-face-function' and maybe `facemenu-end-add-face' are non-`nil' | |
490 they are used to set the face information. | |
471 | 491 |
472 As a special case, if FACE is `default', then the region is left with NO face | 492 As a special case, if FACE is `default', then the region is left with NO face |
473 text property. Otherwise, selecting the default face would not have any | 493 text property. Otherwise, selecting the default face would not have any |
474 effect." | 494 effect. See `facemenu-remove-face-function'." |
475 (interactive "*xFace:\nr") | 495 (interactive "*xFace: \nr") |
476 (if (eq face 'default) | 496 (if (and (eq face 'default) |
477 (remove-text-properties start end '(face default)) | 497 (not (eq facemenu-remove-face-function t))) |
478 (let ((part-start start) part-end) | 498 (if facemenu-remove-face-function |
479 (while (not (= part-start end)) | 499 (funcall facemenu-remove-face-function start end) |
480 (setq part-end (next-single-property-change part-start 'face nil end)) | 500 (remove-text-properties start end '(face default))) |
481 (let ((prev (get-text-property part-start 'face))) | 501 (if facemenu-add-face-function |
482 (put-text-property part-start part-end 'face | 502 (save-excursion |
483 (if (null prev) | 503 (if end (goto-char end)) |
484 face | 504 (save-excursion |
485 (facemenu-active-faces | 505 (if start (goto-char start)) |
486 (cons face | 506 (insert-before-markers |
487 (if (listp prev) prev (list prev))))))) | 507 (funcall facemenu-add-face-function face end))) |
488 (setq part-start part-end))))) | 508 (if facemenu-end-add-face |
509 (insert (if (stringp facemenu-end-add-face) | |
510 facemenu-end-add-face | |
511 (funcall facemenu-end-add-face face))))) | |
512 (if (and start (< start end)) | |
513 (let ((part-start start) part-end) | |
514 (while (not (= part-start end)) | |
515 (setq part-end (next-single-property-change part-start 'face | |
516 nil end)) | |
517 (let ((prev (get-text-property part-start 'face))) | |
518 (put-text-property part-start part-end 'face | |
519 (if (null prev) | |
520 face | |
521 (facemenu-active-faces | |
522 (cons face | |
523 (if (listp prev) | |
524 prev | |
525 (list prev))))))) | |
526 (setq part-start part-end))) | |
527 (setq self-insert-face (if (eq last-command self-insert-face-command) | |
528 (cons face (if (listp self-insert-face) | |
529 self-insert-face | |
530 (list self-insert-face))) | |
531 face) | |
532 self-insert-face-command this-command))))) | |
489 | 533 |
490 (defun facemenu-active-faces (face-list &optional frame) | 534 (defun facemenu-active-faces (face-list &optional frame) |
491 "Return from FACE-LIST those faces that would be used for display. | 535 "Return from FACE-LIST those faces that would be used for display. |
492 This means each face attribute is not specified in a face earlier in FACE-LIST | 536 This means each face attribute is not specified in a face earlier in FACE-LIST |
493 and such a face is therefore active when used to display text. | 537 and such a face is therefore active when used to display text. |
518 (let* ((face (make-face symbol)) | 562 (let* ((face (make-face symbol)) |
519 (name (symbol-name symbol)) | 563 (name (symbol-name symbol)) |
520 (color (substring name 3))) | 564 (color (substring name 3))) |
521 (cond ((string-match "^fg:" name) | 565 (cond ((string-match "^fg:" name) |
522 (set-face-foreground face color) | 566 (set-face-foreground face color) |
523 (and (or (eq window-system 'x) (eq window-system 'win32)) (x-color-defined-p color))) | 567 (and window-system |
568 (x-color-defined-p color))) | |
524 ((string-match "^bg:" name) | 569 ((string-match "^bg:" name) |
525 (set-face-background face color) | 570 (set-face-background face color) |
526 (and (or (eq window-system 'x) (eq window-system 'win32)) (x-color-defined-p color))) | 571 (and window-system |
572 (x-color-defined-p color))) | |
527 (t)))) | 573 (t)))) |
528 symbol)) | 574 symbol)) |
529 | 575 |
530 (defun facemenu-add-new-face (face) | 576 (defun facemenu-add-new-face (face) |
531 "Add a FACE to the appropriate Face menu. | 577 "Add a FACE to the appropriate Face menu. |