From cd48a6421526e00d79ea9db8c3fa63b7a838c00d Mon Sep 17 00:00:00 2001 From: bootchk Date: Mon, 27 Mar 2023 11:27:43 -0400 Subject: [PATCH 1/2] ScriptFu: add dir-list to ftx extension Partial fix for 9704. Further requires changes to contact-sheet.scm --- plug-ins/script-fu/libscriptfu/ftx/ftx.c | 114 +++++++++++++++++++++++ 1 file changed, 114 insertions(+) diff --git a/plug-ins/script-fu/libscriptfu/ftx/ftx.c b/plug-ins/script-fu/libscriptfu/ftx/ftx.c index f9de1bfdccf..08ca456a964 100644 --- a/plug-ins/script-fu/libscriptfu/ftx/ftx.c +++ b/plug-ins/script-fu/libscriptfu/ftx/ftx.c @@ -49,6 +49,7 @@ pointer foreign_diropenstream(scheme *sc, pointer args); pointer foreign_dirreadentry(scheme *sc, pointer args); pointer foreign_dirrewind(scheme *sc, pointer args); pointer foreign_dirclosestream(scheme *sc, pointer args); +pointer foreign_dirlist(scheme *sc, pointer args); pointer foreign_mkdir(scheme *sc, pointer args); pointer foreign_getenv(scheme *sc, pointer args); @@ -245,6 +246,116 @@ pointer foreign_dirclosestream(scheme *sc, pointer args) return sc->T; } + +/* Open and return a GDir for given name. + * Returns NULL on error. + * + * Script errors and filesystem errors are logged using glogging, + * but the script does not stop (does not return a foreign_error) + * i.e. for Gimp users this fails quietly. + * Error messages are not i18n translated. + */ +static GDir * +open_dir (scheme *sc, pointer args) +{ + pointer first_arg; + char *dirpath; + GDir *result = NULL; + + if (args == sc->NIL) + { + g_warning ("Missing directory name arg."); + return result; + } + + first_arg = sc->vptr->pair_car(args); + if (!sc->vptr->is_string(first_arg)) + { + g_warning ("Expected string arg"); + return result; + } + + dirpath = sc->vptr->string_value(first_arg); + dirpath = g_filename_from_utf8 (dirpath, -1, NULL, NULL, NULL); + + result = g_dir_open (dirpath, 0, NULL); + if (result == NULL) + { + g_warning ("Dir name invalid or permissions or other filesystem error"); + } + return result; +} + + +/* Return scheme string for next entry in GDir. + * GDirs are stateful iterators. + * Return NIL on the terminating condition of the iterator. + */ +static pointer +string_from_next_entry_in_dir (scheme *sc, GDir *dir) +{ + gchar *entry; + + if (dir == NULL) + return sc->NIL; + + entry = (gchar *)g_dir_read_name(dir); + if (entry == NULL) + return sc->NIL; + + entry = g_filename_to_utf8 (entry, -1, NULL, NULL, NULL); + return (sc->vptr->mk_string (sc, entry)); +} + + +/* Return list similar to "ls" unix command for given directory name. + * args must be a single string, a path to a directory. + * + * Returns NIL on errors, and when dir is empty. + * Never returns an empty list. + * (NIL and empty list are not the same, and are both truthy) + * + * Returned list elements are names, not paths. + * May be file names or dir names or link names. + * Encoded UTF-8, and may have whitespace on some platforms. + * Unlike the ls command, "*" and "**" are not returned. + * + * Not a recursive search through subdirectories, just the top directory. + * + * Similar to directory-list in Racket. + * + * Depends on glib GDir for portability. + */ +pointer foreign_dirlist (scheme *sc, pointer args) +{ + GDir *dir; + pointer result = sc->NIL; + + dir = open_dir (sc, args); + if (dir == NULL) + { + /* Error already announced. */ + return result; + } + + /* Iterate on dir, appending to list. */ + { + pointer entry; + + while ( (entry = string_from_next_entry_in_dir (sc, dir)) != sc->NIL) + { + result = sc->vptr->cons (sc, + entry, + result); + } + } + + g_dir_close (dir); + + /* ensure result is NIL, or non-empty list. */ + return result; +} + pointer foreign_mkdir(scheme *sc, pointer args) { pointer first_arg; @@ -402,6 +513,9 @@ void init_ftx (scheme *sc) sc->vptr->scheme_define(sc, sc->global_env, sc->vptr->mk_symbol(sc,"dir-close-stream"), sc->vptr->mk_foreign_func(sc, foreign_dirclosestream)); + sc->vptr->scheme_define(sc, sc->global_env, + sc->vptr->mk_symbol(sc,"dir-list"), + sc->vptr->mk_foreign_func(sc, foreign_dirlist)); sc->vptr->scheme_define(sc, sc->global_env, sc->vptr->mk_symbol(sc,"dir-make"), sc->vptr->mk_foreign_func(sc, foreign_mkdir)); -- GitLab From 003a6429d368caf09d595b8a44016cee4112b519 Mon Sep 17 00:00:00 2001 From: bootchk Date: Wed, 29 Mar 2023 09:42:01 -0400 Subject: [PATCH 2/2] script use dir-list instead of dir-open-stream And other changes that may be controversial and soon reverted. --- plug-ins/script-fu/scripts/contactsheet.scm | 203 +++++++++++--------- 1 file changed, 115 insertions(+), 88 deletions(-) diff --git a/plug-ins/script-fu/scripts/contactsheet.scm b/plug-ins/script-fu/scripts/contactsheet.scm index 0d5961710a4..2a79ff6605b 100644 --- a/plug-ins/script-fu/scripts/contactsheet.scm +++ b/plug-ins/script-fu/scripts/contactsheet.scm @@ -148,7 +148,7 @@ ) (let* ( - (dir-stream (dir-open-stream dir)) + (in-files (dir-list dir)) (sheet-num 1) (img-count 0) (pos-x 0) @@ -175,6 +175,13 @@ (tmp-layer 0) ) + ; quit early if nothing to do + (if (null? in-files) + ((gimp-message (string-append _"Unable to open directory or empty directory" dir)) + (quit)) + () + ) + (gimp-context-push) (gimp-context-set-defaults) (gimp-context-set-foreground text-color) @@ -206,114 +213,134 @@ (init-sheet-img sheet-img sheet-num sheet-width border-y off-y) - (if (not dir-stream) - (gimp-message (string-append _"Unable to open directory " dir)) - (begin - (do - ( (file (dir-read-entry dir-stream) (dir-read-entry dir-stream)) ) - ( (eof-object? file) ) - - (set! file-path (string-append dir DIR-SEPARATOR file)) - ; file-path is a full path, file is filename - (if (and (not (re-match "index.*" file)) - (= (file-type file-path) FILE-TYPE-FILE) - ) - (catch () - (set! new-img - (car (gimp-file-load RUN-NONINTERACTIVE file-path))) - - (make-thumbnail-size new-img thumb-w thumb-h) + ; require in-files not empty because in init clause we car and cdr it + ; and TS not allow car an empty list + (begin + ; Iterate over non-empty list of in images + ; Iterative form, not recursive form + ; because this is a hack around a body already structured for iteration + (do + ; let bindings + ( (rest (cdr in-files) (cond ((null? rest) rest) + (else (cdr rest)))) + (file (car in-files) (cond ((null? rest) rest) + (else (car rest))))) + ; terminating condition + ( (null? file) ) + ; body + + (set! file-path (string-append dir DIR-SEPARATOR file)) + ; file-path is a full path, file is filename + + ; file-path can be to subdirectories, links, and files that are not image formats. + ; Formerly checked file-type, now just catching all errors opening non-image files + ; i.e. was (if (= (file-type file-path) FILE-TYPE-FILE))) + + ; Formerly we skipped the "index.jpg" we are creating + ; Now the contact sheet will recursively include "index.jpg" + ; files created in earlier sessions of contact-sheet + ; + ; !!! Note we generate file names "index.jpg" + ; and gimp-file-save will NOT ask user before overwriting. + + ; ignore errors trying to load paths that are not images. + (catch () + (set! new-img + (car (gimp-file-load RUN-NONINTERACTIVE file-path))) + + (make-thumbnail-size new-img thumb-w thumb-h) + + (if (> (car (gimp-image-get-layers new-img)) 1) + (gimp-image-flatten new-img) + ) + (set! tmp-layer + (car (gimp-layer-new-from-drawable + (aref (cadr (gimp-image-get-selected-drawables new-img)) 0) + sheet-img))) - (if (> (car (gimp-image-get-layers new-img)) 1) - (gimp-image-flatten new-img) - ) - (set! tmp-layer - (car (gimp-layer-new-from-drawable - (aref (cadr (gimp-image-get-selected-drawables new-img)) 0) - sheet-img))) + (gimp-image-insert-layer sheet-img tmp-layer 0 0) - (gimp-image-insert-layer sheet-img tmp-layer 0 0) + ;Move thumbnail in to position and center it in area available. + (gimp-layer-set-offsets tmp-layer + (+ border-x off-x (* pos-x (+ thumb-w border-x)) + (/ (- thumb-w (car (gimp-image-get-width new-img))) 2) + ) + (+ border-y off-y (* pos-y (+ thumb-h border-y)) + (/ (- thumb-h (car (gimp-image-get-height new-img))) 2) + ) + ) - ;Move thumbnail in to position and center it in area available. - (gimp-layer-set-offsets tmp-layer - (+ border-x off-x (* pos-x (+ thumb-w border-x)) - (/ (- thumb-w (car (gimp-image-get-width new-img))) 2) - ) - (+ border-y off-y (* pos-y (+ thumb-h border-y)) - (/ (- thumb-h (car (gimp-image-get-height new-img))) 2) - ) - ) + (gimp-image-delete new-img) - (gimp-image-delete new-img) + (set! tmp-layer (car (gimp-text-fontname sheet-img -1 0 0 file + 0 TRUE 12 PIXELS legend-font))) + (gimp-layer-set-offsets tmp-layer + (+ border-x off-x (* pos-x (+ thumb-w border-x)) + (/ (- thumb-w (car (gimp-drawable-get-width tmp-layer))) 2)) + (+ border-y off-y (* pos-y (+ thumb-h border-y)) thumb-h 6) + ) - (set! tmp-layer (car (gimp-text-fontname sheet-img -1 0 0 file - 0 TRUE 12 PIXELS legend-font))) - (gimp-layer-set-offsets tmp-layer - (+ border-x off-x (* pos-x (+ thumb-w border-x)) - (/ (- thumb-w (car (gimp-drawable-get-width tmp-layer))) 2)) - (+ border-y off-y (* pos-y (+ thumb-h border-y)) thumb-h 6) - ) + (set! img-count (+ img-count 1)) - (set! img-count (+ img-count 1)) + (set! pos-x (+ pos-x 1)) + (if (> pos-x max-x) + (begin + (set! pos-x 0) + (set! pos-y (+ pos-y 1)) - (set! pos-x (+ pos-x 1)) - (if (> pos-x max-x) + ; paginate on y i.e. rows + (if (> pos-y max-y) (begin - (set! pos-x 0) - (set! pos-y (+ pos-y 1)) - (if (> pos-y max-y) - (begin - (set! pos-y 0) - (set! sheet-layer (car (gimp-image-flatten sheet-img))) - (gimp-file-save - RUN-NONINTERACTIVE - sheet-img - 1 (vector sheet-layer) - (string-append dir DIR-SEPARATOR - "index" (number->string sheet-num) ".jpg") - ) - - (set! sheet-num (+ sheet-num 1)) - (init-sheet-img sheet-img sheet-num sheet-width - border-y off-y) - (set! img-count 0) - ) + (set! pos-y 0) + (set! sheet-layer (car (gimp-image-flatten sheet-img))) + (gimp-file-save + RUN-NONINTERACTIVE + sheet-img + 1 (vector sheet-layer) + (string-append dir DIR-SEPARATOR + "index" (number->string sheet-num) ".jpg") ) + + (set! sheet-num (+ sheet-num 1)) + (init-sheet-img sheet-img sheet-num sheet-width + border-y off-y) + (set! img-count 0) ) ) ) ) - ) - - (dir-close-stream dir-stream) - - (if (> img-count 0) - (begin - (set! sheet-layer (car (gimp-image-flatten sheet-img))) - (gimp-file-save - RUN-NONINTERACTIVE - sheet-img - 1 (vector sheet-layer) - (string-append dir DIR-SEPARATOR - "index" (number->string sheet-num) ".jpg") - ) + ) ; end catch exception opening non-image + ) ; end do for each file + + ; write partial last page + (if (> img-count 0) + (begin + (set! sheet-layer (car (gimp-image-flatten sheet-img))) + (gimp-file-save + RUN-NONINTERACTIVE + sheet-img + 1 (vector sheet-layer) + (string-append dir DIR-SEPARATOR + "index" (number->string sheet-num) ".jpg") ) ) ) - - (gimp-image-undo-enable sheet-img) - (gimp-image-delete sheet-img) - - (display (string-append _"Created " (number->string sheet-num) - _" contact sheets from a total of " - (number->string img-count) _" images")) - (newline) ) - (gimp-context-pop) + (gimp-image-undo-enable sheet-img) + (gimp-image-delete sheet-img) + + ; Formerly: (display ...) (newline) which has no visible effect + ; and leaves cruft on the gimp status bar. + (gimp-message (string-append _"Created " (number->string sheet-num) + _" contact sheets from a total of " + (number->string img-count) _" images")) ) + + (gimp-context-pop) ) + (script-fu-register "script-fu-contactsheet" _"_Contact Sheet..." _"Create a series of images containing thumbnail sized versions of all of the images in a specified directory." -- GitLab