mmbuffer.el

   1 ;;; mmbuffer.el --- MIME entity module for binary buffer
   2
   3 ;; Copyright (C) 1998,1999,2000 Free Software Foundation, Inc.
   4
   5 ;; Author: MORIOKA Tomohiko <tomo@m17n.org>
   6 ;; Keywords: MIME, multimedia, mail, news
   7
   8 ;; This file is part of FLIM (Faithful Library about Internet Message).
   9
  10 ;; This program is free software; you can redistribute it and/or
  11 ;; modify it under the terms of the GNU General Public License as
  12 ;; published by the Free Software Foundation; either version 2, or (at
  13 ;; your option) any later version.
  14
  15 ;; This program is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; 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; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Code:
  26
  27 (require 'mmgeneric)
  28 (require 'mime)
  29
  30 (eval-and-compile
  31   (luna-define-class mime-buffer-entity (mime-entity)
  32                      (buffer
  33                       header-start
  34                       header-end
  35                       body-start
  36                       body-end))
  37
  38   (luna-define-internal-accessors 'mime-buffer-entity)
  39   )
  40
  41 (luna-define-method initialize-instance :after ((entity mime-buffer-entity)
  42                                                 &rest init-args)
  43   (or (mime-buffer-entity-buffer-internal entity)
  44       (mime-buffer-entity-set-buffer-internal
  45        entity (get-buffer (mime-entity-location-internal entity))))
  46   (save-excursion
  47     (set-buffer (mime-buffer-entity-buffer-internal entity))
  48     (let ((header-start
  49            (or (mime-buffer-entity-header-start-internal entity)
  50                (mime-buffer-entity-set-header-start-internal
  51                 entity (point-min))))
  52           (header-end (mime-buffer-entity-header-end-internal entity))
  53           (body-start (mime-buffer-entity-body-start-internal entity))
  54           (body-end
  55            (or (mime-buffer-entity-body-end-internal entity)
  56                (mime-buffer-entity-set-body-end-internal entity (point-max)))))
  57       (goto-char header-start)
  58       (unless (and header-end body-start)
  59         (if (re-search-forward "^$" body-end t)
  60             (setq header-end (match-end 0)
  61                   body-start (if (= header-end body-end)
  62                                  body-end
  63                                (1+ header-end)))
  64           (setq header-end (point-min)
  65                 body-start (point-min)))
  66         (mime-buffer-entity-set-header-end-internal entity header-end)
  67         (mime-buffer-entity-set-body-start-internal entity body-start)
  68         )
  69       (or (mime-entity-content-type-internal entity)
  70           (save-restriction
  71             (narrow-to-region header-start header-end)
  72             (mime-entity-set-content-type-internal
  73              entity
  74              (let ((str (std11-fetch-field "Content-Type")))
  75                (if str
  76                    (mime-parse-Content-Type str)
  77                  )))
  78             ))
  79       ))
  80   entity)
  81
  82 (luna-define-method mime-entity-name ((entity mime-buffer-entity))
  83   (buffer-name (mime-buffer-entity-buffer-internal entity))
  84   )
  85
  86
  87 ;;; @ entity
  88 ;;;
  89
  90 (luna-define-method mime-insert-entity ((entity mime-buffer-entity))
  91   (insert-buffer-substring (mime-buffer-entity-buffer-internal entity)
  92                            (mime-buffer-entity-header-start-internal entity)
  93                            (mime-buffer-entity-body-end-internal entity))
  94   )
  95
  96 (luna-define-method mime-write-entity ((entity mime-buffer-entity) filename)
  97   (save-excursion
  98     (set-buffer (mime-buffer-entity-buffer-internal entity))
  99     (write-region-as-raw-text-CRLF
 100      (mime-buffer-entity-header-start-internal entity)
 101      (mime-buffer-entity-body-end-internal entity)
 102      filename)
 103     ))
 104
 105
 106 ;;; @ entity header
 107 ;;;
 108
 109
 110 ;;; @ entity body
 111 ;;;
 112
 113 (luna-define-method mime-entity-body ((entity mime-buffer-entity))
 114   (save-excursion
 115     (set-buffer (mime-buffer-entity-buffer-internal entity))
 116     (buffer-substring (mime-buffer-entity-body-start-internal entity)
 117                       (mime-buffer-entity-body-end-internal entity))))
 118
 119 (luna-define-method mime-insert-entity-body ((entity mime-buffer-entity))
 120   (insert-buffer-substring (mime-buffer-entity-buffer-internal entity)
 121                            (mime-buffer-entity-body-start-internal entity)
 122                            (mime-buffer-entity-body-end-internal entity))
 123   )
 124
 125 (luna-define-method mime-write-entity-body ((entity mime-buffer-entity)
 126                                             filename)
 127   (save-excursion
 128     (set-buffer (mime-buffer-entity-buffer-internal entity))
 129     (write-region-as-binary (mime-buffer-entity-body-start-internal entity)
 130                             (mime-buffer-entity-body-end-internal entity)
 131                             filename)
 132     ))
 133
 134
 135 ;;; @ entity content
 136 ;;;
 137
 138 (luna-define-method mime-entity-content ((entity mime-buffer-entity))
 139   (save-excursion
 140     (set-buffer (mime-buffer-entity-buffer-internal entity))
 141     (mime-decode-string
 142      (buffer-substring (mime-buffer-entity-body-start-internal entity)
 143                        (mime-buffer-entity-body-end-internal entity))
 144      (mime-entity-encoding entity))))
 145
 146 (luna-define-method mime-insert-entity-content ((entity mime-buffer-entity))
 147   (insert (with-current-buffer (mime-buffer-entity-buffer-internal entity)
 148             (mime-decode-string
 149              (buffer-substring (mime-buffer-entity-body-start-internal entity)
 150                                (mime-buffer-entity-body-end-internal entity))
 151              (mime-entity-encoding entity)))))
 152
 153 (luna-define-method mime-write-entity-content ((entity mime-buffer-entity)
 154                                                filename)
 155   (save-excursion
 156     (set-buffer (mime-buffer-entity-buffer-internal entity))
 157     (mime-write-decoded-region (mime-buffer-entity-body-start-internal entity)
 158                                (mime-buffer-entity-body-end-internal entity)
 159                                filename
 160                                (or (mime-entity-encoding entity) "7bit"))
 161     ))
 162
 163
 164 ;;; @ header field
 165 ;;;
 166
 167 (luna-define-method mime-entity-fetch-field :around
 168   ((entity mime-buffer-entity) field-name)
 169   (or (luna-call-next-method)
 170       (save-excursion
 171         (set-buffer (mime-buffer-entity-buffer-internal entity))
 172         (save-restriction
 173           (narrow-to-region (mime-buffer-entity-header-start-internal entity)
 174                             (mime-buffer-entity-header-end-internal entity))
 175           (let ((ret (std11-fetch-field field-name)))
 176             (when ret
 177               (or (symbolp field-name)
 178                   (setq field-name
 179                         (intern (capitalize (capitalize field-name)))))
 180               (mime-entity-set-original-header-internal
 181                entity
 182                (put-alist field-name ret
 183                           (mime-entity-original-header-internal entity)))
 184               ret))))))
 185
 186 (luna-define-method mime-insert-header ((entity mime-buffer-entity)
 187                                         &optional invisible-fields
 188                                         visible-fields)
 189   (mime-insert-header-from-buffer
 190    (mime-buffer-entity-buffer-internal entity)
 191    (mime-buffer-entity-header-start-internal entity)
 192    (mime-buffer-entity-header-end-internal entity)
 193    invisible-fields visible-fields)
 194   )
 195
 196
 197 ;;; @ header buffer
 198 ;;;
 199
 200 ;; (luna-define-method mime-entity-header-buffer ((entity mime-buffer-entity))
 201 ;;   (mime-buffer-entity-buffer-internal entity)
 202 ;;   )
 203
 204 ;; (luna-define-method mime-goto-header-start-point ((entity mime-buffer-entity))
 205 ;;   (set-buffer (mime-buffer-entity-buffer-internal entity))
 206 ;;   (goto-char (mime-buffer-entity-header-start-internal entity))
 207 ;;   )
 208
 209 ;; (luna-define-method mime-entity-header-start-point ((entity
 210 ;;                                                      mime-buffer-entity))
 211 ;;   (mime-buffer-entity-header-start-internal entity)
 212 ;;   )
 213
 214 ;; (luna-define-method mime-entity-header-end-point ((entity
 215 ;;                                                    mime-buffer-entity))
 216 ;;   (mime-buffer-entity-header-end-internal entity)
 217 ;;   )
 218
 219
 220 ;;; @ body buffer
 221 ;;;
 222
 223 ;; (luna-define-method mime-entity-body-buffer ((entity mime-buffer-entity))
 224 ;;   (mime-buffer-entity-buffer-internal entity)
 225 ;;   )
 226
 227 ;; (luna-define-method mime-goto-body-start-point ((entity mime-buffer-entity))
 228 ;;   (set-buffer (mime-buffer-entity-buffer-internal entity))
 229 ;;   (goto-char (mime-buffer-entity-body-start-internal entity))
 230 ;;   )
 231
 232 ;; (luna-define-method mime-goto-body-end-point ((entity mime-buffer-entity))
 233 ;;   (set-buffer (mime-buffer-entity-buffer-internal entity))
 234 ;;   (goto-char (mime-buffer-entity-body-end-internal entity))
 235 ;;   )
 236
 237 ;; (luna-define-method mime-entity-body-start-point ((entity mime-buffer-entity))
 238 ;;   (mime-buffer-entity-body-start-internal entity)
 239 ;;   )
 240
 241 ;; (luna-define-method mime-entity-body-end-point ((entity mime-buffer-entity))
 242 ;;   (mime-buffer-entity-body-end-internal entity)
 243 ;;   )
 244
 245
 246 ;;; @ buffer (obsolete)
 247 ;;;
 248
 249 ;; (luna-define-method mime-entity-buffer ((entity mime-buffer-entity))
 250 ;;   (mime-buffer-entity-buffer-internal entity)
 251 ;;   )
 252
 253 ;; (luna-define-method mime-entity-point-min ((entity mime-buffer-entity))
 254 ;;   (mime-buffer-entity-header-start-internal entity)
 255 ;;   )
 256
 257 ;; (luna-define-method mime-entity-point-max ((entity mime-buffer-entity))
 258 ;;   (mime-buffer-entity-body-end-internal entity)
 259 ;;   )
 260
 261
 262 ;;; @ children
 263 ;;;
 264
 265 (defun mmbuffer-parse-multipart (entity)
 266   (with-current-buffer (mime-buffer-entity-buffer-internal entity)
 267     (let* ((representation-type
 268             (mime-entity-representation-type-internal entity))
 269            (content-type (mime-entity-content-type-internal entity))
 270            (dash-boundary
 271             (concat "--"
 272                     (mime-content-type-parameter content-type "boundary")))
 273            (delimiter       (concat "\n" (regexp-quote dash-boundary)))
 274            (close-delimiter (concat delimiter "--[ \t]*$"))
 275            (rsep (concat delimiter "[ \t]*\n"))
 276            (dc-ctl
 277             (if (eq (mime-content-type-subtype content-type) 'digest)
 278                 (make-mime-content-type 'message 'rfc822)
 279               (make-mime-content-type 'text 'plain)
 280               ))
 281            (body-start (mime-buffer-entity-body-start-internal entity))
 282            (body-end (mime-buffer-entity-body-end-internal entity)))
 283       (save-restriction
 284         (goto-char body-end)
 285         (narrow-to-region body-start
 286                           (if (re-search-backward close-delimiter nil t)
 287                               (match-beginning 0)
 288                             body-end))
 289         (goto-char body-start)
 290         (if (re-search-forward
 291              (concat "^" (regexp-quote dash-boundary) "[ \t]*\n")
 292              nil t)
 293             (let ((cb (match-end 0))
 294                   ce ncb ret children
 295                   (node-id (mime-entity-node-id-internal entity))
 296                   (i 0))
 297               (while (re-search-forward rsep nil t)
 298                 (setq ce (match-beginning 0))
 299                 (setq ncb (match-end 0))
 300                 (save-restriction
 301                   (narrow-to-region cb ce)
 302                   (setq ret (mime-parse-message representation-type dc-ctl
 303                                                 entity (cons i node-id)))
 304                   )
 305                 (setq children (cons ret children))
 306                 (goto-char (setq cb ncb))
 307                 (setq i (1+ i))
 308                 )
 309               (setq ce (point-max))
 310               (save-restriction
 311                 (narrow-to-region cb ce)
 312                 (setq ret (mime-parse-message representation-type dc-ctl
 313                                               entity (cons i node-id)))
 314                 )
 315               (setq children (cons ret children))
 316               (mime-entity-set-children-internal entity (nreverse children))
 317               )
 318           (mime-entity-set-content-type-internal
 319            entity (make-mime-content-type 'message 'x-broken))
 320           nil)
 321         ))))
 322
 323 (defun mmbuffer-parse-encapsulated (entity &optional external)
 324   (mime-entity-set-children-internal
 325    entity
 326    (with-current-buffer (mime-buffer-entity-buffer-internal entity)
 327      (save-restriction
 328        (narrow-to-region (mime-buffer-entity-body-start-internal entity)
 329                          (mime-buffer-entity-body-end-internal entity))
 330        (list (mime-parse-message
 331               (if external
 332                   (progn
 333                     (require 'mmexternal)
 334                     'mime-external-entity)
 335                 (mime-entity-representation-type-internal entity))
 336               nil
 337               entity (cons 0 (mime-entity-node-id-internal entity))))))))
 338
 339 (luna-define-method mime-entity-children ((entity mime-buffer-entity))
 340   (let* ((content-type (mime-entity-content-type entity))
 341          (primary-type (mime-content-type-primary-type content-type))
 342          sub-type)
 343     (cond ((eq primary-type 'multipart)
 344            (mmbuffer-parse-multipart entity))
 345           ((eq primary-type 'message)
 346            (setq sub-type (mime-content-type-subtype content-type))
 347            (cond ((eq sub-type 'external-body)
 348                   (mmbuffer-parse-encapsulated entity 'external))
 349                  ((memq sub-type '(rfc822 news))
 350                   (mmbuffer-parse-encapsulated entity)))))))
 351
 352
 353 ;;; @ end
 354 ;;;
 355
 356 (provide 'mmbuffer)
 357
 358 ;;; mmbuffer.el ends here