cgit.sxemacs.org Git - packages/blob - package-clean.el

   1 ;;; package-clean.el --- Remove bogus .elc files in package tree
   2
   3 ;; Copyright (C) 1997 by Free Software Foundation, Inc.
   4 ;; Copyright (C) 2000, 2001 Ben Wing.
   5
   6 ;; Author: Ben Wing <ben@xemacs.org>, based on cleantree.el by
   7 ;;         Steven L Baur <steve@xemacs.org>
   8
   9 ;; This file is part of XEmacs.
  10
  11 ;; XEmacs is free software; you can redistribute it and/or modify it
  12 ;; under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; XEmacs is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  23 ;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  24 ;; 02111-1301, USA.
  25
  26 ;;; Synched up with: Not in FSF
  27
  28 ;;; Commentary:
  29
  30 ;; This is meant to be called -batch at the beginning of package-tree
  31 ;; compilation (i.e. `make' from the top of the package tree) and
  32 ;; removes out-of-date and orphaned .elc files.
  33
  34 ;;; Code:
  35
  36 (setq stack-trace-on-error t)
  37
  38 (when (interactive-p)
  39   (error "package-clean may only be used with -batch"))
  40
  41 (defvar package-clean-ignored-dirs
  42   `("." ".." "CVS" "SCCS" "RCS" ,@(unless (featurep 'mule) '("mule"))))
  43
  44 (defvar package-clean-ignored-files
  45   ;; note: entries here are regexps
  46   '())
  47
  48 (defun package-clean-do-it (dir)
  49   ;; Stage 1.
  50   ;; Remove out-of-date elcs
  51   (let ((files (directory-files dir t "\\.el$"))
  52         file file-c)
  53     (while (setq file (car files))
  54       (setq files (cdr files))
  55       (setq file-c (concat file "c"))
  56       (when (and (file-exists-p file-c)
  57                  (file-newer-than-file-p file file-c))
  58         (message "Removing out-of-date %s" file-c)
  59         (delete-file file-c))))
  60   ;; Remove elcs without corresponding el
  61   (let ((files (directory-files dir t "\\.elc$"))
  62         file file-c)
  63     (while (setq file-c (car files))
  64       (setq files (cdr files))
  65       (setq file (replace-in-string file-c "c$" ""))
  66       (when (and (file-exists-p file-c)
  67                  (not (file-exists-p file)))
  68         (message "Removing %s; no corresponding .el" file-c)
  69         (delete-file file-c))))
  70
  71   ;; We descend recursively
  72   (let ((dirs (directory-files dir t nil t))
  73         dir)
  74     (while (setq dir (pop dirs))
  75       (when (and (not (member (file-name-nondirectory dir)
  76                               package-clean-ignored-dirs))
  77                  (file-directory-p dir))
  78         (package-clean-do-it dir)))))
  79
  80 (message "Removing old or spurious .elcs in directory tree `%s'..."
  81          (expand-file-name "."))
  82 (package-clean-do-it ".")
  83 (message "Removing old or spurious .elcs in directory tree `%s'...done"
  84          (expand-file-name "."))
  85