cgit.sxemacs.org Git - packages/blob - xemacs-packages/mew/mew/contrib/mew-guess.el

   1 ;;; mew-guess.el --- Guess header and template file in draft for Mew
   2
   3 ;; Author:  OBATA Noboru <obata@nippon-control-system.co.jp>
   4 ;; Created: Mar 22, 1999
   5 ;; Revised: Aug 31, 1999
   6
   7 ;;; Commentary:
   8
   9 ;; Shun-ichi GOTO <gotoh@taiyo.co.jp> \e$B$5$s$K46<U$7$^$9!#\e(B
  10
  11 ;; \e$B$3$N%Q%C%1!<%8$O!"%I%i%U%H%b!<%I$K$*$$$F!"4{B8$N%X%C%@$NFbMF$+$i!"B>\e(B
  12 ;; \e$B$N%X%C%@$NFbMF$r?dB,$7$F=q$-49$($k5!G=$rDs6!$7$^$9!#Nc$($P!"\e(BTo: \e$B%X%C\e(B
  13 ;; \e$B%@$+$i\e(B From: \e$B$rJQ99$7$?$j!"\e(BConfig: \e$B$rA^F~$9$k$3$H$,$G$-$^$9!#\e(B
  14 ;;
  15 ;; \e$B$^$?!"$b$&$R$H$D$N5!G=$H$7$F!"J8F,$K%F%-%9%H%U%!%$%k\e(B (\e$B%F%s%W%l!<%H\e(B)
  16 ;; \e$B$rA^F~$9$k$3$H$,$G$-$^$9!#A^F~$9$k%U%!%$%kL>$b!"%X%C%@$+$i?dB,$5$;$k\e(B
  17 ;; \e$B$3$H$,$G$-$^$9!#\e(B
  18 ;;
  19 ;; \e$B%$%s%9%H!<%k$NJ}K!!#\e(B
  20 ;;
  21 ;;  - \e$B$3$N%U%!%$%k$r\e(B emacs \e$B$,8+IU$1$i$l$k>l=j$KCV$-$^$9!#\e(B
  22 ;;
  23 ;;  - .emacs \e$B$K<!$N5-=R$rDI2C$7$^$9!#\e(B(define-key ...) \e$B$O%-!<%P%$%s%I$NNc\e(B
  24 ;;  \e$B$G$9!#$*9%$_$K9g$o$;$FJQ$($F2<$5$$!#\e(B
  25 ;;
  26 ;;    (add-hook 'mew-init-hook
  27 ;;      (lambda ()
  28 ;;        (require 'mew-guess)
  29 ;;        (define-key mew-draft-header-map "\C-c\C-v" 'mew-guess-template)
  30 ;;        (define-key mew-draft-header-map "\C-c\C-d" 'mew-guess-header)
  31 ;;        (define-key mew-draft-body-map "\C-c\C-v" 'mew-guess-template)
  32 ;;        (define-key mew-draft-body-map "\C-c\C-d" 'mew-guess-header)))
  33 ;;
  34 ;; \e$B@_Dj$NNc!#\e(B
  35 ;;
  36 ;;  - \e$B%X%C%@?dB,$NNc!#\e(B
  37 ;;
  38 ;;    (setq mew-guess-header-alist
  39 ;;          '(
  40 ;;            ("From:"
  41 ;;             ;; From: \e$B$N?dB,$N%k!<%k\e(B
  42 ;;             ("To:"
  43 ;;              ;; To: \e$B$NFbMF$,!"\e(B"sorry@" \e$B$K%^%C%A$7$?$i!"\e(BFrom: \e$B$NFbMF$r\e(B
  44 ;;              ;; "\e$B>.H(\e(B \e$B>:\e(B <obata@nippon-control-system.co.jp>" \e$B$K=q$-\e(B
  45 ;;              ;; \e$B49$($^$9!#\e(B
  46 ;;              ("sorry@" "\e$B>.H(\e(B \e$B>:\e(B <obata@nippon-control-system.co.jp>")
  47 ;;              ;; \e$BF1MM$K!"\e(BTo: \e$B$NFbMF$,\e(B "@linux\\.or\\.jp" \e$B$K%^%C%A$7$?\e(B
  48 ;;              ;; \e$B$i!"\e(BFrom: \e$B$r\e(B "OBATA Noboru <obata@hh.iij4u.or.jp>" \e$B$K\e(B
  49 ;;              ;; \e$B=q$-49$($^$9!#\e(B
  50 ;;              ("@linux\\.or\\.jp" "OBATA Noboru <obata@hh.iij4u.or.jp>")
  51 ;;              )
  52 ;;             ("Config:"
  53 ;;              ;; Config: \e$B$NFbMF$K$h$C$F=q$-49$($?$$>l9g!#\e(B
  54 ;;              ("office" "OBATA Noboru <obata@nippon-control-system.co.jp>"))
  55 ;;             ;; \e$B<!$NFCJL$J5-K!$K$h$C$F!"%G%U%)%k%HCM$r;XDj$7$^$9!#\e(B
  56 ;;             (t "OBATA Noboru <obata@nippon-control-system.co.jp>"))
  57 ;;            ))
  58 ;;
  59 ;;  \e$BCV498e$NJ8;zNs$H$7$F!"CM$H$7$FJ8;zNs$r;}$DJQ?tL>$d!"J8;zNs$rJV$94X?t\e(B
  60 ;;  \e$BL>$d%i%`%@<0$r5-=R$G$-$^$9!#Nc$($P!"<!$N$h$&$K=q$1$P\e(B Config: \e$B$K\e(B
  61 ;;  mew-config-imget \e$B$NCM$r@_Dj$G$-$^$9!#\e(B
  62 ;;
  63 ;;    (setq mew-guess-header-alist
  64 ;;          '(
  65 ;;            ("Config:"
  66 ;;             (t mew-config-imget)
  67 ;;             )
  68 ;;            ))
  69 ;;
  70 ;;  - \e$B%F%s%W%l!<%H?dB,$NNc!#\e(B
  71 ;;
  72 ;;    (setq mew-guess-template-alist
  73 ;;          '(("To:"
  74 ;;             ;; To: \e$B$NFbMF$,\e(B "foo" \e$B$K%^%C%A$7$?$i!"J8F,$K%U%!%$%k\e(B
  75 ;;             ;; "~/.ff-foo" \e$B$rA^F~$7$^$9!#\e(B
  76 ;;             ("foo" "~/.ff-foo")
  77 ;;             ;; \e$BF1MM!#\e(B
  78 ;;             ("bar" "~/.ff-bar")
  79 ;;             )
  80 ;;            ))
  81 ;;
  82 ;;  - \e$B%-!<%o!<%ICV49$NNc!#>e$NJ}K!$G$O!"?dB,$N%k!<%k$@$1%U%!%$%k$r:n$i$J\e(B
  83 ;;  \e$B$/$F$O$$$1$J$$$N$G!"LLE]$G$9!#%F%s%W%l!<%H%U%!%$%k$K\e(B |>keyword<| \e$B$N\e(B
  84 ;;  \e$B=q<0$G%-!<%o!<%I$rKd$a9~$_!"$=$N%-!<%o!<%I$NCV49$r;XDj$9$k$3$H$,$G$-\e(B
  85 ;;  \e$B$^$9!#\e(B
  86 ;;
  87 ;;    (setq mew-guess-template-alist
  88 ;;          '(("To:"
  89 ;;             ;; To: \e$B$NFbMF$,\e(B "foo" \e$B$K%^%C%A$7$?$i!"J8F,$K%U%!%$%k\e(B
  90 ;;             ;; "~/.ff-foo" \e$B$rA^F~$7$^$9!#$=$N$H$-!"%U%!%$%kFb$N%-!<%o!<\e(B
  91 ;;             ;; \e$B%I\e(B |>me<| \e$B$r!"\e(B"\e$B$U!<\e(B" (\e$B%@%V%k%/%)!<%F!<%7%g%s$O$J$7\e(B) \e$B$K\e(B
  92 ;;             ;; \e$BCV$-49$($^$9!#\e(B
  93 ;;             ("foo" "~/.ff-foo" ("me" . "\e$B$U!<\e(B"))
  94 ;;             ;; \e$BF1MM!#\e(B
  95 ;;             ("bar" "~/.ff-foo" ("me" . "\e$B$P!<\e(B"))
  96 ;;             )
  97 ;;            ;; \e$B%G%U%)%k%H\e(B
  98 ;;            (t "~/.ff-foo")
  99 ;;            ))
 100 ;;
 101 ;;  \e$B$=$N:]!"%-!<%o!<%ICV49$N4{DjCM$r!"<!$N$h$&$K5-=R$9$k$3$H$,$G$-$^$9!#\e(B
 102 ;;  \e$BCV498e$NJ8;zNs$H$7$F!"JQ?tL>!"4X?tL>!"%i%`%@<0$r5-=R$G$-$^$9!#\e(B
 103 ;;
 104 ;;    (setq mew-draft-replace-alist
 105 ;;          '(("me" . "\e$B>.H(\e(B")
 106 ;;            ("email" . mew-mail-address)
 107 ;;            ("time" . (lambda () (current-time-string)))
 108 ;;            ;; ("time" . current-time-string) \e$B$b\e(B OK
 109 ;;            ))
 110
 111 ;;; Code:
 112
 113
 114 (defvar mew-guess-query-when-replaced nil
 115   "*If non-nil, make query to accept result of replacement.")
 116
 117 ;; Guess
 118
 119 (defun mew-guess-by-alist (alist)
 120   (let (name header sublist key val ent ret)
 121     (while (and alist (not ret))
 122       (setq name (car (car alist)))
 123       (setq sublist (cdr (car alist)))
 124       (cond
 125        ((eq name t)
 126         (setq ret sublist))
 127        ;;((eq name nil)
 128        ;;(setq ret sublist))
 129        (t
 130         (setq header (mew-header-get-value name))
 131         (if header
 132             (while (and sublist (not ret))
 133               (setq key (car (car sublist)))
 134               (setq val (cdr (car sublist)))
 135               (if (and (stringp key) (string-match key header))
 136                   (cond
 137                    ((stringp (car val))
 138                     (setq ent
 139                           (mew-refile-guess-by-alist2 key header (car val))))
 140                    ((or (functionp (car val))
 141                         (symbolp (car val)))
 142                     (setq ent (car val)))
 143                    ((listp (car val))
 144                     (setq ent (mew-guess-by-alist val)))))
 145               (if ent (setq ret val))
 146               (setq sublist (cdr sublist))))))
 147       (setq alist (cdr alist)))
 148     ret))
 149
 150 ;; Header
 151
 152 (defvar mew-guess-header-alist nil
 153   "*Alist to guess header contents.
 154 The syntax is:
 155
 156     (HEADER-GUS (HEADER-CND (KEY VALUE)... )... )...
 157
 158 HEADER-GUS is the target header which you want to guess and modify.
 159
 160 HEADER-CND and KEY specify the condition to guess. If regexp KEY matches
 161 to contents of HEADER-CND, contents are replaced with string VALUE.")
 162
 163 (defun mew-guess-header ()
 164   "Guess and modify header according to \"mew-guess-header-alist\"."
 165   (interactive)
 166   (let ((alist mew-guess-header-alist)
 167         header-gus sublist header-cnd glist undo changed)
 168     (save-excursion
 169       (mew-header-goto-end)
 170       (setq undo (buffer-substring 1 (point)))
 171       (while alist
 172         (setq header-gus (car (car alist)))
 173         (setq glist (mew-guess-by-alist (cdr (car alist))))
 174         (if glist
 175             (mew-header-replace-value header-gus (car glist)))
 176         (setq alist (cdr alist)))
 177       ;; compare with original
 178       (mew-header-goto-end)
 179       (setq changed (not (string= undo (buffer-substring 1 (point)))))
 180       (if (not changed)
 181           (if (interactive-p)
 182               (message "Nothing changed")) ; nothing done
 183         ;; something changed! query if need
 184         (mew-highlight-header)
 185         (mew-draft-header-keymap)
 186         (if (or (not mew-guess-query-when-replaced)
 187                 (y-or-n-p "Headers are changed. Accept this? "))
 188             (message "Some headers are changed") ; accepted
 189           ;; restore original
 190           (kill-region 1 (point))
 191           (insert undo)
 192           (mew-header-goto-end)
 193           (mew-highlight-header)
 194           (mew-draft-header-keymap)
 195           (message "Changes are canceled"))))))
 196
 197
 198 (defun mew-header-replace-value (field value)
 199   "Replace header contents."
 200   (interactive)
 201   (let ((newvalue (cond
 202                    ((stringp value) value)
 203                    ((symbolp value)
 204                     (cond
 205                      ((eq value 'delete) nil) ; delete this line
 206                      ((fboundp value)
 207                       (funcall value))  ; use function result
 208                      ((and (boundp value)
 209                            (stringp (symbol-value value)))
 210                       (symbol-value value)) ; use value of variable
 211                      (t nil)))
 212                    ((functionp value) (funcall value))
 213                    (t nil)))
 214         orgvalue)
 215     (if (not (and (stringp field)
 216                   (or (null newvalue) (stringp newvalue))))
 217         (error "Invalid field pair in mew-header-replace-alist")
 218       (setq orgvalue (mew-header-get-value field))
 219       (if (and orgvalue
 220                newvalue
 221                (string= (downcase newvalue) (downcase orgvalue)))
 222           ()                            ; same ... don't replace
 223         (if orgvalue
 224             (mew-header-delete-lines (list field))
 225           (mew-header-goto-end))
 226         (if newvalue
 227             (insert field " " newvalue "\n"))))))
 228
 229 ;; Template
 230
 231 (defvar mew-guess-template-alist nil
 232   "*Alist to guess template file.
 233 The basic syntax is:
 234
 235     (HEADER (KEY TEMPLATE)... )...
 236
 237 If regexp KEY matches to contents of HEADER, file TEMPLATE is guessed
 238 and guess is finished. Note that there is no dot (.) between KEY and
 239 TEMPLATE.
 240
 241 You can specify alists for keyword replacement like:
 242
 243     (HEADER (KEY TEMPLATE (REPLACE-FROM . REPLACE-TO)... )... )...
 244
 245 Alists in this form take precedence over \"mew-draft-replace-alist\".
 246
 247 For example:
 248
 249     (setq mew-guess-template-alist
 250           '((\"To:\"
 251              (\"mew-dist@mew.org\" \"~/.ff-mew-dist\"
 252               (\"hello\" . \"Mew friends,\")))
 253              (\"foo@hoge.hoge\" \"~/.ff-other\")
 254             (t \"~/.ff-default\")
 255             ))
 256
 257 There is exceptional form as you can see in the example:
 258
 259     (t TEMPLATE [(REPLACE-FROM . REPLACE-TO)...])
 260
 261 You can specify default TEMPLATE in this form, putting it on the last.")
 262
 263 (defun mew-guess-template ()
 264   "Insert template file on the top of the draft message."
 265   (interactive)
 266   (let* ((glist (mew-guess-by-alist mew-guess-template-alist))
 267          (file (car glist)) (kwlist (cdr glist)) deleted efile)
 268     (if file
 269         (progn
 270           (setq efile (expand-file-name file))
 271           (if (not (file-exists-p efile))
 272               (message "No template file %s" efile)
 273             (progn
 274               (forward-char
 275                (mew-draft-insert-file-and-replace
 276                 efile 'top (list kwlist mew-draft-replace-alist)))))))))
 277
 278 ;; Misc
 279
 280 (defvar mew-draft-replace-alist nil
 281   "*Alist for keyword replacement in draft.
 282 Keywords \"|>keyword<|\" in the template file and signature file (not
 283 yet) are replaced with it's associated value. It is possible to specify
 284 string, function, variable and lambda expression as the associated
 285 value, which is evaluated when replacement occurs.
 286
 287 You can replace keyword to the string flushed on the right. For example:
 288
 289     (setq mew-draft-replace-alist
 290           '((\"name\" . \"HOGE Hoge\")
 291             (\"email\" . \"foo@hoge.hoge\")
 292             (\"time\" .
 293              (lambda () (format (format \"%%%ds\" fill-column)
 294                                 (current-time-string))))
 295             ))")
 296
 297 (defun mew-draft-insert-file-and-replace (file pos &optional alists)
 298   "Insert file and replace keyword.
 299 Insert file FILE on position POS (possible values are top, bottom and
 300 here), and replace keyword according to ALISTS (list of alist)."
 301   (interactive)
 302   (cond
 303    ((eq pos 'top)
 304     (goto-char (mew-header-end))
 305     (forward-line))
 306    ((eq pos 'bottom)
 307     (if (null (mew-attach-p))
 308         (goto-char (point-max))
 309       (goto-char (mew-attach-begin))
 310       (forward-line -1)
 311       (end-of-line)
 312       (insert "\n"))))
 313   (let (bytes)
 314     (save-restriction
 315       (narrow-to-region
 316        (point) (+ (point) (car (cdr (insert-file-contents file)))))
 317       (while alists
 318         (mew-draft-replace-by-alist (car alists))
 319         (setq alists (cdr alists)))
 320       (mew-fib-delete-frame)
 321       (setq bytes (- (point-max) (point-min))))))
 322
 323 (defun mew-draft-replace-by-alist (alist)
 324   "Fill |>item<| by alist."
 325   (interactive)
 326   (save-excursion
 327     (let (begin end str)
 328       (goto-char (point-min))
 329       (while (re-search-forward "|>\\([^<]+\\)<|" nil t)
 330         (setq begin (match-beginning 1)
 331               end (match-end 1)
 332               str (buffer-substring begin end))
 333         (delete-region begin end)
 334         (backward-char 2)
 335         (insert (let ((obj (cdr (assoc (downcase str) alist))))
 336                   (cond
 337                    ((null obj) str)
 338                    ((stringp obj) obj)
 339                    ((functionp obj) (funcall obj))
 340                    ((symbolp obj)
 341                     (if (fboundp obj) (funcall obj)
 342                       (if (and (boundp obj)
 343                                (stringp (symbol-value obj)))
 344                           (symbol-value obj))))
 345                    (t str))))))))
 346
 347 (provide 'mew-guess)
 348
 349 ;;; mew-guess.el ends here