cgit.sxemacs.org Git - sxemacs/blob - lisp/package-admin.el

   1 ;;; package-admin.el --- Installation and Maintenance of SXEmacs packages
   2
   3 ;; Copyright (C) 1997 by Free Software Foundation, Inc.
   4 ;; Copyright (C) 2003 - 2015 Steve Youngs.
   5
   6 ;; Author: SL Baur <steve@xemacs.org>
   7 ;; Keywords: internal
   8
   9 ;; This file is part of SXEmacs.
  10
  11 ;; SXEmacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; SXEmacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Synched up with: Not in FSF
  25
  26 ;;; Commentary:
  27
  28 ;; First pass at lisp front end to package maintenance.
  29
  30 ;;; Code:
  31
  32 (require 'config)
  33
  34 (defvar package-admin-sxemacs (concat invocation-directory invocation-name)
  35   "Location of SXEmacs binary to use.")
  36
  37 (defvar package-admin-temp-buffer "*Package Output*"
  38   "Temporary buffer where output of backend commands is saved.")
  39
  40 (defvar package-admin-install-function 'package-admin-default-install-function
  41   "The function to call to install a package.
  42 Three args are passed: FILENAME PKG-DIR BUFFER
  43 Install package FILENAME into directory PKG-DIR, with any messages output
  44 to buffer BUFFER.")
  45
  46 (defvar package-admin-error-messages '(
  47                                        "No space left on device"
  48                                        "No such file or directory"
  49                                        "Filename too long"
  50                                        "Read-only file system"
  51                                        "File too large"
  52                                        "Too many open files"
  53                                        "Not enough space"
  54                                        "Permission denied"
  55                                        "Input/output error"
  56                                        "Out of memory"
  57                                        "Unable to create directory"
  58                                        "Directory checksum error"
  59                                        "Cannot exclusively open file"
  60                                        "corrupted file"
  61                                        "incomplete .* tree"
  62                                        "Bad table"
  63                                        "corrupt input"
  64                                        "invalid compressed data"
  65                                        "too many leaves in Huffman tree"
  66                                        "not a valid zip file"
  67                                        "first entry not deflated or stored"
  68                                        "encrypted file --"
  69                                        "unexpected end of file"
  70                                        )
  71   "Regular expressions of possible error messages.
  72 After each package extraction, the `package-admin-temp-buffer' buffer is
  73 scanned for these messages.  An error code is returned if one of these are
  74 found.
  75
  76 This is awful, but it exists because error return codes aren't reliable
  77 under MS Windows.")
  78
  79 (defvar package-admin-tar-filename-regexps
  80   '(
  81     ;; GNU tar:
  82     ;; drwxrwxr-x john/doe 123 1997-02-18 15:48 pathname
  83     "\\S-+\\s-+[-a-z0-9_/]+\\s-+[0-9]+\\s-+[-0-9]+\\s-+[0-9:]+\\s-+\\(\\S-.*\\)"
  84     ;; HP-UX & SunOS tar:
  85     ;; rwxrwxr-x 501/501    123 Feb 18 15:46 1997 pathname
  86     ;; Solaris tar (phooey!):
  87     ;; rwxrwxr-x501/501    123 Feb 18 15:46 1997 pathname
  88     ;; AIX tar:
  89     ;; -rw-r--r-- 147 1019   32919 Mar 26 12:00:09 1992 pathname
  90     "\\S-+\\s-*[-a-z0-9_]+[/ ][-a-z0-9_]+\\s-+[0-9]+\\s-+[a-z][a-z][a-z]\\s-+[0-9]+\\s-+[0-9:]+\\s-+[0-9]+\\s-+\\(\\S-.*\\)"
  91
  92     ;; djtar:
  93     ;; drwx Aug 31 02:01:41 1998       123 pathname
  94     "\\S-+\\s-+[a-z][a-z][a-z]\\s-+[0-9]+\\s-+[0-9:]+\\s-+[0-9]+\\s-+[0-9]+\\s-+\\(\\S-.*\\)"
  95
  96     )
  97   "List of regexps to use to search for tar filenames.
  98 Note that \"\\(\" and \"\\)\" must be used to delimit the pathname (as
  99 match #1).  Don't put \"^\" to match the beginning of the line; this
 100 is already implicit, as `looking-at' is used.  Filenames can,
 101 unfortunately, contain spaces, so be careful in constructing any
 102 regexps.")
 103
 104 (defvar package-install-hook nil
 105   "*List of hook functions to be called when a new package is successfully
 106 installed. The hook function is passed two arguments: the package name, and
 107 the install directory.")
 108
 109 (defvar package-delete-hook nil
 110   "*List of hook functions to be called when a package is deleted. The
 111 hook is called *before* the package is deleted. The hook function is passed
 112 two arguments: the package name, and the install directory.")
 113
 114 (defun package-admin-default-install-function (filename pkg-dir buffer)
 115   "Default function to install a package.
 116 Install package FILENAME into directory PKG-DIR, with any messages output
 117 to BUFFER."
 118   (let* ((pkg-dir (file-name-as-directory pkg-dir))
 119          (default-directory pkg-dir)
 120          (filename (expand-file-name filename)))
 121     (unless (file-directory-p pkg-dir)
 122       (make-directory pkg-dir t))
 123     ;; Don't assume GNU tar.
 124     (if (shell-command (concat "gunzip -c " filename " | tar xvf -") buffer)
 125         0
 126       1)))
 127
 128 ;; A few things needed by the following 2 functions.
 129 (eval-when-compile
 130   (require 'packages)
 131   (autoload 'package-get-info "package-get")
 132   (autoload 'paths-decode-directory-path "find-paths")
 133   (defvar package-get-install-to-user-directory))
 134
 135 (defun package-admin-find-top-directory (type &optional user-dir)
 136   "Return the top level directory for a package.
 137
 138 Argument TYPE is a symbol that determines the type of package we're
 139 trying to find a directory for.
 140
 141 Optional Argument USER-DIR if non-nil use directories off
 142 `user-packages-topdir'.  This overrides everything except
 143 \"EMACSPACKAGEPATH\".
 144
 145 This function honours the environment variable \"EMACSPACKAGEPATH\"
 146 and returns directories found there as a priority.  If that variable
 147 doesn't exist and USER-DIR is nil, check in the normal places.
 148
 149 If we still can't find a suitable directory, return nil.
 150
 151 Possible values for TYPE are:
 152
 153     sxemacs == For \"sxemacs\" packages that go in '/sxemacs-packages/'
 154     std     == For \"standard\" packages that go in '/xemacs-packages/'
 155     mule    == For \"mule\" packages that go in '/mule-packages/'
 156     site    == For \"unsupported\" packages that go in '/site-packages/'
 157
 158 "
 159   (let* ((env-value (getenv "EMACSPACKAGEPATH"))
 160          top-dir)
 161     ;; First, check the environment var.
 162     (if env-value
 163         (let ((path-list (paths-decode-directory-path env-value 'drop-empties)))
 164           (cond ((eq type 'site)
 165                  (while path-list
 166                    (if (equal (file-name-nondirectory
 167                                (directory-file-name (car path-list)))
 168                               "site-packages")
 169                        (setq top-dir (car path-list)))
 170                    (setq path-list (cdr path-list))))
 171                 ((eq type 'sxemacs)
 172                  (while path-list
 173                    (if (equal (file-name-nondirectory
 174                                (directory-file-name (car path-list)))
 175                               "sxemacs-packages")
 176                        (setq top-dir (car path-list)))
 177                    (setq path-list (cdr path-list))))
 178                 ((eq type 'std)
 179                  (while path-list
 180                    (if (equal (file-name-nondirectory
 181                                (directory-file-name (car path-list)))
 182                               "xemacs-packages")
 183                        (setq top-dir (car path-list)))
 184                    (setq path-list (cdr path-list))))
 185                 ((eq type 'mule)
 186                  (while path-list
 187                    (if (equal (file-name-nondirectory
 188                                (directory-file-name (car path-list)))
 189                               "mule-packages")
 190                        (setq top-dir (car path-list)))
 191                    (setq path-list (cdr path-list)))))))
 192     ;; Wasn't in the environment, try `user-packages-topdir' if
 193     ;; USER-DIR is non-nil.
 194     (if (and user-dir
 195              (not top-dir))
 196         (cond ((eq type 'site)
 197                (setq top-dir (file-name-as-directory
 198                               (expand-file-name "site-packages"
 199                                                 user-packages-topdir))))
 200               ((eq type 'sxemacs)
 201                (setq top-dir (file-name-as-directory
 202                               (expand-file-name "sxemacs-packages"
 203                                                 user-packages-topdir))))
 204               ((eq type 'std)
 205                (setq top-dir (file-name-as-directory
 206                               (expand-file-name "xemacs-packages"
 207                                                 user-packages-topdir))))
 208               ((eq type 'mule)
 209                (setq top-dir (file-name-as-directory
 210                               (expand-file-name "mule-packages"
 211                                                 user-packages-topdir))))))
 212     ;; Finally check the normal places
 213     (if (not top-dir)
 214         (let ((path-list (nth 1 (packages-find-packages
 215                                  emacs-roots
 216                                  (packages-compute-package-locations
 217                                   user-packages-topdir)))))
 218           (cond ((eq type 'site)
 219                  (while path-list
 220                    (if (equal (file-name-nondirectory
 221                                (directory-file-name (car path-list)))
 222                               "site-packages")
 223                        (setq top-dir (car path-list)))
 224                    (setq path-list (cdr path-list))))
 225                 ((eq type 'sxemacs)
 226                  (while path-list
 227                    (if (equal (file-name-nondirectory
 228                                (directory-file-name (car path-list)))
 229                               "sxemacs-packages")
 230                        (setq top-dir (car path-list)))
 231                    (setq path-list (cdr path-list))))
 232                 ((eq type 'std)
 233                  (while path-list
 234                    (if (equal (file-name-nondirectory
 235                                (directory-file-name (car path-list)))
 236                               "xemacs-packages")
 237                        (setq top-dir (car path-list)))
 238                    (setq path-list (cdr path-list))))
 239                 ((eq type 'mule)
 240                  (while path-list
 241                    (if (equal (file-name-nondirectory
 242                                (directory-file-name (car path-list)))
 243                               "mule-packages")
 244                        (setq top-dir (car path-list)))
 245                    (setq path-list (cdr path-list)))))))
 246     ;; Now return either the directory or nil.
 247     top-dir))
 248
 249 (defun package-admin-get-install-dir (package &optional pkg-dir)
 250   "Find a suitable installation directory for a package.
 251
 252 Argument PACKAGE is the package to find a installation directory for.
 253 Optional Argument PKG-DIR, if non-nil is a directory to use for
 254 installation.
 255
 256 If PKG-DIR is non-nil and writable, return that.  Otherwise check to
 257 see if the PACKAGE is already installed and return that location, if
 258 it is writable.  Finally, fall back to the `user-packages-topdir' if
 259 all else fails.  As a side effect of installing packages under
 260 `user-packages-topdir' these packages become part of `early-packages'."
 261   ;; If pkg-dir specified, return that if writable.
 262   (if (and pkg-dir
 263            (file-writable-p (directory-file-name pkg-dir)))
 264       pkg-dir
 265     ;; If the user want her packages in her $HOME, do so.  Currently,
 266     ;; that means in `user-packages-topdir'.
 267     (let ((type (package-get-info package 'category)))
 268       (if package-get-install-to-user-directory
 269           (progn
 270             (cond ((equal type "site")
 271                    (setq pkg-dir (package-admin-find-top-directory 'site 'user-dir)))
 272                   ((equal type "sxemacs")
 273                    (setq pkg-dir (package-admin-find-top-directory 'sxemacs 'user-dir)))
 274                   ((equal type "standard")
 275                    (setq pkg-dir (package-admin-find-top-directory 'std 'user-dir)))
 276                   ((equal type "mule")
 277                    (setq pkg-dir (package-admin-find-top-directory 'mule 'user-dir))))
 278             pkg-dir)
 279         ;; Maybe the package has been installed before, if so, return
 280         ;; that directory.
 281         (let ((package-feature (intern-soft (concat
 282                                              (symbol-name package) "-autoloads")))
 283               autoload-dir)
 284           (when (and (not (eq package 'unknown))
 285                      (featurep package-feature)
 286                      (setq autoload-dir (feature-file package-feature))
 287                      (setq autoload-dir (file-name-directory autoload-dir))
 288                      (member autoload-dir (append early-package-load-path late-package-load-path)))
 289             ;; Find the corresponding entry in late-package
 290             (setq pkg-dir
 291                   (car-safe (member-if (lambda (h)
 292                                          (string-match (concat "^" (regexp-quote h))
 293                                                        autoload-dir))
 294                                        (append (cdr early-packages) late-packages)))))
 295           (if (and pkg-dir
 296                    (file-writable-p (directory-file-name pkg-dir)))
 297               pkg-dir
 298             ;; OK, the package hasn't been previously installed so we need
 299             ;; to guess where it should go.
 300             (cond ((equal type "site")
 301                    (setq pkg-dir (package-admin-find-top-directory 'site)))
 302                   ((equal type "sxemacs")
 303                    (setq pkg-dir (package-admin-find-top-directory 'sxemacs)))
 304                   ((equal type "standard")
 305                    (setq pkg-dir (package-admin-find-top-directory 'std)))
 306                   ((equal type "mule")
 307                    (setq pkg-dir (package-admin-find-top-directory 'mule)))
 308                   (t
 309                    (error 'invalid-operation
 310                           "Invalid package type")))
 311             (if (and pkg-dir
 312                      (file-writable-p (directory-file-name pkg-dir)))
 313                 pkg-dir
 314               ;; Oh no!  Either we still haven't found a suitable
 315               ;; directory, or we can't write to the one we did find.
 316               ;; Drop back to the `user-packages-topdir'.
 317               (if (y-or-n-p (format "Directory isn't writable, use %s instead? "
 318                                     user-packages-topdir))
 319                   (progn
 320                     (cond ((equal type "site")
 321                            (setq pkg-dir (package-admin-find-top-directory 'site 'user-dir)))
 322                           ((equal type "sxemacs")
 323                            (setq pkg-dir (package-admin-find-top-directory 'sxemacs 'user-dir)))
 324                           ((equal type "standard")
 325                            (setq pkg-dir (package-admin-find-top-directory 'std 'user-dir)))
 326                           ((equal type "mule")
 327                            (setq pkg-dir (package-admin-find-top-directory 'mule 'user-dir)))
 328                           (t
 329                            (error 'invalid-operation
 330                                   "Invalid package type")))
 331                     ;; Turn on `package-get-install-to-user-directory'
 332                     ;; so we don't get asked for each package we try to
 333                     ;; install in this session.
 334                     (setq package-get-install-to-user-directory t)
 335                     pkg-dir)
 336                 ;; If we get to here SXEmacs can't make up its mind and
 337                 ;; neither can the user, nothing left to do except barf. :-(
 338                 (error 'search-failed
 339                        (format
 340                         "Can't find suitable installation directory for package: %s"
 341                         package))))))))))
 342
 343 (defun package-admin-get-manifest-file (pkg-topdir package)
 344   "Return the name of the MANIFEST file for package PACKAGE.
 345 Note that PACKAGE is a symbol, and not a string."
 346   (let ((dir (file-name-as-directory
 347               (expand-file-name "pkginfo" pkg-topdir))))
 348     (expand-file-name (concat "MANIFEST." (symbol-name package)) dir)))
 349
 350 (defun package-admin-check-manifest (pkg-outbuf pkg-topdir)
 351   "Check for a MANIFEST.<package> file in the package distribution.
 352 If it doesn't exist, create and write one.
 353 PKG-OUTBUF is the buffer that holds the output from `tar', and PKG-TOPDIR
 354 is the top-level directory under which the package was installed."
 355   (let ((manifest-buf " *pkg-manifest*")
 356         (old-case-fold-search case-fold-search)
 357         regexp package-name pathname regexps)
 358     (unwind-protect
 359         (save-excursion                         ;; Probably redundant.
 360           (set-buffer (get-buffer pkg-outbuf))  ;; Probably already the current buffer.
 361           (goto-char (point-min))
 362
 363           ;; Make filenames case-insensitive, if necessary
 364           (if (eq system-type 'windows-nt)
 365               (setq case-fold-search t))
 366
 367           (setq regexp (concat "\\bpkginfo"
 368                                (char-to-string directory-sep-char)
 369                                "MANIFEST\\...*"))
 370
 371           ;; Look for the manifest.
 372           (if (not (re-search-forward regexp nil t))
 373               (progn
 374                 ;; We didn't find a manifest.  Make one.
 375
 376                 ;; Yuk.  We weren't passed the package name, and so we have
 377                 ;; to dig for it.  Look for it as the subdirectory name below
 378                 ;; "lisp", or "man".
 379                 ;; Here, we don't use a single regexp because we want to search
 380                 ;; the directories for a package name in a particular order.
 381                 (if (catch 'done
 382                       (let ((dirs '("lisp" "man"))
 383                             rexp)
 384                         (while dirs
 385                           (setq rexp (concat "\\b" (car dirs)
 386                                              "[\\/]\\([^\\/]+\\)[\//]"))
 387                           (if (re-search-forward rexp nil t)
 388                               (throw 'done t))
 389                           (setq dirs (cdr dirs)))))
 390                     (progn
 391                       (setq package-name (buffer-substring (match-beginning 1)
 392                                                            (match-end 1)))
 393
 394                       ;; Get and erase the manifest buffer
 395                       (setq manifest-buf (get-buffer-create manifest-buf))
 396                       (buffer-disable-undo manifest-buf)
 397                       (erase-buffer manifest-buf)
 398
 399                       ;; Now, scan through the output buffer, looking for
 400                       ;; file and directory names.
 401                       (goto-char (point-min))
 402                       ;; for each line ...
 403                       (while (< (point) (point-max))
 404                         (beginning-of-line)
 405                         (setq pathname nil)
 406
 407                         ;; scan through the regexps, looking for a pathname
 408                         (if (catch 'found-path
 409                               (setq regexps package-admin-tar-filename-regexps)
 410                               (while regexps
 411                                 (if (looking-at (car regexps))
 412                                     (progn
 413                                       (setq pathname
 414                                             (buffer-substring
 415                                              (match-beginning 1)
 416                                              (match-end 1)))
 417                                       (throw 'found-path t)))
 418                                 (setq regexps (cdr regexps))))
 419                             (progn
 420                               ;; found a pathname -- add it to the manifest
 421                               ;; buffer
 422                               (save-excursion
 423                                 (set-buffer manifest-buf)
 424                                 (goto-char (point-max))
 425                                 (insert pathname "\n"))))
 426                         (forward-line 1))
 427
 428                       ;; Processed all lines.
 429                       ;; Now, create the file, pkginfo/MANIFEST.<pkgname>
 430
 431                       ;; We use `expand-file-name' instead of `concat',
 432                       ;; for portability.
 433                       (setq pathname (expand-file-name "pkginfo"
 434                                                        pkg-topdir))
 435                       ;; Create pkginfo, if necessary
 436                       (if (not (file-directory-p pathname))
 437                           (make-directory pathname))
 438                       (setq pathname (expand-file-name
 439                                       (concat "MANIFEST." package-name)
 440                                       pathname))
 441                       (save-excursion
 442                         (set-buffer manifest-buf)
 443                         ;; Put the files in sorted order
 444                         (if-fboundp 'sort-lines
 445                             (sort-lines nil (point-min) (point-max))
 446                           (warn "`xemacs-base' not installed, MANIFEST.%s not sorted"
 447                                 package-name))
 448                         ;; Write the file.
 449                         ;; Note that using `write-region' *BYPASSES* any check
 450                         ;; to see if SXEmacs is currently editing/visiting the
 451                         ;; file.
 452                         (write-region (point-min) (point-max) pathname))
 453                       (kill-buffer manifest-buf))))))
 454       ;; Restore old case-fold-search status
 455       (setq case-fold-search old-case-fold-search))))
 456
 457 ;;;###autoload
 458 (defun package-admin-add-binary-package (file &optional pkg-dir)
 459   "Install a pre-bytecompiled XEmacs package into package hierarchy."
 460   (interactive "fPackage tarball: ")
 461   (let ((buf (get-buffer-create package-admin-temp-buffer))
 462         (status 1)
 463         start err-list)
 464     (setq pkg-dir (package-admin-get-install-dir 'unknown pkg-dir))
 465     ;; Ensure that the current directory doesn't change
 466     (save-excursion
 467       (set-buffer buf)
 468       ;; This is not really needed
 469       (setq default-directory (file-name-as-directory pkg-dir))
 470       (setq case-fold-search t)
 471       (buffer-disable-undo)
 472       (goto-char (setq start (point-max)))
 473       (if (= 0 (setq status (funcall package-admin-install-function
 474                                      file pkg-dir buf)))
 475           (progn
 476             ;; First, check for errors.
 477             ;; We can't necessarily rely upon process error codes.
 478             (catch 'done
 479               (goto-char start)
 480               (setq err-list package-admin-error-messages)
 481               (while err-list
 482                 (if (re-search-forward (car err-list) nil t)
 483                     (progn
 484                       (setq status 1)
 485                       (throw 'done nil)))
 486                 (setq err-list (cdr err-list))))
 487             ;; Make sure that the MANIFEST file exists
 488             (package-admin-check-manifest buf pkg-dir))))
 489     status))
 490
 491 (defun package-admin-rmtree (directory)
 492   "Delete a directory and all of its contents, recursively.
 493 This is a feeble attempt at making a portable rmdir."
 494   (setq directory (file-name-as-directory directory))
 495   (let ((files (directory-files directory nil nil nil t))
 496         (dirs (directory-files directory nil nil nil 'dirs)))
 497     (while dirs
 498       (if (not (member (car dirs) '("." "..")))
 499           (let ((dir (expand-file-name (car dirs) directory)))
 500             (condition-case err
 501                 (if (file-symlink-p dir) ;; just in case, handle symlinks
 502                     (delete-file dir)
 503                   (package-admin-rmtree dir))
 504               (file-error
 505                (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err)))))
 506         (setq dirs (cdr dirs))))
 507     (while files
 508       (condition-case err
 509           (delete-file (expand-file-name (car files) directory))
 510         (file-error
 511          (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err))))
 512       (setq files (cdr files)))
 513     (condition-case err
 514         (delete-directory directory)
 515       (file-error
 516        (message "%s: %s: \"%s\"" (nth 1 err) (nth 2 err) (nth 3 err))))))
 517
 518 (defun package-admin-get-lispdir  (pkg-topdir package)
 519   (let (package-lispdir)
 520     (if (and (setq package-lispdir (expand-file-name "lisp" pkg-topdir))
 521              (setq package-lispdir (expand-file-name (symbol-name package)
 522                                                      package-lispdir))
 523              (file-accessible-directory-p package-lispdir))
 524         package-lispdir)))
 525
 526 (defun package-admin-delete-binary-package (package pkg-topdir)
 527   "Delete a binary installation of PACKAGE below directory PKG-TOPDIR.
 528 PACKAGE is a symbol, not a string."
 529   (let (manifest-file package-lispdir dirs file)
 530     (setq pkg-topdir (package-admin-get-install-dir package pkg-topdir))
 531     (setq manifest-file (package-admin-get-manifest-file pkg-topdir package))
 532     (run-hook-with-args 'package-delete-hook package pkg-topdir)
 533     (if (file-exists-p manifest-file)
 534         (progn
 535           ;; The manifest file exists!  Use it to delete the old distribution.
 536           (message "Removing old files for package \"%s\" ..." package)
 537           (sit-for 0)
 538           (with-temp-buffer
 539             (buffer-disable-undo)
 540             (erase-buffer)
 541             (insert-file-contents manifest-file)
 542             (goto-char (point-min))
 543
 544             ;; For each entry in the MANIFEST ...
 545             (while (< (point) (point-max))
 546               (beginning-of-line)
 547               (setq file (expand-file-name (buffer-substring
 548                                             (point)
 549                                             (point-at-eol))
 550                                            pkg-topdir))
 551               (if (file-directory-p file)
 552                   ;; Keep a record of each directory
 553                   (setq dirs (cons file dirs))
 554                   ;; Delete each file.
 555                   ;; Make sure that the file is writable.
 556                   ;; (This is important under MS Windows.)
 557                   ;; I do not know why it important under MS Windows but
 558                   ;;    1. It bombs out when the file does not exist. This can be condition-cased
 559                   ;;    2. If I removed the write permissions, I do not want SXEmacs to just ignore them.
 560                   ;;       If it wants to, SXEmacs may ask, but that is about all
 561                   ;; (set-file-modes file 438) ;; 438 -> #o666
 562                   ;; Note, user might have removed the file!
 563                 (condition-case ()
 564                     (delete-file file)
 565                   (error nil)))         ;; We may want to turn the error into a Warning?
 566               (forward-line 1))
 567
 568             ;; Delete empty directories.
 569             (if dirs
 570                 (progn
 571                   (mapc
 572                    (lambda (dir)
 573                      (condition-case ()
 574                          (delete-directory dir)))
 575                    dirs)))
 576           ;; Delete the MANIFEST file
 577           ;; (set-file-modes manifest-file 438) ;; 438 -> #o666
 578           ;; Note. Packages can have MANIFEST in MANIFEST.
 579           (condition-case ()
 580               (delete-file manifest-file)
 581             (error nil)) ;; Do warning?
 582           (message "Removing old files for package \"%s\" ... done" package)))
 583       ;; The manifest file doesn't exist.  Fallback to just deleting the
 584       ;; package-specific lisp directory, if it exists.
 585       ;;
 586       ;; Delete old lisp directory, if any
 587       ;; Gads, this is ugly.  However, we're not supposed to use `concat'
 588       ;; in the name of portability.
 589       (setq package-lispdir (package-admin-get-lispdir pkg-topdir package))
 590       (when package-lispdir
 591         (message "Removing old lisp directory \"%s\" ..." package-lispdir)
 592         (sit-for 0)
 593         (package-admin-rmtree package-lispdir)
 594         (message "Removing old lisp directory \"%s\" ... done" package-lispdir)))
 595     ;; Delete the package from the database of installed packages.
 596     (package-delete-name package)))
 597
 598 (provide 'package-admin)
 599
 600 ;;; package-admin.el ends here