misc:software:Common Lisp:sbcl:ファイルの更新時刻を改変する

ファイルの更新時刻を改変する

指定したディレクトリ以下のファイルのうち、特定の拡張子のファイルの更新時刻を現在の時刻に書き換える。 ただし、もとの更新時刻が4時から21時の間のときにのみ更新時刻を書き換える。

使用例

./update_mtime.exe ../ txt htm html

(ql:quickload 'cl-fad)

(defun get-time-hour (time)
  (nth 2 (multiple-value-list 
          (decode-universal-time time))))

(defun get-current-hour ()
  (get-time-hour (get-universal-time)))

(ql:quickload :cffi)

(cffi:defcstruct system-time
  (year :ushort)
  (month :ushort)
  (day-of-week :ushort)
  (day :ushort)
  (hour :ushort)
  (minute :ushort)
  (second :ushort)
  (milli-seconds :ushort))

(cffi:defcstruct file-time
  (low-date-time :ulong)
  (high-date-time :ulong))

(cffi:defcfun ("GetSystemTime" get-system-time) :void
  (st :pointer))

(cffi:defcfun ("SystemTimeToFileTime" system-time-to-file-time) :boolean
  (st :pointer)
  (ft :pointer))

(cffi:defcfun ("SetFileTime" set-file-time) :boolean
  (handle :pointer)
  (creation :pointer)
  (last-access :pointer)
  (last-write :pointer))

(cffi:defcfun ("CreateFileA" create-file) :pointer
  (file-name :string)
  (desired-access :ulong)
  (share-mode :ulong)
  (security-attributes :pointer)
  (creation-disposition :ulong)
  (flags-and-attributes :ulong)
  (template-file :pointer))
  
(cffi:defcfun ("CloseHandle" close-handle) :boolean
  (object :pointer))

(defconstant +generic-write+ #x40000000)
(defconstant +open-existing+ 3)
(defconstant +file-attribute-normal+ #x80)
(defconstant +invalid-handle-value+ ; (HANDLE)-1
  #-x86-64 #.(1- (expt 2 32))
  #+x86-64 #.(1- (expt 2 64)))

(defun update-file-mtime (file)
  (cffi:with-foreign-objects ((st 'system-time) (ft 'file-time))
    (get-system-time st)
    (system-time-to-file-time st ft)
    (let* ((null (cffi:null-pointer))
           (file (create-file file +generic-write+ 0 null +open-existing+
                              +file-attribute-normal+ null)))
      (unless (= (cffi:pointer-address file) +invalid-handle-value+)
        (unwind-protect (set-file-time file null null ft)
          (close-handle file))))))

(defun update-files-within-dir ()
  (let* ((now (get-universal-time))
         (never-proc-p t)
         (arg (cdr sb-ext:*posix-argv*))
         (dir (car arg))
         (update-file-type (append (cdr arg))))
    (unless (cl-fad:directory-exists-p dir)
      (format t "Error: the directory is not found.~%")
      (quit))
    (cl-fad:walk-directory
     dir
     (lambda (file)
       (when (member (pathname-type file) update-file-type :test #'equal)
         (let* ((file-mtime (file-write-date file))
                (file-mtime-hour (get-time-hour file-mtime)))
           (when (<= 4 file-mtime-hour 21)
             (setf never-proc-p nil)
             (update-file-mtime (namestring file)))))))
    (if never-proc-p
        (format t "mtime of no files was updated.")
        (format t "updated ~{*.~A~^, ~} in ~A." update-file-type dir))))

(sb-ext:save-lisp-and-die "update_mtime.exe"  ; .exe をつける（Windows 用）
                          :toplevel #'update-files-within-dir
                          :compression t
                          :executable t)