Skip to content

Commit c8b92f7

Browse files
author
cage
committed
- added command 'gemini-images-montage'.
1 parent 9efb99b commit c8b92f7

8 files changed

+146
-9
lines changed

Diff for: ‎Makefile.in

+1
Original file line numberDiff line numberDiff line change
@@ -312,6 +312,7 @@ LTLIBOBJS = @LTLIBOBJS@
312312
MAKEINFO = @MAKEINFO@
313313
MAN = @MAN@
314314
MKDIR_P = @MKDIR_P@
315+
MONTAGE = @MONTAGE@
315316
MSGFMT = @MSGFMT@
316317
MSGFMT_015 = @MSGFMT_015@
317318
MSGMERGE = @MSGMERGE@

Diff for: ‎configure

+59
Original file line numberDiff line numberDiff line change
@@ -621,6 +621,7 @@ ac_subst_vars='am__EXEEXT_FALSE
621621
am__EXEEXT_TRUE
622622
LTLIBOBJS
623623
LIBOBJS
624+
MONTAGE
624625
DIRNAME
625626
CHMOD
626627
GIT
@@ -7624,6 +7625,64 @@ if test "$DIRNAME" = "no" ; then
76247625
exit 1;
76257626
fi
76267627
7628+
for ac_prog in montage
7629+
do
7630+
# Extract the first word of "$ac_prog", so it can be a program name with args.
7631+
set dummy $ac_prog; ac_word=$2
7632+
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
7633+
printf %s "checking for $ac_word... " >&6; }
7634+
if test ${ac_cv_path_MONTAGE+y}
7635+
then :
7636+
printf %s "(cached) " >&6
7637+
else $as_nop
7638+
case $MONTAGE in
7639+
[\\/]* | ?:[\\/]*)
7640+
ac_cv_path_MONTAGE="$MONTAGE" # Let the user override the test with a path.
7641+
;;
7642+
*)
7643+
as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
7644+
for as_dir in $PATH
7645+
do
7646+
IFS=$as_save_IFS
7647+
case $as_dir in #(((
7648+
'') as_dir=./ ;;
7649+
*/) ;;
7650+
*) as_dir=$as_dir/ ;;
7651+
esac
7652+
for ac_exec_ext in '' $ac_executable_extensions; do
7653+
if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then
7654+
ac_cv_path_MONTAGE="$as_dir$ac_word$ac_exec_ext"
7655+
printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5
7656+
break 2
7657+
fi
7658+
done
7659+
done
7660+
IFS=$as_save_IFS
7661+
7662+
;;
7663+
esac
7664+
fi
7665+
MONTAGE=$ac_cv_path_MONTAGE
7666+
if test -n "$MONTAGE"; then
7667+
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $MONTAGE" >&5
7668+
printf "%s\n" "$MONTAGE" >&6; }
7669+
else
7670+
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5
7671+
printf "%s\n" "no" >&6; }
7672+
fi
7673+
7674+
7675+
test -n "$MONTAGE" && break
7676+
done
7677+
test -n "$MONTAGE" || MONTAGE="no"
7678+
7679+
7680+
if test "$MONTAGE" = "no" ; then
7681+
{ printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: Can not find imagemagick 'montage' executable." >&5
7682+
printf "%s\n" "$as_me: WARNING: Can not find imagemagick 'montage' executable." >&2;}
7683+
exit 1;
7684+
fi
7685+
76277686
76287687
76297688

Diff for: ‎configure.ac

+7
Original file line numberDiff line numberDiff line change
@@ -123,6 +123,13 @@ if test "$DIRNAME" = "no" ; then
123123
exit 1;
124124
fi
125125

126+
AC_PATH_PROGS([MONTAGE],[montage],[no])
127+
128+
if test "$MONTAGE" = "no" ; then
129+
AC_MSG_WARN([Can not find imagemagick 'montage' executable.])
130+
exit 1;
131+
fi
132+
126133
AC_PROG_MKDIR_P
127134

128135
dnl checks for libraries

Diff for: ‎etc/init.lisp

+2
Original file line numberDiff line numberDiff line change
@@ -482,6 +482,8 @@
482482

483483
(define-key "C-[" #'go-to-previous-link *gemini-message-keymap*)
484484

485+
(define-key "I M" #'gemini-images-montage *gemini-message-keymap*)
486+
485487
;; gemini page table of contents keymap
486488

487489
(define-key "up" #'gemini-toc-scroll-up *gemini-toc-keymap*)

Diff for: ‎src/config.lisp.in.in

+6-2
Original file line numberDiff line numberDiff line change
@@ -19,7 +19,9 @@
1919

2020
(alexandria:define-constant +unzip-bin+ "@UNZIP@" :test #'string=)
2121

22-
(alexandria:define-constant +man-bin+ "@MAN@" :test #'string=)
22+
(alexandria:define-constant +man-bin+ "@MAN@" :test #'string=)
23+
24+
(alexandria:define-constant +montage-bin+ "@MONTAGE@" :test #'string=)
2325

2426
(eval-when (:compile-toplevel :load-toplevel :execute)
2527

@@ -30,7 +32,9 @@
3032

3133
(allow-features +unzip-bin+ :gempub-support)
3234

33-
(allow-features +man-bin+ :man-bin))
35+
(allow-features +man-bin+ :man-bin)
36+
37+
(allow-features +montage-bin+ :montage-bin))
3438

3539
(defmacro with-return-untranslated ((untranslated) &body body)
3640
`(handler-bind ((i18n-conditions:no-translation-table-error

Diff for: ‎src/os-utils.lisp

+11-7
Original file line numberDiff line numberDiff line change
@@ -79,7 +79,9 @@
7979
search
8080
input
8181
output
82-
(error :output))
82+
(error :output)
83+
#+sbcl (if-output-exists :supersede)
84+
#+sbcl (if-error-exists :supersede))
8385
(declare (ignorable search))
8486
#+ecl (ext:run-program program
8587
args
@@ -88,12 +90,14 @@
8890
:error error
8991
:wait wait)
9092
#+sbcl (sb-ext:run-program program
91-
args
92-
:wait wait
93-
:search search
94-
:input input
95-
:output output
96-
:error error))
93+
args
94+
:wait wait
95+
:search search
96+
:input input
97+
:output output
98+
:error error
99+
:if-output-exists if-output-exists
100+
:if-error-exists if-error-exists))
97101

98102
(defun process-exit-code (process)
99103
#+ecl (nth-value 1 (ext:external-process-status process))

Diff for: ‎src/package.lisp

+2
Original file line numberDiff line numberDiff line change
@@ -36,6 +36,7 @@
3636
:+xdg-open-bin+
3737
:+unzip-bin+
3838
:+man-bin+
39+
:+montage-bin+
3940
:_
4041
:n_))
4142

@@ -2799,6 +2800,7 @@
27992800
:search-link-window
28002801
:open-gemini-message-link-window
28012802
:open-message-link
2803+
:gemini-images-montage
28022804
:open-message-link-go-up
28032805
:open-message-link-go-down
28042806
:open-message-link-perform-opening

Diff for: ‎src/ui-goodies.lisp

+58
Original file line numberDiff line numberDiff line change
@@ -1496,6 +1496,64 @@ It an existing file path is provided the command will refuse to run."
14961496
:enqueue enqueue
14971497
:links links)))
14981498

1499+
(define-constant +image-link-extension-re+ "(?i)(\\.jpg$)|(\\.bmp$)|(\\.png$)|(\\.tiff$)|(\\.tga$)|(\\.ps$)|(\\.svg)|(\\.pcx)"
1500+
:test #'string=)
1501+
1502+
(defun gemini-images-montage ()
1503+
#+montage-bin
1504+
(when-let* ((window *message-window*)
1505+
(metadata (message-window:metadata window))
1506+
(links (gemini-viewer:gemini-metadata-links metadata))
1507+
(images-uris (remove-if-not (lambda (a) (cl-ppcre:scan +image-link-extension-re+
1508+
(gemini-parser:target a)))
1509+
links))
1510+
(images-count (length images-uris))
1511+
(name-padding (num:count-digit images-count))
1512+
(name-format (format nil (_"\"Figure: ~~~d,'0d\"") name-padding))
1513+
(names (loop for ct from 1 below (1+ images-count)
1514+
collect
1515+
(format nil name-format ct)))
1516+
(files (loop for ct from 0 below images-count
1517+
collect
1518+
(fs:temporary-file :extension ".bitmap")))
1519+
(output-file (fs:temporary-file)))
1520+
(loop for file in files
1521+
for uri in images-uris
1522+
do
1523+
(let ((data (gemini-client:slurp-gemini-url (gemini-parser:target uri))))
1524+
(with-open-file (stream file
1525+
:direction :output
1526+
:if-does-not-exist :error
1527+
:if-exists :supersede
1528+
:element-type filesystem-tree-window:+octect-type+)
1529+
(write-sequence data stream))))
1530+
(let* ((command-line (flatten (list "-title" (gemini-viewer:current-gemini-url)
1531+
"-frame" "5"
1532+
"-geometry" "320x320"
1533+
"-tile" "x4"
1534+
"-background" "Grey"
1535+
"-bordercolor" "SkyBlue"
1536+
"-mattecolor" "Lavender"
1537+
"-font" "Arial"
1538+
"-pointsize" "12"
1539+
(loop for name in names
1540+
for file in files
1541+
collect
1542+
(list "-label" name file))
1543+
"-")))
1544+
(process (os-utils:run-external-program +montage-bin+
1545+
command-line
1546+
:search t
1547+
:wait t
1548+
:input t
1549+
:output output-file
1550+
:error t)))
1551+
(if (not (os-utils:process-exit-success-p process))
1552+
(error-message (_ "Error during image composition."))
1553+
(os-utils:xdg-open output-file))))
1554+
#-montage-bin
1555+
(notify (_ "ImageMagick binaries not found on this system") :as-error t))
1556+
14991557
(defun open-message-link ()
15001558
"Open message links window
15011559

0 commit comments

Comments
 (0)