+(defun gnus-xmas-call-region (command &rest args)
+ (apply
+ 'call-process-region (point-min) (point-max) command t '(t nil) nil
+ args))
+
+(defvar gnus-xmas-modeline-left-extent
+ (let ((ext (copy-extent modeline-buffer-id-left-extent)))
+ ext))
+
+(defvar gnus-xmas-modeline-right-extent
+ (let ((ext (copy-extent modeline-buffer-id-right-extent)))
+ ext))
+
+(defvar gnus-xmas-modeline-glyph
+ (progn
+ (let* ((file-xpm (expand-file-name "gnus-pointer.xpm"
+ gnus-xmas-glyph-directory))
+ (file-xbm (expand-file-name "gnus-pointer.xbm"
+ gnus-xmas-glyph-directory))
+ (glyph (make-glyph
+ ;; Gag gag gag.
+ (cond ((featurep 'xpm)
+ ;; Let's try a nifty XPM
+ `[xpm :file ,file-xpm])
+ ((featurep 'xbm)
+ ;; Then a not-so-nifty XBM
+ `[xbm :file ,file-xbm])
+ ;; Then the simple string
+ (t [string :data "Gnus:"])))))
+ (set-glyph-face glyph 'modeline-buffer-id)
+ glyph)))
+
+(defun gnus-xmas-mode-line-buffer-identification (line)
+ (let ((line (car line))
+ chop)
+ (cond
+ ;; This is some weird type of id.
+ ((not (stringp line))
+ (list line))
+ ;; This is non-standard, so we just pass it through.
+ ((not (string-match "^Gnus:" line))
+ (list line))
+ ;; We have a standard line, so we colorize and glyphize it a bit.
+ (t
+ (setq chop (match-end 0))
+ (list
+ (if gnus-xmas-modeline-glyph
+ (cons gnus-xmas-modeline-left-extent gnus-xmas-modeline-glyph)
+ (cons gnus-xmas-modeline-left-extent (substring line 0 chop)))
+ (cons gnus-xmas-modeline-right-extent (substring line chop)))))))
+
+(defun gnus-xmas-splash ()
+ (when (eq (device-type) 'x)
+ (gnus-splash)))
+
+(defun gnus-xmas-annotation-in-region-p (b e)
+ (or (map-extents (lambda (e u) t) nil b e nil nil 'mm t)
+ (if (= b e)
+ (eq (cadr (memq 'gnus-undeletable (text-properties-at b))) t)
+ (text-property-any b e 'gnus-undeletable t))))
+
+(defun gnus-xmas-mime-button-menu (event prefix)
+ "Construct a context-sensitive menu of MIME commands."
+ (interactive "e\nP")
+ (let ((response (get-popup-menu-response
+ `("MIME Part"
+ ,@(mapcar (lambda (c) `[,(caddr c) ,(car c) t])
+ gnus-mime-button-commands)))))
+ (set-buffer (event-buffer event))
+ (goto-char (event-point event))
+ (funcall (event-function response) (event-object response))))
+
+(defun gnus-group-add-icon ()
+ "Add an icon to the current line according to `gnus-group-icon-list'."
+ (let* ((p (point))
+ (end (gnus-point-at-eol))
+ ;; now find out where the line starts and leave point there.
+ (beg (progn (beginning-of-line) (point))))
+ (save-restriction
+ (narrow-to-region beg end)
+ (goto-char beg)
+ (when (search-forward "==&&==" nil t)
+ (let* ((group (gnus-group-group-name))
+ (entry (gnus-group-entry group))
+ (unread (if (numberp (car entry)) (car entry) 0))
+ (active (gnus-active group))
+ (total (if active (1+ (- (cdr active) (car active))) 0))
+ (info (nth 2 entry))
+ (method (gnus-server-get-method group (gnus-info-method info)))
+ (marked (gnus-info-marks info))
+ (mailp (memq 'mail (assoc (symbol-name
+ (car (or method gnus-select-method)))
+ gnus-valid-select-methods)))
+ (level (or (gnus-info-level info) gnus-level-killed))
+ (score (or (gnus-info-score info) 0))
+ (ticked (gnus-range-length (cdr (assq 'tick marked))))
+ (group-age (gnus-group-timestamp-delta group))
+ (inhibit-read-only t)
+ (list gnus-group-icon-list)
+ (mystart (match-beginning 0))
+ (myend (match-end 0)))
+ (goto-char (point-min))
+ (while (and list
+ (not (eval (caar list))))
+ (setq list (cdr list)))
+ (if list
+ (let* ((file (cdar list))
+ (glyph (gnus-group-icon-create-glyph
+ (buffer-substring mystart myend)
+ file)))
+ (if glyph
+ (progn
+ (mapcar 'delete-annotation (annotations-at myend))
+ (let ((ext (make-extent mystart myend))
+ (ant (make-annotation glyph myend 'text)))
+ ;; set text extent params
+ (set-extent-property ext 'end-open t)
+ (set-extent-property ext 'start-open t)
+ (set-extent-property ext 'invisible t)))
+ (delete-region mystart myend)))
+ (delete-region mystart myend))))
+ (widen))
+ (goto-char p)))
+
+(defun gnus-group-icon-create-glyph (substring pixmap)
+ "Create a glyph for insertion into a group line."
+ (or
+ (cdr-safe (assoc pixmap gnus-group-icon-cache))
+ (let* ((glyph (make-glyph
+ (list
+ (cons 'x
+ (expand-file-name pixmap gnus-xmas-glyph-directory))
+ (cons 'mswindows
+ (expand-file-name pixmap gnus-xmas-glyph-directory))
+ (cons 'tty substring)))))
+ (setq gnus-group-icon-cache
+ (cons (cons pixmap glyph) gnus-group-icon-cache))
+ (set-glyph-face glyph 'default)
+ glyph)))
+
+(defun gnus-xmas-mailing-list-menu-add ()
+ (gnus-xmas-menu-add mailing-list
+ gnus-mailing-list-menu))
+
+(defun gnus-xmas-image-type-available-p (type)
+ (and window-system
+ (featurep (if (eq type 'pbm) 'xbm type))))
+
+(defun gnus-xmas-create-image (file &optional type data-p &rest props)
+ (let ((type (if type
+ (symbol-name type)
+ (car (last (split-string file "[.]")))))
+ (face (plist-get props :face))
+ glyph)
+ (when (equal type "pbm")
+ (with-temp-buffer
+ (if data-p
+ (insert file)
+ (insert-file-contents-literally file))
+ (shell-command-on-region (point-min) (point-max)
+ "ppmtoxpm 2>/dev/null" t)
+ (setq file (buffer-string)
+ type "xpm"
+ data-p t)))
+ (setq glyph
+ (if (equal type "xbm")
+ (make-glyph (list (cons 'x file)))
+ (with-temp-buffer
+ (if data-p
+ (insert file)
+ (insert-file-contents-literally file))
+ (make-glyph
+ (vector
+ (or (intern type)
+ (mm-image-type-from-buffer))
+ :data (buffer-string))))))
+ (when face
+ (set-glyph-face glyph face))
+ glyph))
+
+(defun gnus-xmas-put-image (glyph &optional string category)
+ "Insert STRING, but display GLYPH.
+Warning: Don't insert text immediately after the image."
+ (let ((begin (point))
+ extent)
+ (if (and (bobp) (not string))
+ (setq string " "))
+ (if string
+ (insert string)
+ (setq begin (1- begin)))
+ (setq extent (make-extent begin (point)))
+ (set-extent-property extent 'gnus-image category)
+ (set-extent-property extent 'duplicable t)
+ (if string
+ (set-extent-property extent 'invisible t))
+ (set-extent-property extent 'end-glyph glyph))
+ glyph)
+
+(defun gnus-xmas-remove-image (image &optional category)
+ (map-extents
+ (lambda (ext unused)
+ (when (equal (extent-end-glyph ext) image)
+ (set-extent-property ext 'invisible nil)
+ (set-extent-property ext 'end-glyph nil))
+ nil)
+ nil nil nil nil nil 'gnus-image category))
+
+(defun gnus-xmas-completing-read (prompt table &optional
+ predicate require-match history)
+ (when (and history
+ (not (boundp history)))
+ (set history nil))
+ (completing-read
+ (if (symbol-value history)
+ (concat prompt " (" (car (symbol-value history)) "): ")
+ (concat prompt ": "))
+ table
+ predicate
+ require-match
+ nil
+ history))
+
+;; This macro is because XEmacs versions prior to 21.2 do not have the
+;; PROTOCOL argument to `open-network-stream'.
+(defmacro gnus-xmas-open-network-stream (name buffer host service &optional protocol)
+ "Like `open-network-stream' but take into account older XEmacs versions."
+ (if (and (featurep 'xemacs)
+ (fboundp 'open-network-stream)
+ (emacs-version>= 21 2))
+ `(open-network-stream ,name ,buffer ,host ,service ,protocol)
+ `(open-network-stream ,name ,buffer ,host ,service)))
+
+(defun gnus-xmas-assq-delete-all (key alist)
+ (let ((elem nil))
+ (while (setq elem (assq key alist))
+ (setq alist (delq elem alist)))
+ alist))
+
+(provide 'gnus-xmas)
+
projects / gnus / blobdiff