diff --git a/Makefile.in b/Makefile.in index dad6d77..3173e0e 100644 --- a/Makefile.in +++ b/Makefile.in @@ -312,6 +312,7 @@ LTLIBOBJS = @LTLIBOBJS@ MAKEINFO = @MAKEINFO@ MAN = @MAN@ MKDIR_P = @MKDIR_P@ +MONTAGE = @MONTAGE@ MSGFMT = @MSGFMT@ MSGFMT_015 = @MSGFMT_015@ MSGMERGE = @MSGMERGE@ diff --git a/configure b/configure index 1945e39..50f5c48 100755 --- a/configure +++ b/configure @@ -621,6 +621,7 @@ ac_subst_vars='am__EXEEXT_FALSE am__EXEEXT_TRUE LTLIBOBJS LIBOBJS +MONTAGE DIRNAME CHMOD GIT @@ -7624,6 +7625,64 @@ if test "$DIRNAME" = "no" ; then exit 1; fi +for ac_prog in montage +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +printf %s "checking for $ac_word... " >&6; } +if test ${ac_cv_path_MONTAGE+y} +then : + printf %s "(cached) " >&6 +else $as_nop + case $MONTAGE in + [\\/]* | ?:[\\/]*) + ac_cv_path_MONTAGE="$MONTAGE" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + case $as_dir in #((( + '') as_dir=./ ;; + */) ;; + *) as_dir=$as_dir/ ;; + esac + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then + ac_cv_path_MONTAGE="$as_dir$ac_word$ac_exec_ext" + printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +MONTAGE=$ac_cv_path_MONTAGE +if test -n "$MONTAGE"; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $MONTAGE" >&5 +printf "%s\n" "$MONTAGE" >&6; } +else + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 +printf "%s\n" "no" >&6; } +fi + + + test -n "$MONTAGE" && break +done +test -n "$MONTAGE" || MONTAGE="no" + + +if test "$MONTAGE" = "no" ; then + { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Can not find imagemagick 'montage' executable." >&5 +printf "%s\n" "$as_me: WARNING: Can not find imagemagick 'montage' executable." >&2;} + exit 1; +fi + diff --git a/configure.ac b/configure.ac index d12dfbe..32701cf 100644 --- a/configure.ac +++ b/configure.ac @@ -123,6 +123,13 @@ if test "$DIRNAME" = "no" ; then exit 1; fi +AC_PATH_PROGS([MONTAGE],[montage],[no]) + +if test "$MONTAGE" = "no" ; then + AC_MSG_WARN([Can not find imagemagick 'montage' executable.]) + exit 1; +fi + AC_PROG_MKDIR_P dnl checks for libraries diff --git a/etc/init.lisp b/etc/init.lisp index 9e913f9..56f4a6d 100644 --- a/etc/init.lisp +++ b/etc/init.lisp @@ -482,6 +482,8 @@ (define-key "C-[" #'go-to-previous-link *gemini-message-keymap*) +(define-key "I M" #'gemini-images-montage *gemini-message-keymap*) + ;; gemini page table of contents keymap (define-key "up" #'gemini-toc-scroll-up *gemini-toc-keymap*) diff --git a/src/config.lisp.in.in b/src/config.lisp.in.in index 6dff526..b6569b0 100644 --- a/src/config.lisp.in.in +++ b/src/config.lisp.in.in @@ -19,7 +19,9 @@ (alexandria:define-constant +unzip-bin+ "@UNZIP@" :test #'string=) -(alexandria:define-constant +man-bin+ "@MAN@" :test #'string=) +(alexandria:define-constant +man-bin+ "@MAN@" :test #'string=) + +(alexandria:define-constant +montage-bin+ "@MONTAGE@" :test #'string=) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -30,7 +32,9 @@ (allow-features +unzip-bin+ :gempub-support) - (allow-features +man-bin+ :man-bin)) + (allow-features +man-bin+ :man-bin) + + (allow-features +montage-bin+ :montage-bin)) (defmacro with-return-untranslated ((untranslated) &body body) `(handler-bind ((i18n-conditions:no-translation-table-error diff --git a/src/os-utils.lisp b/src/os-utils.lisp index b5b06cb..3fd6535 100644 --- a/src/os-utils.lisp +++ b/src/os-utils.lisp @@ -79,7 +79,9 @@ search input output - (error :output)) + (error :output) + #+sbcl (if-output-exists :supersede) + #+sbcl (if-error-exists :supersede)) (declare (ignorable search)) #+ecl (ext:run-program program args @@ -88,12 +90,14 @@ :error error :wait wait) #+sbcl (sb-ext:run-program program - args - :wait wait - :search search - :input input - :output output - :error error)) + args + :wait wait + :search search + :input input + :output output + :error error + :if-output-exists if-output-exists + :if-error-exists if-error-exists)) (defun process-exit-code (process) #+ecl (nth-value 1 (ext:external-process-status process)) diff --git a/src/package.lisp b/src/package.lisp index 75d9d6c..43d77e5 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -36,6 +36,7 @@ :+xdg-open-bin+ :+unzip-bin+ :+man-bin+ + :+montage-bin+ :_ :n_)) @@ -2799,6 +2800,7 @@ :search-link-window :open-gemini-message-link-window :open-message-link + :gemini-images-montage :open-message-link-go-up :open-message-link-go-down :open-message-link-perform-opening diff --git a/src/ui-goodies.lisp b/src/ui-goodies.lisp index 7bc7ec5..af3119b 100644 --- a/src/ui-goodies.lisp +++ b/src/ui-goodies.lisp @@ -1496,6 +1496,64 @@ It an existing file path is provided the command will refuse to run." :enqueue enqueue :links links))) +(define-constant +image-link-extension-re+ "(?i)(\\.jpg$)|(\\.bmp$)|(\\.png$)|(\\.tiff$)|(\\.tga$)|(\\.ps$)|(\\.svg)|(\\.pcx)" + :test #'string=) + +(defun gemini-images-montage () + #+montage-bin + (when-let* ((window *message-window*) + (metadata (message-window:metadata window)) + (links (gemini-viewer:gemini-metadata-links metadata)) + (images-uris (remove-if-not (lambda (a) (cl-ppcre:scan +image-link-extension-re+ + (gemini-parser:target a))) + links)) + (images-count (length images-uris)) + (name-padding (num:count-digit images-count)) + (name-format (format nil (_"\"Figure: ~~~d,'0d\"") name-padding)) + (names (loop for ct from 1 below (1+ images-count) + collect + (format nil name-format ct))) + (files (loop for ct from 0 below images-count + collect + (fs:temporary-file :extension ".bitmap"))) + (output-file (fs:temporary-file))) + (loop for file in files + for uri in images-uris + do + (let ((data (gemini-client:slurp-gemini-url (gemini-parser:target uri)))) + (with-open-file (stream file + :direction :output + :if-does-not-exist :error + :if-exists :supersede + :element-type filesystem-tree-window:+octect-type+) + (write-sequence data stream)))) + (let* ((command-line (flatten (list "-title" (gemini-viewer:current-gemini-url) + "-frame" "5" + "-geometry" "320x320" + "-tile" "x4" + "-background" "Grey" + "-bordercolor" "SkyBlue" + "-mattecolor" "Lavender" + "-font" "Arial" + "-pointsize" "12" + (loop for name in names + for file in files + collect + (list "-label" name file)) + "-"))) + (process (os-utils:run-external-program +montage-bin+ + command-line + :search t + :wait t + :input t + :output output-file + :error t))) + (if (not (os-utils:process-exit-success-p process)) + (error-message (_ "Error during image composition.")) + (os-utils:xdg-open output-file)))) + #-montage-bin + (notify (_ "ImageMagick binaries not found on this system") :as-error t)) + (defun open-message-link () "Open message links window