diff options
| author | Alan Pearce | 2013-05-18 21:39:31 +0100 |
|---|---|---|
| committer | Alan Pearce | 2013-05-18 21:39:31 +0100 |
| commit | d67bf2ed02d312a943caa11c13a65cd20ca9aba3 (patch) | |
| tree | febd20d7f684faa6896e4629e24b2f50e0850e70 /emacs/elisp/web-vcs.el | |
| parent | 98500a2e5f73f72d4b120ef98cab40f8a225d212 (diff) | |
| download | dotfiles-d67bf2ed02d312a943caa11c13a65cd20ca9aba3.tar.lz dotfiles-d67bf2ed02d312a943caa11c13a65cd20ca9aba3.tar.zst dotfiles-d67bf2ed02d312a943caa11c13a65cd20ca9aba3.zip | |
Emacs: remove unused web-vcs
Diffstat (limited to 'emacs/elisp/web-vcs.el')
| -rw-r--r-- | emacs/elisp/web-vcs.el | 2342 |
1 files changed, 0 insertions, 2342 deletions
diff --git a/emacs/elisp/web-vcs.el b/emacs/elisp/web-vcs.el deleted file mode 100644 index 1e2c322..0000000 --- a/emacs/elisp/web-vcs.el +++ /dev/null @@ -1,2342 +0,0 @@ -;;; web-vcs.el --- Download file trees from VCS web pages -;; -;; Author: Lennart Borgman (lennart O borgman A gmail O com) -;; Created: 2009-11-26 Thu -(defconst web-vcs:version "0.62") ;; Version: -;; Last-Updated: 2011-03-12 Sat -;; URL: -;; Keywords: -;; Compatibility: -;; -;; Features that might be required by this library: -;; -;; `advice', `advice-preload', `backquote', `bytecomp', `cus-edit', -;; `cus-face', `cus-load', `cus-start', `help-fns', `ietf-drums', -;; `mail-parse', `mail-prsvr', `mm-bodies', `mm-decode', -;; `mm-encode', `mm-util', `rfc2045', `rfc2047', `rfc2231', -;; `timer', `web-autoload', `wid-edit'. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Commentary: -;; -;; Update file trees within Emacs from VCS systems using information -;; on their web pages. -;; -;; Available download commands are currently: -;; -;; `web-vcs-nxhtml' -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Change log: -;; -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU General Public License as -;; published by the Free Software Foundation; either version 3, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; General Public License for more details. -;; -;; You should have received a copy of the GNU General Public License -;; along with this program; see the file COPYING. If not, write to -;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth -;; Floor, Boston, MA 02110-1301, USA. -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;;; Code: - -(eval-when-compile (require 'cl)) -(eval-when-compile (require 'compile)) -(eval-and-compile (require 'cus-edit)) -(eval-and-compile (require 'mm-decode)) -(eval-when-compile (require 'url-http)) - -(require 'advice) -(require 'web-autoload nil t) -;; (require 'url-util) -;; (require 'url) -;;(require 'url-parse) - -(defvar web-vcs-comp-dir nil) - -(defgroup web-vcs nil - "Customization group for web-vcs." - :group 'nxhtml) - -(defcustom web-vcs-links-regexp - `( - (lp-1-10 ;; Id - ;; Comment: - "http://www.launchpad.com/ uses this 2009-11-29 with Loggerhead 1.10 (generic?)" - ;; Files URL regexp: - ;; - ;; Extend this format to catch date/time too. - ;; - ;; ((patt (rx ...)) - ;; ;; use subexp numbers - ;; (url 1) - ;; (time 2) - ;; (rev 3)) - - ((time 1) - (url 2) - (patt ,(rx-to-string '(and "<td class=\"date\">" - (submatch (regexp "[^<]*")) - "</td>" - (0+ space) - "<td class=\"timedate2\">" - (regexp ".+") - "</td>" - (*? (regexp ".\\|\n")) - "href=\"" - (submatch (regexp ".*/download/[^\"]*")) - "\"")))) - ;; Dirs URL regexp: - ,(rx-to-string '(and "href=\"" - (group (regexp ".*%3A/[^\"]*/")) - "\"")) - ;; File name URL part regexp: - "\\([^\/]*\\)$" - ;; Page revision regexp: - ,(rx-to-string '(and "for revision" - (+ whitespace) - "<span>" - (submatch (+ digit)) - "</span>")) - ;; Release revision regexp: - ,(rx-to-string '(and "/" - (submatch (+ digit)) - "\"" (+ (not (any ">"))) ">" - (optional "Release ") - (+ digit) "." (+ digit) "<")) - ) - (lp ;; Id - ;; Comment: - "http://www.launchpad.com/ uses this 2010-06-26 with Loggerhead 1.17 (generic?)" - ;; Files URL regexp: - ;; - ;; Extend this format to catch date/time too. - ;; - ;; ((patt (rx ...)) - ;; ;; use subexp numbers - ;; (url 1) - ;; (time 2) - ;; (rev 3)) - ((time 1) - (url 2) - (patt ,(rx-to-string '(and "<td class=\"date\">" - (submatch - (*\? - (not (any "<")))) - "</td>" - (*? anything) - "<a href=\"" - (submatch "/~nxhtml/nxhtml/main/download/" - (* - (not (any "\""))) - ) - "\" title=\"Download" - ) - ))) - ;; Dirs URL regexp: - ,(rx-to-string '(and "<td class=\"autcell\"><a href=\"" - (submatch (+? nonl) - "/files/head:/" - (+? (not (any "\"")))) - "\">") - ;;(and "href=\"" (group (regexp ".*%3A/[^\"]*/")) "\"") - ) - ;; File name URL part regexp: - "\\([^\/]*\\)$" - ;; Page revision regexp: - ,(rx-to-string '(and "for revision" - (+ whitespace) - "<span>" - (submatch (+ digit)) - "</span>")) - ;; Release revision regexp: - ,(rx-to-string '(and "/" - (submatch (+ digit)) - "\"" (+ (not (any ">"))) ">" - (optional "Release ") - (+ digit) "." (+ digit) "<")) - ) - ) - "Regexp patterns for matching links on a VCS web page. -The patterns are grouped by VCS web system type. - -\\<mozadd-mirror-mode-map> -To make a new pattern you can do like this: - -- Open the file in Firefox. -- View the buffer source in Emacs in some way. -- Turn on `mozadd-mirror-mode'. -- Use the command `mozadd-init-href-patten'. -- Then start `re-builder' to refine the pattern. - (Or, use isearch if you prefer that.) -- Use `ourcomments-copy-target-region-to-reb' for - easy copying from target buffer to re-builder. -- To see what you patterns matches in the web page - use `M-x mozadd-update-mozilla'. -- If the page looks terrible then add a <base href=...> - tag by doing `M-x mozadd-add-href-base'. - -*Note: It is always sub match 1 from these patterns that are - used." - :type '(repeat - (list - (symbol :tag "VCS web system type specifier") - (string :tag "Description") - (set (list (const time) integer) - (list (const url) integer) - (list (const patt) regexp)) - ;;(regexp :tag "Files URL regexp") - (regexp :tag "Dirs URL regexp") - (regexp :tag "File name URL part regexp") - (regexp :tag "Page revision regexp") - (regexp :tag "Release revision regexp") - )) - :group 'web-vcs) - -(defface web-vcs-mode-line - '((t (:foreground "black" :background "OrangeRed"))) - "Mode line face during download." - :group 'web-vcs) - -(defface web-vcs-mode-line-inactive - '((t (:foreground "black" :background "Orange"))) - "Mode line face during download." - :group 'web-vcs) - -(defface web-vcs-gold - '((t (:foreground "black" :background "gold"))) - "Face for web-vcs messages." - :group 'web-vcs) - -(defface web-vcs-red - '((t (:foreground "black" :background "#f86"))) - "Face for web-vcs messages." - :group 'web-vcs) - -(defface web-vcs-green - '((t (:foreground "black" :background "#8f6"))) - "Face for web-vcs messages." - :group 'web-vcs) - -(defface web-vcs-yellow - '((t (:foreground "black" :background "yellow"))) - "Face for web-vcs messages." - :group 'web-vcs) - -(defface web-vcs-pink - '((t (:foreground "black" :background "pink"))) - "Face for web-vcs messages." - :group 'web-vcs) - -(defcustom web-vcs-default-download-directory - "~/.emacs.d/" - "Default download directory." - :type '(choice (const :tag "~/.emacs.d/" "~/.emacs.d/") - (const :tag "Fist site-lisp in `load-path'" site-lisp-dir) - (const :tag "Directory where `site-run-file' lives" site-run-dir) - (string :tag "Specify directory")) - :group 'web-vcs) - -;;(web-vcs-default-download-directory) -;;;###autoload -(defun web-vcs-default-download-directory () - "Try to find a suitable place. -Use the choice in `web-vcs-default-download-directory'. -If this does not fit fall back to \"~/.emacs.d/\"." - (let* ((site-run-dir (when site-run-file - (let ((lib (locate-library site-run-file))) - (when lib - (file-name-directory lib))))) - (site-lisp-dir (catch 'first-site-lisp - (dolist (d load-path) - (let ((dir (file-name-nondirectory (directory-file-name d)))) - (when (string= dir "site-lisp") - (throw 'first-site-lisp (file-name-as-directory d))))))) - (dummy (message "site-run-dir=%S site-lisp-dir=%S" site-run-dir site-lisp-dir)) - (dir (or (case web-vcs-default-download-directory - ;;('~/.emacs.d/ "~/.emacs.d/") - ('site-lisp-dir site-lisp-dir) - ('site-run-dir site-run-dir)) - web-vcs-default-download-directory))) - (or dir "~/.emacs.d/"))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Logging - -(defcustom web-vcs-log-file "~/.emacs.d/web-vcs-log.org" - "Log file for web-vcs." - :type 'file - :group 'web-vcs) - -;;;###autoload -(defun web-vcs-log-edit () - "Open log file." - (interactive) - (find-file web-vcs-log-file)) - -(defvar web-vcs-log-save-timer nil) - -(defun web-vcs-log-save-when-idle () - (when (timerp web-vcs-log-save-timer) (cancel-timer web-vcs-log-save-timer)) - (run-with-idle-timer 0 nil 'web-vcs-log-save)) - -(defun web-vcs-log-save () - (let ((log-buf (find-buffer-visiting web-vcs-log-file))) - (when (and log-buf (buffer-modified-p log-buf)) - (with-current-buffer log-buf - (basic-save-buffer))) - log-buf)) - -(defun web-vcs-log-close () - (let ((log-buf (web-vcs-log-save))) - (when log-buf - (kill-buffer log-buf)))) - -;; Fix-me: Add some package descriptor to log -(defun web-vcs-log (url dl-file msg) - (unless (file-exists-p web-vcs-log-file) - (let ((dir (file-name-directory web-vcs-log-file))) - (unless (file-directory-p dir) - (make-directory dir)))) - (with-current-buffer (find-file-noselect web-vcs-log-file) - (setq buffer-save-without-query t) - (web-vcs-log-save-when-idle) - (save-restriction - (widen) - (let ((today-entries (format-time-string "* %Y-%m-%d")) - (now (format-time-string "%H:%M:%S GMT" nil t))) - (goto-char (point-max)) - (unless (re-search-backward (concat "^" today-entries) nil t) - (goto-char (point-max)) - (insert "\n" today-entries "\n")) - (goto-char (point-max)) - (when url - (insert "** Downloading file " now "\n" - (format " file [[file:%s][%s]]\n from %s\n" dl-file dl-file url) - )) - (cond - ((stringp msg) - (goto-char (point-max)) - (insert msg "\n")) - (msg (basic-save-buffer))))))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Finding and downloading files - -;;;###autoload -(defun web-vcs-get-files-from-root (web-vcs full-url dl-dir) - "Download a file tree from VCS system using the web interface. -Use WEB-VCS entry in variable `web-vcs-links-regexp' to download -files via http from FULL-URL to directory DL-DIR. - -Show FULL-URL first and offer to visit the page. That page will -give you information about version control system \(VCS) system -used etc." - (unless (web-vcs-contains-moved-files dl-dir) - (let ((resize-mini-windows (or resize-mini-windows t))) - (when (if (not (y-or-n-p (concat "Download files from \"" full-url "\".\n" - "You can see on that page which files will be downloaded.\n\n" - "Visit that page before downloading? "))) - t - (browse-url full-url) - (if (y-or-n-p "Start downloading? ") - t - (message "Aborted") - nil)) - (message "") - (web-vcs-get-files-on-page web-vcs full-url t (file-name-as-directory dl-dir) nil) - t)))) - -(defun web-vcs-get-files-on-page (web-vcs page-url recursive dl-dir test) - "Download files listed by WEB-VCS on web page PAGE-URL. -WEB-VCS is a specifier in `web-vcs-links-regexp'. - -If RECURSIVE go into sub folders on the web page and download -files from them too. - -Place the files under DL-DIR. - -Before downloading check if the downloaded revision already is -the same as the one on the web page. This is stored in the file -web-vcs-revision.txt. After downloading update this file. - -If TEST is non-nil then do not download, just list the files." - (unless (string= dl-dir (file-name-as-directory (expand-file-name dl-dir))) - (error "Download dir dl-dir=%S must be a full directory path" dl-dir)) - (catch 'command-level - (when (web-vcs-contains-moved-files dl-dir) - (throw 'command-level nil)) - (let ((vcs-rec (or (assq web-vcs web-vcs-links-regexp) - (error "Does not know web-cvs %S" web-vcs))) - (start-time (current-time))) - (unless (file-directory-p dl-dir) - (if (yes-or-no-p (format "Directory %S does not exist, create it? " - (file-name-as-directory - (expand-file-name dl-dir)))) - (make-directory dl-dir t) - (message "Can't download then") - (throw 'command-level nil))) - ;; (let ((old-win (selected-window))) - ;; (unless (eq (get-buffer "*Messages*") (window-buffer old-win)) - ;; (switch-to-buffer-other-window "*Messages*")) - ;; (goto-char (point-max)) - ;; (insert "\n") - ;; (insert (propertize (format "\n\nWeb-Vcs Download: %S\n" page-url) 'face 'web-vcs-gold)) - ;; (insert "\n") - ;; (redisplay t) - ;; (set-window-point (selected-window) (point-max)) - ;; (select-window old-win)) - (web-vcs-message-with-face 'web-vcs-gold "\n\nWeb-Vcs Download: %S\n" page-url) - (web-vcs-display-messages nil) - (let* ((rev-file (expand-file-name "web-vcs-revision.txt" dl-dir)) - (rev-buf (find-file-noselect rev-file)) - ;; Fix-me: Per web vcs speficier. - (old-rev-range (with-current-buffer rev-buf - (widen) - (goto-char (point-min)) - (when (re-search-forward (format "%s:\\(.*\\)\n" web-vcs) nil t) - ;;(buffer-substring-no-properties (point-min) (line-end-position)) - ;;(match-string 1) - (cons (match-beginning 1) (match-end 1)) - ))) - (old-revision (when old-rev-range - (with-current-buffer rev-buf - (buffer-substring-no-properties (car old-rev-range) - (cdr old-rev-range))))) - (dl-revision (web-vcs-get-revision-on-page vcs-rec page-url)) - ret - moved) - (when (and old-revision (string= old-revision dl-revision)) - (when (y-or-n-p (format "You already have revision %s. Quit? " dl-revision)) - (message "Aborted") - (kill-buffer rev-buf) - (throw 'command-level nil))) - ;; We do not have a revision number once we start download. - (with-current-buffer rev-buf - (when old-rev-range - (delete-region (car old-rev-range) (cdr old-rev-range)) - (basic-save-buffer))) - (setq ret (web-vcs-get-files-on-page-1 - vcs-rec page-url - dl-dir - "" - nil - (if recursive 0 nil) - dl-revision - test - 0)) - (setq moved (nth 1 ret)) - ;; Now we have a revision number again. - (with-current-buffer rev-buf - (when (= 0 (buffer-size)) - (insert "WEB VCS Revisions\n\n")) - (goto-char (point-max)) - (unless (eolp) (insert "\n")) - (insert (format "%s:%s\n" web-vcs dl-revision)) - (basic-save-buffer) - (kill-buffer)) - (message "-----------------") - (web-vcs-message-with-face 'web-vcs-gold "Web-Vcs Download Ready: %S" page-url) - (web-vcs-message-with-face 'web-vcs-gold " Time elapsed: %S" - (web-vcs-nice-elapsed start-time (current-time))) - (when (> moved 0) - (web-vcs-message-with-face 'web-vcs-yellow - " %i files updated (old versions renamed to *.moved)" - moved)))))) - -(defun web-vcs-get-files-on-page-1 (vcs-rec page-url dl-root dl-relative file-mask recursive dl-revision test num-files) - "Download files listed by VCS-REC on web page page-URL. -VCS-REC should be an entry like the entries in the list -`web-vcs-links-regexp'. - -If FILE-MASK is non-nil then it is used to match a file relative -path. Only matching files will be downloaded. FILE-MASK can -have two forms, a regular expression or a function. - -If FILE-MASK is a regular expression then each part of the path -may be a regular expresion \(not containing /). - -If FILE-MASK is a function then this function is called in each -directory under DL-ROOT. The function is called with the -directory as a parameter and should return a cons. The first -element of the cons should be a regular expression matching file -names in that directory that should be downloaded. The cdr -should be t if subdirectories should be visited. - -If RECURSIVE go into sub folders on the web page and download -files from them too. - -Place the files under DL-DIR. - -The revision on the page page-URL should match DL-REVISION if this is non-nil. - -If TEST is non-nil then do not download, just list the files" - ;;(web-vcs-message-with-face 'font-lock-comment-face "web-vcs-get-files-on-page-1 %S %S %S %S" page-url dl-root dl-relative file-mask) - (let* ((files-matcher (nth 2 vcs-rec)) - (dirs-href-regexp (nth 3 vcs-rec)) - (revision-regexp (nth 5 vcs-rec)) - ;; (setq x (url-generic-parse-url "http://somewhere.com/file/path.el")) - ;; (setq x (url-generic-parse-url "http://somewhere.com")) - ;; (setq x (url-generic-parse-url "/somewhere.com")) - ;; (url-type x) - ;; (url-host x) - ;; (url-filename x) - ;; (url-fullness x) - ;; (url-port x) - ;; (setq y (url-expand-file-name "/suburl/other.el" x)) - ;; (setq y (url-expand-file-name "http://other.com/suburl/other.el" x)) - ;;(page-urlobj (url-generic-parse-url page-url)) - ;;(page-url-fullness (or (url-fullness page-urlobj) (error "Incomplete URL: %S" page-url))) - ;;(page-url-host (url-host page-urlobj)) - ;;(page-url-type (url-type page-urlobj)) - ;;(page-url-file (url-filename page-urlobj)) - ;;(page-host-url (concat page-url-type "://" page-url-host)) - (dl-dir (file-name-as-directory (expand-file-name dl-relative dl-root))) - (lst-dl-relative (web-vcs-file-name-as-list dl-relative)) - (lst-file-mask (when (stringp file-mask) (web-vcs-file-name-as-list file-mask))) - ;;(url-buf (url-retrieve-synchronously page-url)) - this-page-revision - files - suburls - (moved 0) - (temp-file-base (expand-file-name "web-vcs-temp-list.tmp" dl-dir)) - temp-list-file - temp-list-buf - folder-res - http-sts) - ;; Fix-me: It looks like there is maybe a bug in url-copy-file so - ;; that it runs synchronously. Try to workaround the problem by - ;; making a new file temp file name. - (web-vcs-display-messages nil) - (unless (file-directory-p dl-dir) (make-directory dl-dir t)) - ;;(message "TRACE: dl-dir=%S" dl-dir) - (setq temp-list-file (make-temp-name temp-file-base)) - (setq temp-list-buf (web-vcs-ass-folder-cache page-url)) - (unless temp-list-buf - ;;(setq temp-list-buf (generate-new-buffer "web-wcs-folder")) - ;;(web-vcs-url-copy-file-and-check page-url temp-list-file nil) - (let ((ready nil)) - (while (not ready) - (setq folder-res (web-vcs-url-retrieve-synch page-url)) - ;; (with-current-buffer temp-list-buf - ;; (insert-file-contents temp-list-file)) - (if (memq (cdr folder-res) '(200 201)) - (setq ready t) - (web-vcs-message-with-face 'web-vcs-red "Could not get %S" page-url) - (web-vcs-display-messages t) - (when (y-or-n-p (format "Could not get %S, visit page to see what is wrong? " page-url)) - (browse-url page-url)) - (unless (y-or-n-p "Try again? (It is safe to break here and try again later.) ") - (throw 'command-level nil)))))) - ;;(with-current-buffer temp-list-buf - (with-current-buffer (car folder-res) - ;;(delete-file temp-list-file) - ;;(find-file-noselect temp-list-file) - (when dl-revision - (setq this-page-revision (web-vcs-get-revision-from-url-buf vcs-rec (current-buffer) page-url))) - (when dl-revision - (unless (string= dl-revision this-page-revision) - (web-vcs-message-with-face 'web-vcs-red "Revision on %S is %S, but should be %S" - page-url this-page-revision dl-revision) - (web-vcs-display-messages t) - (throw 'command-level nil))) - ;; Find files - (goto-char (point-min)) - (let ((files-href-regexp (nth 1 (assq 'patt files-matcher))) - (url-num (nth 1 (assq 'url files-matcher))) - (time-num (nth 1 (assq 'time files-matcher)))) - (while (re-search-forward files-href-regexp nil t) - ;; Fix-me: What happened to full url??? - (let* ((file (match-string url-num)) - (time (match-string time-num)) - (full-file (url-expand-file-name file page-url))) - (add-to-list 'files (list full-file time))))) - (when (< (length files) num-files) - (message "files-on-page-1: found %d files, expected %d" (length files) num-files)) - ;; Find subdirs - (when recursive - (goto-char (point-min)) - (while (re-search-forward dirs-href-regexp nil t) - (let* ((suburl (match-string 1)) - (lenurl (length page-url)) - (full-suburl (url-expand-file-name suburl page-url))) - ;;(message "suburl=%S" suburl) - (when (and (> (length full-suburl) lenurl) - (string= (substring full-suburl 0 lenurl) page-url)) - ;;(message "...added") - (add-to-list 'suburls full-suburl))))) - (kill-buffer)) - ;; Download files - ;;(message "TRACE: files=%S" files) - (web-vcs-download-files vcs-rec files dl-dir dl-root) - ;; Download subdirs - (when suburls - (dolist (suburl (reverse suburls)) - (let* ((dl-sub-dir (substring suburl (length page-url))) - (full-dl-sub-dir (file-name-as-directory - (expand-file-name dl-sub-dir dl-dir))) - (rel-dl-sub-dir (file-relative-name full-dl-sub-dir dl-root))) - ;;(message "web-vcs-get-revision-from-url-buf dir: %S %S" file-mask rel-dl-sub-dir) - (when (or (not file-mask) - (not (stringp file-mask)) - (= 1 (length (web-vcs-file-name-as-list file-mask))) - (web-vcs-match-folderwise file-mask rel-dl-sub-dir)) - ;;(message "matched dir %S" rel-dl-sub-dir) - (unless (web-vcs-contains-file dl-dir full-dl-sub-dir) - (error "Subdir %S not in %S" dl-sub-dir dl-dir)) - (let* ((ret (web-vcs-get-files-on-page-1 vcs-rec - suburl - dl-root - rel-dl-sub-dir - file-mask - (1+ recursive) - this-page-revision - test - 0))) - (setq moved (+ moved (nth 1 ret)))))))) - (list this-page-revision moved))) - -(defun web-vcs-get-missing-matching-files (web-vcs url dl-dir file-mask num-files) - "Download missing files from VCS system using the web interface. -Use WEB-VCS entry in variable `web-vcs-links-regexp' to download -files via http from URL to directory DL-DIR. - -FILE-MASK is used to match files that should be downloaded. See -`web-vcs-get-files-on-page-1' for more information. - -Before downloading offer to visit the page from which the -downloading will be made. -" - (unless file-mask (error "file-mask is nil")) - (let ((vcs-rec (or (assq web-vcs web-vcs-links-regexp) - (error "Does not know web-cvs %S" web-vcs)))) - (web-vcs-get-files-on-page-1 vcs-rec url dl-dir "" file-mask 0 nil nil num-files))) - - -;; (web-vcs-get-files-on-page 'lp "http://bazaar.launchpad.net/%7Enxhtml/nxhtml/main/files/head%3A/" t "c:/test/temp13/" t) - -(defvar web-vcs-folder-cache nil) ;; dyn var -(defun web-vcs-add-folder-cache (url buf) - (add-to-list 'web-vcs-folder-cache (list url buf))) -(defun web-vcs-ass-folder-cache (url) - (assoc url web-vcs-folder-cache)) -(defun web-vcs-clear-folder-cache () - (while web-vcs-folder-cache - (let ((ub (car web-vcs-folder-cache))) - (setq web-vcs-folder-cache (cdr web-vcs-folder-cache)) - (kill-buffer (nth 1 ub))))) - -(defun web-vcs-url-copy-file-and-check (file-url dl-file dest-file) - "Copy FILE-URL to DL-FILE. -Log what happened. Use DEST-FILE in the log, not DL-FILE which is -a temporary file." - (let ((http-sts nil) - (file-nonempty nil) - (fail-reason nil)) - (when dest-file (web-vcs-log file-url dest-file nil)) - (web-vcs-display-messages nil) - ;;(message "before url-copy-file %S" dl-file) - (setq http-sts (web-vcs-url-copy-file file-url dl-file nil t)) ;; don't overwrite, keep time - ;;(message "after url-copy-file %S" dl-file) - (if (and (file-exists-p dl-file) - (setq file-nonempty (< 0 (nth 7 (file-attributes dl-file)))) ;; file size 0 - (memq http-sts '(200 201))) - (when dest-file - (web-vcs-log nil nil " Done.\n")) - (setq fail-reason - (cond - (http-sts (format "HTTP %s" http-sts)) - (file-nonempty "File looks bad") - (t "Server did not respond"))) - (unless dest-file (web-vcs-log file-url dl-file "TEMP FILE")) - (web-vcs-log nil nil (format " *Failed:* %s\n" fail-reason)) - ;; Requires user attention and intervention - (web-vcs-message-with-face 'web-vcs-red "Download failed: %s, %S" fail-reason file-url) - (web-vcs-display-messages t) - (when (y-or-n-p (format "Vist page %S to see what is wrong? " file-url)) - (browse-url file-url)) - (message "\n") - (web-vcs-message-with-face 'web-vcs-yellow "Please retry what you did before!\n") - (throw 'command-level nil)))) - -(defvar web-autoload-temp-file-prefix "TEMPORARY-WEB-AUTO-LOAD-") -(defvar web-autoload-active-file-sub-url) ;; Dyn var, active during file download check -(defun web-autoload-acvtive () - (and (boundp 'web-autoload-active-file-sub-url) - web-autoload-active-file-sub-url)) - -(defun web-vcs-download-files (vcs-rec files dl-dir dl-root) - (dolist (file (reverse files)) - (let* ((url-file (nth 0 file)) - (url-file-time-str (nth 1 file)) - ;; date-to-time assumes GMT so this is ok: - (url-file-time (when url-file-time-str (date-to-time url-file-time-str))) - (url-file-name-regexp (nth 4 vcs-rec)) - (url-file-rel-name (progn - (when (string-match url-file-name-regexp url-file) - (match-string 1 url-file)))) - (dl-file-name (expand-file-name url-file-rel-name dl-dir)) - (dl-file-time (nth 5 (file-attributes dl-file-name))) - (file-rel-name (file-relative-name dl-file-name dl-root)) - (file-name (file-name-nondirectory dl-file-name)) - (temp-file (expand-file-name (concat web-autoload-temp-file-prefix file-name) dl-dir)) - temp-buf) - (cond - ;;((and file-mask (not (web-vcs-match-folderwise file-mask file-rel-name)))) - ((and dl-file-time - url-file-time - (progn - ;;(message "dl-file-time =%s" (when dl-file-time (current-time-string dl-file-time))) - ;;(message "url-file-time=%s" (when url-file-time (current-time-string url-file-time))) - ;;(message "url-file-tstr=%s" (when url-file-time url-file-time-str)) - t) - (time-less-p url-file-time - (time-add dl-file-time (seconds-to-time 1)))) - (web-vcs-message-with-face 'web-vcs-green "Local file %s is newer or same age" file-rel-name)) - ;;(test (progn (message "TEST url-file=%S" url-file) (message "TEST url-file-rel-name=%S" url-file-rel-name) (message "TEST dl-file-name=%S" dl-file-name) )) - (t - ;; Avoid trouble with temp file - (while (setq temp-buf (find-buffer-visiting temp-file)) - (set-buffer-modified-p nil) (kill-buffer temp-buf)) - (when (file-exists-p temp-file) (delete-file temp-file)) - ;;(web-vcs-message-with-face 'font-lock-comment-face "Starting url-copy-file %S %S t t" url-file temp-file) - (web-vcs-url-copy-file-and-check url-file temp-file dl-file-name) - ;;(web-vcs-message-with-face 'font-lock-comment-face "Finished url-copy-file %S %S t t" url-file temp-file) - (let* ((time-after-url-copy (current-time)) - (old-buf-open (find-buffer-visiting dl-file-name))) - (when (and old-buf-open (buffer-modified-p old-buf-open)) - (save-excursion - (switch-to-buffer old-buf-open) - (when (y-or-n-p (format "Buffer %S is modified, save to make a backup? " dl-file-name)) - (save-buffer)))) - (if (and dl-file-time (web-vcs-equal-files dl-file-name temp-file)) - (progn - (delete-file temp-file) - (when url-file-time (set-file-times dl-file-name url-file-time)) - (web-vcs-message-with-face 'web-vcs-green "File %S was ok" dl-file-name)) - (when dl-file-time - (let ((backup (concat dl-file-name ".moved"))) - (rename-file dl-file-name backup t))) - ;; Be paranoid and let user check here. I actually - ;; believe that is a very good thing here. - (web-vcs-be-paranoid temp-file dl-file-name file-rel-name) - (rename-file temp-file dl-file-name) - (when url-file-time (set-file-times dl-file-name url-file-time)) - ;; (let ((buf (find-buffer-visiting dl-file-name))) - ;; (when buf - ;; (with-current-buffer buf - ;; (message "before revert-buffer") - ;; (revert-buffer nil t t) - ;; (message "after revert-buffer") - ;; ))) - (if dl-file-time - (web-vcs-message-with-face 'web-vcs-yellow "Updated %S" dl-file-name) - (web-vcs-message-with-face 'web-vcs-green "Downloaded %S" dl-file-name)) - (when old-buf-open - (with-current-buffer old-buf-open - (set-buffer-modified-p nil) - (revert-buffer nil t t))) - (with-current-buffer (find-file-noselect dl-file-name) - (setq header-line-format - (propertize (format-time-string "This file was downloaded %Y-%m-%d %H:%M") - 'face 'web-vcs-green)))) - (web-vcs-display-messages nil) - ;; This is both for user and remote server load. Do not remove this. - (redisplay t) (sit-for (- 1.0 (float-time (time-subtract (current-time) time-after-url-copy)))) - ;; (unless old-buf-open - ;; (when old-buf - ;; (kill-buffer old-buf))) - ))) - (redisplay t)))) - -(defun web-vcs-get-revision-on-page (vcs-rec url) - "Get revision number using VCS-REC on page URL. -VCS-REC should be an entry like the entries in the list -`web-vcs-links-regexp'." - ;; url-insert-file-contents - (let ((url-buf (url-retrieve-synchronously url))) - (web-vcs-get-revision-from-url-buf vcs-rec url-buf url))) - -(defun web-vcs-get-revision-from-url-buf (vcs-rec url-buf rev-page-url) - "Get revision number using VCS-REC. -VCS-REC should be an entry in the list `web-vcs-links-regexp'. -The buffer URL-BUF should contain the content on page -REV-PAGE-URL." - (let ((revision-regexp (nth 5 vcs-rec))) - ;; Get revision number - (with-current-buffer url-buf - (goto-char (point-min)) - (if (not (re-search-forward revision-regexp nil t)) - (progn - (web-vcs-message-with-face 'web-vcs-red "Can't find revision number on %S" rev-page-url) - (web-vcs-display-messages t) - (when (y-or-n-p (format "Coult not find rev no on %S, visit page to see what is wrong? " rev-page-url)) - (browse-url rev-page-url)) - (throw 'command-level nil)) - (match-string 1))))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Auto Download - - -;; fix-me: To emulation-mode-map -;; Fix-me: put this on better keys -(defvar web-vcs-paranoid-state-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [(control ?c)(control ?c)] 'exit-recursive-edit) - (define-key map [(control ?c)(control ?n)] 'web-autoload-continue-no-stop) - (define-key map [(control ?c)(control ?r)] 'web-vcs-investigate-elisp-file) - (define-key map [(control ?c)(control ?q)] 'web-vcs-quit-auto-download) - map)) - -(defun web-vcs-quit-auto-download () - "Quit download process. -This stops the current web autoload processing." - (interactive) - ;; Fix-me. - (when (y-or-n-p "Stop web autoload processing? You can resume it later. ") - (web-vcs-message-with-face 'web-vcs-red - "Stopped autoloading in process. It will be resumed when necessary again.") - (web-vcs-log nil nil "User stopped autoloading") - (throw 'top-level 'web-autoload-stop))) - -(define-minor-mode web-vcs-paranoid-state-mode - "Mode used temporarily during user check of downloaded file. -Do not turn on this yourself." - :lighter (concat " " (propertize "Download file check" 'face 'font-lock-warning-face)) - :global t - :group 'web-vcs - (or (not web-vcs-paranoid-state-mode) - (web-autoload-acvtive) - (error "This mode can't be used when not downloading"))) - -(defcustom web-autoload-paranoid t - "Be paranoid and break to check each file after download." - :type 'boolean - :group 'web-vcs) - -(defun web-autoload-continue-no-stop () - "Continue web auto download. -This is used after inspecting downloaded elisp files. Set -`web-autoload-paranoid' to nil before contiuning to avoid further -breaks to check downloaded files." - (interactive) - (setq web-autoload-paranoid nil) - (web-autoload-continue)) - -(defun web-autoload-continue () - "Continue web auto download. -This is used after inspecting downloaded elisp files." - (interactive) - (if (< 0 (recursion-depth)) - (exit-recursive-edit) - (web-autoload-byte-compile-queue))) - -(defun web-vcs-be-paranoid (temp-file file-dl-name file-sub-url) - "Be paranoid and check FILE-DL-NAME." - (when (or (not (boundp 'web-autoload-paranoid)) - web-autoload-paranoid) - (save-window-excursion - (let* ((comp-buf (get-buffer "*Compilation*")) - (comp-win (and comp-buf - (get-buffer-window comp-buf))) - (msg-win (web-vcs-display-messages nil)) - temp-buf - (kf-desc (lambda (fun) - (let* ((key (where-is-internal fun nil t)) - (k-desc (when key (key-description key))) - (fmt-kf "\n %s (or %s)") - (fmt-f "\n %s")) - (if key - (format fmt-kf k-desc fun) - (format fmt-f fun) - ))))) - (if comp-win - (progn - (select-window comp-win) - (find-file file-dl-name)) - (select-window msg-win) - (find-file-other-window temp-file)) - (setq temp-buf (current-buffer)) - (web-vcs-log-save) - (message "-") - (message "") - (with-selected-window msg-win - (goto-char (point-max))) - (let ((proceed nil) - (web-autoload-active-file-sub-url file-sub-url) ;; Dyn var, active during file download check - (ws (with-current-buffer "*Messages*" (point-marker)))) - (web-vcs-paranoid-state-mode 1) - (web-vcs-message-with-face - 'secondary-selection - (concat "Please check the downloaded file and then continue by doing" - (funcall kf-desc 'exit-recursive-edit) - (if (fboundp 'web-autoload-continue-no-stop) - (concat - "\n\nOr, for no more breaks to check files do" - (funcall kf-desc 'web-autoload-continue-no-stop)) - "") - "\n\nTo stop the web autoloading process for now do" - (funcall kf-desc 'web-autoload-quit-download) - "\n\nTo see the log file you can do" - (funcall kf-desc 'web-vcs-log-edit) - "\n")) - (message "") - (let ((msg-win (car (get-buffer-window-list "*Messages*" nil nil)))) - (when msg-win (set-window-start msg-win ws))) - (while (not proceed) - (condition-case err - (when (eq 'web-autoload-stop - (catch 'top-level - ;; Fix-me: review file before rename! - (setq header-line-format - (propertize - (format "Review for downloading. Continue: C-c C-c%s. Destination: %S" - (if (string= "el" (file-name-extension file-dl-name)) - ", Check: C-c C-r" - "") - file-dl-name) - 'face 'web-vcs-red)) - (unwind-protect - (progn - (recursive-edit)) - (web-vcs-paranoid-state-mode -1)) - (with-current-buffer temp-buf - (set-buffer-modified-p nil) - (kill-buffer temp-buf)) - (setq proceed t))) - (throw 'top-level t)) - (error (message "%s" (error-message-string err)))))) - (web-vcs-display-messages t) - )))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Auto Download Compile Queue -;; -;; Downloaded elisp files are placed in a compile queue. They are not -;; compiled until all required elisp files are downloaded (and -;; optionally compiled). -;; -;; This mechanism works through -;; - reading (eval-when-compile ...) etc in the files -;; - a defadviced require that is the driver of the process - -(defvar web-autoload-compile-queue nil) - -(defvar web-autoload-byte-compile-queue-active nil) ;; Dyn var - -(defun web-autoload-byte-compile-file (file load comp-fun) - (if nil ;;(file-exists-p file) - (byte-compile-file file load) - (let ((added-entry (list file load comp-fun nil))) - (if (member added-entry web-autoload-compile-queue) - (setq added-entry nil) - (web-vcs-message-with-face 'web-vcs-gold "Add to compile queue (%S %s)" file load) - (setq web-autoload-compile-queue (cons added-entry - web-autoload-compile-queue))) - (when added-entry - (if web-autoload-byte-compile-queue-active - (throw 'web-autoload-comp-restart t) - (web-autoload-byte-compile-queue)))))) - -;;(web-autoload-byte-compile-queue) -(defun web-autoload-byte-compile-queue () - (let ((top-entry) - (web-autoload-byte-compile-queue-active t)) - (while (and web-autoload-compile-queue - (not (equal top-entry - (car web-autoload-compile-queue)))) - (setq top-entry (car web-autoload-compile-queue)) - (catch 'web-autoload-comp-restart - (web-autoload-byte-compile-first) - (setq web-autoload-compile-queue (cdr web-autoload-compile-queue)))))) - -(defun web-autoload-byte-compile-first () - "Compile first file on compile queue and maybe load it. -Compile the car of `web-autoload-compile-queue' and load if this -entry says so." - (let* ((compiled-it nil) - (first-entry (car web-autoload-compile-queue)) - (el-file (nth 0 first-entry)) - (load (nth 1 first-entry)) - (comp-fun (nth 2 first-entry)) - (req-done (nth 3 first-entry)) - (elc-file (byte-compile-dest-file el-file)) - (need-compile (or (not (file-exists-p elc-file)) - (file-newer-than-file-p el-file elc-file)))) - (if (not need-compile) - nil ;;(when load (load elc-file)) - (unless req-done - (web-autoload-do-eval-requires el-file) - (setcar (nthcdr 3 first-entry) t)) - (when (catch 'web-autoload-comp-restart - (condition-case err - (progn - (web-vcs-message-with-face 'font-lock-comment-face "Start byte compiling %S" el-file) - (web-vcs-message-with-face 'web-vcs-pink "Compiling QUEUE: %S" web-autoload-compile-queue) - (let ((web-autoload-skip-require-advice t)) (funcall comp-fun el-file load)) - (web-vcs-message-with-face 'font-lock-comment-face "Ready byte compiling %S" el-file) - ;; Return nil to tell there are no known problems - (if (file-exists-p elc-file) - nil - (web-vcs-message-with-face - 'web-vcs-red "Error: byte compiling did not produce %S" elc-file) - (web-vcs-display-messages nil) - ;; Clean up before restart - (web-autoload-try-cleanup-after-failed-compile first-entry) - t)) - (error - (web-vcs-message-with-face - 'web-vcs-red "Error in byte compiling %S: %s" el-file (error-message-string err)) - (web-vcs-display-messages nil) - ;; Clean up before restart - (web-autoload-try-cleanup-after-failed-compile first-entry) - t ;; error - ))) - (throw 'web-autoload-comp-restart t) - )))) - -(defun web-autoload-do-eval-requires (el-file) - "Do eval-when-compile and eval-and-compile." - ;;(message "web-autoload-do-eval-requires %S" el-file) - (let ((old-buf (find-buffer-visiting el-file))) - (with-current-buffer (or old-buf (find-file-noselect el-file)) - (let ((here (point)) - (web-autoload-require-skip-noerror-entries t)) - (save-restriction - (widen) - (goto-char (point-min)) - ;;(message "web-autoload-do-eval-requires cb=%s" (current-buffer)) - (while (progn - (while (progn (skip-chars-forward " \t\n\^l") - (looking-at ";")) - (forward-line 1)) - (not (eobp))) - (let ((form (read (current-buffer)))) - (when (memq (car form) '(eval-when-compile eval-and-compile)) - (web-vcs-message-with-face 'web-vcs-gold " eval %S" form) - (eval form)) - ))) - (if old-buf (kill-buffer) (goto-char here)))))) - - -;; Fix-me: protect against deep nesting -(defun web-autoload-do-require (feature filename noerror) - (let* ((feat-name (symbol-name feature)) - (lib (or filename feat-name))) - (if (load lib noerror t) - (progn - (unless (featurep feature) - (error "web-autoload: Required feature `%s' was not provided" feature)) - feature) - nil - ))) - -(defvar web-autoload-require-skip-noerror-entries nil) - -(defadvice require (around - web-autoload-ad-require) - (let ((feature (ad-get-arg 0)) - (filename (ad-get-arg 1)) - (noerror (ad-get-arg 2))) - (if (featurep feature) - feature - (if (or filename - (and noerror - (or (not (boundp 'web-autoload-skip-require-advice)) - web-autoload-skip-require-advice))) - (progn - (message "Doing nearly original require %s, because skipping" (ad-get-arg 0)) - ;; Can't ad-do-it because defadviced functions in load - ;;(web-autoload-do-require feature filename noerror) - ;; - ;; Fix-me: Implement lazy loading here? Could it be done with while-no-input? - ;; - ;;(when (assq feature web-autoload-require-list) ) - ad-do-it) - (unless (and noerror - web-autoload-require-skip-noerror-entries) - (let* ((auto-rec (assq feature web-autoload-require-list)) - (web-vcs (nth 1 auto-rec)) - (base-url (nth 2 auto-rec)) - (relative-url (nth 3 auto-rec)) - (base-dir (nth 4 auto-rec)) - (comp-fun (nth 5 auto-rec))) - (if (not auto-rec) - ad-do-it - (let* ((full-el (concat (expand-file-name relative-url base-dir) ".el")) - (full-elc (byte-compile-dest-file full-el)) - (our-buffer (current-buffer)) ;; Need to come back here - (our-wcfg (current-window-configuration)) - (mode-line-old (web-vcs-redefine-face 'mode-line 'web-vcs-mode-line)) - (mode-line-inactive-old (web-vcs-redefine-face 'mode-line-inactive 'web-vcs-mode-line-inactive)) - (header-line-format-old (with-current-buffer "*Messages*" - (prog1 - header-line-format - (setq header-line-format - (propertize "Downloading needed files..." - 'face 'web-vcs-mode-line - ;;'face '(:height 1.5) ;; does not work - )))))) - ;; Fix-me: can't update while accessing the menus - ;;(message "trying (redisplay t) ;; mode line") - ;;(sit-for 1) (redisplay t) ;; mode line - (unwind-protect - (progn - (web-vcs-message-with-face 'web-vcs-gold "Doing the really adviced require for %s" feature) - ;; Check if already downloaded first - (unless (file-exists-p full-el) - (setq base-url (eval base-url)) - ;; Download and try again - (setq relative-url (concat relative-url ".el")) - (web-vcs-message-with-face 'web-vcs-green "Need to download feature '%s" feature) - (catch 'web-autoload-comp-restart - (web-vcs-get-missing-matching-files web-vcs base-url base-dir relative-url))) - (set-buffer our-buffer) ;; Before we load.. - (when web-autoload-autocompile - (unless (file-exists-p full-elc) - ;; Byte compile the downloaded file - (web-autoload-byte-compile-file full-el t comp-fun))) - (web-vcs-message-with-face 'web-vcs-gold "Doing finally require for %s" feature) - (set-buffer our-buffer) ;; ... and after we load - (set-window-configuration our-wcfg)) - (with-current-buffer "*Messages*" (setq header-line-format header-line-format-old)) - (web-vcs-redefine-face 'mode-line mode-line-old) - (web-vcs-redefine-face 'mode-line-inactive mode-line-inactive-old))) - ad-do-it))))))) - -;; (setq x (web-vcs-redefine-face 'mode-line (setq z (face-all-attributes 'web-vcs-mode-line (selected-frame))))) -;; (setq x (web-vcs-redefine-face 'mode-line 'web-vcs-mode-line)) -;; (setq y (web-vcs-redefine-face 'mode-line x)) -;; (describe-face 'web-vcs-mode-line) -(defun web-vcs-redefine-face (face as-new) - "Redefine FACE to use the attributes in AS-NEW. -AS-NEW may be either a face or a list returned by `face-all-attributes'. -Return an alist with old attributes." - (let ((ret (face-all-attributes face (selected-frame))) - (new-face-att (if (facep as-new) - (face-all-attributes as-new (selected-frame)) - as-new)) - new-at-prop-list - ) - (dolist (at new-face-att) - (let ((sym (car at)) - (val (cdr at))) - (unless (eq val 'unspecified) - (setq new-at-prop-list (cons sym - (cons val - new-at-prop-list))) - ;;(message "new=%S" new-at-prop-list) - ))) - (apply 'set-face-attribute face (selected-frame) new-at-prop-list) - ret - )) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Web Autoload Define - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Helpers - -;;(web-vcs-file-name-as-list "/a/b/c.el") -;;(web-vcs-file-name-as-list "a/b/c.el") -;;(web-vcs-file-name-as-list "c:/a/b/c.el") -;;(web-vcs-file-name-as-list ".*/a/c/") -;;(web-vcs-file-name-as-list "[^/]*/a/c/") ;; Just avoid this. -;;(web-vcs-file-name-as-list "\\(?:\\.\\.?\\|README\\.txt\\(?:\\.moved\\)?\\|a\\(?:lts\\|utostart\\(?:\\.elc?\\|22\\.elc?\\)\\)\\|e\\(?:macs22\\.cmd\\|tc\\)\\|nxhtml\\(?:-\\(?:base\\.elc?\\|loaddefs\\.el\\(?:\\.moved\\|c\\)?\\|web-vcs\\.el\\(?:\\.moved\\|c\\)?\\)\\|maint\\.elc?\\)?\\|related\\|tests\\|util\\|web-\\(?:autoload\\.elc?\\|vcs\\.el\\(?:\\.moved\\|c\\)?\\)\\)") - -(defun web-vcs-file-name-as-list (filename) - "Split file name FILENAME into a list with file names." - ;; We can't use the primitives since they converts \ to / and - ;; therefore damages the reg exps. Just use our knowledge of the - ;; internal file name representation instead. - (split-string filename "/")) -;; (let ((lst-name nil) -;; (head filename) -;; (old-head "")) -;; (while (and (not (string= old-head head)) -;; (> (length head) 0)) -;; (let* ((file-head (directory-file-name head)) -;; (tail (file-name-nondirectory (directory-file-name head)))) -;; (setq old-head head) -;; (setq head (file-name-directory file-head)) -;; ;; For an abs path the final tail is "", use root instead: -;; (when (= 0 (length tail)) -;; (setq tail head)) -;; (setq lst-name (cons tail lst-name)))) -;; lst-name)) - -;;(web-vcs-match-folderwise ".*/util/mum.el" "top/util/mum.el") -;;(web-vcs-match-folderwise ".*/util/mu.el" "top/util/mum.el") -;;(web-vcs-match-folderwise ".*/ut/mum.el" "top/util/mum.el") -;;(web-vcs-match-folderwise ".*/ut../mum.el" "top/util/mum.el") -;;(web-vcs-match-folderwise ".*/ut../mum.el" "top/util") -;;(web-vcs-match-folderwise ".*/ut../mum.el" "top") -;;(web-vcs-match-folderwise "top/ut../mum.el" "top") -(defun web-vcs-match-folderwise (regex file) - "Split REGEXP as a file path and match against FILE parts." - ;;(message "folderwise %S %S" regex file) - (let ((lst-regex (web-vcs-file-name-as-list regex)) - (lst-file (web-vcs-file-name-as-list file))) - ;; Called from web-vcs-download-files for tree? - (when (= 1 (length lst-regex)) - (setq lst-file (last lst-file)) - (message "lst-file => %S" lst-file) - ) - (when (>= (length lst-regex) (length lst-file)) - (catch 'match - (while lst-file - (let ((head-file (car lst-file)) - (head-regex (car lst-regex))) - (unless (or (= 0 (length head-file)) ;; Last /, if present, gives "" - (string-match-p (concat "^" head-regex "$") head-file)) - (throw 'match nil))) - (setq lst-file (cdr lst-file)) - (setq lst-regex (cdr lst-regex))) - t)))) - -(defun web-vcs-contains-file (dir file) - "Return t if DIR contain FILE." - (assert (string= dir (file-name-as-directory (expand-file-name dir))) t) - (assert (or (string= file (file-name-as-directory (expand-file-name file))) - (string= file (expand-file-name file))) t) - (let ((dir-len (length dir))) - (assert (string= "/" (substring dir (1- dir-len)))) - (when (> (length file) dir-len) - (string= dir (substring file 0 dir-len))))) - -(defun web-vcs-nice-elapsed (start-time end-time) - "Format elapsed time between START-TIME and END-TIME nicely. -Those times should have the same format as time returned by -`current-time'." - (format-seconds "%h h %m m %z%s s" (float-time (time-subtract end-time start-time)))) - -;; (web-vcs-equal-files "web-vcs.el" "temp.tmp") -;; (web-vcs-equal-files "../.nosearch" "temp.tmp") -(defun web-vcs-equal-files (file-a file-b) - "Return t if files FILE-A and FILE-B are equal." - (let* ((cmd (if (eq system-type 'windows-nt) - (list "fc" nil nil nil - "/B" "/OFF" - (convert-standard-filename file-a) - (convert-standard-filename file-b)) - (list diff-command nil nil nil - "--binary" "-q" file-a file-b))) - (ret (apply 'call-process cmd))) - ;;(message "ret=%s, cmd=%S" ret cmd) (sit-for 2) - (cond - ((= 1 ret) - nil) - ((= 0 ret) - t) - (t - (error "%S returned %d" cmd ret))))) - -(defun web-vcs-display-messages (select) - "Display *Messages* buffer. Select its window if SELECT." - (let ((msg-win (display-buffer "*Messages*"))) - (with-selected-window msg-win (goto-char (point-max))) - (when select (select-window msg-win)) - msg-win)) - -;; (web-vcs-message-with-face 'secondary-selection "I am saying: %s and %s" "Hi" "Farwell!") -;;;###autoload -(defun web-vcs-message-with-face (face format-string &rest args) - "Display a colored message at the bottom of the string. -FACE is the face to use for the message. -FORMAT-STRING and ARGS are the same as for `message'. - -Also put FACE on the message in *Messages* buffer." - (with-current-buffer "*Messages*" - (save-restriction - (widen) - (let* ((start (let ((here (point))) - (goto-char (point-max)) - (prog1 - (copy-marker - (if (bolp) (point-max) - (1+ (point-max)))) - (goto-char here)))) - (msg-with-face (propertize (apply 'format format-string args) - 'face face))) - ;; This is for the echo area: - (message "%s" msg-with-face) - ;; This is for the buffer: - (when (< 0 (length msg-with-face)) - (goto-char (1- (point-max))) - ;;(backward-char) - ;;(unless (eolp) (goto-char (line-end-position))) - (put-text-property start (point) - 'face face)))))) - -(defun web-vcs-num-moved (root) - "Return nof files matching *.moved inside directory ROOT." - (let* ((file-regexp ".*\\.moved$") - (files (directory-files root t file-regexp)) - (subdirs (directory-files root t))) - (dolist (subdir subdirs) - (when (and (file-directory-p subdir) - (not (or (string= "/." (substring subdir -2)) - (string= "/.." (substring subdir -3))))) - (setq files (append files (web-vcs-rdir-get-files subdir file-regexp) nil)))) - (length files))) - -;; Copy of rdir-get-files in ourcomment-util.el -(defun web-vcs-rdir-get-files (root file-regexp) - (let ((files (directory-files root t file-regexp)) - (subdirs (directory-files root t))) - (dolist (subdir subdirs) - (when (and (file-directory-p subdir) - (not (or (string= "/." (substring subdir -2)) - (string= "/.." (substring subdir -3))))) - (setq files (append files (web-vcs-rdir-get-files subdir file-regexp) nil)))) - files)) - -(defun web-vcs-contains-moved-files (dl-dir) - "Return t if there are *.moved files in DL-DIR." - (let ((num-moved (web-vcs-num-moved dl-dir))) - (when (> num-moved 0) - (web-vcs-message-with-face 'font-lock-warning-face - (concat "There are %d *.moved files (probably from prev download)\n" - "in %S.\nPlease delete them first.") - num-moved dl-dir) - t))) - - -(defun web-vcs-set&save-option (symbol value) - (customize-set-variable symbol value) - (customize-set-value symbol value) - (when (condition-case nil (custom-file) (error nil)) - (customize-mark-to-save symbol) - (custom-save-all) - (message "web-vcs: Saved option %s with value %s" symbol value))) - -(defvar web-vcs-el-this (or load-file-name - (when (boundp 'bytecomp-filename) bytecomp-filename) - buffer-file-name)) - - -(require 'bytecomp) -(defun web-vcs-byte-compile-newer-file (el-file load) - (let ((elc-file (byte-compile-dest-file el-file))) - (when (or (not (file-exists-p elc-file)) - (file-newer-than-file-p el-file elc-file)) - (byte-compile-file el-file load)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Compiling - -;;;###autoload -(defun web-vcs-byte-compile-file (file &optional load extra-load-path comp-dir) - "Byte compile FILE in a new Emacs sub process. -EXTRA-LOAD-PATH is added to the front of `load-path' during -compilation. - -FILE is set to `buffer-file-name' when called interactively. -If LOAD" - (interactive (list (buffer-file-name) - t)) - (when (with-no-warnings (called-interactively-p)) - (unless (eq major-mode 'emacs-lisp-mode) - (error "Must be in emacs-lisp-mode"))) - (let* ((old-env-load-path (getenv "EMACSLOADPATH")) - (sub-env-load-path (or old-env-load-path - ;;(mapconcat 'identity load-path ";"))) - (mapconcat 'identity load-path path-separator))) - ;; Fix-me: name of compile log buffer. When should it be - ;; deleted? How do I bind it to byte-compile-file? Or do I? - (file-buf (find-buffer-visiting file)) - (old-out-buf (get-buffer "*Compile-Log*")) - (default-directory (or (when old-out-buf - (with-current-buffer old-out-buf - default-directory)) - comp-dir - (and (boundp 'nxhtml-install-dir) nxhtml-install-dir) - default-directory)) - (out-buf (or old-out-buf (get-buffer-create "*Compile-Log*"))) - (elc-file (byte-compile-dest-file file)) - (this-emacs-exe (locate-file invocation-name - (list invocation-directory) - exec-suffixes)) - (debug-on-error t) - start) - ;; (when (and file-buf - ;; (buffer-modified-p file-buf)) - ;; (switch-to-buffer file-buf) - ;; (error "Buffer must be saved first: %S" file-buf)) - (dolist (full-p extra-load-path) - ;;(setq sub-env-load-path (concat full-p ";" sub-env-load-path))) - (setq sub-env-load-path (concat full-p path-separator sub-env-load-path))) - (unless (get-buffer-window out-buf (selected-frame)) - (if (string= file (buffer-file-name)) - (display-buffer out-buf) - (unless (eq (current-buffer) out-buf) - (switch-to-buffer out-buf)))) - (with-selected-window (get-buffer-window out-buf) - (with-current-buffer out-buf - (unless (local-variable-p 'web-vcs-comp-dir) - (set (make-local-variable 'web-vcs-comp-dir) (or comp-dir default-directory))) - (setq default-directory web-vcs-comp-dir) - (widen) - (goto-char (point-max)) - (when (or (= 0 (buffer-size)) - (not (derived-mode-p 'compilation-mode))) - (insert (propertize "\nWeb VCS compilation output" 'font-lock-face 'font-lock-comment-face)) - (compilation-mode) - (setq font-lock-verbose nil) - (font-lock-add-keywords nil - '(("\\<Compile\\>" . 'compilation-info)))) - (let ((inhibit-read-only t) - (rel-file (file-relative-name file))) - (insert "\n\n") - (insert "** Compile " rel-file "\n")) - (setq start (point)) - (when (file-exists-p elc-file) (delete-file elc-file)) - (if (or (not window-system) - (< emacs-major-version 23)) - (byte-compile-file file) - ;;(message "web-vcs-byte-compile-file:sub-env-load-path=%s" sub-env-load-path) - (unless (file-exists-p this-emacs-exe) - (error "Can't find this-emacs-exe=%s" this-emacs-exe)) - (unless (stringp sub-env-load-path) (error "I did it again, sub-env-load-path=%S" sub-env-load-path)) - (setenv "EMACSLOADPATH" sub-env-load-path) - ;; Fix-me: status - (let* ((inhibit-read-only t) - (ret (apply 'call-process this-emacs-exe nil out-buf t - "-Q" "--batch" - "--eval" "(setq debug-on-error t)" - "--eval" "(remove-hook 'find-file-hook 'vc-find-file-hook)" - "--file" file - "-f" "emacs-lisp-byte-compile" - nil))) - ;;(insert (format "call-process returned: %s\n" ret)) - ) - (setenv "EMACSLOADPATH" old-env-load-path)) - (goto-char start) - (while (re-search-forward "^\\([a-zA-Z0-9/\._-]+\\):[0-9]+:[0-9]+:" nil t) - (let ((rel-file (file-relative-name file)) - (inhibit-read-only t)) - (replace-match rel-file nil nil nil 1))) - (goto-char (point-max)))) - (when (file-exists-p elc-file) - (when (and load window-system) (load elc-file)) - t))) - - -;;;;;;;;;;;;;;;;;;;;;;;; -;;; Temporary helpers, possibly included in Emacs - -;; Fix-me: Doing (require 'url-http) in the functions below led to -;; that url-show-status is void. So I require it here instead. -;;(require 'url-http) - -;; (setq x (web-vcs-url-retrieve-synch "http://emacswiki.org/")) -;;;###autoload -(defun web-vcs-url-retrieve-synch (url) - "Retrieve URL, return cons with buffer and http status." - (require 'url-http) - (let* ((url-show-status nil) ;; just annoying showing status here - (buffer (url-retrieve-synchronously url)) - (handle nil) - (http-status nil)) - (if (not buffer) - (error "Retrieving url %s gave no buffer" url)) - (with-current-buffer buffer - (if (= 0 (buffer-size)) - (progn - (kill-buffer) - nil) - (setq http-status (url-http-parse-response)) - (if (memq http-status '(200 201)) - (progn - (goto-char (point-min)) - (unless (search-forward "\n\n" nil t) - (error "Could not find header end in buffer for %s" url)) - (delete-region (point-min) (point)) - (set-buffer-modified-p nil) - (goto-char (point-min))) - (kill-buffer buffer) - (setq buffer nil)))) - (cons buffer http-status))) - -;; Modified just to return http status -;;;###autoload -(defun web-vcs-url-copy-file (url newname &optional ok-if-already-exists - keep-time preserve-uid-gid) - "Copy URL to NEWNAME. Both args must be strings. -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 what happens in interactive use with M-x. -Fourth arg KEEP-TIME non-nil means give the new file the same -last-modified time as the old one. (This works on only some systems.) -Fifth arg PRESERVE-UID-GID is ignored. -A prefix arg makes KEEP-TIME non-nil." - (if (and (file-exists-p newname) - (not ok-if-already-exists)) - (error "Opening output file: File already exists, %s" newname)) - (require 'url-http) - (let ((buffer (url-retrieve-synchronously url)) - (handle nil) - (ret nil)) - (if (not buffer) - (error "Retrieving url %s gave no buffer" url)) - (with-current-buffer buffer - (if (= 0 (buffer-size)) - (progn - (kill-buffer) - nil) - (setq ret (url-http-parse-response)) - (setq handle (mm-dissect-buffer t)) - (mm-save-part-to-file handle newname) - (kill-buffer buffer) - (mm-destroy-parts handle))) - ret)) - -(defun web-vcs-read-and-accept-key (prompt accepted &optional reject-message help-function) - (let ((key nil) - rejected - (resize-mini-windows (or resize-mini-windows t))) - (while (not (member key accepted)) - (if (and help-function - (or (member key help-event-list) - (eq key ??))) - (funcall help-function) - (unless rejected - (setq rejected t) - (setq prompt (concat (or reject-message "Please answer with one of the alternatives.") - "\n\n" - prompt)) - (setq key (web-vcs-read-key prompt))))) - key)) - -(defconst web-vcs-read-key-empty-map (make-sparse-keymap)) - -(defvar web-vcs-read-key-delay 0.01) ;Fast enough for 100Hz repeat rate, hopefully. - -(defun web-vcs-read-key (&optional prompt) - "Read a key from the keyboard. -Contrary to `read-event' this will not return a raw event but instead will -obey the input decoding and translations usually done by `read-key-sequence'. -So escape sequences and keyboard encoding are taken into account. -When there's an ambiguity because the key looks like the prefix of -some sort of escape sequence, the ambiguity is resolved via `web-vcs-read-key-delay'." - (let ((overriding-terminal-local-map web-vcs-read-key-empty-map) - (overriding-local-map nil) - (old-global-map (current-global-map)) - (timer (run-with-idle-timer - ;; Wait long enough that Emacs has the time to receive and - ;; process all the raw events associated with the single-key. - ;; But don't wait too long, or the user may find the delay - ;; annoying (or keep hitting more keys which may then get - ;; lost or misinterpreted). - ;; This is only relevant for keys which Emacs perceives as - ;; "prefixes", such as C-x (because of the C-x 8 map in - ;; key-translate-table and the C-x @ map in function-key-map) - ;; or ESC (because of terminal escape sequences in - ;; input-decode-map). - web-vcs-read-key-delay t - (lambda () - (let ((keys (this-command-keys-vector))) - (unless (zerop (length keys)) - ;; `keys' is non-empty, so the user has hit at least - ;; one key; there's no point waiting any longer, even - ;; though read-key-sequence thinks we should wait - ;; for more input to decide how to interpret the - ;; current input. - (throw 'read-key keys))))))) - (unwind-protect - (progn - (use-global-map web-vcs-read-key-empty-map) - (message (concat (apply 'propertize prompt (member 'face minibuffer-prompt-properties)) - (propertize " " 'face 'cursor))) - (aref (catch 'read-key (read-key-sequence-vector nil nil t)) 0)) - (cancel-timer timer) - (use-global-map old-global-map)))) - -;; End temp helpers -;;;;;;;;;;;;;;;;;;;;;;;; - -;;(web-vcs-existing-files-matcher default-directory) -(defun web-vcs-existing-files-matcher (dir) - (let ((files-and-dirs (directory-files dir nil "[^#~]$")) - files - (default-directory dir)) - (dolist (df files-and-dirs) - (unless (file-directory-p df) - (setq files (cons df files)))) - (cons (regexp-opt files) t))) - -(defun web-vcs-update-existing-files (vcs base-url dl-dir this-dir) - (let ((files-and-dirs (directory-files this-dir nil "\\(?:\\.elc\\|\\.moved\\|[^#~]\\)$")) - files - dirs - (this-rel (file-relative-name this-dir dl-dir)) - file-mask) - (when (string= "./" this-rel) (setq this-rel "")) - (dolist (df files-and-dirs) - (if (and (file-directory-p df) - (not (member df '("." "..")))) - (setq dirs (cons df dirs)) - (setq files (cons df files)))) - ;;(web-vcs-message-with-face 'hi-blue "this-rel=%S %S %S" this-rel dl-dir this-dir) - (setq file-mask (concat this-rel (regexp-opt files))) - ;;(web-vcs-message-with-face 'hi-blue "r=%S" file-mask) - (web-vcs-get-missing-matching-files vcs base-url dl-dir file-mask (length files)) - (dolist (d dirs) - (web-vcs-update-existing-files vcs base-url dl-dir - (file-name-as-directory - (expand-file-name d this-dir)))))) - - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Some small bits for security and just overview. - -(defun web-vcs-fontify-as-ps-print() - (save-restriction - (widen) - (let ((start (point-min)) - (end (point-max))) - (cond ((and (boundp 'jit-lock-mode) (symbol-value 'jit-lock-mode)) - (jit-lock-fontify-now start end)) - ;; ((and (boundp 'lazy-lock-mode) (symbol-value 'lazy-lock-mode)) - ;; (lazy-lock-fontify-region start end)) - )))) - - -;;(web-vcs-get-fun-details 'describe-function) -;;(web-vcs-get-fun-details 'require) -;;(describe-function 'describe-function) -(defun web-vcs-get-fun-details (function) - (unless (symbolp function) (error "Not a symbol: %s" function)) - (unless (functionp function) (error "Not a function: %s" function)) - ;; Do as in `describe-function': - (let* ((advised (and (symbolp function) (featurep 'advice) - (ad-get-advice-info function))) - ;; If the function is advised, use the symbol that has the - ;; real definition, if that symbol is already set up. - (real-function - (or (and advised - (let ((origname (cdr (assq 'origname advised)))) - (and (fboundp origname) origname))) - function)) - ;; Get the real definition. - (def (if (symbolp real-function) - (symbol-function real-function) - function)) - errtype file-name (beg "") string) - ;; Just keep this as it is to more easily compare with `describe-function-1'. - (setq string - (cond ((or (stringp def) - (vectorp def)) - "a keyboard macro") - ((subrp def) - (if (eq 'unevalled (cdr (subr-arity def))) - (concat beg "special form") - (concat beg "built-in function"))) - ((byte-code-function-p def) - (concat beg "compiled Lisp function")) - ((symbolp def) - (while (and (fboundp def) - (symbolp (symbol-function def))) - (setq def (symbol-function def))) - ;; Handle (defalias 'foo 'bar), where bar is undefined. - (or (fboundp def) (setq errtype 'alias)) - (format "an alias for `%s'" def)) - ((eq (car-safe def) 'lambda) - (concat beg "Lisp function")) - ((eq (car-safe def) 'macro) - "a Lisp macro") - ((eq (car-safe def) 'autoload) - ;;(setq file-name-auto (nth 1 def)) - ;;(setq file-name-auto (find-lisp-object-file-name function def)) - ;;(setq file-auto-noext (file-name-sans-extension file-name-auto)) - (format "%s autoloaded %s" - (if (commandp def) "an interactive" "an") - (if (eq (nth 4 def) 'keymap) "keymap" - (if (nth 4 def) "Lisp macro" "Lisp function")))) - ((keymapp def) - (let ((is-full nil) - (elts (cdr-safe def))) - (while elts - (if (char-table-p (car-safe elts)) - (setq is-full t - elts nil)) - (setq elts (cdr-safe elts))) - (if is-full - "a full keymap" - "a sparse keymap"))) - (t ""))) - (setq file-name (find-lisp-object-file-name function def)) - (list errtype advised file-name string) - )) - -;; (setq next-error-function 'web-vcs-investigate-next-error) -;; fix-me: -;; (defvar web-vcs-investigate-header-str "Found these possible problems when reading the file:\n") -;; (defun web-vcs-investigate-next-error (argp reset) -;; (interactive "p") -;; ;; Search from within the investigate output buffer -;; (with-current-buffer -;; ;; Choose the buffer and make it current. -;; (if (next-error-buffer-p (current-buffer)) -;; (current-buffer) -;; (next-error-find-buffer nil nil -;; (lambda () -;; (let ((here (point))) -;; (save-restriction -;; (widen) -;; (goto-char (point-min)) -;; (string= (buffer-substring-no-properties -;; 0 (length web-vcs-investigate-header-str)) -;; web-vcs-investigate-header-str)))))) - -;; (goto-char (cond (reset (point-min)) -;; ((< argp 0) (line-beginning-position)) -;; ((> argp 0) (line-end-position)) -;; ((point)))) -;; (occur-find-match -;; (abs argp) -;; (if (> 0 argp) -;; #'previous-single-property-change -;; #'next-single-property-change) -;; "No more matches") -;; ;; In case the *Occur* buffer is visible in a nonselected window. -;; (let ((win (get-buffer-window (current-buffer) t))) -;; (if win (set-window-point win (point)))) -;; (occur-mode-goto-occurrence))) - -;;(web-vcs-investigate-read "c:/emacsw32/nxhtml/nxhtml/nxhtml-autoload.el" "*Messages*") -(defun web-vcs-investigate-read (elisp out-buf) - "Check forms in buffer by reading it." - (let* ((here (point)) - unsafe-eval re-fun re-var - elisp-el-file - (is-same-file (lambda (file) - (when file - (setq file (concat (file-name-sans-extension file) ".el")) - (string= (file-truename file) elisp-el-file))))) - (with-current-buffer elisp - (setq elisp-el-file (when (buffer-file-name) - (file-truename (buffer-file-name)))) - (save-restriction - (widen) - (web-vcs-fontify-as-ps-print) - (goto-char (point-min)) - (while (progn - (while (progn (skip-chars-forward " \t\n\^l") - (looking-at ";")) - (forward-line 1)) - (not (eobp))) - (let* ((pos (point)) - (form (read (current-buffer))) - (def (nth 0 form)) - (sym (and (listp form) - (symbolp (nth 1 form)) - (nth 1 form))) - (form-fun (and sym - (functionp sym) - (symbol-function sym))) - (form-var (boundp sym)) - (safe-forms '( declare-function - defun defmacro defsubst - define-minor-mode define-globalized-minor-mode - defvar defconst - defcustom - defface defgroup - ;; fix-me: check if these do re-fun too: - define-derived-mode - define-global-minor-mode - define-globalized-minor-mode - - make-local-variable make-variable-buffer-local - provide - require - message)) - (safe-eval (or (memq def safe-forms) - (and (memq def '( eval-when-compile eval-and-compile)) - (or (not (consp (nth 1 form))) - (memq (car (nth 1 form)) safe-forms))))) - ) - (cond - ((not safe-eval) - (setq unsafe-eval - (cons (list form (copy-marker pos) (buffer-substring pos (point))) - unsafe-eval))) - ((and form-fun - (memq def '( defun defmacro define-minor-mode define-globalized-minor-mode))) - (setq re-fun (cons (cons sym pos) re-fun))) - ((and form-var - (memq def '( defvar defconst defcustom)) - (or (not (eq sym 'defvar)) - (< 2 (length form)))) - (setq re-var (cons sym re-var))))))) - (goto-char here)) - (with-current-buffer out-buf - (save-restriction - (widen) - (goto-char (point-max)) - (unless (bobp) (insert "\n\n")) - (insert (propertize "Found these possible problems when reading the file:\n" - 'font-lock-face '(:height 1.5))) - (or unsafe-eval - re-fun - (insert "\n" - "Found no problems (but there may still be)" - "\n")) - - ;; Fix-me: Link - (when unsafe-eval - (insert "\n" - (propertize - (format "* Forms that are executed when loading the file (found %s):" - (length unsafe-eval)) - 'font-lock-face '(:background "yellow" :height 1.2)) - "\n\n") - (dolist (u (reverse unsafe-eval)) - (insert (format "Line %s\n" - (with-current-buffer elisp - (line-number-at-pos (marker-position (nth 1 u)))))) - ;; (insert-text-button (format "Go to form below, line %s" (marker-position (nth 1 u))) - ;; 'font-lock-face '(compilation-info underline) - ;; 'action - ;; `(lambda (button) - ;; (let* ((marker ,(nth 1 u)) - ;; (buf (marker-buffer marker))) - ;; (switch-to-buffer-other-window buf) - ;; (unless (and (< marker (point-max)) - ;; (> marker (point-min))) - ;; (widen)) - ;; (goto-char marker)))) - (insert (nth 2 u) "\n\n")) - (insert "\n")) - (when re-fun - (insert (propertize - (format "\n* The file perhaps redefines these functions that are defined now (%s):\n" - (length re-fun)) - 'font-lock-face '(:background "yellow" :height 1.2))) - (setq re-fun (sort re-fun (lambda (a b) (string< (symbol-name (car a)) (symbol-name (car b)))))) - (let ((row 0) - (re-fun-with-info (mapcar (lambda (fun) - (cons fun (web-vcs-get-fun-details (car fun)))) - re-fun)) - re-fun-other-files - (n-same 0) - (n-web-auto 0)) - ;; Check same file - (dolist (info re-fun-with-info) - (let* ((file-name (nth 3 info)) - (fun (car (nth 0 info))) - (web-auto (get fun 'web-autoload))) - (cond ((funcall is-same-file file-name) - (setq n-same (1+ n-same))) - (web-auto - (setq n-web-auto (1+ n-web-auto)) - (setq re-fun-other-files (cons info re-fun-other-files))) - (t - (setq re-fun-other-files (cons info re-fun-other-files)))))) - - (when (< 0 n-same) - (insert "\n " - (propertize (format "%s functions alreay defined by this file (which seems ok)" n-same) - 'font-lock-face 'web-vcs-green) - "\n")) - - (dolist (info re-fun-other-files) - (let* ((fun-rec (nth 0 info)) - (errtype (nth 1 info)) - (advised (nth 2 info)) - (file-name (nth 3 info)) - (string (nth 4 info)) - (fun (car fun-rec)) - (fun-pos (cdr fun-rec)) - (fun-web-auto (get fun 'web-autoload)) - ) - (when (= 0 (% row 5)) (insert "\n")) - (setq row (1+ row)) - (insert " `") - (insert-text-button (format "%s" fun) - 'action - `(lambda (button) - (describe-function ',fun))) - (insert "'") - (insert " (" string) - (when fun-web-auto - (insert " autoloaded from web, ") - (insert-text-button "info" - 'action - `(lambda (button) - ;; Fix-me: maybe a bit more informative ... ;-) - (message "%S" ',fun-web-auto)))) - (insert ")") - (when advised (insert ", " (propertize "adviced" 'font-lock-face 'font-lock-warning-face))) - (insert ", " - (cond - ((funcall is-same-file file-name) - (propertize "defined in this file" 'font-lock-face 'web-vcs-green) - ) - (fun-web-auto - (if (not (web-autoload-acvtive)) - (propertize "web download not active" 'font-lock-face 'web-vcs-yellow) - ;; See if file matches - (let ((active-sub-url web-autoload-active-file-sub-url) - (fun-sub-url (nth 2 fun-web-auto))) - (setq active-sub-url (file-name-sans-extension active-sub-url)) - (if (string-match-p fun-sub-url active-sub-url) - (propertize "web download, matches" 'font-lock-face 'web-vcs-yellow) - (propertize "web download, doesn't matches" 'font-lock-face 'web-vcs-red) - )))) - (t - (propertize "defined in other file" 'font-lock-face 'web-vcs-red)))) - (unless (funcall is-same-file file-name) - (insert " (") - (insert-text-button "go to new definition" - 'action - `(lambda (button) - (interactive) - (let ((m-pos ,(with-current-buffer elisp - (copy-marker fun-pos)))) - (switch-to-buffer-other-window (marker-buffer m-pos)) - (goto-char m-pos)))) - (insert ")")) - (insert "\n") - ))))) - (web-vcs-investigate-output-mode) - ))) - -(defvar web-vcs-investigate-current-file nil) -(make-variable-buffer-local 'web-vcs-investigate-current-file) -(put 'web-vcs-investigate-current-file 'permanent-local t) - -(defun web-vcs-investigate-current-file () - `(,web-vcs-investigate-current-file)) - -;; (defun web-vcs-investigate-fontification-fun (bound) -;; ;;(compilation-error-properties (file line end-line col end-col type fmt) -;; (while (re-search-forward "^Line \\([0-9]+\\)$" bound t) -;; (put-text-property (match-beginning 1) (match-end 1) -;; 'face 'highlight) -;; (let ((line (string-to-number (match-string-no-properties 1)))) -;; (compilation-error-properties 'web-vcs-investigate-current-file line line nil nil nil nil)) -;; ) -;; nil) - - -;; (defvar web-vcs-investigate-output-font-lock-keywords -;; ;; '(("^\\*\\*\\* \\(.+\\.el\\): \\([^ \n]+\\)" -;; ;; '(("^\\*\\*\\* \\(.+\\.el\\): \\([^ \n]+\\)" -;; ;; (1 font-lock-function-name-face) -;; ;; (2 font-lock-comment-face))) -;; ;; "Keywords used to highlight a checkdoc diagnostic buffer.") -;; nil) -;; ;;'(("^\\(Line\\) \\([0-9]+\\)$" 1 2))) -;; ;;'(web-vcs-investigate-fontification-fun)) - -(defvar web-vcs-investigate-output-error-regex-alist - '( - ("^Line \\([0-9]+\\)$" web-vcs-investigate-current-file 1 - ;; column type - nil 1) - ;; Fix-me: This is just a terrible hack making the hit into a - ;; compilation error point with # as the link and the rest as the - ;; action for that line. And it even does not work... - Only the - ;; first line becomes an error line. No idea why at the moment. - ("\\(#\\)Eval the file with all" web-vcs-investigate-current-file nil nil nil 1) - ("\\(#\\)Eval the file with just" web-vcs-investigate-current-file nil nil nil 1) - ("\\(#\\)Eval the file with no" web-vcs-investigate-current-file nil nil nil 1) - )) - -;; (defvar checkdoc-pending-errors nil -;; "Non-nil when there are errors that have not been displayed yet.") - -(define-compilation-mode web-vcs-investigate-output-mode "Investigate Elisp" - "Set up the major mode for the buffer containing the list of errors." - (set (make-local-variable 'compilation-error-regexp-alist) - web-vcs-investigate-output-error-regex-alist) - ;;(set (make-local-variable 'compilation-error-face) grep-hit-face) - ;; (set (make-local-variable 'compilation-mode-font-lock-keywords) - ;; web-vcs-investigate-output-font-lock-keywords) - ) - -;; I am quite tired of doing this over and over again. Why is this not -;; in Emacs? -(defvar web-vcs-button-mode-map - (let ((map (make-sparse-keymap))) - (define-key map [tab] 'forward-button) - (define-key map [(shift tab)] 'backward-button) - map)) -(define-minor-mode web-vcs-button-mode - "Just to bind `forward-button' etc" - :lighter nil) - -(defvar web-vcs-eval-output-start nil) -(make-variable-buffer-local 'web-vcs-eval-output-start) -(defvar web-vcs-eval-output-end nil) -(make-variable-buffer-local 'web-vcs-eval-output-end) - -;;(web-vcs-investigate-elisp-file) -;;;###autoload -(defun web-vcs-investigate-elisp-file (file-or-buffer) - (interactive (list - (if (derived-mode-p 'emacs-lisp-mode) - (current-buffer) - (read-file-name "Elisp file to check: ")))) - (let* ((elisp (if (bufferp file-or-buffer) - file-or-buffer - (find-file-noselect file-or-buffer))) - (elisp-file (with-current-buffer elisp (buffer-file-name))) - (out-buf-name "Web VCS Sec Inv") - (out-buf (let ((old-buf (get-buffer out-buf-name))) - (when old-buf (kill-buffer old-buf)) - (get-buffer-create out-buf-name)))) - (if (not (with-current-buffer elisp (derived-mode-p 'emacs-lisp-mode))) - (progn - (unless (eq (current-buffer) elisp) - (display-buffer elisp)) - (message "Buffer %s is not in emacs-lisp-mode" (buffer-name elisp))) - (switch-to-buffer-other-window out-buf) - (setq web-vcs-investigate-current-file elisp-file) - (let ((inhibit-read-only t)) - (erase-buffer) - (setq buffer-read-only t) - (web-vcs-button-mode 1) - (insert (propertize "A quick look for problems" 'font-lock-face '(:height 1.5))) - (let ((here (point))) - (insert - "\n" - (propertize - (concat "Note that this is just a quick look at the file." - " You have to investigate the file more carefully yourself" - " (or be sure someone else has done it for you)." - " The following are checked for here:" - "\n") - 'font-lock-face font-lock-comment-face)) - (fill-region here (point))) - (insert - (propertize - (concat - "- Top level forms that might be executed when loading the file.\n" - "- Redefinition of functions.\n") - 'font-lock-face font-lock-comment-face)) - - (insert "\n") - (if elisp-file - (progn - (insert "File ") - (insert-text-button elisp-file - 'action - `(lambda (button) - (interactive) - (find-file-other-window ,elisp-file)))) - (insert "Buffer ") - (insert-text-button (buffer-name elisp) - 'action - `(lambda (button) - (interactive) - (switch-to-buffer-other-window ,elisp)))) - - (web-vcs-investigate-read elisp out-buf) - (when elisp-file - (insert "\n\n\n") - (insert (propertize "* Investigate what the file loads and redefines\n" - 'font-lock-face '(:background "yellow" :height 1.2))) - (let ((here (point))) - (insert "\nIf you want to see what will actually be added to `load-history'" - " and which functions will be defined you can" - " load the file in a batch Emacs session" - " and show the result here." - " (`load-path' will be set to your current value for the loading.)" - "\n" - ) - (fill-region here (point)) - - (setq here (point)) - (insert "\nYour current Emacs will not be affected by the loading," - " but please be aware that this does not mean your computer can not be." - "\n" - ) - (fill-region here (point)) - - (insert (propertize "\n Note: Click the part after #.\n" 'font-lock-face 'italic)) - (when t ;init-file-user - (insert " ") - (insert-text-button "#Load the file with all your current init files" - 'action `(lambda (button) (interactive) - (web-vcs-investigate-eval ,elisp-file ,out-buf "--debug-init"))) - (insert "\n")) - (when t ;(and site-run-file (not init-file-user)) - (insert " ") - (insert-text-button "#Load the file with just your site init file (i.e. -q)" - 'action `(lambda (button) (interactive) - (web-vcs-investigate-eval ,elisp-file ,out-buf "-q"))) - (insert "\n")) - (when t ;(not site-run-file) - (insert " ") - (insert-text-button "#Load the file with no init file (i.e. -Q)" - 'action `(lambda (button) (interactive) - (web-vcs-investigate-eval ,elisp-file ,out-buf "-Q"))) - (insert "\n")) - - (setq web-vcs-eval-output-start (point)) - (setq web-vcs-eval-output-end (point-max)) - )) - (set-buffer-modified-p nil) - (goto-char (point-min)))))) - - -;;(web-vcs-investigate-eval "c:/emacsw32/nxhtml/nxhtml/nxhtml-autoload.el" "*Messages*") -;;(web-vcs-investigate-eval "c:/emacsw32/nxhtml/autostart.el" "*Messages*") -(defun web-vcs-investigate-eval (elisp-file out-buf init) - "Get compile loads when evaling buffer. -Eval the buffer in a fresh Emacs and return the resulting -load-history entries with comments about what is new etc." - (let* ((emacs-exe (locate-file invocation-name - (list invocation-directory) - exec-suffixes)) - ;; see custom-load-symbol - (get-lhe '(let ((lhe (or (assoc buffer-file-name load-history) - (assoc (concat (file-name-sans-extension buffer-file-name) ".elc") - load-history)))) - (prin1 "STARTHERE\n") - (prin1 lhe))) - (elisp-file-name (file-name-sans-extension (file-name-nondirectory elisp-file))) - (elisp-el-file (file-truename (concat (file-name-sans-extension elisp-file) ".el"))) - (temp-prefix web-autoload-temp-file-prefix) - (temp-prefix-len (length temp-prefix)) - (is-downloading (and (boundp 'web-autoload-paranoid) - web-autoload-paranoid)) - (is-temp-file (and is-downloading - (< (length temp-prefix) (length elisp-file-name)) - (string= temp-prefix - (substring elisp-file-name 0 temp-prefix-len)))) - (elisp-feature-name (if is-temp-file - (substring elisp-file-name temp-prefix-len) - elisp-file-name)) - (is-same-file (lambda (file) - (when file ;; self protecting - (setq file (concat (file-name-sans-extension file) ".el")) - (string= (file-truename file) elisp-el-file)))) - (active-sub-url (when (web-autoload-acvtive) - (file-name-sans-extension web-autoload-active-file-sub-url))) - whole-result - batch-error - result) - (with-current-buffer out-buf - (when web-vcs-eval-output-start - (let ((here (point)) - (inhibit-read-only t)) - (save-restriction - (widen) - ;;(goto-char web-vcs-eval-output-start) - (delete-region web-vcs-eval-output-start web-vcs-eval-output-end)) - (goto-char here)))) - ;; Fix-me: do not use temp buffer so we can check errors - (with-temp-buffer - (let ((old-loadpath (getenv "EMACSLOADPATH")) - ;;(new-loadpath (mapconcat 'identity load-path ";")) - (new-loadpath (mapconcat 'identity load-path path-separator)) - ret-val) - (setenv new-loadpath) - (message "Loading file in batch Emacs...") - (setq ret-val - (call-process emacs-exe nil - (current-buffer) - t "--batch" - ;; fix-me: "-Q" - should be run in the users current environment. - ;; init-file-user nil => -Q - ;; site-run-file nil => -q - - ;; (cond - ;; ((not init-file-user) "-Q") - ;; ((not site-run-file) "-q") - ;; (t "--debug-init")) ;; have to have something here... - init - - "-eval" (format "(setq load-path '%S)" load-path) - "-l" elisp-file - elisp-file - "-eval" (format "%S" get-lhe))) - (message "Loading file in batch Emacs... done, returned %S" ret-val) - (setenv old-loadpath)) - ;; Fix-me: how do you check the exit status on different platforms? - (setq whole-result (buffer-substring-no-properties (point-min) (point-max))) - (condition-case err - (progn - (goto-char (point-min)) - (search-forward "STARTHERE") - (search-forward "(") - (backward-char) - (setq result (read (current-buffer)))) - (error (message "") - ;; Process should probably have failed if we are here, - ;; but anyway... ;-) - (setq batch-error - (concat "Sorry, batch Emacs failed. It returned this message:\n\n" - whole-result - (if is-downloading - (concat - "\n--------\n" - "The error may depend on that not all needed files are yet downloaded.\n") - "\n"))) - ))) - (with-current-buffer out-buf - (let ((here (point)) - (inhibit-read-only t)) - (save-restriction - (widen) - ;;(goto-char (point-max)) - (goto-char web-vcs-eval-output-start) - (if batch-error - (progn - (insert "\n\n") - (insert (propertize batch-error 'font-lock-face 'web-vcs-red))) - (insert (propertize (format "\n\nLoading file (%s) added to `load-history':\n\n" init) - 'font-lock-face '(:height 1.5))) - (insert " (\"" (car result) "\"\n") - (dolist (e (cdr result)) - (insert (format " %S" e)) - (cond ((stringp e)) ;; Should not happen... - ;; Variables - ((symbolp e) - (insert " - ") - (insert (if (not (boundp e)) - (propertize "New" 'font-lock-face 'web-vcs-yellow) - (let ((e-file (symbol-file e))) - (if (funcall is-same-file e-file) - (propertize "Same file now" 'font-lock-face 'web-vcs-green) - (let* ((fun-web-auto (get e 'web-autoload)) - (fun-sub-url (nth 2 fun-web-auto))) - (if (and fun-sub-url - (string= fun-sub-url active-sub-url)) - (propertize "Web download, matches current download" - 'font-lock-face 'web-vcs-yellow) - (propertize (format "Loaded from %S now" e-file) - 'font-lock-face 'web-vcs-red)))))))) - ;; provide - ((eq (car e) 'provide) - (insert " - ") - (let* ((feat (car e)) - (feat-name (symbol-name feat))) - (insert (cond - ((not (featurep feat)) - (if (or (string= elisp-feature-name - (symbol-name (cdr e)))) - (propertize "Web download, matches file name" 'font-lock-face 'web-vcs-green) - (propertize "Does not match file name" 'font-lock-face 'web-vcs-red))) - (t - ;; symbol-file will be where it is loaded - ;; so check load-path instead. - (let ((file (locate-library feat-name))) - (if (funcall is-same-file file) - (propertize "Probably loaded from same file now" 'font-lock-face 'web-vcs-yellow) - (propertize (format "Probably loaded from %S now" file) - 'font-lock-face 'web-vcs-yellow)))))))) - ;; require - ((eq (car e) 'require) - (if (featurep (cdr e)) - (insert " - " (propertize "Loaded now" 'font-lock-face 'web-vcs-green)) - (insert " - " (propertize "Not loaded now" 'font-lock-face 'web-vcs-yellow)))) - ;; Functions - ((memq (car e) '( defun macro)) - (insert " - ") - (let ((fun (cdr e))) - (insert (if (functionp fun) - (let ((e-file (symbol-file e))) - (if (funcall is-same-file e-file) - (propertize "Same file now" 'font-lock-face 'web-vcs-green) - (let* ((fun-web-auto (get fun 'web-autoload)) - (fun-sub-url (nth 2 fun-web-auto))) - ;; Fix-me: check for temp download file. - (if (string= fun-sub-url active-sub-url) - (propertize "Web download, matches current download" - 'font-lock-face 'web-vcs-yellow) - (propertize (format "Loaded from %S now" e-file) - 'font-lock-face 'web-vcs-yellow))))) - ;; Note that web autoloaded functions are already defined. - (propertize "New" 'font-lock-face 'web-vcs-yellow)))))) - (insert "\n")) - (insert " )\n") - (setq web-vcs-eval-output-end (point-max)) - (goto-char here)))) - (set-buffer-modified-p nil)))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Specific for nXhtml - -;;(defvar nxhtml-web-vcs-base-url "http://bazaar.launchpad.net/%7Enxhtml/nxhtml/main/") -(defvar nxhtml-web-vcs-base-url "http://bazaar.launchpad.net/~nxhtml/nxhtml/main/") - -;; Fix-me: make gen for 'lp etc -(defun nxhtml-download-root-url (revision) - (let* ((base-url nxhtml-web-vcs-base-url) - (files-url (concat base-url "files/")) - (rev-part (if revision (number-to-string revision) - ;; "head%3A/" - "head:/" - ))) - (concat files-url rev-part))) - -(defun web-vcs-nxhtml () - "Install nXhtml. -Download and install nXhtml." - (interactive) - (catch 'command-level - (setq debug-on-error t) - (let* ((this-dir (file-name-directory web-vcs-el-this)) - (root-url (nxhtml-download-root-url nil)) - ;;(files '("nxhtml-web-vcs.el" "nxhtml-base.el")) - (files '("nxhtml-web-vcs.el")) - (files2 (mapcar (lambda (file) - (cons file (expand-file-name file this-dir))) - files)) - need-dl) - (dolist (file files2) - (unless (file-exists-p (cdr file)) - (setq need-dl t))) - (when need-dl - (let ((prompt - (concat "Welcome to install nXhtml." - "\nFirst the nXhtml specific web install file must be downloaded." - "\nYou will get a chance to review it before it is used." - "\n\nDo you want to continue? ")) - (resize-mini-windows (or resize-mini-windows t))) - (unless (y-or-n-p prompt) - (message "Aborted") - (throw 'command-level nil)))) - (message nil) - (unless (get-buffer-window "*Messages*") - (web-vcs-display-messages t) - (delete-other-windows)) - (dolist (file files2) - (unless (file-exists-p (cdr file)) - (web-vcs-get-missing-matching-files 'lp root-url this-dir (car file) 0))) - (load (cdr (car files2)))) - (call-interactively 'nxhtml-setup-install))) - - -(provide 'web-vcs) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; web-vcs.el ends here |