davin.50webs.com/research
Bringing to you notes for the ages

Main Menu	Research Projects	Photo Album	Curriculum Vitae	The Greatest Artists
Email Address	Computer Games	Web Design	Java Training Wheels	The Fly (A Story)
Political Activism	Scruff the Cat	My Life Story	Smoking Cessation	Other Links
Debugging Macros	String Class I	Linked List System I	Java for C Programmers	Naming Convention
String Class II	How I use m4	Strings III	Symmetrical I/O	Linked Lists II
Run-Time Type Info	Virtual Methods	An Array System	Science & Religion	Submodes
Nested Packages	Memory Leaks	Garbage Collection	Internet & Poverty	What is Knowledge?
Limits of Evolution	Emacs Additions	Function Plotter	Romantic Love	The Next Big Thing
Science Fiction	Faster Compilation	Theory of Morality	Elisp Scoping	Elisp Advice
S.O.G.M. Pattern	Safe Properties	School Bullying	Charisma Control	Life and Death
Splitting Java	Multiple Ctors	Religious Beliefs	Conversation 1	Conversation 2
J.T.W. Language	Emacs Additions II	Build Counter	Relation Plotter	Lisp++ Language
Memory Leaks II	Super Constructors	CRUD Implementation	Order a Website Form	There Is An Afterlife
More Occam's Razor	C to Java Translator	Theory of Morality II

cull-size-quota.el

    
;;; cull-size-quota.el

;; Copyright (C) 2006-2015 Davin Pearson

;; Author/Maintainer: Davin Max Pearson <http://davin.50webs.com>
;; Keywords: Cull Size Quota
;; Version: 1.0

;;; Commentary:

;; This file is not part of GNU Emacs.

;; This file deletes archive files that exceed a certain size.

;;; 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-size-quota>
;;
;; 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-size-quota)

;;; Known Bugs:

;; None!

;;; Code:

(defun d-file-size (file)
  (if (file-exists-p file)
      (nth 7 (file-attributes file))
    0))

;;;
;;; (shell-command "cp -r d:/home/bak/baz d:/")
;;;
;;; (setq count 0)
(defun cull-size-quota-inner-inner (dirname regexp total-size)

  ;;(debug)
  ;;(d-beeps "called cull-size-quota-inner-inner dirname=%s regexp=%s total-size=%s count=%s" dirname regexp total-size count)
  (incf count)

  ;;
  ;; NOTE: deletes files that exceed quota `total-size'
  ;;
  (let* ((list (nreverse (directory-files dirname t regexp)))
         (ptr  list)
         (size 0))
    (while (and ptr (<= size total-size))
      ;;(message "skipping file %s" (car ptr))
      (setq size (+ size (/ (d-file-size (car ptr)) 1024.0 1024.0)))
      (setq ptr (cdr ptr)))
    (while ptr
      (message "deleting file %s as total file size exceeds quota %s MB" (car ptr) total-size)
      (delete-file (car ptr))
      (setq ptr (cdr ptr))))

  ;;
  ;; NOTE: sets an upper bound on the number of files
  ;;
  (let* ((number-to-keep 200)
         (list (nreverse (directory-files dirname t regexp)))
         (ptr  list)
         (i    0))
    (while (and ptr (< i number-to-keep))
      (incf i)
      (setq ptr (cdr ptr)))
    (while ptr
      (message "deleting file %s as number of files exceeds 200" (car ptr))
      (delete-file (car ptr))
      (setq ptr (cdr ptr))))
  )

;;(cull-size-quota-inner "~/" (setq extension ".zip") 0)
(defun cull-size-quota-inner (dirname extension total-size)
  ;;(message "cull-size-quota-inner dirname=%s extension=%s total-size=%s" (prin1-to-string dirname) (prin1-to-string extension) (prin1-to-string total-size))
  (when (file-exists-p dirname)
    (assert (or (string-match "\\.tar\\.gz$" extension)
                (string-match "\\.tar$"      extension)
                (string-match "\\.zip$"      extension)
                (string-match "\\.pdf$"      extension)))
    (let* ((list          (bak--get-bases dirname extension))
           (ptr           list)
           (count         0)
           (len           (length list))
           (pr1-dirname   (prin1-to-string dirname))
           (pr1-extension (prin1-to-string extension)))
      (while ptr
        (incf count)
        (message "cull-size-quota-inner dirname=%s extension=%s total-size=%sMB progress=%s%%"
                 pr1-dirname
                 pr1-extension
                 total-size
                 (/ (* 100 count) len))
        (cull-size-quota-inner-inner dirname (concat "^"
                                                     (car ptr)
                                                     bak--yyyymmdd
                                                     bak--hhmmss
                                                     (regexp-quote extension)
                                                     "$")
                                     total-size)
        (setq ptr (cdr ptr)))
      )))

;; (cull-size-quota "d:/home/bak/")
;; (cull-size-quota "g:/home/bak")
(defun cull-size-quota-dir-plus-extension (dirname extension)
  (assert (or (string-match "\\.tar\\.gz$" extension)
              (string-match "\\.tar$"      extension)
              (string-match "\\.zip$"      extension)
              (string-match "\\.pdf$"      extension)
              ))
  (message "cull-size-quota %s" (prin1-to-string dirname))
  (progn
    ;;
    ;; NOTE: canonicalise dirname
    ;;
    (setq dirname (expand-file-name dirname))
    (if (not (string-match "/$" dirname))
        (setq dirname (concat dirname "/"))))

(if (file-exists-p "f:/")
      (assert (or (file-exists-p "f:/big") (file-exists-p "f:/small"))))

(if (file-exists-p "/media/www/F2TB/")
      (assert (or (file-exists-p "/media/www/F2TB/big") (file-exists-p "/media/www/F2TB/small"))))

(if (file-exists-p "g:/")
      (assert (or (file-exists-p "g:/big") (file-exists-p "g:/small"))))

(if (file-exists-p "/media/www/G16GB/")
      (assert (or (file-exists-p "/media/www/G16GB/big") (file-exists-p "/media/www/G16GB/small"))))

(if (file-exists-p "h:/")
      (assert (or (file-exists-p "h:/big") (file-exists-p "h:/small"))))

(if (file-exists-p "j:/")
      (assert (or (file-exists-p "j:/big") (file-exists-p "j:/small"))))

(if (file-exists-p "/media/www/H16GB/")
      (assert (or (file-exists-p "/media/www/H16GB/big") (file-exists-p "/media/www/H16GB/small"))))

  ;; NOTE: these sizes are in megabytes
  (let (alist total-size)
    (progn
      (setq alist '(
                    ("c:/home/bak/"                     . 10)
                    ("c:/home/bak/baz/"                 . 10)
                    ("f:/home/bak/"                     . (if (file-exists-p "f:/big") 800  10))
                    ("f:/home/bak/baz/"                 . (if (file-exists-p "f:/big") 800 100))
                    ("f:/davinpearson-com/binaries/"    . (if (file-exists-p "f:/big") 800 100))
                    ("g:/home/bak/"                     . (if (file-exists-p "g:/big") 800  10))
                    ("g:/home/bak/baz/"                 . (if (file-exists-p "g:/big") 800 100))
                    ("h:/home/bak/"                     . (if (file-exists-p "h:/big") 800  10))
                    ("h:/home/bak/baz/"                 . (if (file-exists-p "h:/big") 800 100))
                    ("j:/home/bak/"                     . (if (file-exists-p "j:/big") 800  10))
                    ("j:/home/bak/baz/"                 . (if (file-exists-p "j:/big") 800 100))
                    ("/home/www/bak/"                   . 200)
                    ("/home/www/bak/baz/"               . 400)
                    ("/home/www/C/home/bak/"            . 10)
                    ("/home/www/C/home/bak/baz/"        . 10)
                    ("/home/www/F/home/bak/"            . (if (file-exists-p "/home/www/F/big") 800  10))
                    ("/home/www/F/home/bak/baz/"        . (if (file-exists-p "/home/www/F/big") 800 100))
                    ("/home/www/G/home/bak/"            . (if (file-exists-p "/home/www/G/big") 800  10))
                    ("/home/www/G/home/bak/baz/"        . (if (file-exists-p "/home/www/G/big") 800 100))
                    ("/home/www/H/home/bak/"            . (if (file-exists-p "/home/www/H/big") 800  10))
                    ("/home/www/H/home/bak/baz/"        . (if (file-exists-p "/home/www/H/big") 800 100))
                    ("/media/www/C1TB/home/bak/"       . 100)
                    ("/media/www/C1TB/home/bak/baz/"   . 100)
                    ("/media/www/F2TB/home/bak/"        . (if (file-exists-p "/media/www/F2TB/big")  800  10))
                    ("/media/www/F2TB/home/bak/baz/"    . (if (file-exists-p "/media/www/F2TB/big")  800 100))
                    ("/media/www/G16GB/home/bak/"       . (if (file-exists-p "/media/www/G16GB/big") 800  10))
                    ("/media/www/G16GB/home/bak/baz/"   . (if (file-exists-p "/media/www/G16GB/big") 800 100))
                    ("/media/www/H16GB/home/bak/"       . (if (file-exists-p "/media/www/H16GB/big") 800  10))
                    ("/media/www/H16GB/home/bak/baz/"   . (if (file-exists-p "/media/www/H16GB/big") 800 100))
                    ("/media/www/I16GB/home/bak/"       . (if (file-exists-p "/media/www/I16GB/big") 800  10))
                    ("/media/www/I16GB/home/bak/baz/"   . (if (file-exists-p "/media/www/I16GB/big") 800 100))
                    ("/media/www/J600GB/home/bak/"      . (if (file-exists-p "/media/www/J600GB/big") 800  10))
                    ("/media/www/J600GB/home/bak/baz/"  . (if (file-exists-p "/media/www/J600GB/big") 800 100))
                    ("/media/www/K2TB/home/bak/"        . (if (file-exists-p "/media/www/K2TB/big") 800  10))
                    ("/media/www/K2TB/home/bak/baz/"    . (if (file-exists-p "/media/www/K2TB/big") 800 100))
                    ("/media/www/BLU16GB/home/bak/"     . (if (file-exists-p "/media/www/BLU16GB/big") 800  10))
                    ("/media/www/BLU16GB/home/bak/baz/" . (if (file-exists-p "/media/www/BLU16GB/big") 800 100))
                    ("/media/www/BLU16GB/davinpearson-com/binaries/" . (if (file-exists-p "/media/www/BLU16GB/big") 800  10))
                    ("/media/www/GRN16GB/home/bak/"                  . (if (file-exists-p "/media/www/GRN16GB/big") 800 100))
                    ("/media/www/GRN16GB/home/bak/baz/"              . (if (file-exists-p "/media/www/GRN16GB/big") 800 100))
                    ("/media/www/GRN16GB/davinpearson-com/binaries/" . (if (file-exists-p "/media/www/GRN16GB/big") 800  10))
                    ("/media/www/WD2TB/home/bak/"                  . (if (file-exists-p "/media/www/WD2TB/big") 800 100))
                    ("/media/www/WD2TB/home/bak/baz/"              . (if (file-exists-p "/media/www/WD2TB/big") 800 100))
                    ("/media/www/WD2TB/davinpearson-com/binaries/" . (if (file-exists-p "/media/www/WD2TB/big") 800  10))
                    ("/media/www/WD2TB2/home/bak/"                  . (if (file-exists-p "/media/www/WD2TB2/big") 800 100))
                    ("/media/www/WD2TB2/home/bak/baz/"              . (if (file-exists-p "/media/www/WD2TB2/big") 800 100))
                    ("/media/www/WD2TB2/davinpearson-com/binaries/" . (if (file-exists-p "/media/www/WD2TB2/big") 800  10))
                    ("c:/home/hairy-lemon/output/davinpearson-com/binaries/" . 200)))
      (setq total-size (eval (cdr (assoc dirname alist))))
      (assert (boundp 'total-size))
      (assert total-size)
      (cull-size-quota-inner dirname extension total-size)
      )
    )
  )

;;; (setq dirname (expand-file-name "~/bak/"))
;;; (setq dirname "/media/www/G16GB/home/bak/")
(defun cull-size-quota (dirname)
  (interactive "DEnter dir: ")
  (let ((d-message-on t))
    (cull-size-quota-dir-plus-extension dirname ".tar.gz")
    (cull-size-quota-dir-plus-extension dirname ".tar")
    (cull-size-quota-dir-plus-extension dirname ".zip")
    (cull-size-quota-dir-plus-extension dirname ".pdf")
    )
  )

(provide 'cull-size-quota)

Back