mu-scm: add filename procedure for mime-part

This commit is contained in:
Dirk-Jan C. Binnema
2025-07-08 19:04:31 +03:00
parent 5fdb13fd72
commit 7b4aea432e
3 changed files with 33 additions and 14 deletions

View File

@ -121,10 +121,14 @@
((index . 2) (content-type . "image/jpeg") (size . 21566) (filename . "custer.jpg"))) ((index . 2) (content-type . "image/jpeg") (size . 21566) (filename . "custer.jpg")))
(map (lambda (part) (mime-part->alist part)) (mime-parts msg))) (map (lambda (part) (mime-part->alist part)) (mime-parts msg)))
(test-equal "mime-part-0" (filename (list-ref (mime-parts msg) 0)))
(test-equal "sittingbull.jpg" (filename (list-ref (mime-parts msg) 1)))
(test-equal "custer.jpg" (filename (list-ref (mime-parts msg) 2)))
(let* ((part (list-ref (mime-parts msg) 1)) (let* ((part (list-ref (mime-parts msg) 1))
(alist (mime-part->alist part)) (alist (mime-part->alist part))
(fname (format #f "~a/~a" tmpdir (assoc-ref alist 'filename)))) (fname (format #f "~a/~a" tmpdir (assoc-ref alist 'filename))))
(write-to-file part #:filename fname) (write-to-file part #:path fname)
(test-assert (access? fname R_OK)) (test-assert (access? fname R_OK))
;; note, the 23881 is the _encoded_ size. ;; note, the 23881 is the _encoded_ size.
(test-equal 17674 (stat:size (stat fname)))) (test-equal 17674 (stat:size (stat fname))))

View File

@ -28,6 +28,7 @@
<mime-part> <mime-part>
mime-part->alist mime-part->alist
make-port make-port
filename
write-to-file write-to-file
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Message ;; Message
@ -159,27 +160,33 @@ If DECODE? is #t, decode the content (from e.g., base64); in that case,
CONTENT-ONLY? is implied to be #t." CONTENT-ONLY? is implied to be #t."
(cc-mime-make-stream-port (slot-ref mime-part 'mimepart) content-only? decode?)) (cc-mime-make-stream-port (slot-ref mime-part 'mimepart) content-only? decode?))
(define* (make-output-file mime-part #:key (filename #f) (overwrite? #f)) (define-method (filename (mime-part <mime-part>))
"Determine the file-name for MIME-part.
Either the 'filename' field in the mime-part and if that does not exist, use
'mime-part-<index>' with <index> being the number of the mime-part."
(let ((alist (mime-part->alist mime-part)))
(or (assoc-ref alist 'filename)
(format #f "mime-part-~d" (assoc-ref alist 'index)))))
(define* (make-output-file mime-part #:key (path #f) (overwrite? #f))
"Create a port for the file to write MIME-PART to. "Create a port for the file to write MIME-PART to.
FILENAME is the path to the file name. If not specified, use the 'filename' PATH is file-name or path to the file name. If not specified, use the 'filename'
field in the mime-part and if that does not exist, use 'mime-part-<index>' with field in the mime-part and if that does not exist, use 'mime-part-<index>' with
<index> being the number of the mime-part. <index> being the number of the mime-part.
OVERWRITE? specifies whether existing files by the same name or overwritten. OVERWRITE? specifies whether existing files by the same name or overwritten.
Otherwise, trying to overwrite an existing file raises an error." Otherwise, trying to overwrite an existing file raises an error."
(let* ((alist (mime-part->alist mime-part)) (let* ((alist (mime-part->alist mime-part))
(filename (or filename (path (or path (filename mime-part))))
(assoc-ref alist 'filename)
(format #f "mime-part-~d" (assoc-ref alist 'index)))))
;; we need an fd-based port since we want to support overwrite? ;; we need an fd-based port since we want to support overwrite?
(open filename (open path
(logior O_WRONLY O_CREAT O_TRUNC (if overwrite? O_EXCL 0)) #o644))) (logior O_WRONLY O_CREAT O_TRUNC (if overwrite? O_EXCL 0)) #o644)))
(define* (write-to-file mime-part #:key (filename #f) (overwrite? #f)) (define* (write-to-file mime-part #:key (path #f) (overwrite? #f))
"Write MIME-PART to a file. "Write MIME-PART to a file.
FILENAME is the path to the file name. If not specified, use the 'filename' PATH is the path/filename for the file. If not specified, use the 'filename'
field in the mime-part and if that does not exist, use 'mime-part-<index>' with field in the mime-part and if that does not exist, use 'mime-part-<index>' with
<index> being the number of the mime-part. <index> being the number of the mime-part.
@ -187,7 +194,7 @@ OVERWRITE? specifies whether existing files by the same name or overwritten.
Otherwise, trying to overwrite an existing file raises an error." Otherwise, trying to overwrite an existing file raises an error."
(let* ((input (make-port mime-part)) (let* ((input (make-port mime-part))
(output (make-output-file mime-part (output (make-output-file mime-part
#:filename filename #:overwrite? overwrite?)) #:path path #:overwrite? overwrite?))
(buf (make-bytevector 4096)) ;; just a guess... (buf (make-bytevector 4096)) ;; just a guess...
(bytes 0)) (bytes 0))
(while (not (eof-object? bytes)) ;; XXX do this in a more elegant way. (while (not (eof-object? bytes)) ;; XXX do this in a more elegant way.

View File

@ -515,12 +515,20 @@ case, @code{content-only?} is implied to be #t.
Write MIME-part to file. Write MIME-part to file.
Use @code{filename} is the file/path to use for writing; if this is @code{#f}, Use @code{filename} is the file/path to use for writing; if this is @code{#f},
the name is taken from the @t{filename} property of the MIME-part alist. If that the name using the @code{filename} procedure.
does not exist, a generic name is chosen.
If @code{overwrite?} is true, overwrite existing files of the same name; If @code{overwrite?} is true, overwrite existing files of the same name;
otherwise, raise an error if the file already exists. otherwise, raise an error if the file already exists.
@deffn {Scheme Procedure} filename mime-part
@end deffn
Determine a filename for the given MIME-part.
This is either taken from the @t{filename} property of the MIME-part alist, or,
If that does not exist, a generic name.
@subsection Contacts @subsection Contacts
Message fields @t{To:}, @t{From:}, @t{Cc:} and @t{Bcc:} contain @emph{contacts}. Message fields @t{To:}, @t{From:}, @t{Cc:} and @t{Bcc:} contain @emph{contacts}.