~akwm/vm/abbreviate-headers : revision 1159

213

:parts :cache :message-symbol :display-error

214

:layout-is-converted :unconverted-layout])

215

216

(defun vm-pp-mime-layout (layout)

217

(pp (vm-zip-vectors vm-mime-layout-fields layout))

218

nil)

219

216

220

(defun vm-make-layout (&rest plist)

217

221

(vector

218

222

(plist-get plist 'type)

2258

2262

(insert-buffer-substring work-buffer start end)

2259

2263

(delete-region (point) (+ (point) oldsize))))

2260

2264

(nth 1 ooo))

2261

(and work-buffer (kill-buffer work-buffer)))))

2265

;; unwind-protection

2266

(when work-buffer (kill-buffer work-buffer)))))

2262

2267

2263

2268

(defun vm-mime-should-display-button (layout dont-honor-content-disposition)

2264

2269

(if (and vm-honor-mime-content-disposition

2451

2456

If DONT-HONOR-C-D non-Nil, then don't honor the Content-Disposition

2452

2457

declarations in the attachments and make a decision independently.

2453

2458

2454

LAYOUT can be a mime layout vector. It can also be an

2455

overlay of a button in the current buffer, in which case the

2456

'vm-mime-layout property of the overlay will be extracted.

2457

USR, 2011-02-08"

2459

LAYOUT can be a mime layout vector. It can also be a button

2460

extent in the current buffer, in which case the 'vm-mime-layout

2461

property of the overlay will be extracted. The button may be

2462

deleted.

2463

2464

Returns t if the display was successful. Not clear what happens if it

2465

is not successful. USR, 2011-03-25"

2458

2466

(let ((modified (buffer-modified-p))

2459

2467

handler new-layout file type type2 type-no-subtype (extent nil))

2460

2468

(unless (vectorp layout)

2484

2492

type-no-subtype (car (vm-parse type "\\([^/]+\\)")))))

2485

2493

2486

2494

(cond ((and (vm-mime-should-display-button layout dont-honor-c-d)

2495

;; original conditional-cases changed to fboundp

2496

;; checks. USR, 2011-03-25

2487

2497

(or (fboundp

2488

2498

(setq handler

2489

2499

(intern (concat "vm-mime-display-button-"

2534

2544

extent

2535

2545

(or (vm-mm-layout-display-error layout)

2536

2546

"no external viewer defined for type")))

2537

(if (vm-mime-types-match "message/external-body" type)

2538

(if (null extent)

2539

(vm-mime-display-button-xxxx layout t)

2540

(setq extent nil))

2541

(vm-mime-display-internal-application/octet-stream

2542

(or extent layout)))

2547

(cond ((vm-mime-types-match "message/external-body" type)

2548

(if (null extent)

2549

(vm-mime-display-button-xxxx layout t)

2550

(setq extent nil)))

2551

((vm-mime-types-match "application/octet-stream" type)

2552

(vm-mime-display-internal-application/octet-stream

2553

(or extent layout)))

2554

;; if everything else fails, do nothing

2555

)

2543

2556

))

2544

2557

(when extent (vm-mime-delete-button-maybe extent)))

2545

2558

;; unwind-protection

2799

2812

t )

2800

2813

2801

2814

(defun vm-mime-display-internal-application/octet-stream (layout)

2815

"Display a button for the MIME LAYOUT. If a button extent is

2816

given as the argument instead, then nothing is done. USR, 2011-03-25"

2802

2817

(if (vectorp layout)

2803

2818

(let ((buffer-read-only nil)

2804

2819

(vm-mf-default-action "save to a file"))

2807

2822

(function

2808

2823

(lambda (layout)

2809

2824

(save-excursion

2810

(vm-mime-display-internal-application/octet-stream layout))))

2811

layout nil))

2825

(vm-mime-save-application/octet-stream layout))))

2826

layout nil)))

2827

t)

2828

2829

(defun vm-mime-save-application/octet-stream (layout)

2830

"Save an application/octet-stream object with LAYOUT to the

2831

stated filename. A button extent with a layout can also be given as

2832

the argument. USR, 2011-03-25"

2833

(unless (vectorp layout)

2812

2834

(goto-char (vm-extent-start-position layout))

2813

(setq layout (vm-extent-property layout 'vm-mime-layout))

2814

;; support old "name" paramater for application/octet-stream

2815

;; but don't override the "filename" parameter extracted from

2816

;; Content-Disposition, if any.

2817

(let ((default-filename (vm-mime-get-disposition-filename layout))

2818

(file nil))

2819

(setq file (vm-mime-send-body-to-file layout default-filename))

2820

(if vm-mime-delete-after-saving

2821

(let ((vm-mime-confirm-delete nil))

2822

;; we don't care if the delete fails

2823

(condition-case nil

2824

(vm-delete-mime-object (expand-file-name file))

2825

(error nil))))))

2835

(setq layout (vm-extent-property layout 'vm-mime-layout)))

2836

;; support old "name" paramater for application/octet-stream

2837

;; but don't override the "filename" parameter extracted from

2838

;; Content-Disposition, if any.

2839

(let ((default-filename (vm-mime-get-disposition-filename layout))

2840

(file nil))

2841

(setq file (vm-mime-send-body-to-file layout default-filename))

2842

(if vm-mime-delete-after-saving

2843

(let ((vm-mime-confirm-delete nil))

2844

;; we don't care if the delete fails

2845

(condition-case nil

2846

(vm-delete-mime-object (expand-file-name file))

2847

(error nil)))))

2826

2848

t )

2827

2849

(fset 'vm-mime-display-button-application/octet-stream

2828

2850

'vm-mime-display-internal-application/octet-stream)

2829

2851

2830

2852

(defun vm-mime-display-button-application (layout)

2853

"Display button for an application type object described by LAYOUT."

2831

2854

(vm-mime-display-button-xxxx layout nil))

2832

2855

2833

2856

3542

3565

'vm-mime-display-internal-message/partial)

3543

3566

3544

3567

(defun vm-mime-display-internal-image-xxxx (layout image-type name)

3568

"Display the image object described by LAYOUT internally.

3569

IMAGE-TYPE is its image type (png, jpeg etc.). NAME is a string

3570

describing the image type. USR, 2011-03-25"

3545

3571

(cond

3546

3572

(vm-xemacs-p

3547

3573

(vm-mime-display-internal-image-xemacs-xxxx layout image-type name))

3675

3701

(defvar vm-menu-fsfemacs-image-menu)

3676

3702

3677

3703

(defun vm-mime-display-internal-image-fsfemacs-xxxx (layout image-type name)

3704

"Display the image object described by LAYOUT internally.

3705

IMAGE-TYPE is its image type (png, jpeg etc.). NAME is a string

3706

describing the image type. USR, 2011-03-25"

3678

3707

(if (and (vm-images-possible-here-p)

3679

3708

(vm-image-type-available-p image-type))

3680

3709

(let (start end tempfile image work-buffer

3773

3802

(if vm-use-menus

3774

3803

(overlay-put o 'vm-image vm-menu-fsfemacs-image-menu)))))

3775

3804

t )

3805

;; otherwise, image-type not available here

3776

3806

nil ))

3777

3807

3778

3808

;; FSF Emacs 19 is not supported any more. USR, 2011-02-23

4242

4272

(vm-mime-display-internal-image-xxxx layout 'xbm "XBM"))

4243

4273

4244

4274

(defun vm-mime-frob-image-xxxx (extent &rest convert-args)

4275

"Create and display a thumbnail (a PNG image) for the MIME

4276

object described by EXTENT. The thumbnail is stored in a file

4277

whose identity is saved in the MIME layout cache of the object.

4278

4279

The remaining arguments CONVERT-ARGS are passed to the ImageMagick

4280

convert program during the creation of the thumbnail image.

4281

4282

The return value does not seem to be meaningful. USR, 2011-03-25"

4245

4283

(let* ((layout (vm-extent-property extent 'vm-mime-layout))

4246

4284

(blob (get (vm-mm-layout-cache layout)

4247

4285

'vm-mime-display-internal-image-xxxx))

4253

4291

(if (consp blob)

4254

4292

(setq tempfile (car blob))

4255

4293

(setq tempfile blob))

4294

(setq work-buffer (vm-make-work-buffer))

4256

4295

(unwind-protect

4257

(save-excursion

4258

(setq work-buffer (vm-make-work-buffer))

4259

(set-buffer work-buffer)

4296

(with-current-buffer work-buffer

4260

4297

(set-buffer-file-coding-system (vm-binary-coding-system))

4261

4298

;; convert just the first page "[0]" and enforce PNG output by "png:"

4262

4299

(let ((coding-system-for-read (vm-binary-coding-system)))

4264

4301

(eq 0 (apply 'call-process vm-imagemagick-convert-program

4265

4302

tempfile t nil

4266

4303

(append convert-args (list "-[0]" "png:-"))))))

4267

(if success

4268

(progn

4269

(write-region (point-min) (point-max) tempfile nil 0)

4270

(if (consp blob)

4271

(setcar (nthcdr 5 blob) 0))

4272

(put (vm-mm-layout-cache layout) 'vm-image-modified t))))

4273

(and work-buffer (kill-buffer work-buffer)))

4274

(when success

4275

;; the output is always PNG now, so fix it for displaying, but restore

4276

;; it for the layout afterwards

4277

(vm-set-mm-layout-type layout '("image/png"))

4278

(vm-mark-image-tempfile-as-message-garbage-once layout tempfile)

4279

(vm-mime-display-generic extent)

4304

(when success

4305

(write-region (point-min) (point-max) tempfile nil 0)

4306

(when (consp blob)

4307

(setcar (nthcdr 5 blob) 0))

4308

(put (vm-mm-layout-cache layout) 'vm-image-modified t)))

4309

;; unwind-protection

4310

(when work-buffer (kill-buffer work-buffer)))

4311

(unwind-protect

4312

(when success

4313

;; the output is always PNG now, so fix it for displaying, but restore

4314

;; it for the layout afterwards

4315

(vm-set-mm-layout-type layout '("image/png"))

4316

(vm-mark-image-tempfile-as-message-garbage-once layout tempfile)

4317

(vm-mime-display-internal-generic extent))

4280

4318

(vm-set-mm-layout-type layout saved-type))))

4281

4319

4282

4320

(defun vm-mark-image-tempfile-as-message-garbage-once (layout tempfile)

4353

4391

(int-to-string (/ (nth 1 dims) 2))))))

4354

4392

4355

4393

(defcustom vm-mime-thumbnail-max-geometry "80x80"

4356

"*Max width and height of image thumbnail."

4394

"If thumbnails should be displayed as part of MIME buttons, then set

4395

this variable to a string describing the geometry, e.g., \"80x80\".

4396

Otherwise, set it to nil. USR, 2011-03-25"

4357

4397

:group 'vm-mime

4358

4398

:type '(choice string

4359

4399

(const :tag "Disable thumbnails." nil)))

4360

4400

4361

4401

(defun vm-mime-display-button-image (layout)

4362

"Displays a button for the image and when possible a thumbnail."

4363

(if (not (and vm-imagemagick-convert-program

4364

vm-mime-thumbnail-max-geometry

4365

(vm-images-possible-here-p)))

4366

;; just display the normal button

4367

(vm-mime-display-button-xxxx layout t)

4368

;; otherwise create a thumb and display it

4369

(let (tempfile start end x glyph)

4370

;; fake an extent to display the image as thumb

4371

(setq start (point))

4372

(insert " ")

4373

(setq x (vm-make-extent start (point)))

4374

(vm-set-extent-property x 'vm-mime-layout layout)

4375

(vm-set-extent-property x 'vm-mime-disposable nil)

4376

(vm-set-extent-property x 'start-open t)

4377

;; write out the image data

4378

(save-excursion

4379

(set-buffer (vm-make-work-buffer))

4380

(vm-mime-insert-mime-body layout)

4381

(vm-mime-transfer-decode-region layout (point-min) (point-max))

4382

(setq tempfile (vm-make-tempfile))

4383

(let ((coding-system-for-write (vm-binary-coding-system)))

4384

(write-region (point-min) (point-max) tempfile nil 0))

4385

(kill-buffer (current-buffer)))

4386

;; store the temp filename

4387

(put (vm-mm-layout-cache layout)

4388

'vm-mime-display-internal-image-xxxx

4389

tempfile)

4390

(vm-register-folder-garbage-files (list tempfile))

4391

;; force display

4392

(let ((vm-mime-internal-content-types '("image"))

4393

(vm-mime-internal-content-type-exceptions nil)

4394

(vm-mime-use-image-strips nil))

4395

(vm-mime-frob-image-xxxx x

4396

"-thumbnail"

4397

vm-mime-thumbnail-max-geometry))

4398

;; extract image data

4399

(setq glyph (if vm-xemacs-p

4400

(let ((e1 (vm-extent-at start))

4401

(e2 (vm-extent-at (1+ start))))

4402

(or (and e1 (extent-begin-glyph e1))

4403

(and e2 (extent-begin-glyph e2))))

4404

(get-text-property start 'display)))

4405

(delete-region start (point))

4406

;; insert the button and correct the image

4407

(setq start (point))

4408

(vm-mime-display-button-xxxx layout t)

4409

(when glyph

4410

(if vm-xemacs-p

4411

(set-extent-begin-glyph (vm-extent-at start) glyph)

4412

(put-text-property start (1+ start) 'display glyph)))

4413

;; force redisplay in original size

4414

(put (vm-mm-layout-cache layout)

4415

'vm-mime-display-internal-image-xxxx

4416

nil)

4417

t)))

4402

"Displays a button for the MIME LAYOUT and includes a thumbnail

4403

image when possible."

4404

(if (and vm-imagemagick-convert-program

4405

vm-mime-thumbnail-max-geometry

4406

(vm-images-possible-here-p))

4407

;; create a thumbnail and display it

4408

(let (tempfile start end thumb-extent glyph)

4409

;; fake an extent to display the image as thumb

4410

(setq start (point))

4411

(insert " ")

4412

(setq thumb-extent (vm-make-extent start (point)))

4413

(vm-set-extent-property thumb-extent 'vm-mime-layout layout)

4414

(vm-set-extent-property thumb-extent 'vm-mime-disposable nil)

4415

(vm-set-extent-property thumb-extent 'start-open t)

4416

;; write out the image data

4417

(with-current-buffer (vm-make-work-buffer)

4418

(vm-mime-insert-mime-body layout)

4419

(vm-mime-transfer-decode-region layout (point-min) (point-max))

4420

(setq tempfile (vm-make-tempfile))

4421

(let ((coding-system-for-write (vm-binary-coding-system)))

4422

(write-region (point-min) (point-max) tempfile nil 0))

4423

(kill-buffer (current-buffer)))

4424

;; store the temp filename

4425

(put (vm-mm-layout-cache layout)

4426

'vm-mime-display-internal-image-xxxx

4427

tempfile)

4428

(vm-register-folder-garbage-files (list tempfile))

4429

;; display a thumbnail over the fake extent

4430

(let ((vm-mime-internal-content-types '("image"))

4431

(vm-mime-internal-content-type-exceptions nil)

4432

(vm-mime-use-image-strips nil))

4433

(vm-mime-frob-image-xxxx thumb-extent

4434

"-thumbnail"

4435

vm-mime-thumbnail-max-geometry))

4436

;; extract image data, don't need the image itself!

4437

;; if the display was not successful, glyph will be nil

4438

(setq glyph (if vm-xemacs-p

4439

(let ((e1 (vm-extent-at start))

4440

(e2 (vm-extent-at (1+ start))))

4441

(or (and e1 (extent-begin-glyph e1))

4442

(and e2 (extent-begin-glyph e2))))

4443

(get-text-property start 'display)))

4444

(delete-region start (point))

4445

;; insert the button and replace the image

4446

(setq start (point))

4447

(vm-mime-display-button-xxxx layout t)

4448

(when glyph

4449

(if vm-xemacs-p

4450

(set-extent-begin-glyph (vm-extent-at start) glyph)

4451

(put-text-property start (1+ start) 'display glyph)))

4452

;; remove the cached thumb so that full sized image will be shown

4453

(put (vm-mm-layout-cache layout)

4454

'vm-mime-display-internal-image-xxxx

4455

nil)

4456

t)

4457

;; just display the normal button

4458

(vm-mime-display-button-xxxx layout t)))

4418

4459

4419

4460

(defun vm-mime-display-button-application/pdf (layout)

4420

4461

(vm-mime-display-button-image layout))

4459

4500

(vm-mime-auto-displayed-content-type-exceptions nil))

4460

4501

(vm-decode-mime-layout layout t))))

4461

4502

4503

(defun vm-mime-display-internal-generic (layout)

4504

"Display the mime object described by LAYOUT internally,

4505

irrespective of whether it is meant to be to be displayed

4506

automatically. No external viewers are tried. USR, 2011-03-25"

4507

(save-excursion

4508

(let ((vm-mime-auto-displayed-content-types t)

4509

(vm-mime-auto-displayed-content-type-exceptions nil)

4510

(vm-mime-external-content-types-alist nil))

4511

(vm-decode-mime-layout layout t))))

4512

4462

4513

(defun vm-mime-display-button-xxxx (layout disposable)

4463

4514

"Display a button for the mime object described by LAYOUT. If

4464

4515

DISPOSABLE is true, then the button will be removed when it is

4864

4915

(defvar vm-menu-mime-dispose-menu)

4865

4916

4866

4917

(defun vm-mime-set-image-stamp-for-type (e type)

4918

"Set an image stamp for MIME button extent E as appropriate for

4919

TYPE. USR, 2011-03-25"

4867

4920

(cond

4868

4921

(vm-xemacs-p

4869

4922

(vm-mime-xemacs-set-image-stamp-for-type e type))

4880

4933

("multipart" "multipart.xpm")))

4881

4934

4882

4935

(defun vm-mime-xemacs-set-image-stamp-for-type (e type)

4936

"Set an image stamp for MIME button extent E as appropriate for

4937

TYPE. USR, 2011-03-25"

4883

4938

(if (and (vm-images-possible-here-p)

4884

4939

(vm-image-type-available-p 'xpm)

4885

4940

(> (device-bitplanes) 7))

4906

4961

(and glyph (set-extent-begin-glyph e glyph)))))

4907

4962

4908

4963

(defun vm-mime-fsfemacs-set-image-stamp-for-type (e type)

4964

"Set an image stamp for MIME button extent E as appropriate for

4965

TYPE.

4966

4967

This is done by extending the extent with one character position at

4968

the front and placing the image there as the display text property.

4969

USR, 2011-03-25"

4909

4970

(if (and (vm-images-possible-here-p)

4910

4971

(vm-image-type-available-p 'xpm))

4911

4972

(let ((dir (vm-image-directory))