--- /dev/null
+;; (defun image-file-timestamp (image-file)
+;; (with-temp-buffer
+;; (call-process "identify" nil t nil
+;; "-verbose" (expand-file-name image-file))
+;; (goto-char (point-min))
+;; (if (re-search-forward "^[ \t]*Timestamp: " nil t)
+;; (buffer-substring (match-end 0)(point-at-eol)))))
+
+(defun exif-image-file-date-time-original (image-file)
+ (with-temp-buffer
+ (call-process "exif" nil t nil
+ "-t" "DateTimeOriginal"
+ (expand-file-name image-file))
+ (goto-char (point-min))
+ (if (re-search-forward "^[ \t]*Value: " nil t)
+ (buffer-substring (match-end 0)(point-at-eol)))))
+
+;; (directory-files
+;; "~/Pictures/iPhoto Library/Originals/2006/")
+
+(defun exif-find-image-directories-by-original-date (year month day)
+ (let (base-dir date-time date-pat dest ret)
+ (setq base-dir (format "~/Pictures/iPhoto Library/Modified/%d/" year))
+ (setq date-time (encode-time 0 0 0 day month year))
+ (setq date-pat (format "^%d:%02d:%02d" year month day))
+ (dolist (dir (directory-files base-dir))
+ (when (and (not (string-match "^\\.+$" dir))
+ (setq dir (expand-file-name dir base-dir))
+ (file-directory-p dir)
+ (setq ret (nth 5 (file-attributes dir)))
+ (or (> (car ret)(car date-time))
+ (and (= (car ret)(car date-time))
+ (>= (nth 1 ret)(nth 1 date-time))))
+ (setq ret
+ (exif-image-file-date-time-original
+ (car
+ (directory-files dir 'full "\\.[A-Za-z0-9]+$"))))
+ (string-match date-pat ret))
+ (setq dest
+ (cons dir dest))))
+ dest))
+
+(defun exif-image-directory-original-time-range (image-dir)
+ (let (ret time-min time-max
+ date time
+ year month day hour min sec)
+ (dolist (file (directory-files
+ image-dir
+ 'full "\\.\\(JPG\\|jpg\\)$" 'no-sort))
+ (when (and (setq ret (exif-image-file-date-time-original file))
+ (setq ret (split-string ret " "))
+ (setq date (car ret)
+ time (nth 1 ret))
+ (setq ret (split-string date ":"))
+ (setq year (string-to-int (car ret))
+ month (string-to-int (nth 1 ret))
+ day (string-to-int (nth 2 ret)))
+ (setq ret (split-string time ":"))
+ (setq hour (string-to-int (car ret))
+ min (string-to-int (nth 1 ret))
+ sec (string-to-int (nth 2 ret)))
+ (setq ret (encode-time sec min hour day month year)))
+ (if (or (null time-min)
+ (< (car ret)(car time-min))
+ (and (= (car ret)(car time-min))
+ (< (nth 1 ret)(nth 1 time-min))))
+ (setq time-min ret))
+ (if (or (null time-max)
+ (< (car time-min)(car ret))
+ (and (= (car time-min)(car ret))
+ (< (nth 1 time-min)(nth 1 ret))))
+ (setq time-max ret))
+ ))
+ (cons time-min time-max)))
+
+(defun iphoto-dir-format-time-range-as-album-dir (range year month day)
+ (let ((time-min (decode-time (car range)))
+ (time-max (decode-time (cdr range))))
+ (format "%s_%s"
+ (if (and (= (nth 3 time-min) day)
+ (= (nth 4 time-min) month)
+ (= (nth 5 time-min) year))
+ (format "%02d-%02d-%02d"
+ (nth 2 time-min)
+ (nth 1 time-min)
+ (nth 0 time-min))
+ (format "%d-%02d-%02d-%02d-%02d-%02d"
+ (nth 5 time-min)
+ (nth 4 time-min)
+ (nth 3 time-min)
+ (nth 2 time-min)
+ (nth 1 time-min)
+ (nth 0 time-min)))
+ (if (and (= (nth 3 time-max) day)
+ (= (nth 4 time-max) month)
+ (= (nth 5 time-max) year))
+ (format "%02d-%02d-%02d"
+ (nth 2 time-max)
+ (nth 1 time-max)
+ (nth 0 time-max))
+ (format "%d-%02d-%02d-%02d-%02d-%02d"
+ (nth 5 time-max)
+ (nth 4 time-max)
+ (nth 3 time-max)
+ (nth 2 time-max)
+ (nth 1 time-max)
+ (nth 0 time-max))))))
+
+(defun iphoto-dir-to-album-dir (year month day album-name
+ url-root album-dir-root)
+ (let ((coding-system-for-write 'utf-8-jp-er)
+ (album-dir-base (expand-file-name album-name album-dir-root))
+ album-dir album-dir-original ret a-dir-n a-dirs)
+ (dolist (dir
+ (exif-find-image-directories-by-original-date
+ year month day))
+ (setq album-dir
+ (expand-file-name
+ (setq a-dir-n
+ (iphoto-dir-format-time-range-as-album-dir
+ (exif-image-directory-original-time-range dir)
+ year month day))
+ album-dir-base))
+ (setq a-dirs (cons a-dir-n a-dirs))
+ (setq album-dir-original
+ (expand-file-name "Originals" album-dir))
+ (unless (file-exists-p album-dir)
+ (make-directory album-dir 'parents))
+ (dolist (file (directory-files dir 'full nil 'no-sort t))
+ (call-process "cp" nil nil nil
+ "-al"
+ file
+ album-dir))
+ (with-temp-buffer
+ (insert ";; -*- mode: emacs-lisp; coding: utf-8-jp-er; -*-\n")
+ (insert (pp (list
+ (cons 'title
+ (format "(%s)"
+ (mapconcat
+ (lambda (time)
+ (mapconcat #'identity
+ (split-string time "-")
+ ":"))
+ (split-string a-dir-n "_")
+ "\e$B!A\e(B")))
+ (cons 'files
+ (directory-files dir nil nil nil t))
+ (cons 'exit album-name))))
+ (write-region (point-min)(point-max)
+ (expand-file-name "dir.desc" album-dir)))
+ (unless (file-exists-p album-dir-original)
+ (make-directory album-dir-original 'parents))
+ (dolist (file (directory-files
+ (expand-file-name
+ (file-name-nondirectory dir)
+ (format "~/Pictures/iPhoto Library/Originals/%d/"
+ year))
+ 'full nil 'no-sort t))
+ (call-process "cp" nil nil nil
+ "-al"
+ file
+ album-dir-original))
+ (call-process "chgrp" nil nil nil
+ "-R" "www-data"
+ album-dir)
+ (call-process "chmod" nil nil nil
+ "-R" "g+r"
+ album-dir)
+ (call-process "chmod" nil nil nil
+ "g+w"
+ album-dir)
+ )
+ (with-temp-buffer
+ (insert "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
+\"http://www.w3.org/TR/html4/loose.dtd\">
+<html lang=\"ja\">
+<head>
+")
+ (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"
+ year month day))
+ (insert "</head>\n<body>\n")
+ (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"
+ year month day))
+ (insert "\n<hr>\n")
+ (insert "\n<ul>\n")
+ (dolist (sub-url (sort a-dirs #'string<))
+ (insert (format " <li><a
+ href=\"%s/%s/%s/&lang=ja\"
+ ><img
+ src=\"%s/%s/%s/%s&size=thumbnail\"
+ >%s</a>
+"
+ url-root album-name sub-url
+ url-root album-name sub-url
+ (progn
+ (setq ret
+ (directory-files
+ (expand-file-name sub-url album-dir-base)
+ nil "\\.\\(JPG\\|jpg\\)$" 'no-sort))
+ (nth (random (length ret))
+ ret))
+ (cdr
+ (assq 'title
+ (with-temp-buffer
+ (insert-file-contents
+ (expand-file-name
+ "dir.desc"
+ (expand-file-name sub-url album-dir-base)))
+ (read (current-buffer))))))))
+ (insert "</ul>
+
+<hr>
+
+</body>
+</html>
+")
+ (write-region (point-min)(point-max)
+ (expand-file-name
+ "index.html.ja.utf-8" album-dir-base))
+ )))
+
\ No newline at end of file
projects / elisp / album.git / blobdiff