;; Script to rename my scanned files.
;; Kevin Layer, Jan 2006.
;;
;; This code is in the public domain. No warranty, express or implied.
;; Use at your own risk.
;;
;; When I scan photos from slides or film negatives, I give the resulting
;; files names like "cat-on-roof.jpg". I put them into directories with
;; names like "1998-02-cat", or "1998-02-14-cat" if the date is known that
;; precisely. I want the date in the name of the files, but it is very
;; laborious to do this manually, and if I later change the name of the
;; directory, I have to rename all the files again. Tedious, to say the
;; least.
;;
;; This script prefixes files with the numeric prefix of the parent
;; directory. In addition to as base name, files may also contain a
;; sequence number, used for sorting photos so they can be ordered for
;; slideshows, etc. The full form of resulting filenames is:
;;
;; [YYYY-[MM-[DD-]]][SSS[S]-]name.jpg
;;
;; For example:
;;
;; OLD NEW
;; 1998-02-cat\cat.jpg 1998-02-cat\1998-02-cat.jpg
;; 1999-02-cat\1998-02-cat.jpg 1999-02-cat\1999-02-cat.jpg
;; 1998-02-cat\000-cat.jpg 1998-02-cat\1998-02-000-cat.jpg
;; 1998-1-1-cat\001-cat.jpg 1998-1-1-cat\1998-1-1-001-cat.jpg
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package :user)
(defvar *usage*
"~
Usage: scanprefix [-x] directory
-s seq - add a numerical sequence number SEQ to each filename
-x - do the renames, otherwise just print what would be done
directory - the directory to scan for .jpg's~%")
(eval-when (compile)
;; We use this feature to produce a fasl file that doesn't actually do
;; anything when loaded other than define the functions defined here.
;; Without this feature being defined, the script executes based on the
;; command line arguments given to Lisp.
(pushnew :compiling *features* :test #'eq))
(defun scan-root (root &key rename sequence
&aux (renames 0))
(setq root (pathname-as-directory root))
(map-over-directory
(lambda (p)
(when (file-directory-p p)
(let ((last-dir (car (last (pathname-directory p)))))
;; Calculate the prefix for this directory.
(multiple-value-bind (found whole new-prefix)
(match-re "^([-0-9]+)" last-dir)
(declare (ignore whole))
(if* (not found)
then (when (not (equalp root p))
(warn "Couldn't determine prefix for: ~a" p))
else ;; Make sure there's a hyphen at the end of the numbers
;; in the prefix.
(when (char/= #\-
(schar new-prefix (1- (length new-prefix))))
(setq new-prefix
(concatenate 'simple-string new-prefix "-")))
(incf renames
(scan-directory p new-prefix
:sequence sequence
:rename rename)))))))
root
:include-directories t)
renames)
(defvar *names* (make-hash-table :size 101 :test #'equalp)
"Used to keep track of the renamings in a directory, for duplicate and
collision detection.")
(defun scan-directory (directory new-prefix &key rename sequence
&aux (renames 0)
(warnings 0)
printed-directory
seq)
;; Scan DIRECTORY for files that need NEW-PREFIX prepended to them. If
;; RENAME is non-nil, then rename the files, otherwise just print what
;; would be done.
;;
;; We make two passes so we can detect problems. If any problems are
;; found, we don't do any renamings, since the resolution of the problems
;; might change the eventual names.
;;
(labels
((replace-prefix (path)
;; Replace the numeric prefix with a new one, based on
;; new-prefix. It's not as easy as removing the numeric prefix,
;; since we can't remove the sequence numbers.
(multiple-value-bind (found whole ignore1 ignore2 name seq)
(match-re
(load-time-value
(compile-re
;; The filename we are matching is:
;; [YYYY-[MM-[DD-]]][SSS[S]-]name.jpg
;; The goal is to extract the ``[SSS[S]-]name.jpg''
"^(\\d{4}-(\\d{1,2}-){0,2})?((\\d{3,4}-)?(.*))"))
(file-namestring path))
(declare (ignore whole ignore1 ignore2))
(when (not found)
(error "renumber couldn't parse path: ~a" path))
(values
(merge-pathnames (format nil "~a~@[~4,'0d-~]~a" new-prefix
sequence name)
path)
seq)))
(maybe-print-directory ()
(when (not printed-directory)
(format t "~&~%~a:~%" directory)
(setq printed-directory t)))
(warning (fs &rest args)
(incf warnings)
(maybe-print-directory)
(apply #'warn fs args)))
(clrhash *names*)
(dolist (p (directory (merge-pathnames "*.jpg" directory)))
(let (newp)
;; Calculate the new name.
(if* (digit-char-p (schar (file-namestring p) 0))
then (multiple-value-setq (newp seq) (replace-prefix p))
(when (and sequence seq)
(warning "Existing file already has a sequence number: ~a"
(file-namestring p)))
else (setq newp
(merge-pathnames
(format nil "~a~@[~4,'0d-~]~a" new-prefix
sequence (file-namestring p))
p)))
;; Remember the current and new names for later error checking.
(push p (gethash newp *names*))
(when (and (not (equalp newp p)) (probe-file newp))
(warning "~
~a cannot be renamed because a file of the same name (~a) already exists."
(file-namestring p)
(file-namestring newp)))))
;; Print any warnings that are pending.
(maphash
(lambda (new-name old-names)
(when (cdr old-names)
(warning "Multiple files (~a) resolve to same new name: ~a."
(list-to-delimited-string
(mapcar #'file-namestring old-names)
", ")
(file-namestring new-name))))
*names*)
(when (= warnings 0)
;; No warnings, so do the renamings.
(maphash
(lambda (newp old-names &aux (p (car old-names)))
(when (not (probe-file newp))
(maybe-print-directory)
(if* rename
then (rename-file-raw p newp)
(format t " renamed: ")
else (format t " "))
(format t "~a => ~a~%" (file-namestring p) (file-namestring newp))
(incf renames)))
*names*))
(clrhash *names*)
renames))
(defun usage (&optional format-string &rest format-arguments)
(when format-string
(apply #'format t format-string format-arguments)
(terpri))
(format t *usage*)
(exit -1 :quiet t))
#-compiling
(system:with-command-line-arguments ("s:x" sequence rename)
(directories)
(when (null directories) (usage))
(dolist (directory directories)
(when (not (probe-file directory))
(usage "Directory ~a does not exist." directory)))
;; Now scan them.
(let ((renames 0))
(dolist (directory directories)
(incf renames (scan-root directory :rename rename :sequence sequence)))
(when (> renames 0)
;; We did or could have done some work.
(format t "~&~%")
(if* rename
then (format t "Renamed ~d files.~%" renames)
else (format t "You can rename the above files by executing:~%")
(format t "scanprefix -x~{ ~a~}~%" directories)))))
