;;; cull-same-dates.el
;; Copyright (C) 2006-2015 Davin Pearson
;; Author/Maintainer: Davin Max Pearson <http://davin.50webs.com>
;; Keywords: Cull Same Dates
;; Version: 1.0
;;; Commentary:
;; This file is not part of GNU Emacs.
;; This file deletes all but one file that was modified at every date,
;; so that you have a maximum of one archive file per day.
;;; Limitation of Warranty
;; This program 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.
;;
;; This program 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 GNU Emacs, see the file COPYING. If not, see:
;;
;; <http://www.gnu.org/licenses/gpl-3.0.txt>.
;;; Install Instructions:
;; See the following URL for the latest info and a tarball:
;;
;; <http://davin.50webs.com/research/2006/mopa2e.html#cull-same-dates>
;;
;; Then untar the tarball to a folder pointed to by the Emacs variable
;; load-path and add the following line to your ~/.emacs file.
;;
;; (require 'cull-same-dates)
;;; Known Bugs:
;; None!
;;; Code:
;;
;; NOTE: small bug in cull-same-dates-inner keeps YYMMDD files
;;
;; (cull-same-dates-inner (setq dirname "d:/home/bak/") (setq extension "\\.tar\\.gz$"))
;; (cull-same-dates-inner (setq dirname "d:/home/not-exist/") (setq extension "\\.tar\\.gz$"))
;;
;; (cull-same-dates-inner "~/bak/baz" "\\.tar$")
;;
;; (setq dirname "~/bak/smeg/")
;; (setq dirname "~/bak/baz/")
;; (setq extension "\\.tar$")
;; (cull-same-dates-inner dirname extension)
;;
;; (bak--copy-to-other-drive--internal "~/bak" "d:/bak")
;; (cull-same-dates-inner (setq dirname "d:/bak") (setq extension "\\.tar\\.gz$"))
;;
;; (setq extension ".tar.gz")
(defun cull-same-dates-dir-plus-extension (dirname extension)
(message "cull-same-dates-inner dirname=%s extension=%s" (prin1-to-string dirname) (prin1-to-string extension))
(assert (string-match "\\.\\(tar\\|tar.gz\\|zip\\)$" extension))
(when (and (file-exists-p dirname) (file-directory-p dirname))
(let* ((list (directory-files dirname nil (concat (regexp-quote extension) "$")))
(ptr list))
;;(count 0)
;;(len (length list)))
(while ptr
;;(message "cull-same-dates-inner progress=%s%%" (/ (* count 100) len))
(if (string-match (concat "\\(.*" bak--yyyymmdd "\\)" bak--hhmmss (regexp-quote extension) "$") (car ptr))
(setcar ptr (substring (car ptr) (match-beginning 1) (match-end 1)))
(setcar ptr nil))
;;(incf count)
(setq ptr (cdr ptr)))
(setq list (delete-duplicates list :test 'string=))
(setq list (delq nil list))
(setq ptr list)
(let* ((count 0)
(len (length list))
(pr1-dirname (prin1-to-string dirname))
(pr1-extension (prin1-to-string extension)))
(while ptr
(incf count)
(message "cull-same-dates-dirname-plus-extension dirname=%s extension=%s progress=%s%%"
pr1-dirname
pr1-extension
(/ (* count 100) len))
(let* ((list2 (nreverse (directory-files dirname nil (concat "^"
(regexp-quote (car ptr))
bak--hhmmss
(regexp-quote extension)
"$"))))
(ptr2 list2))
;;(count 0)
;;(len (length list2)))
(setq ptr2 (cdr ptr2))
(while ptr2
(message "Deleting file %s" (concat dirname "/" (car ptr2)))
(delete-file (concat dirname "/" (car ptr2)))
(setq ptr2 (cdr ptr2))))
(setq ptr (cdr ptr)))))))
(defun cull-same-dates (dirname)
(interactive "DEnter dir: ")
(let ((d-message-on t))
(message "cull-same-dates %s" (prin1-to-string dirname))
(cull-same-dates-dir-plus-extension dirname ".tar")
(cull-same-dates-dir-plus-extension dirname ".tar.gz")
(cull-same-dates-dir-plus-extension dirname ".zip")
)
)
(defun cull (dirname)
(interactive "DEnter dir: ")
(cull-same-dates dirname)
(cull-size-quota dirname)
)
(provide 'cull-same-dates)
| Back |