;;; mew-bq.el --- Base64 and Quoted-Printable encoding for Mew

;; Author:  Kazu Yamamoto <Kazu@Mew.org>
;; Created: Aug 20, 1997
;; Revised: Aug 26, 1997

;;; Code:

(defconst mew-bq-version "mew-bq.el version 0.02")

(require 'mew)

(defvar mew-header-encode-switch
  (list
   (cons "B" 'mew-header-encode-base64)
   (cons "Q" 'mew-header-encode-qp)
   ))

(defvar mew-header-decode-switch
  (list
   (cons "B" 'mew-header-decode-base64)
   (cons "Q" 'mew-header-decode-qp)
   ))

(defconst mew-base64-boundary1 26)
(defconst mew-base64-boundary2 52)
(defconst mew-base64-boundary3 62)
(defconst mew-base64-boundary4 63)

(defconst mew-header-decode-regex 
  "=\\?\\([^?]+\\)\\?\\(.\\)\\?\\([^?]+\\)\\?=")

;;;
;;;
;;;

(defun mew-header-encode (charset b-or-q cs-str cs)
  (let* ((str (mew-cs-encode-string cs-str cs))
	 (fun (cdr (mew-assoc-case-equal b-or-q mew-header-encode-switch 0))))
    (concat "=?" charset "?" b-or-q "?" (funcall fun str) "?=")))

(defun mew-header-decode (charset b-or-q str)
  ;; don't use mew-charset-to-cs because both us-ascii and unkown 
  ;; charset are represented as nil.
  (let* ((fun (cdr (mew-assoc-case-equal b-or-q mew-header-decode-switch 0)))
	 (cl (mew-assoc-case-equal charset mew-cs-charset 0))
	 (cs (nth 1 cl))
	 ret)
    (cond
     ((null cl)
      mew-error-unknown-charset)
     (cs
      (setq ret (mew-cs-decode-string (funcall fun str) cs))
      (while (string-match "[\000-\010\012-\037\177]+" ret)
	(setq ret (concat (substring ret 0 (match-beginning 0))
			  (substring ret (match-end 0)))))
      ret)
     (t
      str)
     )))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Base64 encoding
;;;

(defun mew-base64-char256 (ch64)
  (cond
   ((null ch64) 0)
   ((and (<= ?A ch64) (<= ch64 ?Z)) (- ch64 ?A))
   ((and (<= ?a ch64) (<= ch64 ?z)) (+ (- ch64 ?a) mew-base64-boundary1))
   ((and (<= ?0 ch64) (<= ch64 ?9)) (+ (- ch64 ?0) mew-base64-boundary2))
   ((char-equal ch64 ?+) mew-base64-boundary3)
   ((char-equal ch64 ?/) mew-base64-boundary4)
   ((char-equal ch64 ?=) 0)
   )
  )

(defun mew-header-encode-base64 (str256)
  (let* ((rest (% (length str256) 3))
	 (count 0)
	 zpad epad len end
	 (ret ""))
    (cond 
     ((= rest 0) (setq zpad 0 epad 0 end nil))
     ((= rest 1) (setq zpad 2 epad 2 end -2))
     ((= rest 2) (setq zpad 1 epad 1 end -1))
     )
    (setq str256 (concat str256 (make-string zpad 0)))
    (setq len (length str256))
    (while (< count len)
      (let ((char0 (aref str256 count))
	    (char1 (aref str256 (1+ count)))
	    (char2 (aref str256 (+ 2 count))))
	(setq ret
	      (concat
	       ret
	       (char-to-string (mew-base64-char64 (lsh char0 -2)))
	       (char-to-string
		(mew-base64-char64 (logior (lsh (logand char0 3) 4)
					   (lsh char1 -4))))
	       (char-to-string
		(mew-base64-char64 (logior (lsh (logand char1 15) 2)
					   (lsh char2 -6))))
	       (char-to-string (mew-base64-char64 (logand char2 63))) ;; xxx
	       )
	      )
	(setq count (+ count 3))
	))
    (concat (substring ret 0 end) (make-string epad ?=))
    ))
	      
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Base64 decoding
;;;

(defun mew-base64-char64 (ch256)
  (aref "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" 
	ch256)
  )

(defun mew-header-decode-base64 (str64)
  (let* ((len (length str64))
	 (pad 0)
	 (count 0)
	 (ret ""))
    (if (string-match "=+$" str64)
	(setq pad (- (match-end 0) (match-beginning 0))))
    (if (or (string-match "[^a-zA-Z0-9+/=]" str64)
	    (not (equal (* (/ len 4) 4) len))
	    (< pad 0)
	    (> pad 3))
	mew-error-illegal-base64 ;; return value
      (while (< count len)
	(let ((char0 (mew-base64-char256 (aref str64 count)))
	      (char1 (mew-base64-char256 (aref str64 (1+ count))))
	      (char2 (mew-base64-char256 (aref str64 (+ 2 count))))
	      (char3 (mew-base64-char256 (aref str64 (+ 3 count)))))
	  (setq ret
		(concat
		 ret
		 (char-to-string
		  (logand (logior (lsh char0 2) (lsh char1 -4)) 255))
		 (char-to-string 
		  (logand (logior (lsh char1 4) (lsh char2 -2)) 255))
		 (char-to-string
		  (logand (logior (lsh char2 6) char3) 255))
		 )
		)
	  (setq count (+ count 4))
	  ))
    (if (equal pad 0)
	ret
      (substring ret 0 (- pad))
      ))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Quoted-printable encoding
;;;

(defun mew-char-to-qhex (char)
  (concat "="
	  (char-to-string (aref "0123456789ABCDEF" (lsh char -4)))
	  (char-to-string (aref "0123456789ABCDEF" (logand char 15)))))

(defun mew-header-encode-qp (str)
  (let ((len (length str))
	(count 0)
	(ch nil)
	(ret))
    (while (< count len)
      (setq ch (aref str count))
      (cond
       ((and (> ch 32)
	     (< ch 126)
	     (not (equal ch ?=))
	     (not (equal ch ??))
	     (not (equal ch ?_)) ;; space
	     )
	(setq ret (concat ret (char-to-string ch)))
	)
       ((equal ch 32)
	(setq ret (concat ret "_"))
	)
       (t 
	(setq ret (concat ret (mew-char-to-qhex ch)))
	)
       )
      (setq count (1+ count))
      )
    ret
    ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Quoted-printable decoding
;;;

(defun mew-hexstring-to-int (hex)
  (let ((len (length hex))
	(count 0)
	(ch nil)
	(ret 0))
    (while (< count len)
      (setq ch (aref hex count))
      (cond
       ((and (<= ?0 ch) (<= ch ?9))
	(setq ret (+ (* ret 16) (- ch ?0))))
       ((and (<= ?A ch) (<= ch ?F))
	(setq ret (+ (* ret 16) (+ (- ch ?A) 10))))
       ((and (<= ?a ch) (<= ch ?f))
	(setq ret (+ (* ret 16) (+ (- ch ?a) 10))))
       )
      (setq count (1+ count))
      )
    ret
    ))

(defun mew-header-decode-qp (qpstr)
  (let ((start -1) (end))
    (while (string-match "_" qpstr)
      (aset qpstr (match-beginning 0) 32)) ;; 32 = space
    (while (string-match "=[0-9A-Z][0-9A-Z]" qpstr (1+ start))
      (setq start (match-beginning 0))
      (setq end (match-end 0))
      (setq qpstr
	    (concat (substring qpstr 0 start)
		    (char-to-string (mew-hexstring-to-int 
				     (substring qpstr (1+ start) end)))
		    (substring qpstr end nil))))
    qpstr
    ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; RFC 2047 encoding
;;

(defun mew-cs-separate-region (beg end)
  "Separate the region into sub-regions where the same cs
is continuous. Return list of (start end cs)."
  (interactive "r")
  (if (equal beg end)
      () ;; just in case
    (goto-char beg)
    (let (start last ocode ncode ret)
      (setq start (point))
      (forward-char) ;; independent on internal code v^^
      (setq last (point))
      (setq ocode (mew-find-cs-region start last))
      (while (< (point) end)
	(forward-char)
	(setq ncode (mew-find-cs-region last (point)))
	(if (equal ocode ncode)
	    ()
	  ;; ocode is list... so use a lot of cons
	  (setq ret (cons (cons start (cons last ocode)) ret))
	  (setq ocode ncode)
	  (setq ncode nil)
	  (setq start last))
	(setq last (point)))
      ;; ocode is list... so use a lot of cons
      (setq ret (cons (cons start (cons (point) ocode)) ret))
      (nreverse ret))))

(defun mew-cs-grouping-magic (csl)
  "Make cs for latin to be encoded with Q and ASCII the same group.
Return a list of (start end one-entry-of-*mew-cs-for-header*)."
  (if (null csl)
      ()
    (let ((a (car csl)) lgroup cgroup lvec ret)
      (setq csl (cdr csl))
      (setq lvec (make-vector 3 nil))
      (aset lvec 0 (nth 0 a))
      (aset lvec 1 (nth 1 a))
      (setq lgroup (mew-assoc-member (nth 2 a) mew-cs-for-header 1))
      (aset lvec 2 lgroup)
      (while csl
	(setq a (car csl))
	(setq csl (cdr csl))
	(setq cgroup (mew-assoc-member (nth 2 a) mew-cs-for-header 1))
	(cond
	 ((equal lgroup cgroup)
	  (aset lvec 1 (nth 1 a)))
	 ((and (equal (nth 3 cgroup) "Q")
	       (equal (nth 1 lgroup) (list mew-lc-ascii)))
	  (aset lvec 1 (nth 1 a))
	  (aset lvec 2 cgroup))
	 ((and (equal (nth 3 lgroup) "Q")
	       (equal (nth 1 cgroup) (list mew-lc-ascii)))
	  (aset lvec 1 (nth 1 a)))
	 (t
	  (setq ret (cons lvec ret))
	  (setq lvec (make-vector 3 nil))
	  (aset lvec 0 (nth 0 a))
	  (aset lvec 1 (nth 1 a))
	  (aset lvec 2 cgroup)
	  (setq lgroup cgroup))
	 ))
      (setq ret (cons lvec ret))
      (nreverse ret)
      )
    ))

;;
;; Unlike mew-header-decode-{text,address}, 
;; mew-header-encode-{text,address} SHOULD be called with region.

(defun mew-header-encode-text (beg end)
  ;; RFC 2047 encoding for 'text'.
  ;; This violates RFC 2047 on two points.
  ;; (1) Each line may be resulted in more than 75 chars.
  ;; (2) 'text' and 'encoded-word' may not be separated by
  ;;    'linear-white-space'
  (if (or (equal beg end)
	  (equal mew-cs-ascii (mew-find-cs-region beg end)))
      ();; fast path
    (let ((spec (mew-cs-grouping-magic
		 (mew-cs-separate-region beg end)))
	  (str (buffer-substring beg end))
	  (first t)
	  substr1 charset1 cs1 b-or-q1
	  substr2 charset2 cs2 b-or-q2 s2)
      (goto-char beg);; just in case
      (delete-region beg end)
      ;;
      (setq s2 (car spec))
      (setq spec (cdr spec))
      (setq substr2  (substring str (- (aref s2 0) beg) (- (aref s2 1) beg)))
      (setq charset2 (nth 0 (aref s2 2)))
      (setq cs2      (nth 2 (aref s2 2)))
      (setq b-or-q2  (nth 3 (aref s2 2)))
      (while spec
	(setq substr1 substr2)
	(setq charset1 charset2)
	(setq cs1 cs2)
	(setq b-or-q1 b-or-q2)
	;;
	(setq s2 (car spec))
	(setq spec (cdr spec))
	;;
	(setq substr2  (substring str (- (aref s2 0) beg) (- (aref s2 1) beg)))
	(setq charset2 (nth 0 (aref s2 2)))
	(setq cs2      (nth 2 (aref s2 2)))
	(setq b-or-q2  (nth 3 (aref s2 2)))
	(cond
	 ((not (or (null b-or-q1) (null b-or-q2)))
	  ;; in between 'encoded-word's
	  (insert (mew-header-encode charset1 b-or-q1 substr1 cs1))
	  (insert "\n ") ;; ignored when decoded
	  )
	 ((null b-or-q1)
	  ;; b-or-q2 is "B"
	  (cond
	   ((string-match "^[ \t]+$" substr1)
	    (setq substr2 (concat substr1 substr2))
	    ;; fold it to save length
	    (insert "\n ")  ;; ignored when decoded
	    )
	   ((string-match "[ \t]$" substr1)
	    (if first
		(progn
		  (insert substr1)
		  (setq first nil))
	      (insert (substring substr1 0 -1))
	      (insert "\n") ;; fold it to save length
	      (insert (substring substr1 -1 nil));; preserved when decoded
	      ))
	   (t
	    ;; not fold
	    (insert substr1))
	   ))
	 (t 
	  ;; b-or-q1 is "B" and b-or-q2 is nil
	  (insert (mew-header-encode charset1 b-or-q1 substr1 cs1))
	  (cond
	   ((string-match "^[ \t]+$" substr2)
	    ()) ;; nothing
	   ((or (string-match "^[ \t][^ \t]+[ \t]$" substr2)
		(and (string-match "^[ \t][^ \t]+" substr2) (null spec)))
	    (insert "\n") ;; fold it to save length
	    (insert (substring substr2 0 1));; preserved when decoded
	    (setq substr2 (substring substr2 1 nil))
	    )
	   (t
	    ()) ;; nothing
	   )
	  )
	 )
	);; end of while
      (if b-or-q2
	  (insert (mew-header-encode charset2 b-or-q2 substr2 cs2))
	(insert substr2))
      )))

(defun mew-header-encode-address (beg end)
  ;; RFC 2047 encoding for 'text'.
  ;; This violates RFC 2047 on two points.
  ;; (1) Each line may be resulted in more than 75 chars.
  ;; (2) Not check for 'qtext'.
  (if (or (equal beg end)
	  (equal mew-cs-ascii (mew-find-cs-region beg end)))
      ();; fast path
    (let ((spec (mew-cs-grouping-magic
		 (mew-cs-separate-region beg end)))
	  (str (buffer-substring beg end))
	  substr1 charset1 cs1 b-or-q1 s1)
      (goto-char beg);; just in case
      (delete-region beg end)
      ;;
      (while spec
	(setq s1 (car spec))
	(setq spec (cdr spec))
	(setq substr1  (substring str (- (aref s1 0) beg) 
				  (- (aref s1 1) beg)))
	(setq charset1 (nth 0 (aref s1 2)))
	(setq cs1      (nth 2 (aref s1 2)))
	(setq b-or-q1  (nth 3 (aref s1 2)))
	(if b-or-q1
	    (insert (mew-header-encode charset1 b-or-q1 substr1 cs1))
	  (insert substr1))
	))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; RFC 2047 decoding
;;

(defun mew-header-decode-region (addrp rbeg rend &optional unfold)
  ;; RFC 2047 decoding. This is liberal on the one point from RFC 2047.
  ;; (1) Each line may be more than 75.
  (save-restriction
    (narrow-to-region rbeg rend)
    (goto-char (point-min))
    (if (and (not unfold) 
	     (not (re-search-forward mew-header-decode-regex nil t)))
	() ;; let it be
      (let ((regex (concat "\"\\|" mew-header-decode-regex))
	    beg end cs-str)
	(goto-char (point-min))
	(cond
	 (addrp
	  ;; If each line doesn't end with ",", unfold it.
	  ;; In Page 5 of RFC822 says, "Unfolding is accomplished by
	  ;; regarding CRLF immediately followed by a LWSP-char as
	  ;; equivalent to the LWSP-char". However, it also says, 
	  ;; "In structured field bodies, multiple linear space ASCII 
	  ;; characters (namely HTABs and SPACEs) are treated as single 
	  ;; spaces and may freely surround any symbol." So, remove
	  ;; continuous white spaces.
	  (while (re-search-forward ",[ \t]+\n" nil t)
	    (replace-match ",\n" nil t))
	  (goto-char (point-min))
	  (while (re-search-forward "\\([^,]\\)[ \t]*\n[ \t]+" nil t)
	    (replace-match (concat (mew-match 1) " ") nil t)))
	 (t ;; text
	  ;; In Page 5 of RFC822 says, "Unfolding is accomplished by
	  ;; regarding CRLF immediately followed by a LWSP-char as
	  ;; equivalent to the LWSP-char".
	  (while (re-search-forward "\n\\([ \t]\\)" nil t)
	    (replace-match (mew-match 1) nil t))
	  )
	 )
	(goto-char (point-min))
	;; In Page 10 of RFC 2047 says, "When displaying a particular 
	;; header field that contains multiple 'encoded-word's, any 
	;; 'linear-white-space' that separates a pair of adjacent 
	;; 'encoded-word's is ignored".
	(goto-char (point-min))
	(while (re-search-forward "\\?=[ \t]+=\\?" nil t)
	  (replace-match "?==?" nil t))
	(goto-char (point-min))
	(while (re-search-forward regex nil t)
	  (if (eq (char-after (match-beginning 0)) ?\")
	      (if (re-search-forward "[^\\]\"" nil t)
		  (goto-char (match-end 0)))
	    (setq beg (match-beginning 0)
		  end (match-end 0)
		  cs-str (mew-header-decode (mew-match 1)
					    (mew-match 2)
					    (mew-match 3)))
	    (delete-region beg end)
	    (insert cs-str)))
	))
    (goto-char (point-max))))

(provide 'mew-bq)

;;; Copyright Notice:

;; Copyright (C) 1997, 1998 Mew developing team.
;; All rights reserved.

;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;; 
;; 1. Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;; 2. Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;; 3. All advertising materials mentioning features or use of this software
;;    must display the following acknowledgement:
;;       This product includes software developed by 
;;       Mew developing team and its contributors.
;; 4. Neither the name of the team nor the names of its contributors
;;    may be used to endorse or promote products derived from this software
;;    without specific prior written permission.
;; 
;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND
;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
;; PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE
;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;;; mew-bq.el ends here
