aboutsummaryrefslogtreecommitdiff
path: root/scheme/idest/batch/setpic.scm
blob: 3daf57084094cc51cebc0e01183442c24b79df2b (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
;; This file is part of Idest
;; Copyright (C) 2011, 2015-2017 Sergey Poznyakoff
;;
;; Idest is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;;
;; Idest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Idest.  If not, see <http://www.gnu.org/licenses/>.

(define-module (idest batch setpic))

(use-modules (ice-9 getopt-long)
	     (rnrs io ports))

(define-public description
  "set attached picture from a file")

(define-public idest-main #f)

(define (read-picture file)
  (with-output-to-string
    (lambda ()
      (let ((port (open-file-input-port file)))
	(let ((get-byte (lambda () (get-u8 port))))
	  (let loop ((n (get-byte)))
	    (cond
	     ((not (eof-object? n))
	      (if (< n 16)
		  (display "0"))
	      (display (number->string n 16))
	      (loop (get-byte))))))
	(close-port port)))))
	    
(define-public (idest-init)
  (let* ((cmd (command-line))
	 (progname (car cmd))
	 (description "")
	 (mime-type #f)
	 (pic-type "0")
	 (file #f)
	 (grammar `((description (single-char #\d) (value #t))
		    (mime-type (single-char #\m) (value #t))
		    (pic-type (single-char #\p) (value #t))
		    (file (single-char #\f) (value #t))
		    (help (single-char #\h)))))
    (catch 'misc-error
	   (lambda ()
	     (for-each
	      (lambda (x)
		(case (car x)
		  ((description)
		   (set! description (cdr x)))
		  ((mime-type)
		   (set! mime-type (cdr x)))
		  ((pic-type)
		   (set! pic-type (cdr x)))
		  ((file)
		   (set! file (cdr x)))
		  ((help)
		   (format #t "usage: idest --format=~A [OPTIONS] FILE...\n"
			   progname)
		   (format #t "OPTIONS are:\n")
		   (format #t "  -d, --description STR  set description\n")
		   (format #t "  -m, --mime-type TYPE   set MIME type\n")
		   (format #t "  -p, --pic-type NUM     set picture type\n")
		   (format #t "  -f, --file FILE        read picture from FILE\n")
		   (format #t "  -h, --help             show this help summary\n")
		   (newline)
		   (exit 0))
		  (else
		   (set-program-arguments (cons progname (cdr x))))))
	      (getopt-long cmd grammar)))
	   (lambda (key . args)
	     (with-output-to-port
		 (current-error-port)
	       (lambda ()
		 (format #t "~A: " progname)
		 (apply format #t (list-ref args 1) (list-ref args 2))
		 (newline)
		 (exit 1)))))

    (cond
     ((not file)
      (format #t "~A: missing --file option\n" progname)
      (exit 1))
     ((not mime-type)
      (let ((i (string-rindex file #\.)))
	(cond ((= i -1)
	       (format #t
		       "~A: cannot deduce MIME type for ~A: use --mime-type option\n"
		       progname
		       file)
	       (exit 1)))
	(set! mime-type (string-append "image/" (substring file (1+ i)))))))

    (cond
     ((= -1 (string-rindex mime-type #\/))
      (set! mime-type (string-append "image/" mime-type)))
     ((not (string-prefix? "image/" mime-type))
      (format #t "~A: invalid MIME type" progname)))

    (set! idest-main
	  (lambda (name frames)
	    (append
	     (filter
	      (lambda (elt)
		(not
		 (and
		  (string=? (car elt) "APIC")
		  (string-ci=?
		   (or (assoc-ref (cdr elt) 'mime-type) "image/png") mime-type)
		  (string=? (or (assoc-ref (cdr elt) 'pic-type) "0") pic-type)
		  (string-ci=? (or (assoc-ref (cdr elt) 'condesc) "") description))))
	      frames)
	     (list
	        (cons
		 "APIC"
		 (list
		  (cons 'mime-type (string-downcase mime-type))
		  (cons 'pic-type pic-type)
		  (cons 'condesc description)
		  (cons 'text (read-picture file))))))))))

    
    

Return to:

Send suggestions and report system problems to the System administrator.