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     (let ((coding-system-for-write 'raw-text-dos))
 100       (write-region (mime-buffer-entity-header-start-internal entity)
 101                     (mime-buffer-entity-body-end-internal entity)
 102                     filename))))
 103
 104
 105 ;;; @ entity header
 106 ;;;
 107
 108
 109 ;;; @ entity body
 110 ;;;
 111
 112 (luna-define-method mime-entity-body ((entity mime-buffer-entity))
 113   (save-excursion
 114     (set-buffer (mime-buffer-entity-buffer-internal entity))
 115     (buffer-substring (mime-buffer-entity-body-start-internal entity)
 116                       (mime-buffer-entity-body-end-internal entity))))
 117
 118 (luna-define-method mime-insert-entity-body ((entity mime-buffer-entity))
 119   (insert-buffer-substring (mime-buffer-entity-buffer-internal entity)
 120                            (mime-buffer-entity-body-start-internal entity)
 121                            (mime-buffer-entity-body-end-internal entity))
 122   )
 123
 124 (luna-define-method mime-write-entity-body ((entity mime-buffer-entity)
 125                                             filename)
 126   (save-excursion
 127     (set-buffer (mime-buffer-entity-buffer-internal entity))
 128     (write-region-as-binary (mime-buffer-entity-body-start-internal entity)
 129                             (mime-buffer-entity-body-end-internal entity)
 130                             filename)
 131     ))
 132
 133
 134 ;;; @ entity content
 135 ;;;
 136
 137 (luna-define-method mime-entity-content ((entity mime-buffer-entity))
 138   (save-excursion
 139     (set-buffer (mime-buffer-entity-buffer-internal entity))
 140     (mime-decode-string
 141      (buffer-substring (mime-buffer-entity-body-start-internal entity)
 142                        (mime-buffer-entity-body-end-internal entity))
 143      (mime-entity-encoding entity))))
 144
 145 (luna-define-method mime-insert-entity-content ((entity mime-buffer-entity))
 146   (insert (with-current-buffer (mime-buffer-entity-buffer-internal entity)
 147             (mime-decode-string
 148              (buffer-substring (mime-buffer-entity-body-start-internal entity)
 149                                (mime-buffer-entity-body-end-internal entity))
 150              (mime-entity-encoding entity)))))
 151
 152 (luna-define-method mime-write-entity-content ((entity mime-buffer-entity)
 153                                                filename)
 154   (save-excursion
 155     (set-buffer (mime-buffer-entity-buffer-internal entity))
 156     (mime-write-decoded-region (mime-buffer-entity-body-start-internal entity)
 157                                (mime-buffer-entity-body-end-internal entity)
 158                                filename
 159                                (or (mime-entity-encoding entity) "7bit"))
 160     ))
 161
 162
 163 ;;; @ header field
 164 ;;;
 165
 166 (luna-define-method mime-entity-fetch-field :around
 167   ((entity mime-buffer-entity) field-name)
 168   (or (luna-call-next-method)
 169       (save-excursion
 170         (set-buffer (mime-buffer-entity-buffer-internal entity))
 171         (save-restriction
 172           (narrow-to-region (mime-buffer-entity-header-start-internal entity)
 173                             (mime-buffer-entity-header-end-internal entity))
 174           (let ((ret (std11-fetch-field field-name)))
 175             (when ret
 176               (or (symbolp field-name)
 177                   (setq field-name
 178                         (intern (capitalize (capitalize field-name)))))
 179               (mime-entity-set-original-header-internal
 180                entity
 181                (put-alist field-name ret
 182                           (mime-entity-original-header-internal entity)))
 183               ret))))))
 184
 185 (luna-define-method mime-insert-header ((entity mime-buffer-entity)
 186                                         &optional invisible-fields
 187                                         visible-fields)
 188   (mime-insert-header-from-buffer
 189    (mime-buffer-entity-buffer-internal entity)
 190    (mime-buffer-entity-header-start-internal entity)
 191    (mime-buffer-entity-header-end-internal entity)
 192    invisible-fields visible-fields)
 193   )
 194
 195
 196 ;;; @ header buffer
 197 ;;;
 198
 199 ;; (luna-define-method mime-entity-header-buffer ((entity mime-buffer-entity))
 200 ;;   (mime-buffer-entity-buffer-internal entity)
 201 ;;   )
 202
 203 ;; (luna-define-method mime-goto-header-start-point ((entity mime-buffer-entity))
 204 ;;   (set-buffer (mime-buffer-entity-buffer-internal entity))
 205 ;;   (goto-char (mime-buffer-entity-header-start-internal entity))
 206 ;;   )
 207
 208 ;; (luna-define-method mime-entity-header-start-point ((entity
 209 ;;                                                      mime-buffer-entity))
 210 ;;   (mime-buffer-entity-header-start-internal entity)
 211 ;;   )
 212
 213 ;; (luna-define-method mime-entity-header-end-point ((entity
 214 ;;                                                    mime-buffer-entity))
 215 ;;   (mime-buffer-entity-header-end-internal entity)
 216 ;;   )
 217
 218
 219 ;;; @ body buffer
 220 ;;;
 221
 222 ;; (luna-define-method mime-entity-body-buffer ((entity mime-buffer-entity))
 223 ;;   (mime-buffer-entity-buffer-internal entity)
 224 ;;   )
 225
 226 ;; (luna-define-method mime-goto-body-start-point ((entity mime-buffer-entity))
 227 ;;   (set-buffer (mime-buffer-entity-buffer-internal entity))
 228 ;;   (goto-char (mime-buffer-entity-body-start-internal entity))
 229 ;;   )
 230
 231 ;; (luna-define-method mime-goto-body-end-point ((entity mime-buffer-entity))
 232 ;;   (set-buffer (mime-buffer-entity-buffer-internal entity))
 233 ;;   (goto-char (mime-buffer-entity-body-end-internal entity))
 234 ;;   )
 235
 236 ;; (luna-define-method mime-entity-body-start-point ((entity mime-buffer-entity))
 237 ;;   (mime-buffer-entity-body-start-internal entity)
 238 ;;   )
 239
 240 ;; (luna-define-method mime-entity-body-end-point ((entity mime-buffer-entity))
 241 ;;   (mime-buffer-entity-body-end-internal entity)
 242 ;;   )
 243
 244
 245 ;;; @ buffer (obsolete)
 246 ;;;
 247
 248 ;; (luna-define-method mime-entity-buffer ((entity mime-buffer-entity))
 249 ;;   (mime-buffer-entity-buffer-internal entity)
 250 ;;   )
 251
 252 ;; (luna-define-method mime-entity-point-min ((entity mime-buffer-entity))
 253 ;;   (mime-buffer-entity-header-start-internal entity)
 254 ;;   )
 255
 256 ;; (luna-define-method mime-entity-point-max ((entity mime-buffer-entity))
 257 ;;   (mime-buffer-entity-body-end-internal entity)
 258 ;;   )
 259
 260
 261 ;;; @ children
 262 ;;;
 263
 264 (defun mmbuffer-parse-multipart (entity &optional representation-type)
 265   (with-current-buffer (mime-buffer-entity-buffer-internal entity)
 266     (or representation-type
 267         (setq representation-type
 268               (mime-entity-representation-type-internal entity)))
 269     (let* ((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                                            representation-type)
 325   (mime-entity-set-children-internal
 326    entity
 327    (with-current-buffer (mime-buffer-entity-buffer-internal entity)
 328      (save-restriction
 329        (narrow-to-region (mime-buffer-entity-body-start-internal entity)
 330                          (mime-buffer-entity-body-end-internal entity))
 331        (list (mime-parse-message
 332               (if external
 333                   (progn
 334                     (require 'mmexternal)
 335                     'mime-external-entity)
 336                 (or representation-type
 337                     (mime-entity-representation-type-internal entity)))
 338               nil
 339               entity (cons 0 (mime-entity-node-id-internal entity))))))))
 340
 341 (luna-define-method mime-entity-children ((entity mime-buffer-entity))
 342   (let* ((content-type (mime-entity-content-type entity))
 343          (primary-type (mime-content-type-primary-type content-type))
 344          sub-type)
 345     (cond ((eq primary-type 'multipart)
 346            (mmbuffer-parse-multipart entity))
 347           ((eq primary-type 'message)
 348            (setq sub-type (mime-content-type-subtype content-type))
 349            (cond ((eq sub-type 'external-body)
 350                   (mmbuffer-parse-encapsulated entity 'external))
 351                  ((memq sub-type '(rfc822 news))
 352                   (mmbuffer-parse-encapsulated entity)))))))
 353
 354
 355 ;;; @ end
 356 ;;;
 357
 358 (provide 'mmbuffer)
 359
 360 ;;; mmbuffer.el ends here