From mboxrd@z Thu Jan 1 00:00:00 1970 X-Msuck: nntp://news.gmane.io/gmane.emacs.gnus.general/7822 Path: main.gmane.org!not-for-mail From: Wesley.Hardaker@sphys.unil.ch Newsgroups: gmane.emacs.gnus.general Subject: gnus-picons update Date: 06 Sep 1996 15:11:14 +0200 Sender: whardake@iptsun2.unil.ch Message-ID: NNTP-Posting-Host: coloc-standby.netfonds.no X-Trace: main.gmane.org 1035148082 8662 80.91.224.250 (20 Oct 2002 21:08:02 GMT) X-Complaints-To: usenet@main.gmane.org NNTP-Posting-Date: Sun, 20 Oct 2002 21:08:02 +0000 (UTC) Return-Path: ding-request@ifi.uio.no Original-Received: from ifi.uio.no (ifi.uio.no [129.240.64.2]) by deanna.miranova.com (8.7.5/8.6.9) with SMTP id GAA12084 for ; Fri, 6 Sep 1996 06:55:08 -0700 Original-Received: from cisun29el32.unil.ch (cisun29el32.unil.ch [130.223.27.29]) by ifi.uio.no with SMTP (8.6.11/ifi2.4) id for ; Fri, 6 Sep 1996 15:12:41 +0200 Original-Received: from iptsun2.unil.ch by cisun29 with SMTP inbound; Fri, 6 Sep 1996 15:12:23 +0200 Original-Received: by iptsun2.unil.ch (5.x/Unil-3.1/) id AA22799; Fri, 6 Sep 1996 15:11:15 +0200 Original-To: ding@ifi.uio.no Original-Lines: 330 X-Mailer: Red Gnus v0.24/XEmacs 19.14 Xref: main.gmane.org gmane.emacs.gnus.general:7822 X-Report-Spam: http://spam.gmane.org/gmane.emacs.gnus.general:7822 Heh... Ok, I've out-done myself in stupid useless coding projects with this one. There is no reason what-so-ever for actually using the following features... You have been warned... The following patch is against rgnus-0.27 and does 2 things: 1) speed improvements: - first, I put a sit-for at the top of the display routines so that you can begin reading the article in question before the icons show up... This really should be an option... Oh well... - Lars, in order to simplify and shorten the code length, searched both the domains and users database for both types of icons (username and "unknown"). I removed this, as you will never find username directories under the domains section and likewise for the users section... IE, half the number of searches (I realize this is only a slight speed gain). 2) Stupid useless improvements: - The icons are now displayed as a real email address rather than just as icons. It relpaces the parts of the address that can be represented by icons with icons, and replaces the user name with a face for the user, if present. You can, of course, click on the appropriate graphic symbol and have it change into text and vise-versa. As I said... Stupid... But cute... 3) gnus-group-display-picons: Hey... Can't have it all in a day. I still have to munge this one... It can actually be done fairly easily, providing you don't mind the newsgroup tokens being backwards (ie, gnus.emacs.gnu instead of gnu.emacs.gnus)... sigh... Hey! I hate that! What a stupid idea! Please make it go away! : (setq gnus-picons-display-as-address nil) Lars, I greatly @#$#ed up the nice pretty code you had in there... Sorry about that... It needs to be visually cleaned up a bit, reworking the indentation sceme... Sorry... Wes Index: ChangeLog =================================================================== RCS file: /home/whardake/src/cvsroot/rgnus/ChangeLog,v retrieving revision 1.1.1.5 retrieving revision 1.6 diff -c -r1.1.1.5 -r1.6 *** 1.1.1.5 1996/09/06 12:35:19 --- 1.6 1996/09/06 12:45:19 *************** *** 1,3 **** --- 1,14 ---- + Fri Sep 6 14:38:54 1996 Wes Hardaker + + * gnus-picons.el (gnus-picons-display-as-address): New variable. + (gnus-picons-map): New keymap for picons. + (gnus-picons-toggle-extent): New function. + (gnus-article-display-picons): use them. + (gnus-picons-insert-face-if-exists): ditto. + (gnus-picons-try-to-find-face): ditto. + (gnus-group-display-picons): let display catch up. + (gnus-article-display-picons): ditto. + Thu Sep 5 19:50:19 1996 Lars Magne Ingebrigtsen * gnus-xmas.el (gnus-xmas-modeline-glyph): Set string properly. Index: gnus-picon.el =================================================================== RCS file: /home/whardake/src/cvsroot/rgnus/gnus-picon.el,v retrieving revision 1.1.1.1 retrieving revision 1.3 diff -c -r1.1.1.1 -r1.3 *** 1.1.1.1 1996/08/20 07:06:45 --- 1.3 1996/09/06 12:32:53 *************** *** 110,115 **** --- 110,118 ---- "Command to convert the x-face header into a xbm file." ) + (defvar gnus-picons-display-as-address t + "*If t display textual email addresses along with pictures.") + (defvar gnus-picons-file-suffixes (when (featurep 'x) (let ((types (list "xbm"))) *************** *** 124,129 **** --- 127,137 ---- "*Whether to move point to first empty line when displaying picons. This has only an effect if `gnus-picons-display-where' hs value article.") + (defvar gnus-picons-map (make-sparse-keymap "gnus-picons-keys") + "keymap to hide/show picon glpyhs") + + (define-key gnus-picons-map [(button2)] 'gnus-picons-toggle-extent) + ;;; Internal variables. (defvar gnus-group-annotations nil) *************** *** 207,212 **** --- 215,222 ---- (defun gnus-article-display-picons () "Display faces for an author and his/her domain in gnus-picons-display-where." (interactive) + ;; let drawing catch up + (sit-for 0) (let (from at-idx databases) (when (and (featurep 'xpm) (or (not (fboundp 'device-type)) (equal (device-type) 'x)) *************** *** 240,264 **** (gnus-picons-remove gnus-article-annotations) (setq gnus-article-annotations nil) ! (setq databases (append gnus-picons-user-directories ! gnus-picons-domain-directories)) (while databases (setq gnus-article-annotations (nconc (gnus-picons-insert-face-if-exists (car databases) addrs ! "unknown") ! (gnus-picons-insert-face-if-exists ! (car databases) ! addrs ! (downcase username) t) gnus-article-annotations)) (setq databases (cdr databases))) (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all)))))) (defun gnus-group-display-picons () "Display icons for the group in the gnus-picons-display-where buffer." (interactive) (when (and (featurep 'xpm) (or (not (fboundp 'device-type)) (equal (device-type) 'x))) (save-excursion --- 250,300 ---- (gnus-picons-remove gnus-article-annotations) (setq gnus-article-annotations nil) ! ;; look for domain paths. ! (setq databases gnus-picons-domain-directories) (while databases (setq gnus-article-annotations (nconc (gnus-picons-insert-face-if-exists (car databases) addrs ! "unknown" t) gnus-article-annotations)) (setq databases (cdr databases))) + + ;; add an '@' if displaying as address + (when gnus-picons-display-as-address + (setq gnus-article-annotations + (nconc gnus-article-annotations + (list + (make-annotation "@" (point) 'text nil nil nil t))))) + + ;; then do user directories, + (let (found) + (setq databases gnus-picons-user-directories) + (setq username (downcase username)) + (while databases + (setq found + (nconc (gnus-picons-insert-face-if-exists + (car databases) + addrs + username) + found)) + (setq databases (cdr databases))) + ;; add their name if no face exists + (when (and gnus-picons-display-as-address (not found)) + (setq found + (list + (make-annotation username (point) 'text nil nil nil t)))) + (setq gnus-article-annotations + (nconc found gnus-article-annotations))) + (add-hook 'gnus-summary-exit-hook 'gnus-picons-remove-all)))))) (defun gnus-group-display-picons () "Display icons for the group in the gnus-picons-display-where buffer." (interactive) + ;; let display catch up so far + (sit-for 0) (when (and (featurep 'xpm) (or (not (fboundp 'device-type)) (equal (device-type) 'x))) (save-excursion *************** *** 312,345 **** ;; 1. MISC/Name ;; The special treatment of MISC doesn't conform with the conventions for ;; picon databases, but otherwise we would always see the MISC/unknown face. ! (let ((bar (and (not nobar-p) (annotations-in-region (point) (min (point-max) (1+ (point))) (current-buffer)))) (path (concat (file-name-as-directory gnus-picons-database) database "/")) ! picons found bar-ann) (if (string-match "/MISC" database) (setq addrs '(""))) (while (and addrs (file-accessible-directory-p path)) ! (setq path (concat path (pop addrs) "/")) ! (when (setq found ! (gnus-picons-try-suffixes ! (concat path filename "/face."))) ! (when bar ! (setq bar-ann (gnus-picons-try-to-find-face ! (concat gnus-xmas-glyph-directory "bar.xbm"))) ! (when bar-ann ! (setq picons (nconc picons bar-ann)) ! (setq bar nil))) ! (setq picons (nconc (gnus-picons-try-to-find-face found) ! picons)))) ! (nreverse picons))) (defvar gnus-picons-glyph-alist nil) ! (defun gnus-picons-try-to-find-face (path &optional xface-p) "If PATH exists, display it as a bitmap. Returns t if succedded." (let ((glyph (and (not xface-p) (cdr (assoc path gnus-picons-glyph-alist))))) --- 348,398 ---- ;; 1. MISC/Name ;; The special treatment of MISC doesn't conform with the conventions for ;; picon databases, but otherwise we would always see the MISC/unknown face. ! (let ((bar (and (not gnus-picons-display-as-address) ! (not nobar-p) (annotations-in-region (point) (min (point-max) (1+ (point))) (current-buffer)))) (path (concat (file-name-as-directory gnus-picons-database) database "/")) ! (domainp (and gnus-picons-display-as-address nobar-p)) ! picons found bar-ann cur first) (if (string-match "/MISC" database) (setq addrs '(""))) (while (and addrs (file-accessible-directory-p path)) ! (setq cur (pop addrs) ! path (concat path cur "/")) ! (if (setq found ! (gnus-picons-try-suffixes (concat path filename "/face."))) ! (progn ! (when bar ! (setq bar-ann (gnus-picons-try-to-find-face ! (concat gnus-xmas-glyph-directory "bar.xbm"))) ! (when bar-ann ! (setq picons (nconc picons bar-ann)) ! (setq bar nil))) ! (setq picons (nconc (when (and domainp first) ! (list (make-annotation "." (point) 'text ! nil nil nil t) picons)) ! (gnus-picons-try-to-find-face ! found nil (if domainp cur filename)) ! picons))) ! (when domainp ! (setq picons ! (nconc (list (make-annotation (if first (concat cur ".") cur) ! (point) 'text nil nil nil t)) ! picons)))) ! (setq first t)) ! (when (and addrs domainp) ! (let ((it (mapconcat 'downcase addrs "."))) ! (make-annotation ! (if first (concat it ".") it) (point) 'text nil nil nil t))) ! picons)) (defvar gnus-picons-glyph-alist nil) ! (defun gnus-picons-try-to-find-face (path &optional xface-p part) "If PATH exists, display it as a bitmap. Returns t if succedded." (let ((glyph (and (not xface-p) (cdr (assoc path gnus-picons-glyph-alist))))) *************** *** 349,362 **** (unless xface-p (push (cons path glyph) gnus-picons-glyph-alist)) (set-glyph-face glyph 'default)) ! (nconc ! (list (make-annotation glyph (point) 'text)) ! (when (eq major-mode 'gnus-article-mode) ! (list (make-annotation " " (point) 'text))))))) (defun gnus-picons-reverse-domain-path (str) "a/b/c/d -> d/c/b/a" (mapconcat 'downcase (nreverse (message-tokenize-header str "/")) "/")) (gnus-add-shutdown 'gnus-picons-close 'gnus) --- 402,435 ---- (unless xface-p (push (cons path glyph) gnus-picons-glyph-alist)) (set-glyph-face glyph 'default)) ! (let ((new (make-annotation glyph (point) 'text nil nil nil t))) ! (nconc ! (list new) ! (when (and (eq major-mode 'gnus-article-mode) ! (not gnus-picons-display-as-address) ! (not part)) ! (list (make-annotation " " (point) 'text nil nil nil t))) ! (when (and part gnus-picons-display-as-address) ! (let ((txt (make-annotation part (point) 'text nil nil nil t))) ! (hide-annotation txt) ! (set-extent-property txt 'its-partner new) ! (set-extent-property txt 'keymap gnus-picons-map) ! (set-extent-property txt 'mouse-face gnus-article-mouse-face) ! (set-extent-property new 'its-partner txt) ! (set-extent-property new 'keymap gnus-picons-map)))))))) (defun gnus-picons-reverse-domain-path (str) "a/b/c/d -> d/c/b/a" (mapconcat 'downcase (nreverse (message-tokenize-header str "/")) "/")) + + (defun gnus-picons-toggle-extent (event) + "Toggle picon glyph at given point" + (interactive "e") + (let* ((ant1 (event-glyph-extent event)) + (ant2 (extent-property ant1 'its-partner))) + (when (and (annotationp ant1) (annotationp ant2)) + (reveal-annotation ant2) + (hide-annotation ant1)))) (gnus-add-shutdown 'gnus-picons-close 'gnus)