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     (binary-write-region (mime-buffer-entity-body-start-internal entity)
 129                          (mime-buffer-entity-body-end-internal entity)
 130                          filename)))
 131
 132
 133 ;;; @ entity content
 134 ;;;
 135
 136 (luna-define-method mime-entity-content ((entity mime-buffer-entity))
 137   (save-excursion
 138     (set-buffer (mime-buffer-entity-buffer-internal entity))
 139     (mime-decode-string
 140      (buffer-substring (mime-buffer-entity-body-start-internal entity)
 141                        (mime-buffer-entity-body-end-internal entity))
 142      (mime-entity-encoding entity))))
 143
 144 (luna-define-method mime-insert-entity-content ((entity mime-buffer-entity))
 145   (insert (with-current-buffer (mime-buffer-entity-buffer-internal entity)
 146             (mime-decode-string
 147              (buffer-substring (mime-buffer-entity-body-start-internal entity)
 148                                (mime-buffer-entity-body-end-internal entity))
 149              (mime-entity-encoding entity)))))
 150
 151 (luna-define-method mime-write-entity-content ((entity mime-buffer-entity)
 152                                                filename)
 153   (save-excursion
 154     (set-buffer (mime-buffer-entity-buffer-internal entity))
 155     (mime-write-decoded-region (mime-buffer-entity-body-start-internal entity)
 156                                (mime-buffer-entity-body-end-internal entity)
 157                                filename
 158                                (or (mime-entity-encoding entity) "7bit"))
 159     ))
 160
 161
 162 ;;; @ header field
 163 ;;;
 164
 165 (luna-define-method mime-entity-fetch-field :around
 166   ((entity mime-buffer-entity) field-name)
 167   (or (luna-call-next-method)
 168       (save-excursion
 169         (set-buffer (mime-buffer-entity-buffer-internal entity))
 170         (save-restriction
 171           (narrow-to-region (mime-buffer-entity-header-start-internal entity)
 172                             (mime-buffer-entity-header-end-internal entity))
 173           (let ((ret (std11-fetch-field field-name)))
 174             (when ret
 175               (or (symbolp field-name)
 176                   (setq field-name
 177                         (intern (capitalize (capitalize field-name)))))
 178               (mime-entity-set-original-header-internal
 179                entity
 180                (put-alist field-name ret
 181                           (mime-entity-original-header-internal entity)))
 182               ret))))))
 183
 184 (luna-define-method mime-insert-header ((entity mime-buffer-entity)
 185                                         &optional invisible-fields
 186                                         visible-fields)
 187   (mime-insert-header-from-buffer
 188    (mime-buffer-entity-buffer-internal entity)
 189    (mime-buffer-entity-header-start-internal entity)
 190    (mime-buffer-entity-header-end-internal entity)
 191    invisible-fields visible-fields)
 192   )
 193
 194
 195 ;;; @ header buffer
 196 ;;;
 197
 198 ;; (luna-define-method mime-entity-header-buffer ((entity mime-buffer-entity))
 199 ;;   (mime-buffer-entity-buffer-internal entity)
 200 ;;   )
 201
 202 ;; (luna-define-method mime-goto-header-start-point ((entity mime-buffer-entity))
 203 ;;   (set-buffer (mime-buffer-entity-buffer-internal entity))
 204 ;;   (goto-char (mime-buffer-entity-header-start-internal entity))
 205 ;;   )
 206
 207 ;; (luna-define-method mime-entity-header-start-point ((entity
 208 ;;                                                      mime-buffer-entity))
 209 ;;   (mime-buffer-entity-header-start-internal entity)
 210 ;;   )
 211
 212 ;; (luna-define-method mime-entity-header-end-point ((entity
 213 ;;                                                    mime-buffer-entity))
 214 ;;   (mime-buffer-entity-header-end-internal entity)
 215 ;;   )
 216
 217
 218 ;;; @ body buffer
 219 ;;;
 220
 221 ;; (luna-define-method mime-entity-body-buffer ((entity mime-buffer-entity))
 222 ;;   (mime-buffer-entity-buffer-internal entity)
 223 ;;   )
 224
 225 ;; (luna-define-method mime-goto-body-start-point ((entity mime-buffer-entity))
 226 ;;   (set-buffer (mime-buffer-entity-buffer-internal entity))
 227 ;;   (goto-char (mime-buffer-entity-body-start-internal entity))
 228 ;;   )
 229
 230 ;; (luna-define-method mime-goto-body-end-point ((entity mime-buffer-entity))
 231 ;;   (set-buffer (mime-buffer-entity-buffer-internal entity))
 232 ;;   (goto-char (mime-buffer-entity-body-end-internal entity))
 233 ;;   )
 234
 235 ;; (luna-define-method mime-entity-body-start-point ((entity mime-buffer-entity))
 236 ;;   (mime-buffer-entity-body-start-internal entity)
 237 ;;   )
 238
 239 ;; (luna-define-method mime-entity-body-end-point ((entity mime-buffer-entity))
 240 ;;   (mime-buffer-entity-body-end-internal entity)
 241 ;;   )
 242
 243
 244 ;;; @ buffer (obsolete)
 245 ;;;
 246
 247 ;; (luna-define-method mime-entity-buffer ((entity mime-buffer-entity))
 248 ;;   (mime-buffer-entity-buffer-internal entity)
 249 ;;   )
 250
 251 ;; (luna-define-method mime-entity-point-min ((entity mime-buffer-entity))
 252 ;;   (mime-buffer-entity-header-start-internal entity)
 253 ;;   )
 254
 255 ;; (luna-define-method mime-entity-point-max ((entity mime-buffer-entity))
 256 ;;   (mime-buffer-entity-body-end-internal entity)
 257 ;;   )
 258
 259
 260 ;;; @ children
 261 ;;;
 262
 263 (defun mmbuffer-parse-multipart (entity &optional representation-type)
 264   (with-current-buffer (mime-buffer-entity-buffer-internal entity)
 265     (or representation-type
 266         (setq representation-type
 267               (mime-entity-representation-type-internal entity)))
 268     (let* ((content-type (mime-entity-content-type-internal entity))
 269            (dash-boundary
 270             (concat "--"
 271                     (mime-content-type-parameter content-type "boundary")))
 272            (delimiter       (concat "\n" (regexp-quote dash-boundary)))
 273            (close-delimiter (concat delimiter "--[ \t]*$"))
 274            (rsep (concat delimiter "[ \t]*\n"))
 275            (dc-ctl
 276             (if (eq (mime-content-type-subtype content-type) 'digest)
 277                 (make-mime-content-type 'message 'rfc822)
 278               (make-mime-content-type 'text 'plain)
 279               ))
 280            (body-start (mime-buffer-entity-body-start-internal entity))
 281            (body-end (mime-buffer-entity-body-end-internal entity)))
 282       (save-restriction
 283         (goto-char body-end)
 284         (narrow-to-region body-start
 285                           (if (re-search-backward close-delimiter nil t)
 286                               (match-beginning 0)
 287                             body-end))
 288         (goto-char body-start)
 289         (if (re-search-forward
 290              (concat "^" (regexp-quote dash-boundary) "[ \t]*\n")
 291              nil t)
 292             (let ((cb (match-end 0))
 293                   ce ncb ret children
 294                   (node-id (mime-entity-node-id-internal entity))
 295                   (i 0))
 296               (while (re-search-forward rsep nil t)
 297                 (setq ce (match-beginning 0))
 298                 (setq ncb (match-end 0))
 299                 (save-restriction
 300                   (narrow-to-region cb ce)
 301                   (setq ret (mime-parse-message representation-type dc-ctl
 302                                                 entity (cons i node-id)))
 303                   )
 304                 (setq children (cons ret children))
 305                 (goto-char (setq cb ncb))
 306                 (setq i (1+ i))
 307                 )
 308               (setq ce (point-max))
 309               (save-restriction
 310                 (narrow-to-region cb ce)
 311                 (setq ret (mime-parse-message representation-type dc-ctl
 312                                               entity (cons i node-id)))
 313                 )
 314               (setq children (cons ret children))
 315               (mime-entity-set-children-internal entity (nreverse children))
 316               )
 317           (mime-entity-set-content-type-internal
 318            entity (make-mime-content-type 'message 'x-broken))
 319           nil)
 320         ))))
 321
 322 (defun mmbuffer-parse-encapsulated (entity &optional external
 323                                            representation-type)
 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                 (or representation-type
 336                     (mime-entity-representation-type-internal entity)))
 337               nil
 338               entity (cons 0 (mime-entity-node-id-internal entity))))))))
 339
 340 (luna-define-method mime-entity-children ((entity mime-buffer-entity))
 341   (let* ((content-type (mime-entity-content-type entity))
 342          (primary-type (mime-content-type-primary-type content-type))
 343          sub-type)
 344     (cond ((eq primary-type 'multipart)
 345            (mmbuffer-parse-multipart entity))
 346           ((eq primary-type 'message)
 347            (setq sub-type (mime-content-type-subtype content-type))
 348            (cond ((eq sub-type 'external-body)
 349                   (mmbuffer-parse-encapsulated entity 'external))
 350                  ((memq sub-type '(rfc822 news))
 351                   (mmbuffer-parse-encapsulated entity)))))))
 352
 353
 354 ;;; @ end
 355 ;;;
 356
 357 (provide 'mmbuffer)
 358
 359 ;;; mmbuffer.el ends here