comparison lisp/mail/mail-extr.el @ 37148:aca2b7839d21

(mail-extr-delete-char, mail-extr-safe-move-sexp) (mail-extr-skip-whitespace-forward, mail-extr-nuke-char-at) (mail-extr-skip-whitespace-backward, mail-extr-undo-backslash-quoting): Use `defsubst' rather than a macro to ease debugging. (mail-extr-last): Remove (use `last' instead). (mail-extract-address-components): Properly reset the syntax-table after parsing an address. Use `last' rather than mail-extr-last. Make sure the end marker stays at the very end.

37147:4ba3b922976f

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Utility functions and macros.
;;

(defmacro mail-extr-delete-char (n)
  ;; in v19, delete-char is compiled as a function call, but delete-region
  ;; is byte-coded, so it's much much faster.
  (list 'delete-region '(point) (list '+ '(point) n)))

(defmacro mail-extr-skip-whitespace-forward ()
  ;; v19 fn skip-syntax-forward is more tasteful, but not byte-coded.
  '(skip-chars-forward " \t\n\r\240"))

(defmacro mail-extr-skip-whitespace-backward ()
  ;; v19 fn skip-syntax-backward is more tasteful, but not byte-coded.
  '(skip-chars-backward " \t\n\r\240"))


(defmacro mail-extr-undo-backslash-quoting (beg end)
  (`(save-excursion
      (save-restriction
	(narrow-to-region (, beg) (, end))
	(goto-char (point-min))
	;; undo \ quoting
	(while (search-forward "\\" nil t)
	  (mail-extr-delete-char -1)
	  (or (eobp)
	      (forward-char 1))
	  )))))

(defmacro mail-extr-nuke-char-at (pos)
  (` (save-excursion
       (goto-char (, pos))
       (mail-extr-delete-char 1)
       (insert ?\ ))))

(put 'mail-extr-nuke-outside-range
     'edebug-form-spec '(symbolp &optional form form atom))

(defmacro mail-extr-nuke-outside-range (list-symbol

  ;; coerces pos to a marker if non-nil.
  (if (or (markerp pos) (null pos))
      pos
    (copy-marker pos)))

(defmacro mail-extr-last (list)
  ;; Returns last element of LIST.
  ;; Could be a subst.
  (` (let ((list (, list)))
       (while (not (null (cdr list)))
	 (setq list (cdr list)))
       (car list))))
  
(defmacro mail-extr-safe-move-sexp (arg)
  ;; Safely skip over one balanced sexp, if there is one.  Return t if success.
  (` (condition-case error
	 (progn
	   (goto-char (or (scan-sexps (point) (, arg)) (point)))
	   t)
       (error
	;; #### kludge kludge kludge kludge kludge kludge kludge !!!
	(if (string-equal (nth 1 error) "Unbalanced parentheses")
	    nil
	  (while t
	    (signal (car error) (cdr error))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; The main function to grind addresses
;;

or more recipients, separated by commas, and we return a list of
the form ((FULL-NAME CANONICAL-ADDRESS) ...) with one element for
each recipient.  If ALL is nil, then if ADDRESS contains more than
one recipients, all but the first is ignored.

ADDRESS may be a string or a buffer.  If it is a buffer, the visible 
 (narrowed) portion of the buffer will be interpreted as the address.
 (This feature exists so that the clever caller might be able to avoid
 consing a string.)"
  (let ((canonicalization-buffer (get-buffer-create " *canonical address*"))
	(extraction-buffer (get-buffer-create " *extract address components*"))
	value-list)

    (save-excursion
      (set-buffer extraction-buffer)
      (fundamental-mode)
      (buffer-disable-undo extraction-buffer)
      (set-syntax-table mail-extr-address-syntax-table)
      (widen)
      (erase-buffer)

	    (t
	     (error "Invalid address: %s" address)))

      (set-text-properties (point-min) (point-max) nil)

      (save-excursion
	(set-buffer canonicalization-buffer)
	(fundamental-mode)
	(buffer-disable-undo canonicalization-buffer)
	(set-syntax-table mail-extr-address-syntax-table)
	(setq case-fold-search nil))

      
      ;; Unfold multiple lines.
      (goto-char (point-min))

	      saved-%-pos saved-!-pos saved-@-pos
	      domain-pos \.-pos insert-point
	      ;;	mailbox-name-processed-flag
	      disable-initial-guessing-flag) ; dynamically set from -voodoo

	  (goto-char (point-min))

	  ;; Insert extra space at beginning to allow later replacement with <
	  ;; without having to move markers.
	  (or (eq (following-char) ?\ )

		       (and >-pos
			    ;; handle weird munged addresses
			    ;; BUG FIX: This test was reversed.  Thanks to the
			    ;; brilliant Rod Whitby <[e-mail]>
			    ;; for discovering this!
			    (< (mail-extr-last <-pos) (car >-pos)))))
	      ;; The argument contains more than one address.
	      ;; Temporarily hide everything after this one.
	      (setq end-of-address (copy-marker (1+ (point))))
	      (narrow-to-region (point-min) (1+ (point)))
	      (mail-extr-delete-char 1)
	      (setq char ?\() ; HAVE I NO SHAME??
	      )
	     ;; record the position of various interesting chars, determine
	     ;; legality later.
	     ((setq record-pos-symbol

				(insert "%")
				(setq insert-point (point-max)))
			       (mail-extr-@-binds-tighter-than-!
				(setq insert-point (point-max)))
			       (%-pos
				(setq insert-point (mail-extr-last %-pos)
				      saved-%-pos (mapcar 'mail-extr-markerize %-pos)
				      %-pos nil
				      @-pos (mail-extr-markerize @-pos)))
			       (@-pos
				(setq insert-point @-pos)

37148:aca2b7839d21

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Utility functions and macros.
;;

(defsubst mail-extr-delete-char (n)
  ;; in v19, delete-char is compiled as a function call, but delete-region
  ;; is byte-coded, so it's much much faster.
  (delete-region (point) (+ (point) n)))

(defsubst mail-extr-skip-whitespace-forward ()
  ;; v19 fn skip-syntax-forward is more tasteful, but not byte-coded.
  (skip-chars-forward " \t\n\r\240"))

(defsubst mail-extr-skip-whitespace-backward ()
  ;; v19 fn skip-syntax-backward is more tasteful, but not byte-coded.
  (skip-chars-backward " \t\n\r\240"))


(defsubst mail-extr-undo-backslash-quoting (beg end)
  (save-excursion
    (save-restriction
      (narrow-to-region beg end)
      (goto-char (point-min))
      ;; undo \ quoting
      (while (search-forward "\\" nil t)
	(mail-extr-delete-char -1)
	(or (eobp)
	    (forward-char 1))))))

(defsubst mail-extr-nuke-char-at (pos)
  (save-excursion
    (goto-char pos)
    (mail-extr-delete-char 1)
    (insert ?\ )))

(put 'mail-extr-nuke-outside-range
     'edebug-form-spec '(symbolp &optional form form atom))

(defmacro mail-extr-nuke-outside-range (list-symbol

  ;; coerces pos to a marker if non-nil.
  (if (or (markerp pos) (null pos))
      pos
    (copy-marker pos)))

(defsubst mail-extr-safe-move-sexp (arg)
  ;; Safely skip over one balanced sexp, if there is one.  Return t if success.
  (condition-case error
      (progn
	(goto-char (or (scan-sexps (point) arg) (point)))
	t)
    (error
     ;; #### kludge kludge kludge kludge kludge kludge kludge !!!
     (if (string-equal (nth 1 error) "Unbalanced parentheses")
	 nil
       (while t
	 (signal (car error) (cdr error)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; The main function to grind addresses
;;

or more recipients, separated by commas, and we return a list of
the form ((FULL-NAME CANONICAL-ADDRESS) ...) with one element for
each recipient.  If ALL is nil, then if ADDRESS contains more than
one recipients, all but the first is ignored.

ADDRESS may be a string or a buffer.  If it is a buffer, the visible
 (narrowed) portion of the buffer will be interpreted as the address.
 (This feature exists so that the clever caller might be able to avoid
 consing a string.)"
  (let ((canonicalization-buffer (get-buffer-create " *canonical address*"))
	(extraction-buffer (get-buffer-create " *extract address components*"))
	value-list)

    (with-current-buffer (get-buffer-create extraction-buffer)
      (fundamental-mode)
      (buffer-disable-undo extraction-buffer)
      (set-syntax-table mail-extr-address-syntax-table)
      (widen)
      (erase-buffer)

	    (t
	     (error "Invalid address: %s" address)))

      (set-text-properties (point-min) (point-max) nil)

      (with-current-buffer (get-buffer-create canonicalization-buffer)
	(fundamental-mode)
	(buffer-disable-undo canonicalization-buffer)
	(setq case-fold-search nil))

      
      ;; Unfold multiple lines.
      (goto-char (point-min))

	      saved-%-pos saved-!-pos saved-@-pos
	      domain-pos \.-pos insert-point
	      ;;	mailbox-name-processed-flag
	      disable-initial-guessing-flag) ; dynamically set from -voodoo

	  (set-syntax-table mail-extr-address-syntax-table)
	  (goto-char (point-min))

	  ;; Insert extra space at beginning to allow later replacement with <
	  ;; without having to move markers.
	  (or (eq (following-char) ?\ )

		       (and >-pos
			    ;; handle weird munged addresses
			    ;; BUG FIX: This test was reversed.  Thanks to the
			    ;; brilliant Rod Whitby <[e-mail]>
			    ;; for discovering this!
			    (< (car (last <-pos)) (car >-pos)))))
	      ;; The argument contains more than one address.
	      ;; Temporarily hide everything after this one.
	      (setq end-of-address (copy-marker (1+ (point)) t))
	      (narrow-to-region (point-min) (1+ (point)))
	      (delete-char 1)
	      (setq char ?\() ; HAVE I NO SHAME??
	      )
	     ;; record the position of various interesting chars, determine
	     ;; legality later.
	     ((setq record-pos-symbol

				(insert "%")
				(setq insert-point (point-max)))
			       (mail-extr-@-binds-tighter-than-!
				(setq insert-point (point-max)))
			       (%-pos
				(setq insert-point (car (last %-pos))
				      saved-%-pos (mapcar 'mail-extr-markerize %-pos)
				      %-pos nil
				      @-pos (mail-extr-markerize @-pos)))
			       (@-pos
				(setq insert-point @-pos)