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