Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-util.el @ 30:ec9a17fef872 r19-15b98

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b98
author cvs
date Mon, 13 Aug 2007 08:52:29 +0200
parents 1917ad0d78d7
children e04119814345
comparison
equal deleted inserted replaced
29:7976500f47f9 30:ec9a17fef872
33 (require 'custom) 33 (require 'custom)
34 (require 'cl) 34 (require 'cl)
35 (require 'nnheader) 35 (require 'nnheader)
36 (require 'timezone) 36 (require 'timezone)
37 (require 'message) 37 (require 'message)
38
39 (eval-and-compile
40 (autoload 'nnmail-date-to-time "nnmail"))
38 41
39 (defun gnus-boundp (variable) 42 (defun gnus-boundp (variable)
40 "Return non-nil if VARIABLE is bound and non-nil." 43 "Return non-nil if VARIABLE is bound and non-nil."
41 (and (boundp variable) 44 (and (boundp variable)
42 (symbol-value variable))) 45 (symbol-value variable)))
140 (progn (forward-line ,(or n 1)) (point)))) 143 (progn (forward-line ,(or n 1)) (point))))
141 144
142 (defun gnus-byte-code (func) 145 (defun gnus-byte-code (func)
143 "Return a form that can be `eval'ed based on FUNC." 146 "Return a form that can be `eval'ed based on FUNC."
144 (let ((fval (symbol-function func))) 147 (let ((fval (symbol-function func)))
145 (if (byte-code-function-p fval) 148 (if (compiled-function-p fval)
146 (let ((flist (append fval nil))) 149 (let ((flist (append fval nil)))
147 (setcar flist 'byte-code) 150 (setcar flist 'byte-code)
148 flist) 151 flist)
149 (cons 'progn (cddr fval))))) 152 (cons 'progn (cddr fval)))))
150 153
315 (define-key keymap key (pop plist)) 318 (define-key keymap key (pop plist))
316 (pop plist))))) 319 (pop plist)))))
317 320
318 (defun gnus-completing-read (default prompt &rest args) 321 (defun gnus-completing-read (default prompt &rest args)
319 ;; Like `completing-read', except that DEFAULT is the default argument. 322 ;; Like `completing-read', except that DEFAULT is the default argument.
320 (let* ((prompt (if default 323 (let* ((prompt (if default
321 (concat prompt " (default " default ") ") 324 (concat prompt " (default " default ") ")
322 (concat prompt " "))) 325 (concat prompt " ")))
323 (answer (apply 'completing-read prompt args))) 326 (answer (apply 'completing-read prompt args)))
324 (if (or (null answer) (zerop (length answer))) 327 (if (or (null answer) (zerop (length answer)))
325 default 328 default
370 time))))) 373 time)))))
371 374
372 (defsubst gnus-time-iso8601 (time) 375 (defsubst gnus-time-iso8601 (time)
373 "Return a string of TIME in YYMMDDTHHMMSS format." 376 "Return a string of TIME in YYMMDDTHHMMSS format."
374 (format-time-string "%Y%m%dT%H%M%S" time)) 377 (format-time-string "%Y%m%dT%H%M%S" time))
375 378
376 (defun gnus-date-iso8601 (header) 379 (defun gnus-date-iso8601 (header)
377 "Convert the date field in HEADER to YYMMDDTHHMMSS" 380 "Convert the date field in HEADER to YYMMDDTHHMMSS"
378 (condition-case () 381 (condition-case ()
379 (gnus-time-iso8601 (gnus-date-get-time (mail-header-date header))) 382 (gnus-time-iso8601 (gnus-date-get-time (mail-header-date header)))
380 (error ""))) 383 (error "")))
476 (setq max (max max (current-column))) 479 (setq max (max max (current-column)))
477 (forward-line 1)) 480 (forward-line 1))
478 (goto-char orig) 481 (goto-char orig)
479 ;; Scroll horizontally to center (sort of) the point. 482 ;; Scroll horizontally to center (sort of) the point.
480 (if (> max (window-width)) 483 (if (> max (window-width))
481 (set-window-hscroll 484 (set-window-hscroll
482 (get-buffer-window (current-buffer) t) 485 (get-buffer-window (current-buffer) t)
483 (min (- (current-column) (/ (window-width) 3)) 486 (min (- (current-column) (/ (window-width) 3))
484 (+ 2 (- max (window-width))))) 487 (+ 2 (- max (window-width)))))
485 (set-window-hscroll (get-buffer-window (current-buffer) t) 0)) 488 (set-window-hscroll (get-buffer-window (current-buffer) t) 0))
486 max))) 489 max)))
494 (defun gnus-sortable-date (date) 497 (defun gnus-sortable-date (date)
495 "Make sortable string by string-lessp from DATE. 498 "Make sortable string by string-lessp from DATE.
496 Timezone package is used." 499 Timezone package is used."
497 (condition-case () 500 (condition-case ()
498 (progn 501 (progn
499 (setq date (inline (timezone-fix-time 502 (setq date (inline (timezone-fix-time
500 date nil 503 date nil
501 (aref (inline (timezone-parse-date date)) 4)))) 504 (aref (inline (timezone-parse-date date)) 4))))
502 (inline 505 (inline
503 (timezone-make-sortable-date 506 (timezone-make-sortable-date
504 (aref date 0) (aref date 1) (aref date 2) 507 (aref date 0) (aref date 1) (aref date 2)
505 (inline 508 (inline
506 (timezone-make-time-string 509 (timezone-make-time-string
507 (aref date 3) (aref date 4) (aref date 5)))))) 510 (aref date 3) (aref date 4) (aref date 5))))))
508 (error ""))) 511 (error "")))
509 512
510 (defun gnus-copy-file (file &optional to) 513 (defun gnus-copy-file (file &optional to)
511 "Copy FILE to TO." 514 "Copy FILE to TO."
512 (interactive 515 (interactive
513 (list (read-file-name "Copy file: " default-directory) 516 (list (read-file-name "Copy file: " default-directory)
514 (read-file-name "Copy file to: " default-directory))) 517 (read-file-name "Copy file to: " default-directory)))
547 (substring gname (match-end 0)) 550 (substring gname (match-end 0))
548 gname))) 551 gname)))
549 552
550 (defun gnus-make-sort-function (funs) 553 (defun gnus-make-sort-function (funs)
551 "Return a composite sort condition based on the functions in FUNC." 554 "Return a composite sort condition based on the functions in FUNC."
552 (cond 555 (cond
553 ((not (listp funs)) funs) 556 ((not (listp funs)) funs)
554 ((null funs) funs) 557 ((null funs) funs)
555 ((cdr funs) 558 ((cdr funs)
556 `(lambda (t1 t2) 559 `(lambda (t1 t2)
557 ,(gnus-make-sort-function-1 (reverse funs)))) 560 ,(gnus-make-sort-function-1 (reverse funs))))
702 ;(put 'gnus-atomic-setq 'edebug-form-spec '(body)) 705 ;(put 'gnus-atomic-setq 'edebug-form-spec '(body))
703 706
704 707
705 ;;; Functions for saving to babyl/mail files. 708 ;;; Functions for saving to babyl/mail files.
706 709
710 (defvar rmail-default-rmail-file)
707 (defun gnus-output-to-rmail (filename &optional ask) 711 (defun gnus-output-to-rmail (filename &optional ask)
708 "Append the current article to an Rmail file named FILENAME." 712 "Append the current article to an Rmail file named FILENAME."
709 (require 'rmail) 713 (require 'rmail)
710 ;; Most of these codes are borrowed from rmailout.el. 714 ;; Most of these codes are borrowed from rmailout.el.
711 (setq filename (expand-file-name filename)) 715 (setq filename (expand-file-name filename))