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