;; 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)))))
Copyright © 2014 Franz Inc., All Rights Reserved | Privacy Statement
Delicious Google Buzz Twitter Google+