>>>> "SJT" == Stephen J Turnbull
<stephen(a)xemacs.org> writes:
>>>> "Joachim" == Joachim Schrod <jschrod(a)acm.org> writes:
Joachim> If somebody wants to see that 80%-ready code nevertheless, I
Joachim> can make it available, of course.
SJT> Please do. Thanks!
Stephen wanted it, you get it. As I've written, 80% finished; i.e., it
does not run properly. ;-) This is posted here for discussion. All
known problems or open issues in the code are tagged with `FIXME:'.
I will send an other email to xemacs-beta with my view on requirements
and about design decisions that I made. This shall enable a thread on
the basic implementation. But first the list of open technical
questions that need to be resolved and where I would be grateful for
any opinions.
Known errors:
-- #'package-get-update-base definitively does not work. I don't know
how this function is supposed to be used. I understand what it
does, but don't know if I grok the call context good enough.
-- Code has been changed recently, but not been tested. (It compiles
without errors, but probably won't run. :-)
Known issues / problems:
-- User interface for site selection probably needs rework (see other
email).
-- Currently, the download site description has no leading / in
directory names for ftp sites. I want to demand absolute paths for
HTTP and SSH -- will that be a problem?
-- Do we need a file-readable-p for all transport protocols? (IMO no.)
-- Shall we really support environment variables in local package
specifications; i.e., ? Currently, it is done for this very special case
and not anywhere else.
-- Index file handling is not good; the database is both fetched too
often (in #'package-get-maybe-save-index) and not fetching is
allowed (when 'package-get-remote is set).
Missing:
-- Update of site descriptions.
-- Support for http and ssh ports.
-- Support for (authenticated) http proxies.
-- Better error checks if copy-file does not succeed.
lisp/ChangeLog addition:
2005-10-26 Joachim Schrod <jschrod(a)acm.org>
* package-get.el: Replace all access functions to index and
package files with calls to package-transport functions.
* package-transport.el: New module that provides abstraction for
package downloads, over several transport protocols.
XEmacs 21.4 source patch:
Diff command: cvs -q -f diff -u -N
Files affected: lisp/package-transport.el lisp/package-get.el
Index: lisp/package-get.el
===================================================================
RCS file: /pack/xemacscvs/XEmacs/xemacs/lisp/package-get.el,v
retrieving revision 1.39.2.9
diff -u -r1.39.2.9 package-get.el
--- lisp/package-get.el 2004/06/28 01:19:56 1.39.2.9
+++ lisp/package-get.el 2005/10/26 00:23:54
@@ -8,6 +8,7 @@
;; Heavy-Modifications: Greg Klanderman <greg(a)alphatech.com>
;; Jan Vroonhof <vroonhof(a)math.ethz.ch>
;; Steve Youngs <youngs(a)xemacs.org>
+;; Medium Modifications: Joachim Schrod <jschrod(a)acm.org>
;; Keywords: internal
;; This file is part of XEmacs.
@@ -105,7 +106,7 @@
;;; Code:
(require 'package-admin)
-;; (require 'package-get-base)
+(require 'package-transport)
(defgroup package-tools nil
"Tools to manipulate packages."
@@ -170,7 +171,7 @@
:group 'package-get)
;;;###autoload
-(defcustom package-get-package-index-file-location
+(defcustom package-get-package-index-file-location
(car (split-path (or (getenv "EMACSPACKAGEPATH") user-init-directory)))
"*The directory where the package-index file can be found."
:type 'directory
@@ -200,6 +201,9 @@
;;;###autoload
(defcustom package-get-download-sites
'(
+ ;; Test for http
+ ;; FIXME: Need to update the site descriptions!
+ ("http test site" "localhost" "/xemacs/packages"
'http)
;; Main XEmacs Site (
ftp.xemacs.org)
("US (Main XEmacs Site)"
"ftp.xemacs.org" "pub/xemacs/packages")
@@ -469,60 +473,58 @@
(defun package-get-locate-file (file &optional nil-if-not-found no-remote)
"Locate an existing FILE with respect to `package-get-remote'.
-If FILE is an absolute path or is not found, simply return FILE.
-If optional argument NIL-IF-NOT-FOUND is non-nil, return nil
-if FILE can not be located.
+Returns '(SITE FILE).
+If FILE is an absolute path, always return FILE with a local SITE.
+If optional argument NIL-IF-NOT-FOUND is non-nil, return nil if
+FILE can not be located; otherwise return FILE with a local SITE.
If NO-REMOTE is non-nil never search remote locations."
(if (file-name-absolute-p file)
- file
- (let ((site package-get-remote)
- (expanded nil))
- (when site
- (unless (and no-remote (caar (list site)))
- (let ((expn (package-get-remote-filename (car (list site)) file)))
- (if (and expn (file-exists-p expn))
- (setq site nil
- expanded expn)))))
- (or expanded
- (and (not nil-if-not-found)
- file)))))
+ (list nil file)
+ (let ((site (if (and no-remote
+ (package-transport-remote-p package-get-remote))
+ nil
+ package-get-remote)))
+ (if (package-transport-file-exists-p site file)
+ (list site file)
+ (and (not nil-if-not-found)
+ (list nil file))))))
(defun package-get-locate-index-file (no-remote)
- "Locate the package-get index file.
+ "Locate the package-get index file. Returns '(SITE FILE).
-Do not return remote paths if NO-REMOTE is non-nil. If the index
+Do not return remote SITE if NO-REMOTE is non-nil. If the index
file doesn't exist in `package-get-package-index-file-location', ask
the user if one should be created using the index file in core as a
template."
(or (package-get-locate-file package-get-base-filename t no-remote)
- (if (file-exists-p (expand-file-name package-get-base-filename
- package-get-package-index-file-location))
- (expand-file-name package-get-base-filename
- package-get-package-index-file-location)
- (if (y-or-n-p (format "No index file, shall I create one in %s? "
- package-get-package-index-file-location))
- (progn
- (save-excursion
- (set-buffer
- (find-file-noselect (expand-file-name
- package-get-base-filename
- package-get-package-index-file-location)))
- (let ((coding-system-for-write 'binary))
- (erase-buffer)
- (insert-file-contents-literally
- (locate-data-file package-get-base-filename))
- (save-buffer (current-buffer))
- (kill-buffer (current-buffer))))
- (expand-file-name package-get-base-filename
+ (let ((index-file (expand-file-name
+ package-get-base-filename
+ package-get-package-index-file-location)))
+ (if (file-exists-p index-file)
+ (list nil index-file)
+ (if (y-or-n-p (format "No index file, shall I create one in %s? "
package-get-package-index-file-location))
- (error 'search-failed
- "Can't locate a package index file.")))))
+ (progn
+ (save-excursion
+ (set-buffer (find-file-noselect index-file))
+ (let ((coding-system-for-write 'binary))
+ (erase-buffer)
+ (insert-file-contents-literally
+ (locate-data-file package-get-base-filename))
+ (save-buffer (current-buffer))
+ (kill-buffer (current-buffer))))
+ (list nil index-file))
+ (error 'search-failed
+ "Can't locate a package index file."))))))
(defun package-get-maybe-save-index (filename)
"Offer to save the current buffer as the local package index file,
if different."
- (let ((location (package-get-locate-index-file t)))
- (unless (and filename (equal filename location))
+ (let* ((location-spec (package-get-locate-index-file t))
+ (location (expand-file-name (second location-spec)
+ (cadar location-spec)))
+ (file (expand-file-name filename)))
+ (unless (and file (equal file location))
(unless (and location
(equal (md5 (current-buffer))
(with-temp-buffer
@@ -533,42 +535,57 @@
location user-init-directory))
(setq location (expand-file-name
package-get-base-filename
- package-get-package-index-file-location))
+ user-init-directory))
(error 'file-error
(format "%s is read-only" location))))
(when (y-or-n-p (concat "Update package index in " location "? "))
(let ((coding-system-for-write 'binary))
(write-file location)))))))
+
;;;###autoload
(defun package-get-update-base (&optional db-file force-current)
"Update the package-get database file with entries from DB-FILE.
+DB-FILE is NIL or '(SITE FILE).
Unless FORCE-CURRENT is non-nil never try to update the database."
+ ;; FIXME: How is this function supposed to be used interactively?
(interactive
(let ((dflt (package-get-locate-index-file nil)))
+ ;; FIXME: This does not work at all. db-file ain't no filename
+ ;; any more. One could read a URI here and convert it to a
+ ;; transport file spec. In any case, #'read-file-name must not be
+ ;; used.
(list (read-file-name "Load package-get database: "
(file-name-directory dflt)
dflt
t
(file-name-nondirectory dflt)))))
- (setq db-file (expand-file-name (or db-file
- (package-get-locate-index-file
- (not force-current)))))
- (if (not (file-exists-p db-file))
+ (unless db-file
+ (setq db-file (package-get-locate-index-file (not force-current))))
+ (if (not (apply #'package-transport-file-exists-p db-file))
(error 'file-error
- (format "Package-get database file `%s' does not exist" db-file)))
- (if (not (file-readable-p db-file))
+ (format "Package-get database file `%s' does not exist"
+ (package-transport-uri db-file))))
+ ;; FIXME: Maybe we don't want to check for readability and catch the copy
+ ;; failure instead? Then we have one method less to implement in
+ ;; package-transport-readable-p.
+ (if (not (apply #'package-transport-file-readable-p db-file))
(error 'file-error
- (format "Package-get database file `%s' not readable" db-file)))
+ (format "Package-get database file `%s' not readable"
+ (package-transport-uri db-file))))
(let ((buf (get-buffer-create "*package database*")))
(unwind-protect
(save-excursion
(set-buffer buf)
(erase-buffer buf)
- (insert-file-contents-literally db-file)
+ ;; FIXME: Need to use package-transport-copy-file here. Or provide a
+ ;; package-transport-insert-file-contents-literally function.
+ ;; FIXME: Might it be that the index file gets fetched too often?
+ ;; How about usage of already fetched file?
+ (insert-file-contents-literally (second db-file))
(package-get-update-base-from-buffer buf)
- (if (file-remote-p db-file)
- (package-get-maybe-save-index db-file)))
+ (if (package-transport-remote-p (first db-file))
+ (package-get-maybe-save-index (second db-file))))
(kill-buffer buf))))
;; This is here because the `process-error' datum doesn't exist in
@@ -612,7 +629,7 @@
(setq good-sig t))
(if good-sig
(setq package-get-continue-update-base t)
- (error 'process-error
+ (error 'process-error
"GnuPG error. Package database not updated")))
(if (yes-or-no-p
"Package Index is not PGP signed. Continue anyway? ")
@@ -967,7 +984,7 @@
(when (memq item (package-get-info (caar pkgs) field))
(setq results (push (caar pkgs) results)))
(setq pkgs (cdr pkgs)))))
- (t
+ (t
(error 'wrong-type-argument field)))
(if (interactive-p)
(if arg
@@ -1006,13 +1023,12 @@
(latest (package-get-info-prop this-package 'version))
(installed (package-get-key package :version))
(found nil)
- (search-dir package-get-remote)
(base-filename (package-get-info-prop this-package 'filename))
(package-status t)
filenames full-package-filename)
(if (and (equal (package-get-info package 'category) "mule")
(not (featurep 'mule)))
- (error 'invalid-state
+ (error 'invalid-state
"Mule packages can't be installed with a non-Mule XEmacs"))
(if (null this-package)
(if package-get-remote
@@ -1058,43 +1074,44 @@
;; and copy it into the staging directory. Then validate
;; the checksum. Finally, install the package.
(catch 'done
- (let (search-filenames host dir current-filename dest-filename)
- ;; In each search directory ...
- (when search-dir
- (setq host (car search-dir)
- dir (car (cdr search-dir))
- search-filenames filenames)
+ (let (search-filenames current-filename dest-filename)
+ ;; FIXME: That when might be superfluous. If package-get-remote is
+ ;; NIL, we interpret that as "local filename". Maybe we want that
+ ;; here?!
+ (when package-get-remote
+ (setq search-filenames filenames)
;; Look for one of the possible package filenames ...
(while search-filenames
(setq current-filename (car search-filenames)
dest-filename (package-get-staging-dir current-filename))
(cond
- ;; No host means look on the current system.
- ((null host)
+ ;; Local package file can be used directly, no copy necessary.
+ ((package-transport-remote-p package-get-remote)
(setq full-package-filename
+ ;; FIXME: Do we really want a substitute-in-file-name
+ ;; here? If yes, we need it as well at other places where
+ ;; we handle local files!!
(substitute-in-file-name
(expand-file-name current-filename
- (file-name-as-directory dir)))))
+ (second package-get-remote)))))
- ;; If it's already on the disk locally, and the size is
- ;; correct
+ ;; If it's already on the disk locally, and the size is correct.
((and (file-exists-p dest-filename)
(eq (nth 7 (file-attributes dest-filename))
(package-get-info package 'size)))
(setq full-package-filename dest-filename))
;; If the file exists on the remote system ...
- ((file-exists-p (package-get-remote-filename
- search-dir current-filename))
+ ((package-transport-file-exists-p package-get-remote
+ current-filename)
;; Get it
(setq full-package-filename dest-filename)
(message "Retrieving package `%s' ..."
current-filename)
(sit-for 0)
- (copy-file (package-get-remote-filename search-dir
- current-filename)
- full-package-filename t)))
+ (package-transport-copy-file package-get-remote current-filename
+ full-package-filename)))
;; If we found it, we're done.
(if (and full-package-filename
@@ -1221,30 +1238,6 @@
(nth 2 (efs-ftp-path filename)))
filename))
(file-name-as-directory package-get-dir)))
-
-(defun package-get-remote-filename (search filename)
- "Return FILENAME as a remote filename.
-It first checks if FILENAME already is a remote filename. If it is
-not, then it uses the (car search) as the remote site-name and the (cadr
-search) as the remote-directory and concatenates filename. In other
-words
- site-name:remote-directory/filename.
-
-If (car search) is nil, (cadr search is interpreted as a local directory).
-"
- (if (file-remote-p filename)
- filename
- (let ((dir (cadr search)))
- (concat (when (car search)
- (concat
- (if (string-match "@" (car search))
- "/"
- "/anonymous@")
- (car search) ":"))
- (if (string-match "/$" dir)
- dir
- (concat dir "/"))
- filename))))
(defun package-get-installedp (package version)
"Determine if PACKAGE with VERSION has already been installed.
Index: lisp/package-transport.el
===================================================================
RCS file: package-transport.el
diff -N package-transport.el
--- /dev/null Wed Oct 26 02:23:48 2005
+++ package-transport.el Wed Oct 26 02:23:55 2005
@@ -0,0 +1,447 @@
+;; package-transport.el --- Download packages via various protocols.
+
+;; Copyright (C) 2003 Steve Youngs
+;; Copyright (C) 2005 Joachim Schrod
+
+;; RCS: $Id: $
+;; Original Author: Steve Youngs <youngs(a)xemacs.org>
+;; Heavily Rewritten: Joachim Schrod <jschrod(a)acm.org>
+;; Maintainer: N.N.
+;; Created: <2003-07-19>
+;; Last-Modified: 25 Oct 05
+;; Homepage:
http://www.xemacs.org/
+;; Keywords: package pui internal
+
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;;
+;; 3. Neither the name of the author nor the names of any contributors
+;; may be used to endorse or promote products derived from this
+;; software without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
+;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+;; DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
+;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
+;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
+;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;;; Commentary:
+;;
+;; This code provides the ability to download packages via several
+;; protocols. Currently supported are:
+;; file package depot is on a local file system
+;; ftp package depot access via EFS
+;; http package depot access via HTTP
+;; ssh package depot access via ssh/scp
+;;
+;; This module provides functions package-transport-FUNCNAME, for
+;; FUNCNAME being
+;; - `file-exists-p'
+;; - `file-readable-p'
+;; - `copy-file'
+;; All these functions have almost the same signature as FUNCNAME,
+;; with an additional first argument that is a SITE clause in form
+;; '(HOST DIRECTORY PROTOCOL). HOST and DIRECTORY are strings.
+;; PROTOCOL is a symbol from the set named above and is optional;
+;; it defaults to 'file if HOST is nil and 'ftp otherwise. The
+;; SITE clause can also be nil, that's the same as '(nil "" file),
+;; i.e., file is just a filename on the local file system.
+;;
+;; The specific semantics of the SITE clauses are explained below,
+;; for each transport protocol.
+;;
+;; Further functions:
+;; #'package-transport-remote-p tells if a SITE clause is remote
+;; or not.
+;; #'package-transport-uri creates a URI from a SITE clause and an
+;; optional FILE. That URI is supposed to be used in user messages.
+;;
+;; This is all extremely PUI-centric, but some of it may be useful
+;; elsewhere. What we have here is a set of tools that will enable
+;; different transport (download) methods in PUI.
+;;
+;; The rationale behind this was that PUI was a little brain-damaged
+;; in that before you could use it you had to already have some
+;; packages pre-installed. Enabling different transport methods
+;; directly in core XEmacs will overcome this.
+;;
+;; It is hoped that this library is "modular" enough so that adding
+;; new transport methods should be a fairly painless task.
+;;
+;; To enable a new transport method: add METHOD specific defuns.
+;; You should name these defuns `package-transport-METHOD-FUNCNAME',
+;; for example: `package-transport-http-file-exists-p' for a HTTP
+;; version of `file-exists-p' defun.
+
+;;; Todo:
+;;
+;; o Create a '(SITE FILE) specifier from a URI.
+
+;;; Code:
+
+;; Stuff common to all methods:
+(defgroup package-transport nil
+ "Package download methods."
+:prefix "package-transport-"
+:group 'package-get)
+
+
+;; Some convenience functions.
+
+(defun package-transport-protocol (site)
+ "Get protocol from SITE description."
+ (or (third site)
+ (if (first site) 'ftp 'file)))
+
+(defun package-transport-remote-p (site)
+ "Returns if a SITE description is remote or not.
+All SITE descriptions that need special access methods are deemed
+remote, even if they would access localhost. I.e., if this function
+returns true, one can use normal Elisp functions to access the file
+and use (second SITE) as the directory."
+ (eq (package-transport-protocol site) 'file))
+
+(defun package-transport-uri (site &optional file)
+ "Return a URI that can be used in messages to the user."
+ (let ((host (first site))
+ (dir (second site))
+ (protocol (package-transport-protocol site)))
+ (concat protocol ":"
+ (if host (concat "//" host))
+ dir "/" file)))
+
+
+;; Dispatcher functions, since we have no defmethod.
+
+(defun package-transport-dispatch (method args)
+ (let ((protocol (package-transport-protocol (car args))))
+ (apply (intern (format "package-transport-%s-%s" protocol method))
+ args)))
+
+(defun package-transport-file-exists-p (site filename)
+ "Check if FILENAME exists on SITE.
+SITE is a site description '(HOST DIR PROTOCOL); FILENAME is a string.
+Read the doc string of `file-exists-p' for further description."
+ (package-transport-dispatch "file-exists-p"
+ (list site filename)))
+
+(defun package-transport-file-readable-p (site filename)
+ "Check if FILENAME is readable on SITE.
+SITE is a site description '(HOST DIR PROTOCOL); FILENAME is a string.
+Read the doc string of `file-readable-p' for further description."
+ (package-transport-dispatch "file-readable-p"
+ (list site filename)))
+
+;; Note: no KEEP-TIME argument. I don't think we need that.
+(defun package-transport-copy-file (site src dest
+ &optional ok-if-already-exists)
+ "Copy file content of SRC to DEST. SRC is on SITE.
+SITE is a site description '(HOST DIR PROTOCOL); SRC and DEST are strings.
+Read the doc string of `copy-file' for further description."
+ (package-transport-dispatch "copy-file"
+ (list site src dest ok-if-already-exists)))
+
+
+;; And now for the transport methods themselves.
+
+;;; File
+
+;; FIXME: Support DIRECTORY with and without leading "/".
+(defun package-transport-file-filename (site filename)
+ (expand-file-name filename (concat "/" (second site))))
+
+(defun package-transport-file-file-exists-p (site filename)
+ "Does a local file exist?"
+ (file-exists-p (package-transport-file-filename site filename)))
+
+(defun package-transport-file-file-readable-p (site filename)
+ "Is a local file readable?"
+ (file-readable-p (package-transport-file-filename site filename)))
+
+(defun package-transport-file-copy-file (site src dest
+ &optional ok-if-already-exists)
+ "Copy a local file."
+ (copy-file (package-transport-file-filename site src) dest
+ ok-if-already-exists))
+
+
+;;; HTTP
+
+;; FIXME: Implement fetching via proxy server, with authentication.
+;; FIXME: Implement authentication.
+;; FIXME: Implement support for other ports than 80. E.g., allow HOST
+;; strings that are "HOSTNAME:PORT".
+
+;; I realise that most (all?) of this has already been done in Bill
+;; Perry's 'URL' and 'W3' packages, but the whole point is to have
it
+;; in core so PUI will work in a virgin XEmacs installation. --SY.
+
+(defcustom package-transport-http-port 80
+ "*The port to use for HTTP package transfers, defaults to '80'."
+:type 'integer
+:group 'package-transport)
+
+(defun package-transport-http-url (site filename)
+ (let ((host (or (first site) "localhost"))
+ (dir (second site)))
+ (concat "http://" host dir "/" filename)))
+
+;; A bit of eye candy. Kudos to Zappo for this.
+(eval-and-compile
+ (condition-case nil
+ (require 'working)
+ (error
+ (progn
+ (eval-when-compile
+ (defvar msg)
+ (defvar dstr)
+ (defvar refl))
+ (defmacro working-status-forms (message donestr &rest forms)
+ "Contain a block of code during which a working status is shown."
+ (list 'let (list (list 'msg message) (list 'dstr donestr)
+ '(ref1 0))
+ (cons 'progn forms)))
+ (defun working-dynamic-status (&optional number &rest args)
+ "Called within the macro `working-status-forms', show the status."
+ (message "%s%s" (apply 'format msg args)
+ (format "... %c" (aref [ ?- ?/ ?| ?\\ ] (% ref1 4))))
+ (setq ref1 (1+ ref1)))
+ (put 'working-status-forms 'lisp-indent-function 2)))))
+
+;; FIXME: Combine the protocol handling into an internal function that
+;; just takes the HTTP command.
+;; FIXME: Support DIRECTORY with and without leading "/".
+(defun package-transport-http-file-exists-p (site filename)
+ "Check to see if a remote file exists over the HTTP protocol."
+ (let* ((host (first site))
+ (path (concat (second site) "/" filename))
+ (coding-system-for-read 'binary)
+ (coding-system-for-write 'binary)
+ (user-agent (concat "XEmacs " emacs-program-version))
+ (http (open-network-stream "http-file-exists-proc"
+ " *http-proc-buf*"
+ host
+ package-transport-http-port))
+ (pbuf (process-buffer http))
+ (status nil))
+ (process-send-string
+ http
+ (concat "HEAD /" path " HTTP/1.1\r\n"
+ "MIME-Version: 1.0\r\n"
+ "Connection: close\r\n"
+ ;; FIXME: But we don't speak SSL, do we?
+ "Extension: Security/Digest Security/SSL\r\n"
+ "Host: " host "\r\n"
+ "Accept: */*\r\n"
+ "User-Agent: " user-agent "\r\n\r\n"))
+ (working-status-forms (concat "Checking existence of: " path)
"Done!"
+ (while (eq (process-status http) 'open)
+ (working-dynamic-status nil)
+ (sleep-for 0.05))
+ (working-dynamic-status t))
+ (setq status (with-temp-buffer
+ (erase-buffer)
+ (insert-buffer pbuf)
+ (goto-char (point-min))
+ (re-search-forward "200 OK" nil t)))
+ (kill-buffer pbuf)
+ (when status
+ (setq status t))
+ status))
+
+(defalias 'package-transport-http-file-readable-p
+ 'package-transport-http-file-exists-p)
+
+;; FIXME: Support DIRECTORY with and without leading "/".
+(defun package-transport-http-copy-file (site src dest
+ &optional ok-if-already-exists)
+ "Copy a remote file to the local machine via HTTP."
+ (and (file-exists-p 'dest)
+ (not ok-if-already-exists)
+ (not (y-or-n-p "Destination file exists, overwrite? "))
+ (error 'file-already-exists dest))
+ (let* ((host (first site))
+ (path (concat (second site) "/" src))
+ (coding-system-for-read 'binary)
+ (coding-system-for-write 'binary)
+ (user-agent (concat "XEmacs " emacs-program-version))
+ (http (open-network-stream "http-copy-file-proc"
+ " *http-proc-buf*"
+ host
+ package-transport-http-port))
+ (pbuf (process-buffer http)))
+ (process-send-string
+ http
+ (concat "GET /" path " HTTP/1.1\r\n"
+ "MIME-Version: 1.0\r\n"
+ "Connection: close\r\n"
+ ;; FIXME: But we don't speak SSL, do we?
+ "Extension: Security/Digest Security/SSL\r\n"
+ "Host: " host "\r\n"
+ "Accept: */*\r\n"
+ "User-Agent: " user-agent "\r\n\r\n"))
+ (working-status-forms (concat "Downloading " path) "Done!"
+ (while (eq (process-status http) 'open)
+ (working-dynamic-status nil)
+ (sleep-for 0.05))
+ (working-dynamic-status t))
+ (with-temp-buffer
+ (erase-buffer)
+ (insert-buffer pbuf)
+ (goto-char (point-min))
+ (re-search-forward "^Content-Length: \\([0-9]+.*$\\)" nil t)
+ (let* ((file-length (string-to-int (match-string 1)))
+ (file-begin (progn
+ (goto-char (point-min))
+ (re-search-forward "^Content-Encoding:" nil t)
+ (forward-line 2)
+ (point-at-bol))))
+ (goto-char file-begin)
+ (forward-char file-length)
+ (narrow-to-region file-begin (point))
+ (write-region (point-min) (point-max) dest)))
+ (kill-buffer pbuf)))
+
+
+;;; FTP (using EFS)
+
+;; Because PUI was originally set up to use EFS we just have to
+;; construct an appropriate file name and can call the core functions.
+
+;; FIXME: Support DIRECTORY with and without leading "/".
+(defun package-transport-ftp-filename (site filename)
+ (concat "/" (or (first site) "localhost")
+ ":/" (second site)
+ "/" filename))
+
+(defun package-transport-ftp-file-exists-p (site filename)
+ "Does a ftp file exist?"
+ (file-exists-p (package-transport-ftp-filename site filename)))
+
+(defun package-transport-ftp-file-readable-p (site filename)
+ "Is a ftp file readable?"
+ (file-readable-p (package-transport-ftp-filename site filename)))
+
+(defun package-transport-ftp-copy-file (site src dest
+ &optional ok-if-already-exists)
+ "Copy a ftp file."
+ (copy-file (package-transport-ftp-filename site src) dest
+ ok-if-already-exists))
+
+
+
+;;; SSH (via scp)
+
+;; FIXME: The port and user stuff is not usable. These are
+;; site-specific, not user preferences. But we want to support
+;; something like this in HOST part of SITE clauses.
+
+;; I don't have access to anything other than GNU/Linux based system
+;; so the SSH method probably isn't very portable outside of Unix
+;; systems. --SY.
+(defcustom package-transport-ssh-port 22
+ "*The port to use for SSH package transfers."
+:type 'integer
+:group 'package-transport)
+
+(defcustom package-transport-ssh-user-name (user-login-name)
+ "*The default SSH user name to use for package retrieval via scp."
+:type 'string
+:group 'package-transport)
+
+;; FIXME: Combine the protocol handling into an internal function that
+;; just takes the ssh command.
+;; FIXME: Support DIRECTORY with and without leading "/"?
+(defun package-transport-ssh-file-exists-p (site filename)
+ "A `file-remote-p' to use over SSH."
+ (let* ((host (first site))
+ (path (concat (second site) "/" filename))
+ (proc "ssh-file-exists-proc")
+ (pbuf " *ssh-file-exists-proc-buf*")
+ (status nil)
+ (ssh (start-process-shell-command
+ proc
+ pbuf
+ (concat "ssh "
+; (if port
+; (concat "-p " port " ")
+; (concat "-p " (number-to-string package-transport-ssh-port) "
"))
+; (if user
+; (concat user "@" host)
+; (concat package-transport-ssh-user-name "@" host))
+ (or host "localhost")
+ ;; FIXME: What about spaces in path?
+ ;; FIXME: Why ls -l and not just test -e?
+ " 'ls -l " path "'"))))
+ (working-status-forms (concat "Checking existence of: " path)
"Done!"
+ (while (eq (process-status ssh) 'run)
+ (working-dynamic-status nil)
+ (sleep-for 0.05))
+ (working-dynamic-status t))
+ (setq status (process-exit-status ssh))
+ (kill-buffer pbuf)
+ (if (eq status 0)
+ (setq status t)
+ (setq status nil))
+ status))
+
+;; FIXME: For now; until we have decided if we need readable-p at all.
+(defalias 'package-transport-ssh-file-readable-p
+ 'package-transport-ssh-file-exists-p)
+
+;; FIXME: Support DIRECTORY with and without leading "/"?
+(defun package-transport-ssh-copy-file (site src dest
+ &optional ok-if-already-exists)
+ "Copy remote SRC to local DEST via SSH using 'scp'."
+ (and (file-exists-p 'dest)
+ (not ok-if-already-exists)
+ (not (y-or-n-p "Destination file exists, overwrite? "))
+ (error 'file-already-exists dest))
+ (let* ((host (first site))
+ (path (concat (second site) "/" src))
+ (proc "ssh-copy-file-proc")
+ (pbuf " *ssh-copy-file-proc-buf*")
+ (ssh (start-process-shell-command
+ proc
+ pbuf
+ (concat "scp -q "
+; "-P "
+; (or (number-to-string port)
+; (number-to-string package-transport-ssh-port))
+; (if user
+; (concat " " user "@" host ":" path " ")
+; (concat " " package-transport-ssh-user-name "@" host
":" path " "))
+ (or host "localhost") ":" path
+ dest))))
+ (working-status-forms (concat "Downloading " path) "Done!"
+ (while (eq (process-status ssh) 'run)
+ (working-dynamic-status nil)
+ (sleep-for 0.05))
+ (working-dynamic-status t))
+ (kill-buffer pbuf)))
+
+
+(provide 'package-transport)
+;;; package-transport.el ends here
+
+;Local Variables:
+;time-stamp-start: "Last-Modified:[ ]+\\\\?[\"<]+"
+;time-stamp-end: "\\\\?[\">]"
+;time-stamp-line-limit: 10
+;time-stamp-format: "%4y-%02m-%02d %02H:%02M:%02S (%u)"
+;End:
+
Best,
Joachim
--
=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
Joachim Schrod Email: jschrod(a)acm.org
Roedermark, Germany