;;; album.el --- Photo album utility ;; Copyright (C) 2005,2006 MORIOKA Tomohiko ;; Keywords: Photo, image, album, HTML, WWW ;; This file is part of Album. ;; Album 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 2, or (at your option) ;; any later version. ;; Album 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 GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ;;; Commentary: ;; It requires `convert' and `identify' of ImageMagick. ;;; Code: (defun album-write-html (dest-dir prev-file file next-file prev-grade grade next-grade lang image-url-prefix &optional image-url) (with-temp-buffer (insert "\n") (insert "\n") (insert "\n") (insert (format "%s\n" file)) (insert "\n") (insert "\n") ;; (insert (format "

%s

\n" file)) (if prev-file (insert (format "" prev-file))) (insert "[Previous]") (if prev-file (insert "")) (insert "\n") (if next-file (insert (format "" next-file))) (insert "[Next]") (if next-file (insert "")) (insert "\n") (if prev-grade (insert (format "" prev-grade file))) (insert "[Smaller]") (if prev-grade (insert "")) (insert "\n") (if next-grade (insert (format "" next-grade file))) (insert "[Larger]") (if next-grade (insert "")) (insert "\n") (insert "
") (insert "") (insert (format "\"%s\"" (or image-url (concat file ".jpg")) (if image-url-prefix (format "%s%s/%s" (file-name-as-directory image-url-prefix) grade (or image-url file)) (or image-url (concat file ".jpg"))))) (insert "
[index] ") (unless (file-exists-p (expand-file-name (symbol-name grade) dest-dir)) (make-directory (expand-file-name (symbol-name grade) dest-dir))) (write-region (point-min)(point-max) (expand-file-name (concat file ".html") (expand-file-name (symbol-name grade) dest-dir))))) (defun album-convert-image (image-dest-dir prev-file file next-file lang image-url-prefix html-dest-dir) (setq file (expand-file-name file)) (unless html-dest-dir (setq html-dest-dir image-dest-dir)) (let* ((ret (with-temp-buffer (call-process "identify" nil t t file) (goto-char (point-min)) (and (re-search-forward " \\([0-9]+\\)x\\([0-9]+\\) " nil t) (cons (string-to-number (match-string 1)) (string-to-number (match-string 2)))))) (width (car ret)) (height (cdr ret)) (specs '((QVGA 320 240) (VGA 640 480) (SVGA 800 600) (XGA 1024 768) (WXGA 1280 768) (SXGA 1280 1024) (SXGA+ 1400 1050) (WSXGA+ 1680 1050) (UXGA 1600 1200) (WUXGA 1920 1200) (QXGA 2048 1536) (WQXGA 2560 1600) )) prev-grade rest dest) (unless (file-exists-p (expand-file-name "thumbnail" image-dest-dir)) (make-directory (expand-file-name "thumbnail" image-dest-dir))) (call-process "convert" nil nil nil "-resize" "160x160>" file (expand-file-name (concat (file-name-sans-extension (file-name-nondirectory file)) ".jpg") (expand-file-name "thumbnail" image-dest-dir))) (setq rest specs) (while rest (setq spec (car rest)) (when (or (> width (nth 1 spec)) (> height (nth 2 spec))) (album-write-html html-dest-dir (if prev-file (file-name-sans-extension (file-name-nondirectory prev-file))) (file-name-sans-extension (file-name-nondirectory file)) (if next-file (file-name-sans-extension (file-name-nondirectory next-file))) prev-grade (car spec) ; (aref spec 1) (if (nth 1 rest) ;; (aref (nth 1 rest) 1) (car (nth 1 rest)) ) lang image-url-prefix) (call-process "convert" nil nil nil "-resize" (format "%dx%d>" (nth 1 spec)(nth 2 spec)) file (expand-file-name (concat (file-name-sans-extension (file-name-nondirectory file)) ".jpg") (expand-file-name (symbol-name (car spec)) image-dest-dir))) (setq prev-grade (car spec))) (setq rest (cdr rest))) (unless (file-exists-p (expand-file-name "fullsize" image-dest-dir)) (make-directory (expand-file-name "fullsize" image-dest-dir))) (if (string= (downcase (file-name-extension file)) "jpg") (call-process "ln" nil nil nil "-f" file (expand-file-name "fullsize" image-dest-dir)) (call-process "convert" nil nil nil file (expand-file-name (concat (file-name-sans-extension (file-name-nondirectory file)) ".jpg") (expand-file-name "fullsize" image-dest-dir)))) dest)) (defun album-convert-images (image-dest-dir source-images &optional lang title parent-url image-url-prefix html-dest-dir) (unless html-dest-dir (setq html-dest-dir image-dest-dir)) ;; (if (and (consp (car source-images)) ;; (null (cdr source-images))) ;; (setq source-images (car source-images))) (album-make-thumbnails html-dest-dir source-images lang title image-url-prefix parent-url) (let (file prev-file) (while source-images (setq file (car source-images)) (album-convert-image image-dest-dir prev-file file (nth 1 source-images) lang image-url-prefix html-dest-dir) (setq prev-file file source-images (cdr source-images))))) (defun album-make-thumbnails (html-dest-dir source-images lang title image-url-prefix parent-url) (unless title (setq title (file-name-nondirectory (if (eq (aref html-dest-dir (1- (length html-dest-dir))) ?/) (substring html-dest-dir 0 (1- (length html-dest-dir))) html-dest-dir)))) (let (file) (with-temp-buffer (insert "\n") (insert "\n") (insert "\n") (insert (format "%s\n" title)) (insert "\n") (insert "\n") (insert (format "

%s

\n" title)) (insert "
") (dolist (image-file source-images) (setq file (file-name-sans-extension (file-name-nondirectory image-file))) (insert "") (insert (format "\"%s\"" file (if image-url-prefix (format "%s/%s/%s" image-url-prefix grade file) file))) (insert "\n")) (insert "
") (if parent-url (insert (format "[Return]\n" parent-url))) (insert " ") (write-region (point-min)(point-max) (expand-file-name "index.html" html-dest-dir))))) (defun album-convert-directory (image-dest-dir source-dir &optional patterns lang title parent-url image-url-prefix html-dest-dir) (let (files) (if patterns (dolist (pat patterns) (setq files (append files (directory-files source-dir 'full pat)))) (setq files (let (case-fold-search) (directory-files source-dir 'full ".+\\.\\(tiff\\|TIFF\\|jpg\\|JPG\\|jpeg\\|JPEG\\|gif\\|GIF\\|png\\|PNG\\)$")))) (album-convert-images image-dest-dir files lang title parent-url image-url-prefix html-dest-dir))) (defun album-make-selection-1 (image-dest-dir prev-file file next-file lang image-url-prefix html-dest-dir &optional image-url-spec) (setq file (expand-file-name file)) (unless html-dest-dir (setq html-dest-dir image-dest-dir)) (let* ((specs '((QVGA 320 240) (VGA 640 480) (SVGA 800 600) (XGA 1024 768) (WXGA 1280 768) (SXGA 1280 1024) (SXGA+ 1400 1050) (WSXGA+ 1680 1050) (UXGA 1600 1200) (WUXGA 1920 1200) (QXGA 2048 1536) (WQXGA 2560 1600) )) prev-grade rest dest) (setq rest specs) (while rest (setq spec (car rest)) (album-write-html html-dest-dir (if prev-file (file-name-sans-extension (file-name-nondirectory prev-file))) (file-name-sans-extension (file-name-nondirectory file)) (if next-file (file-name-sans-extension (file-name-nondirectory next-file))) prev-grade (car spec) (if (nth 1 rest) (car (nth 1 rest))) lang (if image-url-spec (nth 1 image-url-spec) image-url-prefix) (if image-url-spec (nth 2 image-url-spec)) ) (setq prev-grade (car spec)) (setq rest (cdr rest))) dest)) (defun album-make-selection (image-dest-dir source-images &optional lang title parent-url image-url-prefix html-dest-dir) (unless html-dest-dir (setq html-dest-dir image-dest-dir)) ;; (album-make-thumbnails html-dest-dir source-images ;; lang title image-url-prefix parent-url) (let ((i 1) image-url-spec prev-file) (while source-images (setq image-url-spec (car source-images)) (setq file (format "%d" i)) (album-make-selection-1 image-dest-dir prev-file file (if (nth 1 source-images) (format "%d" (1+ i))) lang image-url-prefix html-dest-dir image-url-spec) (setq prev-file file source-images (cdr source-images)) (setq i (1+ i))))) (provide 'album) ;;; album.el ends here