4a53fc82eda67863fe12426e1140cd4b44187206
[elisp/album.git] / iphoto-util.el
1 ;; (defun image-file-timestamp (image-file)
2 ;;   (with-temp-buffer
3 ;;     (call-process "identify" nil t nil
4 ;;                   "-verbose" (expand-file-name image-file))
5 ;;     (goto-char (point-min))
6 ;;     (if (re-search-forward "^[ \t]*Timestamp: " nil t)
7 ;;         (buffer-substring (match-end 0)(point-at-eol)))))
8
9 ;;; for exif 0.6.9
10 ;; (defun exif-image-file-date-time-original (image-file)
11 ;;   (with-temp-buffer
12 ;;     (call-process "exif" nil t nil
13 ;;                   "-t" "DateTimeOriginal"
14 ;;                   (expand-file-name image-file))
15 ;;     (goto-char (point-min))
16 ;;     (if (re-search-forward "^[ \t]*Value: " nil t)
17 ;;         (buffer-substring (match-end 0)(point-at-eol)))))
18
19 ;;; for exif 0.6.15
20 (defun exif-image-file-date-time-original (image-file)
21   (with-temp-buffer
22     (call-process "exif" nil t nil
23                   "-x" (expand-file-name image-file))
24     (goto-char (point-min))
25     (if (re-search-forward
26          "<Date_and_Time__original_>\\([^<>]+\\)</Date_and_Time__original_>"
27          nil t)
28         (match-string 1))))
29
30 ;; (directory-files
31 ;;  "~/Pictures/iPhoto Library/Originals/2006/")
32
33 (defun exif-find-image-directories-by-original-date (year month day)
34   (let (base-dir date-time date-pat dest ret)
35     (setq base-dir (format "~/Pictures/iPhoto Library/Modified/%d/" year))
36     (setq date-time (encode-time 0 0 0 day month year))
37     (setq date-pat (format "^%d:%02d:%02d" year month day))
38     (dolist (dir (directory-files base-dir))
39       (when (and (not (string-match "^\\.+$" dir))
40                  (setq dir (expand-file-name dir base-dir))
41                  (file-directory-p dir)
42                  ;; (setq ret (nth 5 (file-attributes dir)))
43                  ;; (or (> (car ret)(car date-time))
44                  ;;     (and (= (car ret)(car date-time))
45                  ;;          (>= (nth 1 ret)(nth 1 date-time))))
46                  (setq ret
47                        (exif-image-file-date-time-original
48                         (car
49                          (directory-files dir 'full "\\.[A-Za-z0-9]+$"))))
50                  (string-match date-pat ret))
51         (setq dest
52               (cons dir dest))))
53     dest))
54
55 (defun exif-image-directory-original-time-range (image-dir)
56   (let (ret time-min time-max
57             date time
58             year month day hour min sec)
59     (dolist (file (directory-files 
60                    image-dir
61                    'full "\\.\\(JPG\\|jpg\\)$" 'no-sort))
62       (when (and (setq ret (exif-image-file-date-time-original file))
63                  (setq ret (split-string ret " "))
64                  (setq date (car ret)
65                        time (nth 1 ret))
66                  (setq ret (split-string date ":"))
67                  (setq year (string-to-int (car ret))
68                        month (string-to-int (nth 1 ret))
69                        day (string-to-int (nth 2 ret)))
70                  (setq ret (split-string time ":"))
71                  (setq hour (string-to-int (car ret))
72                        min (string-to-int (nth 1 ret))
73                        sec (string-to-int (nth 2 ret)))
74                  (setq ret (encode-time sec min hour day month year)))
75         (if (or (null time-min)
76                 (< (car ret)(car time-min))
77                 (and (= (car ret)(car time-min))
78                      (< (nth 1 ret)(nth 1 time-min))))
79             (setq time-min ret))
80         (if (or (null time-max)
81                 (< (car time-min)(car ret))
82                 (and (= (car time-min)(car ret))
83                      (< (nth 1 time-min)(nth 1 ret))))
84             (setq time-max ret))
85         ))
86     (cons time-min time-max)))
87
88 (defun iphoto-dir-format-time-range-as-album-dir (range year month day)
89   (let ((time-min (decode-time (car range)))
90         (time-max (decode-time (cdr range))))
91     (format "%s-%s"
92             (if (and (= (nth 3 time-min) day)
93                      (= (nth 4 time-min) month)
94                      (= (nth 5 time-min) year))
95                 (format "%02dh%02dm%02ds"
96                         (nth 2 time-min)
97                         (nth 1 time-min)
98                         (nth 0 time-min))
99               (format "%d-%02d-%02d-%02dh%02dm%02ds"
100                       (nth 5 time-min)
101                       (nth 4 time-min)
102                       (nth 3 time-min)
103                       (nth 2 time-min)
104                       (nth 1 time-min)
105                       (nth 0 time-min)))
106             (if (and (= (nth 3 time-max) day)
107                      (= (nth 4 time-max) month)
108                      (= (nth 5 time-max) year))
109                 (format "%02dh%02dm%02ds"
110                         (nth 2 time-max)
111                         (nth 1 time-max)
112                         (nth 0 time-max))
113               (format "%d-%02d-%02d-%02dh%02dm%02ds"
114                       (nth 5 time-max)
115                       (nth 4 time-max)
116                       (nth 3 time-max)
117                       (nth 2 time-max)
118                       (nth 1 time-max)
119                       (nth 0 time-max))))))
120
121 (defun iphoto-dir-to-album-dir (year month day album-name
122                                      album-dir-root url-root image-url-root
123                                      album-url-prefix)
124   (let ((coding-system-for-write 'utf-8-jp-er)
125         (album-dir-base (expand-file-name album-name album-dir-root))
126         album-dir album-dir-original ret a-dir-n a-dirs)
127     (dolist (dir
128              (exif-find-image-directories-by-original-date
129               year month day))
130       (setq album-dir
131             (expand-file-name
132              (setq a-dir-n
133                    (iphoto-dir-format-time-range-as-album-dir
134                     (exif-image-directory-original-time-range dir)
135                     year month day))
136              album-dir-base))
137       (setq a-dirs (cons a-dir-n a-dirs))
138       (setq album-dir-original
139             (expand-file-name "Originals" album-dir))
140       (unless (file-exists-p album-dir)
141         (make-directory album-dir 'parents))
142       (dolist (file (directory-files dir 'full nil 'no-sort t))
143         (call-process "cp" nil nil nil
144                       "-al" 
145                       file
146                       album-dir))
147       (with-temp-buffer
148         (insert ";; -*- mode: emacs-lisp; coding: utf-8-jp-er; -*-\n")
149         (insert (pp (list
150                      (cons 'title
151                            (format "(%s)"
152                                    (mapconcat
153                                     (lambda (time)
154                                       (mapconcat #'identity
155                                                  (nbutlast
156                                                   (split-string time "[hms]"))
157                                                  ":"))
158                                     (split-string a-dir-n "-")
159                                     "\e$B!A\e(B")))
160                      ;; (cons 'files
161                      ;;       (directory-files dir nil nil nil t))
162                      (cons 'exit (concat album-url-prefix album-name)))))
163         (write-region (point-min)(point-max)
164                       (expand-file-name "dir.desc" album-dir)))
165       (dolist (file (directory-files
166                      (expand-file-name
167                       (file-name-nondirectory dir)
168                       (format "~/Pictures/iPhoto Library/Originals/%d/"
169                               year))
170                      'full nil 'no-sort t))
171         (cond
172          ((string= (downcase (file-name-extension file)) "jpg")
173           (unless (file-exists-p album-dir-original)
174             (make-directory album-dir-original 'parents))
175           (call-process "cp" nil nil nil
176                         "-al" 
177                         file
178                         album-dir-original)
179           )
180          (t
181           (call-process "cp" nil nil nil
182                         "-al" 
183                         file
184                         album-dir)
185           ))
186         )
187       (call-process "chgrp" nil nil nil
188                     "-R" "www-data"
189                     album-dir)
190       (call-process "chmod" nil nil nil
191                     "-R" "g+r"
192                     album-dir)
193       (call-process "chmod" nil nil nil
194                     "g+w"
195                     album-dir)
196       )
197     (with-temp-buffer
198       (insert "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
199 \"http://www.w3.org/TR/html4/loose.dtd\">
200 <html lang=\"ja\">
201 <head>
202 ")
203       (insert (format "<title>\e$B!J\e(B%d\e$BG/\e(B%d\e$B7n\e(B%d\e$BF|!K\e(B</title>\n"
204                       year month day))
205       (insert "</head>\n<body>\n")
206       (insert (format "<h1>\e$B!J\e(B%d\e$BG/\e(B%d\e$B7n\e(B%d\e$BF|!K\e(B</h1>\n"
207                       year month day))
208       (insert "\n<hr>\n")
209       (insert "\n<ul>\n")
210       (dolist (sub-url (sort a-dirs #'string<))
211         (insert (format "  <li><a
212       href=\"%s/%s/%s/&lang=ja\"
213       ><img
214       src=\"%s/%s/%s/%s&size=thumbnail\"
215       >%s</a>
216 "
217                         url-root album-name sub-url
218                         image-url-root album-name sub-url
219                         (progn
220                           (setq ret
221                                 (directory-files
222                                  (expand-file-name sub-url album-dir-base)
223                                  nil "\\.\\(JPG\\|jpg\\)$" 'no-sort))
224                           (nth (random (length ret))
225                                ret))
226                         (cdr
227                          (assq 'title
228                                (with-temp-buffer
229                                  (insert-file-contents
230                                   (expand-file-name
231                                    "dir.desc"
232                                    (expand-file-name sub-url album-dir-base)))
233                                  (read (current-buffer))))))))
234       (insert "</ul>
235
236 <hr>
237
238 </body>
239 </html>
240 ")
241       (write-region (point-min)(point-max)
242                     (expand-file-name
243                      "index.html.ja.utf-8" album-dir-base))
244       )))