The Book of Conworlds Scan Processing System
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 

95 lines
3.8 KiB

;;;; call-programs.lisp
#|| This file is part of BOCPROC.
BOCPROC is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
BOCPROC is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with BOCPROC. If not, see <https://www.gnu.org/licenses/>.
||#
(in-package #:info.isoraqathedh.bocproc)
(named-readtables:in-readtable bocproc)
;;; exiftool
(defun format-exiftool% (stream key-name value)
(typecase value
(null nil) ; do nothing on null value
(list
(dolist (i value)
(format-exiftool% stream key-name i)))
(local-time:timestamp
(format stream "-~a=~a~%"
key-name
(local-time:format-timestring
nil value
:format '(:year ":" (:month 2) ":" (:day 2) " "
(:hour 2) ":" (:min 2) ":" (:sec 2) :gmt-offset))))
(string
(format stream "-~a=~a~%" key-name
;; Only the first line.
(subseq value 0 (position #\Newline value))))
(t (error "Cannot print ~s to exiftool" value))))
(defun format-exiftool-tags (stream key-name tags)
(dolist (i tags)
(format stream "-~a=~a~%"
key-name
(or (defaulting-getf (tag-plist (find-tag i))
(column-defaulting (find-column :exiftool)))
"(Unnamed tag)"))))
(defun format-exiftool (stream page)
(let ((page-plist->exiftool '((:scan-date . "CreateDate")
(:title . "Title")
(:subject . "Subject")
(:comment . "Comment"))))
(loop with plist = (copy-list (page-plist page))
while plist do
(multiple-value-bind (key value tail)
(get-properties plist (mapcar #'car page-plist->exiftool))
(when key
(let ((key-name (cdr (assoc key page-plist->exiftool))))
(case key
(:subject (format-exiftool-tags stream key-name value))
(t (format-exiftool% stream key-name value)))))
(setf plist (cddr tail))))
(format stream "-overwrite_original_in_place~%~
~a~%~
-execute~%"
(uiop:native-namestring
(merge-pathnames (or (getf (page-plist page) :location)
(error "No filename found for page ~s" page))
(root *loaded-file*))))))
(defun run-exiftool-on-pages (pages)
(uiop:with-temporary-file (:stream stream :pathname file
:direction :output :external-format :utf-8)
(dolist (page pages)
(format-exiftool stream page))
:close-stream
(uiop:run-program (list "exiftool" "[email protected]" (uiop:native-namestring file))
:output :lines))) ; Clean up this output later
;;; to do: jpegtran
;;; Display with feh
(defun display-pages (entry-list)
(uiop:launch-program (list "feh" "-d.f" "-")
:input (make-string-input-stream
(with-output-to-string (s)
(dolist (i entry-list)
(fresh-line s)
(princ (uiop:native-namestring
(merge-pathnames
(getf (page-plist i) :location)
(root *loaded-file*)))
s))))))