;;; www-page.el --- Album page generator for page.cgi. ;; Copyright (C) 2005,2006,2007 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: (defconst www-page-version "0.4") (defvar www-page-coding-system (if (featurep 'chise) 'utf-8-jp-er 'utf-8)) (defvar www-page-default-base-directory "../pub/pages/") (defvar www-page-size-specs '((thumbnail 160 160) (QVGA 320 240) (VGA 640 480) (SVGA 800 600) (XGA 1024 768) (WXGA 1280 800) (SXGA 1280 1024) (SXGA+ 1400 1050) (WSXGA+ 1680 1050) (UXGA 1600 1200) (WUXGA 1920 1200) (QXGA 2048 1536) (WQXGA 2560 1600) (original nil nil) )) (defun decode-url-string (string &optional coding-system) (if (> (length string) 0) (let ((i 0) dest) (while (string-match "%\\([0-9A-F][0-9A-F]\\)" string i) (setq dest (concat dest (substring string i (match-beginning 0)) (char-to-string (int-char (string-to-int (match-string 1 string) 16)))) i (match-end 0))) (decode-coding-string (concat dest (substring string i)) coding-system)))) (defun www-page-open-dir (url-dir &optional image-root) (let* ((path (expand-file-name url-dir image-root)) (desc-file (expand-file-name "dir.desc" path))) (cons (cons 'location path) (with-temp-buffer (when (file-exists-p desc-file) (insert-file-contents desc-file) (read (current-buffer))))))) (defun www-page-directory-image-files (url-dir image-root) (let (source-images) (dolist (file (directory-files (expand-file-name url-dir image-root) nil "\\.\\(jpg\\|JPG\\)$" nil t)) (unless (string-match "_[^_]+GA[^_]*$" (file-name-sans-extension file)) (setq source-images (cons file source-images)))) (nreverse source-images))) (defun www-page-display-dir (url-dir &optional size image-root lang title parent-url hide-cgi pivot-mode) (setq url-dir (file-name-as-directory url-dir)) (princ "Content-Type: text/html; charset=UTF-8 ") (let* ((params (www-page-open-dir url-dir image-root)) source-images ref-images file i ref-file prev-file next-file file-desc note) (when (setq title (assq 'title params)) (setq title (cdr title))) (unless title (setq title (file-name-nondirectory (substring url-dir 0 (1- (length url-dir)))))) (when (setq source-images (assq 'files params)) (setq source-images (cdr source-images))) (when (setq ref-images (assq 'refs params)) (setq ref-images (cdr ref-images))) (unless (or source-images ref-images) (setq source-images (www-page-directory-image-files url-dir image-root))) (when (setq note (assq 'note params)) (setq note (cdr note))) (when (setq parent-url (assq 'exit params)) (setq parent-url (cdr parent-url))) (with-temp-buffer (insert "\n") (insert "\n") (insert "\n") (insert (format "%s\n" title)) (insert "\n") (insert "\n") (insert (format "

%s

\n" title)) (insert "
") (cond ((or (eq lang 'ja) (string= lang "ja")) (insert "[Note] サムネイルをクリックすると大きな画像が表示されます
") ) (t (insert (format "lang = %s
\n" lang)))) (dolist (image-file source-images) (setq file (file-name-nondirectory image-file)) (insert "" (or lang 'en) (or size 'VGA) (or pivot-mode t))) (insert (format "\"%s\"") (insert "\n")) (setq i 1) (while ref-images (setq ref-file (car ref-images)) (setq next-file (if (cdr ref-images) (format "%d" (1+ i)))) (setq file-desc (expand-file-name (format "%d.desc" i) (expand-file-name url-dir image-root))) (unless (file-exists-p file-desc) (with-temp-buffer (insert "(") (if prev-file (insert (format "(prev-file . %S)\n " prev-file))) ;; (insert (format "(ref . \"%s%s\")\n " ;; url-dir ref-file)) (insert (format "(ref . \"%s\")\n " ref-file)) (if next-file (insert (format "(next-file . %S)\n " next-file))) (insert "))\n") (write-region (point-min)(point-max) file-desc))) (setq file (file-name-nondirectory ref-file)) (insert "" i (or lang 'en) (or size 'VGA))) ;; (insert (format "\"%s\"" ;; file url-dir ref-file)) (insert (format "\"%s\"" file ref-file)) (insert "\n") (setq prev-file (format "%d" i)) (setq i (1+ i) ref-images (cdr ref-images))) (when note (insert "

") (insert note)) (insert "


") (if parent-url (insert (format "[Return]\n" parent-url))) (insert (format "
Powered by MnjAlbum WWW-Page Version %s." www-page-version)) (insert " ") (encode-coding-region (point-min)(point-max) www-page-coding-system) (princ (buffer-string)) ))) (defun www-page-display-page (file &optional size image-root lang prev-file next-file hide-cgi pivot-mode) (if (stringp size) (setq size (intern size))) (if (stringp pivot-mode) (setq pivot-mode (intern pivot-mode))) (if (stringp lang) (setq lang (intern lang))) (princ "Content-Type: text/html; charset=UTF-8 ") (with-temp-buffer (insert "\n") (insert "\n") (insert "\n") (insert (format "%s\n" file)) (insert "\n") (insert "\n") ;; (insert (format "

%s

\n" file)) (let* ((desc-file (expand-file-name (concat file ".desc") image-root)) (params (with-temp-buffer (when (file-exists-p desc-file) (insert-file-contents desc-file) (read (current-buffer))))) ;; dir-desc-file image-file image-ref prev-file next-file prev-grade next-grade rest spec ret) (unless params ;; (setq dir-desc-file ;; (expand-file-name "dir.desc" ;; (expand-file-name (file-name-directory file) ;; image-root))) (setq params (www-page-open-dir (file-name-directory file) image-root) ;; (with-temp-buffer ;; (when (file-exists-p dir-desc-file) ;; (insert-file-contents dir-desc-file) ;; (read (current-buffer)))) ) (unless (assq 'refs params) (if (setq rest (assq 'files params)) (setq rest (cdr rest)) (setq rest (www-page-directory-image-files (file-name-directory file) image-root))) (setq ret (file-name-nondirectory file)) (while (and rest (not (string= (car rest) ret))) (setq prev-file (car rest) rest (cdr rest))) (setq next-file (car (cdr rest))) (if prev-file (setq params (list (cons 'prev-file prev-file)))) (if next-file (setq params (cons (cons 'next-file next-file) params))) (if (file-directory-p (file-name-directory desc-file)) (with-temp-buffer (insert (format "%S" params)) ;; (princ "X-XEmacs-Message: ") (write-region (point-min)(point-max) desc-file) ;; (princ "\n") )))) (if (setq image-ref (assq 'ref params)) (setq image-ref (cdr image-ref)) (setq image-file file)) (if (setq prev-file (assq 'prev-file params)) (setq prev-file (cdr prev-file))) (if (setq next-file (assq 'next-file params)) (setq next-file (cdr next-file))) (setq rest www-page-size-specs) (while (and rest (setq spec (car rest)) (not (eq (car spec) size))) (setq prev-grade (car spec) rest (cdr rest))) (setq next-grade (car (car (cdr rest)))) (when prev-file (insert "" prev-file (or lang 'en) size pivot-mode)) ) (cond ((eq lang 'ja) (insert "[前]") ) (t (insert "[Previous]") )) (if prev-file (insert "")) (insert "\n") (when next-file (insert "" next-file (or lang 'en) size pivot-mode)) ) (cond ((eq lang 'ja) (insert "[次]") ) (t (insert "[Next]") )) (if next-file (insert "")) (insert "\n") (when prev-grade (insert "" (file-name-nondirectory file) (or lang 'en) prev-grade pivot-mode)) ) (cond ((eq lang 'ja) (insert "[縮小]") ) (t (insert "[Smaller]") )) (if prev-grade (insert "")) (insert "\n") (when next-grade (insert "" (file-name-nondirectory file) (or lang 'en) next-grade pivot-mode)) ) (cond ((eq lang 'ja) (insert "[拡大]") ) (t (insert "[Larger]") )) (if next-grade (insert "")) (insert "\n") (insert "
") (when next-file (insert "" next-file (or lang 'en) size pivot-mode)) ) (cond (image-ref (insert (format "\"%s\"" file image-ref size pivot-mode)) ) (t ; (file-exists-p (expand-file-name image-file image-root)) (insert (format "\"%s\"" (file-name-nondirectory image-file) size pivot-mode)) ) (t (insert "

") (insert (format (cond ((eq lang 'ja) "画像ファイル %s が見付かりません。\n") (t "Image file %s is not found.\n")) file)))) (if next-file (insert "")) ) (insert "


") ;; (insert ;; (format "[index]" ;; (file-name-directory file) ;; (or lang 'en) ;; size)) (insert "%s" (or lang 'en) size pivot-mode (cond ((eq lang 'ja) "[index] に戻る") (t "[index]")))) (insert (cond ((eq lang 'ja) "(変更した大きさは維持されます)") (t ""))) (insert (format "
Powered by MnjAlbum WWW-Page Version %s." www-page-version)) (insert " ") (encode-coding-region (point-min)(point-max) www-page-coding-system) (princ (buffer-string)) )) (defun www-page-display-image (file &optional size image-root pivot-mode) (if (stringp pivot-mode) (setq pivot-mode (intern pivot-mode))) (setq file (expand-file-name file image-root)) (when (file-exists-p file) (let (file-dir file-name resized-file resized-dir spec width height orig-width orig-height size-opt) (setq size (intern size)) (cond ((and size (setq spec (assq size www-page-size-specs)) (setq width (nth 1 spec)) (setq height (nth 2 spec))) (setq file-dir (file-name-directory file) file-name (file-name-nondirectory file)) (setq size-opt (or (when (and (eq pivot-mode t) (> width height)) (with-temp-buffer (call-process "identify" nil t nil file) (goto-char (point-min)) (if (re-search-forward "^[^ ]+ [^ ]+ \\([0-9]+\\)x\\([0-9]+\\) " nil t) (setq orig-width (string-to-int (match-string 1)) orig-height (string-to-int (match-string 2))))) (if (> orig-height orig-width) 'p)) "")) (setq resized-file (format "%s_%s%s.%s" (file-name-sans-extension file) size size-opt (file-name-extension file))) (unless (file-exists-p resized-file) (setq resized-file (expand-file-name file-name (setq resized-dir (expand-file-name (format "%s%s" size size-opt) file-dir)))) (unless (file-exists-p resized-file) (condition-case nil (unless (file-exists-p resized-dir) (make-directory resized-dir)) (error nil)) (call-process "convert" nil nil nil "-resize" (if (eq size-opt 'p) (format "%dx%d>" height width) (format "%dx%d>" width height)) file resized-file))) ;; (princ resized-file) (setq file resized-file) ) (t ;; (princ file) )) (princ (format "Content-Type: %s" (with-temp-buffer (call-process "file" nil t t "-b" "--mime" file) (insert "\n") (let ((coding-system-for-read 'binary) (coding-system-for-write 'binary)) (insert-file-contents-literally file)) (buffer-string))))))) (defun www-page-batch-get () ;; (set-coding-priority-list ;; '(iso-7 iso-8-2 utf-8 big5 shift-jis ;; iso-8-designate iso-8-1 iso-lock-shift no-conversion)) ;; (set-coding-category-system 'utf-8 'utf-8-jp) (let (target params method size pivot-mode key image-root lang ret hide-cgi) (let ((rest (car command-line-args-left)) arg val) (if rest (setq rest (split-string rest "&"))) (setq target (car rest) rest (cdr rest)) (while rest (when (and (string-match "=" (setq arg (car rest))) (> (length (setq val (substring arg (match-end 0)))) 0)) (setq key (substring arg 0 (match-beginning 0))) (set-alist 'params key (cons (decode-url-string val www-page-coding-system) (cdr (assoc key params))))) (setq rest (cdr rest)))) (setq method (cond ((string-match "\\.html\\(\\.\\([a-z]+\\)\\)?$" target) (setq lang (match-string 2 target)) (setq target (substring target 0 (match-beginning 0))) (cond ((string= (file-name-nondirectory ;; (substring target 0 (match-beginning 0)) target ) "index") (setq target (file-name-directory target)) 'dir) (t 'page)) ) ((or (string= (file-name-nondirectory target) "") (null (file-name-extension target))) 'dir))) ;; (setq file (car (cdr (assoc "file" params)))) (setq size (or (car (cdr (assoc "size" params))) 'VGA)) (setq pivot-mode t) (if (setq ret (cdr (assoc "p" params))) (setq pivot-mode (car ret))) (if (setq ret (cdr (assoc "lang" params))) (setq lang (car ret))) (setq command-line-args-left (cdr command-line-args-left)) (setq hide-cgi (string= (car command-line-args-left) "hide-cgi")) (setq command-line-args-left (cdr command-line-args-left)) (setq image-root (or (car command-line-args-left) (expand-file-name www-page-default-base-directory default-directory))) (setq command-line-args-left (cdr command-line-args-left)) (cond ((eq method 'dir) (www-page-display-dir target size image-root lang nil nil hide-cgi pivot-mode) ) ((eq method 'page) (www-page-display-page target size image-root lang nil nil hide-cgi pivot-mode) ) (t (www-page-display-image target size image-root pivot-mode) ) ))) (provide 'www-page) ;;; www-page.el ends here