X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;ds=sidebyside;f=www-page.el;h=2c50727d0bc707653f80904635642511416b8c8a;hb=40a882698055201c3dee08225c4700cf71a4d948;hp=9f92a1a8db8ccbda2660ced19bf56b7cb97a1cec;hpb=34d4fd8cbbdb321f571e5ad98b1f9b5f78cabf18;p=elisp%2Falbum.git diff --git a/www-page.el b/www-page.el index 9f92a1a..2c50727 100644 --- a/www-page.el +++ b/www-page.el @@ -1,6 +1,6 @@ ;;; www-page.el --- Album page generator for page.cgi. -;; Copyright (C) 2005,2006 MORIOKA Tomohiko +;; Copyright (C) 2005,2006,2007 MORIOKA Tomohiko ;; Keywords: Photo, image, album, HTML, WWW @@ -27,6 +27,8 @@ ;;; Code: +(defconst www-page-version "0.4") + (defvar www-page-coding-system (if (featurep 'chise) 'utf-8-jp-er @@ -41,7 +43,7 @@ (VGA 640 480) (SVGA 800 600) (XGA 1024 768) - (WXGA 1280 768) + (WXGA 1280 800) (SXGA 1280 1024) (SXGA+ 1400 1050) (WSXGA+ 1680 1050) @@ -49,6 +51,7 @@ (WUXGA 1920 1200) (QXGA 2048 1536) (WQXGA 2560 1600) + (original nil nil) )) (defun decode-url-string (string &optional coding-system) @@ -66,20 +69,32 @@ (concat dest (substring string i)) coding-system)))) -(defun www-page-display-thumbnails (url-dir &optional size image-root - lang title parent-url) +(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* ((desc-file - (expand-file-name "dir.desc" - (expand-file-name url-dir image-root))) - (params - (with-temp-buffer - (when (file-exists-p desc-file) - (insert-file-contents desc-file) - (read (current-buffer))))) + (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) @@ -93,6 +108,9 @@ (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)) @@ -110,20 +128,36 @@ (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 "" + (insert (format ".html.%s&size=%s&p=%s\">" (or lang 'en) - (or size 'VGA))) - (insert (format " $\"%s\"$ " - file url-dir file)) + (or size 'VGA) + (or pivot-mode t))) + (insert (format " $\"%s\"$ ") (insert "\n")) (setq i 1) @@ -150,8 +184,11 @@ (insert "))\n") (write-region (point-min)(point-max) file-desc))) (setq file (file-name-nondirectory ref-file)) - (insert "" i (or lang 'en) @@ -176,6 +213,9 @@ (if parent-url (insert (format "[Return]\n" parent-url))) + (insert + (format "

+Powered by MnjAlbum WWW-Page Version %s." www-page-version)) (insert " @@ -185,9 +225,12 @@ ))) (defun www-page-display-page (file &optional size image-root - lang prev-file next-file) + 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 @@ -207,156 +250,215 @@ (insert "\n") ;; (insert (format "

%s

\n" file)) - (if (file-exists-p (expand-file-name file image-root)) - (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 - (with-temp-buffer - (when (file-exists-p dir-desc-file) - (insert-file-contents dir-desc-file) - (read (current-buffer))))) - (when (setq rest (assq 'files params)) - (setq rest (cdr rest))) - (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))) + (let* ((desc-file (expand-file-name (concat file ".desc") image-root)) + (params (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) + (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 - (setq spec (car rest)) - (not (eq (car spec) size))) - (setq prev-grade (car spec) + (not (string= (car rest) ret))) + (setq prev-file (car rest) rest (cdr rest))) - (setq next-grade (car (car (cdr rest)))) - (if prev-file - (insert (format "" - (file-name-directory file) prev-file - (or lang 'en) - size))) - (cond ((eq lang 'ja) - (insert "[前]") - ) - (t - (insert "[Previous]") - )) + (setq next-file (car (cdr rest))) (if prev-file - (insert "")) - (insert "\n") - - (if next-file - (insert (format "" - (file-name-directory file) next-file - (or lang 'en) - size))) - (cond ((eq lang 'ja) - (insert "[次]") - ) - (t - (insert "[Next]") - )) + (setq params (list (cons 'prev-file prev-file)))) (if next-file - (insert "")) - (insert "\n") - - (if prev-grade - (insert (format "" - file - (or lang 'en) - prev-grade))) - (cond ((eq lang 'ja) - (insert "[縮小]") - ) - (t - (insert "[Smaller]") - )) - (if prev-grade - (insert "")) - (insert "\n") - - (if next-grade - (insert (format "" - file - (or lang 'en) - next-grade))) - (cond ((eq lang 'ja) - (insert "[拡大]") - ) - (t - (insert "[Larger]") - )) - (if next-grade - (insert "")) - (insert "\n") - - (insert " + (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 "

") - (if next-file - (insert (format "" - (file-name-directory file) next-file - (or lang 'en) - size))) - (insert - (if image-ref - (format " $\"%s\"$ " - file image-ref size) - (format " $\"%s\"$ " - file image-file size))) - (if next-file - (insert "")) - ) - (insert "

") - (insert (format - (cond - ((eq lang 'ja) - "画像ファイル %s が見付かりません。\n") - (t - "Image file %s is not found.\n")) - file)) + (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 - (format "[index]" - (file-name-directory file) - (or lang 'en) - size)) + (cond ((eq lang 'ja) + "（変更した大きさは維持されます）") + (t + ""))) + (insert + (format "

+Powered by MnjAlbum WWW-Page Version %s." www-page-version)) (insert " @@ -365,59 +467,86 @@ (princ (buffer-string)) )) -(defun www-page-display-image (file &optional size image-root) +(defun www-page-display-image (file &optional size image-root pivot-mode) (setq file (expand-file-name file image-root)) - (let (file-dir file-name - resized-file resized-dir - spec) - (cond - (size - (setq file-dir (file-name-directory file) - file-name (file-name-nondirectory file)) - (setq resized-file - (expand-file-name - file-name - (setq resized-dir - (expand-file-name - size file-dir)))) - (unless (file-exists-p resized-file) - (setq size (intern size)) - (if (setq spec (assq size www-page-size-specs)) - (progn - (condition-case nil - (unless (file-exists-p resized-dir) - (make-directory resized-dir)) - (error nil)) - (call-process - "convert" nil nil nil - "-resize" (format "%dx%d>" (nth 1 spec)(nth 2 spec)) - file resized-file) - ) - (setq resized-file 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)))))) + (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 pivot-mode + (> 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 key image-root lang ret) + (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 @@ -453,22 +582,29 @@ 'dir))) ;; (setq file (car (cdr (assoc "file" params)))) (setq size (car (cdr (assoc "size" params)))) + (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-thumbnails target size image-root lang) + (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) + (www-page-display-page target size image-root lang + nil nil hide-cgi pivot-mode) ) (t - (www-page-display-image target size image-root) + (www-page-display-image target size image-root pivot-mode) ) )))