;;; www-page.el --- Album page generator for page.cgi.
-;; Copyright (C) 2005,2006 MORIOKA Tomohiko
+;; Copyright (C) 2005,2006,2007,2009,2010 MORIOKA Tomohiko
;; Keywords: Photo, image, album, HTML, WWW
;;; Code:
+(defconst www-page-version "0.5")
+
(defvar www-page-coding-system
(if (featurep 'chise)
'utf-8-jp-er
(VGA 640 480)
(SVGA 800 600)
(XGA 1024 768)
- (WXGA 1280 768)
+ (WXGA 1280 800)
(SXGA 1280 1024)
(SXGA+ 1400 1050)
(WSXGA+ 1680 1050)
(WUXGA 1920 1200)
(QXGA 2048 1536)
(WQXGA 2560 1600)
+ (original nil nil)
))
(defun decode-url-string (string &optional coding-system)
(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)
(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))
(insert "</head>\n")
(insert "<body>\n")
(insert (format "<h1>%s</h1>\n" title))
-
(insert "
<hr>
")
+ (cond
+ ((or (eq lang 'ja)
+ (string= lang "ja"))
+ (insert
+ "[Note] \e$B%5%`%M%$%k$r%/%j%C%/$9$k$HBg$-$J2hA|$,I=<($5$l$^$9\e(B
+<hr>
+")
+ )
+ (t
+ (insert (format "lang = %s<br>\n" lang))))
(dolist (image-file source-images)
(setq file (file-name-nondirectory image-file))
- (insert "<a href=\"page.cgi?")
- (insert url-dir)
+ (insert "<a href=\"")
+ (unless hide-cgi
+ (insert "page.cgi?")
+ (insert url-dir)
+ )
(insert file)
- (insert (format ".html.%s&size=%s\">"
+ (insert (format ".html.%s&size=%s&p=%s\">"
(or lang 'en)
- (or size 'VGA)))
- (insert (format "<img alt=\"%s\" src=\"page.cgi?%s%s&size=thumbnail\">"
- file url-dir file))
+ (or size 'VGA)
+ (or pivot-mode t)))
+ (insert (format "<img alt=\"%s\" src=\"" file))
+ (unless hide-cgi
+ (insert (format "img.cgi?%s" url-dir)))
+ (insert file)
+ (insert "&size=thumbnail\">")
(insert "</a>\n"))
(setq i 1)
(insert "))\n")
(write-region (point-min)(point-max) file-desc)))
(setq file (file-name-nondirectory ref-file))
- (insert "<a href=\"page.cgi?")
- (insert url-dir)
+ (insert "<a href=\"")
+ (unless hide-cgi
+ (insert "page.cgi?")
+ (insert url-dir)
+ )
(insert (format "%d.html.%s&size=%s\">"
i
(or lang 'en)
(if parent-url
(insert (format "[<a href=\"%s\">Return</a>]\n" parent-url)))
+ (insert
+ (format "<hr>
+Powered by MnjAlbum WWW-Page Version %s." www-page-version))
(insert "
</body>
</html>
)))
(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
(insert "<body>\n")
;; (insert (format "<h1>%s</h1>\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 "<a href=\"page.cgi?%s%s.html.%s&size=%s\">"
- (file-name-directory file) prev-file
- (or lang 'en)
- size)))
- (cond ((eq lang 'ja)
- (insert "[\e$BA0\e(B]")
- )
- (t
- (insert "[Previous]")
- ))
+ (setq next-file (car (cdr rest)))
(if prev-file
- (insert "</a>"))
- (insert "\n")
-
- (if next-file
- (insert (format "<a href=\"page.cgi?%s%s.html.%s&size=%s\">"
- (file-name-directory file) next-file
- (or lang 'en)
- size)))
- (cond ((eq lang 'ja)
- (insert "[\e$B<!\e(B]")
- )
- (t
- (insert "[Next]")
- ))
+ (setq params (list (cons 'prev-file prev-file))))
(if next-file
- (insert "</a>"))
- (insert "\n")
-
- (if prev-grade
- (insert (format "<a href=\"page.cgi?%s.html.%s&size=%s\">"
- file
- (or lang 'en)
- prev-grade)))
- (cond ((eq lang 'ja)
- (insert "[\e$B=L>.\e(B]")
- )
- (t
- (insert "[Smaller]")
- ))
- (if prev-grade
- (insert "</a>"))
- (insert "\n")
-
- (if next-grade
- (insert (format "<a href=\"page.cgi?%s.html.%s&size=%s\">"
- file
- (or lang 'en)
- next-grade)))
- (cond ((eq lang 'ja)
- (insert "[\e$B3HBg\e(B]")
- )
- (t
- (insert "[Larger]")
- ))
- (if next-grade
- (insert "</a>"))
- (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 "<a href=\"")
+ (unless hide-cgi
+ (insert (format "page.cgi?%s" (file-name-directory file))))
+ (insert (format "%s.html.%s&size=%s&p=%s\">"
+ prev-file
+ (or lang 'en)
+ size
+ pivot-mode))
+ )
+ (cond ((eq lang 'ja)
+ (insert "[\e$BA0\e(B]")
+ )
+ (t
+ (insert "[Previous]")
+ ))
+ (if prev-file
+ (insert "</a>"))
+ (insert "\n")
+
+ (when next-file
+ (insert "<a href=\"")
+ (unless hide-cgi
+ (insert (format "page.cgi?%s" (file-name-directory file))))
+ (insert (format "%s.html.%s&size=%s&p=%s\">"
+ next-file
+ (or lang 'en)
+ size
+ pivot-mode))
+ )
+ (cond ((eq lang 'ja)
+ (insert "[\e$B<!\e(B]")
+ )
+ (t
+ (insert "[Next]")
+ ))
+ (if next-file
+ (insert "</a>"))
+ (insert "\n")
+
+ (when prev-grade
+ (insert "<a href=\"")
+ (unless hide-cgi
+ (insert (format "page.cgi?%s" (file-name-directory file))))
+ (insert (format "%s.html.%s&size=%s&p=%s\">"
+ (file-name-nondirectory file)
+ (or lang 'en)
+ prev-grade
+ pivot-mode))
+ )
+ (cond ((eq lang 'ja)
+ (insert "[\e$B=L>.\e(B]")
+ )
+ (t
+ (insert "[Smaller]")
+ ))
+ (if prev-grade
+ (insert "</a>"))
+ (insert "\n")
+
+ (when next-grade
+ (insert "<a href=\"")
+ (unless hide-cgi
+ (insert (format "page.cgi?%s" (file-name-directory file))))
+ (insert (format "%s.html.%s&size=%s&p=%s\">"
+ (file-name-nondirectory file)
+ (or lang 'en)
+ next-grade
+ pivot-mode))
+ )
+ (cond ((eq lang 'ja)
+ (insert "[\e$B3HBg\e(B]")
+ )
+ (t
+ (insert "[Larger]")
+ ))
+ (if next-grade
+ (insert "</a>"))
+ (insert "\n")
+
+ (insert "
<hr>
")
- (if next-file
- (insert (format "<a href=\"page.cgi?%s%s.html.%s&size=%s\">"
- (file-name-directory file) next-file
- (or lang 'en)
- size)))
- (insert
- (if image-ref
- (format "<img alt=\"%s\" src=\"%s&size=%s\">"
- file image-ref size)
- (format "<img alt=\"%s\" src=\"page.cgi?%s&size=%s\">"
- file image-file size)))
- (if next-file
- (insert "</a>"))
- )
- (insert "<p>")
- (insert (format
- (cond
- ((eq lang 'ja)
- "\e$B2hA|%U%!%$%k\e(B %s \e$B$,8+IU$+$j$^$;$s!#\e(B\n")
- (t
- "Image file %s is not found.\n"))
- file))
+ (when next-file
+ (insert "<a href=\"")
+ (unless hide-cgi
+ (insert (format "page.cgi?%s" (file-name-directory file))))
+ (insert (format "%s.html.%s&size=%s&p=%s\">"
+ next-file
+ (or lang 'en)
+ size
+ pivot-mode))
+ )
+ (cond
+ (image-ref
+ (insert
+ (format "<img alt=\"%s\" src=\"%s&size=%s&p=%s\">"
+ file image-ref size pivot-mode))
+ )
+ (t ; (file-exists-p (expand-file-name image-file image-root))
+ (insert (format "<img alt=\"%s\" src=\"" file))
+ (unless hide-cgi
+ (insert (format "img.cgi?%s" (file-name-directory image-file))))
+ (insert (format "%s&size=%s&p=%s\">"
+ (file-name-nondirectory image-file)
+ size pivot-mode))
+ )
+ (t
+ (insert "<p>")
+ (insert (format
+ (cond
+ ((eq lang 'ja)
+ "\e$B2hA|%U%!%$%k\e(B %s \e$B$,8+IU$+$j$^$;$s!#\e(B\n")
+ (t
+ "Image file %s is not found.\n"))
+ file))))
+
+ (if next-file
+ (insert "</a>"))
)
(insert "
<hr>
")
+ ;; (insert
+ ;; (format "<a href=\"page.cgi?%s&lang=%s&size=%s\">[index]</a>"
+ ;; (file-name-directory file)
+ ;; (or lang 'en)
+ ;; size))
+ (insert "<a href=\"")
+ (unless hide-cgi
+ (insert (format "page.cgi?%s" (file-name-directory file))))
+ (insert (format "&lang=%s&size=%s&p=%s\">%s</a>"
+ (or lang 'en)
+ size
+ pivot-mode
+ (cond ((eq lang 'ja)
+ "[index] \e$B$KLa$k\e(B")
+ (t
+ "[index]"))))
(insert
- (format "<a href=\"page.cgi?%s&lang=%s&size=%s\">[index]</a>"
- (file-name-directory file)
- (or lang 'en)
- size))
+ (cond ((eq lang 'ja)
+ "\e$B!JJQ99$7$?Bg$-$5$O0];}$5$l$^$9!K\e(B")
+ (t
+ "")))
+ (insert
+ (format "<hr>
+Powered by MnjAlbum WWW-Page Version %s." www-page-version))
(insert "
</body>
</html>
(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)
+ (if (stringp pivot-mode)
+ (setq pivot-mode (intern 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 (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 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
(null (file-name-extension target)))
'dir)))
;; (setq file (car (cdr (assoc "file" params))))
- (setq size (car (cdr (assoc "size" 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-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)
)
)))
projects / elisp / album.git / blobdiff