lisp/mail/qp.el

   1 ;;; qp.el --- Quoted-Printable functions
   2
   3 ;; Copyright (C) 1998-2018 Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: mail, extensions
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; Functions for encoding and decoding quoted-printable text as
  26 ;; defined in RFC 2045.
  27
  28 ;;; Code:
  29
  30 ;;;###autoload
  31 (defun quoted-printable-decode-region (from to &optional coding-system)
  32   "Decode quoted-printable in the region between FROM and TO, per RFC 2045.
  33 If CODING-SYSTEM is non-nil, decode bytes into characters with that
  34 coding-system.
  35
  36 Interactively, you can supply the CODING-SYSTEM argument
  37 with \\[universal-coding-system-argument].
  38
  39 The CODING-SYSTEM argument is a historical hangover and is deprecated.
  40 QP encodes raw bytes and should be decoded into raw bytes.  Decoding
  41 them into characters should be done separately."
  42   (interactive
  43    ;; Let the user determine the coding system with "C-x RET c".
  44    (list (region-beginning) (region-end) coding-system-for-read))
  45   (when (and coding-system
  46              (not (coding-system-p coding-system))) ; e.g. `ascii' from Gnus
  47     (setq coding-system nil))
  48   (save-excursion
  49     (save-restriction
  50       ;; RFC 2045:  ``An "=" followed by two hexadecimal digits, one
  51       ;; or both of which are lowercase letters in "abcdef", is
  52       ;; formally illegal. A robust implementation might choose to
  53       ;; recognize them as the corresponding uppercase letters.''
  54       (let ((case-fold-search t))
  55         (narrow-to-region from to)
  56         ;; Do this in case we're called from Gnus, say, in a buffer
  57         ;; which already contains non-ASCII characters which would
  58         ;; then get doubly-decoded below.
  59         (if coding-system
  60             (encode-coding-region (point-min) (point-max) coding-system))
  61         (goto-char (point-min))
  62         (while (and (skip-chars-forward "^=")
  63                     (not (eobp)))
  64           (cond ((eq (char-after (1+ (point))) ?\n)
  65                  (delete-char 2))
  66                 ((looking-at "\\(=[0-9A-F][0-9A-F]\\)+")
  67                  ;; Decode this sequence at once; i.e. by a single
  68                  ;; deletion and insertion.
  69                  (let* ((n (/ (- (match-end 0) (point)) 3))
  70                         (str (make-string n 0)))
  71                    (dotimes (i n)
  72                      (let ((n1 (char-after (1+ (point))))
  73                            (n2 (char-after (+ 2 (point)))))
  74                        (aset str i
  75                              (+ (* 16 (- n1 (if (<= n1 ?9) ?0
  76                                               (if (<= n1 ?F) (- ?A 10)
  77                                                 (- ?a 10)))))
  78                                 (- n2 (if (<= n2 ?9) ?0
  79                                         (if (<= n2 ?F) (- ?A 10)
  80                                           (- ?a 10)))))))
  81                      (forward-char 3))
  82                    (delete-region (match-beginning 0) (match-end 0))
  83                    (insert str)))
  84                 (t
  85                  (message "Malformed quoted-printable text")
  86                  (forward-char)))))
  87       (if coding-system
  88           (decode-coding-region (point-min) (point-max) coding-system)))))
  89
  90 (defun quoted-printable-decode-string (string &optional coding-system)
  91   "Decode the quoted-printable encoded STRING and return the result.
  92 If CODING-SYSTEM is non-nil, decode the string with coding-system.
  93 Use of CODING-SYSTEM is deprecated; this function should deal with
  94 raw bytes, and coding conversion should be done separately."
  95   (with-temp-buffer
  96     (set-buffer-multibyte nil)
  97     (insert string)
  98     (quoted-printable-decode-region (point-min) (point-max) coding-system)
  99     (buffer-string)))
 100
 101 (defun quoted-printable-encode-region (from to &optional fold class)
 102   "Quoted-printable encode the region between FROM and TO per RFC 2045.
 103
 104 If FOLD, fold long lines at 76 characters (as required by the RFC).
 105 If CLASS is non-nil, translate the characters not matched by that
 106 regexp class, which is in the form expected by `skip-chars-forward'.
 107 You should probably avoid non-ASCII characters in this arg.
 108
 109 If `mm-use-ultra-safe-encoding' is set, fold lines unconditionally and
 110 encode lines starting with \"From\"."
 111   (interactive "r")
 112   (unless class
 113     ;; Avoid using 8bit characters. = is \075.
 114     ;; Equivalent to "^\000-\007\013\015-\037\200-\377="
 115     (setq class "\010-\012\014\040-\074\076-\177"))
 116   (save-excursion
 117     (goto-char from)
 118     (if (re-search-forward (string-to-multibyte "[^\x0-\x7f\x80-\xff]")
 119                            to t)
 120         (error "Multibyte character in QP encoding region"))
 121     (save-restriction
 122       (narrow-to-region from to)
 123       ;; Encode all the non-ascii and control characters.
 124       (goto-char (point-min))
 125       (while (and (skip-chars-forward class)
 126                   (not (eobp)))
 127         (insert
 128          (prog1
 129              (format "=%02X" (char-after))
 130            (delete-char 1))))
 131       ;; Encode white space at the end of lines.
 132       (goto-char (point-min))
 133       (while (re-search-forward "[ \t]+$" nil t)
 134         (goto-char (match-beginning 0))
 135         (while (not (eolp))
 136           (insert
 137            (prog1
 138                (format "=%02X" (char-after))
 139              (delete-char 1)))))
 140       (let ((ultra
 141              (and (boundp 'mm-use-ultra-safe-encoding)
 142                   mm-use-ultra-safe-encoding)))
 143         (when (or fold ultra)
 144           (let ((tab-width 1)           ; HTAB is one character.
 145                 (case-fold-search nil))
 146             (goto-char (point-min))
 147             (while (not (eobp))
 148               ;; In ultra-safe mode, encode "From " at the beginning
 149               ;; of a line.
 150               (when ultra
 151                 (if (looking-at "From ")
 152                     (replace-match "From=20" nil t)
 153                   (if (looking-at "-")
 154                       (replace-match "=2D" nil t))))
 155               (end-of-line)
 156               ;; Fold long lines.
 157               (while (> (current-column) 76) ; tab-width must be 1.
 158                 (beginning-of-line)
 159                 (forward-char 75)       ; 75 chars plus an "="
 160                 (search-backward "=" (- (point) 2) t)
 161                 (insert "=\n")
 162                 (end-of-line))
 163               (forward-line))))))))
 164
 165 (defun quoted-printable-encode-string (string)
 166   "Encode the STRING as quoted-printable and return the result."
 167   (with-temp-buffer
 168     (if (multibyte-string-p string)
 169         (set-buffer-multibyte 'to)
 170       (set-buffer-multibyte nil))
 171     (insert string)
 172     (quoted-printable-encode-region (point-min) (point-max))
 173     (buffer-string)))
 174
 175 (provide 'qp)
 176
 177 ;;; qp.el ends here