Functions in here are called with one argument JOB containing
the job which just finished.")
+;;}}}
+\f
+;;{{{ file handlers
+;; There's probably more that could be added here, but for now, just
+;; enough to get PUI working seemlessly with ffi-curl (HTTP/FTP) or
+;; EFS (FTP). --SY.
+
+;; file-exists-p
+(defun curl:file-exists-p (uri)
+ "Curl implementation of `file-exists-p'.
+
+Don't call this directly, use `file-exists-p' and give it a URI for
+the FILENAME arg. The underlying file name handlers will take care of
+calling this function.
+
+Currently only HTTP and FTP are supported, and then only if the URL ends
+in a filename. IOW you can't do \(file-exists-p \"http://example.com/\"\)"
+ (let ((lfile (expand-file-name
+ (make-temp-file "curl:") (temp-directory)))
+ (resp nil))
+ (curl:download uri lfile :header t :nobody t)
+ (with-temp-buffer
+ (insert-file-contents-literally lfile)
+ (and (re-search-forward #r"^\(HTTP/1\.1 200 OK\|Content-Length\)" nil t)
+ (setq resp t)))
+ (delete-file lfile)
+ resp))
+(put 'file-exists-p 'curl 'curl:file-exists-p)
+
+;; file-readable-p
+;; doesn't make much sense for HTTP, so just alias to file-exists-p
+(defalias 'curl:file-readable-p 'curl:file-exists-p)
+(put 'file-readable-p 'curl 'curl:file-readable-p)
+
+;; insert-file-contents-literally
+(defun curl:insert-file-contents-literally (uri &optional visit
+ start end replace)
+ "Curl implementation of `insert-file-contents-literally'.
+
+Don't call this directly, use `insert-file-contents-literally' and
+give it a URI for the FILENAME arg. The underlying file name handlers
+will take care of calling this function.
+
+Currently only HTTP and FTP are supported, and then only if the URL
+ends in a filename."
+ (let ((file-name-handler-alist nil)
+ (format-alist nil)
+ (after-insert-file-functions nil)
+ (coding-system-for-read 'binary)
+ (coding-system-for-write 'binary)
+ (find-buffer-file-type-function
+ (if (fboundp 'find-buffer-file-type)
+ (symbol-function 'find-buffer-file-type)
+ nil))
+ (lfile (expand-file-name
+ (make-temp-file "curl:") (temp-directory))))
+ (unwind-protect
+ (progn
+ (curl:download uri lfile)
+ (fset 'find-buffer-file-type (lambda (lfile) t))
+ (insert-file-contents lfile visit start end replace))
+ (if find-buffer-file-type-function
+ (fset 'find-buffer-file-type find-buffer-file-type-function)
+ (fmakunbound 'find-buffer-file-type))
+ (delete-file lfile))))
+(put 'insert-file-contents-literally
+ 'curl 'curl:insert-file-contents-literally)
+
+;;; FIXME: calling `copy-file' interactively on a URI doesn't work. The
+;;; minibuffer tries to do expansion or completion or something on the
+;;; URI before the file name handlers kick in. --SY.
+;; copy-file
+(defun curl:copy-file (uri newname &optional ok-if-already-exists
+ &rest args)
+ "Curl implementation of `copy-file'.
+
+Copy remote file, URI to local file, NEWNAME. Copying in the
+other direction, local to remote, is not supported and will result in
+an error.
+
+Signals a `file-already-exists' error if file NEWNAME already exists,
+unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.
+A number as third arg means request confirmation if NEWNAME already
+exists. This is the default for interactive use.
+
+Don't call this directly, use `copy-file' and give it a URI for
+the FILENAME arg. The underlying file name handlers will take care of
+calling this function.
+
+Currently only HTTP and FTP are supported, and then only if the URL
+ends in a filename."
+ (when (string-match #r"^\(https?\|s?ftp\)://" newname)
+ (error 'invalid-argument newname "Destination cannot be a URI"))
+ (let ((newname (expand-file-name newname))
+ doit)
+ (if (file-exists-p newname)
+ (if (or (interactive-p) (numberp ok-if-already-exists))
+ (and (y-or-n-p
+ (format "Existing file: %s Overwrite? " newname))
+ (setq doit t))
+ (if ok-if-already-exists
+ (setq doit t)
+ (error 'file-already-exists "Existing file" newname)))
+ (setq doit t))
+ (and doit (curl:download uri newname))))
+(put 'copy-file 'curl 'curl:copy-file)
+
+;; expand-file-name
+(defun curl:expand-file-name (&rest args)
+ "Return the 1st argument unchanged.
+
+Don't use this. In fact, forget that you even saw it. There is no
+way you're ever going to need to use this. It's sole purpose is to
+keep `file-exists-p' happy when that is given a URI to check. "
+ (car args))
+(put 'expand-file-name 'curl 'curl:expand-file-name)
+
+;; file-name-directory
+(defun curl:file-name-directory (uri)
+ "A curl implementation of `file-name-directory'.
+
+Returns URI without the filename.
+
+Don't call this directly, use `file-name-directory' with URI for the
+FILENAME arg. The underlying file name handlers will take care of
+calling this function.
+
+Currently only HTTP and FTP are supported, and then only if the URL
+ends in a filename."
+ (progn
+ (string-match curl:file-handler-regexp uri)
+ (substring uri (match-beginning 1) (match-end 2))))
+(put 'file-name-directory 'curl 'curl:file-name-directory)
+
+;; file-name-nondirectory
+(defun curl:file-name-nondirectory (uri)
+ "A curl implementation of `file-name-nondirectory'.
+
+Returns the filename portion of URI.
+
+Don't call this directly, use `file-name-nondirectory' with URI for the
+FILENAME arg. The underlying file name handlers will take care of
+calling this function.
+
+Currently only HTTP and FTP are supported, and then only if the URL
+ends in a filename."
+ (progn
+ (string-match curl:file-handler-regexp uri)
+ (substring uri (match-end 2))))
+(put 'file-name-nondirectory 'curl 'curl:file-name-nondirectory)
+
+;; This regexp contains trailing whitespace DO NOT REMOVE OR MANGLE
+(defregexp curl:file-handler-regexp
+ #r"\(https?://\|s?ftp://\)[^]
+ \"'()<>[^`{}]*[^]
+ \"'()<>[^`{}.,;]+\(/\)\([^/].*[^/]$\)"
+"Regexp used in `file-name-handler-alist'.
+
+It matches HTTP/FTP URLs but only if they end with a filename.
+So, for example, \"http://example.com/file.ext\" would match, but
+\"http://example.com/\" would not.")
+
+;; handler function
+(defun curl:file-handler (operation &rest args)
+ (let ((op (get operation 'curl)))
+ (if op
+ (apply op args)
+ (error 'unimplemented
+ (concat "curl:" (symbol-name operation))))))
+
+(defvar curl:file-handler
+ (cons curl:file-handler-regexp 'curl:file-handler))
+
+(unless (memq curl:file-handler file-name-handler-alist)
+ (setq file-name-handler-alist
+ (cons curl:file-handler file-name-handler-alist)))
+
;;}}}
\f
"Update the package-get database file with entries from DB-FILE.
Unless FORCE-CURRENT is non-nil never try to update the database."
(interactive
- (let ((dflt (package-get-locate-index-file nil)))
+ (let* ((dflt (package-get-locate-index-file nil))
+ (match (not (string-match #r"^\(https?\|s?ftp\)://" dflt))))
(list (read-file-name "Load package-get database: "
(file-name-directory dflt)
dflt
- t
+ match
(file-name-nondirectory dflt)))))
(setq db-file (expand-file-name (or db-file
(package-get-locate-index-file
(format "Package-get database file `%s' does not exist" db-file)))
(if (not (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" db-file)))
(let ((buf (get-buffer-create "*package database*")))
(unwind-protect
(save-excursion
(erase-buffer buf)
(insert-file-contents-literally db-file)
(package-get-update-base-from-buffer buf)
- (if (file-remote-p db-file)
+ (if (or (file-remote-p db-file)
+ (and (string-match #r"^\(https?\|s?ftp\)://" db-file)
+ package-get-have-curl))
(package-get-maybe-save-index db-file)))
(kill-buffer buf))))
(package-get-info package 'size)))
(setq full-package-filename dest-filename))
- ;; Using EFS
;; If the file exists on the remote system ...
- ((and (not package-get-have-curl)
- (file-exists-p (package-get-remote-filename
- search-dir current-filename)))
+ ((file-exists-p (package-get-remote-filename
+ search-dir current-filename))
;; Get it
(setq full-package-filename dest-filename)
(message "Retrieving package `%s' ..."
(sit-for 0)
(copy-file (package-get-remote-filename search-dir
current-filename)
- full-package-filename t))
-
- ;; Using ffi-curl
- (package-get-have-curl
- (setq full-package-filename dest-filename)
- (message "Retrieving package `%s' ..." current-filename)
- (declare-fboundp
- (curl:download (package-get-remote-filename search-dir
- current-filename)
- full-package-filename))))
+ full-package-filename t)))
;; If we found it, we're done.
(if (and full-package-filename
If (car search) is nil, (cadr search is interpreted as a local
directory)."
- (if (file-remote-p filename)
+ (if (or (file-remote-p filename)
+ (and (string-match #r"^\(https?\|s?ftp\)://" filename)
+ package-get-have-curl))
filename
(let ((site (car search))
(dir (cadr search))
projects / sxemacs / commitdiff