# HG changeset patch # User cvs # Date 1186987829 -7200 # Node ID 8fc7fe29b841806443e1d4d594852105b28bbca0 # Parent b88636d63495b206177261de71f7da090ea62789 Import from CVS: tag r19-15b94 diff -r b88636d63495 -r 8fc7fe29b841 CHANGES-beta --- a/CHANGES-beta Mon Aug 13 08:50:06 2007 +0200 +++ b/CHANGES-beta Mon Aug 13 08:50:29 2007 +0200 @@ -1,5 +1,37 @@ -*- indented-text -*- +to 19.15 beta94 +-- New symbol `signal-error-on-buffer-boundary'. Set to nil to avoid + lossage of zmacs region when moving against buffer boundaries. +-- python-mode.el-2.89 Courtesy of Barry Warsaw +-- added mouse-[123] and down-mouse-[123] Emacs-compatible keysyms +-- W3-3.0.59 +-- Clicking on `**' buffer modified status in mode-line now works the same + way as C-x C-q. +-- Miscellanous bug fixes from a number of people +-- mine.el-1.17 Courtesy of Jacques Duthen [New] +-- fast-lock.el-3.10.2 Courtesy of Simon Marshall +-- browse-cltl2.el-1.1 Courtesy of Holger Schauer +-- eldoc.el-1.8 Courtesy of Noah Friedman [New] +-- webjump.el-1.4 Courtesy of Neil W. Van Dyke [New] +-- Canna coredump fixed +-- verilog-mode.el Courtesy of Michael McNamara & Adrian Aichner [New] +-- overlay.el Courtesy of Joseph Nuspl [New] +-- hm--html-menus-5.1 Courtesy of Heiko Muenkel +-- tm-7.105 +-- Initial port of edmacro.el courtesy of Hrvoje Niksic [New] +-- custom-1.40 +-- Native sound support for FreeBSD Courtesy Dick van den Burg +-- Correct detection of GIF89, and implement detection of PNG +-- efs-1.15 courtesy of Andy Norman and Michael Sperber [New] +-- Easy customization of toolbar support courtesy of Hrvoje Niksic +-- Gnus-5.4.12 +-- balloon-help-1.03 courtesy of Kyle Jones [New] +-- 'compatible byte compiler warning type added and turned off by default +-- redo.el-1.00 courtesy of Kyle Jones [New] +-- floating-toolbar.el courtesy of Kyle Jones [New] + to 19.15 beta93 +-- W3-3.0.56 -- VM-6.13 Courtesy of Kyle Jones -- Custom-1.30 -- Replicating extents are history diff -r b88636d63495 -r 8fc7fe29b841 README --- a/README Mon Aug 13 08:50:06 2007 +0200 +++ b/README Mon Aug 13 08:50:29 2007 +0200 @@ -1,4 +1,4 @@ -This directory tree holds version 19.14 of XEmacs, the extensible, +This directory tree holds version 19.15 of XEmacs, the extensible, customizable, self-documenting real-time display editor. See the file `etc/NEWS' for information on new features and other diff -r b88636d63495 -r 8fc7fe29b841 etc/custom/check0.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/custom/check0.xpm Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,17 @@ +/* XPM */ +static char * check0_xpm[] = { +"11 11 3 1", +" c #E6E6E6E6E6E6", +". c #737373737373", +"X c #BFBFBFBFBFBF", +" ", +" .", +" XXXXXXX..", +" XXXXXXX..", +" XXXXXXX..", +" XXXXXXX..", +" XXXXXXX..", +" XXXXXXX..", +" XXXXXXX..", +" .........", +" .........."}; diff -r b88636d63495 -r 8fc7fe29b841 etc/custom/check1.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/custom/check1.xpm Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,17 @@ +/* XPM */ +static char * check1_xpm[] = { +"11 11 3 1", +" c #737373737373", +". c #E6E6E6E6E6E6", +"X c #22228B8B2222", +" ", +" .", +" XXXXXXX..", +" XXXXXXX..", +" XXXXXXX..", +" XXXXXXX..", +" XXXXXXX..", +" XXXXXXX..", +" XXXXXXX..", +" .........", +" .........."}; diff -r b88636d63495 -r 8fc7fe29b841 etc/custom/radio0.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/custom/radio0.xpm Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,18 @@ +/* XPM */ +static char * radio0_xpm[] = { +"12 11 4 1", +" c #FFFFFFFFFFFF s background", +". c #E6E6E6E6E6E6", +"X c #BFBFBFBFBFBF", +"o c #737373737373", +" .. ", +" .... ", +" ..XX.. ", +" ..XXXX.. ", +" ..XXXXXX.. ", +"ooXXXXXXXXoo", +" ooXXXXXXoo ", +" ooXXXXoo ", +" ooXXoo ", +" oooo ", +" oo "}; diff -r b88636d63495 -r 8fc7fe29b841 etc/custom/radio1.xpm --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/etc/custom/radio1.xpm Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,18 @@ +/* XPM */ +static char * radio1_xpm[] = { +"12 11 4 1", +" c #FFFFFFFFFFFF s background", +". c #737373737373", +"X c #22228B8B2222", +"o c #E6E6E6E6E6E6", +" .. ", +" .... ", +" ..XX.. ", +" ..XXXX.. ", +" ..XXXXXX.. ", +"ooXXXXXXXXoo", +" ooXXXXXXoo ", +" ooXXXXoo ", +" ooXXoo ", +" oooo ", +" oo "}; diff -r b88636d63495 -r 8fc7fe29b841 etc/sounds/README --- a/etc/sounds/README Mon Aug 13 08:50:06 2007 +0200 +++ b/etc/sounds/README Mon Aug 13 08:50:29 2007 +0200 @@ -1,6 +1,9 @@ This directory contains some mu-law encoded SunOS 4.1 sound files. -If you're running XEmacs on the console of a SparcStation or SGI -machine, you can use these sounds to replace the default beep. See the +You can only play sound files if you are running on display 0 of the +console of a machine with native sound support or running a NetAudio +server and XEmacs has the necessary sound support compiled in. + +You can use these sounds to replace the default beep. See the documentation of the `sound-alist' variable, and the functions `load-default-sounds' and `load-sound-file' from lisp/prim/sound.el. diff -r b88636d63495 -r 8fc7fe29b841 etc/w3/stylesheet --- a/etc/w3/stylesheet Mon Aug 13 08:50:06 2007 +0200 +++ b/etc/w3/stylesheet Mon Aug 13 08:50:29 2007 +0200 @@ -94,11 +94,15 @@ ** This functionality will be removed as soon as the W3C comes up with ** the standard way to do this, perhaps in CSS level 2. */ -input { text-decoration: underline; } -input:submit { color: green; text-decoration: none; } -input:reset { color: red; text-decoration: none; } -input:button { color: yellow; text-decoration: none; } -input:image { text-decoration: none; } +input:text, +input:integer, +input:float, +input:url, +input:text { text-decoration: underline; } +input:submit { color: green; text-decoration: none; } +input:reset { color: red; text-decoration: none; } +input:button { color: yellow; text-decoration: none; } +input:image { text-decoration: none; } /* ** List formatting instructions diff -r b88636d63495 -r 8fc7fe29b841 info/dir --- a/info/dir Mon Aug 13 08:50:06 2007 +0200 +++ b/info/dir Mon Aug 13 08:50:29 2007 +0200 @@ -46,11 +46,9 @@ Packages: -* Ange-FTP:: Making the entire network accessible as a pseudo-filesystem. * CC-MODE:: Mode for editing C, C++, and Objective-C code. * CL:: A Common Lisp compatibility package for Emacs-Lisp. * Custom:: Customization Library for Emacs -* Dired:: Manual for Tree Dired. * Ediff:: A Visual Interface to Unix Diff and Patch Utilities. * External-Widget:: Use XEmacs as a text widget inside of another program. diff -r b88636d63495 -r 8fc7fe29b841 lib-src/Makefile.in.in --- a/lib-src/Makefile.in.in Mon Aug 13 08:50:06 2007 +0200 +++ b/lib-src/Makefile.in.in Mon Aug 13 08:50:29 2007 +0200 @@ -100,7 +100,7 @@ /* Things that a user might actually run, which should be installed in bindir. */ INSTALLABLES = etags ctags emacsclient b2m gnuclient gnuattach gnudoit -INSTALLABLE_SCRIPTS = rcs-checkin +INSTALLABLE_SCRIPTS = rcs-checkin pstogif /* Things that Emacs runs internally, or during the build process, which should not be installed in bindir. */ @@ -262,10 +262,16 @@ rm -f vcdiff ; ${LN_S} ${srcdir}/vcdiff . ; \ fi +$(TM_SCRIPTS): force + @if [ ! -r $@ ] ; then \ + rm -f $@ ; ${LN_S} ${srcdir}/$@ . ; \ + fi + force: #else /* ultrix */ rcs2log: vcdiff: +$(TM_SCRIPTS): #endif /* ultrix */ #ifdef MOVEMAIL_NEEDS_BLESSING diff -r b88636d63495 -r 8fc7fe29b841 lib-src/update-elc.sh --- a/lib-src/update-elc.sh Mon Aug 13 08:50:06 2007 +0200 +++ b/lib-src/update-elc.sh Mon Aug 13 08:50:29 2007 +0200 @@ -101,6 +101,7 @@ \!/energize/write-file.el$!d \!/eos/!d \!/gnus/!d +\!/efs/!d \!/ilisp/!d \!/paths.el$!d \!/prim/loadup.el$!d @@ -142,6 +143,12 @@ echo Viper done. fi +if [ -d lisp/efs ]; then + echo Compiling efs... + ( cd lisp/efs ; make EMACS=$REAL ) + echo efs done. +fi + # Gnus now has a makefile... echo Compiling Gnus... ( cd lisp/gnus ; make EMACS=$REAL some ) diff -r b88636d63495 -r 8fc7fe29b841 lisp/bytecomp/byte-optimize.el --- a/lisp/bytecomp/byte-optimize.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/bytecomp/byte-optimize.el Mon Aug 13 08:50:29 2007 +0200 @@ -273,7 +273,10 @@ form) ;; else (if (and (consp fn) (eq (car fn) 'autoload)) - (load (nth 1 fn))) + (progn + (load (nth 1 fn)) + (setq fn (or (cdr (assq name byte-compile-function-environment)) + (and (fboundp name) (symbol-function name)))))) (if (and (consp fn) (eq (car fn) 'autoload)) (error "file \"%s\" didn't define \"%s\"" (nth 1 fn) name)) (if (symbolp fn) diff -r b88636d63495 -r 8fc7fe29b841 lisp/bytecomp/bytecomp-runtime.el --- a/lisp/bytecomp/bytecomp-runtime.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/bytecomp/bytecomp-runtime.el Mon Aug 13 08:50:29 2007 +0200 @@ -113,6 +113,34 @@ (put var 'byte-obsolete-variable new) var) +;; By overwhelming demand, we separate out truly obsolete symbols from +;; those that are present for GNU Emacs compatibility. +(defun make-compatible (fn new) + "Make the byte-compiler know that FUNCTION is provided for compatibility. +The warning will say that NEW should be used instead. +If NEW is a string, that is the `use instead' message." + (interactive "aMake function compatible: \nxCompatible replacement: ") + (let ((handler (get fn 'byte-compile))) + (if (eq 'byte-compile-compatible handler) + (setcar (get fn 'byte-compatible-info) new) + (put fn 'byte-compatible-info (cons new handler)) + (put fn 'byte-compile 'byte-compile-compatible))) + fn) + +(defun make-compatible-variable (var new) + "Make the byte-compiler know that VARIABLE is provided for compatibility. +and NEW should be used instead. If NEW is a string, then that is the +`use instead' message." + (interactive + (list + (let ((str (completing-read "Make variable compatible: " + obarray 'boundp t))) + (if (equal str "") (error "")) + (intern str)) + (car (read-from-string (read-string "Compatible replacement: "))))) + (put var 'byte-compatible-variable new) + var) + (put 'dont-compile 'lisp-indent-hook 0) (defmacro dont-compile (&rest body) "Like `progn', but the body always runs interpreted (not compiled). diff -r b88636d63495 -r 8fc7fe29b841 lisp/bytecomp/bytecomp.el --- a/lisp/bytecomp/bytecomp.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/bytecomp/bytecomp.el Mon Aug 13 08:50:29 2007 +0200 @@ -103,6 +103,8 @@ ;;; a macro to a lambda or vice versa, ;;; or redefined to take other args) ;;; 'obsolete (obsolete variables and functions) +;;; 'pedantic (references to Emacs-compatible +;;; symbols) ;;; (RMS calls the following option byte-compile-compatibility but ;;; our name is better) ;;; byte-compile-emacs18-compatibility Whether the compiler should @@ -353,6 +355,7 @@ redefine function cell redefined from a macro to a lambda or vice versa, or redefined to take a different number of arguments. obsolete use of an obsolete function or variable. + pedantic warn of use of compatible symbols. The default set is specified by `byte-compile-default-warnings' and normally encompasses all possible warnings. @@ -951,6 +954,16 @@ (car new) (format "use %s instead." (car new))))) (funcall (or (cdr new) 'byte-compile-normal-call) form))) + +;;; Used by make-obsolete. +(defun byte-compile-compatible (form) + (let ((new (get (car form) 'byte-compatible-info))) + (if (memq 'pedantic byte-compile-warnings) + (byte-compile-warn "%s is provided for compatibility; %s" (car form) + (if (stringp (car new)) + (car new) + (format "use %s instead." (car new))))) + (funcall (or (cdr new) 'byte-compile-normal-call) form))) ;; Compiler options @@ -2583,6 +2596,13 @@ (if (stringp ob) ob (format "use %s instead." ob))))) + (if (and (get var 'byte-compatible-variable) + (memq 'pedantic byte-compile-warnings)) + (let ((ob (get var 'byte-compatible-variable))) + (byte-compile-warn "%s is provided for compatibility; %s" var + (if (stringp ob) + ob + (format "use %s instead." ob))))) (if (memq 'free-vars byte-compile-warnings) (if (eq base-op 'byte-varbind) (setq byte-compile-bound-variables diff -r b88636d63495 -r 8fc7fe29b841 lisp/comint/gdb.el --- a/lisp/comint/gdb.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/comint/gdb.el Mon Aug 13 08:50:29 2007 +0200 @@ -267,7 +267,7 @@ ;; XEmacs change: (make-local-hook 'kill-buffer-hook) (add-hook 'kill-buffer-hook 'gdb-delete-arrow-extent nil t) - (setq comint-input-sentinel 'shell-directory-tracker) + (add-hook 'comint-input-filter-functions 'shell-directory-tracker nil t) (run-hooks 'gdb-mode-hook)) (defun gdb-delete-arrow-extent () @@ -652,11 +652,13 @@ (goto-char (point-max)) (insert comm))) -(defun gdb-control-c-subjob () - "Send a Control-C to the subprocess." - (interactive) - (process-send-string (get-buffer-process (current-buffer)) - "\C-c")) +(fset 'gdb-control-c-subjob 'comint-interrupt-subjob) + +;(defun gdb-control-c-subjob () +; "Send a Control-C to the subprocess." +; (interactive) +; (process-send-string (get-buffer-process (current-buffer)) +; "\C-c")) (defun gdb-toolbar-break () (interactive) diff -r b88636d63495 -r 8fc7fe29b841 lisp/custom/ChangeLog --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/custom/ChangeLog Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,1228 @@ +Sat Feb 15 22:27:07 1997 Per Abrahamsen + + * Version 1.40 released. + +Sat Feb 15 22:18:57 1997 Per Abrahamsen + + * custom-edit.el: Use the `changed' state. + +Fri Feb 14 12:46:46 1997 Per Abrahamsen + + * Version 1.39 released. + +Fri Feb 14 12:35:15 1997 Per Abrahamsen + + * custom-edit.el (custom-variable-action): Capitalize. + (custom-face-action): Ditto. + (custom-group-action): Ditto. + * widget-edit.el (widget-choose): Use title in XEmacs. + Patch by Jens Lautenbacher . + +Thu Feb 13 21:14:41 1997 Per Abrahamsen + + * Version 1.38 released. + +Thu Feb 13 15:15:24 1997 Per Abrahamsen + + * custom-edit.el (custom-buffer-create): Added `Done' button. + + * custom-edit.el (custom-variable-state-set): Customized to + factory setting is the same as uncustomized. + (custom-variable-set): Did not set `customized-value' right. + + * widget-edit.el (widget-plist-member): Changed to defsubst. + (widget-get): Made it non-recursive. + + * widget-edit.el (widget-glyph-insert-glyph): New function. + (widget-glyph-insert): Use it. + (widget-push-button-gui): New option. + (widget-push-button-cache): New variable. + (widget-gui-action): New function. + (widget-push-button-value-create): New function. + (push-button): Use it. + (widget-editable-list-gui): New option. + (widget-editable-list-format-handler): Use it. + (widget-editable-list-value-create): Ditto. + This implements GUI push buttons. + + * Version 1.37 released. + +Thu Feb 13 13:51:20 1997 Per Abrahamsen + + * custom-edit.el (custom-redraw): Protect point. + + * widget-edit.el (widget-button1-click): New function. + (widget-keymap): Bind it. + + * Version 1.36 released. + +Thu Feb 13 13:16:34 1997 Per Abrahamsen + + * custom.el: Removed all `;;;###autoload' at the request of Steven + L Baur . + Don't call `autoload' or `custom-menu-reset' when `load-gc' is + fbound. + + * Version 1.35 released. + +Thu Feb 13 10:37:18 1997 Per Abrahamsen + + * widget-edit.el (boolean): Forgot terminating newline in :format. + +Wed Feb 12 18:49:03 1997 Per Abrahamsen + + * Version 1.34 released. + +Wed Feb 12 09:13:52 1997 Per Abrahamsen + + * widget-edit.el (widget-field-keymap): Disabled menu-bar in the + worng keymap. + (widget-text-keymap): Ditto. + (widget-glyph-directory): Default to "data-directory/custom/'. + + * Version 1.33 released. + +Wed Feb 12 09:11:23 1997 Per Abrahamsen + + * Makefile (TEXT): Added `check0.xpm' and `check1.xpm'. + + * widget-edit.el (checkbox): Add glyphs. + +Mon Feb 10 22:52:03 1997 Per Abrahamsen + + * widget-browse.el (widget-browse-sexps): New function. + (:args): Use it. + (widget-browse-action): New function. + (widget-browse): Use it. + (widget-browse-widgets): Use it. + + * Version 1.32 released. + +Mon Feb 10 15:39:45 1997 Per Abrahamsen + + * widget-browse.el (widget-browse-sexp): Catch printing errors. + (widget-browse-widgets): Print types instead of numbers. + + * all: Renamed `widget-name' to `widget-type'. + + * widget-edit.el (widget-button-click): Call the right command. + + * widget.texi (Basic Types): Documented new glyph options. + + * Version 1.31 released. + +Mon Feb 10 13:04:14 1997 Per Abrahamsen + + * widget-edit.el (widget-glyph-directory): New option. + (widget-glyph-enable): New option. + (widget-glyph-insert): New function. + (widget-toggle-value-create): Use it. + (radio-button): Use it. + (widget-field-activate): Only look for a field + (widget-button-click): Handle glyph events. + (widget-default-create): Handle `:glyph'. + * widget.el (:on-glyph): New keyword. + (:off-glyph): Ditto. + (:glyph): Ditto. + * widget.texi (toggle): Documented them.. + (Basic Types): Ditto. + * radio1.xpm: New file. + * radio0.xpm: Ditto. + Original patch provided by Robert Bihlmeyer . + + * widget-browse.el (widget-browse): Add group. + (widget-browse-mode-menu): Add commands. + + * widget-edit.el (widget-keymap): Bind [mouse-2-down] instead of + [mouse-2]. + + * widget-edit.el (widget-keymap): Don't bind [menu-bar] here. + (widget-field-keymap): Bind it here instead. + (widget-text-keymap): And here. + +Sun Feb 9 20:33:25 1997 Per Abrahamsen + + * widget-browse.el: New file. + * Makefile (WIDGET): Added it. + * widget.el (widget-browse-at): Added autoload. + (widget-browse): Ditto. + * widget-edit.el (widget-identify): Deleted. + + * custom-edit.el (custom-mode): Install custom-mode-menu under + XEmacs. + +Sat Feb 08 13:16:17 1997 Per Abrahamsen + + * Version 1.30 released. + +Sat Feb 8 13:15:21 1997 Per Abrahamsen + + * widget-edit.el (widget-name): New macro. + * widget.texi: Document it. + +Sat Feb 08 12:35:22 1997 Per Abrahamsen + + * Version 1.29 released. + +Sat Feb 8 12:29:48 1997 Per Abrahamsen + + * widget-edit.el (widget-get-sibling): New function. + (widget-identify): New command. + + * widget-edit.el (toggle): Don't use subwidgets. + (widget-toggle-convert-widget): Deleted. + (widget-toggle-value-create): New function. + (widget-toggle-action): New function. + (checkbox): Caller updated. + (radio-button): Ditto. + (boolean): Ditto. + * custom.el (custom-face-attributes): Ditto. + +Fri Feb 07 18:34:42 1997 Per Abrahamsen + + * Version 1.28 released. + +Fri Feb 7 18:33:47 1997 Per Abrahamsen + + * widget-edit.el (widget-keymap): Don't bind `C-a' and `C-e' + here. + (widget-field-keymap): Bind them here instead. + (widget-text-keymap): And here. + +Fri Feb 07 18:29:31 1997 Per Abrahamsen + + * Version 1.27 released. + +Fri Feb 7 18:18:31 1997 Per Abrahamsen + + * widget-edit.el (widget-beginning-of-line): New function. + (widget-keymap): Bind it. + Patch by "William M. Perry" . + (widget-end-of-line): New function. + (widget-keymap): Bind it. + +Thu Feb 06 19:21:09 1997 Per Abrahamsen + + * Version 1.26 released. + +Thu Feb 6 19:19:12 1997 Per Abrahamsen + + * widget-edit.el (widget-kill-line): New function. + (widget-keymap): Bind it. + +Thu Feb 06 19:10:37 1997 Per Abrahamsen + + * Version 1.25 released. + +Thu Feb 6 19:09:52 1997 Per Abrahamsen + + * widget-edit.el (widget-specify-field-update): Unconditionally + set local keymap property after the field. + +Sat Feb 01 13:13:48 1997 Per Abrahamsen + + * Version 1.24 released. + +Thu Jan 30 13:04:30 1997 Per Abrahamsen + + * widget-edit.el (widget-field-value-delete): Fix problem with + editable fields where the format string doesn't contain %v. + +Tue Jan 28 08:23:17 1997 Per Abrahamsen + + * Version 1.23 released. + +Tue Jan 28 04:33:24 1997 Per Abrahamsen + + * widget.el (:valid-regexp): New keyword. + * widget-edit.el (widget-field-validate): New function. + (editable-field): Use them. + * widget.texi (editable-field): Document it. + + * custom-edit.el (custom-face-format-handler): Removed unused + variable `state'. + + * custom.el (custom-menu-reset): Support menu-less XEmacs. + Reported by Carsten Leonhardt . + +Mon Jan 27 11:51:17 1997 Per Abrahamsen + + * Version 1.22 released. + +Mon Jan 27 08:46:05 1997 Per Abrahamsen + + * custom-edit.el (custom-variable-set): Fixed error message. + (custom-variable-save): Ditto. + + * Version 1.21 released. + +Mon Jan 27 07:17:55 1997 Per Abrahamsen + + * widget.el (:secret): New keyword. + * widget-edit.el (widget-specify-field-update): Support it. + (widget-field-value-get): Ditto. + * widget.texi (editable-field): Documented it. + + * widget-edit.el (widget-field-keymap): New variable. + (editable-field): Use it. + (widget-text-keymap): New variable. + (text): Use it. + (widget-field-activate): New command. + +Sun Jan 26 13:02:20 1997 Per Abrahamsen + + * custom.el (customize): Include `widgets' customization group. + +Sat Jan 25 08:23:02 1997 Per Abrahamsen + + * Version 1.20 released. + +Sat Jan 25 07:13:26 1997 Per Abrahamsen + + * widget-edit.el (widget-specify-field-update): Use + `widget-keymap' by default. + +Fri Jan 24 08:10:46 1997 Per Abrahamsen + + * Version 1.19 released. + +Fri Jan 24 06:53:48 1997 Per Abrahamsen + + * widget-edit.el (widget-documentation-face): Typo in face name. + + * custom-edit.el (custom-variable-sample-face): New face. + (custom-variable-button-face): New face. + (custom-variable-value-create): Use them. + (custom-face-tag-face): New face. + (custom-face): Use it. + (custom-face-format-handler): Don't make the sample a button. + (custom-group-tag-faces): New variable. + (custom-group-tag-face-1): New face. + (custom-group-tag-face): New face. + (custom-group-sample-face-get): New function. + (custom-group): Use it. + + * widget-edit.el (character): Use sample face for tag. + (list): Ditto. + (vector): Ditto. + (cons): Ditto. + (radio): Ditto. + (repeat): Ditto. + (set): Ditto. + (boolean): Ditto. + +Thu Jan 23 20:25:46 1997 Per Abrahamsen + + * widget.el (:sample-face-get): New keyword. + (:sample-face): New keyword. + + * widget-edit.el (widget-default-create): Support %{ and %} + escapes. + (widget-specify-sample): New function. + (default): Define `:sample-face-get'. + (widget-default-sample-face-get): New function. + + * custom-edit.el (custom-variable-action): Show if hidden. + +Wed Jan 22 04:54:10 1997 Per Abrahamsen + + * widget-edit.el (error-message-string): Define if unbound. + +Thu Jan 16 16:07:09 1997 Per Abrahamsen + + * Version 1.18 released. + +Thu Jan 16 16:03:25 1997 Per Abrahamsen + + * custom-edit.el (custom-load-symbol): Use `assoc' instead of + `member' to check if a file is in load-history. + (custom-load-symbol): Use `condition-case' around loads. + +Tue Jan 14 20:51:37 1997 Per Abrahamsen + + * custom-edit.el (:custom-reset): Split into + :`custom-reset-current', `:custom-reset-saved', and + `:custom-reset-factory'. + (custom-mode-menu): Ditto. + (custom-mode): Ditto. + (custom-variable): Ditto. + (custom-variable-menu): Ditto. + (custom-face): Ditto. + (custom-face-menu): Ditto. + (custom-group): Ditto. + (custom-group-menu): Ditto. + (custom-group-reset): Ditto. + (custom-reset-menu): New variable. + (custom-reset): Use it. + (custom-reset-current): New function. + (custom-reset-saved): New function. + (custom-reset-factory): New function. + (custom-buffer-create): Pass event to `custom-reset'. + (custom-variable-reset-saved): Renamed from + `custom-variable-default'. + (custom-variable-reset-factory): Renamed from + `custom-variable-factory'. + (custom-face-reset-saved): Renamed from `custom-face-default'. + (custom-face-reset-factory): Renamed from + `custom-face-reset-factory'. + +Mon Jan 13 01:23:36 1997 Per Abrahamsen + + * Version 1.17 released. + +Mon Jan 13 00:19:35 1997 Per Abrahamsen + + * custom-edit.el (custom-face-format-handler): Missing "hide". + (custom-face-action): Show when hidden. + + * custom.texi: (The State Button): Updated. + +Wed Jan 8 15:23:29 1997 Per Abrahamsen + + * custom-edit.el (custom-quote): Support `characterp'. Patch + by Sudish Joseph . + + * custom-edit.el (custom-magic-alist): Refer to state button + instead of level button. + +Sat Jan 04 21:34:12 1997 Per Abrahamsen + + * Version 1.16 released. + +Fri Jan 3 22:56:57 1997 Per Abrahamsen + + * custom-edit.el (custom-group): Group tags are no longer buttons. + (custom-group-action): Show when hidden. + (custom-magic-value-create): Added :help-echo. + (custom-manual): Ditto. + * widget-edit.el (link): Ditto. + +Fri Jan 03 00:00:37 1997 Per Abrahamsen + + * Version 1.15 released. + +Thu Jan 2 23:30:43 1997 Per Abrahamsen + + * custom-edit.el (custom-magic): Can now contain multiple buttons. + (custom-magic-alist): Add description element. + (custom-magic-show): New variable. + (custom-magic-show-button): New variable. + (custom-magic-value-create): Use them. + (custom): Ditto. + (custom-variable): Ditto. + (custom-face): Ditto. + (widget-face-value-create): Ditto. + (custom-group): Ditto. + (custom-variable-value-create): Don't create [show] button. + (custom-variable-factory): Only save when saved. + (custom-face-factory): Ditto. + +Sat Dec 28 18:54:38 1996 Per Abrahamsen + + * Version 1.14 released. + +Sat Dec 28 13:43:44 1996 Per Abrahamsen + + * custom-edit.el: (custom-changed-face): New face. + (custom-magic-alist): New `changed' state. + (custom-variable-state-set): Support `set' state. + (custom-save): Ditto. + (custom-variable-set): Ditto. + (custom-variable-save): Ditto. + (custom-variable-default): Ditto. + (custom-variable-factory): Ditto. + (custom-face-state-set): Ditto. + (custom-face-set): Ditto. + (custom-face-save): Ditto. + (custom-face-default): Ditto. + (custom-face-factory): Ditto. + (custom-group-save): Ditto. + + * custom.texi (The State Button): Documented `changed' state. + + * custom-edit.el: New terminology: `Set default' automatically + saves the new value and has been renamed `Save'. `Apply' has been + renamed `Set'. `Edit Default' has been renamed to `Edit Lisp'. + * custom.texi: Ditto. + + * widget-edit.el (widget-move): New function. + (widget-forward): Use it. + (widget-backward): Ditto. + +Tue Dec 17 10:47:23 1996 Per Abrahamsen + + * custom-edit.el (custom-mode-menu): Added help item. + + * custom.texi (Declarations): New section. Documented `:tag' + keyword. + (Declaring Groups): Documented `:prefix' keyword. + + * custom-edit.el (custom-set-default): Also save. + (custom-buffer-create): Removed save button. + +Thu Dec 12 07:57:23 1996 Per Abrahamsen + + * widget-edit.el (widget-menu-max-size): Added `:group'. + + * custom-edit.el (custom-display): Added support for `pm', `pc', + and `win32' window systems. + + * widget-edit.el (widget-field-face): Do not require X. + +Tue Dec 10 13:28:22 1996 Per Abrahamsen + + * widget-edit.el (widget-documentation-face): Green by default. + +Mon Dec 09 12:28:10 1996 Per Abrahamsen + + * Version 1.13 released. + +Mon Dec 9 08:50:46 1996 Per Abrahamsen + + * custom-edit.el (custom-unlispify-tag-names): New variable. + (custom-unlispify-tag-name): New function. + (custom-variable-value-create): Use it. + (custom-group-value-create): Use it. + (:custom-prefixes): New keyword. + (custom-variable-value-create): Use it. + (custom-group-value-create): Use it. + + * widget-edit.el (widget-item-convert-widget): Doc fix. + + * custom-edit.el (custom-menu-create): Do not create menus for + groups with more than `widget-menu-max-size' members. + +Sun Dec 08 16:19:21 1996 Per Abrahamsen + + * Version 1.12 released. + +Sun Dec 8 14:38:42 1996 Per Abrahamsen + + * custom.el (:tag): New keyword. + (custom-handle-keyword): Accept it. + + * custom.el (:prefix): New keyword. + (custom-declare-group): Handle it. + (customize): Use it. + * widget-edit.el (widgets): Use it. + + * custom-edit.el (custom-prefix-list): New variable. + (custom-unlispify-menu-entries): New variable. + (custom-unlispify-menu-entry): New function. + (custom-face-menu-create): Use it. + (custom-variable-menu-create): Use it. + (boolean): Use it. + (custom-menu-create): Use it. + + * custom-edit.el (custom-menu-create): New function. + (custom-group-menu-create): Use it. + +Thu Dec 5 14:00:04 1996 Per Abrahamsen + + * custom-opt.el: New file. + +Thu Dec 05 13:53:48 1996 Per Abrahamsen + + * Version 1.11 released. + +Thu Dec 5 13:22:31 1996 Per Abrahamsen + + * custom-edit.el (:custom-menu): New keyword. + (custom-variable): Use it. + (custom-face): Ditto. + (custom-group): Ditto. + (boolean): Ditto. + (custom-menu-update): Ditto. + (custom-face-menu-create): New function. + (custom-variable-menu-create): New function. + (custom-group-menu-create): New function. + (custom-menu-create-entry): Removed. + +Tue Dec 3 09:28:19 1996 Per Abrahamsen + + * custom.texi (Utilities): Documented `custom-add-load'. + +Tue Dec 03 08:42:15 1996 Per Abrahamsen + + * Version 1.10 released. + +Tue Dec 3 00:42:14 1996 Per Abrahamsen + + * custom-edit.el (custom-menu-nesting): Moved from `custom.el'. + (custom-menu-create-entry): Ditto. + (custom-menu-update): Ditto. + +Mon Dec 2 22:48:14 1996 Per Abrahamsen + + * custom.el (:load): New keyword. + (custom-add-load): New function. + (custom-handle-keyword): Use them. + * custom.texi: Document it. + * custom-edit.el (custom-load-symbol): New function. + (custom-load-widget): New function. + (custom-group-value-create): Use it. + (custom-variable-value-create): Use it. + (custom-face-value-create): Use it. + + * custom.el (custom-handle-keyword): New function. + (custom-declare-variable): Use it. + (custom-handle-all-keywords): New function. + (custom-declare-group): Use it. + (custom-declare-face): Use it. + +Sat Nov 30 01:37:07 1996 Per Abrahamsen + + * Version 1.09 released. + +Sat Nov 30 01:36:24 1996 Per Abrahamsen + + * widget-edit.el (widget-specify-field): Make terminating newline + writable under XEmacs. + +Thu Nov 28 22:03:56 1996 Per Abrahamsen + + * Version 1.08 released. + +Thu Nov 28 21:46:30 1996 Per Abrahamsen + + * custom-edit.el (custom-hook-convert-widget): Make space part of + function instead of the editable-list. + + * Version 1.07 released. + +Thu Nov 28 21:31:31 1996 Per Abrahamsen + + * custom-edit.el (custom-variable-state-set): Handle void + variables. + + * Version 1.06 released. + +Thu Nov 28 01:35:54 1996 Per Abrahamsen + + * widget-edit.el (widget-create-child-value): New function. + (widget-choice-value-create): Use it. + (widget-checklist-add-item): Ditto. + (widget-radio-add-item): Ditto. + (widget-editable-list-entry-create): Ditto + (widget-group-value-create): Ditto. + + * widget-edit.el (widget-specify-field): Extend read-only extent. + + * widget-edit.el (widget-create-child): Obey `:extra-offset'. + + * custom-edit.el (custom-mode-hook): Added. + +Tue Nov 26 17:04:45 1996 Per Abrahamsen + + * widget-edit.el: More patches for support of old Emacsen from + William Perry . + + * Version 1.05 released. + +Tue Nov 26 15:05:36 1996 Per Abrahamsen + + * widget-edit.el (widget-make-intangible): New function. + (widget-specify-field): Use it. + (widget-after-change): Remove XEmacs workaround. + (widget-field-value-create): Ditto. + (widget-specify-text): Fully specify stickyness. + +Mon Nov 25 17:01:05 1996 Per Abrahamsen + + * custom-edit.el (custom-face-format-handler): Create face before + use under XEmacs. + + * Version 1.04 released. + +Mon Nov 25 01:14:13 1996 Per Abrahamsen + + * custom.el (custom-facep): New function. + (custom-declare-face): Use it. + * custom-edit.el (customize-face): Ditto. + (customize-customized): Ditto. + (customize-apropos): Ditto. + (custom-save-faces): Ditto. + + * custom.el (custom-declare-variable): Return symbol. Suggested + by Lars Magne Ingebrigtsen . + (custom-declare-group): Ditto. + (custom-declare-face): Return face. + + * widget-edit.el (widget-button-face): Removed :link. + (widget-mouse-face): Ditto. + (widget-field-face): Ditto. + + * custom.el (emacs): Link to (emacs)Top, not (dir)Top. + + * Version 1.03 released. + +Mon Nov 25 00:29:27 1996 Per Abrahamsen + + * widget-edit.el (widgets): Add links. + (widget-button-face): Add link. + (widget-mouse-face): Add link. + (widget-field-face): Add link. + + * widget.texi (User Interface): Use `deffn Face' instead of + `defopt' for declaring faces. + + * custom-edit.el (custom-manual): New widget. + (custom-format-handler): Support "%a" escape. + (custom-variable): Use it. + (custom-face): Use it. + (custom-group): Use it. + + * custom.el (:link): New keyword. + (custom-declare-variable): Support it. + (custom-declare-face): Ditto. + (custom-declare-group): Ditto. + (emacs): Use it. + (customize): Ditto. + (custom-add-link): New function. + + * custom.texi (Utilities): New section. Document `custom-manual' + `custom-add-to-group', and `custom-add-link'. + + * widget.texi (url-link): New section. + (info-link): New section. + +Sat Nov 23 17:45:32 1996 Per Abrahamsen + + * Version 1.02 released. + +Sat Nov 23 17:42:31 1996 Per Abrahamsen + + * custom.el (set-face-font-family) New XEmacs function. + (custom-face-attributes): Added family support for XEmacs. + +Fri Nov 22 18:59:29 1996 Per Abrahamsen + + * Version 1.01 released. + +Fri Nov 22 16:29:08 1996 Per Abrahamsen + + * custom.el (custom-display-match-frame): Use `frame-device' to + convert a frame to a device. + + * widget-edit.el (widget-after-change): Avoid zero sized fields in + XEmacs. + (widget-field-value-create): Ditto. + + * custom.el (custom-face-display-set): Removed call to + `make-face'. Patch by David Moore . + (custom-declare-variable): If there is a saved value, use it, even + if the variable is already bound. Reported by Jens Lautenbacher + . + (custom-declare-face): If there is a saved face, use it, even + if the face is already made. + (custom-face-attributes): Added :size for XEmacs. Thanks to + William Perry for part of the code. + +Wed Nov 20 16:40:53 1996 Per Abrahamsen + + * custom-edit.el (custom-variable-value-create): Use + `default-value' instead of `symbol-value'. + (custom-variable-state-set): Ditto. + +Tue Nov 19 17:11:27 1996 Per Abrahamsen + + * widget-edit.el (custom): Wrap require in `eval-and-compile'. + +Mon Nov 18 15:55:16 1996 Per Abrahamsen + + * Version 1.00 released. + +Sat Nov 16 20:58:01 1996 Per Abrahamsen + + * custom.el (custom-help-menu): Renamed update entry to `Update + menu...'. + +Thu Nov 14 23:16:53 1996 Per Abrahamsen + + * custom-edit.el (customize-customized): Ignore uninitialized + faces and variables. + +Wed Nov 13 20:39:08 1996 Per Abrahamsen + + * Version 0.999 released. + +Wed Nov 13 12:21:56 1996 Per Abrahamsen + + * custom-edit.el: Added autolaod. + + * custom.el: Added menu support. + + * custom-edit.el (customize-customized): New command. + (custom-variable-default): Remember to evaluate default setting. + + * Version 0.998 released. + +Mon Nov 11 19:30:24 1996 Per Abrahamsen + + * widget-edit.el (widget-at): New function by William Perry + . + (widget-echo-help): Use it. + +Fri Nov 8 20:34:59 1996 Per Abrahamsen + + * widget-edit.el (widget-checklist-match-up): Cleaned up. + (function-item): Removed :match and :value-delete properties. + (variable-item): Ditto. + + * custom.el (custom-add-option): Only add option if not already + there. + (custom-declare-variable): Ditto. + + * custom-edit.el (custom-buffer-create): Reset magic. + +Thu Nov 07 16:14:35 1996 Per Abrahamsen + + * Version 0.997 released. + +Thu Nov 7 14:24:33 1996 Per Abrahamsen + + * custom-edit.el (custom-split-regexp-maybe): New function. + + * custom.el (x-color-values): Define if missing. + (frame-property): Define if missing. + (custom-background-mode): Optimized. + (custom-display-match-frame): Use above. + + * custom.el (custom-add-option): New function. + +Wed Nov 06 18:00:59 1996 Per Abrahamsen + + * Version 0.996 released. + +Wed Nov 6 09:42:33 1996 Per Abrahamsen + + * widget-edit.el (widget-children-value-delete): Renamed from + `widget-children-value-delete'. + Updated all callers. + (widget-choice-convert-widget): Renamed from `'. + + * custom-edit.el (widget-face-value-create): Add child to + `custom-options'. + (widget-face-value-delete): Added. + + * widget-edit.el (widget-keymap): Added binding for [backtab]. + Requested by Greg Stark . + +Sat Nov 2 13:40:49 1996 Per Abrahamsen + + + * custom.el (custom-set-variables): Accept `(SYMBOL VALUE [NOW])' + format. + (custom-set-faces): Accept `(FACE SPEC [NOW])' format. + * custom-edit.el (custom-save-variables): Write in new format. + (custom-save-faces): Ditto. + + * custom-edit.el (custom-format-handler): Handle `%L' escape. + (custom-group): Add `%L' escape. + (custom-face-format-handler): Use the text "hide" for sample in + shown faces. + (custom-buffer-create): Show single option. + +Tue Oct 29 13:36:11 1996 Per Abrahamsen + + * Version 0.995 released. + +Tue Oct 29 12:21:57 1996 Per Abrahamsen + + * custom.el (custom-display-match-frame): Fixed bug for + `display-type'. + + * custom.el (custom-background-mode): Memorized + `custom-background-mode' as suggested by David Moore + . + + * widget-edit.el (widget-specify-button): Make a button non-sticky + on XEmacs. + +Sun Oct 20 20:16:05 1996 Per Abrahamsen + + * custom-edit.el (easymenu): Added require. + +Mon Oct 14 15:09:43 1996 Per Abrahamsen + + * widget-edit.el: Removed `eval-and-compile' around compatibility + code. + +Sat Oct 12 21:15:04 1996 Per Abrahamsen + + * Version 0.994 released. + +Sat Oct 12 20:11:19 1996 Per Abrahamsen + + * custom.el (:options): New keyword. + + * widget-edit.el (hook): Removed widget. + (function): Allow any sexp. + + * custom-edit.el (hook): Added widget. + (custom-hook-convert-widget): New function. + + * custom.el (custom-declare-face): Check that facep is defined. + reported by Enami Tsugutomo + +Wed Oct 09 01:41:55 1996 Per Abrahamsen + + * Version 0.993 released. + +Tue Oct 8 01:48:02 1996 Per Abrahamsen + + * custom.el (custom-set-face-bold): Removed condition-case. + (custom-set-face-italic): Ditto. + (custom-face-attribites-set): Added condition-case. + (custom-set-variables): Do not bind symbol here. + (custom-set-faces): Do not create face here. + (custom-declare-variable): Use saved-value property, if is exists. + + * custom-edit.el (custom-face-format-handler): Changed `sample' to + `show'. + + * custom.el (custom-declare-face): Do not overwrite an existing + face. + +Sat Oct 05 01:23:27 1996 Per Abrahamsen + + * Version 0.992 released. + +Fri Oct 4 23:54:54 1996 Per Abrahamsen + + * widget-edit.el (character): New widget. + (widget-specify-field): Allow use of newline in format to hide + space. + +Wed Oct 2 19:06:17 1996 Per Abrahamsen + + * widget.texi (menu-choice): Document `:case-fold'. + +Wed Oct 02 19:02:45 1996 Per Abrahamsen + + * Version 0.991 released. + +Wed Oct 2 18:54:53 1996 Per Abrahamsen + + * widget-edit.el (widget-choice-action): Use :case-fold. + (menu-choice): Initialize :case-fold. + + * widget.el (:case-fold): New keyword, patch by David Byers + . + +Mon Sep 30 20:26:59 1996 Per Abrahamsen + + * lpath.el (maybe-fbind): New function. + Shut up byte compiler under XEmacs. + + * custom-edit.el (custom-format-handler): Removed unused binding. + (custom-variable-apply): Added missing argument to error. + (custom-variable-set-default): Ditto. + + * widget-edit.el (regexp): Add `:tag'. + + * custom-edit.el (custom-variable-factory): Evaluate factory + setting before applying. + +Sun Sep 29 01:24:31 1996 Per Abrahamsen + + * Version 0.99 released. + +Sun Sep 29 00:16:31 1996 Per Abrahamsen + + * widget-edit.el (widget-color-action): Notify parent. + (widget-field-action): Ditto. + (widget-choice-action): Ditto. + (widget-file-action): Ditto. + + * custom-edit.el (custom-magic-alist): Changed `item' to `const'. + (face): Fixed formatting. + (widget-face-value-create): Ditto. + (widget-face-action): Notify parent. + + * widget-edit.el (widget-field-value-get): Don't strip trailing + spaces from zero-sized fields. Requested by David Byers + . + +Sat Sep 28 00:31:54 1996 Per Abrahamsen + + * custom-edit.el (custom-save-needed-p): New variable. + (kill-emacs-hook): Add `custom-save-maybe'. + (custom-save-maybe): New function. + (custom-variable-set-default): Set `custom-save-needed-p'. + (custom-variable-factory): Ditto. + (custom-save): Ditto. + (custom-unimplemented): Deleted. + + * Version 0.98 released. + +Sat Sep 28 00:04:58 1996 Per Abrahamsen + + * widget-edit.el (widget-choice-action): Got validate wrong, once + again. + + * widget.texi (Basic Types): Documented `%h'. + +Fri Sep 27 00:32:14 1996 Per Abrahamsen + + * widget-edit.el (widget-field-action): Set value directly. + + * custom-edit.el (custom-format-handler): Use default format + handler. + + * widget-edit.el (widget-cons-match): Parameters in wrong order. + (text): Parent should be `editable-field'. + (widget-field-action): Call `widget-setup' after modification. + (symbol): Make multiple convertion kludge more robust. + (integer): Ditto. + (number): Ditto. + (widget-echo-help): New function, patch by William Perry + . + (widget-forward): Use it + (widget-echo-help-mouse): New function. + (repeat): Don't highlight tag. + (set): Ditto. + (widget-editable-list-format-handler): Default to help format + handler. + (function-item): Use default format handler. + (variable-item): Ditto. + (widget-help-format-handler): Rename to and merge with + `widget-default-format-handler'. + +Wed Sep 25 22:44:45 1996 Per Abrahamsen + + * Version 0.97 released. + +Wed Sep 25 00:12:09 1996 Per Abrahamsen + + * widget-edit.el (url-link): New widget. + + * custom-edit.el (custom-variable-set-default): Also set current + value. + + * lpath.el: Added dummy definitions to really shut up the byte + compiler. + + * custom-edit.el (custom-buffer-create): Create a help button. + + * widget-edit.el (info-link): New widget. + +Tue Sep 24 23:52:07 1996 Per Abrahamsen + + * custom.texi (The Customization Buffer): Exanded a lot. + +Mon Sep 23 18:27:55 1996 Per Abrahamsen + + * Makefile (FTPDIR): New variable. + (dist): Use it. + + * Version 0.96 released. + +Mon Sep 23 13:30:08 1996 Per Abrahamsen + + * widget.texi (editable-field): Added explanation of + :hide-front-space and :hide-rear-space. + + * widget-edit.el (widget-specify-field): Make front and rear + spaces intangible only when the :format string says it is safe, or + the user has explictly requested it. + + * widget.el (:hide-front-space): New keyword. + (:hide-rear-space): New keyword. + + * widget-edit.el (widget-field-value-create): Don't insert space + for empty values. + (widget-specify-field-update): Make null sized field have a face + that extents to the end of the line. + (widget-after-change): Make sure face is updated after extending a + fixed size field. + +Sun Sep 22 21:07:56 1996 Per Abrahamsen + + * Version 0.95 released. + +Sun Sep 22 13:44:02 1996 Per Abrahamsen + + * widget-edit.el (symbol): Kludge allowing multiple conversions. + (widget-field-value-create): Don't append spaces unless empty. + Suggested by David Byers . + (widget-field-value-get): Don't remove trailing spacesfor variable + sized fields. Suggested by David Byers . + + * custom-edit.el (custom-show): New function. + (custom-variable-value-create): Use it. + (editable-field): Only show when value has no newlines and is + shorter than 40 characters. + (custom-buffer-create): Use `switch-to-buffer' instead of + `switch-to-buffer-other-window'. + + * widget-edit.el: Added hack to make `widget-edit.el' useful even + with the old custom library. Suggested by David Byers + . + + * custom-edit.el (custom-help): Delete widget. + (custom-help-action): Delete function. + (:custom-doc): Delete keyword. + (:custom-documentation-property): Delete keyword. + (custom-format-handler): Leave `h' to `widget-help-format-handler'. + (custom): Replace `:custom-documentation-property' with + `:documentation-property'. + (custom-variable): Ditto. + (custom-face): Ditto. + (custom-group): Ditto. + + * widget-edit.el (widget-help): New widget. + (widget-help-action): New function. + (widget-help-format-handler): New function. + (function-item): New widget. + (variable-item): New widget. + (hook): New widget. + + * widget.el (:documentation-property): New keyword. + (:widget-doc): New keyword. + + * custom-edit.el (custom-variable-state-set): Compare value to + evaluted defaults. + + * widget-edit.el (radio): New sexp widget. + + * lpath.el (custom): Add require. + + * custom.el: (custom-face-empty): Test for `(boundp 'make-face)'. + Reported by enami tsugutomo . + (custom-face-display-set): Ditto. + + * lpath.el: Removed byte compiler kludge. + +Sun Sep 22 11:48:02 1996 Lars Magne Ingebrigtsen + + * custom.el (defcustom): Eval and compile. + * widget.el (define-widget-keywords): Ditto. + +Sat Sep 21 23:17:22 1996 Per Abrahamsen + + * Version 0.94 released. + +Sat Sep 21 13:26:15 1996 Per Abrahamsen + + * custom-edit.el: Added `:custom-apply', `:custom-set-default', + and `:custom-reset' keywords. + (custom-variable): Bind above. + (custom-face): Ditto. + (custom-group): Ditto. + (custom-group-menu): Activate functions below. + (custom-group-apply): New function. + (custom-group-set-default): New function. + (custom-group-reset): New function. + (custom-mode-menu): New menu. + (custom-mode): Describe all commands. + (custom-mode): Added `custom-mode-hook' hook. + (custom-apply): New command. + (custom-set-default): New command. + (custom-reset): New command. + (custom-buffer-create): Set `custom-options' properly. + (custom-buffer-create): Add `apply', `Set Default', and `Reset' + butons. + + * custom.texi (Wishlist): Remove implemented items from the + wishlist. + + * widget.texi (atoms): Document `boolean' widget. + (composite): Document `choice', `set', and `repeat' widgets. + + * widget-edit.el (boolean): New sexp widget. + + * Version 0.93 released. + +Sat Sep 21 00:57:14 1996 Per Abrahamsen + + * lpath.el Disable byte compiler hacking on XEmacs. + + * Version 0.92 released. + +Fri Sep 20 03:04:53 1996 Per Abrahamsen + + * Added support for automatic indentation of nested widgets. + + * Made code and internal API creation of nested widget more + clear and less buggy. + + * Version 0.91 released. + +Thu Sep 19 19:30:46 1996 Per Abrahamsen + + * lpath.el: Add code to shut up the compiler. + + * widget.el (define-widget-keywords): Use this to shut up the + bytecompiler. + + * widget-edit.el: (widget-field-action): New function. + (field): Added. + (string, list, vector, cons): Added tag. + + * custom-edit.el (custom-magic): New widget. + Most other widgets and functions updated to support it. + (custom-notify): New function. + (custom): Use it. + (customize-apropos): Less greedy. Thanks Ilya + Zakharevich . + + * widget-edit.el (pp-to-string): Added autoload. Thanks Ilya + Zakharevich . + +Wed Sep 18 19:24:03 1996 Per Abrahamsen + + * widget-edit.el (widget-documentation-face): New face. + (widget-specify-doc): Use it. + +Tue Sep 17 00:57:02 1996 Per Abrahamsen + + * widget-edit.el (item): Add "%d" to format. + (function): New widget. + (variable): New widget. + (regexp): New widget. + + * custom.el (custom-x-color-values): Stolen from Gnus. + (custom-background-mode): Stolen from Gnus. + (custom-display-match-frame): Should now work on XEmacs. + + * custom-edit.el: Minor cleanups in organization. + (custom-variable-value-create): Handle case where the value of a + variable does not match the type gracefully. + (custom-redraw): Renamed from `custom-reset'. + + * Version 0.9 released. + +Tue Sep 17 00:21:01 1996 Per Abrahamsen + + * widget-edit.el (widget-color-action): Use `read-prompt' in + XEmacs and `read-string' on a tty. + + * custom-edit.el (customize-apropos): Don't match undocumented + variables. + +Mon Sep 16 15:44:34 1996 Per Abrahamsen + + * custom-edit.el: Added help text to many widgets. + + * widget-edit.el (color-item): Made it a choice-item. + + * custom-edit.el (custom-level): New widget. + (custom-help): New widget. + (custom): New widget. + (custom-variable): Derive widget from `custom'. + (custom-face): Ditto. + (custom-group): Ditto. + + * widget-edit.el (widget-choose): Do not reverse the items here. + (widget-choice-action): Reverese the items here instead. + + * custom.el (keywords): Only define the keywords used by + declarations here. + + * widget-edit.el (toggle): Removed `:void' property. + + * custom.texi (Declaring Groups): Use proper defuns. + + * Makefile (TEXT): Added `ChangeLog' and `custom.texi'. + (dist): Add release to `ChangeLog'. diff -r b88636d63495 -r 8fc7fe29b841 lisp/custom/custom-edit.el --- a/lisp/custom/custom-edit.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/custom/custom-edit.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,10 +1,10 @@ ;;; custom-edit.el --- Tools for customization Emacs. ;; -;; Copyright (C) 1996 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. ;; ;; Author: Per Abrahamsen ;; Keywords: help, faces -;; Version: 1.30 +;; Version: 1.40 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;;; Commentary: @@ -156,6 +156,7 @@ (setq major-mode 'custom-mode mode-name "Custom") (use-local-map custom-mode-map) + (easy-menu-add custom-mode-menu) (make-local-variable 'custom-options) (run-hooks 'custom-mode-hook)) @@ -361,9 +362,15 @@ (widget-insert " ") (widget-create 'push-button :tag "Reset" - :help-echo "Push me to undo all modifications.." + :help-echo "Push me to undo all modifications." :action (lambda (widget &optional event) (custom-reset event))) + (widget-insert " ") + (widget-create 'push-button + :tag "Done" + :help-echo "Push me to bury the buffer." + :action (lambda (widget &optional event) + (bury-buffer))) (widget-insert "\n") (widget-setup)) @@ -700,8 +707,14 @@ (defun custom-redraw (widget) "Redraw WIDGET with current settings." - (widget-value-set widget (widget-value widget)) - (custom-redraw-magic widget)) + (let ((pos (point)) + (from (marker-position (widget-get widget :from))) + (to (marker-position (widget-get widget :to)))) + (save-excursion + (widget-value-set widget (widget-value widget)) + (custom-redraw-magic widget)) + (when (and (>= pos from) (<= pos to)) + (goto-char pos)))) (defun custom-redraw-magic (widget) "Redraw WIDGET state with current settings." @@ -860,20 +873,20 @@ (if (condition-case nil (equal value (eval (car tmp))) (error nil)) - 'saved - 'set)) + 'set + 'changed)) ((setq tmp (get symbol 'saved-value)) (if (condition-case nil (equal value (eval (car tmp))) (error nil)) 'saved - 'set)) + 'changed)) ((setq tmp (get symbol 'factory-value)) (if (condition-case nil (equal value (eval (car tmp))) (error nil)) 'factory - 'set)) + 'changed)) (t 'rogue)))) (widget-put widget :custom-state state))) @@ -898,7 +911,8 @@ (widget-put widget :custom-state 'unknown) (custom-redraw widget)) (let* ((completion-ignore-case t) - (answer (widget-choose (symbol-name (widget-get widget :value)) + (answer (widget-choose (capitalize + (symbol-name (widget-get widget :value))) custom-variable-menu event))) (if answer @@ -932,7 +946,7 @@ (set symbol (eval (setq val (widget-value child)))) (put symbol 'customized-value (list val))) (t - (set symbol (widget-value child)) + (set symbol (setq val (widget-value child))) (put symbol 'customized-value (list (custom-quote val))))) (custom-variable-state-set widget) (custom-redraw-magic widget))) @@ -1139,7 +1153,7 @@ (custom-redraw widget)) (let* ((completion-ignore-case t) (symbol (widget-get widget :value)) - (answer (widget-choose (symbol-name symbol) + (answer (widget-choose (capitalize (symbol-name symbol)) custom-face-menu event))) (if answer (funcall answer widget))))) @@ -1362,7 +1376,8 @@ (widget-put widget :custom-state 'unknown) (custom-redraw widget)) (let* ((completion-ignore-case t) - (answer (widget-choose (symbol-name (widget-get widget :value)) + (answer (widget-choose (capitalize + (symbol-name (widget-get widget :value))) custom-group-menu event))) (if answer diff -r b88636d63495 -r 8fc7fe29b841 lisp/custom/custom.el --- a/lisp/custom/custom.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/custom/custom.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,10 +1,10 @@ ;;; custom.el -- Tools for declaring and initializing options. ;; -;; Copyright (C) 1996 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. ;; ;; Author: Per Abrahamsen ;; Keywords: help, faces -;; Version: 1.30 +;; Version: 1.40 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;;; Commentary: @@ -22,6 +22,7 @@ (define-widget-keywords :prefix :tag :load :link :options :type :group) ;; These autoloads should be deleted when the file is added to Emacs + (unless (fboundp 'load-gc) (autoload 'customize "custom-edit" nil t) (autoload 'customize-variable "custom-edit" nil t) @@ -93,7 +94,6 @@ ;;; The `defcustom' Macro. -;;; Don't ;;;###autoload (defun custom-declare-variable (symbol value doc &rest args) "Like `defcustom', but SYMBOL and VALUE are evaluated as notmal arguments." (unless (and (default-boundp symbol) @@ -130,7 +130,6 @@ (run-hooks 'custom-define-hook) symbol) -;;; Don't ;;;###autoload (defmacro defcustom (symbol value doc &rest args) "Declare SYMBOL as a customizable variable that defaults to VALUE. DOC is the variable documentation. @@ -155,7 +154,6 @@ ;;; The `defface' Macro. -;;; Don't ;;;###autoload (defun custom-declare-face (face spec doc &rest args) "Like `defface', but FACE is evaluated as a normal argument." (put face 'factory-face spec) @@ -171,7 +169,6 @@ (run-hooks 'custom-define-hook) face) -;;; Don't ;;;###autoload (defmacro defface (face spec doc &rest args) "Declare FACE as a customizable face that defaults to SPEC. FACE does not need to be quoted. @@ -221,7 +218,6 @@ ;;; The `defgroup' Macro. -;;; Don't ;;;###autoload (defun custom-declare-group (symbol members doc &rest args) "Like `defgroup', but SYMBOL is evaluated as a normal argument." (put symbol 'custom-group (nconc members (get symbol 'custom-group))) @@ -245,7 +241,6 @@ (run-hooks 'custom-define-hook) symbol) -;;; Don't ;;;###autoload (defmacro defgroup (symbol members doc &rest args) "Declare SYMBOL as a customization group containing MEMBERS. SYMBOL does not need to be quoted. @@ -270,7 +265,6 @@ information." `(custom-declare-group (quote ,symbol) ,members ,doc ,@args)) -;;; Don't ;;;###autoload (defun custom-add-to-group (group option widget) "To existing GROUP add a new OPTION of type WIDGET, If there already is an entry for that option, overwrite it." @@ -468,7 +462,6 @@ (make-face-italic face frame) (make-face-unitalic face frame))) -;;; Don't ;;;###autoload (defun custom-initialize-faces (&optional frame) "Initialize all custom faces for FRAME. If FRAME is nil or omitted, initialize them for all frames." @@ -480,7 +473,6 @@ ;;; Initializing. -;;; Don't ;;;###autoload (defun custom-set-variables (&rest args) "Initialize variables according to user preferences. @@ -508,7 +500,6 @@ (put symbol 'saved-value (list value))) (setq args (cdr (cdr args))))))) -;;; Don't ;;;###autoload (defun custom-set-faces (&rest args) "Initialize faces according to user preferences. The arguments should be a list where each entry has the form: diff -r b88636d63495 -r 8fc7fe29b841 lisp/custom/widget-browse.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/custom/widget-browse.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,232 @@ +;;; widget-browse.el --- Functions for browsing widgets. +;; +;; Copyright (C) 1997 Free Software Foundation, Inc. +;; +;; Author: Per Abrahamsen +;; Keywords: extensions +;; Version: 1.40 +;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ + +;;; Commentary: +;; +;; Widget browser. See `widget.el'. + +;;; Code: + +(require 'easymenu) +(require 'custom) +(require 'widget-edit) +(require 'cl) + +(defgroup widget-browse nil + "Customization support for browsing widgets." + :group 'widgets) + +;;; The Mode. + +(defvar widget-browse-mode-map nil + "Keymap for `widget-browse-mode'.") + +(unless widget-browse-mode-map + (setq widget-browse-mode-map (make-sparse-keymap)) + (set-keymap-parent widget-browse-mode-map widget-keymap)) + +(easy-menu-define widget-browse-mode-menu + widget-browse-mode-map + "Menu used in widget browser buffers." + '("Widget" + ["Browse" widget-browse t] + ["Browse At" widget-browse-at t])) + +(defcustom widget-browse-mode-hook nil + "Hook called when entering widget-browse-mode." + :type 'hook + :group 'widget-browse) + +(defun widget-browse-mode () + "Major mode for widget browser buffers. + +The following commands are available: + +\\[widget-forward] Move to next button or editable field. +\\[widget-backward] Move to previous button or editable field. +\\[widget-button-click] Activate button under the mouse pointer. +\\[widget-button-press] Activate button under point. + +Entry to this mode calls the value of `widget-browse-mode-hook' +if that value is non-nil." + (kill-all-local-variables) + (setq major-mode 'widget-browse-mode + mode-name "Widget") + (use-local-map widget-browse-mode-map) + (easy-menu-add widget-browse-mode-menu) + (run-hooks 'widget-browse-mode-hook)) + +;;; Commands. + +;;;###autoload +(defun widget-browse-at (pos) + "Browse the widget under point." + (interactive "d") + (let* ((field (get-text-property pos 'field)) + (button (get-text-property pos 'button)) + (doc (get-text-property pos 'widget-doc)) + (text (cond (field "This is an editable text area.") + (button "This is an active area.") + (doc "This is documentation text.") + (t "This is unidentified text."))) + (widget (or field button doc))) + (when widget + (widget-browse widget)) + (message text))) + +(defvar widget-browse-history nil) + +(defun widget-browse (widget) + "Create a widget browser for WIDGET." + (interactive (list (completing-read "Widget: " + obarray + (lambda (symbol) + (get symbol 'widget-type)) + t nil 'widget-browse-history))) + (if (stringp widget) + (setq widget (intern widget))) + (unless (if (symbolp widget) + (get widget 'widget-type) + (and (consp widget) + (get (widget-type widget) 'widget-type))) + (error "Not a widget.")) + ;; Create the buffer. + (if (symbolp widget) + (let ((buffer (format "*Browse %s Widget*" widget))) + (kill-buffer (get-buffer-create buffer)) + (switch-to-buffer (get-buffer-create buffer))) + (kill-buffer (get-buffer-create "*Browse Widget*")) + (switch-to-buffer (get-buffer-create "*Browse Widget*"))) + (widget-browse-mode) + + ;; Quick way to get out. + (widget-create 'push-button + :action (lambda (widget &optional event) + (bury-buffer)) + "Quit") + (widget-insert "\n") + + ;; Top text indicating whether it is a class or object browser. + (if (listp widget) + (widget-insert "Widget object browser.\n\nClass: ") + (widget-insert "Widget class browser.\n\n") + (widget-create 'widget-browse + :format "%[%v%]\n%d" + :doc (get widget 'widget-documentation) + widget) + (unless (eq (preceding-char) ?\n) + (widget-insert "\n")) + (widget-insert "\nSuper: ") + (setq widget (get widget 'widget-type))) + + ;; Now show the attributes. + (let ((name (car widget)) + (items (cdr widget)) + key value printer) + (widget-create 'widget-browse + :format "%[%v%]" + name) + (widget-insert "\n") + (while items + (setq key (nth 0 items) + value (nth 1 items) + printer (or (get key 'widget-keyword-printer) + 'widget-browse-sexp) + items (cdr (cdr items))) + (widget-insert "\n" (symbol-name key) "\n\t") + (funcall printer widget key value) + (widget-insert "\n"))) + (widget-setup) + (goto-char (point-min))) + +;;; The `widget-browse' Widget. + +(define-widget 'widget-browse 'push-button + "Button for creating a widget browser. +The :value of the widget shuld be the widget to be browsed." + :format "%[[%v]%]" + :value-create 'widget-browse-value-create + :action 'widget-browse-action) + +(defun widget-browse-action (widget &optional event) + ;; Create widget browser for WIDGET's :value. + (widget-browse (widget-get widget :value))) + +(defun widget-browse-value-create (widget) + ;; Insert type name. + (let ((value (widget-get widget :value))) + (cond ((symbolp value) + (insert (symbol-name value))) + ((consp value) + (insert (symbol-name (widget-type value)))) + (t + (insert "strange"))))) + +;;; Keyword Printer Functions. + +(defun widget-browse-widget (widget key value) + "Insert description of WIDGET's KEY VALUE. +VALUE is assumed to be a widget." + (widget-create 'widget-browse value)) + +(defun widget-browse-widgets (widget key value) + "Insert description of WIDGET's KEY VALUE. +VALUE is assumed to be a list of widgets." + (while value + (widget-create 'widget-browse + (car value)) + (setq value (cdr value)) + (when value + (widget-insert " ")))) + +(defun widget-browse-sexp (widget key value) + "Insert description of WIDGET's KEY VALUE. +Nothing is assumed about value." + (let ((pp (condition-case signal + (pp-to-string value) + (error (prin1-to-string signal))))) + (when (string-match "\n\\'" pp) + (setq pp (substring pp 0 (1- (length pp))))) + (if (cond ((string-match "\n" pp) + nil) + ((> (length pp) (- (window-width) (current-column))) + nil) + (t t)) + (widget-insert pp) + (widget-create 'push-button + :tag "show" + :action (lambda (widget &optional event) + (with-output-to-temp-buffer + "*Pp Eval Output*" + (princ (widget-get widget :value)))) + pp)))) + +(defun widget-browse-sexps (widget key value) + "Insert description of WIDGET's KEY VALUE. +VALUE is assumed to be a list of widgets." + (let ((target (current-column))) + (while value + (widget-browse-sexp widget key (car value)) + (setq value (cdr value)) + (when value + (widget-insert "\n" (make-string target ?\ )))))) + +;;; Keyword Printers. + +(put :parent 'widget-keyword-printer 'widget-browse-widget) +(put :children 'widget-keyword-printer 'widget-browse-widgets) +(put :buttons 'widget-keyword-printer 'widget-browse-widgets) +(put :button 'widget-keyword-printer 'widget-browse-widget) +(put :args 'widget-keyword-printer 'widget-browse-sexps) + +;;; The End: + +(provide 'widget-browse) + +;; widget-browse.el ends here diff -r b88636d63495 -r 8fc7fe29b841 lisp/custom/widget-edit.el --- a/lisp/custom/widget-edit.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/custom/widget-edit.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,10 +1,10 @@ ;;; widget-edit.el --- Functions for creating and using widgets. ;; -;; Copyright (C) 1996 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. ;; ;; Author: Per Abrahamsen ;; Keywords: extensions -;; Version: 1.30 +;; Version: 1.40 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;;; Commentary: @@ -49,6 +49,7 @@ (defmacro defgroup (&rest args) nil) (defmacro defcustom (&rest args) nil) (defmacro defface (&rest args) nil) + (define-widget-keywords :prefix :tag :load :link :options :type :group) (when (fboundp 'copy-face) (copy-face 'default 'widget-documentation-face) (copy-face 'bold 'widget-button-face) @@ -126,7 +127,7 @@ ;; ;; These are not really widget specific. -(defun widget-plist-member (plist prop) +(defsubst widget-plist-member (plist prop) ;; Return non-nil if PLIST has the property PROP. ;; PLIST is a property list, which is a list of the form ;; (PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol. @@ -174,7 +175,7 @@ event (fboundp 'popup-menu) window-system) ;; We are in XEmacs, pressed by the mouse (let ((val (get-popup-menu-response - (cons "" + (cons title (mapcar (function (lambda (x) @@ -346,8 +347,8 @@ ;;; Widget Properties. -(defsubst widget-name (widget) - "Return the name of WIDGET, asymbol." +(defsubst widget-type (widget) + "Return the type of WIDGET, a symbol." (car widget)) (defun widget-put (widget property value) @@ -359,11 +360,17 @@ "In WIDGET, get the value of PROPERTY. The value could either be specified when the widget was created, or later with `widget-put'." - (cond ((widget-plist-member (cdr widget) property) - (plist-get (cdr widget) property)) - ((car widget) - (widget-get (get (car widget) 'widget-type) property)) - (t nil))) + (let ((missing t) + value tmp) + (while missing + (cond ((setq tmp (widget-plist-member (cdr widget) property)) + (setq value (car (cdr tmp)) + missing nil)) + ((setq tmp (car widget)) + (setq widget (get tmp 'widget-type))) + (t + (setq missing nil)))) + value)) (defun widget-member (widget property) "Non-nil iff there is a definition in WIDGET for PROPERTY." @@ -398,6 +405,50 @@ (cons (list (car vals)) (cdr vals))) (t nil))) +;;; Glyphs. + +(defcustom widget-glyph-directory (concat data-directory "custom/") + "Where widget glyphs are located. +If this variable is nil, widget will try to locate the directory +automatically. This does not work yet." + :group 'widgets + :type 'directory) + +(defcustom widget-glyph-enable t + "If non nil, use glyphs in images when available." + :group 'widgets + :type 'boolean) + +(defun widget-glyph-insert (widget tag image) + "In WIDGET, insert the text TAG or, if supported, IMAGE. +IMAGE should be a name sans extension of an xpm or xbm file located in +`widget-glyph-directory'" + (if (and (string-match "XEmacs" emacs-version) + widget-glyph-enable + (fboundp 'make-glyph) + image) + (let ((file (concat widget-glyph-directory + (if (string-match "/\\'" widget-glyph-directory) + "" + "/") + image + (if (featurep 'xpm) ".xpm" ".xbm")))) + (if (file-readable-p file) + (widget-glyph-insert-glyph widget tag (make-glyph file)) + ;; File not readable, give up. + (insert tag))) + ;; We don't want or can't use glyphs. + (insert tag))) + +(defun widget-glyph-insert-glyph (widget tag glyph) + "In WIDGET, with alternative text TAG, insert GLYPH." + (set-glyph-image glyph (cons 'tty tag)) + (set-glyph-property glyph 'widget widget) + (insert "*") + (add-text-properties (1- (point)) (point) + (list 'invisible t + 'end-glyph glyph))) + ;;; Creating Widgets. ;;;###autoload @@ -516,9 +567,11 @@ (define-key widget-keymap [(shift tab)] 'widget-backward) (define-key widget-keymap [backtab] 'widget-backward) (if (string-match "XEmacs" (emacs-version)) - (define-key widget-keymap [button2] 'widget-button-click) - (define-key widget-keymap [menu-bar] 'nil) - (define-key widget-keymap [mouse-2] 'widget-button-click)) + (progn + (define-key widget-keymap [button2] 'widget-button-click) + (define-key widget-keymap [button1] 'widget-button1-click)) + (define-key widget-keymap [mouse-2] 'ignore) + (define-key widget-keymap [down-mouse-2] 'widget-button-click)) (define-key widget-keymap "\C-m" 'widget-button-press)) (defvar widget-global-map global-map @@ -530,6 +583,8 @@ (unless widget-field-keymap (setq widget-field-keymap (copy-keymap widget-keymap)) + (unless (string-match "XEmacs" (emacs-version)) + (define-key widget-field-keymap [menu-bar] 'nil)) (define-key widget-field-keymap "\C-m" 'widget-field-activate) (define-key widget-field-keymap "\C-a" 'widget-beginning-of-line) (define-key widget-field-keymap "\C-e" 'widget-end-of-line) @@ -540,6 +595,8 @@ (unless widget-text-keymap (setq widget-text-keymap (copy-keymap widget-keymap)) + (unless (string-match "XEmacs" (emacs-version)) + (define-key widget-text-keymap [menu-bar] 'nil)) (define-key widget-text-keymap "\C-a" 'widget-beginning-of-line) (define-key widget-text-keymap "\C-e" 'widget-end-of-line) (set-keymap-parent widget-text-keymap global-map)) @@ -547,7 +604,7 @@ (defun widget-field-activate (pos &optional event) "Activate the ediable field at point." (interactive "@d") - (let* ((field (get-text-property pos 'field))) + (let ((field (get-text-property pos 'field))) (if field (widget-apply field :action event) (call-interactively @@ -556,16 +613,43 @@ (defun widget-button-click (event) "Activate button below mouse pointer." (interactive "@e") - (widget-button-press (event-point event) event)) + (cond ((and (fboundp 'event-glyph) + (event-glyph event)) + (let ((widget (glyph-property (event-glyph event) 'widget))) + (if widget + (widget-apply widget :action event) + (message "You clicked on a glyph.")))) + ((event-point event) + (let ((button (get-text-property (event-point event) 'button))) + (if button + (widget-apply button :action event) + (call-interactively + (or (lookup-key widget-global-map [ button2 ]) + (lookup-key widget-global-map [ down-mouse-2 ]) + (lookup-key widget-global-map [ mouse-2])))))) + (t + (message "You clicked somewhere weird.")))) + +(defun widget-button1-click (event) + "Activate glyph below mouse pointer." + (interactive "@e") + (if (and (fboundp 'event-glyph) + (event-glyph event)) + (let ((widget (glyph-property (event-glyph event) 'widget))) + (if widget + (widget-apply widget :action event) + (message "You clicked on a glyph."))) + (call-interactively (lookup-key widget-global-map (this-command-keys))))) (defun widget-button-press (pos &optional event) "Activate button at POS." (interactive "@d") - (let* ((button (get-text-property pos 'button))) + (let ((button (get-text-property pos 'button))) (if button (widget-apply button :action event) - (call-interactively - (lookup-key widget-global-map (this-command-keys)))))) + (let ((command (lookup-key widget-global-map (this-command-keys)))) + (when (commandp command) + (call-interactively command)))))) (defun widget-move (arg) "Move point to the ARG next field or button. @@ -672,37 +756,6 @@ (kill-region (point) next) (call-interactively 'kill-line)))) -(defun widget-identify (pos) - "Identify the widget under point." - (interactive "d") - (let* ((field (get-text-property pos 'field)) - (button (get-text-property pos 'button)) - (doc (get-text-property pos 'widget-doc)) - (widget (or field button doc))) - (with-output-to-temp-buffer "*Widget Identity*" - (princ (cond (field "This is an editable text area.\n") - (button "This is an active area.\n") - (doc "This is documentation text.\n") - (t "This is unidentified text.\n"))) - (while widget - (princ "It is part of a `") - (princ (car widget)) - (princ "' widget (value: ") - (prin1 (condition-case nil - (widget-value widget) - (error 'error))) - (princ ").\n") - (when (eq (car widget) 'radio-button) - (let ((sibling (widget-get-sibling widget))) - (if (not sibling) - (princ "It doesn't seem to control anything.\n") - (princ "The value of its sibling is: ") - (prin1 (condition-case nil - (widget-value sibling) - (error 'error))) - (princ ".\n")))) - (setq widget (widget-get widget :parent)))))) - ;;; Setting up the buffer. (defvar widget-field-new nil) @@ -841,6 +894,7 @@ (widget-specify-insert (let ((from (point)) (tag (widget-get widget :tag)) + (glyph (widget-get widget :tag-glyph)) (doc (widget-get widget :doc)) button-begin button-end sample-begin sample-end @@ -848,7 +902,7 @@ value-pos) (insert (widget-get widget :format)) (goto-char from) - ;; Parse % escapes in format. + ;; Parse escapes in format. (while (re-search-forward "%\\(.\\)" nil t) (let ((escape (aref (match-string 1) 0))) (replace-match "" t t) @@ -867,10 +921,13 @@ (insert "\n") (insert-char ? (widget-get widget :indent)))) ((eq escape ?t) - (if tag - (insert tag) - (let ((standard-output (current-buffer))) - (princ (widget-get widget :value))))) + (cond (glyph + (widget-glyph-insert widget (or tag "image") glyph)) + (tag + (insert tag)) + (t + (let ((standard-output (current-buffer))) + (princ (widget-get widget :value)))))) ((eq escape ?d) (when doc (setq doc-begin (point)) @@ -1043,9 +1100,40 @@ ;;; The `push-button' Widget. +(defcustom widget-push-button-gui t + "If non nil, use GUI push buttons when available." + :group 'widgets + :type 'boolean) + +;; Cache already created GUI objects. +(defvar widget-push-button-cache nil) + (define-widget 'push-button 'item "A pushable button." - :format "%[[%t]%]") + :value-create 'widget-push-button-value-create + :format "%[%v%]") + +(defun widget-push-button-value-create (widget) + ;; Insert text representing the `on' and `off' states. + (let* ((tag (or (widget-get widget :tag) + (widget-get widget :value))) + (text (concat "[" tag "]")) + (gui (cdr (assoc tag widget-push-button-cache)))) + (if (and (fboundp 'make-gui-button) + (fboundp 'make-glyph) + widget-push-button-gui + (string-match "XEmacs" emacs-version)) + (progn + (unless gui + (setq gui (make-gui-button tag 'widget-gui-action widget)) + (push (cons tag gui) widget-push-button-cache)) + (widget-glyph-insert-glyph widget text + (make-glyph (car (aref gui 1))))) + (insert text)))) + +(defun widget-gui-action (widget) + "Apply :action for WIDGET." + (widget-apply widget :action (this-command-keys))) ;;; The `link' Widget. @@ -1321,8 +1409,12 @@ (defun widget-toggle-value-create (widget) ;; Insert text representing the `on' and `off' states. (if (widget-value widget) - (insert (widget-get widget :on)) - (insert (widget-get widget :off)))) + (widget-glyph-insert widget + (widget-get widget :on) + (widget-get widget :on-glyph)) + (widget-glyph-insert widget + (widget-get widget :off) + (widget-get widget :off-glyph)))) (defun widget-toggle-action (widget &optional event) ;; Toggle value. @@ -1335,7 +1427,9 @@ "A checkbox toggle." :format "%[%v%]" :on "[X]" - :off "[ ]") + :on-glyph "check1" + :off "[ ]" + :off-glyph "check0") ;;; The `checklist' Widget. @@ -1504,7 +1598,9 @@ :notify 'widget-radio-button-notify :format "%[%v%]" :on "(*)" - :off "( )") + :on-glyph "radio1" + :off "( )" + :off-glyph "radio0") (defun widget-radio-button-notify (widget child &optional event) ;; Tell daddy. @@ -1688,6 +1784,11 @@ ;;; The `editable-list' Widget. +(defcustom widget-editable-list-gui nil + "If non nil, use GUI push-buttons in editable list when available." + :type 'boolean + :group 'widgets) + (define-widget 'editable-list 'default "A variable list of widgets of the same type." :convert-widget 'widget-types-convert-widget @@ -1707,12 +1808,13 @@ (defun widget-editable-list-format-handler (widget escape) ;; We recognize the insert button. - (cond ((eq escape ?i) - (and (widget-get widget :indent) - (insert-char ? (widget-get widget :indent))) - (widget-create-child-and-convert widget 'insert-button)) - (t - (widget-default-format-handler widget escape)))) + (let ((widget-push-button-gui widget-editable-list-gui)) + (cond ((eq escape ?i) + (and (widget-get widget :indent) + (insert-char ? (widget-get widget :indent))) + (widget-create-child-and-convert widget 'insert-button)) + (t + (widget-default-format-handler widget escape))))) (defun widget-editable-list-value-create (widget) ;; Insert all values @@ -1822,6 +1924,7 @@ (defun widget-editable-list-entry-create (widget value conv) ;; Create a new entry to the list. (let ((type (nth 0 (widget-get widget :args))) + (widget-push-button-gui widget-editable-list-gui) child delete insert) (widget-specify-insert (save-excursion @@ -2150,7 +2253,7 @@ (define-widget 'boolean 'toggle "To be nil or non-nil, that is the question." :tag "Boolean" - :format "%{%t%}: %[%v%]") + :format "%{%t%}: %[%v%]\n") ;;; The `color' Widget. diff -r b88636d63495 -r 8fc7fe29b841 lisp/custom/widget-example.el --- a/lisp/custom/widget-example.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/custom/widget-example.el Mon Aug 13 08:50:29 2007 +0200 @@ -4,7 +4,7 @@ ;; ;; Author: Per Abrahamsen ;; Keywords: help, extensions, faces, hypermedia -;; Version: 1.30 +;; Version: 1.40 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ (require 'widget) diff -r b88636d63495 -r 8fc7fe29b841 lisp/custom/widget.el --- a/lisp/custom/widget.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/custom/widget.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,10 +1,10 @@ ;;; widget.el --- a library of user interface components. ;; -;; Copyright (C) 1996 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. ;; ;; Author: Per Abrahamsen ;; Keywords: help, extensions, faces, hypermedia -;; Version: 1.30 +;; Version: 1.40 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ ;;; Commentary: @@ -27,7 +27,7 @@ (set (car keywords) (car keywords))) (setq keywords (cdr keywords))))))) -(define-widget-keywords :valid-regexp +(define-widget-keywords :tag-glyph :off-glyph :on-glyph :valid-regexp :secret :sample-face :sample-face-get :case-fold :widget-doc :create :convert-widget :format :value-create :offset :extra-offset :tag :doc :from :to :args :value :value-from :value-to :action @@ -44,6 +44,8 @@ ;; These autoloads should be deleted when the file is added to Emacs. (autoload 'widget-create "widget-edit") (autoload 'widget-insert "widget-edit") +(autoload 'widget-browse "widget-browse" nil t) +(autoload 'widget-browse-at "widget-browse" nil t) ;;;###autoload (defun define-widget (name class doc &rest args) diff -r b88636d63495 -r 8fc7fe29b841 lisp/dired/ange-ftp.el --- a/lisp/dired/ange-ftp.el Mon Aug 13 08:50:06 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,6155 +0,0 @@ -;;; ange-ftp.el --- transparent FTP support for GNU Emacs -;; Keywords: comm - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; File: ange-ftp.el -;; RCS: Header: ange-ftp.el,v 4.20 92/08/14 17:04:34 ange Exp -;; Description: transparent FTP support for GNU Emacs -;; Author: Andy Norman, ange@hplb.hpl.hp.com -;; Created: Thu Oct 12 14:00:05 1989 -;; Modified: Wed May 3 00:50:40 1995 (Andy Norman) ange@hplb.hpl.hp.com -;; Modified for XEmacs by jwz -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; Copyright (C) 1989, 1990, 1991, 1992 Andy Norman. -;;; -;;; Author: Andy Norman (ange@hplb.hpl.hp.com) -;;; -;;; 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 1, 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. -;;; -;;; A copy of the GNU General Public License can be obtained from this -;;; program's author (send electronic mail to ange@hplb.hpl.hp.com) or from -;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA -;;; 02139, USA. - -;;; Synched up with: Not synched with FSF. - -;;; Description: -;;; -;;; This package attempts to make accessing files and directories using FTP -;;; from within GNU Emacs as simple and transparent as possible. A subset of -;;; the common file-handling routines are extended to interact with FTP. - -;;; Installation: -;;; -;;; Byte-compile ange-ftp.el to ange-ftp.elc and put them both in a directory -;;; on your load-path. Load the package from your .emacs file with: -;;; -;;; (require 'ange-ftp). -;;; -;;; ange-ftp can't sensibly be auto-loaded; you are either using it, or you -;;; ain't. - -;;; Usage: -;;; -;;; Some of the common GNU Emacs file-handling operations have been made -;;; FTP-smart. If one of these routines is given a filename that matches -;;; '/user@host:path' then it will spawn an FTP process connecting to machine -;;; 'host' as account 'user' and perform its operation on the file 'path'. -;;; -;;; For example: if find-file is given a filename of: -;;; -;;; /ange@anorman:/tmp/notes -;;; -;;; then ange-ftp will spawn an FTP process, connect to the host 'anorman' as -;;; user 'ange', get the file '/tmp/notes' and pop up a buffer containing the -;;; contents of that file as if it were on the local filesystem. If ange-ftp -;;; needed a password to connect then it would prompt the user in the -;;; minibuffer. - -;;; Extended filename syntax: -;;; -;;; The default extended filename syntax is '/user@host:path', where the -;;; 'user@' part may be omitted. This syntax can be customised to a certain -;;; extent by changing ange-ftp-path-format. There are limitations. -;;; -;;; If the user part is omitted then ange-ftp will generate a default user -;;; instead whose value depends on the variable ange-ftp-default-user. - -;;; Passwords: -;;; -;;; A password is required for each host / user pair. This will be prompted -;;; for when needed, unless already set by calling ange-ftp-set-passwd, or -;;; specified in a *valid* ~/.netrc file. - -;;; Passwords for user "anonymous": -;;; -;;; Passwords for the user "anonymous" (or "ftp") are handled specially. The -;;; variable ange-ftp-generate-anonymous-password controls what happens: if -;;; the value of this variable is a string, then this is used as the password; -;;; if non-nil, then a password is created from the name of the user and the -;;; hostname of the machine on which GNU Emacs is running; if nil (the -;;; default) then the user is prompted for a password as normal. - -;;; "Dumb" UNIX hosts: -;;; -;;; The FTP servers on some UNIX machines have problems if the 'ls' command is -;;; used. -;;; -;;; The routine ange-ftp-add-dumb-unix-host can be called to tell ange-ftp to -;;; limit itself to the DIR command and not 'ls' for a given UNIX host. Note -;;; that this change will take effect for the current GNU Emacs session only. -;;; See below for a discussion of non-UNIX hosts. If a large number of -;;; machines with similar hostnames have this problem then it is easier to set -;;; the value of ange-ftp-dumb-unix-host-regexp in your .emacs file. ange-ftp -;;; is unable to automatically recognize dumb unix hosts. - -;;; File name completion: -;;; -;;; Full file-name completion is supported on UNIX, VMS, CMS, and MTS hosts. -;;; To do filename completion, ange-ftp needs a listing from the remote host. -;;; Therefore, for very slow connections, it might not save any time. - -;;; FTP processes: -;;; -;;; When ange-ftp starts up an FTP process, it leaves it running for speed -;;; purposes. Some FTP servers will close the connection after a period of -;;; time, but ange-ftp should be able to quietly reconnect the next time that -;;; the process is needed. -;;; -;;; The FTP process will be killed should the associated "*ftp user@host*" -;;; buffer be deleted. This should not cause ange-ftp any grief. - -;;; Binary file transfers: -;;; -;;; By default ange-ftp will transfer files in ASCII mode. If a file being -;;; transferred matches the value of ange-ftp-binary-file-name-regexp then the -;;; FTP process will be toggled into BINARY mode before the transfer and back -;;; to ASCII mode after the transfer. - -;;; Account passwords: -;;; -;;; Some FTP servers require an additional password which is sent by the -;;; ACCOUNT command. ange-ftp partially supports this by allowing the user to -;;; specify an account password by either calling ange-ftp-set-account, or by -;;; specifying an account token in the .netrc file. If the account password -;;; is set by either of these methods then ange-ftp will issue an ACCOUNT -;;; command upon starting the FTP process. - -;;; Preloading: -;;; -;;; ange-ftp can be preloaded, but must be put in the site-init.el file and -;;; not the site-load.el file in order for the documentation strings for the -;;; functions being overloaded to be available. - -;;; Status reports: -;;; -;;; Most ange-ftp commands that talk to the FTP process output a status -;;; message on what they are doing. In addition, ange-ftp can take advantage -;;; of the FTP client's HASH command to display the status of transferring -;;; files and listing directories. See the documentation for the variables -;;; ange-ftp-{ascii,binary}-hash-mark-size, ange-ftp-send-hash and -;;; ange-ftp-process-verbose for more details. - -;;; Gateways: -;;; -;;; Sometimes it is neccessary for the FTP process to be run on a different -;;; machine than the machine running GNU Emacs. This can happen when the -;;; local machine has restrictions on what hosts it can access. -;;; -;;; ange-ftp has support for running the ftp process on a different (gateway) -;;; machine. The way it works is as follows: -;;; -;;; 1) Set the variable 'ange-ftp-gateway-host' to the name of a machine -;;; that doesn't have the access restrictions. -;;; -;;; 2) Set the variable 'ange-ftp-local-host-regexp' to a regular expression -;;; that matches hosts that can be contacted from running a local ftp -;;; process, but fails to match hosts that can't be accessed locally. For -;;; example: -;;; -;;; "\\.hp\\.com$\\|^[^.]*$" -;;; -;;; will match all hosts that are in the .hp.com domain, or don't have an -;;; explicit domain in their name, but will fail to match hosts with -;;; explicit domains or that are specified by their ip address. -;;; -;;; 3) Using NFS and symlinks, make sure that there is a shared directory with -;;; the *same* name between the local machine and the gateway machine. -;;; This directory is neccessary for temporary files created by ange-ftp. -;;; -;;; 4) Set the variable 'ange-ftp-gateway-tmp-name-template' to the name of -;;; this directory plus an identifying filename prefix. For example: -;;; -;;; "/nfs/hplose/ange/ange-ftp" -;;; -;;; where /nfs/hplose/ange is a directory that is shared between the -;;; gateway machine and the local machine. -;;; -;;; The simplest way of getting a ftp process running on the gateway machine -;;; is if you can spawn a remote shell using either 'rsh' or 'remsh'. If you -;;; can't do this for some reason such as security then points 7 onwards will -;;; discuss an alternative approach. -;;; -;;; 5) Set the variable ange-ftp-gateway-program to the name of the remote -;;; shell process such as 'remsh' or 'rsh' if the default isn't correct. -;;; -;;; 6) Set the variable ange-ftp-gateway-program-interactive to nil if it -;;; isn't already. This tells ange-ftp that you are using a remote shell -;;; rather than logging in using telnet or rlogin. -;;; -;;; That should be all you need to allow ange-ftp to spawn a ftp process on -;;; the gateway machine. If you have to use telnet or rlogin to get to the -;;; gateway machine then follow the instructions below. -;;; -;;; 7) Set the variable ange-ftp-gateway-program to the name of the program -;;; that lets you log onto the gateway machine. This may be something like -;;; telnet or rlogin. -;;; -;;; 8) Set the variable ange-ftp-gateway-prompt-pattern to a regular -;;; expression that matches the prompt you get when you login to the -;;; gateway machine. Be very specific here; this regexp must not match -;;; *anything* in your login banner except this prompt. -;;; shell-prompt-pattern is far too general as it appears to match some -;;; login banners from Sun machines. For example: -;;; -;;; "^$*$ *" -;;; -;;; 9) Set the variable ange-ftp-gateway-program-interactive to 't' to let -;;; ange-ftp know that it has to "hand-hold" the login to the gateway -;;; machine. -;;; -;;; 10) Set the variable ange-ftp-gateway-setup-term-command to a UNIX command -;;; that will put the pty connected to the gateway machine into a -;;; no-echoing mode, and will strip off carriage-returns from output from -;;; the gateway machine. For example: -;;; -;;; "stty -onlcr -echo" -;;; -;;; will work on HP-UX machines, whereas: -;;; -;;; "stty -echo nl" -;;; -;;; appears to work for some Sun machines. -;;; -;;; That's all there is to it. - -;;; Smart gateways: -;;; -;;; If you have a "smart" ftp program that allows you to issue commands like -;;; "USER foo@bar" which do nice proxy things, then look at the variables -;;; ange-ftp-smart-gateway and ange-ftp-smart-gateway-port. - -;;; Tips for using ange-ftp: -;;; -;;; 1. For dired to work on a host which marks symlinks with a trailing @ in -;;; an ls -alF listing, you need to (setq dired-ls-F-marks-symlinks t). -;;; Most UNIX systems do not do this, but ULTRIX does. If you think that -;;; there is a chance you might connect to an ULTRIX machine (such as -;;; prep.ai.mit.edu), then set this variable accordingly. This will have -;;; the side effect that dired will have problems with symlinks whose names -;;; end in an @. If you get youself into this situation then editing -;;; dired's ls-switches to remove "F", will temporarily fix things. -;;; -;;; 2. If you know that you are connecting to a certain non-UNIX machine -;;; frequently, and ange-ftp seems to be unable to guess its host-type, -;;; then setting the appropriate host-type regexp -;;; (ange-ftp-vms-host-regexp, ange-ftp-mts-host-regexp, or -;;; ange-ftp-cms-host-regexp) accordingly should help. Also, please report -;;; ange-ftp's inability to recognize the host-type as a bug. -;;; -;;; 3. For slow connections, you might get "listing unreadable" error -;;; messages, or get an empty buffer for a file that you know has something -;;; in it. The solution is to increase the value of ange-ftp-retry-time. -;;; Its default value is 5 which is plenty for reasonable connections. -;;; However, for some transatlantic connections I set this to 20. -;;; -;;; 4. Beware of compressing files on non-UNIX hosts. Ange-ftp will do it by -;;; copying the file to the local machine, compressing it there, and then -;;; sending it back. Binary file transfers between machines of different -;;; architectures can be a risky business. Test things out first on some -;;; test files. See "Bugs" below. Also, note that ange-ftp copies files by -;;; moving them through the local machine. Again, be careful when doing -;;; this with binary files on non-Unix machines. -;;; -;;; 5. Beware that dired over ftp will use your setting of dired-no-confirm -;;; (list of dired commands for which confirmation is not asked). You -;;; might want to reconsider your setting of this variable, because you -;;; might want confirmation for more commands on remote direds than on -;;; local direds. For example, I strongly recommend that you not include -;;; compress and uncompress in this list. If there is enough demand it -;;; might be a good idea to have an alist ange-ftp-dired-no-confirm of -;;; pairs ( TYPE . LIST ), where TYPE is an operating system type and LIST -;;; is a list of commands for which confirmation would be suppressed. Then -;;; remote dired listings would take their (buffer-local) value of -;;; dired-no-confirm from this alist. Who votes for this? - -;;; --------------------------------------------------------------------- -;;; Non-UNIX support: -;;; --------------------------------------------------------------------- - -;;; VMS support: -;;; -;;; Ange-ftp has full support for VMS hosts, including tree dired support. It -;;; should be able to automatically recognize any VMS machine. However, if it -;;; fails to do this, you can use the command ange-ftp-add-vms-host. As well, -;;; you can set the variable ange-ftp-vms-host-regexp in your .emacs file. We -;;; would be grateful if you would report any failures to automatically -;;; recognize a VMS host as a bug. -;;; -;;; Filename Syntax: -;;; -;;; For ease of *implementation*, the user enters the VMS filename syntax in a -;;; UNIX-y way. For example: -;;; PUB$:[ANONYMOUS.SDSCPUB.NEXT]README.TXT;1 -;;; would be entered as: -;;; /PUB$$:/ANONYMOUS/SDSCPUB/NEXT/README.TXT;1 -;;; i.e. to log in as anonymous on ymir.claremont.edu and grab the file: -;;; [.CSV.POLICY]RULES.MEM -;;; you would type: -;;; C-x C-f /anonymous@ymir.claremont.edu:CSV/POLICY/RULES.MEM -;;; -;;; A legal VMS filename is of the form: FILE.TYPE;## -;;; where FILE can be up to 39 characters -;;; TYPE can be up to 39 characters -;;; ## is a version number (an integer between 1 and 32,767) -;;; Valid characters in FILE and TYPE are A-Z 0-9 _ - $ -;;; $ cannot begin a filename, and - cannot be used as the first or last -;;; character. -;;; -;;; Tips: -;;; 1. Although VMS is not case sensitive, EMACS running under UNIX is. -;;; Therefore, to access a VMS file, you must enter the filename with upper -;;; case letters. -;;; 2. To access the latest version of file under VMS, you use the filename -;;; without the ";" and version number. You should always edit the latest -;;; version of a file. If you want to edit an earlier version, copy it to a -;;; new file first. This has nothing to do with ange-ftp, but is simply -;;; good VMS operating practice. Therefore, to edit FILE.TXT;3 (say 3 is -;;; latest version), do C-x C-f /ymir.claremont.edu:FILE.TXT. If you -;;; inadvertently do C-x C-f /ymir.claremont.edu:FILE.TXT;3, you will find -;;; that VMS will not allow you to save the file because it will refuse to -;;; overwrite FILE.TXT;3, but instead will want to create FILE.TXT;4, and -;;; attach the buffer to this file. To get out of this situation, M-x -;;; write-file /ymir.claremont.edu:FILE.TXT will attach the buffer to -;;; latest version of the file. For this reason, in tree dired "f" -;;; (dired-find-file), always loads the file sans version, whereas "v", -;;; (dired-view-file), always loads the explicit version number. The -;;; reasoning being that it reasonable to view old versions of a file, but -;;; not to edit them. -;;; 3. EMACS has a feature in which it does environment variable substitution -;;; in filenames. Therefore, to enter a $ in a filename, you must quote it -;;; by typing $$. There is a bug in EMACS, in that it neglects to quote the -;;; $'s in the default directory when it writes it in the minibuffer. You -;;; must edit the minibuffer to quote the $'s manually. Hopefully, this bug -;;; will be fixed in EMACS 19. If you use Sebastian Kremer's gmhist (V 4.26 -;;; or newer), you will not have this problem. - -;;; MTS support: -;;; -;;; Ange-ftp has full support, including tree dired support, for hosts running -;;; the Michigan terminal system. It should be able to automatically -;;; recognize any MTS machine. However, if it fails to do this, you can use -;;; the command ange-ftp-add-mts-host. As well, you can set the variable -;;; ange-ftp-mts-host-regexp in your .emacs file. We would be grateful if you -;;; would report any failures to automatically recognize a MTS host as a bug. -;;; -;;; Filename syntax: -;;; -;;; MTS filenames are entered in a UNIX-y way. For example, if your account -;;; was YYYY, the file FILE in the account XXXX: on mtsg.ubc.ca would be -;;; entered as -;;; /YYYY@mtsg.ubc.ca:/XXXX:/FILE -;;; In other words, MTS accounts are treated as UNIX directories. Of course, -;;; to access a file in another account, you must have access permission for -;;; it. If FILE were in your own account, then you could enter it in a -;;; relative path fashion as -;;; /YYYY@mtsg.ubc.ca:FILE -;;; MTS filenames can be up to 12 characters. Like UNIX, the structure of the -;;; filename does not contain a TYPE (i.e. it can have as many "."'s as you -;;; like.) MTS filenames are always in upper case, and hence be sure to enter -;;; them as such! MTS is not case sensitive, but an EMACS running under UNIX -;;; is. - -;;; CMS support: -;;; -;;; Ange-ftp has full support, including tree dired support, for hosts running -;;; CMS. It should be able to automatically recognize any CMS machine. -;;; However, if it fails to do this, you can use the command -;;; ange-ftp-add-cms-host. As well, you can set the variable -;;; ange-ftp-cms-host-regexp in your .emacs file. We would be grateful if you -;;; would report any failures to automatically recognize a CMS host as a bug. -;;; -;;; Filename syntax: -;;; -;;; CMS filenames are entered in a UNIX-y way. In otherwords, minidisks are -;;; treated as UNIX directories. For example to access the file READ.ME in -;;; minidisk *.311 on cuvmb.cc.columbia.edu, you would enter -;;; /anonymous@cuvmb.cc.columbia.edu:/*.311/READ.ME -;;; If *.301 is the default minidisk for this account, you could access -;;; FOO.BAR on this minidisk as -;;; /anonymous@cuvmb.cc.columbia.edu:FOO.BAR -;;; CMS filenames are of the form FILE.TYPE, where both FILE and TYPE can be -;;; up to 8 characters. Again, beware that CMS filenames are always upper -;;; case, and hence must be entered as such. -;;; -;;; Tips: -;;; 1. CMS machines, with the exception of anonymous accounts, nearly always -;;; need an account password. To have ange-ftp send an account password, -;;; you can either include it in your .netrc file, or use -;;; ange-ftp-set-account. -;;; 2. Ange-ftp cannot send "write passwords" for a minidisk. Hopefully, we -;;; can fix this. -;;; -;;; ------------------------------------------------------------------ -;;; Bugs: -;;; ------------------------------------------------------------------ -;;; -;;; 1. Umask problems: -;;; Be warned that files created by using ange-ftp will take account of the -;;; umask of the ftp daemon process rather than the umask of the creating -;;; user. This is particulary important when logging in as the root user. -;;; The way that I tighten up the ftp daemon's umask under HP-UX is to make -;;; sure that the umask is changed to 027 before I spawn /etc/inetd. I -;;; suspect that there is something similar on other systems. -;;; -;;; 2. Some combinations of FTP clients and servers break and get out of sync -;;; when asked to list a non-existent directory. Some of the ai.mit.edu -;;; machines cause this problem for some FTP clients. Using -;;; ange-ftp-kill-process can be used to restart the ftp process, which -;;; should get things back in synch. -;;; -;;; 3. Ange-ftp does not check to make sure that when creating a new file, -;;; you provide a valid filename for the remote operating system. -;;; If you do not, then the remote FTP server will most likely -;;; translate your filename in some way. This may cause ange-ftp to -;;; get confused about what exactly is the name of the file. The -;;; most common causes of this are using lower case filenames on systems -;;; which support only upper case, and using filenames which are too -;;; long. -;;; -;;; 4. Null (blank) passwords confuse both ange-ftp and some FTP daemons. -;;; -;;; 5. Ange-ftp likes to use pty's to talk to its FTP processes. If GNU Emacs -;;; for some reason creates a FTP process that only talks via pipes then -;;; ange-ftp won't be getting the information it requires at the time that -;;; it wants it since pipes flush at different times to pty's. One -;;; disgusting way around this problem is to talk to the FTP process via -;;; rlogin which does the 'right' things with pty's. -;;; -;;; 6. For CMS support, we send too many cd's. Since cd's are cheap, I haven't -;;; worried about this too much. Eventually, we should have some caching -;;; of the current minidisk. -;;; -;;; 7. Some CMS machines do not assign a default minidisk when you ftp them as -;;; anonymous. It is then necessary to guess a valid minidisk name, and cd -;;; to it. This is (understandably) beyond ange-ftp. -;;; -;;; 8. Remote to remote copying of files on non-Unix machines can be risky. -;;; Depending on the variable ange-ftp-binary-file-name-regexp, ange-ftp -;;; will use binary mode for the copy. Between systems of different -;;; architecture, this still may not be enough to guarantee the integrity -;;; of binary files. Binary file transfers from VMS machines are -;;; particularly problematical. Should ange-ftp-binary-file-name-regexp be -;;; an alist of OS type, regexp pairs? -;;; -;;; 9. The code to do compression of files over ftp is not as careful as it -;;; should be. It deletes the old remote version of the file, before -;;; actually checking if the local to remote transfer of the compressed -;;; file succeeds. Of course to delete the original version of the file -;;; after transferring the compressed version back is also dangerous, -;;; because some OS's have severe restrictions on the length of filenames, -;;; and when the compressed version is copied back the "-Z" or ".Z" may be -;;; truncated. Then, ange-ftp would delete the only remaining version of -;;; the file. Maybe ange-ftp should make backups when it compresses files -;;; (of course, the backup "~" could also be truncated off, sigh...). -;;; Suggestions? -;;; - -;;; 10. If a dir listing is attempted for an empty directory on (at least -;;; some) VMS hosts, an ftp error is given. This is really an ftp bug, and -;;; I don't know how to get ange-ftp work to around it. -;;; -;;; 11. Bombs on filenames that start with a space. Deals well with filenames -;;; containing spaces, but beware that the remote ftpd may not like them -;;; much. -;;; -;;; 12. No classic dired support for non-UNIX systems. Tree dired was enough. -;;; -;;; 13. The famous @ bug. As mentioned above in TIPS, ULTRIX marks symlinks -;;; with a trailing @ in a ls -alF listing. In order to account for this -;;; ange-ftp looks to chop trailing @'s off of symlink names when it is -;;; parsing a listing with the F switch. This will cause ange-ftp to -;;; incorrectly get the name of a symlink on a non-ULTRIX host if its name -;;; ends in an @. ange-ftp will correct itself if you take F out of the -;;; dired ls switches (C-u s will allow you to edit the switches). The -;;; dired buffer will be automatically reverted, which will allow ange-ftp -;;; to fix its files hashtable. A cookie to anyone who can think of a -;;; fast, sure-fire way to recognize ULTRIX over ftp. - -;;; If you find any bugs or problems with this package, PLEASE either e-mail -;;; the above author, or send a message to the ange-ftp-lovers mailing list -;;; below. Ideas and constructive comments are especially welcome. - -;;; ange-ftp-lovers: -;;; -;;; ange-ftp has its own mailing list modestly called ange-ftp-lovers. All -;;; users of ange-ftp are welcome to subscribe (see below) and to discuss -;;; aspects of ange-ftp. New versions of ange-ftp are posted periodically to -;;; the mailing list. -;;; -;;; To [un]subscribe to ange-ftp-lovers, or to report mailer problems with the -;;; list, please mail one of the following addresses: -;;; -;;; ange-ftp-lovers-request@anorman.hpl.hp.com -;;; or -;;; ange-ftp-lovers-request%anorman.hpl.hp.com@hplb.hpl.hp.com -;;; -;;; Please don't forget the -request part. -;;; -;;; For mail to be posted directly to ange-ftp-lovers, send to one of the -;;; following addresses: -;;; -;;; ange-ftp-lovers@anorman.hpl.hp.com -;;; or -;;; ange-ftp-lovers%anorman.hpl.hp.com@hplb.hpl.hp.com -;;; -;;; Alternatively, there is a mailing list that only gets announcements of new -;;; ange-ftp releases. This is called ange-ftp-lovers-announce, and can be -;;; subscribed to by e-mailing to the -request address as above. Please make -;;; it clear in the request which mailing list you wish to join. - -;;; The latest version of ange-ftp can usually be obtained via anonymous ftp -;;; from: -;;; alpha.gnu.ai.mit.edu:ange-ftp/ange-ftp.tar.Z -;;; or: -;;; ugle.unit.no:/pub/gnu/emacs-lisp/ange-ftp.tar.Z -;;; or: -;;; archive.cis.ohio-state.edu:pub/gnu/emacs/elisp-archive/packages/ange-ftp.tar.Z - -;;; The archives for ange-ftp-lovers can be found via anonymous ftp under: -;;; -;;; ftp.reed.edu:pub/mailing-lists/ange-ftp/ - -;;; ----------------------------------------------------------- -;;; Technical information on this package: -;;; ----------------------------------------------------------- - -;;; The following GNU Emacs functions are replaced by this package: -;;; -;;; write-region -;;; insert-file-contents -;;; dired-readin -;;; dired-revert -;;; dired-call-process -;;; diff -;;; delete-file -;;; read-file-name-internal -;;; verify-visited-file-modtime -;;; directory-files -;;; backup-buffer -;;; file-directory-p -;;; file-writable-p -;;; file-exists-p -;;; file-readable-p -;;; file-symlink-p -;;; file-attributes -;;; copy-file -;;; rename-file -;;; file-name-as-directory -;;; file-name-directory -;;; file-name-nondirectory -;;; file-name-completion -;;; directory-file-name -;;; expand-file-name -;;; file-name-all-completions - -;;; LISPDIR ENTRY for the Elisp Archive -;;; -;;; LCD Archive Entry: -;;; ange-ftp|Andy Norman|ange@hplb.hpl.hp.com -;;; |transparent FTP Support for GNU Emacs -;;; |Date: 92/08/14 17:04:34 |Revision: 4.20 | - -;;; Checklist for adding non-UNIX support for TYPE -;;; -;;; The following functions may need TYPE versions: -;;; (not all functions will be needed for every OS) -;;; -;;; ange-ftp-fix-path-for-TYPE -;;; ange-ftp-fix-dir-path-for-TYPE -;;; ange-ftp-TYPE-host -;;; ange-ftp-TYPE-add-host -;;; ange-ftp-parse-TYPE-listing -;;; ange-ftp-TYPE-delete-file-entry -;;; ange-ftp-TYPE-add-file-entry -;;; ange-ftp-TYPE-file-name-as-directory -;;; -;;; Variables: -;;; -;;; ange-ftp-TYPE-host-regexp -;;; May need to add TYPE to ange-ftp-dumb-host-types -;;; -;;; Check the following functions for OS dependent coding: -;;; -;;; ange-ftp-host-type -;;; ange-ftp-guess-host-type -;;; ange-ftp-allow-child-lookup -;;; -;;; For Tree Dired support: -;;; -;;; ange-ftp-dired-TYPE-insert-headerline -;;; ange-ftp-dired-TYPE-move-to-filename -;;; ange-ftp-dired-TYPE-move-to-end-of-filename -;;; ange-ftp-dired-TYPE-get-filename -;;; ange-ftp-dired-TYPE-between-files -;;; ange-ftp-TYPE-make-compressed-filename -;;; ange-ftp-dired-TYPE-ls-trim -;;; ange-ftp-TYPE-bob-version -;;; ange-ftp-dired-TYPE-clean-directory -;;; ange-ftp-dired-TYPE-flag-backup-files -;;; ange-ftp-dired-TYPE-backup-diff -;;; -;;; Variables for dired: -;;; -;;; ange-ftp-dired-TYPE-re-exe -;;; ange-ftp-dired-TYPE-re-dir - -;;; Host type conventions: -;;; -;;; The function ange-ftp-host-type and the variable ange-ftp-dired-host-type -;;; (mostly) follow the following conventions for remote host types. At -;;; least, I think that future code should try to follow these conventions, -;;; and the current code should eventually be made compliant. -;;; -;;; nil = local host type, whatever that is (probably unix). -;;; Think nil as in "not a remote host". This value is used by -;;; ange-ftp-dired-host-type for local buffers. -;;; -;;; t = a remote host of unknown type. Think t is in true, it's remote. -;;; Currently, 'unix is used as the default remote host type. -;;; Maybe we should use t. -;;; -;;; 'type = a remote host of TYPE type. -;;; -;;; 'type:list = a remote host of TYPE type, using a specialized ftp listing -;;; program called list. This is currently only used for Unix -;;; dl (descriptive listings), when ange-ftp-dired-host-type -;;; is set to 'unix:dl. - -;;; Bug report codes: -;;; -;;; Because of their naive faith in this code, there are certain situations -;;; which the writers of this program believe could never happen. However, -;;; being realists they have put calls to 'error in the program at these -;;; points. These errors provide a code, which is an integer, greater than 1. -;;; To aid debugging. the error codes, and the functions in which they reside -;;; are listed below. -;;; -;;; 1: See ange-ftp-ls -;;; - -;;; XEmacs changes from 4.20 -;;; -;;; - added gzip support -;;; - added "lazy" messages -;;; - fixed completion list in the root dir (nil vs (nil)) -;;; - use (message nil) to repaint minibuf instead of that awful kludge -;;; - call compute-buffer-file-truename to set truenames properly for -;;; when find-file-compare-truenames is set -;;; - make-directory takes a second optional argument -;;; - made ange-ftp-overwrite-fn use the 19.8 interface to byte-code objects -;;; - made ange-ftp-shell-mode work better with the latest comint -;;; - insert-file-contents takes 2-5 args in v19 -;;; - moved invocation of shell-mode to get along with the latest shell-font.el -;;; - implemented ange-ftp-read-passwd in terms of read-passwd (from passwd.el) -;;; - initialize all buffer-local variables to nil -;;; - Apollo stuff from Bob Weiner - - -;;; ----------------------------------------------------------- -;;; Hall of fame: -;;; ----------------------------------------------------------- -;;; -;;; Thanks to Roland McGrath for improving the filename syntax handling, -;;; for suggesting many enhancements and for numerous cleanups to the code. -;;; -;;; Thanks to Jamie Zawinski for bugfixes and for ideas such as gateways. -;;; -;;; Thanks to Ken Laprade for improved .netrc parsing, password reading, and -;;; dired / shell auto-loading. -;;; -;;; Thanks to Sebastian Kremer for tree dired support and for many ideas and -;;; bugfixes. -;;; -;;; Thanks to Joe Wells for bugfixes, the original non-UNIX system support, -;;; VOS support, and hostname completion. -;;; -;;; Thanks to Nakagawa Takayuki for many good ideas, filename-completion, help -;;; with file-name expansion, efficiency worries, stylistic concerns and many -;;; bugfixes. -;;; -;;; Thanks to Sandy Rutherford who re-wrote most of ange-ftp to support VMS, -;;; MTS, CMS and UNIX-dls. Sandy also added dired-support for non-UNIX OS and -;;; auto-recognition of the host type. -;;; -;;; Thanks to Dave Smith who wrote the info file for ange-ftp. -;;; -;;; Finally, thanks to Keith Waclena, Mark D. Baushke, Terence Kelleher, Ping -;;; Zhou, Edward Vielmetti, Jack Repenning, Mike Balenger, Todd Kaufmann, -;;; Kjetil Svarstad, Tom Wurgler, Linus Tolke, Niko Makila, Carl Edman, Bill -;;; Trost, Dave Brennan, Dan Jacobson, Andy Scott, Steve Anderson, Sanjay -;;; Mathur, the folks on the ange-ftp-lovers mailing list and many others -;;; whose names I've forgotten who have helped to debug and fix problems with -;;; ange-ftp.el. - -;;;; ------------------------------------------------------------ -;;;; User customization variables. -;;;; ------------------------------------------------------------ - -;;;###autoload -(defvar ange-ftp-path-format - '("^/\\(\\([^@/:]*\\)@\\)?\\([^@/:]*\\):\\(.*\\)" . (3 2 4)) - "*Format of a fully expanded remote pathname. This is a cons -\(REGEXP . \(HOST USER PATH\)\), where REGEXP is a regular expression matching -the full remote pathname, and HOST, USER, and PATH are the numbers of -parenthesized expressions in REGEXP for the components (in that order).") - -;; ange-ftp-multi-skip-msgs should only match ###-, where ### is one of -;; the number codes corresponding to ange-ftp-good-msgs or ange-ftp-fatal-msgs. -;; Otherwise, ange-ftp will go into multi-skip mode, and never come out. - -;; XEmacs patch from Bob Weiner -(defvar ange-ftp-multi-msgs - "^331-\\|^220-\\|^230-\\|^226\\|^25.-\\|^221-\\|^200-\\|^530-\\|^4[25]1-" - "*Regular expression matching messages from the ftp process that start -a multiline reply.") - -(defvar ange-ftp-good-msgs - "^220 \\|^230 \\|^226 \\|^25. \\|^221 \\|^200 \\|^[Hh]ash mark" - "*Regular expression matching messages from the ftp process that indicate -that the action that was initiated has completed successfully.") - -;; CMS and the odd VMS machine say 200 Port rather than 200 PORT. -;; Also CMS machines use a multiline 550- reply to say that you -;; don't have write permission. ange-ftp gets into multi-line skip -;; mode and hangs. Have it ignore 550- instead. It will then barf -;; when it gets the 550 line, as it should. - -(defvar ange-ftp-skip-msgs - (concat "^200 \\(PORT\\|Port\\) \\|^331 \\|^150 \\|^350 \\|^[0-9]+ bytes \\|" - "^Connected \\|^$\\|^Remote system\\|^Using\\|^ \\|Password:\\|" - "^local:\\|^Trying\\|^125 \\|^550-\\|^221 .*oodbye") - "*Regular expression matching messages from the ftp process that can be -ignored.") - -(defvar ange-ftp-fatal-msgs - (concat "^ftp: \\|^Not connected\\|^530 \\|^4[25]1 \\|rcmd: \\|" - "^No control connection\\|unknown host\\|^lost connection") - "*Regular expression matching messages from the FTP process that indicate -something has gone drastically wrong attempting the action that was -initiated and that the FTP process should (or already has) been killed.") - -(defvar ange-ftp-gateway-fatal-msgs - "No route to host\\|Connection closed\\|No such host\\|Login incorrect" - "*Regular expression matching messages from the rlogin / telnet process that -indicates that logging in to the gateway machine has gone wrong.") - -(defvar ange-ftp-xfer-size-msgs - "^150 .* connection for .* (\\([0-9]+\\) bytes)" - "*Regular expression used to determine the number of bytes in a FTP transfer.") - -(defvar ange-ftp-tmp-name-template "/tmp/ange-ftp" - "*Template used to create temporary files.") - -(defvar ange-ftp-gateway-tmp-name-template "/tmp/ange-ftp" - "*Template used to create temporary files when ftp-ing through a gateway. -Files starting with this prefix need to be accessible from BOTH the local -machine and the gateway machine, and need to have the SAME name on both -machines, that is, /tmp is probably NOT what you want, since that is rarely -cross-mounted.") - -(defvar ange-ftp-netrc-filename "~/.netrc" - "*File in .netrc format to search for passwords.") - -(defvar ange-ftp-disable-netrc-security-check nil - "*If non-nil avoid checking permissions on the .netrc file.") - -(defvar ange-ftp-default-user "anonymous" - "*User name to use when none is specied in a pathname. -If nil, then the name under which the user is logged in is used. -If non-nil but not a string, the user is prompted for the name.") - -(defvar ange-ftp-default-password nil - "*Password to use when the user is the same as ange-ftp-default-user.") - -(defvar ange-ftp-default-account nil - "*Account password to use when the user is the same as ange-ftp-default-user.") - -(defvar ange-ftp-generate-anonymous-password t ;; changed wing@666.com - "*If t, use a password of user@host when logging in as the anonymous user. -If a string then use that as the password. -If nil then prompt the user for a password.") - -(defvar ange-ftp-dumb-unix-host-regexp nil - "*If non-nil, if the host being ftp'd to matches this regexp then the FTP -process uses the \'dir\' command to get directory information.") - -(defvar ange-ftp-binary-file-name-regexp - (concat "\\.g?z$\\|\\.Z$\\|\\.lzh$\\|\\.arc$\\|\\.zip$\\|\\.zoo$\\|\\.tar$\\|" - "\\.dvi$\\|\\.ps$\\|\\.elc$\\|TAGS$\\|\\.gif$\\|" - "\\.EXE\\(;[0-9]+\\)?$\\|\\.g?z-part-..$\\|\\.Z-part-..$") - "*If a file matches this regexp then it is transferred in binary mode.") - -(defvar ange-ftp-gateway-host nil - "*Name of host to use as gateway machine when local FTP isn't possible.") - -(defvar ange-ftp-local-host-regexp ".*" - "*If a host being FTP'd to matches this regexp then the ftp process is started -locally, otherwise the FTP process is started on \`ange-ftp-gateway-host\' -instead.") - -(defvar ange-ftp-gateway-program-interactive nil - "*If non-nil then the gateway program is expected to connect to the gateway -machine and eventually give a shell prompt. Both telnet and rlogin do something -like this.") - -(defvar ange-ftp-gateway-program (if (eq system-type 'hpux) "remsh" "rsh") - "*Name of program to spawn a shell on the gateway machine. Valid candidates -are rsh (remsh on hp-ux), telnet and rlogin. See also the gateway variable -above.") - -(defvar ange-ftp-gateway-prompt-pattern "^[^#$%>;]*[#$%>;] *" - "*Regexp used to detect that the logging-in sequence is completed on the -gateway machine and that the shell is now awaiting input. Make this regexp as -strict as possible; it shouldn't match *anything* at all except the user's -initial prompt. The above string will fail under most SUN-3's since it -matches the login banner.") - -(defvar ange-ftp-gateway-setup-term-command - (if (eq system-type 'hpux) - "stty -onlcr -echo\n" - "stty -echo nl\n") - "*Command to use after logging in to the gateway machine to stop the terminal -echoing each command and to strip out trailing ^M characters.") - -(defvar ange-ftp-smart-gateway nil - "*If the gateway FTP is smart enough to use proxy server, then don't bother -telnetting etc, just issue a user@host command instead.") - -(defvar ange-ftp-smart-gateway-port "21" - "*Port on gateway machine to use when smart gateway is in operation.") - -(defvar ange-ftp-send-hash t - "*If non-nil, send the HASH command to the FTP client.") - -(defvar ange-ftp-binary-hash-mark-size nil - "*Default size, in bytes, between hash-marks when transferring a binary file. -If NIL, this variable will be locally overridden if the FTP client outputs a -suitable response to the HASH command. If non-NIL then this value takes -precedence over the local value.") - -(defvar ange-ftp-ascii-hash-mark-size 1024 - "*Default size, in bytes, between hash-marks when transferring an ASCII file. -This variable is buffer-local and will be locally overridden if the FTP client -outputs a suitable response to the HASH command.") - -(defvar ange-ftp-process-verbose t - "*If non-NIL then be chatty about interaction with the FTP process.") - -(defvar ange-ftp-ftp-program-name "ftp" - "*Name of FTP program to run.") - -(defvar ange-ftp-gateway-ftp-program-name "ftp" - "*Name of FTP program to run on gateway machine. -Some AT&T folks claim to use something called `pftp' here.") - -(defvar ange-ftp-ftp-program-args '("-i" "-n" "-g" "-v") - "*A list of arguments passed to the FTP program when started.") - -(defvar ange-ftp-nslookup-program nil - "*If non-NIL then a string naming nslookup program." ) - -(defvar ange-ftp-make-backup-files () - "*A list of operating systems for which ange-ftp will make Emacs backup -files on the remote host. For example, '\(unix\) makes sense, but -'\(unix vms\) or '\(vms\) would be silly, since vms makes its own backups.") - -(defvar ange-ftp-retry-time 5 - "*Number of seconds to wait before retrying if a file or listing -doesn't arrive. This might need to be increased for very slow connections.") - -(defvar ange-ftp-auto-save 0 - "If 1, allows ange-ftp files to be auto-saved. -If 0, suppresses auto-saving of ange-ftp files. -Don't use any other value.") - -;;;; ------------------------------------------------------------ -;;;; Hash table support. -;;;; ------------------------------------------------------------ - -(require 'backquote) - -(defun ange-ftp-make-hashtable (&optional size) - "Make an obarray suitable for use as a hashtable. -SIZE, if supplied, should be a prime number." - (make-vector (or size 31) 0)) - -(defun ange-ftp-map-hashtable (fun tbl) - "Call FUNCTION on each key and value in HASHTABLE." - (mapatoms - (function - (lambda (sym) - (funcall fun (get sym 'key) (get sym 'val)))) - tbl)) - -(defmacro ange-ftp-make-hash-key (key) - "Convert KEY into a suitable key for a hashtable." - (` (if (stringp (, key)) - (, key) - (prin1-to-string (, key))))) - -(defun ange-ftp-get-hash-entry (key tbl) - "Return the value associated with KEY in HASHTABLE." - (let ((sym (intern-soft (ange-ftp-make-hash-key key) tbl))) - (and sym (get sym 'val)))) - -(defun ange-ftp-put-hash-entry (key val tbl) - "Record an association between KEY and VALUE in HASHTABLE." - (let ((sym (intern (ange-ftp-make-hash-key key) tbl))) - (put sym 'val val) - (put sym 'key key))) - -(defun ange-ftp-del-hash-entry (key tbl) - "Copy all symbols except KEY in HASHTABLE and return modified hashtable." - (let* ((len (length tbl)) - (new-tbl (ange-ftp-make-hashtable len)) - (i (1- len))) - (ange-ftp-map-hashtable - (function - (lambda (k v) - (or (equal k key) - (ange-ftp-put-hash-entry k v new-tbl)))) - tbl) - (while (>= i 0) - (aset tbl i (aref new-tbl i)) - (setq i (1- i))) - tbl)) - -(defun ange-ftp-hash-entry-exists-p (key tbl) - "Return whether there is an association for KEY in TABLE." - (intern-soft (ange-ftp-make-hash-key key) tbl)) - -(defun ange-ftp-hash-table-keys (tbl) - "Return a sorted list of all the active keys in the hashtable, as strings." - (sort (all-completions "" tbl) - (function string-lessp))) - -;;;; ------------------------------------------------------------ -;;;; Internal variables. -;;;; ------------------------------------------------------------ - -(defconst ange-ftp-version "Revision: 4.20.XEmacs") - -(defvar ange-ftp-data-buffer-name " *ftp data*" - "Buffer name to hold directory listing data received from ftp process.") - -(defvar ange-ftp-netrc-modtime nil - "Last modified time of the netrc file from file-attributes.") - -(defvar ange-ftp-user-hashtable (ange-ftp-make-hashtable) - "Hash table holding associations between HOST, USER pairs.") - -(defvar ange-ftp-passwd-hashtable (ange-ftp-make-hashtable) - "Mapping between a HOST, USER pair and a PASSWORD for them.") - -(defvar ange-ftp-account-hashtable (ange-ftp-make-hashtable) - "Mapping between a HOST, USER pair and a ACCOUNT password for them.") - -(defvar ange-ftp-files-hashtable (ange-ftp-make-hashtable 97) - "Hash table for storing directories and their respective files.") - -(defvar ange-ftp-ls-cache-lsargs nil - "Last set of args used by ange-ftp-ls.") - -(defvar ange-ftp-ls-cache-file nil - "Last file passed to ange-ftp-ls.") - -(defvar ange-ftp-ls-cache-res nil - "Last result returned from ange-ftp-ls.") - -;; New error symbols. -;; XEmacs change -(define-error 'ftp-error "FTP error" 'file-error) - -;;; ------------------------------------------------------------ -;;; Match-data support (stolen from Kyle I think) -;;; ------------------------------------------------------------ - -(defmacro ange-ftp-save-match-data (&rest body) - "Execute the BODY forms, restoring the global value of the match data. -Before executing BODY, case-fold-search is locally bound to nil." - (let ((original (make-symbol "match-data")) - case-fold-search) - (list - 'let (list (list original '(match-data))) - (list 'unwind-protect - (cons 'progn body) - (list 'store-match-data original))))) - -(put 'ange-ftp-save-match-data 'lisp-indent-hook 0) -(put 'ange-ftp-save-match-data 'edebug-form-hook '(&rest form)) - -;;; ------------------------------------------------------------ -;;; Enhanced message support. -;;; ------------------------------------------------------------ - -(defun ange-ftp-message (fmt &rest args) - "Output the given message, but truncate to the size of the minibuffer -window." - (let ((msg (apply (function format) fmt args)) - (max (window-width (minibuffer-window)))) - (if (>= (length msg) max) - (setq msg (concat "> " (substring msg (- 3 max))))) - (message "%s" msg))) - -(defvar ange-ftp-lazy-message-time 0) -(defun ange-ftp-lazy-message (fmt &rest args) - "Output the given message, but truncate to the size of the minibuffer -window, and don't print the message if we've printed another message -less than one second ago." - (if (= ange-ftp-lazy-message-time - (setq ange-ftp-lazy-message-time (nth 1 (current-time)))) - nil - (apply 'ange-ftp-message fmt args))) - -(or (fboundp 'current-time) (fset 'ange-ftp-lazy-message 'ange-ftp-message)) - - -(defun ange-ftp-abbreviate-filename (file &optional new) - "Abbreviate the given filename relative to the default-directory. If the -optional parameter NEW is given and the non-directory parts match, only return -the directory part of the file." - (ange-ftp-save-match-data - (if (and default-directory - (string-match (concat "^" - (regexp-quote default-directory) - ".") file)) - (setq file (substring file (1- (match-end 0))))) - (if (and new - (string-equal (file-name-nondirectory file) - (file-name-nondirectory new))) - (setq file (file-name-directory file))) - (or file "./"))) - -;;;; ------------------------------------------------------------ -;;;; User / Host mapping support. -;;;; ------------------------------------------------------------ - -(defun ange-ftp-set-user (host user) - "For a given HOST, set or change the default USER." - (interactive "sHost: \nsUser: ") - (ange-ftp-put-hash-entry host user ange-ftp-user-hashtable)) - -(defun ange-ftp-get-user (host) - "Given a HOST, return the default USER." - (ange-ftp-parse-netrc) - (let ((user (ange-ftp-get-hash-entry host ange-ftp-user-hashtable))) - (or user - (prog1 - (setq user - (cond ((stringp ange-ftp-default-user) - ;; We have a default name. Use it. - ange-ftp-default-user) - (ange-ftp-default-user - ;; Ask the user. - (let ((enable-recursive-minibuffers t)) - (read-string (format "User for %s: " host) - (user-login-name)))) - ;; Default to the user's login name. - (t - (user-login-name)))) - (ange-ftp-set-user host user))))) - -;;;; ------------------------------------------------------------ -;;;; Password support. -;;;; ------------------------------------------------------------ - -(defun ange-ftp-read-passwd (prompt &optional default) - "Read a password from the user. -See documentation of `read-passwd' for more info." - (read-passwd prompt nil default)) - -;(defun ange-ftp-read-passwd (prompt &optional default) -; "Read a password from the user. Echos a . for each character typed. -;End with RET, LFD, or ESC. DEL or C-h rubs out. ^U kills line. -;Optional DEFAULT is password to start with." -; (let ((pass (if default default "")) -; (c 0) -; (echo-keystrokes 0) -; (cursor-in-echo-area t)) -; (while (and (/= c ?\r) (/= c ?\n) (/= c ?\e)) -; (message "%s%s" -; prompt -; (make-string (length pass) ?.)) -; (setq c (read-char)) -; (if (= c ?\C-u) -; (setq pass "") -; (if (and (/= c ?\b) (/= c ?\177)) -; (setq pass (concat pass (char-to-string c))) -; (if (> (length pass) 0) -; (setq pass (substring pass 0 -1)))))) -; (ange-ftp-repaint-minibuffer) -; (substring pass 0 -1))) - -(defmacro ange-ftp-generate-passwd-key (host user) - (` (concat (, host) "/" (, user)))) - -(defmacro ange-ftp-lookup-passwd (host user) - (` (ange-ftp-get-hash-entry (ange-ftp-generate-passwd-key (, host) (, user)) - ange-ftp-passwd-hashtable))) - -(defun ange-ftp-set-passwd (host user passwd) - "For a given HOST and USER, set or change the associated PASSWORD." - (interactive (list (read-string "Host: ") - (read-string "User: ") - (ange-ftp-read-passwd "Password: "))) - (ange-ftp-put-hash-entry (ange-ftp-generate-passwd-key host user) - passwd - ange-ftp-passwd-hashtable)) - -(defun ange-ftp-get-host-with-passwd (user) - "Given a USER, return a host we know the password for." - (ange-ftp-parse-netrc) - (catch 'found-one - (ange-ftp-map-hashtable - (function (lambda (host val) - (if (ange-ftp-lookup-passwd host user) - (throw 'found-one host)))) - ange-ftp-user-hashtable) - (ange-ftp-save-match-data - (ange-ftp-map-hashtable - (function - (lambda (key value) - (if (string-match "^[^/]*\\(/\\).*$" key) - (let ((host (substring key 0 (match-beginning 1)))) - (if (and (string-equal user (substring key (match-end 1))) - value) - (throw 'found-one host)))))) - ange-ftp-passwd-hashtable)) - nil)) - -(defun ange-ftp-get-passwd (host user) - "Given a HOST and USER, return the FTP password, prompting if it was not -previously set." - (ange-ftp-parse-netrc) - - ;; look up password in the hash table first; user might have overriden the - ;; defaults. - (cond ((ange-ftp-lookup-passwd host user)) - - ;; see if default user and password set from the .netrc file. - ((and (stringp ange-ftp-default-user) - ange-ftp-default-password - (string-equal user ange-ftp-default-user)) - ange-ftp-default-password) - - ;; anonymous ftp password is handled specially since there is an - ;; unwritten rule about how that is used on the Internet. - ((and (or (string-equal user "anonymous") - (string-equal user "ftp")) - ange-ftp-generate-anonymous-password) - (if (stringp ange-ftp-generate-anonymous-password) - ange-ftp-generate-anonymous-password - (concat (user-login-name) "@" (system-name)))) - - ;; see if same user has logged in to other hosts; if so then prompt - ;; with the password that was used there. - (t - (let* ((other (ange-ftp-get-host-with-passwd user)) - (passwd (if other - - ;; found another machine with the same user. - ;; Try that account. - (ange-ftp-read-passwd - (format "passwd for %s@%s (same as %s@%s): " - user host user other) - (ange-ftp-lookup-passwd other user)) - - ;; I give up. Ask the user for the password. - (ange-ftp-read-passwd - (format "Password for %s@%s: " user host))))) - (ange-ftp-set-passwd host user passwd) - passwd)))) - -;;;; ------------------------------------------------------------ -;;;; Account support -;;;; ------------------------------------------------------------ - -;; Account passwords must be either specified in the .netrc file, or set -;; manually by calling ange-ftp-set-account. For the moment, ange-ftp doesn't -;; check to see whether the FTP process is actually prompting for an account -;; password. - -(defun ange-ftp-set-account (host user account) - "For a given HOST and USER, set or change the associated ACCOUNT password." - (interactive (list (read-string "Host: ") - (read-string "User: ") - (ange-ftp-read-passwd "Account password: "))) - (ange-ftp-put-hash-entry (ange-ftp-generate-passwd-key host user) - account - ange-ftp-account-hashtable)) - -(defun ange-ftp-get-account (host user) - "Given a HOST and USER, return the FTP account." - (ange-ftp-parse-netrc) - (or (ange-ftp-get-hash-entry (ange-ftp-generate-passwd-key host user) - ange-ftp-account-hashtable) - (and (stringp ange-ftp-default-user) - (string-equal user ange-ftp-default-user) - ange-ftp-default-account))) - -;;;; ------------------------------------------------------------ -;;;; ~/.netrc support -;;;; ------------------------------------------------------------ - -(defun ange-ftp-chase-symlinks (file) - "Return the filename that FILENAME references, following all symbolic links." - (let (temp) - (while (setq temp (ange-ftp-real-file-symlink-p file)) - (setq file - (if (file-name-absolute-p temp) - temp - (concat (file-name-directory file) temp))))) - file) - -(defun ange-ftp-parse-netrc-token (token limit) - "Move along current line looking for the value of the TOKEN. Valid -separators between TOKEN and its value are commas and whitespace. -Second arg LIMIT is a limit for the search." - (if (search-forward token limit t) - (let (beg) - (skip-chars-forward ", \t\r\n" limit) - (if (eq (following-char) ?\") ;quoted token value - (progn (forward-char 1) - (setq beg (point)) - (skip-chars-forward "^\"" limit) - (forward-char 1) - (buffer-substring beg (1- (point)))) - (setq beg (point)) - (skip-chars-forward "^, \t\r\n" limit) - (buffer-substring beg (point)))))) - -(defun ange-ftp-parse-netrc-group () - "Extract the values for the tokens \`machine\', \`login\', \`password\' -and \`account\' in the current buffer. If successful, record the information -found." - (beginning-of-line) - (let ((start (point)) - (end (progn (re-search-forward "machine\\|default" - (point-max) 'end 2) (point))) - machine login password account) - (goto-char start) - (setq machine (ange-ftp-parse-netrc-token "machine" end) - login (ange-ftp-parse-netrc-token "login" end) - password (ange-ftp-parse-netrc-token "password" end) - account (ange-ftp-parse-netrc-token "account" end)) - (if (and machine login) - ;; found a `machine` token. - (progn - (ange-ftp-set-user machine login) - (ange-ftp-set-passwd machine login password) - (and account - (ange-ftp-set-account machine login account))) - (goto-char start) - (if (search-forward "default" end t) - ;; found a `default' token - (progn - (setq login (ange-ftp-parse-netrc-token "login" end) - password (ange-ftp-parse-netrc-token "password" end) - account (ange-ftp-parse-netrc-token "account" end)) - (and login - (setq ange-ftp-default-user login)) - (and password - (setq ange-ftp-default-password password)) - (and account - (setq ange-ftp-default-account account))))) - (goto-char end))) - -(defun ange-ftp-parse-netrc () - "If ~/.netrc file exists and has the correct permissions then extract the -\`machine\', \`login\', \`password\' and \`account\' information from within." - - ;; We set this before actually doing it to avoid the possibility - ;; of an infinite loop if ange-ftp-netrc-filename is an FTP file. - (interactive) - (let* ((file (ange-ftp-chase-symlinks - (ange-ftp-real-expand-file-name ange-ftp-netrc-filename))) - (attr (ange-ftp-real-file-attributes file))) - (if (and attr ; file exists. - (not (equal (nth 5 attr) ange-ftp-netrc-modtime))) ; file changed - (ange-ftp-save-match-data - (if (or ange-ftp-disable-netrc-security-check - (and (eq (nth 2 attr) (user-uid)) ; Same uids. - (string-match ".r..------" (nth 8 attr)))) - (save-excursion - ;; we are cheating a bit here. I'm trying to do the equivalent - ;; of find-file on the .netrc file, but then nuke it afterwards. - ;; with the bit of logic below we should be able to have - ;; encrypted .netrc files. - (set-buffer (generate-new-buffer "*ftp-.netrc*")) - (ange-ftp-real-insert-file-contents file) - (setq buffer-file-name file) - (setq default-directory (file-name-directory file)) - (normal-mode t) - (mapcar 'funcall find-file-hooks) - (setq buffer-file-name nil) - (goto-char (point-min)) - (while (not (eobp)) - (ange-ftp-parse-netrc-group)) - (kill-buffer (current-buffer))) - (ange-ftp-message "%s either not owned by you or badly protected." - ange-ftp-netrc-filename) - (sit-for 1)) - (setq ange-ftp-netrc-modtime (nth 5 attr)))))) - -(defun ange-ftp-generate-root-prefixes () - "Return a list of prefixes of the form 'user@host:' to be used when -completion is done in the root directory." - (ange-ftp-parse-netrc) - (ange-ftp-save-match-data - (let (res) - (ange-ftp-map-hashtable - (function - (lambda (key value) - (if (string-match "^[^/]*\\(/\\).*$" key) - (let ((host (substring key 0 (match-beginning 1))) - (user (substring key (match-end 1)))) - (setq res (cons (list (concat user "@" host ":")) - res)))))) - ange-ftp-passwd-hashtable) - (ange-ftp-map-hashtable - (function (lambda (host user) - (setq res (cons (list (concat host ":")) - res)))) - ange-ftp-user-hashtable) -;; (or res (list nil)) - res - ))) - -;;;; ------------------------------------------------------------ -;;;; Remote pathname syntax support. -;;;; ------------------------------------------------------------ - -(defmacro ange-ftp-ftp-path-component (n ns path) - "Extract the Nth ftp path component from NS." - (` (let ((elt (nth (, n) (, ns)))) - (if (match-beginning elt) - (substring (, path) (match-beginning elt) (match-end elt)))))) - -(defvar ange-ftp-ftp-path-arg "") -(defvar ange-ftp-ftp-path-res nil) - -(defun ange-ftp-ftp-path (path) - "Parse PATH according to ange-ftp-path-format (which see). -Returns a list (HOST USER PATH), or nil if PATH does not match the format." - (if (string-equal path ange-ftp-ftp-path-arg) - ange-ftp-ftp-path-res - (setq ange-ftp-ftp-path-arg path - ange-ftp-ftp-path-res - (ange-ftp-save-match-data - (if (string-match (car ange-ftp-path-format) path) - (let* ((ns (cdr ange-ftp-path-format)) - (host (ange-ftp-ftp-path-component 0 ns path)) - (user (ange-ftp-ftp-path-component 1 ns path)) - (path (ange-ftp-ftp-path-component 2 ns path))) - (if (zerop (length user)) - (setq user (ange-ftp-get-user host))) - (list host user path)) - nil))))) - -(defun ange-ftp-replace-path-component (fullpath path) - "Take a FULLPATH that matches according to ange-ftp-path-format and -replace the path component with PATH." - (ange-ftp-save-match-data - (if (string-match (car ange-ftp-path-format) fullpath) - (let* ((ns (cdr ange-ftp-path-format)) - (elt (nth 2 ns))) - (concat (substring fullpath 0 (match-beginning elt)) - path - (substring fullpath (match-end elt))))))) - -;;;; ------------------------------------------------------------ -;;;; Miscellaneous utils. -;;;; ------------------------------------------------------------ - -(setq ange-ftp-tmp-keymap (make-sparse-keymap)) -(define-key ange-ftp-tmp-keymap "\C-m" 'exit-minibuffer) - -(defun ange-ftp-repaint-minibuffer () - "Gross hack to set minibuf_message = 0, so that the contents of the -minibuffer will show." - (if (eq (selected-window) (minibuffer-window)) - (if (string-match "XEmacs" emacs-version) - (message nil) - ;; v18 GNU Emacs - (let ((unread-command-char ?\C-m) - (enable-recursive-minibuffers t)) - (read-from-minibuffer "" nil ange-ftp-tmp-keymap nil))))) - -(defun ange-ftp-ftp-process-buffer (host user) - "Return the name of the buffer that collects output from the ftp process -connected to the given HOST and USER pair." - (concat "*ftp " user "@" host "*")) - -(defun ange-ftp-error (host user msg) - "Display the last chunk of output from the ftp process for the given HOST -USER pair, and signal an error including MSG in the text." - (let ((cur (selected-window)) - (pop-up-windows t)) - (pop-to-buffer - (get-buffer-create - (ange-ftp-ftp-process-buffer host user))) - (goto-char (point-max)) - (select-window cur)) - (signal 'ftp-error (list (format "FTP Error: %s" msg)))) - -(defun ange-ftp-set-buffer-mode () - "Set the correct modes for the current buffer if it is visiting a remote -file." - (if (and (stringp buffer-file-name) - (ange-ftp-ftp-path buffer-file-name)) - (progn - (auto-save-mode ange-ftp-auto-save) - (make-variable-buffer-local 'revert-buffer-function) - (setq revert-buffer-function 'ange-ftp-revert-buffer)))) - -(defun ange-ftp-kill-ftp-process (buffer) - "If the BUFFER's visited filename or default-directory is an ftp filename -then kill the related ftp process." - (interactive "bKill FTP process associated with buffer: ") - (if (null buffer) - (setq buffer (current-buffer))) - (let ((file (or (buffer-file-name) default-directory))) - (if file - (let ((parsed (ange-ftp-ftp-path (expand-file-name file)))) - (if parsed - (let ((host (nth 0 parsed)) - (user (nth 1 parsed))) - (kill-buffer (ange-ftp-ftp-process-buffer host user)))))))) - -(defun ange-ftp-quote-string (string) - "Quote any characters in STRING that may confuse the ftp process." - (apply (function concat) - (mapcar (function - (lambda (char) - (if (or (<= char ? ) - (> char ?\~) - (= char ?\") - (= char ?\\)) - (vector ?\\ char) - (vector char)))) - string))) - -(defun ange-ftp-barf-if-not-directory (directory) - (or (file-directory-p directory) - (signal 'file-error - (list "Opening directory" - (if (file-exists-p directory) - "not a directory" - "no such file or directory") - directory)))) - -;;;; ------------------------------------------------------------ -;;;; Remote file name syntax support. -;;;; ------------------------------------------------------------ -(defvar ange-ftp-name-format - '("^/\\(\\([^@/:]*\\)@\\)?\\([^@/:]*[^@/:.]\\):\\(.*\\)" . (3 2 4)) - "*Format of a fully expanded remote file name. -This is a list of the form \(REGEXP HOST USER NAME\), -where REGEXP is a regular expression matching -the full remote name, and HOST, USER, and NAME are the numbers of -parenthesized expressions in REGEXP for the components (in that order).") - -(defun ange-ftp-real-load (&rest args) - (ange-ftp-run-real-handler 'load args)) - -(defmacro ange-ftp-ftp-name-component (n ns name) - "Extract the Nth ftp file name component from NS." - (` (let ((elt (nth (, n) (, ns)))) - (if (match-beginning elt) - (substring (, name) (match-beginning elt) (match-end elt)))))) - -(defvar ange-ftp-ftp-name-arg "") -(defvar ange-ftp-ftp-name-res nil) - -;; Parse NAME according to `ange-ftp-name-format' (which see). -;; Returns a list (HOST USER NAME), or nil if NAME does not match the format. -(defun ange-ftp-ftp-name (name) - (if (string-equal name ange-ftp-ftp-name-arg) - ange-ftp-ftp-name-res - (setq ange-ftp-ftp-name-arg name - ange-ftp-ftp-name-res - (save-match-data - (if (posix-string-match (car ange-ftp-name-format) name) - (let* ((ns (cdr ange-ftp-name-format)) - (host (ange-ftp-ftp-name-component 0 ns name)) - (user (ange-ftp-ftp-name-component 1 ns name)) - (name (ange-ftp-ftp-name-component 2 ns name))) - (if (zerop (length user)) - (setq user (ange-ftp-get-user host))) - (list host user name)) - nil))))) - -;; Take a FULLNAME that matches according to ange-ftp-name-format and -;; replace the name component with NAME. -(defun ange-ftp-replace-name-component (fullname name) - (save-match-data - (if (posix-string-match (car ange-ftp-name-format) fullname) - (let* ((ns (cdr ange-ftp-name-format)) - (elt (nth 2 ns))) - (concat (substring fullname 0 (match-beginning elt)) - name - (substring fullname (match-end elt))))))) - -(defun ange-ftp-file-local-copy (file) - (let* ((fn1 (expand-file-name file)) - (pa1 (ange-ftp-ftp-name fn1))) - (if pa1 - (let ((tmp1 (ange-ftp-make-tmp-name (car pa1)))) - (ange-ftp-copy-file-internal fn1 tmp1 t nil - (format "Getting %s" fn1)) - tmp1)))) - -(defun ange-ftp-load (file &optional noerror nomessage nosuffix) - (if (ange-ftp-ftp-name file) - (let ((tryfiles (if nosuffix - (list file) - (list (concat file ".elc") (concat file ".el") file))) - copy) - (while (and tryfiles (not copy)) - (condition-case error - (setq copy (ange-ftp-file-local-copy (car tryfiles))) - (ftp-error nil)) - (setq tryfiles (cdr tryfiles))) - (if copy - (unwind-protect - (funcall 'load copy noerror nomessage nosuffix) - (delete-file copy)) - (or noerror - (signal 'file-error (list "Cannot open load file" file))))) - (ange-ftp-real-load file noerror nomessage nosuffix))) -(put 'load 'ange-ftp 'ange-ftp-load) - -;;;; ------------------------------------------------------------ -;;;; FTP process filter support. -;;;; ------------------------------------------------------------ - -(defun ange-ftp-process-handle-line (line proc) - "Look at the given LINE from the ftp process PROC. Try to catagorize it -into one of four categories: good, skip, fatal, or unknown." - (cond ((string-match ange-ftp-xfer-size-msgs line) - (setq ange-ftp-xfer-size - (ash (string-to-int (substring line - (match-beginning 1) - (match-end 1))) - -10))) - ((string-match ange-ftp-skip-msgs line) - (setq ange-ftp-process-multi-skip nil) ;; XEmacs patch (Bob Weiner) - t) - ((string-match ange-ftp-good-msgs line) - (setq ange-ftp-process-busy nil - ange-ftp-process-result t - ange-ftp-process-result-line line)) - ((string-match ange-ftp-fatal-msgs line) - (delete-process proc) - (setq ange-ftp-process-busy nil - ange-ftp-process-result-line line)) - ((string-match ange-ftp-multi-msgs line) - (setq ange-ftp-process-multi-skip t)) - (ange-ftp-process-multi-skip - t) - (t - (setq ange-ftp-process-busy nil - ange-ftp-process-result-line line)))) - -(defun ange-ftp-process-log-string (proc str) - "For a given PROCESS, log the given STRING at the end of its -associated buffer." - (let ((old-buffer (current-buffer))) - (unwind-protect - (let (moving) - (set-buffer (process-buffer proc)) - (setq moving (= (point) (process-mark proc))) - (save-excursion - ;; Insert the text, moving the process-marker. - (goto-char (process-mark proc)) - (insert str) - (set-marker (process-mark proc) (point))) - (if moving (goto-char (process-mark proc)))) - (set-buffer old-buffer)))) - -(defun ange-ftp-set-xfer-size (host user bytes) - "Set the size of the next FTP transfer in bytes." - (let ((proc (ange-ftp-get-process host user))) - (if proc - (let ((buf (process-buffer proc))) - (if buf - (save-excursion - (set-buffer buf) - (setq ange-ftp-xfer-size (ash bytes -10)))))))) - -(defun ange-ftp-process-handle-hash (str) - "Remove hash marks from STRING and display count so far." - (setq str (concat (substring str 0 (match-beginning 0)) - (substring str (match-end 0))) - ange-ftp-hash-mark-count (+ (- (match-end 0) - (match-beginning 0)) - ange-ftp-hash-mark-count)) - (and ange-ftp-process-msg - ange-ftp-process-verbose - (not (eq (selected-window) (minibuffer-window))) - (not (boundp 'search-message)) ;screws up isearch otherwise - (not cursor-in-echo-area) ;screws up y-or-n-p otherwise - (let ((kbytes (ash (* ange-ftp-hash-mark-unit - ange-ftp-hash-mark-count) - -6))) - (if (zerop ange-ftp-xfer-size) - (ange-ftp-lazy-message "%s...%dk" ange-ftp-process-msg kbytes) - (let ((percent (/ (* 100 kbytes) ange-ftp-xfer-size))) - ;; cut out the redisplay of identical %-age messages. - (if (not (eq percent ange-ftp-last-percent)) - (progn - (setq ange-ftp-last-percent percent) - (ange-ftp-lazy-message "%s...%d%%" - ange-ftp-process-msg percent))))))) - str) - -(defun ange-ftp-call-cont (cont result line) - "Call the function specified by CONT. CONT can be either a function or a -list of a function and some args. The first two parameters passed to the -function will be RESULT and LINE. The remaining args will be taken from CONT -if a list was passed." - (if cont - (if (and (listp cont) - (not (eq (car cont) 'lambda))) - (apply (car cont) result line (cdr cont)) - (funcall cont result line)))) - -(defun ange-ftp-process-filter (proc str) - "Build up a complete line of output from the ftp PROCESS and pass it -on to ange-ftp-process-handle-line to deal with." - (let ((buffer (process-buffer proc)) - (old-buffer (current-buffer))) - - ;; see if the buffer is still around... it could have been deleted. - (if (buffer-name buffer) - (unwind-protect - (ange-ftp-save-match-data - (set-buffer (process-buffer proc)) - - ;; handle hash mark printing - (and ange-ftp-hash-mark-unit - ange-ftp-process-busy - (string-match "^#+$" str) - (setq str (ange-ftp-process-handle-hash str))) - (ange-ftp-process-log-string proc str) - (if ange-ftp-process-busy - (progn - (setq ange-ftp-process-string (concat ange-ftp-process-string - str)) - - ;; if we gave an empty password to the USER command earlier - ;; then we should send a null password now. - (if (string-match "Password: *$" ange-ftp-process-string) - (send-string proc "\n")))) - (while (and ange-ftp-process-busy - (string-match "\n" ange-ftp-process-string)) - (let ((line (substring ange-ftp-process-string - 0 - (match-beginning 0)))) - (setq ange-ftp-process-string (substring ange-ftp-process-string - (match-end 0))) - (while (string-match "^ftp> *" line) - (setq line (substring line (match-end 0)))) - (ange-ftp-process-handle-line line proc))) - - ;; has the ftp client finished? if so then do some clean-up - ;; actions. - (if (not ange-ftp-process-busy) - (progn - ;; reset the xfer size - (setq ange-ftp-xfer-size 0) - - ;; issue the "done" message since we've finished. - (if (and ange-ftp-process-msg - ange-ftp-process-verbose - ange-ftp-process-result) - (progn - (ange-ftp-message "%s...done" ange-ftp-process-msg) - (ange-ftp-repaint-minibuffer) - (setq ange-ftp-process-msg nil))) - - ;; is there a continuation we should be calling? if so, - ;; we'd better call it, making sure we only call it once. - (if ange-ftp-process-continue - (let ((cont ange-ftp-process-continue)) - (setq ange-ftp-process-continue nil) - (ange-ftp-call-cont cont - ange-ftp-process-result - ange-ftp-process-result-line)))))) - (set-buffer old-buffer))))) - -(defun ange-ftp-process-sentinel (proc str) - "When ftp process changes state, nuke all file-entries in cache." - (ange-ftp-save-match-data - (let ((name (process-name proc))) - (if (string-match "\\*ftp \\([^@]+\\)@\\([^*]+\\)*" name) - (let ((user (substring name (match-beginning 1) (match-end 1))) - (host (substring name (match-beginning 2) (match-end 2)))) - (ange-ftp-wipe-file-entries host user)))) - (setq ange-ftp-ls-cache-file nil))) - -;;;; ------------------------------------------------------------ -;;;; Gateway support. -;;;; ------------------------------------------------------------ - -(defun ange-ftp-use-gateway-p (host) - "Returns whether to access this host via a normal (non-smart) gateway." - ;; yes, I know that I could simplify the following expression, but it is - ;; clearer (to me at least) this way. - (and (not ange-ftp-smart-gateway) - (ange-ftp-save-match-data - (not (string-match ange-ftp-local-host-regexp host))))) - -(defun ange-ftp-use-smart-gateway-p (host) - "Returns whether to access this host via a smart gateway." - (and ange-ftp-smart-gateway - (ange-ftp-save-match-data - (not (string-match ange-ftp-local-host-regexp host))))) - - -;;; ------------------------------------------------------------ -;;; Temporary file location and deletion... -;;; ------------------------------------------------------------ - -(defvar ange-ftp-tmp-name-files ()) -(defvar ange-ftp-tmp-name-hashtable (ange-ftp-make-hashtable 10)) -(defvar ange-ftp-pid nil) - -(defun ange-ftp-get-pid () - "Half-hearted attempt to get the current process's id." - (setq ange-ftp-pid (substring (make-temp-name "") 1))) - -(defun ange-ftp-make-tmp-name (host) - "This routine will return the name of a new file." - (let* ((template (if (ange-ftp-use-gateway-p host) - ange-ftp-gateway-tmp-name-template - ange-ftp-tmp-name-template)) - (pid (or ange-ftp-pid (ange-ftp-get-pid))) - (start ?a) - file entry) - (while - (progn - (setq file (format "%s%c%s" template start pid)) - (setq entry (intern file ange-ftp-tmp-name-hashtable)) - (or (memq entry ange-ftp-tmp-name-files) - (ange-ftp-real-file-exists-p file))) - (if (> (setq start (1+ start)) ?z) - (progn - (setq template (concat template "X")) - (setq start ?a)))) - (setq ange-ftp-tmp-name-files - (cons entry ange-ftp-tmp-name-files)) - file)) - -(defun ange-ftp-del-tmp-name (temp) - (setq ange-ftp-tmp-name-files - (delq (intern temp ange-ftp-tmp-name-hashtable) - ange-ftp-tmp-name-files)) - (condition-case () - (ange-ftp-real-delete-file temp) - (error nil))) - -;;;; ------------------------------------------------------------ -;;;; Interactive gateway program support. -;;;; ------------------------------------------------------------ - -(defvar ange-ftp-gwp-running t) -(defvar ange-ftp-gwp-status nil) - -(defun ange-ftp-gwp-sentinel (proc str) - (setq ange-ftp-gwp-running nil)) - -(defun ange-ftp-gwp-filter (proc str) - (ange-ftp-save-match-data - (ange-ftp-process-log-string proc str) - (cond ((string-match "login: *$" str) - (send-string proc - (concat - (let ((ange-ftp-default-user t)) - (ange-ftp-get-user ange-ftp-gateway-host)) - "\n"))) - ((string-match "Password: *$" str) - (send-string proc - (concat - (ange-ftp-get-passwd ange-ftp-gateway-host - (ange-ftp-get-user - ange-ftp-gateway-host)) - "\n"))) - ((string-match ange-ftp-gateway-fatal-msgs str) - (delete-process proc) - (setq ange-ftp-gwp-running nil)) - ((string-match ange-ftp-gateway-prompt-pattern str) - (setq ange-ftp-gwp-running nil - ange-ftp-gwp-status t))))) - -(defun ange-ftp-gwp-start (host user name args) - "Login to the gateway machine and fire up an ftp process." - (let* ((gw-user (ange-ftp-get-user ange-ftp-gateway-host)) - (proc (start-process name name - ange-ftp-gateway-program - ange-ftp-gateway-host)) - (ftp (mapconcat (function identity) args " "))) - (process-kill-without-query proc) - (set-process-sentinel proc (function ange-ftp-gwp-sentinel)) - (set-process-filter proc (function ange-ftp-gwp-filter)) - (set-marker (process-mark proc) (point)) - (setq ange-ftp-gwp-running t - ange-ftp-gwp-status nil) - (ange-ftp-message "Connecting to gateway %s..." ange-ftp-gateway-host) - (while ange-ftp-gwp-running ;perform login sequence - (accept-process-output proc)) - (if (not ange-ftp-gwp-status) - (ange-ftp-error host user "unable to login to gateway")) - (ange-ftp-message "Connecting to gateway %s...done" ange-ftp-gateway-host) - (setq ange-ftp-gwp-running t - ange-ftp-gwp-status nil) - (process-send-string proc ange-ftp-gateway-setup-term-command) - (while ange-ftp-gwp-running ;zap ^M's and double echoing. - (accept-process-output proc)) - (if (not ange-ftp-gwp-status) - (ange-ftp-error host user "unable to set terminal modes on gateway")) - (setq ange-ftp-gwp-running t - ange-ftp-gwp-status nil) - (process-send-string proc (concat "exec " ftp "\n")) ;spawn ftp process - proc)) - -;;;; ------------------------------------------------------------ -;;;; Support for sending commands to the ftp process. -;;;; ------------------------------------------------------------ - -(defun ange-ftp-raw-send-cmd (proc cmd &optional msg cont nowait) - "Low-level routine to send the given ftp CMD to the ftp PROCESS. -MSG is an optional message to output before and after the command. -If CONT is non-NIL then it is either a function or a list of function and -some arguments. The function will be called when the ftp command has completed. -If CONT is NIL then this routine will return \( RESULT . LINE \) where RESULT -is whether the command was successful, and LINE is the line from the FTP -process that caused the command to complete. -If NOWAIT is given then the routine will return immediately the command has -been queued with no result. CONT will still be called, however." - (if (memq (process-status proc) '(run open)) - (save-excursion - (set-buffer (process-buffer proc)) - (while ange-ftp-process-busy - (accept-process-output)) - (setq ange-ftp-process-string "" - ange-ftp-process-result-line "" - ange-ftp-process-busy t - ange-ftp-process-result nil - ange-ftp-process-multi-skip nil - ange-ftp-process-msg msg - ange-ftp-process-continue cont - ange-ftp-hash-mark-count 0 - ange-ftp-last-percent -1 - cmd (concat cmd "\n")) - (and msg ange-ftp-process-verbose (ange-ftp-message "%s..." msg)) - (goto-char (point-max)) -; (move-marker last-input-start (point)) - ;; don't insert the password into the buffer on the USER command. - (ange-ftp-save-match-data - (if (string-match "^user \"[^\"]*\"" cmd) - (insert (substring cmd 0 (match-end 0)) " Turtle Power!\n") - (insert cmd))) -; (move-marker last-input-end (point)) - (send-string proc cmd) - (set-marker (process-mark proc) (point)) - (if nowait - nil - ;; hang around for command to complete - (while ange-ftp-process-busy - (accept-process-output proc)) - (if cont - nil ;cont has already been called - (cons ange-ftp-process-result ange-ftp-process-result-line)))))) - -(defun ange-ftp-nslookup-host (host) - "Attempt to resolve the given HOSTNAME using nslookup if possible." - (interactive "sHost: ") - (if ange-ftp-nslookup-program - (let ((proc (start-process " *nslookup*" " *nslookup*" - ange-ftp-nslookup-program host)) - (res host)) - (process-kill-without-query proc) - (save-excursion - (set-buffer (process-buffer proc)) - (while (memq (process-status proc) '(run open)) - (accept-process-output proc)) - (goto-char (point-min)) - (if (re-search-forward "Name:.*\nAddress: *\\(.*\\)$" nil t) - (setq res (buffer-substring (match-beginning 1) - (match-end 1)))) - (kill-buffer (current-buffer))) - res) - host)) - -(defun ange-ftp-start-process (host user name) - "Spawn a new ftp process ready to connect to machine HOST and give it NAME. -If HOST is only ftp-able through a gateway machine then spawn a shell -on the gateway machine to do the ftp instead." - (let* ((use-gateway (ange-ftp-use-gateway-p host)) - (ftp-prog (if use-gateway - ange-ftp-gateway-ftp-program-name - ange-ftp-ftp-program-name)) - (args (append (list ftp-prog) ange-ftp-ftp-program-args)) - (saved-term-var (getenv "TERM")) - proc) - ;; fix problems in losing Linux FTP's, which like to output - ;; ESC sequences to highlight the ftp prompt, which messes things up - (unwind-protect - (progn - (setenv "TERM" "dumb") - (if use-gateway - (if ange-ftp-gateway-program-interactive - (setq proc (ange-ftp-gwp-start host user name args)) - (setq proc (apply 'start-process name name - (append (list ange-ftp-gateway-program - ange-ftp-gateway-host) - args)))) - (setq proc (apply 'start-process name name args))) - (process-kill-without-query proc) - (set-process-sentinel proc (function ange-ftp-process-sentinel)) - (set-process-filter proc (function ange-ftp-process-filter))) - (setenv "TERM" saved-term-var)) - ;; jwz: turn on shell mode after setting the proc filter for the - ;; benefit of shell-font. - (require 'shell) - (save-excursion - (set-buffer (process-buffer proc)) - (ange-ftp-shell-mode)) - (accept-process-output proc) ;wait for ftp startup message - proc)) - -(defun ange-ftp-smart-login (host user pass account proc) - "Connect to the FTP-server on HOST as USER using PASSWORD and ACCOUNT. -PROC is the FTP-client's process. This routine uses the smart-gateway -host specified in ``ange-ftp-gateway-host''." - (let ((result (ange-ftp-raw-send-cmd - proc - (format "open %s %s" - (ange-ftp-nslookup-host ange-ftp-gateway-host) - ange-ftp-smart-gateway-port) - (format "Opening FTP connection to %s via %s" - host - ange-ftp-gateway-host)))) - (or (car result) - (ange-ftp-error host user - (concat "OPEN request failed: " - (cdr result)))) - (setq result (ange-ftp-raw-send-cmd - proc (format "user \"%s\"@%s %s %s" - user - (ange-ftp-nslookup-host host) - pass - account) - (format "Logging in as user %s@%s" - user host))) - (or (car result) - (progn - (ange-ftp-set-passwd host user nil) ; reset password - (ange-ftp-set-account host user nil) ; reset account - (ange-ftp-error host user - (concat "USER request failed: " - (cdr result))))))) - -(defun ange-ftp-normal-login (host user pass account proc) - "Connect to the FTP-server on HOST as USER using PASSWORD and ACCOUNT. -PROC is the process to the FTP-client." - (let ((result (ange-ftp-raw-send-cmd - proc - (format "open %s" (ange-ftp-nslookup-host host)) - (format "Opening FTP connection to %s" host)))) - (or (car result) - (ange-ftp-error host user - (concat "OPEN request failed: " - (cdr result)))) - (setq result (ange-ftp-raw-send-cmd - proc - (format "user \"%s\" %s %s" user pass account) - (format "Logging in as user %s@%s" user host))) - (or (car result) - (progn - (ange-ftp-set-passwd host user nil) ;reset password. - (ange-ftp-set-account host user nil) ;reset account. - (ange-ftp-error host user - (concat "USER request failed: " - (cdr result))))))) - -(defvar ange-ftp-hash-mark-msgs - "[hH]ash mark [^0-9]*\\([0-9]+\\)" - "*Regexp matching the FTP client's output upon doing a HASH command.") - -(defun ange-ftp-guess-hash-mark-size (proc) - (if ange-ftp-send-hash - (save-excursion - (set-buffer (process-buffer proc)) - (let* ((status (ange-ftp-raw-send-cmd proc "hash")) - (result (car status)) - (line (cdr status))) - (ange-ftp-save-match-data - (if (string-match ange-ftp-hash-mark-msgs line) - (let ((size (string-to-int - (substring line - (match-beginning 1) - (match-end 1))))) - (setq ange-ftp-ascii-hash-mark-size size - ange-ftp-hash-mark-unit (ash size -4)) - - ;; if a default value for this is set, use that value. - (or ange-ftp-binary-hash-mark-size - (setq ange-ftp-binary-hash-mark-size size))))))))) - -(defun ange-ftp-get-process (host user) - "Return the process object for a FTP process connected to HOST and -logged in as USER. Create a new process if needed." - (let* ((name (ange-ftp-ftp-process-buffer host user)) - (proc (get-process name))) - (if (and proc (memq (process-status proc) '(run open))) - proc - (let ((pass (ange-ftp-quote-string - (ange-ftp-get-passwd host user))) - (account (ange-ftp-quote-string - (ange-ftp-get-account host user)))) - ;; grab a suitable process. - (setq proc (ange-ftp-start-process host user name)) - - ;; login to FTP server. - (if (ange-ftp-use-smart-gateway-p host) - (ange-ftp-smart-login host user pass account proc) - (ange-ftp-normal-login host user pass account proc)) - - ;; Tell client to send back hash-marks as progress. It isn't usually - ;; fatal if this command fails. - (ange-ftp-guess-hash-mark-size proc) - - ;; Guess at the host type. - (ange-ftp-guess-host-type host user) - - ;; Run any user-specified hooks. Note that proc, host and user are - ;; dynamically bound at this point. - (run-hooks 'ange-ftp-process-startup-hook)) - proc))) - -;; Variables for caching host and host-type -(defvar ange-ftp-host-cache nil) -(defvar ange-ftp-host-type-cache nil) - -;; If ange-ftp-host-type is called with the optional user -;; argument, it will attempt to guess the host type by connecting -;; as user, if necessary. For efficiency, I have tried to give this -;; optional second argument only when necessary. Have I missed any calls -;; to ange-ftp-host-type where it should have been supplied? - -(defun ange-ftp-host-type (host &optional user) - "Return a symbol which represents the type of the HOST given. -If the optional argument USER is given, attempts to guess the -host-type by logging in as USER." - (if (eq host ange-ftp-host-cache) - ange-ftp-host-type-cache - ;; Trigger an ftp connection, in case we need to guess at the host type. - (if (and user (ange-ftp-get-process host user) (eq host ange-ftp-host-cache)) - ange-ftp-host-type-cache - (setq ange-ftp-host-cache host - ange-ftp-host-type-cache - (cond ((ange-ftp-dumb-unix-host host) - 'dumb-unix) - ((and (fboundp 'ange-ftp-vos-host) - (ange-ftp-vos-host host)) - 'vos) - ((and (fboundp 'ange-ftp-vms-host) - (ange-ftp-vms-host host)) - 'vms) - ((and (fboundp 'ange-ftp-mts-host) - (ange-ftp-mts-host host)) - 'mts) - ((and (fboundp 'ange-ftp-cms-host) - (ange-ftp-cms-host host)) - 'cms) - (t - 'unix)))))) - -;; It would be nice to abstract the functions ange-ftp-TYPE-host and -;; ange-ftp-add-TYPE-host. The trick is to abstract these functions -;; without sacrificing speed. Also, having separate variables -;; ange-ftp-TYPE-regexp is more user friendly then requiring the user to -;; set an alist to indicate that a host is of a given type. Even with -;; automatic host type recognition, setting a regexp is still a good idea -;; (for efficiency) if you log into a particular non-UNIX host frequently. - -(defvar ange-ftp-fix-path-func-alist nil - "Association list of \( TYPE \. FUNC \) pairs, where FUNC is a routine -which can change a UNIX path into a path more suitable for a host of type -TYPE.") - -(defvar ange-ftp-fix-dir-path-func-alist nil - "Association list of \( TYPE \. FUNC \) pairs, where FUNC is a routine -which can change UNIX directory path into a directory path more suitable -for a host of type TYPE.") - -;; *** Perhaps the sense of this variable should be inverted, since there -;; *** is only 1 host type that can take ls-style listing options. -(defvar ange-ftp-dumb-host-types '(dumb-unix) - "List of host types that can't take UNIX ls-style listing options.") - -(defun ange-ftp-send-cmd (host user cmd &optional msg cont nowait) - "Find an ftp process connected to HOST logged in as USER and send it CMD. -MSG is an optional status message to be output before and after issuing the -command. -See the documentation for ange-ftp-raw-send-cmd for a description of CONT -and NOWAIT." - ;; Handle conversion to remote pathname syntax and remote ls option - ;; capability. - (let ((cmd0 (car cmd)) - (cmd1 (nth 1 cmd)) - cmd2 cmd3 host-type fix-pathname-func) - - (cond - - ;; pwd case (We don't care what host-type.) - ((null cmd1)) - - ;; cmd == 'dir "remote-path" "local-path" "ls-switches" - ((progn - (setq cmd2 (nth 2 cmd) - host-type (ange-ftp-host-type host user)) - ;; This will trigger an FTP login, if one doesn't exist - (eq cmd0 'dir)) - (setq cmd1 (funcall - (or (cdr (assq host-type ange-ftp-fix-dir-path-func-alist)) - 'identity) - cmd1) - cmd3 (nth 3 cmd)) - ;; Need to deal with the HP-UX ftp bug. This should also allow - ;; us to resolve symlinks to directories on SysV machines. (Sebastian will - ;; be happy.) - (and (eq host-type 'unix) - (string-match "/$" cmd1) - (not (string-match "R" cmd3)) - (setq cmd1 (concat cmd1 "."))) - ;; If the remote ls can take switches, put them in - (or (memq host-type ange-ftp-dumb-host-types) - (setq cmd0 'ls - cmd1 (format "\"%s %s\"" cmd3 cmd1)))) - - ;; First argument is the remote pathname - ((progn - (setq fix-pathname-func (or (cdr (assq host-type - ange-ftp-fix-path-func-alist)) - 'identity)) - (memq cmd0 '(get delete mkdir rmdir cd))) - (setq cmd1 (funcall fix-pathname-func cmd1))) - - ;; Second argument is the remote pathname - ((memq cmd0 '(append put chmod)) - (setq cmd2 (funcall fix-pathname-func cmd2))) - - ;; Both arguments are remote pathnames - ((eq cmd0 'rename) - (setq cmd1 (funcall fix-pathname-func cmd1) - cmd2 (funcall fix-pathname-func cmd2)))) - - ;; Turn the command into one long string - (setq cmd0 (symbol-name cmd0)) - (setq cmd (concat cmd0 - (and cmd1 (concat " " cmd1)) - (and cmd2 (concat " " cmd2)))) - - ;; Actually send the resulting command. - (let (afsc-result - afsc-line) - (ange-ftp-raw-send-cmd - (ange-ftp-get-process host user) - cmd - msg - (list - (function (lambda (result line host user - cmd msg cont nowait) - (or cont - (setq afsc-result result - afsc-line line)) - (if result - (ange-ftp-call-cont cont result line) - (ange-ftp-raw-send-cmd - (ange-ftp-get-process host user) - cmd - msg - (list - (function (lambda (result line cont) - (or cont - (setq afsc-result result - afsc-line line)) - (ange-ftp-call-cont cont result line))) - cont) - nowait)))) - host user cmd msg cont nowait) - nowait) - - (if nowait - nil - (if cont - nil - (cons afsc-result afsc-line)))))) - -;; It might be nice to message users about the host type identified, -;; but there is so much other messaging going on, it would not be -;; seen. No point in slowing things down just so users can read -;; a host type message. - -(defconst ange-ftp-cms-path-template - (concat - "^[-A-Z0-9$*][-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?" - "[-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?\\.[0-9][0-9][0-9A-Z]$")) -(defconst ange-ftp-vms-path-template - "^[-A-Z0-9_$]+:\\[[-A-Z0-9_$]+\\(\\.[-A-Z0-9_$]+\\)*\\]$") -(defconst ange-ftp-mts-path-template - "^[A-Z0-9._][A-Z0-9._][A-Z0-9._][A-Z0-9._]:$") - -(defun ange-ftp-guess-host-type (host user) - "Guess at the host type of HOST by doing a pwd, and examining -the directory syntax." - (let ((host-type (ange-ftp-host-type host)) - (key (concat host "/" user "/~"))) - (if (eq host-type 'unix) - ;; Note that ange-ftp-host-type returns unix as the default value. - (ange-ftp-save-match-data - (let* ((result (ange-ftp-get-pwd host user)) - (dir (car result)) - fix-path-func) - (cond ((null dir) - (message "Warning! Unable to get home directory") - (sit-for 1) - (if (string-match - "^450 No current working directory defined$" - (cdr result)) - - ;; We'll assume that if pwd bombs with this - ;; error message, then it's CMS. - (progn - (ange-ftp-add-cms-host host) - (setq ange-ftp-host-cache host - ange-ftp-host-type-cache 'cms)))) - - ;; try for VMS - ((string-match ange-ftp-vms-path-template dir) - (ange-ftp-add-vms-host host) - ;; The add-host functions clear the host type cache. - ;; Therefore, need to set the cache afterwards. - (setq ange-ftp-host-cache host - ange-ftp-host-type-cache 'vms)) - - ;; try for MTS - ((string-match ange-ftp-mts-path-template dir) - (ange-ftp-add-mts-host host) - (setq ange-ftp-host-cache host - ange-ftp-host-type-cache 'mts)) - - ;; try for CMS - ((string-match ange-ftp-cms-path-template dir) - (ange-ftp-add-cms-host host) - (setq ange-ftp-host-cache host - ange-ftp-host-type-cache 'cms)) - - ;; assume UN*X - (t - (setq ange-ftp-host-cache host - ange-ftp-host-type-cache 'unix))) - - ;; Now that we have done a pwd, might as well put it in - ;; the expand-dir hashtable. - (setq fix-path-func (cdr (assq ange-ftp-host-type-cache - ange-ftp-fix-path-func-alist))) - (if fix-path-func - (setq dir (funcall fix-path-func dir 'reverse))) - (ange-ftp-put-hash-entry key dir - ange-ftp-expand-dir-hashtable)))) - - ;; In the special case of CMS make sure that know the - ;; expansion of the home minidisk now, because we will - ;; be doing a lot of cd's. - (if (and (eq host-type 'cms) - (not (ange-ftp-hash-entry-exists-p - key ange-ftp-expand-dir-hashtable))) - (let ((dir (car (ange-ftp-get-pwd host user)))) - (if dir - (ange-ftp-put-hash-entry key (concat "/" dir) - ange-ftp-expand-dir-hashtable) - (message "Warning! Unable to get home directory") - (sit-for 1)))))) - - -;;;; ------------------------------------------------------------ -;;;; Simple FTP process shell support. -;;;; ------------------------------------------------------------ - -(defvar ange-ftp-shell-mode-map nil) - -(defun ange-ftp-shell-mode () - "Major mode for interacting with an FTP process. -Return at end of buffer sends line as input. -Return not at end copies rest of line to end and sends it. - -The following commands imitate the usual Unix interrupt and editing -control characters: -\\{ange-ftp-shell-mode-map} -Runs ange-ftp-shell-mode-hook if not nil." - (interactive) - (let ((proc (get-buffer-process (current-buffer)))) - (kill-all-local-variables) - (shell-mode) - (if (null ange-ftp-shell-mode-map) - (progn - (setq ange-ftp-shell-mode-map (make-sparse-keymap)) - (set-keymap-parent ange-ftp-shell-mode-map shell-mode-map) - (set-keymap-name ange-ftp-shell-mode-map 'ange-ftp-shell-mode-map))) - (use-local-map ange-ftp-shell-mode-map) - (setq major-mode 'ange-ftp-shell-mode) - (setq mode-name "ange-ftp") - (goto-char (point-max)) - (set-marker (process-mark proc) (point)) - (set (make-local-variable 'ange-ftp-process-string) nil) - (setq ange-ftp-process-string "") - (set (make-local-variable 'ange-ftp-process-busy) nil) - (set (make-local-variable 'ange-ftp-process-result) nil) - (set (make-local-variable 'ange-ftp-process-msg) nil) - (set (make-local-variable 'ange-ftp-process-multi-skip) nil) - (set (make-local-variable 'ange-ftp-process-result-line) nil) - (set (make-local-variable 'ange-ftp-process-continue) nil) - (set (make-local-variable 'ange-ftp-hash-mark-count) nil) - (set (make-local-variable 'ange-ftp-binary-hash-mark-size) nil) - (set (make-local-variable 'ange-ftp-ascii-hash-mark-size) nil) - (set (make-local-variable 'ange-ftp-hash-mark-unit) nil) - (set (make-local-variable 'ange-ftp-xfer-size) nil) - (set (make-local-variable 'ange-ftp-last-percent) nil) - (setq ange-ftp-hash-mark-count 0) - (setq ange-ftp-xfer-size 0) - (setq ange-ftp-process-result-line "") - (run-hooks 'ange-ftp-shell-mode-hook))) - -;;;; ------------------------------------------------------------ -;;;; Remote file and directory listing support. -;;;; ------------------------------------------------------------ - -(defun ange-ftp-dumb-unix-host (host) - "Returns whether HOST's FTP server doesn't like \'ls\' or \'dir\' commands -to take switch arguments." - (and ange-ftp-dumb-unix-host-regexp - (ange-ftp-save-match-data - (string-match ange-ftp-dumb-unix-host-regexp host)))) - -(defun ange-ftp-add-dumb-unix-host (host) - "Interactively adds a given HOST to ange-ftp-dumb-unix-host-regexp." - (interactive - (list (read-string "Host: " - (let ((name (or (buffer-file-name) - (and (eq major-mode 'dired-mode) - dired-directory)))) - (and name (car (ange-ftp-ftp-path name))))))) - (if (not (ange-ftp-dumb-unix-host host)) - (setq ange-ftp-dumb-unix-host-regexp - (concat "^" (regexp-quote host) "$" - (and ange-ftp-dumb-unix-host-regexp "\\|") - ange-ftp-dumb-unix-host-regexp) - ange-ftp-host-cache nil))) - -(defvar ange-ftp-parse-list-func-alist nil - "Association list of \( TYPE \. FUNC \) pairs. The FUNC is a routine -which can parse the output from a DIR listing for a host of type TYPE.") - -;; With no-error nil, this function returns: -;; an error if file is not an ange-ftp-path -;; (This should never happen.) -;; an error if either the listing is unreadable or there is an ftp error. -;; the listing (a string), if everything works. -;; -;; With no-error t, it returns: -;; an error if not an ange-ftp-path -;; error if listing is unreable (most likely caused by a slow connection) -;; nil if ftp error (this is because although asking to list a nonexistent -;; directory on a remote unix machine usually (except -;; maybe for dumb hosts) returns an ls error, but no -;; ftp error, if the same is done on a VMS machine, -;; an ftp error is returned. Need to trap the error -;; so we can go on and try to list the parent.) -;; the listing, if everything works. - -(defun ange-ftp-ls (file lsargs parse &optional no-error) - "Return the output of an `DIR' or `ls' command done over ftp. -FILE is the full name of the remote file, LSARGS is any args to pass to the -`ls' command, and PARSE specifies that the output should be parsed and stored -away in the internal cache." - ;; If parse is t, we assume that file is a directory. i.e. we only parse - ;; full directory listings. - (setq file (ange-ftp-expand-file-name file)) - (let ((parsed (ange-ftp-ftp-path file))) - (if parsed - (let* ((host (nth 0 parsed)) - (user (nth 1 parsed)) - (path (ange-ftp-quote-string (nth 2 parsed))) - (key (directory-file-name file)) - (host-type (ange-ftp-host-type host user)) - (dumb (memq host-type ange-ftp-dumb-host-types)) - result - temp - lscmd parse-func) - (if (string-equal path "") - (setq path - (ange-ftp-real-file-name-as-directory - (ange-ftp-expand-dir host user "~")))) - (if (and ange-ftp-ls-cache-file - (string-equal key ange-ftp-ls-cache-file) - ;; Don't care about lsargs for dumb hosts. - (or dumb (string-equal lsargs ange-ftp-ls-cache-lsargs))) - ange-ftp-ls-cache-res - (setq temp (ange-ftp-make-tmp-name host)) - (setq lscmd (list 'dir path temp lsargs)) - (unwind-protect - (if (car (setq result (ange-ftp-send-cmd - host - user - lscmd - (format "Listing %s" - (ange-ftp-abbreviate-filename - file))))) - (save-excursion - (set-buffer (get-buffer-create - ange-ftp-data-buffer-name)) - (erase-buffer) - (if (ange-ftp-real-file-readable-p temp) - (ange-ftp-real-insert-file-contents temp) - (sleep-for ange-ftp-retry-time) - ;wait for file to possibly appear - (if (ange-ftp-real-file-readable-p temp) - ;; Try again. - (ange-ftp-real-insert-file-contents temp) - (ange-ftp-error host user - (format - "list data file %s not readable" - temp)))) - (if parse - (ange-ftp-set-files - file - (if (setq - parse-func - (cdr (assq host-type - ange-ftp-parse-list-func-alist))) - (funcall parse-func) - (ange-ftp-parse-dired-listing lsargs)))) - (setq ange-ftp-ls-cache-file key - ange-ftp-ls-cache-lsargs lsargs - ; For dumb hosts-types this is - ; meaningless but harmless. - ange-ftp-ls-cache-res (buffer-string)) - ;; (kill-buffer (current-buffer)) - ange-ftp-ls-cache-res) - (if no-error - nil - (ange-ftp-error host user - (concat "DIR failed: " (cdr result))))) - (ange-ftp-del-tmp-name temp)))) - (error "Should never happen. Please report. Bug ref. no.: 1")))) - -;;;; ------------------------------------------------------------ -;;;; Directory information caching support. -;;;; ------------------------------------------------------------ - -(defconst ange-ftp-date-regexp - (concat - " \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" - "\\|Nov\\|Dec\\) +[0-3]?[0-9] ")) - -(defvar ange-ftp-add-file-entry-alist nil - "Association list of pairs \( TYPE \. FUNC \), where FUNC -is a function to be used to add a file entry for the OS TYPE. The -main reason for this alist is to deal with file versions in VMS.") - -(defvar ange-ftp-delete-file-entry-alist nil - "Association list of pairs \( TYPE \. FUNC \), where FUNC -is a function to be used to delete a file entry for the OS TYPE. -The main reason for this alist is to deal with file versions in -VMS.") - -(defun ange-ftp-add-file-entry (path &optional dir-p) - "Given a PATH, add the file entry for it, if its directory -info exists." - (funcall (or (cdr (assq (ange-ftp-host-type - (car (ange-ftp-ftp-path path))) - ange-ftp-add-file-entry-alist)) - 'ange-ftp-internal-add-file-entry) - path dir-p) - (setq ange-ftp-ls-cache-file nil)) - -(defun ange-ftp-delete-file-entry (path &optional dir-p) - "Given a PATH, delete the file entry for it, if its directory -info exists." - (funcall (or (cdr (assq (ange-ftp-host-type - (car (ange-ftp-ftp-path path))) - ange-ftp-delete-file-entry-alist)) - 'ange-ftp-internal-delete-file-entry) - path dir-p) - (setq ange-ftp-ls-cache-file nil)) - -(defmacro ange-ftp-parse-filename () - ;;Extract the filename from the current line of a dired-like listing. - (` (let ((eol (progn (end-of-line) (point)))) - (beginning-of-line) - (if (re-search-forward ange-ftp-date-regexp eol t) - (progn - (skip-chars-forward " ") - (skip-chars-forward "^ " eol) - (skip-chars-forward " " eol) - ;; We bomb on filenames starting with a space. - (buffer-substring (point) eol)))))) - -;; This deals with the F switch. Should also do something about -;; unquoting names obtained with the SysV b switch and the GNU Q -;; switch. See Sebastian's dired-get-filename. - -(defmacro ange-ftp-ls-parser () - ;; Note that switches is dynamically bound. - ;; Meant to be called by ange-ftp-parse-dired-listing - (` (let ((tbl (ange-ftp-make-hashtable)) - (used-F (and (stringp switches) - (string-match "F" switches))) - file-type symlink directory file) - (while (setq file (ange-ftp-parse-filename)) - (beginning-of-line) - (skip-chars-forward "\t 0-9") - (setq file-type (following-char) - directory (eq file-type ?d)) - (if (eq file-type ?l) - (if (string-match " -> " file) - (setq symlink (substring file (match-end 0)) - file (substring file 0 (match-beginning 0))) - ;; Shouldn't happen - (setq symlink "")) - (setq symlink nil)) - ;; Only do a costly regexp search if the F switch was used. - (if (and used-F - (not (string-equal file "")) - (looking-at - ".[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)")) - (let ((socket (eq file-type ?s)) - (executable - (and (not symlink) ; x bits don't mean a thing for symlinks - (string-match "[xst]" - (concat - (buffer-substring - (match-beginning 1) - (match-end 1)) - (buffer-substring - (match-beginning 2) - (match-end 2)) - (buffer-substring - (match-beginning 3) - (match-end 3))))))) - ;; Some ls's with the F switch mark symlinks with an @ (ULTRIX) - ;; and others don't. (sigh...) Beware, that some Unix's don't - ;; seem to believe in the F-switch - (if (or (and symlink (string-match "@$" file)) - (and directory (string-match "/$" file)) - (and executable (string-match "*$" file)) - (and socket (string-match "=$" file))) - (setq file (substring file 0 -1))))) - (ange-ftp-put-hash-entry file (or symlink directory) tbl) - (forward-line 1)) - (ange-ftp-put-hash-entry "." t tbl) - (ange-ftp-put-hash-entry ".." t tbl) - tbl))) - -;;; The dl stuff for descriptive listings - -(defvar ange-ftp-dl-dir-regexp nil - "Regexp matching directories which are listed in dl format. This regexp -shouldn't be anchored with a trailing $ so that it will match subdirectories -as well.") - -(defun ange-ftp-add-dl-dir (dir) - "Interactively adds a given directory to ange-ftp-dl-dir-regexp." - (interactive - (list (read-string "Directory: " - (let ((name (or (buffer-file-name) - (and (eq major-mode 'dired-mode) - dired-directory)))) - (and name (ange-ftp-ftp-path name) - (file-name-directory name)))))) - (if (not (and ange-ftp-dl-dir-regexp - (string-match ange-ftp-dl-dir-regexp dir))) - (setq ange-ftp-dl-dir-regexp - (concat "^" (regexp-quote dir) - (and ange-ftp-dl-dir-regexp "\\|") - ange-ftp-dl-dir-regexp)))) - -(defmacro ange-ftp-dl-parser () - ;; Parse the current buffer, which is assumed to be a descriptive - ;; listing, and return a hashtable. - (` (let ((tbl (ange-ftp-make-hashtable))) - (while (not (eobp)) - (ange-ftp-put-hash-entry - (buffer-substring (point) - (progn - (skip-chars-forward "^ /\n") - (point))) - (eq (following-char) ?/) - tbl) - (forward-line 1)) - (ange-ftp-put-hash-entry "." t tbl) - (ange-ftp-put-hash-entry ".." t tbl) - tbl))) - -(defun ange-ftp-parse-dired-listing (&optional switches) - "Parse the current buffer which is assumed to be in a dired-like listing -format, and return a hashtable as the result. If the listing is not really -a listing, then return nil." - (ange-ftp-save-match-data - (cond - ((looking-at "^total [0-9]+$") - (forward-line 1) - (ange-ftp-ls-parser)) - ((looking-at "[^\n]+\\( not found\\|: Not a directory\\)\n\\'") - ;; It's an ls error message. - nil) - ((eobp) ; i.e. (zerop (buffer-size)) - ;; This could be one of: - ;; (1) An Ultrix ls error message - ;; (2) A listing with the A switch of an empty directory - ;; on a machine which doesn't give a total line. - ;; (3) The twilight zone. - ;; We'll assume (1) for now. - nil) - ((re-search-forward ange-ftp-date-regexp nil t) - (beginning-of-line) - (ange-ftp-ls-parser)) - ((re-search-forward "^[^ \n\t]+ +\\([0-9]+\\|-\\|=\\) " nil t) - ;; It's a dl listing (I hope). - ;; file is bound by the call to ange-ftp-ls - (ange-ftp-add-dl-dir file) - (beginning-of-line) - (ange-ftp-dl-parser)) - (t nil)))) - -(defun ange-ftp-set-files (directory files) - "For a given DIRECTORY, set or change the associated FILES hashtable." - (and files (ange-ftp-put-hash-entry (file-name-as-directory directory) - files ange-ftp-files-hashtable))) - -(defun ange-ftp-get-files (directory &optional no-error) - "Given a given DIRECTORY, return a hashtable of file entries. -This will give an error or return nil, depending on the value of -NO-ERROR, if a listing for DIRECTORY cannot be obtained." - (setq directory (file-name-as-directory directory)) ;normalize - (or (ange-ftp-get-hash-entry directory ange-ftp-files-hashtable) - (ange-ftp-save-match-data - (and (ange-ftp-ls directory - ;; This is an efficiency hack. We try to - ;; anticipate what sort of listing dired - ;; might want, and cache just such a listing. - (if (and (boundp 'dired-actual-switches) - (stringp dired-actual-switches) - ;; We allow the A switch, which lists - ;; all files except "." and "..". - ;; This is OK because we manually - ;; insert these entries - ;; in the hash table. - (string-match - "[aA]" dired-actual-switches) - (string-match - "l" dired-actual-switches) - (not (string-match - "R" dired-actual-switches))) - dired-actual-switches - (if (and (boundp 'dired-listing-switches) - (stringp dired-listing-switches) - (string-match - "[aA]" dired-listing-switches) - (string-match - "l" dired-listing-switches) - (not (string-match - "R" dired-listing-switches))) - dired-listing-switches - "-al")) - t no-error) - (ange-ftp-get-hash-entry - directory ange-ftp-files-hashtable))))) - -(defmacro ange-ftp-get-file-part (path) - "Given PATH, return the file part that can be used for looking up the -file's entry in a hashtable." - (` (let ((file (file-name-nondirectory (, path)))) - (if (string-equal file "") - "." - file)))) - -(defmacro ange-ftp-allow-child-lookup (dir file) - "Return whether ange-ftp-file-entry-p and ange-ftp-get-file-entry are -allowed to determine if PATH is a sub-directory by listing it directly, -rather than listing its parent directory. This is used for efficiency so -that a wasted listing is not done: -1. When looking for a .dired file in dired-x.el. -2. The syntax of FILE and DIR make it impossible that FILE could be a valid - subdirectory. This is of course an OS dependent judgement." - (` (not - (let* ((efile (, file)) ; expand once. - (edir (, dir)) - (parsed (ange-ftp-ftp-path edir)) - (host-type (ange-ftp-host-type - (car parsed)))) - (or - ;; Deal with dired - (and (boundp 'dired-local-variables-file) - (stringp dired-local-variables-file) - (string-equal dired-local-variables-file efile)) - ;; No dots in dir names in vms. - (and (eq host-type 'vms) - (string-match "\\." efile)) - ;; No subdirs in mts of cms. - (and (memq host-type '(mts cms)) - (not (string-equal "/" (nth 2 parsed))))))))) - -(defun ange-ftp-file-entry-p (path) - "Given PATH, return whether there is a file entry for it." - (let* ((path (directory-file-name path)) - (dir (file-name-directory path)) - (ent (ange-ftp-get-hash-entry dir ange-ftp-files-hashtable)) - (file (ange-ftp-get-file-part path))) - (if ent - (ange-ftp-hash-entry-exists-p file ent) - (or (and (ange-ftp-allow-child-lookup dir file) - (setq ent (ange-ftp-get-files path t)) - ;; Try a child lookup. i.e. try to list file as a - ;; subdirectory of dir. This is a good idea because - ;; we may not have read permission for file's parent. Also, - ;; people tend to work down directory trees anyway. We use - ;; no-error ;; because if file does not exist as a subdir., - ;; then dumb hosts will give an ftp error. Smart unix hosts - ;; will simply send back the ls - ;; error message. - (ange-ftp-get-hash-entry "." ent)) - ;; Child lookup failed. Try the parent. If this bombs, - ;; we are at wits end -- signal an error. - ;; Problem: If this signals an error, the error message - ;; may not have a lot to do with what went wrong. - (ange-ftp-hash-entry-exists-p file - (ange-ftp-get-files dir)))))) - -(defun ange-ftp-get-file-entry (path) - "Given PATH, return the given file entry which will be either t for a -directory, nil for a normal file, or a string for a symlink. If the file -isn't in the hashtable, this also returns nil." - (let* ((path (directory-file-name path)) - (dir (file-name-directory path)) - (ent (ange-ftp-get-hash-entry dir ange-ftp-files-hashtable)) - (file (ange-ftp-get-file-part path))) - (if ent - (ange-ftp-get-hash-entry file ent) - (or (and (ange-ftp-allow-child-lookup dir file) - (setq ent (ange-ftp-get-files path t)) - (ange-ftp-get-hash-entry "." ent)) - ;; i.e. it's a directory by child lookup - (ange-ftp-get-hash-entry file - (ange-ftp-get-files dir)))))) - -(defun ange-ftp-internal-delete-file-entry (path &optional dir-p) - (if dir-p - (progn - (setq path (file-name-as-directory path)) - (ange-ftp-del-hash-entry path ange-ftp-files-hashtable) - (setq path (directory-file-name path)))) - ;; Note that file-name-as-directory followed by directory-file-name - ;; serves to canonicalize directory file names to their unix form. - ;; i.e. in VMS, FOO.DIR -> FOO/ -> FOO - (let ((files (ange-ftp-get-hash-entry (file-name-directory path) - ange-ftp-files-hashtable))) - (if files - (ange-ftp-del-hash-entry (ange-ftp-get-file-part path) - files)))) - -(defun ange-ftp-internal-add-file-entry (path &optional dir-p) - (and dir-p - (setq path (directory-file-name path))) - (let ((files (ange-ftp-get-hash-entry (file-name-directory path) - ange-ftp-files-hashtable))) - (if files - (ange-ftp-put-hash-entry (ange-ftp-get-file-part path) - dir-p - files)))) - -(defun ange-ftp-wipe-file-entries (host user) - "Replace the file entry information hashtable with one that doesn't have any -entries for the given HOST, USER pair." - (let ((new-tbl (ange-ftp-make-hashtable (length ange-ftp-files-hashtable)))) - (ange-ftp-map-hashtable - (function - (lambda (key val) - (let ((parsed (ange-ftp-ftp-path key))) - (if parsed - (let ((h (nth 0 parsed)) - (u (nth 1 parsed))) - (or (and (equal host h) (equal user u)) - (ange-ftp-put-hash-entry key val new-tbl))))))) - ange-ftp-files-hashtable) - (setq ange-ftp-files-hashtable new-tbl))) - -;;;; ------------------------------------------------------------ -;;;; File transfer mode support. -;;;; ------------------------------------------------------------ - -(defun ange-ftp-set-binary-mode (host user) - "Tell the ftp process for the given HOST & USER to switch to binary mode." - (let ((result (ange-ftp-send-cmd host user '(type "binary")))) - (if (not (car result)) - (ange-ftp-error host user (concat "BINARY failed: " (cdr result))) - (save-excursion - (set-buffer (process-buffer (ange-ftp-get-process host user))) - (and ange-ftp-binary-hash-mark-size - (setq ange-ftp-hash-mark-unit (ash ange-ftp-binary-hash-mark-size -4))))))) - -(defun ange-ftp-set-ascii-mode (host user) - "Tell the ftp process for the given HOST & USER to switch to ascii mode." - (let ((result (ange-ftp-send-cmd host user '(type "ascii")))) - (if (not (car result)) - (ange-ftp-error host user (concat "ASCII failed: " (cdr result))) - (save-excursion - (set-buffer (process-buffer (ange-ftp-get-process host user))) - (and ange-ftp-ascii-hash-mark-size - (setq ange-ftp-hash-mark-unit (ash ange-ftp-ascii-hash-mark-size -4))))))) - -;;; ------------------------------------------------------------ -;;; expand-file-name and friends... -;;; ------------------------------------------------------------ - -(defun ange-ftp-cd (host user dir) - (let ((result (ange-ftp-send-cmd host user (list 'cd dir) "Doing CD"))) - (or (car result) - (ange-ftp-error host user (concat "CD failed: " (cdr result)))))) - -(defun ange-ftp-get-pwd (host user) - "Attempts to get the current working directory for the given HOST/USER pair. -Returns \( DIR . LINE \) where DIR is either the directory or NIL if not found, -and LINE is the relevant success or fail line from the FTP-client." - (let* ((result (ange-ftp-send-cmd host user '(pwd) "Getting PWD")) - (line (cdr result)) - dir) - (if (car result) - (ange-ftp-save-match-data - (and (or (string-match "\"\\([^\"]*\\)\"" line) - (string-match " \\([^ ]+\\) " line)) ; stone-age VMS servers! - (setq dir (substring line - (match-beginning 1) - (match-end 1)))))) - (cons dir line))) - -(defconst ange-ftp-expand-dir-hashtable (ange-ftp-make-hashtable)) - -(defconst ange-ftp-expand-dir-regexp "^5.0 \\([^: ]+\\):") - -(defun ange-ftp-expand-dir (host user dir) - "Return the result of doing a PWD in the current FTP session to machine HOST -logged in as user USER and cd'd to directory DIR." - (let* ((host-type (ange-ftp-host-type host user)) - ;; It is more efficient to call ange-ftp-host-type - ;; before binding res, because ange-ftp-host-type sometimes - ;; adds to the info in the expand-dir-hashtable. - (fix-pathname-func - (cdr (assq host-type ange-ftp-fix-path-func-alist))) - (key (concat host "/" user "/" dir)) - (res (ange-ftp-get-hash-entry key ange-ftp-expand-dir-hashtable))) - (or res - (progn - (or - (string-equal user "anonymous") - (string-equal user "ftp") - (not (eq host-type 'unix)) - (let* ((ange-ftp-good-msgs (concat ange-ftp-expand-dir-regexp - "\\|" - ange-ftp-good-msgs)) - (result (ange-ftp-send-cmd host user - (list 'get dir "/dev/null") - (format "expanding %s" dir))) - (line (cdr result))) - (setq res - (if (string-match ange-ftp-expand-dir-regexp line) - (substring line - (match-beginning 1) - (match-end 1)))))) - (or res - (if (string-equal dir "~") - (setq res (car (ange-ftp-get-pwd host user))) - (let ((home (ange-ftp-expand-dir host user "~"))) - (unwind-protect - (and (ange-ftp-cd host user dir) - (setq res (car (ange-ftp-get-pwd host user)))) - (ange-ftp-cd host user home))))) - (if res - (progn - (if fix-pathname-func - (setq res (funcall fix-pathname-func res 'reverse))) - (ange-ftp-put-hash-entry - key res ange-ftp-expand-dir-hashtable))) - res)))) - -(defun ange-ftp-canonize-filename (n) - "Take a string and short-circuit //, /. and /.." - (if (string-match "[^:]+//" n) ;don't upset Apollo users - (setq n (substring n (1- (match-end 0))))) - (let ((parsed (ange-ftp-ftp-path n))) - (if parsed - (let ((host (car parsed)) - (user (nth 1 parsed)) - (path (nth 2 parsed))) - - ;; See if remote path is absolute. If so then just expand it and - ;; replace the path component of the overall path. - (cond ((string-match "^/" path) - path) - - ;; Path starts with ~ or ~user. Resolve that part of the path - ;; making it absolute then re-expand it. - ((string-match "^~[^/]*" path) - (let* ((tilda (substring path - (match-beginning 0) - (match-end 0))) - (rest (substring path (match-end 0))) - (dir (ange-ftp-expand-dir host user tilda))) - (if dir - (setq path (concat dir rest)) - (error "User \"%s\" is not known" - (substring tilda 1))))) - - ;; relative path. Tack on homedir and re-expand. - (t - (let ((dir (ange-ftp-expand-dir host user "~"))) - (if dir - (setq path (concat - (ange-ftp-real-file-name-as-directory dir) - path)) - (error "Unable to obtain CWD"))))) - - (if (not (string-match "^//" path)) - (progn - (setq path (ange-ftp-real-expand-file-name path)) - - (if (string-match "^//" path) - (setq path (substring path 1))))) - - ;; Now substitute the expanded path back into the overall filename. - (ange-ftp-replace-path-component n path)) - - ;; non-ange-ftp path. Just expand normally. - (if (eq (string-to-char n) ?/) - (ange-ftp-real-expand-file-name n) - (ange-ftp-real-expand-file-name - (ange-ftp-real-file-name-nondirectory n) - (ange-ftp-real-file-name-directory n)))))) - -(defun ange-ftp-expand-file-name (name &optional default) - "Documented as original." - (ange-ftp-save-match-data - (if (eq (string-to-char name) ?/) - (while (cond ((string-match "[^:]+//" name) ;don't upset Apollo users - (setq name (substring name (1- (match-end 0))))) - ((string-match "/~" name) - (setq name (substring name (1- (match-end 0)))))))) - (cond ((eq (string-to-char name) ?~) - (ange-ftp-real-expand-file-name name)) - ((eq (string-to-char name) ?/) - (ange-ftp-canonize-filename name)) - ((zerop (length name)) - (ange-ftp-canonize-filename (or default default-directory))) - ((ange-ftp-canonize-filename - (concat (file-name-as-directory (or default default-directory)) - name)))))) - -;;;; ------------------------------------------------------------ -;;;; Redefinitions of standard GNU Emacs functions. -;;;; ------------------------------------------------------------ - -(defvar ange-ftp-file-name-as-directory-alist nil - "Association list of \( TYPE \. FUNC \) pairs, where -FUNC converts a filename to a directory name for the operating -system TYPE.") - -(defun ange-ftp-file-name-as-directory (name) - "Documented as original." - (let ((parsed (ange-ftp-ftp-path name))) - (if parsed - (if (string-equal (nth 2 parsed) "") - name - (funcall (or (cdr (assq - (ange-ftp-host-type (car parsed)) - ange-ftp-file-name-as-directory-alist)) - 'ange-ftp-real-file-name-as-directory) - name)) - (ange-ftp-real-file-name-as-directory name)))) - -(defun ange-ftp-file-name-directory (name) - "Documented as original." - (let ((parsed (ange-ftp-ftp-path name))) - (if parsed - (let ((path (nth 2 parsed))) - (if (ange-ftp-save-match-data - (string-match "^~[^/]*$" path)) - name - (ange-ftp-replace-path-component - name - (ange-ftp-real-file-name-directory path)))) - (ange-ftp-real-file-name-directory name)))) - -(defun ange-ftp-file-name-nondirectory (name) - "Documented as original." - (let ((parsed (ange-ftp-ftp-path name))) - (if parsed - (let ((path (nth 2 parsed))) - (if (ange-ftp-save-match-data - (string-match "^~[^/]*$" path)) - "" - (ange-ftp-real-file-name-nondirectory path))) - (ange-ftp-real-file-name-nondirectory name)))) - -(defun ange-ftp-directory-file-name (dir) - "Documented as original." - (let ((parsed (ange-ftp-ftp-path dir))) - (if parsed - (ange-ftp-replace-path-component - dir - (ange-ftp-real-directory-file-name (nth 2 parsed))) - (ange-ftp-real-directory-file-name dir)))) - -(defun ange-ftp-binary-file (file) - "Returns whether the given FILE is to be considered as a binary file for -ftp transfers." - (ange-ftp-save-match-data - (string-match ange-ftp-binary-file-name-regexp file))) - -(defun ange-ftp-write-region (start end filename &optional append visit - lockname) - "Documented as original." - (interactive "r\nFWrite region to file: ") - (setq filename (expand-file-name filename)) - (let ((parsed (ange-ftp-ftp-path filename))) - (if parsed - (let* ((host (nth 0 parsed)) - (user (nth 1 parsed)) - (path (ange-ftp-quote-string (nth 2 parsed))) - (temp (ange-ftp-make-tmp-name host)) - (binary (ange-ftp-binary-file filename)) - (cmd (if append 'append 'put)) - (abbr (ange-ftp-abbreviate-filename filename))) - (unwind-protect - (progn - (let ((executing-macro t) - (filename (buffer-file-name)) - (mod-p (buffer-modified-p))) - (unwind-protect - (ange-ftp-real-write-region start end temp nil - visit lockname) - ;; cleanup forms - (setq buffer-file-name filename) - (if (fboundp 'compute-buffer-file-truename) - (compute-buffer-file-truename)) - (set-buffer-modified-p mod-p))) - (if binary - (ange-ftp-set-binary-mode host user)) - - ;; tell the process filter what size the transfer will be. - (let ((attr (file-attributes temp))) - (if attr - (ange-ftp-set-xfer-size host user (nth 7 attr)))) - - ;; put or append the file. - (let ((result (ange-ftp-send-cmd host user - (list cmd temp path) - (format "Writing %s" abbr)))) - (or (car result) - (signal 'ftp-error - (list - "Opening output file" - (format "FTP Error: \"%s\"" (cdr result)) - filename))))) - (ange-ftp-del-tmp-name temp) - (if binary - (ange-ftp-set-ascii-mode host user))) - (if (eq visit t) - (progn - (ange-ftp-set-buffer-mode) - (setq buffer-file-name filename) - (if (fboundp 'compute-buffer-file-truename) - (compute-buffer-file-truename)) - (set-buffer-modified-p nil))) - (ange-ftp-message "Wrote %s" abbr) - (ange-ftp-add-file-entry filename)) - (ange-ftp-real-write-region start end filename append visit lockname)))) - -(defun ange-ftp-insert-file-contents (filename &optional visit beg end replace) - "Documented as original." - (barf-if-buffer-read-only) - (setq filename (expand-file-name filename)) - (let ((parsed (ange-ftp-ftp-path filename))) - (if parsed - (progn - (if visit - (progn - (setq buffer-file-name filename) - (if (fboundp 'compute-buffer-file-truename) - (compute-buffer-file-truename)))) - (if (or (file-exists-p filename) - (progn - (setq ange-ftp-ls-cache-file nil) - (ange-ftp-del-hash-entry (file-name-directory filename) - ange-ftp-files-hashtable) - (file-exists-p filename))) - (let* ((host (nth 0 parsed)) - (user (nth 1 parsed)) - (path (ange-ftp-quote-string (nth 2 parsed))) - (temp (ange-ftp-make-tmp-name host)) - (binary (ange-ftp-binary-file filename)) - (abbr (ange-ftp-abbreviate-filename filename)) - size) - (unwind-protect - (progn - (if binary - (ange-ftp-set-binary-mode host user)) - (let ((result (ange-ftp-send-cmd host user - (list 'get path temp) - (format "Retrieving %s" abbr)))) - (or (car result) - (signal 'ftp-error - (list - "Opening input file" - (format "FTP Error: \"%s\"" (cdr result)) - filename)))) - (if (or (ange-ftp-real-file-readable-p temp) - (sleep-for ange-ftp-retry-time) - ;; Wait for file to hopefully appear. - (ange-ftp-real-file-readable-p temp)) - (setq - size - (nth 1 (progn - (if replace ; kludge... - (delete-region (point-min) - (point-max))) - (ange-ftp-real-insert-file-contents - temp visit beg end nil)))) - (signal 'ftp-error - (list - "Opening input file:" - (format - "FTP Error: %s not arrived or readable" - filename))))) - (if binary - (ange-ftp-set-ascii-mode host user)) - (ange-ftp-del-tmp-name temp)) - (if visit - (progn - (setq buffer-file-name filename) - (if (fboundp 'compute-buffer-file-truename) - (compute-buffer-file-truename)))) - (list filename size)) - (signal 'file-error - (list - "Opening input file" - filename)))) - (ange-ftp-real-insert-file-contents filename visit beg end replace)))) - -(defun ange-ftp-revert-buffer (arg noconfirm) - "Revert this buffer from a remote file using ftp." - (let ((opoint (point))) - (cond ((null buffer-file-name) - (error "Buffer does not seem to be associated with any file")) - ((or noconfirm - (yes-or-no-p (format "Revert buffer from file %s? " - buffer-file-name))) - (let ((buffer-read-only nil)) - ;; Set buffer-file-name to nil - ;; so that we don't try to lock the file. - (let ((buffer-file-name nil)) - (unlock-buffer) - (erase-buffer)) - (insert-file-contents buffer-file-name t)) - (goto-char (min opoint (point-max))) - (after-find-file nil) - t)))) - -(defun ange-ftp-expand-symlink (file dir) - (if (file-name-absolute-p file) - (ange-ftp-replace-path-component dir file) - (expand-file-name file dir))) - -(defun ange-ftp-file-symlink-p (file) - "Documented as original." - ;; call ange-ftp-expand-file-name rather than the normal - ;; expand-file-name to stop loops when using a package that - ;; redefines both file-symlink-p and expand-file-name. - (setq file (ange-ftp-expand-file-name file)) - (if (ange-ftp-ftp-path file) - (let ((file-ent - (ange-ftp-get-hash-entry - (ange-ftp-get-file-part file) - (ange-ftp-get-files (file-name-directory file))))) - (if (stringp file-ent) - (if (file-name-absolute-p file-ent) - (ange-ftp-replace-path-component - (file-name-directory file) file-ent) - file-ent))) - (ange-ftp-real-file-symlink-p file))) - -(defun ange-ftp-file-exists-p (path) - "Documented as original." - (setq path (expand-file-name path)) - (if (ange-ftp-ftp-path path) - (if (ange-ftp-file-entry-p path) - (let ((file-ent (ange-ftp-get-file-entry path))) - (if (stringp file-ent) - (file-exists-p - (ange-ftp-expand-symlink file-ent - (file-name-directory - (directory-file-name path)))) - t))) - (ange-ftp-real-file-exists-p path))) - -(defun ange-ftp-file-directory-p (path) - "Documented as original." - (setq path (expand-file-name path)) - (if (ange-ftp-ftp-path path) - ;; We do a file-name-as-directory on path here because some - ;; machines (VMS) use a .DIR to indicate the filename associated - ;; with a directory. This needs to be canonicalized. - (let ((file-ent (ange-ftp-get-file-entry - (ange-ftp-file-name-as-directory path)))) - (if (stringp file-ent) - (file-directory-p - (ange-ftp-expand-symlink file-ent - (file-name-directory - (directory-file-name path)))) - file-ent)) - (ange-ftp-real-file-directory-p path))) - -(defun ange-ftp-directory-files (directory &optional full match - &rest v19-args) - "Documented as original." - (setq directory (expand-file-name directory)) - (if (ange-ftp-ftp-path directory) - (progn - (ange-ftp-barf-if-not-directory directory) - (let ((tail (ange-ftp-hash-table-keys - (ange-ftp-get-files directory))) - files f) - (setq directory (file-name-as-directory directory)) - (ange-ftp-save-match-data - (while tail - (setq f (car tail) - tail (cdr tail)) - (if (or (not match) (string-match match f)) - (setq files - (cons (if full (concat directory f) f) files))))) - (nreverse files))) - (apply 'ange-ftp-real-directory-files directory full match v19-args))) - -(defun ange-ftp-file-attributes (file) - "Documented as original." - (setq file (expand-file-name file)) - (let ((parsed (ange-ftp-ftp-path file))) - (if parsed - (let ((part (ange-ftp-get-file-part file)) - (files (ange-ftp-get-files (file-name-directory file)))) - (if (ange-ftp-hash-entry-exists-p part files) - (let ((host (nth 0 parsed)) - (user (nth 1 parsed)) - (path (nth 2 parsed)) - (dirp (ange-ftp-get-hash-entry part files))) - (list (if (and (stringp dirp) (file-name-absolute-p dirp)) - (ange-ftp-expand-symlink dirp - (file-name-directory file)) - dirp) ;0 file type - -1 ;1 link count - -1 ;2 uid - -1 ;3 gid - '(0 0) ;4 atime - '(0 0) ;5 mtime - '(0 0) ;6 ctime - -1 ;7 size - (concat (if (stringp dirp) "l" (if dirp "d" "-")) - "?????????") ;8 mode - nil ;9 gid weird - ;; Hack to give remote files a unique "inode number". - ;; It's actually the sum of the characters in its name. - (apply '+ (nconc (mapcar 'identity host) - (mapcar 'identity user) - (mapcar 'identity - (directory-file-name path)))) - -1 ;11 device number [v19 only] - )))) - (ange-ftp-real-file-attributes file)))) - -(defun ange-ftp-file-writable-p (file) - "Documented as original." - (setq file (expand-file-name file)) - (if (ange-ftp-ftp-path file) - (or (file-exists-p file) ;guess here for speed - (file-directory-p (file-name-directory file))) - (ange-ftp-real-file-writable-p file))) - -(defun ange-ftp-file-readable-p (file) - "Documented as original." - (setq file (expand-file-name file)) - (if (ange-ftp-ftp-path file) - (file-exists-p file) - (ange-ftp-real-file-readable-p file))) - -(defun ange-ftp-delete-file (file) - "Documented as original." - (interactive "fDelete file: ") - (setq file (expand-file-name file)) - (let ((parsed (ange-ftp-ftp-path file))) - (if parsed - (let* ((host (nth 0 parsed)) - (user (nth 1 parsed)) - (path (ange-ftp-quote-string (nth 2 parsed))) - (abbr (ange-ftp-abbreviate-filename file)) - (result (ange-ftp-send-cmd host user - (list 'delete path) - (format "Deleting %s" abbr)))) - (or (car result) - (signal 'ftp-error - (list - "Removing old name" - (format "FTP Error: \"%s\"" (cdr result)) - file))) - (ange-ftp-delete-file-entry file)) - (ange-ftp-real-delete-file file)))) - -(defun ange-ftp-verify-visited-file-modtime (buf) - "Documented as original." - (let ((name (buffer-file-name buf))) - (if (and (stringp name) (ange-ftp-ftp-path name)) - t - (ange-ftp-real-verify-visited-file-modtime buf)))) - -(defun ange-ftp-backup-buffer () - "Documented as original." - (let (parsed) - (if (and - (listp ange-ftp-make-backup-files) - (stringp buffer-file-name) - (setq parsed (ange-ftp-ftp-path buffer-file-name)) - (or - (null ange-ftp-make-backup-files) - (not - (memq - (ange-ftp-host-type - (car parsed)) - ange-ftp-make-backup-files)))) - nil - (ange-ftp-real-backup-buffer)))) - -;;;; ------------------------------------------------------------ -;;;; File copying support... totally re-written 6/24/92. -;;;; ------------------------------------------------------------ - -(defun ange-ftp-barf-or-query-if-file-exists (absname querystring interactive) - (if (file-exists-p absname) - (if (not interactive) - (signal 'file-already-exists (list absname)) - (if (not (yes-or-no-p (format "File %s already exists; %s anyway? " - absname querystring))) - (signal 'file-already-exists (list absname)))))) - -;; async local copy commented out for now since I don't seem to get -;; the process sentinel called for some processes. -;; -;; (defun ange-ftp-copy-file-locally (filename newname ok-if-already-exists -;; keep-date cont) -;; "Kludge to copy a local file and call a continuation when the copy -;; finishes." -;; ;; check to see if we can overwrite -;; (if (or (not ok-if-already-exists) -;; (numberp ok-if-already-exists)) -;; (ange-ftp-barf-or-query-if-file-exists newname "copy to it" -;; (numberp ok-if-already-exists))) -;; (let ((proc (start-process " *copy*" -;; (generate-new-buffer "*copy*") -;; "cp" -;; filename -;; newname)) -;; res) -;; (set-process-sentinel proc (function ange-ftp-copy-file-locally-sentinel)) -;; (process-kill-without-query proc) -;; (save-excursion -;; (set-buffer (process-buffer proc)) -;; (make-variable-buffer-local 'copy-cont) -;; (setq copy-cont cont)))) -;; -;; (defun ange-ftp-copy-file-locally-sentinel (proc status) -;; (save-excursion -;; (set-buffer (process-buffer proc)) -;; (let ((cont copy-cont) -;; (result (buffer-string))) -;; (unwind-protect -;; (if (and (string-equal status "finished\n") -;; (zerop (length result))) -;; (ange-ftp-call-cont cont t nil) -;; (ange-ftp-call-cont cont -;; nil -;; (if (zerop (length result)) -;; (substring status 0 -1) -;; (substring result 0 -1)))) -;; (kill-buffer (current-buffer)))))) - -;; this is the extended version of ange-ftp-copy-file-internal that works -;; asyncronously if asked nicely. -(defun ange-ftp-copy-file-internal (filename newname ok-if-already-exists - keep-date &optional msg cont nowait) - (setq filename (expand-file-name filename) - newname (expand-file-name newname)) - - ;; canonicalize newname if a directory. - (if (file-directory-p newname) - (setq newname (expand-file-name (file-name-nondirectory filename) newname))) - - (let ((f-parsed (ange-ftp-ftp-path filename)) - (t-parsed (ange-ftp-ftp-path newname))) - - ;; local file to local file copy? - (if (and (not f-parsed) (not t-parsed)) - (progn - (ange-ftp-real-copy-file filename newname ok-if-already-exists - keep-date) - (if cont - (ange-ftp-call-cont cont t "Copied locally"))) - ;; one or both files are remote. - (let* ((f-host (and f-parsed (nth 0 f-parsed))) - (f-user (and f-parsed (nth 1 f-parsed))) - (f-path (and f-parsed (ange-ftp-quote-string (nth 2 f-parsed)))) - (f-abbr (ange-ftp-abbreviate-filename filename)) - (t-host (and t-parsed (nth 0 t-parsed))) - (t-user (and t-parsed (nth 1 t-parsed))) - (t-path (and t-parsed (ange-ftp-quote-string (nth 2 t-parsed)))) - (t-abbr (ange-ftp-abbreviate-filename newname filename)) - (binary (or (ange-ftp-binary-file filename) - (ange-ftp-binary-file newname))) - temp1 - temp2) - - ;; check to see if we can overwrite - (if (or (not ok-if-already-exists) - (numberp ok-if-already-exists)) - (ange-ftp-barf-or-query-if-file-exists newname "copy to it" - (numberp ok-if-already-exists))) - - ;; do the copying. - (if f-parsed - - ;; filename was remote. - (progn - (if (or (ange-ftp-use-gateway-p f-host) - t-parsed) - ;; have to use intermediate file if we are getting via - ;; gateway machine or we are doing a remote to remote copy. - (setq temp1 (ange-ftp-make-tmp-name f-host))) - - (if binary - (ange-ftp-set-binary-mode f-host f-user)) - - (ange-ftp-send-cmd - f-host - f-user - (list 'get f-path (or temp1 newname)) - (or msg - (if (and temp1 t-parsed) - (format "Getting %s" f-abbr) - (format "Copying %s to %s" f-abbr t-abbr))) - (list (function ange-ftp-cf1) - filename newname binary msg - f-parsed f-host f-user f-path f-abbr - t-parsed t-host t-user t-path t-abbr - temp1 temp2 cont nowait) - nowait)) - - ;; filename wasn't remote. newname must be remote. call the - ;; function which does the remainder of the copying work. - (ange-ftp-cf1 t nil - filename newname binary msg - f-parsed f-host f-user f-path f-abbr - t-parsed t-host t-user t-path t-abbr - nil nil cont nowait)))))) - -;; next part of copying routine. -(defun ange-ftp-cf1 (result line - filename newname binary msg - f-parsed f-host f-user f-path f-abbr - t-parsed t-host t-user t-path t-abbr - temp1 temp2 cont nowait) - (if line - ;; filename must have been remote, and we must have just done a GET. - (unwind-protect - (or result - ;; GET failed for some reason. Clean up and get out. - (progn - (and temp1 (ange-ftp-del-tmp-name temp1)) - (or cont - (signal 'ftp-error (list "Opening input file" - (format "FTP Error: \"%s\"" line) - filename))))) - ;; cleanup - (if binary - (ange-ftp-set-ascii-mode f-host f-user)))) - - (if result - ;; We now have to copy either temp1 or filename to newname. - (if t-parsed - - ;; newname was remote. - (progn - (if (ange-ftp-use-gateway-p t-host) - (setq temp2 (ange-ftp-make-tmp-name t-host))) - - ;; make sure data is moved into the right place for the - ;; outgoing transfer. gateway temporary files complicate - ;; things nicely. - (if temp1 - (if temp2 - (if (string-equal temp1 temp2) - (setq temp1 nil) - (ange-ftp-real-copy-file temp1 temp2 t)) - (setq temp2 temp1 temp1 nil)) - (if temp2 - (ange-ftp-real-copy-file filename temp2 t))) - - (if binary - (ange-ftp-set-binary-mode t-host t-user)) - - ;; tell the process filter what size the file is. - (let ((attr (file-attributes (or temp2 filename)))) - (if attr - (ange-ftp-set-xfer-size t-host t-user (nth 7 attr)))) - - (ange-ftp-send-cmd - t-host - t-user - (list 'put (or temp2 filename) t-path) - (or msg - (if (and temp2 f-parsed) - (format "Putting %s" newname) - (format "Copying %s to %s" f-abbr t-abbr))) - (list (function ange-ftp-cf2) - newname t-host t-user binary temp1 temp2 cont) - nowait)) - - ;; newname wasn't remote. - (ange-ftp-cf2 t nil newname t-host t-user binary temp1 temp2 cont)) - - ;; first copy failed, tell caller - (ange-ftp-call-cont cont result line))) - -;; last part of copying routine. -(defun ange-ftp-cf2 (result line newname t-host t-user binary temp1 temp2 cont) - (unwind-protect - (if line - ;; result from doing a local to remote copy. - (unwind-protect - (progn - (or result - (or cont - (signal 'ftp-error - (list "Opening output file" - (format "FTP Error: \"%s\"" line) - newname)))) - - (ange-ftp-add-file-entry newname)) - - ;; cleanup. - (if binary - (ange-ftp-set-ascii-mode t-host t-user))) - - ;; newname was local. - (if temp1 - (ange-ftp-real-copy-file temp1 newname t))) - - ;; clean up - (and temp1 (ange-ftp-del-tmp-name temp1)) - (and temp2 (ange-ftp-del-tmp-name temp2)) - (ange-ftp-call-cont cont result line))) - -(defun ange-ftp-copy-file (filename newname &optional ok-if-already-exists - keep-date) - "Documented as original." - (interactive "fCopy file: \nFCopy %s to file: \np") - (ange-ftp-copy-file-internal filename - newname - ok-if-already-exists - keep-date - nil - nil - (interactive-p))) - -;;;; ------------------------------------------------------------ -;;;; File renaming support. -;;;; ------------------------------------------------------------ - -(defun ange-ftp-rename-remote-to-remote (filename newname f-parsed t-parsed - binary) - "Rename remote file FILE to remote file NEWNAME." - (let ((f-host (nth 0 f-parsed)) - (f-user (nth 1 f-parsed)) - (t-host (nth 0 t-parsed)) - (t-user (nth 1 t-parsed))) - (if (and (string-equal f-host t-host) - (string-equal f-user t-user)) - (let* ((f-path (ange-ftp-quote-string (nth 2 f-parsed))) - (t-path (ange-ftp-quote-string (nth 2 t-parsed))) - (cmd (list 'rename f-path t-path)) - (fabbr (ange-ftp-abbreviate-filename filename)) - (nabbr (ange-ftp-abbreviate-filename newname filename)) - (result (ange-ftp-send-cmd f-host f-user cmd - (format "Renaming %s to %s" - fabbr - nabbr)))) - (or (car result) - (signal 'ftp-error - (list - "Renaming" - (format "FTP Error: \"%s\"" (cdr result)) - filename - newname))) - (ange-ftp-add-file-entry newname) - (ange-ftp-delete-file-entry filename)) - (ange-ftp-copy-file-internal filename newname t nil) - (delete-file filename)))) - -(defun ange-ftp-rename-local-to-remote (filename newname) - "Rename local FILE to remote file NEWNAME." - (let* ((fabbr (ange-ftp-abbreviate-filename filename)) - (nabbr (ange-ftp-abbreviate-filename newname filename)) - (msg (format "Renaming %s to %s" fabbr nabbr))) - (ange-ftp-copy-file-internal filename newname t nil msg) - (let (ange-ftp-process-verbose) - (delete-file filename)))) - -(defun ange-ftp-rename-remote-to-local (filename newname) - "Rename remote file FILE to local file NEWNAME." - (let* ((fabbr (ange-ftp-abbreviate-filename filename)) - (nabbr (ange-ftp-abbreviate-filename newname filename)) - (msg (format "Renaming %s to %s" fabbr nabbr))) - (ange-ftp-copy-file-internal filename newname t nil msg) - (let (ange-ftp-process-verbose) - (delete-file filename)))) - -(defun ange-ftp-rename-file (filename newname &optional ok-if-already-exists) - "Documented as original." - (interactive "fRename file: \nFRename %s to file: \np") - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) - (let* ((f-parsed (ange-ftp-ftp-path filename)) - (t-parsed (ange-ftp-ftp-path newname)) - (binary (if (or f-parsed t-parsed) (ange-ftp-binary-file filename)))) - (if (and (or f-parsed t-parsed) - (or (not ok-if-already-exists) - (numberp ok-if-already-exists))) - (ange-ftp-barf-or-query-if-file-exists - newname - "rename to it" - (numberp ok-if-already-exists))) - (if f-parsed - (if t-parsed - (ange-ftp-rename-remote-to-remote filename newname f-parsed - t-parsed binary) - (ange-ftp-rename-remote-to-local filename newname)) - (if t-parsed - (ange-ftp-rename-local-to-remote filename newname) - (ange-ftp-real-rename-file filename newname ok-if-already-exists))))) - -;;;; ------------------------------------------------------------ -;;;; Classic Dired support. -;;;; ------------------------------------------------------------ - -(defvar ange-ftp-dired-host-type nil - "The host type associated with a dired buffer. (buffer local)") -(make-variable-buffer-local 'ange-ftp-dired-host-type) - -(defun ange-ftp-dired-readin (dirname buffer) - "Documented as original." - (let ((file (ange-ftp-abbreviate-filename dirname)) - (parsed (ange-ftp-ftp-path dirname))) - (save-excursion - (ange-ftp-message "Reading directory %s..." file) - (set-buffer buffer) - (let ((buffer-read-only nil)) - (widen) - (erase-buffer) - (setq dirname (expand-file-name dirname)) - (if parsed - (let ((host-type (ange-ftp-host-type (car parsed)))) - (setq ange-ftp-dired-host-type host-type) - (insert (ange-ftp-ls dirname dired-listing-switches t))) - (if (ange-ftp-real-file-directory-p dirname) - (call-process "ls" nil buffer nil - dired-listing-switches dirname) - (let ((default-directory - (ange-ftp-real-file-name-directory dirname))) - (call-process - shell-file-name nil buffer nil - "-c" (concat - "ls " dired-listing-switches " " - (ange-ftp-real-file-name-nondirectory dirname)))))) - (goto-char (point-min)) - (while (not (eobp)) - (insert " ") - (forward-line 1)) - (goto-char (point-min)))) - (ange-ftp-message "Reading directory %s...done" file))) - -(defun ange-ftp-dired-revert (&optional arg noconfirm) - "Documented as original." - (if (and dired-directory - (ange-ftp-ftp-path (expand-file-name dired-directory))) - (setq ange-ftp-ls-cache-file nil)) - (ange-ftp-real-dired-revert arg noconfirm)) - -;;;; ------------------------------------------------------------ -;;;; Tree Dired support (ange & Sebastian Kremer) -;;;; ------------------------------------------------------------ - -(defvar ange-ftp-dired-re-exe-alist nil - "Association list of regexps \(strings\) which match file lines of - executable files.") - -(defvar ange-ftp-dired-re-dir-alist nil - "Association list of regexps \(strings\) which match file lines of - subdirectories.") - -(defvar ange-ftp-dired-insert-headerline-alist nil - "Association list of \(TYPE \. FUNC \) pairs, where FUNC is -the function to be used by dired to insert the headerline of -the dired buffer.") - -(defvar ange-ftp-dired-move-to-filename-alist nil - "Association list of \(TYPE \. FUNC \) pairs, where FUNC is -the function to be used by dired to move to the beginning of a -filename.") - -(defvar ange-ftp-dired-move-to-end-of-filename-alist nil - "Association list of \(TYPE \. FUNC \) pairs, where FUNC is -the function to be used by dired to move to the end of a -filename.") - -(defvar ange-ftp-dired-get-filename-alist nil - "Association list of \(TYPE \. FUNC \) pairs, where FUNC is -the function to be used by dired to get a filename from the -current line.") - -(defvar ange-ftp-dired-between-files-alist nil - "Association list of \(TYPE \. FUNC \) pairs, where FUNC is -the function to be used by dired to determine when the point -is on a line between files.") - -(defvar ange-ftp-dired-ls-trim-alist nil - "Association list of \( TYPE \. FUNC \) pairs, where FUNC is -a function which trims extraneous lines from a directory listing.") - -(defvar ange-ftp-dired-clean-directory-alist nil - "Association list of \( TYPE \. FUNC \) pairs, where FUNC is -a function which cleans out old versions of files in the OS TYPE.") - -(defvar ange-ftp-dired-flag-backup-files-alist nil - "Association list of \( TYPE \. FUNC \) pairs, where FUNC is -a functions which flags the backup files for deletion in the OS TYPE.") - -(defvar ange-ftp-dired-backup-diff-alist nil - "Association list of \( TYPE \. FUNC \) pairs, where FUNC diffs -a file with its backup. The backup file is determined according to -the OS TYPE.") - -;; Could use dired-before-readin-hook here, instead of overloading -;; dired-readin. However, if people change this hook after ange-ftp -;; is loaded, they'll break things. -;; Also, why overload dired-readin rather than dired-mode? -;; Because I don't want to muck up virtual dired (see dired-x.el). - -(defun ange-ftp-tree-dired-readin (dirname buffer) - "Documented as original." - (let ((parsed (ange-ftp-ftp-path dirname))) - (if parsed - (save-excursion - (set-buffer buffer) - (setq ange-ftp-dired-host-type - (ange-ftp-host-type (car parsed))) - (and ange-ftp-dl-dir-regexp - (eq ange-ftp-dired-host-type 'unix) - (string-match ange-ftp-dl-dir-regexp dirname) - (setq ange-ftp-dired-host-type 'unix:dl)) - (let ((eentry (assq ange-ftp-dired-host-type - ange-ftp-dired-re-exe-alist)) - (dentry (assq ange-ftp-dired-host-type - ange-ftp-dired-re-dir-alist))) - (if eentry - (set (make-local-variable 'dired-re-exe) (cdr eentry))) - (if dentry - (set (make-local-variable 'dired-re-dir) (cdr dentry))) - ;; No switches are sent to dumb hosts, so don't confuse dired. - ;; I hope that dired doesn't get excited if it doesn't see the l - ;; switch. If it does, then maybe fake things by setting this to - ;; "-Al". - (if (memq ange-ftp-dired-host-type ange-ftp-dumb-host-types) - (setq dired-actual-switches "-Al")))))) - (ange-ftp-real-dired-readin dirname buffer)) - -(defun ange-ftp-dired-insert-headerline (dir) - "Documented as original." - (funcall (or (and ange-ftp-dired-host-type - (cdr (assq ange-ftp-dired-host-type - ange-ftp-dired-insert-headerline-alist))) - 'ange-ftp-real-dired-insert-headerline) - dir)) - -(defun ange-ftp-dired-move-to-filename (&optional raise-error eol) - "Documented as original." - (funcall (or (and ange-ftp-dired-host-type - (cdr (assq ange-ftp-dired-host-type - ange-ftp-dired-move-to-filename-alist))) - 'ange-ftp-real-dired-move-to-filename) - raise-error eol)) - -(defun ange-ftp-dired-move-to-end-of-filename (&optional no-error) - "Documented as original." - (funcall (or (and ange-ftp-dired-host-type - (cdr (assq ange-ftp-dired-host-type - ange-ftp-dired-move-to-end-of-filename-alist))) - 'ange-ftp-real-dired-move-to-end-of-filename) - no-error)) - -(defun ange-ftp-dired-get-filename (&optional localp no-error-if-not-filep) - "Documented as original." - (funcall (or (and ange-ftp-dired-host-type - (cdr (assq ange-ftp-dired-host-type - ange-ftp-dired-get-filename-alist))) - 'ange-ftp-real-dired-get-filename) - localp no-error-if-not-filep)) - -(defun ange-ftp-dired-between-files () - "Documented as original." - (funcall (or (and ange-ftp-dired-host-type - (cdr (assq ange-ftp-dired-host-type - ange-ftp-dired-between-files-alist))) - 'ange-ftp-real-dired-between-files))) - -(defvar ange-ftp-bob-version-alist nil - "Association list of pairs \( TYPE \. FUNC \), where FUNC is -a function to be used to bob the version number off of a filename -in OS TYPE.") - -(defun ange-ftp-dired-find-file () - "Documented as original." - (interactive) - (find-file (funcall (or (and ange-ftp-dired-host-type - (cdr (assq ange-ftp-dired-host-type - ange-ftp-bob-version-alist))) - 'identity) - (dired-get-filename)))) - -;; Need the following functions for making filenames of compressed -;; files, because some OS's (unlike UNIX) do not allow a filename to -;; have two extensions. - -(defvar ange-ftp-dired-compress-make-compressed-filename-alist nil - "Association list of \( TYPE \. FUNC \) pairs, where FUNC converts a -filename to the filename of the associated compressed file.") - -;;; this overwrites dired's `dired-compress-make-compressed-filename' -(defun ange-ftp-dired-compress-make-compressed-filename (name &optional reverse) - "Converts a filename to the filename of the associated compressed -file. With an optional reverse argument, the reverse conversion is done. - -Modified to work with gzip (GNU zip) files." - (let ((parsed (ange-ftp-ftp-path name)) - conversion-func) - (if (and parsed - (setq conversion-func - (cdr (assq (ange-ftp-host-type (car parsed)) - ange-ftp-dired-compress-make-compressed-filename-alist)))) - (funcall conversion-func name reverse) - (if reverse - - ;; uncompress... - ;; return `nil' if no match found -- better than nothing - (let (case-fold-search ; case-sensitive search - (string - (concat "\\.\\(g?z\\|" (regexp-quote dired-gzip-file-extension) - "$\\|Z\\)$"))) - - (and (string-match string name) - (substring name 0 (match-beginning 0)))) - - ;; add appropriate extension - ;; note: it could be that `gz' is not the proper extension for gzip - (concat name - (if dired-use-gzip-instead-of-compress - dired-gzip-file-extension ".Z")))))) - -(defun ange-ftp-dired-clean-directory (keep) - "Documented as original." - (interactive "P") - (funcall (or (and ange-ftp-dired-host-type - (cdr (assq ange-ftp-dired-host-type - ange-ftp-dired-clean-directory-alist))) - 'ange-ftp-real-dired-clean-directory) - keep)) - -(defun ange-ftp-dired-backup-diff (&optional switches) - "Documented as original." - (interactive (list (if (fboundp 'diff-read-switches) - (diff-read-switches "Diff with switches: ")))) - (funcall (or (and ange-ftp-dired-host-type - (cdr (assq ange-ftp-dired-host-type - ange-ftp-dired-backup-diff-alist))) - 'ange-ftp-real-dired-backup-diff) - switches)) - - -(defun ange-ftp-dired-fixup-subdirs (start file) - "Turn each subdir name into a valid ange-ftp filename." - - ;; We haven't indented the listing yet. - ;; Must be careful about filelines ending in a colon: exclude spaces! - (let ((subdir-regexp "^\\([^ \n\r]+\\)\\(:\\)[\n\r]")) - (save-restriction - (save-excursion - (narrow-to-region start (point)) - (goto-char start) - (while (re-search-forward subdir-regexp nil t) - (goto-char (match-beginning 1)) - (let ((name (buffer-substring (point) - (match-end 1)))) - (delete-region (point) (match-end 1)) - (insert (ange-ftp-replace-path-component - file - name)))))))) - -(defun ange-ftp-dired-ls (file switches &optional wildcard full-directory-p) - "Documented as original." - (let ((parsed (ange-ftp-ftp-path file))) - (if parsed - (let* ((pt (point)) - (path (nth 2 parsed)) - (host-type (ange-ftp-host-type (car parsed))) - (dumb (memq host-type ange-ftp-dumb-host-types)) - trim-func case-fold-search) - ;; Make sure that case-fold-search is nil - ;; so that we can look at the switches. - (if wildcard - (if (not (memq host-type '(unix dumb-unix))) - (insert (ange-ftp-ls file switches nil)) - ;; Prevent ls from inserting subdirs, as the subdir header - ;; line format would be wrong (it would have no "/user@host:" - ;; prefix) - (insert (ange-ftp-ls file (concat switches "d") nil)) - - ;; Quoting the path part of the file name seems to be a good - ;; idea (using dired.el's shell-quote function), but ftpd - ;; always globs ls args before passing them to /bin/ls or even - ;; doing the ls formatting itself. --> So wildcard characters - ;; in FILE lose. Sigh... - - ;; When using wildcards, some ftpd's put the whole directory - ;; name in front of each filename. Walk down the listing - ;; generated and remove this stuff. - (let ((dir (ange-ftp-real-file-name-directory path))) - (if dir - (let ((dirq (regexp-quote dir))) - (save-restriction - (save-excursion - (narrow-to-region pt (point)) - (goto-char pt) - (while (not (eobp)) - (if (dired-move-to-filename) - (if (re-search-forward dirq nil t) - (replace-match ""))) - (forward-line 1)))))))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; Big issue here Andy! ;; - ;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; In tree dired V5.245 Sebastian has used the following - ;; trick to resolve symbolic links to directories. This causes - ;; havoc with ange-ftp, because ange-ftp expands dots, with - ;; expand-file-name before it sends them. This means that this - ;; trick currently fails for remote SysV machines. But worse, - ;; /vms:/DEV:/FOO/. expands to /vms:/DEV:/FOO, which converts - ;; to DEV:FOO and not DEV:[FOO]. i.e it is only in UNIX that - ;; we can play fast and loose with the difference between - ;; directory names and their associated filenames. - ;; My temporary fix is to knock Sebastian's dot off. - ;; Maybe things can be made real clever in - ;; the future, so that Sebastian can have his way with remote - ;; SysV machines. - ;; Sebastian in dired-readin-insert says: - - ;; On SysV derived system, symbolic links to - ;; directories are not resolved, while on BSD - ;; derived it suffices to let DIRNAME end in slash. - ;; We always let it end in "/." since it does no - ;; harm on BSD and makes Dired work on such links on - ;; SysV. - - (if (string-match "/\\.$" path) - (setq - file - (ange-ftp-replace-path-component - file (substring path 0 -1)))) - (if (string-match "R" switches) - (progn - (insert (ange-ftp-ls file switches nil)) - ;; fix up the subdirectory names in the recursive - ;; listing. - (ange-ftp-dired-fixup-subdirs pt file)) - (insert - (ange-ftp-ls file - switches - (and (or dumb (string-match "[aA]" switches)) - full-directory-p)))) - (if (and (null full-directory-p) - (setq trim-func - (cdr (assq host-type - ange-ftp-dired-ls-trim-alist)))) - ;; If full-directory-p and wild-card are null, then only one - ;; line per file must be inserted. - ;; Some OS's (like VMS) insert other crap. Clean it out. - (save-restriction - (narrow-to-region pt (point)) - (funcall trim-func))))) - (ange-ftp-real-dired-ls file switches wildcard full-directory-p)))) - -(defvar ange-ftp-remote-shell-file-name - (if (memq system-type '(hpux usg-unix-v)) ; hope that's right - "remsh" - "rsh") - "Remote shell used by ange-ftp.") - -(defun ange-ftp-dired-run-shell-command (command &optional in-background) - "Documented as original." - (let* ((parsed (ange-ftp-ftp-path default-directory)) - (host (nth 0 parsed)) - (user (nth 1 parsed)) - (path (nth 2 parsed))) - (if (not parsed) - (ange-ftp-real-dired-run-shell-command command in-background) - (if (> (length path) 0) ; else it's $HOME - (setq command (concat "cd " path "; " command))) - (setq command - (format "%s %s \"%s\"" ; remsh -l USER does not work well - ; on a hp-ux machine I tried - ange-ftp-remote-shell-file-name host command)) - (ange-ftp-message "Remote command '%s' ..." command) - ;; Cannot call ange-ftp-real-dired-run-shell-command here as it - ;; would prepend "cd default-directory" --- which bombs because - ;; default-directory is in ange-ftp syntax for remote path names. - (if in-background - (comint::background command) - (shell-command command))))) - -(defun ange-ftp-make-directory (dir &optional parents) - "Documented as original." - (interactive (list (let ((current-prefix-arg current-prefix-arg)) - (read-directory-name "Create directory: ")) - current-prefix-arg)) - (if (file-exists-p dir) - (error "Cannot make directory %s: file already exists" dir) - (let ((parsed (ange-ftp-ftp-path dir))) - (if parsed - (let* ((host (nth 0 parsed)) - (user (nth 1 parsed)) - ;; Some ftp's on unix machines (at least on Suns) - ;; insist that mkdir take a filename, and not a - ;; directory-name name as an arg. Argh!! This is a bug. - ;; Non-unix machines will probably always insist - ;; that mkdir takes a directory-name as an arg - ;; (as the ftp man page says it should). - (path (ange-ftp-quote-string - (if (eq (ange-ftp-host-type host) 'unix) - (ange-ftp-real-directory-file-name (nth 2 parsed)) - (ange-ftp-real-file-name-as-directory - (nth 2 parsed))))) - (abbr (ange-ftp-abbreviate-filename dir)) - (result (ange-ftp-send-cmd host user - (list 'mkdir path) - (format "Making directory %s" - abbr)))) - (or (car result) - (ange-ftp-error host user - (format "Could not make directory %s: %s" - dir - (cdr result)))) - (ange-ftp-add-file-entry dir t)) - (ange-ftp-real-make-directory dir parents))))) - -(defun ange-ftp-remove-directory (dir) - "Documented as original." - (interactive - (list (expand-file-name (read-file-name "Remove directory: " - nil nil 'confirm)))) - (if (file-directory-p dir) - (let ((parsed (ange-ftp-ftp-path dir))) - (if parsed - (let* ((host (nth 0 parsed)) - (user (nth 1 parsed)) - ;; Some ftp's on unix machines (at least on Suns) - ;; insist that rmdir take a filename, and not a - ;; directory-name name as an arg. Argh!! This is a bug. - ;; Non-unix machines will probably always insist - ;; that rmdir takes a directory-name as an arg - ;; (as the ftp man page says it should). - (path (ange-ftp-quote-string - (if (eq (ange-ftp-host-type host) 'unix) - (ange-ftp-real-directory-file-name - (nth 2 parsed)) - (ange-ftp-real-file-name-as-directory - (nth 2 parsed))))) - (abbr (ange-ftp-abbreviate-filename dir)) - (result (ange-ftp-send-cmd host user - (list 'rmdir path) - (format "Removing directory %s" - abbr)))) - (or (car result) - (ange-ftp-error host user - (format "Could not remove directory %s: %s" - dir - (cdr result)))) - (ange-ftp-delete-file-entry dir t)) - (ange-ftp-real-remove-directory dir))) - (error "Not a directory: %s" dir))) - -;; XEmacs change: This function isn't in the FSF version. Maybe -;; because there is no such function as diff-read-args. I can't find -;; where there ever _has_ been such a function. If you want this -;; functionality, write diff-read-args and uncomment this. - -;;(defun ange-ftp-diff (fn1 fn2 &optional switches) -;; "Documented as original." -;; (interactive (diff-read-args "Diff: " "Diff %s with: " -;; "Diff with switches: ")) -;; (or (and (stringp fn1) -;; (stringp fn2)) -;; (error "diff: arguments must be strings: %s %s" fn1 fn2)) -;; (or switches -;; (setq switches (if (stringp diff-switches) -;; diff-switches -;; (if (listp diff-switches) -;; (mapconcat 'identity diff-switches " ") -;; "")))) -;; (let* ((fn1 (expand-file-name fn1)) -;; (fn2 (expand-file-name fn2)) -;; (pa1 (ange-ftp-ftp-path fn1)) -;; (pa2 (ange-ftp-ftp-path fn2))) -;; (if (or pa1 pa2) -;; (let* ((tmp1 (and pa1 (ange-ftp-make-tmp-name (car pa1)))) -;; (tmp2 (and pa2 (ange-ftp-make-tmp-name (car pa2)))) -;; (bin1 (and pa1 (ange-ftp-binary-file fn1))) -;; (bin2 (and pa2 (ange-ftp-binary-file fn2))) -;; (dir1 (file-directory-p fn1)) -;; (dir2 (file-directory-p fn2)) -;; (old-dir default-directory) -;; (default-directory "/tmp")) ;fool FTP-smart compile.el -;; (unwind-protect -;; (progn -;; (if (and dir1 dir2) -;; (error "can't compare remote directories")) -;; (if dir1 -;; (setq fn1 (expand-file-name (file-name-nondirectory fn2) -;; fn1) -;; pa1 (ange-ftp-ftp-path fn1) -;; bin1 (ange-ftp-binary-file fn1))) -;; (if dir2 -;; (setq fn2 (expand-file-name (file-name-nondirectory fn1) -;; fn2) -;; pa2 (ange-ftp-ftp-path fn2) -;; bin2 (ange-ftp-binary-file fn2))) -;; (and pa1 (ange-ftp-copy-file-internal fn1 tmp1 t nil -;; (format "Getting %s" fn1))) -;; (and pa2 (ange-ftp-copy-file-internal fn2 tmp2 t nil -;; (format "Getting %s" fn2))) -;; (and ange-ftp-process-verbose -;; (ange-ftp-message "doing diff...")) -;; (sit-for 0) -;; (ange-ftp-real-diff (or tmp1 fn1) (or tmp2 fn2) switches) -;; (cond ((boundp 'compilation-process) -;; (while (and compilation-process -;; (eq (process-status compilation-process) -;; 'run)) -;; (accept-process-output compilation-process))) -;; ((boundp 'compilation-last-buffer) -;; (while (and compilation-last-buffer -;; (buffer-name compilation-last-buffer) -;; (get-buffer-process -;; compilation-last-buffer) -;; (eq (process-status -;; (get-buffer-process -;; compilation-last-buffer)) -;; 'run)) -;; (accept-process-output)))) -;; (and ange-ftp-process-verbose -;; (ange-ftp-message "doing diff...done")) -;; (save-excursion -;; (set-buffer (get-buffer-create "*compilation*")) -;; -;; ;; replace the default directory that we munged earlier. -;; (goto-char (point-min)) -;; (if (search-forward (concat "cd " default-directory) nil t) -;; (replace-match (concat "cd " old-dir))) -;; (setq default-directory old-dir) -;; -;; ;; massage the diff output, replacing the temporary file- -;; ;; names with their original names. -;; (if tmp1 -;; (let ((q1 (shell-quote tmp1))) -;; (goto-char (point-min)) -;; (while (search-forward q1 nil t) -;; (replace-match fn1)))) -;; (if tmp2 -;; (let ((q2 (shell-quote tmp2))) -;; (goto-char (point-min)) -;; (while (search-forward q2 nil t) -;; (replace-match fn2)))))) -;; (and tmp1 (ange-ftp-del-tmp-name tmp1)) -;; (and tmp2 (ange-ftp-del-tmp-name tmp2)))) -;; (ange-ftp-real-diff fn1 fn2 switches)))) - -(defun ange-ftp-dired-call-process (program discard &rest arguments) - "Documented as original." - ;; PROGRAM is always one of those below in the cond in dired.el. - ;; The ARGUMENTS are (nearly) always files. - (if (ange-ftp-ftp-path default-directory) - ;; Can't use ange-ftp-dired-host-type here because the current - ;; buffer is *dired-check-process output* - (condition-case oops - (cond ((equal "compress" program) - (ange-ftp-call-compress arguments)) - ((equal "uncompress" program) - (ange-ftp-call-uncompress arguments)) - ((equal "chmod" program) - (ange-ftp-call-chmod arguments)) - ;; ((equal "chgrp" program)) - ;; ((equal dired-chown-program program)) - (t (error "Unknown remote command: %s" program))) - (ftp-error (insert (format "%s: %s, %s\n" - (nth 1 oops) - (nth 2 oops) - (nth 3 oops)))) - (error (insert (format "%s\n" (nth 1 oops))))) - (apply 'call-process program nil (not discard) nil arguments))) - - -(defun ange-ftp-call-compress (args) - "Perform a compress command on a remote file. -Works by taking a copy of the file, compressing it and copying the file -back." - (if (or (not (= (length args) 2)) - (not (string-equal "-f" (car args)))) - (error - "ange-ftp-call-compress: missing -f flag and/or missing filename: %s" - args)) - (let* ((file (nth 1 args)) - (parsed (ange-ftp-ftp-path file)) - (tmp1 (ange-ftp-make-tmp-name (car parsed))) - (tmp2 (ange-ftp-make-tmp-name (car parsed))) - (abbr (ange-ftp-abbreviate-filename file)) - (nfile (ange-ftp-dired-compress-make-compressed-filename file)) - (nabbr (ange-ftp-abbreviate-filename nfile)) - (msg1 (format "Getting %s" abbr)) - (msg2 (format "Putting %s" nabbr))) - (unwind-protect - (progn - (ange-ftp-copy-file-internal file tmp1 t nil msg1) - (and ange-ftp-process-verbose - (ange-ftp-message "Compressing %s..." abbr)) - (call-process-region (point) - (point) - shell-file-name - nil - t - nil - "-c" - (format "compress -f -c < %s > %s" tmp1 tmp2)) - (and ange-ftp-process-verbose - (ange-ftp-message "Compressing %s...done" abbr)) - (if (zerop (buffer-size)) - (progn - (let (ange-ftp-process-verbose) - (delete-file file)) - (ange-ftp-copy-file-internal tmp2 nfile t nil msg2)))) - (ange-ftp-del-tmp-name tmp1) - (ange-ftp-del-tmp-name tmp2)))) - -(defun ange-ftp-call-uncompress (args) - "Perform an uncompress command on a remote file. -Works by taking a copy of the file, uncompressing it and copying the file -back." - (if (not (= (length args) 1)) - (error "ange-ftp-call-uncompress: missing filename: %s" args)) - (let* ((file (car args)) - (parsed (ange-ftp-ftp-path file)) - (tmp1 (ange-ftp-make-tmp-name (car parsed))) - (tmp2 (ange-ftp-make-tmp-name (car parsed))) - (abbr (ange-ftp-abbreviate-filename file)) - (nfile (ange-ftp-dired-compress-make-compressed-filename file 'reverse)) - (nabbr (ange-ftp-abbreviate-filename nfile)) - (msg1 (format "Getting %s" abbr)) - (msg2 (format "Putting %s" nabbr)) -;; ;; Cheap hack because of problems with binary file transfers from -;; ;; VMS hosts. -;; (gbinary (not (eq 'vms (ange-ftp-host-type (car parsed))))) - ) - (unwind-protect - (progn - (ange-ftp-copy-file-internal file tmp1 t nil msg1) - (and ange-ftp-process-verbose - (ange-ftp-message "Uncompressing %s..." abbr)) - (call-process-region (point) - (point) - shell-file-name - nil - t - nil - "-c" - (format "uncompress -c < %s > %s" tmp1 tmp2)) - (and ange-ftp-process-verbose - (ange-ftp-message "Uncompressing %s...done" abbr)) - (if (zerop (buffer-size)) - (progn - (let (ange-ftp-process-verbose) - (delete-file file)) - (ange-ftp-copy-file-internal tmp2 nfile t nil msg2)))) - (ange-ftp-del-tmp-name tmp1) - (ange-ftp-del-tmp-name tmp2)))) - -(defvar ange-ftp-remote-shell "rsh" - "Remote shell to use for chmod, if FTP server rejects the `chmod' command.") - -(defun ange-ftp-call-chmod (args) - (if (< (length args) 2) - (error "ange-ftp-call-chmod: missing mode and/or filename: %s" args)) - (let ((mode (car args))) - (mapcar - (function - (lambda (file) - (setq file (expand-file-name file)) - (let ((parsed (ange-ftp-ftp-path file))) - (if parsed - (let* ((host (nth 0 parsed)) - (user (nth 1 parsed)) - (path (ange-ftp-quote-string (nth 2 parsed))) - (abbr (ange-ftp-abbreviate-filename file)) - (result (ange-ftp-send-cmd host user - (list 'chmod mode path) - (format "doing chmod %s" - abbr)))) - (or (car result) - ;; if FTP server rejects chmod, try rsh chmod instead - (call-process - ange-ftp-remote-shell - nil t nil host "chmod" mode path))))))) - (cdr args))) - (setq ange-ftp-ls-cache-file nil)) ;stop confusing dired - -;; Need to abstract the way dired computes the names of compressed files. -;; I feel badly about these two overloads. - -(defun ange-ftp-dired-compress () - ;; Compress current file. Return nil for success, offending filename else. - (let* (buffer-read-only - (from-file (dired-get-filename)) - (to-file (ange-ftp-dired-compress-make-compressed-filename from-file))) - (cond ((save-excursion (beginning-of-line) - (looking-at dired-re-sym)) - (dired-log (concat "Attempt to compress a symbolic link:\n" - from-file)) - (dired-make-relative from-file)) - ((dired-check-process (concat "Compressing " from-file) - "compress" "-f" from-file) - ;; errors from the process are already logged by - ;; dired-check-process - (dired-make-relative from-file)) - (t - (dired-update-file-line to-file) - nil)))) - -(defun ange-ftp-dired-uncompress () - ;; Uncompress current file. Return nil for success, - ;; offending filename else. - (let* (buffer-read-only - (from-file (dired-get-filename)) - (to-file (ange-ftp-dired-compress-make-compressed-filename from-file 'reverse))) - (if (dired-check-process (concat "Uncompressing " from-file) - "uncompress" from-file) - (dired-make-relative from-file) - (dired-update-file-line to-file) - nil))) - -(defun ange-ftp-dired-flag-backup-files (&optional unflag-p) - "Documented as original." - (interactive "P") - (funcall (or (and ange-ftp-dired-host-type - (cdr (assq ange-ftp-dired-host-type - ange-ftp-dired-flag-backup-files-alist))) - 'ange-ftp-real-dired-flag-backup-files) - unflag-p)) - -;;; ------------------------------------------------------------ -;;; Noddy support for async copy-file within dired. -;;; ------------------------------------------------------------ - -(defun ange-ftp-dired-copy-file (from to ok-flag &optional cont nowait) - "Documented as original." - (dired-handle-overwrite to) - (ange-ftp-copy-file-internal from to ok-flag dired-copy-preserve-time nil - cont nowait)) - -(defun ange-ftp-dired-do-create-files (op-symbol file-creator operation arg - &optional marker-char op1 - how-to) - "Documented as original." - ;; we need to let ange-ftp-dired-create-files know that we indirectly - ;; called it rather than somebody else. - (let ((ange-ftp-dired-do-create-files t)) ; tell who caller is - (ange-ftp-real-dired-do-create-files op-symbol file-creator operation - arg marker-char op1 how-to))) - -(defun ange-ftp-dired-create-files (file-creator operation fn-list name-constructor - &optional marker-char) - "Documented as original." - (if (and (boundp 'ange-ftp-dired-do-create-files) - ;; called from ange-ftp-dired-do-create-files? - ange-ftp-dired-do-create-files - ;; any files worth copying? - fn-list - ;; we only support async copy-file at the mo. - (eq file-creator 'dired-copy-file) - ;; it is only worth calling the alternative function for remote files - ;; as we tie ourself in recursive knots otherwise. - (or (ange-ftp-ftp-path (car fn-list)) - ;; we can only call the name constructor for dired-do-create-files - ;; since the one for regexps starts prompting here, there and - ;; everywhere. - (ange-ftp-ftp-path (funcall name-constructor (car fn-list))))) - ;; use the process-filter driven routine rather than the iterative one. - (ange-ftp-dcf-1 file-creator - operation - fn-list - name-constructor - (and (boundp 'target) target) ;dynamically bound - marker-char - (current-buffer) - nil ;overwrite-query - nil ;overwrite-backup-query - nil ;failures - nil ;skipped - 0 ;success-count - (length fn-list) ;total - ) - ;; normal case... use the interative routine... much cheaper. - (ange-ftp-real-dired-create-files file-creator operation fn-list - name-constructor marker-char))) - -(defun ange-ftp-dcf-1 (file-creator operation fn-list name-constructor - target marker-char buffer overwrite-query - overwrite-backup-query failures skipped - success-count total) - (let ((old-buf (current-buffer))) - (unwind-protect - (progn - (set-buffer buffer) - (if (null fn-list) - (ange-ftp-dcf-3 failures operation total skipped - success-count buffer) - - (let* ((from (car fn-list)) - (to (funcall name-constructor from))) - (if (equal to from) - (progn - (setq to nil) - (dired-log "Cannot %s to same file: %s\n" - (downcase operation) from))) - (if (not to) - (ange-ftp-dcf-1 file-creator - operation - (cdr fn-list) - name-constructor - target - marker-char - buffer - overwrite-query - overwrite-backup-query - failures - (cons (dired-make-relative from) skipped) - success-count - total) - (let* ((overwrite (file-exists-p to)) - (overwrite-confirmed ; for dired-handle-overwrite - (and overwrite - (let ((help-form '(format "\ -Type SPC or `y' to overwrite file `%s', -DEL or `n' to skip to next, -ESC or `q' to not overwrite any of the remaining files, -`!' to overwrite all remaining files with no more questions." to))) - (dired-query 'overwrite-query - "Overwrite `%s'?" to)))) - ;; must determine if FROM is marked before file-creator - ;; gets a chance to delete it (in case of a move). - (actual-marker-char - (cond ((integerp marker-char) marker-char) - (marker-char (dired-file-marker from)) ; slow - (t nil)))) - (condition-case err - (funcall file-creator from to overwrite-confirmed - (list (function ange-ftp-dcf-2) - nil ;err - file-creator operation fn-list - name-constructor - target - marker-char actual-marker-char - buffer to from - overwrite - overwrite-confirmed - overwrite-query - overwrite-backup-query - failures skipped success-count - total) - t) - (file-error ; FILE-CREATOR aborted - (ange-ftp-dcf-2 nil ;result - nil ;line - err - file-creator operation fn-list - name-constructor - target - marker-char actual-marker-char - buffer to from - overwrite - overwrite-confirmed - overwrite-query - overwrite-backup-query - failures skipped success-count - total)))))))) - (set-buffer old-buf)))) - -(defun ange-ftp-dcf-2 (result line err - file-creator operation fn-list - name-constructor - target - marker-char actual-marker-char - buffer to from - overwrite - overwrite-confirmed - overwrite-query - overwrite-backup-query - failures skipped success-count - total) - (let ((old-buf (current-buffer))) - (unwind-protect - (progn - (set-buffer buffer) - (if (or err (not result)) - (progn - (setq failures (cons (dired-make-relative from) failures)) - (dired-log "%s `%s' to `%s' failed:\n%s\n" - operation from to (or err line))) - (if overwrite - ;; If we get here, file-creator hasn't been aborted - ;; and the old entry (if any) has to be deleted - ;; before adding the new entry. - (dired-remove-file to)) - (setq success-count (1+ success-count)) - (message "%s: %d of %d" operation success-count total) - (dired-add-file to actual-marker-char)) - - (ange-ftp-dcf-1 file-creator operation (cdr fn-list) - name-constructor - target - marker-char - buffer - overwrite-query - overwrite-backup-query - failures skipped success-count - total)) - (set-buffer old-buf)))) - -(defun ange-ftp-dcf-3 (failures operation total skipped success-count - buffer) - (let ((old-buf (current-buffer))) - (unwind-protect - (progn - (set-buffer buffer) - (cond - (failures - (dired-log-summary - (message "%s failed for %d of %d file%s %s" - operation (length failures) total - (dired-plural-s total) failures))) - (skipped - (dired-log-summary - (message "%s: %d of %d file%s skipped %s" - operation (length skipped) total - (dired-plural-s total) skipped))) - (t - (message "%s: %s file%s." - operation success-count (dired-plural-s success-count)))) - (dired-move-to-filename)) - (set-buffer old-buf)))) - -;;;; ----------------------------------------------- -;;;; Unix Descriptive Listing (dl) Support -;;;; ----------------------------------------------- - -(defconst ange-ftp-dired-dl-re-dir - "^. [^ /]+/[ \n]" - "Regular expression to use to search for dl directories.") - -(or (assq 'unix:dl ange-ftp-dired-re-dir-alist) - (setq ange-ftp-dired-re-dir-alist - (cons (cons 'unix:dl ange-ftp-dired-dl-re-dir) - ange-ftp-dired-re-dir-alist))) - -(defun ange-ftp-dired-dl-move-to-filename (&optional raise-error eol) - "In dired, move to the first character of the filename on this line." - ;; This is the Unix dl version. - (or eol (setq eol (progn (end-of-line) (point)))) - (let (case-fold-search) - (beginning-of-line) - (if (looking-at ". [^ ]+ +\\([0-9]+\\|-\\|=\\) ") - (goto-char (+ (point) 2)) - (if raise-error - (error "No file on this line") - nil)))) - -(or (assq 'unix:dl ange-ftp-dired-move-to-filename-alist) - (setq ange-ftp-dired-move-to-filename-alist - (cons '(unix:dl . ange-ftp-dired-dl-move-to-filename) - ange-ftp-dired-move-to-filename-alist))) - -(defun ange-ftp-dired-dl-move-to-end-of-filename (&optional no-error eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; On failure, signals an error or returns nil. - ;; This is the Unix dl version. - (let ((opoint (point)) - case-fold-search hidden) - (or eol (setq eol (save-excursion (end-of-line) (point)))) - (setq hidden (and selective-display - (save-excursion - (search-forward "\r" eol t)))) - (if hidden - (if no-error - nil - (error - (substitute-command-keys - "File line is hidden, type \\[dired-hide-subdir] to unhide"))) - (skip-chars-forward "^ /" eol) - (if (eq opoint (point)) - (if no-error - nil - (error "No file on this line")) - (point))))) - -(or (assq 'unix:dl ange-ftp-dired-move-to-end-of-filename-alist) - (setq ange-ftp-dired-move-to-end-of-filename-alist - (cons '(unix:dl . ange-ftp-dired-dl-move-to-end-of-filename) - ange-ftp-dired-move-to-end-of-filename-alist))) - -;;;; ------------------------------------------------------------ -;;;; File name completion support. -;;;; ------------------------------------------------------------ - -(defun ange-ftp-file-entry-active-p (sym) - "If the file entry is a symlink, returns whether the file pointed to exists. -Note that DIR is dynamically bound." - (let ((val (get sym 'val))) - (or (not (stringp val)) - (file-exists-p (ange-ftp-expand-symlink val dir))))) - -(defun ange-ftp-file-entry-not-ignored-p (sym) - "If the file entry is not a directory (nor a symlink pointing to a directory) -returns whether the file (or file pointed to by the symlink) is ignored -by completion-ignored-extensions. -Note that DIR and COMPLETION-IGNORED-PATTERN are dynamically bound." - (let ((val (get sym 'val)) - (symname (symbol-name sym))) - (if (stringp val) - (let ((file (ange-ftp-expand-symlink val dir))) - (or (file-directory-p file) - (and (file-exists-p file) - (not (string-match completion-ignored-pattern - symname))))) - (or val ; is a directory name - (not (string-match completion-ignored-pattern symname)))))) - -(defun ange-ftp-file-name-all-completions (file dir) - "Documented as original." - (setq dir (expand-file-name dir)) - (if (ange-ftp-ftp-path dir) - (progn - (ange-ftp-barf-if-not-directory dir) - (setq dir (ange-ftp-real-file-name-as-directory dir)) - (let* ((tbl (ange-ftp-get-files dir)) - (completions - (all-completions file tbl - (function ange-ftp-file-entry-active-p)))) - - ;; see whether each matching file is a directory or not... - (mapcar - (function - (lambda (file) - (let ((ent (ange-ftp-get-hash-entry file tbl))) - (if (and ent - (or (not (stringp ent)) - (file-directory-p - (ange-ftp-expand-symlink ent dir)))) - (concat file "/") - file)))) - completions))) - - (if (string-equal "/" dir) - (nconc (all-completions file (ange-ftp-generate-root-prefixes)) - (ange-ftp-real-file-name-all-completions file dir)) - (ange-ftp-real-file-name-all-completions file dir)))) - -(defun ange-ftp-file-name-completion (file dir) - "Documented as original." - (setq dir (expand-file-name dir)) - (if (ange-ftp-ftp-path dir) - (progn - (ange-ftp-barf-if-not-directory dir) - (if (equal file "") - "" - (setq dir (ange-ftp-real-file-name-as-directory dir)) ;real? - (let* ((tbl (ange-ftp-get-files dir)) - (completion-ignored-pattern - (mapconcat (function - (lambda (s) (if (stringp s) - (concat (regexp-quote s) "$") - "/"))) ; / never in filename - completion-ignored-extensions - "\\|"))) - (ange-ftp-save-match-data - (or (ange-ftp-file-name-completion-1 - file tbl dir (function ange-ftp-file-entry-not-ignored-p)) - (ange-ftp-file-name-completion-1 - file tbl dir (function ange-ftp-file-entry-active-p))))))) - (if (string-equal "/" dir) - (try-completion - file - (nconc (ange-ftp-generate-root-prefixes) - (mapcar 'list - (ange-ftp-real-file-name-all-completions file "/")))) - (ange-ftp-real-file-name-completion file dir)))) - - -(defun ange-ftp-file-name-completion-1 (file tbl dir predicate) - "Internal subroutine for ange-ftp-file-name-completion. Do not call this." - (let ((bestmatch (try-completion file tbl predicate))) - (if bestmatch - (if (eq bestmatch t) - (if (file-directory-p (expand-file-name file dir)) - (concat file "/") - t) - (if (and (eq (try-completion bestmatch tbl predicate) t) - (file-directory-p - (expand-file-name bestmatch dir))) - (concat bestmatch "/") - bestmatch))))) - -(defun ange-ftp-quote-filename (file) - "Quote `$' as `$$' in FILE to get it past function `substitute-in-file-name.'" - (let ((pos 0)) - (while (setq pos (string-match "\\$" file pos)) - (setq file (concat (substring file 0 pos) - "$";; precede by escape character (also a $) - (substring file pos)) - ;; add 2 instead 1 since another $ was inserted - pos (+ 2 pos))) - file)) - -;; (defun ange-ftp-read-file-name-internal (string dir action) -;; "Documented as original." -;; (let (name realdir) -;; (if (eq action 'lambda) -;; (if (> (length string) 0) -;; (file-exists-p (substitute-in-file-name string))) -;; (if (zerop (length string)) -;; (setq name string realdir dir) -;; (setq string (substitute-in-file-name string) -;; name (file-name-nondirectory string) -;; realdir (file-name-directory string)) -;; (setq realdir (if realdir (expand-file-name realdir dir) dir))) -;; (if action -;; (file-name-all-completions name realdir) -;; (let ((specdir (file-name-directory string)) -;; (val (file-name-completion name realdir))) -;; (if (and specdir (stringp val)) -;; (ange-ftp-quote-filename (concat specdir val)) -;; val)))))) - -;; Put these lines uncommmented in your .emacs if you want C-r to refresh -;; ange-ftp's cache whilst doing filename completion. -;; -;;(define-key minibuffer-local-completion-map "\C-r" 'ange-ftp-re-read-dir) -;;(define-key minibuffer-local-must-match-map "\C-r" 'ange-ftp-re-read-dir) - -(defun ange-ftp-re-read-dir (&optional dir) - "Forces a re-read of the directory DIR. If DIR is omitted then it defaults -to the directory part of the contents of the current buffer." - (interactive) - (if dir - (setq dir (expand-file-name dir)) - (setq dir (file-name-directory (expand-file-name (buffer-string))))) - (if (ange-ftp-ftp-path dir) - (progn - (setq ange-ftp-ls-cache-file nil) - (ange-ftp-del-hash-entry dir ange-ftp-files-hashtable) - (ange-ftp-get-files dir t)))) - -;;;; ------------------------------------------------------------ -;;;; Bits and bobs to bolt ange-ftp into GNU Emacs. -;;;; ------------------------------------------------------------ - -(defvar ange-ftp-overwrite-msg - "Note: This function has been modified to work with ange-ftp.") - -(defun ange-ftp-safe-documentation (fun) - "A documentation function that isn't quite as fragile." - (condition-case () - (documentation fun) - (error nil))) - -(defun ange-ftp-overwrite-fn (fun) - "Replace FUN's function definition with ange-ftp-FUN's, saving the -original definition as ange-ftp-real-FUN. The original documentation is -placed on the new definition suitably augmented." - (let* ((name (symbol-name fun)) - (saved (intern (concat "ange-ftp-real-" name))) - (new (intern (concat "ange-ftp-" name))) - (nfun (symbol-function new)) - (exec-directory (if (or (equal (nth 3 command-line-args) "dump") - (equal (nth 4 command-line-args) "dump")) - "../etc/" - exec-directory))) - - ;; *** This is unnecessary for any ange-ftp function (I think): - (while (symbolp nfun) - (setq nfun (symbol-function nfun))) - - ;; Interpose the ange-ftp function between the function symbol and the - ;; original definition of the function symbol AT TIME OF FIRST LOAD. - ;; We must only redefine the symbol-function of FUN the very first - ;; time, to avoid blowing away stuff that overloads FUN after this. - - ;; We direct the function symbol to the ange-ftp's function symbol - ;; rather than function definition to allow reloading of this file or - ;; redefining of the individual function (e.g., during debugging) - ;; later after some other code has been loaded on top of our stuff. - - (or (fboundp saved) - (progn - (fset saved (symbol-function fun)) - (fset fun new))) - - ;; Rewrite the doc string on the new ange-ftp function. This should - ;; be done every time the file is loaded (or a function is redefined), - ;; because the underlying overloaded function may have changed its doc - ;; string. - - (let* ((doc-str (ange-ftp-safe-documentation saved)) - (ndoc-str (concat doc-str (and doc-str "\n") - ange-ftp-overwrite-msg))) - - (cond ((listp nfun) - ;; Probe to test whether function is in preloaded read-only - ;; memory, and if so make writable copy: - (condition-case nil - (setcar nfun (car nfun)) - (error - (setq nfun (copy-sequence nfun)) ; shallow copy only - (fset new nfun))) - (let ((ndoc-cdr (nthcdr 2 nfun))) - (if (stringp (car ndoc-cdr)) - ;; Replace the existing docstring. - (setcar ndoc-cdr ndoc-str) - ;; There is no docstring. Insert the overwrite msg. - (setcdr ndoc-cdr (cons (car ndoc-cdr) (cdr ndoc-cdr))) - (setcar ndoc-cdr ange-ftp-overwrite-msg)))) - (t - ;; it's an emacs19 compiled-code object - (if (not (fboundp 'compiled-function-arglist)) - ;; the old way (typical emacs lack of abstraction) - (let ((new-code (append nfun nil))) ; turn it into a list - (if (nthcdr 4 new-code) - (setcar (nthcdr 4 new-code) ndoc-str) - (setcdr (nthcdr 3 new-code) (cons ndoc-str nil))) - (fset new (apply 'make-byte-code new-code))) - ;; the new way (marginally less random) for XEmacs 19.8+ - (fset new - (apply 'make-byte-code - (compiled-function-arglist nfun) - (compiled-function-instructions nfun) - (compiled-function-constants nfun) - (compiled-function-stack-depth nfun) - ndoc-str - (if (commandp nfun) - (list (nth 1 (compiled-function-interactive - nfun))) - nil))) - )))))) - -(defun ange-ftp-overwrite-dired () - (if (not (fboundp 'dired-ls)) ;dired should have been loaded by now - (ange-ftp-overwrite-fn 'dired-readin) ; classic dired - (ange-ftp-overwrite-fn 'make-directory) ; tree dired and v19 stuff - (ange-ftp-overwrite-fn 'remove-directory) - ;; XEmacs - not anymore because ange-ftp-diff is hosed - ;; (ange-ftp-overwrite-fn 'diff) - (ange-ftp-overwrite-fn 'dired-run-shell-command) - (ange-ftp-overwrite-fn 'dired-ls) - (ange-ftp-overwrite-fn 'dired-call-process) - ;; Can't use (fset 'ange-ftp-dired-readin 'ange-ftp-tree-dired-readin) - ;; here because it confuses ange-ftp-overwrite-fn. - (fset 'ange-ftp-dired-readin (symbol-function 'ange-ftp-tree-dired-readin)) - (ange-ftp-overwrite-fn 'dired-readin) - (ange-ftp-overwrite-fn 'dired-insert-headerline) - (ange-ftp-overwrite-fn 'dired-move-to-filename) - (ange-ftp-overwrite-fn 'dired-move-to-end-of-filename) - (ange-ftp-overwrite-fn 'dired-get-filename) - (ange-ftp-overwrite-fn 'dired-between-files) - (ange-ftp-overwrite-fn 'dired-clean-directory) - (ange-ftp-overwrite-fn 'dired-flag-backup-files) - (ange-ftp-overwrite-fn 'dired-backup-diff) - (if (fboundp 'dired-do-create-files) - ;; dired 6.0 or later. - (progn - (ange-ftp-overwrite-fn 'dired-copy-file) - (ange-ftp-overwrite-fn 'dired-create-files) - (ange-ftp-overwrite-fn 'dired-do-create-files))) - (if (fboundp 'dired-compress-make-compressed-filename) - ;; it's V5.255 or later - (ange-ftp-overwrite-fn 'dired-compress-make-compressed-filename) - ;; ange-ftp-overwrite-fn confuses dired-mark-map here. - (fset 'ange-ftp-real-dired-compress (symbol-function 'dired-compress)) - (fset 'dired-compress 'ange-ftp-dired-compress) - (fset 'ange-ftp-real-dired-uncompress (symbol-function 'dired-uncompress)) - (fset 'dired-uncompress 'ange-ftp-dired-uncompress))) - - (ange-ftp-overwrite-fn 'dired-find-file) - (ange-ftp-overwrite-fn 'dired-revert)) - -;; Attention! -;; It would be nice if ange-ftp-add-hook was generalized to -;; (defun ange-ftp-add-hook (hook-var hook-function &optional postpend), -;; where the optional postpend variable stipulates that hook-function -;; should be post-pended to the hook-var, rather than prepended. -;; Then, maybe we should overwrite dired with -;; (ange-ftp-add-hook 'dired-load-hook 'ange-ftp-overwrite-dired t). -;; This is because dired-load-hook is commonly used to add the dired extras -;; features (dired-x.el, dired-trns.el, dired-nstd.el, ...). Some of these -;; extras features overwrite functions in dired.el with fancier versions. -;; The "extras" overwrites would then clobber the ange-ftp overwrites. -;; As long as the ange-ftp overwrites are carefully written to use -;; ange-ftp-real-... when the directory is local, then doing the ange-ftp -;; overwrites after the extras overwites should be OK. -;; At the moment, I think that there aren't any conflicts between the extras -;; overwrites, and the ange-ftp overwrites. This may not last though. - -(defun ange-ftp-add-hook (hook-var hook-function) - "Prepend hook-function to hook-var's value, if it is not already an element. -hook-var's value may be a single function or a list of functions." - (if (boundp hook-var) - (let ((value (symbol-value hook-var))) - (if (and (listp value) (not (eq (car value) 'lambda))) - (and (not (memq hook-function value)) - (set hook-var - (if value (cons hook-function value) hook-function))) - (and (not (eq hook-function value)) - (set hook-var - (list hook-function value))))) - (set hook-var hook-function))) - -;; To load ange-ftp and not dired (leaving it to autoload), define -;; dired-load-hook and make sure dired.el ends with: -;; (run-hooks 'dired-load-hook) -;; -(if (and (boundp 'dired-load-hook) - (not (featurep 'dired))) - (ange-ftp-add-hook 'dired-load-hook 'ange-ftp-overwrite-dired) - (require 'dired) - (ange-ftp-overwrite-dired)) - -;; In case v19 or emacs-19.el already loaded: -;; (Can't use fboundp to check if emacs-19.el is -;; loaded, because these functions are probably -;; bound to autoloads.) - -(if (and (fboundp 'make-directory) - (not (and (listp (symbol-function 'make-directory)) - (eq (car (symbol-function 'make-directory)) 'autoload)))) - (ange-ftp-overwrite-fn 'make-directory)) -(if (and (fboundp 'remove-directory) - (not (and (listp (symbol-function 'remove-directory)) - (eq (car (symbol-function 'remove-directory)) 'autoload)))) - (ange-ftp-overwrite-fn 'remove-directory)) -;; XEmacs change -- ange-ftp-diff is hosed -;;(if (and (fboundp 'diff) -;; (not (and (listp (symbol-function 'diff)) -;; (eq (car (symbol-function 'diff)) 'autoload)))) -;; (ange-ftp-overwrite-fn 'diff)) - -(ange-ftp-overwrite-fn 'insert-file-contents) -(ange-ftp-overwrite-fn 'directory-files) -(ange-ftp-overwrite-fn 'file-directory-p) -(ange-ftp-overwrite-fn 'file-writable-p) -(ange-ftp-overwrite-fn 'file-readable-p) -(ange-ftp-overwrite-fn 'file-symlink-p) -(ange-ftp-overwrite-fn 'delete-file) -;; (ange-ftp-overwrite-fn 'read-file-name-internal) -(ange-ftp-overwrite-fn 'verify-visited-file-modtime) -(ange-ftp-overwrite-fn 'file-exists-p) -(ange-ftp-overwrite-fn 'write-region) -(ange-ftp-overwrite-fn 'backup-buffer) -(ange-ftp-overwrite-fn 'copy-file) -(ange-ftp-overwrite-fn 'rename-file) -(ange-ftp-overwrite-fn 'file-attributes) -(ange-ftp-overwrite-fn 'file-name-directory) -(ange-ftp-overwrite-fn 'file-name-nondirectory) -(ange-ftp-overwrite-fn 'file-name-as-directory) -(ange-ftp-overwrite-fn 'directory-file-name) -(ange-ftp-overwrite-fn 'expand-file-name) -(ange-ftp-overwrite-fn 'file-name-all-completions) -(ange-ftp-overwrite-fn 'file-name-completion) -(ange-ftp-overwrite-fn 'load) - -(or (memq 'ange-ftp-set-buffer-mode find-file-hooks) - (setq find-file-hooks - (cons 'ange-ftp-set-buffer-mode find-file-hooks))) - - -;;;; ------------------------------------------------------------ -;;;; VOS support (VOS support is probably broken, -;;;; but I don't know anything about VOS.) -;;;; ------------------------------------------------------------ -; -;(defun ange-ftp-fix-path-for-vos (path &optional reverse) -; (setq path (copy-sequence path)) -; (let ((from (if reverse ?\> ?\/)) -; (to (if reverse ?\/ ?\>)) -; (i (1- (length path)))) -; (while (>= i 0) -; (if (= (aref path i) from) -; (aset path i to)) -; (setq i (1- i))) -; path)) -; -;(or (assq 'vos ange-ftp-fix-path-func-alist) -; (setq ange-ftp-fix-path-func-alist -; (cons '(vos . ange-ftp-fix-path-for-vos) -; ange-ftp-fix-path-func-alist))) -; -;(or (memq 'vos ange-ftp-dumb-host-types) -; (setq ange-ftp-dumb-host-types -; (cons 'vos ange-ftp-dumb-host-types))) -; -;(defun ange-ftp-fix-dir-path-for-vos (dir-path) -; (ange-ftp-fix-path-for-vos -; (concat dir-path -; (if (eq ?/ (aref dir-path (1- (length dir-path)))) -; "" "/") -; "*"))) -; -;(or (assq 'vos ange-ftp-fix-dir-path-func-alist) -; (setq ange-ftp-fix-dir-path-func-alist -; (cons '(vos . ange-ftp-fix-dir-path-for-vos) -; ange-ftp-fix-dir-path-func-alist))) -; -;(defvar ange-ftp-vos-host-regexp nil -; "If a host matches this regexp then it is assumed to be running VOS.") -; -;(defun ange-ftp-vos-host (host) -; (and ange-ftp-vos-host-regexp -; (ange-ftp-save-match-data -; (string-match ange-ftp-vos-host-regexp host)))) -; -;(defun ange-ftp-parse-vos-listing () -; "Parse the current buffer which is assumed to be in VOS list -all -;format, and return a hashtable as the result." -; (let ((tbl (ange-ftp-make-hashtable)) -; (type-list -; '(("^Files: [0-9]+ +Blocks: [0-9]+\n+" nil 40) -; ("^Dirs: [0-9]+\n+" t 30))) -; type-regexp type-is-dir type-col file) -; (goto-char (point-min)) -; (ange-ftp-save-match-data -; (while type-list -; (setq type-regexp (car (car type-list)) -; type-is-dir (nth 1 (car type-list)) -; type-col (nth 2 (car type-list)) -; type-list (cdr type-list)) -; (if (re-search-forward type-regexp nil t) -; (while (eq (char-after (point)) ? ) -; (move-to-column type-col) -; (setq file (buffer-substring (point) -; (progn -; (end-of-line 1) -; (point)))) -; (ange-ftp-put-hash-entry file type-is-dir tbl) -; (forward-line 1)))) -; (ange-ftp-put-hash-entry "." 'vosdir tbl) -; (ange-ftp-put-hash-entry ".." 'vosdir tbl)) -; tbl)) -; -;(or (assq 'vos ange-ftp-parse-list-func-alist) -; (setq ange-ftp-parse-list-func-alist -; (cons '(vos . ange-ftp-parse-vos-listing) -; ange-ftp-parse-list-func-alist))) - -;;;; ------------------------------------------------------------ -;;;; VMS support. -;;;; ------------------------------------------------------------ - -(defun ange-ftp-fix-path-for-vms (path &optional reverse) - "Convert PATH from UNIX-ish to VMS. If REVERSE given then convert from VMS -to UNIX-ish." - (ange-ftp-save-match-data - (if reverse - (if (string-match "^\\([^:]+:\\)?\\(\\[.*\\]\\)?\\([^][]*\\)$" path) - (let (drive dir file) - (if (match-beginning 1) - (setq drive (substring path - (match-beginning 1) - (match-end 1)))) - (if (match-beginning 2) - (setq dir - (substring path (match-beginning 2) (match-end 2)))) - (if (match-beginning 3) - (setq file - (substring path (match-beginning 3) (match-end 3)))) - (and dir - (setq dir (apply (function concat) - (mapcar (function - (lambda (char) - (if (= char ?.) - (vector ?/) - (vector char)))) - (substring dir 1 -1))))) - (concat (and drive - (concat "/" drive "/")) - dir (and dir "/") - file)) - (error "path %s didn't match" path)) - (let (drive dir file tmp) - (if (string-match "^/[^:]+:/" path) - (setq drive (substring path 1 - (1- (match-end 0))) - path (substring path (match-end 0)))) - (setq tmp (file-name-directory path)) - (if tmp - (setq dir (apply (function concat) - (mapcar (function - (lambda (char) - (if (= char ?/) - (vector ?.) - (vector char)))) - (substring tmp 0 -1))))) - (setq file (file-name-nondirectory path)) - (concat drive - (and dir (concat "[" (if drive nil ".") dir "]")) - file))))) - -;; (ange-ftp-fix-path-for-vms "/PUB$:/ANONYMOUS/SDSCPUB/NEXT/Readme.txt;1") -;; (ange-ftp-fix-path-for-vms "/PUB$:[ANONYMOUS.SDSCPUB.NEXT]Readme.txt;1" t) - -(or (assq 'vms ange-ftp-fix-path-func-alist) - (setq ange-ftp-fix-path-func-alist - (cons '(vms . ange-ftp-fix-path-for-vms) - ange-ftp-fix-path-func-alist))) - -(or (memq 'vms ange-ftp-dumb-host-types) - (setq ange-ftp-dumb-host-types - (cons 'vms ange-ftp-dumb-host-types))) - -;; It is important that this function barf for directories for which we know -;; that we cannot possibly get a directory listing, such as "/" and "/DEV:/". -;; This is because it saves an unnecessary FTP error, or possibly the listing -;; might succeed, but give erroneous info. This last case is particularly -;; likely for OS's (like MTS) for which we need to use a wildcard in order -;; to list a directory. - -(defun ange-ftp-fix-dir-path-for-vms (dir-path) - "Convert path from UNIX-ish to VMS ready for a DIRectory listing." - ;; Should there be entries for .. -> [-] and . -> [] below. Don't - ;; think so, because expand-filename should have already short-circuited - ;; them. - (cond ((string-equal dir-path "/") - (error "Cannot get listing for fictitious \"/\" directory.")) - ((string-match "^/[-A-Z0-9_$]+:/$" dir-path) - (error "Cannot get listing for device.")) - ((ange-ftp-fix-path-for-vms dir-path)))) - -(or (assq 'vms ange-ftp-fix-dir-path-func-alist) - (setq ange-ftp-fix-dir-path-func-alist - (cons '(vms . ange-ftp-fix-dir-path-for-vms) - ange-ftp-fix-dir-path-func-alist))) - -(defvar ange-ftp-vms-host-regexp nil) - -(defun ange-ftp-vms-host (host) - "Return whether HOST is running VMS." - (and ange-ftp-vms-host-regexp - (ange-ftp-save-match-data - (string-match ange-ftp-vms-host-regexp host)))) - -;; Because some VMS ftp servers convert filenames to lower case -;; we allow a-z in the filename regexp. I'm not too happy about this. - -(defconst ange-ftp-vms-filename-regexp - (concat - "\\(\\([_A-Za-z0-9$]?\\|[_A-Za-z0-9$][_A-Za-z0-9$---]*\\)\\." - "[_A-Za-z0-9$---]*;+[0-9]*\\)") - "Regular expression to match for a valid VMS file name in Dired buffer. -Stupid freaking bug! Position of _ and $ shouldn't matter but they do. -Having [A-Z0-9$_] bombs on filename _$$CHANGE_LOG$.TXT$ and $CHANGE_LOG$.TX -Other orders of $ and _ seem to all work just fine.") - -;; These parsing functions are as general as possible because the syntax -;; of ftp listings from VMS hosts is a bit erratic. What saves us is that -;; the VMS filename syntax is so rigid. If they bomb on a listing in the -;; standard VMS Multinet format, then this is a bug. If they bomb on a listing -;; from vms.weird.net, then too bad. - -(defun ange-ftp-parse-vms-filename () - "Extract the next filename from a VMS dired-like listing." - (if (re-search-forward - ange-ftp-vms-filename-regexp - nil t) - (buffer-substring (match-beginning 0) (match-end 0)))) - -(defun ange-ftp-parse-vms-listing () - "Parse the current buffer which is assumed to be in MultiNet FTP dir -format, and return a hashtable as the result." - (let ((tbl (ange-ftp-make-hashtable)) - file) - (goto-char (point-min)) - (ange-ftp-save-match-data - (while (setq file (ange-ftp-parse-vms-filename)) - (if (string-match "\\.\\(DIR\\|dir\\);[0-9]+" file) - ;; deal with directories - (ange-ftp-put-hash-entry - (substring file 0 (match-beginning 0)) t tbl) - (ange-ftp-put-hash-entry file nil tbl) - (if (string-match ";[0-9]+$" file) ; deal with extension - ;; sans extension - (ange-ftp-put-hash-entry - (substring file 0 (match-beginning 0)) nil tbl))) - (forward-line 1)) - ;; Would like to look for a "Total" line, or a "Directory" line to - ;; make sure that the listing isn't complete garbage before putting - ;; in "." and "..", but we can't even count on all VAX's giving us - ;; either of these. - (ange-ftp-put-hash-entry "." t tbl) - (ange-ftp-put-hash-entry ".." t tbl)) - tbl)) - -(or (assq 'vms ange-ftp-parse-list-func-alist) - (setq ange-ftp-parse-list-func-alist - (cons '(vms . ange-ftp-parse-vms-listing) - ange-ftp-parse-list-func-alist))) - -;; This version only deletes file entries which have -;; explicit version numbers, because that is all VMS allows. - -;; Can the following two functions be speeded up using file -;; completion functions? - -(defun ange-ftp-vms-delete-file-entry (path &optional dir-p) - (if dir-p - (ange-ftp-internal-delete-file-entry path t) - (ange-ftp-save-match-data - (let ((file (ange-ftp-get-file-part path))) - (if (string-match ";[0-9]+$" file) - ;; In VMS you can't delete a file without an explicit - ;; version number, or wild-card (e.g. FOO;*) - ;; For now, we give up on wildcards. - (let ((files (ange-ftp-get-hash-entry - (file-name-directory path) - ange-ftp-files-hashtable))) - (if files - (let* ((root (substring file 0 - (match-beginning 0))) - (regexp (concat "^" - (regexp-quote root) - ";[0-9]+$")) - versions) - (ange-ftp-del-hash-entry file files) - ;; Now we need to check if there are any - ;; versions left. If not, then delete the - ;; root entry. - (mapatoms - '(lambda (sym) - (and (string-match regexp (get sym 'key)) - (setq versions t))) - files) - (or versions - (ange-ftp-del-hash-entry root files)))))))))) - -(or (assq 'vms ange-ftp-delete-file-entry-alist) - (setq ange-ftp-delete-file-entry-alist - (cons '(vms . ange-ftp-vms-delete-file-entry) - ange-ftp-delete-file-entry-alist))) - -(defun ange-ftp-vms-add-file-entry (path &optional dir-p) - (if dir-p - (ange-ftp-internal-add-file-entry path t) - (let ((files (ange-ftp-get-hash-entry - (file-name-directory path) - ange-ftp-files-hashtable))) - (if files - (let ((file (ange-ftp-get-file-part path))) - (ange-ftp-save-match-data - (if (string-match ";[0-9]+$" file) - (ange-ftp-put-hash-entry - (substring file 0 (match-beginning 0)) - nil files) - ;; Need to figure out what version of the file - ;; is being added. - (let ((regexp (concat "^" - (regexp-quote file) - ";\\([0-9]+\\)$")) - (version 0)) - (mapatoms - '(lambda (sym) - (let ((name (get sym 'key))) - (and (string-match regexp name) - (setq version - (max version - (string-to-int - (substring name - (match-beginning 1) - (match-end 1)))))))) - files) - (setq version (1+ version)) - (ange-ftp-put-hash-entry - (concat file ";" (int-to-string version)) - nil files)))) - (ange-ftp-put-hash-entry file nil files)))))) - -(or (assq 'vms ange-ftp-add-file-entry-alist) - (setq ange-ftp-add-file-entry-alist - (cons '(vms . ange-ftp-vms-add-file-entry) - ange-ftp-add-file-entry-alist))) - - -(defun ange-ftp-add-vms-host (host) - "Interactively adds a given HOST to ange-ftp-vms-host-regexp." - (interactive - (list (read-string "Host: " - (let ((name (or (buffer-file-name) - (and (eq major-mode 'dired-mode) - dired-directory)))) - (and name (car (ange-ftp-ftp-path name))))))) - (if (not (ange-ftp-vms-host host)) - (setq ange-ftp-vms-host-regexp - (concat "^" (regexp-quote host) "$" - (and ange-ftp-vms-host-regexp "\\|") - ange-ftp-vms-host-regexp) - ange-ftp-host-cache nil))) - - -(defun ange-ftp-vms-file-name-as-directory (name) - (ange-ftp-save-match-data - (if (string-match "\\.\\(DIR\\|dir\\)\\(;[0-9]+\\)?$" name) - (setq name (substring name 0 (match-beginning 0)))) - (ange-ftp-real-file-name-as-directory name))) - -(or (assq 'vms ange-ftp-file-name-as-directory-alist) - (setq ange-ftp-file-name-as-directory-alist - (cons '(vms . ange-ftp-vms-file-name-as-directory) - ange-ftp-file-name-as-directory-alist))) - -;;; Tree dired support: - -;; For this code I have borrowed liberally from Sebastian Kremer's -;; dired-vms.el - - -;; These regexps must be anchored to beginning of line. -;; Beware that the ftpd may put the device in front of the filename. - -(defconst ange-ftp-dired-vms-re-exe "^. [^ \t.]+\\.\\(EXE\\|exe\\)[; ]" - "Regular expression to use to search for VMS executable files.") - -(defconst ange-ftp-dired-vms-re-dir "^. [^ \t.]+\\.\\(DIR\\|dir\\)[; ]" - "Regular expression to use to search for VMS directories.") - -(or (assq 'vms ange-ftp-dired-re-exe-alist) - (setq ange-ftp-dired-re-exe-alist - (cons (cons 'vms ange-ftp-dired-vms-re-exe) - ange-ftp-dired-re-exe-alist))) - -(or (assq 'vms ange-ftp-dired-re-dir-alist) - (setq ange-ftp-dired-re-dir-alist - (cons (cons 'vms ange-ftp-dired-vms-re-dir) - ange-ftp-dired-re-dir-alist))) - -(defun ange-ftp-dired-vms-insert-headerline (dir) - ;; VMS inserts a headerline. I would prefer the headerline - ;; to be in ange-ftp format. This version tries to - ;; be careful, because we can't count on a headerline - ;; over ftp, and we wouldn't want to delete anything - ;; important. - (save-excursion - (if (looking-at "^ wildcard ") - (forward-line 1)) - (if (looking-at "^[ \n\t]*[^\n]+\\][ \t]*\n") - (delete-region (point) (match-end 0)))) - (ange-ftp-real-dired-insert-headerline dir)) - -(or (assq 'vms ange-ftp-dired-insert-headerline-alist) - (setq ange-ftp-dired-insert-headerline-alist - (cons '(vms . ange-ftp-dired-vms-insert-headerline) - ange-ftp-dired-insert-headerline-alist))) - -(defun ange-ftp-dired-vms-move-to-filename (&optional raise-error eol) - "In dired, move to first char of filename on this line. -Returns position (point) or nil if no filename on this line." - ;; This is the VMS version. - (let (case-fold-search) - (or eol (setq eol (progn (end-of-line) (point)))) - (beginning-of-line) - (if (re-search-forward ange-ftp-vms-filename-regexp eol t) - (goto-char (match-beginning 1)) - (if raise-error - (error "No file on this line") - nil)))) - -(or (assq 'vms ange-ftp-dired-move-to-filename-alist) - (setq ange-ftp-dired-move-to-filename-alist - (cons '(vms . ange-ftp-dired-vms-move-to-filename) - ange-ftp-dired-move-to-filename-alist))) - -(defun ange-ftp-dired-vms-move-to-end-of-filename (&optional no-error eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; case-fold-search must be nil, at least for VMS. - ;; On failure, signals an error or returns nil. - ;; This is the VMS version. - (let (opoint hidden case-fold-search) - (setq opoint (point)) - (or eol (setq eol (save-excursion (end-of-line) (point)))) - (setq hidden (and selective-display - (save-excursion (search-forward "\r" eol t)))) - (if hidden - nil - (re-search-forward ange-ftp-vms-filename-regexp eol t)) - (or no-error - (not (eq opoint (point))) - (error - (if hidden - (substitute-command-keys - "File line is hidden, type \\[dired-hide-subdir] to unhide") - "No file on this line"))) - (if (eq opoint (point)) - nil - (point)))) - -(or (assq 'vms ange-ftp-dired-move-to-end-of-filename-alist) - (setq ange-ftp-dired-move-to-end-of-filename-alist - (cons '(vms . ange-ftp-dired-vms-move-to-end-of-filename) - ange-ftp-dired-move-to-end-of-filename-alist))) - -(defun ange-ftp-dired-vms-between-files () - (save-excursion - (beginning-of-line) - (or (equal (following-char) 10) ; newline - (equal (following-char) 9) ; tab - (progn (forward-char 2) - (or (looking-at "Total of") - (equal (following-char) 32)))))) - -(or (assq 'vms ange-ftp-dired-between-files-alist) - (setq ange-ftp-dired-between-files-alist - (cons '(vms . ange-ftp-dired-vms-between-files) - ange-ftp-dired-between-files-alist))) - -;; Beware! In VMS filenames must be of the form "FILE.TYPE". -;; Therefore, we cannot just append a ".Z" to filenames for -;; compressed files. Instead, we turn "FILE.TYPE" into -;; "FILE.TYPE-Z". Hope that this is a reasonable thing to do. - -(defun ange-ftp-vms-make-compressed-filename (name &optional reverse) - (if reverse - (cond - ((string-match "-Z;[0-9]+$" name) - (substring name 0 (match-beginning 0))) - ((string-match ";[0-9]+$" name) - (substring name 0 (match-beginning 0))) - ((string-match "-Z$" name) - (substring name 0 -2)) - (t name)) - (if (string-match ";[0-9]+$" name) - (concat (substring name 0 (match-beginning 0)) - "-Z") - (concat name "-Z")))) - -(or (assq 'vms ange-ftp-dired-compress-make-compressed-filename-alist) - (setq ange-ftp-dired-compress-make-compressed-filename-alist - (cons '(vms . ange-ftp-vms-make-compressed-filename) - ange-ftp-dired-compress-make-compressed-filename-alist))) - -;; When the filename is too long, VMS will use two lines to list a file -;; (damn them!) This will confuse dired. To solve this, need to convince -;; Sebastian to use a function dired-go-to-end-of-file-line, instead of -;; (forward-line 1). This would require a number of changes to dired.el. -;; If dired gets confused, revert-buffer will fix it. - -(defun ange-ftp-dired-vms-ls-trim () - (goto-char (point-min)) - (let ((case-fold-search nil)) - (re-search-forward ange-ftp-vms-filename-regexp)) - (beginning-of-line) - (delete-region (point-min) (point)) - (forward-line 1) - (delete-region (point) (point-max))) - - -(or (assq 'vms ange-ftp-dired-ls-trim-alist) - (setq ange-ftp-dired-ls-trim-alist - (cons '(vms . ange-ftp-dired-vms-ls-trim) - ange-ftp-dired-ls-trim-alist))) - -(defun ange-ftp-vms-bob-version (name) - (ange-ftp-save-match-data - (if (string-match ";[0-9]+$" name) - (substring name 0 (match-beginning 0)) - name))) - -(or (assq 'vms ange-ftp-bob-version-alist) - (setq ange-ftp-bob-version-alist - (cons '(vms . ange-ftp-vms-bob-version) - ange-ftp-bob-version-alist))) - -;;; The vms version of clean-directory has 2 more optional args -;;; than the usual dired version. This is so that it can be used by -;;; ange-ftp-dired-vms-flag-backup-files. - -(defun ange-ftp-dired-vms-clean-directory (keep &optional marker msg) - "Flag numerical backups for deletion. -Spares `dired-kept-versions' latest versions, and `kept-old-versions' oldest. -Positive prefix arg KEEP overrides `dired-kept-versions'; -Negative prefix arg KEEP overrides `kept-old-versions' with KEEP made positive. - -To clear the flags on these files, you can use \\[dired-flag-backup-files] -with a prefix argument." -; (interactive "P") ; Never actually called interactively. - (setq keep (max 1 (if keep (prefix-numeric-value keep) dired-kept-versions))) - (let ((early-retention (if (< keep 0) (- keep) kept-old-versions)) - ;; late-retention must NEVER be allowed to be less than 1 in VMS! - ;; This could wipe ALL copies of the file. - (late-retention (max 1 (if (<= keep 0) dired-kept-versions keep))) - (action (or msg "Cleaning")) - (trample-marker (or marker dired-del-marker)) - (file-version-assoc-list ())) - (message (concat action - " numerical backups (keeping %d late, %d old)...") - late-retention early-retention) - ;; Look at each file. - ;; If the file has numeric backup versions, - ;; put on file-version-assoc-list an element of the form - ;; (FILENAME . VERSION-NUMBER-LIST) - (dired-map-dired-file-lines (function - ange-ftp-dired-vms-collect-file-versions)) - ;; Sort each VERSION-NUMBER-LIST, - ;; and remove the versions not to be deleted. - (let ((fval file-version-assoc-list)) - (while fval - (let* ((sorted-v-list (cons 'q (sort (cdr (car fval)) '<))) - (v-count (length sorted-v-list))) - (if (> v-count (+ early-retention late-retention)) - (rplacd (nthcdr early-retention sorted-v-list) - (nthcdr (- v-count late-retention) - sorted-v-list))) - (rplacd (car fval) - (cdr sorted-v-list))) - (setq fval (cdr fval)))) - ;; Look at each file. If it is a numeric backup file, - ;; find it in a VERSION-NUMBER-LIST and maybe flag it for deletion. - (dired-map-dired-file-lines - (function - ange-ftp-dired-vms-trample-file-versions mark)) - (message (concat action " numerical backups...done")))) - -(or (assq 'vms ange-ftp-dired-clean-directory-alist) - (setq ange-ftp-dired-clean-directory-alist - (cons '(vms . ange-ftp-dired-vms-clean-directory) - ange-ftp-dired-clean-directory-alist))) - -(defun ange-ftp-dired-vms-collect-file-versions (fn) - ;; "If it looks like file FN has versions, return a list of the versions. - ;;That is a list of strings which are file names. - ;;The caller may want to flag some of these files for deletion." -(let ((path (nth 2 (ange-ftp-ftp-path fn)))) - (if (string-match ";[0-9]+$" path) - (let* ((path (substring path 0 (match-beginning 0))) - (fn (ange-ftp-replace-path-component fn path))) - (if (not (assq fn file-version-assoc-list)) - (let* ((base-versions - (concat (file-name-nondirectory path) ";")) - (bv-length (length base-versions)) - (possibilities (file-name-all-completions - base-versions - (file-name-directory fn))) - (versions (mapcar - '(lambda (arg) - (if (and (string-match - "[0-9]+$" arg bv-length) - (= (match-beginning 0) bv-length)) - (string-to-int (substring arg bv-length)) - 0)) - possibilities))) - (if versions - (setq - file-version-assoc-list - (cons (cons fn versions) - file-version-assoc-list))))))))) - -(defun ange-ftp-dired-vms-trample-file-versions (fn) - (let* ((start-vn (string-match ";[0-9]+$" fn)) - base-version-list) - (and start-vn - (setq base-version-list ; there was a base version to which - (assoc (substring fn 0 start-vn) ; this looks like a - file-version-assoc-list)) ; subversion - (not (memq (string-to-int (substring fn (1+ start-vn))) - base-version-list)) ; this one doesn't make the cut - (progn (beginning-of-line) - (delete-char 1) - (insert trample-marker))))) - -(defun ange-ftp-dired-vms-flag-backup-files (&optional unflag-p) - (let ((dired-kept-versions 1) - (kept-old-versions 0) - marker msg) - (if unflag-p - (setq marker ?\040 msg "Unflagging") - (setq marker dired-del-marker msg "Cleaning")) - (ange-ftp-dired-vms-clean-directory nil marker msg))) - -(or (assq 'vms ange-ftp-dired-flag-backup-files-alist) - (setq ange-ftp-dired-flag-backup-files-alist - (cons '(vms . ange-ftp-dired-vms-flag-backup-files) - ange-ftp-dired-flag-backup-files-alist))) - -(defun ange-ftp-dired-vms-backup-diff (&optional switches) - (let ((file (dired-get-filename 'no-dir)) - bak) - (if (and (string-match ";[0-9]+$" file) - ;; Find most recent previous version. - (let ((root (substring file 0 (match-beginning 0))) - (ver - (string-to-int (substring file (1+ (match-beginning 0))))) - found) - (setq ver (1- ver)) - (while (and (> ver 0) (not found)) - (setq bak (concat root ";" (int-to-string ver))) - (and (file-exists-p bak) (setq found t)) - (setq ver (1- ver))) - found)) - (if switches - (diff (expand-file-name bak) (expand-file-name file) switches) - (diff (expand-file-name bak) (expand-file-name file))) - (error "No previous version found for %s" file)))) - -(or (assq 'vms ange-ftp-dired-backup-diff-alist) - (setq ange-ftp-dired-backup-diff-alist - (cons '(vms . ange-ftp-dired-vms-backup-diff) - ange-ftp-dired-backup-diff-alist))) - - -;;;; ------------------------------------------------------------ -;;;; MTS support -;;;; ------------------------------------------------------------ - - -(defun ange-ftp-fix-path-for-mts (path &optional reverse) - "Convert PATH from UNIX-ish to MTS. If REVERSE given then convert from -MTS to UNIX-ish." - (ange-ftp-save-match-data - (if reverse - (if (string-match "^\\([^:]+:\\)?\\(.*\\)$" path) - (let (acct file) - (if (match-beginning 1) - (setq acct (substring path 0 (match-end 1)))) - (if (match-beginning 2) - (setq file (substring path - (match-beginning 2) (match-end 2)))) - (concat (and acct (concat "/" acct "/")) - file)) - (error "path %s didn't match" path)) - (if (string-match "^/\\([^:]+:\\)/\\(.*\\)$" path) - (concat (substring path 1 (match-end 1)) - (substring path (match-beginning 2) (match-end 2))) - ;; Let's hope that mts will recognize it anyway. - path)))) - -(or (assq 'mts ange-ftp-fix-path-func-alist) - (setq ange-ftp-fix-path-func-alist - (cons '(mts . ange-ftp-fix-path-for-mts) - ange-ftp-fix-path-func-alist))) - -(defun ange-ftp-fix-dir-path-for-mts (dir-path) - "Convert path from UNIX-ish to MTS ready for a DIRectory listing. -Remember that there are no directories in MTS." - (if (string-equal dir-path "/") - (error "Cannot get listing for fictitious \"/\" directory.") - (let ((dir-path (ange-ftp-fix-path-for-mts dir-path))) - (cond - ((string-equal dir-path "") - "?") - ((string-match ":$" dir-path) - (concat dir-path "?")) - (dir-path))))) ; It's just a single file. - -(or (assq 'mts ange-ftp-fix-dir-path-func-alist) - (setq ange-ftp-fix-dir-path-func-alist - (cons '(mts . ange-ftp-fix-dir-path-for-mts) - ange-ftp-fix-dir-path-func-alist))) - -(or (memq 'mts ange-ftp-dumb-host-types) - (setq ange-ftp-dumb-host-types - (cons 'mts ange-ftp-dumb-host-types))) - -(defvar ange-ftp-mts-host-regexp nil) - -(defun ange-ftp-mts-host (host) - "Return whether HOST is running MTS." - (and ange-ftp-mts-host-regexp - (ange-ftp-save-match-data - (string-match ange-ftp-mts-host-regexp host)))) - -(defun ange-ftp-parse-mts-listing () - "Parse the current buffer which is assumed to be in -mts ftp dir format." - (let ((tbl (ange-ftp-make-hashtable))) - (goto-char (point-min)) - (ange-ftp-save-match-data - (while (re-search-forward ange-ftp-date-regexp nil t) - (end-of-line) - (skip-chars-backward " ") - (let ((end (point))) - (skip-chars-backward "-A-Z0-9_.!") - (ange-ftp-put-hash-entry (buffer-substring (point) end) nil tbl)) - (forward-line 1))) - ;; Don't need to bother with .. - (ange-ftp-put-hash-entry "." t tbl) - tbl)) - -(or (assq 'mts ange-ftp-parse-list-func-alist) - (setq ange-ftp-parse-list-func-alist - (cons '(mts . ange-ftp-parse-mts-listing) - ange-ftp-parse-list-func-alist))) - -(defun ange-ftp-add-mts-host (host) - "Interactively adds a given HOST to ange-ftp-mts-host-regexp." - (interactive - (list (read-string "Host: " - (let ((name (or (buffer-file-name) - (and (eq major-mode 'dired-mode) - dired-directory)))) - (and name (car (ange-ftp-ftp-path name))))))) - (if (not (ange-ftp-mts-host host)) - (setq ange-ftp-mts-host-regexp - (concat "^" (regexp-quote host) "$" - (and ange-ftp-mts-host-regexp "\\|") - ange-ftp-mts-host-regexp) - ange-ftp-host-cache nil))) - -;;; Tree dired support: - -;; There aren't too many systems left that use MTS. This dired support will -;; work for the implementation of ftp on mtsg.ubc.ca. I hope other mts systems -;; implement ftp in the same way. If not, it might be necessary to make the -;; following more flexible. - -(defun ange-ftp-dired-mts-move-to-filename (&optional raise-error eol) - "In dired, move to first char of filename on this line. -Returns position (point) or nil if no filename on this line." - ;; This is the MTS version. - (or eol (setq eol (progn (end-of-line) (point)))) - (beginning-of-line) - (if (re-search-forward - ange-ftp-date-regexp eol t) - (progn - (skip-chars-forward " ") ; Eat blanks after date - (skip-chars-forward "0-9:" eol) ; Eat time or year - (skip-chars-forward " " eol) ; one space before filename - ;; When listing an account other than the users own account it appends - ;; ACCT: to the beginning of the filename. Skip over this. - (and (looking-at "[A-Z0-9_.]+:") - (goto-char (match-end 0))) - (point)) - (if raise-error - (error "No file on this line") - nil))) - -(or (assq 'mts ange-ftp-dired-move-to-filename-alist) - (setq ange-ftp-dired-move-to-filename-alist - (cons '(mts . ange-ftp-dired-mts-move-to-filename) - ange-ftp-dired-move-to-filename-alist))) - -(defun ange-ftp-dired-mts-move-to-end-of-filename (&optional no-error eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; On failure, signals an error or returns nil. - ;; This is the MTS version. - (let (opoint hidden case-fold-search) - (setq opoint (point) - eol (save-excursion (end-of-line) (point)) - hidden (and selective-display - (save-excursion (search-forward "\r" eol t)))) - (if hidden - nil - (skip-chars-forward "-A-Z0-9._!" eol)) - (or no-error - (not (eq opoint (point))) - (error - (if hidden - (substitute-command-keys - "File line is hidden, type \\[dired-hide-subdir] to unhide") - "No file on this line"))) - (if (eq opoint (point)) - nil - (point)))) - -(or (assq 'mts ange-ftp-dired-move-to-end-of-filename-alist) - (setq ange-ftp-dired-move-to-end-of-filename-alist - (cons '(mts . ange-ftp-dired-mts-move-to-end-of-filename) - ange-ftp-dired-move-to-end-of-filename-alist))) - -;;;; ------------------------------------------------------------ -;;;; CMS support -;;;; ------------------------------------------------------------ - -;; Since CMS doesn't have any full pathname syntax, we have to fudge -;; things with cd's. We actually send too many cd's, but is dangerous -;; to try to remember the current minidisk, because if the connection -;; is closed and needs to be reopened, we will find ourselves back in -;; the default minidisk. This is fairly likely since CMS ftp servers -;; usually close the connection after 5 minutes of inactivity. - -;; Have I got the filename character set right? - -(defun ange-ftp-fix-path-for-cms (path &optional reverse) - "Convert PATH from UNIX-ish to CMS. If REVERSE is given, convert -from CMS to UNIX. Actually, CMS doesn't have a full pathname syntax, -so we fudge things by sending cd's." - (ange-ftp-save-match-data - (if reverse - ;; Since we only convert output from a pwd in this direction, - ;; we'll assume that it's a minidisk, and make it into a - ;; directory file name. Note that the expand-dir-hashtable - ;; stores directories without the trailing /. Is this - ;; consistent? - (concat "/" path) - (if (string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$" - path) - (let ((minidisk (substring path 1 (match-end 1)))) - (if (match-beginning 2) - (let ((file (substring path (match-beginning 2) - (match-end 2))) - (cmd (concat "cd " minidisk)) - - ;; Note that host and user are bound in the call - ;; to ange-ftp-send-cmd - (proc (ange-ftp-get-process host user))) - - ;; Must use ange-ftp-raw-send-cmd here to avoid - ;; an infinite loop. - (if (car (ange-ftp-raw-send-cmd proc cmd msg)) - file - ;; failed... try ONCE more. - (setq proc (ange-ftp-get-process host user)) - (let ((result (ange-ftp-raw-send-cmd proc cmd msg))) - (if (car result) - file - ;; failed. give up. - (ange-ftp-error host user - (format "cd to minidisk %s failed: %s" - minidisk (cdr result))))))) - ;; return the minidisk - minidisk)) - (error "Invalid CMS filename"))))) - -(or (assq 'cms ange-ftp-fix-path-func-alist) - (setq ange-ftp-fix-path-func-alist - (cons '(cms . ange-ftp-fix-path-for-cms) - ange-ftp-fix-path-func-alist))) - -(or (memq 'cms ange-ftp-dumb-host-types) - (setq ange-ftp-dumb-host-types - (cons 'cms ange-ftp-dumb-host-types))) - -(defun ange-ftp-fix-dir-path-for-cms (dir-path) - "Convert path from UNIX-ish to VMS ready for a DIRectory listing." - (cond - ((string-equal "/" dir-path) - (error "Cannot get listing for fictitious \"/\" directory.")) - ((string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$" dir-path) - (let* ((minidisk (substring dir-path (match-beginning 1) (match-end 1))) - ;; host and user are bound in the call to ange-ftp-send-cmd - (proc (ange-ftp-get-process host user)) - (cmd (concat "cd " minidisk)) - (file (if (match-beginning 2) - ;; it's a single file - (substring path (match-beginning 2) - (match-end 2)) - ;; use the wild-card - "*"))) - (if (car (ange-ftp-raw-send-cmd proc cmd)) - file - ;; try again... - (setq proc (ange-ftp-get-process host user)) - (let ((result (ange-ftp-raw-send-cmd proc cmd))) - (if (car result) - file - ;; give up - (ange-ftp-error host user - (format "cd to minidisk %s failed: " - minidisk (cdr result)))))))) - (t (error "Invalid CMS pathname")))) - -(or (assq 'cms ange-ftp-fix-dir-path-func-alist) - (setq ange-ftp-fix-dir-path-func-alist - (cons '(cms . ange-ftp-fix-dir-path-for-cms) - ange-ftp-fix-dir-path-func-alist))) - -(defvar ange-ftp-cms-host-regexp nil - "Regular expression to match hosts running the CMS operating system.") - -(defun ange-ftp-cms-host (host) - "Return whether the host is running CMS." - (and ange-ftp-cms-host-regexp - (ange-ftp-save-match-data - (string-match ange-ftp-cms-host-regexp host)))) - -(defun ange-ftp-add-cms-host (host) - "Interactively adds a given HOST to ange-ftp-cms-host-regexp." - (interactive - (list (read-string "Host: " - (let ((name (or (buffer-file-name) - (and (eq major-mode 'dired-mode) - dired-directory)))) - (and name (car (ange-ftp-ftp-path name))))))) - (if (not (ange-ftp-cms-host host)) - (setq ange-ftp-cms-host-regexp - (concat "^" (regexp-quote host) "$" - (and ange-ftp-cms-host-regexp "\\|") - ange-ftp-cms-host-regexp) - ange-ftp-host-cache nil))) - -(defun ange-ftp-parse-cms-listing () - "Parse the current buffer which is assumed to be a CMS directory listing." - ;; If we succeed in getting a listing, then we will assume that the minidisk - ;; exists. file is bound by the call to ange-ftp-ls. This doesn't work - ;; because ange-ftp doesn't know that the root hashtable has only part of - ;; the info. It will assume that if a minidisk isn't in it, then it doesn't - ;; exist. It would be nice if completion worked for minidisks, as we - ;; discover them. -; (let* ((dir-file (directory-file-name file)) -; (root (file-name-directory dir-file)) -; (minidisk (ange-ftp-get-file-part dir-file)) -; (root-tbl (ange-ftp-get-hash-entry root ange-ftp-files-hashtable))) -; (if root-tbl -; (ange-ftp-put-hash-entry minidisk t root-tbl) -; (setq root-tbl (ange-ftp-make-hashtable)) -; (ange-ftp-put-hash-entry minidisk t root-tbl) -; (ange-ftp-put-hash-entry "." t root-tbl) -; (ange-ftp-set-files root root-tbl))) - ;; Now do the usual parsing - (let ((tbl (ange-ftp-make-hashtable))) - (goto-char (point-min)) - (ange-ftp-save-match-data - (while - (re-search-forward - "^\\([-A-Z0-9$_]+\\) +\\([-A-Z0-9$_]+\\) +[VF] +[0-9]+ " nil t) - (ange-ftp-put-hash-entry - (concat (buffer-substring (match-beginning 1) - (match-end 1)) - "." - (buffer-substring (match-beginning 2) - (match-end 2))) - nil tbl) - (forward-line 1)) - (ange-ftp-put-hash-entry "." t tbl)) - tbl)) - -(or (assq 'cms ange-ftp-parse-list-func-alist) - (setq ange-ftp-parse-list-func-alist - (cons '(cms . ange-ftp-parse-cms-listing) - ange-ftp-parse-list-func-alist))) - -;;; Tree dired support: - -(defconst ange-ftp-dired-cms-re-exe - "^. [-A-Z0-9$_]+ +EXEC " - "Regular expression to use to search for CMS executables.") - -(or (assq 'cms ange-ftp-dired-re-exe-alist) - (setq ange-ftp-dired-re-exe-alist - (cons (cons 'cms ange-ftp-dired-cms-re-exe) - ange-ftp-dired-re-exe-alist))) - - -(defun ange-ftp-dired-cms-insert-headerline (dir) - ;; CMS has no total line, so we insert a blank line for - ;; aesthetics. - (insert "\n") - (forward-char -1) - (ange-ftp-real-dired-insert-headerline dir)) - -(or (assq 'cms ange-ftp-dired-insert-headerline-alist) - (setq ange-ftp-dired-insert-headerline-alist - (cons '(cms . ange-ftp-dired-cms-insert-headerline) - ange-ftp-dired-insert-headerline-alist))) - -(defun ange-ftp-dired-cms-move-to-filename (&optional raise-error eol) - "In dired, move to the first char of filename on this line." - ;; This is the CMS version. - (or eol (setq eol (progn (end-of-line) (point)))) - (let (case-fold-search) - (beginning-of-line) - (if (re-search-forward " [-A-Z0-9$_]+ +[-A-Z0-9$_]+ +[VF] +[0-9]+ " eol t) - (goto-char (1+ (match-beginning 0))) - (if raise-error - (error "No file on this line") - nil)))) - -(or (assq 'cms ange-ftp-dired-move-to-filename-alist) - (setq ange-ftp-dired-move-to-filename-alist - (cons '(cms . ange-ftp-dired-cms-move-to-filename) - ange-ftp-dired-move-to-filename-alist))) - -(defun ange-ftp-dired-cms-move-to-end-of-filename (&optional no-error eol) - ;; Assumes point is at beginning of filename. - ;; So, it should be called only after (dired-move-to-filename t). - ;; case-fold-search must be nil, at least for VMS. - ;; On failure, signals an error or returns nil. - ;; This is the CMS version. - (let ((opoint (point)) - case-fold-search hidden) - (or eol (setq eol (save-excursion (end-of-line) (point)))) - (setq hidden (and selective-display - (save-excursion - (search-forward "\r" eol t)))) - (if hidden - (if no-error - nil - (error - (substitute-command-keys - "File line is hidden, type \\[dired-hide-subdir] to unhide"))) - (skip-chars-forward "-A-Z0-9$_" eol) - (skip-chars-forward " " eol) - (skip-chars-forward "-A-Z0-9$_" eol) - (if (eq opoint (point)) - (if no-error - nil - (error "No file on this line")) - (point))))) - -(or (assq 'cms ange-ftp-dired-move-to-end-of-filename-alist) - (setq ange-ftp-dired-move-to-end-of-filename-alist - (cons '(cms . ange-ftp-dired-cms-move-to-end-of-filename) - ange-ftp-dired-move-to-end-of-filename-alist))) - -(defun ange-ftp-cms-make-compressed-filename (name &optional reverse) - (if reverse - (if (string-match "-Z$" name) - (substring name 0 -2) - name) - (concat name "-Z"))) - -(or (assq 'cms ange-ftp-dired-compress-make-compressed-filename-alist) - (setq ange-ftp-dired-compress-make-compressed-filename-alist - (cons '(cms . ange-ftp-cms-make-compressed-filename) - ange-ftp-dired-compress-make-compressed-filename-alist))) - -(defun ange-ftp-dired-cms-get-filename (&optional localp no-error-if-not-filep) - (let ((name (ange-ftp-real-dired-get-filename localp no-error-if-not-filep))) - (and name - (if (string-match "^\\([^ ]+\\) +\\([^ ]+\\)$" name) - (concat (substring name 0 (match-end 1)) - "." - (substring name (match-beginning 2) (match-end 2))) - name)))) - -(or (assq 'cms ange-ftp-dired-get-filename-alist) - (setq ange-ftp-dired-get-filename-alist - (cons '(cms . ange-ftp-dired-cms-get-filename) - ange-ftp-dired-get-filename-alist))) - -;;;; ------------------------------------------------------------ -;;;; Finally provide package. -;;;; ------------------------------------------------------------ - -;; This is so that VC doesn't need to be hacked up. I think the fsf way is -;; a bit cleaner. (Forgive me, as I have sinned...) The great side-effect -;; of this change is that ange-ftp will now autoload...even w/o being fully -;; converted to use the filename-handler-alist. --Stig - -;; Turn off RCS/SCCS processing to save time. -;; This returns nil for any file name as argument. -(put 'vc-registered 'ange-ftp 'null) -^L -;;; Define ways of getting at unmodified Emacs primitives, -;;; turning off our handler. - -(defun ange-ftp-run-real-handler (operation args) - (let ((inhibit-file-name-handlers - (cons 'ange-ftp-hook-function - (cons 'ange-ftp-completion-hook-function - (and (eq inhibit-file-name-operation operation) - inhibit-file-name-handlers)))) - (inhibit-file-name-operation operation)) - (apply operation args))) - -;;;###autoload -(defun ange-ftp-hook-function (operation &rest args) - (let ((fn (get operation 'ange-ftp))) - (if fn (apply fn args) - (ange-ftp-run-real-handler operation args)))) - -;;;###autoload -(or (assoc (car ange-ftp-path-format) file-name-handler-alist) - (setq file-name-handler-alist - (cons (cons (car ange-ftp-path-format) 'ange-ftp-hook-function) - file-name-handler-alist))) - -;; ;;; This regexp recognizes and absolute filenames with only one component, -;; ;;; for the sake of hostname completion. -;; ;;;###autoload -;; (or (assoc "^/[^/:]*\\'" file-name-handler-alist) -;; (setq file-name-handler-alist -;; (cons '("^/[^/:]*\\'" . ange-ftp-completion-hook-function) -;; file-name-handler-alist))) - -(provide 'ange-ftp) diff -r b88636d63495 -r 8fc7fe29b841 lisp/dired/dired-cd.el --- a/lisp/dired/dired-cd.el Mon Aug 13 08:50:06 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,219 +0,0 @@ -;;; -*- Mode: Emacs-lisp -*- ;;; -;;; dired-cd.el - Adjust Working Directory for Tree Dired Shell Commands -;;; Id: dired-cd.el,v 1.14 1991/11/01 14:28:27 sk RelBeta -;;; Copyright (C) 1991 Hugh Secker-Walker -;;; -;;; Author: Hugh Secker-Walker hugh@ear-ache.mit.edu -;;; -;;; Modified by Sebastian Kremer -;;; -;;; 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 1, 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. -;;; -;;; A copy of the GNU General Public License can be obtained from this -;;; program's author (send electronic mail to the above address) or from -;;; Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -;; LISPDIR ENTRY for the Elisp Archive =============================== -;; LCD Archive Entry: -;; dired-cd|Hugh Secker-Walker|hugh@ear-ache.mit.edu -;; |Adjust Working Directory for Tree Dired Shell Commands -;; |Date: 1991/11/01 14:28:27 |Revision: 1.14 | - -;;; SUMMARY - -;;; This extension to Sebastian Kremer's (sk@thp.Uni-Koeln.DE) Tree-Dired -;;; permits the working directory of the dired shell commands -;;; dired-do-shell-command and dired-do-background-shell-command -;;; to be the files' subdirectory under certain circumstances. -;;; Loading this extension does not change the behavior of dired until -;;; the variables dired-cd-same-subdir and/or dired-cd-on-each are -;;; non-nil. - - -;;; FUNCTIONALITY PROVIDED - -;;; If dired-cd-same-subdir is non-nil and if all the selected files -;;; (marked, non-zero numeric ARG, etc.) are in the same directory, then -;;; dired-do-shell-command and dired-do-background-shell-command will -;;; cause the shell to perform a cd into that directory before the -;;; commands are executed. Also, the selected filenames will be provided -;;; to the command without any directory components. - -;;; If dired-cd-on-each is non-nil and if the on-each option is specified -;;; (numeric arg of zero), then dired-do-shell-command and -;;; dired-do-background-shell-command will perform a cd into the -;;; directory of each file before the commands on that file are executed. -;;; Also, each filename will be provided to the command without any -;;; directory components. Note that this on-each behavior occurs -;;; regardless of whether the files are all in the same directory or not. - -;;; After the above "cd wrapping" has occured, the existing -;;; dired-shell-stuff-it is used to do file-name substitution and -;;; quoting, so custom versions of this procedure should work, e.g. -;;; dired-trans will transform commands correctly. However, since -;;; filenames lack any directory components, features that use the -;;; directory components will fail, e.g. the dired-trans [d] transform -;;; specifier will be empty. - -;;; New variables (user options): -;;; dired-cd-same-subdir -;;; dired-cd-on-each -;;; -;;; Replaces procedures: -;;; dired-do-shell-command (new doc and prompt, calls dired-cd-wrap-it) -;;; -;;; Adds procedures: -;;; dired-cd-wrap-it (wraps calls to dired-shell-stuff-it with "cd ") -;;; dired-files-same-directory - - -;; INSTALLATION -;; -;; Put this file into your load-path and add (load "dired-cd") to -;; your dired-load-hook, e.g. -;; -;; (setq dired-load-hook '(lambda () -;; ;; possibly more statements here -;; (load "dired-cd"))) -;; -;; Do (setq dired-cd-same-subdir t) and perhaps (setq dired-cd-on-each t) -;; in your .emacs. By default, dired-cd doesn't change the behavior of -;; dired when it is loaded. -;; -;; If dired-cd-same-subdir is non-nil, then the shell commands cd to -;; the appropriate directory if all the selected files (marked, -;; numeric ARG, etc.) are in that directory; however, on-each behavior -;; is not changed. -;; -;; If dired-cd-on-each is non-nil, then each instance of the command -;; for an on-each shell command runs in the file's directory -;; regardless of whether the files are all in the same directory. - - -(defvar dired-cd-same-subdir nil - "*If non-nil, and selected file(s) (by marks, numeric arg, \\[universal-argument]) are in same -subdir, causes dired shell command to run in that subdir. Filenames provided -to shell commands are stripped of their directory components. Does not -affect behavior of on-each, for that see variable dired-cd-on-each.") - -(defvar dired-cd-on-each nil - "*If non-nil, on-each causes each dired shell command to run in the -file's directory. Filenames provided to shell commands are stripped of -their directory components. Also see variable dired-cd-same-subdir.") - -;; Redefines dired.el's version. -;; Changes to documentation and prompt, and uses dired-cd-wrap-it. -(defun dired-do-shell-command (&optional arg in-background) - "Run a shell command on the marked files. -If there is output, it goes to a separate buffer. -The list of marked files is appended to the command string unless asterisks - `*' indicate the place(s) where the list should go. -If no files are marked or a specific numeric prefix arg is given, uses - next ARG files. With a zero argument, run command on each marked file - separately: `cmd * foo' results in `cmd F1 foo; ...; cmd Fn foo'. - As always, a raw arg (\\[universal-argument]) means the current file. -The option variables dired-cd-same-subdir and dired-cd-on-each - permit the command\(s\) to run in the files' directories if appropriate, - and thus determine where output files are created. Default is top - directory. The prompt mentions the file(s) or the marker, the cd subdir, - and the on-each flags when they apply. -No automatic redisplay is attempted, as the file names may have - changed. Type \\[dired-do-redisplay] to redisplay the marked files." - ;; Function dired-shell-stuff-it (called by dired-cd-wrap-it) does the - ;; actual file-name substitution and can be redefined for customization. - (interactive "P") - (let* ((on-each (equal arg 0)) - (file-list (dired-mark-get-files t (if on-each nil arg))) - (prompt (concat (if in-background "& " "! ") - (if (or (and on-each dired-cd-on-each) - (and dired-cd-same-subdir - (not on-each) - (dired-files-same-directory file-list))) - "cd ; " "") - "on " - (if on-each "each " "") - "%s: ")) - ;; Give feedback on file(s) and working directory status - (command (dired-read-shell-command - prompt (if on-each nil arg) file-list)) - (result (dired-cd-wrap-it command file-list on-each arg))) - ;; execute the shell command - (dired-run-shell-command result in-background))) - -(defun dired-cd-wrap-it (command files on-each &optional raw) - "Args COMMAND FILES ON-EACH &optional RAW-ARG, like dired-shell-stuff-it. -Calls dired-shell-stuff-it, but wraps the resulting command\(s\) -with \"cd \" commands when appropriate. Note: when ON-EACH is non-nil, -dired-shell-stuff-it is called once for each file in FILES. -See documentation of variables dired-cd-same-subdir and dired-cd-on-each -for wrap conditions." - (if on-each;; command applied to each file separately - ;; cd's are done in subshells since all shells I know of have subshells - (let* ((cwd "");; current working directory - (in-subshell nil) - (cmd (mapconcat;; files over command, fuss with "cd " - (function - (lambda (file) - (let ((cd "") d);; cd command and file's directory - (if (not dired-cd-on-each) nil;; poor man's (when ...) - (setq d;; directory, relative to default-directory - (directory-file-name - (or (file-name-directory file) "")) - file (file-name-nondirectory file)) - (if (not (string= d cwd));; new subdir, new subshell - (setq cwd d - ;; close existing subshell, - ;; open a new one - cd (concat (if in-subshell "); " "") - "(cd " (shell-quote cwd) "; ") - in-subshell t)) - ) - ;; existing dired-shell-stuff-it does - ;; actual command substitution - (concat cd (dired-shell-stuff-it command (list file) - on-each raw))))) - files "; "))) - (if in-subshell (concat cmd ")") cmd));; close an open subshell - - ;; not on-each, all files are args to single command instance - (let ((same-dir (and dired-cd-same-subdir - (dired-files-same-directory files nil))) - (cd "")) - ;; Let the prepended cd command be relative to default-directory, - ;; and only give it if necessary. This way, after ange-ftp - ;; prepends its own cd command, it will still work. - ;; sk 3-Sep-1991 14:23 - ;; hsw 31-Oct-1991 -- filenames relative to default-directory - (if (and same-dir (not (equal same-dir ""))) - (setq files (mapcar (function file-name-nondirectory) files) - cd (concat "cd " (shell-quote same-dir) "; "))) - ;; existing dired-shell-stuff-it does the command substitution - (concat cd (dired-shell-stuff-it command files on-each raw))))) - -(defun dired-files-same-directory (file-list &optional absolute) - "If all files in LIST are in the same directory return it, otherwise nil. -Returned name has no trailing slash. \"Same\" means file-name-directory of -the files are string=. File names in LIST must all be absolute or all be -relative. Implicitly, relative file names are in default-directory. If -optional ABS is non-nil, the returned name will be absolute, otherwise the -returned name will be absolute or relative as per the files in LIST." - (let ((dir (file-name-directory (car file-list)))) - (if (memq nil (mapcar (function - (lambda (file) - (string= dir (file-name-directory file)))) - file-list)) - nil - (directory-file-name - (if (or (not absolute) (and dir (file-name-absolute-p dir))) - (or dir "") - (concat default-directory dir)))))) - -(provide 'dired-cd) diff -r b88636d63495 -r 8fc7fe29b841 lisp/dired/dired-chmod.el --- a/lisp/dired/dired-chmod.el Mon Aug 13 08:50:06 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,174 +0,0 @@ -;;; dired-chmod.el - interactive editing of file permissions in Dired listings. - -;;; Copyright (C) 1995 Russell Ritchie, - -;; Keywords: dired extensions, faces, interactive chmod - -;; This file is part of XEmacs. - -;; XEmacs 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 2, or (at your option) -;; any later version. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; To turn this on do: -;;; (require 'dired-chmod) -;;; (add-hook 'dired-after-readin-hook 'dired-permissions-highlight) - -(require 'dired) ; - -(defvar dired-permissions-regexp "[-r][-w][-Ssx][-r][-w][-sx][-r][-w][-xst]" - "Regexp matching the file permissions part of a dired line.") - -(defvar dired-pre-permissions-regexp "^. [0-9 ]*[-d]" - "Regexp matching the preamble to file permissions part of a dired line. -This shouldn't match socket or symbolic link lines (which aren't editable).") - -(or (find-face 'dired-face-permissions) - (and - (make-face 'dired-face-permissions) - (set-face-foreground 'dired-face-permissions '(color . "mediumorchid") - nil nil 'append) - (set-face-underline-p 'dired-face-permissions '((mono . t) - (grayscale . t)) nil - nil 'append))) - -(defun dired-activate-extent (extent keys fn) - (let ((keymap (make-sparse-keymap))) - (while keys - (define-key keymap (car keys) fn) - (setq keys (cdr keys))) - (set-extent-face extent 'dired-face-permissions) - (set-extent-property extent 'keymap keymap) - (set-extent-property extent 'highlight t) - (set-extent-property - extent 'help-echo - "Type rsStwx to set file permissions to taste interactively."))) - -(defun dired-chmod-do-chmod (state) - (let* ((file (dired-get-filename)) - (operation (concat "chmod" " " state " " file)) - (failure (apply (function dired-check-process) - operation "chmod" state (list file))) - (here (point))) - (dired-do-redisplay) - (goto-char (+ here 1)) - (dired-make-permissions-interactive) - (if failure - (dired-log-summary - (message "%s: error - type W to see why." operation))))) - -(defun dired-u-r () - (interactive) - (if (equal (event-key last-command-event) ?r) - (dired-chmod-do-chmod "u+r") - (dired-chmod-do-chmod "u-r"))) - -(defun dired-u-w () - (interactive) - (if (equal (event-key last-command-event) ?w) - (dired-chmod-do-chmod "u+w") - (dired-chmod-do-chmod "u-w"))) - -(defun dired-u-x () - (interactive) - (let ((key (event-key last-command-event))) - (cond ((equal key ?s) (dired-chmod-do-chmod "u+s")) - ((equal key ?S) (dired-chmod-do-chmod "u+S")) - ((equal key ?x) (dired-chmod-do-chmod "u+x")) - (t (dired-chmod-do-chmod (cond ((looking-at "s") "u-s") - ((looking-at "S") "u-S") - ((looking-at "x") "u-x") - (t "u-x"))))))) - -(defun dired-g-r () - (interactive) - (if (equal (event-key last-command-event) ?r) - (dired-chmod-do-chmod "g+r") - (dired-chmod-do-chmod "g-r"))) - -(defun dired-g-w () - (interactive) - (if (equal (event-key last-command-event) ?w) - (dired-chmod-do-chmod "g+w") - (dired-chmod-do-chmod "g-w"))) - -(defun dired-g-x () - (interactive) - (let ((key (event-key last-command-event))) - (cond ((equal key ?s) (dired-chmod-do-chmod "g+s")) - ((equal key ?x) (dired-chmod-do-chmod "g+x")) - (t (dired-chmod-do-chmod (if (looking-at "s") "g-s" "g-x")))))) - -(defun dired-o-r () - (interactive) - (if (equal (event-key last-command-event) ?r) - (dired-chmod-do-chmod "o+r") - (dired-chmod-do-chmod "o-r"))) - -(defun dired-o-w () - (interactive) - (if (equal (event-key last-command-event) ?w) - (dired-chmod-do-chmod "o+w") - (dired-chmod-do-chmod "o-w"))) - -(defun dired-o-x () - (interactive) - (let ((key (event-key last-command-event))) - (cond ((equal key ?s) (dired-chmod-do-chmod "o+s")) - ((equal key ?t) (dired-chmod-do-chmod "o+t")) - ((equal key ?x) (dired-chmod-do-chmod "o+x")) - (t (dired-chmod-do-chmod (cond ((looking-at "s") "o-s") - ((looking-at "t") "o-t") - ((looking-at "x") "o-x") - (t "o-x"))))))) - -;;;###autoload -(defun dired-make-permissions-interactive () - (save-excursion - (beginning-of-line 0) - (if (and (re-search-forward dired-pre-permissions-regexp (end-of-line) t) - (looking-at dired-permissions-regexp)) - (let* ((start (point)) - (u-r-extent (make-extent start (+ start 1))) - (u-w-extent (make-extent (+ start 1) (+ start 2))) - (u-x-extent (make-extent (+ start 2) (+ start 3))) - (g-r-extent (make-extent (+ start 3) (+ start 4))) - (g-w-extent (make-extent (+ start 4) (+ start 5))) - (g-x-extent (make-extent (+ start 5) (+ start 6))) - (o-r-extent (make-extent (+ start 6) (+ start 7))) - (o-w-extent (make-extent (+ start 7) (+ start 8))) - (o-x-extent (make-extent (+ start 8) (+ start 9)))) - (dired-activate-extent u-r-extent '(r space) 'dired-u-r) - (dired-activate-extent u-w-extent '(w space) 'dired-u-w) - (dired-activate-extent u-x-extent '(s S x space) 'dired-u-x) - (dired-activate-extent g-r-extent '(r space) 'dired-g-r) - (dired-activate-extent g-w-extent '(w space) 'dired-g-w) - (dired-activate-extent g-x-extent '(s x space) 'dired-g-x) - (dired-activate-extent o-r-extent '(r space) 'dired-o-r) - (dired-activate-extent o-w-extent '(w space) 'dired-o-w) - (dired-activate-extent o-x-extent '(s t x space) 'dired-o-x))))) - -(defun dired-permissions-highlight () - (message "Highlighting permissions...") - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (and (not (eolp)) - (dired-make-permissions-interactive)) - (forward-line 1)) - (message "Highlighting permissions...done"))) - -(provide 'dired-chmod) - -;; dired-chmod.el ends here. diff -r b88636d63495 -r 8fc7fe29b841 lisp/dired/dired-cwd.el --- a/lisp/dired/dired-cwd.el Mon Aug 13 08:50:06 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,86 +0,0 @@ -;;;; dired-cwd.el - Fix a command's current working directory in Tree Dired. - -(defconst dired-cwd-version (substring "!Revision: 1.2 !" 11 -2) - "!Id: dired-cwd.el,v 1.2 1991/10/08 15:31:28 sk RelBeta !") - -;; Copyright (C) 1991 by Sebastian Kremer - -;; 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 1, 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; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -;; LISPDIR ENTRY for the Elisp Archive =============================== -;; LCD Archive Entry: -;; dired-cwd|Sebastian Kremer|sk@thp.uni-koeln.de -;; |Fix a command's current working directory in Tree Dired. -;; |Date: 1991/10/08 15:31:28 |Revision: 1.2 | - -;; INSTALLATION ====================================================== -;; -;; Put this file into your load-path and the following in your ~/.emacs: -;; -;; (autoload 'dired-cwd-make-magic "dired-cwd") -;; -;; You have to load dired-x.el in your dired-load-hook to define -;; function default-directory, or you will not benefit from this -;; package: as long as function default-directory is not defined, the -;; functions wrapped by dired-cwd-make-magic will behave as before. - -;; EXAMPLE USAGE ====================================================== -;; -;; How to fix M-x compile (and grep) to know about Tree Dired's multiple -;; working directories by putting the following lines into your ~/.emacs: -;; -;; (require 'compile) -;; (dired-cwd-make-magic 'compile1) -;; -;; After that, a compilation or grep started in a subdirectory in a -;; Dired buffer will have that subdirectory as working directory. -;; -;; Note you must require 'compile as function compile1 is redefined. -;; You could use a load hook instead by adding the line -;; -;; (run-hooks 'compile-load-hook) -;; -;; at the end of compile.el and setting -;; -;; (setq compile-load-hook '(lambda () (dired-cwd-make-magic 'compile1))) -;; -;; in your ~/.emacs. - - -;;;###autoload -(defun dired-cwd-make-magic (function) - "Modify COMMAND so that it's working directory is the current dired directory. -This works by binding `default-directory' to `(default-directory)'s value. -See also function `default-directory'." - (interactive "aMake work with tree dired (function): ") - (if (commandp function) - (error "Cannot make interactive functions work for tree dired")) - (let ((save-name (intern (concat "dired-cwd-wrap-real-" (symbol-name - function)))) - new-function) - (setq new-function - (` (lambda (&rest dired-cwd-args) - ;; Name our formal args unique to avoid shadowing - ;; through dynamic scope. - (let ((default-directory - (if (fboundp 'default-directory) - ;; This is defined in dired-x.el, but dired - ;; may not yet be loaded. - (default-directory) - default-directory))) - (apply 'funcall (quote (, save-name)) dired-cwd-args))))) - (or (fboundp save-name) - (fset save-name (symbol-function function))) - (fset function new-function))) diff -r b88636d63495 -r 8fc7fe29b841 lisp/dired/dired-guess.el --- a/lisp/dired/dired-guess.el Mon Aug 13 08:50:06 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,121 +0,0 @@ -;;; -*- Mode: Emacs-lisp -*- ;;; -;;; dired-guess.el - In Dired, guess what shell command to apply. - -;;; Copyright (C) 1991, 1992 Gregory N. Shapiro -;;; -;;; Author: Gregory N. Shapiro gshapiro@wpi.wpi.edu -;;; -;;; 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 2, 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. -;;; -;;; A copy of the GNU General Public License can be obtained from this -;;; program's author (send electronic mail to the above address) or from -;;; Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - - -;;; This extension to Sebastian Kremer's (sk@thp.Uni-Koeln.DE) Tree-Dired -;;; permits dired to guess a shell command to use when the user performs -;;; a shell command on a single file. -;;; -;;; New variables (user options): -;;; dired-auto-shell-command-alist -;;; dired-auto-shell-use-last-extension -;;; dired-guess-have-gnutar -;;; -;;; Replaces procedures: -;;; dired-read-shell-command (new doc, calls dired-guess-shell-command) -;;; -;;; Adds procedures: -;;; dired-guess-shell-command (guesses command by comparing file extensions -;;; to dired-auto-shell-command-alist) - -;; LISPDIR ENTRY for the Elisp Archive =============================== -;; LCD Archive Entry: -;; dired-guess|Gregory N. Shapiro|gshapiro@wpi.wpi.edu -;; |Guess a Dired shell command from the filename. - -;; INSTALLATION -;; -;; Put this file into your load-path and add (load "dired-guess") to -;; your dired-load-hook, e.g. -;; -;; (setq dired-load-hook '(lambda () -;; ;; possibly more statements here -;; (load "dired-guess"))) -;; -;; Note: dired-guess must be loaded after dired-extra. -;; -;; If dired-auto-shell-use-last-extension is nil, all file extensions will -;; be used to determine the command to use. If nil, use all the -;; extensions. For example, foo.tar.Z would guess for the .tar.Z extension. -;; If non-nil, uses only the last extension of the filename. For example, -;; foo.tar.Z would use the guess for the .Z extension. -;; -;; Set dired-guess-have-gnutar to the name of the GNU tar file (defaults to -;; "gnutar"). Set to nil if you don't have GNU tar installed on your system. -;; GNU tar is available for anonymous ftp at prep.ai.mit.edu. - -(defvar dired-guess-have-gnutar "gnutar" - "*If non-nil, name of GNU tar (e.g. \"tar\" or \"gnutar\"). -GNU tar's `z' switch is used for compressed tar files. -If you don't have GNU tar, set this to nil: a pipe is then used.") - -(defvar dired-guess-tar (or dired-guess-have-gnutar "tar")) - -(defvar dired-auto-shell-command-alist - (list - '(".Z" . "uncompress") - '(".Z.uu" . "uudecode * | uncompress") - '(".uu" . "uudecode") - '(".hqx" . "mcvert") - '(".sh" . "sh") - '(".shar" . "unshar") - (cons ".tar" (concat dired-guess-tar " xvf")) - (cons ".tar.Z" (if dired-guess-have-gnutar - (concat dired-guess-tar " xvfz") - (concat "zcat * | " dired-guess-tar " xvf -"))) - (cons ".tar.Z.uu" (if dired-guess-have-gnutar - (concat "uudecode * | " dired-guess-tar " xvfz -") - "uudecode * | zcat | tar xvf -"))) - - "*Alist of file extensions and their suggested commands. -See also variable `dired-auto-shell-use-last-extension'.") - -(defvar dired-auto-shell-use-last-extension nil - "*If non-nil, uses only the last extension of the filename. - For example, foo.tar.Z would use the guess for the .Z extension. -If nil, use all the extensions. For example, foo.tar.Z would guess - for the .tar.Z extension.") - -(defun dired-read-shell-command (prompt arg files) - "Read a dired shell command using generic minibuffer history. -This command tries to guess a command from the filename(s) -from the variable `dired-auto-shell-command-alist' (which see)." - (dired-mark-pop-up - nil 'shell files ; bufname type files - 'dired-guess-shell-command ; function &rest args - (format prompt (dired-mark-prompt arg files)) files)) - - -(defun dired-guess-shell-command (prompt files) - ;;"Ask user with PROMPT for a shell command, guessing a default from FILES." - (let ((defalt (if (cdr files) - nil ; If more than one file, don't guess - (cdr (assoc - (substring (car files) ; Separate extension & lookup - (if dired-auto-shell-use-last-extension - (string-match "\.[^.]*$" (car files)) - (string-match "\\." (car files)))) - dired-auto-shell-command-alist))))) - (if (not (featurep 'gmhist)) - (read-string prompt defalt) - (if defalt - (put 'dired-shell-command-history 'default defalt))) - (read-with-history-in 'dired-shell-command-history prompt))) diff -r b88636d63495 -r 8fc7fe29b841 lisp/dired/dired-link.el --- a/lisp/dired/dired-link.el Mon Aug 13 08:50:06 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,135 +0,0 @@ -;;!emacs -;; -;; FILE: dired-link.el -;; SUMMARY: Properly resolves UNIX (and Apollo variant) links under dired. -;; Works for both classic dired (V18) and tree dired (V19). -;; -;; AUTHOR: Bob Weiner -;; -;; ORIG-DATE: 09-May-89 -;; LAST-MOD: 30-Aug-92 at 19:15:57 by Bob Weiner -;; -;; Copyright (C) 1989, 1991, 1992, Free Software Foundation, Inc. -;; Available for use and distribution under the same terms as GNU Emacs. -;; -;; This file is part of InfoDock. -;; -;; DESCRIPTION: -;; -;; This library is used in conjunction with the Emacs dired facility. -;; To install it, simply load this file or create a -;; dired hook which loads this file. Then use {M-x dired RTN} -;; or {C-x C-f RTN} as one normally would. -;; -;; The changes below to 'dired-noselect' assume UNIX shell file -;; abbreviation and UNIX file name conventions. -;; -;; This modified version of the 'dired-noselect' function automatically -;; resolves all recursive links properly and edits the final directory that -;; a link points to, called the link referent. It handles Apollo-isms such -;; as /usr/local -> $(SERVER_LOCAL)/usr/local, /usr/bin -> -;; ../$(SYSTYPE)/usr/bin and /tmp -> `node_data/tmp. It also handles -;; relative links properly as in /usr/local/emacs -> gnu/emacs which must -;; be resolved relative to the '/usr/local' directory. -;; -;; DESCRIP-END. - -;; ************************************************************************ -;; Internal functions -;; ************************************************************************ - -;; Normally, if one performs a dired multiple times on a directory which is a -;; link, a new buffer will be created each time. This is due to the fact -;; that 'dired-find-buffer' is called in 'dired-noselect' before the link is -;; resolved. The following code solves this problem by checking for a -;; previously existing buffer that is performing dired on the directory that -;; the link resolves to. This is also done recursively. If one is found, -;; the dired buffer that shows the link is killed and the previously existing -;; one is used and re-read in. - -(defun dired-link-noselect-classic (dirname) - "Like M-x dired but returns the dired buffer as value, does not select it." - (or dirname (setq dirname default-directory)) - (setq dirname (dired-link-referent (directory-file-name dirname))) - (if (equal dirname "") - nil - (if (= (aref dirname 0) ?~) (setq dirname (expand-file-name dirname))) - (if (file-directory-p dirname) - (setq dirname (file-name-as-directory dirname))) - (let ((buffer (dired-find-buffer dirname))) - (set-buffer buffer) - (dired-readin dirname buffer) - (dired-move-to-filename) - (dired-mode dirname) - buffer))) - -(defun dired-link-noselect-tree (dirname &optional switches) - "Like `dired' but returns the dired buffer as value, does not select it." - (or dirname (setq dirname default-directory)) - (setq dirname (expand-file-name - (dired-link-referent (directory-file-name dirname)))) - (if (file-directory-p dirname) - (setq dirname (file-name-as-directory dirname))) - (dired-internal-noselect dirname switches)) - -;; Overload as appropriate for Classic (V18) or Tree Dired -(fset 'dired-noselect (if (fboundp 'dired-internal-noselect) - 'dired-link-noselect-tree - 'dired-link-noselect-classic)) - -;; -;; Resolves all UNIX links. -;; Works with Apollo's variant and other strange links. Will fail on -;; Apollos if the '../' notation is used to move just above the '/' -;; directory level. This is fairly uncommon and so the problem has not been -;; fixed. -;;; -(defun dired-link-referent (linkname) - "Returns expanded file or directory referent of LINKNAME. -LINKNAME should not end with a directory delimiter. -If LINKNAME is not a string, returns nil. -If LINKNAME is not a link, it is simply expanded and returned." - (if (not (stringp linkname)) - nil - (let ((referent)) - (while (setq referent (file-symlink-p linkname)) - (setq linkname (dired-link-expand - referent (file-name-directory linkname))))) - (dired-link-expand linkname (file-name-directory linkname)))) - -(defun dired-link-expand (referent dirname) - "Expands REFERENT relative to DIRNAME and returns." - (let ((var-link) - (dir dirname)) - (while (string-match "\\$(\\([^\)]*\\))" referent) - (setq var-link (getenv (substring referent (match-beginning 1) - (match-end 1))) - referent (concat (substring referent 0 (match-beginning 0)) - var-link - (substring referent (match-end 0))))) - ;; If referent is not an absolute path - (let ((nd-abbrev (string-match "`node_data" referent))) - (if (and nd-abbrev (= nd-abbrev 0)) - (setq referent (concat - ;; Prepend node name given in dirname, if any - (and (string-match "^//[^/]+" dirname) - (substring dirname 0 (match-end 0))) - "/sys/" (substring referent 1))))) - (while (string-match "\\.\\." referent) - ;; Match to "//.." or "/.." at the start of link referent - (while (string-match "^\\(//\\.\\.\\|/\\.\\.\\)\\(/\\|$\\)" referent) - (setq referent (substring referent (match-end 1)))) - ;; Match to "../" or ".." at the start of link referent - (while (string-match "^\\.\\.\\(/\\|$\\)" referent) - (setq dir (file-name-directory (directory-file-name dir)) - referent (concat dir (substring referent (match-end 0))))) - ;; Match to rest of "../" in link referent - (while (string-match "[^/]+/\\.\\./" referent) - (setq referent (concat (substring referent 0 (match-beginning 0)) - (substring referent (match-end 0)))))) - (and (/= (aref referent 0) ?~) - (/= (aref referent 0) ?/) - (setq referent (concat dirname referent)))) - referent) - -(provide 'dired-link) diff -r b88636d63495 -r 8fc7fe29b841 lisp/dired/dired-lisp.el --- a/lisp/dired/dired-lisp.el Mon Aug 13 08:50:06 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,285 +0,0 @@ -;;;; dired-lisp.el - emulate Tree Dired's ls completely in Emacs Lisp - -;;;; READ THE WARNING BELOW BEFORE USING THIS PROGRAM! - -(defconst dired-lisp-version (substring "!Revision: 1.8 !" 11 -2) - "!Id: dired-lisp.el,v 1.8 1992/05/01 17:50:56 sk Exp !") - -;; Copyright (C) 1992 by Sebastian Kremer - -;; 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 1, 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; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -;; LISPDIR ENTRY for the Elisp Archive =============================== -;; LCD Archive Entry: -;; dired-lisp|Sebastian Kremer|sk@thp.uni-koeln.de -;; |emulate Tree Dired's ls completely in Emacs Lisp -;; |Date: 1992/05/01 17:50:56 |Revision: 1.8 | - -;; INSTALLATION ======================================================= -;; -;; Put this file into your load-path. Loading it will result in -;; redefining function dired-ls to not call ls. - -;; You need tree dired from ftp.cs.buffalo.edu:pub/Emacs/diredall.tar.Z, -;; classic (e.g. 18.57) dired.el will not work. - -;; OVERVIEW =========================================================== - -;; This file overloads tree dired so that all fileinfo is retrieved -;; directly from Emacs lisp, without using an ls subprocess. - -;; Useful if you cannot afford to fork Emacs on a real memory UNIX, -;; under VMS, or if you don't have the ls program, or if you want -;; different format from what ls offers. - -;; Beware that if you change the output format of dired-ls, you'll -;; have to change dired-move-to-filename and -;; dired-move-to-end-of-filename as well. - -;; With this package is loaded, dired uses regexps instead of shell -;; wildcards. If you enter regexps remember to double each $ sign. -;; For example, to dired all elisp (*.el) files, enter `.*\.el$$', -;; resulting in the regexp `.*\.el$'. - -;; WARNING =========================================================== - -;; With earlier version of this program I sometimes got an internal -;; Emacs error: - -;; Signalling: (wrong-type-argument natnump #) - -;; The datatype differs (I also got #o67 once). - -;; Sometimes emacs just crashed with a fatal error. - -;; After I've avoided using directory-files and file-attributes -;; together inside a mapcar, the bug didn't surface any longer. - -;; RESTRICTIONS ===================================================== - -;; * many ls switches are ignored, see docstring of `dired-ls'. - -;; * In Emacs 18: cannot display date of file, displays a fake date -;; "Jan 00 00:00" instead (dates do work in Emacs 19) - -;; * Only numeric uid/gid - -;; * if you load dired-lisp after ange-ftp, remote listings look -;; really strange: -;; -;; total 1 -;; d????????? -1 -1 -1 -1 Jan 1 1970 . -;; d????????? -1 -1 -1 -1 Jan 1 1970 .. -;; -;; This is because ange-ftp's file-attributes does not return much -;; useful information. -;; -;; If you load dired-lisp first, there seem to be no problems. - -;; TODO ============================================================== - -;; Recognize some more ls switches: R F - - -(require 'dired) ; we will redefine dired-ls: -(or (fboundp 'dired-lisp-unix-ls) - (fset 'dired-lisp-unix-ls (symbol-function 'dired-ls))) - -(fset 'dired-ls 'dired-lisp-ls) - -(defun dired-lisp-ls (file &optional switches wildcard full-directory-p) - "dired-lisp.el's version of dired-ls. -Known switches: A a S r i s t -In Emacs 19, additional known switches are: c u -Others are ignored. - - Insert ls output of FILE, optionally formatted with SWITCHES. -Optional third arg WILDCARD means treat non-directory part of FILE as -emacs regexp (_not_ a shell wildcard). If you enter regexps remember -to double each $ sign. - -Optional fourth arg FULL-DIRECTORY-P means file is a directory and -switches do not contain `d'. - -SWITCHES default to dired-listing-switches." - (or switches (setq switches dired-listing-switches)) - (or (consp switches) ; convert to list of chars - (setq switches (mapcar 'identity switches))) - (if wildcard - (setq wildcard (file-name-nondirectory file) ; actually emacs regexp - ;; perhaps convert it from shell to emacs syntax? - file (file-name-directory file))) - (if (or wildcard - full-directory-p) - (let* ((dir (file-name-as-directory file)) - (default-directory dir);; so that file-attributes works - (sum 0) - elt - (file-list (directory-files dir nil wildcard)) - file-alist - ;; do all bindings here for speed - fil attr) - (cond ((memq ?A switches) - (setq file-list - (dired-lisp-delete-matching "^\\.\\.?$" file-list))) - ((not (memq ?a switches)) - ;; if neither -A nor -a, flush . files - (setq file-list - (dired-lisp-delete-matching "^\\." file-list)))) - (setq file-alist - (mapcar - (function - (lambda (x) - ;; file-attributes("~bogus") bombs - (cons x (file-attributes (expand-file-name x))))) - ;; inserting the call to directory-files right here - ;; seems to stimulate an Emacs bug - ;; ILLEGAL DATATYPE (#o37777777727) or #o67 - file-list)) - (insert "total \007\n") ; filled in afterwards - (setq file-alist - (dired-lisp-handle-switches file-alist switches)) - (while file-alist - (setq elt (car file-alist) - short (car elt) - attr (cdr elt) - file-alist (cdr file-alist) - fil (concat dir short) - sum (+ sum (nth 7 attr))) - (insert (dired-lisp-format short attr switches))) - ;; Fill in total size of all files: - (save-excursion - (search-backward "total \007") - (goto-char (match-end 0)) - (delete-char -1) - (insert (format "%d" (1+ (/ sum 1024)))))) - ;; if not full-directory-p, FILE *must not* end in /, as - ;; file-attributes will not recognize a symlink to a directory - ;; must make it a relative filename as ls does: - (setq file (file-name-nondirectory file)) - (insert (dired-lisp-format file (file-attributes file) switches)))) - -(defun dired-lisp-delete-matching (regexp list) - ;; Delete all elements matching REGEXP from LIST, return new list. - ;; Should perhaps use setcdr for efficiency. - (let (result) - (while list - (or (string-match regexp (car list)) - (setq result (cons (car list) result))) - (setq list (cdr list))) - result)) - -(defun dired-lisp-handle-switches (file-alist switches) - ;; FILE-ALIST's elements are (FILE . FILE-ATTRIBUTES). - ;; Return new alist sorted according to SWITCHES which is a list of - ;; characters. Default sorting is alphabetically. - (let (index) - (setq file-alist - (sort file-alist - (cond ((memq ?S switches) ; sorted on size - (function - (lambda (x y) - ;; 7th file attribute is file size - ;; Make largest file come first - (< (nth 7 (cdr y)) - (nth 7 (cdr x)))))) - ((memq ?t switches) ; sorted on time - (setq index (dired-lisp-time-index switches)) - (function - (lambda (x y) - (time-lessp (nth index (cdr y)) - (nth index (cdr x)))))) - (t ; sorted alphabetically - (function - (lambda (x y) - (string-lessp (car x) - (car y))))))))) - (if (memq ?r switches) ; reverse sort order - (setq file-alist (nreverse file-alist))) - file-alist) - -;; From Roland McGrath. Can use this to sort on time. -(defun time-lessp (time0 time1) - (let ((hi0 (car time0)) - (hi1 (car time1)) - (lo0 (car (cdr time0))) - (lo1 (car (cdr time1)))) - (or (< hi0 hi1) - (and (= hi0 hi1) - (< lo0 lo1))))) - - -(defun dired-lisp-format (file-name file-attr &optional switches) - (let ((file-type (nth 0 file-attr))) - (concat (if (memq ?i switches) ; inode number - (format "%6d " (nth 10 file-attr))) - ;; nil is treated like "" in concat - (if (memq ?s switches) ; size in K - (format "%4d " (1+ (/ (nth 7 file-attr) 1024)))) - (nth 8 file-attr) ; permission bits - ;; numeric uid/gid are more confusing than helpful - ;; Emacs should be able to make strings of them. - ;; user-login-name and user-full-name could take an - ;; optional arg. - (format " %3d %-8d %-8d %8d " - (nth 1 file-attr) ; no. of links - (nth 2 file-attr) ; uid - (nth 3 file-attr) ; gid - (nth 7 file-attr) ; size in bytes - ) - (dired-lisp-format-time file-attr switches) - " " - file-name - (if (stringp file-type) ; is a symbolic link - (concat " -> " file-type) - "") - "\n" - ))) - -(defun dired-lisp-time-index (switches) - ;; Return index into file-attributes according to ls SWITCHES. - (cond - ((memq ?c switches) 6) ; last mode change - ((memq ?u switches) 4) ; last access - ;; default is last modtime - (t 5))) - -(defun dired-lisp-format-time (file-attr switches) - ;; Format time string for file with attributes FILE-ATTR according - ;; to SWITCHES (a list of ls option letters of which c and u are recognized). - ;; file-attributes's time is in a braindead format - ;; Emacs 19 can format it using a new optional argument to - ;; current-time-string, for Emacs 18 we just return the faked fixed - ;; date "Jan 00 00:00 ". - (condition-case error-data - (let* ((time (current-time-string - (nth (dired-lisp-time-index switches) file-attr))) - (date (substring time 4 11)) ; "Apr 30 " - (clock (substring time 11 16)) ; "11:27" - (year (substring time 19 24)) ; " 1992" - (same-year (equal year (substring (current-time-string) 19 24)))) - (concat date ; has trailing SPC - (if same-year - ;; this is not exactly the same test used by ls - ;; ls tests if the file is older than 6 months - ;; but we can't do time differences easily - clock - year))) - (error - "Jan 00 00:00"))) - -(provide 'dired-lisp) diff -r b88636d63495 -r 8fc7fe29b841 lisp/dired/dired-nstd.el --- a/lisp/dired/dired-nstd.el Mon Aug 13 08:50:06 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,438 +0,0 @@ -;;; -*- Mode:Emacs-Lisp -*- -;;; Jamie Zawinski 7-may-91 -;;; -;;; This makes dired buffers which display multiple directories display -;;; them in a tree rather than in an "ls -R"-like format. Which, as every -;;; Lisp Machine hacker knows, is the Right Thing! -;;; -;;; -rw-r--r-- 1 jwz 31543 Mar 26 03:20 reportmail.el -;;; -rw-r--r-- 1 jwz 14919 Mar 26 03:20 reportmail.elc -;;; drwxr-xr-x 2 jwz 1024 Apr 5 13:08 sk-dired/ -;;; -rw-r--r-- 1 jwz 3258 Mar 6 06:33 ange-ftp-dired.el -;;; -rw-r--r-- 1 jwz 1750 Mar 12 15:04 ange-ftp-dired.elc -;;; -rw-r--r-- 1 jwz 3151 Mar 29 00:01 symbol-syntax.el -;;; -rw-r--r-- 1 jwz 1504 Mar 29 01:01 symbol-syntax.elc - -;;; 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 2, 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. -;;; -;;; A copy of the GNU General Public License can be obtained from this -;;; program's author (send electronic mail to the above address) or from -;;; Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(defconst dired-subdir-alist nil - "Association list of subdirectories and their buffer positions: - - ((LASTDIR STARTMARKER ENDMARKER NESTING-DEPTH) - ... - (DEFAULT-DIRECTORY POINTMIN POINTMAX 0)). -" -;;The markers point right at the end of the line, so that the cursor -;;looks at either \\n or \\r, the latter for a hidden subdir. -;; The directories must be file-name-as-directory, of course. -) - -(defun dired-simple-subdir-alist () - ;; Build and return `dired-subdir-alist' assuming just the top level - ;; directory to be inserted. Don't parse the buffer. - (set (make-local-variable 'dired-subdir-alist) - (list (list default-directory - (point-min-marker) (point-max-marker) 0)))) - -(define-key dired-mode-map "i" 'dired-insert-subdir-inline) -(define-key dired-mode-map "j" 'dired-maybe-insert-subdir) - -;;; ## these should be macros when this is integrated with the distribution. -(defun dired-get-subdir-min (elt) (nth 1 elt)) -(defun dired-get-subdir-max (elt) (nth 2 elt)) - -(defun dired-subdir-min () - (let ((d (dired-current-directory)) - c) - (if (setq c (assoc d dired-subdir-alist)) - (marker-position (dired-get-subdir-min c)) - (error "not in a subdir!")))) - -(defun dired-subdir-max () - (let ((d (dired-current-directory)) - c) - (if (setq c (assoc d dired-subdir-alist)) - (marker-position (dired-get-subdir-max c)) - (point-max)))) - -(defun dired-clear-alist () - (while dired-subdir-alist - (let ((elt (car dired-subdir-alist))) - (set-marker (nth 1 elt) nil) - (set-marker (nth 2 elt) nil)) - (setq dired-subdir-alist (cdr dired-subdir-alist)))) - -(defun dired-unsubdir (dir) - ;; Remove DIR from the alist. - ;; also remove any directories which are inside of it. - (let* ((elt (assoc dir dired-subdir-alist)) - (min (nth 1 elt)) - (max (nth 2 elt)) - other-elt - (rest dired-subdir-alist)) - (while rest - (setq other-elt (car rest)) - (if (and (<= min (nth 1 other-elt)) - (>= max (nth 2 other-elt))) - (setq dired-subdir-alist (delq other-elt dired-subdir-alist))) - (setq rest (cdr rest))))) - -;;; this needs to be changed to grok indentation. Or not. -jwz -;;; Probably not, as dired-revert either starts with one dir and inserting -;;; then enlarges the alist automatically, or it inserts all dirs with -;;; one "ls -lR". -sk -(defun dired-build-subdir-alist () - "Build dired-subdir-alist by parsing the buffer and return it's new value." - (interactive) - (dired-clear-alist) - (save-excursion - (let ((count 0)) - (goto-char (point-min)) - (setq dired-subdir-alist nil) - (while (re-search-forward dired-subdir-regexp nil t) - (setq count (1+ count)) - (dired-alist-add (buffer-substring (match-beginning 1) - (match-end 1)) - ;; Put subdir boundary between lines: - (save-excursion - (goto-char (match-beginning 0)) - (beginning-of-line) - (point-marker)) - ;; isn't this wrong when already more than one - ;; subdir is present with -lR? - ;; maybe. I don't know. But we can't call - ;; dired-subdir-max here, it loops. -jwz. - (point-max-marker) - 0) - (message "%d" count)) - (message "%d director%s." count (if (= 1 count) "y" "ies")) - ;; return new alist: - dired-subdir-alist))) - -(defun dired-alist-add (dir start-marker end-marker indentation-depth) - ;; indentation-depth may be 0 for more than one directory -- this happens - ;; when "ls -R" format is used. - ;; ## debugging code - (or start-marker (error "start marker nil")) - (or end-marker (error "end marker nil")) - ;;(or (/= start-marker end-marker) (error "markers are the same")) - (let ((old (assoc dir dired-subdir-alist))) - (setq dired-subdir-alist - (cons (list (dired-normalize-subdir dir) - start-marker end-marker - (or indentation-depth 0)) - (delq old dired-subdir-alist))) - (dired-alist-sort))) - -;; can't see at the moment how this could work with a mixed format -;; alist -sk -(defun dired-current-directory (&optional relative) - "Get the subdirectory to which this line belongs. -This returns a string with trailing slash, like default-directory. -Optional argument means return a name relative to default-directory." - (let (elt - (here (point)) - (alist (or dired-subdir-alist (dired-build-subdir-alist))) - best-so-far) - (while alist - (setq elt (car alist)) - (if (or (< here (nth 1 elt)) - (> here (nth 2 elt))) - nil ;; the subdir is disjoint - ;; otherwise it's on the path between the current file and the root. - ;; decide if it's deeper than what we've already got. - (if (or (null best-so-far) - (< (- (nth 2 elt) (nth 1 elt)) - (- (nth 2 best-so-far) (nth 1 best-so-far)))) - (setq best-so-far elt))) - (setq alist (cdr alist))) - (if best-so-far - (if relative - (dired-make-relative (car best-so-far) default-directory) - (car best-so-far)) - (progn - (dired-build-subdir-alist) - (dired-current-directory relative))))) - -(defun dired-insert-subdir-del (element) - ;; Erase an already present subdir (given by ELEMENT) from buffer. - ;; Move to that buffer position. Return a mark-alist. - (let ((begin-marker (dired-get-subdir-min element)) - (end-marker (dired-get-subdir-max element))) - (goto-char end-marker) - (or (eobp) - (not (= 0 (nth 3 element))) - ;; for -R style, want a separating newline _between_ subdirs. - (forward-char -1)) - (if (= 0 (nth 3 element)) - (insert "\n\n")) - (prog1 - (dired-remember-marks begin-marker (point)) - (delete-region begin-marker (point))))) - - -(defun dired-insert-subdir-doupdate (dirname elt beg-end) - (let ((beg (nth 0 beg-end)) - (end (nth 1 beg-end)) - (indent (or (nth 2 beg-end) 0))) - (if (and elt - (not (eq indent (nth 2 elt)))) - (setq elt nil - dired-subdir-alist (delq elt dired-subdir-alist))) - (if elt - (let ((old-start (nth 1 elt)) - (old-end (nth 2 elt))) - (set-marker old-start beg) - (set-marker old-end end) - (setcar (nthcdr 3 elt) indent)) - (dired-alist-add dirname - (set-marker (make-marker) beg) - (set-marker (make-marker) end) - indent)))) - -(defun dired-insert-subdir-inline (dirname &optional switches no-error-if-not-dir-p) - "Insert this subdirectory into the same dired buffer. -If it is already present, overwrites previous entry, - else inserts it, indented, within its parent's listing. -With a prefix arg, you may edit the ls switches used for this listing. - This command ignores the `R' switch." - ;; NO-ERROR-IF-NOT-DIR-P needed for special filesystems like - ;; Prospero where dired-ls does the right thing, but - ;; file-directory-p has not been redefined. - (interactive - (list (dired-get-filename) - (if current-prefix-arg - (read-string "Switches for listing: " dired-actual-switches)))) - (setq dirname (file-name-as-directory (expand-file-name dirname))) - (if (let ((case-fold-search nil)) - (string-match "R" (or switches ""))) - (setq switches (concat (substring switches 0 (match-beginning 0)) - (substring switches (match-end 0))))) - (dired-make-relative dirname default-directory) ; error on failure - (or no-error-if-not-dir-p - (file-directory-p dirname) - (error "Attempt to insert a non-directory: %s" dirname)) - (let ((elt (assoc dirname dired-subdir-alist)) - (parentdir (file-name-directory (directory-file-name dirname))) - beg end old-start old-end new-start new-end - mark-alist - tail-adjascents - buffer-read-only case-fold-search) - (if elt - ;; subdir is already present - must first erase it from buffer. - ;; if it's already in -R format, pretend it wasn't there, but - ;; remember its file marks. - (progn - (setq mark-alist - (append (dired-insert-subdir-del elt) mark-alist)) - (setq dired-subdir-alist - (delq elt dired-subdir-alist)))) - ;;(dired-insert-subdir-newpos) ;## - (dired-goto-file dirname) - (forward-line 1) - (dired-insert-subdir-doupdate - dirname elt (dired-insert-subdir-inline-doinsert dirname switches parentdir)) - (dired-initial-position dirname) - (save-excursion (dired-mark-remembered mark-alist))) - (dired-nuke-extra-newlines) - ) - - -(defun dired-insert-subdir (dirname &optional switches no-error-if-not-dir-p) - "Insert this subdirectory into the same dired buffer. -If it is already present, overwrites previous entry, - else appends at end of buffer. -With a prefix arg, you may edit the ls switches used for this listing. - You can add `R' to the switches to expand the whole tree starting at - this subdirectory. -This function takes some pains to conform to ls -lR output." - ;; NO-ERROR-IF-NOT-DIR-P needed for special filesystems like - ;; Prospero where dired-ls does the right thing, but - ;; file-directory-p has not been redefined. - (interactive - (list (dired-get-filename) - (if current-prefix-arg - (read-string "Switches for listing: " dired-actual-switches)))) - (setq dirname (file-name-as-directory (expand-file-name dirname))) - (dired-make-relative dirname default-directory) ; error on failure - (or no-error-if-not-dir-p - (file-directory-p dirname) - (error "Attempt to insert a non-directory: %s" dirname)) - (let ((elt (assoc dirname dired-subdir-alist)) - (switches-have-R (and switches (string-match "R" switches))) - mark-alist - buffer-read-only case-fold-search) - (if switches-have-R ; avoid double subdirs - (setq mark-alist (dired-kill-tree dirname t))) - (let ((was-nested (and (nth 3 elt) (not (eq 0 (nth 3 elt)))))) - (if elt ; subdir is already present - (setq mark-alist ; remove it, remembering marks - (append (dired-insert-subdir-del elt) mark-alist))) - (if (or was-nested (null elt)) - (dired-insert-subdir-newpos dirname)) - (if was-nested (setcar (nthcdr 3 elt) 0))) - (dired-insert-subdir-doupdate - dirname elt (dired-insert-subdir-doinsert dirname switches)) - (if switches-have-R (dired-build-subdir-alist)) - (dired-initial-position dirname) - (save-excursion (dired-mark-remembered mark-alist))) - (dired-nuke-extra-newlines)) - -(defun dired-nuke-extra-newlines () - (let ((buffer-read-only nil)) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward "\n\n\n+" nil t) - (goto-char (+ 2 (match-beginning 0))) - (delete-region (point) (match-end 0)))))) - - -(defun dired-insert-subdir-newpos (new-dir) - ;; Find pos for new subdir, according to tree order. - ;;(goto-char (point-max)) - (let ((alist dired-subdir-alist) elt dir pos new-pos) - (while alist - (setq elt (car alist) - alist (cdr alist) - dir (car elt) - pos (dired-get-subdir-min elt)) - (if (and (= 0 (nth 3 elt)) ; nested ones don't count. - (dired-tree-lessp dir new-dir)) - ;; Insert NEW-DIR after DIR - (setq new-pos (dired-get-subdir-max elt) - alist nil))) - (goto-char new-pos)) - ;; want a separating newline between subdirs - (insert "\n\n") - (point)) - - -(defvar dired-no-inline-headerlines t - "*set this to t to suppress the directory header and `total' line.") - - -(defun dired-insert-subdir-inline-doinsert (dirname switches parentdir) - ;; Insert ls output after point and put point on the correct - ;; position for the subdir alist. - ;; returns the dired-subdir-alist entry. - (let ((begin (point)) end - indent - tail-adjascents) - (message "Reading directory %s..." dirname) - (dired-ls dirname - (or switches - (dired-replace-in-string "R" "" dired-actual-switches)) - nil t) - (message "Reading directory %s...done" dirname) - (setq end (point)) - (setq indent (1+ (nth 3 (assoc parentdir dired-subdir-alist)))) - - (save-excursion - (goto-char begin) - (or dired-no-inline-headerlines - (progn - (dired-insert-headerline dirname) - (save-excursion (delete-horizontal-space))) - (goto-char begin) - (delete-horizontal-space)) - (if (and dired-no-inline-headerlines - (looking-at "^ *total [0-9]")) - (progn - (delete-region (point) (progn (forward-line 1) (point))) - (setq begin (point))))) - ;; - ;; If there are other directories whose end-point is right here, - ;; then they are the directories such that X is the last directory - ;; in the listing of Y. We need to grab them and update their - ;; last-point to be the same as ours will be (goofy margin-case). - ;; - (let ((rest dired-subdir-alist)) - (while rest - (if (= (point) (nth 2 (car rest))) - (setq tail-adjascents (cons (car rest) tail-adjascents))) - (setq rest (cdr rest)))) - (let ((indent-tabs-mode nil)) - (indent-rigidly begin (point) (* 2 (1+ indent)))) - (setq end (point-marker)) - (goto-char begin) - (while tail-adjascents - (set-marker (nth 2 (car tail-adjascents)) end) - (setq tail-adjascents (cdr tail-adjascents))) - (if dired-after-readin-hook - (save-restriction - (narrow-to-region begin end) - (run-hooks 'dired-after-readin-hook))) - ;; call dired-insert-headerline afterwards, as under VMS dired-ls - ;; does insert the headerline itself and the insert function just - ;; moves point. - (setq end (prog1 (marker-position end) (set-marker end nil))) - (goto-char begin) - (list begin end indent))) - - -(defun dired-insert-subdir-doinsert (dirname switches) - ;; Insert ls output after point and put point on the correct - ;; position for the subdir alist. - ;; Return the boundary of the inserted text (as list of BEG and END). - (let ((begin (point)) end) - (message "Reading directory %s..." dirname) - (dired-ls dirname - (or switches - (dired-replace-in-string "R" "" dired-actual-switches)) - nil t) - (message "Reading directory %s...done" dirname) - (insert "\n\n") - (setq end (point-marker)) - (indent-rigidly begin (point) 2) - (if dired-after-readin-hook - (save-restriction - (narrow-to-region begin (point)) - (run-hooks 'dired-after-readin-hook))) - ;; call dired-insert-headerline afterwards, as under VMS dired-ls - ;; does insert the headerline itself and the insert function just - ;; moves point. - (goto-char begin) - (dired-insert-headerline dirname) - ;; point is now like in dired-build-subdir-alist - (setq end (prog1 (marker-position end) (set-marker end nil))) - (list begin end))) - - -(defun dired-insert-old-subdirs (old-subdir-alist) - ;; Try to insert all subdirs that were displayed before - (or (string-match "R" dired-actual-switches) - (let (elt dir) - (setq old-subdir-alist (sort old-subdir-alist - (function (lambda (x y) - (< (nth 3 x) (nth 3 y)))))) - (while old-subdir-alist - (setq elt (car old-subdir-alist) - old-subdir-alist (cdr old-subdir-alist) - dir (car elt)) - (condition-case () - (if (= 0 (nth 3 elt)) - (dired-insert-subdir dir) - (dired-insert-subdir-inline dir)) - (error nil)))))) - -(defun dired-add-entry-do-indentation (marker-char) - ;; two spaces or a marker plus a space, plus nesting indentation. - ;; Uses fluid vars `directory', `marker-char' from dired-add-entry - (insert (if marker-char - (if (integerp marker-char) marker-char dired-marker-char) - ?\040) - ?\040) - (let ((indent (nth 3 (assoc directory dired-subdir-alist)))) - (insert (make-string (* 2 indent) ?\040)))) diff -r b88636d63495 -r 8fc7fe29b841 lisp/dired/dired-num.el --- a/lisp/dired/dired-num.el Mon Aug 13 08:50:06 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,123 +0,0 @@ -;;;; dired-num.el - Renaming with numbers in Tree Dired. - -(defconst dired-num-version (substring "!Revision: 1.2 !" 11 -2) - "Id: dired-num.el,v 1.2 1991/10/15 13:24:10 sk RelBeta ") - -;; Copyright (C) 1991 by Sebastian Kremer - -;; 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 1, 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; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -;; LISPDIR ENTRY for the Elisp Archive =============================== -;; LCD Archive Entry: -;; dired-num|Sebastian Kremer|sk@thp.uni-koeln.de -;; |Renaming with numbers in Tree Dired. -;; |Date: 1991/10/15 13:24:10 |Revision: 1.2 | - -;; INSTALLATION ====================================================== -;; -;; Put this file into your load-path and the following in your ~/.emacs: -;; -;; (autoload 'dired-do-rename-numeric "dired-num") -;; (autoload 'dired-do-rename-list "dired-num") -;; -;; Do -;; -;; (define-key dired-mode-map "%#" 'dired-do-rename-numeric) -;; (define-key dired-mode-map "%(" 'dired-do-rename-list) -;; -;; inside your dired-load-hook. - -(require 'dired);; we need its macros when being compiled - -(defun dired-number-of-marked-files (&optional arg) - ;; Return the number of marked files in a dired buffer. - ;; Optional ARG as in dired-mark-map. - (length - (save-excursion - ;; this returns a list of ``results'' (i.e. nil's): - (dired-mark-map nil arg)))) - -(defun dired-do-create-files-numeric (file-creator operation arg format start - &optional arg) - ;; Create a new file for each marked file using numbers. - ;; FILE-CREATOR and OPERATION as in dired-create-files. - ;; ARG as in dired-mark-get-files. - ;; FORMAT is a format string for use with an integer, assuming - ;; values starting from START, incremented for each marked file. - (let ((i (1- start)));; signals an error if START is not a number - (dired-create-files-non-directory - file-creator - (function (lambda (x) - (format format (setq i (1+ i))))) - operation arg))) - -;;;###autoload -(defun dired-do-rename-numeric (format start &optional arg) - "Rename all marked (or next ARG) files using numbers. -You are prompted for a format string, e.g \"part_%d_of_8\", and a starting -number, e.g. 1. If there are 8 marked files, this example will rename them to - - part_1_of_8 - part_2_of_8 - ... - part_8_of_8" - (interactive - (list - (read-string - (format "Rename numeric [%d files] (format string using %%d): " - (dired-number-of-marked-files current-prefix-arg))) - (read-minibuffer "Numbers start at: " "1") - current-prefix-arg)) - (dired-do-create-files-numeric - (function dired-rename-file) - "Rename-numeric" arg format start)) - -;; Copy etc. would be similar to implement. - - -(defun dired-do-create-files-list (file-creator operation arg format list - &optional arg) - ;; Create a new file for each marked file by subsituting elements - ;; from LIST in the format string FORMAT. - ;; FILE-CREATOR and OPERATION as in dired-create-files. - ;; ARG as in dired-mark-get-files. - (let ((rest list)) - (dired-create-files-non-directory - file-creator - (function (lambda (x) - (format format (prog1 - (car rest) - (setq rest (cdr rest)))))) - operation arg))) - -;;;###autoload -(defun dired-do-rename-list (format list &optional arg) - "Rename all marked (or next ARG) files using elements from LIST. -You are prompted for a format string, e.g \"x_%s\", and the list, -e.g. '(foo bar zod). This example will rename the marked files to - - x_foo - x_bar - x_zod - -It is an error if LIST has not as many elements as there are files." - (interactive "sRename list (format using %%s): \nxList: \nP") - (or (= (dired-number-of-marked-files arg) - (length list)) - (error "Must have as many elements as there are files to rename")) - (dired-do-create-files-list - (function dired-rename-file) - "Rename-list" arg format list)) - diff -r b88636d63495 -r 8fc7fe29b841 lisp/dired/dired-rcs.el --- a/lisp/dired/dired-rcs.el Mon Aug 13 08:50:06 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,196 +0,0 @@ -;;;; dired-rcs.el - RCS support for Tree Dired - -(defconst dired-rcs-version (substring "!Revision: 1.6 !" 11 -2) - "I don't speak RCS-ese") - -;; Originally written by Sebastian Kremer -;; Rewritten by Heiko Muenkel - -;; Copyright (C) 1991 by Sebastian Kremer -;; Copyright (C) 1994 by Heiko Muenkel - -;; 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 1, 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; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -;; INSTALLATION ====================================================== -;; -;; This will not work with classic (18.xx) Dired, you'll need Tree Dired, -;; available via anonymous ftp from -;; -;; ftp.thp.Uni-Koeln.DE[134.95.64.1]:/pub/gnu/emacs/diredall.tar.Z -;; -;; Put this file into your load-path and the following in your ~/.emacs: -;; -;; (autoload 'dired-rcs-mark-rcs-locked-files "dired-rcs") -;; (autoload 'dired-rcs-mark-rcs-files "dired-rcs") -;; -;; Put this inside your dired-load-hook: -;; -;; (define-key dired-mode-map "," 'dired-rcs-mark-rcs-files) -;; (define-key dired-mode-map "\M-," 'dired-rcs-mark-rcs-locked-files) -;; - -(require 'dired) - -;;;###autoload -(defun dired-rcs-mark-rcs-locked-files (&optional unflag-p) - "Mark all files that are under RCS control and RCS-locked. -With prefix argument, unflag all those files. -Mentions RCS files for which a working file was not found in this buffer. -Type \\[dired-why] to see them again." - (interactive "P") - (dired-rcs-mark-rcs-files unflag-p t)) - -;;;###autoload -(defun dired-rcs-mark-rcs-files (&optional unflag-p locked) - "Mark all files that are under RCS control. -With prefix argument, unflag all those files. -Mentions RCS files for which a working file was not found in this buffer. -Type \\[dired-why] to see them again." - ;; Returns list of failures, or nil on success. - ;; Optional arg LOCKED means just mark RCS-locked files. - (interactive "P") - (message "%s %sRCS controlled files..." - (if unflag-p "Unmarking" "Marking") - (if locked "locked " "")) - (let ((dired-marker-char (if unflag-p ?\ dired-marker-char)) - rcs-files wf failures count total) - ;; Loop over subdirs to set `rcs-files' - (mapcar - (function - (lambda (dir) - (or (equal (file-name-nondirectory (directory-file-name dir)) - "RCS") - ;; skip inserted RCS subdirs - (setq rcs-files - (append (if locked - ;; these two functions from sk's rcs.el - (rcs-locked-files dir) - (rcs-files dir)) - rcs-files))))) - (mapcar (function car) dired-subdir-alist)) - (setq total (length rcs-files)) - (while rcs-files - (setq wf (rcs-working-file (car rcs-files)) - rcs-files (cdr rcs-files)) - (save-excursion (if (dired-goto-file wf) - (dired-mark-file 1) - (dired-log "RCS working file not found: %s\n" wf) - (setq failures (cons (dired-make-relative wf) - failures))))) - (if (null failures) - (message "%d %sRCS file%s %smarked." - total - (if locked "locked " "") - (dired-plural-s total) - (if unflag-p "un" "")) - (setq count (length failures)) - (dired-log-summary "RCS working file not found %s" failures) - (message "%d %sRCS file%s: %d %smarked - %d not found %s." - total - (if locked "locked " "") - (dired-plural-s total) (- total count) - (if unflag-p "un" "") count failures)) - failures)) - -(defun rcs-files (directory) - "Return list of RCS data files for all RCS controlled files in DIRECTORY." - (setq directory (file-name-as-directory directory)) - (let ((rcs-dir (file-name-as-directory (expand-file-name "RCS" directory))) - (rcs-files (directory-files directory t ",v$"))) - (if (file-directory-p rcs-dir) - (setq rcs-files - (append (directory-files rcs-dir t ",v$") - rcs-files))) - rcs-files)) - -(defvar rcs-output-buffer "*RCS-output*" - "If non-nil, buffer name used by function `rcs-get-output-buffer' (q.v.). -If nil, a new buffer is used each time.") - -(defun rcs-get-output-buffer (file) - ;; Get a buffer for RCS output for FILE, make it writable and clean - ;; it up. Return the buffer. - ;; The buffer used is named according to variable - ;; `rcs-output-buffer'. If the caller wants to be reentrant, it - ;; should let-bind this to nil: a new buffer will be chosen. - (let* ((default-major-mode 'fundamental-mode);; no frills! - (buf (get-buffer-create (or rcs-output-buffer "*RCS-output*")))) - (if rcs-output-buffer - nil - (setq buf (generate-new-buffer "*RCS-output*"))) - (save-excursion - (set-buffer buf) - (setq buffer-read-only nil - default-directory (file-name-directory (expand-file-name file))) - (erase-buffer)) - buf)) - -(defun rcs-locked-files (directory) - "Return list of RCS data file names of all RCS-locked files in DIRECTORY." - (let ((output-buffer (rcs-get-output-buffer directory)) - (rcs-files (rcs-files directory)) - result) - (and rcs-files - (save-excursion - (set-buffer output-buffer) - (apply (function call-process) "rlog" nil t nil "-L" "-R" rcs-files) - (goto-char (point-min)) - (while (not (eobp)) - (setq result (cons (buffer-substring (point) - (progn (forward-line 1) - (1- (point)))) - result))) - result)))) - -(defun rcs-working-file (filename) - "Convert an RCS file name to a working file name. -That is, convert `...foo,v' and `...RCS/foo,v' to `...foo'. -If FILENAME doesn't end in `,v' it is returned unchanged." - (if (not (string-match ",v$" filename)) - filename - (setq filename (substring filename 0 -2)) - (let ((dir (file-name-directory filename))) - (if (null dir) - filename - (let ((dir-file (directory-file-name dir))) - (if (equal "RCS" (file-name-nondirectory dir-file)) - ;; Working file for ./RCS/foo,v is ./foo. - ;; Don't use expand-file-name as this converts "" -> pwd - ;; and thus forces a relative FILENAME to be relative to - ;; the current value of default-directory, which may not - ;; what the caller wants. Besides, we want to change - ;; FILENAME only as much as necessary. - (concat (file-name-directory dir-file) - (file-name-nondirectory filename)) - filename)))))) - -(defun dired-do-vc-register (&optional arg) - "Register the marked (or next ARG) files under version control." - (interactive "P") - (dired-mark-map-check (function dired-vc-register) arg 'register t)) - -(defun dired-vc-register () - (let ((file (dired-get-filename)) failure) - (condition-case err - (save-window-excursion - (find-file file) - (vc-register)) - (error (setq failure err))) - (if (not failure) - nil - (dired-log "Register error for %s:\n%s\n" file failure) - (dired-make-relative file)))) - -(provide 'dired-rcs) diff -r b88636d63495 -r 8fc7fe29b841 lisp/dired/dired-trns.el --- a/lisp/dired/dired-trns.el Mon Aug 13 08:50:06 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,192 +0,0 @@ -;; dired-trns.el - file transformers for dired shell commands. - -;; Id: dired-trns.el,v 1.6 1991/07/05 13:36:01 sk RelBeta - -;; Code contributed by Hans Chalupsky . -;; Integrated with my dired.el sk@sparc0 11-Jan-1991 14:38. -;; And hacked up a bit. - -;; LISPDIR ENTRY for the Elisp Archive =============================== -;; LCD Archive Entry: -;; dired-trns|Hans Chalupsky|hans@cs.Buffalo.EDU -;; |Filename Transformation for Tree Dired Shell Commands -;; |Date: 1991/07/05 13:36:01 |Revision: 1.6 | - -;; INSTALLATION ====================================================== -;; Put this file into your load-path and add (load "dired-trns") to -;; your dired-load-hook, e.g. -;; -;; (setq dired-load-hook '(lambda () -;; ;; possibly more statements here -;; (load "dired-trns"))) - -;; Transformers are functions that take a file (a string) as an argument -;; and transform it into some other string (e.g., a filename without an -;; extension). -;; -;; Each transformer is associated with a dispatch character. The associations -;; are stored in a keymap for fast and easy lookup. The dispatch character -;; is used to activate the associated transformer function at a particular -;; position in a shell command issued in dired. -;; -;; Transformers can be used to construct complicated shell commands that -;; operate on a large number of files, for example, they allow to create -;; functionality such as "mv *.lsp *.lisp" where each .lsp file is -;; renamed into a a file with same name but new extension .lisp. - -(defvar dired-trans-map (make-keymap) - "Array that associates keys with file transformer functions") - -(defmacro dired-trans-define (char &rest body) - "Macro that assigns the transformer function (lambda (file) BODY) to -CHAR (a character or string). BODY must return a string (the transformed -file or whatever. This macro allows easy definition of user specific -transformation functions." - (if (not (stringp char)) (setq char (char-to-string char))) - (list 'define-key 'dired-trans-map char - (list 'function (append '(lambda (file)) body)))) - -(defun dired-trans-run (transformers file) - "Applies each transformer supplied in the string TRANSFORMERS in sequence -to FILE and returns the concatenation of the results." - (mapconcat (function - (lambda (transformer) - (setq transformer (char-to-string transformer)) - (funcall (or (lookup-key dired-trans-map transformer) - (error "Undefined transfomer: %s" transformer)) - file))) - transformers nil)) - -(defvar dired-trans-re-ext "\\.[^.]*\\(\\.\\(\\(g?z\\)\\|Z\\)\\)?$" - "The part of a filename matching this regexp will be viewed as extension") - -(defun dired-trans-init () - "Defines a basic set of useful transformers. - -* is a noop that returns the unmodified filename (equivalent to [dbe]). -n returns the Name component of a filename without directory information -d returns the Directory component of a filename -b returns the Basename of a filename, i.e., the name of the file without - directory and extension (see dired-trans-re-ext) - A basename with directory component can be obtained by [db]. -e returns the Extension of a filename (i.e., whatever - dired-trans-re-ext splits off) -v returns a file without directory and without ,v suffixes if any. -z returns a file without directory and without .Z .z .gz suffixes if any." - (dired-trans-define - "*" file) - (dired-trans-define - "n" (or (file-name-nondirectory file) "")) - (dired-trans-define - "d" (or (file-name-directory file) "")) - (dired-trans-define - "b" (setq file (dired-trans-run "n" file)) - (substring file 0 (string-match dired-trans-re-ext file))) - (dired-trans-define - "e" (let ((e (string-match dired-trans-re-ext file))) - (if e - (substring file e) - ""))) - (dired-trans-define - "v" (setq file (dired-trans-run "n" file)) - (substring file 0 (string-match ",v$" file))) - (dired-trans-define - "z" (setq file (dired-trans-run "n" file)) - (substring file 0 (string-match "\\.\\(\\(g?z\\)\\|Z\\)$" file))) - ) - -(dired-trans-init) - -(defun dired-trans-mklist (files &optional transformers) - "Takes a list of FILES and applies the sequence of TRANSFORMERS to each -of them. The transformed results are concatenated, separated by -dired-mark-separator, prefixed by dired-mark-prefix and postfixed by -dired-mark-postfix to generate a file list suitable for a particular shell." - (if (not (consp files))(setq files (list files))) - (if (null transformers) (setq transformers "*")) - (let ((file-list - (mapconcat (function - (lambda (file) - (shell-quote - (dired-trans-run transformers file)))) - files dired-mark-separator))) - (if (> (length files) 1) - (concat dired-mark-prefix file-list dired-mark-postfix) - file-list))) - -;; By default, transformations can be specified like this: -;; [db] or [dv] or #z# or #dbe# or #dbe (blank at the end). - -(defvar dired-trans-starters "[#[]" - "User definable set of characters to be used to indicate the start of a -transformer sequence") - -(defvar dired-trans-enders "[]# ]" - "User definable set of characters to be used to indicate the end of a -transformer sequence") - -(defun dired-trans-expand (command files) - "Takes a shell COMMAND and a list of FILES and substitutes each occurance -of a transformer sequence by an accordingly transformed file list. Special -characters such as [,] or * can be quoted with a backslash." - (let ((quoted nil) - (collect-transformers nil) - (transformers "")) - (mapconcat (function - (lambda (char) - (setq char (char-to-string char)) - (cond (quoted (setq quoted nil) char) - ((equal char "\\") (setq quoted t) nil) - (collect-transformers - (cond ((string-match dired-trans-enders char) - (setq collect-transformers nil) - (prog1 (dired-trans-mklist - files transformers) - (setq transformers ""))) - (t (setq transformers - (concat transformers char)) - nil))) - ((string-match dired-trans-starters char) - (setq collect-transformers t) nil) - ;; for compatibility and as a special case that should - ;; not be redefinable by the user (used below) - ((equal char "*") - (dired-trans-mklist files "*")) - (t char)))) - command nil))) - -(defun dired-trans-make (command files &optional all-at-once) - "Takes a shell COMMAND and a list of FILES and returns a command operating -on the list of files (transformed if COMMAND contains transformers). If -ALL-AT-ONCE is t the resulting command will be of the form - cmd file1 file2 ... fileN -otherwise it will be - cmd file1; cmd file2; ... cmd fileN; -Both examples assume a single reference to the file list." - (let (fns expanded-command) - (cond (all-at-once - (setq expanded-command (dired-trans-expand command files)) - (if (equal command expanded-command) - (concat command (dired-trans-expand " *" files)) - expanded-command)) - (t (mapconcat - (function - (lambda (file) - (dired-trans-make command file t))) - files ";"))))) - -;; Redefine this function from dired.el: - -(defun dired-shell-stuff-it (command file-list on-each &optional raw-arg) -"Make up a shell command line from COMMAND and FILE-LIST. -If ON-EACH is t, COMMAND should be applied to each file, else - simply concat all files. -The list of marked files is appended to the command string unless asterisks - `*' or transformer sequences enclosed in `[]' indicate the place(s) where - the (transformed) list should go. See documentation of function - dired-trans-init for a list of transformers. -With a zero argument the resulting command will be of the form - cmd file1; cmd file2; ... cmd fileN assuming only one reference to the - file list. E.g., to rename all .lsp files into .lisp files mark all the - .lsp files and issue the command `mv * [db].lisp' ." - (dired-trans-make command file-list (not on-each))) diff -r b88636d63495 -r 8fc7fe29b841 lisp/dired/dired-vms.el --- a/lisp/dired/dired-vms.el Mon Aug 13 08:50:06 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,279 +0,0 @@ -;; dired-vms.el - VMS support for dired. Revision: 1.17 -;; Copyright (C) 1990, 1992 Free Software Foundation, Inc. - -;; This file is part of XEmacs. - -;; XEmacs 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 2, or (at your option) -;; any later version. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;; Id: dired-vms.el,v 1.17 1991/09/09 16:54:03 sk RelBeta - -;; You'll need vmsproc.el for this function: -(autoload 'subprocess-command-to-buffer "vmsproc") - -(setq dired-subdir-regexp "^ *Directory \\([][:.A-Z-0-9_$;<>]+\\)\\(\\)[\n\r]") - -(defconst dired-vms-filename-regexp -"\\(\\([_A-Z0-9$]?\\|[_A-Z0-9$][_A-Z0-9$---]*\\)\\.[_A-Z0-9$---]*;+[0-9]*\\)" - "Regular expression to match for a valid VMS file name in Dired buffer. -Stupid freaking bug! Position of _ and $ shouldn't matter but they do. -Having [A-Z0-9$_] bombs on filename _$$CHANGE_LOG$.TXT$ and $CHANGE_LOG$.TX -Other orders of $ and _ seem to all work just fine.") - -(setq dired-re-mark "^[^ \n\t]") - -(defvar dired-directory-command - "DIRECTORY/SIZE/DATE/PROT" - "Directory command for dired under VMS.") - -;; requires vmsproc.el to work -(defun dired-ls (file switches &optional wildcard full-directory-p) - "Insert ls output of FILE,formatted according to SWITCHES. -Optional third arg WILDCARD means treat FILE as shell wildcard. -Optional fourth arg FULL-DIRECTORY-P means file is a directory and -switches do not contain `d'. - -SWITCHES default to dired-listing-switches. - -This is the VMS version of this UNIX command. -The SWITCHES and WILDCARD arguments are ignored. -Uses dired-directory-command." - (save-restriction;; Must drag point along: - (narrow-to-region (point) (point)) - (subprocess-command-to-buffer - (concat dired-directory-command " " file) - (current-buffer)) - (if full-directory-p - (goto-char (point-max)) - ;; Just the file line if no full directory required: - (goto-char (point-min)) - (let ((case-fold-search nil)) - (re-search-forward dired-subdir-regexp) - (re-search-forward (concat "^" dired-vms-filename-regexp))) - (beginning-of-line) - (delete-region (point-min) (point)) - (forward-line 1) - (delete-region (point) (point-max))))) - -(defun dired-insert-headerline (dir) ; redefinition - ;; VMS dired-ls makes its own headerline, but we must position the - ;; cursor where dired-insert-subdir expects it. - ;; This does not check whether the headerline matches DIR. - (re-search-forward dired-subdir-regexp) - (goto-char (match-end 1))) - - -(defun dired-make-absolute (file &optional dir) - ;;"Convert FILE (a pathname relative to DIR) to an absolute pathname." - ;; This should be good enough for ange-ftp, but might easily be - ;; redefined (for VMS?). - ;; It should be reasonably fast, though, as it is called in - ;; dired-get-filename. - (concat (or dir - (dired-current-directory) - default-directory) - file)) - -(defun dired-make-relative (file &optional dir) - ;; In VMS we don't want relative names at all because of search path - ;; logical names. Also, we never need to raise an error when a file - ;; `doesn't belong' in this buffer (like in the Unix case). - file) - -(defun dired-in-this-tree (file dir) - ;;"Is FILE part of the directory tree starting at DIR?" - ;; Under VMS, file="DEV:[foo.bar]zod", dir="DEV:[foo]" - (or (string= (substring dir -1) "\]") - (string= (substring dir -1) "\:") - (error "Not a directory: %s" dir)) - (string-match (concat "^" (regexp-quote (substring dir 0 -1))) - file)) - -(defun dired-vms-split-filename (file) - (if (string-match;; "DEV:[DIR]FIL" \1=DEV \2=DIR \3=FIL - "^\\([.A-Z-0-9_$;]*\\):?[[<]\\([.A-Z-0-9_$;]*\\)[]>]\\([.A-Z-0-9_$;]*\\)$" - file) - (mapcar '(lambda (x) - (substring file (match-beginning x) (match-end x))) - '(1 2 3)))) - -;; Must use this in dired-noselect instead of expand-file-name and -;; file-name-as-directory -;; Taken from the VMS dired version by -;;Roland Roberts BITNET: roberts@uornsrl -;; Nuclear Structure Research Lab INTERNET: rbr4@uhura.cc.rochester.edu -;; 271 East River Road UUCP: rochester!ur-cc!uhura!rbr4 -;; Rochester, NY 14267 AT&T: (716) 275-8962 - - -(defun dired-noselect (dirname &optional switches) - "Like M-x dired but returns the dired buffer as value, does not select it." - (setq dirname (dired-fix-directory dirname)) - (dired-internal-noselect dirname switches)) - -(defun dired-fix-directory (dirname) - "Fix up dirname to be a valid directory name and return it" - (setq dirname - (expand-file-name (or dirname (setq dirname default-directory)))) - (let ((end (1- (length dirname))) - bracket colon) - (if (or (char-equal ?\] (elt dirname end)) - (char-equal ?\: (elt dirname end))) - dirname - (setq bracket (string-match "\\]" dirname)) - (setq colon (string-match "\\:" dirname)) - (setq end (string-match "\\.DIR" dirname (or bracket colon))) - (if end - (let ((newdir - (if bracket (concat (substring dirname 0 bracket) - ".") - (if colon (concat (substring dirname 0 (1+ colon)) - "[") - "[")))) - (concat newdir (substring dirname - (1+ (or bracket colon)) end) - "]")) - (if bracket (substring dirname 0 (1+ bracket)) - (if colon (substring dirname 0 (1+ colon)) - default-directory)))))) - -;; Versions are not yet supported in dired.el (as of version 4.53): -;;(setq dired-file-version-regexp "[.;][0-9]+$") - -(defun dired-move-to-filename (&optional raise-error eol) - "In dired, move to first char of filename on this line. -Returns position (point) or nil if no filename on this line." - ;; This is the VMS version. - (or eol (setq eol (progn (end-of-line) (point)))) - (beginning-of-line) - (if (re-search-forward (concat " " dired-vms-filename-regexp) eol t) - (goto-char (match-beginning 1)) - (if raise-error - (error "No file on this line") - nil))) - -(defun dired-move-to-end-of-filename (&optional no-error eol) - ;; Assumes point is at beginning of filename, - ;; thus the rwx bit re-search-backward below will succeed in *this* line. - ;; So, it should be called only after (dired-move-to-filename t). - ;; case-fold-search must be nil, at least for VMS. - ;; On failure, signals an error or returns nil. - ;; This is the VMS version. - (let (opoint flag ex sym hidden case-fold-search) - (setq opoint (point)) - (or eol (setq eol (save-excursion (end-of-line) (point)))) - (setq hidden (and selective-display - (save-excursion (search-forward "\r" eol t)))) - (if hidden - nil - (re-search-forward dired-vms-filename-regexp eol t)) - (or no-error - (not (eq opoint (point))) - (error (if hidden - (substitute-command-keys - "File line is hidden, type \\[dired-hide-subdir] to unhide") - "No file on this line"))) - (if (eq opoint (point)) - nil - (point)))) - -(defun dired-tree-lessp (dir1 dir2) - (setq dir1 (substring (file-name-as-directory dir1) 0 -1) - dir2 (substring (file-name-as-directory dir2) 0 -1)) - (let ((components-1 (dired-split "[:.]" dir1)) - (components-2 (dired-split "[:.]" dir2))) - (while (and components-1 - components-2 - (equal (car components-1) (car components-2))) - (setq components-1 (cdr components-1) - components-2 (cdr components-2))) - (let ((c1 (car components-1)) - (c2 (car components-2))) - - (cond ((and c1 c2) - (string-lessp c1 c2)) - ((and (null c1) (null c2)) - nil) ; they are equal, not lessp - ((null c1) ; c2 is a subdir of c1: c1c2 - nil) - (t (error "This can't happen")))))) - -(defun dired-insert-subdir-validate (dirname) - (let ((alist dired-subdir-alist) - (found nil) - item) - (while (and alist (not found)) - (setq item (car alist) - alist (cdr alist)) - (setq found (dired-in-this-tree dirname (car item)))) - (if (not found) - (error "%s: directory not in this buffer" dirname)))) - -(defun dired-insert-subdir-newpos (new-dir) - ;; Find pos for new subdir, according to tree order. - (let ((alist (reverse dired-subdir-alist)) elt dir pos new-pos found) - (while alist - (setq elt (car alist) - alist (cdr alist) - dir (car elt) - pos (dired-get-subdir-min elt)) - (if (or (and found - (or (dired-in-this-tree dir found) - (setq alist nil))) - (and (dired-in-this-tree new-dir dir) - (setq found dir))) - (if (dired-tree-lessp dir new-dir) - ;; Insert NEW-DIR after DIR - (setq new-pos (dired-get-subdir-max elt))))) - (goto-char new-pos)) - ;; want a separating newline between subdirs - (or (eobp) - (forward-line -1)) - (insert "\n") - (point)) - -(defun dired-between-files () - (save-excursion - (beginning-of-line) - (or (equal (following-char) 9) - (progn (forward-char 2) - (or (looking-at "Total of") - (equal (following-char) 32)))))) - -(defun dired-buffers-for-dir (dir) - ;; Return a list of buffers that dired DIR (top level or in-situ subdir). - ;; The list is in reverse order of buffer creation, most recent last. - ;; As a side effect, killed dired buffers for DIR are removed from - ;; dired-buffers. - (setq dir (file-name-as-directory dir)) - (let ((alist dired-buffers) result elt) - (while alist - (setq elt (car alist)) - ;; In Unix we only looked into the buffer when - ;; (dired-in-this-tree dir (car elt)) returned non-nil. - ;; In VMS we have to look into each buffer because it doesn't - ;; necessarily contain only the tree starting at the top level directory - (let ((buf (cdr elt))) - (if (buffer-name buf) - (if (assoc dir (save-excursion - (set-buffer buf) - dired-subdir-alist)) - (setq result (cons buf result))) - ;; else buffer is killed - clean up: - (setq dired-buffers (delq elt dired-buffers)))) - (setq alist (cdr alist))) - result)) diff -r b88636d63495 -r 8fc7fe29b841 lisp/dired/dired-x.el --- a/lisp/dired/dired-x.el Mon Aug 13 08:50:06 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1679 +0,0 @@ -;;; dired-x.el --- Sebastian Kremer's Extra DIRED hacked up for GNU Emacs19 -;; Keywords: dired extensions - -(defconst dired-extra-version (substring "!Revision: 1.191 !" 11 -2) - "Id: dired-x.el,v 1.191 1992/05/14 11:41:54 sk RelBeta ") - -;; Copyright (C) 1991 Sebastian Kremer. - -;; This file is part of XEmacs. - -;; XEmacs 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 2, or (at your option) -;; any later version. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;; LISPDIR ENTRY for the Elisp Archive =============================== -;; LCD Archive Entry: -;; dired-x|Sebastian Kremer|sk@thp.uni-koeln.de -;; |Extra Features for Tree Dired -;; |Date: 1992/05/14 11:41:54 |Revision: 1.191 | - -;; INSTALLATION ====================================================== - -;; In your ~/.emacs, say -;; -;; (setq dired-load-hook '(lambda () (load "dired-x"))) -;; -;; At load time dired-x will install itself using the various other -;; dired hooks. It will redefine some functions and bind dired keys. -;; If gmhist is present, dired-x will take advantage of it. - -(require 'dired) ; we will redefine some functions - ; and also need some macros - -(provide 'dired-extra) ; but this file is "dired-x" -(provide 'dired-x) ; but this file is "dired-x" - -;; Customization (see also defvars in other sections below) - -;; user should define this as `nil' prior to loading dired-x in order that the -;; compression/decompression material of emacs19 is not overwritten. -(defvar dired-mark-keys '("Z") - "*List of keys (strings) that insert themselves as file markers.") - -(defvar dired-dangerous-shell-command "^rm" ; e.g. "rm" or "rmdir" - "*Regexp for dangerous shell commands that should never be the default.") - -;; Add key bindings. This file is supposed to be loaded immediately -;; after dired, inside dired-load-hook. - -(define-key dired-mode-map "V" 'dired-vm) -(define-key dired-mode-map "\(" 'dired-set-marker-char) -(define-key dired-mode-map "\)" 'dired-restore-marker-char) -(define-key dired-mode-map "I" 'dired-do-insert-subdir) -;;(define-key dired-mode-map "\M-f" 'dired-flag-extension) -(define-key dired-mode-map "\M-M" 'dired-do-unmark) -(define-key dired-mode-map "\M-o" 'dired-omit-toggle) -(define-key dired-mode-map "\M-(" 'dired-mark-sexp) -(define-key dired-mode-map "," 'dired-mark-rcs-files) -(define-key dired-mode-map "\M-!" 'dired-smart-shell-command) -(define-key dired-mode-map "\M-&" 'dired-smart-background-shell-command) -(define-key dired-mode-map "T" 'dired-do-toggle) -(define-key dired-mode-map "w" 'dired-copy-filename-as-kill) -(define-key dired-mode-map "\M-g" 'dired-goto-file) -(define-key dired-mode-map "\M-G" 'dired-goto-subdir) -(define-key dired-mode-map "&" 'dired-do-background-shell-command) -(define-key dired-mode-map "A" 'dired-do-byte-compile-and-load) -(define-key dired-mode-map "F" 'dired-do-find-file) -(define-key dired-mode-map "S" 'dired-do-relsymlink) -(define-key dired-mode-map "%S" 'dired-do-relsymlink-regexp) - -(mapcar (function;; do this last to override bindings above - (lambda (x) - (define-key dired-mode-map x 'dired-mark-with-this-char))) - dired-mark-keys) - -;; Install ourselves into the appropriate hooks - -(defun dired-add-hook (hook-var function) - "Add a function to a hook. -First argument HOOK-VAR (a symbol) is the name of a hook, second -argument FUNCTION is the function to add. -Returns nil if FUNCTION was already present in HOOK-VAR, else new -value of HOOK-VAR." - (interactive "SAdd to hook-var (symbol): \naAdd which function to %s? ") - (if (not (boundp hook-var)) (set hook-var nil)) - (if (or (not (listp (symbol-value hook-var))) - (eq (car (symbol-value hook-var)) 'lambda)) - (set hook-var (list (symbol-value hook-var)))) - (if (memq function (symbol-value hook-var)) - nil - (set hook-var (cons function (symbol-value hook-var))))) - -(dired-add-hook 'dired-mode-hook 'dired-extra-startup) -(dired-add-hook 'dired-after-readin-hook 'dired-omit-expunge) - -(defvar dired-default-marker dired-marker-char - "*The value of `dired-marker-char' in effect before dired-x was -loaded and the value which is restored if the marker stack underflows. -This is usually the asterisk `*'.") - -;;;###autoload -(defun dired-extra-startup () - "Automatically put on dired-mode-hook to get extra dired features: -\\ - \\[dired-vm]\t-- VM on folder - \\[dired-rmail]\t-- Rmail on folder - \\[dired-do-insert-subdir]\t-- insert all marked subdirs - \\[dired-do-find-file]\t-- visit all marked files simultaneously - \\[dired-set-marker-char], \\[dired-restore-marker-char]\t-- change and display dired-marker-char dynamically. - \\[dired-omit-toggle]\t-- toggle omitting of files - \\[dired-mark-sexp]\t-- mark by lisp expression - \\[dired-do-unmark]\t-- replace existing marker with another. - \\[dired-mark-rcs-files]\t-- mark all RCS controlled files - \\[dired-mark-files-compilation-buffer]\t-- mark compilation files - \\[dired-copy-filename-as-kill]\t-- copy the file or subdir names into the kill ring. - \t You can feed it to other commands using \\[yank]. - -For more features, see variables - - dired-omit-files - dired-omit-extenstions - dired-dangerous-shell-command - dired-mark-keys - dired-local-variables-file - dired-find-subdir - dired-guess-have-gnutar - dired-auto-shell-command-alist - -See also functions - - dired-sort-on-size - dired-do-relsymlink - dired-flag-extension - dired-virtual - dired-jump-back - dired-jump-back-other-window -" - (interactive) - ;; This must be done in each new dired buffer: - (dired-hack-local-variables) - (dired-omit-startup) - (dired-marker-stack-startup)) - -;;; Handle customization - -(or (fboundp 'read-with-history-in) ; it's loaded - (not (subrp (symbol-function 'read-from-minibuffer))) ; it's 19.4L - ;; else try to load gmhist - (load "gmhist" t)) - -(if (not (fboundp 'read-with-history-in)) - - nil ; Gmhist is not available - - ;; Else use generic minibuffer history - (put 'dired-shell-command-history 'dangerous dired-dangerous-shell-command) - - ;; Redefinition - when this is loaded, dired.el has alreay been loaded. - - (defun dired-read-regexp (prompt &optional initial) - (setq dired-flagging-regexp - (if (null initial) - (read-with-history-in 'regexp-history prompt initial) - (put 'regexp-history 'default - nil) - (put 'regexp-history 'default - (read-with-history-in 'regexp-history prompt initial))))) - - (defun dired-read-dir-and-switches (str) - (nreverse - (list - (if current-prefix-arg - (read-string "Dired listing switches: " dired-listing-switches)) - (read-file-name-with-history-in - 'file-history ; or 'dired-history? - (format "Dired %s(directory): " str) nil default-directory nil)))) -) - - - -;;; Dynamic Markers - -(defun dired-mark-with-this-char (arg) - "Mark the current file or subdir with the last key you pressed to invoke -this command. Else like \\[dired-mark-subdir-or-file] command." - (interactive "p") - (let ((dired-marker-char;; use last character, in case of prefix cmd - last-command-char)) - (dired-mark-subdir-or-file arg))) - -(defvar dired-marker-stack nil - "List of previously used dired marker characters.") - -(defvar dired-marker-string "" - "String version of `dired-marker-stack'.") - -(defun dired-current-marker-string () - "Computes and returns `dired-marker-string'." - (setq dired-marker-string - (concat " " - (mapconcat (function char-to-string) - (reverse dired-marker-stack) - "")))) - -(defun dired-marker-stack-startup () - (make-local-variable 'dired-marker-char) - (make-local-variable 'dired-del-marker) - (make-local-variable 'dired-marker-stack) - (or (assq 'dired-marker-stack minor-mode-alist) - (setq minor-mode-alist - (cons '(dired-marker-stack dired-marker-string) - minor-mode-alist)))) - -(defun dired-set-marker-char (c) - "Set the marker character to something else. -Use \\[dired-restore-marker-char] to restore the previous value." - (interactive "cNew marker character: ") - (setq dired-marker-stack (cons c dired-marker-stack)) - (dired-current-marker-string) - (setq dired-marker-char c) - (set-buffer-modified-p (buffer-modified-p)) ; update mode line - (message "New marker is %c" dired-marker-char)) - -(defun dired-restore-marker-char () - "Restore the marker character to its previous value. -Uses `dired-default-marker' if the marker stack is empty." - (interactive) - (setq dired-marker-stack (cdr dired-marker-stack) - dired-marker-char (car dired-marker-stack)) - (dired-current-marker-string) - (set-buffer-modified-p (buffer-modified-p)) ; update mode line - (or dired-marker-char (setq dired-marker-char dired-default-marker)) - (message "Marker is %c" dired-marker-char)) - -;;; Sort on Size kludge if your ls can't do it - -(defun dired-sort-on-size () - "Sorts a dired listing on file size. -If your ls cannot sort on size, this is useful as `dired-after-readin-hook': - \(setq dired-after-readin-hook 'dired-sort-on-size\)" - (require 'sort) - (goto-char (point-min)) - (dired-goto-next-file) ; skip `total' line - (beginning-of-line) - (sort-subr t ; biggest file first - 'forward-line 'end-of-line 'dired-get-file-size)) - -(defun dired-get-file-size () - (re-search-forward "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\)") - (goto-char (match-beginning 1)) - (forward-char -1) - (string-to-int (buffer-substring (save-excursion - (backward-word 1) - (point)) - (point)))) - - -;;; Misc. (mostly featurismic) commands - -;; Mail folders - -(defvar dired-vm-read-only-folders nil - "*If t, \\[dired-vm] will visit all folders read-only. -If neither nil nor t, e.g. the symbol `if-file-read-only', only -files not writable by you are visited read-only. - -Read-only folders only work in VM 5, not in VM 4.") - -(defun dired-vm (&optional read-only) - "Run VM on this file. -With prefix arg, visit folder read-only (this requires at least VM 5). -See also variable `dired-vm-read-only-folders'." - (interactive "P") - (let ((dir (dired-current-directory)) - (fil (dired-get-filename))) - ;; take care to supply 2nd arg only if requested - may still run VM 4! - (cond (read-only (vm-visit-folder fil t)) - ((eq t dired-vm-read-only-folders) (vm-visit-folder fil t)) - ((null dired-vm-read-only-folders) (vm-visit-folder fil)) - (t (vm-visit-folder fil (not (file-writable-p fil))))) - ;; so that pressing `v' inside VM does prompt within current directory: - (set (make-local-variable 'vm-folder-directory) dir))) - -(defun dired-rmail () - "Run RMAIL on this file." - (interactive) - (rmail (dired-get-filename))) - -;; More subdir operations - -(defun dired-do-insert-subdir () - "Insert all marked subdirectories in situ that are not yet inserted. -Non-directories are silently ignored." - (interactive) - (let ((files (or (dired-mark-get-files) - (error "No files marked.")))) - (while files - (if (file-directory-p (car files)) - (save-excursion (dired-maybe-insert-subdir (car files)))) - (setq files (cdr files))))) - -(defun dired-mark-extension (extension &optional marker-char) - "Mark all files with a certain extension for use in later commands. -A `.' is not automatically prepended to the string entered." - ;; EXTENSION may also be a list of extensions instead of a single one. - ;; Optional MARKER-CHAR is marker to use. - (interactive "sMarking extension: \nP") - (or (listp extension) - (setq extension (list extension))) - (dired-mark-files-regexp - (concat ".";; don't match names with nothing but an extension - "\\(" - (mapconcat 'regexp-quote extension "\\|") - "\\)$") - marker-char)) - -(defun dired-flag-extension (extension) - "In dired, flag all files with a certain extension for deletion. -A `.' is *not* automatically prepended to the string entered." - (interactive "sFlagging extension: ") - (dired-mark-extension extension dired-del-marker)) - -(defvar patch-unclean-extensions - '(".rej" ".orig") - "List of extensions of dispensable files created by the `patch' program.") - -(defvar tex-unclean-extensions - '(".toc" ".log" ".aux");; these are already in completion-ignored-extensions - "List of extensions of dispensable files created by TeX.") - -(defvar latex-unclean-extensions - '(".idx" ".lof" ".lot" ".glo") - "List of extensions of dispensable files created by LaTeX.") - -(defvar bibtex-unclean-extensions - '(".blg" ".bbl") - "List of extensions of dispensable files created by BibTeX.") - -(defvar texinfo-unclean-extensions - '(".cp" ".cps" ".fn" ".fns" ".ky" ".kys" ".pg" ".pgs" - ".tp" ".tps" ".vr" ".vrs") - "List of extensions of dispensable files created by texinfo.") - -(defun dired-clean-patch () - "Flag dispensable files created by patch for deletion. -See variable `patch-unclean-extensions'." - (interactive) - (dired-flag-extension patch-unclean-extensions)) - -(defun dired-clean-tex () - "Flag dispensable files created by tex etc. for deletion. -See variable `texinfo-unclean-extensions', `latex-unclean-extensions', -`bibtex-unclean-extensions' and `texinfo-unclean-extensions'." - (interactive) - (dired-flag-extension (append texinfo-unclean-extensions - latex-unclean-extensions - bibtex-unclean-extensions - tex-unclean-extensions))) - -(defun dired-do-unmark (unmarker) - "Unmark marked files by replacing the marker with another character. -The new character defaults to a space, effectively unmarking them." - (interactive "sChange marker to: ") - (if (string= unmarker "") - (setq unmarker " ")) - (setq unmarker (substring unmarker 0 1)) - (let ((regexp (dired-marker-regexp)) - (buffer-read-only nil)) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (replace-match unmarker))))) - -;; This is unused but might come in handy sometime -;(defun dired-directories-of (files) -; ;; Return unique list of parent directories of FILES. -; (let (dirs dir file) -; (while files -; (setq file (car files) -; files (cdr files) -; dir (file-name-directory file)) -; (or (member dir dirs) -; (setq dirs (cons dir dirs)))) -; dirs)) - -;; Adapted from code by wurgler@zippysun.math.uakron.edu (Tom Wurgler). -;; Suggest you bind it to a key. I use C-x C-j. -(defun dired-jump-back (&optional other-window) - "Jump back to dired: -If in a file, dired the current directory and move to file's line. -If in dired already, pop up a level and goto old directory's line. -In case the proper dired file line cannot be found, refresh the dired - buffer and try again." - (interactive) - (let* ((file buffer-file-name) - (dir (if file (file-name-directory file) default-directory))) - (if (eq major-mode 'dired-mode) - (progn - (setq dir (dired-current-directory)) - (if other-window - (dired-up-directory-other-window) - (dired-up-directory)) - (dired-really-goto-file dir)) - (if other-window - (dired-other-window dir) - (dired dir)) - (if file (dired-really-goto-file file))))) - -(defun dired-jump-back-other-window () - "Like \\[dired-jump-back], but to other window." - (interactive) - (dired-jump-back t)) - -(defun dired-really-goto-file (file) - (or (dired-goto-file file) - (progn ; refresh and try again - (dired-insert-subdir (file-name-directory file)) - (dired-goto-file file)))) - -(defun dired-up-directory-other-window () - "Like `dired-up-directory', but in other window." - (interactive) - (let* ((dir (dired-current-directory)) - (up (file-name-directory (directory-file-name dir)))) - (or (dired-goto-file (directory-file-name dir)) - (dired-goto-subdir up) - ;; Only in this case it really uses another window: - (progn - (dired-other-window up) - (dired-goto-file dir))))) - -(defun dired-mark-rcs-files (&optional unflag-p) - "Mark all files that are under RCS control. -With prefix argument, unflag all those files. -Mentions RCS files for which a working file was not found in this buffer. -Type \\[dired-why] to see them again." - ;; Returns failures, or nil on success. - ;; Finding those with locks would require to peek into the ,v file, - ;; depends slightly on the RCS version used and should be done - ;; together with the Emacs RCS interface. - ;; Unfortunately, there is no definitive RCS interface yet. - (interactive "P") - (message "%sarking RCS controlled files..." (if unflag-p "Unm" "M")) - (let ((dired-marker-char (if unflag-p ?\ dired-marker-char)) - rcs-files wf failures count total) - (mapcar ; loop over subdirs - (function - (lambda (dir) - (or (equal (file-name-nondirectory (directory-file-name dir)) - "RCS") - ;; skip inserted RCS subdirs - (setq rcs-files - (append (directory-files dir t ",v$") ; *,v and RCS/*,v - (let ((rcs-dir (expand-file-name "RCS" dir))) - (if (file-directory-p rcs-dir) - (mapcar ; working files from ./RCS are in ./ - (function - (lambda (x) - (expand-file-name x dir))) - (directory-files - (file-name-as-directory rcs-dir) nil ",v$")))) - rcs-files))))) - (mapcar (function car) dired-subdir-alist)) - (setq total (length rcs-files)) - (while rcs-files - (setq wf (substring (car rcs-files) 0 -2) - rcs-files (cdr rcs-files)) - (save-excursion (if (dired-goto-file wf) - (dired-mark-file 1) - (setq failures (cons wf failures))))) - (if (null failures) - (message "%d RCS file%s %smarked." - total (dired-plural-s total) (if unflag-p "un" "")) - (setq count (length failures)) - (dired-log-summary "RCS working file not found %s" failures) - (message "%d RCS file%s: %d %smarked - %d not found %s." - total (dired-plural-s total) (- total count) - (if unflag-p "un" "") count failures)) - failures)) - -(defun dired-do-toggle () - "Toggle marks. -That is, currently marked files become unmarked and vice versa. -Files marked with other flags (such as `D') are not affected. -`.' and `..' are never toggled. -As always, hidden subdirs are not affected." - (interactive) - (save-excursion - (goto-char (point-min)) - (let (buffer-read-only) - (while (not (eobp)) - (or (dired-between-files) - (looking-at dired-re-dot) - ;; use subst instead of insdel because it does not move - ;; the gap and thus should be faster and because - ;; other characters are left alone automatically - (apply 'subst-char-in-region - (point) (1+ (point)) - (if (eq ?\040 (following-char)) ; SPC - (list ?\040 dired-marker-char) - (list dired-marker-char ?\040)))) - (forward-line 1))))) - -;; This function is missing in simple.el -(defun copy-string-as-kill (string) - "Save STRING as if killed in a buffer." - (setq kill-ring (cons string kill-ring)) - (if (> (length kill-ring) kill-ring-max) - (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil)) - (setq kill-ring-yank-pointer kill-ring)) - -(defvar dired-marked-files nil - "List of filenames from last `dired-copy-filename-as-kill' call.") - -(defun dired-copy-filename-as-kill (&optional arg) - "Copy names of marked (or next ARG) files into the kill ring. -The names are separated by a space. -With a zero prefix arg, use the complete pathname of each marked file. -With a raw (just \\[universal-argument]) prefix arg, use the relative pathname of each marked file. - -If on a subdir headerline and no prefix arg given, use subdirname instead. - -You can then feed the file name to other commands with \\[yank]. - -The list of names is also stored onto the variable -`dired-marked-files' for use, e.g., in an `\\[eval-expression]' command." - (interactive "P") - (copy-string-as-kill - (or (and (not arg) - (dired-get-subdir)) - (mapconcat (function identity) - (setq dired-marked-files - (if arg - (cond ((zerop (prefix-numeric-value arg)) - (dired-mark-get-files)) - ((integerp arg) - (dired-mark-get-files 'no-dir arg)) - (t ; else a raw arg - (dired-mark-get-files t))) - (dired-mark-get-files 'no-dir))) - " "))) - (message "%s" (car kill-ring))) - -(defun dired-do-background-shell-command (&optional arg) - "Like \\[dired-do-shell-command], but starts command in background. -Note that you can type input to the command in its buffer. -This requires background.el from the comint package to work." - ;; With the version in emacs-19.el, you can alternatively just - ;; append an `&' to any shell command to make it run in the - ;; background, but you can't type input to it. - (interactive "P") - (dired-do-shell-command arg t)) - -;; redefines dired.el to put back in the dired-offer-kill-buffer -;; feature which rms didn't like. -(defun dired-clean-up-after-deletion (fn) - ;; Clean up after a deleted file or directory FN. - ;; Remove expanded subdir of deleted dir, if any - (save-excursion (and (dired-goto-subdir fn) - (dired-kill-subdir))) - ;; Offer to kill buffer of deleted file FN. - (let ((buf (get-file-buffer fn))) - (and buf - (funcall (function y-or-n-p) - (format "Kill buffer of %s, too? " - (file-name-nondirectory fn))) - (save-excursion;; you never know where kill-buffer leaves you - (kill-buffer buf)))) - (let ((buf-list (dired-buffers-for-top-dir fn)) - (buf nil)) - (and buf-list - (y-or-n-p (format "Kill dired buffer%s of %s, too? " - (dired-plural-s (length buf-list)) - (file-name-nondirectory fn))) - (while buf-list - (save-excursion (kill-buffer (car buf-list))) - (setq buf-list (cdr buf-list))))) - ;; Anything else? - ) - -;;; Omitting - -;;; Enhanced omitting of lines from directory listings. -;;; Marked files are never omitted. -;;; Adapted from code submitted by: -;;; Michael D. Ernst, mernst@theory.lcs.mit.edu, 1/11/91 - -(make-variable-buffer-local - (defvar dired-omit-files-p nil - "*If non-nil, \"uninteresting\" files are not listed (buffer-local). -Use \\[dired-omit-toggle] to toggle its value. -Uninteresting files are those whose filenames match regexp `dired-omit-files', -plus those ending with extensions in `dired-omit-extensions'.")) - -(defvar dired-omit-files "^#\\|\\.$" - "*Filenames matching this regexp will not be displayed (buffer-local). -This only has effect when `dired-omit-files-p' is t. -See also `dired-omit-extensions'.") - -(defvar dired-omit-extensions - (append completion-ignored-extensions - latex-unclean-extensions - bibtex-unclean-extensions - texinfo-unclean-extensions) - "*If non-nil, a list of extensions (strings) to omit from Dired -listings. Defaults to the elements of -`completion-ignored-extensions', `latex-unclean-extensions', -`bibtex-unclean-extensions' and `texinfo-unclean-extensions'.") - -;; should probably get rid of this and always use 'no-dir. -;; sk 28-Aug-1991 09:37 -(defvar dired-omit-localp 'no-dir - "The LOCALP argument dired-omit-expunge passes to dired-get-filename. -If it is 'no-dir, omitting is much faster, but you can only match -against the basename of the file. Set it to nil if you need to match the -whole pathname.") - -;; \017=^O for Omit - other packages can chose other control characters. -(defvar dired-omit-marker-char ?\017 - "Temporary marker used by dired-omit. -Should never be used as a marker by the user or other packages.") - -(defun dired-omit-startup () - (or (assq 'dired-omit-files-p minor-mode-alist) - ;; Append at end so that it doesn't get between "Dired" and "by name". - (setq minor-mode-alist - (append minor-mode-alist '((dired-omit-files-p " Omit")))))) - -(defun dired-omit-toggle (&optional flag) - "Toggle between displaying and omitting files matching `dired-omit-files'. -With an arg, and if omitting was off, don't toggle and just mark the - files but don't actually omit them. -With an arg, and if omitting was on, turn it off but don't refresh the buffer." - (interactive "P") - (if flag - (if dired-omit-files-p - (setq dired-omit-files-p (not dired-omit-files-p)) - (dired-mark-unmarked-files (dired-omit-regexp) nil nil - dired-omit-localp)) - ;; no FLAG - (setq dired-omit-files-p (not dired-omit-files-p)) - (if (not dired-omit-files-p) - (revert-buffer) - ;; this will mention how many were omitted: - (dired-omit-expunge)))) - -;; This is sometimes let-bound to t if messages would be annoying, -;; e.g., in dired-awrh.el. -(defvar dired-omit-silent nil) - -;; in emacs19 `(dired-do-kill)' is called `(dired-do-kill-lines)' -(if (fboundp 'dired-do-kill-lines) - (fset 'dired-do-kill 'dired-do-kill-lines)) - -(defun dired-omit-expunge (&optional regexp) - "Erases all unmarked files matching REGEXP. -Does nothing if global variable `dired-omit-files-p' is nil. -If REGEXP is nil or not specified, uses `dired-omit-files', and also omits - filenames ending in `dired-omit-extensions'. -If REGEXP is the empty string, this function is a no-op. - -This functions works by temporarily binding `dired-marker-char' to -`dired-omit-marker-char' and calling `dired-do-kill'." - (interactive "sOmit files (regexp): ") - (if dired-omit-files-p - (let ((omit-re (or regexp (dired-omit-regexp))) - count) - (or (string= omit-re "") - (let ((dired-marker-char dired-omit-marker-char)) - (or dired-omit-silent (message "Omitting...")) - (if (dired-mark-unmarked-files - omit-re nil nil dired-omit-localp) - (setq count (dired-do-kill nil (if dired-omit-silent - "" - "Omitted %d line%s."))) - (or dired-omit-silent - (message "(Nothing to omit)"))))) - count))) - -(defun dired-omit-regexp () - (concat (if dired-omit-files (concat "\\(" dired-omit-files "\\)") "") - (if (and dired-omit-files dired-omit-extensions) "\\|" "") - (if dired-omit-extensions - (concat ".";; a non-extension part should exist - "\\(" - (mapconcat 'regexp-quote dired-omit-extensions "\\|") - "\\)$") - ""))) - -;; Returns t if any work was done, nil otherwise. -(defun dired-mark-unmarked-files (regexp msg &optional unflag-p localp) - "Marks unmarked files matching REGEXP, displaying MSG. -REGEXP is matched against the complete pathname. -Does not re-mark files which already have a mark. -With prefix argument, unflag all those files. -Second optional argument LOCALP is as in `dired-get-filename'." - (interactive "P") - (let ((dired-marker-char (if unflag-p ?\ dired-marker-char))) - (dired-mark-if - (and - ;; not already marked - (looking-at " ") - ;; uninteresting - (let ((fn (dired-get-filename localp t))) - (and fn (string-match regexp fn)))) - msg))) - -(defun dired-omit-new-add-entry (filename &optional marker-char) - ;; This redefines dired.el's dired-add-entry to avoid calling ls for - ;; files that are going to be omitted anyway. - (if dired-omit-files-p - ;; perhaps return t without calling ls - (let ((omit-re (dired-omit-regexp))) - (if (or (string= omit-re "") - (not - (string-match omit-re - (cond - ((eq 'no-dir dired-omit-localp) - filename) - ((eq t dired-omit-localp) - (dired-make-relative filename)) - (t - (dired-make-absolute filename directory)))))) - ;; if it didn't match, go ahead and add the entry - (dired-omit-old-add-entry filename marker-char) - ;; dired-add-entry returns t for success, perhaps we should - ;; return file-exists-p - t)) - ;; omitting is not turned on at all - (dired-omit-old-add-entry filename marker-char))) - -;; Save old defun if not already done: -(or (fboundp 'dired-omit-old-add-entry) - (fset 'dired-omit-old-add-entry (symbol-function 'dired-add-entry))) -;; Redefine dired.el -(fset 'dired-add-entry 'dired-omit-new-add-entry) - - -;; -(defun dired-mark-sexp (predicate &optional unflag-p) - "Mark files for which PREDICATE returns non-nil. -With a prefix arg, unflag those files instead. - -PREDICATE is a lisp expression that can refer to the following symbols: - - inode [integer] the inode of the file (only for ls -i output) - s [integer] the size of the file for ls -s output - (ususally in blocks or, with -k, in KByte) - mode [string] file permission bits, e.g. \"-rw-r--r--\" - nlink [integer] number of links to file - uid [string] owner - gid [string] group (If the gid is not displayed by ls, - this will still be set (to the same as uid)) - size [integer] file size in bytes - time [string] the time that ls displays, e.g. \"Feb 12 14:17\" - name [string] the name of the file - sym [string] if file is a symbolic link, the linked-to name, else \"\" - -For example, use - - (equal 0 size) - -to mark all zero length files." - ;; Using sym="" instead of nil avoids the trap of - ;; (string-match "foo" sym) into which a user would soon fall. - ;; Give `equal' instead of `=' in the example, as this works on - ;; integers and strings. - (interactive "xMark if (lisp expr): \nP") - (message "%s" predicate) - (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char)) - inode s mode nlink uid gid size time name sym) - (dired-mark-if - (save-excursion (and (dired-parse-ls) - (eval predicate))) - (format "'%s file" predicate)) - ;; With Jamie's compiler we could do the following instead: -; (eval (byte-compile-sexp -; (macroexpand -; (` (dired-mark-if -; (save-excursion (and (dired-parse-ls) -; (, predicate))) -; (format "'%s file" (quote (, predicate)))))))) - ;; This isn't measurably faster, though, at least for simple predicates. - ;; Caching compiled predicates might be interesting if you use - ;; this command a lot or with complicated predicates. - ;; Alternatively compiling PREDICATE by hand should not be too - ;; hard - e.g., if it uses just one variable, not all of the ls - ;; line needs to be parsed. - )) - -(if (fboundp 'gmhist-make-magic) - (gmhist-make-magic 'dired-mark-sexp 'eval-expression-history)) - -(defun dired-parse-ls () - ;; Sets vars - ;; inode s mode nlink uid gid size time name sym - ;; (probably let-bound in caller) according to current file line. - ;; Returns t for succes, nil if this is no file line. - ;; Upon success, all variables are set, either to nil or the - ;; appropriate value, so they need not be initialized. - ;; Moves point within the current line. - (if (dired-move-to-filename) - (let (pos - (mode-len 10) ; length of mode string - ;; like in dired.el, but with subexpressions \1=inode, \2=s: - (dired-re-inode-size "\\s *\\([0-9]*\\)\\s *\\([0-9]*\\) ?")) - (beginning-of-line) - (forward-char 2) - (if (looking-at dired-re-inode-size) - (progn - (goto-char (match-end 0)) - (setq inode (string-to-int (buffer-substring (match-beginning 1) - (match-end 1))) - s (string-to-int (buffer-substring (match-beginning 2) - (match-end 2))))) - (setq inode nil - s nil)) - (setq mode (buffer-substring (point) (+ mode-len (point)))) - (forward-char mode-len) - (setq nlink (read (current-buffer))) - (setq uid (buffer-substring (point) (progn (forward-word 1) (point)))) - (re-search-forward "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\)") - (goto-char (match-beginning 1)) - (forward-char -1) - (setq size (string-to-int (buffer-substring (save-excursion - (backward-word 1) - (setq pos (point))) - (point)))) - (goto-char pos) - (backward-word 1) - ;; if no gid is displayed, gid will be set to uid - ;; but user will then not reference it anyway in PREDICATE. - (setq gid (buffer-substring (save-excursion (forward-word 1) (point)) - (point)) - time (buffer-substring (match-beginning 1) - (1- (dired-move-to-filename))) - name (buffer-substring (point) - (or (dired-move-to-end-of-filename t) - (point))) - sym (progn - (if (looking-at " -> ") - (buffer-substring (progn (forward-char 4) (point)) - (progn (end-of-line) (point))) - ""))) - t) - nil)) - - -;; tester -;;(defun dired-parse-ls-show () -;; (interactive) -;; (let (inode s mode size uid gid nlink time name sym) -;; (if (dired-parse-ls) -;; (message "%s" (list inode s mode nlink uid gid size time name sym)) -;; (message "Not on a file line.")))) - - -;; Mark files whose names appear in another buffer. - -(defun dired-mark-these-files (file-list from) - ;; Mark the files in FILE-LIST. Relative filenames are taken to be - ;; in the current dired directory. - ;; FROM is a string (used for logging) describing where FILE-LIST - ;; came from. - ;; Logs files that were not found and displays a success or failure - ;; message. - (message "Marking files %s..." from) - (let ((total (length file-list)) - (cur-dir (dired-current-directory)) - file failures) - (while file-list - (setq file (dired-make-absolute (car file-list) cur-dir) - file-list (cdr file-list)) - ;;(message "Marking file `%s'" file) - (save-excursion - (if (dired-goto-file file) - (dired-mark-file 1) - (setq failures (cons (dired-make-relative file) failures)) - (dired-log "Cannot mark this file (not found): %s\n" file)))) - (if failures - (dired-log-summary (message "Failed to mark %d of %d files %s %s" - (length failures) total from failures)) - (message "Marked %d file%s %s." total (dired-plural-s total) from)))) - -(defun dired-mark-files-from-other-dired-buffer (buf) - "Mark files that are marked in the other Dired buffer. -I.e, mark those files in this Dired buffer that have the same -non-directory part as the marked files in the Dired buffer in the other window." - (interactive (list (window-buffer (next-window)))) - (if (eq (get-buffer buf) (current-buffer)) - (error "Other dired buffer is the same")) - (or (stringp buf) (setq buf (buffer-name buf))) - (let ((other-files (save-excursion - (set-buffer buf) - (or (eq major-mode 'dired-mode) - (error "%s is not a dired buffer" buf)) - (dired-mark-get-files 'no-dir)))) - (dired-mark-these-files other-files (concat "from buffer " buf)))) - -(defun dired-mark-files-compilation-buffer (&optional regexp buf) - "Mark the files mentioned in the `*compilation*' buffer. -With an arg, you may specify the other buffer and your own regexp -instead of `compilation-error-regexp'. -Use `^.+$' (the default with a prefix arg) to match complete lines or -an empty string for `compilation-error-regexp'. -In conjunction with narrowing the other buffer you can mark an -arbitrary list of files, one per line, with this command." - (interactive - (if current-prefix-arg - (list - (read-string "Use compilation regexp: " "^.+$") - (read-buffer "Use buffer: " - (let ((next-buffer (window-buffer (next-window)))) - (if (eq next-buffer (current-buffer)) - (other-buffer) - next-buffer)))))) - (let (other-files user-regexp-p) - (if (zerop (length regexp)) ; nil or "" - (setq regexp compilation-error-regexp) - (setq user-regexp-p t)) - (or buf (setq buf "*compilation*")) - (or (stringp buf) (setq buf (buffer-name buf))) - (save-excursion - (set-buffer (or (get-buffer buf) - (error "No %s buffer!" buf))) - (goto-char (point-min)) - (let (file new-file) - (while (re-search-forward regexp nil t) - (setq new-file - (buffer-substring - ;; If user specified a regexp with subexpr 1, and it - ;; matched, take that one for the file name, else - ;; take whole match. - ;; Else take the match from the compile regexp - (if user-regexp-p - (or (match-beginning 1) - (match-beginning 0)) - (match-beginning 1)) - (if user-regexp-p - (or (match-end 1) - (match-end 0)) - (match-beginning 2)))) - (or (equal file new-file) - ;; Avoid marking files twice as this is slow. Multiple - ;; lines for the same file are common when compiling. - (setq other-files (cons new-file other-files) - file new-file))))) - (dired-mark-these-files other-files (concat "from buffer " buf)))) - - -;; make-symbolic-link always expand-file-name's its args, so relative -;; symlinks (e.g. "foo" -> "../bar/foo") are impossible to create. -;; Following code uses ln -s for a workaround. - -(defvar dired-keep-marker-relsymlink ?S - "See variable `dired-keep-marker-move'.") - -(defun dired-make-symbolic-link (name1 name2 &optional ok-if-already-exists) - ;; Args NAME1 NAME2 &optional OK-IF-ALREADY-EXISTS. - ;; Create file NAME2, a symbolic link pointing to NAME1 (which may - ;; be any string whatsoever and is passed untouched to ln -s). - ;; OK-IF-ALREADY-EXISTS means that NAME2 will be overwritten if it - ;; already exists. If it is an integer, user will be asked about this. - ;; On error, signals a file-error. - (interactive "FSymlink to (string): \nFMake symbolic link to `%s': \np") - (setq name2 (expand-file-name name2)) - (let* ((file-symlink-p (file-symlink-p name2)) - (file-exists-p (file-exists-p name2)) ; dereferences symlinks - (file-or-symlink-exists (or file-symlink-p file-exists-p))) - (if (and file-symlink-p (not file-exists-p)) - ;; We do something dirty here as dired.el never checks - ;; file-symlink-p in addition to file-exists-p. - ;; This way me make sure we never silently overwrite even - ;; symlinks to non-existing files (what an achievement! ;-) - (setq ok-if-already-exists 1)) - (if (or (null ok-if-already-exists) - (integerp ok-if-already-exists)) - (if (and file-or-symlink-exists - (not (and (integerp ok-if-already-exists) - (yes-or-no-p - (format - "File %s already exists; symlink anyway? " - name2))))) - (signal 'file-error (cons "File already exists" name2)))) - ;; Bombs if NAME1 starts with "-", but not all ln programs may - ;; understand "--" to mean end of options...sigh - (let (err) - (if file-or-symlink-exists (delete-file name2)) - (setq err (dired-check-process "SymLink" "ln" "-s" name1 name2)) - (if err - (signal 'file-error (cons "ln" err)))))) - -(defun dired-make-relative-symlink (file1 file2 &optional ok-if-already-exists) - "Three arguments: FILE1 FILE2 &optional OK-IF-ALREADY-EXISTS -Make a symbolic link (pointing to FILE1) in FILE2. -The link is relative (if possible), for example - - \"/vol/tex/bin/foo\" \"/vol/local/bin/foo\" - -results in - - \"../../tex/bin/foo\" \"/vol/local/bin/foo\" -" - (interactive "FRelSymLink: \nFRelSymLink %s: \np") - (let (name1 name2 len1 len2 (index 0) sub) - (setq file1 (expand-file-name file1) - file2 (expand-file-name file2) - len1 (length file1) - len2 (length file2)) - ;; Find common initial pathname components: - (let (next) - (while (and (setq next (string-match "/" file1 index)) - (setq next (1+ next)) - (< next (min len1 len2)) - ;; For the comparison, both substrings must end in - ;; `/', so NEXT is *one plus* the result of the - ;; string-match. - ;; E.g., consider the case of linking "/tmp/a/abc" - ;; to "/tmp/abc" erronously giving "/tmp/a" instead - ;; of "/tmp/" as common initial component - (string-equal (substring file1 0 next) - (substring file2 0 next))) - (setq index next)) - (setq name2 file2 - sub (substring file1 0 index) - name1 (substring file1 index))) - (if (string-equal sub "/") - ;; No common initial pathname found - (setq name1 file1) - ;; Else they have a common parent directory - (let ((tem (substring file2 index)) - (start 0) - (count 0)) - ;; Count number of slashes we must compensate for ... - (while (setq start (string-match "/" tem start)) - (setq count (1+ count) - start (1+ start))) - ;; ... and prepend a "../" for each slash found: - (while (> count 0) - (setq count (1- count) - name1 (concat "../" name1))))) - (dired-make-symbolic-link - (directory-file-name name1) ; must not link to foo/ - ; (trailing slash!) - name2 ok-if-already-exists))) - -(defun dired-do-relsymlink (&optional arg) - "Symlink all marked (or next ARG) files into a directory, -or make a symbolic link to the current file. -This creates relative symbolic links like - - foo -> ../bar/foo - -not absolute ones like - - foo -> /ugly/path/that/may/change/any/day/bar/foo" - (interactive "P") - (dired-do-create-files 'relsymlink (function dired-make-relative-symlink) - "RelSymLink" arg dired-keep-marker-relsymlink)) - -;; XEmacs: added extra arg per tbarker@sun059.cpdsc.com (Ted Barker) -(defun dired-do-relsymlink-regexp (regexp newname &optional arg whole-path) - "RelSymlink all marked files containing REGEXP to NEWNAME. -See functions `dired-rename-regexp' and `dired-do-relsymlink' - for more info. With optional prefix ARG, will operate on ARG files following -point if no files are marked." - (interactive (dired-mark-read-regexp "RelSymLink")) - (dired-do-create-files-regexp - (function dired-make-relative-symlink) - "RelSymLink" arg regexp newname whole-path dired-keep-marker-relsymlink)) - -;; Virtual dired mode to browse ls -lR listings -;; sk@sun5 7-Mar-1991 16:00 - -(fset 'virtual-dired 'dired-virtual) -(defun dired-virtual (dirname &optional switches) - "Put this buffer into Virtual Dired mode. - -In Virtual Dired mode, all commands that do not actually consult the -filesystem will work. - -This is useful if you want to peruse and move around in an ls -lR -output file, for example one you got from an ftp server. With -ange-ftp, you can even dired a directory containing an ls-lR file, -visit that file and turn on virtual dired mode. But don't try to save -this file, as dired-virtual indents the listing and thus changes the -buffer. - -If you have save a Dired buffer in a file you can use \\[dired-virtual] to -resume it in a later session. - -Type \\\\[revert-buffer] in the -Virtual Dired buffer and answer `y' to convert the virtual to a real -dired buffer again. You don't have to do this, though: you can relist -single subdirs using \\[dired-do-redisplay]. -" - - ;; DIRNAME is the top level directory of the buffer. It will become - ;; its `default-directory'. If nil, the old value of - ;; default-directory is used. - - ;; Optional SWITCHES are the ls switches to use. - - ;; Shell wildcards will be used if there already is a `wildcard' - ;; line in the buffer (thus it is a saved Dired buffer), but there - ;; is no other way to get wildcards. Insert a `wildcard' line by - ;; hand if you want them. - - (interactive - (list (read-string "Virtual Dired directory: " (dired-virtual-guess-dir)))) - (goto-char (point-min)) - (or (looking-at " ") - ;; if not already indented, do it now: - (indent-region (point-min) (point-max) 2)) - (or dirname (setq dirname default-directory)) - (setq dirname (expand-file-name (file-name-as-directory dirname))) - (setq default-directory dirname) ; contains no wildcards - (let ((wildcard (save-excursion - (goto-char (point-min)) - (forward-line 1) - (and (looking-at "^ wildcard ") - (buffer-substring (match-end 0) - (progn (end-of-line) (point))))))) - (if wildcard - (setq dirname (expand-file-name wildcard default-directory)))) - ;; If raw ls listing (not a saved old dired buffer), give it a - ;; decent subdir headerline: - (goto-char (point-min)) - (or (looking-at dired-subdir-regexp) - (dired-insert-headerline default-directory)) - (dired-mode dirname (or switches dired-listing-switches)) - (setq mode-name "Virtual Dired" - revert-buffer-function 'dired-virtual-revert) - (set (make-local-variable 'dired-subdir-alist) nil) - (dired-build-subdir-alist) - (goto-char (point-min)) - (dired-initial-position dirname)) - -(defun dired-virtual-guess-dir () - - ;; Guess and return appropriate working directory of this buffer, - ;; assumed to be in Dired or ls -lR format. - ;; The guess is based upon buffer contents. - ;; If nothing could be guessed, returns nil. - - (let ((regexp "^\\( \\)?\\([^ \n\r]*\\)\\(:\\)[\n\r]") - (subexpr 2)) - (goto-char (point-min)) - (cond ((looking-at regexp) - ;; If a saved dired buffer, look to which dir and - ;; perhaps wildcard it belongs: - (let ((dir (buffer-substring (match-beginning subexpr) - (match-end subexpr)))) - (file-name-as-directory dir))) - ;; Else no match for headerline found. It's a raw ls listing. - ;; In raw ls listings the directory does not have a headerline - ;; try parent of first subdir, if any - ((re-search-forward regexp nil t) - (file-name-directory - (directory-file-name - (file-name-as-directory - (buffer-substring (match-beginning subexpr) - (match-end subexpr)))))) - (t ; if all else fails - nil)))) - - -(defun dired-virtual-revert (&optional arg noconfirm) - (if (not - (y-or-n-p "Cannot revert a Virtual Dired buffer - switch to Real Dired mode? ")) - (error "Cannot revert a Virtual Dired buffer.") - (setq mode-name "Dired" - revert-buffer-function 'dired-revert) - (revert-buffer))) - -;; A zero-arg version of dired-virtual. -;; You need my modified version of set-auto-mode for the -;; `buffer-contents-mode-alist'. -;; Or you use infer-mode.el and infer-mode-alist, same syntax. -(defun dired-virtual-mode () - "Put current buffer into virtual dired mode (see `dired-virtual'). -Useful on `buffer-contents-mode-alist' (which see) with the regexp - - \"^ \\(/[^ /]+\\)/?+:$\" - -to put saved dired buffers automatically into virtual dired mode. - -Also useful for `auto-mode-alist' (which see) like this: - - \(setq auto-mode-alist (cons '(\"[^/]\\.dired$\" . dired-virtual-mode) - auto-mode-alist)\) -" - (interactive) - (dired-virtual (dired-virtual-guess-dir))) - - -(defvar dired-find-subdir nil ; t is pretty near to DWIM... - "*If non-nil, Dired does not make a new buffer for a directory if it -can be found (perhaps as subdir) in some existing Dired buffer. - -If there are several Dired buffers for a directory, the most recently -used is chosen. - -Dired avoids switching to the current buffer, so that if you have -a normal and a wildcard buffer for the same directory, C-x d RET will -toggle between those two.") - -(or (fboundp 'dired-old-find-buffer-nocreate) - (fset 'dired-old-find-buffer-nocreate - (symbol-function 'dired-find-buffer-nocreate))) - -(defun dired-find-buffer-nocreate (dirname) ; redefine dired.el - (if dired-find-subdir - (let* ((cur-buf (current-buffer)) - (buffers (nreverse (dired-buffers-for-dir-exact dirname))) - (cur-buf-matches (and (memq cur-buf buffers) - ;; wildcards must match, too: - (equal dired-directory dirname)))) - ;; We don't want to switch to the same buffer--- - (setq buffers (delq cur-buf buffers));;need setq with delq - (or (car (sort buffers (function dired-x-buffer-more-recently-used-p))) - ;; ---unless it's the only possibility: - (and cur-buf-matches cur-buf))) - (dired-old-find-buffer-nocreate dirname))) - -;; this should be a builtin -(defun dired-x-buffer-more-recently-used-p (buffer1 buffer2) - "Return t if BUFFER1 is more recently used than BUFFER2." - (if (equal buffer1 buffer2) - nil - (let ((more-recent nil) - (list (buffer-list))) - (while (and list - (not (setq more-recent (equal buffer1 (car list)))) - (not (equal buffer2 (car list)))) - (setq list (cdr list))) - more-recent))) - -(defun dired-buffers-for-dir-exact (dir) -;; Return a list of buffers that dired DIR (a directory or wildcard) -;; at top level, or as subdirectory. -;; Top level matches must match the wildcard part too, if any. -;; The list is in reverse order of buffer creation, most recent last. -;; As a side effect, killed dired buffers for DIR are removed from -;; dired-buffers. - (let ((alist dired-buffers) result elt) - (while alist - (setq elt (car alist) - alist (cdr alist)) - (let ((buf (cdr elt))) - (if (buffer-name buf) - ;; Top level must match exactly against dired-directory in - ;; case one of them is a wildcard. - (if (or (equal dir (save-excursion (set-buffer buf) - dired-directory)) - (assoc dir (save-excursion (set-buffer buf) - dired-subdir-alist))) - (setq result (cons buf result))) - ;; else buffer is killed - clean up: - (setq dired-buffers (delq elt dired-buffers))))) - result)) - -(defun dired-buffers-for-top-dir (dir) -;; Return a list of buffers that dired DIR (a directory, not a wildcard) -;; at top level, with or without wildcards. -;; As a side effect, killed dired buffers for DIR are removed from -;; dired-buffers. - (setq dir (file-name-as-directory dir)) - (let ((alist dired-buffers) result elt) - (while alist - (setq elt (car alist) - alist (cdr alist)) - (let ((buf (cdr elt))) - (if (buffer-name buf) - (if (equal dir (save-excursion (set-buffer buf) default-directory)) - (setq result (cons buf result))) - ;; else buffer is killed - clean up: - (setq dired-buffers (delq elt dired-buffers))))) - result)) - -(defun dired-initial-position (dirname) ; redefine dired.el - (end-of-line) - (if dired-find-subdir (dired-goto-subdir dirname)) ; new - (if dired-trivial-filenames (dired-goto-next-nontrivial-file))) - -;;; Let `C-x f' and `C-x 4 f' know about Tree Dired's multiple directories. -;;; As a bonus, you get filename-at-point as default with a prefix arg. - -;; It's easier to add to this alist than redefine function -;; default-directory while keeping the old information. -(defconst default-directory-alist - '((dired-mode . (if (fboundp 'dired-current-directory) - (dired-current-directory) - default-directory))) - "Alist of major modes and their opinion on default-directory, as a -lisp expression to evaluate. A resulting value of nil is ignored in -favor of default-directory.") - -(defun default-directory () - "Usage like variable `default-directory', but knows about the special -cases in variable `default-directory-alist' (which see)." - (or (eval (cdr (assq major-mode default-directory-alist))) - default-directory)) - -(defun find-file-read-filename-at-point (prompt) - (if (fboundp 'gmhist-read-file-name) - (if current-prefix-arg - (let ((fn (filename-at-point))) - (gmhist-read-file-name - prompt (default-directory) fn nil - ;; the INITIAL arg is only accepted in Emacs 19 or with gmhist: - fn)) - (gmhist-read-file-name prompt (default-directory))) - ;; Else gmhist is not available, thus no initial input possible. - ;; Could use filename-at-point as default and mung prompt...ugh. - ;; Nah, get gmhist, folks! - (read-file-name prompt (default-directory)))) - -(defun filename-at-point () - "Get the filename closest to point, but don't change your position. -Has a preference for looking backward when not directly on a symbol." - ;; Not at all perfect - point must be right in the name. - (let ((filename-chars ".a-zA-Z0-9---_/:$") start end filename - (bol (save-excursion (beginning-of-line) (point))) - (eol (save-excursion (end-of-line) (point)))) - (save-excursion - ;; first see if you're just past a filename - (if (not (eobp)) - (if (looking-at "[] \t\n[{}()]") ; whitespace or some parens - (progn - (skip-chars-backward " \n\t\r({[]})") - (if (not (bobp)) - (backward-char 1))))) - (if (string-match (concat "[" filename-chars "]") - (char-to-string (following-char))) - (progn - (skip-chars-backward filename-chars) - (setq start (point)) - (if (string-match "[/~]" (char-to-string (preceding-char))) - (setq start (1- start))) - (skip-chars-forward filename-chars)) - (error "No file found around point!")) - (expand-file-name (buffer-substring start (point)))))) - -(defun find-this-file (fn) - "Edit file FILENAME. -Switch to a buffer visiting file FILENAME, creating one if none already exists. - -Interactively, with a prefix arg, calls `filename-at-point'. -Useful to edit the file mentioned in the buffer you are editing, or to -test if that file exists: use minibuffer completion after snatching the -name or part of it." - (interactive (list (find-file-read-filename-at-point "Find file: "))) - (find-file (expand-file-name fn))) - -(defun find-this-file-other-window (fn) - "Edit file FILENAME in other window. -Switch to a buffer visiting file FILENAME, creating one if none already exists. - -Interactively, with a prefix arg, call `filename-at-point'. -Useful to edit the file mentioned in the buffer you are editing, or to -test if that file exists: use minibuffer completion after snatching the -name or part of it." - (interactive (list (find-file-read-filename-at-point "Find file: "))) - (find-file-other-window (expand-file-name fn))) - -(defun dired-smart-shell-command (cmd &optional insert) - "Like function `shell-command', but in the current Tree Dired directory." - (interactive "sShell command: \nP") - (let ((default-directory (default-directory))) - (shell-command cmd insert))) - -(if (fboundp 'gmhist-make-magic) - (gmhist-make-magic 'dired-smart-shell-command 'shell-history)) - -(defun dired-smart-background-shell-command (cmd) - "Run a shell command in the background. -Like function `background' but in the current Tree Dired directory." - (interactive "s%% ") - (shell-command (concat "cd " (default-directory) "; " cmd " &"))) - -(if (fboundp 'gmhist-make-magic) - (gmhist-make-magic 'dired-smart-background-shell-command 'shell-history)) - - -;; Local variables for Dired buffers - -(defvar dired-local-variables-file ".dired" - "If non-nil, filename for local variables for Dired. -If Dired finds a file with that name in the current directory, it will -temporarily insert it into the dired buffer and run `hack-local-variables'. - -Type \\[info] and `g' `(emacs)File Variables' `RET' for more info on -local variables.") - -(defun dired-hack-local-variables () - "Parse, and bind or evaluate as appropriate, any local variables -for current dired buffer. -See variable `dired-local-variables-file'." - (if (and dired-local-variables-file - (file-exists-p dired-local-variables-file)) - (let (buffer-read-only opoint ) - (save-excursion - (goto-char (point-max)) - (setq opoint (point-marker)) - (insert "\^L\n") - (insert-file-contents dired-local-variables-file)) - (let ((buffer-file-name dired-local-variables-file)) - (hack-local-variables)) - ;; Must delete it as (eobp) is often used as test for last - ;; subdir in dired.el. - (delete-region opoint (point-max)) - (set-marker opoint nil)))) - -;; Guess what shell command to apply to a file. - -(defvar dired-guess-have-gnutar nil - "*If non-nil, name of the GNU tar executable (e.g. \"tar\" or \"gnutar\"). -GNU tar's `z' switch is used for compressed tar files. -If you don't have GNU tar, set this to nil: a pipe using `zcat' is then used.") - -(defvar dired-make-gzip-quiet t - "*If non-nil, pass -q to shell commands involving gzip this will override -GZIP environment variable.") - -(defvar dired-znew-switches nil - "*If non-nil, a string of switches that will be passed to `znew' -example: \"-K\"") - -(defvar dired-auto-shell-command-alist-default - (list - (list "\\.tar$" (if dired-guess-have-gnutar - (concat dired-guess-have-gnutar " xvf") - "tar xvf")) - - ;; regexps for compressed archives must come before the .Z rule to - ;; be recognized: - (list "\\.tar\\.Z$" (if dired-guess-have-gnutar - (concat dired-guess-have-gnutar " zxvf") - (concat "zcat * | tar xvf -")) - ;; optional conversion to gzip (GNU zip) format - (concat "znew" - (if dired-make-gzip-quiet " -q") - " " dired-znew-switches)) - - ;; gzip'ed (GNU zip) archives - (list "\\.tar\\.g?z$\\|\\.tgz$" (if dired-guess-have-gnutar - (concat dired-guess-have-gnutar " zxvf") - ;; use `gunzip -qc' instead of `zcat' since some - ;; people don't install GNU zip's version of zcat - (concat "gunzip -qc * | tar xvf -"))) - '("\\.shar.Z$" "zcat * | unshar") - ;; use `gunzip -c' instead of `zcat' - '("\\.shar.g?z$" "gunzip -qc * | unshar") - '("\\.ps$" "ghostview" "xv" "lpr") - '("\\.ps.g?z$" "gunzip -qc * | ghostview -" - ;; optional decompression - (concat "gunzip" (if dired-make-gzip-quiet " -q"))) - '("\\.ps.Z$" "zcat * | ghostview -" - ;; optional conversion to gzip (GNU zip) format - (concat "znew" - (if dired-make-gzip-quiet " -q") - " " dired-znew-switches)) - '("\\.dvi$" "xdvi" "dvips") - '("\\.au$" "play") ; play Sun audiofiles - '("\\.mpg$" "mpeg_play") - '("\\.dl$" "xdl") ; loop pictures - '("\\.fli$" "xanim") - '("\\.gl$" "xgrasp") - '("\\.uu$" "uudecode") - '("\\.hqx$" "mcvert") - '("\\.sh$" "sh") ; execute shell scripts - '("\\.xbm$" "bitmap") ; view X11 bitmaps - '("\\.xpm$" "sxpm") - '("\\.gp$" "gnuplot") - '("\\.p[bgpn]m$" "xv") - '("\\.gif$" "xv") ; view gif pictures - '("\\.tif$" "xv") - '("\\.jpg$" "xv") - '("\\.fig$" "xfig") ; edit fig pictures - '("\.tex$" "latex" "tex") - '("\\.texi\\(nfo\\)?$" "makeinfo" "texi2dvi") - (if (eq window-system 'x) ; under X, offer both... - '("\\.dvi$" "xtex" "dvips") ; ...preview and printing - '("\\.dvi$" "dvips")) - '("\\.g?z$" (concat "gunzip" (if dired-make-gzip-quiet " -q" ""))) ; quiet? - '("\\.Z$" "uncompress" - ;; optional conversion to gzip (GNU zip) format - (concat "znew" (if dired-make-gzip-quiet " -q") " " dired-znew-switches)) - ;; some popular archivers: - '("\\.zoo$" "zoo x//") - '("\\.zip$" "unzip") - '("\\.lzh$" "lharc x") - '("\\.arc$" "arc x") - '("\\.shar$" "unshar") ; use "sh" if you don't have unshar - ) - - "Default for variable `dired-auto-shell-command-alist' (which see). -Set this to nil to turn off shell command guessing.") - -(defvar dired-auto-shell-command-alist nil - "*If non-nil, an alist of file regexps and their suggested commands. -Dired shell commands will look up the name of a file in this list -and suggest the matching command as default. - -Each element of this list looks like - - \(REGEXP COMMAND...\) - -where each COMMAND can either be a string or a lisp expression that -evaluates to a string. If several COMMANDs are given, the first one -will be the default and minibuffer completion will use the given set. - -These rules take precedence over the predefined rules in the variable -`dired-auto-shell-command-alist-default' (to which they are prepended). - -You can set this variable in your ~/.emacs. For example, to add -rules for `.foo' and `.bar' files, write - -\(setq dired-auto-shell-command-alist - (list (list \"\\\\.foo$\" \"FOO-COMMAND\");; fixed rule - ;; possibly more rules ... - (list \"\\\\.bar$\";; rule with condition test - '(if condition - \"BAR-COMMAND-1\" - \"BAR-COMMAND-2\")))\) -") - -(setq dired-auto-shell-command-alist - (if dired-auto-shell-command-alist;; join user and default value: - (append dired-auto-shell-command-alist - dired-auto-shell-command-alist-default) - ;; else just copy the default value: - dired-auto-shell-command-alist-default)) - -(defun dired-guess-default (files) - ;; Guess a shell command for FILES. - ;; Returns a command or a list of commands. - ;; You may want to redefine this to try something smarter. - (if (or (cdr files) - (null dired-auto-shell-command-alist)) - nil ; If more than one file, don't guess - (let* ((file (car files)) - (alist dired-auto-shell-command-alist) - (case-fold-search nil) ; need search to be case-sensitive in order - ; to distinguish between gzip'ed (`.z') and - ; compressed (`.Z') files - elt re cmds) - (while alist - (setq elt (car alist) - re (car elt) - alist (cdr alist)) - (if (string-match re file) - (setq cmds (cdr elt) - alist nil))) - (cond ((not (cdr cmds)) (eval (car cmds))) ; single command - (t (mapcar (function eval) cmds)))))) - -(defun dired-guess-shell-command (prompt files) - ;;"Ask user with PROMPT for a shell command, guessing a default from FILES." - (let ((default (dired-guess-default files)) - default-list old-history val (failed t)) - (if (not (featurep 'gmhist)) - (read-string prompt (if (listp default) (car default) default)) - ;; else we have gmhist - (if (null default) - (read-with-history-in 'dired-shell-command-history prompt) - (or (boundp 'dired-shell-command-history) - (setq dired-shell-command-history nil)) - (setq old-history dired-shell-command-history) - (if (listp default) - ;; more than one guess - (setq default-list default - default (car default) - prompt (concat - prompt - (format "{%d guesses} " (length default-list)))) - ;; just one guess - (setq default-list (list default))) - (put 'dired-shell-command-history 'default default) - ;; push guesses onto history so that they can be retrieved with M-p - (setq dired-shell-command-history - (append default-list dired-shell-command-history)) - ;; the unwind-protect returns VAL, and we too. - (unwind-protect - (progn - (setq val (read-with-history-in - 'dired-shell-command-history prompt) - failed nil) - val) - (progn - ;; Undo pushing onto the history list so that an aborted - ;; command doesn't get the default in the next command. - (setq dired-shell-command-history old-history) - (if (not failed) - (or (equal val (car-safe dired-shell-command-history)) - (setq dired-shell-command-history - (cons val dired-shell-command-history)))))))))) - -;; redefine dired.el's version: -(defun dired-read-shell-command (prompt arg files) - "Read a dired shell command using generic minibuffer history. -This command tries to guess a command from the filename(s) -from the variable `dired-auto-shell-command-alist' (which see)." - (dired-mark-pop-up - nil 'shell files ; bufname type files - 'dired-guess-shell-command ; function &rest args - (format prompt (dired-mark-prompt arg files)) files)) - - -;; Byte-compile-and-load (requires jwz@lucid.com's new byte compiler) -(defun dired-do-byte-compile-and-load (&optional arg) - "Byte compile marked and load (or next ARG) Emacs lisp files. -This requires jwz@lucid.com's new optimizing byte compiler." - (interactive "P") - (dired-mark-map-check (function dired-byte-compile-and-load) arg - 'byte-compile-and-load t)) - -(defun dired-byte-compile-and-load () - ;; Return nil for success, offending file name else. - (let* (buffer-read-only - (from-file (dired-get-filename)) - (new-file (byte-compile-dest-file from-file))) - (if (not (string-match elisp-source-extention-re from-file)) - (progn - (dired-log "Attempt to compile non-elisp file %s\n" from-file) - ;; return a non-nil value as error indication - (dired-make-relative from-file)) - (save-excursion;; Jamie's compiler may switch buffer - (byte-compile-and-load-file from-file)) - (dired-remove-file new-file) - (forward-line) ; insert .elc after its .el file - (dired-add-file new-file) - nil))) - -;; Visit all marked files simultaneously. -;; After an idea by wurgler@zippysun.math.uakron.edu (Tom Wurgler). - -(defun dired-do-find-file (&optional arg) - "Visit all marked files at once, and display them simultaneously. -See also function `simultaneous-find-file'. -If you want to keep the dired buffer displayed, type \\[split-window-vertically] first. -If you want just the marked files displayed and nothing else, type \\[delete-other-windows] first." - (interactive "P") - (simultaneous-find-file (dired-mark-get-files nil arg))) - -(defun simultaneous-find-file (file-list) - "Visit all files in FILE-LIST and display them simultaneously. - -The current window is split across all files in FILE-LIST, as evenly -as possible. Remaining lines go to the bottommost window. - -The number of files that can be displayed this way is restricted by -the height of the current window and the variable `window-min-height'." - ;; It is usually too clumsy to specify FILE-LIST interactively - ;; unless via dired (dired-do-find-file). - (let ((size (/ (window-height) (length file-list)))) - (or (<= window-min-height size) - (error "Too many files to visit simultaneously")) - (find-file (car file-list)) - (setq file-list (cdr file-list)) - (while file-list - ;; Split off vertically a window of the desired size - ;; The upper window will have SIZE lines. We select the lower - ;; (larger) window because we want to split that again. - (select-window (split-window nil size)) - (find-file (car file-list)) - (setq file-list (cdr file-list))))) diff -r b88636d63495 -r 8fc7fe29b841 lisp/dired/dired-xemacs-highlight.el --- a/lisp/dired/dired-xemacs-highlight.el Mon Aug 13 08:50:06 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,207 +0,0 @@ -;;; Copyright (C) 1993 Cengiz Alaettinoglu -;;; Cengiz Alaettinoglu - -;;; Copyright (C) 1991 Tim Wilson and Sebastian Kremer -;;; Tim.Wilson@cl.cam.ac.uk -;;; Sebastian Kremer -;;; Modified to work with XEmacs - -;; Keywords: dired extensions, faces - -;; This file is part of XEmacs. - -;; XEmacs 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 2, or (at your option) -;; any later version. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: Not synched with FSF. - - -; How to install -; (add-hook 'dired-load-hook '(lambda () (require 'dired-xemacs-highlight)) t) - -(require 'dired) -(require 'dired-extra "dired-x") -(provide 'dired-xemacs-highlight) - -(or (find-face 'dired-face-marked) - (and - (make-face 'dired-face-marked) - (or (face-differs-from-default-p 'dired-face-marked) - (if (eq (device-class) 'color) - (progn - (set-face-foreground 'dired-face-marked (face-foreground 'default)) - (set-face-background 'dired-face-marked "PaleVioletRed")) - (set-face-underline-p 'dired-face-marked t))))) - -(or (find-face 'dired-face-deleted) - (and - (make-face 'dired-face-deleted) - (or (face-differs-from-default-p 'dired-face-deleted) - (if (eq (device-class) 'color) - (progn - (set-face-foreground 'dired-face-deleted - (face-foreground 'default)) - (set-face-background 'dired-face-deleted "LightSlateGray")) - (set-face-underline-p 'dired-face-deleted t))))) - -(or (find-face 'dired-face-directory) - (and - (make-face 'dired-face-directory) - (or (face-differs-from-default-p 'dired-face-directory) - (if (eq (device-class) 'color) - (progn - (set-face-foreground 'dired-face-directory - (face-foreground 'default)) - (make-face-bold 'dired-face-directory)) - (make-face-bold-italic 'dired-face-directory))))) - -(or (find-face 'dired-face-executable) - (and - (make-face 'dired-face-executable) - (or (face-differs-from-default-p 'dired-face-executable) - (if (eq (device-class) 'color) - (set-face-foreground 'dired-face-executable "SeaGreen") - (make-face-bold 'dired-face-executable))))) - -(or (find-face 'dired-face-setuid) - (and - (make-face 'dired-face-setuid) - (or (face-differs-from-default-p 'dired-face-setuid) - (if (eq (device-class) 'color) - (set-face-foreground 'dired-face-setuid "Red") - (make-face-bold 'dired-face-setuid))))) - -(or (find-face 'dired-face-socket) - (and - (make-face 'dired-face-socket) - (or (face-differs-from-default-p 'dired-face-socket) - (if (eq (device-class) 'color) - (set-face-foreground 'dired-face-socket "Gold") - (make-face-italic 'dired-face-socket))))) - -(or (find-face 'dired-face-symlink) - (and - (make-face 'dired-face-symlink) - (or (face-differs-from-default-p 'dired-face-symlink) - (if (eq (device-class) 'color) - (progn - (set-face-foreground 'dired-face-symlink "MediumBlue") - (make-face-bold 'dired-face-symlink)) - (make-face-italic 'dired-face-symlink))))) - -(or (find-face 'dired-face-boring) - (and - (make-face 'dired-face-boring) - (or (face-differs-from-default-p 'dired-face-boring) - (if (eq (device-class) 'color) - (set-face-foreground 'dired-face-boring "Grey") - (set-face-background-pixmap - 'dired-face-boring - [32 2 "\125\125\125\125\252\252\252\252"]))))) - -(defvar dired-do-permission-highlighting-too nil - "Set if we think we should use dired-chmod style permission highlighting. -This is determined at first-pass time, to avoid filtering the buffer twice.") - -(defvar dired-x11-re-boring (if (fboundp 'dired-omit-regexp) - (dired-omit-regexp) - "^#\\|~$") - "Regexp to match backup, autosave and otherwise boring files. -Those files are displayed in a boring color such as grey (see -variable `dired-x11-boring-color').") - -(defvar dired-re-socket - (concat dired-re-maybe-mark dired-re-inode-size "s")) - -(defvar dired-re-setuid - (concat dired-re-maybe-mark dired-re-inode-size - "-[-r][-w][Ss][-r][-w][sx][-r][-w][xst]") - "setuid plain file (even if not executable)") - -(defvar dired-re-setgid - (concat dired-re-maybe-mark dired-re-inode-size - "-[-r][-w][-x][-r][-w][Ss][-r][-w][xst]") - "setgid plain file (even if not executable)") - -(defun dired-xemacs-highlight-one (face) - (and (dired-move-to-filename t) - (set-extent-face (make-extent (dired-move-to-filename) - (dired-move-to-end-of-filename)) - face))) - -(defun dired-xemacs-highlight () - (message "Highlighting... directory") - ;; Let's try to do this in one pass... - (setq dired-do-permission-highlighting-too - (or dired-do-permission-highlighting-too (featurep 'dired-chmod))) - (if (and dired-do-permission-highlighting-too - (member 'dired-permissions-highlight dired-after-readin-hook)) - (remove-hook 'dired-after-readin-hook 'dired-permissions-highlight)) - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (and (not (eolp)) - (progn - (beginning-of-line) - (cond - ((re-search-forward - dired-x11-re-boring - (save-excursion - (end-of-line) - (point)) - t) - (dired-xemacs-highlight-one 'dired-face-boring)) - ((looking-at dired-re-dir) - (dired-xemacs-highlight-one 'dired-face-directory)) - ((looking-at dired-re-sym) - (dired-xemacs-highlight-one 'dired-face-symlink)) - ((or (looking-at dired-re-setuid) - (looking-at dired-re-setgid)) - (dired-xemacs-highlight-one 'dired-face-setuid)) - ((looking-at dired-re-exe) - (dired-xemacs-highlight-one 'dired-face-executable)) - ((looking-at dired-re-socket) - (dired-xemacs-highlight-one 'dired-face-socket))) - (if dired-do-permission-highlighting-too - (dired-make-permissions-interactive)))) - (forward-line 1)) - (message "Highlighting...done") - )) - -;FSF's version? -;(defconst dired-font-lock-keywords -; (list (cons "^\\*.*$" 'dired-face-marked) -; (cons "^\\D.*$" 'dired-face-deleted))) - -(defconst dired-font-lock-keywords (purecopy - (let ((bn (concat "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|" - "Aug\\|Sep\\|Oct\\|Nov\\|Dec\\) +[0-9]+ +[0-9:]+"))) - (list - '("^ [/~].*:$" . bold-italic) ; Header - (list (concat "^\\(\\([^ ].*\\)" bn "\\) \\(.*\\)$") 1 'bold) ; Marked - (list (concat "^. +d.*" bn " \\(.*\\)$") 2 'bold) ; Subdirs - (list (concat "^. +l.*" bn " \\(.*\\)$") 2 'italic) ; Links - (cons (concat "^. +-..[xsS]......\\|" ; Regular files with executable - "^. +-.....[xsS]...\\|" ; or setuid/setgid bits set - "^. +-........[xsS]") - 'bold) - ;; Possibly we should highlight more types of files differently: - ;; backups; autosaves; core files? Those with ignored-extensions? - ))) - "Expressions to highlight in Dired buffers.") - -(put 'dired-mode 'font-lock-keywords 'dired-font-lock-keywords) - -(add-hook 'dired-after-readin-hook 'dired-xemacs-highlight) diff -r b88636d63495 -r 8fc7fe29b841 lisp/dired/dired-xemacs-menu.el --- a/lisp/dired/dired-xemacs-menu.el Mon Aug 13 08:50:06 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,247 +0,0 @@ -;;; dired-xemacs-menu.el: A menu for the dired-mode. -;;; v2.90; 7 Dec 1993 -;;; Copyright (C) 1993 Heiko Muenkel -;;; email: muenkel@tnt.uni-hannover.de -;;; -;;; 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 1, 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; if not, write to the Free Software -;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -(require 'mode-motion) - -;; Popup and Pulldown Menu - -(defvar dired-menu - '("Dired Commands" - ["Open File" dired-find-file t] - ["Open File Other Window" dired-find-file-other-window t] - ["View File" dired-view-file t] - "----" - ("Mark" - ["Mark File" dired-mark-subdir-or-file t] - ["Mark Files in Region" dired-mark-region (mark)] - ["Mark Files by Regexp..." dired-mark-files-regexp t] - ["Mark All Directories" dired-mark-directories t] - ["Mark All Executables" dired-mark-executables t] - ["Mark All Symbolic Links" dired-mark-symlinks t] - "----" - ["Unmark File" dired-unmark-subdir-or-file t] - ["Unmark All Files" (dired-unflag-all-files nil) t] - ["Unmark All Files (Query)..." (dired-unflag-all-files nil t) t] - ["Unmark Files in Region" dired-unmark-region (mark)] - ) - ("Copy/Link" - ["Copy Files..." dired-do-copy t] - ["Copy Files by Regexp..." dired-do-copy-regexp t] - "----" - ["Symlink Files in Directory..." dired-do-symlink t] - ["Symlink Files in Directory by Regexp..." dired-do-symlink-regexp t] - "----" - ["Hard-Link Files in Directory..." dired-do-hardlink t] - ["Hard-Link Files in Directory by Regexp..." dired-do-hardlink-regexp t] - ) - ("Rename" - ["Rename Marked Files..." dired-do-move t] - ["Rename Files by Regexp..." dired-do-rename-regexp t] - "----" - ["Downcase Names of Marked Files..." dired-downcase t] - ["Upcase Names of Marked Files..." dired-upcase t] - ) - ("Delete" - ["Delete Marked Files..." dired-do-delete t] - ["Delete Flagged Files..." dired-do-deletions t] - "----" - ["Flag Marked Files for Deletion" dired-flag-file-deleted t] - ["Flag Files in Region for Deletion" dired-flag-region (mark)] - ["Flag Files for Deletion by Regexp..." dired-flag-regexp-files t] - ["Flag Backup Files for Deletion" dired-clean-directory t] - ["Flag Autosave Files for Deletion" dired-flag-auto-save-files t] - "----" - ["Unflag Marked Files" dired-unflag t] - ["Unflag Backup Files" dired-backup-unflag t] - ["Unflag All Files" (dired-unflag-all-files nil) t] - ["Unflag All Files (Query)..." (dired-unflag-all-files nil) t] - ["Unflag Files in Region" dired-unflag-region (mark)] - ) - ("Shell commands" - ["Compress Marked Files..." dired-do-compress t] - ["Uncompress Marked Files..." dired-do-uncompress t] - ["Print Marked Files..." dired-do-print t] - ["Shell Command on Marked Files..." dired-do-shell-command t] - "----" - ["Load Marked Files" dired-do-load t] - ["Byte-Compile Marked Files..." dired-do-byte-compile t] - "----" - ["Diff File Against Backup" dired-backup-diff t] - ["Diff File..." dired-diff t] - "----" - ["Change Permissions of Marked Files..." dired-do-chmod t] - ["Change Group of Marked Files..." dired-do-chgrp t] - ["Change Owner of Marked Files..." dired-do-chown t] - ) - "----" - ("Directory" - ["Up Directory" dired-up-directory t] - ["Home Directory" (dired "~/") t] - "----" - ["Dired..." dired t] - ["Dired Other Window..." dired-other-window t] - ["Redisplay All Files" revert-buffer t] - "----" - ["Create Directory..." dired-create-directory t] - "----" - ["Insert Subdirectory" dired-insert-subdir t] - ["Hide Subdirectory" dired-kill-subdir t] - ["Hide All Subdirectories..." dired-kill-tree t] - ) - ("Goto" - ["Next Directory Line" dired-next-dirline t] - ["Previous Directory Line" dired-prev-dirline t] - ["Next Marked File" dired-next-marked-file t] - ["Previous Marked File" dired-prev-marked-file t] - "----" - ["File..." dired-goto-file t] - ["Top of Directory..." dired-goto-subdir t] - ["Down Directory" dired-tree-down t] - ["Up Directory" dired-tree-up t] - ) - ("Display" - ["Undisplay Line or Subdirectory" dired-kill-line-or-subdir t] - ["Undisplay Tree" dired-kill-tree t] - ["Undisplay Marked Lines" dired-do-kill t] - "----" - ["Redisplay All Files" revert-buffer t] - ["Redisplay All Marked Files" dired-do-redisplay t] - ["Undo" dired-undo t] - "----" - ["Sort by Date/Name (Toggle)" dired-sort-toggle-or-edit t] - ["Edit `ls' Switches..." (dired-sort-toggle-or-edit t) t] - ) - "----" - ("Options, This Buffer" - ["Action is find-file" (set (make-local-variable 'dired-mouse-action) - 'dired-mouse-find-file) - :style radio - :selected (eq dired-mouse-action 'dired-mouse-find-file)] - ["Action is find-file-other-window" - (set (make-local-variable 'dired-mouse-action) - 'dired-mouse-find-file-other-window) - :style radio - :selected (eq dired-mouse-action 'dired-mouse-find-file-other-window)]) - ("Options, Global" - ["Action is find-file" (setq-default dired-mouse-action - 'dired-mouse-find-file) - :style radio - :selected (eq (default-value 'dired-mouse-action) - 'dired-mouse-find-file)] - ["Action is find-file-other-window" - (setq-default dired-mouse-action 'dired-mouse-find-file-other-window) - :style radio - :selected (eq (default-value 'dired-mouse-action) - 'dired-mouse-find-file-other-window)]) - "----" - ["Explain Last Failure" dired-why t] - ) - "*The menu for Dired.") - -(defun dired-mouse-file-on-line-p (event) - "Return t if there is a file under the mouse." - (interactive "@e") - (save-excursion - (mouse-set-point event) - (if (dired-move-to-filename) - t - nil))) - -(defun dired-mode-motion-highlight-line (event) - (if (dired-mouse-file-on-line-p event) - (mode-motion-highlight-line event))) - -(defun dired-install-menubar () - "Installs the Dired menu at the menubar." - (if (and (boundp 'current-menubar) current-menubar - (not (assoc "Dired" current-menubar))) - (progn - (set-buffer-menubar (copy-sequence current-menubar)) - (add-menu nil "Dired" (cdr dired-menu)))) - (make-local-variable 'mode-motion-hook) - (setq mode-motion-hook '(dired-mode-motion-highlight-line - mode-motion-add-help-echo)) - ;; #### double-click left is supposed to work but it doesn't. - ;; I'm not sure why. - (setq mode-motion-help-echo-string - "Middle button to select file under mouse.") - ) -(add-hook 'dired-mode-hook 'dired-install-menubar) - -(defun dired-popup-menu (event) - "Display the Dired Menu." - (interactive "@e") - (mouse-set-point event) - (dired-next-line 0) - (popup-menu dired-menu)) - -(defun dired-mouse-find-file (event) - "Edit the file under the mouse." - (interactive "e") - (mouse-set-point event) - (dired-next-line 0) - (dired-find-file)) - -(defun dired-mouse-find-file-other-window (event) - "Edit the file under the mouse, in another window." - (interactive "e") - (mouse-set-point event) - (dired-next-line 0) - (dired-find-file-other-window)) - -(defvar dired-mouse-action 'dired-mouse-find-file - "*Function to be called when button2 is clicked on a file in Dired.") - -(defun dired-mouse-do-action (event) - (interactive "e") - (funcall dired-mouse-action event)) - -(defun dired-mark-region (&optional form-to-eval) - "Mark all files in the region." - (interactive) - (or form-to-eval (setq form-to-eval '(dired-mark-subdir-or-file nil))) - (save-excursion - (let ((end (region-end))) - (goto-char (region-beginning)) - (beginning-of-line) - (while (<= (point) end) - (save-excursion (eval form-to-eval)) - (forward-line 1))))) - -(defun dired-unmark-region () - "Unmark all files in the region." - (interactive) - (dired-mark-region '(dired-unmark-subdir-or-file nil))) - -(defun dired-flag-region () - "Flag all files in the region for deletion." - (interactive) - (dired-mark-region '(dired-flag-file-deleted nil))) - -(defun dired-unflag-region () - "Unflag all files in the region for deletion." - (interactive) - (dired-mark-region '(dired-unflag 1))) - - -(define-key dired-mode-map 'button2 'dired-mouse-do-action) -(define-key dired-mode-map 'button3 'dired-popup-menu) - - -(provide 'dired-xemacs-menu) diff -r b88636d63495 -r 8fc7fe29b841 lisp/dired/dired.el --- a/lisp/dired/dired.el Mon Aug 13 08:50:06 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,3781 +0,0 @@ -;;; dired.el --- directory-browsing commands -;; Keywords: dired extensions - -;; Copyright (C) 1985, 1986, 1991, 1992 Free Software Foundation, Inc. - -;; This file is part of XEmacs. - -;; XEmacs 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 2, or (at your option) -;; any later version. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;; Rewritten in 1990/1991 to add tree features, file marking and -;; sorting by Sebastian Kremer . - -(provide 'dired) - -(defconst dired-version (substring "!Revision: 6.0 !" 11 -2) - "The revision number of Tree Dired (as string). The complete RCS id is: - - !Id: dired.el,v 6.0 1992/05/15 14:25:45 sk RelBeta ! - -Don't forget to mention this when reporting bugs to: - - Sebastian Kremer - -Tree dired is available for anonymous ftp in USA in: - - ftp.cs.buffalo.edu:pub/Emacs/diredall.tar.Z - -and in Europe at my own site in Germany: - - ftp.uni-koeln.de:/pub/gnu/emacs/diredall.tar.Z") -;; Should perhaps later give bug-gnu-emacs@prep.gnu.ai.mit.edu instead. - -;; compatibility package when using Emacs 18.55 -;; XEmacs fix: -(defvar dired-emacs-19-p (not (equal (substring emacs-version 0 2) "18"))) -;;;#### install (is there a better way to test for Emacs 19?) -(or dired-emacs-19-p - (require 'emacs-19)) - -;;; Customizable variables - -;;; The funny comments are for autoload.el, to automagically update -;;; loaddefs. - -(defvar dired-use-gzip-instead-of-compress t - "*If non-nil, use gzip instead of compress as the standard compress -program") - -(defvar dired-make-gzip-quiet t - "*If non-nil, pass -q to shell commands involving gzip this will override -GZIP environment variable.") - -(defvar dired-znew-switches nil - "*If non-nil, a string of switches that will be passed to `znew' -example: \"-K\"") - -(defvar dired-gzip-file-extension ".gz" - "*A string representing the suffix created by gzip. This should probably -match the value of --suffix or -S in the GZIP environment variable if it -exists and \".gz\" if it does not.") - -;;;###autoload -(defvar dired-listing-switches (purecopy "-al") - "*Switches passed to ls for dired. MUST contain the `l' option. -Can contain even `F', `b', `i' and `s'.") - -; Don't use absolute paths as /bin should be in any PATH and people -; may prefer /usr/local/gnu/bin or whatever. However, chown is -; usually not in PATH. - -;;;###autoload -(defvar dired-chown-program - (purecopy - (if (memq system-type '(dgux-unix hpux usg-unix-v silicon-graphics-unix irix)) - "chown" "/etc/chown")) - "*Name of chown command (usully `chown' or `/etc/chown').") - -;;;###autoload -(defvar dired-ls-program (purecopy "ls") - "*Absolute or relative name of the ls program used by dired.") - -;;;###autoload -(defvar dired-ls-F-marks-symlinks t - "*Informs dired about how ls -lF marks symbolic links. -Set this to t if `dired-ls-program' with -lF marks the symbolic link -itself with a trailing @ (usually the case under Ultrix). - -Example: if `ln -s foo bar; ls -F bar' gives `bar -> foo', set it to -nil, if it gives `bar@ -> foo', set it to t. - -Dired checks if there is really a @ appended. Thus, if you have a -marking ls program on one host and a non-marking on another host, and -don't care about symbolic links which really end in a @, you can -always set this variable to t.") - -;;;###autoload -(defvar dired-trivial-filenames (purecopy "^\\.\\.?$\\|^#") - "*Regexp of files to skip when moving point to the first file of a new directory listing. -Nil means move to the subdir line, t means move to first file.") - -;;;###autoload -(defvar dired-keep-marker-move t - ;; Use t as default so that moved files `take their markers with them' - "If t, moved marked files are marked if their originals were. -If a character, those files (marked or not) are marked with that character.") - -;;;###autoload -(defvar dired-keep-marker-copy ?C - "If t, copied files are marked if their source files were. -If a character, those files are always marked with that character.") - -;;;###autoload -(defvar dired-keep-marker-hardlink ?H - "If t, hard-linked files are marked if the linked-to files were. -If a character, those files are always marked with that character.") - -;;;###autoload -(defvar dired-keep-marker-symlink ?Y - "If t, symlinked marked files are marked if the linked-to files were. -If a character, those files are always marked with that character.") - -;;;###autoload -(defvar dired-dwim-target nil - "*If non-nil, dired tries to guess a default target directory: -If there is a dired buffer displayed in the next window, use -its current subdir, instead of the current subdir of this dired -buffer. - -The target is used in the prompt for file copy, move etc.") - -;;;###autoload -(defvar dired-copy-preserve-time nil - "*If non-nil, Dired preserves the last-modified time in a file copy. -\(This works on only some systems.)\\ -Use `\\[dired-do-copy]' with a zero prefix argument to toggle its value.") - -;;; Hook variables - -(defvar dired-load-hook nil - "Run after loading dired. -You can customize key bindings or load extensions with this.") - -(defvar dired-mode-hook nil - "Run at the very end of dired-mode.") - -(defvar dired-before-readin-hook nil - "This hook is run before a dired buffer is newly read in (created or reverted).") - -(defvar dired-after-readin-hook nil - "After each listing of a file or directory, this hook is run -with the buffer narrowed to the listing.") -;; Note this can't simply be run inside function dired-ls as the hook -;; functions probably depend on the dired-subdir-alist to be OK. - -;;; Internal variables - -(defvar dired-marker-char ?* ; the answer is 42 - ;; so that you can write things like - ;; (let ((dired-marker-char ?X)) - ;; ;; great code using X markers ... - ;; ) - ;; For example, commands operating on two sets of files, A and B. - ;; Or marking files with digits 0-9. This could implicate - ;; concentric sets or an order for the marked files. - ;; The code depends on dynamic scoping on the marker char. - "In dired, character used to mark files for later commands.") - -(defvar dired-del-marker ?D - "Character used to flag files for deletion.") - -(defvar dired-shrink-to-fit - (if (fboundp 'baud-rate) (> (baud-rate) search-slow-speed) t) - "Whether dired shrinks the display buffer to fit the marked files.") - -(defvar dired-flagging-regexp nil);; Last regexp used to flag files. - -(defvar dired-directory nil - "The directory name or shell wildcard passed as argument to ls. -Local to each dired buffer.") - -(defvar dired-actual-switches nil - "The actual (buffer-local) value of `dired-listing-switches'.") - -(defvar dired-re-inode-size "[0-9 \t]*" - "Regexp for optional initial inode and file size as produced by ls' -i and -s flags.") - -;; These regexps must be tested at beginning-of-line, but are also -;; used to search for next matches, so neither omitting "^" nor -;; replacing "^" by "\n" (to make it slightly faster) will work. - -(defvar dired-re-mark "^[^ \n]") -;; "Regexp matching a marked line. -;; Important: the match ends just after the marker." -(defvar dired-re-maybe-mark "^. ") -;; Note that dired-re-inode-size allows for an arbitray amount of -;; whitespace, making nested indentation in dired-nstd.el work. -(defvar dired-re-dir (concat dired-re-maybe-mark dired-re-inode-size "d")) -(defvar dired-re-sym (concat dired-re-maybe-mark dired-re-inode-size "l")) -(defvar dired-re-exe;; match ls permission string of an executable file - (mapconcat (function - (lambda (x) - (concat dired-re-maybe-mark dired-re-inode-size x))) - '("-[-r][-w][xs][-r][-w].[-r][-w]." - "-[-r][-w].[-r][-w][xs][-r][-w]." - "-[-r][-w].[-r][-w].[-r][-w][xst]") - "\\|")) -(defvar dired-re-dot "^.* \\.\\.?/?$") ; with -F, might end in `/' - -(defvar dired-subdir-alist nil - "Association list of subdirectories and their buffer positions: - - \((LASTDIR . LASTMARKER) ... (DEFAULT-DIRECTORY . FIRSTMARKER)).") - -(defvar dired-subdir-regexp "^. \\([^ \n\r]+\\)\\(:\\)[\n\r]" - "Regexp matching a maybe hidden subdirectory line in ls -lR output. -Subexpression 1 is the subdirectory proper, no trailing colon. -The match starts at the beginning of the line and ends after the end -of the line (\\n or \\r). -Subexpression 2 must end right before the \\n or \\r.") - - -;;; Macros must be defined before they are used - for the byte compiler. - -;; Returns the count if any work was done, nil otherwise. -(defmacro dired-mark-if (predicate msg) - (` (let (buffer-read-only count) - (save-excursion - (setq count 0) - (if (, msg) (message "Marking %ss..." (, msg))) - (goto-char (point-min)) - (while (not (eobp)) - (if (, predicate) - (progn - (delete-char 1) - (insert dired-marker-char) - (setq count (1+ count)))) - (forward-line 1)) - (if (, msg) (message "%s %s%s %s%s." - count - (, msg) - (dired-plural-s count) - (if (eq dired-marker-char ?\040) "un" "") - (if (eq dired-marker-char dired-del-marker) - "flagged" "marked")))) - (and (> count 0) count)))) - -(defmacro dired-mark-map (body arg &optional show-progress) -;; "Macro: Perform BODY with point somewhere on each marked line -;;and return a list of BODY's results. -;;If no marked file could be found, execute BODY on the current line. -;; If ARG is an integer, use the next ARG (or previous -ARG, if ARG<0) -;; files instead of the marked files. -;; In that case point is dragged along. This is so that commands on -;; the next ARG (instead of the marked) files can be chained easily. -;; If ARG is otherwise non-nil, use current file instead. -;;If optional third arg SHOW-PROGRESS evaluates to non-nil, -;; redisplay the dired buffer after each file is processed. -;;No guarantee is made about the position on the marked line. -;; BODY must ensure this itself if it depends on this. -;;Search starts at the beginning of the buffer, thus the car of the list -;; corresponds to the line nearest to the buffer's bottom. This -;; is also true for (positive and negative) integer values of ARG. -;;BODY should not be too long as it is expanded four times." -;; -;;Warning: BODY must not add new lines before point - this may cause an -;;endless loop. -;;This warning should not apply any longer, sk 2-Sep-1991 14:10. - (` (prog1 - (let (buffer-read-only case-fold-search found results) - (if (, arg) - (if (integerp (, arg)) - (progn;; no save-excursion, want to move point. - (dired-repeat-over-lines - (, arg) - (function (lambda () - (if (, show-progress) (sit-for 0)) - (setq results (cons (, body) results))))) - (if (< (, arg) 0) - (nreverse results) - results)) - ;; non-nil, non-integer ARG means use current file: - (list (, body))) - (let ((regexp (dired-marker-regexp)) next-position) - (save-excursion - (goto-char (point-min)) - ;; remember position of next marked file before BODY - ;; can insert lines before the just found file, - ;; confusing us by finding the same marked file again - ;; and again and... - (setq next-position (and (re-search-forward regexp nil t) - (point-marker)) - found (not (null next-position))) - (while next-position - (goto-char next-position) - (if (, show-progress) (sit-for 0)) - (setq results (cons (, body) results)) - ;; move after last match - (goto-char next-position) - (forward-line 1) - (set-marker next-position nil) - (setq next-position (and (re-search-forward regexp nil t) - (point-marker))))) - (if found - results - (list (, body)))))) - ;; save-excursion loses, again - (dired-move-to-filename)))) - -(defun dired-mark-get-files (&optional localp arg) - "Return the marked files as list of strings. -The list is in the same order as the buffer, that is, the car is the - first marked file. -Values returned are normally absolute pathnames. -Optional arg LOCALP as in `dired-get-filename'. -Optional second argument ARG forces to use other files. If ARG is an - integer, use the next ARG files. If ARG is otherwise non-nil, use - current file. Usually ARG comes from the current prefix arg." - (nreverse (save-excursion (dired-mark-map (dired-get-filename localp) arg)))) - - -;; Function dired-ls is redefinable for VMS, ange-ftp, Prospero or -;; other special applications. - -;; dired-ls -;; - must insert _exactly_one_line_ describing FILE if WILDCARD and -;; FULL-DIRECTORY-P is nil. -;; The single line of output must display FILE's name as it was -;; given, namely, an absolute path name. -;; - must insert exactly one line for each file if WILDCARD or -;; FULL-DIRECTORY-P is t, plus one optional "total" line -;; before the file lines, plus optional text after the file lines. -;; Lines are delimited by "\n", so filenames containing "\n" are not -;; allowed. -;; File lines should display the basename, not a path name. -;; - must drag point after inserted text -;; - must be consistent with -;; - functions dired-move-to-filename, (these two define what a file line is) -;; dired-move-to-end-of-filename, -;; dired-between-files, (shortcut for (not (dired-move-to-filename))) -;; dired-insert-headerline -;; dired-after-subdir-garbage (defines what a "total" line is) -;; - variables dired-subdir-regexp -(defun dired-ls (file switches &optional wildcard full-directory-p) -; "Insert ls output of FILE, formatted according to SWITCHES. -;Optional third arg WILDCARD means treat FILE as shell wildcard. -;Optional fourth arg FULL-DIRECTORY-P means file is a directory and -;switches do not contain `d', so that a full listing is expected. -; -;Uses dired-ls-program (and shell-file-name if WILDCARD) to do the work." - (if wildcard - (let ((default-directory (file-name-directory file))) - (call-process shell-file-name nil t nil - "-c" (concat dired-ls-program " -d " switches " " - (file-name-nondirectory file)))) - (call-process dired-ls-program nil t nil switches file))) - -;; The dired command - -(defun dired-read-dir-and-switches (str) - ;; For use in interactive. - (reverse (list - (if current-prefix-arg - (read-string "Dired listing switches: " - dired-listing-switches)) - (read-file-name (format "Dired %s(directory): " str) - nil default-directory nil)))) - -;;;###autoload (define-key ctl-x-map "d" 'dired) -;;;###autoload -(defun dired (dirname &optional switches) - "\"Edit\" directory DIRNAME--delete, rename, print, etc. some files in it. -With an optional prefix argument you can specify the ls SWITCHES that are used. -Dired displays a list of files in DIRNAME (which may also have - shell wildcards appended to select certain files). -You can move around in it with the usual commands. -You can flag files for deletion with \\\\[dired-flag-file-deleted] and then delete them by - typing \\[dired-do-deletions]. -Type \\[describe-mode] after entering dired for more info. - -If DIRNAME is already in a dired buffer, that buffer is used without refresh." - ;; Cannot use (interactive "D") because of wildcards. - (interactive (dired-read-dir-and-switches "")) - (switch-to-buffer (dired-noselect dirname switches))) - -;;;###autoload (define-key ctl-x-4-map "d" 'dired-other-window) -;;;###autoload -(defun dired-other-window (dirname &optional switches) - "\"Edit\" directory DIRNAME. Like `dired' but selects in another window." - (interactive (dired-read-dir-and-switches "in other window ")) - (switch-to-buffer-other-window (dired-noselect dirname switches))) - -;;;###autoload -(defun dired-noselect (dirname &optional switches) - "Like `dired' but returns the dired buffer as value, does not select it." - (or dirname (setq dirname default-directory)) - ;; This loses the distinction between "/foo/*/" and "/foo/*" that - ;; some shells make: - (setq dirname (expand-file-name (directory-file-name dirname))) - (if (file-directory-p dirname) - (setq dirname (file-name-as-directory dirname))) - (dired-internal-noselect dirname switches)) - -;; Separate function from dired-noselect for the sake of dired-vms.el. -(defun dired-internal-noselect (dirname &optional switches) - ;; If there is an existing dired buffer for DIRNAME, just leave - ;; buffer as it is (don't even call dired-revert). - ;; This saves time especially for deep trees or with ange-ftp. - ;; The user can type `g'easily, and it is more consistent with find-file. - ;; But if SWITCHES are given they are probably different from the - ;; buffer's old value, so call dired-sort-other, which does - ;; revert the buffer. - ;; A pity we can't possibly do "Directory has changed - refresh? " - ;; like find-file does...maybe in the GNU OS. - (let* ((buffer (dired-find-buffer-nocreate dirname)) - ;; note that buffer already is in dired-mode, if found - (new-buffer-p (not buffer)) - (old-buf (current-buffer))) - (or buffer - (let ((default-major-mode 'fundamental-mode)) - ;; We don't want default-major-mode to run hooks and set auto-fill - ;; or whatever, now that dired-mode does not - ;; kill-all-local-variables any longer. - (setq buffer (create-file-buffer (directory-file-name dirname))))) - (set-buffer buffer) - (if (not new-buffer-p) ; existing buffer ... - (if switches ; ... but new switches - (dired-sort-other switches)) ; this calls dired-revert - ;; Else a new buffer - (setq default-directory (if (file-directory-p dirname) - dirname - (file-name-directory dirname))) - (or switches (setq switches dired-listing-switches)) - (dired-mode dirname switches) - ;; default-directory and dired-actual-switches are set now - ;; (buffer-local), so we can call dired-readin: - (let ((failed t)) - (unwind-protect - (progn (dired-readin dirname buffer) - (setq failed nil)) - ;; dired-readin can fail if parent directories are inaccessible. - ;; Don't leave an empty buffer around in that case. - (if failed (kill-buffer buffer)))) - ;; No need to narrow since the whole buffer contains just - ;; dired-readin's output, nothing else. The hook can - ;; successfully use dired functions (e.g. dired-get-filename) - ;; as the subdir-alist has been built in dired-readin. - (let ((buffer-read-only nil)) - (run-hooks 'dired-after-readin-hook)) - (goto-char (point-min)) - (dired-initial-position dirname)) - (set-buffer old-buf) - buffer)) - -;; This differs from dired-buffers-for-dir in that it does not consider -;; subdirs of default-directory and searches for the first match only -(defun dired-find-buffer-nocreate (dirname) - (let (found (blist (buffer-list))) - (while blist - (save-excursion - (set-buffer (car blist)) - (if (and (eq major-mode 'dired-mode) - (equal dired-directory dirname)) - (setq found (car blist) - blist nil) - (setq blist (cdr blist))))) - found)) - - -;; Read in a new dired buffer - -;; dired-readin differs from dired-insert-subdir in that it accepts -;; wildcards, erases the buffer, and builds the subdir-alist anew -;; (including making it buffer-local and clearing it first). -(defun dired-readin (dirname buffer) - ;; default-directory and dired-actual-switches must be buffer-local - ;; and initialized by now. - ;; Thus we can test (equal default-directory dirname) instead of - ;; (file-directory-p dirname) and save a filesystem transaction. - ;; Also, we can run this hook which may want to modify the switches - ;; based on default-directory, e.g. with ange-ftp to a SysV host - ;; where ls won't understand -Al switches. - (setq dirname (expand-file-name dirname)) - (run-hooks 'dired-before-readin-hook) - (save-excursion - (message "Reading directory %s..." dirname) - (set-buffer buffer) - (let (buffer-read-only) - (widen) - (erase-buffer) - (dired-readin-insert dirname) - (dired-indent-rigidly (point-min) (point-max) 2) - ;; We need this to make the root dir have a header line as all - ;; other subdirs have: - (goto-char (point-min)) - (dired-insert-headerline default-directory) - ;; can't run dired-after-readin-hook here, it may depend on the subdir - ;; alist to be OK. - ) - (message "Reading directory %s...done" dirname) - (set-buffer-modified-p nil) - ;; Must first make alist buffer local and set it to nil because - ;; dired-build-subdir-alist will call dired-clear-alist first - (set (make-local-variable 'dired-subdir-alist) nil) - (let (case-fold-search) - (if (string-match "R" dired-actual-switches) - (dired-build-subdir-alist) - ;; no need to parse the buffer if listing is not recursive - (dired-simple-subdir-alist))))) - -;; Subroutines of dired-readin - -(defun dired-readin-insert (dirname) - ;; Just insert listing for DIRNAME, assuming a clean buffer. - (let ((font-lock-mode nil)) - (if (equal default-directory dirname);; i.e., (file-directory-p dirname) - (dired-ls (if (or (let (case-fold-search) - (string-match "R" dired-actual-switches)) - (eq system-type 'vax-vms)) - dirname - ;; On SysV derived system, symbolic links to - ;; directories are not resolved, while on BSD - ;; derived it suffices to let DIRNAME end in slash. - ;; We always let it end in "/." since it does no - ;; harm on BSD and makes Dired work on such links on - ;; SysV. - ;; Cannot do this with -R since "dir/./subdir" - ;; headerlines would result, utterly confusing dired. - (concat dirname ".")) - dired-actual-switches nil t) - (if (not (file-readable-p - (directory-file-name (file-name-directory dirname)))) - (error "Directory %s inaccessible or nonexistent" dirname) - ;; else assume it contains wildcards: - (dired-ls dirname dired-actual-switches t) - (save-excursion;; insert wildcard instead of total line: - (goto-char (point-min)) - (insert "wildcard " (file-name-nondirectory dirname) "\n")))))) - -(defun dired-insert-headerline (dir);; also used by dired-insert-subdir - ;; Insert DIR's headerline with no trailing slash, exactly like ls - ;; would, and put cursor where dired-build-subdir-alist puts subdir - ;; boundaries. - (save-excursion (insert " " (directory-file-name dir) ":\n"))) - -;; Make the file names highlight when the mouse is on them. -;; from FSF 19.30. -(defun dired-insert-set-properties (beg end) - (save-excursion - (goto-char beg) - (while (< (point) end) - (condition-case nil - (if (dired-move-to-filename) - (put-text-property (point) - (save-excursion - (dired-move-to-end-of-filename) - (point)) - 'highlight t)) - (error nil)) - (forward-line 1)))) - - -;; Reverting a dired buffer - -(defun dired-revert (&optional arg noconfirm) - ;; Reread the dired buffer. Must also be called after - ;; dired-actual-switches have changed. - ;; Should not fail even on completely garbaged buffers. - ;; Preserves old cursor, marks/flags, hidden-p. - (widen) ; just in case user narrowed - (let ((opoint (point)) - (ofile (dired-get-filename nil t)) - (mark-alist nil) ; save marked files - (hidden-subdirs (dired-remember-hidden)) - (old-subdir-alist (cdr (reverse dired-subdir-alist))) ; except pwd - case-fold-search ; we check for upper case ls flags - buffer-read-only) - (goto-char (point-min)) - (setq mark-alist;; only after dired-remember-hidden since this unhides: - (dired-remember-marks (point-min) (point-max))) - ;; treat top level dir extra (it may contain wildcards) - (dired-readin dired-directory (current-buffer)) - (let ((dired-after-readin-hook nil)) - ;; don't run that hook for each subdir... - (dired-insert-old-subdirs old-subdir-alist)) - (dired-mark-remembered mark-alist) ; mark files that were marked - ;; ... run the hook for the whole buffer, and only after markers - ;; have been reinserted (else omitting in dired-x would omit marked files) - (run-hooks 'dired-after-readin-hook) ; no need to narrow - (or (and ofile (dired-goto-file ofile)) ; move cursor to where it - (goto-char opoint)) ; was before - (dired-move-to-filename) - (save-excursion ; hide subdirs that were hidden - (mapcar (function (lambda (dir) - (if (dired-goto-subdir dir) - (dired-hide-subdir 1)))) - hidden-subdirs))) - ;; outside of the let scope - (setq buffer-read-only t)) - -;; Subroutines of dired-revert -;; Some of these are also used when inserting subdirs. - -(defun dired-remember-marks (beg end) - ;; Return alist of files and their marks, from BEG to END. - (if selective-display ; must unhide to make this work. - (let (buffer-read-only) - (subst-char-in-region beg end ?\r ?\n))) - (let (fil chr alist) - (save-excursion - (goto-char beg) - (while (re-search-forward dired-re-mark end t) - (if (setq fil (dired-get-filename nil t)) - (setq chr (preceding-char) - alist (cons (cons fil chr) alist))))) - alist)) - -(defun dired-mark-remembered (alist) - ;; Mark all files remembered in ALIST. - (let (elt fil chr) - (while alist - (setq elt (car alist) - alist (cdr alist) - fil (car elt) - chr (cdr elt)) - (if (dired-goto-file fil) - (save-excursion - (beginning-of-line) - (delete-char 1) - (insert chr)))))) - -(defun dired-remember-hidden () - (let ((l dired-subdir-alist) dir result) - (while l - (setq dir (car (car l)) - l (cdr l)) - (if (dired-subdir-hidden-p dir) - (setq result (cons dir result)))) - result)) - -(defun dired-insert-old-subdirs (old-subdir-alist) - ;; Try to insert all subdirs that were displayed before - (or (string-match "R" dired-actual-switches) - (let (elt dir) - (while old-subdir-alist - (setq elt (car old-subdir-alist) - old-subdir-alist (cdr old-subdir-alist) - dir (car elt)) - (condition-case () - (dired-insert-subdir dir) - (error nil)))))) - - -;; dired mode key bindings and initialization - -(defvar dired-mode-map nil "Local keymap for dired-mode buffers.") -(if dired-mode-map - nil - ;; Force `f' rather than `e' in the mode doc: - (fset 'dired-advertised-find-file 'dired-find-file) - ;; This looks ugly when substitute-command-keys uses C-d instead d: - ;; (define-key dired-mode-map "\C-d" 'dired-flag-file-deleted) - - (setq dired-mode-map (make-keymap)) - (suppress-keymap dired-mode-map) - ;; Commands to mark certain categories of files - (define-key dired-mode-map "#" 'dired-flag-auto-save-files) - (define-key dired-mode-map "*" 'dired-mark-executables) - (define-key dired-mode-map "." 'dired-clean-directory) - (define-key dired-mode-map "/" 'dired-mark-directories) - (define-key dired-mode-map "@" 'dired-mark-symlinks) - ;; Upper case keys (except !, c, r) for operating on the marked files - (define-key dired-mode-map "c" 'dired-do-copy) - (define-key dired-mode-map "r" 'dired-do-move) - (define-key dired-mode-map "!" 'dired-do-shell-command) - (define-key dired-mode-map "B" 'dired-do-byte-compile) - (define-key dired-mode-map "C" 'dired-do-compress) - (define-key dired-mode-map "G" 'dired-do-chgrp) - (define-key dired-mode-map "H" 'dired-do-hardlink) - (define-key dired-mode-map "L" 'dired-do-load) - (define-key dired-mode-map "M" 'dired-do-chmod) - (define-key dired-mode-map "O" 'dired-do-chown) - (define-key dired-mode-map "P" 'dired-do-print) - (define-key dired-mode-map "U" 'dired-do-uncompress) - (define-key dired-mode-map "X" 'dired-do-delete) - (define-key dired-mode-map "Y" 'dired-do-symlink) - ;; exceptions to the upper key rule - (define-key dired-mode-map "D" 'dired-diff) - (define-key dired-mode-map "W" 'dired-why) - ;; Tree Dired commands - (define-key dired-mode-map "\M-\C-?" 'dired-unflag-all-files) - (define-key dired-mode-map "\M-\C-d" 'dired-tree-down) - (define-key dired-mode-map "\M-\C-u" 'dired-tree-up) - (define-key dired-mode-map "\M-\C-n" 'dired-next-subdir) - (define-key dired-mode-map "\M-\C-p" 'dired-prev-subdir) - ;; move to marked files - (define-key dired-mode-map "\M-{" 'dired-prev-marked-file) - (define-key dired-mode-map "\M-}" 'dired-next-marked-file) - ;; kill marked files - (define-key dired-mode-map "\M-k" 'dired-do-kill) - ;; Make all regexp commands share a `%' prefix: - (fset 'dired-regexp-prefix (make-sparse-keymap)) - (define-key dired-mode-map "%" 'dired-regexp-prefix) - (define-key dired-mode-map "%u" 'dired-upcase) - (define-key dired-mode-map "%l" 'dired-downcase) - (define-key dired-mode-map "%d" 'dired-flag-regexp-files) - (define-key dired-mode-map "%m" 'dired-mark-files-regexp) - (define-key dired-mode-map "%r" 'dired-do-rename-regexp) - (define-key dired-mode-map "%c" 'dired-do-copy-regexp) - (define-key dired-mode-map "%H" 'dired-do-hardlink-regexp) - (define-key dired-mode-map "%Y" 'dired-do-symlink-regexp) - ;; Lower keys for commands not operating on all the marked files - (define-key dired-mode-map "d" 'dired-flag-file-deleted) - (define-key dired-mode-map "e" 'dired-find-file) - (define-key dired-mode-map "f" 'dired-advertised-find-file) - (define-key dired-mode-map "g" 'revert-buffer) - (define-key dired-mode-map "h" 'describe-mode) - (define-key dired-mode-map "i" 'dired-maybe-insert-subdir) - (define-key dired-mode-map "k" 'dired-kill-line-or-subdir) - (define-key dired-mode-map "l" 'dired-do-redisplay) - (define-key dired-mode-map "m" 'dired-mark-subdir-or-file) - (define-key dired-mode-map "n" 'dired-next-line) - (define-key dired-mode-map "o" 'dired-find-file-other-window) - (define-key dired-mode-map "p" 'dired-previous-line) - (define-key dired-mode-map "q" 'dired-quit) - (define-key dired-mode-map "s" 'dired-sort-toggle-or-edit) - (define-key dired-mode-map "u" 'dired-unmark-subdir-or-file) - (define-key dired-mode-map "v" 'dired-view-file) - (define-key dired-mode-map "x" 'dired-do-deletions) - (define-key dired-mode-map "~" 'dired-flag-backup-files) - (define-key dired-mode-map "\M-~" 'dired-backup-diff) - (define-key dired-mode-map "+" 'dired-create-directory) - ;; moving - (define-key dired-mode-map "<" 'dired-prev-dirline) - (define-key dired-mode-map ">" 'dired-next-dirline) - (define-key dired-mode-map "^" 'dired-up-directory) - (define-key dired-mode-map " " 'dired-next-line) - (define-key dired-mode-map "\C-n" 'dired-next-line) - (define-key dired-mode-map "\C-p" 'dired-previous-line) - ;; hiding - (define-key dired-mode-map "$" 'dired-hide-subdir) - (define-key dired-mode-map "=" 'dired-hide-all) - ;; misc - (define-key dired-mode-map "?" 'dired-summary) - (define-key dired-mode-map "\177" 'dired-backup-unflag) - (define-key dired-mode-map "\C-_" 'dired-undo) - (define-key dired-mode-map "\C-xu" 'dired-undo) - ) - -(or (equal (assq 'dired-sort-mode minor-mode-alist) - '(dired-sort-mode dired-sort-mode)) - ;; Test whether this has already been done in case dired is reloaded - ;; There may be several elements with dired-sort-mode as car. - (setq minor-mode-alist - (cons '(dired-sort-mode dired-sort-mode) - ;; dired-sort-mode is nil outside dired - minor-mode-alist))) - -;; Dired mode is suitable only for specially formatted data. -(put 'dired-mode 'mode-class 'special) - -(defun dired-mode (&optional dirname switches) - "\ -Mode for \"editing\" directory listings. -In dired, you are \"editing\" a list of the files in a directory and - \(optionally) its subdirectories, in the format of `ls -lR'. - Each directory is a page: use \\[backward-page] and \\[forward-page] to move pagewise. -\"Editing\" means that you can run shell commands on files, visit, - compress, load or byte-compile them, change their file attributes - and insert subdirectories into the same buffer. You can \"mark\" - files for later commands or \"flag\" them for deletion, either file - by file or all files matching certain criteria. -You can move using the usual cursor motion commands.\\ -Letters no longer insert themselves. Digits are prefix arguments. -Instead, type \\[dired-flag-file-deleted] to flag a file for Deletion. -Type \\[dired-mark-subdir-or-file] to Mark a file or subdirectory for later commands. - Most commands operate on the marked files and use the current file - if no files are marked. Use a numeric prefix argument to operate on - the next ARG (or previous -ARG if ARG<0) files, or just `1' - to operate on the current file only. Prefix arguments override marks. - Mark-using commands display a list of failures afterwards. Type \\[dired-why] to see - why something went wrong. -Type \\[dired-unmark-subdir-or-file] to Unmark a file or all files of a subdirectory. -Type \\[dired-backup-unflag] to back up one line and unflag. -Type \\[dired-do-deletions] to eXecute the deletions requested. -Type \\[dired-advertised-find-file] to Find the current line's file - (or dired it in another buffer, if it is a directory). -Type \\[dired-find-file-other-window] to find file or dired directory in Other window. -Type \\[dired-maybe-insert-subdir] to Insert a subdirectory in this buffer. -Type \\[dired-do-move] to Rename a file or move the marked files to another directory. -Type \\[dired-do-copy] to Copy files. -Type \\[dired-sort-toggle-or-edit] to toggle sorting by name/date or change the ls switches. -Type \\[revert-buffer] to read all currently expanded directories again. - This retains all marks and hides subdirs again that were hidden before. -SPC and DEL can be used to move down and up by lines. - -If dired ever gets confused, you can either type \\[revert-buffer] \ -to read the -directories again, type \\[dired-do-redisplay] \ -to relist a single or the marked files or a -subdirectory, or type \\[dired-build-subdir-alist] to parse the buffer -again for the directory tree. - -Customization variables (rename this buffer and type \\[describe-variable] on each line -for more info): - - dired-listing-switches - dired-trivial-filenames - dired-shrink-to-fit - dired-marker-char - dired-del-marker - dired-keep-marker-move - dired-keep-marker-copy - dired-keep-marker-hardlink - dired-keep-marker-symlink - -Hooks (use \\[describe-variable] to see their documentation): - - dired-before-readin-hook - dired-after-readin-hook - dired-mode-hook - dired-load-hook - -Keybindings: -\\{dired-mode-map}" - ;; Not to be called interactively (e.g. dired-directory will be set - ;; to default-directory, which is wrong with wildcards). - (kill-all-local-variables) - (use-local-map dired-mode-map) - (dired-advertise) ; default-directory is already set - (setq major-mode 'dired-mode - mode-name "Dired" - case-fold-search nil - buffer-read-only t - selective-display t ; for subdirectory hiding - modeline-buffer-identification - (list (cons modeline-buffer-id-left-extent "Dired: ") - (cons modeline-buffer-id-right-extent "%17b"))) - (set (make-local-variable 'revert-buffer-function) - (function dired-revert)) - (set (make-local-variable 'page-delimiter) - "\n\n") - (set (make-local-variable 'dired-directory) - (or dirname default-directory)) - (set (make-local-variable 'list-buffers-directory) - dired-directory) - (set (make-local-variable 'dired-actual-switches) - (or switches dired-listing-switches)) - (make-local-variable 'dired-sort-mode) - (dired-sort-other dired-actual-switches t) - (run-hooks 'dired-mode-hook)) - - -(defun dired-check-ls-l () - (let (case-fold-search) - (or (string-match "l" dired-actual-switches) - (error "Dired needs -l in ls switches")))) - -(defun dired-repeat-over-lines (arg function) - ;; This version skips non-file lines. - (beginning-of-line) - (while (and (> arg 0) (not (eobp))) - (setq arg (1- arg)) - (beginning-of-line) - (while (and (not (eobp)) (dired-between-files)) (forward-line 1)) - (save-excursion (funcall function)) - (forward-line 1)) - (while (and (< arg 0) (not (bobp))) - (setq arg (1+ arg)) - (forward-line -1) - (while (and (not (bobp)) (dired-between-files)) (forward-line -1)) - (beginning-of-line) - (save-excursion (funcall function)) - (dired-move-to-filename)) - (dired-move-to-filename)) - -(defun dired-flag-file-deleted (arg) - "In dired, flag the current line's file for deletion. -With prefix arg, repeat over several lines. - -If on a subdir headerline, mark all its files except `.' and `..'." - (interactive "P") - (let ((dired-marker-char dired-del-marker)) - (dired-mark-subdir-or-file arg))) - -(defun dired-quit () - "Bury the current dired buffer." - (interactive) - (bury-buffer)) - -(defun dired-summary () - (interactive) - ;>> this should check the key-bindings and use substitute-command-keys if non-standard - (message - "d-elete, u-ndelete, x-punge, f-ind, o-ther window, r-ename, c-opy, h-elp")) - -(defun dired-create-directory (directory) - "Create a directory called DIRECTORY." - (interactive - (list (read-file-name "Create directory: " (dired-current-directory)))) - (let ((expanded (directory-file-name (expand-file-name directory)))) - (make-directory expanded) - (dired-add-file expanded) - (dired-move-to-filename))) - -(defun dired-undo () - "Undo in a dired buffer. -This doesn't recover lost files, it is just normal undo with temporarily -writeable buffer. You can use it to recover marks, killed lines or subdirs. -In the latter case, you have to do \\[dired-build-subdir-alist] to -parse the buffer again." - (interactive) - (let (buffer-read-only) - (undo))) - -(defun dired-unflag (arg) - "In dired, remove the current line's delete flag then move to next line. -Optional prefix ARG says how many lines to unflag." - (interactive "p") - (dired-repeat-over-lines arg - '(lambda () - (let (buffer-read-only) - (delete-char 1) - (insert " ") - (forward-char -1) - nil)))) - -(defun dired-backup-unflag (arg) - "In dired, move up lines and remove deletion flag there. -Optional prefix ARG says how many lines to unflag; default is one line." - (interactive "p") - (dired-unflag (- arg))) - -(defun dired-next-line (arg) - "Move down lines then position at filename. -Optional prefix ARG says how many lines to move; default is one line." - (interactive "_p") - (next-line arg) - (dired-move-to-filename)) - -(defun dired-previous-line (arg) - "Move up lines then position at filename. -Optional prefix ARG says how many lines to move; default is one line." - (interactive "_p") - (previous-line arg) - (dired-move-to-filename)) - -(defun dired-up-directory () - "Run dired on parent directory of current directory. -Find the parent directory either in this buffer or another buffer. -Creates a buffer if necessary." - (interactive) - (let* ((dir (dired-current-directory)) - (up (file-name-directory (directory-file-name dir)))) - (or (dired-goto-file (directory-file-name dir)) - (dired-goto-subdir up) - (progn - (dired up) - (dired-goto-file dir))))) - -(defun dired-find-file () - "In dired, visit the file or directory named on this line." - (interactive) - (let ((find-file-run-dired t)) - (find-file (dired-get-filename)))) - -(defun dired-view-file () - "In dired, examine a file in view mode, returning to dired when done. -When file is a directory, show it in this buffer if it is inserted; -otherwise, display it in another buffer." - (interactive) - (if (file-directory-p (dired-get-filename)) - (or (dired-goto-subdir (dired-get-filename)) - (dired (dired-get-filename))) - (view-file (dired-get-filename)))) - -(defun dired-find-file-other-window () - "In dired, visit this file or directory in another window." - (interactive) - (let ((find-file-run-dired t)) ;; XEmacs - (find-file-other-window (dired-get-filename)))) - -(defun dired-get-filename (&optional localp no-error-if-not-filep) - "In dired, return name of file mentioned on this line. -Value returned normally includes the directory name. -Optional arg LOCALP with value `no-dir' means don't include directory - name in result. A value of t means use path name relative to - `default-directory', which still may contain slashes if in a subdirectory. -Optional arg NO-ERROR-IF-NOT-FILEP means return nil if no filename on - this line, otherwise an error occurs." - (let (case-fold-search file p1 p2) - (save-excursion - (if (setq p1 (dired-move-to-filename (not no-error-if-not-filep))) - (setq p2 (dired-move-to-end-of-filename no-error-if-not-filep)))) - ;; nil if no file on this line, but no-error-if-not-filep is t: - (if (setq file (and p1 p2 (buffer-substring p1 p2))) - ;; Check if ls quoted the names, and unquote them. - ;; Using read to unquote is much faster than substituting - ;; \007 (4 chars) -> ^G (1 char) etc. in a lisp loop. - (cond ((string-match "b" dired-actual-switches) ; System V ls - ;; This case is about 20% slower than without -b. - (setq file - (read - (concat "\"" - ;; some ls -b don't escape quotes, argh! - ;; This is not needed for GNU ls, though. - (or (dired-string-replace-match - "\\([^\\]\\)\"" file "\\1\\\\\"") - file) - "\"")))) - ;; If you do this, update dired-insert-subdir-validate too - ;; ((string-match "Q" dired-actual-switches) ; GNU ls - ;; (setq file (read file))) - )) - (if (eq localp 'no-dir) - file - (and file (concat (dired-current-directory localp) file))))) - -(defun dired-move-to-filename (&optional raise-error eol) - "In dired, move to first char of filename on this line. -Returns position (point) or nil if no filename on this line." - ;; This is the UNIX version. - (or eol (setq eol (progn (end-of-line) (point)))) - (beginning-of-line) - (if (string-match "l" dired-actual-switches) - (if (re-search-forward - "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|Dec\\)[ ]+[0-9]+" - eol t) - (progn - (skip-chars-forward " ") ; there is one SPC after day of month - (skip-chars-forward "^ " eol) ; move after time of day (or year) - (skip-chars-forward " " eol) ; there is space before the file name - ;; Actually, if the year instead of clock time is displayed, - ;; there are (only for some ls programs?) two spaces instead - ;; of one before the name. - ;; If we could depend on ls inserting exactly one SPC we - ;; would not bomb on names _starting_ with SPC. - (point)) - (if raise-error - (error "No file on this line") - nil)) - ;; else ls switches don't contain -l. - ;; Note that even if we make dired-move-to-filename and - ;; dired-move-to-end-of-filename (and thus dired-get-filename) - ;; work, all commands that gleaned information from the permission - ;; bits (like dired-mark-directories) will cease to work properly. - (if (eolp) - (if raise-error - (error "No file on this line") - nil) - ;; skip marker, if any - (forward-char)) - (skip-chars-forward " ") - (point))) - -(defun dired-move-to-end-of-filename (&optional no-error) - ;; Assumes point is at beginning of filename, - ;; thus the rwx bit re-search-backward below will succeed in *this* - ;; line if at all. So, it should be called only after - ;; (dired-move-to-filename t). - ;; On failure, signals an error (with non-nil NO-ERROR just returns nil). - ;; This is the UNIX version. - (let (opoint file-type executable symlink hidden case-fold-search used-F eol) - ;; case-fold-search is nil now, so we can test for capital F: - (setq used-F (string-match "F" dired-actual-switches) - opoint (point) - eol (save-excursion (end-of-line) (point)) - hidden (and selective-display - (save-excursion (search-forward "\r" eol t)))) - (if hidden - nil - (save-excursion;; Find out what kind of file this is: - ;; Restrict perm bits to be non-blank, - ;; otherwise this matches one char to early (looking backward): - ;; "l---------" (some systems make symlinks that way) - ;; "----------" (plain file with zero perms) - (if (re-search-backward - "\\([^ ]\\)[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)" - nil t) - (setq file-type (char-after (match-beginning 1)) - symlink (eq file-type ?l) - ;; Only with -F we need to know whether it's an executable - executable (and - used-F - (string-match - "[xst]";; execute bit set anywhere? - (concat - (buffer-substring (match-beginning 2) - (match-end 2)) - (buffer-substring (match-beginning 3) - (match-end 3)) - (buffer-substring (match-beginning 4) - (match-end 4)))))) - (or no-error - (not (string-match "l" dired-actual-switches)) - (error "No file on this line")))) - ;; Move point to end of name: - (if symlink - (if (search-forward " ->" eol t) - (progn - (forward-char -3) - (and used-F - dired-ls-F-marks-symlinks - (eq (preceding-char) ?@);; did ls really mark the link? - (forward-char -1)))) - (goto-char eol);; else not a symbolic link - ;; ls -lF marks dirs, sockets and executables with exactly one - ;; trailing character. (Executable bits on symlinks ain't mean - ;; a thing, even to ls, but we know it's not a symlink.) - (and used-F - ;; -F may not actually be honored, e.g. by an FTP ls in ange-ftp - (let ((char (preceding-char))) - (or (and (eq file-type ?d) (eq char ?/)) - (and executable (eq char ?*)) - (and (eq file-type ?s) (eq char ?=)))) - (forward-char -1)))) - (or no-error - (not (eq opoint (point))) - (error (if hidden - (substitute-command-keys - "File line is hidden, type \\[dired-hide-subdir] to unhide") - "No file on this line"))) - (if (eq opoint (point)) - nil - (point)))) - - -;; Perhaps something could be done to handle VMS' own backups. - -(defun dired-clean-directory (keep) - "Flag numerical backups for deletion. -Spares `dired-kept-versions' latest versions, and `kept-old-versions' oldest. -Positive prefix arg KEEP overrides `dired-kept-versions'; -Negative prefix arg KEEP overrides `kept-old-versions' with KEEP made positive. - -To clear the flags on these files, you can use \\[dired-flag-backup-files] -with a prefix argument." - (interactive "P") - (setq keep (if keep (prefix-numeric-value keep) dired-kept-versions)) - (let ((early-retention (if (< keep 0) (- keep) kept-old-versions)) - (late-retention (if (<= keep 0) dired-kept-versions keep)) - (file-version-assoc-list ())) - (message "Cleaning numerical backups (keeping %d late, %d old)..." - late-retention early-retention) - ;; Look at each file. - ;; If the file has numeric backup versions, - ;; put on file-version-assoc-list an element of the form - ;; (FILENAME . VERSION-NUMBER-LIST) - (dired-map-dired-file-lines (function dired-collect-file-versions)) - ;; Sort each VERSION-NUMBER-LIST, - ;; and remove the versions not to be deleted. - (let ((fval file-version-assoc-list)) - (while fval - (let* ((sorted-v-list (cons 'q (sort (cdr (car fval)) '<))) - (v-count (length sorted-v-list))) - (if (> v-count (+ early-retention late-retention)) - (rplacd (nthcdr early-retention sorted-v-list) - (nthcdr (- v-count late-retention) - sorted-v-list))) - (rplacd (car fval) - (cdr sorted-v-list))) - (setq fval (cdr fval)))) - ;; Look at each file. If it is a numeric backup file, - ;; find it in a VERSION-NUMBER-LIST and maybe flag it for deletion. - (dired-map-dired-file-lines (function dired-trample-file-versions)) - (message "Cleaning numerical backups...done"))) - -;;; Subroutines of dired-clean-directory. - -(defun dired-map-dired-file-lines (fun) - ;; Perform FUN with point at the end of each non-directory line. - ;; FUN takes one argument, the filename (complete pathname). - (dired-check-ls-l) - (save-excursion - (let (file buffer-read-only) - (goto-char (point-min)) - (while (not (eobp)) - (save-excursion - (and (not (looking-at dired-re-dir)) - (not (eolp)) - (setq file (dired-get-filename nil t)) ; nil on non-file - (progn (end-of-line) - (funcall fun file)))) - (forward-line 1))))) - -(defun dired-collect-file-versions (fn) - ;; "If it looks like file FN has versions, return a list of the versions. - ;;That is a list of strings which are file names. - ;;The caller may want to flag some of these files for deletion." - (let* ((base-versions - (concat (file-name-nondirectory fn) ".~")) - (bv-length (length base-versions)) - (possibilities (file-name-all-completions - base-versions - (file-name-directory fn))) - (versions (mapcar 'backup-extract-version possibilities))) - (if versions - (setq file-version-assoc-list (cons (cons fn versions) - file-version-assoc-list))))) - -(defun dired-trample-file-versions (fn) - (let* ((start-vn (string-match "\\.~[0-9]+~$" fn)) - base-version-list) - (and start-vn - (setq base-version-list ; there was a base version to which - (assoc (substring fn 0 start-vn) ; this looks like a - file-version-assoc-list)) ; subversion - (not (memq (string-to-int (substring fn (+ 2 start-vn))) - base-version-list)) ; this one doesn't make the cut - (progn (beginning-of-line) - (delete-char 1) - (insert dired-del-marker))))) - - -;; Keeping Dired buffers in sync with the filesystem and with each other - -(defvar dired-buffers nil - ;; Enlarged by dired-advertise - ;; Queried by function dired-buffers-for-dir. When this detects a - ;; killed buffer, it is removed from this list. - "Alist of directories and their associated dired buffers.") - -(defun dired-buffers-for-dir (dir) -;; Return a list of buffers that dired DIR (top level or in-situ subdir). -;; The list is in reverse order of buffer creation, most recent last. -;; As a side effect, killed dired buffers for DIR are removed from -;; dired-buffers. - (setq dir (file-name-as-directory dir)) - (let ((alist dired-buffers) result elt) - (while alist - (setq elt (car alist)) - (if (dired-in-this-tree dir (car elt)) - (let ((buf (cdr elt))) - (if (buffer-name buf) - (if (assoc dir (save-excursion - (set-buffer buf) - dired-subdir-alist)) - (setq result (cons buf result))) - ;; else buffer is killed - clean up: - (setq dired-buffers (delq elt dired-buffers))))) - (setq alist (cdr alist))) - result)) - -(defun dired-advertise () - ;;"Advertise in variable `dired-buffers' that we dired `default-directory'." - ;; With wildcards we actually advertise too much. - (if (memq (current-buffer) (dired-buffers-for-dir default-directory)) - t ; we have already advertised ourselves - (setq dired-buffers - (cons (cons default-directory (current-buffer)) - dired-buffers)))) - -(defun dired-unadvertise (dir) - ;; Remove DIR from the buffer alist in variable dired-buffers. - ;; This has the effect of removing any buffer whose main directory is DIR. - ;; It does not affect buffers in which DIR is a subdir. - ;; Removing is also done as a side-effect in dired-buffer-for-dir. - (setq dired-buffers - (delq (assoc dir dired-buffers) dired-buffers))) - -(defun dired-fun-in-all-buffers (directory fun &rest args) - ;; In all buffers dired'ing DIRECTORY, run FUN with ARGS. - ;; Return list of buffers where FUN succeeded (i.e., returned non-nil). - (let ((buf-list (dired-buffers-for-dir directory)) - (obuf (current-buffer)) - buf success-list) - (while buf-list - (setq buf (car buf-list) - buf-list (cdr buf-list)) - (unwind-protect - (progn - (set-buffer buf) - (if (apply fun args) - (setq success-list (cons (buffer-name buf) success-list)))) - (set-buffer obuf))) - success-list)) - -(defun dired-add-file (filename &optional marker-char) - (dired-fun-in-all-buffers - (file-name-directory filename) - (function dired-add-entry) filename marker-char)) - -(defun dired-add-entry (filename &optional marker-char) - ;; Add a new entry for FILENAME, optionally marking it - ;; with MARKER-CHAR (a character, else dired-marker-char is used). - ;; Note that this adds the entry `out of order' if files sorted by - ;; time, etc. - ;; At least this version inserts in the right subdirectory (if present). - ;; And it skips "." or ".." (see `dired-trivial-filenames'). - ;; Hidden subdirs are exposed if a file is added there. - (setq filename (directory-file-name filename)) - ;; Entry is always for files, even if they happen to also be directories - (let ((opoint (point)) - (cur-dir (dired-current-directory)) - (directory (file-name-directory filename)) - reason) - (setq filename (file-name-nondirectory filename) - reason - (catch 'not-found - (if (string= directory cur-dir) - (progn - (if (dired-subdir-hidden-p cur-dir) - (dired-unhide-subdir)) - ;; We are already where we should be, except when - ;; point is before the subdir line or its total line. - (let ((p (dired-after-subdir-garbage cur-dir))) - (if (< (point) p) - (goto-char p)))) - ;; else try to find correct place to insert - (if (dired-goto-subdir directory) - (progn;; unhide if necessary - (if (looking-at "\r");; point is at end of subdir line - (dired-unhide-subdir)) - ;; found - skip subdir and `total' line - ;; and uninteresting files like . and .. - ;; This better not moves into the next subdir! - (dired-goto-next-nontrivial-file)) - ;; not found - (throw 'not-found "Subdir not found"))) - ;; found and point is at The Right Place: - (let (buffer-read-only) - (beginning-of-line) - (dired-add-entry-do-indentation marker-char) - (dired-ls (dired-make-absolute filename directory);; don't expand `.' ! - (concat dired-actual-switches "d")) - (forward-line -1) - ;; We want to have the non-directory part, only: - (let* ((beg (dired-move-to-filename t)) ; error for strange output - (end (dired-move-to-end-of-filename))) - (setq filename (buffer-substring beg end)) - (delete-region beg end) - (insert (file-name-nondirectory filename))) - (if dired-after-readin-hook;; the subdir-alist is not affected... - (save-excursion;; ...so we can run it right now: - (save-restriction - (beginning-of-line) - (narrow-to-region (point) (save-excursion - (forward-line 1) (point))) - (run-hooks 'dired-after-readin-hook)))) - (dired-move-to-filename)) - ;; return nil if all went well - nil)) - (if reason ; don't move away on failure - (goto-char opoint)) - (not reason))) ; return t on succes, nil else - -;; This is a separate function for the sake of nested dired format. -(defun dired-add-entry-do-indentation (marker-char) - ;; two spaces or a marker plus a space: - (insert (if marker-char - (if (integerp marker-char) marker-char dired-marker-char) - ?\040) - ?\040)) - -(defun dired-after-subdir-garbage (dir) - ;; Return pos of first file line of DIR, skipping header and total - ;; or wildcard lines. - ;; Important: never moves into the next subdir. - ;; DIR is assumed to be unhidden. - ;; Will probably be redefined for VMS etc. - (save-excursion - (or (dired-goto-subdir dir) (error "This cannot happen")) - (forward-line 1) - (while (and (not (eolp)) ; don't cross subdir boundary - (not (dired-move-to-filename))) - (forward-line 1)) - (point))) - -(defun dired-remove-file (file) - (dired-fun-in-all-buffers - (file-name-directory file) (function dired-remove-entry) file)) - -(defun dired-remove-entry (file) - (save-excursion - (and (dired-goto-file file) - (let (buffer-read-only) - (delete-region (progn (beginning-of-line) (point)) - (save-excursion (forward-line 1) (point))))))) - -(defun dired-relist-file (file) - (dired-fun-in-all-buffers (file-name-directory file) - (function dired-relist-entry) file)) - -(defun dired-relist-entry (file) - ;; Relist the line for FILE, or just add it if it did not exist. - ;; FILE must be an absolute pathname. - (let (buffer-read-only marker) - ;; If cursor is already on FILE's line delete-region will cause - ;; save-excursion to fail because of floating makers, - ;; moving point to beginning of line. Sigh. - (save-excursion - (and (dired-goto-file file) - (delete-region (progn (beginning-of-line) - (setq marker (following-char)) - (point)) - (save-excursion (forward-line 1) (point)))) - (setq file (directory-file-name file)) - (dired-add-entry file (if (eq ?\040 marker) nil marker))))) - -(defun dired-update-file-line (file) - ;; Delete the current line, and insert an entry for FILE. - ;; If FILE is nil, then just delete the current line. - ;; Keeps any marks that may be present in column one (doing this - ;; here is faster than with dired-add-entry's optional arg). - ;; Does not update other dired buffers. Use dired-relist-entry for that. - (beginning-of-line) - (let ((char (following-char)) (opoint (point))) - (delete-region (point) (progn (forward-line 1) (point))) - (if file - (progn - (dired-add-entry file) - ;; Replace space by old marker without moving point. - ;; Faster than goto+insdel inside a save-excursion? - (subst-char-in-region opoint (1+ opoint) ?\040 char)))) - (dired-move-to-filename)) - - -;; Running subprocesses, checking and logging of their errors. - -(defvar dired-log-buf "*Dired log*") - -(defun dired-why () - "Pop up a buffer with error log output from Dired. -A group of errors from a single command ends with a formfeed. -Thus, use \\[backward-page] to find the beginning of a group of errors." - (interactive) - (let ((obuf (current-buffer))) - (pop-to-buffer dired-log-buf) - (goto-char (point-max)) - (recenter -1) - (switch-to-buffer-other-window obuf))) - -(defun dired-log (log &rest args) - ;; Log a message or the contents of a buffer. - ;; If LOG is a string and there are more args, it is formatted with - ;; those ARGS. Usually the LOG string ends with a \n. - ;; End each bunch of errors with (dired-log t): this inserts - ;; current time and buffer, and a \f (formfeed). - (let ((obuf (current-buffer))) - (unwind-protect ; want to move point - (progn - (set-buffer (get-buffer-create dired-log-buf)) - (goto-char (point-max)) - (let (buffer-read-only) - (cond ((stringp log) - (insert (if args - (apply (function format) log args) - log))) - ((bufferp log) - (insert-buffer log)) - ((eq t log) - (insert "\n\t" (current-time-string) - "\tBuffer `" (buffer-name obuf) "'\n\f\n"))))) - (set-buffer obuf)))) - -(defun dired-log-summary (log &rest args) - ;; Log a summary describing a bunch of errors. - (apply (function dired-log) (concat "\n" log) args) - (dired-log t)) - -;; In Emacs 19 this will return program's exit status. -;; This is a separate function so that ange-ftp can redefine it. -(defun dired-call-process (program discard &rest arguments) -; "Run PROGRAM with output to current buffer unless DISCARD is t. -;Remaining arguments are strings passed as command arguments to PROGRAM." - (apply 'call-process program nil (not discard) nil arguments)) - -(defun dired-check-process-checker (exit-status) - ;; In Emacs 19, EXIT-STATUS comes from (dired-)call-process - ;; Then this function should return (/= 0 exit-status) - ;; In Emacs 18 the exit status is not accessible, so we - ;; do the following which is not always correct as some compress - ;; programs are verbose by default or otherwise braindamaged - (if (and dired-emacs-19-p exit-status) - (/= 0 exit-status);; #### install (does it work in Emacs 19?) - (/= 0 (buffer-size))) ; run in program's output buffer - ;; If have you one of those compress programs, you might - ;; want to redefine this function to look closer at compress' output. - ;; This is why it is a separate function. - ) - -(defun dired-check-process (msg program &rest arguments) -; "Display MSG while running PROGRAM, and check for output. -;Remaining arguments are strings passed as command arguments to PROGRAM. -; On error as determined by dired-check-process-checker, insert output -; in a log buffer and return the offending ARGUMENTS or PROGRAM. -; Caller can cons up a list of failed args. -;Else returns nil for success." - (let (err-buffer err (dir default-directory)) - (message "%s..." msg) - (save-excursion - ;; Get a clean buffer for error output: - (setq err-buffer (get-buffer-create " *dired-check-process output*")) - (set-buffer err-buffer) - (erase-buffer) - (setq default-directory dir ; caller's default-directory - err (dired-check-process-checker - (apply (function dired-call-process) program nil arguments))) - (if err - (progn - (dired-log (concat program " " (prin1-to-string arguments) "\n")) - (dired-log err-buffer) - (or arguments program t)) - (kill-buffer err-buffer) - (message "%s...done" msg) - nil)))) - -;;; 7K -;;;###begin dired-cmd.el -;; Diffing and compressing - -(defun dired-diff (file &optional switches) - "Compare file at point with file FILE using `diff'. -FILE defaults to the file at the mark. -The prompted-for file is the first file given to `diff'. -Prefix arg lets you edit the diff switches. See the command `diff'." - (interactive - (let ((default (if (mark) - (save-excursion (goto-char (mark)) - (dired-get-filename t t))))) - (list (read-file-name (format "Diff %s with: %s" - (dired-get-filename t) - (if default - (concat "(default " default ") ") - "")) - (dired-current-directory) default t) - (if (fboundp 'diff-read-switches) - (diff-read-switches "Options for diff: "))))) - (if switches ; Emacs 19's diff has but two - (diff file (dired-get-filename t) switches) ; args (yet ;-) - (diff file (dired-get-filename t)))) - -(defun dired-backup-diff (&optional switches) - "Diff this file with its backup file or vice versa. -Uses the latest backup, if there are several numerical backups. -If this file is a backup, diff it with its original. -The backup file is the first file given to `diff'. -Prefix arg lets you edit the diff switches. See the command `diff'." - (interactive (list (if (fboundp 'diff-read-switches) - (diff-read-switches "Diff with switches: ")))) - (let (bak ori (file (dired-get-filename))) - (if (backup-file-name-p file) - (setq bak file - ori (file-name-sans-versions file)) - (setq bak (or (latest-backup-file file) - (error "No backup found for %s" file)) - ori file)) - (if switches - (diff bak ori switches) - (diff bak ori)))) - -;;#### install (move this function into files.el) -(defun latest-backup-file (fn) ; actually belongs into files.el - "Return the latest existing backup of FILE, or nil." - ;; First try simple backup, then the highest numbered of the - ;; numbered backups. - ;; Ignore the value of version-control because we look for existing - ;; backups, which maybe were made earlier or by another user with - ;; a different value of version-control. - (setq fn (expand-file-name fn)) - (or - (let ((bak (make-backup-file-name fn))) - (if (file-exists-p bak) bak)) - (let* ((dir (file-name-directory fn)) - (base-versions (concat (file-name-nondirectory fn) ".~")) - (bv-length (length base-versions))) - (concat dir - (car (sort - (file-name-all-completions base-versions dir) - ;; bv-length is a fluid var for backup-extract-version: - (function - (lambda (fn1 fn2) - (> (backup-extract-version fn1) - (backup-extract-version fn2)))))))))) - -;; This is a separate function for the sake of ange-ftp.el -(defun dired-compress-make-compressed-filename (from-file &optional reverse) -;; "Converts a filename FROM-FILE to the filename of the associated -;; compressed file. With an optional argument REVERSE, the reverse -;; conversion is done." - - (if reverse - - ;; uncompress... - ;; return `nil' if no match found -- better than nothing - (let (case-fold-search ; case-sensitive search - (string - (concat "\\.\\(g?z\\|" (regexp-quote dired-gzip-file-extension) - "$\\|Z\\)$"))) - - (and (string-match string from-file) - (substring from-file 0 (match-beginning 0)))) - - ;; compress... - ;; note: it could be that `gz' is not the proper extension for gzip - (concat from-file - (if dired-use-gzip-instead-of-compress - dired-gzip-file-extension ".Z")))) - - -(defun dired-compress () - ;; Compress current file. Return nil for success, offending filename else. - (dired-check-ls-l) - (let* (buffer-read-only - (from-file (dired-get-filename)) - (to-file (dired-compress-make-compressed-filename from-file))) - (cond ((save-excursion (beginning-of-line) - (looking-at dired-re-sym)) - (dired-log (concat "Attempt to compress a symbolic link:\n" - from-file)) - (dired-make-relative from-file)) - ( - - (if dired-use-gzip-instead-of-compress - ;; gzip (GNU zip) - ;; use `-q' (quiet) switch for gzip in case GZIP environment - ;; variable contains `--verbose' - lrd - Feb 18, 1993 - (dired-check-process (concat "Gzip'ing " from-file) - "gzip" "--quiet" "--force" "--suffix" - dired-gzip-file-extension from-file) - - (dired-check-process (concat "Compressing " from-file) - "compress" "-f" from-file)) - ;; errors from the process are already logged by dired-check-process - (dired-make-relative from-file)) - (t - (dired-update-file-line to-file) - nil)))) - -(defun dired-uncompress () - ;; Uncompress current file. Return nil for success, offending filename else. - (let* (buffer-read-only - (from-file (dired-get-filename)) - (to-file (dired-compress-make-compressed-filename from-file t))) - (if - (if dired-use-gzip-instead-of-compress - ;; gzip (GNU zip) - ;; use `-q' (quiet) switch for gzip in case GZIP environment - ;; variable contains `--verbose' - lrd - Feb 18, 1993 - (dired-check-process (concat "Gunzip'ing " from-file) - "gzip" "--decompress" "--quiet" "--suffix" - dired-gzip-file-extension from-file) - - (dired-check-process (concat "Uncompressing " from-file) - "uncompress" from-file)) - - (dired-make-relative from-file) - (dired-update-file-line to-file) - nil))) - -(defun dired-mark-map-check (fun arg op-symbol &optional show-progress) -; "Map FUN over marked files (with second ARG like in dired-mark-map) -; and display failures. - -; FUN takes zero args. It returns non-nil (the offending object, e.g. -; the short form of the filename) for a failure and probably logs a -; detailed error explanation using function `dired-log'. - -; OP-SYMBOL is a symbol describing the operation performed (e.g. -; `compress'). It is used with `dired-mark-pop-up' to prompt the user -; (e.g. with `Compress * [2 files]? ') and to display errors (e.g. -; `Failed to compress 1 of 2 files - type W to see why ("foo")') - -; SHOW-PROGRESS if non-nil means redisplay dired after each file." - (if (dired-mark-confirm op-symbol arg) - (let* ((total-list;; all of FUN's return values - (dired-mark-map (funcall fun) arg show-progress)) - (total (length total-list)) - (failures (delq nil total-list)) - (count (length failures))) - (if (not failures) - (message "%s: %d file%s." - (capitalize (symbol-name op-symbol)) - total (dired-plural-s total)) - (message "Failed to %s %d of %d file%s - type W to see why %s" - (symbol-name op-symbol) count total (dired-plural-s total) - ;; this gives a short list of failed files in parens - ;; which may be sufficient for the user even - ;; without typing `W' for the process' diagnostics - failures) - ;; end this bunch of errors: - (dired-log-summary - "Failed to %s %d of %d file%s" - (symbol-name op-symbol) count total (dired-plural-s total)))))) - -(defun dired-do-compress (&optional arg) - "Compress marked (or next ARG) files. -Type \\[dired-do-uncompress] to uncompress again." - (interactive "P") - (dired-mark-map-check (function dired-compress) arg 'compress t)) - -(defun dired-do-uncompress (&optional arg) - "Uncompress marked (or next ARG) files." - (interactive "P") - (dired-mark-map-check (function dired-uncompress) arg 'uncompress t)) - -;; Commands for Emacs Lisp files - load and byte compile - -(defun dired-byte-compile () - ;; Return nil for success, offending file name else. - (let* ((filename (dired-get-filename)) - (elc-file - (if (eq system-type 'vax-vms) - (concat (substring filename 0 (string-match ";" filename)) "c") - (concat filename "c"))) - buffer-read-only failure) - (condition-case err - (save-excursion (byte-compile-file filename)) - (error - (setq failure err))) - (if failure - (progn - (dired-log "Byte compile error for %s:\n%s\n" filename failure) - (dired-make-relative filename)) - (dired-remove-file elc-file) - (forward-line) ; insert .elc after its .el file - (dired-add-file elc-file) - nil))) - -(defun dired-do-byte-compile (&optional arg) - "Byte compile marked (or next ARG) Emacs lisp files." - (interactive "P") - (dired-mark-map-check (function dired-byte-compile) arg 'byte-compile t)) - -(defun dired-load () - ;; Return nil for success, offending file name else. - (let ((file (dired-get-filename)) failure) - (condition-case err - (load file nil nil t) - (error (setq failure err))) - (if (not failure) - nil - (dired-log "Load error for %s:\n%s\n" file failure) - (dired-make-relative file)))) - -(defun dired-do-load (&optional arg) - "Load the marked (or next ARG) Emacs lisp files." - (interactive "P") - (dired-mark-map-check (function dired-load) arg 'load t)) - -(defun dired-do-chxxx (attribute-name program op-symbol arg) - ;; Change file attributes (mode, group, owner) of marked files and - ;; refresh their file lines. - ;; ATTRIBUTE-NAME is a string describing the attribute to the user. - ;; PROGRAM is the program used to change the attribute. - ;; OP-SYMBOL is the type of operation (for use in dired-mark-pop-up). - ;; ARG describes which files to use, like in dired-mark-get-files. - (let* ((files (dired-mark-get-files t arg)) - (new-attribute - (dired-mark-read-string - (concat "Change " attribute-name " of %s to: ") - nil op-symbol arg files)) - (operation (concat program " " new-attribute)) - (failure (apply (function dired-check-process) - operation program new-attribute - files))) - (dired-do-redisplay arg);; moves point if ARG is an integer - (if failure - (dired-log-summary - (message "%s: error - type W to see why." operation))))) - -(defun dired-do-chmod (&optional arg) - "Change the mode of the marked (or next ARG) files. -This calls chmod, thus symbolic modes like `g+w' are allowed." - (interactive "P") - (dired-do-chxxx "Mode" "chmod" 'chmod arg)) - -(defun dired-do-chgrp (&optional arg) - "Change the group of the marked (or next ARG) files." - (interactive "P") - (dired-do-chxxx "Group" "chgrp" 'chgrp arg)) - -(defun dired-do-chown (&optional arg) - "Change the owner of the marked (or next ARG) files." - (interactive "P") - (dired-do-chxxx "Owner" dired-chown-program 'chown arg)) - -;;;###end dired-cmd.el - - -;; Deleting files - -;; #### called dired-do-flagged-delete in FSF -(defun dired-do-deletions (&optional nomessage) - "In dired, delete the files flagged for deletion. -If NOMESSAGE is non-nil, we don't display any message -if there are no flagged files." - (interactive) - (let* ((dired-marker-char dired-del-marker) - (regexp (dired-marker-regexp)) - case-fold-search) - (if (save-excursion (goto-char (point-min)) - (re-search-forward regexp nil t)) - (dired-internal-do-deletions - ;; this can't move point since ARG is nil - (dired-mark-map (cons (dired-get-filename) (point)) - nil) - nil) - (or nomessage - (message "(No deletions requested)"))))) - -(defun dired-do-delete (&optional arg) - "Delete all marked (or next ARG) files." - ;; This is more consistent with the file marking feature than - ;; dired-do-deletions. - (interactive "P") - (dired-internal-do-deletions - ;; this may move point if ARG is an integer - (dired-mark-map (cons (dired-get-filename) (point)) - arg) - arg)) - -(defvar dired-deletion-confirmer 'yes-or-no-p) ; or y-or-n-p? - -(defun dired-internal-do-deletions (l arg) - ;; L is an alist of files to delete, with their buffer positions. - ;; ARG is the prefix arg. - ;; Filenames are absolute (VMS needs this for logical search paths). - ;; (car L) *must* be the *last* (bottommost) file in the dired buffer. - ;; That way as changes are made in the buffer they do not shift the - ;; lines still to be changed, so the (point) values in L stay valid. - ;; Also, for subdirs in natural order, a subdir's files are deleted - ;; before the subdir itself - the other way around would not work. - (let ((files (mapcar (function car) l)) - (count (length l)) - (succ 0)) - ;; canonicalize file list for pop up - (setq files (nreverse (mapcar (function dired-make-relative) files))) - (if (dired-mark-pop-up - " *Deletions*" 'delete files dired-deletion-confirmer - (format "Delete %s " (dired-mark-prompt arg files))) - (save-excursion - (let (failures);; files better be in reverse order for this loop! - (while l - (goto-char (cdr (car l))) - (let (buffer-read-only) - (condition-case err - (let ((fn (car (car l)))) - ;; This test is equivalent to - ;; (and (file-directory-p fn) (not (file-symlink-p fn))) - ;; but more efficient - (if (eq t (car (file-attributes fn))) - (remove-directory fn) - (delete-file fn)) - ;; if we get here, removing worked - (setq succ (1+ succ)) - (message "%s of %s deletions" succ count) - (delete-region (progn (beginning-of-line) (point)) - (progn (forward-line 1) (point))) - (dired-clean-up-after-deletion fn)) - (error;; catch errors from failed deletions - (dired-log "%s\n" err) - (setq failures (cons (car (car l)) failures))))) - (setq l (cdr l))) - (if (not failures) - (message "%d deletion%s done" count (dired-plural-s count)) - (dired-log-summary - (message "%d of %d deletion%s failed: %s" - (length failures) count - (dired-plural-s count) - (prin1-to-string failures)))))) - (message "(No deletions performed)"))) - (dired-move-to-filename)) - -;; This is a separate function for the sake of dired-x.el. -(defun dired-clean-up-after-deletion (fn) - ;; Clean up after a deleted file or directory FN. - (save-excursion (and (dired-goto-subdir fn) - (dired-kill-subdir)))) - - -(defun dired-replace-in-string (regexp newtext string) - ;; Replace REGEXP with NEWTEXT everywhere in STRING and return result. - ;; NEWTEXT is taken literally---no \\DIGIT escapes will be recognized. - (let ((result "") (start 0) mb me) - (while (string-match regexp string start) - (setq mb (match-beginning 0) - me (match-end 0) - result (concat result (substring string start mb) newtext) - start me)) - (concat result (substring string start)))) - -(defun dired-next-dirline (arg &optional opoint) - "Goto ARG'th next directory file line." - (interactive "_p") - (dired-check-ls-l) - (or opoint (setq opoint (point))) - (if (if (> arg 0) - (re-search-forward dired-re-dir nil t arg) - (beginning-of-line) - (re-search-backward dired-re-dir nil t (- arg))) - (dired-move-to-filename) ; user may type `i' or `f' - (goto-char opoint) - (error "No more subdirectories"))) - -(defun dired-prev-dirline (arg) - "Goto ARG'th previous directory file line." - (interactive "_p") - (dired-next-dirline (- arg))) - -(defun dired-unflag-all-files (flag &optional arg) - "Remove a specific or all flags from every file. -With an arg, queries for each marked file. -Type \\[help-command] at that time for help." - (interactive "sRemove flag: (default: all flags) \nP") - (let ((count 0) - (re (if (zerop (length flag)) dired-re-mark - (concat "^" (regexp-quote flag))))) - (save-excursion - (let (buffer-read-only case-fold-search query - (help-form "\ -Type SPC or `y' to unflag one file, DEL or `n' to skip to next, -`!' to unflag all remaining files with no more questions.")) - (goto-char (point-min)) - (while (re-search-forward re nil t) - (if (or (not arg) - (dired-query 'query "Unflag file `%s' ? " - (dired-get-filename t))) - (progn (delete-char -1) (insert " ") (setq count (1+ count)))) - (forward-line 1)))) - (message "%s" (format "Flags removed: %d %s" count flag) ))) - -;; pop ups and user input for file marking - -(defun dired-marker-regexp () - (concat "^" (regexp-quote (char-to-string dired-marker-char)))) - -(defun dired-plural-s (count) - (if (= 1 count) "" "s")) - -(defun dired-mark-prompt (arg files) - ;; Return a string for use in a prompt, either the current file - ;; name, or the marker and a count of marked files. - (let ((count (length files))) - (if (= count 1) - (car files) - ;; more than 1 file: - (if (integerp arg) - ;; abs(arg) = count - ;; Perhaps this is nicer, but it also takes more screen space: - ;;(format "[%s %d files]" (if (> arg 0) "next" "previous") - ;; count) - (format "[next %d files]" arg) - (format "%c [%d files]" dired-marker-char count))))) - -(defvar dired-query-alist - '((?\y . y) (?\040 . y) ; `y' or SPC means accept once - (?n . n) (?\177 . n) ; `n' or DEL skips once - (?! . yes) ; `!' accepts rest - (?q. no) (?\e . no) ; `q' or ESC skips rest - ;; None of these keys quit - use C-g for that. - )) - -(defun dired-query (qs-var qs-prompt &rest qs-args) - ;; Query user and return nil or t. - ;; Store answer in symbol VAR (which must initially be bound to nil). - ;; Format PROMPT with ARGS. - ;; Binding variable help-form will help the user who types C-h. - (let* ((char (symbol-value qs-var)) - (action (cdr (assoc char dired-query-alist)))) - (cond ((eq 'yes action) - t) ; accept, and don't ask again - ((eq 'no action) - nil) ; skip, and don't ask again - (t;; no lasting effects from last time we asked - ask now - (let ((qprompt (concat qs-prompt - (if help-form - (format " [Type yn!q or %s] " - (key-description - (char-to-string help-char))) - " [Type y, n, q or !] "))) - result elt) - ;; Actually it looks nicer without cursor-in-echo-area - you can - ;; look at the dired buffer instead of at the prompt to decide. - (apply 'message qprompt qs-args) - (setq char (set qs-var (read-char))) - (while (not (setq elt (assoc char dired-query-alist))) - (message "Invalid char - type %c for help." help-char) - (ding) - (sit-for 1) - (apply 'message qprompt qs-args) - (setq char (set qs-var (read-char)))) - (memq (cdr elt) '(t y yes))))))) - -(defun dired-pop-to-buffer (buf) - ;; Pop up buffer BUF. - ;; If dired-shrink-to-fit is t, make its window fit its contents. - (if (not dired-shrink-to-fit) - (pop-to-buffer (get-buffer-create buf)) - ;; let window shrink to fit: - (let ((window (selected-window)) - target-lines w2) - (cond ;; if split-window-threshold is enabled, use the largest window - ((and (> (window-height (setq w2 (get-largest-window))) - split-height-threshold) - (= (screen-width) (window-width w2))) - (setq window w2)) - ;; if the least-recently-used window is big enough, use it - ((and (> (window-height (setq w2 (get-lru-window))) - (* 2 window-min-height)) - (= (screen-width) (window-width w2))) - (setq window w2))) - (save-excursion - (set-buffer buf) - (goto-char (point-max)) - (skip-chars-backward "\n\r\t ") - (setq target-lines (count-lines (point-min) (point)))) - (if (<= (window-height window) (* 2 window-min-height)) - ;; At this point, every window on the screen is too small to split. - (setq w2 (display-buffer buf)) - (setq w2 (split-window window - (max window-min-height - (- (window-height window) - (1+ (max window-min-height target-lines))))))) - (set-window-buffer w2 buf) - (if (< (1- (window-height w2)) target-lines) - (progn - (select-window w2) - (enlarge-window (- target-lines (1- (window-height w2)))))) - (set-window-start w2 1) - ))) - -(defvar dired-no-confirm nil -;; "If non-nil, list of symbols for commands dired should not confirm. -;;It can be a sublist of -;; -;; '(byte-compile chgrp chmod chown compress copy delete hardlink load -;; move print shell symlink uncompress)" - ) - -(defun dired-mark-confirm (op-symbol arg) - ;; Request confirmation from the user that the operation described - ;; by OP-SYMBOL is to be performed on the marked files. - ;; Confirmation consists in a y-or-n question with a file list - ;; pop-up unless OP-SYMBOL is a member of `dired-no-confirm'. - ;; The files used are determined by ARG (like in dired-mark-get-files). - (or (memq op-symbol dired-no-confirm) - (let ((files (dired-mark-get-files t arg))) - (dired-mark-pop-up nil op-symbol files (function y-or-n-p) - (concat (capitalize (symbol-name op-symbol)) " " - (dired-mark-prompt arg files) "? "))))) - -(defun dired-mark-pop-up (bufname op-symbol files function &rest args) - ;;"Args BUFNAME OP-SYMBOL FILES FUNCTION &rest ARGS. - ;;Return FUNCTION's result on ARGS after popping up a window (in a buffer - ;;named BUFNAME, nil gives \" *Marked Files*\") showing the marked - ;;files. Uses function `dired-pop-to-buffer' to do that. - ;; FUNCTION should not manipulate files. - ;; It should only read input (an argument or confirmation). - ;;The window is not shown if there is just one file or - ;; OP-SYMBOL is a member of the list in `dired-no-confirm'. - ;;FILES is the list of marked files." - (or bufname (setq bufname " *Marked Files*")) - (if (or (memq op-symbol dired-no-confirm) - (= (length files) 1)) - (apply function args) - (save-excursion - (set-buffer (get-buffer-create bufname)) - (erase-buffer) - (dired-format-columns-of-files files)) - (save-window-excursion - (dired-pop-to-buffer bufname) - (apply function args)))) - -(defun dired-format-columns-of-files (files) - ;; Files should be in forward order for this loop. - ;; i.e., (car files) = first file in buffer. - ;; Returns the number of lines used. - (let* ((maxlen (+ 2 (apply 'max (mapcar 'length files)))) - (width (- (window-width (selected-window)) 2)) - (columns (max 1 (/ width maxlen))) - (nfiles (length files)) - (rows (+ (/ nfiles columns) - (if (zerop (% nfiles columns)) 0 1))) - (i 0) - (j 0)) - (setq files (nconc (copy-sequence files) ; fill up with empty fns - (make-list (- (* columns rows) nfiles) ""))) - (setcdr (nthcdr (1- (length files)) files) files) ; make circular - (while (< j rows) - (while (< i columns) - (indent-to (* i maxlen)) - (insert (car files)) - (setq files (nthcdr rows files) - i (1+ i))) - (insert "\n") - (setq i 0 - j (1+ j) - files (cdr files))) - rows)) - -;; Read arguments for a mark command of type OP-SYMBOL, -;; perhaps popping up the list of marked files. -;; ARG is the prefix arg and indicates whether the files came from -;; marks (ARG=nil) or a repeat factor (integerp ARG). -;; If the current file was used, the list has but one element and ARG -;; does not matter. (It is non-nil, non-integer in that case, namely '(4)). - -(defun dired-mark-read-string (prompt initial op-symbol arg files) - ;; PROMPT for a string, with INITIAL input. - ;; Other args are used to give user feedback and pop-up: - ;; OP-SYMBOL of command, prefix ARG, marked FILES. - (dired-mark-pop-up - nil op-symbol files - (function read-string) - (format prompt (dired-mark-prompt arg files)) initial)) - -(defun dired-mark-read-file-name (prompt dir op-symbol arg files) - (dired-mark-pop-up - nil op-symbol files - (function read-file-name) - (format prompt (dired-mark-prompt arg files)) dir)) - -(defun dired-mark-file (arg) - "In dired, mark the current line's file for later commands. -With arg, repeat over several lines. -Use \\[dired-unflag-all-files] to remove all flags." - (interactive "p") - (let (buffer-read-only) - (dired-repeat-over-lines - arg - (function (lambda () (delete-char 1) (insert dired-marker-char)))))) - -(defun dired-next-marked-file (arg &optional wrap opoint) - "Move to the next marked file, wrapping around the end of the buffer." - (interactive "_p\np") - (or opoint (setq opoint (point)));; return to where interactively started - (if (if (> arg 0) - (re-search-forward dired-re-mark nil t arg) - (beginning-of-line) - (re-search-backward dired-re-mark nil t (- arg))) - (dired-move-to-filename) - (if (null wrap) - (progn - (goto-char opoint) - (error "No next marked file")) - (message "(Wraparound for next marked file)") - (goto-char (if (> arg 0) (point-min) (point-max))) - (dired-next-marked-file arg nil opoint)))) - -(defun dired-prev-marked-file (arg &optional wrap) - "Move to the previous marked file, wrapping around the end of the buffer." - (interactive "_p\np") - (dired-next-marked-file (- arg) wrap)) - -(defun dired-file-marker (file) - ;; Return FILE's marker, or nil if unmarked. - (save-excursion - (and (dired-goto-file file) - (progn - (beginning-of-line) - (if (not (equal ?\040 (following-char))) - (following-char)))))) - -(defun dired-read-regexp (prompt &optional initial) -;; This is an extra function so that gmhist can redefine it. - (setq dired-flagging-regexp - (read-string prompt (or initial dired-flagging-regexp)))) - -(defun dired-mark-files-regexp (regexp &optional marker-char) - "Mark all files matching REGEXP for use in later commands. -A prefix argument means to unmark them instead. -`.' and `..' are never marked. - -REGEXP is an Emacs regexp, not a shell wildcard. Thus, use `\\.o$' for -object files--just `.o' will mark more than you might think." - (interactive - (list (dired-read-regexp (concat (if current-prefix-arg "Unmark" "Mark") - " files (regexp): ")) - (if current-prefix-arg ?\040))) - (let ((dired-marker-char (or marker-char dired-marker-char))) - (dired-mark-if - (and (not (looking-at dired-re-dot)) - (not (eolp)) ; empty line - (let ((fn (dired-get-filename nil t))) - (and fn (string-match regexp (file-name-nondirectory fn))))) - "matching file"))) - -(defun dired-flag-regexp-files (regexp) - "In dired, flag all files containing the specified REGEXP for deletion. -The match is against the non-directory part of the filename. Use `^' - and `$' to anchor matches. Exclude subdirs by hiding them. -`.' and `..' are never flagged." - (interactive (list (dired-read-regexp "Flag for deletion (regexp): "))) - (dired-mark-files-regexp regexp dired-del-marker)) - -(defun dired-mark-symlinks (unflag-p) - "Mark all symbolic links. -With prefix argument, unflag all those files." - (interactive "P") - (dired-check-ls-l) - (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) - (dired-mark-if (looking-at dired-re-sym) "symbolic link"))) - -(defun dired-mark-directories (unflag-p) - "Mark all directory file lines except `.' and `..'. -With prefix argument, unflag all those files." - (interactive "P") - (dired-check-ls-l) - (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) - (dired-mark-if (and (looking-at dired-re-dir) - (not (looking-at dired-re-dot))) - "directory file"))) - -(defun dired-mark-executables (unflag-p) - "Mark all executable files. -With prefix argument, unflag all those files." - (interactive "P") - (dired-check-ls-l) - (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) - (dired-mark-if (looking-at dired-re-exe) "executable file"))) - -;; dired-x.el has a dired-mark-sexp interactive command: mark -;; files for which PREDICATE returns non-nil. - -(defun dired-flag-auto-save-files (&optional unflag-p) - "Flag for deletion files whose names suggest they are auto save files. -A prefix argument says to unflag those files instead." - (interactive "P") - (dired-check-ls-l) - (let ((dired-marker-char (if unflag-p ?\040 dired-del-marker))) - (dired-mark-if - (and (not (looking-at dired-re-dir)) - (let ((fn (dired-get-filename t t))) - (if fn (auto-save-file-name-p - (file-name-nondirectory fn))))) - "auto save file"))) - -(defun dired-flag-backup-files (&optional unflag-p) - "Flag all backup files (names ending with `~') for deletion. -With prefix argument, unflag these files." - (interactive "P") - (dired-check-ls-l) - (let ((dired-marker-char (if unflag-p ?\040 dired-del-marker))) - (dired-mark-if - (and (not (looking-at dired-re-dir)) - (let ((fn (dired-get-filename t t))) - (if fn (backup-file-name-p fn)))) - "backup file"))) - - -;;; Shell commands -;;#### install (move this function into simple.el) -(defun shell-quote (filename) ; actually belongs into simple.el - "Quote a file name for inferior shell (see variable shell-file-name)." - ;; Quote everything except POSIX filename characters. - ;; This should be safe enough even for really wierd shells. - (let ((result "") (start 0) end) - (while (string-match "[^---0-9a-zA-Z_./]" filename start) - (setq end (match-beginning 0) - result (concat result (substring filename start end) - "\\" (substring filename end (1+ end))) - start (1+ end))) - (concat result (substring filename start)))) - -(defun dired-read-shell-command (prompt arg files) -;; "Read a dired shell command prompting with PROMPT (using read-string). -;;ARG is the prefix arg and may be used to indicate in the prompt which -;; files are affected. -;;This is an extra function so that you can redefine it, e.g., to use gmhist." - (dired-mark-pop-up - nil 'shell files - (function read-string) (format prompt (dired-mark-prompt arg files)))) - -;; The in-background argument is only needed in Emacs 18 where -;; shell-command doesn't understand an appended ampersand `&'. -(defun dired-do-shell-command (&optional arg in-background) - "Run a shell command on the marked files. -If there is output, it goes to a separate buffer. -The list of marked files is appended to the command string unless asterisks - `*' indicate the place(s) where the list should go. -If no files are marked or a specific numeric prefix arg is given, uses - next ARG files. As always, a raw arg (\\[universal-argument]) means the current file. - The prompt mentions the file(s) or the marker, as appropriate. -With a zero argument, run command on each marked file separately: `cmd * - foo' results in `cmd F1 foo; ...; cmd Fn foo'. -No automatic redisplay is attempted, as the file names may have - changed. Type \\[dired-do-redisplay] to redisplay the marked files. -The shell command has the top level directory as working directory, so - output files usually are created there instead of in a subdir." -;;Functions dired-run-shell-command and dired-shell-stuff-it do the -;;actual work and can be redefined for customization. - (interactive "P") - (let* ((on-each (equal arg 0)) - (prompt (concat (if in-background "& on " "! on ") - (if on-each "each " "") - "%s: ")) - (file-list (dired-mark-get-files t (if on-each nil arg))) - ;; Want to give feedback whether this file or marked files are used: - (command (dired-read-shell-command - prompt (if on-each nil arg) file-list)) - (result - (dired-shell-stuff-it command file-list on-each arg))) - ;; execute the shell command - (dired-run-shell-command result in-background))) - -;; Might use {,} for bash or csh: -(defvar dired-mark-prefix "" - "Prepended to marked files in dired shell commands.") -(defvar dired-mark-postfix "" - "Appended to marked files in dired shell commands.") -(defvar dired-mark-separator " " - "Separates marked files in dired shell commands.") - -(defun dired-shell-stuff-it (command file-list on-each &optional raw-arg) -;; "Make up a shell command line from COMMAND and FILE-LIST. -;; If ON-EACH is t, COMMAND should be applied to each file, else -;; simply concat all files and apply COMMAND to this. -;; FILE-LIST's elements will be quoted for the shell." -;; Might be redefined for smarter things and could then use RAW-ARG -;; (coming from interactive P and currently ignored) to decide what to do. -;; Smart would be a way to access basename or extension of file names. -;; See dired-trns.el for an approach to this. - ;; Bug: There is no way to quote a * - ;; On the other hand, you can never accidentally get a * into your cmd. - (let ((stuff-it - (if (string-match "\\*" command) - (function (lambda (x) - (dired-replace-in-string "\\*" x command))) - (function (lambda (x) (concat command " " x)))))) - (if on-each - (mapconcat stuff-it (mapcar (function shell-quote) file-list) ";") - (let ((fns (mapconcat (function shell-quote) - file-list dired-mark-separator))) - (if (> (length file-list) 1) - (setq fns (concat dired-mark-prefix fns dired-mark-postfix))) - (funcall stuff-it fns))))) - -;; This is an extra function so that it can be redefined by ange-ftp. -(defun dired-run-shell-command (command &optional in-background) - (if (and in-background (not (string-match "&[ \t]*$" command))) - (setq command (concat command " &"))) - (shell-command command)) - -(defun dired-do-print (&optional arg) - "Print the marked (or next ARG) files. -Uses the shell command coming from variables `lpr-command' and -`lpr-switches' as default." - (interactive "P") - (or (listp lpr-switches) - (error "lpr-switches must be a *list* of strings")) - (let* ((file-list (dired-mark-get-files t arg)) - (switches (mapconcat (function identity) lpr-switches " ")) - (command (dired-mark-read-string - "Print %s with: " - (concat lpr-command " " switches) - 'print arg file-list))) - (dired-run-shell-command (dired-shell-stuff-it command file-list nil)))) - - -;;; 10K -;;;###begin dired-cp.el -;;; Copy, move/rename, making hard and symbolic links - -(defvar dired-backup-if-overwrite nil - "*Non-nil if Dired should ask about making backups before overwriting files. -Special value 'always suppresses confirmation.") - -(defun dired-handle-overwrite (to) - ;; Save old version of a to be overwritten file TO. - ;; `overwrite-confirmed' and `overwrite-backup-query' are fluid vars - ;; from dired-create-files. - (if (and dired-backup-if-overwrite - overwrite-confirmed - (or (eq 'always dired-backup-if-overwrite) - (dired-query 'overwrite-backup-query - (format "Make backup for existing file `%s'? " to)))) - (let ((backup (car (find-backup-file-name to)))) - (rename-file to backup 0) ; confirm overwrite of old backup - (dired-relist-entry backup)))) - -(defun dired-copy-file (from to ok-flag) - (dired-handle-overwrite to) - (copy-file from to ok-flag dired-copy-preserve-time)) - -(defun dired-rename-file (from to ok-flag) - (dired-handle-overwrite to) - (rename-file from to ok-flag) ; error is caught in -create-files - ;; Silently rename the visited file of any buffer visiting this file. - (and (get-file-buffer from) - (save-excursion - (set-buffer (get-file-buffer from)) - (let ((modflag (buffer-modified-p))) - (set-visited-file-name to) ; kills write-file-hooks - (set-buffer-modified-p modflag)))) - (dired-remove-file from) - ;; See if it's an inserted subdir, and rename that, too. - (dired-rename-subdir from to)) - -(defun dired-rename-subdir (from-dir to-dir) - (setq from-dir (file-name-as-directory from-dir) - to-dir (file-name-as-directory to-dir)) - (dired-fun-in-all-buffers from-dir - (function dired-rename-subdir-1) from-dir to-dir) - ;; Update visited file name of all affected buffers - (let ((blist (buffer-list))) - (while blist - (save-excursion - (set-buffer (car blist)) - (if (and buffer-file-name - (dired-in-this-tree buffer-file-name from-dir)) - (let ((modflag (buffer-modified-p)) - (to-file (dired-replace-in-string - (concat "^" (regexp-quote from-dir)) - to-dir - buffer-file-name))) - (set-visited-file-name to-file) - (set-buffer-modified-p modflag)))) - (setq blist (cdr blist))))) - -(defun dired-rename-subdir-1 (dir to) - ;; Rename DIR to TO in headerlines and dired-subdir-alist, if DIR or - ;; one of its subdirectories is expanded in this buffer. - (let ((alist dired-subdir-alist) - (elt nil)) - (while alist - (setq elt (car alist) - alist (cdr alist)) - (if (dired-in-this-tree (car elt) dir) - ;; ELT's subdir is affected by the rename - (dired-rename-subdir-2 elt dir to))) - (if (equal dir default-directory) - ;; if top level directory was renamed, lots of things have to be - ;; updated: - (progn - (dired-unadvertise dir) ; we no longer dired DIR... - (setq default-directory to - dired-directory (expand-file-name;; this is correct - ;; with and without wildcards - (file-name-nondirectory dired-directory) - to)) - (let ((new-name (file-name-nondirectory - (directory-file-name dired-directory)))) - ;; try to rename buffer, but just leave old name if new - ;; name would already exist (don't try appending "<%d>") - (or (get-buffer new-name) - (rename-buffer new-name))) - ;; ... we dired TO now: - (dired-advertise))))) - -(defun dired-rename-subdir-2 (elt dir to) - ;; Update the headerline and dired-subdir-alist element of directory - ;; described by alist-element ELT to reflect the moving of DIR to TO. - ;; Thus, ELT describes either DIR itself or a subdir of DIR. - - ;; Bug: If TO is not longer part of the same dired tree as DIR was, - ;; updating the headerline is actually not the right thing---it - ;; should be removed in that case and a completely new entry be - ;; added for TO. Actually, removing and adding anew would always be - ;; the right (but slow) way of doing it. - - ;; The consequences are pretty harmless though (no updates since - ;; dired-buffers-for-dir will not suspect it to be in this dired - ;; buffer). - - (save-excursion - (let ((regexp (regexp-quote (directory-file-name dir))) - (newtext (directory-file-name to)) - buffer-read-only) - (goto-char (dired-get-subdir-min elt)) - ;; Update subdir headerline in buffer - (if (not (looking-at dired-subdir-regexp)) - (error "%s not found where expected - dired-subdir-alist broken?" - dir) - (goto-char (match-beginning 1)) - (if (re-search-forward regexp (match-end 1) t) - (replace-match newtext t t) - (error "Expected to find `%s' in headerline of %s" dir (car elt)))) - ;; Update buffer-local dired-subdir-alist - (setcar elt - (dired-normalize-subdir - (dired-replace-in-string regexp newtext (car elt))))))) - -;; Cloning replace-match to work on strings instead of in buffer: -;; The FIXEDCASE parameter of replace-match is not implemented. -(defun dired-string-replace-match (regexp string newtext - &optional literal global) - "Replace first match of REGEXP in STRING with NEWTEXT. -If it does not match, nil is returned instead of the new string. -Optional arg LITERAL means to take NEWTEXT literally. -Optional arg GLOBAL means to replace all matches." - (if global - (let ((result "") (start 0) mb me) - (while (string-match regexp string start) - (setq mb (match-beginning 0) - me (match-end 0) - result (concat result - (substring string start mb) - (if literal - newtext - (dired-expand-newtext string newtext))) - start me)) - (if mb ; matched at least once - (concat result (substring string start)) - nil)) - ;; not GLOBAL - (if (not (string-match regexp string 0)) - nil - (concat (substring string 0 (match-beginning 0)) - (if literal newtext (dired-expand-newtext string newtext)) - (substring string (match-end 0)))))) - -(defun dired-expand-newtext (string newtext) - ;; Expand \& and \1..\9 (referring to STRING) in NEWTEXT, using match data. - ;; Note that in Emacs 18 match data are clipped to current buffer - ;; size...so the buffer should better not be smaller than STRING. - (let ((pos 0) - (len (length newtext)) - (expanded-newtext "")) - (while (< pos len) - (setq expanded-newtext - (concat expanded-newtext - (let ((c (aref newtext pos))) - (if (= ?\\ c) - (cond ((= ?\& (setq c - (aref newtext - (setq pos (1+ pos))))) - (substring string - (match-beginning 0) - (match-end 0))) - ((and (>= c ?1) (<= c ?9)) - ;; return empty string if N'th - ;; sub-regexp did not match: - (let ((n (- c ?0))) - (if (match-beginning n) - (substring string - (match-beginning n) - (match-end n)) - ""))) - (t - (char-to-string c))) - (char-to-string c))))) - (setq pos (1+ pos))) - expanded-newtext)) - -;; The basic function for half a dozen variations on cp/mv/ln/ln -s. -(defun dired-create-files (file-creator operation fn-list name-constructor - &optional marker-char) - -;; Create a new file for each from a list of existing files. The user -;; is queried, dired buffers are updated, and at the end a success or -;; failure message is displayed - -;; FILE-CREATOR must accept three args: oldfile newfile ok-if-already-exists - -;; It is called for each file and must create newfile, the entry of -;; which will be added. The user will be queried if the file already -;; exists. If oldfile is removed by FILE-CREATOR (i.e, it is a -;; rename), it is FILE-CREATOR's responsibility to update dired -;; buffers. FILE-CREATOR must abort by signalling a file-error if it -;; could not create newfile. The error is caught and logged. - -;; OPERATION (a capitalized string, e.g. `Copy') describes the -;; operation performed. It is used for error logging. - -;; FN-LIST is the list of files to copy (full absolute pathnames). - -;; NAME-CONSTRUCTOR returns a newfile for every oldfile, or nil to -;; skip. If it skips files for other reasons than a direct user -;; query, it is supposed to tell why (using dired-log). - -;; Optional MARKER-CHAR is a character with which to mark every -;; newfile's entry, or t to use the current marker character if the -;; oldfile was marked. - - (let (failures skipped (success-count 0) (total (length fn-list))) - (let (to overwrite-query - overwrite-backup-query) ; for dired-handle-overwrite - (mapcar - (function - (lambda (from) - (setq to (funcall name-constructor from)) - (if (equal to from) - (progn - (setq to nil) - (dired-log "Cannot %s to same file: %s\n" - (downcase operation) from))) - (if (not to) - (setq skipped (cons (dired-make-relative from) skipped)) - (let* ((overwrite (file-exists-p to)) - (overwrite-confirmed ; for dired-handle-overwrite - (and overwrite - (let ((help-form '(format "\ -Type SPC or `y' to overwrite file `%s', -DEL or `n' to skip to next, -ESC or `q' to not overwrite any of the remaining files, -`!' to overwrite all remaining files with no more questions." to))) - (dired-query 'overwrite-query - "Overwrite `%s'?" to)))) - ;; must determine if FROM is marked before file-creator - ;; gets a chance to delete it (in case of a move). - (actual-marker-char - (cond ((integerp marker-char) marker-char) - (marker-char (dired-file-marker from)) ; slow - (t nil)))) - (condition-case err - (progn - (funcall file-creator from to overwrite-confirmed) - (if overwrite - ;; If we get here, file-creator hasn't been aborted - ;; and the old entry (if any) has to be deleted - ;; before adding the new entry. - (dired-remove-file to)) - (setq success-count (1+ success-count)) - (message "%s: %d of %d" operation success-count total) - (dired-add-file to actual-marker-char)) - (file-error ; FILE-CREATOR aborted - (progn - (setq failures (cons (dired-make-relative from) failures)) - (dired-log "%s `%s' to `%s' failed:\n%s\n" - operation from to err)))))))) - fn-list)) - (cond - (failures - (dired-log-summary - (message "%s failed for %d of %d file%s %s" - operation (length failures) total - (dired-plural-s total) failures))) - (skipped - (dired-log-summary - (message "%s: %d of %d file%s skipped %s" - operation (length skipped) total - (dired-plural-s total) skipped))) - (t - (message "%s: %s file%s." - operation success-count (dired-plural-s success-count))))) - (dired-move-to-filename)) - -(defun dired-do-create-files (op-symbol file-creator operation arg - &optional marker-char op1 - how-to) - ;; Create a new file for each marked file. - ;; Prompts user for target, which is a directory in which to create - ;; the new files. Target may be a plain file if only one marked - ;; file exists. - ;; OP-SYMBOL is the symbol for the operation. Function `dired-mark-pop-up' - ;; will determine wether pop-ups are appropriate for this OP-SYMBOL. - ;; FILE-CREATOR and OPERATION as in dired-create-files. - ;; ARG as in dired-mark-get-files. - ;; Optional arg OP1 is an alternate form for OPERATION if there is - ;; only one file. - ;; Optional arg MARKER-CHAR as in dired-create-files. - ;; Optional arg HOW-TO determines how to treat target: - ;; If HOW-TO is not given (or nil), and target is a directory, the - ;; file(s) are created inside the target directory. If target - ;; is not a directory, there must be exactly one marked file, - ;; else error. - ;; If HOW-TO is t, then target is not modified. There must be - ;; exactly one marked file, else error. - ;; Else HOW-TO is assumed to be a function of one argument, target, - ;; that looks at target and returns a value for the into-dir - ;; variable. The function dired-into-dir-with-symlinks is provided - ;; for the case (common when creating symlinks) that symbolic - ;; links to directories are not to be considered as directories - ;; (as file-directory-p would if HOW-TO had been nil). - (or op1 (setq op1 operation)) - (let* ((fn-list (dired-mark-get-files nil arg)) - (fn-count (length fn-list)) - (target (expand-file-name - (dired-mark-read-file-name - (concat (if (= 1 fn-count) op1 operation) " %s to: ") - (dired-dwim-target-directory) - op-symbol arg (mapcar (function dired-make-relative) fn-list)))) - (into-dir (cond ((null how-to) (file-directory-p target)) - ((eq how-to t) nil) - (t (funcall how-to target))))) - (if (and (> fn-count 1) - (not into-dir)) - (error "Marked %s: target must be a directory: %s" operation target)) - ;; rename-file bombs when moving directories unless we do this: - (or into-dir (setq target (directory-file-name target))) - (dired-create-files - file-creator operation fn-list - (if into-dir ; target is a directory - ;; This function uses fluid vars into-dir and target when called - ;; inside dired-create-files: - (function (lambda (from) - (expand-file-name (file-name-nondirectory from) target))) - (function (lambda (from) target))) - marker-char))) - -(defun dired-dwim-target-directory () - ;; Try to guess which target directory the user may want. - ;; If there is a dired buffer displayed in the next window, use - ;; its current subdir, else use current subdir of this dired buffer. - (let ((this-dir (and (eq major-mode 'dired-mode) - (dired-current-directory)))) - ;; non-dired buffer may want to profit from this function, e.g. vm-uudecode - (if dired-dwim-target - (let* ((other-buf (window-buffer (next-window))) - (other-dir (save-excursion - (set-buffer other-buf) - (and (eq major-mode 'dired-mode) - (dired-current-directory))))) - (or other-dir this-dir)) - this-dir))) - -(defun dired-into-dir-with-symlinks (target) - (and (file-directory-p target) - (not (file-symlink-p target)))) -;; This may not always be what you want, especially if target is your -;; home directory and it happens to be a symbolic link, as is often the -;; case with NFS and automounters. Or if you want to make symlinks -;; into directories that themselves are only symlinks, also quite -;; common. - -;; So we don't use this function as value for HOW-TO in -;; dired-do-symlink, which has the minor disadvantage of -;; making links *into* a symlinked-dir, when you really wanted to -;; *overwrite* that symlink. In that (rare, I guess) case, you'll -;; just have to remove that symlink by hand before making your marked -;; symlinks. - -(defun dired-do-copy (&optional arg) - "Copy all marked (or next ARG) files, or copy the current file. -Thus, a zero prefix argument copies nothing. But it toggles the -variable `dired-copy-preserve-time' (which see)." - (interactive "P") - (if (not (zerop (prefix-numeric-value arg))) - (dired-do-create-files 'copy (function dired-copy-file) - (if dired-copy-preserve-time "Copy [-p]" "Copy") - arg dired-keep-marker-copy) - (setq dired-copy-preserve-time (not dired-copy-preserve-time)) - (if dired-copy-preserve-time - (message "Copy will preserve time.") - (message "Copied files will get current date.")))) - -(defun dired-do-symlink (&optional arg) - "Symlink all marked (or next ARG) files into a directory, -or make a symbolic link to the current file." - (interactive "P") - (dired-do-create-files 'symlink (function make-symbolic-link) - "SymLink" arg dired-keep-marker-symlink)) - -(defun dired-do-hardlink (&optional arg) - "Hard-link all marked (or next ARG) files into a directory, -or make a hard link to the current file." - (interactive "P") - (dired-do-create-files 'hardlink (function add-name-to-file) - "HardLink" arg dired-keep-marker-hardlink)) - -(defun dired-do-move (&optional arg) - "Move all marked (or next ARG) files into a directory, -or rename the current file. -A zero ARG moves no files but toggles `dired-dwim-target' (which see)." - (interactive "P") - (if (not (zerop (prefix-numeric-value arg))) - (dired-do-create-files 'move (function dired-rename-file) - "Move" arg dired-keep-marker-move "Rename") - (setq dired-dwim-target (not dired-dwim-target)) - (message "dired-dwim-target is %s." (if dired-dwim-target "ON" "OFF")))) - -;;;###end dired-cp.el - -;;; 5K -;;;###begin dired-re.el -(defun dired-do-create-files-regexp - (file-creator operation arg regexp newname &optional whole-path marker-char) - ;; Create a new file for each marked file using regexps. - ;; FILE-CREATOR and OPERATION as in dired-create-files. - ;; ARG as in dired-mark-get-files. - ;; Matches each marked file against REGEXP and constructs the new - ;; filename from NEWNAME (like in function replace-match). - ;; Optional arg WHOLE-PATH means match/replace the whole pathname - ;; instead of only the non-directory part of the file. - ;; Optional arg MARKER-CHAR as in dired-create-files. - (let* ((fn-list (dired-mark-get-files nil arg)) - (fn-count (length fn-list)) - (operation-prompt (concat operation " `%s' to `%s'?")) - (rename-regexp-help-form (format "\ -Type SPC or `y' to %s one match, DEL or `n' to skip to next, -`!' to %s all remaining matches with no more questions." - (downcase operation) - (downcase operation))) - (regexp-name-constructor - ;; Function to construct new filename using REGEXP and NEWNAME: - (if whole-path ; easy (but rare) case - (function - (lambda (from) - (let ((to (dired-string-replace-match regexp from newname)) - ;; must bind help-form directly around call to - ;; dired-query - (help-form rename-regexp-help-form)) - (if to - (and (dired-query 'rename-regexp-query - operation-prompt - from - to) - to) - (dired-log "%s: %s did not match regexp %s\n" - operation from regexp))))) - ;; not whole-path, replace non-directory part only - (function - (lambda (from) - (let* ((new (dired-string-replace-match - regexp (file-name-nondirectory from) newname)) - (to (and new ; nil means there was no match - (expand-file-name new - (file-name-directory from)))) - (help-form rename-regexp-help-form)) - (if to - (and (dired-query 'rename-regexp-query - operation-prompt - (dired-make-relative from) - (dired-make-relative to)) - to) - (dired-log "%s: %s did not match regexp %s\n" - operation (file-name-nondirectory from) regexp))))))) - rename-regexp-query) - (dired-create-files - file-creator operation fn-list regexp-name-constructor marker-char))) - -(defun dired-mark-read-regexp (operation) - ;; Prompt user about performing OPERATION. - ;; Read and return list of: regexp newname arg whole-path. - (let* ((whole-path - (equal 0 (prefix-numeric-value current-prefix-arg))) - (arg - (if whole-path nil current-prefix-arg)) - (regexp - (dired-read-regexp - (concat (if whole-path "Path " "") operation " from (regexp): ") - dired-flagging-regexp)) - (newname - (read-string - (concat (if whole-path "Path " "") operation " " regexp " to: ")))) - (list regexp newname arg whole-path))) - -(defun dired-do-rename-regexp (regexp newname &optional arg whole-path) - "Rename marked files containing REGEXP to NEWNAME. -As each match is found, the user must type a character saying - what to do with it. For directions, type \\[help-command] at that time. -NEWNAME may contain \\=\\ or \\& as in `query-replace-regexp'. -REGEXP defaults to the last regexp used. -With a zero prefix arg, renaming by regexp affects the complete - pathname - usually only the non-directory part of file names is used - and changed." - (interactive (dired-mark-read-regexp "Rename")) - (dired-do-create-files-regexp - (function dired-rename-file) - "Rename" arg regexp newname whole-path dired-keep-marker-move)) - -(defun dired-do-copy-regexp (regexp newname &optional arg whole-path) - "Copy all marked files containing REGEXP to NEWNAME. -See function `dired-rename-regexp' for more info." - (interactive (dired-mark-read-regexp "Copy")) - (dired-do-create-files-regexp - (function dired-copy-file) - (if dired-copy-preserve-time "Copy [-p]" "Copy") - arg regexp newname whole-path dired-keep-marker-copy)) - -(defun dired-do-hardlink-regexp (regexp newname &optional arg whole-path) - "Hardlink all marked files containing REGEXP to NEWNAME. -See function `dired-rename-regexp' for more info." - (interactive (dired-mark-read-regexp "HardLink")) - (dired-do-create-files-regexp - (function add-name-to-file) - "HardLink" arg regexp newname whole-path dired-keep-marker-hardlink)) - -(defun dired-do-symlink-regexp (regexp newname &optional arg whole-path) - "Symlink all marked files containing REGEXP to NEWNAME. -See function `dired-rename-regexp' for more info." - (interactive (dired-mark-read-regexp "SymLink")) - (dired-do-create-files-regexp - (function make-symbolic-link) - "SymLink" arg regexp newname whole-path dired-keep-marker-symlink)) - -(defun dired-create-files-non-directory - (file-creator basename-constructor operation arg) - ;; Perform FILE-CREATOR on the non-directory part of marked files - ;; using function BASENAME-CONSTRUCTOR, with query for each file. - ;; OPERATION like in dired-create-files, ARG like in dired-mark-get-files. - (let (rename-non-directory-query) - (dired-create-files - file-creator - operation - (dired-mark-get-files nil arg) - (function - (lambda (from) - (let ((to (concat (file-name-directory from) - (funcall basename-constructor - (file-name-nondirectory from))))) - (and (let ((help-form (format "\ -Type SPC or `y' to %s one file, DEL or `n' to skip to next, -`!' to %s all remaining matches with no more questions." - (downcase operation) - (downcase operation)))) - (dired-query 'rename-non-directory-query - (concat operation " `%s' to `%s'") - (dired-make-relative from) - (dired-make-relative to))) - to)))) - dired-keep-marker-move))) - -(defun dired-rename-non-directory (basename-constructor operation arg) - (dired-create-files-non-directory - (function dired-rename-file) - basename-constructor operation arg)) - -(defun dired-upcase (&optional arg) - "Rename all marked (or next ARG) files to upper case." - (interactive "P") - (dired-rename-non-directory (function upcase) "Rename upcase" arg)) - -(defun dired-downcase (&optional arg) - "Rename all marked (or next ARG) files to lower case." - (interactive "P") - (dired-rename-non-directory (function downcase) "Rename downcase" arg)) - -;;;###end dired-re.el - - -;; Tree Dired - -;;; utility functions - -(defun dired-in-this-tree (file dir) - ;;"Is FILE part of the directory tree starting at DIR?" - (let (case-fold-search) - (string-match (concat "^" (regexp-quote dir)) file))) - -(defun dired-make-absolute (file &optional dir) - ;;"Convert FILE (a pathname relative to DIR) to an absolute pathname." - ;; We can't always use expand-file-name as this would get rid of `.' - ;; or expand in / instead default-directory if DIR=="". - ;; This should be good enough for ange-ftp, but might easily be - ;; redefined (for VMS?). - ;; It should be reasonably fast, though, as it is called in - ;; dired-get-filename. - (concat (or dir default-directory) file)) - -(defun dired-make-relative (file &optional dir no-error) - ;;"Convert FILE (an absolute pathname) to a pathname relative to DIR. - ;; Else error (unless NO-ERROR is non-nil, then FILE is returned unchanged) - ;;DIR defaults to default-directory." - ;; DIR must be file-name-as-directory, as with all directory args in - ;; elisp code. - (or dir (setq dir default-directory)) - (if (string-match (concat "^" (regexp-quote dir)) file) - (substring file (match-end 0)) - (if no-error - file - (error "%s: not in directory tree growing at %s" file dir)))) - -(defun dired-normalize-subdir (dir) - ;; Prepend default-directory to DIR if relative path name. - ;; dired-get-filename must be able to make a valid filename from a - ;; file and its directory DIR. - (file-name-as-directory - (if (file-name-absolute-p dir) - dir - (expand-file-name dir default-directory)))) - -(defun dired-between-files () - ;; Point must be at beginning of line - ;; Should be equivalent to (save-excursion (not (dired-move-to-filename))) - ;; but is about 1.5..2.0 times as fast. (Actually that's not worth it) - (or (looking-at "^$\\|^. *$\\|^. total\\|^. wildcard") - (looking-at dired-subdir-regexp))) - -(defun dired-get-subdir () - ;;"Return the subdir name on this line, or nil if not on a headerline." - ;; Look up in the alist whether this is a headerline. - (save-excursion - (let ((cur-dir (dired-current-directory))) - (beginning-of-line) ; alist stores b-o-l positions - (and (zerop (- (point) - (dired-get-subdir-min (assoc cur-dir - dired-subdir-alist)))) - cur-dir)))) - -;(defun dired-get-subdir-min (elt) -; (cdr elt)) -;; can't use macro, must be redefinable for other alist format in dired-nstd. -(fset 'dired-get-subdir-min 'cdr) - -(defun dired-get-subdir-max (elt) - (save-excursion - (goto-char (dired-get-subdir-min elt)) - (dired-subdir-max))) - -(defun dired-clear-alist () - (while dired-subdir-alist - (set-marker (dired-get-subdir-min (car dired-subdir-alist)) nil) - (setq dired-subdir-alist (cdr dired-subdir-alist)))) - -(defun dired-simple-subdir-alist () - ;; Build and return `dired-subdir-alist' assuming just the top level - ;; directory to be inserted. Don't parse the buffer. - (set (make-local-variable 'dired-subdir-alist) - (list (cons default-directory (point-min-marker))))) - -(defun dired-build-subdir-alist () - "Build `dired-subdir-alist' by parsing the buffer and return it's new value." - (interactive) - (dired-clear-alist) - (save-excursion - (let ((count 0)) - (goto-char (point-min)) - (setq dired-subdir-alist nil) - (while (re-search-forward dired-subdir-regexp nil t) - (setq count (1+ count)) - (dired-alist-add-1 (buffer-substring (match-beginning 1) - (match-end 1)) - ;; Put subdir boundary between lines: - (save-excursion - (goto-char (match-beginning 0)) - (beginning-of-line) - (point-marker))) - (message "%d" count)) - (message "%d director%s." count (if (= 1 count) "y" "ies")) - ;; We don't need to sort it because it is in buffer order per - ;; constructionem. Return new alist: - dired-subdir-alist))) - -(defun dired-alist-add (dir new-marker) - ;; Add new DIR at NEW-MARKER. Sort alist. - (dired-alist-add-1 dir new-marker) - (dired-alist-sort)) - -(defun dired-alist-add-1 (dir new-marker) - ;; Add new DIR at NEW-MARKER. Don't sort. - (setq dired-subdir-alist - (cons (cons (dired-normalize-subdir dir) new-marker) - dired-subdir-alist))) - -(defun dired-alist-sort () - ;; Keep the alist sorted on buffer position. - (setq dired-subdir-alist - (sort dired-subdir-alist - (function (lambda (elt1 elt2) - (> (dired-get-subdir-min elt1) - (dired-get-subdir-min elt2))))))) - -(defun dired-unsubdir (dir) - ;; Remove DIR from the alist - (setq dired-subdir-alist - (delq (assoc dir dired-subdir-alist) dired-subdir-alist))) - -(defun dired-goto-next-nontrivial-file () - ;; Position point on first nontrivial file after point. - (dired-goto-next-file);; so there is a file to compare with - (if (stringp dired-trivial-filenames) - (while (and (not (eobp)) - (string-match dired-trivial-filenames - (file-name-nondirectory - (or (dired-get-filename nil t) "")))) - (forward-line 1) - (dired-move-to-filename)))) - -(defun dired-goto-next-file () - (let ((max (1- (dired-subdir-max)))) - (while (and (not (dired-move-to-filename)) (< (point) max)) - (forward-line 1)))) - -(defun dired-goto-subdir (dir) - "Goto end of header line of DIR in this dired buffer. -Return value of point on success, otherwise return nil. -The next char is either \\n, or \\r if DIR is hidden." - (interactive - (prog1 ; let push-mark display its message - (list (expand-file-name - (completing-read "Goto in situ directory: " ; prompt - dired-subdir-alist ; table - nil ; predicate - t ; require-match - (dired-current-directory)))) - (push-mark))) - (setq dir (file-name-as-directory dir)) - (let ((elt (assoc dir dired-subdir-alist))) - (and elt - (goto-char (dired-get-subdir-min elt)) - ;; dired-subdir-hidden-p and dired-add-entry depend on point being - ;; at either \r or \n after this function succeeds. - (progn (skip-chars-forward "^\r\n") - (point))))) - -(defun dired-goto-file (file) - "Goto file line of FILE in this dired buffer." - ;; Return value of point on success, else nil. - ;; FILE must be an absolute pathname. - ;; Loses if FILE contains control chars like "\007" for which ls - ;; either inserts "?" or "\\007" into the buffer, so we won't find - ;; it in the buffer. - (interactive - (prog1 ; let push-mark display its message - (list (expand-file-name - (read-file-name "Goto file: " - (dired-current-directory)))) - (push-mark))) - (setq file (directory-file-name file)) ; does no harm if no directory - (let (found case-fold-search) - (save-excursion - (if (dired-goto-subdir (or (file-name-directory file) - (error "Need absolute pathname for %s" file))) - (let ((base (file-name-nondirectory file)) - (boundary (dired-subdir-max))) - (while (and (not found) - ;; filenames are preceded by SPC, this makes - ;; the search faster (e.g. for the filename "-"!). - (search-forward (concat " " base) boundary 'move)) - ;; Match could have BASE just as initial substring - ;; or in permission bits or date or - ;; not be a proper filename at all: - (if (equal base (dired-get-filename 'no-dir t)) - ;; Must move to filename since an (actually - ;; correct) match could have been elsewhere on the - ;; ;; line (e.g. "-" would match somewhere in the - ;; permission bits). - (setq found (dired-move-to-filename))))))) - (and found - ;; return value of point (i.e., FOUND): - (goto-char found)))) - -(defun dired-initial-position (dirname) - ;; Where point should go in a new listing of DIRNAME. - ;; Point assumed at beginning of new subdir line. - ;; You may redefine this function as you wish, e.g. like in dired-x.el. - (end-of-line) - (if dired-trivial-filenames (dired-goto-next-nontrivial-file))) - -;;; moving by subdirectories - -(defun dired-subdir-index (dir) - ;; Return an index into alist for use with nth - ;; for the sake of subdir moving commands. - (let (found (index 0) (alist dired-subdir-alist)) - (while alist - (if (string= dir (car (car alist))) - (setq alist nil found t) - (setq alist (cdr alist) index (1+ index)))) - (if found index nil))) - -(defun dired-next-subdir (arg &optional no-error-if-not-found no-skip) - "Go to next subdirectory, regardless of level." - ;; Use 0 arg to go to this directory's header line. - ;; NO-SKIP prevents moving to end of header line, returning whatever - ;; position was found in dired-subdir-alist. - (interactive "_p") - (let ((this-dir (dired-current-directory)) - pos index) - ;; nth with negative arg does not return nil but the first element - (setq index (- (dired-subdir-index this-dir) arg)) - (setq pos (if (>= index 0) - (dired-get-subdir-min (nth index dired-subdir-alist)))) - (if pos - (progn - (goto-char pos) - (or no-skip (skip-chars-forward "^\n\r")) - (point)) - (if no-error-if-not-found - nil ; return nil if not found - (error "%s directory" (if (> arg 0) "Last" "First")))))) - -(defun dired-prev-subdir (arg &optional no-error-if-not-found no-skip) - "Go to previous subdirectory, regardless of level. -When called interactively and not on a subdir line, go to this subdir's line." - ;;(interactive "_p") - (interactive - (list (if current-prefix-arg - (prefix-numeric-value current-prefix-arg) - ;; if on subdir start already, don't stay there! - (if (dired-get-subdir) 1 0)))) - (dired-next-subdir (- arg) no-error-if-not-found no-skip)) - -(defun dired-tree-up (arg) - "Go up ARG levels in the dired tree." - (interactive "_p") - (let ((dir (dired-current-directory))) - (while (>= arg 1) - (setq arg (1- arg) - dir (file-name-directory (directory-file-name dir)))) - ;;(setq dir (expand-file-name dir)) - (or (dired-goto-subdir dir) - (error "Cannot go up to %s - not in this tree." dir)))) - -(defun dired-tree-down () - "Go down in the dired tree." - (interactive "_") - (let ((dir (dired-current-directory)) ; has slash - pos case-fold-search) ; filenames are case sensitive - (let ((rest (reverse dired-subdir-alist)) elt) - (while rest - (setq elt (car rest) - rest (cdr rest)) - (if (dired-in-this-tree (directory-file-name (car elt)) dir) - (setq rest nil - pos (dired-goto-subdir (car elt)))))) - (if pos - (goto-char pos) - (error "At the bottom")))) - -;;; hiding - -(defun dired-subdir-hidden-p (dir) - (and selective-display - (save-excursion - (dired-goto-subdir dir) - (looking-at "\r")))) - -(defun dired-unhide-subdir () - (let (buffer-read-only) - (subst-char-in-region (dired-subdir-min) (dired-subdir-max) ?\r ?\n))) - -(defun dired-hide-check () - (or selective-display - (error "selective-display must be t for subdir hiding to work!"))) - -(defun dired-hide-subdir (arg) - "Hide or unhide the current subdirectory and move to next directory. -Optional prefix arg is a repeat factor. -Use \\[dired-hide-all] to (un)hide all directories." - (interactive "p") - (dired-hide-check) - (while (>= (setq arg (1- arg)) 0) - (let* ((cur-dir (dired-current-directory)) - (hidden-p (dired-subdir-hidden-p cur-dir)) - (elt (assoc cur-dir dired-subdir-alist)) - (end-pos (1- (dired-get-subdir-max elt))) - buffer-read-only) - ;; keep header line visible, hide rest - (goto-char (dired-get-subdir-min elt)) - (skip-chars-forward "^\n\r") - (if hidden-p - (subst-char-in-region (point) end-pos ?\r ?\n) - (subst-char-in-region (point) end-pos ?\n ?\r))) - (dired-next-subdir 1 t))) - -(defun dired-hide-all (arg) - "Hide all subdirectories, leaving only their header lines. -If there is already something hidden, make everything visible again. -Use \\[dired-hide-subdir] to (un)hide a particular subdirectory." - (interactive "P") - (dired-hide-check) - (let (buffer-read-only) - (if (save-excursion - (goto-char (point-min)) - (search-forward "\r" nil t)) - ;; unhide - bombs on \r in filenames - (subst-char-in-region (point-min) (point-max) ?\r ?\n) - ;; hide - (let ((pos (point-max)) ; pos of end of last directory - (alist dired-subdir-alist)) - (while alist ; while there are dirs before pos - (subst-char-in-region (dired-get-subdir-min (car alist)) ; pos of prev dir - (save-excursion - (goto-char pos) ; current dir - ;; we're somewhere on current dir's line - (forward-line -1) - (point)) - ?\n ?\r) - (setq pos (dired-get-subdir-min (car alist))) ; prev dir gets current dir - (setq alist (cdr alist))))))) - - -;; This function is the heart of tree dired. -;; It is called for each retrieved filename. -;; It could stand to be faster, though it's mostly function call -;; overhead. Avoiding to funcall seems to save about 10% in -;; dired-get-filename. Make it a defsubst? -(defun dired-current-directory (&optional localp) - "Return the name of the subdirectory to which this line belongs. -This returns a string with trailing slash, like `default-directory'. -Optional argument means return a file name relative to `default-directory'." - (let ((here (point)) - (alist (or dired-subdir-alist - ;; probably because called in a non-dired buffer - (error "No subdir-alist in %s" (current-buffer)))) - elt dir) - (while alist - (setq elt (car alist) - dir (car elt) - ;; use `<=' (not `<') as subdir line is part of subdir - alist (if (<= (dired-get-subdir-min elt) here) - nil ; found - (cdr alist)))) - (if localp - (dired-make-relative dir default-directory) - dir))) - -;; Subdirs start at the beginning of their header lines and end just -;; before the beginning of the next header line (or end of buffer). - -(defun dired-subdir-min () - (save-excursion - (if (not (dired-prev-subdir 0 t t)) - (error "Not in a subdir!") - (point)))) - -(defun dired-subdir-max () - (save-excursion - (if (not (dired-next-subdir 1 t t)) - (point-max) - (point)))) - -(defun dired-kill-line-or-subdir (&optional arg) - "Kill this line (but not this file). -Optional prefix argument is a repeat factor. -If file is displayed as in situ subdir, kill that as well. -If on a subdir headerline, kill whole subdir." - (interactive "p") - (if (dired-get-subdir) - (dired-kill-subdir) - (dired-kill-line arg))) - -(defun dired-kill-line (&optional arg) - (interactive "P") - (setq arg (prefix-numeric-value arg)) - (let (buffer-read-only file) - (while (/= 0 arg) - (setq file (dired-get-filename nil t)) - (if (not file) - (error "Can only kill file lines.") - (save-excursion (and file - (dired-goto-subdir file) - (dired-kill-subdir))) - (delete-region (progn (beginning-of-line) (point)) - (progn (forward-line 1) (point))) - (if (> arg 0) - (setq arg (1- arg)) - (setq arg (1+ arg)) - (forward-line -1)))) - (dired-move-to-filename))) - -(defun dired-kill-subdir (&optional remember-marks) - "Remove all lines of current subdirectory. -Lower levels are unaffected." - ;; With optional REMEMBER-MARKS, return a mark-alist. - (interactive) - (let ((beg (dired-subdir-min)) - (end (dired-subdir-max)) - buffer-read-only cur-dir) - (setq cur-dir (dired-current-directory)) - (if (equal cur-dir default-directory) - (error "Attempt to kill top level directory")) - (prog1 - (if remember-marks (dired-remember-marks beg end)) - (delete-region beg end) - (if (eobp) ; don't leave final blank line - (delete-char -1)) - (dired-unsubdir cur-dir)))) - -(defun dired-do-kill (&optional arg fmt) - "Kill all marked lines (not files). -With a prefix arg, kill all lines not marked or flagged." - ;; Returns count of killed lines. FMT="" suppresses message. - (interactive "P") - (save-excursion - (goto-char (point-min)) - (let (buffer-read-only (count 0)) - (if (not arg) ; kill marked lines - (let ((regexp (dired-marker-regexp))) - (while (and (not (eobp)) - (re-search-forward regexp nil t)) - (setq count (1+ count)) - (delete-region (progn (beginning-of-line) (point)) - (progn (forward-line 1) (point))))) - ;; else kill unmarked lines - (while (not (eobp)) - (if (or (dired-between-files) - (not (looking-at "^ "))) - (forward-line 1) - (setq count (1+ count)) - (delete-region (point) (save-excursion - (forward-line 1) - (point)))))) - (or (equal "" fmt) - (message (or fmt "Killed %d line%s.") count (dired-plural-s count))) - count))) - -(defun dired-do-redisplay (&optional arg test-for-subdir) - "Redisplay all marked (or next ARG) files. - -If on a subdir line, redisplay that subdirectory. In that case, -a prefix arg lets you edit the ls switches used for the new listing." - ;; Moves point if the next ARG files are redisplayed. - (interactive "P\np") - (if (and test-for-subdir (dired-get-subdir)) - (dired-insert-subdir - (dired-get-subdir) - (if arg (read-string "Switches for listing: " dired-actual-switches))) - (message "Redisplaying...") - ;; message instead of making dired-mark-map show-progress is much faster - (dired-mark-map (let ((fname (dired-get-filename))) - (message "Redisplaying... %s" fname) - (dired-update-file-line fname)) - arg) - (dired-move-to-filename) - (message "Redisplaying...done"))) - -(defun dired-mark-files-in-region (start end) - (let (buffer-read-only) - (if (> start end) - (error "start > end")) - (goto-char start) ; assumed at beginning of line - (while (< (point) end) - ;; Skip subdir line and following garbage like the `total' line: - (while (and (< (point) end) (dired-between-files)) - (forward-line 1)) - (if (and (not (looking-at dired-re-dot)) - (dired-get-filename nil t)) - (progn - (delete-char 1) - (insert dired-marker-char))) - (forward-line 1)))) - -(defun dired-mark-subdir-files () - "Mark all files except `.' and `..'." - (interactive "P") - (let ((p-min (dired-subdir-min))) - (dired-mark-files-in-region p-min (dired-subdir-max)))) - -(defun dired-mark-subdir-or-file (arg) - "Mark the current (or next ARG) files. -If on a subdir headerline, mark all its files except `.' and `..'. - -Use \\[dired-unflag-all-files] to remove all marks -and \\[dired-unmark-subdir-or-file] on a subdir to remove the marks in -this subdir." - (interactive "P") - (if (dired-get-subdir) - (save-excursion (dired-mark-subdir-files)) - (dired-mark-file (prefix-numeric-value arg)))) - -(defun dired-unmark-subdir-or-file (arg) - "Unmark the current (or next ARG) files. -If looking at a subdir, unmark all its files except `.' and `..'." - (interactive "P") - (let ((dired-marker-char ?\040)) - (dired-mark-subdir-or-file arg))) - -;;; 5K -;;;###begin dired-ins.el - -(defun dired-maybe-insert-subdir (dirname &optional - switches no-error-if-not-dir-p) - "Insert this subdirectory into the same dired buffer. -If it is already present, just move to it (type \\[dired-do-redisplay] to refresh), - else inserts it at its natural place (as ls -lR would have done). -With a prefix arg, you may edit the ls switches used for this listing. - You can add `R' to the switches to expand the whole tree starting at - this subdirectory. -This function takes some pains to conform to ls -lR output." - (interactive - (list (dired-get-filename) - (if current-prefix-arg - (read-string "Switches for listing: " dired-actual-switches)))) - (let ((opoint (point))) - ;; We don't need a marker for opoint as the subdir is always - ;; inserted *after* opoint. - (setq dirname (file-name-as-directory dirname)) - (or (and (not switches) - (dired-goto-subdir dirname)) - (dired-insert-subdir dirname switches no-error-if-not-dir-p)) - ;; Push mark so that it's easy to find back. Do this after the - ;; insert message so that the user sees the `Mark set' message. - (push-mark opoint))) - -(defun dired-insert-subdir (dirname &optional switches no-error-if-not-dir-p) - "Insert this subdirectory into the same dired buffer. -If it is already present, overwrites previous entry, - else inserts it at its natural place (as ls -lR would have done). -With a prefix arg, you may edit the ls switches used for this listing. - You can add `R' to the switches to expand the whole tree starting at - this subdirectory. -This function takes some pains to conform to ls -lR output." - ;; NO-ERROR-IF-NOT-DIR-P needed for special filesystems like - ;; Prospero where dired-ls does the right thing, but - ;; file-directory-p has not been redefined. - (interactive - (list (dired-get-filename) - (if current-prefix-arg - (read-string "Switches for listing: " dired-actual-switches)))) - (setq dirname (file-name-as-directory (expand-file-name dirname))) - (dired-insert-subdir-validate dirname switches) - (or no-error-if-not-dir-p - (file-directory-p dirname) - (error "Attempt to insert a non-directory: %s" dirname)) - (let ((elt (assoc dirname dired-subdir-alist)) - switches-have-R mark-alist case-fold-search buffer-read-only) - ;; case-fold-search is nil now, so we can test for capital `R': - (if (setq switches-have-R (and switches (string-match "R" switches))) - ;; avoid duplicated subdirs - (setq mark-alist (dired-kill-tree dirname t))) - (if elt - ;; If subdir is already present, remove it and remember its marks - (setq mark-alist (nconc (dired-insert-subdir-del elt) mark-alist)) - (dired-insert-subdir-newpos dirname)) ; else compute new position - (dired-insert-subdir-doupdate - dirname elt (dired-insert-subdir-doinsert dirname switches)) - (if switches-have-R (dired-build-subdir-alist)) - (dired-initial-position dirname) - (save-excursion (dired-mark-remembered mark-alist)))) - -;; This is a separate function for dired-vms. -(defun dired-insert-subdir-validate (dirname &optional switches) - ;; Check that it is valid to insert DIRNAME with SWITCHES. - ;; Signal an error if invalid (e.g. user typed `i' on `..'). - (or (dired-in-this-tree dirname default-directory) - (error "%s: not in this directory tree" dirname)) - (if switches - (let (case-fold-search) - (mapcar - (function - (lambda (x) - (or (eq (null (string-match x switches)) - (null (string-match x dired-actual-switches))) - (error "Can't have dirs with and without -%s switches together" - x)))) - ;; all switches that make a difference to dired-get-filename: - '("F" "b"))))) - -(defun dired-kill-tree (dirname &optional remember-marks) - ;;"Kill all proper subdirs of DIRNAME, excluding DIRNAME itself. - ;; With optional arg REMEMBER-MARKS, return an alist of marked files." - (interactive "DKill tree below directory: ") - (let ((s-alist dired-subdir-alist) dir m-alist) - (while s-alist - (setq dir (car (car s-alist)) - s-alist (cdr s-alist)) - (if (and (not (string-equal dir dirname)) - (dired-in-this-tree dir dirname) - (dired-goto-subdir dir)) - (setq m-alist (nconc (dired-kill-subdir remember-marks) m-alist)))) - m-alist)) - -(defun dired-insert-subdir-newpos (new-dir) - ;; Find pos for new subdir, according to tree order. - (let ((alist dired-subdir-alist) elt dir pos new-pos) - (while alist - (setq elt (car alist) - alist (cdr alist) - dir (car elt) - pos (dired-get-subdir-min elt)) - (if (dired-tree-lessp dir new-dir) - ;; Insert NEW-DIR after DIR - (setq new-pos (dired-get-subdir-max elt) - alist nil))) - (goto-char new-pos)) - ;; want a separating newline between subdirs - (or (eobp) - (forward-line -1)) - (insert "\n") - (point)) - -(defun dired-insert-subdir-del (element) - ;; Erase an already present subdir (given by ELEMENT) from buffer. - ;; Move to that buffer position. Return a mark-alist. - (let ((begin-marker (dired-get-subdir-min element))) - (goto-char begin-marker) - ;; Are at beginning of subdir (and inside it!). Now determine its end: - (goto-char (dired-subdir-max)) - (or (eobp);; want a separating newline _between_ subdirs: - (forward-char -1)) - (prog1 - (dired-remember-marks begin-marker (point)) - (delete-region begin-marker (point))))) - -(defun dired-insert-subdir-doinsert (dirname switches) - ;; Insert ls output after point and put point on the correct - ;; position for the subdir alist. - ;; Return the boundary of the inserted text (as list of BEG and END). - (let ((begin (point)) end) - (message "Reading directory %s..." dirname) - (let ((dired-actual-switches - (or switches - (dired-replace-in-string "R" "" dired-actual-switches)))) - (if (equal dirname (car (car (reverse dired-subdir-alist)))) - ;; top level directory may contain wildcards: - (dired-readin-insert dired-directory) - (dired-ls dirname dired-actual-switches nil t))) - (message "Reading directory %s...done" dirname) - (setq end (point-marker)) - (dired-indent-rigidly begin end 2) - ;; call dired-insert-headerline afterwards, as under VMS dired-ls - ;; does insert the headerline itself and the insert function just - ;; moves point. - ;; Need a marker for END as this inserts text. - (goto-char begin) - (dired-insert-headerline dirname) - ;; point is now like in dired-build-subdir-alist - (prog1 - (list begin (marker-position end)) - (set-marker end nil)))) - -(defun dired-insert-subdir-doupdate (dirname elt beg-end) - ;; Point is at the correct subdir alist position for ELT, - ;; BEG-END is the subdir-region (as list of begin and end). - (if elt ; subdir was already present - ;; update its position (should actually be unchanged) - (set-marker (dired-get-subdir-min elt) (point-marker)) - (dired-alist-add dirname (point-marker))) - ;; The hook may depend on the subdir-alist containing the just - ;; inserted subdir, so run it after dired-alist-add: - (if dired-after-readin-hook - (save-excursion - (let ((begin (nth 0 beg-end)) - (end (nth 1 beg-end))) - (goto-char begin) - (save-restriction - (narrow-to-region begin end) - ;; hook may add or delete lines, but the subdir boundary - ;; marker floats - (run-hooks 'dired-after-readin-hook)))))) - -(defun dired-tree-lessp (dir1 dir2) - ;; Lexicographic order on pathname components, like `ls -lR': - ;; DIR1 < DIR2 iff DIR1 comes *before* DIR2 in an `ls -lR' listing, - ;; i.e., iff DIR1 is a (grand)parent dir of DIR2, - ;; or DIR1 and DIR2 are in the same parentdir and their last - ;; components are string-lessp. - ;; Thus ("/usr/" "/usr/bin") and ("/usr/a/" "/usr/b/") are tree-lessp. - ;; string-lessp could arguably be replaced by file-newer-than-file-p - ;; if dired-actual-switches contained `t'. - (setq dir1 (file-name-as-directory dir1) - dir2 (file-name-as-directory dir2)) - (let ((components-1 (dired-split "/" dir1)) - (components-2 (dired-split "/" dir2))) - (while (and components-1 - components-2 - (equal (car components-1) (car components-2))) - (setq components-1 (cdr components-1) - components-2 (cdr components-2))) - (let ((c1 (car components-1)) - (c2 (car components-2))) - - (cond ((and c1 c2) - (string-lessp c1 c2)) - ((and (null c1) (null c2)) - nil) ; they are equal, not lessp - ((null c1) ; c2 is a subdir of c1: c1c2 - nil) - (t (error "This can't happen")))))) - -;; There should be a builtin split function - inverse to mapconcat. -(defun dired-split (pat str &optional limit) - "Splitting on regexp PAT, turn string STR into a list of substrings. -Optional third arg LIMIT (>= 1) is a limit to the length of the -resulting list. -Thus, if SEP is a regexp that only matches itself, - - (mapconcat 'identity (dired-split SEP STRING) SEP) - -is always equal to STRING." - (let* ((start (string-match pat str)) - (result (list (substring str 0 start))) - (count 1) - (end (if start (match-end 0)))) - (if end ; else nothing left - (while (and (or (not (integerp limit)) - (< count limit)) - (string-match pat str end)) - (setq start (match-beginning 0) - count (1+ count) - result (cons (substring str end start) result) - end (match-end 0) - start end) - )) - (if (and (or (not (integerp limit)) - (< count limit)) - end) ; else nothing left - (setq result - (cons (substring str end) result))) - (nreverse result))) - -(defun dired-indent-rigidly (start end arg) - ;; like indent-rigidly but has more efficient behavior w.r.t. the - ;; after-change-functions (i.e., font-lock-mode.) - (save-excursion - (let ((after-change-functions nil) - (after-change-function nil)) - (goto-char end) - (indent-rigidly start end arg)) - ;; deletion - (run-hook-with-args 'after-change-functions start start (- end start)) - (run-hook-with-args 'after-change-function start start (- end start)) - ;; insertion - (run-hook-with-args 'after-change-functions start (point) 0) - (run-hook-with-args 'after-change-function start (point) 0) - )) - -(if (string-lessp emacs-version "19") - (fset 'dired-indent-rigidly (symbol-function 'indent-rigidly))) - -;;;###end dired-ins.el - - -;;; Sorting - -;; Most ls can only sort by name or by date (with -t), nothing else. -;; GNU ls sorts on size with -S, on extension with -X, and unsorted with -U. -;; So anything that does not contain these is sort "by name". - -(defvar dired-ls-sorting-switches "SXU" - "String of ls switches (single letters) except `t' that influence sorting.") - -(defvar dired-sort-by-date-regexp - (concat "^-[^" dired-ls-sorting-switches - "]*t[^" dired-ls-sorting-switches "]*$") - "Regexp recognized by dired to set `by date' mode.") - -(defvar dired-sort-by-name-regexp - (concat "^-[^t" dired-ls-sorting-switches "]+$") - "Regexp recognized by dired to set `by name' mode.") - -(defvar dired-sort-mode nil - "Whether Dired sorts by name, date etc. (buffer-local).") -;; This is nil outside dired buffers so it can be used in the modeline - -(defun dired-sort-set-modeline () - ;; Set modeline display according to dired-actual-switches. - ;; Modeline display of "by name" or "by date" guarantees the user a - ;; match with the corresponding regexps. Non-matching switches are - ;; shown literally. - (setq dired-sort-mode - (let (case-fold-search) - (cond ((string-match dired-sort-by-name-regexp dired-actual-switches) - " by name") - ((string-match dired-sort-by-date-regexp dired-actual-switches) - " by date") - (t - (concat " " dired-actual-switches))))) - ;; update mode line: - (set-buffer-modified-p (buffer-modified-p))) - -(defun dired-sort-toggle-or-edit (&optional arg) - "Toggle between sort by date/name and refresh the dired buffer. -With a prefix argument you can edit the current listing switches instead." - (interactive "P") - (if arg - (dired-sort-other - (read-string "ls switches (must contain -l): " dired-actual-switches)) - (dired-sort-toggle))) - -(defun dired-sort-toggle () - ;; Toggle between sort by date/name. Reverts the buffer. - (setq dired-actual-switches - (let (case-fold-search) - (concat - "-l" - (dired-replace-in-string (concat "[---lt" - dired-ls-sorting-switches "]") - "" - dired-actual-switches) - (if (string-match (concat "[t" dired-ls-sorting-switches "]") - dired-actual-switches) - "" - "t")))) - (dired-sort-set-modeline) - (revert-buffer)) - -(defun dired-sort-other (switches &optional no-revert) - ;; Specify new ls SWITCHES for current dired buffer. Values matching - ;; `dired-sort-by-date-regexp' or `dired-sort-by-name-regexp' set the - ;; minor mode accordingly, others appear literally in the mode line. - ;; With optional second arg NO-REVERT, don't refresh the listing afterwards. - (setq dired-actual-switches switches) - (dired-sort-set-modeline) - (or no-revert (revert-buffer))) - -(if (eq system-type 'vax-vms) - (load "dired-vms")) - -(if (string-match "XEmacs" emacs-version) - (load "dired-xemacs-menu")) - -(run-hooks 'dired-load-hook) ; for your customizations diff -r b88636d63495 -r 8fc7fe29b841 lisp/dired/find-dired.el --- a/lisp/dired/find-dired.el Mon Aug 13 08:50:06 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,259 +0,0 @@ -;;; find-dired.el --- run a `find' command and dired the output - -;;; Copyright (C) 1992, 1994, 1995 Free Software Foundation, Inc. - -;; Author: Roland McGrath , -;; Sebastian Kremer -;; Keywords: unix - -;; This file is part of XEmacs. - -;; XEmacs 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 2, or (at your option) -;; any later version. - -;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Synched up with: FSF 19.30. - -;;; Commentary: - -;; To bind the following functionality to a key, put, e.g.: -;; -;; (global-set-key "\C-cf" 'find-dired) -;; (global-set-key "\C-cn" 'find-name-dired) -;; (global-set-key "\C-cl" 'find-grep-dired) -;; -;; in your ~/.emacs. - -;;; Code: - -(require 'dired) - -;; find's -ls corresponds to these switches. -;; Note -b, at least GNU find quotes spaces etc. in filenames -;;;###autoload -(defvar find-ls-option (purecopy - ;; XEmacs: add purecopy - (if (eq system-type 'berkeley-unix) '("-ls" . "-gilsb") - '("-exec ls -ld {} \\;" . "-ld"))) - "*Description of the option to `find' to produce an `ls -l'-type listing. -This is a cons of two strings (FIND-OPTION . LS-SWITCHES). FIND-OPTION -gives the option (or options) to `find' that produce the desired output. -LS-SWITCHES is a list of `ls' switches to tell dired how to parse the output.") - -;;;###autoload -(defvar find-grep-options (purecopy - ;; XEmacs: add purecopy - (if (eq system-type 'berkeley-unix) "-s" "-q")) - "*Option to grep to be as silent as possible. -On Berkeley systems, this is `-s'; on Posix, and with GNU grep, `-q' does it. -On other systems, the closest you can come is to use `-l'.") - -;; XEmacs additions: next two variables. - -;;;###autoload -(defvar find-dired-multiple-buffers nil - "*If non-nil, generates a new buffer for each find") - -(defvar find-dired-dir-history nil - "History of directories used by find-dired") - -(defvar find-args nil - "Last arguments given to `find' by \\[find-dired].") - -(defvar find-args-history nil - "Last arguments given to `find' by \\[find-dired].") - -;; XEmacs: various changes in next function. - -;;;###autoload -(defun find-dired (dir args) - "Run `find' and go into dired-mode on a buffer of the output. -The command run (after changing into DIR) is - - find . \\( ARGS \\) -ls" - (interactive (list (read-file-name "Run find in directory: " - nil "" t nil 'find-dired-dir-history) - (if (featurep 'gmhist) - (read-with-history-in 'find-args-history - "Run find (with args): ") - (read-string "Run find (with args): " - (or (and (fboundp 'symbol-near-point) - (symbol-near-point)) - (car find-args-history)) - 'find-args-history)))) - ;; Expand DIR ("" means default-directory), and make sure it has a - ;; trailing slash. - (setq dir (file-name-as-directory (expand-file-name dir))) - ;; Check that it's really a directory. - (or (file-directory-p dir) - (error "find-dired needs a directory: %s" dir)) - (switch-to-buffer-other-window (if find-dired-multiple-buffers - (generate-new-buffer (concat "*Find-in-" - (file-name-nondirectory (directory-file-name dir)) - "/..*")) - (get-buffer-create "*Find*"))) - (widen) - (kill-all-local-variables) - (setq buffer-read-only nil) - (erase-buffer) - (setq default-directory dir - find-args args ; save for next interactive call - args (concat "find . " - (if (string= args "") - "" - (concat "\\( " args " \\) ")) - (car find-ls-option))) - ;; The next statement will bomb in classic dired (no optional arg allowed) - (dired-mode dir (cdr find-ls-option)) - ;; This really should rerun the find command, but I don't - ;; have time for that. - (let ((keymap (make-sparse-keymap))) - (set-keymap-parents keymap (list (current-local-map))) - (define-key keymap "g" 'undefined) - (use-local-map keymap)) - ;; Set subdir-alist so that Tree Dired will work: - (if (fboundp 'dired-simple-subdir-alist) - ;; will work even with nested dired format (dired-nstd.el,v 1.15 - ;; and later) - (dired-simple-subdir-alist) - ;; else we have an ancient tree dired (or classic dired, where - ;; this does no harm) - (set (make-local-variable 'dired-subdir-alist) - (list (cons default-directory (point-min-marker))))) - (setq buffer-read-only nil) - ;; Subdir headlerline must come first because the first marker in - ;; subdir-alist points there. - (insert " " dir ":\n") - ;; Make second line a ``find'' line in analogy to the ``total'' or - ;; ``wildcard'' line. - (insert " " args "\n") - ;; Start the find process - (message "Searching .... (but you can continue other work)") - (sit-for 0) - (let ((proc (start-process-shell-command "find" (current-buffer) args))) - (set-process-filter proc (function find-dired-filter)) - (set-process-sentinel proc (function find-dired-sentinel)) - ;; Initialize the process marker; it is used by the filter. - (move-marker (process-mark proc) 1 (current-buffer))) - (setq modeline-process '(": %s"))) - -;;;###autoload -(defun find-name-dired (dir pattern) - "Search DIR recursively for files matching the globbing pattern PATTERN, -and run dired on those files. -PATTERN is a shell wildcard (not an Emacs regexp) and need not be quoted. -The command run (after changing into DIR) is - - find . -name 'PATTERN' -ls" - (interactive - "DFind-name (directory): \nsFind-name (filename wildcard): ") - (find-dired dir (concat "-name '" pattern "'"))) - -;; This functionality suggested by -;; From: oblanc@watcgl.waterloo.edu (Olivier Blanc) -;; Subject: find-dired, lookfor-dired -;; Date: 10 May 91 17:50:00 GMT -;; Organization: University of Waterloo - -(defalias 'lookfor-dired 'find-grep-dired) - -;; XEmacs addition -(defvar find-grep-dired-history nil - "history for find-grep-dired input") - -;;;###autoload -(defun find-grep-dired (dir args) - "Find files in DIR containing a regexp ARG and start Dired on output. -The command run (after changing into DIR) is - - find . -type f -exec test -r {} \\\; -exec egrep -s ARG {} \\\; -ls - -Thus ARG can also contain additional grep options." - (interactive - ;; XEmacs improvements here. - (list (read-string "Find-grep (directory): " - default-directory 'find-dired-dir-history) - (read-string "Find-grep (grep args): " (and (fboundp 'symbol-near-point) - (symbol-near-point)) - 'find-grep-dired-history))) - ;; find -exec doesn't allow shell i/o redirections in the command, - ;; or we could use `grep -l >/dev/null' - (find-dired dir - ;; XEmacs improvements here. - (concat "-type f -exec test -r {} \\\; -exec egrep " - find-grep-options " " args " {} \\\; "))) - -(defun find-dired-filter (proc string) - ;; Filter for \\[find-dired] processes. - (let ((buf (process-buffer proc))) - (if (buffer-name buf) ; not killed? - (save-excursion - (set-buffer buf) - (save-restriction - (widen) - (save-excursion - (let ((buffer-read-only nil) - (end (point-max))) - (goto-char end) - (insert string) - (goto-char end) - (or (looking-at "^") - (forward-line 1)) - (while (looking-at "^") - (insert " ") - (forward-line 1)) - ;; Convert ` ./FILE' to ` FILE' - ;; This would lose if the current chunk of output - ;; starts or ends within the ` ./', so back up a bit: - (goto-char (- end 3)) ; no error if < 0 - (while (search-forward " ./" nil t) - (delete-region (point) (- (point) 2))) - ;; Find all the complete lines in the unprocessed - ;; output and process it to add text properties. - (goto-char end) - (if (search-backward "\n" (process-mark proc) t) - (progn - (dired-insert-set-properties (process-mark proc) - (1+ (point))) - (move-marker (process-mark proc) (1+ (point))))) - )))) - ;; The buffer has been killed. - (delete-process proc)))) - -(defun find-dired-sentinel (proc state) - ;; Sentinel for \\[find-dired] processes. - (let ((buf (process-buffer proc))) - (if (buffer-name buf) - (save-excursion - (set-buffer buf) - (let ((buffer-read-only nil)) - (save-excursion - (goto-char (point-max)) - (insert "\nfind " state) - (forward-char -1) ;Back up before \n at end of STATE. - (insert " at " (substring (current-time-string) 0 19)) - (forward-char 1) - (setq modeline-process ;; XEmacs: newer spelling - (concat ":" - (symbol-name (process-status proc)))) - ;; Since the buffer and mode line will show that the - ;; process is dead, we can delete it now. Otherwise it - ;; will stay around until M-x list-processes. - (delete-process proc) - (redraw-modeline))) ;; XEmacs function - (message "find-dired %s finished." (current-buffer)))))) - -(provide 'find-dired) - -;;; find-dired.el ends here diff -r b88636d63495 -r 8fc7fe29b841 lisp/dired/gmhist-app.el --- a/lisp/dired/gmhist-app.el Mon Aug 13 08:50:06 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,237 +0,0 @@ -;;;; gmhist-app.el - applications of gmhist for some standard commands -;;;; Id: gmhist-app.el,v 4.16 1992/02/26 14:32:27 sk RelBeta - -;;;; The following commands are redefined to get history: -;;;; keep-lines -;;;; flush-lines -;;;; how-many -;;;; occur -;;;; => regexp-history -;;;; grep => grep-history -;;;; shell-command -;;;; shell-command-on-region -;;;; => shell-history -;;;; eval-expression => eval-expression-history -;;;; compile => compile-history - -;;;; You probably want to establish this key binding in your ~/.emacs, -;;;; it will make `M-x M-p' equivalent to `C-x ESC': - -;;;; (define-key esc-map "x" 'gmhist-execute-extended-command) -;;;; (define-key esc-map "X" 'execute-extended-command) ; save old M-x command - -;;;; The second line is to save the old M-x command under M-X, just in -;;;; case anything goes wrong. - -(require 'gmhist) - -;;; gmhist modifications for replace.el (preloaded). - -(mapcar '(lambda (x) - (gmhist-make-magic x 'regexp-history)) - (if gmhist-emacs-19-p - '(keep-lines flush-lines how-many) - '(keep-lines flush-lines how-many occur))) - - -(if gmhist-emacs-19-p - (progn - (gmhist-replace-spec - 'occur - '(gmhist-interactive "sList lines matching regexp: \nP" - 'regexp-history)) - (gmhist-replace-spec - 'grep - '(list (read-with-history-in - 'grep-history ; or 'regexp-history? - (concat "Run " - (substring grep-command 0 - (string-match "[\t ]+" grep-command)) - " (with args): ") - )))) - ;; else - (gmhist-make-magic 'grep 'grep-history)) - -;;; gmhist modification for simple.el (is preloaded) - -(if gmhist-emacs-19-p - (progn - (gmhist-replace-spec - 'shell-command - '(gmhist-interactive "sShell command: \nP" 'shell-history)) - (gmhist-replace-spec - 'shell-command-on-region - '(gmhist-interactive "r\nsShell command on region: \nP\np" - 'shell-history)) - ) - (gmhist-make-magic 'shell-command 'shell-history) - (gmhist-make-magic 'shell-command-on-region 'shell-history) - ) -(gmhist-make-magic 'eval-expression) - -;;; gmhist modification for compile.el (autoloaded) - -;; Often people make the variable compile-command buffer-local. -;; -;; Instead of compile-command, you now have compile-history, which is -;; initialized to -;; -;; (list compile-command) -;; -;; but afterwards gmhist ignores compile-command. So your old file -;; local variable sections or mode hooks will cease to work. -;; -;; Here is a solution: Make compile-history instead of compile-command -;; buffer-local (in a local var section of a file or in a hook, using -;; function make-local-variable). If you only sometimes have gmhist -;; loaded, make both variables buffer-local. - -;; (gmhist-make-magic 'compile 'compile-history) won't work because -;; the interactive spec is not a string. Instead, hand-craft it: - -(gmhist-replace-spec - 'compile - '(list - (read-with-history-in 'compile-history "Compile command: "))) -;; instead of... -;;(put 'compile-history 'default compile-command) -;; ... do the following -(put 'compile-history 'backup t) ; requires at least gmhist 3.22 -(put 'compile-history 'no-default t) -(put 'compile-history 'initial-hist (list compile-command)) -(put 'compile-history 'cursor-end t) - -;;; gmhist modifications for tags.el (is autoloaded) -;;; The distributed version of tags.el does not support a load hook. -;;; Add the statement -;;; (run-hooks 'tags-load-hook) -;;; at the very end of tags.el. - -(defvar tags-history nil - "History of tags.") - -(setq tags-load-hook - ;; redefine find-tag-tag upon loading of tags.el - '(lambda () - (fset 'find-tag-tag 'gmhist-find-tag-tag))) - -(defun gmhist-find-tag-tag (string) - ;; compare these two lines to the original definition... - (let ((defalt (find-tag-default))) - (if (and defalt - (string-match "[:']$" defalt)) - (setq defalt (substring defalt 0 -1))) - (put 'tags-history 'default defalt) - ;; so that M-p lets you edit the default - (setq tags-history (cons defalt tags-history)) - (list (read-with-history-in 'tags-history string)))) - -;; Gmhist version of M-x - -;; Make M-x have history (it actually has one already, but only through -;; C-x ESC (repeat-complex-command), not via M-p within the M-x -;; prompt.) - -;; execute-extended-command must be rewritten if minibuffer history is -;; implemented in C. Probably call-interactively too. - -(defvar gmhist-execute-extended-command-map (copy-keymap gmhist-completion-map) - "Keymap used inside `gmhist-execute-extended-command'.") - -;; We have to define custom version of RET and SPC (actually TAB as -;; well) since they behave completely different immediately after M-x -;; (reading a command) or after the history postion has been changed -;; to a non-zero value (editing an s-expr, an old command with its -;; arguments). - -(define-key gmhist-execute-extended-command-map - "\r" 'gmhist-execute-extended-command-exit) - -(define-key gmhist-execute-extended-command-map - " " 'gmhist-execute-extended-command-space) - -(defun gmhist-execute-extended-command-exit () - "Maybe complete the minibuffer contents, and exit. -Completes commands before exiting, but leaves command history items alone." - ;; Completion (over the set of commands) only occurs if - ;; minibufer-history-position is 0, meaning we are editing a command - ;; name. Non-zero history positions mean we are editing an sexp - ;; resulting from an earlier command and its argument, and - ;; completion is not meaningful. - (interactive) - (if (equal 0 minibuffer-history-position) - ;; Rather than calling minibuffer-complete-and-exit directly, - ;; account for the possibility that e.g. a partial completion - ;; has been loaded and changed the bindings - (funcall (lookup-key minibuffer-local-must-match-map "\C-m")) - (exit-minibuffer))) - -(defun gmhist-execute-extended-command-space () - (interactive) - (if (equal 0 minibuffer-history-position) - (funcall (lookup-key minibuffer-local-must-match-map " ")) - (insert " "))) - -(defun gmhist-execute-extended-command () ; M-x - "Read function name, then read its arguments and call it. -You can use all gmhist commands (see variable gmhist-completion-map), -especially \\\\[gmhist-previous] to backup in command-history." - (interactive) - ;; We don't want '(gmhist-execute-extended-command (quote COMMAND)) - ;; on the command history, since this is ugly, and COMMAND itself is - ;; always right next to it. This is so because - ;; gmhist-execute-extended-command is not a builtin like - ;; execute-extended-command and thus is itself entered on the - ;; command-history. - (if (assq 'gmhist-execute-extended-command command-history) - (let ((list command-history) - elt) - (while list - (setq elt (car list)) - (if (eq (car-safe elt) 'gmhist-execute-extended-command) - ;; destructively remove this elt from command-history - (progn - (setcar list nil) - ;; and exit the loop since if we're doing this each time - ;; there shouldn't be more than one such elt - the one - ;; from the last time - (setq list nil)) - (setq list (cdr list)))) - (setq command-history (delq nil command-history)))) - (let (cmd) - (let ((minibuffer-completion-confirm nil) - ;; We only need read-with-history-in here to make M-p available, - ;; the new command will be recorded below - (minibuffer-history-read-only t)) - (put 'command-history 'cursor-end t) - ;; command-history is maintained automatically: - (put 'command-history 'hist-ignore ".*") - (put 'command-history 'no-default t) - (put 'command-history 'completion-table obarray) - (put 'command-history 'hist-map gmhist-execute-extended-command-map) - (put 'command-history 'completion-predicate 'commandp) - (put 'command-history 'backup nil) - (setq cmd - (read-with-history-in - 'command-history - (if current-prefix-arg - (format "%s M-x " - current-prefix-arg - ;; this is not exactly like the original M-x - ;; but the following doesn't seem to work right -; (cond ((eq '(4) current-prefix-arg) -; "C-u") -; (t -; (prefix-numeric-value current-prefix-arg))) - ) - "M-x ") - nil t))) - (if (commandp cmd) - (let ((prefix-arg current-prefix-arg)) - (setq this-command cmd) - (command-execute cmd t)) - ;; else it is a lisp form from the history of old commands - (prog1 - (eval cmd) - (setq command-history (cons cmd command-history)))))) - diff -r b88636d63495 -r 8fc7fe29b841 lisp/dired/gmhist-cmp.el --- a/lisp/dired/gmhist-cmp.el Mon Aug 13 08:50:06 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,33 +0,0 @@ -;; gmhist-cmp.el - -;; Gmhist support for completer.el by ccm@CS.CMU.EDU (Christopher McConnell). -;; This is known to work with version 3.01 of completer.el. - -;; You only need this when you don't like it that TAB and SPC complete -;; partially and rather want M-TAB and M-SPC do that, leaving normal -;; completion on TAB and SPC. - -;; Do partial filename completion only with M-SPC and M-TAB (SPC and -;; TAB do usual completion) within gmhist's version of read-file-name. - -(require 'completer) ; let it mung the keymaps - -;; Establish a filename key map separate from the other gmhist maps: -(setq completer-complete-filenames t - gmhist-filename-completion-map 'gmhist-completer-filename-completion-map - gmhist-filename-must-match-map 'gmhist-completer-filename-must-match-map) - -;; Fill the map with completer and gmhist key bindings: -(setq gmhist-completer-filename-must-match-map - (copy-keymap minibuffer-local-must-match-map) - gmhist-completer-filename-completion-map - (copy-keymap minibuffer-local-completion-map)) -(mapcar - '(lambda (map) - (gmhist-define-keys map) - (define-key map "\e\t" 'completer-complete) - (define-key map "\e " 'completer-word) - (define-key map "\t" 'minibuffer-complete) - (define-key map " " 'minibuffer-complete-word)) - (list gmhist-completer-filename-completion-map - gmhist-completer-filename-must-match-map)) diff -r b88636d63495 -r 8fc7fe29b841 lisp/dired/gmhist-mh.el --- a/lisp/dired/gmhist-mh.el Mon Aug 13 08:50:06 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,354 +0,0 @@ -;;;; gmhist-mh.el - emulate proposed Emacs 19 builtin Minibuffer History -;;;; Id: gmhist-mh.el,v 4.8 1991/09/20 13:15:40 sk RelBeta - -;;;; This package redefines the functions -;;;; -;;;; read-string -;;;; completing-read -;;;; write-region -;;;; delete-file -;;;; read-buffer -;;;; read-file-name -;;;; switch-to-buffer -;;;; -;;;; to implement the variables -;;;; -;;;; minibuffer-history-symbol -;;;; file-history-symbol -;;;; buffer-history-symbol -;;;; buffer-history-lru-order -;;;; max-minibuffer-history-length -;;;; -;;;; and the hooks -;;;; -;;;; after-write-region-hook -;;;; after-delete-file-hook - -(require 'gmhist) -(provide 'gmhist-mh) - -(defvar max-minibuffer-history-length 'not-implemented) - -;;;; Redefining basic Emacs functions - -(defun gmhist-overwrite (fun) - ;; Overwrite FUN (a symbol, the name of a function) with gmhist-new-FUN. - ;; Save the old def of FUN in gmhist-old-FUN. - ;; Conventions: gmhist-FUN emulates FUN, but with history. - ;; gmhist-new-FUN may take additional care of the case - ;; that history is disabled before calling gmhist-FUN - ;; to do the real work. - (let* ((fun-name (symbol-name fun)) - (old-name (intern (concat "gmhist-old-" fun-name))) - (new-name (intern (concat "gmhist-new-" fun-name)))) - (or (fboundp old-name) - (fset old-name (symbol-function fun))) - (fset fun new-name))) - -;;; Minibuffer history (not specialized like file or buffer history) - -;;; Should perhaps modify minibuffer keymaps directly: -;;; minibuffer-local-completion-map -;;; minibuffer-local-map -;;; minibuffer-local-must-match-map -;;; minibuffer-local-ns-map - -(defun gmhist-new-read-string (gnrs-prompt &optional initial-input) - "Read a string from the minibuffer, prompting with string PROMPT. -If non-nil second arg INITIAL-INPUT is a string to insert before reading. -See also `minibuffer-history-symbol'." - (if minibuffer-history-symbol - (gmhist-read-from-minibuffer gnrs-prompt initial-input gmhist-map) - (gmhist-old-read-string gnrs-prompt initial-input))) - -(gmhist-overwrite 'read-string) - -(defun gmhist-new-completing-read - (gncr-prompt table &optional predicate mustmatch initial) - "Read a string in the minibuffer, with completion and history. -Args are PROMPT, TABLE, PREDICATE, REQUIRE-MATCH and INITIAL-INPUT. -PROMPT is a string to prompt with; normally it ends in a colon and a space. -TABLE is an alist whose elements' cars are strings, or an obarray (see - try-completion). -PREDICATE limits completion to a subset of TABLE see try-completion - for details. -If REQUIRE-MATCH is non-nil, the user is not allowed to exit unless - the input is (or completes to) an element of TABLE. - If it is also not t, Return does not exit if it does non-null completion. -If INITIAL-INPUT is non-nil, insert it in the minibuffer initially. -Case is ignored if ambient value of completion-ignore-case is non-nil. - -*** This is the gmhist version *** -See variable `minibuffer-history-symbol'." - (if minibuffer-history-symbol - (gmhist-completing-read gncr-prompt table predicate mustmatch initial) - (gmhist-old-completing-read gncr-prompt table predicate mustmatch initial))) - -(gmhist-overwrite 'completing-read) - -;;; File history - -(defvar file-history (get file-history-symbol 'initial-hist) - "Default history of file names read with read-file-name. -This symbol is the default value of file-history-symbol (q.v.).") - -(defvar insert-file-default nil - "*If non-nil, defaults for filenames will be inserted into the -minibuffer prompt. This has the advantage of putting the default onto -the file-history (which see).") - -(defun gmhist-new-read-file-name (gnrfn-prompt - &optional dir default mustmatch initial) - "Read file name, maintaining history in value of -file-history-symbol, prompting with PROMPT, completing in directory DIR. - -Value is not expanded! You must call expand-file-name yourself. - -Default name to third arg DEFAULT if user enters a null string. -\(If DEFAULT is omitted, the visited file name is used.) - -Fourth arg MUSTMATCH non-nil means require existing file's name. -Non-nil and non-t means also require confirmation after completion. - -Fifth arg INITIAL specifies text to start with. -DIR defaults to current buffer's default-directory. - -*** This is the gmhist version *** - -It differs from the original read-file-name in providing a -history of filenames in the variable whose name is the value of -file-history-symbol (usually 'file-history) (both of which see). - -INITIAL defaults to default-directory's value if -insert-default-directory is non-nil. Also, if insert-file-default is -non-nil, it inserts the DEFAULT string if no INITIAL is given, which -has the advantage of putting the default onto the file-history. -However, setting INITIAL to a string is a way for providing an -editable default, something not possible with (pre Emacs-19) -read-file-name. Setting INITIAL and insert-default-directory to nil -will yield a basename for the file, relative to default-directory. - -See function read-with-history-in for a list of properties you can put -on file-history-symbol." - (if (null file-history-symbol) - (gmhist-old-read-file-name gnrfn-prompt dir default mustmatch) - (gmhist-read-file-name gnrfn-prompt dir default mustmatch - (if (and insert-file-default - (not initial)) - default - initial)))) - -;; It is a shame that none of the standard hooks are defvar'd! -;; Also, the coexistence of `hooks' vs `hook' is annoying. -;; The singular seems to be the majority, so I'll use that. - -(defvar after-write-region-hook nil - "Run after the gmhist version of `write-region'. -The variables `start', `end', `filename', `append', `visit' are bound -around the call to the hook.") - -;; Don't use &rest args, as the hook may want to take advantage of our -;; arglist. -(defun gmhist-new-write-region (start end filename - &optional append visit) - "Write current region into specified file. -When called from a program, takes three arguments: -START, END and FILENAME. START and END are buffer positions. -Optional fourth argument APPEND if non-nil means - append to existing file contents (if any). -Optional fifth argument VISIT if t means - set last-save-file-modtime of buffer to this file's modtime - and mark buffer not modified. -If VISIT is neither t nor nil, it means do not print - the \"Wrote file\" message. - -*** This is the gmhist version *** -See variable `after-write-region-hook'." - (interactive "r\nFWrite region to file: ") - (prog1 - (gmhist-old-write-region start end filename append visit) - (condition-case err - ;; basic-save-buffer would assume an error to mean - ;; write-region failed - (run-hooks 'after-write-region-hook) - (error (message "Error in after-write-region-hook %s" err) - (sit-for 1))))) - -(defvar after-delete-file-hook nil - "Run after the gmhist version of `delete-file'. -The hook is run with `filename' bound to the filename.") - -(defun gmhist-new-delete-file (filename) - "Delete specified file. One argument, a file name string. -If file has multiple names, it continues to exist with the other names. - -*** This is the gmhist version *** -See variable `after-delete-file-hook'." - (interactive "fDelete file: ") - (prog1 - (gmhist-old-delete-file filename) - (condition-case err - ;; We don't want callers to assume an error in the hook to - ;; mean delete-file failed - or do we? - (run-hooks 'after-delete-file-hook) - (error (message "Error in after-delete-file-hook %s" err) - (sit-for 1))))) - -(gmhist-overwrite 'read-file-name) -(gmhist-overwrite 'write-region) -(gmhist-overwrite 'delete-file) - -;; Redefining read-file-name does not suffice as interactive "f" -;; calls the C version of read-file-name. -;; gmhist-interactive of gmhist.el,v 4.4 and later understands the -;; indirection from file-history-symbol to 'file-history (or whatever -;; the current value may be). -(gmhist-make-magic 'find-file 'file-history-symbol) -(gmhist-make-magic 'find-file-other-window 'file-history-symbol) -(gmhist-make-magic 'find-file-read-only 'file-history-symbol) -(gmhist-make-magic 'insert-file 'file-history-symbol) -(gmhist-make-magic 'load-file 'file-history-symbol) -(gmhist-make-magic 'set-visited-file-name 'file-history-symbol) -(gmhist-make-magic 'append-to-file 'file-history-symbol) -;; write-region is wrapped by gmhist, no longer a subr, thus this works: -(gmhist-make-magic 'write-region 'file-history-symbol) -;; ditto for delete-file: -(gmhist-make-magic 'delete-file 'file-history-symbol) -(if gmhist-emacs-19-p - ;; In Emacs 19, these call the redefined read-file-name inside - ;; interactive, so we don't need to do anything - nil - (gmhist-make-magic 'write-file 'file-history-symbol) - (gmhist-make-magic 'find-alternate-file 'file-history-symbol)) - - -;;; Buffer history - -(defvar buffer-history-lru-order nil - "*If non-nil, the buffer history will be the complete buffer -list in most recently used order (as returned by buffer-list). - -Usually, the buffer history is in the order entered using read-buffer.") - -(defvar buffer-history (get 'buffer-history 'initial-hist) - "History of all buffer names read with read-buffer.") - -(defun gmhist-new-read-buffer (gnrb-prompt &optional default existing) - "One arg PROMPT, a string. Read the name of a buffer and return as a string. -Prompts with PROMPT. -Optional second arg is value to return if user enters an empty line. -If optional third arg REQUIRE-MATCH is non-nil, only existing buffer names are allowed. - -*** This is the gmhist version *** - -See variables `buffer-history-symbol' and `buffer-history-lru-order'." - (if (and buffer-history-symbol - buffer-history-lru-order) - (set buffer-history-symbol - (mapcar (function buffer-name) (buffer-list)))) - (gmhist-read-buffer gnrb-prompt default existing)) - -(defun gmhist-new-switch-to-buffer (buffer &optional norecord) - "Select buffer BUFFER in the current window. -BUFFER may be a buffer or a buffer name. -Optional second arg NORECORD non-nil means -do not put this buffer at the front of the list of recently selected ones. - -WARNING: This is NOT the way to work on another buffer temporarily -within a Lisp program! Use `set-buffer' instead. That avoids messing with -the window-buffer correspondences. - -*** This is the gmhist version *** - -It adds buffer-history to switch-to-buffer." - (interactive - ;; should perhaps bypass gmhist if NORECORD is given? - (list (gmhist-new-read-buffer "Switch to buffer: " (other-buffer) nil))) - (gmhist-old-switch-to-buffer buffer norecord)) - -(gmhist-overwrite 'read-buffer) -;; switch-to-buffer is a subr: -(gmhist-overwrite 'switch-to-buffer) -;; Redefining read-buffer does not suffice as interactive "b" -;; calls the C version of read-buffer. -;; gmhist-interactive of gmhist.el,v 4.4 and later understands the -;; indirection from buffer-history-symbol to 'buffer-history (or -;; whatever the current value may be). -(mapcar (function (lambda (fun) - (gmhist-make-magic fun 'buffer-history-symbol))) - '(switch-to-buffer-other-window ; files.el - append-to-buffer ; the rest from simple.el - prepend-to-buffer - copy-to-buffer)) - - -;;; read-from-minibuffer -;;; saved and defined in gmhist.el, just need to overwrite: - -(fset 'read-from-minibuffer 'gmhist-new-read-from-minibuffer) - -;; Now that we've redefined read-from-minibuffer we need to make sure -;; that repeat-complex-command (C-x ESC), which calls -;; read-from-minibuffer, adds the command to command-history and not -;; to the ambient value of minibuffer-history-symbol. The latter -;; could be confusing if e.g. inside a C-x C-f a C-x ESC is done (with -;; enable-recursive-minibuffers t): it would add a command to the -;; file-history. - -;(defun repeat-complex-command (repeat-complex-command-arg) -; "Edit and re-evaluate last complex command, or ARGth from last. -;A complex command is one which used the minibuffer. -;The command is placed in the minibuffer as a Lisp form for editing. -;The result is executed, repeating the command as changed. -;If the command has been changed or is not the most recent previous command -;it is added to the front of the command history. -;Whilst editing the command, the following commands are available: -;\\{repeat-complex-command-map}" -; (interactive "p") -; (let ((elt (nth (1- repeat-complex-command-arg) command-history)) -; newcmd) -; (if elt -; (progn -; (setq newcmd -; (let ((minibuffer-history-symbol nil)) -; ;; Don't let gmhist interfere with command-history. -; ;; command-history is special because it's builtin to M-x. -; ;; Also, gmhist would store commands as strings, not -; ;; as s-exprs. -; ;; When gmhist is implemented in C, M-x must be -; ;; fixed to store strings, too. -; (read-from-minibuffer "Redo: " -; (prin1-to-string elt) -; repeat-complex-command-map -; t))) -; ;; If command to be redone does not match front of history, -; ;; add it to the history. -; (or (equal newcmd (car command-history)) -; (setq command-history (cons newcmd command-history))) -; (eval newcmd)) -; (ding)))) - -;; Actually, it's easier to just use the gmhist re-implementation instead -(define-key ctl-x-map "\e" 'gmhist-repeat-complex-command) - -(defun gmhist-repeat-complex-command (arg) ; C-x ESC - ;; This function from Mike Williams - "Edit and re-evaluate last complex command, or ARGth from last. -A complex command is one which used the minibuffer. -The command is placed in the minibuffer as a Lisp form for editing. -The result is executed, repeating the command as changed. -If the command has been changed or is not the most recent previous command -it is added to the front of the command history." - (interactive "p") - (let ((print-escape-newlines t)) - (put 'command-history 'backup arg) - (put 'command-history 'cursor-end t) - (eval (read-with-history-in 'command-history "Redo: " nil 'lisp)) - (put 'command-history 'backup nil))) - -;; TODO: -;; read-minibuffer -;; eval-minibuffer -;; read-no-blanks-input -;; read-command -;; read-variable diff -r b88636d63495 -r 8fc7fe29b841 lisp/dired/gmhist.el --- a/lisp/dired/gmhist.el Mon Aug 13 08:50:06 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,1071 +0,0 @@ -;;;; gmhist.el - Provide generic minibuffer history for commands - -(defconst gmhist-version (substring "!Revision: 4.27 !" 11 -2) - "Id: gmhist.el,v 4.27 1992/04/20 17:17:47 sk RelBeta -Report bugs to Sebastian Kremer .") - -;; Copyright (C) 1990 by Sebastian Kremer - -;; 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 1, 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; if not, write to the Free Software -;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -;; LISPDIR ENTRY for the Elisp Archive =============================== -;; LCD Archive Entry: -;; gmhist|Sebastian Kremer|sk@thp.uni-koeln.de -;; |Generic minibuffer history package. -;; |Date: 1992/04/20 17:17:47 |Revision: 4.27 | - -;; INSTALLATION ====================================================== -;; -;; Put this file into your load-path and the following in your -;; ~/.emacs: -;; -;; (autoload 'read-with-history-in "gmhist") -;; (autoload 'read-file-name-with-history-in "gmhist") -;; (autoload 'completing-read-with-history-in "gmhist") -;; (autoload 'gmhist-make-magic "gmhist" nil t) - -;; USAGE ============================================================= -;; -;; - as an Elisp programmer: use functions read-with-history-in, -;; completing-read-with-history-in, read-file-name-with-history-in or -;; gmhist-interactive inside the interactive clause of your functions -;; instead of a string specification. See the examples at the end of -;; the file. -;; -;; - as an Emacs user: To provide `simple' functions with history, -;; just type M-x gmhist-make-magic and enter the name of the -;; function, e.g., `eval-expression'. This function's arguments -;; are then remembered across calls and are available by typing -;; M-p to the minibuffer prompt of the function. More history -;; commands are mentioned in the documentation of variable -;; gmhist-map. -;; -;; Type M-x gmhist-remove-magic to restore the function's old -;; interactive behaviour. -;; -;; `Simple' functions are those that prompt for strings, file -;; names or lisp objects and perhaps use prefix args and the -;; region. See the file gmhist-app.el for examples with simple -;; and other functions. - -;; I'd like to thank Jamie Zawinski, Piet van Oostrum and Mike -;; Williams for very helpful feedback and ideas. - - -(provide 'gmhist) - -;; Emacs 19 has s-expr interactive's on some functions (sometimes to -;; emulate functionality gmhist would give). So we sometimes have to -;; test this to avoid letting gmhist-make-magic bombing on non-string -;; interactive specifications: -;; XEmacs fix: -(defvar gmhist-emacs-19-p (not (equal (substring emacs-version 0 2) "18"))) - -(defvar gmhist-default-format "[%s] " ; saves screen space, too - "Format used by gmhist to indicate the presence of a default value. -Set this to \"(default %s) \" to get the standard format.") - -(defvar gmhist-search-history nil "History of history searches.") - -(defun read-with-history-in (GMHIST-SYMBOL rwhi-prompt &optional - GMHIST-INITIAL GMHIST-READ) - ;; We have to be careful about dynamical scoping here so as not to - ;; shadow other lisp code that depends on fluid vars like `prompt - ;; (notorious in minibuffer code, e.g. electric-replace). - ;; That's why our own fluid vars have upper-case names starting with - ;; GMHIST- and why `rwhi-prompt' instead of `prompt' is used as - ;; formal argument. Similar below. - "\ -Read a string, maintaining minibuffer history across calls in GMHIST-SYMBOL, - prompting with PROMPT, with optional GMHIST-INITIAL as initial contents. -If optional fourth arg GMHIST-READ is non-nil, then interpret the - result as a lisp object and return that object. -See variable gmhist-map for history commands available during edit. -Example: - (defun foo-command (cmd) - (interactive (list (read-with-history-in 'foo-history \"Foo: \" ))) - (message \"Fooing %s...\" cmd)) - -See function gmhist-make-magic on how to give an existing function -history. - -These properties (see function put) of GMHIST-SYMBOL are supported: - -cursor-end Put cursor at end of a newly retrieved history line. -cursor-pos A regexp to put the cursor on. -keep-dups If t, duplicate commands are remembered, too. -initial-hist Initial value of the history list. -hist-ignore Regexp of commands that are not to be added to the history. -backup If t, backup in the history list (as if user had typed - M-p as first thing). Can also be an integer to backup - more than one history item. -default An empty string as input will default to the last - command (whether the last command was added to the - history or not). The default is stored in this - property, thus its initial value is the first default. -dangerous Commands matching this regexp will never be the default. -no-default If you don't want defaults at all, set this to t. - -Use the following only if you know what you are doing: - -hist-function Name of a function to call instead of doing normal - history processing. read-with-history-in becomes - effectively an alias for this function. - -These will be flushed soon (use let-binding minibuffer-completion-table -etc. instead): - -hist-map Minibuffer key map to use instead of gmhist-map. -completion-table -completion-predicate - Used in completion on history strings, when the hist-map - property has gmhist-completion-map as value. - The special value `t' for the table means to use the - current history list. - Thus, to get completion on history items just do: - (put 'foo-history 'hist-map gmhist-completion-map) - (put 'foo-history 'completion-table t) - -Hooks: - gmhist-after-insert-hook is run after a history item is - inserted into the minibuffer. - gmhist-load-hook is run after this package is loaded. - gmhist-hook is run as first thing inside read-with-history-in. - gmhist-before-move-hook is run before history motion takes place. - Function gmhist-remember-zero is a candidate for that hook. -" - ;; We don't use property names prefixed with 'ghmist-' because the - ;; caller has freedom to use anything for GMHIST-SYMBOL. - ;; The history list is never truncated, but I don't think this will - ;; cause problems. All histories together have at most a few k. - ;; On the other hand, some people run an Emacs session for weeks. - ;; Could use gmhist-hook to truncate the current history list. - ;; You can use 'initial-hist to save (part of) the history in a file - ;; and provide it at next startup. [Is there an exit-emacs-hook?] - ;; You can use 'hist-function to implement a completely different - ;; history mechanism, e.g., a ring instead of a list, without having - ;; to modify existing gmhist applications. - (run-hooks 'gmhist-hook) - (let ((hist-function (get GMHIST-SYMBOL 'hist-function))) - (if (fboundp hist-function) ; hist-function must be a symbol - (funcall hist-function ; not lambda - GMHIST-SYMBOL rwhi-prompt GMHIST-INITIAL GMHIST-READ) - (or (boundp GMHIST-SYMBOL) ; history list defaults to nil - (set GMHIST-SYMBOL (get GMHIST-SYMBOL 'initial-hist))) - ;; else do the usual history processing simply using lists: - (let* ((history (symbol-value GMHIST-SYMBOL)) - (minibuffer-completion-table (let ((table - (get GMHIST-SYMBOL - 'completion-table))) - (if (eq t table) - (mapcar (function list) - history) - table))) - (minibuffer-completion-predicate (get GMHIST-SYMBOL - 'completion-predicate)) - (minibuffer-history-symbol GMHIST-SYMBOL)) - (gmhist-new-read-from-minibuffer rwhi-prompt - GMHIST-INITIAL - (or (get GMHIST-SYMBOL 'hist-map) - gmhist-map) - GMHIST-READ))))) - -(defun completing-read-with-history-in (crwhi-hist-sym &rest args) - "Like completing-read, but with additional first arg HISTORY-SYMBOL." - (let ((minibuffer-history-symbol crwhi-hist-sym)) - (apply 'gmhist-completing-read args))) - -(defun gmhist-completing-read (crwhi-prompt table - &optional predicate - mustmatch initial) - "Like completing-read, but see minibuffer-history-symbol." - (let ((minibuffer-completion-confirm (if (eq mustmatch t) nil t)) - (minibuffer-completion-table table) - (minibuffer-completion-predicate predicate)) - (gmhist-new-read-from-minibuffer crwhi-prompt - initial - (gmhist-lookup-keymap - (if mustmatch - gmhist-must-match-map - gmhist-completion-map))))) - - -(defun read-file-name-with-history-in (crwhi-hist-sym &rest args) - "Like read-file-name, but with additional first arg HISTORY-SYMBOL." - (let ((file-history-symbol crwhi-hist-sym)) - (apply 'gmhist-read-file-name args))) - -(defvar file-history-symbol 'file-history - "*If non-nil, it is the name (a symbol) of a variable on which to cons -filenames entered in the minibuffer. -You may let-bind this to another symbol around calls to read-file-name.") - -(defun gmhist-read-file-name - (grfn-prompt &optional dir default mustmatch initial) - "Args: PROMPT &optional DIR DEFAULT MUSTMATCH INITIAL. -Read file name, maintaining history in file-history-symbol, prompting - with PROMPT, with optional INITIAL input and completing in directory DIR. -Value is not expanded! You must call expand-file-name yourself. -Default name to arg DEFAULT if user enters a null string (or, if - INITIAL was given, leaves it unchanged). -MUSTMATCH non-nil means require existing file's name. - Non-nil and non-t means also require confirmation after completion. -DIR defaults to current buffer's default-directory. - -This function differs from read-file-name in providing a history of -filenames bound to file-history-symbol and (for pre-Emacs 19) in -providing an argument INITIAL not present in Emacs 18's read-file-name." - (setq dir (or dir default-directory) - default (or default buffer-file-name)) - (if file-history-symbol - (progn (put file-history-symbol 'cursor-end t) - (put file-history-symbol 'no-default t))) - ;; $'s should be quoted (against substitute-in-file-name) in file - ;; names inserted here - (if initial - (setq initial (gmhist-quote-dollars (gmhist-unexpand-home initial))) - (if insert-default-directory - (setq initial (gmhist-quote-dollars (gmhist-unexpand-home dir))))) - (let* ((minibuffer-completion-confirm (if (eq mustmatch t) nil t)) - (minibuffer-completion-table 'read-file-name-internal) - (minibuffer-completion-predicate dir) - (minibuffer-history-symbol file-history-symbol) - (val (gmhist-new-read-from-minibuffer - grfn-prompt initial (gmhist-lookup-keymap - (if mustmatch - gmhist-filename-must-match-map - gmhist-filename-completion-map))))) - - (or (and (or (and (stringp initial) - (string= initial val)) - (and (null initial) - (zerop (length val)))) - default) - (substitute-in-file-name val)))) - -(defun gmhist-unexpand-home (file) - ;; Make prompt look nicer by un-expanding home dir. - ;; read-file-name does this, too. - ;; Avoid clobbering match-data with string-match. - (let* ((home (expand-file-name "~/")) - (home-len (length home)) - (file-len (length file))) - (if (and home - (stringp file) - (>= file-len home-len) - (string= home (substring file 0 home-len)) - (eq ?/ (aref file (1- home-len)))) - (concat "~/" (substring file home-len)) - file))) - -; (defun gmhist-quote-dollars (file) -; "Quote `$' as `$$' in FILE to get it past function `substitute-in-file-name.'" -; (apply (function concat) -; (mapcar (function -; (lambda (char) -; (if (= char ?$) -; "$$" -; (vector char)))) -; file))) -;; 10000 iterations of (gmhist-quote-dollars "foo") took 19 seconds -;; and *lots* of garbage collections (about a dozen or more) - -;; This version does not cons and is much faster in the usual case -;; without $ present: -;; 10000 iterations of (gmhist-quote-dollars "foo") took 4 seconds and -;; not a single garbage collection. -(defun gmhist-quote-dollars (file) - "Quote `$' as `$$' in FILE to get it past function `substitute-in-file-name.'" - (let ((pos 0)) - (while (setq pos (string-match "\\$" file pos)) - (setq file (concat (substring file 0 pos) - "$";; precede by escape character (also a $) - (substring file pos)) - ;; add 2 instead 1 since another $ was inserted - pos (+ 2 pos))) - file)) - - - -(defun read-buffer-with-history-in (rbwhi-hist-sym &rest args) - "Like read-buffer, but with additional first arg HISTORY-SYMBOL." - (let ((buffer-history-symbol rbwhi-hist-sym)) - (apply 'gmhist-read-buffer args))) - -(defvar buffer-history-symbol 'buffer-history - "*If non-nil, it is the name (a symbol) of a variable on which to cons -buffer names entered in the minibuffer.") - -(defun gmhist-read-buffer (grb-prompt &optional default existing) - "Read a buffer name, maintaining history in buffer-history-symbol and return as string. -Args PROMPT &optional DEFAULT EXISTING. -Optional arg EXISTING means an existing buffer must be entered." - (if (bufferp default);; want string in prompt, not buffer object - (setq default (buffer-name default))) - (if buffer-history-symbol - (put buffer-history-symbol 'default default)) ; also if nil - (let* ((minibuffer-history-symbol buffer-history-symbol) - (name (gmhist-completing-read - grb-prompt - ;;(function (lambda (buf) (list (buffer-name buf)))) - ;; convert to alist in format (BUF-NAME . BUF-OBJ) - (mapcar - (function (lambda (arg) (cons (buffer-name arg) arg))) - (buffer-list)) - (function (lambda (elt) (get-buffer (car elt)))) - existing))) - (if (equal "" name) - default - name))) - -(defvar minibuffer-history-symbol 'minibuffer-history - "*If non-nil, it is the name (a symbol) of a variable on which to cons -the string entered in the minibuffer. -Input is stored as string, even for e.g. `read-buffer'.") - -(defvar minibuffer-history nil - "List of strings entered using the minibuffer, most recent first.") - -(put 'minibuffer-history 'no-default t) - -(defvar minibuffer-history-read-only nil - "If non-nil, nothing will be stored on `minibuffer-history-symbol'. -History motions commands are still available in the minibuffer.") - -(defvar minibuffer-history-position nil - "If currently reading the minibuffer, the history position.") - -(defvar minibuffer-initial-contents nil - "If currently reading the minibuffer, the initial contents.") - -;; Save the subr, we need it inside the redefined version: -(or (fboundp 'gmhist-old-read-from-minibuffer) - (fset 'gmhist-old-read-from-minibuffer - (symbol-function 'read-from-minibuffer))) - -(defun gmhist-new-read-from-minibuffer - (gnrfm-prompt &optional initial-contents keymap read position) - "Read a string from the minibuffer, prompting with string PROMPT. -If optional second arg INITIAL-CONTENTS is non-nil, it is a string - to be inserted into the minibuffer before reading input. -Third arg KEYMAP is a keymap to use whilst reading; - if omitted or nil, the default is `minibuffer-local-map'. -If fourth arg READ is non-nil, then interpret the result as a lisp object - and return that object: - in other words, do `(car (read-from-string INPUT-STRING))' -Fifth arg POSITION, if non-nil, is where to put point - in the minibuffer after inserting INITIAL-CONTENTS. - -The ambient value of `minibuffer-history-symbol' (q.v.) is used and set. - -*** This is the gmhist version.***" - (if (null minibuffer-history-symbol) - (if gmhist-emacs-19-p - (gmhist-old-read-from-minibuffer - gnrfm-prompt initial-contents keymap read position) - (gmhist-old-read-from-minibuffer gnrfm-prompt initial-contents - keymap read)) - (gmhist-read-from-minibuffer - gnrfm-prompt initial-contents keymap read position))) - -(defun gmhist-read-from-minibuffer (grfm-prompt - &optional - initial-contents keymap read position) - (or keymap (setq keymap minibuffer-local-map)) - (or minibuffer-history-read-only - (boundp minibuffer-history-symbol) ; history list defaults to nil - ;; create history list if not already done - (set minibuffer-history-symbol - (get minibuffer-history-symbol 'initial-hist))) - (let* ((minibuffer-history-position 0) ; fluid var for motion commands - (minibuffer-initial-contents initial-contents) ; ditto - (history (symbol-value minibuffer-history-symbol)) - ;; Command is an s-exp when read->t. In this case, - ;; cannot have empty input: - (no-default (or read - (get minibuffer-history-symbol 'no-default))) - (dangerous (if no-default - nil - (get minibuffer-history-symbol 'dangerous))) - ;; Idea for 'backup feature by Mike Williams - (backup (get minibuffer-history-symbol 'backup)) - (default (if no-default - nil - (get minibuffer-history-symbol 'default))) - (the-prompt (if default - (concat grfm-prompt (format gmhist-default-format - default)) - grfm-prompt)) - (the-initial (if (or minibuffer-initial-contents - (not backup)) - minibuffer-initial-contents - ;; else we must backup in the history list - (setq backup (min (max 0 (or (and (integerp backup) - backup) - 1)) - (length history))) - (if (zerop (setq minibuffer-history-position backup)) - nil - ;; else backup is at least 1 - (let ((backup-input (nth (1- backup) history))) - (if read - (prin1-to-string backup-input) - backup-input))))) - command) - ;; Read the command from minibuffer, providing history motion - ;; key map and minibuffer completion - (setq command - (if position - ;; avoid passing POSITION arg unless given (presumably - ;; we are in Emacs 19 then) - (gmhist-old-read-from-minibuffer the-prompt the-initial keymap - position) - (gmhist-old-read-from-minibuffer the-prompt the-initial keymap))) - ;; Care about default values unless forbidden: - (or no-default - (setq command (gmhist-handle-default command default dangerous))) - (if minibuffer-history-read-only - nil - (let (ignore) - ;; Add to history if first command, or not a dup, or not to be ignored - (or (and history - (or (if (get minibuffer-history-symbol 'keep-dups) - nil - (equal command (car history))) - (if (stringp (setq ignore (get minibuffer-history-symbol - 'hist-ignore))) - (string-match ignore - (gmhist-stringify (car history)))))) - (set minibuffer-history-symbol (cons command history))))) - ;; Return command's value to caller: - (if read - (car (read-from-string command)) - command))) - -(defun gmhist-handle-default (command default dangerous) - (if (string= "" command) - (if default (setq command default))) - ;; Set default value unless it is dangerous. - (or (and (stringp dangerous) - ;; Should actually save match-data as we call string-match - (string-match dangerous (gmhist-stringify command))) - (put minibuffer-history-symbol 'default command)) - ;; Return the prefrobnicated command: - command) - - -;; Minibuffer key maps to implement history - -(defvar gmhist-define-keys-hook nil - "Hook run inside function `gmhist-define-keys' (q.v.), after the -standard gmhist bindings.") - -(or (fboundp 'gmhist-define-keys) - (defun gmhist-define-keys (map) - "Bind the standard history commands in MAP, a key map. - -When gmhist is loaded, this function is only defined if you have not -already defined it, so that you can customize it without worrying -about load order. -You can also use `gmhist-define-keys-hook' if you just want to add to -existing bindings." - (define-key map "\M-p" 'gmhist-previous) - (define-key map "\M-n" 'gmhist-next) - (define-key map "\M-r" 'gmhist-search-backward) - (define-key map "\M-s" 'gmhist-search-forward) - ;;(define-key map "\M-<" 'gmhist-beginning) - ;;(define-key map "\M-<" 'gmhist-beginning) - ;; Last two for bash/readline compatibility. Better M-a and M-e ? - ;; In query-replace, multi-line text together with next-line's - ;; misfeature of adding blank lines really lets you lose without M-< - ;; and M->. - ;;(define-key map "\M-a" 'gmhist-beginning) - ;;(define-key map "\M-e" 'gmhist-end) - ;; M-a is already used in electric replace - ;; Try this as general purpose mover: - (define-key map "\M-g" 'gmhist-toggle) - (define-key map "\M-G" 'gmhist-switch-history) - (define-key map "\M-?" 'gmhist-show) - (run-hooks 'gmhist-define-keys-hook))) - -(defun gmhist-lookup-keymap (map) - (if (keymapp map) - map - (gmhist-lookup-keymap (symbol-value map)))) - -(defvar gmhist-map nil - "Key map for generic minibuffer history. -\\\\[gmhist-previous], \\[gmhist-next], \ -\\[gmhist-beginning], \\[gmhist-end] move through, \ -\\[gmhist-search-backward] and \\[gmhist-search-forward] search, -\\[gmhist-show] displays the history: -\\{gmhist-map}") - -(if gmhist-map - nil - (setq gmhist-map (copy-keymap minibuffer-local-map)) - (gmhist-define-keys gmhist-map)) - -(defvar gmhist-completion-map nil - "Key map for generic minibuffer history with completion, see gmhist-map.") - -(if gmhist-completion-map - nil - ;; If you have loaded D. Gillespie's complete.el or Christopher - ;; McConnell's completer.el *before* gmhist, you get it in gmhist, - ;; too: - (setq gmhist-completion-map (copy-keymap minibuffer-local-completion-map)) - (gmhist-define-keys gmhist-completion-map)) - -(defvar gmhist-must-match-map nil - "Key map for generic minibuffer history with completion that must match, -see gmhist-map.") - -(if gmhist-must-match-map - nil - (setq gmhist-must-match-map (copy-keymap minibuffer-local-must-match-map)) - (gmhist-define-keys gmhist-must-match-map)) - -(defvar gmhist-filename-completion-map 'gmhist-completion-map - "A keymap (or a symbol pointing to one) to use in filename -completion that need not match. Defaults to 'gmhist-completion-map.") - -(defvar gmhist-filename-must-match-map 'gmhist-must-match-map - - "A keymap (or a symbol pointing to one) to use in filename -completion that must match. Defaults to 'gmhist-must-match-map.") - - -;; Minibuffer commands to implement history -;; They run inside read-with-history-in and heavily depend on fluid -;; vars from there. - -(defun gmhist-goto (n) - ;; Go to history position N, 1 <= N <= length of history - ;; N<0 means the future and inserts an empty string - ;; N=0 means minibuffer-initial-contents (fluid var from - ;; gmhist-new-read-from-minibuffer) - (run-hooks 'gmhist-before-move-hook) - (erase-buffer) - (setq minibuffer-history-position n) - (if (< n 0) - nil - (insert - (gmhist-stringify - (if (= n 0) - (or minibuffer-initial-contents "") - (nth (1- n) (symbol-value minibuffer-history-symbol))))) - (run-hooks 'gmhist-after-insert-hook) - ;; next two actually would be a good application for this hook - (goto-char (if (get minibuffer-history-symbol 'cursor-end) - (point-max) - (point-min))) - (let ((pos (get minibuffer-history-symbol 'cursor-pos))) - (if (stringp pos) - (if (eobp) - (re-search-backward pos nil t) - (re-search-forward pos nil t)))))) - -(defun gmhist-beginning () - "Go to the oldest command in the history." - (interactive) - (gmhist-goto (length (symbol-value minibuffer-history-symbol)))) - -(defun gmhist-end () - "Position before the most recent command in the history." - (interactive) - (gmhist-goto 0)) - -(defun gmhist-toggle (&optional n) - "If at end of history, move to beginning, else move to end. -Prefix arg is history position to go to." - (interactive "P") - (if n - (gmhist-goto (prefix-numeric-value n)) - (if (= 0 minibuffer-history-position) - (gmhist-beginning) - (gmhist-end)))) - -(defun gmhist-switch-history (new-history) - "Switch to a different history." - (interactive - (let ((enable-recursive-minibuffers t)) - (list (read-from-minibuffer "Switch to history: " nil nil t)))) - (setq minibuffer-history-symbol new-history - minibuffer-history-position 0)) - -(defun gmhist-next (n) - "Go to next history position." - ;; fluid vars: minibuffer-history-symbol minibuffer-history-position - ;; Inserts the next element of minibuffer-history-symbol's value - ;; into the minibuffer. - ;; minibuffer-history-position is the current history position. - (interactive "p") - ;; clip the new history position to the valid range: - (let ((narg (min (max 0 (- minibuffer-history-position n)) - (length (symbol-value minibuffer-history-symbol))))) - (if (= minibuffer-history-position narg) - (error "No %s item in %s" - (if (= 0 minibuffer-history-position) "following" "preceding") - minibuffer-history-symbol) - (gmhist-goto narg)))) - -(defun gmhist-previous (n) - "Go to previous history position." - (interactive "p") - (gmhist-next (- n))) - -;; Searching the history - -(defun gmhist-search-backward (regexp &optional forward) - "Search backward in the history list for REGEXP. -With prefix argument, search for line that contains match for current line." - (interactive - (if current-prefix-arg - (list (regexp-quote (buffer-string))) - (let ((enable-recursive-minibuffers t)) - (list (read-with-history-in 'gmhist-search-history - "History search (regexp): "))))) - (let* (found - (direction (if forward -1 1)) - (pos (+ minibuffer-history-position direction)) ; find _next_ match! - (history (symbol-value minibuffer-history-symbol)) - (len (length history))) - (while (and (if forward (> pos 0) (<= pos len)) - (not (setq found - (string-match - regexp - (gmhist-stringify (nth (1- pos) history)))))) - (setq pos (+ pos direction))) - (or found (error "%s not found in %s" regexp minibuffer-history-symbol)) - (gmhist-goto pos))) - -(defun gmhist-search-forward (regexp &optional backward) - "Search forward in the history list for REGEXP. -With prefix argument, search for line that matches current line -instead of prompting for REGEXP." - (interactive - (if current-prefix-arg - (list (regexp-quote (buffer-string))) - (let ((enable-recursive-minibuffers t)) - (list (read-with-history-in 'gmhist-search-history - "History search forward (regexp): "))))) - (gmhist-search-backward regexp (not backward))) - -;; Misc. - -(defun gmhist-stringify (elt) - ;; If ELT is not a string, convert it to one. - (if (stringp elt) elt (prin1-to-string elt))) - -(defun gmhist-show () - "Show the history list in another buffer. -Use \\[scroll-other-window] to scroll, with negative arg to scroll back." - (interactive) - (let ((count 0)) - (with-output-to-temp-buffer (concat "*" (symbol-name minibuffer-history-symbol) "*") - (mapcar - (function - (lambda (x) - (princ (format "%2s%2d: %s\n" - (if (eq (setq count (1+ count)) - minibuffer-history-position) - "> " - " ") - count x)))) - (symbol-value minibuffer-history-symbol))))) - -(defun gmhist-remember-zero () - "Put this function on gmhist-before-move-hook to make gmhist -remember the initial value even after you edited it: - - (setq gmhist-before-move-hook 'gmhist-remember-zero)" - (if (zerop minibuffer-history-position) - (setq minibuffer-initial-contents (buffer-string)))) - -;; Hack up interactive specifications of existing functions - -(defun gmhist-copy-function (fun) - (let ((old (gmhist-symbol-function fun))) - (if (consp old) ; interpreted, or v18 compiled - ;; copy-sequence does not copy recursively. - ;; Iteration is faster than recursion, and we need just two levels - ;; to be able to use setcdr to mung the interactive spec. - (let (new elt) - (while old - (setq elt (car old) - old (cdr old) - new (cons (if (sequencep elt) - (copy-sequence elt) - elt) - new))) - (nreverse new)) - ;; else v19 compiled - (let ((new (append old nil))) - (setcar (nthcdr 5 new) (copy-sequence (aref old 5))) - (apply 'make-byte-code new))))) - -(defun gmhist-check-autoload (fun) - "If FUN is an autoload, load its definition." - (let ((lis (symbol-function fun))) - (if (and (listp lis) ; FUN could also be a subr - (eq 'autoload (car lis))) - (load (nth 1 lis))))) - -(defun gmhist-replace-spec (fun new-spec &optional copy-first) - "Replace the interactive specification of FUN with NEW-SPEC. -FUN must be a symbol with a function definition. -Autoload functions are taken care of by loading the appropriate file first. -If FUN is a pure storage function (one dumped into Emacs) it is first - copied onto itself, because pure storage cannot be modified. - Optional non-nil third arg COPY-FIRST is used internally for this. -The old spec is put on FUN's gmhist-old-interactive-spec property. - That property is never overwritten by this function. It is used by - function gmhist-remove-magic." - (gmhist-check-autoload fun) - (if copy-first ; copy (from pure storage) - (fset fun (gmhist-copy-function fun))) - (let* ((flambda (gmhist-symbol-function fun)) - (fint (and (consp flambda) - (if (eq 'interactive (car-safe (nth 2 flambda))) - (nth 2 flambda) - (if (eq 'interactive (car-safe (nth 3 flambda))) - (nth 3 flambda) - (error "%s is not interactive" fun))))) - (old-spec (if fint - (nth 1 fint) - (gmhist-spec fun)))) - ;; Save old interactive spec as property of FUN: - (or (get fun 'gmhist-old-interactive-spec) - (put fun 'gmhist-old-interactive-spec old-spec)) - ;; Replace '(interactive OLD-SPEC) with '(interactive NEW-SPEC) - (if copy-first - ;; This should not fail - if it does, we must abort. - (if (consp flambda) - (setcdr fint (list new-spec)) - ;; can't "aset" a # object, though aref works... - (setq flambda (append flambda nil)) - (setcar (nthcdr 5 flambda) new-spec) - (setq flambda (apply 'make-byte-code flambda)) - (fset fun flambda)) - ;; else prepare for a second try - (condition-case err - (setcdr fint (list new-spec)) - (error - ;; Setcdr bombs on preloaded functions: - ;; (error "Attempt to modify read-only object") - ;; There seems to be no simple way to test whether an object - ;; resides in pure storage, so we let it bomb and try again - ;; after copying it into writable storage. - (gmhist-replace-spec fun new-spec t)))))) - -(defun gmhist-spec (fun) - "Get the current interactive specification for FUN (a symbol). -Signal an error if FUN is not interactive." - (let ((flambda (gmhist-symbol-function fun)) - fint) - (cond ((consp flambda) ; interpreted, or v18 compiled - ;; do it exactly like call-interactively, even if this - ;; means (interactive...) can come arbitrary late in FUN's body - (setq fint (assq 'interactive (cdr (cdr flambda)))) - (or fint - (error "Cannot get spec of a non-interactive command: %s!" fun)) - (nth 1 fint)) - (t ; otherwise it's a v19 compiled-code object - (aref flambda 5))))) - -(defun gmhist-symbol-function (fun) - ;; Return FUN's ultimate definition. - ;; Recurse if FUN is fset to another function's name. - (let ((flambda (symbol-function fun))) - (if (symbolp flambda) - ;; Prefer recursion over while because infinite loop is caught - ;; by max-lisp-eval-depth. - (gmhist-symbol-function flambda) - flambda))) - -;; Automagic gmhistification - -;; There should be a builtin split function - inverse to mapconcat. -(defun gmhist-split (pat str &optional limit) - "Splitting on regexp PAT, turn string STR into a list of substrings. -Optional third arg LIMIT (>= 1) is a limit to the length of the -resulting list. -Thus, if SEP is a regexp that only matches itself, - - (mapconcat 'identity (gmhist-split SEP STRING) SEP) - -is always equal to STRING." - (let* ((start (string-match pat str)) - (result (list (substring str 0 start))) - (count 1) - (end (if start (match-end 0)))) - (if end ; else nothing left - (while (and (or (not (integerp limit)) - (< count limit)) - (string-match pat str end)) - (setq start (match-beginning 0) - count (1+ count) - result (cons (substring str end start) result) - end (match-end 0) - start end) - )) - (if (and (or (not (integerp limit)) - (< count limit)) - end) ; else nothing left - (setq result - (cons (substring str end) result))) - (nreverse result))) - -(defun gmhist-interactive (spec hist) - "Interpret SPEC, an interactive string, like call-interactively -would, only with minibuffer history in HIST (a symbol). - -If the value of HIST is another symbol (which can never happen if -history lists are already stored on it), this symbol is taken instead -to facilitate dynamic indirections. - -Currently recognized key letters are: - - a b B c C d D k m N n s S x X f F r p P v - -and initial `*'. - -Use it inside interactive like this - - \(interactive \(gmhist-interactive \"sPrompt: \\nP\" 'foo-history\)\) - -or even like this: - - \(interactive - \(gmhist-interactive \"sReplace: \\nsReplace %s with: \" 'replace-history\)\) -" - (or (stringp spec) - (error "gmhist-interactive: not a string %s" spec)) - (if (and (> (length spec) 0) (eq ?\* (aref spec 0))) - (progn - (barf-if-buffer-read-only) - (setq spec (substring spec 1)))) - (if (and (boundp hist) - (symbolp (symbol-value hist)) - (not (null (symbol-value hist)))) - (setq hist (symbol-value hist))) - (let ((spec-list (mapcar '(lambda (x) - ;; forgive empty entries like - ;; call-interactively does: - (if (equal "" x) - nil - (cons (aref x 0) (substring x 1)))) - (gmhist-split "\n" spec))) - cur-arg args-so-far special elt char prompt xprompt) - (setq spec-list (delq nil spec-list)) - (while spec-list - (setq elt (car spec-list) - spec-list (cdr spec-list) - special nil ; special handling of args-so-far - char (car elt) - prompt (cdr elt) - xprompt (apply (function format) prompt (reverse args-so-far))) - (cond ((eq char ?a) ; Symbol defined as a function - (setq cur-arg (intern - (completing-read-with-history-in - hist xprompt obarray 'fboundp t nil)))) - ((eq char ?b) ; Name of existing buffer - (setq cur-arg (read-buffer-with-history-in - hist xprompt (other-buffer) t))) - ((eq char ?B) ; Name of possibly non-existing buffer - (setq cur-arg (read-buffer-with-history-in - hist xprompt (other-buffer) nil))) - ((eq char ?c) ; Character - (message xprompt) ; history doesn't make sense for this - (setq cur-arg (read-char))) - ((eq char ?C) ; Command - (setq cur-arg (intern - (completing-read-with-history-in - hist xprompt obarray 'commandp t nil)))) - ((eq char ?d) ; Value of point. Does not do I/O. - (setq cur-arg (point))) - ((eq char ?D) ; directory name - ;; This does not check file-directory-p, but neither does - ;; call-interactively. - (setq cur-arg (read-file-name-with-history-in - hist - xprompt - nil - default-directory - 'confirm))) - ((eq char ?f) ; existing file name - (setq cur-arg (read-file-name-with-history-in - hist - xprompt - nil nil 'confirm))) - ((eq char ?F) ; possibly nonexistent file name - (setq cur-arg (read-file-name-with-history-in - hist - xprompt))) - ((eq char ?k) ; Key sequence (string) - (setq cur-arg (read-key-sequence (if (equal xprompt "") - nil xprompt)))) - ((eq char ?m) ; Value of mark. Does not do I/O. - (setq cur-arg (or (mark) (error "The mark is not set now")))) - ((eq char ?N) ; Prefix arg, else number from minibuf - (if current-prefix-arg - (setq cur-arg (prefix-numeric-value current-prefix-arg)) - (while (not (integerp - (setq cur-arg - (read-with-history-in hist xprompt nil t))))))) - ((eq char ?n) ; Read number from minibuffer - (while (not (integerp - (setq cur-arg - (read-with-history-in hist xprompt nil t)))))) - ((eq char ?p) ; cooked prefix arg - (setq cur-arg (prefix-numeric-value current-prefix-arg))) - ((eq char ?P) ; raw prefix arg - (setq cur-arg current-prefix-arg)) - ((eq char ?r) ; region - (let (region-min region-max) - ;; take some pains to behave exactly like interactive "r" - (setq region-min (min (or (mark) - (error "The mark is not set now")) - (point)) - region-max (max (or (mark) - (error "The mark is not set now")) - (point))) - (setq args-so-far - (append (list region-max region-min) args-so-far) - special t))) - ((eq char '?s) ; string - (setq cur-arg (read-with-history-in hist xprompt))) - ((eq char ?S) ; any symbol - (setq cur-arg (read-with-history-in hist xprompt nil t))) - ((eq char ?v) ; Variable name - (setq cur-arg (completing-read-with-history-in - hist xprompt obarray 'user-variable-p t nil))) - ((memq char '(?x ?X)) ; lisp expression - (setq cur-arg (read-with-history-in - hist - xprompt - nil - ;; have to tell gmhist to read s-exps - ;; instead of strings: - t)) - (if (eq char ?X) ; lisp expression, evaluated - (setq cur-arg (eval cur-arg)))) - - (t - (error "Invalid control letter `%c' in gmhist-interactive" char))) - (or special - (setq args-so-far (cons cur-arg args-so-far)))) - (reverse args-so-far))) - -(defun gmhist-new-spec (fun &optional hist no-error) - "Return a new interactive specification for FUN, suitable for use -with setcdr in function gmhist-replace-spec. -Use symbol HIST to store the history. HIST defaults to `FUN-history'. -The returned spec does the same as the old one, only with history in HIST. - -If FUN is an autoload object, its file is loaded first. - -See function gmhist-interactive for a list of recognized interactive -keys letters. - -Unless optional third arg NO-ERROR is given, signals an error if FUN's -interactive string contains unknown key letters or has no interactive string. -With NO-ERROR, it returns nil." - (or hist (setq hist (intern (concat (symbol-name fun) "-history")))) - (gmhist-check-autoload fun) - (let ((spec (gmhist-spec fun))) - (if (stringp spec) - (list 'gmhist-interactive spec (list 'quote hist)) - (if no-error - nil - (error "Can't gmhistify %s's spec: %s" fun spec))))) - -(defun gmhist-make-magic (fun &optional hist) - "Make FUN magically maintain minibuffer history in symbol HIST. -HIST defaults to `FUN-history'. -This works by modifying the interactive specification, which must be a -string. For more complicated cases, see gmhist-replace-spec. -The magic goes away when you call gmhist-remove-magic on FUN." - (interactive "CPut gmhist magic on command: ") - (let ((new-spec (gmhist-new-spec fun hist t))) - (if new-spec - (gmhist-replace-spec fun new-spec) - ;; else there was some error. Try to find out if this is a retry. - (if (not (get fun 'gmhist-old-interactive-spec)) - (error "Too complicated for gmhist: %s" fun) - (message "Another attempt to put magic on %s..." fun) - (gmhist-remove-magic fun) ; will abort if not a retry - ;; This time we don't catch errors - magic or blow! - (gmhist-replace-spec fun (gmhist-new-spec fun hist)) - (message "Another attempt to put magic on %s...done." fun))))) - -(defun gmhist-remove-magic (fun) - "Remove the magic that gmhist-make-magic put on FUN, -restoring the old interactive spec." - (interactive "CRemove gmhist magic from command: ") - (gmhist-replace-spec - fun - (or (get fun 'gmhist-old-interactive-spec) - (error "Can't find %s's old interactive spec!" fun)))) - -;; Now make yourself magic -(gmhist-make-magic 'gmhist-make-magic 'gmhist-make-magic-history) -(gmhist-make-magic 'gmhist-remove-magic 'gmhist-make-magic-history) - - -;; Examples, pedagogic and serious ones. More in gmhist-app.el. - -;;(defun foo-command (cmd) -;; (interactive (list -;; (read-with-history-in 'foo-history "Foo: "))) -;; (message "Foo %s" cmd)) -;; -;; ;; The interactive clause could also have been the simpler -;; ;; (interactive (gmhist-interactive "sFoo: " 'foo-history)) -;; -;; -;;;(put 'foo-history 'hist-map minibuffer-local-map) ; disable motion ... -;;;(put 'foo-history 'hist-function 'gmhist-read-nohistory) ; and history -;; -;;(put 'foo-history 'hist-function nil) ; enable history ... -;;(put 'foo-history 'hist-map nil) ; and motion again -;; -;;(defun gmhist-read-nohistory (symbol prompt initial-input read) -;; "An example function to put on the hist-function property." -;; (message "read-nohistory...") -;; (sit-for 2) -;; (read-string prompt initial-input)) -;; -;; Example for reading file names: -;;(defun bar-command (cmd) -;; (interactive -;; (list -;; (read-file-name-with-history-in -;; ;; HIST-SYM PROMPT DIR DFLT MUSTMATCH -;; 'bar-history "Bar: " nil nil 'confirm))) -;; (message "Bar %s" cmd)) -;; -;; Example function to apply gmhist-make-magic to. -;; Compare the missing initial input in bar to the magic version of zod. -;;(defun zod-command (cmd) -;; (interactive "fZod: ") -;; (message "Zod %s" cmd)) - -;; Finally run the load-hook - -(run-hooks 'gmhist-load-hook) - -;; End of file gmhist.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/Makefile --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/Makefile Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,244 @@ +############################################################################### +# +# File: Makefile +# Release: $efs release: 1.15 $ +# Version: $Revision: 1.2 $ +# RCS: +# Description: Makefile for byte-compiling efs and dired. +# Author: Andy Norman, HPLabs, Bristol, UK. +# Created: Sat Jan 30 00:18:56 1993 +# Language: Text (make script) +# +############################################################################### + +## Installation Instructions +############################ +# 1. Edit the configuration variables below. +# EMACS should be the name of the emacs program on your system. +# VERSION should be the emacs version. This must be one of: +# 18 for all versions of Emacs 18. +# 19 for all versions of the original GNU Emacs from FSF between +# 19.1 and 19.22, inclusive. +# 19.23 for version 19.23 and later of the original GNU Emacs from FSF +# l19.11 for XEmacs 19.11 trhu 19.14 +# x19.15 for XEmacs 19.15 and later +# LISPDIR should be the directory in which you want the .elc +# files installed. +# BDIR should be the directory containing the .elc files for the +# byte-compiler. Although efs byte-compiles and works with the +# Emacs V18 byte-compiler, it is strongly recommended to use +# Jamie Zawinski's V19 byte-compiler. This byte-compiler is +# standard with Lucid Emacs, XEmacs, and GNU Emacs V19, so in this +# case you can set BDIR to nothing. +# VMDIR should be set to the directory containing the .elc files for +# VM. If you aren't using VM, then set this to nothing. +# +# 2. To byte-compile the entire package, except for VM support (efs-vm.el), +# run make VERSION, where VERSION is the emacs version that you are +# compiling for. It must be one of: +# 18 for Emacs 18 +# 19 for the original GNU Emacs from FSF, versions 19.1 through +# 19.22, inclusive +# 19.23 for the original GNU Emacs from FSF, version 19.23 and later. +# l19.11 for Lucid XEmacs 19.11 thru 19.14 +# x19.15 for XEmacs 19.15 and later +# +# If you have set the VERSION variable correctly, then typing just +# make will suffice. +# +# 3. To byte-compile everything, including VM support, run make all. +# +# 4. To byte-compile all the efs files, except for VM support, +# run make efs. +# +# 5. To byte-compile only the core efs files run make core. +# +# 6. To byte compile an efs-XXX.el file, run make XXX. +# This means that VM support can be compiled by running make vm. +# +# 7. To byte compile only dired, run make dired. +# +# 8. To byte-compile only efs-auto.el, for autoloading efs, run make auto. +# + +## Edit these variables according to your configuration. + +# Name of Emacs program +EMACS=xemacs +# Emacs version. This must be set to one of 18, 19, 19.23, +# l19.11, x19.15 +VERSION=x19.15 +# Current working directory +CWD=`pwd` +# Directory in which to install the lisp files +LISPDIR= +# Directory containing byte-compiler. This is used by fixup.el +BDIR= +# Directory containing VM's .elc files. +VMDIR= +# Bourne shell executable, please. +SHELL=/bin/sh + +###### It should not be necessary to edit anything below this line. ###### + +COREOBJS = efs-defun.elc efs-ovwrt.elc efs-fnh.elc efs-cu.elc efs-netrc.elc \ + efs.elc efs-dired.elc efs-report.elc \ + efs-cp-p.elc auto-save.elc +DOBJS = default-dir.elc dired.elc dired-mob.elc dired-oas.elc \ + dired-rgxp.elc dired-shell.elc dired-vir.elc dired-xy.elc \ + dired-grep.elc dired-uu.elc \ + dired-cmpr.elc dired-diff.elc dired-help.elc dired-sex.elc +EFSOBJS = $(COREOBJS) efs-auto.elc \ + efs-cms.elc efs-cms-knet.elc efs-dos-distinct.elc efs-nos-ve.elc \ + efs-gwp.elc efs-kerberos.elc efs-hell.elc efs-ka9q.elc \ + efs-mpe.elc efs-mts.elc efs-mvs.elc efs-netware.elc \ + efs-pc.elc efs-ti-explorer.elc efs-ti-twenex.elc \ + efs-tops-20.elc efs-dl.elc efs-guardian.elc efs-coke.elc \ + efs-vms.elc efs-vos.elc efs-plan9.elc efs-ms-unix.elc +VMOBJS = efs-vm.elc +GEOBJS = dired-fsf.elc dired-mule.elc efs-dired-mule.elc +XEOBJS = dired-xemacs.elc +OBJS = $(DOBJS) $(EFSOBJS) $(VMOBJS) $(GEOBJS) $(XEOBJS) \ + efs-l19.11.elc efs-x19.15.elc \ + emacs-19.elc fn-handler.elc + +# fixup.el is never byte-compiled. It would do no harm, but be a waste +# of time. + +## Specify new rules. + +.SUFFIXES: .elc .el .texi .info + +.el.elc: + BDIR=$(BDIR) CWD=$(CWD) VMDIR=$(VMDIR) \ + $(EMACS) -batch -l $(CWD)/fixup -f batch-byte-compile $(CWD)/$< + +.texi.info: + $(EMACS) -batch -f batch-texinfo-format $(CWD)/$< + +## targets + +# What lazy fingers buys you +default: $(VERSION) dired + +# .elc files depend on .el source +# Do this in this brain-dead way because different makes do pattern +# rules differently. grumble grumble... +# +# dired +dired.elc: dired.el +dired-mob.elc: dired-mob.el +dired-oas.elc: dired-oas.el +dired-rgxp.elc: dired-rgxp.el +dired-shell.elc: dired-shell.el +dired-vir.elc: dired-vir.el +dired-xy.elc: dired-xy.el +dired-grep.elc: dired-grep.el +dired-uu.elc: dired-uu.el +dired-fsf.elc: dired-fsf.el +dired-cmpr.elc: dired-cmpr.el +dired-help.elc: dired-help.el +dired-diff.elc: dired-diff.el +dired-sex.elc: dired-sex.el +dired-mule.elc: dired-mule.el +dired-xemacs.elc: dired-xemacs.el +default-dir.elc: default-dir.el +# efs core files +efs.elc: efs.el +efs-defun.elc: efs-defun.el +efs-cp-p.elc: efs-cp-p.el +efs-cu.elc: efs-cu.el +efs-netrc.elc: efs-netrc.el +efs-auto.elc: efs-auto.el +efs-dired.elc: efs-dired.el +efs-dired-mule.elc: efs-dired-mule.el +efs-report.elc: efs-report.el +efs-ovwrt.elc: efs-ovwrt.el +efs-fnh.elc: efs-fnh.el +# efs multi-OS and FTP server support +efs-cms.elc: efs-cms.el +efs-cms-knet.elc: efs-cms-knet.el +efs-coke.elc: efs-coke.el +efs-dos-distinct.elc: efs-dos-distinct.el +efs-nos-ve.elc: efs-nos-ve.el +efs-gwp.elc: efs-gwp.el +efs-hell.elc: efs-hell.el +efs-ka9q.elc: efs-ka9q.el +efs-kerberos.elc: efs-kerberos.el +efs-mpe.elc: efs-mpe.el +efs-mts.elc: efs-mts.el +efs-mvs.elc: efs-mvs.el +efs-netware.elc: efs-netware.el +efs-pc.elc: efs-pc.el +efs-ti-explorer.elc: efs-ti-explorer.el +efs-ti-twenex.elc: efs-ti-twenex.el +efs-tops-20.elc: efs-tops-20.el +efs-dl.elc: efs-dl.el +efs-vms.elc: efs-vms.el +efs-vos.elc: efs-vos.el +efs-guardian.elc: efs-guardian.el +efs-plan9.elc: efs-plan9.el +efs-ms-unix.elc: efs-ms-unix.el +# efs support for different Emacs versions +efs-l19.11.elc: efs-l19.11.el +efs-x19.15.elc: efs-x19.15.el +# efs vm support +efs-vm.elc: efs-vm.el +# backward compatibility files +fn-handler.elc: fn-handler.el +emacs-19.elc: emacs-19.el +# auto-save package +auto-save.elc: auto-save.el + +# Core targets +core: $(COREOBJS) + +# Extra perks +auto: core efs-auto.elc +cms: core efs-cms.elc +cms-knet: core efs-cms-knet.elc +dos-distinct: core efs-dos-distinct.elc +nos-ve: core efs-nos-ve.elc +gwp: core efs-gwp.elc +hell: core efs-hell.elc +ka9q: core efs-ka9q.elc +kerberos: core efs-kerberos.elc +mpe: core efs-mpe.elc +mts: core efs-mts.elc +mvs: core efs-mvs.elc +netware: core efs-netware.elc +pc: core efs-pc.elc +ti-explorer: core efs-ti-explorer.elc +ti-twenex: core efs-ti-twenex.elc +tops-20: core efs-tops-20.elc +dl: core efs-dl.elc +vms: core efs-vms.elc +vos: core efs-vos.elc +guardian: core efs-guardian.elc +plan9: core efs-plan9.elc +coke: core efs-coke.elc +vm: core $(VMOBJS) + +# The grand tour +efs: $(EFSOBJS) +dired: $(DOBJS) +all: $(OBJS) + +# Making for a specific emacs version +l19.11: efs dired efs-l19.11.elc $(XEOBJS) +x19.15: efs dired efs-x19.15.elc $(XEOBJS) + +# Installation +install: + @echo "Installing in $(LISPDIR)..." + @ls -C *.elc + cp *.elc $(LISPDIR) +install_src: + @echo "Installing in $(LISPDIR)..." + @ls -C `ls *.el 2>&1 | grep -v "fixup"` 2> /dev/null + cp `ls *.el | grep -v "fixup"` $(LISPDIR) +install_all: install_src install +clean: + rm -f $(OBJS) + +## end of Makefile ## diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/auto-save.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/auto-save.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,513 @@ +;; -*- Emacs-Lisp -*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: auto-save.el +;; Version: $Revision: 1.2 $ +;; RCS: +;; Description: Safer autosaving with support for efs and /tmp. +;; This version of auto-save is designed to work with efs, +;; instead of ange-ftp. +;; Author: Sebastian Kremer , +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defconst auto-save-version (substring "$Revision: 1.2 $" 11 -2) + "Version number of auto-save.") + +;;; Copyright (C) 1992 by Sebastian Kremer + +;;; 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 1, 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; if not, write to the Free Software +;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;;; OVERVIEW ========================================================== + +;;; Combines autosaving for efs (to a local or remote directory) +;;; with the ability to do autosaves to a fixed directory on a local +;;; disk, in case NFS is slow. The auto-save file used for +;;; /usr/foo/bar/baz.txt +;;; will be +;;; AUTOSAVE/#\!usr\!foo\!bar\!baz.txt# +;;; assuming AUTOSAVE is the non-nil value of the variable +;;; `auto-save-directory'. + +;;; Takes care that autosave files for non-file-buffers (e.g. *mail*) +;;; from two simultaneous Emacses don't collide. + +;;; Autosaves even if the current directory is not writable. + +;;; Can limit autosave names to 14 characters using a hash function, +;;; see `auto-save-hash-p'. + +;;; See `auto-save-directory' and `make-auto-save-file-name' and +;;; references therein for complete documentation. + +;;; Meta-x recover-all-files will effectively do recover-file on all +;;; files whose autosave file is newer (one of the benefits of having +;;; all autosave files in the same place). + +;;;; INSTALLATION ====================================================== + +;;; Put this file into your load-path and the following in your ~/.emacs: + +;;; If you want to autosave in the fixed directory /tmp/USER-autosave/ +;;; (setq auto-save-directory +;;; (concat "/tmp/" (user-login-name) "-autosave/")) + +;;; If you don't want to save in /tmp (e.g., because it is swap +;;; mounted) but rather in ~/autosave/ +;;; (setq auto-save-directory (expand-file-name "~/autosave/")) + +;;; If you want to save each file in its own directory (the default) +;;; (setq auto-save-directory nil) +;;; You still can take advantage of autosaving efs remote files +;;; in a fixed local directory, `auto-save-directory-fallback' will +;;; be used. + +;;; If you want to use 14 character hashed autosave filenames +;;; (setq auto-save-hash-p t) + +;;; Finally, put this line after the others in your ~/.emacs: +;;; (require 'auto-save) + + +;;;; ACKNOWLEDGEMENT =================================================== + +;;; This code is loosely derived from autosave-in-tmp.el by Jamie +;;; Zawinski (the version I had was last modified 22 +;;; dec 90 jwz) and code submitted to ange-ftp-lovers on Sun, 5 Apr +;;; 92 23:20:47 EDT by drw@BOURBAKI.MIT.EDU (Dale R. Worley). +;;; auto-save.el tries to cover the functionality of those two +;;; packages. + +;;; Valuable comments and help from Dale Worley, Andy Norman, Jamie +;;; Zawinski and Sandy Rutherford are gratefully acknowledged. + +;;;; PROVISION ======================================================== + +(provide 'auto-save) + +;;;; CUSTOMIZATION ===================================================== + +(defvar auto-save-directory nil + + ;;; Don't make this user-variable-p, it should be set in .emacs and + ;;; left at that. In particular, it should remain constant across + ;;; several Emacs session to make recover-all-files work. + + "If non-nil, fixed directory for autosaving: all autosave files go +there. If this directory does not yet exist at load time, it is +created and its mode is set to 0700 so that nobody else can read your +autosave files. + +If nil, each autosave files goes into the same directory as its +corresponding visited file. + +A non-nil `auto-save-directory' could be on a local disk such as in +/tmp, then auto-saves will always be fast, even if NFS or the +automounter is slow. In the usual case of /tmp being locally mounted, +note that if you run emacs on two different machines, they will not +see each other's auto-save files. + +The value \(expand-file-name \"~/autosave/\"\) might be better if /tmp +is mounted from swap (possible in SunOS, type `df /tmp' to find out) +and thus vanishes after a reboot, or if your system is particularly +thorough when cleaning up /tmp, clearing even non-empty subdirectories. + +It should never be an efs remote filename because that would +defeat `efs-auto-save-remotely'. + +Unless you set `auto-save-hash-p', you shouldn't set this to a +directory in a filesystem that does not support long filenames, since +a file named + + /home/sk/lib/emacs/lisp/auto-save.el + +will have a longish filename like + + AUTO-SAVE-DIRECTORY/#\\!home\\!sk\\!lib\\!emacs\\!lisp\\!auto-save.el# + +as auto save file. + +See also variables `auto-save-directory-fallback', +`efs-auto-save' and `efs-auto-save-remotely'.") + +(defvar auto-save-hash-p nil + "If non-nil, hashed autosave names of length 14 are used. +This is to avoid autosave filenames longer than 14 characters. +The directory used is `auto-save-hash-directory' regardless of +`auto-save-directory'. +Hashing defeats `recover-all-files', you have to recover files +individually by doing `recover-file'.") + +;;; This defvar is in efs.el now, but doesn't hurt to give it here as +;;; well so that loading first auto-save.el does not abort. +(or (boundp 'efs-auto-save) (defvar efs-auto-save 0)) +(or (boundp 'efs-auto-save-remotely) (defvar efs-auto-save-remotely nil)) + +(defvar auto-save-offer-delete nil + "*If non-nil, `recover-all-files' offers to delete autosave files +that are out of date or were dismissed for recovering. +Special value 'always deletes those files silently.") + +;;;; end of customization + + +;;; Preparations to be done at load time + +(defvar auto-save-directory-fallback (expand-file-name "~/autosave/") + ;; not user-variable-p, see above + "Directory used for local autosaving of remote files if +both `auto-save-directory' and `efs-auto-save-remotely' are nil. +Also used if a working directory to be used for autosaving is not writable. +This *must* always be the name of directory that exists or can be +created by you, never nil.") + +(defvar auto-save-hash-directory + (expand-file-name "hash/" (or auto-save-directory + auto-save-directory-fallback)) + "If non-nil, directory used for hashed autosave filenames.") + +(defun auto-save-check-directory (var) + (let ((dir (symbol-value var))) + (if (null dir) + nil + ;; Expand and store back into the variable + (set var (setq dir (expand-file-name dir))) + ;; Make sure directory exists + (if (file-directory-p dir) + nil + ;; Else we create and chmod 0700 the directory + (setq dir (directory-file-name dir)) ; some systems need this + (if (fboundp 'make-directory) ; V19 or tree dired + (make-directory dir) + (call-process "mkdir" nil nil nil dir)) + (set-file-modes dir (* 7 8 8)))))) + +(mapcar (function auto-save-check-directory) + '(auto-save-directory auto-save-directory-fallback)) + +(and auto-save-hash-p + (auto-save-check-directory 'auto-save-hash-directory)) + + +;;; Computing an autosave name for a file and vice versa + +(defun make-auto-save-file-name ();; redefines files.el + ;; auto-save-file-name-p need not be redefined. + + "Return file name to use for auto-saves of current buffer. +Does not consider `auto-save-visited-file-name'; that is checked +before calling this function. + +Offers to autosave all files in the same `auto-save-directory'. All +autosave files can then be recovered at once with function +`recover-all-files'. + +Takes care to make autosave files for files accessed through efs +be local files if variable `efs-auto-save-remotely' is nil. + +Takes care of slashes in buffer names to prevent autosave errors. + +Takes care that autosave files for buffers not visiting any file (such +as `*mail*') from two simultaneous Emacses don't collide by prepending +the Emacs pid. + +Uses 14 character autosave names if `auto-save-hash-p' is true. + +Autosaves even if the current directory is not writable, using +directory `auto-save-directory-fallback'. + +You can redefine this for customization (he he :-). +See also function `auto-save-file-name-p'." + + ;; We have to be very careful about not signalling an error in this + ;; function since files.el does not provide for this (e.g. find-file + ;; would fail for each new file). + + (condition-case error-data + (let* ((file-name (or (and (boundp 'buffer-file-truename) + buffer-file-truename + ;; Make sure that the file name is expanded. + (expand-file-name buffer-file-name)) + (and buffer-file-name + (expand-file-name buffer-file-name)))) + ;; So autosavename looks like #%...#, roughly as with the + ;; old make-auto-save-file-name function. The + ;; make-temp-name inserts the pid of this Emacs: this + ;; avoids autosaving from two Emacses into the same file. + ;; It cannot be recovered automatically then because in + ;; the next Emacs session (the one after the crash) the + ;; pid will be different, but file-less buffers like + ;; *mail* must be recovered manually anyway. + (name-prefix (if file-name nil (make-temp-name "#%"))) + (save-name (or file-name + ;; Prevent autosave errors. Buffername + ;; (to become non-dir part of filename) will + ;; be unslashified twice. Don't care. + (auto-save-unslashify-name (buffer-name)))) + (remote-p (and (stringp file-name) + (fboundp 'efs-ftp-path) + (efs-ftp-path file-name)))) + ;; Return the appropriate auto save file name: + (expand-file-name;; a buffername needs this, a filename not + (if remote-p + (if efs-auto-save-remotely + (auto-save-name-in-same-directory save-name) + ;; We have to use the `fixed-directory' now since the + ;; `same-directory' would be remote. + ;; It will use the fallback if needed. + (auto-save-name-in-fixed-directory save-name)) + ;; Else it is a local file (or a buffer without a file, hence + ;; the name-prefix). + ;; Hashed files always go into the special hash dir, never + ;; in the same directory, to make recognizing reliable. + (if (or auto-save-directory auto-save-hash-p) + (auto-save-name-in-fixed-directory save-name name-prefix) + (auto-save-name-in-same-directory save-name name-prefix))))) + + ;; If any error occurs in the above code, return what the old + ;; version of this function would have done. It is not ok to + ;; return nil, e.g., when after-find-file tests + ;; file-newer-than-file-p, nil would bomb. + + (error (progn + (message "make-auto-save-file-name %s" error-data) + (sit-for 2) + (if buffer-file-name + (concat (file-name-directory buffer-file-name) + "#" + (file-name-nondirectory buffer-file-name) + "#") + (expand-file-name (concat "#%" (buffer-name) "#"))))))) + +(defun auto-save-original-name (savename) + "Reverse of `make-auto-save-file-name'. +Returns nil if SAVENAME was not associated with a file (e.g., it came +from an autosaved `*mail*' buffer) or does not appear to be an +autosave file at all. +Hashed files are not understood, see `auto-save-hash-p'." + (let ((basename (file-name-nondirectory savename)) + (savedir (file-name-directory savename))) + (cond ((or (not (auto-save-file-name-p basename)) + (string-match "^#%" basename)) + nil) + ;; now we know it looks like #...# thus substring is safe to use + ((or (equal savedir auto-save-directory) ; 2nd arg may be nil + (equal savedir auto-save-directory-fallback)) + ;; it is of the `-fixed-directory' type + (auto-save-slashify-name (substring basename 1 -1))) + (t + ;; else it is of `-same-directory' type + (concat savedir (substring basename 1 -1)))))) + +(defun auto-save-name-in-fixed-directory (filename &optional prefix) + ;; Unslashify and enclose the whole FILENAME in `#' to make an auto + ;; save file in the auto-save-directory, or if that is nil, in + ;; auto-save-directory-fallback (which must be the name of an + ;; existing directory). If the results would be too long for 14 + ;; character filenames, and `auto-save-hash-p' is set, hash FILENAME + ;; into a shorter name. + ;; Optional PREFIX is string to use instead of "#" to prefix name. + (let ((base-name (concat (or prefix "#") + (auto-save-unslashify-name filename) + "#"))) + (if (and auto-save-hash-p + auto-save-hash-directory + (> (length base-name) 14)) + (expand-file-name (auto-save-cyclic-hash-14 filename) + auto-save-hash-directory) + (expand-file-name base-name + (or auto-save-directory + auto-save-directory-fallback))))) + +(defun auto-save-name-in-same-directory (filename &optional prefix) + ;; Enclose the non-directory part of FILENAME in `#' to make an auto + ;; save file in the same directory as FILENAME. But if this + ;; directory is not writable, use auto-save-directory-fallback. + ;; FILENAME is assumed to be in non-directory form (no trailing slash). + ;; It may be a name without a directory part (pesumably it really + ;; comes from a buffer name then), the fallback is used then. + ;; Optional PREFIX is string to use instead of "#" to prefix name. + (let ((directory (file-name-directory filename))) + (or (null directory) + (file-writable-p directory) + (setq directory auto-save-directory-fallback)) + (concat directory ; (concat nil) is "" + (or prefix "#") + (file-name-nondirectory filename) + "#"))) + +(defun auto-save-unslashify-name (s) + ;; "Quote any slashes in string S by replacing them with the two + ;;characters `\\!'. + ;;Also, replace any backslash by double backslash, to make it one-to-one." + (let ((limit 0)) + (while (string-match "[/\\]" s limit) + (setq s (concat (substring s 0 (match-beginning 0)) + (if (string= (substring s + (match-beginning 0) + (match-end 0)) + "/") + "\\!" + "\\\\") + (substring s (match-end 0)))) + (setq limit (1+ (match-end 0))))) + s) + +(defun auto-save-slashify-name (s) + ;;"Reverse of `auto-save-unslashify-name'." + (let (pos) + (while (setq pos (string-match "\\\\[\\!]" s pos)) + (setq s (concat (substring s 0 pos) + (if (eq ?! (aref s (1+ pos))) "/" "\\") + (substring s (+ pos 2))) + pos (1+ pos)))) + s) + + +;;; Hashing for autosave names + +;;; Hashing function contributed by Andy Norman +;;; based upon C code from pot@fly.cnuce.cnr.IT (Francesco Potorti`). + +(defun auto-save-cyclic-hash-14 (s) + ;; "Hash string S into a string of length 14. + ;; A 7-bytes cyclic code for burst correction is calculated on a + ;; byte-by-byte basis. The polynomial used is D^7 + D^6 + D^3 +1. + ;; The resulting string consists of hexadecimal digits [0-9a-f]. + ;; In particular, it contains no slash, so it can be used as autosave name." + (let ((crc (make-string 7 0)) + result) + (mapcar + (function + (lambda (new) + (setq new (+ new (aref crc 6))) + (aset crc 6 (+ (aref crc 5) new)) + (aset crc 5 (aref crc 4)) + (aset crc 4 (aref crc 3)) + (aset crc 3 (+ (aref crc 2) new)) + (aset crc 2 (aref crc 1)) + (aset crc 1 (aref crc 0)) + (aset crc 0 new))) + s) + (setq result (format "%02x%02x%02x%02x%02x%02x%02x" + (aref crc 0) + (aref crc 1) + (aref crc 2) + (aref crc 3) + (aref crc 4) + (aref crc 5) + (aref crc 6))) + result)) + +;; This leaves two characters that could be used to wrap it in `#' or +;; make two filenames from it: one for autosaving, and another for a +;; file containing the name of the autosaved filed, to make hashing +;; reversible. +(defun auto-save-cyclic-hash-12 (s) + "Outputs the 12-characters ascii hex representation of a 6-bytes +cyclic code for burst correction calculated on STRING on a +byte-by-byte basis. The used polynomial is D^6 + D^5 + D^4 + D^3 +1." + (let ((crc (make-string 6 0))) + (mapcar + (function + (lambda (new) + (setq new (+ new (aref crc 5))) + (aset crc 5 (+ (aref crc 4) new)) + (aset crc 4 (+ (aref crc 3) new)) + (aset crc 3 (+ (aref crc 2) new)) + (aset crc 2 (aref crc 1)) + (aset crc 1 (aref crc 0)) + (aset crc 0 new))) + s) + (format "%02x%02x%02x%02x%02x%02x" + (aref crc 0) + (aref crc 1) + (aref crc 2) + (aref crc 3) + (aref crc 4) + (aref crc 5)))) + + + +;;; Recovering files + +(defun recover-all-files (&optional silent) + "Do recover-file for all autosave files which are current. +Only works if you have a non-nil `auto-save-directory'. + +Optional prefix argument SILENT means to be silent about non-current +autosave files. This is useful if invoked automatically at Emacs +startup. + +If `auto-save-offer-delete' is t, this function will offer to delete +old or rejected autosave files. + +Hashed files (see `auto-save-hash-p') are not understood, use +`recover-file' to recover them individually." + (interactive "P") + (let ((savefiles (directory-files auto-save-directory t "^#")) + afile ; the auto save file + file ; its original file + (total 0) ; # of files offered to recover + (count 0)) ; # of files actually recovered + (or (equal auto-save-directory auto-save-directory-fallback) + (setq savefiles + (append savefiles + (directory-files auto-save-directory-fallback t "^#")))) + (while savefiles + (setq afile (car savefiles) + file (auto-save-original-name afile) + savefiles (cdr savefiles)) + (cond ((and file (not (file-newer-than-file-p afile file))) + (message "autosave file \"%s\" is not current." afile) + (sit-for 2)) + (t + (setq total (1+ total)) + (with-output-to-temp-buffer "*Directory*" + (call-process "ls" nil standard-output nil + "-l" afile (if file (list file)))) + (if (yes-or-no-p (format "Recover %s from auto save file? " + file)) + (let* ((obuf (current-buffer)) + (buf (set-buffer + (if file + (find-file-noselect file t) + (generate-new-buffer "*recovered*")))) + (buffer-read-only nil)) + (erase-buffer) + (insert-file-contents afile nil) + (condition-case () + (after-find-file nil) + (error nil)) + (setq buffer-auto-save-file-name nil) + (setq count (1+ count)) + (message "\ +Auto-save off in buffer \"%s\" till you do M-x auto-save-mode." + (buffer-name)) + (set-buffer obuf) + (sit-for 1)) + ;; If not used for recovering, offer to delete + ;; autosave file + (and auto-save-offer-delete + (or (eq 'always auto-save-offer-delete) + (yes-or-no-p + (format "Delete autosave file for `%s'? " file))) + (delete-file afile)))))) + (if (zerop total) + (or silent (message "Nothing to recover.")) + (message "%d/%d file%s recovered." count total (if (= count 1) "" "s")))) + (if (get-buffer "*Directory*") (kill-buffer "*Directory*"))) + +;;; end of auto-save.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/default-dir.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/default-dir.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,346 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: default-dir.el +;; RCS: +;; Version: $Revision: 1.5 $ +;; Description: Defines the function default-directory, for fancy handling +;; of the initial contents in the minibuffer when reading +;; file names. +;; Authors: Sebastian Kremer +;; Sandy Rutherford +;; Created: Sun Jul 18 11:38:06 1993 by sandy on ibm550 +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; 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 1, 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 GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +(provide 'default-dir) +(require 'efs-ovwrt) + +(defconst default-dir-emacs-variant + (cond ((string-match "XEmacs" emacs-version) 'xemacs) + ((>= (string-to-int (substring emacs-version 0 2)) 19) 'fsf-19) + (t 'fsf-18))) + +;;;###autoload +(defvar default-directory-function nil + "A function to call to compute the default-directory for the current buffer. +If this is nil, the function default-directory will return the value of the +variable default-directory. +Buffer local.") +(make-variable-buffer-local 'default-directory-function) + +;; As a bonus we give shell-command history if possible. +(defvar shell-command-history nil + "History list of previous shell commands.") + +(defun default-directory () + " Returns the default-directory for the current buffer. +Will use the variable default-directory-function if it non-nil." + (if default-directory-function + (funcall default-directory-function) + (if (eq default-dir-emacs-version 'xemacs) + (abbreviate-file-name default-directory t) + (abbreviate-file-name default-directory)))) + +;;; Overloads + +(if (or (featurep 'mule) + (boundp 'MULE)) + (progn + + (defun default-dir-find-file (file &optional coding-system) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Find file: " (default-directory))) + (and current-prefix-arg + (read-coding-system "Coding-system: ")))) + (default-dir-real-find-file file coding-system)) + + (defun default-dir-find-file-other-window (file &optional coding-system) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Find file in other window: " (default-directory))) + (and current-prefix-arg + (read-coding-system "Coding-system: ")))) + (default-dir-real-find-file-other-window file coding-system)) + + (defun default-dir-find-file-read-only (file &optional coding-system) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Find file read-only: " (default-directory) nil t)) + (and current-prefix-arg + (read-coding-system "Coding-system: ")))) + (default-dir-real-find-file-read-only file coding-system)) + + (if (fboundp 'find-file-read-only-other-window) + (progn + (defun default-dir-find-file-read-only-other-window + (file &optional coding-system) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name + "Find file read-only in other window: " + (default-directory) nil t)) + (and current-prefix-arg + (read-coding-system "Coding-system: ")))) + (default-dir-real-find-file-read-only-other-window file + coding-system)))) + + (if (fboundp 'find-file-other-frame) + (progn + (defun default-dir-find-file-other-frame + (file &optional coding-system) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Find file in other frame: " + (default-directory))) + (and current-prefix-arg + (read-coding-system "Coding-system: ")))) + (default-dir-real-find-file-other-frame file + coding-system)))) + + (if (fboundp 'find-file-read-only-other-frame) + (progn + (defun default-dir-find-file-read-only-other-frame + (file &optional coding-system) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Find file read-only in other frame: " + (default-directory) nil t)) + (and current-prefix-arg + (read-coding-system "Coding-system: ")))) + (default-dir-real-find-file-read-only-other-frame file + coding-system))))) + + (defun default-dir-find-file (file) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Find file: " (default-directory))))) + (default-dir-real-find-file file)) + + (defun default-dir-find-file-other-window (file) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Find file in other window: " (default-directory))))) + (default-dir-real-find-file-other-window file)) + + (defun default-dir-find-file-read-only (file) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Find file read-only: " (default-directory) nil t)))) + (default-dir-real-find-file-read-only file)) + + (if (fboundp 'find-file-read-only-other-window) + (progn + (defun default-dir-find-file-read-only-other-window (file) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name + "Find file read-only in other window: " + (default-directory) nil t)))) + (default-dir-real-find-file-read-only-other-window file)))) + + (if (fboundp 'find-file-other-frame) + (progn + (defun default-dir-find-file-other-frame (file) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Find file in other frame: " + (default-directory))))) + (default-dir-real-find-file-other-frame file)))) + + (if (fboundp 'find-file-read-only-other-frame) + (progn + (defun default-dir-find-file-read-only-other-frame (file) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Find file read-only in other frame: " + (default-directory) nil t)))) + (default-dir-real-find-file-read-only-other-frame file))))) + +(efs-overwrite-fn "default-dir" 'find-file 'default-dir-find-file) +(efs-overwrite-fn "default-dir" 'find-file-other-window + 'default-dir-find-file-other-window) +(if (fboundp 'find-file-other-frame) + (efs-overwrite-fn "default-dir" 'find-file-other-frame + 'default-dir-find-file-other-frame)) +(efs-overwrite-fn "default-dir" 'find-file-read-only + 'default-dir-find-file-read-only) +(if (fboundp 'find-file-read-only-other-window) + (efs-overwrite-fn "default-dir" 'find-file-read-only-other-window + 'default-dir-find-file-read-only-other-window)) +(if (fboundp 'find-file-read-only-other-frame) + (efs-overwrite-fn "default-dir" 'find-file-read-only-other-frame + 'default-dir-find-file-read-only-other-frame)) + + +(defun default-dir-load-file (file) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Load file: " (default-directory) nil t)))) + (default-dir-real-load-file file)) + +(efs-overwrite-fn "default-dir" 'load-file 'default-dir-load-file) + +(require 'view) + +(defun default-dir-view-file (file) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "View file: " (default-directory) nil t)))) + (default-dir-real-view-file file)) + +(efs-overwrite-fn "default-dir" 'view-file 'default-dir-view-file) + +(if (fboundp 'view-file-other-window) + (progn + (defun default-dir-view-file-other-window (file) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "View file in other window: " + (default-directory) nil t)))) + (default-dir-real-view-file-other-window file)) + (efs-overwrite-fn "default-dir" 'view-file-other-window + 'default-dir-view-file-other-window))) + +(if (fboundp 'view-file-other-frame) + (progn + (defun default-dir-view-file-other-frame (file) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "View file in other frame: " + (default-directory) nil t)))) + (default-dir-real-view-file-other-frame file)) + (efs-overwrite-fn "default-dir" 'view-file-other-frame + 'default-dir-view-file-other-frame))) + + +(defun default-dir-shell-command (command &optional insert) + "Documented as original" + (interactive + (list + (let ((prompt (format "Shell command in %s: " (default-directory)))) + (cond + ((memq default-dir-emacs-variant '(fsf-19 xemacs)) + (read-from-minibuffer prompt nil nil nil + 'shell-command-history)) + ((featurep 'gmhist) + (let ((minibuffer-history-symbol 'shell-command-history)) + (read-string prompt))) + (t (read-string prompt)))) + current-prefix-arg)) + (let ((default-directory (expand-file-name (default-directory)))) + (default-dir-real-shell-command command insert))) + +(efs-overwrite-fn "default-dir" 'shell-command 'default-dir-shell-command) + +;; Is advice about? +(if (featurep 'advice) + (defadvice cd (before default-dir-cd activate compile) + (interactive + (list + (expand-file-name + (read-file-name "Change default directory: " (default-directory)))))) + + (defun default-dir-cd (dir) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Change default directory: " (default-directory))))) + (default-dir-real-cd dir)) + + (efs-overwrite-fn "default-dir" 'cd 'default-dir-cd)) + +(defun default-dir-set-visited-file-name (filename) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Set visited file name: " (default-directory))))) + (default-dir-real-set-visited-file-name filename)) + +(efs-overwrite-fn "default-dir" 'set-visited-file-name + 'default-dir-set-visited-file-name) + +(defun default-dir-insert-file (filename &rest args) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Insert file: " (default-directory) nil t)))) + (apply 'default-dir-real-insert-file filename args)) + +(efs-overwrite-fn "default-dir" 'insert-file 'default-dir-insert-file) + +(defun default-dir-append-to-file (start end filename &rest args) + "Documented as original" + (interactive + (progn + (or (mark) (error "The mark is not set now")) + (list + (min (mark) (point)) + (max (mark) (point)) + (expand-file-name + (read-file-name "Append to file: " (default-directory)))))) + (apply 'default-dir-real-append-to-file start end filename args)) + +(efs-overwrite-fn "default-dir" 'append-to-file 'default-dir-append-to-file) + +(defun default-dir-delete-file (file) + "Documented as original" + (interactive + (list + (expand-file-name + (read-file-name "Delete file: " (default-directory) nil t)))) + (default-dir-real-delete-file file)) + +(efs-overwrite-fn "default-dir" 'delete-file 'default-dir-delete-file) + +;;; end of default-dir.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/dired-cmpr.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-cmpr.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,315 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-cmpr.el +;; Dired Version: $Revision: 1.1 $ +;; RCS: +;; Description: Commands for compressing marked files. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Requirements and provisions +(provide 'dired-cmpr) +(require 'dired) + +;;; Entry points. + +(defun dired-do-compress (&optional arg files) + "Compress or uncompress marked (or next ARG) files. +With a zero prefix, prompts for a new value of `dired-compression-method'." + (interactive + (let ((arg (prefix-numeric-value current-prefix-arg)) + files) + (if (zerop arg) + (let ((new (completing-read + (format "Set compression method (currently %s): " + dired-compression-method) + (mapcar + (function + (lambda (x) + (cons (symbol-name (car x)) nil))) + dired-compression-method-alist) + nil t))) + (or (string-equal new "") + (setq dired-compression-method (intern new)))) + (setq files (dired-get-marked-files nil current-prefix-arg)) + (or (memq 'compress dired-no-confirm) + (let* ((dir (dired-current-directory)) + (rfiles (mapcar (function + (lambda (fn) + (dired-make-relative fn dir t))) + files)) + (prompt "") + (comp 0) + (uncomp nil) + (total (length files)) + elt) + (mapcar (function + (lambda (fn) + (if (listp (setq elt + (dired-make-compressed-filename fn))) + (let* ((method (car (nth 3 elt))) + (count (assoc method uncomp))) + (if count + (setcdr count (1+ (cdr count))) + (setq uncomp (cons (cons method 1) uncomp)))) + (setq comp (1+ comp))))) + files) + (if (/= comp 0) + (setq prompt + (format "%s %d" + (car + (nth 2 + (assq dired-compression-method + dired-compression-method-alist))) + comp))) + (if uncomp + (let ((case-fold-search t) + method) + (or (string-equal prompt "") + (setq prompt (concat prompt "; "))) + (setq uncomp + (sort + (mapcar + (function + (lambda (elt) + (setq method (car elt)) + (if (string-equal method "gzip") + (setq method "gunzip") + (or (string-match "^un" method) + (setq method (concat "un" method)))) + (setcar elt method) + elt)) + uncomp) + (function + (lambda (x y) + (string< (car x) (car y)))))) + (setq prompt + (concat prompt + (mapconcat + (function + (lambda (elt) + (format "%s %d" (car elt) (cdr elt)))) + uncomp ", "))))) + (cond + ((= (length rfiles) 1) + (setq prompt (format "%s %s? " + ;; Don't need the number 1 + (substring prompt 0 -2) + (car rfiles)))) + ((or (> (length uncomp) 1) (and (/= 0 comp) uncomp)) + (setq prompt (format "%s? Total: %d file%s " prompt total + (dired-plural-s total)))) + ((setq prompt (format "%s file%s? " prompt + (dired-plural-s total))))) + (or (dired-mark-pop-up nil 'compress rfiles 'y-or-n-p prompt) + (setq arg 0))))) + (list arg files))) + + (if (not (zerop arg)) + (dired-create-files + 'dired-compress-file + "Compress or Uncompress" + files + (function + (lambda (fn) + (let ((cfn (dired-make-compressed-filename fn))) + (if (stringp cfn) + cfn + (substring fn 0 (- (length (nth 1 cfn)))))))) + dired-keep-marker-compress nil t))) + +(defun dired-compress-subdir-files (&optional uncompress) + "Compress all uncompressed files in the current subdirectory. +With a prefix argument uncompresses all compressed files." + (interactive "P") + (let ((dir (dired-current-directory)) + files methods uncomp elt) + (save-excursion + (save-restriction + (narrow-to-region (dired-subdir-min) (dired-subdir-max)) + (dired-map-dired-file-lines + (function + (lambda (f) + (if uncompress + (and (listp (setq uncomp (dired-make-compressed-filename f))) + (let ((program (car (nth 3 uncomp)))) + (setq files (cons f files)) + (if (setq elt (assoc program methods)) + (setcdr elt (1+ (cdr elt))) + (setq methods (cons (cons program 1) methods))))) + (and (stringp (dired-make-compressed-filename f)) + (setq files (cons f files))))))))) + (if files + (let ((total (length files)) + (rfiles (mapcar + (function + (lambda (fn) + (dired-make-relative fn dir t))) + files)) + prompt) + (if uncompress + (progn + (setq prompt (mapconcat + (function + (lambda (x) + (format "%s %d" + (if (string-equal (car x) "gzip") + "gunzip" + (if (string-match "^un" (car x)) + (car x) + (concat "un" (car x)))) + (cdr x)))) + methods ", ")) + (cond + ((= total 1) + (setq prompt + (concat (substring prompt 0 -1) (car rfiles) "? "))) + ((= (length methods) 1) + (setq prompt + (format "%s file%s? " prompt (dired-plural-s total)))) + (t + (setq prompt (format "%s? Total: %d file%s " prompt total + (dired-plural-s total)))))) + (setq prompt + (if (= total 1) + (format "%s %s? " dired-compression-method (car rfiles)) + (format "%s %d file%s? " + dired-compression-method total + (dired-plural-s total))))) + (if (dired-mark-pop-up nil 'compress rfiles 'y-or-n-p prompt) + (dired-create-files + 'dired-compress-file + "Compress or Uncompress" + files + (function + (lambda (fn) + (let ((cfn (dired-make-compressed-filename fn))) + (if (stringp cfn) + cfn + (substring fn 0 (- (length (nth 1 cfn)))))))) + dired-keep-marker-compress nil t))) + (message "No files need %scompressing in %s." + (if uncompress "un" "") + (dired-abbreviate-file-name dir))))) + +(defun dired-compress-file (file ok-flag) + ;; Compress or uncompress FILE. + ;; If ok-flag is non-nil, it is OK to overwrite an existing + ;; file. How well this actually works may depend on the compression + ;; program. + ;; Return the name of the compressed or uncompressed file. + (let ((handler (find-file-name-handler file 'dired-compress-file))) + (if handler + (funcall handler 'dired-compress-file file ok-flag) + (let ((compressed-fn (dired-make-compressed-filename file)) + (err-buff (get-buffer-create " *dired-check-process output*"))) + (save-excursion + (set-buffer err-buff) + (erase-buffer) + (cond ((file-symlink-p file) + (signal 'file-error (list "Error compressing file" + file "a symbolic link"))) + ((listp compressed-fn) + (message "Uncompressing %s..." file) + (let* ((data (nth 3 compressed-fn)) + (ret + (apply 'call-process + (car data) file t nil + (append (cdr data) + (and ok-flag + (list (nth 4 compressed-fn))) + (list file))))) + (if (or (and (integerp ret) (/= ret 0)) + (not (bobp))) + (signal 'file-error + (nconc + (list "Error uncompressing file" + file) + (and (not (bobp)) + (list + (progn + (goto-char (point-min)) + (buffer-substring + (point) (progn (end-of-line) + (point)))))))))) + (message "Uncompressing %s...done" file) + (dired-remove-file file) + (let ((to (substring file 0 + (- (length (nth 1 compressed-fn)))))) + ;; rename any buffers + (and (get-file-buffer file) + (save-excursion + (set-buffer (get-file-buffer file)) + (let ((modflag (buffer-modified-p))) + ;; kills write-file-hooks + (set-visited-file-name to) + (set-buffer-modified-p modflag)))) + to)) + ((stringp compressed-fn) + (message "Compressing %s..." file) + (let* ((data (assq dired-compression-method + dired-compression-method-alist)) + (compr-args (nth 2 data)) + (ret + (apply 'call-process + (car compr-args) file t nil + (append (cdr compr-args) + (and ok-flag + (list (nth 4 data))) + (list file))))) + (if (or (and (integerp ret) (/= ret 0)) + (not (bobp))) + (signal 'file-error + (nconc + (list "Error compressing file" + file) + (and (not (bobp)) + (list + (progn + (goto-char (point-min)) + (buffer-substring + (point) (progn (end-of-line) + (point)))))))))) + (message "Compressing %s...done" file) + (dired-remove-file file) + ;; rename any buffers + (and (get-file-buffer file) + (save-excursion + (set-buffer (get-file-buffer file)) + (let ((modflag (buffer-modified-p))) + ;; kills write-file-hooks + (set-visited-file-name compressed-fn) + (set-buffer-modified-p modflag)))) + compressed-fn) + (t (error "Strange error in dired-compress-file.")))))))) + +(defun dired-make-compressed-filename (name &optional method) + ;; If NAME is in the syntax of a compressed file (according to + ;; dired-compression-method-alist), return the data (a list) from this + ;; alist on how to uncompress it. Otherwise, return a string, the + ;; compressed form of this file name. This is computed using the optional + ;; argument METHOD (a symbol). If METHOD is nil, the ambient value of + ;; dired-compression-method is used. + (let ((handler (find-file-name-handler + name 'dired-make-compressed-filename))) + (if handler + (funcall handler 'dired-make-compressed-filename name method) + (let ((alist dired-compression-method-alist) + (len (length name)) + ext ext-len result) + (while alist + (if (and (> len + (setq ext-len (length (setq ext (nth 1 (car alist)))))) + (string-equal ext (substring name (- ext-len)))) + (setq result (car alist) + alist nil) + (setq alist (cdr alist)))) + (or result + (concat name + (nth 1 (or (assq (or method dired-compression-method) + dired-compression-method-alist) + (error "Unknown compression method: %s" + (or method dired-compression-method)))))) + )))) + +;;; end of dired-cmpr.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/dired-diff.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-diff.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,164 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-diff.el +;; RCS: +;; Dired Version: $Revision: 1.1 $ +;; Description: Support for diff and related commands. +;; Author: Sandy Rutherford +;; Created: Fri Jun 24 08:50:20 1994 by sandy on ibm550 +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; 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 1, 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. +;;; +;;; A copy of the GNU General Public License can be obtained from this +;;; program's author (send electronic mail to sandy@ibm550.sissa.it) or +;;; from the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, +;;; MA 02139, USA. + +(provide 'dired-diff) +(require 'dired) + +(defvar emerge-last-dir-input) +(defvar emerge-last-dir-output) +(defvar emerge-last-dir-ancestor) +(defvar diff-switches) + +(defun dired-diff-read-file-name (prompt) + ;; Read and return a file name for diff. + (let* ((mark-active t) + (default (and (mark) + (save-excursion + (goto-char (mark)) + (dired-get-filename nil t))))) + (read-file-name (format "%s %s with: %s" + prompt (dired-get-filename 'no-dir) + (if default + (concat "[" + (dired-make-relative + default + (dired-current-directory) t) + "] ") + "")) + (default-directory) default t))) + +(defun dired-diff-read-switches (switchprompt) + ;; Read and return a list of switches + (or (boundp 'diff-switches) + (require 'diff)) ; Make sure that `diff-switches' is defined. + (let* ((default (if (listp diff-switches) + (mapconcat 'identity diff-switches " ") + diff-switches)) + (switches + (read-string (format switchprompt default) default))) + (let (result (start 0)) + (while (string-match "\\(\\S-+\\)" switches start) + (setq result (cons (substring switches (match-beginning 1) + (match-end 1)) + result) + start (match-end 0))) + (nreverse result)))) + +(defun dired-diff (file &optional switches) + "Compare file at point with file FILE using `diff'. +FILE defaults to the file at the mark. +The prompted-for file is the first file given to `diff'. +With a prefix allows the switches for the diff program to be edited." + (interactive + (list + (dired-diff-read-file-name "Diff") + (and current-prefix-arg (dired-diff-read-switches "Options for diff: ")))) + (if switches + (diff file (dired-get-filename) switches) + (diff file (dired-get-filename)))) + +(defun dired-backup-diff (&optional switches) + "Diff this file with its backup file or vice versa. +Uses the latest backup, if there are several numerical backups. +If this file is a backup, diff it with its original. +The backup file is the first file given to `diff'." + (interactive (list (and current-prefix-arg + (dired-diff-read-switches "Diff with switches: ")))) + (if switches + (diff-backup (dired-get-filename) switches) + (diff-backup (dired-get-filename)))) + +(defun dired-emerge (arg file out-file) + "Merge file at point with FILE using `emerge'. +FILE defaults to the file at the mark." + (interactive + (let ((file (dired-diff-read-file-name "Merge"))) + (list + current-prefix-arg + file + (and current-prefix-arg (emerge-read-file-name + "Output file" + emerge-last-dir-output + (dired-abbreviate-file-name file) file))))) + (emerge-files arg file (dired-get-filename) out-file)) + +(defun dired-emerge-with-ancestor (arg file ancestor file-out) + "Merge file at point with FILE, using a common ANCESTOR file. +FILE defaults to the file at the mark." + (interactive + (let ((file (dired-diff-read-file-name "Merge"))) + (list + current-prefix-arg + file + (emerge-read-file-name "Ancestor file" emerge-last-dir-ancestor nil file) + (and current-prefix-arg (emerge-read-file-name + "Output file" + emerge-last-dir-output + (dired-abbreviate-file-name file) file))))) + (emerge-files-with-ancestor arg file (dired-get-filename) + ancestor file-out)) + +(defun dired-ediff (file) + "Ediff file at point with FILE. +FILE defaults to the file at the mark." + (interactive (list (dired-diff-read-file-name "Ediff"))) + (ediff-files file (dired-get-filename))) + +(defun dired-epatch (file) + "Patch file at point using `epatch'." + (interactive + (let ((file (dired-get-filename))) + (list + (and (or (memq 'patch dired-no-confirm) + (y-or-n-p (format "Patch %s? " + (file-name-nondirectory file)))) + file)))) + (if file + (ediff-patch-file file) + (message "No file patched."))) + +;;; Autoloads + +;;; Diff (diff) + +(autoload 'diff "diff" "Diff two files." t) +(autoload 'diff-backup "diff" + "Diff this file with its backup or vice versa." t) + +;;; Emerge + +(autoload 'emerge-files "emerge" "Merge two files." t) +(autoload 'emerge-files-with-ancestor "emerge" + "Merge two files having a common ancestor." t) +(autoload 'emerge-read-file-name "emerge") + +;; Ediff + +(autoload 'ediff-files "ediff" "Ediff two files." t) +(autoload 'ediff-patch-file "ediff" "Patch a file." t) + +;;; end of dired-diff.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/dired-fsf.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-fsf.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,684 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-fsf.el +;; Dired Version: $Revision: 1.1 $ +;; RCS: +;; Description: dired functions for V19 of the original GNU Emacs from FSF +;; Created: Sat Jan 29 01:38:49 1994 by sandy on ibm550 +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;; Requirements and provisions +(provide 'dired-fsf) +(require 'dired) + +;;;; Variables to set. + +(setq dired-modeline-tracking-cmds '(mouse-set-point)) + +;;;; Support for text properties + +(defun dired-insert-set-properties (beg end) + ;; Sets the text properties for the file names. + (save-excursion + (goto-char beg) + (beginning-of-line) + (let ((eol (save-excursion (end-of-line) (point))) + (bol (point))) + (while (< (point) end) + (setq eol (save-excursion (end-of-line) (point))) + (if (dired-manual-move-to-filename nil bol eol) + (dired-set-text-properties + (point) (dired-manual-move-to-end-of-filename nil bol eol))) + (goto-char (setq bol (1+ eol))))))) + +(defun dired-remove-text-properties (start end &optional object) + ;; Removes text properties. Called in popup buffers. + (remove-text-properties start end '(mouse-face dired-file-name) object)) + +(defun dired-set-text-properties (start end) + ;; Sets dired's text properties + (put-text-property start end 'mouse-face 'highlight) + (put-text-property start end 'dired-file-name t)) + +(defun dired-move-to-filename (&optional raise-error bol eol) + (or bol (setq bol (save-excursion + (skip-chars-backward "^\n\r") + (point)))) + (or eol (setq eol (save-excursion + (skip-chars-forward "^\n\r") + (point)))) + (goto-char bol) + (let ((spot (next-single-property-change bol 'dired-file-name nil eol))) + (if (= spot eol) + (if raise-error + (error "No file on this line") + nil) + (goto-char spot)))) + +(defun dired-move-to-end-of-filename (&optional no-error bol eol) + ;; Assumes point is at beginning of filename, + ;; thus the rwx bit re-search-backward below will succeed in *this* + ;; line if at all. So, it should be called only after + ;; (dired-move-to-filename t). + ;; On failure, signals an error (with non-nil NO-ERROR just returns nil). + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (and + (null no-error) + selective-display + (or bol (setq bol (save-excursion (skip-chars-backward "^\r\n") (point)))) + (eq (char-after (1- bol)) ?\r) + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit."))))) + (if (get-text-property (point) 'dired-file-name nil) + (goto-char (next-single-property-change (point) 'dired-file-name + nil eol)) + (and (null no-error) (error "No file on this line")))) + +;; Text properties do not work properly in pre-19.26. + +(if (or (not (boundp 'emacs-major-version)) + (= emacs-major-version 19)) + (progn + (if (not (boundp 'emacs-minor-version)) + ;; Argument structure of where-is-internal went through some + ;; changes. + (defun dired-key-description (cmd &rest prefixes) + ;; Return a key description string for a menu. + ;; If prefixes are given, they should be either strings, + ;; integers, or 'universal-argument. + (let ((key (where-is-internal cmd dired-mode-map nil t))) + (if key + (key-description + (apply 'vconcat + (append + (mapcar + (function + (lambda (x) + (if (eq x 'universal-argument) + (where-is-internal 'universal-argument + dired-mode-map nil t) + x))) + prefixes) + (list key)))) + "")))) + (if (or (not (boundp 'emacs-minor-version)) + (< emacs-minor-version 26)) + (progn + (fset 'dired-insert-set-properties 'ignore) + (fset 'dired-remove-text-properties 'ignore) + (fset 'dired-set-text-properties 'ignore) + (fset 'dired-move-to-filename 'dired-manual-move-to-filename) + (fset 'dired-move-to-end-of-filename + 'dired-manual-move-to-end-of-filename))))) + +;;;; Keymaps + +;;; Caching Menus + +(defun dired-menu-item (menu-item cmd width &rest prefixes) + ;; Return a key description string for a menu. If prefixes are given, + ;; they should be either characters, or 'universal-argument. + (let ((desc (apply 'dired-key-description cmd prefixes))) + (if (string-equal desc "") + menu-item + (concat menu-item + (make-string + (max (- width (length menu-item) (length desc) 2) 1) 32) + "(" desc ")")))) + +(defun dired-cache-key (keymap event cmd &rest prefixes) + ;; Caches a keybinding for cms in a menu keymap. + ;; This is able to handle prefix keys. + (let ((desc (apply 'dired-key-description cmd prefixes))) + (or (string-equal desc "") + (progn + (let ((elt (assq event keymap))) + (if elt + (let ((tail (cdr elt))) + (setcdr tail + (cons + (cons + nil (concat " (" desc ")")) + (cdr tail)))))))))) + +;; Don't cache keys in old emacs versions. Is 23 the right cut-off point? +(if (or (not (boundp 'emacs-minor-version)) + (< emacs-minor-version 23)) + (fset 'dired-cache-key 'ignore)) + +(defvar dired-visit-popup-menu nil) +;; Menus of commands in the Visit popup menu. +(defvar dired-do-popup-menu nil) +;; Menu of commands in the dired Do popup menu. + +;; Menus for the menu bar. +(defvar dired-subdir-menu + (cons "Subdir" (make-sparse-keymap "Subdir"))) +(defvar dired-mark-menu + (cons "Mark" (make-sparse-keymap "Mark"))) +(defvar dired-do-menu + (cons "Do" (make-sparse-keymap "Do"))) +(defvar dired-regex-menu + (cons "Regexp" (make-sparse-keymap "Regex"))) +(defvar dired-look-menu + (cons "Look" (make-sparse-keymap "Look"))) +(defvar dired-sort-menu + (cons "Sort" (make-sparse-keymap "Sort"))) +(defvar dired-help-menu nil) + +(defun dired-setup-menus () + + ;; popup menu + + (setq dired-visit-popup-menu + (list + (cons (dired-menu-item "Find File" 'dired-find-file 35) + 'dired-advertised-find-file) + (cons (dired-menu-item "Find in Other Window" + 'dired-find-file-other-window 35) + 'dired-find-file-other-window) + (cons (dired-menu-item "Find in Other Frame" + 'dired-find-file-other-frame 35) + 'dired-find-file-other-frame) + (cons (dired-menu-item "View File" 'dired-view-file 35) + 'dired-view-file) + (cons (dired-menu-item "Display in Other Window" + 'dired-find-file-other-window 35 + 'universal-argument) + 'dired-display-file))) + + ;; Operate popup menu + + (setq dired-do-popup-menu + (list + (cons (dired-menu-item "Copy to..." 'dired-do-copy 35 1) + 'dired-do-copy) + (cons (dired-menu-item "Rename to..." 'dired-do-rename 35 1) + 'dired-do-rename) + (cons (dired-menu-item "Compress/Uncompress" 'dired-do-compress + 35 1) 'dired-do-compress) + (cons (dired-menu-item "Uuencode/Uudecode" 'dired-do-uucode + 35 1) 'dired-do-uucode) + (cons (dired-menu-item "Change Mode..." 'dired-do-chmod 35 1) + 'dired-do-chmod) + (cons (dired-menu-item "Change Owner..." 'dired-do-chown 35 1) + 'dired-do-chown) + (cons (dired-menu-item "Change Group..." 'dired-do-chgrp 35 1) + 'dired-do-chgrp) + (cons (dired-menu-item "Load" 'dired-do-load 35 1) + 'dired-do-load) + (cons (dired-menu-item "Byte-compile" 'dired-do-byte-compile 35 1) + 'dired-do-byte-compile) + (cons (dired-menu-item "Hardlink to..." 'dired-do-hardlink 35 1) + 'dired-do-hardlink) + (cons (dired-menu-item "Symlink to..." 'dired-do-symlink 35 1) + 'dired-do-symlink) + (cons (dired-menu-item "Relative Symlink to..." + 'dired-do-relsymlink 35 1) + 'dired-do-relsymlink) + (cons (dired-menu-item "Shell Command..." + 'dired-do-shell-command 35 1) + 'dired-do-shell-command) + (cons (dired-menu-item "Background Shell Command..." + 'dired-do-background-shell-command 35 1) + 'dired-do-background-shell-command) + (cons (dired-menu-item "Delete" 'dired-do-delete 35 1) + 'dired-do-delete))) + + ;; Subdir Menu-bar Menu + + (define-key dired-mode-map [menu-bar subdir] dired-subdir-menu) + (define-key dired-mode-map [menu-bar subdir uncompress-subdir-files] + (cons "Uncompress Compressed Files" + (function + (lambda () (interactive) (dired-compress-subdir-files t))))) + (dired-cache-key dired-subdir-menu 'uncompress-subdir-files + 'dired-compress-subdir-files 'universal-argument) + (define-key dired-mode-map [menu-bar subdir compress-subdir-files] + '("Compress Uncompressed Files" . dired-compress-subdir-files)) + (define-key dired-mode-map [menu-bar subdir flag] + '("Flag Files for Deletion" . dired-flag-subdir-files)) + (define-key dired-mode-map [menu-bar subdir mark] + '("Mark Files" . dired-mark-subdir-files)) + (define-key dired-mode-map [menu-bar subdir redisplay] + '("Redisplay Subdir" . dired-redisplay-subdir)) + (define-key dired-mode-map [menu-bar subdir subdir-separator] + '("-- Commands on All Files in Subdir --")) + (define-key dired-mode-map [menu-bar subdir kill-subdir] + '("Kill This Subdir" . dired-kill-subdir)) + (define-key dired-mode-map [menu-bar subdir create-directory] + '("Create Directory..." . dired-create-directory)) + (define-key dired-mode-map [menu-bar subdir insert] + '("Insert This Subdir" . dired-maybe-insert-subdir)) + (define-key dired-mode-map [menu-bar subdir down-dir] + '("Down Dir" . dired-down-directory)) + (define-key dired-mode-map [menu-bar subdir up-dir] + '("Up Dir" . dired-up-directory)) + (define-key dired-mode-map [menu-bar subdir prev-dirline] + '("Prev Dirline" . dired-prev-dirline)) + (define-key dired-mode-map [menu-bar subdir next-dirline] + '("Next Dirline" . dired-next-dirline)) + (define-key dired-mode-map [menu-bar subdir prev-subdir] + '("Prev Subdir" . dired-prev-subdir)) + (define-key dired-mode-map [menu-bar subdir next-subdir] + '("Next Subdir" . dired-next-subdir)) + + ;; Mark Menu-bar Menu + + (define-key dired-mode-map [menu-bar mark] dired-mark-menu) + (define-key dired-mode-map [menu-bar mark mark-from-compilation-buffer] + '("Mark Files from Compile Buffer..." . dired-mark-files-compilation-buffer)) + (define-key dired-mode-map [menu-bar mark mark-from-other-buffer] + '("Mark Files from Other Dired" . + dired-mark-files-from-other-dired-buffer)) + (define-key dired-mode-map [menu-bar mark mark-separator] + '("--")) + (define-key dired-mode-map [menu-bar mark marker-char-right] + '("Marker stack right" . dired-marker-stack-right)) + (define-key dired-mode-map [menu-bar mark marker-char-left] + '("Marker stack left" . dired-marker-stack-left)) + (define-key dired-mode-map [menu-bar mark restore-marker] + '("Restore marker char" . dired-restore-marker-char)) + (define-key dired-mode-map [menu-bar mark add-marker] + '("Set new marker char..." . dired-set-marker-char)) + (define-key dired-mode-map [menu-bar mark auto-save-files] + '("Flag Auto-save Files" . dired-flag-auto-save-files)) + (define-key dired-mode-map [menu-bar mark backup-files] + '("Flag Backup Files" . dired-flag-backup-files)) + (define-key dired-mode-map [menu-bar mark executables] + '("Mark Executables" . dired-mark-executables)) + (define-key dired-mode-map [menu-bar mark directory] + '("Mark Old Backups" . dired-clean-directory)) + (define-key dired-mode-map [menu-bar mark directories] + '("Mark Directories" . dired-mark-directories)) + (define-key dired-mode-map [menu-bar mark symlinks] + '("Mark Symlinks" . dired-mark-symlinks)) + (define-key dired-mode-map [menu-bar mark toggle] + (cons "Toggle Marks..." + (function (lambda () (interactive) + (let ((current-prefix-arg t)) + (call-interactively 'dired-change-marks)))))) + (dired-cache-key dired-mark-menu 'toggle 'dired-change-marks + 'universal-argument) + (define-key dired-mode-map [menu-bar mark unmark-all] + '("Unmark All" . dired-unmark-all-files)) + (define-key dired-mode-map [menu-bar mark marks] + '("Change Marks..." . dired-change-marks)) + (define-key dired-mode-map [menu-bar mark prev] + '("Previous Marked" . dired-prev-marked-file)) + (define-key dired-mode-map [menu-bar mark next] + '("Next Marked" . dired-next-marked-file)) + + ;; Do Menu-bar Menu + + (define-key dired-mode-map [menu-bar do] + dired-do-menu) + (define-key dired-mode-map [menu-bar do do-popup] + (cons "Operate on file menu >" + 'dired-do-popup-menu-internal)) + (dired-cache-key dired-do-menu 'do-popup + 'dired-do-popup-menu) + (define-key dired-mode-map [menu-bar do visit-popup] + (cons "Visit file menu >" + 'dired-visit-popup-menu-internal)) + (dired-cache-key dired-do-menu 'visit-popup + 'dired-visit-popup-menu) + (define-key dired-mode-map [menu-bar do delete] + '("Delete Marked Files" . dired-do-delete)) + (define-key dired-mode-map [menu-bar do background-command] + '("Background Shell Command..." . dired-do-background-shell-command)) + (define-key dired-mode-map [menu-bar do command] + '("Shell Command..." . dired-do-shell-command)) + (define-key dired-mode-map [menu-bar do symlink] + '("Symlink to..." . dired-do-symlink)) + (define-key dired-mode-map [menu-bar do hardlink] + '("Hardlink to..." . dired-do-hardlink)) + (define-key dired-mode-map [menu-bar do compile] + '("Byte-compile" . dired-do-byte-compile)) + (define-key dired-mode-map [menu-bar do load] + '("Load" . dired-do-load)) + (define-key dired-mode-map [menu-bar do chgrp] + '("Change Group..." . dired-do-chgrp)) + (define-key dired-mode-map [menu-bar do chown] + '("Change Owner..." . dired-do-chown)) + (define-key dired-mode-map [menu-bar do chmod] + '("Change Mode..." . dired-do-chmod)) + (define-key dired-mode-map [menu-bar do print] + '("Print..." . dired-do-print)) + (define-key dired-mode-map [menu-bar do uucode] + '("Uuencode/Uudecode" . dired-do-uucode)) + (define-key dired-mode-map [menu-bar do compress] + '("Compress/Uncompress" . dired-do-compress)) + (define-key dired-mode-map [menu-bar do expunge] + '("Expunge File Flagged for Deletion" . dired-expunge-deletions)) + (define-key dired-mode-map [menu-bar do rename] + '("Rename to..." . dired-do-rename)) + (define-key dired-mode-map [menu-bar do copy] + '("Copy to..." . dired-do-copy)) + +;; Regex Menu-bar Menu + + (define-key dired-mode-map [menu-bar regex] dired-regex-menu) + (define-key dired-mode-map [menu-bar regex show-omit-regexp] + (cons "Show Omit Regex" + (function + (lambda () + (interactive) + (let ((current-prefix-arg 0)) + (call-interactively 'dired-add-omit-regexp)))))) + (dired-cache-key dired-regex-menu 'show-omit-regexp + 'dired-add-omit-regexp 0) + (define-key dired-mode-map [menu-bar regex remove-omit-extension] + (cons "Remove Omit Extension..." + (function + (lambda () + (interactive) + (let ((current-prefix-arg '(16))) + (call-interactively 'dired-add-omit-regexp)))))) + (dired-cache-key dired-regex-menu 'remove-omit-extension + 'dired-add-omit-regexp 'universal-argument + 'universal-argument) + (define-key dired-mode-map [menu-bar regex add-omit-extension] + (cons "Add Omit Extension..." + (function + (lambda () + (interactive) + (let ((current-prefix-arg '(4))) + (call-interactively 'dired-add-omit-regexp)))))) + (dired-cache-key dired-regex-menu 'add-omit-extension + 'dired-add-omit-regexp 'universal-argument) + (define-key dired-mode-map [menu-bar regex remove-omit-regexp] + (cons "Remove Omit Regex..." + (function + (lambda () + (interactive) + (let ((current-prefix-arg 1)) + (call-interactively 'dired-add-omit-regexp)))))) + (dired-cache-key dired-regex-menu 'remove-omit-regexp + 'dired-add-omit-regexp 1) + (define-key dired-mode-map [menu-bar regex add-omit-regexp] + '("Add Omit Regex..." . dired-add-omit-regexp)) + (define-key dired-mode-map [menu-bar regex separator] + '("--")) + (define-key dired-mode-map [menu-bar regex relsymlink] + '("Relative Symlink..." . dired-do-relsymlink-regexp)) + (define-key dired-mode-map [menu-bar regex symlink] + '("Symlink..." . dired-do-symlink-regexp)) + (define-key dired-mode-map [menu-bar regex hardlink] + '("Hardlink..." . dired-do-hardlink-regexp)) + (define-key dired-mode-map [menu-bar regex rename] + '("Rename..." . dired-do-rename-regexp)) + (define-key dired-mode-map [menu-bar regex copy] + '("Copy..." . dired-do-copy-regexp)) + (define-key dired-mode-map [menu-bar regex upcase] + '("Upcase" . dired-upcase)) + (define-key dired-mode-map [menu-bar regex downcase] + '("Downcase" . dired-downcase)) + (define-key dired-mode-map [menu-bar regex dired-flag-extension] + '("Flag Files with Extension..." . dired-flag-extension)) + (define-key dired-mode-map [menu-bar regex flag] + '("Flag..." . dired-flag-files-regexp)) + (define-key dired-mode-map [menu-bar regex mark-extension] + '("Mark Files with Extension..." . dired-mark-extension)) + (define-key dired-mode-map [menu-bar regex mark] + '("Mark..." . dired-mark-files-regexp)) + + ;; Look Menu-bar Menu + + (define-key dired-mode-map [menu-bar look] dired-look-menu) + (define-key dired-mode-map [menu-bar look patch] + '("Patch File" . dired-epatch)) + (define-key dired-mode-map [menu-bar look ediff] + '("Ediff Files..." . dired-ediff)) + (define-key dired-mode-map [menu-bar look emerge-with-ancestor] + '("Merge Files Having Common Ancestor..." . dired-emerge-with-ancestor)) + (define-key dired-mode-map [menu-bar look emerge] + '("Merge Files..." . dired-emerge)) + (define-key dired-mode-map [menu-bar look backup-diff] + '("Diff with Backup" . dired-backup-diff)) + (define-key dired-mode-map [menu-bar look diff] + '("Diff File..." . dired-diff)) + ;; Put in a separator line. + (define-key dired-mode-map [menu-bar look look-separator] + '("--")) + (define-key dired-mode-map [menu-bar look tags-query-replace] + '("Tags Query Replace..." . dired-do-tags-query-replace)) + (define-key dired-mode-map [menu-bar look tags-search] + '("Tags Search for..." . dired-do-tags-search)) + (define-key dired-mode-map [menu-bar look grep] + '("Grep for..." . dired-do-grep)) + + ;; Sort Menu-bar Menu + + (define-key dired-mode-map [menu-bar sort] dired-sort-menu) + (define-key dired-mode-map [menu-bar sort redisplay-killed] + (cons "Redisplay Killed Lines" + (function (lambda () (interactive) (dired-do-kill-file-lines 0))))) + (dired-cache-key dired-sort-menu 'redisplay-killed + 'dired-do-kill-file-lines 0) + (define-key dired-mode-map [menu-bar sort kill] + '("Kill Marked Lines" . dired-do-kill-file-lines)) + (define-key dired-mode-map [menu-bar sort toggle-omit] + '("Toggle Omit" . dired-omit-toggle)) + (define-key dired-mode-map [menu-bar sort hide-subdir] + '("Hide Subdir" . dired-hide-subdir)) + (define-key dired-mode-map [menu-bar sort hide-all] + '("Hide All Subdirs" . dired-hide-all)) + (define-key dired-mode-map [menu-bar sort sort-separator] + '("--")) + (define-key dired-mode-map [menu-bar sort entire-edit] + (cons "Edit Switches for Entire Buffer..." + (function (lambda () (interactive) + (dired-sort-toggle-or-edit '(16)))))) + (dired-cache-key dired-sort-menu 'entire-edit + 'dired-sort-toggle-or-edit 'universal-argument + 'universal-argument) + (define-key dired-mode-map [menu-bar sort entire-name] + (cons "Sort Entire Buffer by Name" + (function (lambda () (interactive) + (dired-sort-toggle-or-edit 'name))))) + (dired-cache-key dired-sort-menu 'entire-name 'dired-sort-toggle-or-edit + 'universal-argument) + (define-key dired-mode-map [menu-bar sort entire-date] + (cons "Sort Entire Buffer by Date" + (function (lambda () (interactive) + (dired-sort-toggle-or-edit 'date))))) + (dired-cache-key dired-sort-menu 'entire-date 'dired-sort-toggle-or-edit + 'universal-argument) + (define-key dired-mode-map [menu-bar sort new-edit] + (cons "Edit Default Switches for Inserted Subdirs..." + (function (lambda () (interactive) (dired-sort-toggle-or-edit 2))))) + (dired-cache-key dired-sort-menu 'new-edit 'dired-sort-toggle-or-edit 2) + (define-key dired-mode-map [menu-bar sort edit] + (cons "Edit Switches for Current Subdir..." + (function (lambda () (interactive) (dired-sort-toggle-or-edit 1))))) + (dired-cache-key dired-sort-menu 'edit 'dired-sort-toggle-or-edit 1) + (define-key dired-mode-map [menu-bar sort show] + (cons "Show Current Switches" + (function (lambda () (interactive) (dired-sort-toggle-or-edit 0))))) + (dired-cache-key dired-sort-menu 'show 'dired-sort-toggle-or-edit 0) + (define-key dired-mode-map [menu-bar sort toggle] + '("Toggle Current Subdir by Name/Date" . dired-sort-toggle-or-edit)) + + ;; Help Menu-bar Menu + + (or dired-help-menu + (setq dired-help-menu + (if (and (boundp 'menu-bar-help-menu) (keymapp menu-bar-help-menu)) + (cons "Help" (cons 'keymap (cdr menu-bar-help-menu))) + (cons "Help" (make-sparse-keymap "Help"))))) + (define-key dired-mode-map [menu-bar dired-help] dired-help-menu) + (define-key dired-mode-map [menu-bar dired-help help-separator] + '("--")) + (define-key dired-mode-map [menu-bar dired-help dired-bug] + '("Report Dired Bug" . dired-report-bug)) + (define-key dired-mode-map [menu-bar dired-help dired-var-apropos] + (cons "Dired Variable Apropos" + (function (lambda () + (interactive) + (let ((current-prefix-arg t)) + (call-interactively 'dired-apropos)))))) + (dired-cache-key dired-help-menu 'dired-var-apropos + 'dired-apropos 'universal-argument) + (define-key dired-mode-map [menu-bar dired-help dired-apropos] + '("Dired Command Apropos" . dired-apropos)) + (define-key dired-mode-map [menu-bar dired-help dired-info] + (cons "Dired Info Manual" + (function (lambda () + (interactive) + (dired-describe-mode t))))) + (dired-cache-key dired-help-menu 'dired-info 'dired-describe-mode + 'universal-argument) + (define-key dired-mode-map [menu-bar dired-help dired-describe-mode] + '("Describe Dired" . dired-describe-mode)) + (define-key dired-mode-map [menu-bar dired-help dired-summary] + '("Dired Summary Help" . dired-summary))) + +(add-hook 'dired-setup-keys-hook 'dired-setup-menus) + +;;; Mouse functions + +(defun dired-mouse-find-file (event) + "In dired, visit the file or directory name you click on." + (interactive "e") + (save-excursion + (set-buffer (window-buffer (posn-window (event-end event)))) + (if dired-subdir-alist + (save-excursion + (goto-char (posn-point (event-end event))) + (dired-find-file)) + (error + (concat "dired-subdir-alist seems to be mangled. " + (substitute-command-keys + "\\Try dired-revert (\\[dired-revert]).")))))) + +(defun dired-mouse-mark (event) + "In dired, mark the file name that you click on. +If the file name is already marked, this unmarks it." + (interactive "e") + (save-excursion + (set-buffer (window-buffer (posn-window (event-end event)))) + (if dired-subdir-alist + (save-excursion + (goto-char (posn-point (event-end event))) + (beginning-of-line) + (if (looking-at dired-re-mark) + (dired-unmark 1) + (dired-mark 1))) + (error + (concat "dired-subdir-alist seems to be mangled. " + (substitute-command-keys + "\\Try dired-revert (\\[dired-revert]).")))))) + +(defun dired-mouse-flag (event) + "In dired, flag for deletion the file name that you click on. +If the file name is already flag, this unflags it." + (interactive "e") + (save-excursion + (set-buffer (window-buffer (posn-window (event-end event)))) + (if dired-subdir-alist + (save-excursion + (goto-char (posn-point (event-end event))) + (beginning-of-line) + (if (char-equal (following-char) dired-del-marker) + (dired-unflag 1) + (dired-flag-file-deletion 1))) + (error + (concat "dired-subdir-alist seems to be mangled. " + (substitute-command-keys + "\\Try dired-revert (\\[dired-revert]).")))))) + +(defun dired-mouse-get-target (event) + "In dired, put a copy of the selected directory in the active minibuffer." + (interactive "e") + (let ((obuff (current-buffer)) + mb) + (set-buffer (window-buffer (posn-window (event-end event)))) + (if (and dired-subdir-alist (setq mb (dired-get-active-minibuffer-window))) + (let (dir) + (goto-char (posn-point (event-end event))) + (setq dir (dired-current-directory)) + (select-window mb) + (set-buffer (window-buffer mb)) + (erase-buffer) + (insert dir)) + (set-buffer obuff) + (if mb + (error "No directory specified") + (error "No active minibuffer"))))) + +(defun dired-visit-popup-menu (event) + "Popup a menu to visit the moused file." + (interactive "e") + (save-excursion + (set-buffer (window-buffer (posn-window (event-end event)))) + (save-excursion + (goto-char (posn-point (event-end event))) + (dired-visit-popup-menu-internal event)))) + +(defun dired-visit-popup-menu-internal (event) + (interactive "e") + (let ((fn (dired-get-filename 'no-dir)) + fun) + (dired-remove-text-properties 0 (length fn) fn) + (setq fun (x-popup-menu + event + (list "Visit popup menu" + (cons + (concat "Visit " fn " with") + dired-visit-popup-menu)))) + (if fun (funcall fun)))) + +(defun dired-do-popup-menu (event) + ;; Pop up a menu do an operation on the moused file. + (interactive "e") + (let ((obuff (current-buffer))) + (unwind-protect + (progn + (set-buffer (window-buffer (posn-window (event-end event)))) + (dired-save-excursion + (goto-char (posn-point (event-end event))) + (dired-do-popup-menu-internal event))) + (set-buffer obuff)))) + +(defun dired-do-popup-menu-internal (event) + (interactive "e") + (let ((fn (dired-get-filename 'no-dir)) + fun) + (dired-remove-text-properties 0 (length fn) fn) + (setq fun (x-popup-menu + event + (list "Do popup menu" + (cons + (concat "Do operation on " fn) + dired-do-popup-menu)))) + (dired-save-excursion + (if fun (let ((current-prefix-arg 1)) + (call-interactively fun)))))) + +;;; Key maps + +;; Get rid of the Edit menu bar item to save space. +(define-key dired-mode-map [menu-bar edit] 'undefined) +;; We have our own help item +(define-key dired-mode-map [menu-bar help] 'undefined) +(define-key dired-mode-map [mouse-2] 'dired-mouse-find-file) +(define-key dired-mode-map [S-mouse-1] 'dired-mouse-mark) +(define-key dired-mode-map [C-S-mouse-1] 'dired-mouse-flag) +(define-key dired-mode-map [down-mouse-3] 'dired-visit-popup-menu) +;; This can be useful in dired, so move to double click. +(define-key dired-mode-map [double-mouse-3] 'mouse-save-then-kill) +(define-key dired-mode-map [C-down-mouse-2] 'dired-do-popup-menu) +(define-key dired-mode-map [M-mouse-2] 'dired-mouse-get-target) + +(or (memq 'dired-help menu-bar-final-items) + (setq menu-bar-final-items (cons 'dired-help menu-bar-final-items))) + +;;; end of dired-fsf.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/dired-grep.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-grep.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,482 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-grep.el +;; RCS: +;; Dired Version: $Revision: 1.1 $ +;; Description: Support for running grep on marked files in a dired buffer. +;; Author: Sandy Rutherford +;; Created: Tue Jul 13 22:59:37 1993 by sandy on ibm550 +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Copyright (C) 1993 Sandy Rutherford + +;;; 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 1, 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. +;;; +;;; A copy of the GNU General Public License can be obtained from this +;;; program's author (send electronic mail to sandy@ibm550.sissa.it) or +;;; from the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, +;;; MA 02139, USA. + +;;; The user-level command in this file is dired-grep-file. The command +;;; grep is defined in compile.el. This file does not change that command. + +;;; Requirements and provisions + +(provide 'dired-grep) +(or (fboundp 'file-local-copy) (require 'emacs-19)) +(or (fboundp 'generate-new-buffer) (require 'emacs-19)) +(require 'dired) + +;;; Variables + +(defvar dired-grep-program "grep" + "Name of program to use to grep files. +When used with the \"-n\" flag, program must precede each match with \"###:\", +where \"###\" is the line number of the match. +If there are grep programs which don't do this, we'll try to think of +some way to accomodate them.") + +(defvar dired-grep-switches nil + "*Switches to pass to the grep program. +This may be either a string or a list of strings. It is not necessary to +include \"-n\" as that switch is always used.") + +(defvar dired-grep-zcat-program "zcat" + "Name of program to cat compressed files.") + +(defvar dired-grep-compressed-file ".\\.\\(gz\\|[zZ]\\)$" + "Regexp to match names of compressed files.") + +(defvar dired-grep-pop-up-buffer t + "*If non-nil, the grep output is displayed in the other window upon +completion of the grep process.") + +(defvar dired-grep-results-buffer "*Dired Grep*" + "Name of buffer where grep results are logged.") + +(defvar dired-grep-mode-hook nil + "Hook run after going into grep-mode") + +(defvar grep-history nil + "History of previous grep patterns used.") + +(defvar dired-grep-parse-flags-cache nil) +(defvar dired-grep-parse-flags-cache-result nil) + +(defvar dired-grep-mode-map nil + "Keymap for dired-grep-mode buffers.") + +(if dired-grep-mode-map + () + (setq dired-grep-mode-map (make-keymap)) + (suppress-keymap dired-grep-mode-map) + (define-key dired-grep-mode-map "[" 'backward-page) + (define-key dired-grep-mode-map "]" 'forward-page) + (define-key dired-grep-mode-map ">" 'dired-grep-next-hit) + (define-key dired-grep-mode-map "<" 'dired-grep-previous-hit) + (define-key dired-grep-mode-map "n" 'dired-grep-advertized-next-hit) + (define-key dired-grep-mode-map "p" 'dired-grep-advertized-previous-hit) + (define-key dired-grep-mode-map "k" 'dired-grep-delete-line) + (define-key dired-grep-mode-map "d" 'dired-grep-delete-page) + (define-key dired-grep-mode-map "^" 'dired-grep-delete-preceding-pages) + (define-key dired-grep-mode-map "f" 'dired-grep-find-file) + (define-key dired-grep-mode-map "e" 'dired-grep-find-file) + (define-key dired-grep-mode-map "m" 'dired-grep-delete-misses) + (define-key dired-grep-mode-map "o" 'dired-grep-find-file-other-window) + (define-key dired-grep-mode-map "v" 'dired-grep-view-file) + (define-key dired-grep-mode-map "w" 'dired-grep-delete-grep-for) + (define-key dired-grep-mode-map "\C-_" 'dired-grep-undo) + (define-key dired-grep-mode-map "\C-xu" 'dired-grep-undo)) + +;;; Entry functions from dired.el + +(defun dired-grep (pattern flags) + ;; grep the file on the current line for PATTERN, using grep flags FLAGS. + ;; Return nil on success. Offending filename otherwise. + (let* ((file (dired-get-filename)) + (result (dired-grep-file pattern file flags))) + (and result + (progn + (dired-log (buffer-name (current-buffer)) (concat result "\n")) + file)))) + +(defun dired-do-grep (pattern &optional flags arg) + "Grep marked files for a pattern. With a \C-u prefix prompts for grep flags." + (interactive + (let* ((switches (if (consp current-prefix-arg) + (read-string "Switches for grep: ") + dired-grep-switches)) + (prompt (format "grep %sfor pattern" + (if (stringp switches) + (if (string-equal switches "") + switches + (concat switches " ")) + (if switches + (concat (mapconcat 'identity switches " ") " ") + "")))) + (pattern (dired-read-with-history (concat prompt ": ") + nil 'grep-history))) + (list pattern switches + (and (not (consp current-prefix-arg)) current-prefix-arg)))) + (dired-map-over-marks-check + (function + (lambda () + (dired-grep pattern flags))) + arg 'grep (concat "grep " flags (if flags " \"" "\"") pattern "\"") t)) + +;;; Utility functions + +(defun dired-grep-get-results-buffer () + ;; Return the buffer object of the dired-grep-results-buffer, creating and + ;; initializing it if necessary. + (let ((buffer (get-buffer dired-grep-results-buffer))) + (or buffer + (save-excursion + (set-buffer (setq buffer (get-buffer-create dired-grep-results-buffer))) + (dired-grep-mode) + buffer)))) + +;; Only define if undefined, in case efs has got to it already. +(or (fboundp 'dired-grep-delete-local-temp-file) + (defun dired-grep-delete-local-temp-file (file) + (condition-case nil (delete-file file) (error nil)))) + +;;; Commands in the dired-grep-results-buffer buffer. + +(defun dired-grep-mode () + "\\Mode for perusing grep output generated from dired. +The output is divided into pages, one page per grepped file. + +Summary of commands: + +Move to next grep hit \\[dired-grep-advertized-next-hit], \\[dired-grep-next-hit] +Move to previous grep hit \\[dired-grep-advertized-previous-hit], \\[dired-grep-previous-hit] +Move to output for next file \\[forward-page] +Move to output for previous file \\[backward-page] + +Delete the current grep line \\[dired-grep-delete-line] +Delete all output for current file \\[dired-grep-delete-page] +Delete all preceding pages \\[dired-grep-delete-preceding-pages] +Delete all pages for files with no hits \\[dired-grep-delete-misses] +Delete all pages which grep for the + same pattern as the current page \\[dired-grep-delete-grep-for] + +Find current grep hit in file \\[dired-grep-find-file] +Find current grep hit in other window \\[dired-grep-find-file-other-window] +View current grep hit \\[dired-grep-view-file] + +Undo changes to the grep buffer \\[dired-grep-undo] + +Keybindings: +\\{dired-grep-mode-map}" + (kill-all-local-variables) + (use-local-map dired-grep-mode-map) + (setq major-mode 'dired-grep-mode + mode-name "Dired-Grep" + buffer-read-only t) + (set (make-local-variable 'page-delimiter) "\n\n") + (run-hooks 'dired-grep-mode-hook)) + +(defun dired-grep-current-file-and-line () + ;; Returns a list \(FILENAME . LINE\) corresponding to the filename + ;; and line number associated with the position of the point in a + ;; grep buffer. Returns nil if there is none. + (save-excursion + (let (file line) + (and + (progn + (beginning-of-line) + (looking-at "[0-9]+:")) + (progn + (setq line (string-to-int (buffer-substring (point) + (1- (match-end 0))))) + (if (search-backward "\n\n" nil 'move) (forward-char 2)) + (looking-at "Hits for ")) + (progn + (forward-line 1) + (looking-at " ")) + (progn + (setq file (buffer-substring (match-end 0) + (progn (end-of-line) (1- (point))))) + (cons file line)))))) + +(defun dired-grep-find-file () + (interactive) + (let ((file (dired-grep-current-file-and-line))) + (if file + (progn + (find-file (car file)) + (goto-line (cdr file)) + (recenter '(4))) + (error "No file specified by this line.")))) + +(defun dired-grep-find-file-other-window () + (interactive) + (let ((file (dired-grep-current-file-and-line))) + (if file + (progn + (find-file-other-window (car file)) + (goto-line (cdr file)) + (recenter '(4))) + (error "No file specified by this line.")))) + +(defun dired-grep-view-file () + (interactive) + (let ((file (dired-grep-current-file-and-line))) + (if file + (let* ((fun (function + (lambda () (goto-line (cdr file)) (recenter '(4))))) + (view-hook + (if (boundp 'view-hook) + (if (and (listp view-hook) + (not (eq (car view-hook) 'lambda))) + (cons fun view-hook) + (list fun view-hook)) + fun))) + (view-file (car file))) + (error "No file specified by this line.")))) + +(defun dired-grep-next-hit (arg) + "Moves to the next, or next ARGth, grep hit." + (interactive "p") + (forward-line 1) + (if (re-search-forward "^[0-9]" nil 'move arg) + (goto-char (match-beginning 0)) + (error "No further grep hits"))) + +(defun dired-grep-previous-hit (arg) + "Moves to the previous, or previous ARGth, grep hit." + (interactive "p") + (beginning-of-line) + (or (re-search-backward "^[0-9]" nil 'move arg) + (error "No further grep hits"))) + +;; These are only so we can get a decent looking help buffer. +(fset 'dired-grep-advertized-next-hit 'dired-grep-next-hit) +(fset 'dired-grep-advertized-previous-hit 'dired-grep-previous-hit) + +(defun dired-grep-delete-page (arg) + "Deletes the current and ARG - 1 following grep output pages. +If ARG is negative, deletes preceding pages." + (interactive "p") + (let ((done 0) + (buffer-read-only nil) + (backward (< arg 0)) + start) + (if backward (setq arg (- arg))) + (while (and (< done arg) (not (if backward (bobp) (eobp)))) + (or (looking-at "^\n") + (if (search-backward "\n\n" nil 'move) (forward-char 1))) + (setq start (point)) + (if (search-forward "\n\n" nil 'move) (forward-char -1)) + (delete-region start (point)) + (and (bobp) (not (eobp)) (delete-char 1)) + (if backward (skip-chars-backward "\n")) + (setq done (1+ done))))) + +(defun dired-grep-delete-preceding-pages () + "Deletes the current, and all preceding pages from the grep buffer." + (interactive) + (let ((buffer-read-only nil)) + (if (looking-at "^\n") + (forward-char 1) + (search-forward "\n\n" nil 'move)) + (delete-region (point-min) (point)))) + +(defun dired-grep-delete-line (arg) + "Deletes the current line and ARG following lines from the grep buffer. +Only operates on lines which correspond to file lines for grep hits." + (interactive "p") + (let ((opoint (point)) + (buffer-read-only nil) + (backward (< arg 0)) + (done 0)) + (beginning-of-line) + (if backward (setq arg (- arg))) + (if (looking-at "[0-9]+:") + (while (< done arg) + (delete-region (point) (progn (forward-line 1) (point))) + (if backward (forward-line -1)) + (if (looking-at "[0-9]+:") + (setq done (1+ done)) + (setq done arg))) + ;; Do nothing. + (goto-char opoint)))) + +(defun dired-grep-delete-grep-for () + "Deletes all pages which grep some file for the pattern of the current page." + (interactive) + (save-excursion + ;; In case we happen to be right at the beginning of a page. + (or (eobp) (eolp) (forward-char 1)) + (forward-page -1) ; gets to the beginning of the page. + (let* ((eol (save-excursion (end-of-line) (point))) + (line (and (search-forward " grep " eol t) + (buffer-substring (point) eol)))) + (if line + (progn + (goto-char (point-min)) + (while (not (eobp)) + (let* ((eol (save-excursion (end-of-line) (point))) + (this-line (and (search-forward " grep " eol t) + (buffer-substring (point) eol)))) + (if (equal line this-line) + (progn + (dired-grep-delete-page 1) + (skip-chars-forward "\n")) + (or (eobp) (forward-page 1)))))))))) + +(defun dired-grep-delete-misses () + "Delete all pages for which there were no grep hits. +Deletes pages for which grep failed because of an error too." + (interactive) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (if (looking-at "Grep failed \\|No hits ") + (progn + (dired-grep-delete-page 1) + (skip-chars-forward "\n")) + (forward-page 1))))) + +(defun dired-grep-undo () + "Undoes deletions in a grep buffer." + (interactive) + (let (buffer-read-only) + (undo))) + +;;; Commands for grepping files. + +(defun dired-grep-parse-flags (string) + ;; Breaks a string of switches into a list. + (if (equal dired-grep-parse-flags-cache string) + dired-grep-parse-flags-cache-result + (let ((length (length string)) + (pointer 0) + (start 0) + (result nil)) + (while (and (< pointer length) (= (aref string pointer) ?\ )) + (setq pointer (1+ pointer))) + (while (< pointer length) + (setq start pointer) + (while (and (< pointer length) (/= (aref string pointer) ?\ )) + (setq pointer (1+ pointer))) + (setq result (cons (substring string start pointer) result)) + (while (and (< pointer length) (= (aref string pointer) ?\ )) + (setq pointer (1+ pointer)))) + (setq dired-grep-parse-flags-cache string + dired-grep-parse-flags-cache-result (nreverse result))))) + +(defun dired-grep-file (pattern file &optional flags) + "Grep for PATTERN in FILE. +Optional FLAGS are flags to pass to the grep program. +When used interactively, will prompt for FLAGS if a prefix argument is used." + (interactive + (let* ((switches (if (consp current-prefix-arg) + (read-string "Switches for grep: ") + dired-grep-switches)) + (prompt (format "grep %sfor pattern" + (if (stringp switches) + (if (string-match switches "^ *$") + "" + (concat switches " ")) + (if switches + (concat (mapconcat 'identity switches " ") " ") + "")))) + (pattern (dired-read-with-history (concat prompt ": ") + nil 'grep-history)) + (file (read-file-name (concat prompt " \"" pattern "\" in file :")))) + (list pattern file switches))) + (setq file (expand-file-name file)) + (if (listp flags) + (setq flags (mapconcat 'identity flags " ")) + (if (string-match "^ +$" flags) + (setq flags ""))) + (let ((file-buff (get-file-buffer file))) + (if (and file-buff (buffer-modified-p file-buff)) + (if (y-or-n-p (format "Save buffer %s? " (buffer-name file-buff))) + (save-excursion + (set-buffer file-buff) + (save-buffer))))) + (let ((buffer (dired-grep-get-results-buffer)) + (compressed (string-match dired-grep-compressed-file file)) + failed temp-file jka-compr-compression-info-list) + (setq temp-file + (condition-case err + (file-local-copy file) + (error (progn (setq failed (format "%s" err)) nil)))) + (or failed + (save-excursion + (set-buffer buffer) + (goto-char (point-max)) + (let ((buffer-read-only nil) + pos-1 pos-2) + (or (bobp) (insert "\n")) + (setq pos-1 (point)) + (insert "Hits for grep ") + (or (string-equal flags "") (insert flags " ")) + (insert "\"" pattern "\" in\n " file ":\n") + (setq pos-2 (point)) + (condition-case err + (apply + 'call-process + (if compressed "sh" dired-grep-program) + (or temp-file file) + buffer t + (if compressed + (list "-c" (concat dired-grep-zcat-program + " |" dired-grep-program + " " flags " -n '" pattern "'")) + (append (dired-grep-parse-flags flags) + (list "-n" pattern)))) + (error (setq failed (format "%s" err)))) + (if failed + (progn + (if (= pos-2 (point-max)) + (progn + (goto-char (1- pos-2)) + (delete-char -1) + (insert "."))) + (goto-char pos-1) + (delete-char 4) + (insert "Grep failed") + failed) + (if (= pos-2 (point-max)) + (progn + (goto-char pos-1) + (delete-char 1) + (insert "No h") + (forward-line 1) + (end-of-line) + (delete-char -1) + (insert ".")) + (goto-char pos-2) + (or (looking-at "[0-9]+:") + (setq failed (buffer-substring pos-2 + (progn (end-of-line) + (point)))))))))) + (let ((curr-wind (selected-window))) + (unwind-protect + (progn + (pop-to-buffer buffer) + (goto-char (point-max))) + (select-window curr-wind))) + (if temp-file + (dired-grep-delete-local-temp-file temp-file)) + failed)) + +;;; Run the load hook + +(run-hooks 'dired-grep-load-hook) + +;;; end of dired-grep.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/dired-help.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-help.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,398 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-help.el +;; Dired Version: $Revision: 1.1 $ +;; RCS: +;; Description: Obtaining help for dired +;; Modified: Sun Nov 20 21:10:47 1994 by sandy on gandalf +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Requirements and provisions +(provide 'dired-help) +(require 'dired) +(autoload 'reporter-submit-bug-report "reporter") +(defvar reporter-version) ; For the byte-compiler. + +;;; Constants + +(defconst dired-bug-address "efs-bugs@cuckoo.hpl.hp.com") + +(defvar dired-documentation nil) + +;;; Functions + +(defun dired-documentation () + (or dired-documentation + (let ((18-p (string-equal "18." (substring emacs-version 0 3))) + (var-help-key (substitute-command-keys + (if (featurep 'ehelp) + "\\[electric-describe-variable]" + "\\[describe-variable]"))) + (standard-output (get-buffer-create " dired-help-temp"))) + (save-excursion + (set-buffer standard-output) + (unwind-protect + (setq dired-documentation + (substitute-command-keys + (format "\\The Directory Editor: + +For more detailed help, type \\[universal-argument] \\[dired-describe-mode] to start the info +documentation browser. + +In dired, you can edit a list of the files in a directory \(and optionally +its subdirectories in the `ls -lR' format\). + +Editing a directory means that you can visit, rename, copy, compress, +load, byte-compile files. You can change files' attributes, run shell +commands on files, or insert subdirectories into the edit buffer. You can +\"flag\" files for deletion or \"mark\" files for later commands, either one +file at a time or by all files matching certain criteria \(e.g., files that +match a certain regexp\). + +You move throughout the buffer using the usual cursor motion commands. +Letters no longer insert themselves, but execute commands instead. The +digits (0-9) are prefix arguments. + +Most commands operate either on all marked files or on the current file if +no files are marked. Use a numeric prefix argument to operate on the next +ARG files (or previous ARG if ARG < 0). Use the prefix argument `1' to +operate on the current file only. Prefix arguments override marks. Commands +which run a sub-process on a group of files will display a list of files +for which the sub-process failed. Typing \\[dired-why] will try to tell +you what went wrong. + +When editing several directories in one buffer, each directory acts as a +page, so \\[backward-page] and \\[forward-page] can be used to move between directories. + +Summary of commands: + +Motion Commands + move up to previous line \\[dired-next-line] + move down to next line \\[dired-previous-line] + move up to previous directory line \\[dired-prev-dirline] + move down to next directory line \\[dired-next-dirline] + move up to previous subdirectory \\[dired-advertised-prev-subdir] + move down to next subdirectory \\[dired-advertised-next-subdir] + move to parent directory \\[dired-up-directory] + move to first child subdirectory \\[dired-down-directory] + +Immediate Actions on Files + visit current file \\[dired-advertised-find-file] + visit current file in other window \\[dired-find-file-other-window] + visit current file in other frame %s + display current file \\[universal-argument] \\[dired-find-file-other-window] + create a new subdirectory \\[dired-create-directory] + recover file from auto-save \\[dired-recover-file] + +Marking & Unmarking Files + mark a file or subdirectory for later commands \\[dired-mark] + unmark a file or all files of a subdirectory \\[dired-unmark] + unmark all marked files in a buffer \\[dired-unmark-all-files] + count marks in buffer 0 \\[dired-unmark-all-files] + mark all directories \\[dired-mark-directories] + mark all executable files \\[dired-mark-executables] + mark file names matching a regular expression \\[dired-mark-files-regexp] + +Commands on Files Marked or Specified by the Prefix + rename a file or move files to another directory \\[dired-do-rename] + copy files \\[dired-do-copy] + delete marked (as opposed to flagged) files \\[dired-do-delete] + compress or uncompress files \\[dired-do-compress] + uuencode or uudecode files \\[dired-do-uucode] + grep files \\[dired-do-grep] + search for regular expression \\[dired-do-tags-search] + query replace by regular expression \\[dired-do-tags-query-replace] + byte-compile files \\[dired-do-byte-compile] + load files \\[dired-do-load] + shell command on files \\[dired-do-shell-command] + operate shell command separately on each file \\[universal-argument] \\[dired-do-shell-command] + do as above, but in each file's directory \\[universal-argument] \\[universal-argument] \\[dired-do-shell-command] + +Flagging Files for Deletion (unmark commands remove delete flags) + flag file for deletion \\[dired-flag-file-deletion] + backup and remove deletion flag \\[dired-backup-unflag] + flag all backup files (file names ending in ~) \\[dired-flag-backup-files] + flag all auto-save files \\[dired-flag-auto-save-files] + clean directory of numeric backups \\[dired-clean-directory] + execute the deletions requested (flagged files) \\[dired-expunge-deletions] + +Modifying the Dired Buffer + insert a subdirectory in this buffer \\[dired-maybe-insert-subdir] + removing a subdir listing \\[dired-kill-subdir] + relist single file, marked files, or subdir \\[dired-do-redisplay] + re-read all directories (retains all marks) \\[revert-buffer] + toggle sorting of current subdir by name/date \\[dired-sort-toggle-or-edit] + report on current ls switches 0 \\[dired-sort-toggle-or-edit] + edit ls switches for current subdir 1 \\[dired-sort-toggle-or-edit] + edit default ls switches for new subdirs 2 \\[dired-sort-toggle-or-edit] + sort all subdirs by name/date \\[universal-argument] \\[dired-sort-toggle-or-edit] + edit the ls switches for all subdirs \\[universal-argument] \\[universal-argument] \\[dired-sort-toggle-or-edit] + +Hiding File Lines + toggle file omission in current subdir \\[dired-omit-toggle] + kill marked file lines \\[dired-do-kill-file-lines] + +Help on Dired + dired help (what you're reading) \\[dired-describe-mode] + dired summary (short help) \\[dired-summary] + dired info (full dired info manual) \\[universal-argument] \\[dired-describe-mode] + apropos for dired commands \\[dired-apropos] + apropos for dired variables \\[universal-argument] \\[dired-apropos] + +Regular Expression Commands + mark files with a regular expression \\[dired-mark-files-regexp] + copy marked files by regexp \\[dired-do-copy-regexp] + rename marked files by regexp \\[dired-do-rename-regexp] + omit files by regexp \\[dired-omit-expunge] + downcase file names (rename to lowercase) \\[dired-downcase] + upcase files names (rename to uppercase) \\[dired-upcase] + +Comparing Files + diff file at point with file at mark \\[dired-diff] + diff file with its backup \\[dired-backup-diff] + merge file at point with file at mark \\[dired-emerge] + same as above but use a common ancestor \\[dired-emerge-with-ancestor] + ediff file at point with file at mark \\[dired-ediff] + patch file at point \\[dired-epatch] + +Mouse Commands +%s + +Miscellaneous + quit dired \\[dired-quit] + insert current directory in minibuffer \\[dired-get-target-directory] + +If the dired buffer gets confused, you can either type \\[revert-buffer] to read all +directories again, type \\[dired-do-redisplay] to relist a single file, the marked +files, or a subdirectory, or type \\[dired-build-subdir-alist] to parse +the directory tree in the buffer again. + +Customization Variables: +Use %s to obtain more information. + +%s + +Hook Variables: +Use %s to obtain more information. + +%s + +Keybindings: +\\{dired-mode-map}" + + ;; arguments to format + (if 18-p + "Unavailable in Emacs 18" + " \\[dired-find-file-other-frame]") + (if 18-p + " Unavailable in Emacs 18" + "\ + find file with mouse \\[dired-mouse-find-file] + mark file at mouse \\[dired-mouse-mark] + flag for deletion file at mouse \\[dired-mouse-flag] + menu of commands to visit a file \\[dired-visit-popup-menu] + menu of operations to do on a file \\[dired-do-popup-menu] + insert directory of mouse in minibuffer \\[dired-mouse-get-target] +") + var-help-key + (progn + (erase-buffer) + (dired-format-columns-of-files + (sort + (all-completions + "dired-" obarray + (function + (lambda (sym) + (and (user-variable-p sym) + (not (dired-hook-variable-p + sym)))))) + 'string<) t) + (buffer-string)) + var-help-key + (progn + (erase-buffer) + (dired-format-columns-of-files + (sort + (all-completions + "dired-" obarray + (function + (lambda (sym) + (dired-hook-variable-p sym)))) + 'string<) t) + (buffer-string))))) + (kill-buffer " dired-help-temp")))))) + +;;; Commands + +(defun dired-describe-mode (&optional info) + "Detailed description of dired mode. +With a prefix, runs the info documentation browser for dired." + (interactive "P") + ;; Getting dired documentation can be a bit slow. + (if info + (info "dired") + (message "Building dired help...") + (let* ((buff (get-buffer-create "*Help*")) + (standard-output buff) + (mess (dired-documentation))) + (message "Building dired help... done") + (if (featurep 'ehelp) + (with-electric-help + (function + (lambda () + (princ mess) + nil))) ; return nil so ehelp puts us at the top of the buffer. + (with-output-to-temp-buffer (buffer-name buff) + (princ mess) + (print-help-return-message)))))) + +(defun dired-apropos (string &optional var-p) + "Does command apropos for dired commands. +With prefix does apropos for dired variables." + (interactive + (list + (if current-prefix-arg + (read-string "Dired variable apropos (regexp): ") + (read-string "Dired command apropos (regexp): ")) + current-prefix-arg)) + (message "Doing dired %s apropos..." (if var-p "variable" "command")) + (if (featurep 'ehelp) + (with-electric-help + (function + (lambda () + (dired-apropos-internal string var-p) + nil))) + (with-output-to-temp-buffer "*Help*" + (dired-apropos-internal string var-p) + (or (print-help-return-message) + (message "Doing dired %s apropos...done" + (if var-p "variable" "command")))))) + +(defun dired-apropos-internal (string &optional var-p) + (let ((case-fold-search t) + (names (sort (all-completions "dired-" obarray + (if var-p + 'user-variable-p + 'commandp)) + 'string<)) + doc) + (mapcar + (function + (lambda (x) + (and (if var-p (user-variable-p (intern x)) (commandp (intern x))) + (progn + (setq doc (if var-p + (get (intern x) 'variable-documentation) + (documentation (intern x)))) + (and doc (setq doc (substring doc 0 (string-match "\n" doc)))) + (or (string-match string x) + (and doc (string-match string doc)))) + (progn + (princ x) + (if var-p (princ " :") + (princ " :") + (princ (make-string (max 2 (- 30 (length x))) ?\ )) + (princ (dired-help-key-description (intern x)))) + (princ "\n ") + (princ doc) + (princ "\n"))))) + names))) + +(defun dired-help-key-description (fun) + ;; Returns a help string of keys for fun. + (let ((res (mapconcat 'key-description + (where-is-internal fun dired-mode-map) ", "))) + (if (string-equal res "") + "\(not on any keys\)" + res))) + +(defun dired-summary () + "Display summary of basic dired commands in the minibuffer." + (interactive) + (let ((del (where-is-internal 'dired-flag-file-deletion dired-mode-map)) + (und (where-is-internal 'dired-unmark dired-mode-map)) + (exp (where-is-internal 'dired-expunge-deletions dired-mode-map)) + (fin (where-is-internal 'dired-advertised-find-file dired-mode-map)) + (oth (where-is-internal 'dired-find-file-other-window dired-mode-map)) + (ren (where-is-internal 'dired-do-rename dired-mode-map)) + (cop (where-is-internal 'dired-do-copy dired-mode-map)) + (hel (where-is-internal 'dired-describe-mode dired-mode-map))) + (if (member "d" del) + (setq del "d-elete") + (setq del (substitute-command-keys + "\\\\[dired-flag-file-deletion] delete"))) + (if (member "u" und) + (setq und "u-ndelete") + (setq und (substitute-command-keys + "\\\\[dired-unmark] undelete"))) + (if (member "x" exp) + (setq exp "x-punge") + (setq exp (substitute-command-keys + "\\\\[dired-expunge-deletions] expunge"))) + (if (member "f" fin) + (setq fin "f-ind") + (setq fin (substitute-command-keys + "\\\\[dired-advertised-find-file] find"))) + (if (member "o" oth) + (setq oth "o-ther window") + (setq oth + (substitute-command-keys + "\\\\[dired-find-file-other-window] other window") + )) + (if (member "R" ren) + (setq ren "R-ename") + (setq ren (substitute-command-keys + "\\\\[dired-do-rename] rename"))) + (if (member "C" cop) + (setq cop "C-opy") + (setq cop (substitute-command-keys + "\\\\[dired-do-copy] copy"))) + (if (member "h" hel) + (setq hel "h-elp") + (setq hel (substitute-command-keys + "\\\\[describe-mode] help"))) + (message "%s, %s, %s, %s. %s, %s, %s, %s" + del und exp fin oth ren cop hel))) + +(defun dired-hook-variable-p (sym) + ;; Returns t if SYM is a hook variable. Just looks at its name. + (let ((name (symbol-name sym))) + (and (>= (length name) 6) + (or (string-equal (substring name -5) "-hook") + (string-equal (substring name -6) "-hooks"))))) + +;;; Submitting bug reports. + +(defun dired-report-bug () + "Submit a bug report for dired." + (interactive) + (let ((reporter-prompt-for-summary-p t)) + (or (boundp 'reporter-version) + (setq reporter-version + "Your version of reporter is obsolete. Please upgrade.")) + (reporter-submit-bug-report + dired-bug-address "Dired" + (cons + 'dired-version + (nconc + (mapcar + 'intern + (sort + (let (completion-ignore-case) + (all-completions "dired-" obarray 'user-variable-p)) + 'string-lessp)) + (list 'reporter-version))) + (function + (lambda () + (save-excursion + (mail-position-on-field "subject") + (beginning-of-line) + (skip-chars-forward "^:\n") + (if (looking-at ": Dired;") + (progn + (goto-char (match-end 0)) + (delete-char -1) + (insert " " dired-version " bug:"))))))))) + +;;; end of dired-help.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/dired-mob.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-mob.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,122 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-mob.el +;; RCS: +;; Dired Version: $Revision: 1.1 $ +;; Description: Commands for marking files from another buffer. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Requirements and provisions +(provide 'dired-mob) +(require 'dired) +(autoload 'compilation-buffer-p "compile") +(autoload 'compile-reinitialize-errors "compile") + +;; For the byte-compiler +(defvar compilation-error-list) + +;;; Utilities + +(defun dired-mark-these-files (file-list from) + ;; Mark the files in FILE-LIST. Relative filenames are taken to be + ;; in the current dired directory. + ;; FROM is a string (used for logging) describing where FILE-LIST + ;; came from. + ;; Logs files that were not found and displays a success or failure + ;; message. + (message "Marking files %s..." from) + (let ((total (length file-list)) + (cur-dir (dired-current-directory)) + file failures) + (while file-list + (setq file (expand-file-name (car file-list) cur-dir) + file-list (cdr file-list)) + ;;(message "Marking file `%s'" file) + (save-excursion + (if (dired-goto-file file) + (dired-mark 1) ; supplying a prefix keeps it from checking + ; for a subdir. + (setq failures (cons (dired-make-relative file) failures)) + (dired-log (buffer-name (current-buffer)) + "Cannot mark this file (not found): %s\n" file)))) + (dired-update-mode-line-modified t) + (if failures + (dired-log-summary + (buffer-name (current-buffer)) + (format "Failed to mark %d of %d files %s %s" + (length failures) total from failures) failures) + (message "Marked %d file%s %s." total (dired-plural-s total) from)))) + +;;; User commands + +(defun dired-mark-files-from-other-dired-buffer (buf) + "Mark files that are marked in the other Dired buffer. +I.e, mark those files in this Dired buffer that have the same +non-directory part as the marked files in the Dired buffer in the other +window." + (interactive (list (window-buffer (next-window)))) + (if (eq (get-buffer buf) (current-buffer)) + (error "Other dired buffer is the same")) + (or (stringp buf) (setq buf (buffer-name buf))) + (let ((other-files (save-excursion + (set-buffer buf) + (or (eq major-mode 'dired-mode) + (error "%s is not a dired buffer" buf)) + (dired-get-marked-files 'no-dir)))) + (dired-mark-these-files other-files (concat "from buffer " buf)))) + +(defun dired-mark-files-compilation-buffer (&optional buf) + "Mark the files mentioned in the `*compilation*' buffer. +With a prefix, you may specify the other buffer." + (interactive + (list + (let ((buff (let ((owin (selected-window)) + found) + (unwind-protect + (progn + (other-window 1) + (while (null (or found (eq (selected-window) owin))) + (if (compilation-buffer-p + (window-buffer (selected-window))) + (setq found (current-buffer))) + (other-window 1))) + (select-window owin)) + found))) + (if (or current-prefix-arg (null buff)) + (let ((minibuffer-history + (delq nil + (mapcar + (function + (lambda (b) + (and (compilation-buffer-p b) (buffer-name b)))) + (buffer-list))))) + (read-buffer "Use buffer: " + (or buff (car minibuffer-history)))) + buff)))) + (let ((dired-dir (directory-file-name default-directory)) + files) + (save-window-excursion + (set-buffer buf) + (compile-reinitialize-errors nil (point-max)) + (let ((alist compilation-error-list) + f d elt) + (while alist + (setq elt (car alist) + alist (cdr alist)) + (and (consp (setq elt (car (cdr elt)))) + (stringp (setq d (car elt))) + (stringp (setq f (cdr elt))) + (progn + (setq d (expand-file-name d)) + (dired-in-this-tree d dired-dir)) + (progn + (setq f (expand-file-name f d)) + (not (member f files))) + (setq files (cons f files)))))) + (dired-mark-these-files + files + (concat "From compilation buffer " + (if (stringp buf) buf (buffer-name buf)))))) + +;;; end of dired-mob.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/dired-mule.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-mule.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,36 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-mule.el +;; Dired Version: $Revision: 1.1 $ +;; RCS: +;; Description: MULE support for dired. +;; Created: Sun Jul 17 14:45:12 1994 by sandy on ibm550 +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Acknowledgements: +;; +;; Ishikawa Ichiro for sending MULE patches and information. + +(require 'dired) + +(defun dired-find-file (&optional coding-system) + "In dired, visit the file or directory named on this line." + (interactive "ZCoding-system: ") + (find-file (dired-get-filename) coding-system)) + +(defun dired-find-file-other-window (&optional display coding-system) + "In dired, visit this file or directory in another window. +With a prefix, the file is displayed, but the window is not selected." + (interactive "P\nZCoding-system: ") + (if display + (dired-display-file coding-system) + (find-file-other-window (dired-get-filename) coding-system))) + +(defun dired-display-file (&optional coding-system) + "In dired, displays this file or directory in the other window." + (interactive "ZCoding-system: ") + (display-buffer + (find-file-noselect (dired-get-filename) coding-system))) + +;;; end of dired-mule.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/dired-oas.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-oas.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,58 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-oas.el +;; Dired Version: $Revision: 1.1 $ +;; RCS: +;; Description: dired odds and sods. Dired functions not usually needed. +;; This file is not a reference to the Organization of +;; American States. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Don't require or provide anything, as this file is just an archive. + +(defun dired-sort-on-size () + "Sorts a dired listing on file size. +If your ls cannot sort on size, this is useful as `dired-after-readin-hook': + \(setq dired-after-readin-hook 'dired-sort-on-size\)" + (require 'sort) + (goto-char (point-min)) + (dired-goto-next-file) ; skip `total' line + (beginning-of-line) + (sort-subr t 'forward-line 'end-of-line 'dired-get-file-size)) + +(defun dired-directories-of (files) + ;; Return unique list of parent directories of FILES. + (let (dirs dir file) + (while files + (setq file (car files) + files (cdr files) + dir (file-name-directory file)) + (or (member dir dirs) + (setq dirs (cons dir dirs)))) + dirs)) + +(defun dired-parse-ls-show () + (interactive) + (let (inode s mode size uid gid nlink time name sym) + (if (dired-parse-ls) + (message "%s" (list inode s mode nlink uid gid size time name sym)) + (message "Not on a file line.")))) + +(defun dired-files-same-directory (file-list &optional absolute) + "If all files in LIST are in the same directory return it, otherwise nil. +Returned name has no trailing slash. \"Same\" means file-name-directory of +the files are string=. File names in LIST must all be absolute or all be +relative. Implicitly, relative file names are in default-directory. If +optional ABS is non-nil, the returned name will be absolute, otherwise the +returned name will be absolute or relative as per the files in LIST." + (let ((dir (file-name-directory (car file-list)))) + (if (memq nil (mapcar (function + (lambda (file) + (string= dir (file-name-directory file)))) + file-list)) + nil + (directory-file-name + (if (or (not absolute) (and dir (file-name-absolute-p dir))) + (or dir "") + (concat default-directory dir)))))) diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/dired-rgxp.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-rgxp.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,267 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-rgxp.el +;; Dired Version: $Revision: 1.1 $ +;; RCS: +;; Description: Commands for running commands on files whose names +;; match a regular expression. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Requirements and provisions +(provide 'dired-rgxp) +(require 'dired) + +;;; Variables + +(defvar dired-flagging-regexp nil) +;; Last regexp used to flag files. + +;;; Utility functions + +(defun dired-do-create-files-regexp + (file-creator operation arg regexp newname &optional whole-path marker-char) + ;; Create a new file for each marked file using regexps. + ;; FILE-CREATOR and OPERATION as in dired-create-files. + ;; ARG as in dired-get-marked-files. + ;; Matches each marked file against REGEXP and constructs the new + ;; filename from NEWNAME (like in function replace-match). + ;; Optional arg WHOLE-PATH means match/replace the whole pathname + ;; instead of only the non-directory part of the file. + ;; Optional arg MARKER-CHAR as in dired-create-files. + (let* ((fn-list (dired-get-marked-files nil arg)) + (name-constructor + (if whole-path + (list 'lambda '(from) + (list 'let + (list (list 'to + (list 'dired-string-replace-match + regexp 'from newname))) + (list 'or 'to + (list 'dired-log + '(buffer-name (current-buffer)) + "%s: %s did not match regexp %s\n" + operation 'from regexp)) + 'to)) + (list 'lambda '(from) + (list 'let + (list (list 'to + (list 'dired-string-replace-match regexp + '(file-name-nondirectory from) + newname))) + (list 'or 'to + (list 'dired-log '(buffer-name (current-buffer)) + "%s: %s did not match regexp %s\n" + operation '(file-name-nondirectory from) + regexp)) + '(and to + (expand-file-name + to (file-name-directory from))))))) + (operation-prompt (concat operation " `%s' to `%s'?")) + (rename-regexp-help-form (format "\ +Type SPC or `y' to %s one match, DEL or `n' to skip to next, +`!' to %s all remaining matches with no more questions." + (downcase operation) + (downcase operation))) + (query (list 'lambda '(from to) + (list 'let + (list (list 'help-form + rename-regexp-help-form)) + (list 'dired-query + '(quote dired-file-creator-query) + operation-prompt + '(dired-abbreviate-file-name from) + '(dired-abbreviate-file-name to)))))) + (dired-create-files + file-creator operation fn-list name-constructor marker-char query))) + +(defun dired-mark-read-regexp (operation) + ;; Prompt user about performing OPERATION. + ;; Read and return list of: regexp newname arg whole-path. + (let* ((whole-path + (equal 0 (prefix-numeric-value current-prefix-arg))) + (arg + (if whole-path nil current-prefix-arg)) + (regexp + (dired-read-with-history + (concat (if whole-path "Path " "") operation " from (regexp): ") + dired-flagging-regexp 'dired-regexp-history)) + (newname + (read-string + (concat (if whole-path "Path " "") operation " " regexp " to: ") + (and (not whole-path) (dired-dwim-target-directory))))) + (list regexp newname arg whole-path))) + +;;; Marking file names matching a regexp. + +(defun dired-mark-files-regexp (regexp &optional marker-char omission-files-p) + "\\Mark all files matching REGEXP for use in later commands. + +A prefix argument \\[universal-argument] means to unmark them instead. + +A prefix argument 0 means to mark the files that would me omitted by \\[dired-omit-toggle]. +A prefix argument 1 means to unmark the files that would be omitted by \\[dired-omit-toggle]. + +REGEXP is an Emacs regexp, not a shell wildcard. Thus, use \"\\.o$\" for +object files--just `.o' will mark more than you might think. The files \".\" +and \"..\" are never marked. +" + (interactive + (let ((unmark (and (not (eq current-prefix-arg 0)) current-prefix-arg)) + (om-files-p (memq current-prefix-arg '(0 1))) + regexp) + (if om-files-p + (setq regexp (dired-omit-regexp)) + (setq regexp (dired-read-with-history + (concat (if unmark "Unmark" "Mark") + " files (regexp): ") nil + 'dired-regexp-history))) + (list regexp (if unmark ?\ ) om-files-p))) + (let ((dired-marker-char (or marker-char dired-marker-char))) + (dired-mark-if + (and (not (looking-at dired-re-dot)) + (not (eolp)) ; empty line + (let ((fn (dired-get-filename nil t))) + (and fn (string-match regexp (file-name-nondirectory fn))))) + (if omission-files-p + "omission candidate file" + "matching file")))) + +(defun dired-flag-files-regexp (regexp) + "In dired, flag all files containing the specified REGEXP for deletion. +The match is against the non-directory part of the filename. Use `^' + and `$' to anchor matches. Exclude subdirs by hiding them. +`.' and `..' are never flagged." + (interactive (list (dired-read-with-history + "Flag for deletion (regexp): " nil + 'dired-regexp-history))) + (dired-mark-files-regexp regexp dired-del-marker)) + +(defun dired-mark-extension (extension &optional marker-char) + "Mark all files with a certain extension for use in later commands. +A `.' is not prepended to the string entered." + ;; EXTENSION may also be a list of extensions instead of a single one. + ;; Optional MARKER-CHAR is marker to use. + (interactive "sMark files with extension: \nP") + (or (listp extension) + (setq extension (list extension))) + (dired-mark-files-regexp + (concat ".";; don't match names with nothing but an extension + "\\(" + (mapconcat 'regexp-quote extension "\\|") + "\\)$") + marker-char)) + +(defun dired-flag-extension (extension) + "In dired, flag all files with a certain extension for deletion. +A `.' is not prepended to the string entered." + (interactive "sFlag files with extension: ") + (dired-mark-extension extension dired-del-marker)) + +(defun dired-cleanup (program) + "Flag for deletion dispensable files created by PROGRAM. +See variable `dired-cleanup-alist'." + (interactive + (list + (let ((dired-cleanup-history (append dired-cleanup-history + (mapcar 'car dired-cleanup-alist)))) + (dired-completing-read + "Cleanup files for: " dired-cleanup-alist nil t nil + 'dired-cleanup-history)))) + (dired-flag-extension (cdr (assoc program dired-cleanup-alist)))) + +;;; Commands on marked files whose names also match a regexp. + +(defun dired-do-rename-regexp (regexp newname &optional arg whole-path) + "Rename marked files containing REGEXP to NEWNAME. +As each match is found, the user must type a character saying + what to do with it. For directions, type \\[help-command] at that time. +NEWNAME may contain \\=\\ or \\& as in `query-replace-regexp'. +REGEXP defaults to the last regexp used. +With a zero prefix arg, renaming by regexp affects the complete + pathname - usually only the non-directory part of file names is used + and changed." + (interactive (dired-mark-read-regexp "Rename")) + (dired-do-create-files-regexp + (function dired-rename-file) + "Rename" arg regexp newname whole-path dired-keep-marker-rename)) + +(defun dired-do-copy-regexp (regexp newname &optional arg whole-path) + "Copy all marked files containing REGEXP to NEWNAME. +See function `dired-rename-regexp' for more info." + (interactive (dired-mark-read-regexp "Copy")) + (dired-do-create-files-regexp + (function dired-copy-file) + (if dired-copy-preserve-time "Copy [-p]" "Copy") + arg regexp newname whole-path dired-keep-marker-copy)) + +(defun dired-do-hardlink-regexp (regexp newname &optional arg whole-path) + "Hardlink all marked files containing REGEXP to NEWNAME. +See function `dired-rename-regexp' for more info." + (interactive (dired-mark-read-regexp "HardLink")) + (dired-do-create-files-regexp + (function add-name-to-file) + "HardLink" arg regexp newname whole-path dired-keep-marker-hardlink)) + +(defun dired-do-symlink-regexp (regexp newname &optional arg whole-path) + "Symlink all marked files containing REGEXP to NEWNAME. +See function `dired-rename-regexp' for more info." + (interactive (dired-mark-read-regexp "SymLink")) + (dired-do-create-files-regexp + (function make-symbolic-link) + "SymLink" arg regexp newname whole-path dired-keep-marker-symlink)) + +(defun dired-do-relsymlink-regexp (regexp newname &optional whole-path) + "RelSymlink all marked files containing REGEXP to NEWNAME. +See functions `dired-rename-regexp' and `dired-do-relsymlink' + for more info." + (interactive (dired-mark-read-regexp "RelSymLink")) + (dired-do-create-files-regexp + (function dired-make-relative-symlink) + "RelSymLink" nil regexp newname whole-path dired-keep-marker-symlink)) + +;;;; Modifying the case of file names. + +(defun dired-create-files-non-directory + (file-creator basename-constructor operation arg) + ;; Perform FILE-CREATOR on the non-directory part of marked files + ;; using function BASENAME-CONSTRUCTOR, with query for each file. + ;; OPERATION like in dired-create-files, ARG like in dired-get-marked-files. + (let (rename-non-directory-query) + (dired-create-files + file-creator + operation + (dired-get-marked-files nil arg) + (function + (lambda (from) + (let ((to (concat (file-name-directory from) + (funcall basename-constructor + (file-name-nondirectory from))))) + (and (let ((help-form (format "\ +Type SPC or `y' to %s one file, DEL or `n' to skip to next, +`!' to %s all remaining matches with no more questions." + (downcase operation) + (downcase operation)))) + (dired-query 'rename-non-directory-query + (concat operation " `%s' to `%s'") + (dired-make-relative from) + (dired-make-relative to))) + to)))) + dired-keep-marker-rename))) + +(defun dired-rename-non-directory (basename-constructor operation arg) + (dired-create-files-non-directory + (function dired-rename-file) + basename-constructor operation arg)) + +(defun dired-upcase (&optional arg) + "Rename all marked (or next ARG) files to upper case." + (interactive "P") + (dired-rename-non-directory (function upcase) "Rename upcase" arg)) + +(defun dired-downcase (&optional arg) + "Rename all marked (or next ARG) files to lower case." + (interactive "P") + (dired-rename-non-directory (function downcase) "Rename downcase" arg)) + +;;; end of dired-rgxp.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/dired-sex.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-sex.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,156 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-sex.el +;; Dired Version: $Revision: 1.1 $ +;; RCS: +;; Description: Marking files according to sexpressions. Sorry. +;; Created: Wed Sep 14 01:30:43 1994 by sandy on ibm550 +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide 'dired-sex) +(require 'dired) + +(defvar dired-sexpr-history-symbol nil + "History of sexpr used to mark files in dired.") + +;;; Marking files according to sexpr's + +(defmacro dired-parse-ls () + ;; Sets vars + ;; inode s mode nlink uid gid size time name sym + ;; (probably let-bound in caller) according to current file line. + ;; Returns t for succes, nil if this is no file line. + ;; Upon success, all variables are set, either to nil or the + ;; appropriate value, so they need not be initialized. + ;; Moves point within the current line to the end of the file name. + '(let ((bol (progn (beginning-of-line) (point))) + (eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (if (re-search-forward dired-re-month-and-time eol t) + (let ((mode-len 10) ; length of mode string + (tstart (progn (goto-char (match-beginning 0)) + (skip-chars-forward " ") + (point))) + (fstart (match-end 0)) + pos) + (goto-char (1+ bol)) + (skip-chars-forward " \t") + ;; This subdir had better have been created with the current + ;; setting of actual switches. Otherwise, we can't parse. + (cond + ((and (or (memq ?k dired-internal-switches) + (memq ?s dired-internal-switches)) + (memq ?i dired-internal-switches)) + (setq pos (point)) + (skip-chars-forward "0-9") + (if (setq inode (and (/= pos (point)) (string-to-int + (buffer-substring + pos (point))))) + (progn + (skip-chars-forward " ") + (setq pos (point)) + (skip-chars-forward "0-9") + (setq s (and (/= pos (point)) (string-to-int + (buffer-substring + pos (point)))))) + (setq s nil))) + ((or (memq ?s dired-internal-switches) + (memq ?k dired-internal-switches)) + (setq pos (point)) + (skip-chars-forward "0-9") + (setq s (and (/= pos (point)) (string-to-int + (buffer-substring + pos (point)))) + inode nil)) + ((memq ?i dired-internal-switches) + (setq pos (point)) + (skip-chars-forward "0-9") + (setq inode (and (/= pos (point)) (string-to-int + (buffer-substring + pos (point)))) + s nil)) + (t + (setq s nil + inode nil))) + (skip-chars-forward " 0-9") ; in case of junk + (setq mode (buffer-substring (point) (+ mode-len (point)))) + (forward-char mode-len) + (setq nlink (read (current-buffer))) + (or (integerp nlink) (setq nlink nil)) + (setq uid (buffer-substring (point) (progn + (skip-chars-forward "^ ") + (point)))) + (goto-char tstart) + (skip-chars-backward " ") + (setq pos (point)) + (skip-chars-backward "0-9") + (if (= pos (point)) + (setq size nil) + (setq size (string-to-int (buffer-substring (point) pos)))) + (skip-chars-backward " ") + ;; if no gid is displayed, gid will be set to uid + ;; but user will then not reference it anyway in PREDICATE. + (setq gid (buffer-substring (point) (progn + (skip-chars-backward "^ ") + (point))) + time (buffer-substring tstart + (progn + (goto-char fstart) + (skip-chars-backward " ") + (point))) + name (buffer-substring + fstart + (or (dired-move-to-end-of-filename t) + (point))) + sym (and (looking-at "[/*@#=|]? -> ") + (buffer-substring (match-end 0) + eol))) + t)))) ; return t if parsing was a success + + +(defun dired-mark-sexp (predicate &optional unflag-p) + "Mark files for which PREDICATE returns non-nil. +With a prefix arg, unflag those files instead. + +PREDICATE is a lisp expression that can refer to the following symbols: + + inode [integer] the inode of the file (only for ls -i output) + s [integer] the size of the file for ls -s output + (ususally in blocks or, with -k, in KByte) + mode [string] file permission bits, e.g. \"-rw-r--r--\" + nlink [integer] number of links to file + uid [string] owner + gid [string] group (If the gid is not displayed by ls, + this will still be set (to the same as uid)) + size [integer] file size in bytes + time [string] the time that ls displays, e.g. \"Feb 12 14:17\" + name [string] the name of the file + sym [string] if file is a symbolic link, the linked-to name, else nil. + +For example, use + + (equal 0 size) + +to mark all zero length files." + ;; Using sym="" instead of nil avoids the trap of + ;; (string-match "foo" sym) into which a user would soon fall. + ;; No! Want to be able look for symlinks pointing to the empty string. + ;; Can happen. Also, then I can do an (if sym ...) structure. --sandy + ;; Give `equal' instead of `=' in the example, as this works on + ;; integers and strings. + (interactive + (list + (read + (dired-read-with-history "Mark if (lisp expr): " nil + 'dired-sexpr-history)) + current-prefix-arg)) + (message "%s" predicate) + (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char)) + inode s mode nlink uid gid size time name sym) + (dired-mark-if (save-excursion + (and (dired-parse-ls) + (eval predicate))) + (format "'%s file" predicate))) + (dired-update-mode-line-modified t)) + +;;; end of dired-sex.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/dired-shell.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-shell.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,854 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-shell.el +;; Dired Version: $Revision: 1.1 $ +;; RCS: +;; Description: Commands for running shell commands on marked files. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Requirements and provisions +(provide 'dired-shell) +(require 'dired) +(autoload 'comint-mode "comint") + +;;; Variables + +(defvar dired-postscript-print-command + (concat + (if (boundp 'lpr-command) + lpr-command + (if (memq system-type + '(usg-unix-v hpux silicon-graphics-unix)) + "lp" + "lpr")) + (if (and (boundp 'lpr-switches) lpr-switches) + (concat " " + (mapconcat 'identity lpr-switches " ") + " ") + " ")) + "Command to print a postscript file.") + +(defvar dired-text-print-command (concat dired-postscript-print-command " -p") + "Command to print a text file.") + +(defvar dired-print-program-alist + (list + (cons "\\.gif$" (concat "giftoppm * | ppmtopgm | pnmtops | " + dired-postscript-print-command)) + (cons "\\.\\(fts\\|FTS\\)$" (concat "fitstopgm * | pnmtops | " + dired-postscript-print-command)) + ;; People with colour printers won't want the g-flag in djpeg + (cons "\\.\\(JPG\\|jpg\\)$" (concat "djpeg -Pg * | pnmtops | " + dired-postscript-print-command)) + (cons "\\.ps\\.\\(gz\\|Z\\)$" (concat "zcat * | " + dired-postscript-print-command)) + (cons "\\.ps$" dired-postscript-print-command) + (cons "\\.\\(gz\\|Z\\)$" (concat "zcat * | " + dired-postscript-print-command)) + (cons "\\.dvi$" "dvips") + (cons ".*" dired-text-print-command)) + "Alist of regexps and print commands. +This is used by `dired-do-print' to determine the default print command for +printing the marked files.") + +(defvar dired-auto-shell-command-alist nil + "*Alist of regexps and command lists to guess shell commands. +Each element of this list should be a list of regular expression, and a list +of guesses for shell commands to be used if the file name matches the regular +expression. The list of guesses is evalled. This alist is appended to the front +of dired-default-auto-shell-command-alist before prompting for each shell +command.") + +(defvar dired-default-auto-shell-command-alist + (list + + ;; Archiving + '("\\.tar$" + (if dired-gnutar-program + (concat dired-gnutar-program " xvf") + "tar xvf") + (if dired-gnutar-program + (concat dired-gnutar-program " tvf") + "tar tvf")) + ;; regexps for compressed archives must come before the .Z rule to + ;; be recognized: + '("\\.tar\\.\\([zZ]\\|gz\\)\\|\\.tgz$" ; .tgz is for DOS + (if dired-gnutar-program + (concat dired-gnutar-program " zxvf") + "zcat * | tar xvf -") + (if dired-gnutar-program + (concat dired-gnutar-program " ztvf") + "zcat * | tar tvf -")) + '("\\.shar.[zZ]$" (if dired-unshar-program + (concat "zcat * | " dired-unshar-program) + "zcat * | sh")) + '("\\.zoo$" "zoo x//") + '("\\.zip$" "unzip" "unzip -v") + '("\\.lzh$" "lharc x") + '("\\.arc$" "arc x") + '("\\.shar$" (if dired-unshar-program dired-unshar-program "sh")) + + ;; Encoding/compressing + '("\\.uu$" "uudecode") + '("\\.hqx$" "mcvert") + + ;; Executing (in the generalized sense) + '("\\.sh$" "sh") ; execute shell scripts + '("^[Mm]akefile$" "make -f *") + '("\\.diff$" "patch -t <") + + ;; Displaying (assumes X) + '("\\.xbm$" "bitmap") ; view X11 bitmaps + '("\\.gp$" "gnuplot") + '("\\.gif$" "xv") ; view gif pictures + '("\\.fig$" "xfig") ; edit fig pictures + '("\\.ps$" "ghostview") + + ;; Typesetting. For printing documents, see dired-print-program-alist. + '("\\.tex$" "latex" "tex") + '("\\.texi\\(nfo\\)?$" "makeinfo" "texi2dvi") + (if (eq window-system 'x) + (if dired-use-file-transformers + '("\\.dvi$" "xdvi" "dvips -o *b.ps *") + '("\\.dvi$" "xdvi" "dvips")) + (if dired-use-file-transformers + '("\\.dvi$" "dvips -o *b.ps *") + '("\\.dvi$" "dvips"))) + + ;; The last word. Things that cannot be grokked with a regexp. + '("." (if (> (length files) 1) + "tar cvf " + (and (= (length files) 1) (file-directory-p + (expand-file-name + (car files) + (dired-current-directory))) + (concat "tar cvf " (file-name-nondirectory + (directory-file-name (car files))) + ".tar")))) + ) + "Default for variable `dired-auto-shell-command-alist' (which see). +Set this to nil to turn off shell command guessing.") + +;; Might use {,} for bash or csh: +(defvar dired-shell-prefix "" + "Prepended to marked files in dired shell commands.") +(defvar dired-shell-postfix "" + "Appended to marked files in dired shell commands.") +(defvar dired-shell-separator " " + "Separates marked files in dired shell commands.") + +(defvar dired-file-wildcard ?* + "Wildcard character used by dired shell commands. +Indicates where file names should be inserted.") + +(defvar dired-shell-command-separators '(?\ ?| ?> ?< ?& ?;) + "Defines the start of a string specifying a word in a shell command.") + +(defvar dired-trans-map + (list + (cons ?f 'identity) + (cons ?n 'file-name-nondirectory) + (cons ?d 'file-name-directory) + (cons ?b 'dired-file-name-base) + (cons ?e 'dired-file-name-extension) + (cons ?v 'dired-file-name-sans-rcs-extension) + (cons ?z 'dired-file-name-sans-compress-extension)) + "Alist that associates keys with file transformer functions +Each transformer function should be a funcion of one argument, the file name. +The keys are characters.") + +(defvar dired-shell-failure-marker ?! + "*A marker to mark files on which shell commands fail. +If nil, such files are not marked.") + +;;; Internal variables + +;; Make sure this gets defined. +(defvar shell-command-history nil + "History list of previous shell commands.") + +(defvar dired-print-history nil + "History of commands used to print files.") + +(defvar dired-shell-input-start) ; only defined in shell output buffers + +;;; Utility functions and Macros + +(defun dired-shell-quote (filename) + ;; Quote a file name for inferior shell (see variable shell-file-name). + ;; Quote everything except POSIX filename characters. + ;; This should be safe enough even for really wierd shells. + (let ((result "") (start 0) end) + (while (string-match "[^---0-9a-zA-Z_./]" filename start) + (setq end (match-beginning 0) + result (concat result (substring filename start end) + "\\" (substring filename end (1+ end))) + start (1+ end))) + (concat result (substring filename start)))) + +(defun dired-uniquefy-list (list) + ;; Returns list, after removing 2nd and higher occurrences + ;; of all elements. Tests elements with equal. Retains the relative + ;; order of the elements. + ;; For small lists, this way is probably faster than sorting. + (let (result) + (while list + (or (member (car list) result) + (setq result (nconc result (list (car list))))) + (setq list (cdr list))) + result)) + +(defun dired-read-shell-command (prompt arg files) + ;; Read a dired shell command prompting with PROMPT (using read-string). + ;; ARG is the prefix arg and may be used to indicate in the prompt which + ;; files are affected. + (dired-mark-pop-up + nil 'shell files + (function + (lambda (prompt files) + (let* ((default (car shell-command-history)) + (guesses (dired-guess-default files)) + (len (length guesses)) + cmd) + (or (zerop len) + (setq prompt (format "%s{%d guess%s} " + prompt len (if (= len 1) "" "es")))) + (if default (setq prompt (concat prompt "[" default "] "))) + (put 'guesses 'no-default t) ; for gmhist, in case. + (setq guesses (nconc guesses (copy-sequence shell-command-history)) + cmd (dired-read-with-history prompt nil 'guesses)) + (if (string-match "^[ \t\n]*$" cmd) + (if default + (setq cmd default) + (error "No shell command given."))) + (setq shell-command-history + (dired-uniquefy-list + (cons cmd shell-command-history))) + cmd))) + (format prompt (dired-mark-prompt arg files)) files)) + +(defmacro dired-trans-subst (transformers filename dir) +;; Applies each transformer supplied in the string TRANSFORMERS in sequence +;; to FILE and returns the concatenation of the results. Also unquotes \\'s. +;; Returns a string if no file transformations were done, otherwise a list +;; consisting of a single string. + (` (let* ((transformers (, transformers)) + (filename (, filename)) + (len (length transformers)) + (pos 0) + (last 0) + (transformed nil) + (quoted nil) + char result trans) + (while (< pos len) + (setq char (aref transformers pos)) + (cond + (quoted (setq pos (1+ pos) + quoted nil)) + ((= ?\\ char) + (setq quoted t + result (concat result (substring transformers last pos)) + pos (1+ pos) + last pos)) + ((and (null quoted) (= char dired-file-wildcard)) + (setq pos (1+ pos) + trans (and (< pos len) + dired-use-file-transformers + (assq (aref transformers pos) + dired-trans-map)) + transformed t) + (if trans + (setq result (concat result + (substring transformers last (1- pos)) + (funcall (cdr trans) filename)) + pos (1+ pos) + last pos) + (setq result (concat result (substring transformers last (1- pos)) + (dired-make-relative filename (, dir) t)) + last pos))) + ((setq pos (1+ pos))))) + (if result + (progn + (setq result (dired-shell-quote + (concat result (substring transformers last)))) + (if transformed (list result) result)) + transformers)))) + +(defun dired-trans-filenames (transformers files dir) + ;; Applies a transformer string to a list of filenames, + ;; concatenating them into a string. The result will be prefixed + ;; by dired-shell-prefix, the filenames separated by dired-shell-separator, + ;; and postfixed by dired-shell-postfix. + ;; Returns a list if filename subst. was done. A string otherwise. + (let ((list files) + (res nil) + trans) + (while list + (setq trans (dired-trans-subst transformers (car list) dir)) + (if (listp trans) + (setq res (nconc res trans) + list (cdr list)) + (setq res trans + list nil))) + (if (listp res) + (list + (if (> (length files) 1) + (concat dired-shell-prefix + (mapconcat 'identity res dired-shell-separator) + dired-shell-postfix) + (car res))) + res))) + +(defun dired-trans-command (command files dir) + ;; Do all of the trans substitutions in COMMAND for the list + ;; of files FILES. FILES must be a list of *absolute* pathnames. + ;; DIR is an absolute directory wrto which filenames may be relativized. + (let ((len (length command)) + (start 0) + (pos 0) + (last 0) + result char transed transform) + (while (< pos len) + ;; read over word separators. + (while (and (< pos len) (memq (aref command pos) + dired-shell-command-separators)) + (setq pos (1+ pos))) + (setq start pos) + ;; read a word + (while (and (< pos len) (not (memq (setq char (aref command pos)) + dired-shell-command-separators))) + (setq pos (1+ pos)) + ;; look out for quoted separators + (and (= ?\\ char) (< pos len) (or (memq (setq char (aref command pos)) + dired-shell-command-separators) + (= ?\\ char)) + (setq pos (1+ pos)))) + (setq transform (if (= start pos) + "" + (dired-trans-filenames (substring command start pos) + files dir)) + ;; remember if we did any transforming + transed (or transed (listp transform)) + result (concat result + (substring command last start) + (if (listp transform) + (car transform) + transform)) + last pos)) + (if transed + ;; just return result + result + ;; add the filenames at the end. + (let ((fns (if (> (length files) 1) + (concat dired-shell-prefix + (mapconcat + (function + (lambda (fn) + (dired-shell-quote + (dired-make-relative fn dir t)))) + files dired-shell-separator) + dired-shell-postfix) + (dired-shell-quote + (dired-make-relative (car files) dir t))))) + (concat result " " fns))))) + +(defun dired-shell-stuff-it (command file-list dir on-each) + ;; Make up a shell command line from COMMAND and FILE-LIST. + ;; If ON-EACH is t, COMMAND should be applied to each file, else + ;; simply concat all files and apply COMMAND to this. + ;; If ON-EACH is 'dir, the command is run in the directory of each file + ;; In this case FILE-LIST must be a list of full paths. + ;; FILE-LIST's elements will be quoted for the shell. + (cond + ((eq on-each 'dir) + (let ((subshell-dir nil) + (list file-list) + (result nil)) + (while list + (let ((cmd (dired-trans-command command (list (car list)) + (file-name-directory (car list)))) + (fdir (dired-shell-quote (file-name-directory (car list))))) + (setq result + (apply 'concat + result + (if subshell-dir + (if (string-equal dir subshell-dir) + (list "\; " cmd) + (if (string-equal dir fdir) + (progn + (setq subshell-dir nil) + (list "\)\; " cmd)) + (setq subshell-dir fdir) + (list "\)\; \(cd " + fdir + "\; " + cmd))) + (if (string-equal fdir dir) + (list (and result "\; ") + cmd) + (setq subshell-dir fdir) + (list (and result "\; ") + "\(cd " + fdir + "\; " + cmd))))) + (setq list (cdr list)))) + (concat result (and subshell-dir ")")))) + (on-each + (mapconcat (function + (lambda (fn) + (dired-trans-command command (list fn) dir))) + file-list "; ")) + + (t (dired-trans-command command file-list dir)))) + +(defun dired-guess-default (files) + ;; Guess a list of possible shell commands for FILES. + (and dired-default-auto-shell-command-alist + files + (let ((alist (append dired-auto-shell-command-alist + dired-default-auto-shell-command-alist)) + guesses) + (while alist + (let* ((elt (car alist)) + (regexp (car elt))) + (setq guesses + (nconc guesses + (catch 'missed + (mapcar (function + (lambda (file) + (or (string-match regexp file) + (throw 'missed nil)))) + files) + (delq nil (mapcar 'eval (cdr elt))))))) + (setq alist (cdr alist))) + (dired-uniquefy-list guesses)))) + +(defun dired-shell-unhandle-file-name (filename) + "Turn a file name into a form that can be sent to a shell process. +This is particularly usefull if we are sending file names to a remote shell." + (let ((handler (find-file-name-handler filename 'dired-shell-unhandle-file-name))) + (if handler + (funcall handler 'dired-shell-unhandle-file-name filename) + filename))) + +;;; Actually running the shell command + +(defun dired-run-shell-command-closeout (buffer &optional message) + ;; Report on the number of lines produced by a shell command. + (if (get-buffer buffer) + (save-excursion + (set-buffer buffer) + (if (zerop (buffer-size)) + (progn + (if message + (message "Shell command completed with no output. %s" + message) + (message "Shell command completed with no output.")) + (kill-buffer buffer)) + (set-window-start (display-buffer buffer) 1) + (if message + (message "Shell command completed. %s" message) + (message "Shell command completed.")))))) + +(defun dired-rsc-filter (proc string) + ;; Do save-excursion by hand so that we can leave point + ;; numerically unchanged despite an insertion immediately + ;; after it. + (let* ((obuf (current-buffer)) + (buffer (process-buffer proc)) + opoint + (window (get-buffer-window buffer)) + (pos (window-start window))) + (unwind-protect + (progn + (set-buffer buffer) + (setq opoint (point)) + (goto-char (point-max)) + (insert-before-markers string)) + ;; insert-before-markers moved this marker: set it back. + (set-window-start window pos) + ;; Finish our save-excursion. + (goto-char opoint) + (set-buffer obuf)))) + +(defun dired-rsc-sentinel (process signal) + ;; Sentinel function used by dired-run-shell-command + (if (memq (process-status process) '(exit signal)) + (let ((buffer (get-buffer (process-buffer process)))) + (if buffer + (save-excursion + (set-buffer buffer) + (if (zerop (buffer-size)) + (message + "Dired & shell command completed with no output.") + (let ((lines (count-lines dired-shell-input-start + (point-max)))) + (message + "Dired & shell command completed with %d line%s of output." + lines (dired-plural-s lines)))) + (setq mode-line-process nil))) + (delete-process process)))) + +(defun dired-shell-call-process (command dir &optional in-background) + ;; Call a shell command as a process in the current buffer. + ;; The process should try to run in DIR. DIR is also + ;; used to lookup a file-name-handler. + ;; Must return the process object if IN-BACKGROUND is non-nil, + ;; otherwise the process exit status. + (let ((handler (find-file-name-handler dir 'dired-shell-call-process))) + (if handler + (funcall handler 'dired-shell-call-process command dir in-background) + (let ((process-connection-type ; don't waste pty's + (null (null in-background)))) + (setq default-directory dir) + (if in-background + (progn + (setq mode-line-process '(": %s")) + (start-process "Shell" (current-buffer) + shell-file-name "-c" command)) + (call-process shell-file-name nil t nil "-c" command)))))) + +(defun dired-run-shell-command (command dir in-background &optional append) + ;; COMMAND is shell command + ;; DIR is directory in which to do the shell command. + ;; If IN-BACKGROUND is non-nil, the shell command is run in the background. + ;; If it is a string, this is written as header into the output buffer + ;; before the command is run. + ;; If APPEND is non-nil, the results are appended to the contents + ;; of *shell-command* buffer, without erasing its previous contents. + (save-excursion + (if in-background + (let* ((buffer (get-buffer-create + "*Background Shell Command Output*")) + (n 2) + proc) + ;; No reason why we can't run two+ background commands. + (while (get-buffer-process buffer) + (setq buffer (get-buffer-create + (concat "*Background Shell Command Output*<" + (int-to-string n) ">")) + n (1+ n))) + (set-buffer buffer) + (or (eq major-mode 'comint-mode) + (progn + (comint-mode) + (set (make-local-variable 'comint-prompt-regexp) + "^[^\n]*\\? *"))) + (display-buffer buffer) + (barf-if-buffer-read-only) + ;; If will kill a process, query first. + + (set (make-local-variable 'dired-shell-input-start) (point-min)) + (if append + (progn + (goto-char (point-max)) + (or (= (preceding-char) ?\n) (bobp) (insert "\n"))) + (erase-buffer) + (if (stringp in-background) + (progn + (insert in-background) + (set (make-local-variable 'dired-shell-input-start) + (point))))) + (setq proc (dired-shell-call-process command dir t)) + (set-marker (process-mark proc) (point)) + (set-process-sentinel proc 'dired-rsc-sentinel) + (set-process-filter proc 'dired-rsc-filter) + nil) ; return + (let ((buffer (get-buffer-create "*Shell Command Output*"))) + (set-buffer buffer) + (barf-if-buffer-read-only) + (set (make-local-variable 'dired-shell-input-start) (point-min)) + (if append + (progn + (goto-char (point-max)) + (or (= (preceding-char) ?\n) (bobp) (insert "\n"))) + (erase-buffer)) + (dired-shell-call-process command dir))))) + +;;; User commands + +(defun dired-do-shell-command (command arg files &optional in-background) + ;; ARG = (16) means operate on each file, in its own directory. + ;; ARG = (4) means operate on each file, but in the current + ;; default-directory. + "Run a shell command COMMAND on the marked files. +If no files are marked or a non-zero numeric prefix arg is given, +the next ARG files are used. Use prefix 1 to indicate the current file. + +Normally the shell command is executed in the current dired subdirectory. +This is the directory in the dired buffer which currently contains the point. +One shell command is run for all of the files. +e.g. cmd file1 file2 file3 ... +If the total length of of the command exceeds 10000 characters, the files will +be bunched to forms commands shorter than this length, and successive commands +will be sent. + +With a prefix of \\[universal-argument], a separate command for each file will +be executed. + +With a prefix of \\[universal-argument] \\[universal-argument], a separate command will be sent for each file, +and the command will be executed in the directory of that file. The explicit +command will be of the form + + cd dir; cmd file + +When prompting for the shell command, dired will always indicate the directory +in which the command will be executed. + +The following documentation depends on the settings of `dired-file-wildcard', +`dired-shell-command-separators', `dired-trans-map', `dired-shell-prefix', +`dired-shell-separator', and `dired-shell-postfix'. See the documentation for +these variables. Below, I will assume default settings for these variables. + +If the shell command contains a *, then the list of files is substituted for *. +The filenames will be written as relative to the directory in which the shell +command is executing. If there is no *, and the command does not end in &, +then the files are appended to the end of the command. If the command ends in +a &, then the files are inserted before the &. + +If `dired-use-file-transformers' is non-nil, then certain 2-character +sequences represent parts of the file name. +The default transformers are: +*f = full file name +*n = file name without directory +*d = file name's directory + This will end in a \"/\" in unix. +*e = file names extension + By default this the part of the file name without directory, which + proceeds the first \".\". If \".\" is the first character of the name, + then this \".\" is ignored. The definition of extension can + be customized with `dired-filename-re-ext'. +*b = file base name + This is the part of the file name without directory that precedes + the extension. +*v = file name with out version control extension (i.e. \",v\") +*z = file name without compression extension + (i.e. \".Z\", \".z\", or \".gz\") + +Shell commands are divided into words separated by spaces. Then for each +word the file name transformers are applied to the list of files, the result +concatenated together and substituted for the word in the shell command. + +For example + cmd -a *f -b *d*b.fizzle applied to /foo/bar and /la/di/da results in + cmd -a /foo/bar /la/di/da -b /foo/bar.fizzle /la/di/da.fizzle + +The \"on-each\" prefixes \\[universal-argument] and 0, also apply while +using file transformers. As well, when using file-transformers * still +represents the file name relative to the current directory. Not that this +differs from *f, which always represents the full pathname. + +A \"\\\" can always be used to quote any character having special meaning. +For example, if the current directory is /la, then *n applied +to /la/di/da returns la, whereas *\\n returns di/dan. Similarly, +\"*d\\ *n\" returns \"/la/di da\". + +The prefix character for file name transformers is always the same as +`dired-file-wildcard'." + + (interactive + (let ((on-each (or (equal '(4) current-prefix-arg) + (equal '(16) current-prefix-arg))) + (files (dired-get-marked-files + nil (and (not (consp current-prefix-arg)) + current-prefix-arg))) + (dir (and (not (equal current-prefix-arg '(16))) + (dired-current-directory)))) + (list + (dired-read-shell-command + (concat (if dir + (format "! in %s" (dired-abbreviate-file-name dir)) + "cd ; ! ") + "on " + (if on-each "each ") + "%s: ") + (and (not on-each) current-prefix-arg) + (if dir + (mapcar (function + (lambda (fn) + (dired-make-relative fn dir t))) + files) + files)) + current-prefix-arg files nil))) + + ;; Check for background commands + (if (string-match "[ \t]*&[ \t]*$" command) + (setq command (substring command 0 (match-beginning 0)) + in-background t)) + + ;; Look out for remote file names. + + (let* ((on-each (or (equal arg '(4)) (and (equal arg '(16)) 'dir))) + (ufiles (mapcar 'dired-shell-unhandle-file-name files)) + (dir (dired-current-directory)) + (udir (dired-shell-unhandle-file-name dir))) + + (save-excursion ; in case `shell-command' changes buffer + (cond + + ((null ufiles) + ;; Just run as a command on no files. + (if in-background + (dired-run-shell-command command dir t) + (dired-run-shell-command command dir nil) + (dired-run-shell-command-closeout "*Shell Command Output*"))) + + (in-background + ;; Can't use dired-bunch-files for background shell commands. + ;; as we will create a bunch of process running simultaneously. + ;; A better solution needs to be found. + (dired-run-shell-command + (dired-shell-stuff-it command ufiles udir on-each) + dir (if (equal arg '(16)) + (concat "cd ; \"" command "\"\n\n") + (concat "\"" command "\" in " dir "\n\n")))) + (on-each + (let ((buff (get-buffer "*Shell Command Output*")) + failures this-command this-dir ufile return message) + (if buff + (save-excursion + (set-buffer buff) + (erase-buffer))) + (while ufiles + (setq ufile (car ufiles)) + (if (eq on-each 'dir) + (setq this-dir (dired-shell-quote (file-name-directory (directory-file-name ufile))) + this-command (concat "cd " this-dir "; " command)) + (setq this-command command) + (or this-dir (setq this-dir udir))) + (setq return + (dired-run-shell-command + (dired-shell-stuff-it this-command (list ufile) this-dir nil) + this-dir nil t)) + (if (and (integerp return) (/= return 0)) + (save-excursion + (let ((file (nth (- (length files) (length (member ufile ufiles))) files))) + (if (and dired-shell-failure-marker + (dired-goto-file file)) + (let ((dired-marker-char dired-shell-failure-marker)) + (dired-mark 1))) + (setq failures (cons file failures))))) + (setq ufiles (cdr ufiles))) + (if failures + (let ((num (length failures))) + (setq message + (if dired-shell-failure-marker + (format + "Marked %d failure%s with %c." + num (dired-plural-s num) + dired-shell-failure-marker) + "Failed on %d file%s." num + (dired-plural-s num))) + (dired-log + (current-buffer) + "Shell command %s failed (non-zero exit status) for:\n %s" + command failures) + (dired-log (current-buffer) t))) + (dired-run-shell-command-closeout "*Shell Command Output*" message))) + + (t + (dired-bunch-files + (- 10000 (length command)) + (function (lambda (&rest ufiles) + (dired-run-shell-command + (dired-shell-stuff-it command ufiles udir nil) + dir nil) + nil)) ; for the sake of nconc in dired-bunch-files + nil ufiles) + (dired-run-shell-command-closeout "*Shell Command Output*")))) + ;; Update any directories + (or in-background + (let ((dired-no-confirm '(revert-subdirs))) + (dired-verify-modtimes))))) + +(defun dired-do-background-shell-command (command arg files) + "Like \\[dired-do-shell-command], but starts command in background. +Note that you can type input to the command in its buffer. +This requires background.el from the comint package to work." + ;; With the version in emacs-19.el, you can alternatively just + ;; append an `&' to any shell command to make it run in the + ;; background, but you can't type input to it. + (interactive + (let ((on-each (or (equal '(4) current-prefix-arg) + (equal '(16) current-prefix-arg))) + (files (dired-get-marked-files + nil (and (not (consp current-prefix-arg)) + current-prefix-arg))) + (dir (and (not (equal current-prefix-arg '(16))) + (dired-current-directory)))) + (list + (dired-read-shell-command + (concat "& " + (if dir + (format "in %s " (dired-abbreviate-file-name dir)) + "cd ; ") + "on " + (if on-each "each ") + "%s: ") + (and (not on-each) current-prefix-arg) + (if dir + (mapcar (function + (lambda (fn) + (dired-make-relative fn dir t))) + files) + files)) + current-prefix-arg files))) + (dired-do-shell-command command arg files t)) + +;;; Printing files + +(defun dired-do-print (&optional arg command files) + "Print the marked (or next ARG) files. +Uses the shell command coming from variable `dired-print-program-alist'." + (interactive + (progn + (if dired-print-history + (setq dired-print-history (dired-uniquefy-list dired-print-history)) + (setq dired-print-history (mapcar 'cdr dired-print-program-alist))) + (let* ((files (dired-get-marked-files nil current-prefix-arg)) + (rel-files (mapcar (function + (lambda (fn) + (dired-make-relative + fn + (dired-current-directory) t))) + files)) + (alist dired-print-program-alist) + (first (car files)) + (dired-print-history (copy-sequence dired-print-history)) + elt initial command) + ;; For gmhist + (put 'dired-print-history 'no-default t) + (if first + (while (and alist (not initial)) + (if (string-match (car (car alist)) first) + (setq initial (cdr (car alist))) + (setq alist (cdr alist))))) + (if (and initial (setq elt (member initial dired-print-history))) + (setq dired-print-history (nconc + (delq (car elt) dired-print-history) + (list initial)))) + (setq command + (dired-mark-read-string + "Print %s with: " + initial 'print current-prefix-arg rel-files + 'dired-print-history)) + (list current-prefix-arg command files)))) + (or files + (setq files (dired-get-marked-files nil arg))) + (while files + (dired-print-file command (car files)) + (setq files (cdr files)))) + +(defun dired-print-file (command file) + ;; Using COMMAND, print FILE. + (let ((handler (find-file-name-handler file 'dired-print-file))) + (if handler + (funcall handler 'dired-print-file command file) + (let ((rel-file (dired-make-relative file (dired-current-directory) t))) + (message "Spooling %s..." rel-file) + (shell-command (dired-trans-command command (list file) "")) + (message "Spooling %s...done" rel-file))))) + +;;; end of dired-shell.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/dired-uu.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-uu.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,116 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-uu.el +;; Dired Version: $Revision: 1.1 $ +;; RCS: +;; Description: Commands for uuencoding/uudecoding marked files. +;; Author: Sandy Rutherford +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Requirements and provisions +(provide 'dired-uu) +(require 'dired) + +(defvar dired-uu-files-to-decode nil) +;; Fluid var to pass data inside dired-create-files. + +(defun dired-uucode-file (file ok-flag) + ;; uuencode or uudecode FILE. + ;; Don't really support the ok-flag, but needed for compatibility + (let ((handler (find-file-name-handler file 'dired-uucode-file))) + (cond (handler + (funcall handler 'dired-uucode-file file ok-flag)) + ((or (file-symlink-p file) (file-directory-p file)) + nil) + (t + (if (assoc file dired-uu-files-to-decode) + (let ((default-directory (file-name-directory file))) + (if (dired-check-process + (concat "Uudecoding " file) shell-file-name "-c" + (format "uudecode %s" file)) + (signal 'file-error (list "Error uudecoding" file)))) + (let ((nfile (concat file ".uu"))) + (if (dired-check-process + (concat "Uuencoding " file) shell-file-name "-c" + (format "uuencode %s %s > %s" + file (file-name-nondirectory file) nfile)) + (signal 'file-error (list "Error uuencoding" file))))))))) + +(defun dired-uucode-out-file (file) + ;; Returns the name of the output file for the uuencoded FILE. + (let ((buff (get-buffer-create " *dired-check-process output*")) + (case-fold-search t)) + (save-excursion + (set-buffer buff) + (erase-buffer) + (if (string-equal "18." (substring emacs-version 0 3)) + (call-process "head" file buff nil "-n" "1") + (insert-file-contents file nil 0 80)) + (goto-char (point-min)) + (if (looking-at "begin [0-9]+ \\([^\n]*\\)\n") + (expand-file-name + (buffer-substring (match-beginning 1) (match-end 1)) + (file-name-directory file)) + nil)))) + +(defun dired-do-uucode (&optional arg files to-decode) + "Uuencode or uudecode marked (or next ARG) files." + (interactive + (let* ((dir (dired-current-directory)) + (files (dired-get-marked-files nil current-prefix-arg)) + (arg (prefix-numeric-value current-prefix-arg)) + (total (length files)) + rfiles decoders ofile decode encode hint-p) + (mapcar + (function + (lambda (fn) + (if (setq ofile (dired-uucode-out-file fn)) + (setq decoders (cons (cons fn ofile) decoders))))) + files) + (setq decode (length decoders) + encode (- total decode) + hint-p (not (or (zerop decode) (zerop encode)))) + (setq rfiles + (mapcar + (function + (lambda (fn) + (if hint-p + (concat + (if (assoc fn decoders) " [de] " " [en] ") + (dired-make-relative fn dir t)) + (dired-make-relative fn dir t)))) + files)) + (or (memq 'uuencode dired-no-confirm) + (dired-mark-pop-up nil 'uuencode rfiles 'y-or-n-p + (cond + ((null decoders) + (if (= encode 1) + (format "Uuencode %s? " (car rfiles)) + (format "Uuencode %d file%s? " + encode (dired-plural-s encode)))) + ((zerop encode) + (if (= decode 1) + (format "Uudecode %s? " (car rfiles)) + (format "Uudecode %d file%s? " + decode (dired-plural-s decode)))) + (t + (format "Uudecode %d and uuencode %d file%s? " + decode encode (dired-plural-s encode))))) + (setq arg 0)) + (list arg files decoders))) + (let ((dired-uu-files-to-decode to-decode) + out-file) + (if (not (zerop arg)) + (dired-create-files + 'dired-uucode-file + "Uuencode or Uudecode" + files + (function + (lambda (fn) + (if (setq out-file (assoc fn dired-uu-files-to-decode)) + (cdr out-file) + (concat fn ".uu")))) + dired-keep-marker-uucode nil t)))) + +;;; end of dired-uu.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/dired-vir.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-vir.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,137 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-vir.el +;; Dired Version: $Revision: 1.1 $ +;; RCS: +;; Description: Virtual dired mode for browsing ls -lR listings. +;; Author: Sebastian Kremer +;; Created: 7-Mar-1991 16:00 +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Requirements and provisions +(provide 'dired-vir) +(require 'dired) + +(defun dired-virtual (dirname &optional switches) + "Put this buffer into Virtual Dired mode. + +In Virtual Dired mode, all commands that do not actually consult the +filesystem will work. + +This is useful if you want to peruse and move around in an ls -lR +output file, for example one you got from an ftp server. With +efs, you can even dired a directory containing an ls-lR file, +visit that file and turn on virtual dired mode. But don't try to save +this file, as dired-virtual indents the listing and thus changes the +buffer. + +If you have save a Dired buffer in a file you can use \\[dired-virtual] to +resume it in a later session. + +Type \\\\[revert-buffer] in the +Virtual Dired buffer and answer `y' to convert the virtual to a real +dired buffer again. You don't have to do this, though: you can relist +single subdirs using \\[dired-do-redisplay]. +" + + ;; DIRNAME is the top level directory of the buffer. It will become + ;; its `default-directory'. If nil, the old value of + ;; default-directory is used. + + ;; Optional SWITCHES are the ls switches to use. + + ;; Shell wildcards will be used if there already is a `wildcard' + ;; line in the buffer (thus it is a saved Dired buffer), but there + ;; is no other way to get wildcards. Insert a `wildcard' line by + ;; hand if you want them. + + (interactive + (list (read-string "Virtual Dired directory: " (dired-virtual-guess-dir)))) + (goto-char (point-min)) + (or (looking-at " ") + ;; if not already indented, do it now: + (indent-region (point-min) (point-max) 2)) + (or dirname (setq dirname default-directory)) + (setq dirname (expand-file-name (file-name-as-directory dirname))) + (setq default-directory dirname) ; contains no wildcards + (let ((wildcard (save-excursion + (goto-char (point-min)) + (forward-line 1) + (and (looking-at "^ wildcard ") + (buffer-substring (match-end 0) + (progn (end-of-line) (point))))))) + (if wildcard + (setq dirname (expand-file-name wildcard default-directory)))) + ;; If raw ls listing (not a saved old dired buffer), give it a + ;; decent subdir headerline: + (goto-char (point-min)) + (or (looking-at dired-subdir-regexp) + (dired-insert-headerline default-directory)) + (dired-mode dirname (or switches dired-listing-switches)) + (setq mode-name "Virtual Dired" + revert-buffer-function 'dired-virtual-revert) + (set (make-local-variable 'dired-subdir-alist) nil) + (dired-build-subdir-alist) + (goto-char (point-min)) + (dired-initial-position dirname)) + +(defun dired-virtual-guess-dir () + + ;; Guess and return appropriate working directory of this buffer, + ;; assumed to be in Dired or ls -lR format. + ;; The guess is based upon buffer contents. + ;; If nothing could be guessed, returns nil. + + (let ((regexp "^\\( \\)?\\([^ \n\r]*\\)\\(:\\)[\n\r]") + (subexpr 2)) + (goto-char (point-min)) + (cond ((looking-at regexp) + ;; If a saved dired buffer, look to which dir and + ;; perhaps wildcard it belongs: + (let ((dir (buffer-substring (match-beginning subexpr) + (match-end subexpr)))) + (file-name-as-directory dir))) + ;; Else no match for headerline found. It's a raw ls listing. + ;; In raw ls listings the directory does not have a headerline + ;; try parent of first subdir, if any + ((re-search-forward regexp nil t) + (file-name-directory + (directory-file-name + (file-name-as-directory + (buffer-substring (match-beginning subexpr) + (match-end subexpr)))))) + (t ; if all else fails + nil)))) + + +(defun dired-virtual-revert (&optional arg noconfirm) + (if (not + (y-or-n-p "Cannot revert a Virtual Dired buffer - switch to Real Dired mode? ")) + (error "Cannot revert a Virtual Dired buffer.") + (setq mode-name "Dired" + revert-buffer-function 'dired-revert) + (revert-buffer))) + +;; A zero-arg version of dired-virtual. +;; You need my modified version of set-auto-mode for the +;; `buffer-contents-mode-alist'. +;; Or you use infer-mode.el and infer-mode-alist, same syntax. +(defun dired-virtual-mode () + "Put current buffer into virtual dired mode (see `dired-virtual'). +Useful on `buffer-contents-mode-alist' (which see) with the regexp + + \"^ \\(/[^ /]+\\)/?+:$\" + +to put saved dired buffers automatically into virtual dired mode. + +Also useful for `auto-mode-alist' (which see) like this: + + \(setq auto-mode-alist (cons '(\"[^/]\\.dired$\" . dired-virtual-mode) + auto-mode-alist)\) +" + (interactive) + (dired-virtual (dired-virtual-guess-dir))) + +;;; end of dired-vir.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/dired-xemacs.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-xemacs.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,802 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-xemacs.el +;; Dired Version: $Revision: 1.1 $ +;; RCS: +;; Description: dired functions for XEmacs +;; Author: Mike Sperber +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide 'dired-xemacs) +(require 'dired) + +(require 'backquote) + +;;; Variables + +;; kludge +(defun dired-demarkify-regexp (re) + (if (string-equal (substring re 0 (length dired-re-maybe-mark)) + dired-re-maybe-mark) + (concat "^" (substring re + (length dired-re-maybe-mark) + (length re))) + re)) + +(defvar dired-do-highlighting t + "Set if we should use highlighting according to filetype.") + +(defvar dired-do-interactive-permissions t + "Set if we should allow interactive chmod.") + +(defvar dired-re-raw-dir (dired-demarkify-regexp dired-re-dir)) +(defvar dired-re-raw-sym (dired-demarkify-regexp dired-re-sym)) +(defvar dired-re-raw-exe (dired-demarkify-regexp dired-re-exe)) + +(defvar dired-re-raw-boring (dired-omit-regexp) + "Regexp to match backup, autosave and otherwise boring files.") + +(defvar dired-re-raw-socket (concat "^" dired-re-inode-size "s")) + +(defvar dired-re-raw-setuid + (concat "^" dired-re-inode-size + "-[-r][-w][Ss][-r][-w][sx][-r][-w][xst]") + "setuid plain file (even if not executable)") + +(defvar dired-re-raw-setgid + (concat "^" dired-re-inode-size + "-[-r][-w][-x][-r][-w][Ss][-r][-w][xst]") + "setgid plain file (even if not executable)") + +(defvar dired-re-pre-permissions "^.? ?[0-9 ]*[-d]" + "Regexp matching the preamble to file permissions part of a dired line. +This shouldn't match socket or symbolic link lines (which aren't editable).") + +(defvar dired-re-permissions "[-r][-w][-Ssx][-r][-w][-sx][-r][-w][-xst]" + "Regexp matching the file permissions part of a dired line.") + +;;; Setup + +(setq dired-modeline-tracking-cmds '(mouse-track)) + +;;; Make needed faces if the user hasn't already done so. +;;; Respect X resources (`make-face' uses them when they exist). + +(let ((change-it + (function (lambda (face) + (or (if (fboundp 'facep) + (facep face) + (memq face (face-list))) + (make-face face)) + (not (face-differs-from-default-p face)))))) + + (if (funcall change-it 'dired-face-marked) + (progn + (set-face-background 'dired-face-marked "PaleVioletRed" + 'global '(color) 'append) + (set-face-underline-p 'dired-face-marked t + 'global '(mono) 'append) + (set-face-underline-p 'dired-face-marked t + 'global '(grayscale) 'append))) + (if (funcall change-it 'dired-face-deleted) + (progn + (set-face-background 'dired-face-deleted "LightSlateGray" + 'global '(color) 'append) + (set-face-underline-p 'dired-face-deleted t + 'global '(mono) 'append) + (set-face-underline-p 'dired-face-deleted t + 'global '(grayscale) 'append))) + (if (funcall change-it 'dired-face-directory) + (make-face-bold 'dired-face-directory)) + (if (funcall change-it 'dired-face-executable) + (progn + (set-face-foreground 'dired-face-executable "SeaGreen" + 'global '(color) 'append) + (make-face-bold 'dired-face-executable))) + (if (funcall change-it 'dired-face-setuid) + (progn + (set-face-foreground 'dired-face-setuid "Red" + 'global '(color) 'append) + (make-face-bold 'dired-face-setuid))) + (if (funcall change-it 'dired-face-socket) + (progn + (set-face-foreground 'dired-face-socket "Gold" + 'global '(color) 'append) + (make-face-italic 'dired-face-socket))) + (if (funcall change-it 'dired-face-symlink) + (progn + (set-face-foreground 'dired-face-symlink "MediumBlue" + 'global '(color) 'append) + (make-face-bold 'dired-face-symlink))) + + (if (funcall change-it 'dired-face-boring) + (progn + (set-face-foreground 'dired-face-boring "Grey" + 'global '(color) 'append) + (set-face-background-pixmap + 'dired-face-boring + [xbm :data (32 2 "\125\125\125\125\252\252\252\252")] + 'global '(mono) 'append) + (set-face-background-pixmap + 'dired-face-boring + [xbm :data (32 2 "\125\125\125\125\252\252\252\252")] + 'global '(grayscale) 'append))) + (if (funcall change-it 'dired-face-permissions) + (progn + (set-face-foreground 'dired-face-permissions "MediumOrchid" + 'global '(color) 'append) + (set-face-underline-p 'dired-face-deleted t + 'global '(mono) 'append) + (set-face-underline-p 'dired-face-deleted t + 'global '(grayscale) 'append)))) + +;;; Menus + +(defvar dired-subdir-menu nil "The Subdir menu for dired") +(defvar dired-mark-menu nil "The Mark menu for dired") +(defvar dired-do-menu nil "The Do menu for dired") +(defvar dired-regexp-menu nil "The Regexp menu for dired") +(defvar dired-look-menu nil "The Look menu for dired") +(defvar dired-sort-menu nil "The Sort menu for dired") +(defvar dired-help-menu nil "The Help menu for dired") + +(defvar dired-menubar-menus + '(("Subdir" . dired-subdir-menu) + ("Mark" . dired-mark-menu) + ("Do" . dired-do-menu) + ("Regexp" . dired-regexp-menu) + ("Look" . dired-look-menu) + ("Sort" . dired-sort-menu)) + "All the dired menus.") + +(defvar dired-visit-popup-menu nil "The Visit popup for dired") +(defvar dired-do-popup-menu nil "The Do popup for dired") + +(defun dired-setup-menus () + (setq + dired-visit-popup-menu + '(["Find File" dired-find-file t] + ["Find in Other Window" dired-find-file-other-window t] + ["Find in Other Frame" dired-find-file-other-frame t] + ["View File" dired-view-file t] + ["Display in Other Window" dired-find-file-other-window t])) + + (setq + dired-do-popup-menu + '(["Copy to..." dired-do-copy t] + ["Rename to..." dired-do-rename t] + ["Compress/Uncompress" dired-do-compress t] + ["Uuencode/Uudecode" dired-do-uucode t] + ["Change Mode..." dired-do-chmod t] + ["Change Owner..." dired-do-chown t] + ["Change Group..." dired-do-chgrp t] + ["Load" dired-do-load t] + ["Byte-compile" dired-do-byte-compile t] + ["Hardlink to..." dired-do-hardlink t] + ["Symlink to..." dired-do-symlink t] + ["Shell Command..." dired-do-shell-command t] + ["Background Shell Command..." dired-do-background-shell-command t] + ["Delete" dired-do-delete t])) + + (setq + dired-subdir-menu + (list + ["Next Subdir" dired-next-subdir t] + ["Prev Subdir" dired-prev-subdir t] + ["Next Dirline" dired-next-dirline t] + ["Prev Dirline" dired-prev-dirline t] + ["Up Dir" dired-up-directory t] + ["Down Dir" dired-down-directory t] + ["Insert This Subdir" dired-maybe-insert-subdir t] + ["Create Directory..." dired-create-directory t] + ["Kill This Subdir" dired-kill-subdir t] + "-- Commands on All Files in Subdir --" + ["Redisplay Subdir" dired-redisplay-subdir t] + ["Mark Files" dired-mark-subdir-files t] + ["Flag Files for Deletion" dired-flag-subdir-files t] + ["Compress Uncompressed Files" dired-compress-subdir-files t] + (vector "Uncompress Compressed Files" + '(let ((current-prefix-arg t)) + (dired-compress-subdir-files)) + ':keys (dired-key-description 'dired-compress-subdir-files + 'universal-argument)))) + + (setq + dired-mark-menu + (list + ["Next Marked" dired-next-marked-file t] + ["Previous Marked" dired-prev-marked-file t] + ["Change Marks..." dired-change-marks t] + ["Unmark All" dired-unmark-all-files t] + (vector "Toggle marks..." + '(let ((current-prefix-arg t)) + (call-interactively 'dired-change-marks)) + ':keys (dired-key-description 'dired-change-marks + 'universal-argument)) + ["Mark Symlinks" dired-mark-symlinks t] + ["Mark Directories" dired-mark-directories t] + ["Mark Old Backups" dired-clean-directory t] + ["Mark Executables" dired-mark-executables t] + ["Flag Backup Files" dired-flag-backup-files t] + ["Flag Auto-save Files" dired-flag-auto-save-files t] + ["Set new marker char" dired-set-marker-char t] + ["Restore marker char" dired-restore-marker-char t] + ["Marker stack left" dired-marker-stack-left t] + ["Marker stack right" dired-marker-stack-right t] + "---" + ["Mark Files from Other Dired" dired-mark-files-from-other-dired-buffer t] + ["Mark Files from Compile Buffer..." dired-mark-files-compilation-buffer t])) + + (setq + dired-do-menu + '(["Copy to..." dired-do-copy t] + ["Rename to..." dired-do-rename t] + ["Expunge File Flagged for Deletion" dired-expunge-deletions t] + ["Compress/Uncompress" dired-do-compress t] + ["Uuencode/Uudecode" dired-do-uucode t] + ["Print..." dired-do-print t] + ["Change Mode..." dired-do-interactive-chmod t] + ["Change Owner..." dired-do-chown t] + ["Change Group..." dired-do-chgrp t] + ["Byte-compile" dired-do-byte-compile t] + ["Hardlink to..." dired-do-hardlink t] + ["Symlink to..." dired-do-symlink t] + ["Shell Command..." dired-do-shell-command t] + ["Background Shell Command..." dired-do-background-shell-command t] + ["Delete Marked Files" dired-do-delete t] + ["Visit file menu >" dired-visit-popup-menu-internal t] + ["Operate on file menu >" dired-do-popup-menu-internal t])) + + (setq + dired-regexp-menu + (list + ["Mark..." dired-mark-files-regexp t] + ["Mark Files with Extension..." dired-mark-extension t] + ["Flag..." dired-flag-files-regexp t] + ["Flag Files with Extension..." dired-flag-extension t] + ["Downcase" dired-downcase t] + ["Upcase" dired-upcase t] + ["Copy..." dired-do-copy-regexp t] + ["Rename..." dired-do-rename-regexp t] + ["Hardlink..." dired-do-hardlink-regexp t] + ["Symlink..." dired-do-symlink-regexp t] + ["Relative Symlink..." dired-do-relsymlink-regexp t] + "---" + ["Add Omit Regex..." dired-add-omit-regexp t] + (vector "Remove Omit Regex..." + '(let ((current-prefix-arg 1)) + (call-interactively 'dired-add-omit-regexp)) + ':keys (dired-key-description 'dired-add-omit-regexp 1)) + (vector "Add Omit Extension..." + '(let ((current-prefix-arg '(4))) + (call-interactively 'dired-add-omit-regexp)) + ':keys (dired-key-description 'dired-add-omit-regexp 'universal-argument)) + (vector "Remove Omit Extension..." + '(let ((current-prefix-arg '(16))) + (call-interactively 'dired-add-omit-regexp)) + ':keys (dired-key-description 'dired-add-omit-regexp + 'universal-argument 'universal-argument)) + (vector "Show Omit Regex" + '(let ((current-prefix-arg 0)) + (call-interactively 'dired-add-omit-regexp)) + ':keys (dired-key-description 'dired-add-omit-regexp 0)))) + + (setq + dired-look-menu + '(["Grep for..." dired-do-grep t] + ["Tags Search for..." dired-do-tags-search t] + ["Tags Query Replace..." dired-do-tags-query-replace t] + "---" + ["Diff File..." dired-diff t] + ["Diff with Backup" dired-backup-diff t] + ["Merge Files..." dired-emerge t] + ["Merge Files Having Common Ancestor..." dired-emerge-with-ancestor t] + ["Ediff Files..." dired-ediff t] + ["Patch File" dired-epatch t])) + + (setq + dired-sort-menu + (list + ["Toggle Current Subdir by Name/Date" dired-sort-toggle-or-edit t] + (vector "Show Current Switches" + '(dired-sort-toggle-or-edit 0) + ':keys (dired-key-description 'dired-sort-toggle-or-edit 0)) + (vector "Edit Switches for Current Subdir..." + '(dired-sort-toggle-or-edit 1) + ':keys (dired-key-description 'dired-sort-toggle-or-edit 1)) + (vector "Edit Default Switches for Inserted Subdirs..." + '(dired-sort-toggle-or-edit 2) + ':keys (dired-key-description 'dired-sort-toggle-or-edit 2)) + (vector "Sort Entire Buffer by Date" + '(dired-sort-toggle-or-edit 'date) + ':keys (dired-key-description 'dired-sort-toggle-or-edit + 'universal-argument)) + (vector "Sort Entire Buffer by Name" + '(dired-sort-toggle-or-edit 'name) + ':keys (dired-key-description 'dired-sort-toggle-or-edit + 'universal-argument)) + (vector "Edit Switches for Entire Buffer..." + '(dired-sort-toggle-or-edit '(16)) + ':keys (dired-key-description 'dired-sort-toggle-or-edit + 'universal-argument)) + "---" + ["Hide All Subdirs" dired-hide-all t] + ["Hide Subdir" dired-hide-subdir t] + ["Toggle Omit" dired-omit-toggle t] + ["Kill Marked Lines" dired-do-kill-file-lines t] + (vector "Redisplay Killed Lines" + '(dired-do-kill-file-lines 0) + ':keys (dired-key-description 'dired-do-kill-file-lines "0")))) + (setq + dired-help-menu + (list + ["Dired Summary Help" dired-summary t] + ["Describe Dired" dired-describe-mode t] + (vector "Dired Info Manual" + '(dired-describe-mode t) + ':keys (dired-key-description 'dired-describe-mode + 'universal-argument)) + ["Dired Command Apropos" dired-apropos t] + (vector "Dired Variable Apropos" + '(let ((current-prefix-arg t)) + (call-interactively 'dired-apropos)) + ':keys (dired-key-description 'dired-apropos 'universal-argument)) + ["Report Dired Bug" dired-report-bug t]))) + +(defun dired-install-menubar () + "Installs the Dired menu at the menubar." + (if (null dired-help-menu) + (dired-setup-menus)) + (if current-menubar + (progn + (let ((buffer-menubar (copy-sequence current-menubar))) + (delete (assoc "Edit" buffer-menubar) buffer-menubar) + (set-buffer-menubar buffer-menubar) + (mapcar + (function + (lambda (pair) + (let ((name (car pair)) + (menu (symbol-value (cdr pair)))) + (add-submenu nil (cons name menu))))) + dired-menubar-menus)) + (add-menu-button '("Help") (list "---")) + (add-submenu '("Help") (cons "Dired" dired-help-menu))))) + +(add-hook 'dired-mode-hook 'dired-install-menubar) + +;;; Mouse functions + +(defun dired-mouse-find-file (event) + "In dired, visit the file or directory name you click on." + (interactive "e") + (save-excursion + (set-buffer (window-buffer (event-window event))) + (if dired-subdir-alist + (save-excursion + (goto-char (event-point event)) + (dired-find-file)) + (error + (concat "dired-subdir-alist seems to be mangled. " + (substitute-command-keys + "\\Try dired-revert (\\[dired-revert]).")))))) + +(defun dired-mouse-mark (event) + "In dired, mark the file name that you click on. +If the file name is already marked, this unmarks it." + (interactive "e") + (save-excursion + (set-buffer (window-buffer (event-window event))) + (if dired-subdir-alist + (save-excursion + (goto-char (event-point event)) + (beginning-of-line) + (if (looking-at dired-re-mark) + (dired-unmark 1) + (dired-mark 1))) + (error + (concat "dired-subdir-alist seems to be mangled. " + (substitute-command-keys + "\\Try dired-revert (\\[dired-revert]).")))))) + +(defun dired-mouse-flag (event) + "In dired, flag for deletion the file name that you click on. +If the file name is already flag, this unflags it." + (interactive "e") + (save-excursion + (set-buffer (window-buffer (event-window event))) + (if dired-subdir-alist + (save-excursion + (goto-char (event-point event)) + (beginning-of-line) + (if (char-equal (following-char) dired-del-marker) + (dired-unflag 1) + (dired-flag-file-deletion 1))) + (error + (concat "dired-subdir-alist seems to be mangled. " + (substitute-command-keys + "\\Try dired-revert (\\[dired-revert]).")))))) + +(defun dired-mouse-get-target (event) + "In dired, put a copy of the selected directory in the active minibuffer." + (interactive "e") + (let ((obuff (current-buffer)) + mb) + (set-buffer (window-buffer (event-window event))) + (if (and dired-subdir-alist (setq mb (dired-get-active-minibuffer-window))) + (let (dir) + (goto-char (event-point event)) + (setq dir (dired-current-directory)) + (select-window mb) + (set-buffer (window-buffer mb)) + (erase-buffer) + (insert dir)) + (set-buffer obuff) + (if mb + (error "No directory specified") + (error "No active minibuffer"))))) + +(defun dired-visit-popup-menu (event) + "Popup a menu to visit the moused file." + (interactive "e") + (save-excursion + (set-buffer (window-buffer (event-window event))) + (save-excursion + (goto-char (event-point event)) + (dired-visit-popup-menu-internal event)))) + +(defun dired-visit-popup-menu-internal (event) + (interactive "e") + (let ((fn (dired-get-filename 'no-dir))) + (popup-menu + (cons (concat "Visit " fn " with") dired-visit-popup-menu)) + ;; this looks like a kludge to me ... + (while (popup-up-p) + (dispatch-event (next-event))))) + +(defun dired-do-popup-menu (event) + "Pop up a menu to do an operation on the moused file." + (interactive "e") + (let ((obuff (current-buffer))) + (unwind-protect + (progn + (set-buffer (window-buffer (event-window event))) + (dired-save-excursion + (goto-char (event-point event)) + (dired-do-popup-menu-internal event))) + (set-buffer obuff)))) + +(defun dired-do-popup-menu-internal (event) + (interactive "e") + (let ((fn (dired-get-filename 'no-dir)) + (current-prefix-arg 1)) + (popup-menu + (cons (concat "Do operation on " fn) dired-do-popup-menu)) + (while (popup-up-p) + (dispatch-event (next-event))))) + +(defvar dired-filename-local-map + (let ((map (make-sparse-keymap))) + (set-keymap-name map 'dired-filename-local-map) + (define-key map 'button2 'dired-mouse-find-file) + (define-key map 'button3 'dired-visit-popup-menu) + (define-key map '(control button2) 'dired-do-popup-menu) + (define-key map '(shift button1) 'dired-mouse-mark) + (define-key map '(control shift button1) 'dired-mouse-flag) + map) + "Keymap used to activate actions on files in dired.") + +;; Make this defined everywhere in the dired buffer. +(define-key dired-mode-map '(meta button3) 'dired-mouse-get-target) + +;;; Extent managment + +(defun dired-set-text-properties (start end &optional face) + (let ((filename-extent (make-extent start end))) + (set-extent-face filename-extent (or face 'default)) + (set-extent-property filename-extent 'dired-file-name t) + (set-extent-property filename-extent 'start-open t) + (set-extent-property filename-extent 'end-open t) + (set-extent-property filename-extent 'keymap dired-filename-local-map) + (set-extent-property filename-extent 'highlight t) + (set-extent-property + filename-extent 'help-echo + (concat + "button2 finds, button3 visits, " + "C-button2 file ops, [C-]shift-button1 marks/flags.")) + filename-extent)) + +(defun dired-insert-set-properties (beg end) + ;; Sets the extents for the file names and their properties + (save-excursion + (goto-char beg) + (beginning-of-line) + (let ((eol (save-excursion (end-of-line) (point))) + (bol (point)) + start) + (while (< (point) end) + (setq eol (save-excursion (end-of-line) (point))) + + (if dired-do-interactive-permissions + (dired-make-permissions-interactive (point))) + + (if (dired-manual-move-to-filename nil bol eol) + (progn + (setq start (point)) + (dired-manual-move-to-end-of-filename nil bol eol) + (dired-set-text-properties + start + (point) + (save-excursion + (beginning-of-line) + (cond + ((null dired-do-highlighting) nil) + ((looking-at dired-re-raw-dir) 'dired-face-directory) + ((looking-at dired-re-raw-sym) 'dired-face-symlink) + ((or (looking-at dired-re-raw-setuid) + (looking-at dired-re-raw-setgid)) 'dired-face-setuid) + ((looking-at dired-re-raw-exe) 'dired-face-executable) + ((looking-at dired-re-raw-socket) 'dired-face-socket) + ((save-excursion + (goto-char start) + (re-search-forward dired-re-raw-boring eol t)) + 'dired-face-boring)))))) + + (setq bol (1+ eol)) + (goto-char bol))))) + +(defun dired-remove-text-properties (start end) + ;; Removes text properties. Called in popup buffers. + (map-extents + (function + (lambda (extent maparg) + (if (extent-property extent 'dired-file-name) + (delete-extent extent)) + nil)) + nil start end)) + +(defun dired-highlight-filename-mark (extent) + (let ((mark + (save-excursion + (skip-chars-backward "^\n\r") + (following-char))) + (face (extent-face extent))) + (if (char-equal mark ?\ ) + (if (consp face) + (set-extent-face extent (cadr face))) + (let ((new-face + (cond + ((char-equal dired-default-marker mark) + 'dired-face-marked) + ((char-equal dired-del-marker mark) + 'dired-face-deleted) + (t 'default)))) + (set-extent-face + extent + (if (consp face) + (list new-face (cadr face)) + (list new-face face))))))) + +(defun dired-move-to-filename (&optional raise-error bol eol) + (or bol (setq bol (save-excursion + (skip-chars-backward "^\n\r") + (point)))) + (or eol (setq eol (save-excursion + (skip-chars-forward "^\n\r") + (point)))) + (goto-char bol) + (let ((extent + (map-extents + (function + (lambda (extent maparg) + (if (extent-property extent 'dired-file-name) + extent + nil))) + nil bol eol))) + (if extent + (progn + (if dired-do-highlighting + (dired-highlight-filename-mark extent)) + (goto-char (extent-start-position extent))) + (if raise-error + (error "No file on this line") + nil)))) + + +(defun dired-move-to-end-of-filename (&optional no-error bol eol) + ;; Assumes point is at beginning of filename, + ;; thus the rwx bit re-search-backward below will succeed in *this* + ;; line if at all. So, it should be called only after + ;; (dired-move-to-filename t). + ;; On failure, signals an error (with non-nil NO-ERROR just returns nil). + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (and + (null no-error) + selective-display + (or bol (setq bol (save-excursion (skip-chars-backward "^\r\n") (point)))) + (eq (char-after (1- bol)) ?\r) + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit."))))) + (let ((filename-extent (map-extents + (function + (lambda (e p) (and (extent-property e p) e))) + (current-buffer) bol eol 'dired-file-name))) + (if filename-extent + (goto-char (extent-end-position filename-extent)) + (and (null no-error) (error "No file on this line"))))) + +;;; Interactive chmod +;;; (based on ideas from Russell Ritchie's dired-chmod.el) + +(defun dired-do-interactive-chmod (new-attribute) + (let* ((file (dired-get-filename)) + (operation (concat "chmod " new-attribute " " file)) + (failure (apply (function dired-check-process) + operation + "chmod" new-attribute (list file)))) + (dired-do-redisplay) + (if failure + (dired-log-summary (buffer-name (current-buffer)) + (format "%s: error" operation) nil)))) + +(defun dired-chmod-popup-menu (event menu) + (save-excursion + (set-buffer (window-buffer (event-window event))) + (save-excursion + (goto-char (event-point event)) + (popup-menu menu) + ;; this looks like a kludge to me ... + (while (popup-up-p) + (dispatch-event (next-event)))))) + +;; This is probably overdoing it. +;; Someone give me lexical scoping here ... + +(defun dired-setup-chmod-keymap (domain id keys) + (let* ((names + (mapcar + (function + (lambda (key) + (let ((name (intern (concat "dired-" + (list domain ?- key))))) + (eval + `(defun ,name () + (interactive) + (dired-do-interactive-chmod ,(concat (list domain ?+ key))))) + name))) + keys)) + (prefix (concat "dired-" (list domain) "-" (list id))) + (remove-name (intern (concat prefix "-remove"))) + (toggle-name (intern (concat prefix "-toggle"))) + (mouse-toggle-name (intern (concat prefix "-mouse-toggle"))) + (mouse-menu-name (intern (concat prefix "-menu")))) + + (eval + `(defun ,remove-name () + (interactive) + (cond ,@(mapcar (function + (lambda (key) + `((looking-at ,(regexp-quote (char-to-string key))) + (dired-do-interactive-chmod + ,(concat (list domain ?- key)))))) + keys)))) + + (eval + `(defun ,toggle-name () + (interactive) + (cond ((looking-at "-") (dired-do-interactive-chmod + ,(concat (list domain ?+ (car keys))))) + ,@(let ((l keys) + (c '())) + (while l + (setq c + (cons + `((looking-at (regexp-quote (char-to-string ,(car l)))) + (dired-do-interactive-chmod + ,(if (null (cdr l)) + (concat (list domain ?- (car l))) + (concat (list domain ?+ (cadr l)))))) + c)) + (setq l (cdr l))) + (reverse c))))) + + (eval + `(defun ,mouse-toggle-name (event) + (interactive "e") + (save-excursion + (set-buffer (window-buffer (event-window event))) + (save-excursion + (goto-char (event-point event)) + (,toggle-name))))) + + (let ((menu '()) + (loop-keys keys) + (loop-names names)) + (while loop-keys + (setq menu + (cons (vector (concat (list ?+ (car loop-keys))) + (car loop-names) + t) + menu)) + (setq loop-keys (cdr loop-keys) + loop-names (cdr loop-names))) + (setq menu (append menu (list (vector "Toggle" toggle-name t) + (vector "Clear" remove-name t)))) + (setq menu (cons (char-to-string domain) menu)) + + (eval + `(defun ,mouse-menu-name (event) + (interactive "e") + (dired-chmod-popup-menu event ',menu)))) + + (let ((keymap (make-sparse-keymap))) + (let ((loop-keys (cons ?. (cons ?- keys))) + (loop-names (cons toggle-name (cons remove-name names)))) + (while loop-keys + (define-key keymap (car loop-keys) (car loop-names)) + (setq loop-keys (cdr loop-keys) + loop-names (cdr loop-names)))) + + (define-key keymap 'button2 mouse-toggle-name) + (define-key keymap 'button3 mouse-menu-name) + keymap))) + +(defvar dired-u-r-keymap nil "internal keymap for dired") +(defvar dired-u-w-keymap nil "internal keymap for dired") +(defvar dired-u-x-keymap nil "internal keymap for dired") +(defvar dired-g-r-keymap nil "internal keymap for dired") +(defvar dired-g-w-keymap nil "internal keymap for dired") +(defvar dired-g-x-keymap nil "internal keymap for dired") +(defvar dired-o-r-keymap nil "internal keymap for dired") +(defvar dired-o-w-keymap nil "internal keymap for dired") +(defvar dired-o-x-keymap nil "internal keymap for dired") + + +(defun dired-setup-chmod-keymaps () + (setq + dired-u-r-keymap (dired-setup-chmod-keymap ?u ?r '(?r)) + dired-u-w-keymap (dired-setup-chmod-keymap ?u ?w '(?w)) + dired-u-x-keymap (dired-setup-chmod-keymap ?u ?x '(?s ?S ?x)) + dired-g-r-keymap (dired-setup-chmod-keymap ?g ?r '(?r)) + dired-g-w-keymap (dired-setup-chmod-keymap ?g ?w '(?w)) + dired-g-x-keymap (dired-setup-chmod-keymap ?g ?x '(?s ?x)) + dired-o-r-keymap (dired-setup-chmod-keymap ?o ?r '(?r)) + dired-o-w-keymap (dired-setup-chmod-keymap ?o ?w '(?w)) + dired-o-x-keymap (dired-setup-chmod-keymap ?o ?x '(?s ?t ?x)))) + +(defun dired-make-permissions-interactive (beg) + (save-excursion + (goto-char beg) + (buffer-substring (point) (save-excursion (end-of-line) (point))) + (if (and (re-search-forward dired-re-pre-permissions + (save-excursion (end-of-line) (point)) + t) + (looking-at dired-re-permissions)) + (let ((p (point))) + (dired-activate-permissions (make-extent p (+ 1 p)) dired-u-r-keymap) + (dired-activate-permissions (make-extent (+ 1 p) (+ 2 p)) dired-u-w-keymap) + (dired-activate-permissions (make-extent (+ 2 p) (+ 3 p)) dired-u-x-keymap) + (dired-activate-permissions (make-extent (+ 3 p) (+ 4 p)) dired-g-r-keymap) + (dired-activate-permissions (make-extent (+ 4 p) (+ 5 p)) dired-g-w-keymap) + (dired-activate-permissions (make-extent (+ 5 p) (+ 6 p)) dired-g-x-keymap) + (dired-activate-permissions (make-extent (+ 6 p) (+ 7 p)) dired-o-r-keymap) + (dired-activate-permissions (make-extent (+ 7 p) (+ 8 p)) dired-o-w-keymap) + (dired-activate-permissions (make-extent (+ 8 p) (+ 9 p)) dired-o-x-keymap))))) + +(defun dired-activate-permissions (extent keymap) + (set-extent-face extent 'dired-face-permissions) + (set-extent-property extent 'keymap keymap) + (set-extent-property extent 'highlight t) + (set-extent-property + extent 'help-echo + "button2 toggles, button3 changes otherwise.")) + +(dired-setup-chmod-keymaps) + +;;; end of dired-xemacs.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/dired-xy.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired-xy.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,52 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired-xy.el +;; Dired Version: $Revision: 1.1 $ +;; RCS: +;; Description: Commands for reading mail from dired. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Requirements and provisions +(provide 'dired-xy) +(require 'dired) + +;;; Special request: Will an mh-e user please write some mh support in here? + +(defun dired-read-mail (&optional arg) + "Reads the current file as a mail folder. +Uses the setting of `dired-mail-reader' to determine which reader to use. +Possibilities are VM or RMAIL. With a prefix arg, visits the folder read-only\; +this only works with VM." + (interactive "P") + (cond + ((eq dired-mail-reader 'vm) + (dired-vm arg)) + ((eq dired-mail-reader 'rmail) + (dired-rmail)) ; doesn't take read-only arg. + (t (error "Never heard of the mail reader %s" dired-mail-reader)))) + +;; Read-only folders only work in VM 5, not in VM 4. +(defun dired-vm (&optional read-only) + "Run VM on this file. +With prefix arg, visit folder read-only (this requires at least VM 5). +See also variable `dired-vm-read-only-folders'." + (interactive "P") + (let ((dir (dired-current-directory)) + (fil (dired-get-filename))) + ;; take care to supply 2nd arg only if requested - may still run VM 4! + (require 'vm) ; vm-visit-folder may not be an autoload + (setq this-command 'vm-visit-folder) ; for vm window config + (if read-only + (vm-visit-folder fil t) + (vm-visit-folder fil)) + ;; so that pressing `v' inside VM does prompt within current directory: + (set (make-local-variable 'vm-folder-directory) dir))) + +(defun dired-rmail () + "Run RMAIL on this file." + (interactive) + (rmail (dired-get-filename))) + +;; end of dired-xy.el + diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/dired.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/dired.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,6439 @@ + ; -*- Emacs-Lisp -*- +;; DIRED commands for Emacs. +;; Copyright (C) 1985, 1986, 1991 Free Software Foundation, Inc. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: dired.el +;; RCS: +;; Dired Version: $Revision: 1.1 $ +;; Description: The DIRectory EDitor is for manipulating, and running +;; commands on files in a directory. +;; Authors: FSF, +;; Sebastian Kremer , +;; Sandy Rutherford +;; Cast of thousands... +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; 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 1, 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 GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;; Rewritten in 1990/1991 to add tree features, file marking and +;; sorting by Sebastian Kremer . +;; 7-1993: Added special features for efs interaction and upgraded to Emacs 19. +;; Sandy Rutherford + +;;; Dired Version + +(defconst dired-version (substring "$Revision: 1.1 $" 11 -2) + "The revision number of Tree Dired (as a string). + +Don't forget to mention this when reporting bugs to: + + efs-bugs@cuckoo.hpl.hp.com") + +;; Global key bindings: +;; -------------------- +;; +;; By convention, dired uses the following global key-bindings. +;; These may or may not already be set up in your local emacs. If not +;; then you will need to add them to your .emacs file, or the system +;; default.el file. We don't set them automatically here, as users may +;; have individual preferences. +;; +;; (define-key ctl-x-map "d" 'dired) +;; (define-key ctl-x-4-map "d" 'dired-other-window) +;; (define-key ctl-x-map "\C-j" 'dired-jump-back) +;; (define-key ctl-x-4-map "\C-j" 'dired-jump-back-other-window) +;; +;; For V19 emacs only. (Make sure that the ctl-x-5-map exists.) +;; (define-key ctl-x-5-map "d" 'dired-other-frame) +;; (define-key Ctl-x-5-map "\C-j" 'dired-jump-back-other-frame) + + +;;; Grok the current emacs version +;; +;; Hopefully these two variables provide us with enough version sensitivity. + +;; Make sure that we have a frame-width function +(or (fboundp 'frame-width) (fset 'frame-width 'screen-width)) + +;;; Requirements and provisions + +(provide 'dired) +(require 'backquote) ; For macros. + +;; Compatibility requirements for the file-name-handler-alist. +(let ((lucid-p (string-match "Lucid" emacs-version)) + ver subver) + (or (string-match "^\\([0-9]+\\)\\.\\([0-9]+\\)" emacs-version) + (error "dired does not work with emacs version %s" emacs-version)) + (setq ver (string-to-int (substring emacs-version (match-beginning 1) + (match-end 1))) + subver (string-to-int (substring emacs-version (match-beginning 2) + (match-end 2)))) + (cond + ((= ver 18) + (require 'emacs-19) + (require 'fn-handler)) + ((and (= ver 19) (if lucid-p (< subver 10) (< subver 23))) + (require 'fn-handler)) + ((< ver 18) + (error "dired does not work with emacs version %s" emacs-version)))) + +;; Load default-dir last, because we want its interactive specs. +(require 'default-dir) + + +;;;;---------------------------------------------------------------- +;;;; Customizable variables +;;;;---------------------------------------------------------------- +;; +;; The funny comments are for autoload.el, to automagically update +;; loaddefs. + +;;; Variables for compressing files. + +;;;###autoload +(defvar dired-compression-method 'compress + "*Type of compression program to use. +Give as a symbol. +Currently-recognized methods are: gzip pack compact compress. +To change this variable use \\[dired-do-compress] with a zero prefix.") + +;;;###autoload +(defvar dired-compression-method-alist + '((gzip ".gz" ("gzip") ("gzip" "-d") "-f") + ;; Put compress before pack, so that it wins out if we are using + ;; efs to work on a case insensitive OS. The -f flag does + ;; two things in compress. No harm in giving it twice. + (compress ".Z" ("compress" "-f") ("compress" "-d") "-f") + ;; pack support may not work well. pack is too chatty and there is no way + ;; to force overwrites. + (pack ".z" ("pack" "-f") ("unpack")) + (compact ".C" ("compact") ("uncompact"))) + + "*Association list of compression method descriptions. + Each element of the table should be a list of the form + + \(compress-type extension (compress-args) (decompress-args) force-flag\) + + where + `compress-type' is a unique symbol in the alist to which + `dired-compression-method' can be set; + `extension' is the file extension (as a string) used by files compressed + by this method; + `compress-args' is a list of the path of the compression program and + flags to pass as separate arguments; + `decompress-args' is a list of the path of the decompression + program and flags to pass as separate arguments. + `force-flag' is the switch to pass to the command to force overwriting + of existing files. + + For example: + + \(setq dired-compresssion-method-alist + \(cons '\(frobnicate \".frob\" \(\"frob\"\) \(\"frob\" \"-d\"\) \"-f\"\) + dired-compression-method-alist\)\) + => \(\(frobnicate \".frob\" \(\"frob\"\) \(\"frob\" \"-d\"\)\) + \(gzip \".gz\" \(\"gzip\"\) \(\"gunzip\"\)\) + ...\) + + See also: dired-compression-method ") + +;;; Variables for the ls program. + +;;;###autoload +(defvar dired-ls-program "ls" + "*Absolute or relative name of the ls program used by dired.") + +;;;###autoload +(defvar dired-listing-switches "-al" + "*Switches passed to ls for dired. MUST contain the `l' option. +Can contain even `F', `b', `i' and `s'.") + +(defvar dired-ls-F-marks-symlinks + (memq system-type '(aix-v3 hpux silicon-graphics-unix)) + ;; Both SunOS and Ultrix have system-type berkeley-unix. But + ;; SunOS doesn't mark symlinks, but Ultrix does. Therefore, + ;; can't grok this case. + "*Informs dired about how ls -lF marks symbolic links. +Set this to t if `dired-ls-program' with -lF marks the name of the symbolic +link itself with a trailing @. + +For example: If foo is a link pointing to bar, and \"ls -F bar\" gives + + ... bar -> foo + +set this variable to nil. If it gives + + ... bar@ -> foo + +set this variable to t. + +Dired checks if there is really a @ appended. Thus, if you have a +marking ls program on one host and a non-marking on another host, and +don't care about symbolic links which really end in a @, you can +always set this variable to t. + +If you use efs, it will make this variable buffer-local, and control +it according to its assessment of how the remote host marks symbolic +links.") + +(defvar dired-show-ls-switches nil + "*If non-nil dired will show the dired ls switches on the modeline. +If nil, it will indicate how the files are sorted by either \"by name\" or +\"by date\". If it is unable to recognize the sorting defined by the switches, +then the switches will be shown explicitly on the modeline, regardless of the +setting of this variable.") + +;;; Variables for other unix utility programs. + +;; For most program names, don't use absolute paths so that dired +;; uses the user's value of the environment variable PATH. chown is +;; an exception as it is not always in the PATH. + +;;;###autoload +(defvar dired-chown-program + (if (memq system-type '(hpux dgux usg-unix-v)) "chown" "/etc/chown") + "*Name of chown command (usully `chown' or `/etc/chown').") + +;;;###autoload +(defvar dired-gnutar-program nil + "*If non-nil, name of the GNU tar executable (e.g. \"tar\" or \"gnutar\"). +GNU tar's `z' switch is used for compressed tar files. +If you don't have GNU tar, set this to nil: a pipe using `zcat' is then used.") + +;;;###autoload +(defvar dired-unshar-program nil + "*Set to the name of the unshar program, if you have it.") + +;;; Markers + +(defvar dired-keep-marker-rename t + ;; Use t as default so that moved files `take their markers with them' + "*Controls marking of renamed files. +If t, files keep their previous marks when they are renamed. +If a character, renamed files (whether previously marked or not) +are afterward marked with that character.") + +(defvar dired-keep-marker-compress t + "*Controls marking of compressed or uncompressed files. +If t, files keep their previous marks when they are compressed. +If a character, compressed or uncompressed files (whether previously +marked or not) are afterward marked with that character.") + +(defvar dired-keep-marker-uucode ?U + "*Controls marking of uuencoded or uudecoded files. +If t, files keep their previous marks when they are uuencoded. +If a character, uuencoded or uudecoded files (whether previously +marked or not) are afterward marked with that character.") + +(defvar dired-keep-marker-copy ?C + "*Controls marking of copied files. +If t, copied files are marked if and as the corresponding original files were. +If a character, copied files are unconditionally marked with that character.") + +(defvar dired-keep-marker-hardlink ?H + "*Controls marking of newly made hard links. +If t, they are marked if and as the files linked to were marked. +If a character, new links are unconditionally marked with that character.") + +(defvar dired-keep-marker-symlink ?S + "*Controls marking of newly made symbolic links. +If t, they are marked if and as the files linked to were marked. +If a character, new links are unconditionally marked with that character.") + +(defvar dired-keep-marker-kill ?K + "*When killed file lines are redisplayed, they will have this marker. +Setting this to nil means that they will not have any marker.") + +(defvar dired-failed-marker-shell ?! + "*If non-nil, a character with which to mark files of failed shell commands. +Applies to the command `dired-do-shell-command'. Files for which the shell +command has a nonzero exit status will be marked with this character") + +;;; Behavioral Variables + +;;;###autoload +(defvar dired-local-variables-file ".dired" + "*If non-nil, filename for local variables for Dired. +If Dired finds a file with that name in the current directory, it will +temporarily insert it into the dired buffer and run `hack-local-variables'. + +Type \\[info] and `g' `(emacs)File Variables' `RET' for more info on +local variables.") + +;; Usually defined in files.el. Define here anyway, to be safe. +;;;###autoload +(defvar dired-kept-versions 2 + "*When cleaning directory, number of versions to keep.") + +;;;###autoload +(defvar dired-find-subdir nil + "*Determines whether dired tries to lookup a subdir in existing buffers. +If non-nil, dired does not make a new buffer for a directory if it can be +found (perhaps as subdir) in some existing dired buffer. If there are several +dired buffers for a directory, then the most recently used one is chosen. + +Dired avoids switching to the current buffer, so that if you have +a normal and a wildcard buffer for the same directory, C-x d RET will +toggle between those two.") + +;;;###autoload +(defvar dired-use-file-transformers t + "*Determines whether dired uses file transformers. +If non-nil `dired-do-shell-command' will apply file transformers to file names. +See \\[describe-function] for dired-do-shell-command for more information.") + +;;;###autoload +(defvar dired-dwim-target nil + "*If non-nil, dired tries to guess a default target directory. +This means that if there is a dired buffer displayed in the next window, +use its current subdir, instead of the current subdir of this dired buffer. +The target is put in the prompt for file copy, rename, etc.") + +;;;###autoload +(defvar dired-copy-preserve-time nil + "*If non-nil, Dired preserves the last-modified time in a file copy. +\(This works on only some systems.)\\ +Use `\\[dired-do-copy]' with a zero prefix argument to toggle its value.") + +;;;###autoload +(defvar dired-no-confirm nil + "*If non-nil, a list of symbols for commands dired should not confirm. +It can be a sublist of + + '(byte-compile chgrp chmod chown compress copy delete hardlink load + move print shell symlink uncompress recursive-delete kill-file-buffer + kill-dired-buffer patch create-top-dir revert-subdirs) + +The meanings of most of the symbols are obvious. A few exceptions: + + 'compress applies to compression or decompression by any of the + compression program in `dired-compression-method-alist'. + + 'kill-dired-buffer applies to offering to kill dired buffers for + directories which have been deleted. + + 'kill-file-buffer applies to offering to kill buffers visiting files + which have been deleted. + + 'recursive-delete applies to recursively deleting non-empty + directories, and all of their contents. + + 'create-top-dir applies to `dired-up-directory' creating a new top level + directory for the dired buffer. + + 'revert-subdirs applies to re-reading subdirectories which have + been modified on disk. + +Note that this list also applies to remote files accessed with efs +or ange-ftp.") + +;;;###autoload +(defvar dired-backup-if-overwrite nil + "*Non-nil if Dired should ask about making backups before overwriting files. +Special value 'always suppresses confirmation.") + +;;;###autoload +(defvar dired-omit-files nil + "*If non-nil un-interesting files will be omitted from this dired buffer. +Use \\[dired-omit-toggle] to see these files. (buffer local)") +(make-variable-buffer-local 'dired-omit-files) + +;;;###autoload +(defvar dired-mail-reader 'rmail + "*Mail reader used by dired for dired-read-mail \(\\[dired-read-mail]\). +The symbols 'rmail and 'vm are the only two allowed values.") + +(defvar dired-verify-modtimes t + "*If non-nil dired will revert dired buffers for modified subdirectories. +See also dired-no-confirm .") + +;;; File name regular expressions and extensions. + +(defvar dired-trivial-filenames "^\\.\\.?$\\|^#" + "*Regexp of files to skip when finding first file of a directory listing. +A value of nil means move to the subdir line. +A value of t means move to first file.") + +(defvar dired-cleanup-alist + (list + '("tex" ".toc" ".log" ".aux" ".dvi") + '("latex" ".toc" ".log" ".aux" ".idx" ".lof" ".lot" ".glo" ".dvi") + '("bibtex" ".blg" ".bbl") + '("texinfo" ".cp" ".cps" ".fn" ".fns" ".ky" ".kys" ".pg" ".pgs" + ".tp" ".tps" ".vr" ".vrs") + '("patch" ".rej" ".orig") + '("backups" "~") + (cons "completion-ignored-extensions" completion-ignored-extensions)) + "*Alist of extensions for temporary files created by various programs. +Used by `dired-cleanup'.") + +(defvar dired-omit-extensions + (let ((alist dired-cleanup-alist) + x result) + (while alist + (setq x (cdr (car alist)) + alist (cdr alist)) + (while x + (or (member (car x) result) + (setq result (cons (car x) result))) + (setq x (cdr x)))) + result) + "*List of extensions for file names that will be omitted (buffer-local). +This only has effect when the subdirectory is in omission mode. +To make omission mode the default, set `dired-omit-files' to t. +See also `dired-omit-extensions'.") +(make-variable-buffer-local 'dired-omit-extensions) + +(defvar dired-omit-regexps '("^#" "^\\.") + "*File names matching these regexp may be omitted (buffer-local). +This only has effect when the subdirectory is in omission mode. +To make omission mode the default, set `dired-omit-files' to t. +This only has effect when `dired-omit-files-p' is t. +See also `dired-omit-extensions'.") +(make-variable-buffer-local 'dired-omit-files-regexp) + +(defvar dired-filename-re-ext "\\..+$" ; start from the first dot. last dot? + "*Defines what is the extension of a file name. +\(match-beginning 0\) for this regexp in the file name without directory will +be taken to be the start of the extension.") + +;;; Hook variables + +(defvar dired-load-hook nil + "Run after loading dired. +You can customize key bindings or load extensions with this.") + +(defvar dired-grep-load-hook nil + "Run after loading dired-grep.") + +(defvar dired-mode-hook nil + "Run at the very end of dired-mode.") + +(defvar dired-before-readin-hook nil + "Hook run before a dired buffer is newly read in, created,or reverted.") + +(defvar dired-after-readin-hook nil + "Hook run after each listing of a file or directory. +The buffer is narrowed to the new listing.") + +(defvar dired-setup-keys-hook nil + "Hook run when dired sets up its keymap. +This happens the first time that `dired-mode' is called, and runs after +`dired-mode-hook'. This hook can be used to make alterations to the +dired keymap.") + +;;; Internal variables +;; +;; If you set these, know what you are doing. + +;;; Marker chars. + +(defvar dired-marker-char ?* ; the answer is 42 + ; life the universe and everything + ;; so that you can write things like + ;; (let ((dired-marker-char ?X)) + ;; ;; great code using X markers ... + ;; ) + ;; For example, commands operating on two sets of files, A and B. + ;; Or marking files with digits 0-9. This could implicate + ;; concentric sets or an order for the marked files. + ;; The code depends on dynamic scoping on the marker char. + "In dired, character used to mark files for later commands.") +(make-variable-buffer-local 'dired-marker-char) + +(defconst dired-default-marker dired-marker-char) +;; Stores the default value of dired-marker-char when dynamic markers +;; are being used. + +(defvar dired-del-marker ?D + "Character used to flag files for deletion.") + +;; \017=^O for Omit - other packages can chose other control characters. +(defvar dired-omit-marker-char ?\017) +;; Marker used for omitted files. Shouldn't be used by anything else. + +(defvar dired-kill-marker-char ?\C-k) +;; Marker used by dired-do-kill. Shouldn't be used by anything else. + +;;; State variables + +(defvar dired-mode-line-modified "-%s%s%s-" + "*Format string to show the modification status of the buffer.") + +(defvar dired-del-flags-number 0) +(make-variable-buffer-local 'dired-del-flags-number) +(defvar dired-marks-number 0) +(make-variable-buffer-local 'dired-marks-number) +(defvar dired-other-marks-number 0) +(make-variable-buffer-local 'dired-other-marks-number) + +(defvar dired-marked-files nil + "List of filenames from last `dired-copy-filename-as-kill' call.") + +(defvar dired-directory nil + "The directory name or shell wildcard that was used as argument to `ls'. +Local to each dired buffer. May be a list, in which case the car is the +directory name and the cdr is the actual files to list.") +(make-variable-buffer-local 'dired-directory) + +(defvar dired-internal-switches nil + "The actual (buffer-local) value of `dired-listing-switches'. +The switches are represented as a list of characters.") +(make-variable-buffer-local 'dired-internal-switches) + +(defvar dired-subdir-alist nil + "Association list of subdirectories and their buffer positions. +Each subdirectory has an element: (DIRNAME . STARTMARKER). +The order of elements is the reverse of the order in the buffer.") +(make-variable-buffer-local 'dired-subdir-alist) + +(defvar dired-curr-subdir-min 0) +;; Cache for modeline tracking of the cursor +(make-variable-buffer-local 'dired-curr-subdir-min) + +(defvar dired-curr-subdir-max 0) +;; Cache for modeline tracking of the cursor +(make-variable-buffer-local 'dired-curr-subdir-max) + +(defvar dired-subdir-omit nil) +;; Controls whether the modeline shows Omit. +(make-variable-buffer-local 'dired-subdir-omit) + +(defvar dired-in-query nil) +;; let-bound to t when dired is in the process of querying the user. +;; This is to keep asynch messaging from clobbering the query prompt. + +(defvar dired-overwrite-confirmed nil) +;; Fluid variable used to remember if a bunch of overwrites have been +;; confirmed. + +(defvar dired-overwrite-backup-query nil) +;; Fluid var used to remember if backups have been requested for overwrites. + +(defvar dired-file-creator-query nil) +;; Fluid var to remember responses to file-creator queries. + +(defvar dired-omit-silent nil) +;; This is sometimes let-bound to t if messages would be annoying, +;; e.g., in dired-awrh.el. Binding to 0, only suppresses +;; \"(Nothing to omit)\" message. + +(defvar dired-buffers nil + ;; Enlarged by dired-advertise + ;; Queried by function dired-buffers-for-dir. When this detects a + ;; killed buffer, it is removed from this list. + "Alist of directories and their associated dired buffers.") + +(defvar dired-sort-mode nil + "Whether Dired sorts by name, date, etc. +\(buffer-local\)") +;; This is nil outside dired buffers so it can be used in the modeline +(make-variable-buffer-local 'dired-sort-mode) + +(defvar dired-marker-stack nil + "List of previously used dired marker characters.") +(make-variable-buffer-local 'dired-marker-stack) + +(defvar dired-marker-stack-pointer 0) +;; Points to the current marker in the stack +(make-variable-buffer-local 'dired-marker-stack-pointer) + +(defvar dired-marker-stack-cursor ?\ ; space + "Character to use as a cursor in the dired marker stack.") + +(defconst dired-marker-string "" + "String version of `dired-marker-stack'.") +(make-variable-buffer-local 'dired-marker-string) + +(defvar dired-modeline-tracking-cmds nil) +;; List of commands after which the modeline gets updated. + +;;; Config. variables not usually considered fair game for the user. + +(defvar dired-deletion-confirmer 'yes-or-no-p) ; or y-or-n-p? + +(defvar dired-log-buffer "*Dired log*") +;; Name of buffer used to log dired messages and errors. + +;;; Assoc. lists + +;; For pop ups and user input for file marking +(defvar dired-query-alist + '((?\y . y) (?\040 . y) ; `y' or SPC means accept once + (?n . n) (?\177 . n) ; `n' or DEL skips once + (?! . yes) ; `!' accepts rest + (?q. no) (?\e . no) ; `q' or ESC skips rest + ;; None of these keys quit - use C-g for that. + )) + +(defvar dired-sort-type-alist + ;; alist of sort flags, and the sort type, as a symbol. + ;; Don't put ?r in here. It's handled separately. + '((?t . date) (?S . size) (?U . unsort) (?X . ext))) + +;;; Internal regexps for examining ls listings. +;; +;; Many of these regexps must be tested at beginning-of-line, but are also +;; used to search for next matches, so neither omitting "^" nor +;; replacing "^" by "\n" (to make it slightly faster) will work. + +(defvar dired-re-inode-size "[ \t0-9]*") +;; Regexp for optional initial inode and file size. +;; Must match output produced by ls' -i and -s flags. + +(defvar dired-re-mark "^[^ \n\r]") +;; Regexp matching a marked line. +;; Important: the match ends just after the marker. + +(defvar dired-re-maybe-mark "^. ") + +(defvar dired-re-dir (concat dired-re-maybe-mark dired-re-inode-size "d")) +;; Matches directory lines + +(defvar dired-re-sym (concat dired-re-maybe-mark dired-re-inode-size "l")) +;; Matches symlink lines + +(defvar dired-re-exe;; match ls permission string of an executable file + (mapconcat (function + (lambda (x) + (concat dired-re-maybe-mark dired-re-inode-size x))) + '("-[-r][-w][xs][-r][-w].[-r][-w]." + "-[-r][-w].[-r][-w][xs][-r][-w]." + "-[-r][-w].[-r][-w].[-r][-w][xst]") + "\\|")) + +(defvar dired-re-dot "^.* \\.\\.?/?$") ; with -F, might end in `/' +;; . and .. files + +(defvar dired-re-month-and-time + (concat + " \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|June?\\|July?\\|Aug\\|Sep\\|Oct\\|Nov\\|" + ; June and July are for HP-UX 9.0 + "Dec\\) [ 0-3][0-9]\\(" + " [012][0-9]:[0-6][0-9] \\|" ; time + " [12][90][0-9][0-9] \\|" ; year on IRIX, NeXT, SunOS, ULTRIX, Apollo, + ; HP-UX, A/UX + " [12][90][0-9][0-9] \\)" ; year on AIX + )) +;; This regexp MUST match all the way to first character of the filename. +;; You can loosen it to taste, but then you might bomb on filenames starting +;; with a space. This will have to be modified for non-english month names. + +(defvar dired-subdir-regexp + "\\([\n\r]\n\\|\\`\\). \\([^\n\r]+\\)\\(:\\)\\(\\.\\.\\.\r\\|[\n\r]\\)") + ;; Regexp matching a maybe hidden subdirectory line in ls -lR output. + ;; Subexpression 2 is the subdirectory proper, no trailing colon. + ;; Subexpression 3 must end right before the \n or \r at the end of + ;; the subdir heading. Matches headings after indentation has been done. + +(defvar dired-unhandle-add-files nil) +;; List of files that the dired handler function need not add to dired buffers. +;; This is because they have already been added, most likely in +;; dired-create-files. This is because dired-create-files add files with +;; special markers. + +;;; history variables + +(defvar dired-regexp-history nil + "History list of regular expressions used in Dired commands.") + +(defvar dired-chmod-history nil + "History of arguments to chmod in dired.") + +(defvar dired-chown-history nil + "History of arguments to chown in dired.") + +(defvar dired-chgrp-history nil + "History of arguments to chgrp in dired.") + +(defvar dired-cleanup-history nil + "History of arguments to dired-cleanup.") + +(defvar dired-goto-file-history nil) +;; History for dired-goto-file and dired-goto-subdir +(put 'dired-goto-file-history 'cursor-end t) ; for gmhist + +(defvar dired-history nil) +;; Catch-all history variable for dired file ops without +;; their own history. + +(defvar dired-op-history-alist + ;; alist of dired file operations and history symbols + '((chgrp . dired-chgrp-history) (chown . dired-chown-history) + (chmod . dired-chmod-history) )) + +;;; Tell the byte-compiler that we know what we're doing. +;;; Do we? + +(defvar file-name-handler-alist) +(defvar inhibit-file-name-operation) +(defvar inhibit-file-name-handlers) +(defvar efs-dired-host-type) + + +;;;;------------------------------------------------------------------ +;;;; Utilities +;;;;------------------------------------------------------------------ + +;;; Macros +;; +;; Macros must be defined before they are used - for the byte compiler. + +(defmacro dired-get-subdir-min (elt) + ;; Returns the value of the subdir minumum for subdir with entry ELT in + ;; dired-subdir-alist. + (list 'nth 1 elt)) + +(defmacro dired-save-excursion (&rest body) + ;; Saves excursions of the point (not buffer) in dired buffers. + ;; It tries to be robust against deletion of the region about the point. + ;; Note that this assumes only dired-style deletions. + (let ((temp-bolm (make-symbol "bolm")) + (temp-fnlp (make-symbol "fnlp")) + (temp-offset-bol (make-symbol "offset-bol"))) + (` (let (((, temp-bolm) (make-marker)) + (, temp-fnlp) (, temp-offset-bol)) + (let ((bol (save-excursion (skip-chars-backward "^\n\r") (point)))) + (set-marker (, temp-bolm) bol) + (setq (, temp-offset-bol) (- (point) bol) + (, temp-fnlp) (memq (char-after bol) '(?\n\ ?\r)))) + (unwind-protect + (progn + (,@ body)) + ;; Use the marker to try to find the right line, then move to + ;; the proper column. + (goto-char (, temp-bolm)) + (and (not (, temp-fnlp)) + (not (eq (following-char) 0)) (memq (following-char) '(?\n ?\r)) + ;; The line containing the point got deleted. Note that this + ;; logic only works if we don't delete null lines, but we never + ;; do. + (forward-line 1)) ; don't move into a hidden line. + (skip-chars-forward "^\n\r" (+ (point) (, temp-offset-bol)))))))) + +(put 'dired-save-excursion 'lisp-indent-hook 0) + +(defun dired-substitute-marker (pos old new) + ;; Change marker, re-fontify + (subst-char-in-region pos (1+ pos) old new) + (dired-move-to-filename)) + +(defmacro dired-mark-if (predicate msg) + ;; Mark all files for which CONDITION evals to non-nil. + ;; CONDITION is evaluated on each line, with point at beginning of line. + ;; MSG is a noun phrase for the type of files being marked. + ;; It should end with a noun that can be pluralized by adding `s'. + ;; Return value is the number of files marked, or nil if none were marked. + (let ((temp-pt (make-symbol "pt")) + (temp-count (make-symbol "count")) + (temp-msg (make-symbol "msg"))) + (` (let (((, temp-msg) (, msg)) + ((, temp-count) 0) + (, temp-pt) buffer-read-only) + (save-excursion + (if (, temp-msg) (message "Marking %ss..." (, temp-msg))) + (goto-char (point-min)) + (while (not (eobp)) + (if (and (, predicate) + (not (char-equal (following-char) dired-marker-char))) + (progn + ;; Doing this rather than delete-char, insert + ;; avoids re-computing markers + (setq (, temp-pt) (point)) + (dired-substitute-marker + (, temp-pt) + (following-char) dired-marker-char) + (setq (, temp-count) (1+ (, temp-count))))) + (forward-line 1)) + (if (, temp-msg) + (message "%s %s%s %s%s." + (, temp-count) + (, temp-msg) + (dired-plural-s (, temp-count)) + (if (eq dired-marker-char ?\040) "un" "") + (if (eq dired-marker-char dired-del-marker) + "flagged" "marked")))) + (and (> (, temp-count) 0) (, temp-count)))))) + +(defmacro dired-map-over-marks (body arg &optional show-progress) +;; Perform BODY with point somewhere on each marked line +;; and return a list of BODY's results. +;; If no marked file could be found, execute BODY on the current line. +;; If ARG is an integer, use the next ARG (or previous -ARG, if ARG<0) +;; files instead of the marked files. +;; If ARG is t, only apply to marked files. If there are no marked files, +;; the result is a noop. +;; If ARG is otherwise non-nil, use current file instead. +;; If optional third arg SHOW-PROGRESS evaluates to non-nil, +;; redisplay the dired buffer after each file is processed. +;; No guarantee is made about the position on the marked line. +;; BODY must ensure this itself if it depends on this. +;; Search starts at the beginning of the buffer, thus the car of the list +;; corresponds to the line nearest to the buffer's bottom. This +;; is also true for (positive and negative) integer values of ARG. +;; To avoid code explosion, BODY should not be too long as it is +;; expanded four times. +;; +;; Warning: BODY must not add new lines before point - this may cause an +;; endless loop. +;; This warning should not apply any longer, sk 2-Sep-1991 14:10. + (let ((temp-found (make-symbol "found")) + (temp-results (make-symbol "results")) + (temp-regexp (make-symbol "regexp")) + (temp-curr-pt (make-symbol "curr-pt")) + (temp-next-position (make-symbol "next-position"))) + (` (let (buffer-read-only case-fold-search (, temp-found) (, temp-results)) + (dired-save-excursion + (if (and (, arg) (not (eq (, arg) t))) + (if (integerp (, arg)) + (and (not (zerop (, arg))) + (progn;; no save-excursion, want to move point. + (dired-repeat-over-lines + arg + (function (lambda () + (if (, show-progress) (sit-for 0)) + (setq (, temp-results) + (cons (, body) + (, temp-results)))))) + (if (< (, arg) 0) + (nreverse (, temp-results)) + (, temp-results)))) + ;; non-nil, non-integer ARG means use current file: + (list (, body))) + (let (((, temp-regexp) + (concat "^" (regexp-quote (char-to-string + dired-marker-char)))) + (, temp-curr-pt) (, temp-next-position)) + (save-excursion + (goto-char (point-min)) + ;; remember position of next marked file before BODY + ;; can insert lines before the just found file, + ;; confusing us by finding the same marked file again + ;; and again and... + (setq (, temp-next-position) + (and (re-search-forward (, temp-regexp) nil t) + (point-marker)) + (, temp-found) (not (null (, temp-next-position)))) + (while (, temp-next-position) + (setq (, temp-curr-pt) (goto-char (, temp-next-position)) + ;; need to get next position BEFORE body + (, temp-next-position) + (and (re-search-forward (, temp-regexp) nil t) + (point-marker))) + (goto-char (, temp-curr-pt)) + (if (, show-progress) (sit-for 0)) + (setq (, temp-results) (cons (, body) (, temp-results))))) + (if (, temp-found) + (, temp-results) + ;; Do current file, unless arg is t + (and (not (eq (, arg) t)) + (list (, body))))))))))) + +;;; General utility functions + +(defun dired-buffer-more-recently-used-p (buffer1 buffer2) + "Return t if BUFFER1 is more recently used than BUFFER2." + (if (equal buffer1 buffer2) + nil + (let ((more-recent nil) + (list (buffer-list))) + (while (and list + (not (setq more-recent (equal buffer1 (car list)))) + (not (equal buffer2 (car list)))) + (setq list (cdr list))) + more-recent))) + +(defun dired-file-modtime (file) + ;; Return the modtime of FILE, which is assumed to be already expanded + ;; by expand-file-name. + (let ((handler (find-file-name-handler file 'dired-file-modtime))) + (if handler + (funcall handler 'dired-file-modtime file) + (nth 5 (file-attributes file))))) + +(defun dired-set-file-modtime (file alist) + ;; Set the modtime for FILE in the subdir alist ALIST. + (let ((handler (find-file-name-handler file 'dired-set-file-modtime))) + (if handler + (funcall handler 'dired-set-file-modtime file alist) + (let ((elt (assoc file alist))) + (if elt + (setcar (nthcdr 4 elt) (nth 5 (file-attributes file)))))))) + +(defun dired-map-over-marks-check (fun arg op-symbol operation + &optional show-progress no-confirm) + ;; Map FUN over marked files (with second ARG like in dired-map-over-marks) + ;; and display failures. + + ;; FUN takes zero args. It returns non-nil (the offending object, e.g. + ;; the short form of the filename) for a failure and probably logs a + ;; detailed error explanation using function `dired-log'. + + ;; OP-SYMBOL is s symbol representing the operation. + ;; eg. 'compress + + ;; OPERATION is a string describing the operation performed (e.g. + ;; "Compress"). It is used with `dired-mark-pop-up' to prompt the user + ;; (e.g. with `Compress * [2 files]? ') and to display errors (e.g. + ;; `Failed to compress 1 of 2 files - type y to see why ("foo")') + + ;; SHOW-PROGRESS if non-nil means redisplay dired after each file. + + (if (or no-confirm (dired-mark-confirm op-symbol operation arg)) + (let* ((total-list;; all of FUN's return values + (dired-map-over-marks (funcall fun) arg show-progress)) + (total (length total-list)) + (failures (delq nil total-list)) + (count (length failures))) + (if (not failures) + (message "%s: %d file%s." operation total (dired-plural-s total)) + (message "Failed to %s %d of %d file%s - type y to see why %s" + operation count total (dired-plural-s total) + ;; this gives a short list of failed files in parens + ;; which may be sufficient for the user even + ;; without typing `W' for the process' diagnostics + failures) + ;; end this bunch of errors: + (dired-log-summary + (buffer-name (current-buffer)) + (format + "Failed to %s %d of %d file%s" + operation count total (dired-plural-s total)) + failures))))) + +(defun dired-make-switches-string (list) +;; Converts a list of cracters to a string suitable for passing to ls. + (concat "-" (mapconcat 'char-to-string list ""))) + +(defun dired-make-switches-list (string) +;; Converts a string of ls switches to a list of characters. + (delq ?- (mapcar 'identity string))) + +;; Cloning replace-match to work on strings instead of in buffer: +;; The FIXEDCASE parameter of replace-match is not implemented. +(defun dired-string-replace-match (regexp string newtext + &optional literal global) + ;; Replace first match of REGEXP in STRING with NEWTEXT. + ;; If it does not match, nil is returned instead of the new string. + ;; Optional arg LITERAL means to take NEWTEXT literally. + ;; Optional arg GLOBAL means to replace all matches. + (if global + (let ((result "") (start 0) mb me) + (while (string-match regexp string start) + (setq mb (match-beginning 0) + me (match-end 0) + result (concat result + (substring string start mb) + (if literal + newtext + (dired-expand-newtext string newtext))) + start me)) + (if mb ; matched at least once + (concat result (substring string start)) + nil)) + ;; not GLOBAL + (if (not (string-match regexp string 0)) + nil + (concat (substring string 0 (match-beginning 0)) + (if literal newtext (dired-expand-newtext string newtext)) + (substring string (match-end 0)))))) + +(defun dired-expand-newtext (string newtext) + ;; Expand \& and \1..\9 (referring to STRING) in NEWTEXT, using match data. + ;; Note that in Emacs 18 match data are clipped to current buffer + ;; size...so the buffer should better not be smaller than STRING. + (let ((pos 0) + (len (length newtext)) + (expanded-newtext "")) + (while (< pos len) + (setq expanded-newtext + (concat expanded-newtext + (let ((c (aref newtext pos))) + (if (= ?\\ c) + (cond ((= ?\& (setq c + (aref newtext + (setq pos (1+ pos))))) + (substring string + (match-beginning 0) + (match-end 0))) + ((and (>= c ?1) (<= c ?9)) + ;; return empty string if N'th + ;; sub-regexp did not match: + (let ((n (- c ?0))) + (if (match-beginning n) + (substring string + (match-beginning n) + (match-end n)) + ""))) + (t + (char-to-string c))) + (char-to-string c))))) + (setq pos (1+ pos))) + expanded-newtext)) + +(defun dired-in-this-tree (file dir) + ;;Is FILE part of the directory tree starting at DIR? + (let ((len (length dir))) + (and (>= (length file) len) + (string-equal (substring file 0 len) dir)))) + +(defun dired-tree-lessp (dir1 dir2) + ;; Lexicographic order on pathname components, like `ls -lR': + ;; DIR1 < DIR2 iff DIR1 comes *before* DIR2 in an `ls -lR' listing, + ;; i.e., iff DIR1 is a (grand)parent dir of DIR2, + ;; or DIR1 and DIR2 are in the same parentdir and their last + ;; components are string-lessp. + ;; Thus ("/usr/" "/usr/bin") and ("/usr/a/" "/usr/b/") are tree-lessp. + ;; string-lessp could arguably be replaced by file-newer-than-file-p + ;; if dired-internal-switches contained `t'. + (let ((dir1 (file-name-as-directory dir1)) + (dir2 (file-name-as-directory dir2)) + (start1 1) + (start2 1) + comp1 comp2 end1 end2) + (while (progn + (setq end1 (string-match "/" dir1 start1) + comp1 (substring dir1 start1 end1) + end2 (string-match "/" dir2 start2) + comp2 (substring dir2 start2 end2)) + (and end1 end2 (string-equal comp1 comp2))) + (setq start1 (1+ end1) + start2 (1+ end2))) + (if (eq (null end1) (null end2)) + (string-lessp comp1 comp2) + (null end1)))) + +;; So that we can support case-insensitive systems. +(fset 'dired-file-name-lessp 'string-lessp) + + +;;;; ------------------------------------------------------------------ +;;;; Initializing Dired +;;;; ------------------------------------------------------------------ + +;;; Set the minor mode alist + +(or (equal (assq 'dired-sort-mode minor-mode-alist) + '(dired-sort-mode dired-sort-mode)) + ;; Test whether this has already been done in case dired is reloaded + ;; There may be several elements with dired-sort-mode as car. + (setq minor-mode-alist + ;; cons " Omit" in first, so that it doesn't + ;; get stuck between the directory and sort mode on the + ;; mode line. + (cons '(dired-sort-mode dired-sort-mode) + (cons '(dired-subdir-omit " Omit") + (cons '(dired-marker-stack dired-marker-string) + minor-mode-alist))))) + +;;; Keymaps + +(defvar dired-mode-map nil + "Local keymap for dired-mode buffers.") +(defvar dired-regexp-map nil + "Dired keymap for commands that use regular expressions.") +(defvar dired-diff-map nil + "Dired keymap for diff and related commands.") +(defvar dired-subdir-map nil + "Dired keymap for commands that act on subdirs, or the files within them.") + +(defvar dired-keymap-grokked nil + "Set to t after dired has grokked the global keymap.") + +(defun dired-key-description (cmd &rest prefixes) + ;; Return a key description string for a menu. If prefixes are given, + ;; they should be either strings, integers, or 'universal-argument. + (let ((key (where-is-internal cmd dired-mode-map t))) + (if key + (key-description + (apply 'vconcat + (append + (mapcar + (function + (lambda (x) + (cond ((eq x 'universal-argument) + (where-is-internal 'universal-argument + dired-mode-map t)) + ((integerp x) (int-to-string x)) + (t x)))) + prefixes) + (list key)))) + ""))) + +(defun dired-grok-keys (to-command from-command) + ;; Assigns to TO-COMMAND the keys for the global binding of FROM-COMMAND. + ;; Does not clobber anything in the local keymap. In emacs 19 should + ;; use substitute-key-definition, but I believe that this will + ;; clobber things in the local map. + (let ((keys (where-is-internal from-command))) + (while keys + (condition-case nil + (if (eq (global-key-binding (car keys)) (key-binding (car keys))) + (local-set-key (car keys) to-command)) + (error nil)) + (setq keys (cdr keys))))) + +(defun dired-grok-keymap () + ;; Initialize the dired keymaps. + ;; This is actually done the first time that dired-mode runs. + ;; We do it this late, to be sure that the user's global-keymap has + ;; stabilized. + (if dired-keymap-grokked + () ; we've done it + ;; Watch out for dired being invoked from the command line. + ;; This is a bit kludgy, but so is the emacs startup sequence IMHO. + (if (and term-setup-hook (boundp 'command-line-args-left)) + (progn + (if (string-equal "18." (substring emacs-version 0 3)) + (funcall term-setup-hook) + (run-hooks 'term-setup-hook)) + (setq term-setup-hook nil))) + (setq dired-keymap-grokked t) + (run-hooks 'dired-setup-keys-hook) + (dired-grok-keys 'dired-next-line 'next-line) + (dired-grok-keys 'dired-previous-line 'previous-line) + (dired-grok-keys 'dired-undo 'undo) + (dired-grok-keys 'dired-undo 'advertised-undo) + (dired-grok-keys 'dired-scroll-up 'scroll-up) + (dired-grok-keys 'dired-scroll-down 'scroll-down) + (dired-grok-keys 'dired-beginning-of-buffer 'beginning-of-buffer) + (dired-grok-keys 'dired-end-of-buffer 'end-of-buffer) + (dired-grok-keys 'dired-next-subdir 'forward-paragraph) + (dired-grok-keys 'dired-prev-subdir 'backward-paragraph))) + +;; The regexp-map is used for commands using regexp's. +(if dired-regexp-map + () + (setq dired-regexp-map (make-sparse-keymap)) + (define-key dired-regexp-map "C" 'dired-do-copy-regexp) + ;; Not really a regexp, but does transform file names. + (define-key dired-regexp-map "D" 'dired-downcase) + (define-key dired-regexp-map "H" 'dired-do-hardlink-regexp) + (define-key dired-regexp-map "R" 'dired-do-rename-regexp) + (define-key dired-regexp-map "S" 'dired-do-symlink-regexp) + (define-key dired-regexp-map "U" 'dired-upcase) + (define-key dired-regexp-map "Y" 'dired-do-relsymlink-regexp) + (define-key dired-regexp-map "c" 'dired-cleanup) + (define-key dired-regexp-map "d" 'dired-flag-files-regexp) + (define-key dired-regexp-map "e" 'dired-mark-extension) + (define-key dired-regexp-map "m" 'dired-mark-files-regexp) + (define-key dired-regexp-map "o" 'dired-add-omit-regexp) + (define-key dired-regexp-map "x" 'dired-flag-extension)) ; a string, rather + ; than a regexp. + +(if dired-diff-map + () + (setq dired-diff-map (make-sparse-keymap)) + (define-key dired-diff-map "d" 'dired-diff) + (define-key dired-diff-map "b" 'dired-backup-diff) + (define-key dired-diff-map "m" 'dired-emerge) + (define-key dired-diff-map "a" 'dired-emerge-with-ancestor) + (define-key dired-diff-map "e" 'dired-ediff) + (define-key dired-diff-map "p" 'dired-epatch)) + +(if dired-subdir-map + () + (setq dired-subdir-map (make-sparse-keymap)) + (define-key dired-subdir-map "n" 'dired-redisplay-subdir) + (define-key dired-subdir-map "m" 'dired-mark-subdir-files) + (define-key dired-subdir-map "d" 'dired-flag-subdir-files) + (define-key dired-subdir-map "z" 'dired-compress-subdir-files)) + +(fset 'dired-regexp-prefix dired-regexp-map) +(fset 'dired-diff-prefix dired-diff-map) +(fset 'dired-subdir-prefix dired-subdir-map) +(fset 'efs-dired-prefix (function (lambda () + (interactive) + (error "efs-dired not loaded yet")))) + +;; the main map +(if dired-mode-map + nil + ;; Force `f' rather than `e' in the mode doc: + (fset 'dired-advertised-find-file 'dired-find-file) + (fset 'dired-advertised-next-subdir 'dired-next-subdir) + (fset 'dired-advertised-prev-subdir 'dired-prev-subdir) + (setq dired-mode-map (make-keymap)) + (suppress-keymap dired-mode-map) + ;; Commands to mark certain categories of files + (define-key dired-mode-map "~" 'dired-flag-backup-files) + (define-key dired-mode-map "#" 'dired-flag-auto-save-files) + (define-key dired-mode-map "*" 'dired-mark-executables) + (define-key dired-mode-map "." 'dired-clean-directory) + (define-key dired-mode-map "/" 'dired-mark-directories) + (define-key dired-mode-map "@" 'dired-mark-symlinks) + (define-key dired-mode-map "," 'dired-mark-rcs-files) + (define-key dired-mode-map "\M-(" 'dired-mark-sexp) + (define-key dired-mode-map "\M-d" 'dired-mark-files-from-other-dired-buffer) + (define-key dired-mode-map "\M-c" 'dired-mark-files-compilation-buffer) + ;; Upper case keys (except ! and &) for operating on the marked files + (define-key dired-mode-map "A" 'dired-do-tags-search) + (define-key dired-mode-map "B" 'dired-do-byte-compile) + (define-key dired-mode-map "C" 'dired-do-copy) + (define-key dired-mode-map "E" 'dired-do-grep) + (define-key dired-mode-map "F" 'dired-do-find-file) + (define-key dired-mode-map "G" 'dired-do-chgrp) + (define-key dired-mode-map "H" 'dired-do-hardlink) + (define-key dired-mode-map "I" 'dired-do-insert-subdir) + (define-key dired-mode-map "K" 'dired-do-kill-file-lines) + (define-key dired-mode-map "L" 'dired-do-load) + (define-key dired-mode-map "M" 'dired-do-chmod) + (define-key dired-mode-map "N" 'dired-do-redisplay) + (define-key dired-mode-map "O" 'dired-do-chown) + (define-key dired-mode-map "P" 'dired-do-print) + (define-key dired-mode-map "Q" 'dired-do-tags-query-replace) + (define-key dired-mode-map "R" 'dired-do-rename) + (define-key dired-mode-map "S" 'dired-do-symlink) + (define-key dired-mode-map "T" 'dired-do-total-size) + (define-key dired-mode-map "U" 'dired-do-uucode) + (define-key dired-mode-map "W" 'dired-copy-filenames-as-kill) + (define-key dired-mode-map "X" 'dired-do-delete) + (define-key dired-mode-map "Y" 'dired-do-relsymlink) + (define-key dired-mode-map "Z" 'dired-do-compress) + (define-key dired-mode-map "!" 'dired-do-shell-command) + (define-key dired-mode-map "&" 'dired-do-background-shell-command) + ;; Make all regexp commands share a `%' prefix: + (define-key dired-mode-map "%" 'dired-regexp-prefix) + ;; Lower keys for commands not operating on all the marked files + (define-key dired-mode-map "a" 'dired-apropos) + (define-key dired-mode-map "c" 'dired-change-marks) + (define-key dired-mode-map "d" 'dired-flag-file-deletion) + (define-key dired-mode-map "\C-d" 'dired-flag-file-deletion-backup) + (define-key dired-mode-map "e" 'dired-find-file) + (define-key dired-mode-map "f" 'dired-advertised-find-file) + (define-key dired-mode-map "g" 'revert-buffer) + (define-key dired-mode-map "h" 'dired-describe-mode) + (define-key dired-mode-map "i" 'dired-maybe-insert-subdir) + (define-key dired-mode-map "k" 'dired-kill-subdir) + (define-key dired-mode-map "m" 'dired-mark) + (define-key dired-mode-map "o" 'dired-find-file-other-window) + (define-key dired-mode-map "q" 'dired-quit) + (define-key dired-mode-map "r" 'dired-read-mail) + (define-key dired-mode-map "s" 'dired-sort-toggle-or-edit) + (define-key dired-mode-map "t" 'dired-get-target-directory) + (define-key dired-mode-map "u" 'dired-unmark) + (define-key dired-mode-map "v" 'dired-view-file) + (define-key dired-mode-map "w" (if (fboundp 'find-file-other-frame) + 'dired-find-file-other-frame + 'dired-find-file-other-window)) + (define-key dired-mode-map "x" 'dired-expunge-deletions) + (define-key dired-mode-map "y" 'dired-why) + (define-key dired-mode-map "+" 'dired-create-directory) + (define-key dired-mode-map "`" 'dired-recover-file) + ;; dired-jump-back Should be in the global map, but put them here + ;; too anyway. + (define-key dired-mode-map "\C-x\C-j" 'dired-jump-back) + (define-key dired-mode-map "\C-x4\C-j" 'dired-jump-back-other-window) + (define-key dired-mode-map "\C-x5\C-j" 'dired-jump-back-other-frame) + ;; Comparison commands + (define-key dired-mode-map "=" 'dired-diff-prefix) + ;; moving + (define-key dired-mode-map "<" 'dired-prev-dirline) + (define-key dired-mode-map ">" 'dired-next-dirline) + (define-key dired-mode-map " " 'dired-next-line) + (define-key dired-mode-map "n" 'dired-next-line) + (define-key dired-mode-map "\C-n" 'dired-next-line) + (define-key dired-mode-map "p" 'dired-previous-line) + (define-key dired-mode-map "\C-p" 'dired-previous-line) + (define-key dired-mode-map "\C-v" 'dired-scroll-up) + (define-key dired-mode-map "\M-v" 'dired-scroll-down) + (define-key dired-mode-map "\M-<" 'dired-beginning-of-buffer) + (define-key dired-mode-map "\M->" 'dired-end-of-buffer) + ;; This is silly, I'm changing it. -sb + ;; (define-key dired-mode-map "\C-m" 'dired-goto-file) + (define-key dired-mode-map "\C-m" 'dired-advertised-find-file) + ;; motion by subdirectories + (define-key dired-mode-map "^" 'dired-up-directory) + (define-key dired-mode-map "\M-\C-u" 'dired-up-directory) + (define-key dired-mode-map "\M-\C-d" 'dired-down-directory) + (define-key dired-mode-map "\M-\C-n" 'dired-advertised-next-subdir) + (define-key dired-mode-map "\M-\C-p" 'dired-advertised-prev-subdir) + (define-key dired-mode-map "\C-j" 'dired-goto-subdir) + ;; move to marked files + (define-key dired-mode-map "\M-p" 'dired-prev-marked-file) + (define-key dired-mode-map "\M-n" 'dired-next-marked-file) + ;; hiding + (define-key dired-mode-map "$" 'dired-hide-subdir) + (define-key dired-mode-map "\M-$" 'dired-hide-all) + ;; omitting + (define-key dired-mode-map "\C-o" 'dired-omit-toggle) + ;; markers + (define-key dired-mode-map "\(" 'dired-set-marker-char) + (define-key dired-mode-map "\)" 'dired-restore-marker-char) + (define-key dired-mode-map "'" 'dired-marker-stack-left) + (define-key dired-mode-map "\\" 'dired-marker-stack-right) + ;; misc + (define-key dired-mode-map "\C-i" 'dired-mark-prefix) + (define-key dired-mode-map "?" 'dired-summary) + (define-key dired-mode-map "\177" 'dired-backup-unflag) + (define-key dired-mode-map "\C-_" 'dired-undo) + (define-key dired-mode-map "\C-xu" 'dired-undo) + (define-key dired-mode-map "\M-\C-?" 'dired-unmark-all-files) + ;; The subdir map + (define-key dired-mode-map "|" 'dired-subdir-prefix) + ;; efs submap + (define-key dired-mode-map "\M-e" 'efs-dired-prefix)) + + + +;;;;------------------------------------------------------------------ +;;;; The dired command +;;;;------------------------------------------------------------------ + +;;; User commands: +;;; All of these commands should have a binding in the global keymap. + +;;;###autoload (define-key ctl-x-map "d" 'dired) +;;;###autoload +(defun dired (dirname &optional switches) + "\"Edit\" directory DIRNAME--delete, rename, print, etc. some files in it. +Optional second argument SWITCHES specifies the `ls' options used. +\(Interactively, use a prefix argument to be able to specify SWITCHES.) +Dired displays a list of files in DIRNAME (which may also have +shell wildcards appended to select certain files). If DIRNAME is a cons, +its first element is taken as the directory name and the resr as an explicit +list of files to make directory entries for. +\\\ +You can move around in it with the usual commands. +You can flag files for deletion with \\[dired-flag-file-deletion] and then +delete them by typing \\[dired-expunge-deletions]. +Type \\[dired-describe-mode] after entering dired for more info. + +If DIRNAME is already in a dired buffer, that buffer is used without refresh." + ;; Cannot use (interactive "D") because of wildcards. + (interactive (dired-read-dir-and-switches "")) + (switch-to-buffer (dired-noselect dirname switches))) + +;;;###autoload (define-key ctl-x-4-map "d" 'dired-other-window) +;;;###autoload +(defun dired-other-window (dirname &optional switches) + "\"Edit\" directory DIRNAME. Like `dired' but selects in another window." + (interactive (dired-read-dir-and-switches "in other window ")) + (switch-to-buffer-other-window (dired-noselect dirname switches))) + +;;;###autoload (define-key ctl-x-5-map "d" 'dired-other-frame) +;;;###autoload +(defun dired-other-frame (dirname &optional switches) + "\"Edit\" directory DIRNAME. Like `dired' but makes a new frame." + (interactive (dired-read-dir-and-switches "in other frame ")) + (switch-to-buffer-other-frame (dired-noselect dirname switches))) + +;;;###autoload +(defun dired-noselect (dir-or-list &optional switches) + "Like `dired' but returns the dired buffer as value, does not select it." + (or dir-or-list (setq dir-or-list (expand-file-name default-directory))) + ;; This loses the distinction between "/foo/*/" and "/foo/*" that + ;; some shells make: + (let (dirname) + (if (consp dir-or-list) + (setq dirname (car dir-or-list)) + (setq dirname dir-or-list)) + (setq dirname (expand-file-name (directory-file-name dirname))) + (if (file-directory-p dirname) + (setq dirname (file-name-as-directory dirname))) + (if (consp dir-or-list) + (setq dir-or-list (cons dirname (cdr dir-or-list))) + (setq dir-or-list dirname)) + (dired-internal-noselect dir-or-list switches))) + +;; Adapted from code by wurgler@zippysun.math.uakron.edu (Tom Wurgler). +;;;###autoload (define-key ctl-x-map "\C-j" 'dired-jump-back) +;;;###autoload +(defun dired-jump-back () + "Jump back to dired. +If in a file, dired the current directory and move to file's line. +If in dired already, pop up a level and goto old directory's line. +In case the proper dired file line cannot be found, refresh the dired + buffer and try again." + (interactive) + (let* ((file (if (eq major-mode 'dired-mode) + (directory-file-name (dired-current-directory)) + buffer-file-name)) + (dir (if file + (file-name-directory file) + default-directory))) + (dired dir) + (if file (dired-really-goto-file file)))) + +;;;###autoload (define-key ctl-x-4-map "\C-j" 'dired-jump-back-other-window) +;;;###autoload +(defun dired-jump-back-other-window () + "Like \\[dired-jump-back], but to other window." + (interactive) + (let* ((file (if (eq major-mode 'dired-mode) + (directory-file-name (dired-current-directory)) + buffer-file-name)) + (dir (if file + (file-name-directory file) + default-directory))) + (dired-other-window dir) + (if file (dired-really-goto-file file)))) + +;;;###autoload (define-key ctl-x-5-map "\C-j" 'dired-jump-back-other-frame) +;;;###autoload +(defun dired-jump-back-other-frame () + "Like \\[dired-jump-back], but in another frame." + (interactive) + (let* ((file (if (eq major-mode 'dired-mode) + (directory-file-name (dired-current-directory)) + buffer-file-name)) + (dir (if file + (file-name-directory file) + default-directory))) + (dired-other-frame dir) + (if file (dired-really-goto-file file)))) + +;;; Dired mode + +;; Dired mode is suitable only for specially formatted data. +(put 'dired-mode 'mode-class 'special) + +(defun dired-mode (&optional dirname switches) + "\\Dired mode is for \"editing\" directory trees. + +For a simple one-line help message, type \\[dired-summary] +For a moderately detailed description of dired mode, type \\[dired-describe-mode] +For the full dired info tree, type \\[universal-argument] \\[dired-describe-mode]" + ;; Not to be called interactively (e.g. dired-directory will be set + ;; to default-directory, which is wrong with wildcards). + (kill-all-local-variables) + (use-local-map dired-mode-map) + (setq major-mode 'dired-mode + mode-name "Dired" + case-fold-search nil + buffer-read-only t + selective-display t ; for subdirectory hiding + selective-display-ellipses nil ; for omit toggling + mode-line-buffer-identification '("Dired: %12b") + mode-line-modified (format dired-mode-line-modified "--" "--" "-") + dired-directory (expand-file-name (or dirname default-directory)) + dired-internal-switches (dired-make-switches-list + (or switches dired-listing-switches))) + (dired-advertise) ; default-directory is already set + (set (make-local-variable 'revert-buffer-function) + (function dired-revert)) + (set (make-local-variable 'default-directory-function) + 'dired-current-directory) + (set (make-local-variable 'page-delimiter) + "\n\n") + (set (make-local-variable 'list-buffers-directory) + dired-directory) + ;; Will only do something in Emacs 19. + (add-hook (make-local-variable 'kill-buffer-hook) + 'dired-unadvertise-current-buffer) + ;; Same here + (if window-system + (add-hook (make-local-variable 'post-command-hook) + (function + (lambda () + (if (memq this-command dired-modeline-tracking-cmds) + (dired-update-mode-line t)))))) + (dired-sort-other dired-internal-switches t) + (dired-hack-local-variables) + (run-hooks 'dired-mode-hook) + ;; Run this after dired-mode-hook, in case that hook makes changes to + ;; the keymap. + (dired-grok-keymap)) + +;;; Internal functions for starting dired + +(defun dired-read-dir-and-switches (str) + ;; For use in interactive. + (reverse (list + (if current-prefix-arg + (read-string "Dired listing switches: " + dired-listing-switches)) + (let ((default-directory (default-directory))) + (read-file-name (format "Dired %s(directory): " str) + nil default-directory nil))))) + +(defun dired-hack-local-variables () + "Parse, bind or evaluate any local variables for current dired buffer. +See variable `dired-local-variables-file'." + (if (and dired-local-variables-file + (file-exists-p dired-local-variables-file)) + (let (buffer-read-only opoint ) + (save-excursion + (goto-char (point-max)) + (setq opoint (point-marker)) + (insert "\^L\n") + (insert-file-contents dired-local-variables-file)) + (let ((buffer-file-name dired-local-variables-file)) + (condition-case err + (hack-local-variables) + (error (message "Error in dired-local-variables-file: %s" err) + (sit-for 1)))) + ;; Must delete it as (eobp) is often used as test for last + ;; subdir in dired.el. + (delete-region opoint (point-max)) + (set-marker opoint nil)))) + +;; Separate function from dired-noselect for the sake of dired-vms.el. +(defun dired-internal-noselect (dir-or-list &optional switches mode) + ;; If there is an existing dired buffer for DIRNAME, just leave + ;; buffer as it is (don't even call dired-revert). + ;; This saves time especially for deep trees or with efs. + ;; The user can type `g'easily, and it is more consistent with find-file. + ;; But if SWITCHES are given they are probably different from the + ;; buffer's old value, so call dired-sort-other, which does + ;; revert the buffer. + ;; If the user specifies a directory with emacs startup, eg. + ;; emacs ~, dir-or-list may be unexpanded at this point. + + (let* ((dirname (expand-file-name (if (consp dir-or-list) + (car dir-or-list) + dir-or-list))) + (buffer (dired-find-buffer-nocreate dir-or-list mode)) + ;; note that buffer already is in dired-mode, if found + (new-buffer-p (not buffer)) + (old-buf (current-buffer)) + wildcard) + (or buffer + (let ((default-major-mode 'fundamental-mode)) + ;; We don't want default-major-mode to run hooks and set auto-fill + ;; or whatever, now that dired-mode does not + ;; kill-all-local-variables any longer. + (setq buffer (create-file-buffer (directory-file-name dirname))))) + (set-buffer buffer) + (if (not new-buffer-p) ; existing buffer ... + (progn + (if switches + (dired-sort-other + (if (stringp switches) + (dired-make-switches-list switches) + switches))) + (if dired-verify-modtimes (dired-verify-modtimes)) + (if (and dired-find-subdir + (not (string-equal (dired-current-directory) + (file-name-as-directory dirname)))) + (dired-initial-position dirname))) + ;; Else a new buffer + (if (file-directory-p dirname) + (setq default-directory dirname + wildcard (consp dir-or-list)) + (setq default-directory (file-name-directory dirname) + wildcard t)) + (or switches (setq switches dired-listing-switches)) + (dired-mode dirname switches) + ;; default-directory and dired-internal-switches are set now + ;; (buffer-local), so we can call dired-readin: + (let ((failed t)) + (unwind-protect + (progn (dired-readin dir-or-list buffer wildcard) + (setq failed nil)) + ;; dired-readin can fail if parent directories are inaccessible. + ;; Don't leave an empty buffer around in that case. + (if failed (kill-buffer buffer)))) + ;; No need to narrow since the whole buffer contains just + ;; dired-readin's output, nothing else. The hook can + ;; successfully use dired functions (e.g. dired-get-filename) + ;; as the subdir-alist has been built in dired-readin. + (run-hooks 'dired-after-readin-hook) + ;; I put omit-expunge after the dired-after-readin-hook + ;; in case that hook marks files. Does this make sense? Also, users + ;; might want to set dired-omit-files-p in some incredibly clever + ;; way depending on the contents of the directory... I don't know... + (if dired-omit-files + (dired-omit-expunge nil t)) + (goto-char (point-min)) + (dired-initial-position dirname)) + (set-buffer old-buf) + buffer)) + +(defun dired-find-buffer-nocreate (dir-or-list &optional mode) + ;; Returns a dired buffer for DIR-OR-LIST. DIR-OR-LIST may be wildcard, + ;; or a directory and alist of files. + ;; If dired-find-subdir is non-nil, is satisfied with a dired + ;; buffer containing DIR-OR-LIST as a subdirectory. If there is more + ;; than one candidate, returns the most recently used. + (if dired-find-subdir + (let ((buffers (sort (delq (current-buffer) + (dired-buffers-for-dir dir-or-list t)) + (function dired-buffer-more-recently-used-p)))) + (or (car buffers) + ;; Couldn't find another buffer. Will the current one do? + ;; It is up dired-initial-position to actually go to the subdir. + (and (or (equal dir-or-list dired-directory) ; covers wildcards + (and (stringp dir-or-list) + (not (string-equal + dir-or-list + (expand-file-name default-directory))) + (assoc (file-name-as-directory dir-or-list) + dired-subdir-alist))) + (current-buffer)))) + ;; Else just look through the buffer list. + (let (found (blist (buffer-list))) + (or mode (setq mode 'dired-mode)) + (save-excursion + (while blist + (set-buffer (car blist)) + (if (and (eq major-mode mode) + (equal dired-directory dir-or-list)) + (setq found (car blist) + blist nil) + (setq blist (cdr blist))))) + found))) + +(defun dired-initial-position (dirname) + ;; Where point should go in a new listing of DIRNAME. + ;; Point assumed at beginning of new subdir line. + (end-of-line) + (if dired-find-subdir (dired-goto-subdir dirname)) + (if dired-trivial-filenames (dired-goto-next-nontrivial-file)) + (dired-update-mode-line t)) + +(defun dired-readin (dir-or-list buffer &optional wildcard) + ;; Read in a new dired buffer + ;; dired-readin differs from dired-insert-subdir in that it accepts + ;; wildcards, erases the buffer, and builds the subdir-alist anew + ;; (including making it buffer-local and clearing it first). + ;; default-directory and dired-internal-switches must be buffer-local + ;; and initialized by now. + ;; Thus we can test (equal default-directory dirname) instead of + ;; (file-directory-p dirname) and save a filesystem transaction. + ;; This is wrong, if dired-before-readin-hook changes default-directory + ;; Also, we can run this hook which may want to modify the switches + ;; based on default-directory, e.g. with efs to a SysV host + ;; where ls won't understand -Al switches. + (let (dirname other-dirs) + (if (consp dir-or-list) + (setq dir-or-list (dired-frob-dir-list dir-or-list) + other-dirs (cdr dir-or-list) + dir-or-list (car dir-or-list) + dirname (car dir-or-list)) + (setq dirname dir-or-list)) + (setq dirname (expand-file-name dirname)) + (if (consp dir-or-list) + (setq dir-or-list (cons dirname (cdr dir-or-list)))) + (save-excursion + (set-buffer buffer) + (run-hooks 'dired-before-readin-hook) + (message "Reading directory %s..." dirname) + (let (buffer-read-only) + (widen) + (erase-buffer) + (dired-readin-insert dir-or-list wildcard) + (dired-indent-listing (point-min) (point-max)) + ;; We need this to make the root dir have a header line as all + ;; other subdirs have: + (goto-char (point-min)) + (dired-insert-headerline (expand-file-name default-directory))) + (message "Reading directory %s...done" dirname) + (set-buffer-modified-p nil) + ;; Must first make alist buffer local and set it to nil because + ;; dired-build-subdir-alist will call dired-clear-alist first + (setq dired-subdir-alist nil) + (if (memq ?R dired-internal-switches) + (dired-build-subdir-alist) + ;; no need to parse the buffer if listing is not recursive + (dired-simple-subdir-alist)) + (if other-dirs + (mapcar + (function + (lambda (x) + (if (dired-in-this-tree (car x) dirname) + (dired-insert-subdir x)))) + other-dirs))))) + +;;; Subroutines of dired-readin + +(defun dired-readin-insert (dir-or-list &optional wildcard) + ;; Just insert listing for the passed-in directory or + ;; directory-and-file list, assuming a clean buffer. + (let* ((switches (dired-make-switches-string dired-internal-switches)) + (dir-is-list (consp dir-or-list)) + (dirname (if dir-is-list (car dir-or-list) dir-or-list))) + (if wildcard + (progn + (or (file-readable-p + (if dir-is-list + dirname + (directory-file-name (file-name-directory dirname)))) + (error "Directory %s inaccessible or nonexistent" dirname)) + ;; else assume it contains wildcards + (dired-insert-directory dir-or-list switches t) + (save-excursion + ;; insert wildcard instead of total line: + (goto-char (point-min)) + (if dir-is-list + (insert "list wildcard\n") + (insert "wildcard " (file-name-nondirectory dirname) "\n")))) + (dired-insert-directory dir-or-list switches nil t)))) + +(defun dired-insert-directory (dir-or-list switches &optional wildcard full-p) + ;; Do the right thing whether dir-or-list is atomic or not. If it is, + ;; insert all files listed in the cdr -- the car is the passed-in directory + ;; list. + (let ((opoint (point)) + (insert-directory-program dired-ls-program)) + (if (consp dir-or-list) + (mapcar + (function + (lambda (x) + (insert-directory x switches wildcard))) + (cdr dir-or-list)) + (insert-directory dir-or-list switches wildcard full-p)) + (dired-insert-set-properties opoint (point))) + (setq dired-directory dir-or-list)) + +(defun dired-frob-dir-list (dir-list) + (let* ((top (file-name-as-directory (expand-file-name (car dir-list)))) + (tail (cdr dir-list)) + (result (list (list top))) + elt dir) + (setq tail + (mapcar + (function + (lambda (x) + (directory-file-name (expand-file-name x top)))) + tail)) + (while tail + (setq dir (file-name-directory (car tail))) + (if (setq elt (assoc dir result)) + (nconc elt (list (car tail))) + (nconc result (list (list dir (car tail))))) + (setq tail (cdr tail))) + result)) + +(defun dired-insert-headerline (dir);; also used by dired-insert-subdir + ;; Insert DIR's headerline with no trailing slash, exactly like ls + ;; would, and put cursor where dired-build-subdir-alist puts subdir + ;; boundaries. + (save-excursion (insert " " (directory-file-name dir) ":\n"))) + +(defun dired-verify-modtimes () + ;; Check the modtimes of all subdirs. + (let ((alist dired-subdir-alist) + on-disk in-mem badies) + (while alist + (and (setq in-mem (nth 4 (car alist))) + (setq on-disk (dired-file-modtime (car (car alist)))) + (not (equal in-mem on-disk)) + (setq badies (cons (cons (car (car alist)) + (nth 3 (car alist))) + badies))) + (setq alist (cdr alist))) + (and badies + (let* ((ofile (dired-get-filename nil t)) + (osub (and (null ofile) (dired-get-subdir))) + (opoint (point)) + (ocol (current-column))) + (unwind-protect + (and + (or (memq 'revert-subdirs dired-no-confirm) + (save-window-excursion + (let ((flist (mapcar + (function + (lambda (f) + (dired-abbreviate-file-name (car f)))) + badies))) + (switch-to-buffer (current-buffer)) + (dired-mark-pop-up + "*Stale Subdirectories*" 'revert-subdirs + flist 'y-or-n-p + (if (= (length flist) 1) + (concat "Subdirectory " (car flist) + " has changed on disk. Re-list? ") + "Subdirectories have changed on disk. Re-list? ")) + ))) + (while badies + (dired-insert-subdir (car (car badies)) + (cdr (car badies)) nil t) + (setq badies (cdr badies)))) + ;; We can't use dired-save-excursion here, because we are + ;; rewriting the entire listing, and not just changing a single + ;; file line. + (or (if ofile + (dired-goto-file ofile) + (if osub + (dired-goto-subdir osub))) + (progn + (goto-char opoint) + (beginning-of-line) + (skip-chars-forward "^\n\r" (+ (point) ocol)))) + (dired-update-mode-line t) + (dired-update-mode-line-modified t)))))) + +(defun dired-indent-listing (start end) + ;; Indent a dired listing. + (let (indent-tabs-mode) + (indent-rigidly start end 2) + ;; Quote any null lines that shouldn't be. + (save-excursion + (goto-char start) + (while (search-forward "\n\n" end t) + (forward-char -2) + (if (looking-at dired-subdir-regexp) + (goto-char (match-end 3)) + (progn + (forward-char 1) + (insert " "))))))) + + +;;;; ------------------------------------------------------------ +;;;; Reverting a dired buffer, or specific file lines within it. +;;;; ------------------------------------------------------------ + +(defun dired-revert (&optional arg noconfirm) + ;; Reread the dired buffer. Must also be called after + ;; dired-internal-switches have changed. + ;; Should not fail even on completely garbaged buffers. + ;; Preserves old cursor, marks/flags, hidden-p. + (widen) ; just in case user narrowed + (let ((opoint (point)) + (ofile (dired-get-filename nil t)) + (hidden-subdirs (dired-remember-hidden)) + ;; switches for top-level dir + (oswitches (or (nth 3 (nth (1- (length dired-subdir-alist)) + dired-subdir-alist)) + (delq ?R (copy-sequence dired-internal-switches)))) + ;; all other subdirs + (old-subdir-alist (cdr (reverse dired-subdir-alist))) + (omitted-subdirs (dired-remember-omitted)) + ;; do this after dired-remember-hidden, since this unhides + (mark-alist (dired-remember-marks (point-min) (point-max))) + (kill-files-p (save-excursion + (goto-char (point)) + (search-forward + (concat (char-to-string ?\r) + (regexp-quote + (char-to-string + dired-kill-marker-char))) + nil t))) + buffer-read-only) + ;; This is bogus, as it will not handle all the ways that efs uses cache. + ;; Better to just use the fact that revert-buffer-function is a + ;; buffer-local variable, and reset it to something that knows about + ;; cache. + ;; (dired-uncache + ;; (if (consp dired-directory) (car dired-directory) dired-directory)) + ;; treat top level dir extra (it may contain wildcards) + (let ((dired-after-readin-hook nil) + ;; don't run that hook for each subdir... + (dired-omit-files nil) + (dired-internal-switches oswitches)) + (dired-readin dired-directory (current-buffer) + ;; Don't test for wildcards by checking string= + ;; default-directory and dired-directory + ;; in case default-directory got munged. + (or (consp dired-directory) + (null (file-directory-p dired-directory)))) + ;; The R-switch will clobber sorting of subdirs. + ;; What is the right thing to do here? + (dired-insert-old-subdirs old-subdir-alist)) + (dired-mark-remembered mark-alist) ; mark files that were marked + (if kill-files-p (dired-do-hide dired-kill-marker-char)) + (run-hooks 'dired-after-readin-hook) ; no need to narrow + ;; omit-expunge after the readin hook + (save-excursion + (mapcar (function (lambda (dir) + (if (dired-goto-subdir dir) + (dired-omit-expunge)))) + omitted-subdirs)) + ;; hide subdirs that were hidden + (save-excursion + (mapcar (function (lambda (dir) + (if (dired-goto-subdir dir) + (dired-hide-subdir 1)))) + hidden-subdirs)) + ;; Try to get back to where we were + (or (and ofile (dired-goto-file ofile)) + (goto-char opoint)) + (dired-move-to-filename) + (dired-update-mode-line t) + (dired-update-mode-line-modified t))) + +(defun dired-do-redisplay (&optional arg) + "Redisplay all marked (or next ARG) files." + (interactive "P") + ;; message instead of making dired-map-over-marks show-progress is + ;; much faster + (dired-map-over-marks (let ((fname (dired-get-filename))) + (dired-uncache fname nil) + (message "Redisplaying %s..." fname) + (dired-update-file-line fname)) + arg) + (dired-update-mode-line-modified t) + (message "Redisplaying...done")) + +(defun dired-redisplay-subdir (&optional arg) + "Redisplay the current subdirectory. +With a prefix prompts for listing switches." + (interactive "P") + (let ((switches (and arg (dired-make-switches-list + (read-string "Switches for listing: " + (dired-make-switches-string + dired-internal-switches))))) + (dir (dired-current-directory)) + (opoint (point)) + (ofile (dired-get-filename nil t))) + (or switches + (setq switches (nth 3 (assoc dir dired-subdir-alist)))) + (or switches + (setq switches (delq ?R (copy-sequence dired-internal-switches)))) + (message "Redisplaying %s..." dir) + (dired-uncache dir t) + (dired-insert-subdir dir switches) + (dired-update-mode-line-modified t) + (or (and ofile (dired-goto-file ofile)) (goto-char opoint)) + (message "Redisplaying %s... done" dir))) + +(defun dired-update-file-line (file) + ;; Delete the current line, and insert an entry for FILE. + ;; Does not update other dired buffers. Use dired-relist-file for that. + (let* ((start (save-excursion (skip-chars-backward "^\n\r") (point))) + (char (char-after start))) + (dired-save-excursion + ;; don't remember omit marks + (if (memq char (list ?\040 dired-omit-marker-char)) + (setq char nil)) + ;; Delete the current-line. Even though dired-add-entry will not + ;; insert duplicates, the file for the current line may not be the same as + ;; FILE. eg. dired-do-compress + (delete-region (save-excursion (skip-chars-backward "^\n\r") (1- (point))) + (progn (skip-chars-forward "^\n\r") (point))) + ;; dired-add-entry inserts at the end of the previous line. + (forward-char 1) + (dired-add-entry file char t)))) + +;;; Subroutines of dired-revert +;;; Some of these are also used when inserting subdirs. + +;; Don't want to remember omit marks, in case omission regexps +;; were changed, before the dired-revert. If we don't unhide +;; omitted files, we won't see their marks. Therefore we use +;; dired-omit-unhide-region. + +(defun dired-remember-marks (beg end) + ;; Return alist of files and their marks, from BEG to END. + (if selective-display ; must unhide to make this work. + (let (buffer-read-only) + (subst-char-in-region (point-min) (point-max) ?\r ?\n) + (dired-do-hide dired-omit-marker-char))) + (let (fil chr alist) + (save-excursion + (goto-char beg) + (while (re-search-forward dired-re-mark end t) + (if (setq fil (dired-get-filename nil t)) + (setq chr (preceding-char) + alist (cons (cons fil chr) alist))))) + alist)) + +(defun dired-mark-remembered (alist) + ;; Mark all files remembered in ALIST. + (let (elt fil chr) + (while alist + (setq elt (car alist) + alist (cdr alist) + fil (car elt) + chr (cdr elt)) + (if (dired-goto-file fil) + (save-excursion + (beginning-of-line) + (dired-substitute-marker (point) (following-char) chr)))))) + +(defun dired-remember-hidden () + ;; Return a list of all hidden subdirs. + (let ((l dired-subdir-alist) dir result min) + (while l + (setq dir (car (car l)) + min (dired-get-subdir-min (car l)) + l (cdr l)) + (if (and (>= min (point-min)) (<= min (point-max)) + (dired-subdir-hidden-p dir)) + (setq result (cons dir result)))) + result)) + +(defun dired-insert-old-subdirs (old-subdir-alist) + ;; Try to insert all subdirs that were displayed before + (let (elt dir switches) + (while old-subdir-alist + (setq elt (car old-subdir-alist) + old-subdir-alist (cdr old-subdir-alist) + dir (car elt) + switches (or (nth 3 elt) dired-internal-switches)) + (condition-case () + (dired-insert-subdir dir switches) + (error nil))))) + +(defun dired-uncache (file dir-p) + ;; Remove directory DIR from any directory cache. + ;; If DIR-P is non-nil, then FILE is a directory + (let ((handler (find-file-name-handler file 'dired-uncache))) + (if handler + (funcall handler 'dired-uncache file dir-p)))) + + +;;;; ------------------------------------------------------------- +;;;; Inserting subdirectories +;;;; ------------------------------------------------------------- + +(defun dired-maybe-insert-subdir (dirname &optional + switches no-error-if-not-dir-p) + "Insert this subdirectory into the same dired buffer. +If it is already present, just move to it (type \\[dired-do-redisplay] to + refresh), else inserts it at its natural place (as ls -lR would have done). +With a prefix arg, you may edit the ls switches used for this listing. + You can add `R' to the switches to expand the whole tree starting at + this subdirectory. +This function takes some pains to conform to ls -lR output." + (interactive + (list (dired-get-filename) + (if current-prefix-arg + (dired-make-switches-list + (read-string "Switches for listing: " + (dired-make-switches-string + dired-internal-switches)))))) + (let ((opoint (point))) + ;; We don't need a marker for opoint as the subdir is always + ;; inserted *after* opoint. + (setq dirname (file-name-as-directory dirname)) + (or (and (not switches) + (dired-goto-subdir dirname)) + (dired-insert-subdir dirname switches no-error-if-not-dir-p)) + ;; Push mark so that it's easy to find back. Do this after the + ;; insert message so that the user sees the `Mark set' message. + (push-mark opoint))) + +(defun dired-insert-subdir (dir-or-list &optional + switches no-error-if-not-dir-p no-posn) + "Insert this subdirectory into the same dired buffer. +If it is already present, overwrites previous entry, + else inserts it at its natural place (as ls -lR would have done). +With a prefix arg, you may edit the ls switches used for this listing. + You can add `R' to the switches to expand the whole tree starting at + this subdirectory. +This function takes some pains to conform to ls -lR output." + ;; NO-ERROR-IF-NOT-DIR-P needed for special filesystems like + ;; Prospero where dired-ls does the right thing, but + ;; file-directory-p has not been redefined. + ;; SWITCHES should be a list. + ;; If NO-POSN is non-nil, doesn't bother position the point at + ;; the first nontrivial file line. This can be used as an efficiency + ;; hack when calling this from a program. + (interactive + (list (dired-get-filename) + (if current-prefix-arg + (dired-make-switches-list + (read-string "Switches for listing: " + (dired-make-switches-string + dired-internal-switches)))))) + (let ((dirname (if (consp dir-or-list) (car dir-or-list) dir-or-list))) + (setq dirname (file-name-as-directory (expand-file-name dirname))) + (or (dired-in-this-tree dirname (expand-file-name default-directory)) + (error "%s: not in this directory tree" dirname)) + (or no-error-if-not-dir-p + (file-directory-p dirname) + (error "Attempt to insert a non-directory: %s" dirname)) + (if switches + (or (dired-compatible-switches-p dired-internal-switches switches) + (error "Cannot have subdirs with %s and %s switches together." + (dired-make-switches-string dired-internal-switches) + (dired-make-switches-string switches))) + (setq switches dired-internal-switches)) + (let ((elt (assoc dirname dired-subdir-alist)) + mark-alist opoint-max buffer-read-only) + (if (memq ?R switches) + ;; avoid duplicated subdirs + (progn + (setq mark-alist (dired-kill-tree dirname t)) + (dired-insert-subdir-newpos dirname)) + (if elt + ;; If subdir is already present, remove it and remember its marks + (setq mark-alist (dired-insert-subdir-del elt)) + ;; else move to new position + (dired-insert-subdir-newpos dirname))) + (setq opoint-max (point-max)) + (condition-case nil + (dired-insert-subdir-doupdate + dirname (dired-insert-subdir-doinsert dir-or-list switches) + switches elt mark-alist) + (quit ; watch out for aborted inserts + (and (= opoint-max (point-max)) + (null elt) + (= (preceding-char) ?\n) + (delete-char -1)) + (signal 'quit nil)))) + (or no-posn (dired-initial-position dirname)))) + +(defun dired-do-insert-subdir () + "Insert all marked subdirectories in situ that are not yet inserted. +Non-directories are silently ignored." + (interactive) + (let ((files (or (dired-get-marked-files) + (error "No files marked.")))) + (while files + (if (file-directory-p (car files)) + (save-excursion (dired-maybe-insert-subdir (car files)))) + (setq files (cdr files))))) + +;;; Utilities for inserting subdirectories + +(defun dired-insert-subdir-newpos (new-dir) + ;; Find pos for new subdir, according to tree order. + (let ((alist dired-subdir-alist) elt dir new-pos) + (while alist + (setq elt (car alist) + alist (cdr alist) + dir (car elt)) + (if (dired-tree-lessp dir new-dir) + ;; Insert NEW-DIR after DIR + (setq new-pos (dired-get-subdir-max elt) + alist nil))) + (goto-char new-pos)) + (insert "\n") + (point)) + +(defun dired-insert-subdir-del (element) + ;; Erase an already present subdir (given by ELEMENT) from buffer. + ;; Move to that buffer position. Return a mark-alist. + (let ((begin-marker (dired-get-subdir-min element))) + (goto-char begin-marker) + ;; Are at beginning of subdir (and inside it!). Now determine its end: + (goto-char (dired-subdir-max)) + (prog1 + (dired-remember-marks begin-marker (point)) + (delete-region begin-marker (point))))) + +(defun dired-insert-subdir-doinsert (dir-or-list switches) + ;; Insert ls output after point and put point on the correct + ;; position for the subdir alist. + ;; Return the boundary of the inserted text (as list of BEG and END). + ;; SWITCHES should be a non-nil list. + (let ((begin (point)) + (dirname (if (consp dir-or-list) (car dir-or-list) dir-or-list)) + end) + (message "Reading directory %s..." dirname) + (if (string-equal dirname (car (car (reverse dired-subdir-alist)))) + ;; top level directory may contain wildcards: + (let ((dired-internal-switches switches)) + (dired-readin-insert dired-directory + (null (file-directory-p dired-directory)))) + (let ((switches (dired-make-switches-string switches)) + (insert-directory-program dired-ls-program)) + (if (consp dir-or-list) + (progn + (insert "list wildcard\n") + (mapcar + (function + (lambda (x) + (insert-directory x switches t))) + (cdr dir-or-list))) + (insert-directory dirname switches nil t)))) + (message "Reading directory %s...done" dirname) + (setq end (point-marker)) + (dired-indent-listing begin end) + (dired-insert-set-properties begin end) + ;; call dired-insert-headerline afterwards, as under VMS dired-ls + ;; does insert the headerline itself and the insert function just + ;; moves point. + ;; Need a marker for END as this inserts text. + (goto-char begin) + (dired-insert-headerline dirname) + ;; point is now like in dired-build-subdir-alist + (prog1 + (list begin (marker-position end)) + (set-marker end nil)))) + +(defun dired-insert-subdir-doupdate (dirname beg-end switches elt mark-alist) + ;; Point is at the correct subdir alist position for ELT, + ;; BEG-END is the subdir-region (as list of begin and end). + ;; SWITCHES must be a non-nil list. + (if (memq ?R switches) + ;; This will remove ?R from switches on purpose. + (let ((dired-internal-switches (delq ?R switches))) + (dired-build-subdir-alist)) + (if elt + (progn + (set-marker (dired-get-subdir-min elt) (point-marker)) + (setcar (nthcdr 3 elt) switches) + (if dired-verify-modtimes + (dired-set-file-modtime dirname dired-subdir-alist))) + (dired-alist-add dirname (point-marker) dired-omit-files switches))) + (save-excursion + (let ((begin (nth 0 beg-end)) + (end (nth 1 beg-end))) + (goto-char begin) + (save-restriction + (narrow-to-region begin end) + ;; hook may add or delete lines, but the subdir boundary + ;; marker floats + (run-hooks 'dired-after-readin-hook) + (if mark-alist (dired-mark-remembered mark-alist)) + (dired-do-hide dired-kill-marker-char) + (if (if elt (nth 2 elt) dired-omit-files) + (dired-omit-expunge nil t)))))) + + +;;;; -------------------------------------------------------------- +;;;; Dired motion commands -- moving around in the dired buffer. +;;;; -------------------------------------------------------------- + +(defun dired-next-line (arg) + "Move down lines then position at filename. +Optional prefix ARG says how many lines to move; default is one line." + (interactive "p") + (condition-case err + (next-line arg) + (error + (if (eobp) + (error "End of buffer") + (error "%s" err)))) + (dired-move-to-filename) + (dired-update-mode-line)) + +(defun dired-previous-line (arg) + "Move up lines then position at filename. +Optional prefix ARG says how many lines to move; default is one line." + (interactive "p") + (previous-line arg) + (dired-move-to-filename) + (dired-update-mode-line)) + +(defun dired-scroll-up (arg) + "Dired version of scroll up. +Scroll text of current window upward ARG lines; or near full screen if no ARG. +When calling from a program, supply a number as argument or nil." + (interactive "P") + (scroll-up arg) + (dired-move-to-filename) + (dired-update-mode-line)) + +(defun dired-scroll-down (arg) + "Dired version of scroll-down. +Scroll text of current window down ARG lines; or near full screen if no ARG. +When calling from a program, supply a number as argument or nil." + (interactive "P") + (scroll-down arg) + (dired-move-to-filename) + (dired-update-mode-line)) + +(defun dired-beginning-of-buffer (arg) + "Dired version of `beginning of buffer'." + (interactive "P") + (beginning-of-buffer arg) + (dired-update-mode-line)) + +(defun dired-end-of-buffer (arg) + "Dired version of `end-of-buffer'." + (interactive "P") + (end-of-buffer arg) + (while (not (or (dired-move-to-filename) (dired-get-subdir) (bobp))) + (forward-line -1)) + (dired-update-mode-line t)) + +(defun dired-next-dirline (arg &optional opoint) + "Goto ARG'th next directory file line." + (interactive "p") + (if dired-re-dir + (progn + (dired-check-ls-l) + (or opoint (setq opoint (point))) + (if (if (> arg 0) + (re-search-forward dired-re-dir nil t arg) + (beginning-of-line) + (re-search-backward dired-re-dir nil t (- arg))) + (progn + (dired-move-to-filename) ; user may type `i' or `f' + (dired-update-mode-line)) + (goto-char opoint) + (error "No more subdirectories"))))) + +(defun dired-prev-dirline (arg) + "Goto ARG'th previous directory file line." + (interactive "p") + (dired-next-dirline (- arg))) + +(defun dired-next-marked-file (arg &optional wrap opoint) + "Move to the next marked file, wrapping around the end of the buffer." + (interactive "p\np") + (or opoint (setq opoint (point))) ; return to where interactively started + (if (if (> arg 0) + (re-search-forward dired-re-mark nil t arg) + (beginning-of-line) + (re-search-backward dired-re-mark nil t (- arg))) + (dired-move-to-filename) + (if (null wrap) + (progn + (goto-char opoint) + (error "No next marked file")) + (message "(Wraparound for next marked file)") + (goto-char (if (> arg 0) (point-min) (point-max))) + (dired-next-marked-file arg nil opoint))) + (dired-update-mode-line)) + +(defun dired-prev-marked-file (arg &optional wrap) + "Move to the previous marked file, wrapping around the end of the buffer." + (interactive "p\np") + (dired-next-marked-file (- arg) wrap) + (dired-update-mode-line)) + +(defun dired-goto-file (file) + "Goto file line of FILE in this dired buffer." + ;; Return value of point on success, else nil. + ;; FILE must be an absolute pathname. + ;; Loses if FILE contains control chars like "\007" for which ls + ;; either inserts "?" or "\\007" into the buffer, so we won't find + ;; it in the buffer. + (interactive + (prog1 ; let push-mark display its message + (list + (let* ((dired-completer-buffer (current-buffer)) + (dired-completer-switches dired-internal-switches) + (stack (reverse + (mapcar (function + (lambda (x) + (dired-abbreviate-file-name (car x)))) + dired-subdir-alist))) + (initial (car stack)) + (dired-goto-file-history (cdr stack)) + dired-completer-cache) + (expand-file-name + (dired-completing-read "Goto file: " + 'dired-goto-file-completer + nil t initial 'dired-goto-file-history)))) + (push-mark))) + (setq file (directory-file-name file)) ; does no harm if no directory + (let (found case-fold-search) + (save-excursion + (if (dired-goto-subdir (or (file-name-directory file) + (error "Need absolute pathname for %s" + file))) + (let* ((base (file-name-nondirectory file)) + ;; filenames are preceded by SPC, this makes + ;; the search faster (e.g. for the filename "-"!). + (search (concat " " (dired-make-filename-string base t))) + (boundary (dired-subdir-max)) + fn) + (while (and (not found) (search-forward search boundary 'move)) + ;; Match could have BASE just as initial substring or + ;; or in permission bits or date or + ;; not be a proper filename at all: + (if (and (setq fn (dired-get-filename 'no-dir t)) + (string-equal fn base)) + ;; Must move to filename since an (actually + ;; correct) match could have been elsewhere on the + ;; line (e.g. "-" would match somewhere in the + ;; permission bits). + (setq found (dired-move-to-filename))))))) + (and found + ;; return value of point (i.e., FOUND): + (prog1 + (goto-char found) + (dired-update-mode-line))))) + +;;; Moving by subdirectories + +(defun dired-up-directory (arg) + "Move to the ARG'th (prefix arg) parent directory of current directory. +Always stays within the current tree dired buffer. Will insert new +subdirectories if necessary." + (interactive "p") + (if (< arg 0) (error "Can't go up a negative number of directories!")) + (or (zerop arg) + (let* ((dir (dired-current-directory)) + (n arg) + (up dir)) + (while (> n 0) + (setq up (file-name-directory (directory-file-name up)) + n (1- n))) + (if (and (< (length up) (length dired-directory)) + (dired-in-this-tree dired-directory up)) + (if (or (memq 'create-top-dir dired-no-confirm) + (y-or-n-p + (format "Insert new top dir %s and rename buffer? " + (dired-abbreviate-file-name up)))) + (let ((newname (let (buff) + (unwind-protect + (buffer-name + (setq buff + (create-file-buffer + (directory-file-name up)))) + (kill-buffer buff)))) + (buffer-read-only nil)) + (push-mark) + (widen) + (goto-char (point-min)) + (insert-before-markers "\n") + (forward-char -1) + (dired-insert-subdir-doupdate + up (dired-insert-subdir-doinsert up dired-internal-switches) + dired-internal-switches nil nil) + (dired-initial-position up) + (rename-buffer newname) + (dired-unadvertise default-directory) + (setq default-directory up + dired-directory up) + (dired-advertise))) + (dired-maybe-insert-subdir up))))) + +(defun dired-down-directory () + "Go down in the dired tree. +Moves to the first subdirectory of the current directory, which exists in +the dired buffer. Does not take a prefix argument." + ;; What would a prefix mean here? + (interactive) + (let ((dir (dired-current-directory)) ; has slash + (rest (reverse dired-subdir-alist)) + pos elt) + (while rest + (setq elt (car rest)) + (if (dired-in-this-tree (directory-file-name (car elt)) dir) + (setq rest nil + pos (dired-goto-subdir (car elt))) + (setq rest (cdr rest)))) + (prog1 + (if pos + (progn + (push-mark) + (goto-char pos)) + (error "At the bottom")) + (dired-update-mode-line t)))) + +(defun dired-next-subdir (arg &optional no-error-if-not-found no-skip) + "Go to next subdirectory, regardless of level." + ;; Use 0 arg to go to this directory's header line. + ;; NO-SKIP prevents moving to end of header line, returning whatever + ;; position was found in dired-subdir-alist. + (interactive "p") + (let ((this-dir (dired-current-directory)) + pos index) + ;; nth with negative arg does not return nil but the first element + (setq index (- (length dired-subdir-alist) + (length (memq (assoc this-dir dired-subdir-alist) + dired-subdir-alist)) + arg)) + (setq pos (if (>= index 0) + (dired-get-subdir-min (nth index dired-subdir-alist)))) + (if pos + (if no-skip + (goto-char pos) + (goto-char pos) + (skip-chars-forward "^\r\n") + (if (= (following-char) ?\r) + (skip-chars-backward "." (- (point) 3))) + (dired-update-mode-line t) + (point)) + (if no-error-if-not-found + nil ; return nil if not found + (error "%s directory" (if (> arg 0) "Last" "First")))))) + +(defun dired-prev-subdir (arg &optional no-error-if-not-found no-skip) + "Go to previous subdirectory, regardless of level. +When called interactively and not on a subdir line, go to this subdir's line." + (interactive + (list (if current-prefix-arg + (prefix-numeric-value current-prefix-arg) + ;; if on subdir start already, don't stay there! + (if (dired-get-subdir) 1 0)))) + (dired-next-subdir (- arg) no-error-if-not-found no-skip)) + +(defun dired-goto-subdir (dir) + "Goto end of header line of DIR in this dired buffer. +Return value of point on success, otherwise return nil. +The next char is either \\n, or \\r if DIR is hidden." + (interactive + (prog1 ; let push-mark display its message + (list + (let* ((table (mapcar + (function + (lambda (x) + (list (dired-abbreviate-file-name + (car x))))) + dired-subdir-alist)) + (stack (reverse (mapcar 'car table))) + (initial (car stack)) + (dired-goto-file-history (cdr stack))) + (expand-file-name + (dired-completing-read "Goto subdirectory " table nil t + initial 'dired-goto-file-history)))) + (push-mark))) + (setq dir (file-name-as-directory dir)) + (let ((elt (assoc dir dired-subdir-alist))) + (and elt + ;; need to make sure that we get where we're going. + ;; beware: narrowing might be in effect + (eq (goto-char (dired-get-subdir-min elt)) (point)) + (progn + ;; dired-subdir-hidden-p and dired-add-entry depend on point being + ;; at either \n or looking-at ...\r after this function succeeds. + (skip-chars-forward "^\r\n") + (if (= (preceding-char) ?.) + (skip-chars-backward "." (- (point) 3))) + (if (interactive-p) (dired-update-mode-line)) + (point))))) + +;;; Internals for motion commands + +(defun dired-update-mode-line (&optional force) + "Updates the mode line in dired according to the position of the point. +Normally this uses a cache of the boundaries of the current subdirectory, +but if the optional argument FORCE is non-nil, then modeline is always +updated and the cache is recomputed." + (if (or force + (>= (point) dired-curr-subdir-max) + (< (point) dired-curr-subdir-min)) + (let ((alist dired-subdir-alist) + min max) + (while (and alist (< (point) + (setq min (dired-get-subdir-min (car alist))))) + (setq alist (cdr alist) + max min)) + (setq dired-curr-subdir-max (or max (point-max-marker)) + dired-curr-subdir-min (or min (point-min-marker)) + dired-subdir-omit (nth 2 (car alist))) + (dired-sort-set-modeline (nth 3 (car alist)))))) + +(defun dired-manual-move-to-filename (&optional raise-error bol eol) + "In dired, move to first char of filename on this line. +Returns position (point) or nil if no filename on this line." + ;; This is the UNIX version. + ;; have to be careful that we don't move to omitted files + (let (case-fold-search) + + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (or bol (setq bol (progn (skip-chars-backward "^\r\n") (point)))) + + (if (or (memq ?l dired-internal-switches) + (memq ?g dired-internal-switches)) + (if (and + (> (- eol bol) 17) ; a valid file line must have at least + ; 17 chars. 2 leading, 10 perms, + ; separator, node #, separator, owner, + ; separator + (goto-char (+ bol 17)) + (re-search-forward dired-re-month-and-time eol t)) + (point) + (goto-char bol) + (if raise-error + (error "No file on this line") + nil)) + ;; else ls switches don't contain -l. + ;; Note that even if we make dired-move-to-filename and + ;; dired-move-to-end-of-filename (and thus dired-get-filename) + ;; work, all commands that gleaned information from the permission + ;; bits (like dired-mark-directories) will cease to work properly. + (if (= bol eol) + (if raise-error + (error "No file on this line") + nil) + ;; skip marker, if any + (goto-char bol) + (forward-char)) + ;; If we not going to use the l switch, and use nstd listings, + ;; then we must bomb on files starting with spaces. + (skip-chars-forward " \t") + (point)))) + +(defun dired-manual-move-to-end-of-filename (&optional no-error bol eol) + ;; Assumes point is at beginning of filename, + ;; thus the rwx bit re-search-backward below will succeed in *this* + ;; line if at all. So, it should be called only after + ;; (dired-move-to-filename t). + ;; On failure, signals an error (with non-nil NO-ERROR just returns nil). + ;; This is the UNIX version. + (let ((bof (point)) + file-type modes-start case-fold-search) + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (or bol (setq bol (save-excursion (skip-chars-backward "^\r\n") (point)))) + (and + (null no-error) + selective-display + (eq (char-after (1- bol)) ?\r) + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit."))))) + (if (or (memq ?l dired-internal-switches) + (memq ?g dired-internal-switches)) + (if (save-excursion + (goto-char bol) + (re-search-forward + "[^ ][-r][-w][^ ][-r][-w][^ ][-r][-w][^ ][-+ 0-9+]" + bof t)) + (progn + (setq modes-start (match-beginning 0) + file-type (char-after modes-start)) + ;; Move point to end of name: + (if (eq file-type ?l) ; symlink + (progn + (if (search-forward " -> " eol t) + (goto-char (match-beginning 0)) + (goto-char eol)) + (and dired-ls-F-marks-symlinks + (eq (preceding-char) ?@) ; link really marked? + (memq ?F dired-internal-switches) + (forward-char -1)) + (point)) + ;; else not a symbolic link + (goto-char eol) + ;; ls -lF marks dirs, sockets and executables with exactly + ;; one trailing character. -F may not actually be honored, + ;; e.g. by an FTP ls in efs + (and + (memq ?F dired-internal-switches) + (let ((char (preceding-char))) + (or (and (eq char ?*) (or + (memq + (char-after (+ modes-start 3)) + '(?x ?s ?t)) + (memq + (char-after (+ modes-start 6)) + '(?x ?s ?t)) + (memq + (char-after (+ modes-start 9)) + '(?x ?s ?t)))) + (and (eq char ?=) (eq file-type ?s)))) + (forward-char -1)) + ;; Skip back over /'s unconditionally. It's not a valid + ;; file name character. + (skip-chars-backward "/") + (point))) + (and (null no-error) + (error "No file on this line"))) + + ;; A brief listing + (if (eq (point) eol) + (and (null no-error) + (error "No file on this line")) + (goto-char eol) + (if (and (memq (preceding-char) '(?@ ?* ?=)) + (memq ?F dired-internal-switches)) + ;; A guess, since without a long listing, we can't be sure. + (forward-char -1)) + (skip-chars-backward "/") + (point))))) + +(defun dired-goto-next-nontrivial-file () + ;; Position point on first nontrivial file after point. + ;; Does not move into the next sudir. + ;; If point is on a file line, moves to that file. + ;; This does not move to omitted files. + (skip-chars-backward "^\n\r") + (if (= (preceding-char) ?\r) + (forward-line 1)) + (let ((max (dired-subdir-max)) + file) + (while (and (or (not (setq file (dired-get-filename 'no-dir t))) + (string-match dired-trivial-filenames file)) + (< (point) max)) + (forward-line 1))) + (dired-move-to-filename)) + +(defun dired-goto-next-file () + ;; Doesn't move out of current subdir. Does go to omitted files. + ;; Returns the starting position of the file, or nil if none found. + (let ((max (dired-subdir-max)) + found) + (while (and (null (setq found (dired-move-to-filename))) (< (point) max)) + (skip-chars-forward "^\n\r") + (forward-char 1)) + found)) + +;; fluid vars used by dired-goto-file-completer +(defvar dired-completer-buffer nil) +(defvar dired-completer-switches nil) +(defvar dired-completer-cache nil) + +(defun dired-goto-file-completer (string pred action) + (save-excursion + (set-buffer dired-completer-buffer) + (let* ((saved-md (match-data)) + (file (file-name-nondirectory string)) + (dir (file-name-directory string)) + (xstring (expand-file-name string)) + (xdir (file-name-directory xstring)) + (exact (dired-goto-file xstring))) + (unwind-protect + (if (dired-goto-subdir xdir) + (let ((table (cdr (assoc xdir dired-completer-cache))) + fn result max) + (or table + (progn + (setq table (make-vector 37 0)) + (mapcar (function + (lambda (ent) + (setq ent (directory-file-name + (car ent))) + (if (string-equal + (file-name-directory ent) xdir) + (intern + (concat + (file-name-nondirectory ent) "/") + table)))) + dired-subdir-alist) + (or (looking-at "\\.\\.\\.\n\r") + (progn + (setq max (dired-subdir-max)) + (while (and + (< (point) max) + (not + (setq fn + (dired-get-filename 'no-dir t)))) + (forward-line 1)) + (if fn + (progn + (or (intern-soft (concat fn "/") table) + (intern fn table)) + (forward-line 1) + (while (setq fn + (dired-get-filename 'no-dir t)) + (or (intern-soft (concat fn "/") table) + (intern fn table)) + (forward-line 1)))))) + (setq dired-completer-cache (cons + (cons xdir table) + dired-completer-cache)))) + (cond + ((null action) + (setq result (try-completion file table)) + (if exact + (if (stringp result) + string + t) + (if (stringp result) + (concat dir result) + result))) + ((eq action t) + (setq result (all-completions file table)) + (if exact (cons "." result) result)) + ((eq 'lambda action) + (and (or exact (intern-soft file table))))))) + (store-match-data saved-md))))) + +(defun dired-really-goto-file (file) + ;; Goes to a file, even if it needs to insert it parent directory. + (or (dired-goto-file file) + (progn ; refresh and try again + (dired-insert-subdir (file-name-directory file)) + (dired-goto-file file)))) + +(defun dired-between-files () + ;; Point must be at beginning of line + (save-excursion (not (dired-move-to-filename nil (point))))) + +(defun dired-repeat-over-lines (arg function) + ;; This version skips non-file lines. + ;; Skips file lines hidden with selective display. + ;; BACKWARDS means move backwards after each action. This is not the same + ;; as a negative arg, as that skips the current line. + (beginning-of-line) + (let* ((advance (cond ((> arg 0) 1) ((< arg 0) -1) (t nil))) + (check-fun (if (eq advance 1) 'eobp 'bobp)) + (n (if (< arg 0) (- arg) arg)) + (wall (funcall check-fun)) + (done wall)) + (while (not done) + (if advance + (progn + (while (not (or (save-excursion (dired-move-to-filename)) + (setq wall (funcall check-fun)))) + (forward-line advance)) + (or wall + (progn + (save-excursion (funcall function)) + (forward-line advance) + (while (not (or (save-excursion (dired-move-to-filename)) + (setq wall (funcall check-fun)))) + (forward-line advance)) + (setq done (or (zerop (setq n (1- n))) wall))))) + (if (save-excursion (dired-move-to-filename)) + (save-excursion (funcall function))) + (setq done t)))) + (dired-move-to-filename) + ;; Note that if possible the point has now been moved to the beginning of + ;; the file name. + (dired-update-mode-line)) + + +;;;; ---------------------------------------------------------------- +;;;; Miscellaneous dired commands +;;;; ---------------------------------------------------------------- + +(defun dired-quit () + "Bury the current dired buffer." + (interactive) + (bury-buffer)) + +(defun dired-undo () + "Undo in a dired buffer. +This doesn't recover lost files, it is just normal undo with temporarily +writeable buffer. You can use it to recover marks, killed lines or subdirs." + (interactive) + (let ((lines (count-lines (point-min) (point-max))) + buffer-read-only) + (undo) + ;; reset dired-subdir-alist, if a dir may have been affected + ;; Is there a better way to guess this? + (setq lines (- (count-lines (point-min) (point-max)) lines)) + (if (or (>= lines 2) (<= lines -2)) + (dired-build-subdir-alist))) + (dired-update-mode-line-modified t) + (dired-update-mode-line t)) + + +;;;; -------------------------------------------------------- +;;;; Immediate actions on files: visiting, viewing, etc. +;;;; -------------------------------------------------------- + +(defun dired-find-file () + "In dired, visit the file or directory named on this line." + (interactive) + (find-file (dired-get-filename))) + +(defun dired-view-file () + "In dired, examine a file in view mode, returning to dired when done. +When file is a directory, show it in this buffer if it is inserted; +otherwise, display it in another buffer." + (interactive) + (let ((file (dired-get-filename))) + (if (file-directory-p file) + (or (dired-goto-subdir file) + (dired file)) + (view-file file)))) + +(defun dired-find-file-other-window (&optional display) + "In dired, visit this file or directory in another window. +With a prefix, the file is displayed, but the window is not selected." + (interactive "P") + (if display + (dired-display-file) + (find-file-other-window (dired-get-filename)))) + +;; Only for Emacs 19 +(defun dired-find-file-other-frame () + "In dired, visit this file or directory in another frame." + (interactive) + (find-file-other-frame (dired-get-filename))) + +(defun dired-display-file () + "In dired, displays this file or directory in the other window." + (interactive) + (display-buffer (find-file-noselect (dired-get-filename)))) + +;; After an idea by wurgler@zippysun.math.uakron.edu (Tom Wurgler). +(defun dired-do-find-file (&optional arg) + "Visit all marked files at once, and display them simultaneously. +See also function `simultaneous-find-file'. +If you want to keep the dired buffer displayed, type \\[split-window-vertically] first. +If you want just the marked files displayed and nothing else, type \\[delete-other-windows] first." + (interactive "P") + (dired-simultaneous-find-file (dired-get-marked-files nil arg))) + +(defun dired-simultaneous-find-file (file-list) + "Visit all files in FILE-LIST and display them simultaneously. + +The current window is split across all files in FILE-LIST, as evenly +as possible. Remaining lines go to the bottommost window. + +The number of files that can be displayed this way is restricted by +the height of the current window and the variable `window-min-height'." + ;; It is usually too clumsy to specify FILE-LIST interactively + ;; unless via dired (dired-do-find-file). + (let ((size (/ (window-height) (length file-list)))) + (or (<= window-min-height size) + (error "Too many files to visit simultaneously")) + (find-file (car file-list)) + (setq file-list (cdr file-list)) + (while file-list + ;; Split off vertically a window of the desired size + ;; The upper window will have SIZE lines. We select the lower + ;; (larger) window because we want to split that again. + (select-window (split-window nil size)) + (find-file (car file-list)) + (setq file-list (cdr file-list))))) + +(defun dired-create-directory (directory) + "Create a directory called DIRECTORY." + (interactive + (list (read-file-name "Create directory: " + (dired-abbreviate-file-name + (dired-current-directory))))) + (let ((expanded (expand-file-name directory))) + (make-directory expanded) + ;; Because this function is meant to be called interactively, it moves + ;; the point. + (dired-goto-file expanded))) + +(defun dired-recover-file () + "Recovers file from its autosave file. +If the file is an autosave file, then recovers its associated file instead." + (interactive) + (let* ((file (dired-get-filename)) + (name (file-name-nondirectory file)) + (asp (auto-save-file-name-p name)) + (orig (and + asp + (if (fboundp 'auto-save-original-name) + (auto-save-original-name file) + (error + "Need auto-save package to compute original file name.")))) + (buff (if asp + (and orig (get-file-buffer orig)) + (get-file-buffer file)))) + (and + buff + (buffer-modified-p buff) + (or + (yes-or-no-p + (format + "Recover file will erase the modified buffer %s. Do it? " + (buffer-name buff))) + (error "Recover file aborted."))) + (if asp + (if orig + (recover-file orig) + (find-file file)) + (recover-file file)))) + + +;;;; -------------------------------------------------------------------- +;;;; Functions for extracting and manipulating file names +;;;; -------------------------------------------------------------------- + +(defun dired-make-filename-string (filename &optional reverse) + ;; Translates the way that a file name appears in a buffer, to + ;; how it is used in a path name. This is useful for non-unix + ;; support in efs. + filename) + +(defun dired-get-filename (&optional localp no-error-if-not-filep) + "In dired, return name of file mentioned on this line. +Value returned normally includes the directory name. +Optional arg LOCALP with value `no-dir' means don't include directory + name in result. A value of t means use path name relative to + `default-directory', which still may contain slashes if in a subdirectory. +Optional arg NO-ERROR-IF-NOT-FILEP means return nil if no filename on + this line, otherwise an error occurs." + + ;; Compute bol & eol once, rather than twice inside move-to-filename + ;; and move-to-end-of-filename + (let ((eol (save-excursion (skip-chars-forward "^\n\r") (point))) + (bol (save-excursion (skip-chars-backward "^\r\n") (point))) + case-fold-search file p1 p2) + (save-excursion + (and + (setq p1 (dired-move-to-filename (not no-error-if-not-filep) bol eol)) + (setq p2 (dired-move-to-end-of-filename no-error-if-not-filep bol eol)) + (setq file (buffer-substring p1 p2)) + ;; Check if ls quoted the names, and unquote them. + ;; Using read to unquote is much faster than substituting + ;; \007 (4 chars) -> ^G (1 char) etc. in a lisp loop. + (cond ((memq ?b dired-internal-switches) ; System V ls + ;; This case is about 20% slower than without -b. + (setq file + (read + (concat "\"" + ;; some ls -b don't escape quotes, argh! + ;; This is not needed for GNU ls, though. + (or (dired-string-replace-match + "\\([^\\]\\)\"" file "\\1\\\\\"") + file) + "\"")))) + ;; If you do this, update dired-compatible-switches-p + ;; ((memq ?Q dired-internal-switches) ; GNU ls + ;; (setq file (read file))) + ))) + (and file + (if (eq localp 'no-dir) + (dired-make-filename-string file) + (concat (dired-current-directory localp) + (dired-make-filename-string file)))))) + +(defun dired-make-relative (file &optional dir no-error) + ;; Convert FILE (an *absolute* pathname) to a pathname relative to DIR. + ;; FILE must be absolute, or this function will return nonsense. + ;; If FILE is not in a subdir of DIR, an error is signalled, + ;; unless NO-ERROR is t. Then, ".."'s are inserted to give + ;; a relative representation of FILE wrto DIR + ;; eg. FILE = /vol/tex/bin/foo DIR = /vol/local/bin/ + ;; results in ../../tex/bin/foo + ;; DIR must be expanded. + ;; DIR defaults to default-directory. + ;; DIR must be file-name-as-directory, as with all directory args in + ;; elisp code. + (or dir (setq dir (expand-file-name default-directory))) + (let ((flen (length file)) + (dlen (length dir))) + (if (and (> flen dlen) + (string-equal (substring file 0 dlen) dir)) + (substring file dlen) + ;; Need to insert ..'s + (or no-error (error "%s: not in directory tree growing at %s" file dir)) + (if (string-equal file dir) + "./" + (let ((index 1) + (count 0)) + (while (and (string-match "/" dir index) + (<= (match-end 0) flen) + (string-equal (substring file index (match-end 0)) + (substring dir index (match-end 0)))) + (setq index (match-end 0))) + (setq file (substring file index)) + (if (and (/= flen index) + (not (string-match "/" file)) + (< flen dlen) + (string-equal file (substring dir index flen)) + (= (aref dir flen) ?/)) + (setq file "." + count -1)) + ;; count how many slashes remain in dir. + (while (string-match "/" dir index) + (setq index (match-end 0) + count (1+ count))) + (apply 'concat (nconc (make-list count "../") (list file)))))))) + +;;; Functions for manipulating file names. +;; +;; Used by file tranformers. +;; Define here rather than in dired-shell.el, as it wouldn't be +;; unreasonable to use these elsewhere. + +(defun dired-file-name-base (fn) + "Returns the base name of FN. +This is the file without directory part, and extension. See the variable +`dired-filename-re-ext'." + (setq fn (file-name-nondirectory fn)) + (if (string-match dired-filename-re-ext fn 1) + (substring fn 0 (match-beginning 0)) + fn)) + +(defun dired-file-name-extension (fn) + "Returns the extension for file name FN. +See the variable dired-filename-re-ext'." + (setq fn (file-name-nondirectory fn)) + (if (string-match dired-filename-re-ext fn 1) + (substring fn (match-beginning 0)) + "")) + +(defun dired-file-name-sans-rcs-extension (fn) + "Returns the file name FN without its RCS extension \",v\"." + (setq fn (file-name-nondirectory fn)) + (if (string-match ",v$" fn 1) + (substring fn 0 (match-beginning 0)) + fn)) + +(defun dired-file-name-sans-compress-extension (fn) + "Returns the file name FN without the extension from compress or gzip." + (setq fn (file-name-nondirectory fn)) + (if (string-match "\\.\\([zZ]\\|gz\\)$" fn 1) + (substring fn (match-beginning 0)) + fn)) + + +;;;; --------------------------------------------------------------------- +;;;; Working with directory trees. +;;;; --------------------------------------------------------------------- +;;; +;;; This where code for the dired-subdir-alist is. + +;;; Utility functions for dired-subdir-alist + +(defun dired-normalize-subdir (dir) + ;; Prepend default-directory to DIR if relative path name. + ;; dired-get-filename must be able to make a valid filename from a + ;; file and its directory DIR. + ;; Fully expand everything. + (file-name-as-directory + (if (file-name-absolute-p dir) + (expand-file-name dir) + (expand-file-name dir (expand-file-name default-directory))))) + +(defun dired-get-subdir () + ;;"Return the subdir name on this line, or nil if not on a headerline." + ;; Look up in the alist whether this is a headerline. + (save-excursion + (let ((cur-dir (dired-current-directory))) + (beginning-of-line) ; alist stores b-o-l positions + (and (zerop (- (point) + (dired-get-subdir-min (assoc cur-dir + dired-subdir-alist)))) + cur-dir)))) + +(defun dired-get-subdir-max (elt) + ;; returns subdir max. + (let ((pos (- (length dired-subdir-alist) + (length (member elt dired-subdir-alist))))) + (if (zerop pos) + (point-max) + (1- (dired-get-subdir-min (nth (1- pos) dired-subdir-alist)))))) + +(defun dired-clear-alist () + ;; Set all markers in dired-subdir-alist to nil. Set the alist to nil too. + (while dired-subdir-alist + (set-marker (dired-get-subdir-min (car dired-subdir-alist)) nil) + (setq dired-subdir-alist (cdr dired-subdir-alist)))) + +(defun dired-unsubdir (dir) + ;; Remove DIR from the alist + (setq dired-subdir-alist + (delq (assoc dir dired-subdir-alist) dired-subdir-alist))) + +(defun dired-simple-subdir-alist () + ;; Build and return `dired-subdir-alist' assuming just the top level + ;; directory to be inserted. Don't parse the buffer. + (setq dired-subdir-alist + (list (list (expand-file-name default-directory) + (point-min-marker) dired-omit-files + dired-internal-switches nil))) + (if dired-verify-modtimes + (dired-set-file-modtime (expand-file-name default-directory) + dired-subdir-alist))) + +(defun dired-build-subdir-alist () + "Build `dired-subdir-alist' by parsing the buffer and return its new value." + (interactive) + (let ((o-alist dired-subdir-alist) + (count 0) + subdir) + (dired-clear-alist) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward dired-subdir-regexp nil t) + (setq count (1+ count)) + (apply 'dired-alist-add-1 + (setq subdir (buffer-substring (match-beginning 2) + (match-end 2))) + ;; Put subdir boundary between lines. + (set-marker (make-marker) (match-end 1)) + (let ((elt (assoc subdir o-alist))) + (if elt + (list (nth 2 elt) (nth 3 elt)) + (list dired-omit-files dired-internal-switches))))) + (if (interactive-p) + (message "%d director%s." count (if (= 1 count) "y" "ies"))) + ;; We don't need to sort it because it is in buffer order per + ;; constructionem. Return new alist: + ;; pointers for current-subdir may be stale + dired-subdir-alist))) + +(defun dired-alist-add (dir new-marker &optional omit switches) + ;; Add new DIR at NEW-MARKER. Sort alist. + (dired-alist-add-1 dir new-marker omit switches) + (dired-alist-sort)) + +(defun dired-alist-add-1 (dir new-marker &optional omit switches) + ;; Add new DIR at NEW-MARKER. Don't sort. + (let ((dir (dired-normalize-subdir dir))) + (setq dired-subdir-alist + (cons (list dir new-marker omit switches nil) dired-subdir-alist)) + (if dired-verify-modtimes + (dired-set-file-modtime dir dired-subdir-alist)))) + +(defun dired-alist-sort () + ;; Keep the alist sorted on buffer position. + (setq dired-subdir-alist + (sort dired-subdir-alist + (function (lambda (elt1 elt2) + (> (dired-get-subdir-min elt1) + (dired-get-subdir-min elt2))))))) + +;;; Utilities for working with subdirs in the dired buffer + +;; This function is the heart of tree dired. +;; It is called for each retrieved filename. +;; It could stand to be faster, though it's mostly function call +;; overhead. Avoiding to funcall seems to save about 10% in +;; dired-get-filename. Make it a defsubst? +(defun dired-current-directory (&optional localp) + "Return the name of the subdirectory to which this line belongs. +This returns a string with trailing slash, like `default-directory'. +Optional argument means return a file name relative to `default-directory'. +In this it returns \"\" for the top directory." + (let* ((here (point)) + (dir (catch 'done + (mapcar (function + (lambda (x) + (if (<= (dired-get-subdir-min x) here) + (throw 'done (car x))))) + dired-subdir-alist)))) + (if (listp dir) (error "dired-subdir-alist seems to be mangled")) + (if localp + (let ((def-dir (expand-file-name default-directory))) + (if (string-equal dir def-dir) + "" + (dired-make-relative dir def-dir))) + dir))) + +;; Subdirs start at the beginning of their header lines and end just +;; before the beginning of the next header line (or end of buffer). + +(defun dired-subdir-min () + ;; Returns the minimum position of the current subdir + (save-excursion + (if (not (dired-prev-subdir 0 t t)) + (error "Not in a subdir!") + (point)))) + +(defun dired-subdir-max () + ;; Returns the maximum position of the current subdir + (save-excursion + (if (dired-next-subdir 1 t t) + (1- (point)) ; Do not include separating empty line. + (point-max)))) + + +;;;; -------------------------------------------------------- +;;;; Deleting files +;;;; -------------------------------------------------------- + +(defun dired-flag-file-deletion (arg) + "In dired, flag the current line's file for deletion. +With prefix arg, repeat over several lines. + +If on a subdir headerline, mark all its files except `.' and `..'." + (interactive "p") + (dired-mark arg dired-del-marker)) + +(defun dired-flag-file-deletion-backup (arg) + "Flag current file for deletion, and move to previous line. +With a prefix ARG, repeats this ARG times." + (interactive "p") + ;; Use dired-mark-file and not dired-mark, as this function + ;; should do nothing special on subdir headers. + (dired-mark-file (- arg) dired-del-marker)) + +(defun dired-flag-subdir-files () + "Flag all the files in the current subdirectory for deletion." + (interactive) + (dired-mark-subdir-files dired-del-marker)) + +(defun dired-unflag (arg) + "In dired, remove a deletion flag from the current line's file. +Optional prefix ARG says how many lines to unflag." + (interactive "p") + (let (buffer-read-only) + (dired-repeat-over-lines + arg + (function + (lambda () + (if (char-equal (following-char) dired-del-marker) + (progn + (setq dired-del-flags-number (max (1- dired-del-flags-number) 0)) + (dired-substitute-marker (point) dired-del-marker ?\ ))))))) + (dired-update-mode-line-modified)) + +(defun dired-backup-unflag (arg) + "In dired, move up lines and remove deletion flag there. +Optional prefix ARG says how many lines to unflag; default is one line." + (interactive "p") + (dired-unflag (- arg))) + +(defun dired-update-marker-counters (char &optional remove) + (or (memq char '(?\ ?\n ?\r)) + (let ((counter (cond + ((char-equal char dired-del-marker) + 'dired-del-flags-number) + ((char-equal char dired-marker-char) + 'dired-marks-number) + ('dired-other-marks-number)))) + (if remove + (set counter (max (1- (symbol-value counter)) 0)) + (set counter (1+ (symbol-value counter))))))) + +(defun dired-update-mode-line-modified (&optional check) + ;; Updates the value of mode-line-modified in dired. + ;; Currently assumes that it's of the form "-%%-", where % sometimes + ;; gets replaced by %. Should allow some sort of config flag. + ;; SET is t to set to -DD-, nil to set to -%%-, and 'check means + ;; examine the buffer to find out. + (if check + (save-excursion + (let (char) + (goto-char (point-min)) + (setq dired-del-flags-number 0 + dired-marks-number 0 + dired-other-marks-number 0) + (while (not (eobp)) + (setq char (following-char)) + (cond + ((char-equal char dired-del-marker) + (setq dired-del-flags-number (1+ dired-del-flags-number))) + ((char-equal char dired-marker-char) + (setq dired-marks-number (1+ dired-marks-number))) + ((memq char '(?\ ?\n ?\r)) + nil) + ((setq dired-other-marks-number (1+ dired-other-marks-number)))) + (forward-line 1))))) + (setq mode-line-modified + (format dired-mode-line-modified + (if (zerop dired-del-flags-number) + "--" + (format "%d%c" dired-del-flags-number dired-del-marker)) + (if (zerop dired-marks-number) + "--" + (format "%d%c" dired-marks-number dired-marker-char)) + (if (zerop dired-other-marks-number) + "-" + (int-to-string dired-other-marks-number)))) + (set-buffer-modified-p (buffer-modified-p))) + +(defun dired-do-deletions (&optional nomessage) + (dired-expunge-deletions)) + +(defun dired-expunge-deletions () + "In dired, delete the files flagged for deletion." + (interactive) + (let ((files (let ((dired-marker-char dired-del-marker)) + (dired-map-over-marks (cons (dired-get-filename) (point)) + t)))) + (if files + (progn + (dired-internal-do-deletions files nil dired-del-marker) + ;; In case the point gets left somewhere strange -- hope that + ;; this doesn't cause asynch troubles later. + (beginning-of-line) + (dired-goto-next-nontrivial-file) + (dired-update-mode-line-modified t)) ; play safe, it's cheap + (message "(No deletions requested)")))) + +(defun dired-do-delete (&optional arg) + "Delete all marked (or next ARG) files." + ;; This is more consistent with the file marking feature than + ;; dired-expunge-deletions. + (interactive "P") + (dired-internal-do-deletions + ;; this may move point if ARG is an integer + (dired-map-over-marks (cons (dired-get-filename) (point)) + arg) + arg) + (beginning-of-line) + (dired-goto-next-nontrivial-file)) + +(defun dired-internal-do-deletions (l arg &optional marker-char) + ;; L is an alist of files to delete, with their buffer positions. + ;; ARG is the prefix arg. + ;; Filenames are absolute (VMS needs this for logical search paths). + ;; (car L) *must* be the *last* (bottommost) file in the dired buffer. + ;; That way as changes are made in the buffer they do not shift the + ;; lines still to be changed, so the (point) values in L stay valid. + ;; Also, for subdirs in natural order, a subdir's files are deleted + ;; before the subdir itself - the other way around would not work. + (save-excursion + (let ((files (mapcar (function car) l)) + (count (length l)) + (succ 0) + (cdir (dired-current-directory)) + failures) + ;; canonicalize file list for pop up + (setq files (nreverse (mapcar (function + (lambda (fn) + (dired-make-relative fn cdir t))) + files))) + (if (or (memq 'delete dired-no-confirm) + (dired-mark-pop-up + " *Files Flagged for Deletion*" 'delete files + dired-deletion-confirmer + (format "Delete %s " + (dired-mark-prompt arg files marker-char)))) + (save-excursion + ;; files better be in reverse order for this loop! + (while l + (goto-char (cdr (car l))) + (condition-case err + (let ((fn (car (car l)))) + ;; This test is equivalent to + ;; (and (file-directory-p fn) + ;; (not (file-symlink-p fn))) + ;; but more efficient + (if (if (eq t (car (file-attributes fn))) + (if (<= (length (directory-files fn)) 2) + (progn (delete-directory fn) t) + (and (or + (memq 'recursive-delete dired-no-confirm) + (funcall + dired-deletion-confirmer + (format "\ +Recursively delete directory and files within %s? " + (dired-make-relative fn)))) + (progn + (dired-recursive-delete-directory fn) + t))) + (progn (delete-file fn) t)) + (progn + (setq succ (1+ succ)) + (message "%s of %s deletions" succ count) + (dired-clean-up-after-deletion fn)))) + (error;; catch errors from failed deletions + (dired-log (buffer-name (current-buffer)) "%s\n" err) + (setq failures (cons (car (car l)) failures)))) + (setq l (cdr l))))) + (if failures + (dired-log-summary + (buffer-name (current-buffer)) + (format "%d of %d deletion%s failed:" (length failures) count + (dired-plural-s count)) + failures) + (if (zerop succ) + (message "(No deletions performed)") + (message "%d deletion%s done" succ (dired-plural-s succ))))))) + +(defun dired-recursive-delete-directory (fn) + ;; Recursively deletes directory FN, and all of its contents. + (let* ((fn (expand-file-name fn)) + (handler (find-file-name-handler + fn 'dired-recursive-delete-directory))) + (if handler + (funcall handler 'dired-recursive-delete-directory fn) + (progn + (or (file-exists-p fn) + (signal + 'file-error + (list "Removing old file name" "no such directory" fn))) + ;; Which is better, -r or -R? + (call-process "rm" nil nil nil "-r" (directory-file-name fn)) + (and (file-exists-p fn) + (error "Failed to recusively delete %s" fn)))))) + +(defun dired-clean-up-after-deletion (fn) + ;; Offer to kill buffer of deleted file FN. + (let ((buf (get-file-buffer fn))) + (and buf + (or (memq 'kill-file-buffer dired-no-confirm) + (funcall (function yes-or-no-p) + (format "Kill buffer of %s, too? " + (file-name-nondirectory fn)))) + (save-excursion ; you never know where kill-buffer leaves you + (kill-buffer buf))))) + +;;; Cleaning a directory -- flagging backups for deletion + +(defun dired-clean-directory (keep &optional marker msg) + "Flag numerical backups for deletion. +Spares `dired-kept-versions' latest versions, and `kept-old-versions' oldest. +Positive prefix arg KEEP overrides `dired-kept-versions'; +Negative prefix arg KEEP overrides `kept-old-versions' with KEEP made positive. + +To clear the flags on these files, you can use \\[dired-flag-backup-files] +with a prefix argument." + (interactive "P") + (setq keep (if keep (prefix-numeric-value keep) dired-kept-versions)) + (let* ((early-retention (if (< keep 0) (- keep) kept-old-versions)) + (late-retention (if (<= keep 0) dired-kept-versions keep)) + (msg (or msg + (format + "Cleaning numerical backups (keeping %d late, %d old)" + late-retention early-retention))) + (trample-marker (or marker dired-del-marker)) + (file-version-assoc-list)) + (message "%s..." msg) + ;; Do this after messaging, as it may take a while. + (setq file-version-assoc-list (dired-collect-file-versions)) + ;; Sort each VERSION-NUMBER-LIST, + ;; and remove the versions to be deleted. + (let ((fval file-version-assoc-list)) + (while fval + (let* ((sorted-v-list (cons 'q (sort (cdr (car fval)) '<))) + (v-count (length sorted-v-list))) + (if (> v-count (+ early-retention late-retention)) + (rplacd (nthcdr early-retention sorted-v-list) + (nthcdr (- v-count late-retention) + sorted-v-list))) + (rplacd (car fval) + (cdr sorted-v-list))) + (setq fval (cdr fval)))) + ;; Look at each file. If it is a numeric backup file, + ;; find it in a VERSION-NUMBER-LIST and maybe flag it for deletion. + (dired-map-dired-file-lines (function + (lambda (fn) + (dired-trample-file-versions + fn file-version-assoc-list + trample-marker)))) + (message "%s...done" msg))) + +(defun dired-collect-file-versions () + ;; If it looks like a file has versions, return a list of the versions. + ;; The return value is ((FILENAME . (VERSION1 VERSION2 ...)) ...) + (let (result) + (dired-map-dired-file-lines + (function + (lambda (fn) + (let* ((base-versions + (concat (file-name-nondirectory fn) ".~")) + (bv-length (length base-versions)) + (possibilities (file-name-all-completions + base-versions + (file-name-directory fn)))) + (if possibilities + (setq result (cons (cons fn + (mapcar 'backup-extract-version + possibilities)) result))))))) + result)) + +(defun dired-trample-file-versions (fn alist marker) + ;; ALIST is an alist of filenames and versions used to determine + ;; if each file should be flagged for deletion. + ;; This version using file-name-sans-versions is probably a lot slower + ;; than Sebastian's original, but it is more easily adaptable to non-unix. + (let ((base (file-name-sans-versions fn)) + base-version-list bv-length) + (and (not (string-equal base fn)) + (setq base-version-list (assoc base alist)) + (setq bv-length (string-match "[0-9]" fn (length base))) + (not (memq (backup-extract-version fn) base-version-list)) + (progn (skip-chars-backward "^\n\r") + (bolp)) ; make sure the preceding char isn't \r. + (dired-substitute-marker (point) (following-char) marker)))) + +(defun dired-map-dired-file-lines (fun) + ;; Perform FUN with point at the end of each non-directory line. + ;; FUN takes one argument, the filename (complete pathname). + (dired-check-ls-l) + (save-excursion + (let (file buffer-read-only) + (goto-char (point-min)) + (while (not (eobp)) + (save-excursion + (and (not (and dired-re-dir (looking-at dired-re-dir))) + (not (memq (following-char) '(?\n ?\n))) + (setq file (dired-get-filename nil t)) ; nil on non-file + (progn (skip-chars-forward "^\n\r") + (funcall fun file)))) + (forward-line 1))))) ; this guarantees that we don't + ; operate on omitted files. + + +;;;; ----------------------------------------------------------- +;;;; Confirmations and prompting the user. +;;;; ----------------------------------------------------------- + +(defun dired-plural-s (count) + (if (= 1 count) "" "s")) + +(defun dired-mark-prompt (arg files &optional marker-char) + ;; Return a string for use in a prompt, either the current file + ;; name, or the marker and a count of marked files. + (let ((count (length files))) + (if (= count 1) + (car files) + ;; more than 1 file: + (if (integerp arg) + (cond ((zerop arg) "[no files]") + ((> arg 0) "[following]") + ((< arg 0) "[preceding]")) + (char-to-string (or marker-char dired-marker-char)))))) + +(defun dired-pop-to-buffer (buf) + ;; Pop up buffer BUF. + ;; Make its window fit its contents. + (let ((window (selected-window)) + target-lines w2) + (cond ;; if split-window-threshold is enabled, use the largest window + ((and (> (window-height (setq w2 (get-largest-window))) + split-height-threshold) + (= (frame-width) (window-width w2))) + (setq window w2)) + ;; if the least-recently-used window is big enough, use it + ((and (> (window-height (setq w2 (get-lru-window))) + (* 2 window-min-height)) + (= (frame-width) (window-width w2))) + (setq window w2))) + (save-excursion + (set-buffer buf) + (goto-char (point-max)) + (skip-chars-backward "\n\r\t ") + (setq target-lines (count-lines (point-min) (point))) + ;; Don't forget to count the last line. + (if (not (bolp)) + (setq target-lines (1+ target-lines)))) + (if (<= (window-height window) (* 2 window-min-height)) + ;; At this point, every window on the frame is too small to split. + (setq w2 (display-buffer buf)) + (setq w2 (split-window + window + (max window-min-height + (- (window-height window) + (1+ (max window-min-height target-lines))))))) + (set-window-buffer w2 buf) + (if (< (1- (window-height w2)) target-lines) + (progn + (select-window w2) + (enlarge-window (- target-lines (1- (window-height w2)))))) + (set-window-start w2 1))) + +(defun dired-mark-pop-up (bufname op-symbol files function &rest args) + ;; Args BUFNAME OP-SYMBOL FILES FUNCTION &rest ARGS. + ;; Return FUNCTION's result on ARGS after popping up a window (in a buffer + ;; named BUFNAME, nil gives \" *Marked Files*\") showing the marked + ;; files. Uses function `dired-pop-to-buffer' to do that. + ;; FUNCTION should not manipulate files. + ;; It should only read input (an argument or confirmation). + ;; The window is not shown if there is just one file or + ;; OP-SYMBOL is a member of the list in `dired-no-confirm'. + ;; FILES is the list of marked files. + (if (memq op-symbol dired-no-confirm) + (apply function args) + (or bufname (setq bufname " *Marked Files*")) + (if (<= (length files) 1) + (apply function args) + (save-excursion + (let ((standard-output (set-buffer (get-buffer-create bufname)))) + (erase-buffer) + (dired-format-columns-of-files files) + (dired-remove-text-properties (point-min) (point-max)) + (setq mode-line-format (format " %s [%d files]" + bufname (length files))))) + (save-window-excursion + (dired-pop-to-buffer bufname) + (apply function args))))) + +(defun dired-column-widths (columns list &optional across) + ;; Returns the column widths for breaking LIST into + ;; COLUMNS number of columns. + (cond + ((null list) + nil) + ((= columns 1) + (list (apply 'max (mapcar 'length list)))) + ((let* ((len (length list)) + (col-length (/ len columns)) + (remainder (% len columns)) + (i 0) + (j 0) + (max-width 0) + widths padding) + (if (zerop remainder) + (setq padding 0) + (setq col-length (1+ col-length) + padding (- columns remainder))) + (setq list (nconc (copy-sequence list) (make-list padding nil))) + (setcdr (nthcdr (1- (+ len padding)) list) list) + (while (< i columns) + (while (< j col-length) + (setq max-width (max max-width (length (car list))) + list (if across (nthcdr columns list) (cdr list)) + j (1+ j))) + (setq widths (cons (+ max-width 2) widths) + max-width 0 + j 0 + i (1+ i)) + (if across (setq list (cdr list)))) + (setcar widths (- (car widths) 2)) + (nreverse widths))))) + +(defun dired-calculate-columns (list &optional across) + ;; Returns a list of integers which are the column widths that best pack + ;; LIST, a list of strings, onto the screen. + (and list + (let* ((width (1- (window-width))) + (columns (max 1 (/ width + (+ 2 (apply 'max (mapcar 'length list)))))) + col-list last-col-list) + (while (<= (apply '+ (setq col-list + (dired-column-widths columns list across))) + width) + (setq columns (1+ columns) + last-col-list col-list)) + (or last-col-list col-list)))) + +(defun dired-format-columns-of-files (files &optional across) + ;; Returns the number of lines used. + ;; If ACROSS is non-nil, sorts across rather than down the buffer, like + ;; ls -x + (and files + (let* ((columns (dired-calculate-columns files across)) + (ncols (length columns)) + (ncols1 (1- ncols)) + (nfiles (length files)) + (nrows (+ (/ nfiles ncols) + (if (zerop (% nfiles ncols)) 0 1))) + (space-left (- (window-width) (apply '+ columns) 1)) + (i 0) + (j 0) + file padding stretch float-stretch) + (if (zerop ncols1) + (setq stretch 0 + float-stretch 0) + (setq stretch (/ space-left ncols1) + float-stretch (% space-left ncols1))) + (setq files (nconc (copy-sequence files) ; fill up with empty fns + (make-list (- (* ncols nrows) nfiles) ""))) + (setcdr (nthcdr (1- (length files)) files) files) ; make circular + (while (< j nrows) + (while (< i ncols) + (princ (setq file (car files))) + (setq padding (- (nth i columns) (length file))) + (or (= i ncols1) + (progn + (setq padding (+ padding stretch)) + (if (< i float-stretch) (setq padding (1+ padding))))) + (princ (make-string padding ?\ )) + (setq files (if across (cdr files) (nthcdr nrows files)) + i (1+ i))) + (princ "\n") + (setq i 0 + j (1+ j)) + (or across (setq files (cdr files)))) + nrows))) + +(defun dired-query (qs-var qs-prompt &rest qs-args) + ;; Query user and return nil or t. + ;; Store answer in symbol VAR (which must initially be bound to nil). + ;; Format PROMPT with ARGS. + ;; Binding variable help-form will help the user who types C-h. + (let* ((char (symbol-value qs-var)) + (action (cdr (assoc char dired-query-alist)))) + (cond ((eq 'yes action) + t) ; accept, and don't ask again + ((eq 'no action) + nil) ; skip, and don't ask again + (t;; no lasting effects from last time we asked - ask now + (let ((qprompt (concat qs-prompt + (if help-form + (format " [yn!q or %s] " + (key-description + (char-to-string help-char))) + " [ynq or !] "))) + (dired-in-query t) + elt) + ;; Actually it looks nicer without cursor-in-echo-area - you can + ;; look at the dired buffer instead of at the prompt to decide. + (apply 'message qprompt qs-args) + (setq char (set qs-var (read-char))) + (while (not (setq elt (assoc char dired-query-alist))) + (message "Invalid char - type %c for help." help-char) + (ding) + (sit-for 1) + (apply 'message qprompt qs-args) + (setq char (set qs-var (read-char)))) + (memq (cdr elt) '(t y yes))))))) + +(defun dired-mark-confirm (op-symbol operation arg) + ;; Request confirmation from the user that the operation described + ;; by OP-SYMBOL is to be performed on the marked files. + ;; Confirmation consists in a y-or-n question with a file list + ;; pop-up unless OP-SYMBOL is a member of `dired-no-confirm'. + ;; OPERATION is a string describing the operation. Used for prompting + ;; the user. + ;; The files used are determined by ARG (like in dired-get-marked-files). + (or (memq op-symbol dired-no-confirm) + (let ((files (dired-get-marked-files t arg))) + (dired-mark-pop-up nil op-symbol files (function y-or-n-p) + (concat operation " " + (dired-mark-prompt arg files) "? "))))) + +(defun dired-mark-read-file-name (prompt dir op-symbol arg files) + (dired-mark-pop-up + nil op-symbol files + (function read-file-name) + (format prompt (dired-mark-prompt arg files)) dir)) + +(defun dired-mark-read-string (prompt initial op-symbol arg files + &optional history-sym) + ;; Reading arguments with history. + ;; Read arguments for a mark command of type OP-SYMBOL, + ;; perhaps popping up the list of marked files. + ;; ARG is the prefix arg and indicates whether the files came from + ;; marks (ARG=nil) or a repeat factor (integerp ARG). + ;; If the current file was used, the list has but one element and ARG + ;; does not matter. (It is non-nil, non-integer in that case, namely '(4)). + ;; PROMPT for a string, with INITIAL input. + (dired-mark-pop-up + nil op-symbol files + (function + (lambda (prompt initial) + (let ((hist (or history-sym + (cdr (assq op-symbol dired-op-history-alist)) + 'dired-history))) + (dired-read-with-history prompt initial hist)))) + (format prompt (dired-mark-prompt arg files)) initial)) + + +;;;; ---------------------------------------------------------- +;;;; Marking files. +;;;; ---------------------------------------------------------- + +(defun dired-mark (arg &optional char) + "Mark the current (or next ARG) files. +If on a subdir headerline, mark all its files except `.' and `..'. + +Use \\[dired-unmark-all-files] to remove all marks, +and \\[dired-unmark] to remove the mark of the current file." + (interactive "p") + (if (dired-get-subdir) + (dired-mark-subdir-files char) + (dired-mark-file arg char))) + +(defun dired-mark-file (arg &optional char) + "Mark ARG files starting from the current file line. +Optional CHAR indicates a marker character to use." + (let (buffer-read-only) + (if (memq (or char dired-marker-char) '(?\ ?\n ?\r)) + (error "Invalid marker charcter %c" dired-marker-char)) + (or char (setq char dired-marker-char)) + (dired-repeat-over-lines + arg + (function + (lambda () + (dired-update-marker-counters (following-char) t) + (dired-substitute-marker (point) (following-char) char) + (dired-update-marker-counters char)))) + (dired-update-mode-line-modified))) + +(defun dired-mark-subdir-files (&optional char) + "Mark all files except `.' and `..'." + (interactive) + (save-excursion + (dired-mark-files-in-region (dired-subdir-min) (dired-subdir-max) char))) + +(defun dired-unmark (arg) + "Unmark the current (or next ARG) files. +If looking at a subdir, unmark all its files except `.' and `..'." + (interactive "p") + (let (buffer-read-only) + (dired-repeat-over-lines + arg + (function + (lambda () + (let ((char (following-char))) + (or (memq char '(?\ ?\n ?\r)) + (progn + (cond + ((char-equal char dired-marker-char) + (setq dired-marks-number (max (1- dired-marks-number) 0))) + ((char-equal char dired-del-marker) + (setq dired-del-flags-number + (max (1- dired-del-flags-number) 0))) + ((setq dired-other-marks-number + (max (1- dired-other-marks-number) 0)))) + (dired-substitute-marker (point) char ?\ ))))))) + (dired-update-mode-line-modified))) + +(defun dired-mark-prefix (&optional arg) + "Mark the next ARG files with the next character typed. +If ARG is negative, marks the previous files." + (interactive "p") + (if (sit-for echo-keystrokes) + (cond + ((or (= arg 1) (zerop arg)) + (message "Mark with character?")) + ((< arg 0) + (message "Mark %d file%s moving backwards?" + (- arg) (dired-plural-s (- arg)))) + ((> arg 1) + (message "Mark %d following files with character?" arg)))) + (dired-mark arg (read-char))) + +(defun dired-change-marks (old new) + "Change all OLD marks to NEW marks. +OLD and NEW are both characters used to mark files. +With a prefix, prompts for a mark to toggle. In other words, all unmarked +files receive that mark, and all files currently marked with that mark become +unmarked." + ;; When used in a lisp program, setting NEW to nil means toggle the mark OLD. + (interactive + (let* ((cursor-in-echo-area t) + (old nil) + (new nil) + (markers (dired-mark-list)) + (default (cond ((null markers) + (error "No markers in buffer")) + ((= (length markers) 1) + (setq old (car markers))) + ((memq dired-marker-char markers) + dired-marker-char) + ;; picks the last one in the buffer. reasonable? + ((car markers))))) + (or old (setq old + (progn + (if current-prefix-arg + (message "Toggle mark (default %c): " default) + (message "Change old mark (default %c): " default)) + (read-char)))) + (if (memq old '(?\ ?\n ?\r)) (setq old default)) + (or current-prefix-arg + (setq new (progn + (message + "Change %c marks to new mark (RET means abort): " old) + (read-char)))) + (list old new))) + (let ((old-count (cond + ((char-equal old dired-marker-char) + 'dired-marks-number) + ((char-equal old dired-del-marker) + 'dired-del-flags-number) + ('dired-other-marks-number)))) + (if new + (or (memq new '(?\ ?\n ?\r)) + ;; \n and \r aren't valid marker chars. Assume that if the + ;; user hits return, he meant to abort the command. + (let ((string (format "\n%c" old)) + (new-count (cond + ((char-equal new dired-marker-char) + 'dired-marks-number) + ((char-equal new dired-del-marker) + 'dired-del-flags-number) + ('dired-other-marks-number))) + (buffer-read-only nil)) + (save-excursion + (goto-char (point-min)) + (while (search-forward string nil t) + (if (char-equal (preceding-char) old) + (progn + (dired-substitute-marker (1- (point)) old new) + (set new-count (1+ (symbol-value new-count))) + (set old-count (max (1- (symbol-value old-count)) 0)))) + )))) + (save-excursion + (let ((ucount 0) + (mcount 0) + (buffer-read-only nil)) + (goto-char (point-min)) + (while (not (eobp)) + (or (dired-between-files) + (looking-at dired-re-dot) + (cond + ((= (following-char) ?\ ) + (setq mcount (1+ mcount)) + (set old-count (1+ (symbol-value old-count))) + (dired-substitute-marker (point) ?\ old)) + ((= (following-char) old) + (setq ucount (1+ ucount)) + (set old-count (max (1- (symbol-value old-count)) 0)) + (dired-substitute-marker (point) old ?\ )))) + (forward-line 1)) + (message "Unmarked %d file%s; marked %d file%s with %c." + ucount (dired-plural-s ucount) mcount + (dired-plural-s mcount) old))))) + (dired-update-mode-line-modified)) + +(defun dired-unmark-all-files (flag &optional arg) + "Remove a specific mark or any mark from every file. +With prefix arg, query for each marked file. +Type \\[help-command] at that time for help. +With a zero prefix, only counts the number of marks." + (interactive + (let* ((cursor-in-echo-area t) + executing-kbd-macro) ; for XEmacs + (list (and (not (eq current-prefix-arg 0)) + (progn (message "Remove marks (RET means all): ") (read-char))) + current-prefix-arg))) + (save-excursion + (let* ((help-form "\ +Type SPC or `y' to unflag one file, DEL or `n' to skip to next, +`!' to unflag all remaining files with no more questions.") + (allp (memq flag '(?\n ?\r))) + (count-p (eq arg 0)) + (count (if (or allp count-p) + (mapcar + (function + (lambda (elt) + (cons elt 0))) + (nreverse (dired-mark-list))) + 0)) + (msg "") + (no-query (or (not arg) count-p)) + buffer-read-only case-fold-search query) + (goto-char (point-min)) + (if (or allp count-p) + (while (re-search-forward dired-re-mark nil t) + (if (or no-query + (dired-query 'query "Unmark file `%s'? " + (dired-get-filename t))) + (let ((ent (assq (preceding-char) count))) + (if ent (setcdr ent (1+ (cdr ent)))) + (or count-p (dired-substitute-marker + (- (point) 1) (preceding-char) ?\ )))) + (forward-line 1)) + (while (search-forward (format "\n%c" flag) nil t) + (if (or no-query + (dired-query 'query "Unmark file `%s'? " + (dired-get-filename t))) + (progn + (dired-substitute-marker (match-beginning 0) flag ?\ ) + (setq count (1+ count)))))) + (if (or allp count-p) + (mapcar + (function + (lambda (elt) + (or (zerop (cdr elt)) + (setq msg (format "%s%s%d %c%s" + msg + (if (zerop (length msg)) + " " + ", ") + (cdr elt) + (car elt) + (if (= 1 (cdr elt)) "" "'s")))))) + count) + (or (zerop count) + (setq msg (format " %d %c%s" + count flag (if (= 1 count) "" "'s"))))) + (if (zerop (length msg)) + (setq msg " none") + (or count-p (dired-update-mode-line-modified t))) + (message "%s:%s" (if count-p "Number of marks" "Marks removed") msg)))) + +(defun dired-get-marked-files (&optional localp arg) + "Return the marked files' names as list of strings. +The list is in the same order as the buffer, that is, the car is the + first marked file. +Values returned are normally absolute pathnames. +Optional arg LOCALP as in `dired-get-filename'. +Optional second argument ARG forces to use other files. If ARG is an + integer, use the next ARG files. If ARG is otherwise non-nil, use + current file. Usually ARG comes from the current prefix arg." + (save-excursion + (nreverse (dired-map-over-marks (dired-get-filename localp) arg)))) + +;;; Utility functions for marking files + +(defun dired-mark-files-in-region (start end &optional char) + (let (buffer-read-only) + (if (> start end) + (error "start > end")) + (goto-char start) ; assumed at beginning of line + (or char (setq char dired-marker-char)) + (while (< (point) end) + ;; Skip subdir line and following garbage like the `total' line: + (while (and (< (point) end) (dired-between-files)) + (forward-line 1)) + (if (and (/= (following-char) char) + (not (looking-at dired-re-dot)) + (save-excursion + (dired-move-to-filename nil (point)))) + (progn + (dired-update-marker-counters (following-char) t) + (dired-substitute-marker (point) (following-char) char) + (dired-update-marker-counters char))) + (forward-line 1))) + (dired-update-mode-line-modified)) + +(defun dired-mark-list () + ;; Returns a list of all marks currently used in the buffer. + (let ((result nil) + char) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (and (not (memq (setq char (following-char)) '(?\ ?\n ?\r))) + (not (memq char result)) + (setq result (cons char result))) + (forward-line 1))) + result)) + +;;; Dynamic markers + +(defun dired-set-current-marker-string () + "Computes and returns `dired-marker-string'." + (prog1 + (setq dired-marker-string + (if dired-marker-stack + (let* ((n (+ (length dired-marker-stack) 5)) + (str (make-string n ?\ )) + (list dired-marker-stack) + (pointer dired-marker-stack-pointer)) + (setq n (1- n)) + (aset str n ?\]) + (setq n (1- n)) + (while list + (aset str n (car list)) + (if (zerop pointer) + (progn + (setq n (1- n)) + (aset str n dired-marker-stack-cursor))) + (setq n (1- n) + pointer (1- pointer) + list (cdr list))) + (aset str n dired-default-marker) + (if (zerop pointer) + (aset str 2 dired-marker-stack-cursor)) + (aset str 1 ?\[) + str) + "")) + (set-buffer-modified-p (buffer-modified-p)))) + +(defun dired-set-marker-char (c) + "Set the marker character to something else. +Use \\[dired-restore-marker-char] to restore the previous value." + (interactive "cNew marker character: ") + (and (memq c '(?\ ?\n ?\r)) (error "invalid marker char %c" c)) + (setq dired-marker-stack (cons c dired-marker-stack) + dired-marker-stack-pointer 0 + dired-marker-char c) + (dired-update-mode-line-modified t) + (dired-set-current-marker-string)) + +(defun dired-restore-marker-char () + "Restore the marker character to its previous value. +Uses `dired-default-marker' if the marker stack is empty." + (interactive) + (setq dired-marker-stack (cdr dired-marker-stack) + dired-marker-char (car dired-marker-stack) + dired-marker-stack-pointer (min dired-marker-stack-pointer + (length dired-marker-stack))) + (or dired-marker-char + (setq dired-marker-char dired-default-marker)) + (dired-set-current-marker-string) + (dired-update-mode-line-modified t) + (or dired-marker-stack (message "Marker is %c" dired-marker-char))) + +(defun dired-marker-stack-left (n) + "Moves the marker stack cursor to the left." + (interactive "p") + (let ((len (1+ (length dired-marker-stack)))) + (or dired-marker-stack (error "Dired marker stack is empty.")) + (setq dired-marker-stack-pointer + (% (+ dired-marker-stack-pointer n) len)) + (if (< dired-marker-stack-pointer 0) + (setq dired-marker-stack-pointer (+ dired-marker-stack-pointer + len))) + (dired-set-current-marker-string) + (setq dired-marker-char + (if (= dired-marker-stack-pointer (1- len)) + dired-default-marker + (nth dired-marker-stack-pointer dired-marker-stack)))) + (dired-update-mode-line-modified t)) + +(defun dired-marker-stack-right (n) + "Moves the marker stack cursor to the right." + (interactive "p") + (dired-marker-stack-left (- n))) + +;;; Commands to mark or flag files based on their characteristics or names. + +(defun dired-mark-symlinks (&optional unflag-p) + "Mark all symbolic links. +With prefix argument, unflag all those files." + (interactive "P") + (dired-check-ls-l) + (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) + (dired-mark-if (looking-at dired-re-sym) "symbolic link")) + (dired-update-mode-line-modified t)) + +(defun dired-mark-directories (&optional unflag-p) + "Mark all directory file lines except `.' and `..'. +With prefix argument, unflag all those files." + (interactive "P") + (if dired-re-dir + (progn + (dired-check-ls-l) + (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) + (dired-mark-if (and (looking-at dired-re-dir) + (not (looking-at dired-re-dot))) + "directory file")))) + (dired-update-mode-line-modified t)) + +(defun dired-mark-executables (&optional unflag-p) + "Mark all executable files. +With prefix argument, unflag all those files." + (interactive "P") + (if dired-re-exe + (progn + (dired-check-ls-l) + (let ((dired-marker-char (if unflag-p ?\040 dired-marker-char))) + (dired-mark-if (looking-at dired-re-exe) "executable file")))) + (dired-update-mode-line-modified t)) + +(defun dired-flag-backup-files (&optional unflag-p) + "Flag all backup files (names ending with `~') for deletion. +With prefix argument, unflag these files." + (interactive "P") + (dired-check-ls-l) + (let ((dired-marker-char (if unflag-p ?\040 dired-del-marker))) + (dired-mark-if + (and (not (and dired-re-dir (looking-at dired-re-dir))) + (let ((fn (dired-get-filename t t))) + (if fn (backup-file-name-p fn)))) + "backup file")) + (dired-update-mode-line-modified t)) + +(defun dired-flag-auto-save-files (&optional unflag-p) + "Flag for deletion files whose names suggest they are auto save files. +A prefix argument says to unflag those files instead." + (interactive "P") + (let ((dired-marker-char (if unflag-p ?\040 dired-del-marker))) + (dired-mark-if + ;; It is less than general to check for ~ here, + ;; but it's the only way this runs fast enough. + (and (save-excursion (end-of-line) + (eq (preceding-char) ?#)) + (not (and dired-re-dir (looking-at dired-re-dir))) + (let ((fn (dired-get-filename t t))) + (if fn (auto-save-file-name-p + (file-name-nondirectory fn))))) + "auto save file")) + (dired-update-mode-line-modified t)) + +(defun dired-mark-rcs-files (&optional unflag-p) + "Mark all files that are under RCS control. +With prefix argument, unflag all those files. +Mentions RCS files for which a working file was not found in this buffer. +Type \\[dired-why] to see them again." + ;; Returns failures, or nil on success. + ;; Finding those with locks would require to peek into the ,v file, + ;; depends slightly on the RCS version used and should be done + ;; together with the Emacs RCS interface. + ;; Unfortunately, there is no definitive RCS interface yet. + (interactive "P") + (message "%sarking RCS controlled files..." (if unflag-p "Unm" "M")) + (let ((dired-marker-char (if unflag-p ?\ dired-marker-char)) + rcs-files wf failures count total) + (mapcar ; loop over subdirs + (function + (lambda (dir) + (or (equal (file-name-nondirectory (directory-file-name dir)) + "RCS") + ;; skip inserted RCS subdirs + (setq rcs-files + (append (directory-files dir t ",v$") ; *,v and RCS/*,v + (let ((rcs-dir (expand-file-name "RCS" dir))) + (if (file-directory-p rcs-dir) + (mapcar ; working files from ./RCS are in ./ + (function + (lambda (x) + (expand-file-name x dir))) + (directory-files + (file-name-as-directory rcs-dir) + nil ",v$")))) + rcs-files))))) + (mapcar (function car) dired-subdir-alist)) + (setq total (length rcs-files)) + (while rcs-files + (setq wf (substring (car rcs-files) 0 -2) + rcs-files (cdr rcs-files)) + (save-excursion (if (dired-goto-file wf) + (dired-mark 1) ; giving a prefix avoids checking + ; for subdir line. + (setq failures (cons wf failures))))) + (dired-update-mode-line-modified t) + (if (null failures) + (message "%d RCS file%s %smarked." + total (dired-plural-s total) (if unflag-p "un" "")) + (setq count (length failures)) + (dired-log-summary (buffer-name (current-buffer)) + "RCS working file not found %s" failures) + (message "%d RCS file%s: %d %smarked - %d not found %s." + total (dired-plural-s total) (- total count) + (if unflag-p "un" "") count failures)) + failures)) + + +;;;; ------------------------------------------------------------ +;;;; Logging failures +;;;; ------------------------------------------------------------ + +(defun dired-why () + "Pop up a buffer with error log output from Dired. +A group of errors from a single command ends with a formfeed. +Thus, use \\[backward-page] to find the beginning of a group of errors." + (interactive) + (if (get-buffer dired-log-buffer) + (let ((owindow (selected-window)) + (window (display-buffer (get-buffer dired-log-buffer)))) + (unwind-protect + (progn + (select-window window) + (goto-char (point-max)) + (recenter -1)) + (select-window owindow))))) + +(defun dired-log (buffer-name log &rest args) + ;; Log a message or the contents of a buffer. + ;; BUFFER-NAME is the name of the dired buffer to which the message applies. + ;; If LOG is a string and there are more args, it is formatted with + ;; those ARGS. Usually the LOG string ends with a \n. + ;; End each bunch of errors with (dired-log t): this inserts + ;; current time and buffer, and a \f (formfeed). + (or (stringp buffer-name) (setq buffer-name (buffer-name buffer-name))) + (let ((obuf (current-buffer))) + (unwind-protect ; want to move point + (progn + (set-buffer (get-buffer-create dired-log-buffer)) + (goto-char (point-max)) + (let (buffer-read-only) + (cond ((stringp log) + (insert (if args + (apply (function format) log args) + log))) + ((bufferp log) + (insert-buffer log)) + ((eq t log) + (insert "\n\t" (current-time-string) + "\tBuffer `" buffer-name "'\n\f\n"))))) + (set-buffer obuf)))) + +(defun dired-log-summary (buffer-name string failures) + (message (if failures "%s--type y for details %s" + "%s--type y for details") + string failures) + ;; Log a summary describing a bunch of errors. + (dired-log buffer-name (concat "\n" string)) + (if failures (dired-log buffer-name "\n%s" failures)) + (dired-log buffer-name t)) + + +;;;; ------------------------------------------------------- +;;;; Sort mode of dired buffers. +;;;; ------------------------------------------------------- + +(defun dired-sort-type (list) + ;; Returns the sort type of LIST, as a symbol. + (let* ((list (reverse list)) + (alist (sort + (mapcar (function + (lambda (x) + (cons (length (memq (car x) list)) (cdr x)))) + dired-sort-type-alist) + (function + (lambda (x y) + (> (car x) (car y)))))) + (winner (car alist))) + (if (zerop (car winner)) + 'name + (cdr winner)))) + +(defun dired-sort-set-modeline (&optional switches) + ;; Set modeline display according to dired-internal-switches. + ;; Modeline display of "by name" or "by date" guarantees the user a + ;; match with the corresponding regexps. Non-matching switches are + ;; shown literally. + (or switches (setq switches dired-internal-switches)) + (setq dired-sort-mode + (if dired-show-ls-switches + (concat " " (dired-make-switches-string + (or switches dired-internal-switches))) + (concat " by " (and (memq ?r switches) "rev-") + (symbol-name (dired-sort-type switches))))) + ;; update mode line + (set-buffer-modified-p (buffer-modified-p))) + +(defun dired-sort-toggle-or-edit (&optional arg) + "Toggle between sort by date/name for the current subdirectory. + +With a 0 prefix argument, simply reports on the current switches. + +With a prefix 1 allows the ls switches for the current subdirectory to be +edited. + +With a prefix 2 allows the default ls switches for newly inserted +subdirectories to be edited. + +With a prefix \\[universal-argument] allows you to sort the entire +buffer by either name or date. + +With a prefix \\[universal-argument] \\[universal-argument] allows the default switches +for the entire buffer to be edited, and then reverts the buffer so that all +subdirectories are sorted according to these switches. + +Note that although dired allows different ls switches to be used for +different subdirectories, certain combinations of ls switches are incompatible. +If incompatible switches are detected, dired will offer to revert the buffer +to force the ls switches for all subdirectories to a single value. If you +refuse to revert the buffer, any change of ls switches will be aborted." + (interactive "P") + (cond + ((eq arg 0) + ;; Report on switches + (message "Switches for current subdir: %s. Default for buffer: %s." + (dired-make-switches-string + (nth 3 (assoc (dired-current-directory) dired-subdir-alist))) + (dired-make-switches-string dired-internal-switches))) + ((null arg) + ;; Toggle between sort by date/name. + (let* ((dir (dired-current-directory)) + (curr (nth 3 (assoc dir dired-subdir-alist)))) + (dired-sort-other + (if (eq (dired-sort-type curr) 'name) + (cons ?t curr) + (mapcar (function + (lambda (x) + (setq curr + (delq (car x) curr)))) + dired-sort-type-alist) + curr) + nil dir))) + ((eq arg 1) + ;; Edit switches for current subdir. + (let* ((dir (dired-current-directory)) + (switch-string + (read-string + "New ls switches for current subdir (must contain -l): " + (dired-make-switches-string + (nth 3 (assoc dir dired-subdir-alist))))) + (switches (dired-make-switches-list switch-string))) + (if (dired-compatible-switches-p switches dired-internal-switches) + (dired-sort-other switches nil dir) + (if (or + (memq 'sort-revert dired-no-confirm) + (y-or-n-p + (format + "Switches %s incompatible with default %s. Revert buffer? " + switch-string + (dired-make-switches-string dired-internal-switches)))) + (dired-sort-other switches nil nil) + (error "Switches unchanged. Remain as %s." switch-string))))) + ((eq arg 2) + ;; Set new defaults for subdirs inserted in the future. + (let* ((switch-string + (read-string + "Default ls switches for new subdirs (must contain -l): " + (dired-make-switches-string dired-internal-switches))) + (switches (dired-make-switches-list switch-string)) + (alist dired-subdir-alist) + x bad-switches) + (while alist + (setq x (nth 3 (car alist)) + alist (cdr alist)) + (or (dired-compatible-switches-p x switches) + (member x bad-switches) + (setq bad-switches (cons x bad-switches)))) + (if bad-switches + (if (or (memq 'sort-revert dired-no-confirm) + (y-or-n-p + (format + "Switches %s incompatible with %s. Revert buffer? " + switch-string (mapconcat 'dired-make-switches-string + bad-switches ", ")))) + (dired-sort-other switches nil nil) + (error "Default switches unchanged. Remain as %s." + (dired-make-switches-string dired-internal-switches))) + (dired-sort-other switches t nil)))) + ((or (equal arg '(4)) (eq arg 'date) (eq arg 'name)) + ;; Toggle the entire buffer name/data. + (let ((cursor-in-echo-area t) + (switches (copy-sequence dired-internal-switches)) + (type (and (symbolp arg) arg)) + char) + (while (null type) + (message "Sort entire buffer according to (n)ame or (d)ate? ") + (setq char (read-char) + type (cond + ((char-equal char ?d) 'date) + ((char-equal char ?n) 'name) + (t (message "Type one of n or d.") (sit-for 1) nil)))) + (mapcar (function + (lambda (x) + (setq switches + (delq (car x) switches)))) + dired-sort-type-alist) + (dired-sort-other + (if (eq type 'date) (cons ?t switches) switches) nil nil))) + ((equal arg '(16)) + ;; Edit the switches for the entire buffer. + (dired-sort-other + (dired-make-switches-list + (read-string + "Change ls switches for entire buffer to (must contain -l): " + (dired-make-switches-string dired-internal-switches))) + nil nil)) + (t + ;; No idea what's going on. + (error + "Invalid prefix. See %s dired-sort-toggle-or-edit." + (substitute-command-keys + (if (featurep 'ehelp) + "\\[electric-describe-function]" + "\\[describe-function]")))))) + +(defun dired-sort-other (switches &optional no-revert subdir) + ;; Specify new ls SWITCHES for current dired buffer. + ;; With optional second arg NO-REVERT, don't refresh the listing afterwards. + ;; If subdir is non-nil, only changes the switches for the + ;; sudirectory. + (if subdir + (let ((elt (assoc subdir dired-subdir-alist))) + (if elt (setcar (nthcdr 3 elt) switches))) + (setq dired-internal-switches switches)) + (or no-revert + (cond + + (subdir + (let ((ofile (dired-get-filename nil t)) + (opoint (point))) + (message "Relisting %s..." subdir) + (dired-insert-subdir subdir switches) + (message "Relisting %s... done" subdir) + (or (and ofile (dired-goto-file ofile)) (goto-char opoint)))) + + ((memq ?R switches) + ;; We are replacing a buffer with a giant recursive listing. + (let ((opoint (point)) + (ofile (dired-get-filename nil t)) + (hidden-subdirs (dired-remember-hidden)) + (mark-alist (dired-remember-marks (point-min) (point-max))) + (kill-files-p (save-excursion + (goto-char (point)) + (search-forward + (concat (char-to-string ?\r) + (regexp-quote + (char-to-string + dired-kill-marker-char))) + nil t))) + (omit-files (nth 2 (nth (1- (length dired-subdir-alist)) + dired-subdir-alist))) + buffer-read-only) + (dired-readin dired-directory (current-buffer) + (or (consp dired-directory) + (null (file-directory-p dired-directory)))) + (dired-mark-remembered mark-alist) ; mark files that were marked + (if kill-files-p (dired-do-hide dired-kill-marker-char)) + (if omit-files + (dired-omit-expunge nil t)) + ;; hide subdirs that were hidden + (save-excursion + (mapcar (function (lambda (dir) + (if (dired-goto-subdir dir) + (dired-hide-subdir 1)))) + hidden-subdirs)) + ;; Try to get back to where we were + (or (and ofile (dired-goto-file ofile)) + (goto-char opoint)) + (dired-move-to-filename))) + + (t + ;; Clear all switches in the subdir alist + (setq dired-subdir-alist + (mapcar (function + (lambda (x) + (setcar (nthcdr 3 x) nil) + x)) + dired-subdir-alist)) + (revert-buffer nil t)))) + (dired-update-mode-line t)) + +(defun dired-compatible-switches-p (list1 list2) + ;; Returns t if list1 and list2 are allowed as switches in the same + ;; dired buffer. + (and (eq (null (or (memq ?l list1) (memq ?o list1) (memq ?g list1))) + (null (or (memq ?l list2) (memq ?o list2) (memq ?g list2)))) + (eq (null (memq ?F list1)) (null (memq ?F list2))) + (eq (null (memq ?p list1)) (null (memq ?p list2))) + (eq (null (memq ?b list1)) (null (memq ?b list2))))) + +(defun dired-check-ls-l (&optional switches) + ;; Check for long-style listings + (let ((switches (or switches dired-internal-switches))) + (or (memq ?l switches) (memq ?o switches) (memq ?g switches) + (error "Dired needs -l, -o, or -g in ls switches")))) + + +;;;; -------------------------------------------------------------- +;;;; Creating new files. +;;;; -------------------------------------------------------------- +;;; +;;; The dired-create-files paradigm is used for copying, renaming, +;;; compressing, and making hard and soft links. + +(defun dired-file-marker (file) + ;; Return FILE's marker, or nil if unmarked. + (save-excursion + (and (dired-goto-file file) + (progn + (skip-chars-backward "^\n\r") + (and (not (= ?\040 (following-char))) + (following-char)))))) + +;; The basic function for half a dozen variations on cp/mv/ln/ln -s. +(defun dired-create-files (file-creator operation fn-list name-constructor + &optional marker-char query + implicit-to) + ;; Create a new file for each from a list of existing files. The user + ;; is queried, dired buffers are updated, and at the end a success or + ;; failure message is displayed + + ;; FILE-CREATOR must accept three args: oldfile newfile ok-if-already-exists + ;; It is called for each file and must create newfile, the entry of + ;; which will be added. The user will be queried if the file already + ;; exists. If oldfile is removed by FILE-CREATOR (i.e, it is a + ;; rename), it is FILE-CREATOR's responsibility to update dired + ;; buffers. FILE-CREATOR must abort by signalling a file-error if it + ;; could not create newfile. The error is caught and logged. + + ;; OPERATION (a capitalized string, e.g. `Copy') describes the + ;; operation performed. It is used for error logging. + + ;; FN-LIST is the list of files to copy (full absolute pathnames). + + ;; NAME-CONSTRUCTOR returns a newfile for every oldfile, or nil to + ;; skip. If it skips files, it is supposed to tell why (using dired-log). + + ;; Optional MARKER-CHAR is a character with which to mark every + ;; newfile's entry, or t to use the current marker character if the + ;; oldfile was marked. + + ;; QUERY is a function to use to prompt the user about creating a file. + ;; It accepts two args, the from and to files, + ;; and must return nil or t. If QUERY is nil, then no user + ;; confirmation will be requested. + + ;; If IMPLICIT-TO is non-nil, then the file constructor does not take + ;; a to-file arg. e.g. compress. + + (let ((success-count 0) + (total (length fn-list)) + failures skipped overwrite-query) + ;; Fluid vars used for storing responses of previous queries must be + ;; initialized. + (dired-save-excursion + (setq dired-overwrite-backup-query nil + dired-file-creator-query nil) + (mapcar + (function + (lambda (from) + (let ((to (funcall name-constructor from))) + (if to + (if (equal to from) + (progn + (dired-log (buffer-name (current-buffer)) + "Cannot %s to same file: %s\n" + (downcase operation) from) + (setq skipped (cons (dired-make-relative from) skipped))) + (if (or (null query) + (funcall query from to)) + (let* ((overwrite (let (jka-compr-enabled) + ;; Don't let jka-compr fool us. + (file-exists-p to))) + ;; for dired-handle-overwrite + (dired-overwrite-confirmed + (and overwrite + (let ((help-form '(format "\ +Type SPC or `y' to overwrite file `%s', +DEL or `n' to skip to next, +ESC or `q' to not overwrite any of the remaining files, +`!' to overwrite all remaining files with no more questions." to))) + (dired-query 'overwrite-query + "Overwrite %s?" to)))) + ;; must determine if FROM is marked before + ;; file-creator gets a chance to delete it + ;; (in case of a move). + (actual-marker-char + (cond ((integerp marker-char) marker-char) + (marker-char (dired-file-marker from)) + (t nil)))) + (if (and overwrite (null dired-overwrite-confirmed)) + (setq skipped (cons (dired-make-relative from) + skipped)) + (condition-case err + (let ((dired-unhandle-add-files + (cons to dired-unhandle-add-files))) + (if implicit-to + (funcall file-creator from + dired-overwrite-confirmed) + (funcall file-creator from to + dired-overwrite-confirmed)) + (setq success-count (1+ success-count)) + (message "%s: %d of %d" + operation success-count total) + (dired-add-file to actual-marker-char)) + (file-error ; FILE-CREATOR aborted + (progn + (setq failures (cons (dired-make-relative from) + failures)) + (dired-log (buffer-name (current-buffer)) + "%s `%s' to `%s' failed:\n%s\n" + operation from to err)))))) + (setq skipped (cons (dired-make-relative from) skipped)))) + (setq skipped (cons (dired-make-relative from) skipped)))))) + fn-list) + (cond + (failures + (dired-log-summary + (buffer-name (current-buffer)) + (format "%s failed for %d of %d file%s" + operation (length failures) total + (dired-plural-s total)) failures)) + (skipped + (dired-log-summary + (buffer-name (current-buffer)) + (format "%s: %d of %d file%s skipped" + operation (length skipped) total + (dired-plural-s total)) skipped)) + (t + (message "%s: %s file%s." + operation success-count (dired-plural-s success-count))))))) + +(defun dired-do-create-files (op-symbol file-creator operation arg + &optional marker-char + prompter how-to) + ;; Create a new file for each marked file. + ;; Prompts user for target, which is a directory in which to create + ;; the new files. Target may be a plain file if only one marked + ;; file exists. + ;; OP-SYMBOL is the symbol for the operation. Function `dired-mark-pop-up' + ;; will determine wether pop-ups are appropriate for this OP-SYMBOL. + ;; FILE-CREATOR and OPERATION as in dired-create-files. + ;; ARG as in dired-get-marked-files. + ;; PROMPTER is a function of one-arg, the list of files, to return a prompt + ;; to use for dired-read-file-name. If it is nil, then a default prompt + ;; will be used. + ;; Optional arg MARKER-CHAR as in dired-create-files. + ;; Optional arg HOW-TO determines how to treat target: + ;; If HOW-TO is not given (or nil), and target is a directory, the + ;; file(s) are created inside the target directory. If target + ;; is not a directory, there must be exactly one marked file, + ;; else error. + ;; If HOW-TO is t, then target is not modified. There must be + ;; exactly one marked file, else error. + ;; Else HOW-TO is assumed to be a function of one argument, target, + ;; that looks at target and returns a value for the into-dir + ;; variable. The function dired-into-dir-with-symlinks is provided + ;; for the case (common when creating symlinks) that symbolic + ;; links to directories are not to be considered as directories + ;; (as file-directory-p would if HOW-TO had been nil). + + (let* ((fn-list (dired-get-marked-files nil arg)) + (fn-count (length fn-list)) + (cdir (dired-current-directory)) + (target (expand-file-name + (dired-mark-read-file-name + (if prompter + (funcall prompter fn-list) + (concat operation " %s to: ")) + (dired-dwim-target-directory) + op-symbol arg (mapcar (function + (lambda (fn) + (dired-make-relative fn cdir t))) + fn-list)))) + (into-dir (cond ((null how-to) (file-directory-p target)) + ((eq how-to t) nil) + (t (funcall how-to target))))) + (if (and (> fn-count 1) + (not into-dir)) + (error "Marked %s: target must be a directory: %s" operation target)) + ;; rename-file bombs when moving directories unless we do this: + (or into-dir (setq target (directory-file-name target))) + (dired-create-files + file-creator operation fn-list + (if into-dir ; target is a directory + (list 'lambda '(from) + (list 'expand-file-name '(file-name-nondirectory from) target)) + (list 'lambda '(from) target)) + marker-char))) + +(defun dired-into-dir-with-symlinks (target) + (and (file-directory-p target) + (not (file-symlink-p target)))) +;; This may not always be what you want, especially if target is your +;; home directory and it happens to be a symbolic link, as is often the +;; case with NFS and automounters. Or if you want to make symlinks +;; into directories that themselves are only symlinks, also quite +;; common. +;; So we don't use this function as value for HOW-TO in +;; dired-do-symlink, which has the minor disadvantage of +;; making links *into* a symlinked-dir, when you really wanted to +;; *overwrite* that symlink. In that (rare, I guess) case, you'll +;; just have to remove that symlink by hand before making your marked +;; symlinks. + +(defun dired-handle-overwrite (to) + ;; Save old version of a to be overwritten file TO. + ;; `dired-overwrite-confirmed' and `dired-overwrite-backup-query' + ;; are fluid vars from dired-create-files. + (if (and dired-backup-if-overwrite + dired-overwrite-confirmed + (or (eq 'always dired-backup-if-overwrite) + (dired-query 'dired-overwrite-backup-query + (format "Make backup for existing file `%s'? " to)))) + (let ((backup (car (find-backup-file-name to)))) + (rename-file to backup 0)))) ; confirm overwrite of old backup + +(defun dired-dwim-target-directory () + ;; Try to guess which target directory the user may want. + ;; If there is a dired buffer displayed in the next window, use + ;; its current subdir, else use current subdir of this dired buffer. + ;; non-dired buffer may want to profit from this function, e.g. vm-uudecode + (let* ((this-dir (and (eq major-mode 'dired-mode) + (dired-current-directory))) + (dwimmed + (if dired-dwim-target + (let* ((other-buf (window-buffer (next-window))) + (other-dir (save-excursion + (set-buffer other-buf) + (and (eq major-mode 'dired-mode) + (dired-current-directory))))) + (or other-dir this-dir)) + this-dir))) + (and dwimmed (dired-abbreviate-file-name dwimmed)))) + +(defun dired-get-target-directory () + "Writes a copy of the current subdirectory into an active minibuffer." + (interactive) + (let ((mb (dired-get-active-minibuffer-window))) + (if mb + (let ((dir (dired-current-directory))) + (select-window mb) + (set-buffer (window-buffer mb)) + (erase-buffer) + (insert dir)) + (error "No active minibuffer")))) + +;;; Copying files + +(defun dired-do-copy (&optional arg) + "Copy all marked (or next ARG) files, or copy the current file. +When operating on just the current file, you specify the new name. +When operating on multiple or marked files, you specify a directory +and the files are copied into that directory, retaining the same file names. + +A zero prefix argument copies nothing. But it toggles the +variable `dired-copy-preserve-time' (which see)." + (interactive "P") + (if (not (zerop (prefix-numeric-value arg))) + (dired-do-create-files 'copy (function dired-copy-file) + (if dired-copy-preserve-time "Copy [-p]" "Copy") + arg dired-keep-marker-copy) + (setq dired-copy-preserve-time (not dired-copy-preserve-time)) + (if dired-copy-preserve-time + (message "Copy will preserve time.") + (message "Copied files will get current date.")))) + +(defun dired-copy-file (from to ok-flag) + (dired-handle-overwrite to) + (copy-file from to ok-flag dired-copy-preserve-time)) + +;;; Renaming/moving files + +(defun dired-do-rename (&optional arg) + "Rename current file or all marked (or next ARG) files. +When renaming just the current file, you specify the new name. +When renaming multiple or marked files, you specify a directory. + +A zero ARG moves no files but toggles `dired-dwim-target' (which see)." + (interactive "P") + (if (not (zerop (prefix-numeric-value arg))) + (dired-do-create-files 'move (function dired-rename-file) + "Move" arg dired-keep-marker-rename + (function + (lambda (list) + (if (= (length list) 1) + "Rename %s to: " + "Move %s to: ")))) + (setq dired-dwim-target (not dired-dwim-target)) + (message "dired-dwim-target is %s." (if dired-dwim-target "ON" "OFF")))) + +(defun dired-rename-file (from to ok-flag) + (dired-handle-overwrite to) + (let ((insert (assoc (file-name-as-directory from) dired-subdir-alist))) + (rename-file from to ok-flag) ; error is caught in -create-files + ;; Silently rename the visited file of any buffer visiting this file. + (dired-rename-update-buffers from to insert))) + +(defun dired-rename-update-buffers (from to &optional insert) + (if (get-file-buffer from) + (save-excursion + (set-buffer (get-file-buffer from)) + (let ((modflag (buffer-modified-p))) + (set-visited-file-name to) ; kills write-file-hooks + (set-buffer-modified-p modflag))) + ;; It's a directory. More work to do. + (let ((blist (buffer-list)) + (from-dir (file-name-as-directory from)) + (to-dir (file-name-as-directory to))) + (save-excursion + (while blist + (set-buffer (car blist)) + (setq blist (cdr blist)) + (cond + (buffer-file-name + (if (dired-in-this-tree buffer-file-name from-dir) + (let ((modflag (buffer-modified-p))) + (unwind-protect + (set-visited-file-name + (concat to-dir (substring buffer-file-name + (length from-dir)))) + (set-buffer-modified-p modflag))))) + (dired-directory + (if (string-equal from-dir (expand-file-name default-directory)) + ;; If top level directory was renamed, lots of things + ;; have to be updated. + (progn + (dired-unadvertise from-dir) + (setq default-directory to-dir + dired-directory + ;; Need to beware of wildcards. + (expand-file-name + (file-name-nondirectory dired-directory) + to-dir)) + (let ((new-name (file-name-nondirectory + (directory-file-name dired-directory)))) + ;; Try to rename buffer, but just leave old name if new + ;; name would already exist (don't try appending "<%d>") + ;; Why? --sandy 19-8-94 + (or (get-buffer new-name) + (rename-buffer new-name))) + (dired-advertise)) + (and insert + (assoc (file-name-directory (directory-file-name to)) + dired-subdir-alist) + (dired-insert-subdir to)))))))))) + +;;; Making symbolic links + +(defun dired-do-symlink (&optional arg) + "Make symbolic links to current file or all marked (or next ARG) files. +When operating on just the current file, you specify the new name. +When operating on multiple or marked files, you specify a directory +and new symbolic links are made in that directory +with the same names that the files currently have." + (interactive "P") + (dired-do-create-files 'symlink (function make-symbolic-link) + "SymLink" arg dired-keep-marker-symlink)) + +;; Relative symlinks: +;; make-symbolic no longer expands targets (as of at least 18.57), +;; so the code to call ln has been removed. + +(defun dired-do-relsymlink (&optional arg) + "Symlink all marked (or next ARG) files into a directory, +or make a symbolic link to the current file. +This creates relative symbolic links like + + foo -> ../bar/foo + +not absolute ones like + + foo -> /ugly/path/that/may/change/any/day/bar/foo" + (interactive "P") + (dired-do-create-files 'relsymlink (function dired-make-relative-symlink) + "RelSymLink" arg dired-keep-marker-symlink)) + +(defun dired-make-relative-symlink (target linkname + &optional ok-if-already-exists) + "Make a relative symbolic link pointing to TARGET with name LINKNAME. +Three arguments: FILE1 FILE2 &optional OK-IF-ALREADY-EXISTS +The link is relative (if possible), for example + + \"/vol/tex/bin/foo\" \"/vol/local/bin/foo\" + +results in + + \"../../tex/bin/foo\" \"/vol/local/bin/foo\"" + (interactive + (let ((target (read-string "Make relative symbolic link to file: "))) + (list + target + (read-file-name (format "Make relsymlink to file %s: " target)) + 0))) + (let* ((target (expand-file-name target)) + (linkname (expand-file-name linkname)) + (handler (or (find-file-name-handler + linkname 'dired-make-relative-symlink) + (find-file-name-handler + target 'dired-make-relative-symlink)))) + (if handler + (funcall handler 'dired-make-relative-symlink target linkname + ok-if-already-exists) + (setq target (directory-file-name target) + linkname (directory-file-name linkname)) + (make-symbolic-link + (dired-make-relative target (file-name-directory linkname) t) + linkname ok-if-already-exists)))) + +;;; Hard links -- adding names to files + +(defun dired-do-hardlink (&optional arg) + "Add names (hard links) current file or all marked (or next ARG) files. +When operating on just the current file, you specify the new name. +When operating on multiple or marked files, you specify a directory +and new hard links are made in that directory +with the same names that the files currently have." + (interactive "P") + (dired-do-create-files 'hardlink (function add-name-to-file) + "HardLink" arg dired-keep-marker-hardlink)) + + +;;;; --------------------------------------------------------------- +;;;; Running process on marked files +;;;; --------------------------------------------------------------- +;;; +;;; Commands for shell processes are in dired-shell.el. + +;;; Internal functions for running subprocesses, +;;; checking and logging of their errors. + +(defun dired-call-process (program discard &rest arguments) + ;; Run PROGRAM with output to current buffer unless DISCARD is t. + ;; Remaining arguments are strings passed as command arguments to PROGRAM. + ;; Returns program's exit status, as an integer. + ;; This is a separate function so that efs can redefine it. + (let ((return + (apply 'call-process program nil (not discard) nil arguments))) + (if (and (not (equal shell-file-name program)) + (integerp return)) + return + ;; Fudge return code by looking for errors in current buffer. + (if (zerop (buffer-size)) 0 1)))) + +(defun dired-check-process (msg program &rest arguments) + ;; Display MSG while running PROGRAM, and check for output. + ;; Remaining arguments are strings passed as command arguments to PROGRAM. + ;; On error, insert output in a log buffer and return the + ;; offending ARGUMENTS or PROGRAM. + ;; Caller can cons up a list of failed args. + ;; Else returns nil for success. + (let ((err-buffer (get-buffer-create " *dired-check-process output*")) + (dir default-directory)) + (message "%s..." msg) + (save-excursion + ;; Get a clean buffer for error output: + (set-buffer err-buffer) + (erase-buffer) + (setq default-directory dir) ; caller's default-directory + (if (not + (eq 0 (apply (function dired-call-process) program nil arguments))) + (progn + (dired-log (buffer-name (current-buffer)) + (concat program " " (prin1-to-string arguments) "\n")) + (dired-log (buffer-name (current-buffer)) err-buffer) + (or arguments program t)) + (kill-buffer err-buffer) + (message "%s...done" msg) + nil)))) + +;;; Changing file attributes + +(defun dired-do-chxxx (attribute-name program op-symbol arg) + ;; Change file attributes (mode, group, owner) of marked files and + ;; refresh their file lines. + ;; ATTRIBUTE-NAME is a string describing the attribute to the user. + ;; PROGRAM is the program used to change the attribute. + ;; OP-SYMBOL is the type of operation (for use in dired-mark-pop-up). + ;; ARG describes which files to use, like in dired-get-marked-files. + (let* ((files (dired-get-marked-files t arg)) + (new-attribute + (dired-mark-read-string + (concat "Change " attribute-name " of %s to: ") + nil op-symbol arg files)) + (operation (concat program " " new-attribute)) + (failures + (dired-bunch-files 10000 (function dired-check-process) + (list operation program new-attribute) + files))) + (dired-do-redisplay arg);; moves point if ARG is an integer + (if failures + (dired-log-summary (buffer-name (current-buffer)) + (format "%s: error" operation) nil)))) + +(defun dired-do-chmod (&optional arg) + "Change the mode of the marked (or next ARG) files. +This calls chmod, thus symbolic modes like `g+w' are allowed." + (interactive "P") + (dired-do-chxxx "Mode" "chmod" 'chmod arg)) + +(defun dired-do-chgrp (&optional arg) + "Change the group of the marked (or next ARG) files." + (interactive "P") + (dired-do-chxxx "Group" "chgrp" 'chgrp arg)) + +(defun dired-do-chown (&optional arg) + "Change the owner of the marked (or next ARG) files." + (interactive "P") + (dired-do-chxxx "Owner" dired-chown-program 'chown arg)) + +;;; Utilities for running processes on marked files. + +;; Process all the files in FILES in batches of a convenient size, +;; by means of (FUNCALL FUNCTION ARGS... SOME-FILES...). +;; Batches are chosen to need less than MAX chars for the file names, +;; allowing 3 extra characters of separator per file name. +(defun dired-bunch-files (max function args files) + (let (pending + (pending-length 0) + failures) + ;; Accumulate files as long as they fit in MAX chars, + ;; then process the ones accumulated so far. + (while files + (let* ((thisfile (car files)) + (thislength (+ (length thisfile) 3)) + (rest (cdr files))) + ;; If we have at least 1 pending file + ;; and this file won't fit in the length limit, process now. + (if (and pending (> (+ thislength pending-length) max)) + (setq failures + (nconc (apply function (append args pending)) + failures) + pending nil + pending-length 0)) + ;; Do (setq pending (cons thisfile pending)) + ;; but reuse the cons that was in `files'. + (setcdr files pending) + (setq pending files) + (setq pending-length (+ thislength pending-length)) + (setq files rest))) + (nconc (apply function (append args pending)) + failures))) + + +;;;; --------------------------------------------------------------- +;;;; Calculating data or properties for marked files. +;;;; --------------------------------------------------------------- + +(defun dired-do-total-size (&optional arg) + "Show total size of all marked (or next ARG) files." + (interactive "P") + (let* ((result (dired-map-over-marks (dired-get-file-size) arg)) + (total (apply (function +) result)) + (num (length result))) + (message "%d bytes (%d kB) in %s file%s" + total (/ total 1024) num (dired-plural-s num)) + total)) + +(defun dired-get-file-size () + ;; Returns the file size in bytes of the current file, as an integer. + ;; Assumes that it is on a valid file line. It's the caller's responsibility + ;; to ensure this. Assumes that match 0 for dired-re-month-and-time is + ;; at the end of the file size. + (dired-move-to-filename t) + ;; dired-move-to-filename must leave match-beginning 0 at the start of + ;; the date. + (goto-char (match-beginning 0)) + (skip-chars-backward " ") + (string-to-int (buffer-substring (point) + (progn (skip-chars-backward "0-9") + (point))))) + +(defun dired-copy-filenames-as-kill (&optional arg) + "Copy names of marked (or next ARG) files into the kill ring. +The names are separated by a space, and may be copied into other buffers +with \\[yank]. The list of names is also stored in the variable +`dired-marked-files' for possible manipulation in the *scratch* buffer. + +With a 0 prefix argument, use the pathname relative to the top-level dired +directory for each marked file. + +With a prefix \\[universal-argument], use the complete pathname of each +marked file. + +With a prefix \\[universal-argument] \\[universal-argument], copy the complete +file line. In this case, the lines are separated by newlines. + +If on a subdirectory headerline and no prefix argument given, use the +subdirectory name instead." + (interactive "P") + (let (res) + (cond + ((and (null arg) (setq res (dired-get-subdir))) + (kill-new res) + (message "Copied %s into kill ring." res)) + ((equal arg '(16)) + (setq dired-marked-files + (dired-map-over-marks + (concat " " ; Don't copy the mark. + (buffer-substring + (progn (beginning-of-line) (1+ (point))) + (progn (skip-chars-forward "^\n\r") (point)))) + nil)) + (let ((len (length dired-marked-files))) + (kill-new (concat + (mapconcat 'identity dired-marked-files "\n") + "\n")) + (message "Copied %d file line%s into kill ring." + len (dired-plural-s len)))) + (t + (setq dired-marked-files + (cond + ((null arg) + (dired-get-marked-files 'no-dir)) + ((eq arg 0) + (dired-get-marked-files t)) + ((integerp arg) + (dired-get-marked-files 'no-dir arg)) + ((equal arg '(4)) + (dired-get-marked-files)) + (t (error "Invalid prefix %s" arg)))) + (let ((len (length dired-marked-files))) + (kill-new (mapconcat 'identity dired-marked-files " ")) + (message "Copied %d file name%s into kill ring." + len (dired-plural-s len))))))) + + +;;;; ----------------------------------------------------------- +;;;; Killing subdirectories +;;;; ----------------------------------------------------------- +;;; +;;; These commands actually remove text from the dired buffer. + +(defun dired-kill-subdir (&optional remember-marks tree) + "Remove all lines of current subdirectory. +Lower levels are unaffected. If given a prefix when called interactively, +kills the entire directory tree below the current subdirectory." + ;; With optional REMEMBER-MARKS, return a mark-alist. + (interactive (list nil current-prefix-arg)) + (let ((cur-dir (dired-current-directory))) + (if (string-equal cur-dir (expand-file-name default-directory)) + (error "Attempt to kill top level directory")) + (if tree + (dired-kill-tree cur-dir remember-marks) + (let ((beg (dired-subdir-min)) + (end (dired-subdir-max)) + buffer-read-only) + (prog1 + (if remember-marks (dired-remember-marks beg end)) + (goto-char beg) + (or (bobp) (forward-char -1)) ; gobble separator + (delete-region (point) end) + (dired-unsubdir cur-dir) + (dired-update-mode-line) + (dired-update-mode-line-modified t)))))) + +(defun dired-kill-tree (dirname &optional remember-marks) + "Kill all proper subdirs of DIRNAME, excluding DIRNAME itself. +With optional arg REMEMBER-MARKS, return an alist of marked files." + (interactive "DKill tree below directory: ") + (let ((s-alist dired-subdir-alist) dir m-alist) + (while s-alist + (setq dir (car (car s-alist)) + s-alist (cdr s-alist)) + (if (and (not (string-equal dir dirname)) + (dired-in-this-tree dir dirname) + (dired-goto-subdir dir)) + (setq m-alist (nconc (dired-kill-subdir remember-marks) m-alist)))) + (dired-update-mode-line) + (dired-update-mode-line-modified t) + m-alist)) + + +;;;; ------------------------------------------------------------ +;;;; Killing file lines +;;;; ------------------------------------------------------------ +;;; +;;; Uses selective diplay, rather than removing lines from the buffer. + +(defun dired-do-kill-file-lines (&optional arg) + "Kill all marked file lines, or those indicated by the prefix argument. +Killing file lines means hiding them with selective display. Giving +a zero prefix redisplays all killed file lines." + (interactive "P") + (or selective-display + (error "selective-display must be t for file line killing to work!")) + (if (eq arg 0) + (dired-do-unhide dired-kill-marker-char + "Successfully resuscitated %d file line%s." + dired-keep-marker-kill) + (let ((files + (length + (dired-map-over-marks + (progn + (beginning-of-line) + (subst-char-in-region (1- (point)) (point) ?\n ?\r) + (dired-substitute-marker (point) (following-char) + dired-kill-marker-char) + (dired-update-marker-counters dired-marker-char t) + t) + arg)))) + ;; Beware of extreme apparent save-excursion lossage here. + (let ((opoint (point))) + (skip-chars-backward "^\n\r") + (if (= (preceding-char) ?\n) + (goto-char opoint) + (setq opoint (- opoint (point))) + (beginning-of-line) + (skip-chars-forward "^\n\r" (+ (point) opoint)))) + (dired-update-mode-line-modified) + (message "Killed %d file line%s." files (dired-plural-s files))))) + + +;;;; ---------------------------------------------------------------- +;;;; Omitting files. +;;;; ---------------------------------------------------------------- + +;; Marked files are never omitted. +;; Adapted from code submitted by: +;; Michael D. Ernst, mernst@theory.lcs.mit.edu, 1/11/91 +;; Changed to work with selective display by Sandy Rutherford, 13/12/92. +;; For historical reasons, we still use the term expunge, although nothing +;; is expunged from the buffer. + +(defun dired-omit-toggle (&optional arg) + "Toggle between displaying and omitting files matching +`dired-omit-files-regexp' in the current subdirectory. +With a positive prefix, omits files in the entire tree dired buffer. +With a negative prefix, forces all files in the tree dired buffer to be +displayed." + (interactive "P") + (if arg + (let ((arg (prefix-numeric-value arg))) + (if (>= arg 0) + (dired-omit-expunge nil t) + (dired-do-unhide dired-omit-marker-char "") + (mapcar + (function + (lambda (elt) + (setcar (nthcdr 2 elt) nil))) + dired-subdir-alist))) + (if (dired-current-subdir-omitted-p) + (save-restriction + (narrow-to-region (dired-subdir-min) (dired-subdir-max)) + (dired-do-unhide dired-omit-marker-char "") + (setcar (nthcdr 2 (assoc + (dired-current-directory) dired-subdir-alist)) + nil) + (setq dired-subdir-omit nil)) + (dired-omit-expunge) + (setq dired-subdir-omit t))) + (dired-update-mode-line t)) + +(defun dired-current-subdir-omitted-p () + ;; Returns t if the current subdirectory is omited. + (nth 2 (assoc (dired-current-directory) dired-subdir-alist))) + +(defun dired-remember-omitted () + ;; Returns a list of omitted subdirs. + (let ((alist dired-subdir-alist) + result elt) + (while alist + (setq elt (car alist) + alist (cdr alist)) + (if (nth 2 elt) + (setq result (cons (car elt) result)))) + result)) + +(defun dired-omit-expunge (&optional regexp full-buffer) + ;; Hides all unmarked files matching REGEXP. + ;; If REGEXP is nil or not specified, uses `dired-omit-files-regexp', + ;; and also omits filenames ending in `dired-omit-extensions'. + ;; If REGEXP is the empty string, this function is a no-op. + (let ((omit-re (or regexp (dired-omit-regexp))) + (alist dired-subdir-alist) + elt min) + (if (null omit-re) + 0 + (if full-buffer + (prog1 + (dired-omit-region (point-min) (point-max) omit-re) + ;; Set omit property in dired-subdir-alist + (while alist + (setq elt (car alist) + min (dired-get-subdir-min elt) + alist (cdr alist)) + (if (and (<= (point-min) min) (>= (point-max) min)) + (setcar (nthcdr 2 elt) t)))) + (prog1 + (dired-omit-region (dired-subdir-min) (dired-subdir-max) omit-re) + (setcar + (nthcdr 2 (assoc (dired-current-directory) + dired-subdir-alist)) + t)))))) + +(defun dired-omit-region (start end regexp) + ;; Omits files matching regexp in region. Returns count. + (save-restriction + (narrow-to-region start end) + (let ((hidden-subdirs (dired-remember-hidden)) + buffer-read-only count) + (or selective-display + (error "selective-display must be t for file omission to work!")) + (dired-omit-unhide-region start end) + (let ((dired-marker-char dired-omit-marker-char) + ;; since all subdirs are now unhidden, this fakes + ;; dired-move-to-end-of-filename into working faster + (selective-display nil)) + (or dired-omit-silent + dired-in-query (message "Omitting...")) + (if (dired-mark-unmarked-files regexp nil nil 'no-dir) + (setq count (dired-do-hide + dired-marker-char + (and (memq dired-omit-silent '(nil 0)) + (not dired-in-query) + "Omitted %d line%s."))) + (or dired-omit-silent dired-in-query + (message "(Nothing to omit)")))) + (save-excursion ;hide subdirs that were hidden + (mapcar (function (lambda (dir) + (if (dired-goto-subdir dir) + (dired-hide-subdir 1)))) + hidden-subdirs)) + count))) + +(defun dired-omit-unhide-region (beg end) + ;; Unhides hidden, but not marked files in the region. + (save-excursion + (save-restriction + (narrow-to-region beg end) + (goto-char (point-min)) + (while (search-forward "\r" nil t) + (and (char-equal (following-char) ?\ ) + (subst-char-in-region (1- (point)) (point) ?\r ?\n)))))) + +(defun dired-do-unhide (char &optional fmt marker) + ;; Unhides files marked with CHAR. Optional FMT is a message + ;; to be displayed. Note that after unhiding, we will need to re-hide + ;; files belonging to hidden subdirs. + (save-excursion + (goto-char (point-min)) + (let ((count 0) + (string (concat "\r" (char-to-string char))) + (hidden-subdirs (dired-remember-hidden)) + (new (if marker (concat "\n" (char-to-string marker)) "\n ")) + buffer-read-only) + (while (search-forward string nil t) + (replace-match new) + (setq count (1+ count))) + (or (equal "" fmt) + (message (or fmt "Unhid %d line%s.") count (dired-plural-s count))) + (goto-char (point-min)) + (mapcar (function (lambda (dir) + (if (dired-goto-subdir dir) + (dired-hide-subdir 1 t)))) + hidden-subdirs) + (if marker (dired-update-mode-line-modified t)) + count))) + +(defun dired-do-hide (char &optional fmt) + ;; Hides files marked with CHAR. Otional FMT is a message + ;; to be displayed. FMT is a format string taking args the number + ;; of hidden file lines, and dired-plural-s. + (save-excursion + (goto-char (point-min)) + (let ((count 0) + (string (concat "\n" (char-to-string char))) + buffer-read-only) + (while (search-forward string nil t) + (subst-char-in-region (match-beginning 0) + (1+ (match-beginning 0)) ?\n ?\r t) + (setq count (1+ count))) + (if fmt + (message fmt count (dired-plural-s count))) + count))) + +(defun dired-omit-regexp () + (let (rgxp) + (if dired-omit-extensions + (setq rgxp (concat + ".\\(" + (mapconcat 'regexp-quote dired-omit-extensions "\\|") + "\\)$"))) + (if dired-omit-regexps + (setq rgxp + (concat + rgxp + (and rgxp "\\|") + (mapconcat 'identity dired-omit-regexps "\\|")))) + rgxp)) + +(defun dired-mark-unmarked-files (regexp msg &optional unflag-p localp) + ;; Marks unmarked files matching REGEXP, displaying MSG. + ;; REGEXP is matched against the complete pathname, unless localp is + ;; specified. + ;; Does not re-mark files which already have a mark. + ;; Returns t if any work was done, nil otherwise. + (let ((dired-marker-char (if unflag-p ?\ dired-marker-char)) + fn) + (dired-mark-if + (and + ;; not already marked + (eq (following-char) ?\ ) + ;; uninteresting + (setq fn (dired-get-filename localp t)) + (string-match regexp fn)) + msg))) + +(defun dired-add-omit-regexp (rgxp &optional how) + "Adds a new regular expression to the list of omit regular expresions. +With a non-zero numeric prefix argument, deletes a regular expresion from +the list. + +With a prefix argument \\[universal-argument], adds a new extension to +the list of file name extensions omitted. +With a prefix argument \\[universal-argument] \\[universal-argument], deletes +a file name extension from the list. + +With a prefix 0, reports on the current omit regular expressions and +extensions." + (interactive + (list + (cond + ((null current-prefix-arg) + (read-string "New omit regular expression: ")) + ((equal '(4) current-prefix-arg) + (read-string "New omit extension (\".\" is not implicit): ")) + ((equal '(16) current-prefix-arg) + (completing-read + "Remove from omit extensions (type SPACE for options): " + (mapcar 'list dired-omit-extensions) nil t)) + ((eq 0 current-prefix-arg) + nil) + (t + (completing-read + "Remove from omit regexps (type SPACE for options): " + (mapcar 'list dired-omit-regexps) nil t))) + current-prefix-arg)) + (let (remove) + (cond + ((null how) + (if (member rgxp dired-omit-regexps) + (progn + (describe-variable 'dired-omit-regexps) + (error "%s is already included in the list." rgxp)) + (setq dired-omit-regexps (cons rgxp dired-omit-regexps)))) + ((equal how '(4)) + (if (member rgxp dired-omit-extensions) + (progn + (describe-variable 'dired-omit-extensions) + (error "%s is already included in list." rgxp)) + (setq dired-omit-extensions (cons rgxp dired-omit-extensions)))) + ((equal how '(16)) + (let ((tail (member rgxp dired-omit-extensions))) + (if tail + (setq dired-omit-extensions + (delq (car tail) dired-omit-extensions) + remove t) + (setq remove 'ignore)))) + ((eq 0 how) + (setq remove 'ignore) + (if (featurep 'ehelp) + (with-electric-help + (function + (lambda () + (princ "Omit extensions (dired-omit-extensions ):\n") + (dired-format-columns-of-files dired-omit-extensions) + (princ "\n") + (princ "Omit regular expressions (dired-omit-regexps ):\n") + (dired-format-columns-of-files dired-omit-regexps) + nil))) + (with-output-to-temp-buffer "*Help*" + (princ "Omit extensions (dired-omit-extensions ):\n") + (dired-format-columns-of-files dired-omit-extensions) + (princ "\n") + (princ "Omit regular expressions (dired-omit-regexps ):\n") + (dired-format-columns-of-files dired-omit-regexps) + (print-help-return-message)))) + (t + (let ((tail (member rgxp dired-omit-regexps))) + (if tail + (setq dired-omit-regexps (delq (car tail) dired-omit-regexps) + remove t) + (setq remove 'ignore))))) + (or (eq remove 'ignore) + (save-excursion + (mapcar + (function + (lambda (dir) + (if (dired-goto-subdir dir) + (progn + (if remove + (save-restriction + (narrow-to-region + (dired-subdir-min) (dired-subdir-max)) + (dired-do-unhide dired-omit-marker-char ""))) + (dired-omit-expunge))))) + (dired-remember-omitted)))))) + + + +;;;; ---------------------------------------------------------------- +;;;; Directory hiding. +;;;; ---------------------------------------------------------------- +;;; +;;; To indicate a hidden subdir, we actually insert "..." in the buffer. +;;; Aside from giving the look of ellipses (even though +;;; selective-display-ellipses is nil), it allows us to tell the difference +;;; between a dir with a single omitted file, and a hidden subdir with one +;;; file. + +(defun dired-subdir-hidden-p (dir) + (save-excursion + (and selective-display + (dired-goto-subdir dir) + (looking-at "\\.\\.\\.\r")))) + +(defun dired-unhide-subdir () + (let (buffer-read-only) + (goto-char (dired-subdir-min)) + (skip-chars-forward "^\n\r") + (skip-chars-backward "." (- (point) 3)) + (if (looking-at "\\.\\.\\.\r") (delete-char 4)) + (dired-omit-unhide-region (point) (dired-subdir-max)))) + +(defun dired-hide-check () + (or selective-display + (error "selective-display must be t for subdir hiding to work!"))) + +(defun dired-hide-subdir (arg &optional really) + "Hide or unhide the current subdirectory and move to next directory. +Optional prefix arg is a repeat factor. +Use \\[dired-hide-all] to (un)hide all directories. +With the optional argument REALLY, we always hide +the subdir, regardless of dired-subdir-hidden-p." + ;; The arg REALLY is needed because when we unhide + ;; omitted files in a hidden subdir, we want to + ;; re-hide the subdir, regardless of whether dired + ;; thinks it's already hidden. + (interactive "p") + (dired-hide-check) + (dired-save-excursion + (while (>= (setq arg (1- arg)) 0) + (let* ((cur-dir (dired-current-directory)) + (hidden-p (and (null really) + (dired-subdir-hidden-p cur-dir))) + (elt (assoc cur-dir dired-subdir-alist)) + (end-pos (1- (dired-get-subdir-max elt))) + buffer-read-only) + ;; keep header line visible, hide rest + (goto-char (dired-get-subdir-min elt)) + (skip-chars-forward "^\n\r") + (skip-chars-backward "." (- (point) 3)) + (if hidden-p + (progn + (if (looking-at "\\.\\.\\.\r") + (progn + (delete-char 3) + (setq end-pos (- end-pos 3)))) + (dired-omit-unhide-region (point) end-pos)) + (if (looking-at "\\.\\.\\.\r") + (goto-char (match-end 0)) + (insert "...") + (setq end-pos (+ end-pos 3))) + (subst-char-in-region (point) end-pos ?\n ?\r))) + (dired-next-subdir 1 t)))) + +(defun dired-hide-all (arg) + "Hide all subdirectories, leaving only their header lines. +If there is already something hidden, make everything visible again. +Use \\[dired-hide-subdir] to (un)hide a particular subdirectory." + (interactive "P") + (dired-hide-check) + (let (buffer-read-only) + (dired-save-excursion + (if (let ((alist dired-subdir-alist) + (hidden nil)) + (while (and alist (null hidden)) + (setq hidden (dired-subdir-hidden-p (car (car alist))) + alist (cdr alist))) + hidden) + ;; unhide + (let ((alist dired-subdir-alist)) + (while alist + (goto-char (dired-get-subdir-min (car alist))) + (skip-chars-forward "^\n\r") + (delete-region (point) (progn (skip-chars-backward ".") (point))) + (setq alist (cdr alist))) + (dired-omit-unhide-region (point-min) (point-max))) + ;; hide + (let ((alist dired-subdir-alist)) + (while alist + (dired-goto-subdir (car (car alist))) + (dired-hide-subdir 1 t) + (setq alist (cdr alist)))))))) + + +;;;; ----------------------------------------------------------------- +;;;; Automatic dired buffer maintenance. +;;;; ----------------------------------------------------------------- +;;; +;;; Keeping Dired buffers in sync with the filesystem and with each +;;; other. +;;; When used with efs on remote directories, buffer maintainence is +;;; done asynch. + +(defun dired-buffers-for-dir (dir-or-list &optional check-wildcard) +;; Return a list of buffers that dired DIR-OR-LIST +;; (top level or in-situ subdir). +;; The list is in reverse order of buffer creation, most recent last. +;; As a side effect, killed dired buffers for DIR are removed from +;; dired-buffers. If DIR-OR-LIST is a wildcard or list, returns any +;; dired buffers for which DIR-OR-LIST is equal to `dired-directory'. +;; If check-wildcard is non-nil, only returns buffers which contain dir-or-list +;; exactly, including the wildcard part. + (let ((alist dired-buffers) + (as-dir (and (stringp dir-or-list) + (file-name-as-directory dir-or-list))) + result buff elt) + (while alist + (setq buff (cdr (setq elt (car alist))) + alist (cdr alist)) + ;; dired-in-this-tree is not fast. It doesn't pay to use this to check + ;; whether the buffer is a good candidate. + (if (buffer-name buff) + (save-excursion + (set-buffer buff) + (if (or (equal dir-or-list dired-directory) ; the wildcard case. + (and as-dir + (not (and check-wildcard + (string-equal + as-dir + (expand-file-name default-directory)))) + (assoc as-dir dired-subdir-alist))) + (setq result (cons buff result)))) + ;; else buffer is killed - clean up: + (setq dired-buffers (delq elt dired-buffers)))) + (or dired-buffers (dired-remove-from-file-name-handler-alist)) + result)) + +(defun dired-advertise () + ;; Advertise in variable `dired-buffers' that we dired `default-directory'. + ;; With wildcards we actually advertise too much. + ;; Also makes sure that we are installed in the file-name-handler-alist + (prog1 + (let ((ddir (expand-file-name default-directory))) + (if (memq (current-buffer) (dired-buffers-for-dir ddir)) + t ; we have already advertised ourselves + (setq dired-buffers + (cons (cons ddir (current-buffer)) + dired-buffers)))) + ;; Do this last, otherwise the call to dired-buffers-for-dir will + ;; remove dired-handler-fn from the file-name-handler-alist. + ;; Strictly speaking, we only need to do this in th else branch of + ;; the if statement. We do it unconditionally as a sanity check. + (dired-check-file-name-handler-alist))) + +(defun dired-unadvertise (dir) + ;; Remove DIR from the buffer alist in variable dired-buffers. + ;; This has the effect of removing any buffer whose main directory is DIR. + ;; It does not affect buffers in which DIR is a subdir. + ;; Removing is also done as a side-effect in dired-buffer-for-dir. + (setq dired-buffers + (delq (assoc dir dired-buffers) dired-buffers)) + ;; If there are no more dired buffers, we are no longer needed in the + ;; file-name-handler-alist. + (or dired-buffers (dired-remove-from-file-name-handler-alist))) + +(defun dired-unadvertise-current-buffer () + ;; Remove all references to the current buffer in dired-buffers. + (setq dired-buffers + (delq nil + (mapcar + (function + (lambda (x) + (and (not (eq (current-buffer) (cdr x))) x))) + dired-buffers)))) + +(defun dired-fun-in-all-buffers (directory fun &rest args) + ;; In all buffers dired'ing DIRECTORY, run FUN with ARGS. + ;; Return list of buffers where FUN succeeded (i.e., returned non-nil). + (let* ((buf-list (dired-buffers-for-dir directory)) + (obuf (current-buffer)) + (owin (selected-window)) + (win owin) + buf windows success-list) + (if buf-list + (unwind-protect + (progn + (while (not (eq (setq win (next-window win)) owin)) + (and (memq (setq buf (window-buffer win)) buf-list) + (progn + (set-buffer buf) + (= (point) (window-point win))) + (setq windows (cons win windows)))) + (while buf-list + (setq buf (car buf-list) + buf-list (cdr buf-list)) + (set-buffer buf) + (if (apply fun args) + (setq success-list (cons (buffer-name buf) success-list)))) + ;; dired-save-excursion prevents lossage of save-excursion + ;; for point. However, if dired buffers are displayed in + ;; other windows, the setting of window-point loses, and + ;; drags the point with it. This should fix this. + (while windows + (condition-case nil + (progn + (set-buffer (window-buffer (setq win (car windows)))) + (set-window-point win (point))) + (error nil)) + (setq windows (cdr windows)))) + (set-buffer obuf))) + success-list)) + +(defun dired-find-file-place (subdir file) + ;; Finds a position to insert in SUBDIR FILE. If it can't find SUBDIR, + ;; returns nil. + (let ((sort (dired-sort-type dired-internal-switches)) + (rev (memq ?r (nth 3 (assoc subdir dired-subdir-alist))))) + (cond + ((eq sort 'name) + (if (dired-goto-subdir subdir) + (let ((max (dired-subdir-max)) + start end found) + (if (dired-goto-next-file) + (progn + (skip-chars-forward "^\n\r") + (setq start (point)) + (goto-char (setq end max)) + (forward-char -1) + (skip-chars-backward "^\n\r") + ;; This loop must find a file. At the very least, it will + ;; find the one found previously. + (while (not found) + (if (save-excursion (dired-move-to-filename nil (point))) + (setq found t) + (setq end (point)) + (forward-char -1) + (skip-chars-backward "^\n\r"))) + (if rev + (while (< start end) + (goto-char (/ (+ start end) 2)) + (if (dired-file-name-lessp + (or (dired-get-filename 'no-dir t) + (error + "Error in dired-find-file-place")) + file) + (setq end (progn + (skip-chars-backward "^\n\r") + (point))) + (setq start (progn + (skip-chars-forward "^\n\r") + (forward-char 1) + (skip-chars-forward "^\n\r") + (point))))) + (while (< start end) + (goto-char (/ (+ start end) 2)) + (if (dired-file-name-lessp + file + (or (dired-get-filename 'no-dir t) + (error + "Error in dired-find-file-place"))) + (setq end (progn + (skip-chars-backward "^\n\r") + (point))) + (setq start (progn + (skip-chars-forward "^\n\r") + (forward-char 1) + (skip-chars-forward "^\n\r") + (point)))))) + (goto-char end)) + (goto-char max)) + t))) + ((eq sort 'date) + (if (dired-goto-subdir subdir) + (if rev + (goto-char (dired-subdir-max)) + (dired-goto-next-file) + t))) + ;; Put in support for other sorting types. + (t + (if (string-equal (dired-current-directory) subdir) + (progn + ;; We are already where we should be, except when + ;; point is before the subdir line or its total line. + (or (save-excursion (beginning-of-line) (dired-move-to-filename)) + (dired-goto-next-nontrivial-file)) ; in the header somewhere + t) ; return t, for found. + (if (dired-goto-subdir subdir) + (progn + (dired-goto-next-nontrivial-file) + t))))))) + +(defun dired-add-entry (filename &optional marker-char inplace) + ;; Add a new entry for FILENAME, optionally marking it + ;; with MARKER-CHAR (a character, else dired-marker-char is used). + ;; Hidden subdirs are exposed if a file is added there. + ;; + ;; This function now adds the new entry at the END of the previous line, + ;; not the beginning of the current line. + ;; Logically, we now think of the `newline' associated + ;; with a fileline, as the one at the beginning of the line, not the end. + ;; This makes it easier to keep track of omitted files. + ;; + ;; Uses dired-save-excursion, so that it doesn't move the + ;; point around. Especially important when it runs asynch. + ;; + ;; If there is already an entry, delete the existing one before adding a + ;; new one. In this case, doesn't remember its mark. Use + ;; dired-update-file-line for that. + ;; + ;; If INPLACE eq 'relist, then the new entry is put in the + ;; same place as the old, if there was an old entry. + ;; If INPLACE is t, then the file entry is put on the line + ;; currently containing the point. Otherwise, dired-find-file-place + ;; attempts to determine where to put the file. + + (setq filename (directory-file-name filename)) + (dired-save-excursion + (let ((oentry (save-excursion (dired-goto-file filename))) + (directory (file-name-directory filename)) + (file-nodir (file-name-nondirectory filename)) + buffer-read-only) + (if oentry + ;; Remove old entry + (let ((opoint (point))) + (goto-char oentry) + (delete-region (save-excursion + (skip-chars-backward "^\r\n") + (dired-update-marker-counters (following-char) t) + (1- (point))) + (progn + (skip-chars-forward "^\r\n") + (point))) + ;; Move to right place to replace deleted line. + (cond ((eq inplace 'relist) (forward-char 1)) + ((eq inplace t) (goto-char opoint))) + (dired-update-mode-line-modified))) + (if (or (eq inplace t) + (and oentry (eq inplace 'relist)) + ;; Tries to move the point to the right place. + ;; Returns t on success. + (dired-find-file-place directory file-nodir)) + (let ((switches (dired-make-switches-string + (cons ?d dired-internal-switches))) + b-of-l) + ;; Bind marker-char now, in case we are working asynch and + ;; dired-marker-char changes in the meantime. + (if (and marker-char (not (integerp marker-char))) + (setq marker-char dired-marker-char)) + ;; since we insert at the end of a line, + ;; backup to the end of the previous line. + (skip-chars-backward "^\n\r") + (forward-char -1) + (setq b-of-l (point)) + (if (and (featurep 'efs-dired) efs-dired-host-type) + ;; insert asynch + ;; we call the efs version explicitly here, + ;; rather than let the handler-alist work for us + ;; because we want to pass extra args. + ;; Is there a cleaner way to do this? + (efs-insert-directory filename ; don't expand `.' ! + switches nil nil + t ; nowait + marker-char) + (let ((insert-directory-program dired-ls-program)) + (insert-directory filename switches nil nil)) + (dired-after-add-entry b-of-l marker-char)) + (if dired-verify-modtimes + (dired-set-file-modtime directory dired-subdir-alist)) + t))))) ; return t on success, else nil. + +(defun dired-after-add-entry (start marker-char) + ;; Does the cleanup of a dired entry after listing it. + ;; START is the start of the new listing-line. + ;; This is a separate function for the sake of efs. + (save-excursion + (goto-char start) + ;; we make sure that the new line is bracketted by new-lines + ;; so the user doesn't need to use voodoo in the + ;; after-readin-hook. + (insert ?\n) + (dired-add-entry-do-indentation marker-char) + (let* ((beg (dired-manual-move-to-filename t)) + ;; error for strange output + (end (dired-manual-move-to-end-of-filename)) + (filename (buffer-substring beg end))) + ;; We want to have the non-directory part only. + (delete-region beg end) + ;; Any markers pointing to the beginning of the filename, will + ;; still point there after this insertion. Should keep + ;; save-excursion from losing. + (setq beg (point)) + (insert (file-name-nondirectory filename)) + (dired-insert-set-properties beg (point)) + (dired-move-to-filename)) + ;; The subdir-alist is not affected so we can run it right now. + (let ((omit (dired-current-subdir-omitted-p)) + (hide (dired-subdir-hidden-p (dired-current-directory)))) + (if (or dired-after-readin-hook omit hide) + (save-excursion + (save-restriction + ;; Use start so that we get the new-line at + ;; the beginning of the line in case we want + ;; to hide the file. Don't need to test (bobp) + ;; here, since we never add a file at + ;; the beginning of the buffer. + (narrow-to-region start + (save-excursion (forward-line 1) (point))) + (run-hooks 'dired-after-readin-hook) + (if omit + (let ((dired-omit-silent (or dired-omit-silent 0))) + (dired-omit-region (point-min) (point-max) + (dired-omit-regexp)))) + (if hide + (subst-char-in-region (point-min) (1- (point-max)) + ?\n ?\r)))))) + ;; clobber the extra newline at the end of the line + (end-of-line) + (delete-char 1))) + +;; This is a separate function for the sake of nested dired format. +(defun dired-add-entry-do-indentation (marker-char) + ;; two spaces or a marker plus a space: + (insert (if marker-char + (let ((char (if (integerp marker-char) + marker-char + dired-marker-char))) + (dired-update-marker-counters char) + (dired-update-mode-line-modified) + char) + ?\040) + ?\040)) + +(defun dired-remove-file (file) + (let ((alist dired-buffers) + buff) + (save-excursion + (while alist + (setq buff (cdr (car alist))) + (if (buffer-name buff) + (progn + (set-buffer buff) + (dired-remove-entry file)) + (setq dired-buffers (delq (car alist) dired-buffers))) + (setq alist (cdr alist)))) + (or dired-buffers (dired-remove-from-file-name-handler-alist)))) + +(defun dired-remove-entry (file) + (let ((ddir (expand-file-name default-directory)) + (dirname (file-name-as-directory file))) + (if (dired-in-this-tree ddir dirname) + (if (or (memq 'kill-dired-buffer dired-no-confirm) + (y-or-n-p (format "Kill dired buffer %s for %s, too? " + (buffer-name) dired-directory))) + (kill-buffer (current-buffer))) + (if (dired-in-this-tree file ddir) + (let ((alist dired-subdir-alist)) + (while alist + (if (dired-in-this-tree (car (car alist)) dirname) + (save-excursion + (goto-char (dired-get-subdir-min (car alist))) + (dired-kill-subdir))) + (setq alist (cdr alist))) + (dired-save-excursion + (and (dired-goto-file file) + (let (buffer-read-only) + (delete-region + (progn (skip-chars-backward "^\n\r") + (or (memq (following-char) '(\n \r ?\ )) + (progn + (dired-update-marker-counters + (following-char) t) + (dired-update-mode-line-modified))) + (1- (point))) + (progn (skip-chars-forward "^\n\r") (point))) + (if dired-verify-modtimes + (dired-set-file-modtime + (file-name-directory (directory-file-name file)) + dired-subdir-alist)))))))))) + +(defun dired-add-file (filename &optional marker-char) + (dired-fun-in-all-buffers + (file-name-directory filename) + (function dired-add-entry) filename marker-char)) + +(defun dired-relist-file (file) + (dired-uncache file nil) + (dired-fun-in-all-buffers (file-name-directory file) + (function dired-relist-entry) file)) + +(defun dired-relist-entry (file) + ;; Relist the line for FILE, or just add it if it did not exist. + ;; FILE must be an absolute pathname. + (let* ((file (directory-file-name file)) + (directory (file-name-directory file)) + (dd (expand-file-name default-directory))) + (if (assoc directory dired-subdir-alist) + (if (or + ;; Not a wildcard + (equal dd dired-directory) + ;; Not top-level + (not (string-equal directory dd)) + (and (string-equal directory + (if (consp dired-directory) + (file-name-as-directory + (car dired-directory)) + (file-name-directory dired-directory))) + (dired-file-in-wildcard-p dired-directory file))) + (let ((marker (save-excursion + (and (dired-goto-file file) + (dired-file-marker file))))) + ;; recompute omission + (if (eq marker dired-omit-marker-char) + (setq marker nil)) + (dired-add-entry file marker 'relist)) + ;; At least tell dired that we considered updating the buffer. + (if dired-verify-modtimes + (dired-set-file-modtime directory dired-subdir-alist)))))) + +(defun dired-file-in-wildcard-p (wildcard file) + ;; Return t if a file is part of the listing for wildcard. + ;; File should be the non-directory part only. + ;; This version is slow, but meticulously correct. Is it worth it? + (if (consp wildcard) + (let ((files (cdr wildcard)) + (dir (car wildcard)) + yep) + (while (and files (not yep)) + (setq yep (string-equal file (expand-file-name (car files) dir)) + files (cdr files))) + yep) + (let ((err-buff + (let ((default-major-mode 'fundamental-mode)) + (get-buffer-create " *dired-check-process output*"))) + (dir default-directory) + (process-connection-type nil)) + (save-excursion + (set-buffer err-buff) + (erase-buffer) + (setq default-directory dir) + (call-process shell-file-name nil t nil "-c" + (concat dired-ls-program " -d " wildcard " | " + "egrep '(^|/)" file "$'")) + (/= (buffer-size) 0))))) + +;; The difference between dired-add-file and dired-relist-file is that +;; the former creates the entry with a specific marker. The later preserves +;; existing markers on a per buffer basis. This is not the same as +;; giving dired-create-files a marker of t, which uses a marker in a specific +;; buffer to determine the marker for file line creation in all buffers. + + +;;;; ---------------------------------------------------------------- +;;;; Applying Lisp functions to marked files. +;;;; ---------------------------------------------------------------- + +;;; Running tags commands on marked files. +;; +;; Written 8/30/93 by Roland McGrath . +;; Requires tags.el as distributed with GNU Emacs 19.23, or later. + +(defun dired-do-tags-search (regexp) + "Search through all marked files for a match for REGEXP. +Stops when a match is found. +To continue searching for next match, use command \\[tags-loop-continue]." + (interactive "sSearch marked files (regexp): ") + (tags-search regexp '(dired-get-marked-files))) + +(defun dired-do-tags-query-replace (from to &optional delimited) + "Query-replace-regexp FROM with TO through all marked files. +Third arg DELIMITED (prefix arg) means replace only word-delimited matches. +If you exit (\\[keyboard-quit] or ESC), you can resume the query-replace +with the command \\[tags-loop-continue]." + (interactive + "sQuery replace in marked files (regexp): \nsQuery replace %s by: \nP") + (tags-query-replace from to delimited '(dired-get-marked-files))) + +;;; byte compiling + +(defun dired-byte-compile () + ;; Return nil for success, offending file name else. + (let* ((filename (dired-get-filename)) + buffer-read-only failure) + (condition-case err + (save-excursion (byte-compile-file filename)) + (error + (setq failure err))) + ;; We should not need to update any file lines, as this will have + ;; already been done by after-write-region-hook. + (and failure + (progn + (dired-log (buffer-name (current-buffer)) + "Byte compile error for %s:\n%s\n" filename failure) + (dired-make-relative filename))))) + +(defun dired-do-byte-compile (&optional arg) + "Byte compile marked (or next ARG) Emacs lisp files." + (interactive "P") + (dired-map-over-marks-check (function dired-byte-compile) arg + 'byte-compile "byte-compile" t)) + +;;; loading + +(defun dired-load () + ;; Return nil for success, offending file name else. + (let ((file (dired-get-filename)) failure) + (condition-case err + (load file nil nil t) + (error (setq failure err))) + (if (not failure) + nil + (dired-log (buffer-name (current-buffer)) + "Load error for %s:\n%s\n" file failure) + (dired-make-relative file)))) + +(defun dired-do-load (&optional arg) + "Load the marked (or next ARG) Emacs lisp files." + (interactive "P") + (dired-map-over-marks-check (function dired-load) arg 'load "load" t)) + + +;;;; ---------------------------------------------------------------- +;;;; File Name Handler Alist +;;;; ---------------------------------------------------------------- +;;; +;;; Make sure that I/O functions maintain dired buffers. + +(defun dired-remove-from-file-name-handler-alist () + ;; Remove dired from the file-name-handler-alist + (setq file-name-handler-alist + (delq nil + (mapcar + (function + (lambda (x) + (and (not (eq (cdr x) 'dired-handler-fn)) + x))) + file-name-handler-alist)))) + +(defun dired-check-file-name-handler-alist () + ;; Verify that dired is installed as the first item in the alist + (or (eq (cdr (car file-name-handler-alist)) 'dired-handler-fn) + (setq file-name-handler-alist + (cons + '("." . dired-handler-fn) + (dired-remove-from-file-name-handler-alist))))) + +(defun dired-handler-fn (op &rest args) + ;; Function to update dired buffers after I/O. + (prog1 + (let ((inhibit-file-name-handlers + (cons 'dired-handler-fn + (and (eq inhibit-file-name-operation op) + inhibit-file-name-handlers))) + (inhibit-file-name-operation op)) + (apply op args)) + (let ((dired-omit-silent t) + (hf (get op 'dired))) + (and hf (funcall hf args))))) + +(defun dired-handler-fn-1 (args) + (let ((to (expand-file-name (nth 1 args)))) + (or (member to dired-unhandle-add-files) + (dired-relist-file to)))) + +(defun dired-handler-fn-2 (args) + (let ((from (expand-file-name (car args))) + (to (expand-file-name (nth 1 args)))) + ;; Don't remove the original entry if making backups. + ;; Otherwise we lose marks. I'm not completely happy with the + ;; logic here. + (or (and + (eq (nth 2 args) t) ; backups always have OK-IF-OVERWRITE t + (string-equal (car (find-backup-file-name from)) to)) + (dired-remove-file from)) + (or (member to dired-unhandle-add-files) + (dired-relist-file to)))) + +(defun dired-handler-fn-3 (args) + (let ((to (expand-file-name (nth 2 args)))) + (or (member to dired-unhandle-add-files) + (dired-relist-file to)))) + +(defun dired-handler-fn-4 (args) + (dired-remove-file (expand-file-name (car args)))) + +(defun dired-handler-fn-5 (args) + (let ((to (expand-file-name (car args)))) + (or (member to dired-unhandle-add-files) + (dired-relist-file to)))) + +(defun dired-handler-fn-6 (args) + (let ((to (expand-file-name (nth 1 args))) + (old (expand-file-name (car args)))) + (or (member to dired-unhandle-add-files) + (dired-relist-file to)) + (dired-relist-file old))) + +(put 'copy-file 'dired 'dired-handler-fn-1) +(put 'dired-make-relative-symlink 'dired 'dired-handler-fn-1) +(put 'make-symbolic-link 'dired 'dired-handler-fn-1) +(put 'add-name-to-file 'dired 'dired-handler-fn-6) +(put 'rename-file 'dired 'dired-handler-fn-2) +(put 'write-region 'dired 'dired-handler-fn-3) +(put 'delete-file 'dired 'dired-handler-fn-4) +(put 'delete-directory 'dired 'dired-handler-fn-4) +(put 'dired-recursive-delete-directory 'dired 'dired-handler-fn-4) +(put 'make-directory-internal 'dired 'dired-handler-fn-5) +(put 'set-file-modes 'dired 'dired-handler-fn-5) + +;;;; ------------------------------------------------------------ +;;;; Autoload land. +;;;; ------------------------------------------------------------ + +;;; Reading mail (dired-xy) + +(autoload 'dired-read-mail "dired-xy" + "Reads the current file as a mail folder." t) +(autoload 'dired-vm "dired-xy" "Run VM on this file." t) +(autoload 'dired-rmail "dired-xy" "Run RMAIL on this file." t) + +;;; Virtual dired (dired-vir) + +(autoload 'dired-virtual "dired-vir" + "Put this buffer into virtual dired mode." t) + +;;; Grep (dired-grep) + +(autoload 'dired-do-grep "dired-grep" "Grep marked files for a pattern." t) + +;;; Doing diffs (dired-diff) + +(autoload 'dired-diff "dired-diff" + "Compare file at point with FILE using `diff'." t) +(autoload 'dired-backup-diff "dired-diff" + "Diff this file with its backup file or vice versa." t) +(autoload 'dired-emerge "dired-diff" + "Merge file at point with FILE using `emerge'." t) +(autoload 'dired-emerge-with-ancestor "dired-diff" + "Merge file at point with FILE, using a common ANCESTOR file." t) +(autoload 'dired-ediff "dired-diff" "Ediff file at point with FILE." t) +(autoload 'dired-epatch "dired-diff" "Patch file at point using `epatch'." t) + +;;; Shell commands (dired-shell) + +(autoload 'dired-do-print "dired-shell" "Print the marked (next ARG) files." t) +(autoload 'dired-run-shell-command "dired-shell" nil) +(autoload 'dired-do-shell-command "dired-shell" + "Run a shell command on the marked (or next ARG) files." t) +(autoload 'dired-do-background-shell-command "dired-shell" + "Run a background shell command on marked (or next ARG) files." t) + +;;; Commands using regular expressions (dired-rgxp) + +(autoload 'dired-mark-files-regexp "dired-rgxp" + "Mark all files whose names match REGEXP." t) +(autoload 'dired-flag-files-regexp "dired-rgxp" + "Flag for deletion all files whose names match REGEXP." t) +(autoload 'dired-mark-extension "dired-rgxp" + "Mark all files whose names have a given extension." t) +(autoload 'dired-flag-extension "dired-rgxp" + "Flag for deletion all files whose names have a given extension." t) +(autoload 'dired-cleanup "dired-rgxp" + "Flag for deletion dispensable files files created by PROGRAM." t) +(autoload 'dired-do-rename-regexp "dired-rgxp" + "Rename marked files whose names match a given regexp." t) +(autoload 'dired-do-copy-regexp "dired-rgxp" + "Copy marked files whose names match a given regexp." t) +(autoload 'dired-do-hardlink-regexp "dired-rgxp" + "Hardlink all marked files whose names match a regexp." t) +(autoload 'dired-do-symlink "dired-rgxp" + "Make a symbolic link to all files whose names match a regexp." t) +(autoload + 'dired-do-relsymlink-regexp "dired-rgxp" + "Make a relative symbolic link to all files whose names match a regexp." t) +(autoload 'dired-upcase "dired-rgxp" + "Rename all marked (or next ARG) files to upper case." t) +(autoload 'dired-downcase "dired-rgxp" + "Rename all marked (or next ARG) files to lower case." t) + +;;; Marking files from other buffers (dired-mob) + +(autoload 'dired-mark-files-from-other-dired-buffer "dired-mob" + "Mark files which are marked in another dired buffer." t) +(autoload 'dired-mark-files-compilation-buffer "dired-mob" + "Mark the files mentioned in the compilation buffer." t) + +;;; uuencoding (dired-uu) + +(autoload 'dired-do-uucode "dired-uu" "Uuencode or uudecode marked files." t) + +;;; Compressing (dired-cmpr) + +(autoload 'dired-do-compress "dired-cmpr" + "Compress or uncompress marked files." t) +(autoload 'dired-compress-subdir-files "dired-cmpr" + "Compress uncompressed files in the current subdirectory." t) + + +;;; Marking files according to sexps + +(autoload 'dired-mark-sexp "dired-sex" + "Mark files according to an sexpression." t) + +;;; Help! + +(autoload 'dired-summary "dired-help" + "Display summary of basic dired commands in the minibuffer." t) +(autoload 'dired-describe-mode "dired-help" + "Detailed description of dired mode. +With a prefix, runs the info documentation browser for dired." t) +(autoload 'dired-apropos "dired-help" + "Do command apropos help for dired commands. +With prefix does apropos help for dired variables." t) +(autoload 'dired-report-bug "dired-help" "Report a bug for dired." t) + +;;;; -------------------------------------------------------------- +;;;; Multi-flavour Emacs support +;;;; -------------------------------------------------------------- + +(let ((lucid-p (string-match "Lucid" emacs-version)) + ver) + (or (string-match "^\\([0-9]+\\)\\." emacs-version) + (error "Weird emacs version %s" emacs-version)) + (setq ver (string-to-int (substring emacs-version (match-beginning 1) + (match-end 1)))) + + ;; Reading with history. + (if (>= ver 19) + + (defun dired-read-with-history (prompt initial history) + (read-from-minibuffer prompt initial nil nil history)) + + (defun dired-read-with-history (prompt initial history) + (let ((minibuffer-history-symbol history)) ; for gmhist + (read-string prompt initial)))) + + ;; Completing read with history. + (if (>= ver 19) + + (fset 'dired-completing-read 'completing-read) + + (defun dired-completing-read (prompt table &optional predicate + require-match initial-input history) + (let ((minibuffer-history-symbol history)) ; for gmhist + (completing-read prompt table predicate require-match + initial-input)))) + + ;; Abbreviating file names. + (if lucid-p + (fset 'dired-abbreviate-file-name + ;; Lemacs has this extra hack-homedir arg + (function + (lambda (fn) + (abbreviate-file-name fn t)))) + (fset 'dired-abbreviate-file-name 'abbreviate-file-name)) + + ;; Deleting directories + ;; Check for pre 19.8 versions of lucid emacs. + (if lucid-p + (or (fboundp 'delete-directory) + (fset 'delete-directory 'remove-directory))) + + ;; Minibuffers + (if (= ver 18) + + (defun dired-get-active-minibuffer-window () + (and (> (minibuffer-depth) 0) + (minibuffer-window))) + + (defun dired-get-active-minibuffer-window () + (let ((frames (frame-list)) + win found) + (while frames + (if (and (setq win (minibuffer-window (car frames))) + (minibuffer-window-active-p win)) + (setq found win + frames nil) + (setq frames (cdr frames)))) + found))) + + ;; Text properties and menus. + + (cond + (lucid-p + (require 'dired-xemacs)) + ((>= ver 19) + (require 'dired-fsf)) + (t + ;; text property stuff doesn't work in V18 + (fset 'dired-insert-set-properties 'ignore) + (fset 'dired-remove-text-properties 'ignore) + (fset 'dired-set-text-properties 'ignore) + (fset 'dired-move-to-filename 'dired-manual-move-to-filename) + (fset 'dired-move-to-end-of-filename + 'dired-manual-move-to-end-of-filename)))) + +;;; MULE + +(if (or (boundp 'MULE) (featurep 'mule)) (load "dired-mule")) + + +;; Run load hook for user customization. +(run-hooks 'dired-load-hook) + +;;; end of dired.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-auto.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-auto.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,51 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-auto.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Simple way of autoloading efs +;; Author: Andy Norman, Dawn +;; Created: Thu Sep 24 09:50:08 1992 +;; Modified: Sun Nov 27 11:45:28 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;; Provides a way of autoloading efs. To use this, just put +;;; (require 'efs-auto in your .emacs file. +;;; +;;; The Bad News: +;;; +;;; 1. Calls to load and require will not trigger efs to autoload. +;;; If you are want to put remote directories in your load path, +;;; you should require efs. +;;; 2. Because efs does not overload expand-file-name until it is loaded, +;;; "smart" expansion of file names on remote apollos running domain +;;; will not work yet. This means that accessing a file on a remote +;;; apollo may not correctly cause efs to autoload. This will depend +;;; the details of your command sequence. + +(provide 'efs-auto) +(require 'efs-ovwrt) +(require 'efs-fnh) + +(defconst efs-auto-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;; Interactive functions that should be accessible from here. + +(autoload 'efs-report-bug "efs-report" "Submit a bug report for efs." t) +(autoload + 'efs-set-passwd "efs-netrc" + "For a given HOST and USER, set or change the associated PASSWORD." t) +(autoload 'efs-nslookup-host "efs" + "Attempt to resolve a hostname using nslookup if possible." t) + +;;; end of efs-auto.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-cms-knet.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-cms-knet.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,245 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-cms-knet.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: CMS support for efs using KNET/VM server +;; Authors: Sandy Rutherford +;; Joerg-Martin Schwarz +;; Created: Wed Mar 23 14:39:00 1994 by schwarz on hal1 from efs-cms.el +;; Modified: Sun Nov 27 11:45:58 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(provide 'efs-cms-knet) +(require 'efs) + +(defconst efs-cms-knet-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;; ------------------------------------------------------------ +;;;; CMS support for KNET-VM server +;;;; ------------------------------------------------------------ + +;;; efs has full support, including tree dired support, for hosts running +;;; CMS. It should be able to automatically recognize any CMS machine. +;;; We would be grateful if you would report any failures to automatically +;;; recognize a CMS host as a bug. +;;; +;;; Filename syntax: +;;; +;;; KNET/VM Support (J. M. Schwarz, Mar 12, 1994): +;;; This code has been developed and tested with +;;; "KNET/VM FTP server Release 3.2.0" by Spartacus. +;;; +;;; This server uses not only a different listing format than the one used in +;;; efs-cms.el, but also handles minidisks differently. +;;; The cd command for changing minidisk is not supported, +;;; instead a full filename syntax "FILENAME.FILETYPE.FM" is used, where +;;; FM is the filemode. To access a file "PROFILE EXEC A0", efs uses a +;;; syntax "/cms-hostname:/A:/PROFILE.EXEC" (Note the ':') +;;; +;;; In this directory notation, "/A0:" is actually a subset of the "/A:" +;;; directory. + +(efs-defun efs-send-pwd cms-knet (host user &optional xpwd) + ;; cms-knet has no concept of current directory. + ;; Is it safe to always assume this is the user's home? + (cons "A" "")) + +(efs-defun efs-fix-path cms-knet (path &optional reverse) + ;; Convert PATH from UNIX-ish to CMS. If REVERSE is given, convert + ;; from CMS to UNIX. Actually, CMS doesn't have a full pathname syntax, + ;; so we fudge things by sending cd's. + (if reverse + ;; Since we only convert output from a pwd in this direction, + ;; this should never be applied, as PWD doesn't work for this server. + (concat "/" path "/") + (efs-save-match-data + (if (string-match "^/[A-Z]/\\([-A-Z0-9$_+@:]+\\.[-A-Z0-9$_+@:]+\\)$" + path) + (concat + (substring path (match-beginning 1) (match-end 1)) + "." + ;; minidisk + (substring path 1 2)) + (error "Invalid CMS-KNET filename"))))) + +(efs-defun efs-fix-dir-path cms-knet (dir-path) + ;; Convert path from UNIX-ish to CMS-KNET ready for a DIRectory listing. + (cond + ((string-equal "/" dir-path) + "*.*.*") + ((string-match + "^/[A-Z]/\\([-A-Z0-9$._+@:]+\\.[-A-Z0-9$._+@:]+\\)?$" + dir-path) + (concat + (if (match-beginning 1) + (substring dir-path (match-beginning 1) (match-end 1)) + "*") + "." + (substring dir-path 1 2))) + (t (error "Invalid CMS-KNET pathname")))) + +(defconst efs-cms-knet-file-name-regexp + (concat + "^ *\\([-A-Z0-9$_+@:]+\\) +\\([-A-Z0-9$_+@:]+\\) +" + "\\([A-Z]\\)[0-9] +[VF] +[0-9]+ ")) + +(efs-defun efs-parse-listing cms-knet + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a CMS directory listing. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a full remote path + ;; PATH = directory as a full efs-path + (let ((tbl (efs-make-hashtable))) + (goto-char (point-min)) + (efs-save-match-data + (if (string-equal dir "/") + (let ((case-fold (memq 'cms-knet efs-case-insensitive-host-types)) + tbl-alist md md-tbl) + (while (re-search-forward efs-cms-knet-file-name-regexp nil t) + (setq md (buffer-substring (match-beginning 3) (match-end 3)) + md-tbl (or (cdr (assoc md tbl-alist)) + (let ((new-tbl (efs-make-hashtable))) + (setq tbl-alist + (cons (cons md new-tbl) + tbl-alist)) + new-tbl))) + (efs-put-hash-entry md '(t) tbl) + (efs-put-hash-entry (concat + (buffer-substring (match-beginning 1) + (match-end 1)) + "." + (buffer-substring (match-beginning 2) + (match-end 2))) + '(nil) md-tbl) + (forward-line 1)) + (while tbl-alist + (setq md (car (car tbl-alist)) + md-tbl (cdr (car tbl-alist))) + (efs-put-hash-entry "." '(t) md-tbl) + (efs-put-hash-entry ".." '(t) md-tbl) + (efs-put-hash-entry (concat path md "/") md-tbl + efs-files-hashtable case-fold) + (setq tbl-alist (cdr tbl-alist)))) + (while (re-search-forward efs-cms-knet-file-name-regexp nil t) + (efs-put-hash-entry + (concat (buffer-substring (match-beginning 1) + (match-end 1)) + "." + (buffer-substring (match-beginning 2) + (match-end 2))) + '(nil) tbl) + (forward-line 1))) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl)) + tbl)) + +(efs-defun efs-allow-child-lookup cms-knet (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + + ;; CMS file system is flat. Only minidisks are "subdirs". + (string-equal "/" dir)) + +;;; Tree dired support: + +(defconst efs-dired-cms-re-exe + "^. +[-A-Z0-9$_+@:]+ +\\(EXEC\\|MODULE\\) " + "Regular expression to use to search for CMS executables.") + +(or (assq 'cms efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'cms-knet efs-dired-cms-re-exe) + efs-dired-re-exe-alist))) + +(efs-defun efs-dired-insert-headerline cms-knet (dir) + ;; CMS has no total line, so we insert a blank line for + ;; aesthetics. + (insert "\n") + (forward-char -1) + (efs-real-dired-insert-headerline dir)) + +(efs-defun efs-dired-manual-move-to-filename cms-knet + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line. + ;; This is the CMS version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r") + (setq bol (point))) + (if (re-search-forward efs-cms-knet-file-name-regexp eol t) + (goto-char (match-beginning 1)) + (if raise-error + (error "No file on this line.") + (goto-char bol))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename cms-knet + (&optional no-error bol eol) + ;; Assumes point is at beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; case-fold-search must be nil, at least for VMS. + ;; On failure, signals an error or returns nil. + ;; This is the CMS version. + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (if (looking-at "[-A-Z0-9$_+@:]+ +[-A-Z0-9$_+@:]+ +[A-Z][0-9] ") + (goto-char (- (match-end 0) 2)) ; return point + (if no-error + nil + (error "No file on this line.")))) + +(efs-defun efs-dired-get-filename cms-knet + (&optional localp no-error-if-not-filep) + (let ((name (efs-real-dired-get-filename 'no-dir no-error-if-not-filep))) + (and name + (if (string-match + "^\\([-A-Z0-9$_+@:]+\\) +\\([-A-Z0-9$_+@:]+\\) +\\([A-Z]\\)$" + name) + (let* ((dir (dired-current-directory)) + (rdir (nth 2 (efs-ftp-path dir)))) + (setq name (concat (substring name (match-beginning 1) + (match-end 1)) + "." + (substring name (match-beginning 2) + (match-end 2)))) + (if (string-equal rdir "/") + (setq name (concat (substring name (match-beginning 3) + (match-end 3)) "/" name))) + (if (eq localp 'no-dir) + name + (concat (if localp + (dired-current-directory localp) + dir) + name))) + (error "Strange CMS-KNET file name %s" name))))) + +;;; end of efs-cms-knet.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-cms.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-cms.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,462 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-cms.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: CMS support for efs +;; Author: Sandy Rutherford +;; Created: Fri Oct 23 08:52:00 1992 +;; Modified: Sun Nov 27 11:46:51 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(provide 'efs-cms) +(require 'efs) + +(defconst efs-cms-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;; ------------------------------------------------------------ +;;;; CMS support +;;;; ------------------------------------------------------------ + +;;; efs has full support, including tree dired support, for hosts running +;;; CMS. It should be able to automatically recognize any CMS machine. +;;; We would be grateful if you would report any failures to automatically +;;; recognize a CMS host as a bug. +;;; +;;; This should also work with CMS machines running SFS (Shared File System). +;;; +;;; Filename syntax: +;;; +;;; CMS filenames are entered in a UNIX-y way. In otherwords, minidisks are +;;; treated as UNIX directories. For example to access the file READ.ME in +;;; minidisk *.311 on cuvmb.cc.columbia.edu, you would enter +;;; /anonymous@cuvmb.cc.columbia.edu:/*.311/READ.ME +;;; If *.301 is the default minidisk for this account, you could access +;;; FOO.BAR on this minidisk as +;;; /anonymous@cuvmb.cc.columbia.edu:FOO.BAR +;;; CMS filenames are of the form FILE.TYPE, where both FILE and TYPE can be +;;; up to 8 characters. Again, beware that CMS filenames are always upper +;;; case, and hence must be entered as such. +;;; +;;; Tips: +;;; 1. CMS machines, with the exception of anonymous accounts, nearly always +;;; need an account password. To have efs send an account password, +;;; you can either include it in your .netrc file, or use +;;; efs-set-account. +;;; 2. efs-set-account can be used to set account passwords for specific +;;; minidisks. This is usually used to optain write access to the minidisk. +;;; As well you can put tokens of the form +;;; minidisk in your .netrc file. There can be +;;; as many minidisk tokens as you like, however they should follow all +;;; other tokens for a given machine entry. Of course, ordinary ftp +;;; will not understand these entries in your .netrc file. +;;; + + +;;; Since CMS doesn't have any full pathname syntax, we have to fudge +;;; things with cd's. We actually send too many cd's, but is dangerous +;;; to try to remember the current minidisk, because if the connection +;;; is closed and needs to be reopened, we will find ourselves back in +;;; the default minidisk. This is fairly likely since CMS ftp servers +;;; usually close the connection after 5 minutes of inactivity. + +;;; Have I got the filename character set right? + +;;; The following three functions are entry points to this file. +;;; They have been added to the appropriate alists in efs.el + +(efs-defun efs-fix-path cms (path &optional reverse) + ;; Convert PATH from UNIX-ish to CMS. If REVERSE is given, convert + ;; from CMS to UNIX. Actually, CMS doesn't have a full pathname syntax, + ;; so we fudge things by sending cd's. + (efs-save-match-data + (if reverse + (if (string-match ":" path) + ;; It's SFS + (let* ((start (match-end 0)) + (return (concat "/" (substring path 0 start)))) + (while (string-match "\\." path start) + (setq return (concat return "/" + (substring path start + (match-beginning 0))) + start (match-end 0))) + (concat return "/" (substring path start))) + ;; Since we only convert output from a pwd in this direction, + ;; we'll assume that it's a minidisk, and make it into a + ;; directory file name. Note that the expand-dir-hashtable + ;; stores directories without the trailing /. + (if (char-equal (string-to-char path) ?/) + path + (concat "/" path))) + (if (let ((case-fold-search t)) + (string-match + (concat + "^/\\([-A-Z0-9$*._+:]+\\)/" + ;; In case there is a SFS + "\\(\\([-A-Z0-9$*._+]+\\)/\\([-A-Z0-9$*._+]+/\\)?\\)?" + "\\([-A-Z0-9$._+]+\\)$") + path)) + (let ((minidisk (substring path 1 (match-end 1))) + (sfs (and (match-beginning 2) + (substring path (match-beginning 3) + (match-end 3)))) + (file (substring path (match-beginning 5) (match-end 5))) + account) + (and sfs (match-beginning 4) + (setq sfs (concat sfs "." (substring path (match-beginning 4) + (1- (match-end 4)))))) + (unwind-protect + (progn + (or sfs + (setq account + (efs-get-account host user minidisk))) + (efs-raw-send-cd host user (if sfs + (concat minidisk sfs ".") + minidisk)) + (if account + (efs-cms-send-minidisk-acct + host user minidisk account))) + (if account (fillarray account 0))) + file) + (error "Invalid CMS filename"))))) + +(efs-defun efs-fix-dir-path cms (dir-path) + ;; Convert path from UNIX-ish to VMS ready for a DIRectory listing. + (efs-save-match-data + (cond + ((string-equal "/" dir-path) + (error "Cannot get listing for CMS \"/\" directory.")) + ((let ((case-fold-search t)) + (string-match + (concat "^/\\([-A-Z0-9$*._+:]+\\)/" + "\\(\\([-A-Z0-9$*._+]+\\)/\\([-A-Z0-9$*._+]+/\\)?\\)?" + "\\([-A-Z0-9$*_.+]+\\)?$") dir-path)) + (let ((minidisk (substring dir-path (match-beginning 1) (match-end 1))) + (sfs (and (match-beginning 2) + (concat + (substring dir-path (match-beginning 3) + (match-end 3))))) + (file (if (match-beginning 5) + (substring dir-path (match-beginning 5) (match-end 5)) + "*")) + account) + (and sfs (match-beginning 4) + (setq sfs (concat sfs "." (substring dir-path + (match-beginning 4) + (1- (match-end 4)))))) + (unwind-protect + (progn + (or sfs + (setq account (efs-get-account host user minidisk))) + (efs-raw-send-cd host user (if sfs + (concat minidisk sfs ".") + minidisk)) + (if account + (efs-cms-send-minidisk-acct host user minidisk account))) + (if account (fillarray account 0))) + file)) + (t (error "Invalid CMS pathname"))))) + +(defconst efs-cms-file-line-regexp + (concat + "\\([-A-Z0-9$_+]+\\) +" + "\\(\\(\\([-A-Z0-9$_+]+\\) +[VF] +[0-9]+ \\)\\|\\(DIR +- \\)\\)")) + +(efs-defun efs-parse-listing cms + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a CMS directory listing. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a full remote path + ;; PATH = directory as a full efs-path + (let ((tbl (efs-make-hashtable)) + fn dir-p) + (goto-char (point-min)) + (efs-save-match-data + (while (re-search-forward efs-cms-file-line-regexp nil t) + (if (match-beginning 3) + (setq fn (concat (buffer-substring + (match-beginning 1) (match-end 1)) + "." + (buffer-substring + (match-beginning 4) (match-end 4))) + dir-p nil) + (setq fn (buffer-substring (match-beginning 1) (match-end 1)) + dir-p t)) + (efs-put-hash-entry fn (list dir-p) tbl) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl)) + tbl)) + +(defun efs-cms-send-minidisk-acct (host user minidisk account + &optional noretry) + "For HOST and USER, send the account password ACCOUNT. If MINIDISK is given, +the account password is for that minidisk. If PROC is given, send to that +process, rathr than use HOST and USER to look up the process." + (efs-save-match-data + (let ((result (efs-raw-send-cmd + (efs-get-process host user) + (concat "quote acct " account)))) + (cond + ((eq (car result) 'failed) + (setq account nil) + (unwind-protect + (progn + (setq + account + (read-passwd + (format + "Invalid acct. password for %s on %s@%s. Try again: " + minidisk user host))) + (if (string-equal "" account) + (setq account nil))) + ;; This guarantees that an interrupt will clear the account + ;; password. + (efs-set-account host user minidisk account)) + (if account ; give the user another chance + (efs-cms-send-minidisk-acct host user minidisk account))) + ((eq (car result) 'fatal) + (if noretry + ;; give up + (efs-error host user + (concat "ACCOUNT password failed: " (nth 1 result))) + ;; try once more + (efs-cms-send-minidisk-acct host user minidisk account t)))) + ;; return result + result))) + +(efs-defun efs-write-recover cms + (line cont-lines host user cmd msg pre-cont cont nowait noretry) + ;; If a write fails because of insufficient privileges, give the user a + ;; chance to send an account password. + (let ((cmd0 (car cmd)) + (cmd1 (nth 1 cmd)) + (cmd2 (nth 2 cmd))) + (efs-save-match-data + (if (and (or (memq cmd0 '(append put rename)) + (and (eq cmd0 'quote) (eq cmd1 'stor))) + (string-match "^/\\([-A-Z0-9$*._+]+\\)/[-A-Z0-9$*._+]+$" cmd2)) + (let ((minidisk (substring cmd2 (match-beginning 1) (match-end 1))) + account retry) + (unwind-protect + (progn + (setq account + (read-passwd + (format "Account password for minidisk %s on %s@%s: " + minidisk user host))) + (if (string-equal account "") + (setq account nil))) + (efs-set-account host user minidisk account)) + (if account + (progn + (efs-cms-send-minidisk-acct host user minidisk account) + (setq retry + (efs-send-cmd host user cmd msg pre-cont cont + nowait noretry)) + (and (null (or cont nowait)) retry)) + (if cont + (progn + (efs-call-cont cont 'failed line cont-lines) + nil) + (and (null nowait) (list 'failed line cont-lines))))) + (if cont + (progn + (efs-call-cont cont 'failed line cont-lines) + nil) + (and (null nowait) (list 'failed line cont-lines))))))) + +(efs-defun efs-allow-child-lookup cms (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + + ;; CMS file system is flat. Only minidisks are "subdirs". + (or (string-equal "/" dir) + (efs-save-match-data + (string-match "^/[^/:]+:/$" dir)))) + +;;; Sorting listings + +(defconst efs-cms-date-and-time-regexp + (concat + " \\(1?[0-9]\\)/\\([0-3][0-9]\\)/\\([0-9][0-9]\\) +" + "\\([12]?[0-9]\\):\\([0-5][0-9]\\):\\([0-5][0-9]\\) ")) + +(efs-defun efs-t-converter cms (&optional regexp reverse) + (if regexp + nil + (goto-char (point-min)) + (efs-save-match-data + (if (re-search-forward efs-cms-date-and-time-regexp nil t) + (let (list-start list bol nbol) + (beginning-of-line) + (setq list-start (point)) + (while (progn + (setq bol (point)) + (re-search-forward efs-cms-date-and-time-regexp + (setq nbol (save-excursion + (forward-line 1) (point))) + t)) + (setq list + (cons + (cons + (list (string-to-int (buffer-substring + (match-beginning 3) + (match-end 3))) ; year + (string-to-int (buffer-substring + (match-beginning 1) + (match-end 1))) ; month + (string-to-int (buffer-substring + (match-beginning 2) + (match-end 2))) ; day + (string-to-int (buffer-substring + (match-beginning 4) + (match-end 4))) ; hour + (string-to-int (buffer-substring + (match-beginning 5) + (match-end 5))) ; minutes + (string-to-int (buffer-substring + (match-beginning 6) + (match-end 6)))) ; seconds + (buffer-substring bol nbol)) + list)) + (goto-char nbol)) + (if list + (progn + (setq list + (mapcar 'cdr + (sort list 'efs-cms-t-converter-sort-pred))) + (if reverse (setq list (nreverse list))) + (delete-region list-start (point)) + (apply 'insert list))) + t))))) + +(defun efs-cms-t-converter-sort-pred (elt1 elt2) + (let* ((data1 (car elt1)) + (data2 (car elt2)) + (year1 (car data1)) + (year2 (car data2)) + (month1 (nth 1 data1)) + (month2 (nth 1 data2)) + (day1 (nth 2 data1)) + (day2 (nth 2 data2)) + (hour1 (nth 3 data1)) + (hour2 (nth 3 data2)) + (minute1 (nth 4 data1)) + (minute2 (nth 4 data2)) + (second1 (nth 5 data1)) + (second2 (nth 5 data2))) + (or (> year1 year2) + (and (= year1 year2) + (or (> month1 month2) + (and (= month1 month2) + (or (> day1 day2) + (and (= day1 day2) + (or (> hour1 hour2) + (and (= hour1 hour2) + (or (> minute1 minute2) + (and (= minute1 minute2) + (or (> (nth 5 data1) + (nth 5 data2))) + )))))))))))) + + +;;; Tree dired support: + +(defconst efs-dired-cms-re-exe "^. [-A-Z0-9$_+]+ +EXEC ") + +(or (assq 'cms efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'cms efs-dired-cms-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-cms-re-dir "^. [-A-Z0-9$_+]+ +DIR ") + +(or (assq 'cms efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'cms efs-dired-cms-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-insert-headerline cms (dir) + ;; CMS has no total line, so we insert a blank line for + ;; aesthetics. + (insert "\n") + (forward-char -1) + (efs-real-dired-insert-headerline dir)) + +(efs-defun efs-dired-manual-move-to-filename cms + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line. + ;; This is the CMS version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r") + (setq bol (point))) + (if (re-search-forward efs-cms-file-line-regexp eol t) + (goto-char (match-beginning 0)) + (goto-char bol) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename cms + (&optional no-error bol eol) + ;; Assumes point is at beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; case-fold-search must be nil, at least for VMS. + ;; On failure, signals an error or returns nil. + ;; This is the CMS version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "-A-Z0-9$_+") + (or (looking-at " +DIR ") + (progn + (skip-chars-forward " ") + (skip-chars-forward "-A-Z0-9$_+"))) + (if (or (= opoint (point)) (/= (following-char) ?\ )) + (if no-error + nil + (error "No file on this line")) + (point)))) + +(efs-defun efs-dired-make-filename-string cms (filename &optional reverse) + (if reverse + (if (string-match "\\." filename) + ;; Can't count on the number of blanks between the base and the + ;; extension, so ignore the extension. + (substring filename 0 (match-beginning 0)) + filename) + (if (string-match "^\\([^ ]+\\) +\\([^ ]+\\)$" filename) + (concat (substring filename 0 (match-end 1)) + "." + (substring filename (match-beginning 2) (match-end 2))) + filename))) + +;;; end of efs-cms.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-coke.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-coke.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,176 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-coke.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Coke Machine support for efs +;; Author: Sandy Rutherford +;; Created: Fri Oct 14 23:55:04 1994 by sandy on ibm550 +;; Modified: Sun Nov 27 12:16:47 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(provide 'efs-coke) +(require 'efs) + +(defconst efs-coke-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;; ------------------------------------------------------------ +;;;; Coke Machine support +;;;; ------------------------------------------------------------ +;;; +;;; Works for the MIT vending machine FTP server. +;;; Hopefully, a vending machine RFC is on its way, so we won't +;;; need to support a wide variation of vending machine protocols. + +(efs-defun efs-send-pwd coke (host user &optional xpwd) + ;; Directories on vending machines? + "/") + +(efs-defun efs-fix-path coke (path &optional reverse) + (if (= ?/ (aref path 0)) + (if reverse path (substring path 1)) + (if reverse (concat "/" path) path))) + +(efs-defun efs-fix-dir-path coke (dir-path) + ;; Make a beverage path for a dir listing. + (if (or (string-equal dir-path "/") (string-equal dir-path "/.")) + "*" + dir-path)) + +(efs-defun efs-parse-listing coke + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be in coke machine + ;; ftp dir format. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = remote directory as a remote full path + ;; PATH = directory as an efs full path + ;; SWITCHES are never used here, but they + ;; must be specified in the argument list for compatibility + ;; with the unix version of this function. + (let ((tbl (efs-make-hashtable))) + (goto-char (point-min)) + (efs-save-match-data + (while (re-search-forward "^\\(SOLD OUT \\)?\\[[0-9]+\\] +\\([^:\n]+\\)" + nil t) + (efs-put-hash-entry (buffer-substring (match-beginning 2) + (match-end 2)) + (list nil) tbl) + (forward-line 1))) + ;; Don't need to bother with .. + (efs-put-hash-entry "." '(t) tbl) + tbl)) + +(efs-defun efs-allow-child-lookup coke (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + + ;; Coke machine file system is flat. Hopefully not the coke. + (and (string-equal "/" dir) (string-equal "." file))) + +(defun efs-coke-insert-beverage-contents (buffer file line) + ;; Inserts the contents of a beverage (determined by the FTP server + ;; response LINE) into BUFFER, and then drinks it. + ;; FILE is the name of the file. + (efs-save-buffer-excursion + (set-buffer buffer) + (if (zerop (buffer-size)) + (progn + (insert "\n\n\n\n " (substring line 4) "\n") + (set-buffer-modified-p nil) + (set-process-sentinel + (start-process "efs-coke-gulp-buffer" (current-buffer) "sleep" "3") + (function + (lambda (proc str) + (efs-save-buffer-excursion + (let ((buff (process-buffer proc))) + (and buff (get-buffer buff) + (progn + (set-buffer buff) + (erase-buffer) + (insert "\n\n\n\n GULP!!!\n") + (sit-for 1) + (set-buffer-modified-p nil) + (kill-buffer (current-buffer))))))))) + (if (featurep 'dired) + (dired-fun-in-all-buffers + (file-name-directory file) 'dired-revert))) + (message "You haven't finished your last drink in buffer %s!" + (current-buffer)) + (ding) + (sit-for 1)))) + +;;; Dired support + +(efs-defun efs-dired-manual-move-to-filename coke + (&optional raise-error bol eol) + ;; In dired, move to first char of filename on this line. + ;; Returns position (point) or nil if no filename on this line. + ;; This is the COKE version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r") + (setq bol (point))) + (if (looking-at "\\(. \\)?\\(SOLD OUT \\)?\\[[0-9]+\\] +\\([^:\n]+\\): ") + (goto-char (match-beginning 3)) + (and raise-error (error "No file on this line")))) + +(efs-defun efs-dired-manual-move-to-end-of-filename coke + (&optional no-error bol eol) + ;; Assumes point is at beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; On failure, signals an error or returns nil. + ;; This is the COKE version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (if (search-forward ": " eol t) + (goto-char (- (match-end 0) 2)) + (if no-error + nil + (error "No file on this line")) + (point)))) + +(efs-defun efs-dired-insert-headerline coke (dir) + (let* ((parsed (efs-ftp-path dir)) + (host (car parsed)) + (user (nth 1 parsed)) + (accounting + (efs-send-cmd + host user '(quote pwd) + (format "Getting accounting data for %s@%s user host" user host)))) + (insert " " user "@" host "\n " + (if (car accounting) + "Account status unavailable" + (substring (nth 1 accounting) 4))) + (delete-region (point) (progn (skip-chars-backward ":.,;") (point))) + (insert ":\n \n"))) + +;;; end of efs-coke.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-cp-p.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-cp-p.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,165 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-cp-p.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Support for preserving file modtimes with copies. i.e. cp -p +;; Author: Sandy Rutherford +;; Created: Fri Feb 18 03:28:22 1994 by sandy on ibm550 +;; Modified: Sun Nov 27 12:17:33 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(provide 'efs-cp-p) +(require 'efs) + +;;;; Internal Variables + +(defconst efs-cp-p-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +(defvar efs-local-timezone nil) +;; cache. + +;;; Utility functions + +(efs-define-fun efs-gmt-time () + ;; Get the time as the number of seconds elapsed since midnight, + ;; Jan 1, 1970, GMT. Emacs 18 doesn't have `current-time' function. + (let ((time (current-time))) + (list (car time) (nth 1 time)))) + +(defun efs-local-time () + (let ((str (current-time-string))) + (efs-seconds-elapsed + (string-to-int (substring str -4)) + (cdr (assoc (substring str 4 7) efs-month-alist)) + (string-to-int (substring str 8 10)) + (string-to-int (substring str 11 13)) + (string-to-int (substring str 14 16)) + 0))) ; don't care about seconds + +(defun efs-local-timezone () + ;; Returns the local timezone as an integer. Right two digits the minutes, + ;; others the hours. + (or efs-local-timezone + (setq efs-local-timezone + (let* ((local (efs-local-time)) + (gmt (efs-gmt-time)) + (sign 1) + (diff (efs-time-minus local gmt)) + hours minutes) + ;; 2^16 is 36 hours. + (if (zerop (car diff)) + (setq diff (nth 1 diff)) + (error "Weird timezone!")) + (setq diff (/ (- (nth 1 local) (nth 1 gmt)) 60)) + (setq hours (/ diff 60)) + (setq minutes (% diff 60)) + (if (< diff 0) + (setq sign -1 + hours (- hours) + minutes (- minutes))) + ;; Round minutes + (setq minutes (* 10 (/ (+ minutes 5) 10))) + (if (= minutes 60) + (setq hours (1+ hours) + minutes 0)) + (* sign (+ (* hours 100) minutes)))))) + +(defun efs-last-day-of-month (month year) + ;; The last day in MONTH during YEAR. + ;; Taken from calendar.el. Thanks. + (if (and + (or + (and (= (% year 4) 0) + (/= (% year 100) 0)) ; leap-year-p + (= (% year 400) 0)) + (= month 2)) + 29 + (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month)))) + +(defun efs-make-date-local (year month day hour minutes seconds) + ;; Takes a GMT date (list of integers), and returns the local time. + (let* ((lzone (efs-local-timezone)) + (lminutes (% lzone 100)) + (lhour (/ lzone 100))) + (setq minutes (+ minutes lminutes)) + (cond ((> minutes 60) + (setq minutes (- minutes 60) + hour (1+ hour))) + ((< minutes 0) + (setq minutes (+ minutes 60) + hour (1- hour)))) + (setq hour (+ lhour hour)) + (if (or (< hour 0) (> hour 23)) + (progn + (cond ((< hour 0) + (setq hour (+ hour 24) + day (1- day))) + ((> hour 23) + (setq hour (- hour 24) + day (1+ day)))) + (if (or (zerop day) (> day + (efs-last-day-of-month month year))) + (cond ((zerop day) + (setq month (1- month)) + (if (zerop month) + (setq year (1- year) + month 12)) + (setq day (efs-last-day-of-month month year))) + ((> day (efs-last-day-of-month month year)) + (setq month (1+ month) + day 1) + (if (= month 13) + (setq year (1+ year) + month 1))))))) + (list year month day hour minutes seconds))) + +;;;; Entry function + +(defun efs-set-mdtm-of (filename newname &optional cont) + ;; NEWNAME must be local + ;; Always works NOWAIT = 0 + (let* ((parsed (efs-ftp-path filename)) + (host (car parsed)) + (user (nth 1 parsed)) + (file (nth 2 parsed))) + (if (efs-get-host-property host 'mdtm-failed) + (and cont (efs-call-cont cont 'failed "" "") nil) + (efs-send-cmd + host user + (list 'quote 'mdtm file) + nil nil + (efs-cont (result line cont-lines) (host newname cont) + (if (or result + (not (string-match efs-mdtm-msgs line))) + (efs-set-host-property host 'mdtm-failed t) + (let ((time (apply 'efs-make-date-local + (mapcar 'string-to-int + (list + (substring line 4 8) + (substring line 8 10) + (substring line 10 12) + (substring line 12 14) + (substring line 14 16) + (substring line 16 18)))))) + (if time + (call-process "touch" nil 0 nil "-t" + (format "%04d%02d%02d%02d%02d.%02d" + (car time) (nth 1 time) + (nth 2 time) (nth 3 time) + (nth 4 time) (nth 5 time)) + newname)))) + (if cont (efs-call-cont cont result line cont-lines))) + 0)))) + +;;; end of efs-cp-p.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-cu.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-cu.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,635 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-cu.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Common utilities needed by efs files. +;; Author: Sandy Rutherford +;; Created: Fri Jan 28 19:55:45 1994 by sandy on ibm550 +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;;; Provisions and autoloads. + +(provide 'efs-cu) +(require 'backquote) +(autoload 'efs-get-process "efs") +(autoload 'efs-parse-netrc "efs-netrc") + +;;;; ------------------------------------------------------------ +;;;; Use configuration variables. +;;;; ------------------------------------------------------------ + +(defvar efs-default-user nil + "*User name to use when none is specied in a pathname. + +If a string, than this string is used as the default user name. +If nil, then the name under which the user is logged in is used. +If t, then the user is prompted for a name. +If an association list of the form + + '((REGEXP1 . USERNAME1) (REGEXP2 . USERNAME2) ...) + +then the host name is tested against each of the regular expressions +REGEXP in turn, and the default user name is the corresponding value +of USERNAME. USERNAME may be either a string, nil, or t, and these +values are interpreted as above. If there are no matches, then the +user's curent login name is used.") + +(defvar efs-default-password nil + "*Password to use when the user is the same as efs-default-user.") + +(defvar efs-default-account nil + "*Account password to use when the user is efs-default-user.") + +;;;; ------------------------------------------------------------- +;;;; Internal variables. +;;;; ------------------------------------------------------------- + +(defconst efs-cu-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +(defconst efs-case-insensitive-host-types + '(vms cms mts ti-twenex ti-explorer dos mvs tops-20 mpe ka9q dos-distinct + os2 hell guardian ms-unix netware cms-knet nos-ve) + "List of host types for which case is insignificant in file names.") + +;;; Remote path name syntax + +;; All of the following variables must be set consistently. +;; As well the below two functions depend on the grouping constructs +;; in efs-path-regexp. So know what you're doing if you change them. + +(defvar efs-path-regexp "^/\\([^@:/]*@\\)?\\([^@:/]*\\):.*" + "Regexp of a fully expanded remote path.") + +(defvar efs-path-format-string "/%s@%s:%s" + "Format of a fully expanded remote path. Passed to format with +additional arguments user, host, and remote path.") + +(defvar efs-path-format-without-user "/%s:%s" + "Format of a remote path, but not specifying a user.") + +(defvar efs-path-user-at-host-format + (substring efs-path-format-string 1 7) + "Format to return `user@host:' strings for completion in root directory.") + +(defvar efs-path-host-format + (substring efs-path-user-at-host-format 3) + "Format to return `host:' strings for completion in root directory.") + +(defvar efs-path-root-regexp "^/[^/:]+:" + "Regexp to match the `/user@host:' root of an efs full path.") + +(defvar efs-path-root-short-circuit-regexp "//[^/:]+:") +;; Regexp to match an efs user@host root, which short-circuits +;; the part of the path to the left of this pattern. + +;;;; ----------------------------------------------------------- +;;;; Variables for multiple host type support +;;;; ----------------------------------------------------------- + +(defvar efs-vms-host-regexp nil + "Regexp to match the names of hosts running VMS.") +(defvar efs-cms-host-regexp nil + "Regexp to match the names of hosts running CMS.") +(defvar efs-mts-host-regexp nil + "Regexp to match the names of hosts running MTS.") +(defvar efs-ti-explorer-host-regexp nil + "Regexp to match the names of hosts running TI-EXPLORER. +These are lisp machines.") +(defvar efs-ti-twenex-host-regexp nil + "Regexp to match the names of hosts running TI-TWENEX. +These are lisp machines, and this should not be confused with DEC's TOPS-20.") +(defvar efs-sysV-unix-host-regexp nil + "Regexp to match the names of sysV unix hosts. +These are defined to be unix hosts which mark symlinks +with a @ in an ls -lF listing.") +(defvar efs-bsd-unix-host-regexp nil + "Regexp to match the names of bsd unix hosts. +These are defined to be unix hosts which do not mark symlinks +with a @ in an ls -lF listing.") +(defvar efs-next-unix-host-regexp nil + "Regexp to match names of NeXT unix hosts. +These are defined to be unix hosts which put a @ after the +destination of a symlink when doing ls -lF listing.") +(defvar efs-unix-host-regexp nil + "Regexp to match names of unix hosts. +I you know which type of unix, it is much better to set that regexp instead.") +(defvar efs-dumb-unix-host-regexp nil + "Regexp to match names of unix hosts which do not take ls switches. +For these hosts we use the \"dir\" command.") +(defvar efs-super-dumb-unix-host-regexp nil + "Regexp to match names of unix hosts with FTP servers that cannot do a PWD. +It is also assumed that these hosts do not accept ls switches, whether +or not this is actually true.") +(defvar efs-dos-host-regexp nil + "Regexp to match names of hosts running DOS.") +;; In principal there is apollo unix support -- at least efs +;; should do the right thing. However, apollo ftp servers can be +;; very flakey, especially about accessing files by fullpaths. +;; Good luck. +(defvar efs-apollo-unix-host-regexp nil + "Regexp to match names of apollo unix hosts running Apollo's Domain. +For these hosts we don't short-circuit //'s immediately following +\"/user@host:\"") +(defvar efs-mvs-host-regexp nil + "Regexp to match names of hosts running MVS.") +(defvar efs-tops-20-host-regexp nil + "Regexp to match names of hosts runninf TOPS-20.") +(defvar efs-mpe-host-regexp nil + "Regexp to match hosts running the MPE operating system.") +(defvar efs-ka9q-host-regexp nil + "Regexp to match hosts using the ka9q ftp server. +These may actually be running one of DOS, LINUX, or unix.") +(defvar efs-dos-distinct-host-regexp nil + "Regexp to match DOS hosts using the Distinct FTP server. +These are not treated as DOS hosts with a special listing format, because +the Distinct FTP server uses unix-style path syntax.") +(defvar efs-os2-host-regexp nil + "Regexp to match names of hosts running OS/2.") +(defvar efs-vos-host-regexp nil + "Regexp to match hosts running the VOS operating system.") +(defvar efs-hell-host-regexp nil + "Regexp to match hosts using the hellsoft ftp server. +These map be either DOS PC's or Macs.") +;; The way that we implement the hellsoft support, it probably won't +;; work with Macs. This could probably be fixed, if enough people scream. +(defvar efs-guardian-host-regexp nil + "Regexp to match hosts running Tandem's guardian operating system.") +;; Note that ms-unix is really an FTP server running under DOS. +;; It's not a type of unix. +(defvar efs-ms-unix-host-regexp nil + "Regexp to match hosts using the Microsoft FTP server in unix mode.") +(defvar efs-plan9-host-regexp nil + "Regexp to match hosts running ATT's Plan 9 operating system.") +(defvar efs-cms-knet-host-regexp nil + "Regexp to match hosts running the CMS KNET FTP server.") +(defvar efs-nos-ve-host-regexp nil + "Regexp to match hosts running NOS/VE.") +(defvar efs-netware-host-regexp nil + "Regexp to match hosts running Novell Netware.") +(defvar efs-dumb-apollo-unix-regexp nil + "Regexp to match dumb hosts running Apollo's Domain. +These are hosts which do not accept switches to ls over FTP.") + +;;; Further host types: +;; +;; unknown: This encompasses ka9q, dos-distinct, unix, sysV-unix, bsd-unix, +;; next-unix, and dumb-unix. + +(defconst efs-host-type-alist + ;; When efs-add-host is called interactively, it will only allow + ;; host types from this list. + '((dumb-unix . efs-dumb-unix-host-regexp) + (super-dumb-unix . efs-super-dumb-unix-host-regexp) + (next-unix . efs-next-unix-host-regexp) + (sysV-unix . efs-sysV-unix-host-regexp) + (bsd-unix . efs-bsd-unix-host-regexp) + (apollo-unix . efs-apollo-unix-host-regexp) + (unix . efs-unix-host-regexp) + (vms . efs-vms-host-regexp) + (mts . efs-mts-host-regexp) + (cms . efs-cms-host-regexp) + (ti-explorer . efs-ti-explorer-host-regexp) + (ti-twenex . efs-ti-twenex-host-regexp) + (dos . efs-dos-host-regexp) + (mvs . efs-mvs-host-regexp) + (tops-20 . efs-tops-20-host-regexp) + (mpe . efs-mpe-host-regexp) + (ka9q . efs-ka9q-host-regexp) + (dos-distinct . efs-dos-distinct-host-regexp) + (os2 . efs-os2-host-regexp) + (vos . efs-vos-host-regexp) + (hell . efs-hell-host-regexp) + (guardian . efs-guardian-host-regexp) + (ms-unix . efs-ms-unix-host-regexp) + (plan9 . efs-plan9-host-regexp) + (cms-net . efs-cms-knet-host-regexp) + (nos-ve . efs-nos-ve-host-regexp) + (netware . efs-netware-host-regexp) + (dumb-apollo-unix . efs-dumb-apollo-unix-regexp))) + +;; host type cache +(defconst efs-host-cache nil) +(defconst efs-host-type-cache nil) + +;; cache for efs-ftp-path. +(defconst efs-ftp-path-arg "") +(defconst efs-ftp-path-res nil) + +;;;; ------------------------------------------------------------- +;;;; General macros. +;;;; ------------------------------------------------------------- + +(defmacro efs-save-match-data (&rest body) + "Execute the BODY forms, restoring the global value of the match data. +Before executing BODY, case-fold-search is locally bound to nil." + ;; Because Emacs is buggy about let-binding buffer-local variables, + ;; we have to do this in a slightly convoluted way. + (let ((match-data-temp (make-symbol "match-data")) + (buff-temp (make-symbol "buff")) + (cfs-temp (make-symbol "cfs"))) + (list + 'let (list (list match-data-temp '(match-data)) + (list buff-temp '(current-buffer)) + (list cfs-temp 'case-fold-search)) + (list 'unwind-protect + (cons 'progn + (cons + '(setq case-fold-search nil) + body)) + (list 'condition-case nil + (list 'save-excursion + (list 'set-buffer buff-temp) + (list 'setq 'case-fold-search cfs-temp)) + '(error nil)) + (list 'store-match-data match-data-temp))))) + +(put 'efs-save-match-data 'lisp-indent-hook 0) +(put 'efs-save-match-data 'edebug-form-spec '(&rest form)) + +(defmacro efs-define-fun (fun args &rest body) + "Like defun, but only defines a function if it has no previous definition." + ;; There are easier ways to do this. This approach is used so that the + ;; byte compiler won't complain about possibly undefined functions. + (` + (progn + (put (quote (, fun)) 'efs-define-fun + (and (fboundp (quote (, fun))) + (symbol-function (quote (, fun))))) + (defun (, fun) (, args) (,@ body)) + (if (and (get (quote (, fun)) 'efs-define-fun) + (not (eq (car-safe (get (quote (, fun)) 'efs-define-fun)) + (quote autoload)))) + (fset (quote (, fun)) (get (quote (, fun)) 'efs-define-fun))) + (put (quote (, fun)) 'efs-define-fun nil) + (quote (, fun))))) + +(put 'efs-define-fun 'lisp-indent-hook 'defun) + +(defmacro efs-quote-dollars (string) + ;; Quote `$' as `$$' in STRING to get it past `substitute-in-file-name.' + (` + (let ((string (, string)) + (pos 0)) + (while (setq pos (string-match "\\$" string pos)) + (setq string (concat (substring string 0 pos) + "$";; precede by escape character (also a $) + (substring string pos)) + ;; add 2 instead 1 since another $ was inserted + pos (+ 2 pos))) + string))) + +(defmacro efs-cont (implicit-args explicit-args &rest body) + "Defines an efs continuation function. +The IMPLICIT-ARGS are bound when the continuation function is called. +The EXPLICIT-ARGS are bound when the continuation function is set." + (let ((fun (list 'function + (cons 'lambda + (cons + (append implicit-args explicit-args) + body))))) + (if explicit-args + (cons 'list (cons fun explicit-args)) + fun))) + +(put 'efs-cont 'lisp-indent-hook 2) + +;;;; ------------------------------------------------------------ +;;;; Utility functions +;;;; ------------------------------------------------------------ + +(efs-define-fun efs-repaint-minibuffer () + ;; Set minibuf_message = 0, so that the contents of the minibuffer will show. + ;; This is the Emacs V19 version of this function. For Emacs 18, it will + ;; be redefined in a grotty way to accomplish the same thing. + (message nil)) + +(defun efs-get-user (host) + "Given a HOST, return the default USER." + (efs-parse-netrc) + ;; We cannot check for users case-insensitively on those systems + ;; which are treat usernames case-insens., because we need to log in + ;; first, before we know what type of system. + (let ((user (efs-get-host-property host 'user))) + (if (stringp user) + user + (prog1 + (setq user + (cond ((stringp efs-default-user) + ;; We have a default name. Use it. + efs-default-user) + ((consp efs-default-user) + ;; Walk the list looking for a host-specific value. + (efs-save-match-data + (let ((alist efs-default-user) + (case-fold-search t) + result) + (while alist + (if (string-match (car (car alist)) host) + (setq result (cdr (car alist)) + alist nil) + (setq alist (cdr alist)))) + (cond + ((stringp result) + result) + (result + (let ((enable-recursive-minibuffers t)) + (read-string (format "User for %s: " host) + (user-login-name)))) + (t + (user-login-name)))))) + (efs-default-user + ;; Ask the user. + (let ((enable-recursive-minibuffers t)) + (read-string (format "User for %s: " host) + (user-login-name)))) + ;; Default to the user's login name. + (t + (user-login-name)))) + (efs-set-user host user))))) + +(defun efs-ftp-path (path) + "Parse PATH according to efs-path-regexp. +Returns a list (HOST USER PATH), or nil if PATH does not match the format." + (or (string-equal path efs-ftp-path-arg) + (setq efs-ftp-path-res + (efs-save-match-data + (and (string-match efs-path-regexp path) + (let ((host (substring path (match-beginning 2) + (match-end 2))) + (user (and (match-beginning 1) + (substring path (match-beginning 1) + (1- (match-end 1))))) + (rpath (substring path (1+ (match-end 2))))) + (list (if (string-equal host "") + (setq host (system-name)) + host) + (or user (efs-get-user host)) + rpath)))) + ;; Set this last, in case efs-get-user calls this + ;; function, which would modify an earlier setting. + efs-ftp-path-arg path)) + efs-ftp-path-res) + +(defun efs-chase-symlinks (file) + ;; If FILE is a symlink, chase it until we get to a real file. + ;; Unlike file truename, this function does not chase symlinks at + ;; every level, only the bottom level. Therefore, it is not useful for + ;; obtaining the truename of a file. It is useful for getting at file + ;; attributes, with a lot less overhead than file truename. + (let ((target (file-symlink-p file))) + (if target + (efs-chase-symlinks + (expand-file-name target (file-name-directory file))) + file))) + +;; If efs-host-type is called with the optional user +;; argument, it will attempt to guess the host type by connecting +;; as user, if necessary. + +(defun efs-host-type (host &optional user) + "Return a symbol which represents the type of the HOST given. +If the optional argument USER is given, attempts to guess the +host-type by logging in as USER." + + (and host + (let ((host (downcase host)) + type) + (cond + + ((and efs-host-cache + (string-equal host efs-host-cache) + efs-host-type-cache)) + + ((setq type + (efs-get-host-property host 'host-type)) + (setq efs-host-cache host + efs-host-type-cache type)) + + ;; Trigger an ftp connection, in case we need to + ;; guess at the host type. + ((and user (efs-get-process host user) + (if (string-equal host efs-host-cache) + ;; logging in may update the cache + efs-host-type-cache + (and (setq type (efs-get-host-property host 'host-type)) + (setq efs-host-cache host + efs-host-type-cache type))))) + + ;; Try the regexps. + ((setq type + (let ((alist efs-host-type-alist) + regexp type-pair) + (catch 'match + (efs-save-match-data + (let ((case-fold-search t)) + (while alist + (progn + (and (setq type-pair (car alist) + regexp (eval (cdr type-pair))) + (string-match regexp host) + (throw 'match (car type-pair))) + (setq alist (cdr alist))))) + nil)))) + (setq efs-host-cache host + efs-host-type-cache type)) + ;; Return 'unknown, but _don't_ cache it. + (t 'unknown))))) + +;;;; ------------------------------------------------------------- +;;;; Functions and macros for hashtables. +;;;; ------------------------------------------------------------- + +(defun efs-make-hashtable (&optional size) + "Make an obarray suitable for use as a hashtable. +SIZE, if supplied, should be a prime number." + (make-vector (or size 31) 0)) + +(defun efs-map-hashtable (fun tbl &optional property) + "Call FUNCTION on each key and value in HASHTABLE. +If PROPERTY is non-nil, it is the property to be used as the second +argument to FUNCTION. The default property is 'val" + (let ((prop (or property 'val))) + (mapatoms + (function + (lambda (sym) + (funcall fun (symbol-name sym) (get sym prop)))) + tbl))) + +(defmacro efs-make-hash-key (key) + "Convert KEY into a suitable key for a hashtable. This returns a string." + (` (let ((key (, key))) ; eval exactly once, in case evalling key moves the + ; point. + (if (stringp key) key (prin1-to-string key))))) + +;;; Note, if you store entries in a hashtable case-sensitively, and then +;;; retrieve them with IGNORE-CASE=t, it is possible that there may be +;;; be more than one entry that could be retrieved. It is more or less random +;;; which one you'll get. The onus is on the programmer to be consistent. +;;; Suggestions to make this faster are gratefully accepted! + +(defmacro efs-case-fold-intern-soft (name tbl) + "Returns a symbol with case-insensitive name NAME in the obarray TBL. +Case is considered insignificant in NAME. Note, if there is more than +one possible match, it is hard to predicate which one you'll get." + (` + (let* ((completion-ignore-case t) + (name (, name)) + (tbl (, tbl)) + (len (length (, name))) + (newname (try-completion name tbl + (function + (lambda (sym) + (= (length (symbol-name sym)) len)))))) + (and newname + (if (eq newname t) + (intern name tbl) + (intern newname tbl)))))) + +(defmacro efs-hash-entry-exists-p (key tbl &optional ignore-case) + "Return whether there is an association for KEY in TABLE. +If optional IGNORE-CASE is non-nil, then ignore-case in the test." + (` (let ((key (efs-make-hash-key (, key)))) + (if (, ignore-case) + (efs-case-fold-intern-soft key (, tbl)) + (intern-soft key (, tbl)))))) + +(defmacro efs-get-hash-entry (key tbl &optional ignore-case) + "Return the value associated with KEY in HASHTABLE. +If the optional argument IGNORE-CASE is given, then case in the key is +considered irrelevant." + (` (let* ((key (efs-make-hash-key (, key))) + (sym (if (, ignore-case) + (efs-case-fold-intern-soft key (, tbl)) + (intern-soft key (, tbl))))) + (and sym (get sym 'val))))) + +(defmacro efs-put-hash-entry (key val tbl &optional ignore-case) + "Record an association between KEY and VALUE in HASHTABLE. +If the optional IGNORE-CASE argument is given, then check for an entry +which is the same modulo case, and update it instead of adding a new entry." + (` (let* ((key (efs-make-hash-key (, key))) + (sym (if (, ignore-case) + (or (efs-case-fold-intern-soft key (, tbl)) + (intern key (, tbl))) + (intern key (, tbl))))) + (put sym 'val (, val))))) + +(defun efs-del-hash-entry (key tbl &optional ignore-case) + "Copy all symbols except KEY in HASHTABLE and return modified hashtable. +If the optional argument CASE-FOLD is non-nil, then fold KEY to lower case." + (let* ((len (length tbl)) + (new-tbl (efs-make-hashtable len)) + (i (1- len)) + (key (efs-make-hash-key key))) + (if ignore-case (setq key (downcase key))) + (efs-map-hashtable + (if ignore-case + (function + (lambda (k v) + (or (string-equal (downcase k) key) + ;; Don't need to specify ignore-case here, because + ;; we have already weeded out possible case-fold matches. + (efs-put-hash-entry k v new-tbl)))) + (function + (lambda (k v) + (or (string-equal k key) + (efs-put-hash-entry k v new-tbl))))) + tbl) + (while (>= i 0) + (aset tbl i (aref new-tbl i)) + (setq i (1- i))) + ;; Return the result. + tbl)) + +(defun efs-hash-table-keys (tbl &optional nosort) + "Return a sorted of all the keys in the hashtable TBL, as strings. +This list is sorted, unless the optional argument NOSORT is non-nil." + (let ((result (all-completions "" tbl))) + (if nosort + result + (sort result (function string-lessp))))) + +;;; hashtable variables + +(defconst efs-host-hashtable (efs-make-hashtable) + "Hash table holding data on hosts.") + +(defconst efs-host-user-hashtable (efs-make-hashtable) + "Hash table for holding data on host user pairs.") + +(defconst efs-minidisk-hashtable (efs-make-hashtable) + "Mapping between a host, user, minidisk triplet and a account password.") + +;;;; ------------------------------------------------------------ +;;;; Host / User mapping +;;;; ------------------------------------------------------------ + +(defun efs-set-host-property (host property value) + ;; For HOST, sets PROPERTY to VALUE. + (put (intern (downcase host) efs-host-hashtable) property value)) + +(defun efs-get-host-property (host property) + ;; For HOST, gets PROPERTY. + (get (intern (downcase host) efs-host-hashtable) property)) + +(defun efs-set-host-user-property (host user property value) + ;; For HOST and USER, sets PROPERTY to VALUE. + (let* ((key (concat (downcase host) "/" user)) + (sym (and (memq (efs-host-type host) efs-case-insensitive-host-types) + (efs-case-fold-intern-soft key efs-host-user-hashtable)))) + (or sym (setq sym (intern key efs-host-user-hashtable))) + (put sym property value))) + +(defun efs-get-host-user-property (host user property) + ;; For HOST and USER, gets PROPERTY. + (let* ((key (concat (downcase host) "/" user)) + (sym (and (memq (efs-host-type host) efs-case-insensitive-host-types) + (efs-case-fold-intern-soft key efs-host-user-hashtable)))) + (or sym (setq sym (intern key efs-host-user-hashtable))) + (get sym property))) + +(defun efs-set-user (host user) + "For a given HOST, set or change the default USER." + (interactive "sHost: \nsUser: ") + (efs-set-host-property host 'user user)) + +;;;; ------------------------------------------------------------ +;;;; Encryption +;;;; ------------------------------------------------------------ + +(defconst efs-passwd-seed nil) +;; seed used to encrypt the password cache. + +(defun efs-get-passwd-seed () + ;; Returns a random number to use for encrypting passwords. + (or efs-passwd-seed + (setq efs-passwd-seed (+ 1 (random 255))))) + +(defun efs-code-string (string) + ;; Encode a string, using `efs-passwd-seed'. This is nil-potent, + ;; meaning applying it twice decodes. + (if (and (fboundp 'int-char) (fboundp 'char-int)) + (mapconcat + (function + (lambda (c) + (char-to-string + (int-char (logxor (efs-get-passwd-seed) (char-int c)))))) + string "") + (mapconcat + (function + (lambda (c) + (char-to-string (logxor (efs-get-passwd-seed) c)))) + string ""))) + +;;; end of efs-cu.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-defun.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-defun.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,393 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-defun.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: efs-defun allows for OS-dependent coding of functions +;; Author: Sandy Rutherford +;; Created: Thu Oct 22 17:58:14 1992 +;; Modified: Sun Nov 27 12:18:35 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;; efs-defun allows object-oriented emacs lisp definitions. +;;; In efs, this feature is used to support multiple host types. +;;; +;;; The first arg after the function name is a key which determines +;;; which version of the function is being defined. Normally, when the function +;;; is called this key is given as the first argument to the function. +;;; +;;; For example: +;;; +;;; (efs-defun foobar vms (x y) +;;; (message "hello vms world") +;;; (+ x y)) +;;; => foobar +;;; +;;; (foobar 'vms 1 2) +;;; => 3 + +;;; The key nil plays a special role: +;;; +;;; First, it defines a default action. If there is no function +;;; definition associated with a given OS-key, then the function +;;; definition associated with nil is used. If further there is no +;;; function definition associated with nil, then an error is +;;; signaled. +;;; +;;; Second, the documentation string for the function is the one given +;;; with the nil definition. You can supply doc-strings with other +;;; definitions of the function, but they are not accessible with +;;; 'describe-function. In fact, when the function is either loaded or +;;; byte-compiled, they are just thrown away. + +;;; There is another way to define the default action of an efs-function. +;;; This is with the use flag. If you give as the key (&use foobar), +;;; then when the function is called the variable foobar will be used to +;;; determine which OS version of the function to use. As well as +;;; allowing you to define the doc string, if the use flag is used, +;;; then you can specify an interactive specification with the function. +;;; Although a function is only interactive, if the default definition +;;; has an interactive spec, it is still necessary to give interactive +;;; specs for the other definitions of the function as well. It is possible +;;; for these interactive specs to differ. +;;; +;;; For example: +;;; +;;; (efs-defun fizzle (&use foobar) +;;; "Fizzle's doc string." +;;; (interactive) +;;; (message "fizz wizz")) +;;; +;;; (efs-defun fizzle vms +;;; (interactive) +;;; (message "VMS is fizzled.")) +;;; +;;; (setq foobar 'unix) +;;; => unix +;;; +;;; (fizzle) +;;; => "fizz wizz" +;;; +;;; (setq foobar 'vms) +;;; => vms +;;; +;;; (fizzle) +;;; => "VMS is fizzled." +;;; +;;; M-x f i z z l e +;;; => "VMS is fizzled." +;;; +;;; Actually, when you use the &use spec, whatever follows it is simply +;;; evaluated at call time. + +;;; Note that when the function is defined, the key is implicitly +;;; quoted, whereas when the function is called, the key is +;;; evaluated. If this seems strange, think about how efs-defuns +;;; are used in practice. + +;;; There are no restrictions on the order in which the different OS-type +;;; definitions are done. + +;;; There are no restrictions on the keys that can be used, nor on the +;;; symbols that can be used as arguments to an efs-defun. We go +;;; to some lengths to avoid potential conflicts. In particular, when +;;; the OS-keys are looked up in the symbol's property list, we +;;; actually look for a symbol with the same name in the special +;;; obarray, efs-key-obarray. This avoids possible conflicts with +;;; other entries in the property list, that are usually accessed with +;;; symbols in the standard obarray. + +;;; The V19 byte-compiler will byte-compile efs-defun's. +;;; The standard emacs V18 compiler will not, however they will still +;;; work, just not at byte-compiled speed. + +;;; efs-autoload works much like the standard autoload, except it +;;; defines the efs function cell for a given host type as an autoload. +;;; The from-kbd arg only makes sense if the default action of the autoload +;;; has been defined with a &use. + +;;; To do: +;;; +;;; 1. Set an edebug-form-hook for efs-defun + +;;; Known Bugs: +;;; +;;; 1. efs-autoload will correctly NOT overload an existing function +;;; definition with an autoload definition. However, it will also +;;; not overload a previous autoload with a new one. It should. An +;;; overload can be forced for the KEY def of function FUN by doing +;;; (put 'FUN (intern "KEY" efs-key-obarray) nil) first. +;;; + +;;; Provisions and requirements + +(provide 'efs-defun) +(require 'backquote) + +;;; Variables + +(defconst efs-defun-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +(defconst efs-key-obarray (make-vector 7 0)) + +;; Unfortunately, we need to track this in bytecomp.el. +;; It's not much to keep track of, although. +(defconst efs-defun-bytecomp-buffer "*Compile-Log*") + +(defvar efs-key nil + "Inside an efs function, this is set to the key that was used to +call the function. You can test this inside the default definition, to +determine which key was actually used.") +(defvar efs-args nil + "Inside an efs function, this is set to a list of the calling args +of the function.") + +;;; Utility Functions + +;;; These functions are called when the macros efs-defun and efs-autoload +;;; are expanded. Their purpose is to help in producing the expanded code. + +(defun efs-defun-arg-count (list) + ;; Takes a list of arguments, and returns a list of three + ;; integers giving the number of normal args, the number + ;; of &optional args, and the number of &rest args (this should + ;; only be 0 or 1, but we don't check this). + (let ((o-leng (length (memq '&optional list))) + (r-leng (length (memq '&rest list))) + (leng (length list))) + (list (- leng (max o-leng r-leng)) + (max 0 (- o-leng r-leng 1)) + (max 0 (1- r-leng))))) + +;; For each efs-function the property efs-function-arg-structure +;; is either a list of three integers to indicate the number of normal, +;; optional, and rest args, or it can be the symbol 'autoload to indicate +;; that all definitions of the function are autoloads, and we have no +;; idea of its arg structure. + +(defun efs-defun-arg-check (fun key list) + ;; Checks that the LIST of args is consistent for the KEY def + ;; of function FUN. + (let ((prop (get fun 'efs-function-arg-structure)) + count) + (if (eq list 'autoload) + (or prop (put fun 'efs-function-arg-structure 'autoload)) + (setq count (efs-defun-arg-count list)) + (if (and prop (not (eq prop 'autoload)) (not (equal prop count))) + (let ((warning + (format + "args. for the %s def. of %s don't agree with previous defs." + key fun))) + (message (concat "Warning: " warning)) + ;; We are compiling, I suppose... + (if (get-buffer efs-defun-bytecomp-buffer) + (save-excursion + (set-buffer efs-defun-bytecomp-buffer) + (goto-char (point-max)) + (insert "efs warning:\n " warning "\n"))))) + (put fun 'efs-function-arg-structure count)))) + +(defun efs-def-generic (fun use doc-string interactive-p) + ;; Generates a generic function def using USE. + ;; If use is nil, the first arg of the function + ;; is the key. + (let ((def-args '(&rest efs-args)) + result) + (or use + (setq def-args (cons 'efs-key def-args))) + (setq result + (` (or (get (quote (, fun)) + (, (if use + (list 'intern + (list 'symbol-name use) + 'efs-key-obarray) + '(intern + (symbol-name efs-key) + efs-key-obarray)))) + (get (quote (, fun)) + (intern "nil" efs-key-obarray))))) + ;; Make the gen fun interactive, if nec. + (setq result + (if interactive-p + (` ((interactive) + (if (interactive-p) + (let ((prefix-arg current-prefix-arg)) + (call-interactively + (, result))) + (, (cons 'apply (list result 'efs-args)))))) + (list (cons 'apply (list result 'efs-args))))) + (if doc-string (setq result (cons doc-string result))) + (cons 'defun (cons fun (cons def-args result))))) + +(defun efs-def-autoload (fun key file from-kbd) + ;; Returns the autoload lambda for FUN and FILE. + ;; I really should have some notion of efs-autoload + ;; objects, and not just plain lambda's. + (let ((result + (if from-kbd + (` + (lambda (&rest args) + (interactive) + (let ((qkey (intern (symbol-name (quote (, key))) + efs-key-obarray)) + (tmp1 (intern "tmp1" efs-key-obarray)) + (tmp2 (intern "tmp2" efs-key-obarray))) + ;; Need to store the a-f-function, to see if it has been + ;; re-defined by the load. This is avoid to an infinite loop. + (set tmp1 (get (quote (, fun)) qkey)) + ;; Need to store the prefix arg in case it's interactive. + ;; These values are stored in variables interned in the + ;; efs-key-obarray, because who knows what loading a + ;; file might do. + (set tmp2 current-prefix-arg) + (load (, file)) + ;; check for re-def + (if (equal (symbol-value tmp1) + (get (quote (, fun)) qkey)) + (error "%s definition of %s is not defined by loading %s" + qkey (quote (, fun)) (, file))) + ;; call function + (if (interactive-p) + (let ((prefix-arg (symbol-value tmp2))) + (call-interactively + (get (quote (, fun)) qkey))) + (apply (get (quote (, fun)) qkey) args))))) + (` (lambda (&rest args) + (let ((qkey (intern (symbol-name (quote (, key))) + efs-key-obarray)) + (tmp1 (intern "tmp1" efs-key-obarray))) + ;; Need to store the a-f-function, to see if it has been + ;; re-defined by the load. This is avoid to an infinite loop. + (set tmp1 (get (quote (, fun)) qkey)) + (load (, file)) + ;; check for re-def + (if (equal (symbol-value tmp1) + (get (quote (, fun)) qkey)) + (error "%s definition of %s is not defined by loading %s" + qkey (quote (, fun)) (, file))) + ;; call function + (apply (get (quote (, fun)) qkey) args))))))) + (list 'put (list 'quote fun) + (list 'intern + (list 'symbol-name (list 'quote key)) + 'efs-key-obarray) + (list 'function result)))) + +;;; User level macros -- efs-defun and efs-autoload. + +(defmacro efs-defun (funame key args &rest body) + (let* ((use (and (eq (car-safe key) '&use) + (nth 1 key))) + (key (and (null use) key)) + result doc-string interactive-p) + ;; check args + (efs-defun-arg-check funame key args) + ;; extract doc-string + (if (stringp (car body)) + (setq doc-string (car body) + body (cdr body))) + ;; If the default fun is interactive, and it's a use construct, + ;; then we allow the gen fun to be interactive. + (if use + (setq interactive-p (eq (car-safe (car-safe body)) 'interactive))) + (setq result + (` ((put (quote (, funame)) + (intern (symbol-name (quote (, key))) + efs-key-obarray) + (function + (, (cons 'lambda + (cons args body))))) + (quote (, funame))))) + ;; if the key is null, make a generic def + (if (null key) + (setq result + (cons (efs-def-generic + funame use doc-string interactive-p) + result))) + ;; return + (cons 'progn result))) + +;;; For lisp-mode + +(put 'efs-defun 'lisp-indent-hook 'defun) + +;; efs-autoload +;; Allows efs function cells to be defined as autoloads. +;; If efs-autoload inserted autoload objects in the property list, +;; and the funcall mechanism in efs-defun checked for such +;; auto-load objects, we could reduce the size of the code +;; resulting from expanding efs-autoload. However, the expansion +;; of efs-defun would be larger. What is the best thing to do? + +(defmacro efs-autoload (fun key file &optional docstring from-kbd) + (let* ((use (and (eq (car-safe key) '&use) + (nth 1 key))) + (key (and (null use) key))) + (efs-defun-arg-check (eval fun) key 'autoload) + ;; has the function been previously defined? + (` + (if (null (get (, fun) + (intern (symbol-name (quote (, key))) + efs-key-obarray))) + (, + (if (null key) + (list 'progn + ;; need to eval fun, since autoload wants an explicit + ;; quote built into the fun arg. + (efs-def-generic + (eval fun) use docstring from-kbd ) + (efs-def-autoload (eval fun) key file from-kbd) + (list 'quote + (list + 'efs-autoload + key file docstring from-kbd))) + (list 'progn + (efs-def-autoload (eval fun) key file from-kbd) + (list 'quote + (list + 'efs-autoload + key file docstring from-kbd))))))))) + +(defun efs-fset (sym key fun) + ;; Like fset but sets KEY's definition of SYM. + (put sym (intern (symbol-name key) efs-key-obarray) fun)) + +(defun efs-fboundp (key fun) + ;; Like fboundp, but checks for KEY's def. + (null (null (get fun (intern (symbol-name key) efs-key-obarray))))) + +;; If we are going to use autoload objects, the following two functions +;; will be useful. +;; +;; (defun efs-defun-do-autoload (fun file key interactive-p args) +;; ;; Loads FILE and runs the KEY def of FUN. +;; (let (fun file key interactive-p args) +;; (load file)) +;; (let ((new-def (get fun key))) +;; (if (eq (car-safe new-def) 'autoload) +;; (error "%s definition of %s is not defined by loading %s" +;; key fun file) +;; (if interactive-p +;; (let ((prefix-arg current-predix-arg)) +;; (call-interactively fun)) +;; (apply new-def args))))) +;; +;; (defun efs-defun-autoload (fun key file doc-string from-kbd) +;; ;; Sets the KEY def of FUN to an autoload object. +;; (let* ((key (intern (symbol-name key) efs-key-obarray)) +;; (def (get fun key))) +;; (if (or (null def) +;; (eq (car-safe def) 'autoload)) +;; (put fun key (list 'autoload file doc-string from-kbd))))) + +;;; end of efs-defun.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-dired-mule.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-dired-mule.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,55 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-dired.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Makes efs-dired.el work with MULE. +;; Author: Ishikawa Ichiro +;; Created: Sat Aug 20 05:25:55 1994 +;; Modified: Sun Nov 27 12:19:17 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defconst efs-dired-mule-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;; Keep the byte-compiler happy +(defvar efs-version-host-types) +(defvar efs-dired-host-type) + +(defun efs-dired-find-file (&optional coding-system) + "Documented as original" + (interactive "ZCoding-system: ") + (let ((file (dired-get-filename))) + (if (memq efs-dired-host-type efs-version-host-types) + (setq file (efs-internal-file-name-sans-versions + efs-dired-host-type file t))) + (find-file file coding-system))) + +(defun efs-dired-find-file-other-window (&optional display coding-system) + "Documented as original" + (interactive "P\nZCoding-system: ") + (if display + (dired-display-file coding-system) + (let ((file (dired-get-filename))) + (if (memq efs-dired-host-type efs-version-host-types) + (setq file (efs-internal-file-name-sans-versions + efs-dired-host-type file t))) + (find-file-other-window file coding-system)))) + + +(defun efs-dired-display-file (&optional coding-system) + "Documented as original" + (interactive "ZCoding-system: ") + (let ((file (dired-get-filename))) + (if (memq efs-dired-host-type efs-version-host-types) + (setq file (efs-internal-file-name-sans-versions + efs-dired-host-type file t))) + (display-buffer (find-file-noselect file coding-system)))) + +;;; end of efs-dired-mule.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-dired.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-dired.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,1645 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-dired.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Extends much of Dired to work under efs. +;; Authors: Sebastian Kremer , +;; Andy Norman , +;; Sandy Rutherford +;; Created: Throughout the ages. +;; Modified: Sun Nov 27 12:19:46 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Provisions and requirements + +(provide 'efs-dired) +(require 'efs) +(require 'dired) +(autoload 'dired-shell-call-process "dired-shell") + +(defconst efs-dired-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;; ---------------------------------------------------------------- +;;;; User Configuration Variables +;;;; ---------------------------------------------------------------- + +(defvar efs-dired-verify-modtime-host-regexp nil + "Regular expression determining on which hosts dired modtimes are checked.") + +(defvar efs-dired-verify-anonymous-modtime nil + "If non-nil, dired modtimes are checked for anonymous logins.") + +(defvar efs-remote-shell-file-name + (if (memq system-type '(hpux usg-unix-v)) ; hope that's right + "remsh" + "rsh") + "Remote shell used by efs.") + +(defvar efs-remote-shell-takes-user + (null (null (memq system-type '(aix-v3 hpux silicon-graphics-unix + berkeley-unix)))) + ;; Complete? Doubt it. + "Set to non-nil if your remote shell command takes \"-l USER\".") + +;;; Internal Variables + +(make-variable-buffer-local 'dired-ls-F-marks-symlinks) + +;;;; ----------------------------------------------------------- +;;;; Inserting Directories into Buffers +;;;; ----------------------------------------------------------- + +;; The main command for inserting a directory listing in a buffer. +;; In Emacs 19 this is in files.el, and not specifically connected to +;; dired. Since our version of it uses some dired functions, it is +;; included here, but there is an autoload for it in efs.el. + +(defun efs-insert-directory (file switches &optional wildcard full-directory-p + nowait marker-char) + ;; Inserts a remote directory. Can do this asynch. + (let* ((parsed (efs-ftp-path file)) + (mk (point-marker)) + (host (car parsed)) + (user (nth 1 parsed)) + (path (nth 2 parsed)) + (host-type (efs-host-type host)) + (dumb (memq host-type efs-dumb-host-types)) + (subdir (and (null (or full-directory-p wildcard)) + (condition-case nil + (dired-current-directory) + (error nil)))) + (case-fold-search nil) ; for testing switches + (parse (and full-directory-p (not wildcard) + (or dumb (efs-parsable-switches-p switches)))) + ;; In case dired-omit-silent isn't defined. + (dired-omit-silent (and (boundp 'dired-omit-silent) + dired-omit-silent))) + + ;; Insert the listing. If it's not a wild-card, and not a full-dir, + ;; then we are updating a dired-line. Do this asynch. + ;; This way of doing the listing makes sure that the dired + ;; buffer is still around after the listing is obtained. + + (efs-ls + file switches t (if parse 'parse t) nil + ;; asynch, if we're inserting in a subdir. Do it nowait = 0, so + ;; updating the file line gets a high priority?? + ;; Insert subdir listings NOWAIT = 0 also so 1-line + ;; updates don't toggle the mode line. + (if (and subdir nowait) 0 nowait) + (efs-cont (listing) (host user file path wildcard + nowait marker-char + mk subdir parse switches dired-omit-silent) + ;; We pass the value of dired-omit-silent from the caller to the cont. + (let ((host-type (efs-host-type host)) + (listing-type (efs-listing-type host user))) + (if (marker-buffer mk) + (efs-save-buffer-excursion + (set-buffer (marker-buffer mk)) + ;; parsing a listing, sometimes updates info + (if (and parse (eq major-mode 'dired-mode)) + (progn + (setq efs-dired-host-type host-type + efs-dired-listing-type listing-type + efs-dired-listing-type-string + (and efs-show-host-type-in-dired + (concat " " + (symbol-name + efs-dired-listing-type)))) + (if (memq host-type '(bsd-unix next-unix)) + (setq dired-ls-F-marks-symlinks nil) + (if (memq host-type '(sysV-unix apollo-unix)) + (setq dired-ls-F-marks-symlinks t))))) + (if subdir + ;; a 1-line re-list + (save-excursion + (efs-update-file-info + host-type file efs-data-buffer-name) + (goto-char mk) + (let ((new-subdir (condition-case nil + (dired-current-directory) + (error nil))) + buffer-read-only) + (if (and new-subdir + (string-equal subdir new-subdir)) + (progn + ;; Is there an existing entry? + (if (dired-goto-file file) + (progn + (delete-region + (save-excursion + (skip-chars-backward "^\n\r") + (1- (point))) + (progn + (skip-chars-forward "^\n\r") + (point))) + (goto-char mk))) + (insert listing) + (save-restriction + (narrow-to-region mk (point)) + (efs-dired-fixup-listing + listing-type file path switches wildcard) + (efs-dired-ls-trim + listing-type) + ;; save-excursion loses if fixup had to + ;; remove and re-add the region. Say for + ;; sorting. + (goto-char (point-max))) + (if (and nowait (eq major-mode 'dired-mode)) + (dired-after-add-entry + (marker-position mk) + marker-char)))))) + (goto-char mk) + (let (buffer-read-only) + (insert listing) + (save-restriction + (narrow-to-region mk (point)) + (efs-dired-fixup-listing + listing-type file path switches wildcard) + (goto-char (point-max)))))))))) + ;; Return 0 if synch, nil if asynch + (if nowait nil 0))) + +;;; Functions for cleaning listings. + +(efs-defun efs-dired-ls-trim nil () + ;; Trims dir listings, so that the listing of a single file is one line. + nil) + +(efs-defun efs-dired-fixup-listing nil (file path &optional switches wildcard) + ;; FILE is in efs syntax. + ;; PATH is just the remote path. + ;; Some ftpd's put the whole directory name in front of each filename. + ;; Seems to depend in a strange way on server-client interaction. + ;; Walk down the listing generated and remove this stuff. + ;; SWITCHES is a string. + (if (memq efs-key efs-unix-host-types) + (let ((continue t) + spot bol) + (goto-char (point-min)) + (while (and (not (eobp)) continue) + (and (setq bol (point) + spot (dired-manual-move-to-filename nil bol)) + (setq continue (= (following-char) ?/)) + (dired-manual-move-to-end-of-filename t bol) + (progn + (skip-chars-backward "^/") + (delete-region spot (point)))) + (forward-line 1)) + (efs-save-match-data + (if (and switches (string-match "R" switches) + (not (string-match "d" switches))) + (let ((subdir-regexp "^\\(/[^ \n\r]+\\):[\n\r]") + name) + (goto-char (point-min)) + (while (re-search-forward subdir-regexp nil t) + (goto-char (match-beginning 0)) + ;; There may be /./ type nonsense. + ;; expand-file-name will handle it. + (setq name (expand-file-name + (buffer-substring (point) (match-end 0)))) + (delete-region (point) (match-end 0)) + (insert (efs-replace-path-component file name))))))))) + + +;;;; ------------------------------------------------------------ +;;;; Tree Dired support +;;;; ------------------------------------------------------------ + +;;; efs-dired keymap + +(defvar efs-dired-map nil + "Keymap for efs commands in dired buffers.") + +(if efs-dired-map + () + (setq efs-dired-map (make-sparse-keymap)) + (define-key efs-dired-map "c" 'efs-dired-close-ftp-process) + (define-key efs-dired-map "k" 'efs-dired-kill-ftp-process) + (define-key efs-dired-map "o" 'efs-dired-display-ftp-process-buffer) + (define-key efs-dired-map "p" 'efs-dired-ping-connection)) + +(fset 'efs-dired-prefix efs-dired-map) + +;;; Functions for dealing with the FTP process + +(defun efs-dired-close-ftp-process () + "Close the FTP process for the current dired buffer. +Closing causes the connection to be dropped, but efs will retain its +cached data for the connection. This will make it more efficient to +reopen the connection." + (interactive) + (or efs-dired-host-type + (error "Dired buffer is not for a remote directory.")) + (efs-close-ftp-process (current-buffer)) + (let ((parsed (efs-ftp-path default-directory))) + (message "Closed FTP connection for %s@%s." (nth 1 parsed) (car parsed)))) + +(defun efs-dired-kill-ftp-process () + "Kills the FTP process for the current dired buffer. +Killing causes the connection to be closed, the process buffer to be killed, +and most of efs's cached data to be wiped." + (interactive) + (or efs-dired-host-type + (error "Dired buffer is not for a remote directory.")) + (efs-kill-ftp-process (current-buffer)) + (let ((parsed (efs-ftp-path default-directory))) + (message "Killed FTP connection for %s@%s." (nth 1 parsed) (car parsed)))) + +(defun efs-dired-display-ftp-process-buffer () + "Displays in another window the FTP process buffer for a dired buffer." + (interactive) + (or efs-dired-host-type + (error "Dired buffer is not for a remote directory.")) + (efs-display-ftp-process-buffer (current-buffer))) + +(defun efs-dired-ping-connection () + "Pings FTP connection associated with current dired buffer." + (interactive) + (or efs-dired-host-type + (error "Dired buffer is not for a remote directory.")) + (efs-ping-ftp-connection (current-buffer))) + + +;;; Reading in dired buffers. + +(defun efs-dired-revert (&optional arg noconfirm) + (let ((efs-ls-uncache t)) + (dired-revert arg noconfirm))) + +(defun efs-dired-default-dir-function () + (let* ((cd (dired-current-directory)) + (parsed (efs-ftp-path cd))) + (if parsed + (efs-save-match-data + (let ((tail directory-abbrev-alist)) + (while tail + (if (string-match (car (car tail)) cd) + (setq cd (concat (cdr (car tail)) + (substring cd (match-end 0))) + parsed nil)) + (setq tail (cdr tail))) + (apply 'efs-unexpand-parsed-filename + (or parsed (efs-ftp-path cd))))) + cd))) + +(defun efs-dired-before-readin () + ;; Put in the dired-before-readin-hook. + (let ((parsed (efs-ftp-path default-directory))) + (if parsed + (let ((host (car parsed)) + (user (nth 1 parsed))) + (setq efs-dired-listing-type (efs-listing-type host user) + efs-dired-host-type (efs-host-type host) + efs-dired-listing-type-string + (and efs-show-host-type-in-dired + (concat " " (symbol-name efs-dired-listing-type)))) + (set (make-local-variable 'revert-buffer-function) + (function efs-dired-revert)) + (set (make-local-variable 'default-directory-function) + (function efs-dired-default-dir-function)) + (set (make-local-variable 'dired-verify-modtimes) + (null (null (and + efs-dired-verify-modtime-host-regexp + (efs-save-match-data + (let ((case-fold-search t)) + (string-match + efs-dired-verify-modtime-host-regexp host)) + (or efs-dired-verify-anonymous-modtime + (not (efs-anonymous-p user)))))))) + ;; The hellsoft ftp server mixes up cases. + ;; However, we may not be able to catch this until + ;; after the first directory is listed. + (if (and + (eq efs-dired-host-type 'hell) + (not (string-equal default-directory + (setq default-directory + (downcase default-directory))))) + (or (string-equal (buffer-name) (downcase (buffer-name))) + (rename-buffer (generate-new-buffer-name + (directory-file-name default-directory))))) + ;; Setup the executable and directory regexps + (let ((eentry (assq efs-dired-listing-type + efs-dired-re-exe-alist)) + (dentry (assq efs-dired-listing-type + efs-dired-re-dir-alist))) + (if eentry + (set (make-local-variable 'dired-re-exe) (cdr eentry))) + (if dentry + (set (make-local-variable 'dired-re-dir) (cdr dentry)))) + ;; No switches are sent to dumb hosts, so don't confuse dired. + ;; I hope that dired doesn't get excited if it doesn't see the l + ;; switch. If it does, then maybe fake things by setting this to + ;; "-Al". + (if (eq efs-dired-listing-type 'vms) + (setq dired-internal-switches + (delq ?F dired-internal-switches)) + (if (memq efs-dired-host-type efs-dumb-host-types) + (setq dired-internal-switches '(?l ?A) + ;; Don't lie on the mode line + dired-sort-mode ""))) + ;; If the remote file system is version-based, don't set + ;; dired-kept-versions to 0. It will flag the most recent + ;; copy of the file for deletion -- this isn't really a backup. + (if (memq efs-dired-host-type efs-version-host-types) + (set (make-local-variable 'dired-kept-versions) + (max 1 dired-kept-versions))))))) + +(efs-defun efs-dired-insert-headerline (&use efs-dired-listing-type) (dir) + "Documented as original." + (efs-real-dired-insert-headerline dir)) + +(defun efs-dired-uncache (file dir-p) + ;; Remove FILE from cache. + (if dir-p + (efs-del-from-ls-cache file nil t) + (efs-del-from-ls-cache file t nil))) + +;;; Checking modtimes of directories. +;; +;; This only runs if efs-dired-verify-anonymous-modtime and +;; efs-verify-modtime-host-regexp turn it on. Few (any?) FTP servers +;; support getting MDTM for directories. As usual, we cache whether +;; this works, and don't keep senselessly trying it if it doesn't. + +(defun efs-dired-file-modtime (file) + ;; Returns the modtime. + (let* ((parsed (efs-ftp-path file)) + (host (car parsed)) + (user (nth 1 parsed)) + (rpath (nth 2 parsed))) + (and (null (efs-get-host-property host 'dir-mdtm-failed)) + (let ((result (efs-send-cmd host user (list 'quote 'mdtm rpath) + (and (eq efs-verbose t) + "Getting modtime"))) + mp) + (if (and (null (car result)) + (setq mp (efs-parse-mdtime (nth 1 result)))) + (let ((ent (efs-get-file-entry file))) + (if ent + (setcdr ent (list (nth 1 ent) (nth 2 ent) + (nth 3 ent) (nth 4 ent) mp))) + parsed) + (efs-set-host-property host 'dir-mdtm-failed t) + nil))))) + +(defun efs-dired-set-file-modtime (file alist) + ;; This works asynch. + (let* ((parsed (efs-ftp-path file)) + (host (car parsed)) + (user (nth 1 parsed)) + (path (nth 2 parsed))) + (if (efs-get-host-property host 'dir-mdtm-failed) + (let ((elt (assoc file alist))) + (if elt (setcar (nthcdr 4 elt) nil))) + (efs-send-cmd + host user (list 'quote 'mdtm path) nil nil + (efs-cont (result line cont-lines) (file alist host) + (let ((elt (assoc file alist)) + modtime) + (if (and (null result) (setq modtime (efs-parse-mdtime line))) + (if elt (setcar (nthcdr 4 elt) modtime)) + (if elt (setcar (nthcdr 4 elt) nil)) + (efs-set-host-property host 'dir-mdtm-failed t)))) + 0) ; Always do this NOWAIT = 0 + nil))) ; return NIL + +;;; Asynch insertion of subdirs. Used when renaming subdirs. + +(defun efs-dired-insert-subdir (dirname &optional noerror nowait) + (let ((buff (current-buffer)) + (switches (delq ?R (copy-sequence dired-internal-switches)))) + (efs-ls + dirname (dired-make-switches-string switches) + t nil noerror nowait + (efs-cont (listing) (dirname buff switches) + (if (and listing (get-buffer buff)) + (save-excursion + (set-buffer buff) + (save-excursion + (let ((elt (assoc dirname dired-subdir-alist)) + mark-list) + (if elt + (setq mark-list (dired-insert-subdir-del elt)) + (dired-insert-subdir-newpos dirname)) + (dired-insert-subdir-doupdate + dirname + (efs-dired-insert-subdir-do-insert dirname listing) + switches elt mark-list))))))))) + +(defun efs-dired-insert-subdir-do-insert (dirname listing) + (let ((begin (point)) + indent-tabs-mode end) + (insert listing) + (setq end (point-marker)) + (indent-rigidly begin end 2) + (goto-char begin) + (dired-insert-headerline dirname) + ;; If the listing has null lines `quote' them so that "\n\n" delimits + ;; subdirs. This is OK, because we aren't inserting -R listings. + (save-excursion + (while (search-forward "\n\n" end t) + (forward-char -1) + (insert " "))) + ;; point is now like in dired-build-subdir-alist + (prog1 + (list begin (marker-position end)) + (set-marker end nil)))) + +;;; Moving around in dired buffers. + +(efs-defun efs-dired-manual-move-to-filename (&use efs-dired-listing-type) + (&optional raise-error bol eol) + "Documented as original." + (efs-real-dired-manual-move-to-filename raise-error bol eol)) + +(efs-defun efs-dired-manual-move-to-end-of-filename + (&use efs-dired-listing-type) (&optional no-error bol eol) + "Documented as original." + (efs-real-dired-manual-move-to-end-of-filename no-error bol eol)) + +(efs-defun efs-dired-make-filename-string (&use efs-dired-listing-type) + (filename &optional reverse) + "Documented as original." + ;; This translates file names from the way that they are displayed + ;; in listings to the way that the user gives them in the minibuffer. + ;; For example, in CMS this should take "FOO BAR" to "FOO.BAR". + filename) + +(defun efs-dired-find-file () + "Documented as original." + (interactive) + (find-file + (if (memq efs-dired-host-type efs-version-host-types) + (efs-internal-file-name-sans-versions + efs-dired-host-type (dired-get-filename) t) + (dired-get-filename)))) + +(defun efs-dired-find-file-other-window (&optional display) + "Documented as original." + (interactive "P") + (if display + (dired-display-file) + (let ((file (dired-get-filename))) + (if (memq efs-dired-host-type efs-version-host-types) + (setq file (efs-internal-file-name-sans-versions + efs-dired-host-type file t))) + (find-file-other-window file)))) + +(defun efs-dired-display-file () + "Documented as original." + (interactive) + (let ((file (dired-get-filename))) + (if (memq efs-dired-host-type efs-version-host-types) + (setq file (efs-internal-file-name-sans-versions + efs-dired-host-type file t))) + (display-buffer (find-file-noselect file)))) + +(defun efs-dired-find-file-other-frame () + "Documented as original." + (interactive) + (find-file-other-frame + (if (memq efs-dired-host-type efs-version-host-types) + (efs-internal-file-name-sans-versions + efs-dired-host-type (dired-get-filename) t) + (dired-get-filename)))) + +;;; Creating and deleting new directories. + +(defun efs-dired-recursive-delete-directory (fn) + ;; Does recursive deletion of remote directories for dired. + (or (file-exists-p fn) + (signal 'file-error + (list "Removing old file name" "no such directory" fn))) + (efs-dired-internal-recursive-delete-directory fn)) + +(defun efs-dired-internal-recursive-delete-directory (fn) + (if (eq (car (file-attributes fn)) t) + (let ((files (efs-directory-files fn))) + (if files + (mapcar (function + (lambda (ent) + (or (string-equal "." ent) + (string-equal ".." ent) + (efs-dired-internal-recursive-delete-directory + (expand-file-name ent fn))))) + files)) + (efs-delete-directory fn)) + (condition-case err + (efs-delete-file fn) + (ftp-error (if (and (nth 2 err) (stringp (nth 2 err)) + (efs-save-match-data + (string-match "^FTP Error: \"550 " (nth 2 err)))) + (message "File %s already deleted." fn) + (signal (car err) (cdr err))))))) + +;;; File backups and versions. + +(efs-defun efs-dired-flag-backup-files + (&use efs-dired-host-type) (&optional unflag-p) + "Documented as original." + (interactive "P") + (efs-real-dired-flag-backup-files unflag-p)) + +(efs-defun efs-dired-collect-file-versions (&use efs-dired-host-type) () + ;; If it looks like a file has versions, return a list of the versions. + ;; The return value is ((FILENAME . (VERSION1 VERSION2 ...)) ...) + (efs-real-dired-collect-file-versions)) + +;;; Sorting dired buffers + +(defun efs-dired-file-name-lessp (name1 name2) + (if (and efs-dired-host-type + (memq efs-dired-host-type efs-case-insensitive-host-types)) + (string< (downcase name1) (downcase name2)) + (string< name1 name2))) + +;;; Support for async file creators. + +(defun efs-dired-copy-file (from to ok-flag &optional cont nowait) + ;; Version of dired-copy-file for remote files. + ;; Assumes that filenames are already expanded. + (dired-handle-overwrite to) + (efs-copy-file-internal from (efs-ftp-path from) to (efs-ftp-path to) + ok-flag dired-copy-preserve-time 0 cont nowait)) + +(defun efs-dired-rename-file (from to ok-flag &optional cont nowait + insert-subdir) + ;; Version of dired-rename-file for remote files. + (dired-handle-overwrite to) + (efs-rename-file-internal + from to ok-flag nil + (efs-cont (result line cont-lines) (from to cont insert-subdir) + (if result + (if cont + (efs-call-cont cont result line cont-lines) + (signal 'ftp-error + (list "Dired Renaming" + (format "FTP Error: \"%s\"" line) + from to))) + (dired-remove-file from) + ;; Silently rename the visited file of any buffer visiting this file. + ;; We do not maintain inserted subdirs for remote + (efs-dired-rename-update-buffers from to insert-subdir) + (if cont (efs-call-cont cont result line cont-lines)))) + nowait)) + +(defun efs-dired-rename-update-buffers (from to &optional insert-subdir) + (if (get-file-buffer from) + (save-excursion + (set-buffer (get-file-buffer from)) + (let ((modflag (buffer-modified-p))) + (set-visited-file-name to) ; kills write-file-hooks + (set-buffer-modified-p modflag))) + ;; It's a directory. More work to do. + (let ((blist (buffer-list)) + (from-dir (file-name-as-directory from)) + (to-dir (file-name-as-directory to))) + (save-excursion + (while blist + (set-buffer (car blist)) + (setq blist (cdr blist)) + (cond + (buffer-file-name + (if (dired-in-this-tree buffer-file-name from-dir) + (let ((modflag (buffer-modified-p))) + (unwind-protect + (set-visited-file-name + (concat to-dir (substring buffer-file-name + (length from-dir)))) + (set-buffer-modified-p modflag))))) + (dired-directory + (if (string-equal from-dir (expand-file-name default-directory)) + ;; If top level directory was renamed, lots of things + ;; have to be updated. + (progn + (dired-unadvertise from-dir) + (setq default-directory to-dir + dired-directory + ;; Need to beware of wildcards. + (expand-file-name + (file-name-nondirectory dired-directory) + to-dir)) + (let ((new-name (file-name-nondirectory + (directory-file-name dired-directory)))) + ;; Try to rename buffer, but just leave old name if new + ;; name would already exist (don't try appending "<%d>") + ;; Why? --sandy 19-8-94 + (or (get-buffer new-name) + (rename-buffer new-name))) + (dired-advertise)) + (and insert-subdir + (assoc (file-name-directory (directory-file-name to)) + dired-subdir-alist) + (if (efs-ftp-path to) + (efs-dired-insert-subdir to t 1) + (dired-insert-subdir to))))))))))) + +(defun efs-dired-make-relative-symlink (from to ok-flag &optional cont nowait) + ;; efs version of dired-make-relative-symlink + ;; Called as a file-name-handler when dired-make-relative-symlink is + ;; called interactively. + ;; efs-dired-create-files calls it directly to supply CONT + ;; and NOWAIT args. + (setq from (directory-file-name from) + to (directory-file-name to)) + (efs-make-symbolic-link-internal + (dired-make-relative from (file-name-directory to) t) + to ok-flag cont nowait)) + +(defun efs-dired-create-files (file-creator operation fn-list name-constructor + &optional marker-char query + implicit-to) + "Documented as original." + (if (catch 'found + (let ((list fn-list) + val) + (while list + (if (setq val (efs-ftp-path (car list))) + (throw 'found val) + (if (setq val (funcall name-constructor (car list))) + (throw 'found (efs-ftp-path val)) + (setq list (cdr list))))))) + (progn + (cond ((eq file-creator 'dired-copy-file) + (setq file-creator 'efs-dired-copy-file)) + ((eq file-creator 'dired-rename-file) + (setq file-creator 'efs-dired-rename-file)) + ((eq file-creator 'make-symbolic-link) + (setq file-creator 'efs-make-symbolic-link-internal)) + ((eq file-creator 'add-name-to-file) + (setq file-creator 'efs-add-name-to-file-internal)) + ((eq file-creator 'dired-make-relative-symlink) + (setq file-creator 'efs-dired-make-relative-symlink)) + ((eq file-creator 'dired-compress-file) + (setq file-creator 'efs-dired-compress-file)) + ((error "Unable to perform operation %s on remote hosts." + file-creator))) + ;; use the process-filter driven routine rather than the iterative one. + (efs-dcf-1 file-creator operation fn-list name-constructor + (if (eq marker-char t) + (mapcar 'dired-file-marker fn-list) + marker-char) + query (buffer-name (current-buffer)) + nil ;overwrite-query + nil ;dired-overwrite-backup-query + nil ;dired-file-creator-query + nil ;failures + nil ;skipped + 0 ;success-count + (length fn-list) ;total + implicit-to + (and (eq file-creator 'efs-dired-rename-file) + (delq nil + (mapcar + (function + (lambda (x) + (and (assoc (file-name-as-directory x) + dired-subdir-alist) + x))) + fn-list))))) + ;; normal case... use the interative routine... much cheaper. + (efs-real-dired-create-files file-creator operation fn-list + name-constructor marker-char query + implicit-to))) + +(defun efs-dcf-1 (file-creator operation fn-list name-constructor + markers query buffer-name overwrite-query + overwrite-backup-query file-creator-query + failures skipped success-count total + implicit-to insertions) + (if (null fn-list) + (efs-dcf-3 failures operation total skipped + success-count buffer-name) + (let* ((from (car fn-list)) + ;; For dired-handle-overwrite and the file-creator-query, + ;; need to set these 2 fluid vars according to the cont data. + (dired-overwrite-backup-query overwrite-backup-query) + (dired-file-creator-query file-creator-query) + (to (funcall name-constructor from)) + (marker-char (if (consp markers) + (prog1 (car markers) + (setq markers (cdr markers))) + markers)) + (fn-list (cdr fn-list))) + (if to + (if (equal to from) + (progn + (dired-log buffer-name "Cannot %s to same file: %s\n" + (downcase operation) from) + (efs-dcf-1 file-creator operation fn-list name-constructor + markers query buffer-name overwrite-query + dired-overwrite-backup-query + dired-file-creator-query failures + (cons (dired-make-relative from nil t) skipped) + success-count total implicit-to insertions)) + (if (or (null query) + (funcall query from to)) + (let* ((overwrite (let (jka-compr-enabled) + ;; Don't let jka-compr fool us. + (file-exists-p to))) + (overwrite-confirmed ; for dired-handle-overwrite + (and overwrite + (let ((help-form '(format "\ +Type SPC or `y' to overwrite file `%s', +DEL or `n' to skip to next, +ESC or `q' to not overwrite any of the remaining files, +`!' to overwrite all remaining files with no more questions." to))) + (dired-query 'overwrite-query + "Overwrite `%s'?" to))))) + (condition-case err + (let ((dired-unhandle-add-files + (cons to dired-unhandle-add-files))) + (if implicit-to + (funcall file-creator from overwrite-confirmed + (list (function efs-dcf-2) + file-creator operation fn-list + name-constructor markers + query marker-char + buffer-name to from overwrite + overwrite-confirmed overwrite-query + dired-overwrite-backup-query + dired-file-creator-query + failures skipped success-count + total implicit-to insertions) + t) + (apply file-creator from to overwrite-confirmed + (list (function efs-dcf-2) + file-creator operation fn-list + name-constructor markers + query marker-char + buffer-name to from overwrite + overwrite-confirmed overwrite-query + dired-overwrite-backup-query + dired-file-creator-query + failures skipped success-count total + implicit-to insertions) + (if insertions + (list t insertions) + '(t))))) + (error ; FILE-CREATOR aborted + (efs-dcf-2 'failed ;result + (format "%s" err) ;line + "" file-creator operation fn-list + name-constructor markers query marker-char + buffer-name to from overwrite + overwrite-confirmed overwrite-query + dired-overwrite-backup-query + dired-file-creator-query failures skipped + success-count total implicit-to insertions)))) + (efs-dcf-1 file-creator operation fn-list name-constructor + markers query buffer-name overwrite-query + dired-overwrite-backup-query dired-file-creator-query + failures + (cons (dired-make-relative from nil t) skipped) + success-count total implicit-to insertions))) + (efs-dcf-1 file-creator operation fn-list name-constructor + markers query buffer-name overwrite-query + dired-overwrite-backup-query dired-file-creator-query + failures (cons (dired-make-relative from nil t) skipped) + success-count total implicit-to insertions))))) + +(defun efs-dcf-2 (result line cont-lines file-creator operation fn-list + name-constructor markers query marker-char + buffer-name to from overwrite overwrite-confirmed + overwrite-query overwrite-backup-query + file-creator-query failures skipped success-count + total implicit-to insertions) + (if result + (progn + (setq failures (cons (dired-make-relative from nil t) failures)) + (dired-log buffer-name "%s `%s' to `%s' failed:\n%s\n" + operation from to line)) + (setq success-count (1+ success-count)) + (message "%s: %d of %d" operation success-count total) + (let ((efs-ls-uncache t)) + (dired-add-file to marker-char))) + ;; iterate again + (efs-dcf-1 file-creator operation fn-list name-constructor + markers query buffer-name overwrite-query overwrite-backup-query + file-creator-query failures skipped success-count total + implicit-to insertions)) + +(defun efs-dcf-3 (failures operation total skipped success-count buffer-name) + (cond + (failures + (dired-log-summary buffer-name (format "%s failed for %d of %d file%s" + operation (length failures) total + (dired-plural-s total)) failures)) + (skipped + (dired-log-summary buffer-name (format "%s: %d of %d file%s skipped" + operation (length skipped) total + (dired-plural-s total)) skipped)) + (t + (message "%s: %s file%s." + operation success-count + (dired-plural-s success-count))))) + +;;; Running remote shell commands + +;;; This support isn't very good. efs is really about a virtual file system, +;;; and not remote processes. What is really required is low-level +;;; support for start-process & call-process on remote hosts. This shouldn't +;;; be part of efs, although. + +(defun efs-dired-shell-unhandle-file-name (filename) + ;; Puts remote file names into a form where they can be passed to remsh. + (nth 2 (efs-ftp-path filename))) + +(defun efs-dired-shell-call-process (command dir &optional in-background) + ;; Runs shell process on remote hosts. + (let* ((parsed (efs-ftp-path dir)) + (host (car parsed)) + (user (nth 1 parsed)) + (rdir (nth 2 parsed)) + (file-name-handler-alist nil)) + (or (string-equal (efs-internal-directory-file-name dir) + (efs-expand-tilde "~" (efs-host-type host) host user)) + (string-match "^cd " command) + (setq command (concat "cd " rdir "; " command))) + (setq command + (format "%s %s%s \"%s\"" ; remsh -l USER does not work well + ; on a hp-ux machine I tried + efs-remote-shell-file-name host + (if efs-remote-shell-takes-user + (concat " -l " user) + "") + command)) + (message "Doing shell command on %s..." host) + (dired-shell-call-process + command (file-name-directory efs-tmp-name-template) in-background))) + +;;; Dired commands for running local processes on remote files. +;; +;; Lots of things in this section need to be re-thunk. + +(defun efs-dired-call-process (program discard &rest arguments) + "Documented as original." + ;; PROGRAM is always one of those below in the cond in dired.el. + ;; The ARGUMENTS are (nearly) always files. + (if (efs-ftp-path default-directory) + ;; Can't use efs-dired-host-type here because the current + ;; buffer is *dired-check-process output* + (condition-case oops + (cond + ((string-equal "efs-call-compress" program) + (apply 'efs-call-compress arguments)) + ((string-equal "chmod" program) + (efs-call-chmod arguments)) + (t (error "Unknown remote command: %s" program))) + (ftp-error (dired-log (buffer-name (current-buffer)) + (format "%s: %s, %s\n" + (nth 1 oops) + (nth 2 oops) + (nth 3 oops)))) + (error (dired-log (buffer-name (current-buffer)) + (format "%s\n" (nth 1 oops))))) + (apply 'call-process program nil (not discard) nil arguments))) + +(defun efs-dired-make-compressed-filename (name &optional method) + ;; Version of dired-make-compressed-filename for efs. + ;; If NAME is in the syntax of a compressed file (according to + ;; dired-compression-method-alist), return the data (a list) from this + ;; alist on how to uncompress it. Otherwise, return a string, the + ;; uncompressed form of this file name. This is computed using the optional + ;; argument METHOD (a symbol). If METHOD is nil, the ambient value of + ;; dired-compression-method is used. + (let* ((host-type (efs-host-type (car (efs-ftp-path name)))) + (ef-alist (if (memq host-type efs-single-extension-host-types) + (mapcar + (function + (lambda (elt) + (list (car elt) + (mapconcat + (function + (lambda (char) + (if (= char ?.) + "-" + (char-to-string char)))) + (nth 1 elt) "") + (nth 2 elt) + (nth 3 elt)))) + dired-compression-method-alist) + dired-compression-method-alist)) + (alist ef-alist) + (len (length name)) + ext ext-len result) + (if (memq host-type efs-version-host-types) + (setq name (efs-internal-file-name-sans-versions host-type name))) + (if (memq host-type efs-case-insensitive-host-types) + (let ((name (downcase name))) + (while alist + (if (and (> len + (setq ext-len (length (setq ext (nth 1 (car alist)))))) + (string-equal (downcase ext) + (substring name (- ext-len)))) + (setq result (car alist) + alist nil) + (setq alist (cdr alist))))) + (while alist + (if (and (> len + (setq ext-len (length (setq ext (nth 1 (car alist)))))) + (string-equal ext (substring name (- ext-len)))) + (setq result (car alist) + alist nil) + (setq alist (cdr alist))))) + (or result + (concat name + (nth 1 (or (assq (or method dired-compression-method) + ef-alist) + (error "Unknown compression method: %s" + (or method dired-compression-method)))))))) + +(defun efs-dired-compress-file (file ok-flag &optional cont nowait) + ;; Version of dired-compress-file for remote files. + (let* ((compressed-fn (efs-dired-make-compressed-filename file)) + (host (car (efs-ftp-path file))) + (host-type (efs-host-type host))) + (cond ((file-symlink-p file) + (if cont + (efs-call-cont + cont 'failed + (format "Cannot compress %s, a symbolic link." file) "") + (signal 'file-error (list "Compress error:" file + "a symbolic link")))) + ((listp compressed-fn) + (let ((newname (substring (if (memq host-type + efs-version-host-types) + (efs-internal-file-name-sans-versions + host-type file) + file) + 0 (- (length (nth 1 compressed-fn))))) + (program (nth 3 compressed-fn))) + (if (and (memq host-type efs-unix-host-types) + (null (efs-get-host-property host 'exec-failed)) + (null (eq (efs-get-host-property + host + (intern + (concat + "exec-" + (efs-compress-progname (car program))))) + 'failed))) + (efs-call-remote-compress + program file newname t ok-flag + (efs-cont (result line cont-lines) (program file newname + cont nowait) + (if result + (if (eq result 'unsupported) + (efs-call-compress program file newname + t t cont nowait) + (if cont + (efs-call-cont cont result line cont-lines) + (signal 'ftp-error + (list "Uncompressing file" + (format "FTP Error: \"%s\" " line) + file)))) + (if cont (efs-call-cont cont result line cont-lines)))) + nowait) + (efs-call-compress + program file newname t ok-flag cont nowait) + newname))) + ((stringp compressed-fn) + (let ((program (nth 2 (assq dired-compression-method + dired-compression-method-alist)))) + (if (and (memq host-type efs-unix-host-types) + (null (efs-get-host-property host 'exec-failed)) + (null (eq (efs-get-host-property + host + (intern + (concat + "exec-" + (efs-compress-progname (car program))))) + 'failed))) + (efs-call-remote-compress + program file compressed-fn nil ok-flag + (efs-cont (result line cont-lines) (program file + compressed-fn + cont nowait) + (if result + (if (eq result 'unsupported) + (efs-call-compress program file compressed-fn nil + t cont nowait) + (if cont + (efs-call-cont cont result line cont-lines) + (signal 'ftp-error + (list "Compressing file" + (format "FTP Error: \"%s\" " line) + file)))) + (if cont (efs-call-cont cont result line cont-lines)))) + nowait) + (efs-call-compress + program file compressed-fn nil ok-flag cont nowait))) + compressed-fn) + (t (error "Strange error in efs-dired-compress-file."))))) + +(defun efs-dired-print-file (command file) + ;; Version of dired-print-file for remote files. + (let ((command (dired-trans-command command (list file) ""))) + ;; Only replace the first occurence of the file name? + (if (string-match (concat "[ ><|]\\(" (regexp-quote + (dired-shell-quote file)) + "\\)\\($\\|[ |><&]\\)") + command) + (setq command (concat (substring command 0 (match-beginning 1)) + "%s" + (substring command (match-end 1)))) + (error "efs-print-command: strange error")) + (efs-call-lpr file command))) + +;;;;---------------------------------------------------------------- +;;;; Support for `processes' run on remote files. +;;;; Usually (but not necessarily) these are only called from dired. +;;;;---------------------------------------------------------------- + +(defun efs-compress-progname (program) + ;; Returns a canonicalized i.e. without the "un", version of a compress + ;; program name. + (efs-save-match-data + (if (string-equal program "gunzip") + "gzip" + (if (string-match "^un" program) + (substring program (match-end 0)) + program)))) + +(defun efs-call-remote-compress (program filename newname &optional uncompress + ok-if-already-exists cont nowait) + ;; Run a remote compress process using SITE EXEC. + (if (or (not ok-if-already-exists) + (numberp ok-if-already-exists)) + (efs-barf-or-query-if-file-exists + newname + (if uncompress + "uncompress to it" + "compress to it") + (numberp ok-if-already-exists))) + (let* ((filename (expand-file-name filename)) + (parsed (efs-ftp-path filename)) + (host (car parsed)) + (user (nth 1 parsed)) + (rpath (nth 2 parsed))) + (if (efs-get-host-property host 'exec-failed) + (if cont + (efs-call-cont cont 'unsupported "SITE EXEC not supported" "") + (signal 'ftp-error (list "Unable to SITE EXEC" host))) + (let* ((progname (efs-compress-progname (car program))) + (propsym (intern (concat "exec-" progname))) + (prop (efs-get-host-property host propsym))) + (cond + ((eq prop 'failed) + (if cont + (efs-call-cont cont 'unsupported + (concat progname " not in FTP exec path") "") + (signal 'ftp-error + (list (concat progname " not in FTP exec path") host)))) + ((eq prop 'worked) + (efs-send-cmd + host user + (list 'quote 'site 'exec + (concat (mapconcat 'identity program " ") " " rpath)) + (concat (if uncompress "Uncompressing " "Compressing ") filename) + nil + (efs-cont (result line cont-lines) (host user filename cont) + (if result + (progn + (efs-set-host-property host 'exec-failed t) + (efs-error host user (concat "FTP exec Error: " line))) + (efs-save-match-data + (if (string-match "\n200-\\([^\n]*\\)" cont-lines) + (let ((err (substring cont-lines (match-beginning 1) + (match-end 1)))) + (if cont + (efs-call-cont cont 'failed err cont-lines) + (efs-error host user (concat "FTP Error: " err)))) + ;; This function only gets called for unix hosts, so + ;; we'll use the default version of efs-delete-file-entry + ;; and save a host-type lookup. + (efs-delete-file-entry nil filename) + (dired-remove-file filename) + (if cont (efs-call-cont cont nil line cont-lines)))))) + nowait)) + (t ; (null prop) + (efs-send-cmd + host user + (list 'quote 'site 'exec (concat progname " " "-V")) + (format "Checking for %s executable" progname) + nil + (efs-cont (result line cont-lines) (propsym host program filename + newname uncompress + cont nowait) + (efs-save-match-data + (if (string-match "\n200-" cont-lines) + (efs-set-host-property host propsym 'worked) + (efs-set-host-property host propsym 'failed))) + (efs-call-remote-compress program filename newname uncompress + t ; already tested for overwrite + cont nowait)) + nowait))))))) + +(defun efs-call-compress (program filename newname &optional uncompress + ok-if-already-exists cont nowait) + "Perform a compress command on a remote file. +PROGRAM is a list of the compression program and args. Works by taking a +copy of the file, compressing it and copying the file back. Returns 0 on +success, 1 or 2 on failure. If UNCOMPRESS is non-nil, does this instead." + (let* ((filename (expand-file-name filename)) + (newname (expand-file-name newname)) + (parsed (efs-ftp-path filename)) + (tmp1 (car (efs-make-tmp-name nil (car parsed)))) + (tmp2 (car (efs-make-tmp-name nil (car parsed)))) + (program (mapconcat 'identity program " "))) + (efs-copy-file-internal + filename parsed tmp1 nil + t nil 2 + (efs-cont (result line cont-lines) (filename newname tmp1 tmp2 program + uncompress ok-if-already-exists + cont nowait) + (if result + (signal 'ftp-error + (list "Opening input file" + (format "FTP Error: \"%s\" " line) filename)) + (let ((err-buff (let ((default-major-mode 'fundamental-mode)) + (get-buffer-create + (generate-new-buffer-name + (format + " efs-call-compress %s" filename)))))) + (save-excursion + (set-buffer err-buff) + (set (make-local-variable 'efs-call-compress-filename) filename) + (set (make-local-variable 'efs-call-compress-newname) newname) + (set (make-local-variable 'efs-call-compress-tmp1) tmp1) + (set (make-local-variable 'efs-call-compress-tmp2) tmp2) + (set (make-local-variable 'efs-call-compress-cont) cont) + (set (make-local-variable 'efs-call-compress-nowait) nowait) + (set (make-local-variable 'efs-call-compress-ok) + ok-if-already-exists) + (set (make-local-variable 'efs-call-compress-uncompress) + uncompress) + (set (make-local-variable 'efs-call-compress-abbr) + (efs-relativize-filename filename)) + (if efs-verbose + (efs-message + (format "%s %s..." + (if uncompress "Uncompressing" "Compressing") + (symbol-value (make-local-variable + 'efs-call-compress-abbr))))) + (set-process-sentinel + (start-process (format "efs-call-compress %s" filename) + err-buff shell-file-name + "-c" (format "%s %s < %s > %s" + program + ;; Hope -c makes the compress + ;; program write to std out. + "-c" + tmp1 tmp2)) + (function + (lambda (proc str) + (let ((buff (get-buffer (process-buffer proc)))) + (if buff + (save-excursion + (set-buffer buff) + (if (/= (buffer-size) 0) + (if cont + (efs-call-cont + (symbol-value + (make-local-variable + 'efs-call-compress-cont)) + 'failed + (concat + "failed to compress " + (symbol-value (make-local-variable + 'efs-call-compress-filename)) + ", " + (buffer-substring + (point-min) + (progn (goto-char (point-min)) + (end-of-line) (point)))))) + (efs-del-tmp-name (symbol-value + (make-local-variable + 'efs-call-compress-tmp1))) + (let ((tmp2 (symbol-value + (make-local-variable + 'efs-call-compress-tmp2))) + (newname (symbol-value + (make-local-variable + 'efs-call-compress-newname))) + (filename (symbol-value + (make-local-variable + 'efs-call-compress-filename))) + (cont (symbol-value + (make-local-variable + 'efs-call-compress-cont))) + (nowait (symbol-value + (make-local-variable + 'efs-call-compress-nowait))) + (ok (symbol-value + (make-local-variable + 'efs-call-compress-ok))) + (uncompress + (symbol-value + (make-local-variable + 'efs-call-compress-uncompress)))) + (if efs-verbose + (efs-message + (format "%s %s...done" + (if uncompress + "Uncompressing" + "Compressing") + (symbol-value + (make-local-variable + 'efs-call-compress-abbr))))) + (kill-buffer (current-buffer)) + (efs-copy-file-internal + tmp2 nil newname (efs-ftp-path newname) + ok nil 1 + (efs-cont (result line cont-lines) (cont + tmp2 + filename) + (efs-del-tmp-name tmp2) + (or result + (let (efs-verbose) + (efs-delete-file filename) + (dired-remove-file filename))) + (if cont + (efs-call-cont cont result line + cont-lines))) + nowait (if uncompress nil 'image))))) + (error "Strange error: %s" proc)))))))))) + nowait (if uncompress 'image nil)))) + +(defun efs-update-mode-string (perms modes) + ;; For PERMS of the form `u+w', and MODES a unix 9-character mode string, + ;; computes the new mode string. + ;; Doesn't call efs-save-match-data. The calling function should. + (or (string-match "^[augo]+\\([+-]\\)[rwxst]+$" perms) + (error "efs-update-mode-string: invalid perms %s" perms)) + (let* ((who (substring perms 0 (match-beginning 1))) + (add (= (aref perms (match-beginning 1)) ?+)) + (what (substring perms (match-end 1))) + (newmodes (copy-sequence modes)) + (read (string-match "r" what)) + (write (string-match "w" what)) + (execute (string-match "x" what)) + (sticky (string-match "t" what)) + (suid (string-match "s" what))) + (if (string-match "a" who) + (if add + (progn + (if read + (progn + (aset newmodes 0 ?r) + (aset newmodes 3 ?r) + (aset newmodes 6 ?r))) + (if write + (progn + (aset newmodes 1 ?w) + (aset newmodes 4 ?w) + (aset newmodes 7 ?w))) + (if execute + (let ((curr (aref newmodes 2))) + (if (= curr ?-) + (aset newmodes 2 ?x) + (if (= curr ?S) + (aset newmodes 2 ?s))) + (setq curr (aref newmodes 5)) + (if (= curr ?-) + (aset newmodes 5 ?x) + (if (= curr ?S) + (aset newmodes 5 ?s))) + (setq curr (aref newmodes 8)) + (if (= curr ?-) + (aset newmodes 8 ?x) + (if (= curr ?T) + (aset newmodes 8 ?t))))) + (if suid + (let ((curr (aref newmodes 2))) + (if (= curr ?-) + (aset newmodes 2 ?S) + (if (= curr ?x) + (aset newmodes 2 ?s))) + (setq curr (aref newmodes 5)) + (if (= curr ?-) + (aset newmodes 5 ?S) + (if (= curr ?x) + (aset newmodes 5 ?s))))) + (if sticky + (let ((curr (aref newmodes 8))) + (if (= curr ?-) + (aset newmodes 8 ?T) + (if (= curr ?x) + (aset newmodes 8 ?t)))))) + (if read + (progn + (aset newmodes 0 ?-) + (aset newmodes 3 ?-) + (aset newmodes 6 ?-))) + (if write + (progn + (aset newmodes 1 ?-) + (aset newmodes 4 ?-) + (aset newmodes 7 ?-))) + (if execute + (let ((curr (aref newmodes 2))) + (if (= curr ?x) + (aset newmodes 2 ?-) + (if (= curr ?s) + (aset newmodes 2 ?S))) + (setq curr (aref newmodes 5)) + (if (= curr ?x) + (aset newmodes 5 ?-) + (if (= curr ?s) + (aset newmodes 5 ?S))) + (setq curr (aref newmodes 8)) + (if (= curr ?x) + (aset newmodes 8 ?-) + (if (= curr ?t) + (aset newmodes 8 ?T))))) + (if suid + (let ((curr (aref newmodes 2))) + (if (= curr ?s) + (aset newmodes 2 ?x) + (if (= curr ?S) + (aset newmodes 2 ?-))) + (setq curr (aref newmodes 5)) + (if (= curr ?s) + (aset newmodes 5 ?x) + (if (= curr ?S) + (aset newmodes 5 ?-))))) + (if sticky + (let ((curr (aref newmodes 8))) + (if (= curr ?t) + (aset newmodes 8 ?x) + (if (= curr ?T) + (aset newmodes 8 ?-)))))) + (if (string-match "u" who) + (if add + (progn + (if read + (aset newmodes 0 ?r)) + (if write + (aset newmodes 1 ?w)) + (if execute + (let ((curr (aref newmodes 2))) + (if (= curr ?-) + (aset newmodes 2 ?x) + (if (= curr ?S) + (aset newmodes 2 ?s))))) + (if suid + (let ((curr (aref newmodes 2))) + (if (= curr ?-) + (aset newmodes 2 ?S) + (if (= curr ?x) + (aset newmodes 2 ?s)))))) + (if read + (aset newmodes 0 ?-)) + (if write + (aset newmodes 1 ?-)) + (if execute + (let ((curr (aref newmodes 2))) + (if (= curr ?x) + (aset newmodes 2 ?-) + (if (= curr ?s) + (aset newmodes 2 ?S))))) + (if suid + (let ((curr (aref newmodes 2))) + (if (= curr ?s) + (aset newmodes 2 ?x) + (if (= curr ?S) + (aset newmodes 2 ?-))))))) + (if (string-match "g" who) + (if add + (progn + (if read + (aset newmodes 3 ?r)) + (if write + (aset newmodes 4 ?w)) + (if execute + (let ((curr (aref newmodes 5))) + (if (= curr ?-) + (aset newmodes 5 ?x) + (if (= curr ?S) + (aset newmodes 5 ?s))))) + (if suid + (let ((curr (aref newmodes 5))) + (if (= curr ?-) + (aset newmodes 5 ?S) + (if (= curr ?x) + (aset newmodes 5 ?s)))))) + (if read + (aset newmodes 3 ?-)) + (if write + (aset newmodes 4 ?-)) + (if execute + (let ((curr (aref newmodes 5))) + (if (= curr ?x) + (aset newmodes 5 ?-) + (if (= curr ?s) + (aset newmodes 5 ?S))))) + (if suid + (let ((curr (aref newmodes 5))) + (if (= curr ?s) + (aset newmodes 5 ?x) + (if (= curr ?S) + (aset newmodes 5 ?-))))))) + (if (string-match "o" who) + (if add + (progn + (if read + (aset newmodes 6 ?r)) + (if write + (aset newmodes 7 ?w)) + (if execute + (let ((curr (aref newmodes 8))) + (if (= curr ?-) + (aset newmodes 8 ?x) + (if (= curr ?T) + (aset newmodes 8 ?t))))) + (if sticky + (let ((curr (aref newmodes 8))) + (if (= curr ?-) + (aset newmodes 8 ?T) + (if (= curr ?x) + (aset newmodes 5 ?t)))))) + (if read + (aset newmodes 6 ?-)) + (if write + (aset newmodes 7 ?-)) + (if execute + (let ((curr (aref newmodes 8))) + (if (= curr ?x) + (aset newmodes 8 ?-) + (if (= curr ?t) + (aset newmodes 8 ?T))))) + (if suid + (let ((curr (aref newmodes 8))) + (if (= curr ?t) + (aset newmodes 8 ?x) + (if (= curr ?T) + (aset newmodes 8 ?-)))))))) + newmodes)) + +(defun efs-compute-chmod-arg (perms file) + ;; Computes the octal number, represented as a string, required to + ;; modify the permissions PERMS of FILE. + (efs-save-match-data + (cond + ((string-match "^[0-7][0-7]?[0-7]?[0-7]?$" perms) + perms) + ((string-match "^[augo]+[-+][rwxst]+$" perms) + (let ((curr-mode (nth 3 (efs-get-file-entry file)))) + (or (and curr-mode + (stringp curr-mode) + (= (length curr-mode) 10)) + (progn + ;; Current buffer is process error buffer + (insert "Require an octal integer to modify modes for " + file ".\n") + (error "Require an octal integer to modify modes for %s." file))) + (format "%o" + (efs-parse-mode-string + (efs-update-mode-string perms + (substring curr-mode 1)))))) + (t + (insert "Don't know how to set modes " perms " for " file ".\n") + (error "Don't know how to set modes %s" perms))))) + +(defun efs-call-chmod (args) + ;; Sends an FTP CHMOD command. + (if (< (length args) 2) + (error "efs-call-chmod: missing mode and/or filename: %s" args)) + (let ((mode (car args)) + bombed) + (mapcar + (function + (lambda (file) + (setq file (expand-file-name file)) + (let ((parsed (efs-ftp-path file))) + (if parsed + (condition-case nil + (let* ((mode (efs-compute-chmod-arg mode file)) + (host (nth 0 parsed)) + (user (nth 1 parsed)) + (path (efs-quote-string + (efs-host-type host user) (nth 2 parsed))) + (abbr (efs-relativize-filename file)) + (result (efs-send-cmd host user + (list 'quote 'site 'chmod + mode path) + (format "doing chmod %s" + abbr)))) + (efs-del-from-ls-cache file t) + (if (car result) + (efs-error host user (format "chmod: %s: \"%s\"" file + (nth 1 result))))) + (error (setq bombed t))))))) + (cdr args)) + (if bombed 1 0))) ; return code + +(defun efs-call-lpr (file command-format) + "Print remote file FILE. SWITCHES are passed to the print program." + ;; Works asynch. + (let* ((file (expand-file-name file)) + (parsed (efs-ftp-path file)) + (abbr (efs-relativize-filename file)) + (temp (car (efs-make-tmp-name nil (car parsed))))) + (efs-copy-file-internal + file parsed temp nil t nil 2 + (efs-cont (result line cont-lines) (command-format file abbr temp) + (if result + (signal 'ftp-error (list "Opening input file" + (format "FTP Error: \"%s\" " line) + file)) + (message "Spooling %s..." abbr) + (set-process-sentinel + (start-process (format "*print %s /// %s*" abbr temp) + (generate-new-buffer-name " *print temp*") + "sh" "-c" (format command-format temp)) + (function + (lambda (proc status) + (let ((buff (process-buffer proc)) + (name (process-name proc))) + (if (and buff (get-buffer buff)) + (unwind-protect + (save-excursion + (set-buffer buff) + (if (> (buffer-size) 0) + (let ((log-buff (get-buffer-create + "*Shell Command Output*"))) + (set-buffer log-buff) + (goto-char (point-max)) + (or (bobp) + (insert "\n")) + (insert-buffer-substring buff) + (goto-char (point-max)) + (display-buffer log-buff)))) + (condition-case nil (kill-buffer buff) (error nil)) + (efs-save-match-data + (if (string-match "^\\*print \\(.*\\) /// \\(.*\\)\\*$" + name) + (let ((abbr (substring name (match-beginning 1) + (match-end 1))) + (temp (substring name (match-beginning 2) + (match-end 2)))) + (or (= (match-beginning 2) (match-end 2)) + (efs-del-tmp-name temp)) + (message "Spooling %s...done" abbr)))))))))))) + t))) + +;;;; -------------------------------------------------------------- +;;;; Attaching onto dired. +;;;; -------------------------------------------------------------- + +;;; Look out for MULE +(if (or (boundp 'MULE) (featurep 'mule)) (load "efs-dired-mule")) + +;;; Magic file name hooks for dired. + +(put 'dired-print-file 'efs 'efs-dired-print-file) +(put 'dired-make-compressed-filename 'efs 'efs-dired-make-compressed-filename) +(put 'dired-compress-file 'efs 'efs-dired-compress-file) +(put 'dired-recursive-delete-directory 'efs + 'efs-dired-recursive-delete-directory) +(put 'dired-uncache 'efs 'efs-dired-uncache) +(put 'dired-shell-call-process 'efs 'efs-dired-shell-call-process) +(put 'dired-shell-unhandle-file-name 'efs 'efs-dired-shell-unhandle-file-name) +(put 'dired-file-modtime 'efs 'efs-dired-file-modtime) +(put 'dired-set-file-modtime 'efs 'efs-dired-set-file-modtime) + +;;; Overwriting functions + +(efs-overwrite-fn "efs" 'dired-call-process) +(efs-overwrite-fn "efs" 'dired-insert-headerline) +(efs-overwrite-fn "efs" 'dired-manual-move-to-filename) +(efs-overwrite-fn "efs" 'dired-manual-move-to-end-of-filename) +(efs-overwrite-fn "efs" 'dired-make-filename-string) +(efs-overwrite-fn "efs" 'dired-flag-backup-files) +(efs-overwrite-fn "efs" 'dired-create-files) +(efs-overwrite-fn "efs" 'dired-find-file) +(efs-overwrite-fn "efs" 'dired-find-file-other-window) +(efs-overwrite-fn "efs" 'dired-find-file-other-frame) +(efs-overwrite-fn "efs" 'dired-collect-file-versions) +(efs-overwrite-fn "efs" 'dired-file-name-lessp) + +;;; Hooks + +(add-hook 'dired-before-readin-hook 'efs-dired-before-readin) + +;;; Handle dired-grep.el too. + +(if (featurep 'dired-grep) + (efs-overwrite-fn "efs" 'dired-grep-delete-local-temp-file + 'efs-diff/grep-del-temp-file) + (add-hook 'dired-grep-load-hook + (function + (lambda () + (efs-overwrite-fn "efs" 'dired-grep-delete-local-temp-file + 'efs-diff/grep-del-temp-file))))) + +;;; end of efs-dired.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-dl.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-dl.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,145 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-dl.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Unix descriptive listing support for efs +;; Author: Sandy Rutherford +;; Created: Wed Jan 13 19:19:20 1993 by sandy on ibm550 +;; Modified: Sun Nov 27 18:29:41 1994 by sandy on gandalf +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(provide 'efs-unix:dl) +(require 'efs) + +(defconst efs-dl-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;----------------------------------------------------------------- +;;; Unix descriptive listing (dl) support for efs +;;;----------------------------------------------------------------- + +;; this is also defined in efs.el, because it used to recognize +;; a dl listing. We re-define it here just to keep the dl stuff self-contained. + +(defconst efs-unix:dl-listing-regexp + "^[^ \n\t]+\n? +\\([0-9]+\\|-\\|=\\) ") + +;; entry point + +(efs-defun efs-parse-listing unix:dl + (host user dir path &optional switches) + ;; Parse the current buffer, which is assumed to be a unix descriptive + ;; listing, and return a hashtable. + ;; HOST = remote host name + ;; USER = user name + ;; DIR = directory in as a full remote path + ;; PATH = directory in full efs path syntax + ;; SWITCHES = ls switches (not relevant here) + (goto-char (point-min)) + ;; Is it really a listing? + (efs-save-match-data + (if (re-search-forward efs-unix:dl-listing-regexp nil t) + (let ((tbl (efs-make-hashtable))) + (goto-char (point-min)) + (while (not (eobp)) + (efs-put-hash-entry + (buffer-substring (point) + (progn + (skip-chars-forward "^ /\n") + (point))) + (list (eq (following-char) ?/)) + tbl) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl)))) + +;;; Support for tree dired. + +(defconst efs-dired-dl-re-dir + "^. [^ /]+/[ \n]" + "Regular expression to use to search for dl directories.") + +(or (assq 'unix:dl efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'unix:dl efs-dired-dl-re-dir) + efs-dired-re-dir-alist))) + + +(efs-defun efs-dired-manual-move-to-filename unix:dl + (&optional raise-error bol eol) + ;; In dired, move to the first character of the filename on this line. + ;; This is the Unix dl version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r") + (setq bol (point))) + (if (and + (> (- eol bol) 3) + (progn + (forward-char 2) + (skip-chars-forward " \t") + (looking-at "[^ \n\t]+\n? +\\([0-9]+\\|-\\|=\\) "))) + (point) + (goto-char bol) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename unix:dl + (&optional no-error bol eol) + ;; Assumes point is at beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; On failure, signals an error or returns nil. + ;; This is the Unix dl version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "^ /\r\n\t") + (if (or (= opoint (point)) (not (memq (following-char) '(?\ ?/)))) + (if no-error + nil + (error "No file on this line")) + (point)))) + +(efs-defun efs-dired-insert-headerline unix:dl (dir) + ;; Unix dl has no total line, so we insert a blank line for + ;; aesthetics. + (insert "\n") + (forward-char -1) + (efs-real-dired-insert-headerline dir)) + +(efs-defun efs-dired-fixup-listing unix:dl (file path &optional + switches wildcard) + ;; Deal with continuation lines. + (efs-save-match-data + (goto-char (point-min)) + (while (re-search-forward "\n +" nil t) + (delete-region (match-beginning 0) (match-end 0)) + (insert " ")))) + +;;; end of efs-dl.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-dos-distinct.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-dos-distinct.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,152 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-dos-distinct.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Distinct's DOS FTP server support for efs +;; Author: Sandy Rutherford +;; Created: Fri Jan 15 22:20:32 1993 by sandy on ibm550 +;; Modified: Sun Nov 27 18:30:04 1994 by sandy on gandalf +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;; Thanks to Rodd Zurcher for beta testing. + +(provide 'efs-dos-distinct) +(require 'efs) + +(defconst efs-dos-distinct-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;; ----------------------------------------------------------------- +;;;; Distinct's DOS FTP server support for efs +;;;; ----------------------------------------------------------------- + +;;; This is not included in efs-dos.el with the support for the +;;; other dos ftp servers, because the Distinct server uses unix syntax +;;; for path names. + +;; This is defined in efs.el, but we put it here too. + +(defconst efs-dos-distinct-date-and-time-regexp + (concat + " \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" + "\\|Nov\\|Dec\\) [ 0-3][0-9],[12][90][0-9][0-9] " + "[ 12][0-9]:[0-5][0-9] ")) + +;;; entry point + +(efs-defun efs-parse-listing dos-distinct + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a listing from + ;; Distinct's DOS FTP server. Both empty dirs, and ls errors return + ;; empty buffers. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = remote directory as a full remote path + ;; PATH = directory in full efs-path syntax + (goto-char (point-min)) + (efs-save-match-data + (if (re-search-forward efs-dos-distinct-date-and-time-regexp nil t) + (let ((tbl (efs-make-hashtable)) + dir-p) + (beginning-of-line) + (while (progn + (setq dir-p (eq (following-char) ?d)) ; we're bolp + (re-search-forward + efs-dos-distinct-date-and-time-regexp nil t)) + (efs-put-hash-entry (buffer-substring (point) + (progn (end-of-line) + (point))) + (list dir-p) tbl) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl)))) + +(efs-defun efs-allow-child-lookup dos-distinct (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + ;; Subdirs in DOS can't have an extension. + (not (string-match "\\." file))) + +;;; Tree Dired + +(defconst efs-dired-dos-distinct-re-exe + "^[^\n]+\\.exe$") + +(or (assq 'dos-distinct efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'dos-distinct efs-dired-dos-distinct-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-dos-distinct-re-dir + "^. [ \t]*d") + +(or (assq 'dos-distinct efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'dos-distinct efs-dired-dos-distinct-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-insert-headerline dos-distinct (dir) + ;; The Distinct DOS server has no total line, so we insert a + ;; blank line for aesthetics. + (insert "\n") + (forward-char -1) + (efs-real-dired-insert-headerline dir)) + +(efs-defun efs-dired-manual-move-to-filename dos-distinct + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line. + ;; Returns (point) or nil if raise-error is nil, and there is no + ;; no filename on this line. + ;; This version is for Distinct's DOS FTP server. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + (if (re-search-forward efs-dos-distinct-date-and-time-regexp eol t) + (point) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename dos-distinct + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + ;; This is the version for Distinct's DOS FTP server. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; it's hidden or omitted + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "-_+=a-z0-9.$") + (if (or (= opoint (point)) (not (memq (following-char) '(\n \r)))) + (if no-error + nil + (error "No file on this line")) + (point)))) + +;;; end of efs-dos-distinct.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-fnh.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-fnh.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,147 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-fnh.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.3 $ +;; RCS: +;; Description: Look for the emacs version, and install into +;; the file-name-handler-alist +;; Author: Sandy Rutherford +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Although used by efs, these utilities could be of general use to other +;;; packages too. Keeping them separate from the main efs program +;;; makes it easier for other programs to require them. + +(provide 'efs-fnh) + +(defconst efs-fnh-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.3 $" 11 -2))) + +;;;; ---------------------------------------------------------------- +;;;; Loading emacs version files +;;;; ---------------------------------------------------------------- + +(defun efs-handle-emacs-version () + ;; Load appropriate files for the current emacs version + (let ((ehev-match-data (match-data))) + (unwind-protect + (let ((lucidp (string-match "Lucid" emacs-version)) + ver subver) + (or (string-match "^\\([0-9]+\\)\\.\\([0-9]+\\)" emacs-version) + (error "efs does not work with emacs version %s" emacs-version)) + (setq ver (string-to-int (substring emacs-version + (match-beginning 1) + (match-end 1))) + subver (string-to-int (substring emacs-version + (match-beginning 2) + (match-end 2)))) + (cond + + ;; Lucid XEmacs (emacs-version looks like \"19.xx XEmacs Lucid\") + (lucidp + (cond + ((and (= ver 19) (>= subver 11) (< subver 15)) + (require 'efs-l19\.11)) + ((and (= ver 19) (>= subver 15)) + (require 'efs-x19\.15)) + ((= ver 20) + (require 'efs-x19\.15)) + (t + (error + "efs does not work with emacs version %s" emacs-version)))) + + ;; Original GNU Emacs from FSF + (t + (cond + ((and (= ver 19) (<= subver 22)) + (require 'efs-19)) + ((and (= ver 19) (>= subver 23)) + (require 'efs-19\.23)) + + ;; GNU Emacs 18- + ((<= ver 18) + (require 'efs-18)) ; this file will (require 'emacs-19) + + (t + (error + "efs does not work with emacs version %s" emacs-version)))))) + + (store-match-data ehev-match-data)))) + +;;;; -------------------------------------------------------------- +;;;; Stuff for file name handlers. +;;;; -------------------------------------------------------------- + +;;; Need to do this now, to make sure that the file-name-handler-alist is +;;; defined for Emacs 18. + +(efs-handle-emacs-version) + +;; Also defined in efs-cu.el +(defvar efs-path-root-regexp "^/[^/:]+:" + "Regexp to match the `/user@host:' root of an efs full path.") + +(defun efs-file-name-handler-alist-sans-fn (fn) + ;; Returns a version of file-name-handler-alist without efs. + (delq nil (mapcar + (function + (lambda (x) + (and (not (eq (cdr x) fn)) x))) + file-name-handler-alist))) + +(defun efs-root-handler-function (operation &rest args) + "Function to handle completion in the root directory." + (let ((handler (get operation 'efs-root))) + (if handler + (apply handler args) + (let ((inhibit-file-name-handlers + (cons 'efs-root-handler-function + (and (eq inhibit-file-name-operation operation) + inhibit-file-name-handlers))) + (inhibit-file-name-operation operation)) + (apply operation args))))) + +(put 'file-name-completion 'efs-root 'efs-root-file-name-completion) +(put 'file-name-all-completions 'efs-root 'efs-root-file-name-all-completions) +(autoload 'efs-root-file-name-all-completions "efs-netrc") +(autoload 'efs-root-file-name-completion "efs-netrc") + +(autoload 'efs-file-handler-function "efs" + "Function to use efs to handle remote files.") + +;; Install into the file-name-handler-alist. +;; If we are already there, remove the old entry, and re-install. +;; Remove the ange-ftp entry too. + +(setq file-name-handler-alist + (let (dired-entry alist) + (setq alist + (nconc + (list + (cons efs-path-root-regexp 'efs-file-handler-function) + '("^/$" . efs-root-handler-function)) + (delq nil + (mapcar + (function + (lambda (x) + (if (eq (cdr x) 'dired-handler-fn) + (progn + (setq dired-entry x) + nil) + (and (not + (memq (cdr x) + '(efs-file-handler-function + efs-root-handler-function + ange-ftp-hook-function + ange-ftp-completion-hook-function))) + x)))) + file-name-handler-alist)))) + ;; Make sure that dired is in first. + (if dired-entry (cons dired-entry alist) alist))) + +;;; end of efs-fnh.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-guardian.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-guardian.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,241 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-guardian.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Guardian support for efs +;; Author: Sandy Rutherford +;; Created: Sat Jul 10 12:26:12 1993 by sandy on ibm550 +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;; Acknowledgements: +;;; Adrian Philips and David Karr for answering questions +;;; and debugging. Thanks. + +(defconst efs-guardian-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +(provide 'efs-guardian) +(require 'efs) + +;;;; ------------------------------------------------------------ +;;;; Support for Tandem's GUARDIAN operating system. +;;;; ------------------------------------------------------------ + +;;; Supposed to work for (Version 2.7 TANDEM 01SEP92). + +;;; File name syntax: +;;; +;;; File names are of the form volume.subvolume.file where +;;; volume is $[alphanumeric characters]{1 to 7} +;;; subvolume is []{0 to 7} +;;; and file is the same as subvolume. + +(defconst efs-guardian-date-regexp + (concat + " [ 1-3][0-9]-\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|" + "Sep\\|Oct\\|Nov\\|Dec\\)-[0-9][0-9] ")) + +;;; entry points -- 2 of 'em. + +(efs-defun efs-fix-path guardian (path &optional reverse) + ;; Convert PATH from unix-ish to guardian. + ;; If REVERSE is non-nil do just that. + (efs-save-match-data + (let ((case-fold-search t)) + (if reverse + (if (string-match + (concat + "^\\(\\\\[A-Z0-9]+\\.\\)?" + "\\(\\$[A-Z0-9]+\\)\\.\\([A-Z0-9]+\\)\\(\\.[A-Z0-9]+\\)?$") + path) + (concat + "/" + (substring path (match-beginning 2) (match-end 2)) + "/" + (substring path (match-beginning 3) (match-end 3)) + "/" + (and (match-beginning 4) + (substring path (1+ (match-beginning 4))))) + (error "path %s is invalid for the GUARDIAN operating system" + path)) + (if (string-match + "^/\\(\\$[A-Z0-9]+\\)/\\([A-Z0-9]+\\)\\(/[A-Z0-9]*\\)?$" path) + (apply 'concat + (substring path 1 (match-end 1)) + "." + (substring path (match-beginning 2) (match-end 2)) + (and (match-beginning 3) + (/= (- (match-end 3) (match-beginning 3)) 1) + (list "." + (substring path (1+ (match-beginning 3)))))) + (error "path %s is invalid for the guardian operating system" + path)))))) + +(efs-defun efs-fix-dir-path guardian (dir-path) + ;; Convert DIR-PATH from unix-ish to guardian fir a DIR listing. + (efs-save-match-data + (let ((case-fold-search t)) + (cond + ((string-equal "/" dir-path) + (error "Can't grok guardian disk volumes.")) + ((string-match "^/\\$[A-Z0-9]+/?$" dir-path) + (error "Can't grok guardian subvolumes.")) + ((string-match "^/\\(\\$[A-Z0-9]+\\)/\\([A-Z0-9]+\\)\\(/[A-Z0-9]*\\)?$" + dir-path) + (apply 'concat + (substring dir-path 1 (match-end 1)) + "." + (substring dir-path (match-beginning 2) (match-end 2)) + (and (match-beginning 3) + (/= (- (match-end 3) (match-beginning 3)) 1) + (list "." + (substring dir-path (1+ (match-beginning 3))))))) + (t + (error "path %s is invalid for the guardian operating system")))))) + +(efs-defun efs-parse-listing guardian + (host user dir path &optional switches) + ;; Parses a GUARDIAN DIRectory listing. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = remote directory as a remote full path + ;; PATH = directory as an efs full path + ;; SWITCHES are never used here, but they + ;; must be specified in the argument list for compatibility + ;; with the unix version of this function. + (efs-save-match-data + (goto-char (point-min)) + (if (re-search-forward efs-guardian-date-regexp nil t) + (let ((tbl (efs-make-hashtable)) + file size) + (while + (progn + (beginning-of-line) + (setq file (buffer-substring (point) + (progn + (skip-chars-forward "A-Z0-9") + (point)))) + (skip-chars-forward " ") + (skip-chars-forward "^ ") + (skip-chars-forward " ") + (setq size (string-to-int (buffer-substring + (point) + (progn + (skip-chars-forward "0-9"))))) + (efs-put-hash-entry file (list nil size) tbl) + (forward-line 1) + (re-search-forward efs-guardian-date-regexp nil t))) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl)))) + +(efs-defun efs-allow-child-lookup guardian (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + (efs-save-match-data + (let ((case-fold-search t)) + (string-match "^/\\$[A-Z0-9]+/$" dir)))) + +(efs-defun efs-internal-file-directory-p guardian (file) + ;; Directories pop into existence simply by putting files in them. + (efs-save-match-data + (let ((case-fold-search t)) + (if (string-match "^/\\$[A-Z0-9]+\\(/[A-Z0-9]+\\)?/?$" file) + t + (efs-internal-file-directory-p nil file))))) + +(efs-defun efs-internal-file-exists-p guardian (file) + ;; Directories pop into existence simply by putting files in them. + (efs-save-match-data + (let ((case-fold-search t)) + (if (string-match "^/\\$[A-Z0-9]+\\(/[A-Z0-9]+\\)?/?$" file) + t + (efs-internal-file-exists-p nil file))))) + +;;; Tree Dired support + +(defconst efs-dired-guardian-re-exe nil) + +(or (assq 'guardian efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'guardian efs-dired-guardian-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-guardian-re-dir nil) + +(or (assq 'guardian efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'guardian efs-dired-guardian-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-manual-move-to-filename guardian + (&optional raise-error bol eol) + ;; In dired, move to first char of filename on this line. + ;; Returns position (point) or nil if no filename on this line. + ;; This is the guardian version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r") + (setq bol (point))) + (if (save-excursion (re-search-forward efs-guardian-date-regexp eol t)) + (progn + (if (looking-at ". [^ ]") + (forward-char 2)) + (point)) + (and raise-error (error "No file on this line")))) + +(efs-defun efs-dired-manual-move-to-end-of-filename guardian + (&optional no-error bol eol) + ;; Assumes point is at beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; On failure, signals an error or returns nil. + ;; This is the guardian version. + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit."))))) + (if (and + (>= (following-char) ?A) + (<= (following-char) ?Z) + (progn + (skip-chars-forward "A-Z0-9") + (= (following-char) ?\ ))) + (point) + (and (null no-error) + (error "No file on this line")))) + +(efs-defun efs-dired-ls-trim guardian () + (goto-char (point-min)) + (let (case-fold-search) + (if (re-search-forward efs-guardian-date-regexp nil t) + (progn + (beginning-of-line) + (delete-region (point-min) (point)) + (forward-line 1) + (delete-region (point) (point-max)))))) + +;;; end of efs-guardian.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-gwp.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-gwp.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,158 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-gwp.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Support for efs to use an interactive gateway. +;; Author: Andy Norman, Dawn +;; Created: Thu Mar 18 13:03:14 1993 +;; Modified: Sun Nov 27 18:31:50 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(provide 'efs-gwp) +(require 'efs) + +;;;; ------------------------------------------------------------ +;;;; Interactive gateway program support. +;;;; ------------------------------------------------------------ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; User Variables and Documentation + +(defvar efs-gwp-setup-term-command + (if (eq system-type 'hpux) + "stty -onlcr -echo\n" + "stty -echo nl\n") + "Command to do terminal setup on the gateway machine. +They must stop the terminal echoing each command and strip out trailing +^M characters. This string must end in \\n. If you need to send multiple +commands, include them all in this string, separated by \\n. +See the documentation in efs.el for some example commands.") + +;; About efs-gwp-term-setup-command: +;; +;; It is important to get efs-gwp-setup-term-command right. +;; Here are some examples. Please tell us about which commands +;; to use on other platforms, so that we can include it in the +;; documentation. +;; +;; +;; HP-UX: +;; +;; "stty -onlcr -echo\n" +;; +;; SunOS: +;; +;; "stty -echo nl\n" +;; +;; VMS: (this should work) +;; +;; "set terminal/noecho\n" +;; + + +(defvar efs-gwp-prompt-pattern "^[^#$%>;]*[#$%>;] *" + "*Regexp used to detect that the gateway login sequence has completed. +It will be assumed that the shell is ready to receive input. Make this +regexp as strict as possible; it shouldn't match *anything* at all except +the shell's initial prompt. The above string will fail under most SUN-3's +since it matches the login banner.") + +;; About efs-gwp-prompt-pattern: +;; +;; It is very important that this not match anything in the machine's +;; login banner. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Internal Variables + +(defconst efs-gwp-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +(defvar efs-gwp-running t) +(defvar efs-gwp-status nil) +(defvar efs-gwp-string "") + +;;; Entry point (defined as an autoload in efs.el) + +(defun efs-gwp-start (host user name) + "Login to the gateway machine and fire up an ftp process." + (message "Connecting to gateway %s..." efs-gateway-host) + (let ((proc (apply 'start-process name (efs-ftp-process-buffer host user) + (nth 1 efs-gateway-type) + (append (nth 2 efs-gateway-type) + (list efs-gateway-host)))) + (ftp (concat (nth 3 efs-gateway-type) " " + (mapconcat (function identity) (nth 4 efs-gateway-type) + " ") "\n"))) + (process-kill-without-query proc) + (set-process-sentinel proc (function efs-gwp-sentinel)) + (set-process-filter proc (function efs-gwp-filter)) + (set-marker (process-mark proc) (point)) + (setq efs-gwp-running t + efs-gwp-status nil + efs-gwp-string "") + (while efs-gwp-running ;perform login sequence + (accept-process-output proc)) + (if (not efs-gwp-status) + (efs-error host user "unable to login to gateway")) + (message "Connecting to gateway %s...done" efs-gateway-host) + (setq efs-gwp-running t + efs-gwp-status nil + efs-gwp-string "") + (process-send-string proc efs-gwp-setup-term-command) + (while efs-gwp-running ;zap ^M's and double echoing. + (accept-process-output proc)) + (if (not efs-gwp-status) + (efs-error host user "unable to set terminal modes on gateway")) + (setq efs-gwp-running t + efs-gwp-status nil + efs-gwp-string "") + (message "Opening FTP connection to %s..." host) + (process-send-string proc ftp) + proc)) + +;;; Process filter/sentinel + +(defun efs-gwp-sentinel (proc str) + (setq efs-gwp-running nil)) + +(defun efs-gwp-filter (proc str) + (efs-save-match-data + ;; Don't be sensitive to login vn LOGIN. + (let ((case-fold-search t)) + (efs-process-log-string proc str) + (setq efs-gwp-string (concat efs-gwp-string str)) + (cond ((string-match "\\(login\\|username\\): *$" efs-gwp-string) + (process-send-string proc + (concat + (let ((efs-default-user t)) + (efs-get-user efs-gateway-host)) + "\n"))) + ((string-match "password: *$" efs-gwp-string) + (process-send-string proc + (concat + (efs-get-passwd efs-gateway-host + (efs-get-user + efs-gateway-host)) + "\n"))) + ((string-match efs-gateway-fatal-msgs + efs-gwp-string) + (delete-process proc) + (setq efs-gwp-running nil)) + ((string-match efs-gwp-prompt-pattern + efs-gwp-string) + (setq efs-gwp-running nil + efs-gwp-status t)))))) + +;;; end of efs-gwp.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-hell.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-hell.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,185 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-hell.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Hellsoft FTP server support for efs +;; Author: Sandy Rutherford +;; Created: Tue May 25 02:31:37 1993 by sandy on ibm550 +;; Modified: Sun Nov 27 18:32:27 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(provide 'efs-hell) +(require 'efs) + +(defconst efs-hell-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;; -------------------------------------------------------------- +;;;; Hellsoft FTP server support for efs +;;;; -------------------------------------------------------------- + +;;; The hellsoft FTP server runs on DOS PC's and Macs. The hellsoft +;;; support here probably won't work for Macs. If enough people need it +;;; the Mac support _might_ be fixed. + +;;; Works for "novell FTP Server for NW 3.11 (v1.8), (c) by HellSoft." + +;; Hellsoft uses unix path syntax. However, we shouldn't append a "." +;; to directories, because if foobar is a plain file, then +;; dir foobar/ will not give a listing (which is correct), but +;; dir foobar/. will give a one-line listing (which is a little strange). + +(efs-defun efs-fix-dir-path hell (dir-path) + dir-path) + +;; Hellsoft returns PWD output in upper case, whereas dir listings are +;; in lower case. To avoid confusion, downcase pwd output. + +(efs-defun efs-send-pwd hell (host user &optional xpwd) + ;; Returns ( DIR . LINE ), where DIR is either the current directory, or + ;; nil if this couldn't be found. LINE is the line of output from the + ;; FTP server. Since the hellsoft server returns pwd output in uppercase, we + ;; downcase it. + (let ((result (efs-send-pwd 'unix host user xpwd))) + (if (car result) + (setcar result (downcase (car result)))) + result)) + +(defconst efs-hell-date-and-time-regexp + (concat + " \\([0-9]+\\) \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" + "\\|Nov\\|Dec\\) [0-3][0-9] " + "\\([012][0-9]:[0-5][0-9]\\| [12][019][0-9][0-9]\\) ")) +;; The end of this regexp corresponds to the start of a filename. + +(defmacro efs-hell-parse-file-line () + ;; Returns ( FILENAME DIR-P SIZE ) from the current line + ;; of a hellsoft listing. Assumes that the point is at the beginning + ;; of the line. + (` (let ((eol (save-excursion (end-of-line) (point))) + (dir-p (= (following-char) ?d))) + (if (re-search-forward efs-hell-date-and-time-regexp eol t) + (list (buffer-substring (point) (progn (end-of-line) (point))) + dir-p + (string-to-int (buffer-substring (match-beginning 1) + (match-end 1)))))))) + +(efs-defun efs-parse-listing hell + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a listing from + ;; a Hellsoft FTP server. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = remote directory as a full remote path + ;; PATH = directory in full efs-path syntax + (goto-char (point-min)) + (efs-save-match-data + (if (re-search-forward efs-hell-date-and-time-regexp nil t) + (let ((tbl (efs-make-hashtable)) + file-info) + (beginning-of-line) + (while (setq file-info (efs-hell-parse-file-line)) + (efs-put-hash-entry (car file-info) (cdr file-info) tbl) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl) + (if (not (string-match (efs-internal-file-name-nondirectory + (efs-internal-directory-file-name dir)) "\\.")) + ;; It's an empty dir + (let ((tbl (efs-make-hashtable))) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl))))) + + +(efs-defun efs-allow-child-lookup hell (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + ;; Subdirs in DOS can't have an extension. + (not (string-match "\\." file))) + +;;; Tree Dired + +(defconst efs-dired-hell-re-exe + "^[^\n]+\\.exe$") + +(or (assq 'hell efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'hell efs-dired-hell-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-hell-re-dir + "^. [ \t]*d") + +(or (assq 'hell efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'hell efs-dired-hell-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-manual-move-to-filename hell + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line, where + ;; line can be delimited by either \r or \n. + ;; Returns (point) or nil if raise-error is nil and there is no + ;; filename on this line. In the later case, leaves the point at the + ;; beginning of the line. + ;; This version is for the Hellsoft FTP server. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + (if (re-search-forward efs-hell-date-and-time-regexp eol t) + (point) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename hell + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + ;; This is the Hellsoft FTP server version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "-_+=a-zA-Z0-9.$~") + (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r)))) + (if no-error + nil + (error "No file on this line")) + (point)))) + +(efs-defun efs-dired-insert-headerline hell (dir) + ;; Insert a blank line for aesthetics + (insert "\n") + (forward-char -1) + (efs-real-dired-insert-headerline dir)) + +;;; end of efs-hell.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-ka9q.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-ka9q.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,190 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-ka9q.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: KA9Q support for efs +;; Author: Sandy Rutherford +;; Created: Mon Dec 21 10:34:43 1992 by sandy on ibm550 +;; Modified: Sun Nov 27 18:32:56 1994 by sandy on gandalf +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;; Thanks go to Joe Reinhardt for beta testing. + +(provide 'efs-ka9q) +(require 'efs) + +(defconst efs-ka9q-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;----------------------------------------------------------------- +;;; KA9Q support for efs +;;;----------------------------------------------------------------- +;;; +;;; KA9Q is not really an OS, but an ftp server that runs on PC's. +;;; It runs under DOS and unix. Seems to have been adopted by LINUX. + +;; KA9Q uses unix syntax for paths, so don't need to bother with pathname +;; converters. It always gives a listing, even if a file or dir doesn't +;; exist. Therefore, we shall assume that empty dir = nonexistent dir. sigh... + +(defconst efs-ka9q-date-regexp + " +[.,0-9]* [ 0-2][0-9]:[0-9][0-9] +[0-9]+/[0-9]+/[0-9]+") + ;; (match-beginning 0) should be the last char of the filename. + +(defun efs-ka9q-bogus-listing (dir path) + ;; Check to see if a 1-line ka9q listing is bogus, and the directory + ;; is really just a file. + (and + (not (string-equal "/" dir)) + (goto-char (point-min)) + (looking-at (regexp-quote + (concat (efs-internal-file-name-nondirectory + (efs-internal-directory-file-name dir)) + " "))) + (forward-line 1) + (looking-at "1 file\\. ") + (string-match "^No files\\. " + ;; ls switches don't matter + (efs-ls (concat path "*") "-al" t t)))) + +(efs-defun efs-parse-listing ka9q + (host user dir path &optional switches) + ;; Parse the current listing which is assumed to be a ka9q listing. + ;; Format is based on version 890421.1a.linux.7 (whatever that means). + ;; Note that ka9q uses two files per line. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a remote full path + ;; PATH = directory in full efs-path syntax + (let ((tbl (efs-make-hashtable)) + dir-p file) + (efs-save-match-data + (if (and + (progn + (goto-char (point-max)) + (forward-line -1) + ;; Although "No files." may refer to an empty + ;; directory, it may also be a non-existent + ;; dir. Returning nil should force a listing + ;; of the parent, which will sort things out. + (looking-at "[0-9]+ files?\\. ")) + ;; Check for a bogus listing. + (not (efs-ka9q-bogus-listing dir path))) + (progn + (goto-char (point-min)) + (while (re-search-forward efs-ka9q-date-regexp nil t) + (goto-char (match-beginning 0)) + (if (setq dir-p (eq (preceding-char) ?/)) + (forward-char -1)) + (setq file (buffer-substring (point) + (progn (skip-chars-backward "^ \n") + (point)))) + (efs-put-hash-entry file (list dir-p) tbl) + (goto-char (match-end 0))) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl))))) + +;;; Tree Dired + +(defconst efs-dired-ka9q-re-exe + "^. [^ \n\r./]+\\.exe ") + +(or (assq 'ka9q efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'ka9q efs-dired-ka9q-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-ka9q-re-dir + "^. [^ \n\r/]+/ ") + +(or (assq 'ka9q efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'ka9q efs-dired-ka9q-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-fixup-listing ka9q (file path &optional switches wildcard) + ;; ka9q puts two files per line. Need to put in one file per line format + ;; for dired. + (let ((regexp (concat efs-ka9q-date-regexp " "))) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (delete-char -3) + (insert-char ?\n 1)) + ;; is there a blank line left? + (if (looking-at "[ \t]*\n") + (delete-region (match-beginning 0) (match-end 0))))) + +(efs-defun efs-dired-ls-trim ka9q () + (goto-char (point-min)) + (let ((case-fold-search nil)) + (forward-line 1) + (if (looking-at "\\([0-9]+\\|No\\) files?\\. ") + (delete-region (point) (point-max))))) + +(efs-defun efs-dired-insert-headerline ka9q (dir) + ;; Insert a headerline + (insert-char ?\n 1) + (forward-char -1) + (efs-real-dired-insert-headerline dir)) + +(efs-defun efs-dired-manual-move-to-filename ka9q + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line. + ;; Returns (point) or nil if raise-error is nil, and there is no + ;; no filename on this line. + ;; This is the KA9Q version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r") + (setq bol (point))) + (if (re-search-forward efs-ka9q-date-regexp eol t) + (progn + (goto-char (match-beginning 0)) + (skip-chars-backward "^ " bol) + (point)) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename ka9q + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + ;; This is the KA9Q version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "^ \n\r/") + (if (or (= opoint (point)) (not (memq (following-char) '(?/ ?\ )))) + (if no-error + nil + (error "No file on this line")) + (point)))) + +;;; end of efs-ka9q.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-kerberos.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-kerberos.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,136 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-efs-kerberos.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Support for Kerberos gateways. +;; Author: Sandy Rutherford +;; Created: Thu Nov 24 21:19:25 1994 by sandy on gandalf +;; Modified: +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Support for the Kerberos gateway authentication system from MIT's +;;; Project Athena. + +(provide 'efs-kerberos) +(require 'efs) + +(defconst efs-kerberos-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;; Internal Variables + +(defvar efs-kerberos-passwd-sent nil) +;; Set to t after the passwd has been sent. +(defvar efs-kerberos-output "") +;; Holds the output lines from the kinit process. +(defvar efs-kerberos-buffer-name "*efs kerberos*") +;; Buffer where kinit output is logged. +(defvar efs-kerberos-passwd-prompt-regexp "^Password: *$") +;; Regular expression to match prompt used by the kinit program. +(defvar efs-kerberos-failed-msgs "[^ ]+") +;; Regular expression to match output for an invalid kinit ticket password. +;; Is this too general? +(defvar efs-kerberos-passwd-failed nil) +;; Whether the kinit command worked. +(defvar efs-kerberos-passwd-retry nil) + +;;; Code + +(defun efs-kerberos-process-filter (proc str) + ;; Process filter for the kinit process. + (setq efs-kerberos-output (concat efs-kerberos-output str)) + (let ((buff (get-buffer (process-buffer proc)))) + (if buff + (efs-save-buffer-excursion + (set-buffer buff) + (efs-save-match-data + (goto-char (point-max)) + (while (string-match "\n" efs-kerberos-output) + (let ((line (substring efs-kerberos-output 0 + (match-beginning 0)))) + (insert line "\n") + (and efs-kerberos-passwd-sent + (string-match efs-kerberos-failed-msgs line) + (setq efs-kerberos-passwd-failed t))) + (setq efs-kerberos-output (substring efs-kerberos-output + (match-end 0)))) + (and (null efs-kerberos-passwd-sent) + (string-match efs-kerberos-passwd-prompt-regexp + efs-kerberos-output) + (memq (process-status proc) '(run open)) + (let ((passwd (or + (efs-lookup-passwd efs-gateway-host "kerberos") + (read-passwd + (if efs-kerberos-passwd-retry + "Password failed. Try again: " + (format "Kerberos password for %s: " + efs-gateway-host)))))) + (unwind-protect + (progn + (insert efs-kerberos-output) + (setq efs-kerberos-output "") + (process-send-string proc passwd) + (insert "Turtle Power!\n")) + (fillarray passwd 0))))))))) + +(defun efs-kerberos-get-ticket () + ;; Gets a kerbos ticket. The password is actually sent by the process + ;; filter. + (let ((mess (format "Getting kerberos ticket for %s..." efs-gateway-host))) + (message mess) + (setq efs-kerberos-passwd-failed nil + efs-kerberos-passwd-sent nil + efs-kerberos-output "") + (condition-case nil (delete-process "*efs kerberos*") (eror nil)) + (let* ((program (or (nth 3 efs-gateway-type) "kinit")) + (args (nth 4 efs-gateway-type)) + (proc (apply 'start-process + "*efs kerberos*" efs-kerberos-buffer-name + program args))) + (set-process-filter proc (function efs-kerberos-process-filter)) + ;; Should check for a pty, but efs-pty-check will potentially eat + ;; important output. Need to wait until Emacs 19.29 to do this properly. + (while (memq (process-status proc) '(run open)) + (accept-process-output proc)) + (if efs-kerberos-passwd-failed + (let ((efs-kerberos-passwd-failed t)) + (efs-kerberos-get-ticket)))) + (message "%sdone" mess))) + +(defun efs-kerberos-login (host user proc) + ;; Open a connection using process PROC to HOST adn USER, using a + ;; kerberos gateway. Returns the process object of the connection. + ;; This may not be PROC, if a ticket collection was necessary. + (let ((to host) + result port cmd) + (if (string-match "#" host) + (setq to (substring host 0 (match-beginning 0)) + port (substring host (match-end 0)))) + (and efs-nslookup-on-connect + (string-match "[^0-9.]" to) + (setq to (efs-nslookup-host to))) + (setq cmd (concat "open " to)) + (if port (setq cmd (concat cmd " " port))) + (setq result (efs-raw-send-cmd proc cmd)) + (while (and (car result) + (string-match "\\bcannot authenticate to server\\b" + (nth 1 result))) + (let ((name (process-name proc))) + (condition-case nil (delete-process proc) (error nil)) + (efs-kerberos-get-ticket) + (setq proc (efs-start-process host user name) + result (efs-raw-send-cmd proc cmd)))) + (if (car result) + (progn + (condition-case nil (delete-process proc) (error nil)) + (efs-error host user (concat "OPEN request failed: " + (nth 1 result))))) + proc)) + +;;; End of efs-kerberos.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-l19.11.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-l19.11.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,175 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-l19.11.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: efs support for XEemacs, versions 19.11, and later. +;; Author: Sandy Rutherford +;; Created: Tue Aug 2 17:40:32 1994 by sandy on ibm550 +;; Modified: Sun Nov 27 18:34:33 1994 by sandy on gandalf +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide 'efs-l19\.11) +(require 'efs-cu) +(require 'default-dir) +(require 'efs-ovwrt) + +(defconst efs-l19\.11-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;; Functions requiring special defs. for these lemacs versions. + +(defun efs-abbreviate-file-name (filename &optional hack-homedir) + ;; lucid emacs version of abbreviate-file-name for remote files. + (let (file-name-handler-alist) + (if (and hack-homedir (efs-ftp-path filename)) + ;; Do replacements from directory-abbrev-alist + (apply 'efs-unexpand-parsed-filename + (efs-ftp-path (abbreviate-file-name filename nil))) + (abbreviate-file-name filename hack-homedir)))) + +(defun efs-relativize-filename (file &optional dir new) + "Abbreviate the given filename relative to DIR . +If DIR is nil, use the value of `default-directory'. If the +optional parameter NEW is given and the non-directory parts match, only return +the directory part of the file." + (let* ((dir (or dir default-directory)) + (dlen (length dir)) + (result file)) + (and (> (length file) dlen) + (string-equal (substring file 0 dlen) dir) + (setq result (substring file dlen))) + (and new + (string-equal (file-name-nondirectory result) + (file-name-nondirectory new)) + (or (setq result (file-name-directory result)) + (setq result "./"))) + (abbreviate-file-name result t))) + +(defun efs-set-buffer-file-name (filename) + ;; Sets the buffer local variables for filename appropriately. + ;; A special function because Lucid and FSF do this differently. + (setq buffer-file-name filename) + (if (and efs-compute-remote-buffer-file-truename + (memq (efs-host-type (car (efs-ftp-path filename))) + efs-unix-host-types)) + (compute-buffer-file-truename) + (setq buffer-file-truename filename))) + +;; Do we need to do anything about compute-buffer-file-truename, or +;; will the handler for file-truename handle this automatically? I suppose +;; that efs-compute-remote-buffer-file-truename should really apply to +;; compute-buffer-file-truename, and not file-truename, but then we would +;; have to do deal with the fact that this function doesn't exist in GNU Emacs. + +;; Only Lucid Emacs has this function. Why do we need both this and +;; set-visited-file-modtime? + +(defun efs-set-buffer-modtime (buffer &optional time) + ;; For buffers visiting remote files, set the buffer modtime. + (or time + (progn + (setq time + (let* ((file (save-excursion + (set-buffer buffer) buffer-file-name)) + (parsed (efs-ftp-path file))) + (efs-get-file-mdtm (car parsed) (nth 1 parsed) + (nth 2 parsed) file))) + (if time + (setq time (cons (car time) (nth 1 time))) + (setq time '(0 . 0))))) + (let (file-name-handler-alist) + (set-buffer-modtime buffer time))) + +;;; Need to add access to the file-name-handler-alist to these functions. + +(defun efs-l19\.11-set-buffer-modtime (buffer &optional time) + "Documented as original" + (let ((handler (save-excursion + (set-buffer buffer) + (and buffer-file-name + (find-file-name-handler buffer-file-name + 'set-buffer-modtime))))) + (if handler + (funcall handler 'set-buffer-modtime buffer time) + (let (file-name-handler-alist) + (efs-real-set-buffer-modtime buffer time))))) + +(efs-overwrite-fn "efs" 'set-buffer-modtime 'efs-l19\.11-set-buffer-modtime) + +(defun efs-l19\.11-backup-buffer () + "Documented as original" + (if buffer-file-name + (let ((handler (find-file-name-handler buffer-file-name 'backup-buffer))) + (if handler + (funcall handler 'backup-buffer) + (let (file-name-handler-alist) + (efs-real-backup-buffer)))))) + +(efs-overwrite-fn "efs" 'backup-buffer 'efs-l19\.11-backup-buffer) + +(defun efs-l19\.11-create-file-buffer (file) + "Documented as original" + (let ((handler (find-file-name-handler file 'create-file-buffer))) + (if handler + (funcall handler 'create-file-buffer file) + (let (file-name-handler-alist) + (efs-real-create-file-buffer file))))) + +(efs-overwrite-fn "efs" 'create-file-buffer 'efs-l19\.11-create-file-buffer) + +(defun efs-l19\.11-abbreviate-file-name (filename &optional hack-homedir) + "Documented as original" + (let ((handler (find-file-name-handler filename 'abbreviate-file-name))) + (if handler + (funcall handler 'abbreviate-file-name filename hack-homedir) + (let (file-name-handler-alist) + (efs-real-abbreviate-file-name filename hack-homedir))))) + +(efs-overwrite-fn "efs" 'abbreviate-file-name + 'efs-l19\.11-abbreviate-file-name) + +(defun efs-l19\.11-recover-file (file) + "Documented as original" + (interactive + (let ((prompt-file buffer-file-name) + (file-name nil) + (file-dir nil)) + (and prompt-file + (setq file-name (file-name-nondirectory prompt-file) + file-dir (file-name-directory prompt-file))) + (list (read-file-name "Recover file: " + file-dir nil nil file-name)))) + (let* ((file (expand-file-name file)) + (handler (or (find-file-name-handler file 'recover-file) + (find-file-name-handler + (let ((buffer-file-name file)) + (make-auto-save-file-name)) + 'recover-file)))) + (if handler + (funcall handler 'recover-file file) + (efs-real-recover-file file)))) + +(efs-overwrite-fn "efs" 'recover-file 'efs-l19\.11-recover-file) + +(defun efs-l19\.11-substitute-in-file-name (filename) + "Documented as original." + (let ((handler (find-file-name-handler filename 'substitute-in-file-name))) + (if handler + (funcall handler 'substitute-in-file-name filename) + (let (file-name-handler-alist) + (efs-real-substitute-in-file-name filename))))) + +(efs-overwrite-fn "efs" 'substitute-in-file-name + 'efs-l19\.11-substitute-in-file-name) + +;;; For the file-name-handler-alist + +(put 'set-buffer-modtime 'efs 'efs-set-buffer-modtime) + +;;; end of efs-l19.11.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-mpe.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-mpe.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,678 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-mpe.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: MPE (HP3000) support for efs. +;; Author: (Corny de Souza) cdesouza@hpbbn.bbn.hp.com +;; Created: Fri Jan 15 12:58:29 1993 +;; Modified: Sun Nov 27 18:36:13 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;; Credits +;; +;; Sandy Rutherford for his help and advice. + +;;; Usage +;; +;; For a general description of remote file access see efs.el. +;; +;; MPE Specifics +;; +;; *) To make things easier (for me) MPE has been UNIXified so think UNIX +;; and you stand a good chance of understanding everything. +;; +;; *) Filename syntax is as follows +;; +;; /session,user.account,group@system:/account/group/file;buildparms +;; +;; the "session," and ",group" in the logon sequence are optional. +;; +;; e.g. /CDSUSER.OSCAR@SYSTEM41:/OSCAR/CDSSRC/TST0000S +;; will get the file TST0000S.CDSSRC.OSCAR +;; +;; The ";buildparms" is also optional. It should be used when creating +;; files whos characteristics differ from the default system buildparms, +;; described in the file FTPDOC.ARPA.SYS (at least it is on my system). +;; Also see variable efs-mpe-default-buildparms. +;; +;; e.g. REC=-256,,V,ASCII +;; +;; *) Password syntax is as follows +;; +;; userpass,accountpass,grouppass +;; +;; Leading commas cannot be omitted, trailing commas can. +;; e.g. USERPASS,ACCTPASS (no group password) +;; ,ACCTPASS (only account password) +;; USERPASS,,GRPPASS (no account password) +;; +;; *) Do not use account name completion on large systems. See the variable +;; efs-mpe-account-completion-confirm +;; +;; *) Do not use group name completion on large accounts. See the variable +;; efs-mpe-group-completion-confirm +;; +;; *) The buffers FILE and FILE;BUILDPARMS both point to the same physical +;; disc file. +;; +;; *) When using filename completion you will usually be given the option +;; between FILE and FILE;BUILDPARMS. Just ignore the FILE;BUILDPARMS +;; bit. +;; +;; *) WARNING ********* Two buffer for the same file ************ WARNING +;; If you land up with two buffers FILE and FILE;BUILDPARMS for the same +;; file kill the FILE;BUILDPARMS one. If however this is newwer than +;; the FILE buffer (and you cannot live with a buffer called +;; FILE;BUILDPARMS) save it kill both buffers and get the FILE buffer again. +;; +;; *) When creating new files only create FILES. It is possible to create +;; files as GROUPs and ACCOUNTs but don't! +;; +;;; To Do +;; +;; A lot of things are likely to change with MPE 4.5 and POSIX so I do not want +;; to invest too much time in this now. I would rather wait until I can see +;; what comes with POSIX. +;; +;; Feel free to send bugs, suggestions for enhancements and enhancements +;; to me cdesouza@hpbbn.bbn.hp.com. If I have TIME I will try to deal with +;; them. Also I'm not a lisp programmer so keep it simple or put in plenty +;; of comments. +;; +;; +;; *) Improve on the dired GROUP and ACCOUNT listings. +;; +;; *) Add ".." to dired FILE and GROUP listings. +;; +;; *) Support POSIX (need POSIX machine first though). +;; +;; *) Test ACCOUNT name completion and listings properly. I have the problem +;; that the only systems available to me are large ( i.e. start a listf +;; @.@.@,2 today and come back tomorrow), which makes +;; it pretty hard for me to test. +;; + +;;; Code + +(provide 'efs-mpe) +(require 'efs) + +;;; User Variables + +(defvar efs-mpe-account-completion-confirm t + "*Set to non-nil will cause a prompt to be issued before attempting ACCOUNT +name completion. For ACCOUNT name completion a LISTF @.@.@,2 is required. +This can take a very long time on large systems") + +(defvar efs-mpe-group-completion-confirm t + "*Set to non-nil will cause a prompt to be issued before attempting GROUP +name completion. For GROUP name completion a LISTF @.@.ACCOUNT,2 is required. +This can take a very long time on large accounts") + +(defvar efs-mpe-default-buildparms "" + "*If set to non empty string used to override the system default buildparms.") + +;;; Internal Variables + +(defconst efs-mpe-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;; Support for build parameters + +(defun efs-mpe-get-buildparms (path) + ;; Gets the mpe buildparms for PATH. PATH should be in efs syntax. + (let ((files (efs-get-files-hashtable-entry (file-name-directory + (directory-file-name path))))) + (if files + (let* ((file (efs-get-file-part path)) + (completion-ignore-case + (memq 'mpe efs-case-insensitive-host-types)) + (bpversions (all-completions (concat file ";") files))) + (cond + ((null bpversions) + efs-mpe-default-buildparms) + ((= (length bpversions) 1) + (substring (car bpversions) (length file))) + (t + (error + "efs-mpe: %s seems to have more than one set of buildparams." + path)))) + ;; return the default + efs-mpe-default-buildparms))) + +(defun efs-mpe-fix-buildparms (buildparms host user path) + "Try to assign buildparms for the file being PUT" + (or + ;; Buildparms specified with file use them. + buildparms + (efs-mpe-get-buildparms (format efs-path-format-string user host path)))) + +;;; entry points + +(efs-defun efs-fix-path mpe (path &optional reverse) + ;; Convert PATH from UNIX-ish to MPE. If REVERSE given then convert from + ;; MPE to UNIX-ish. N.B. Path does not contain HOST or USER part so the + ;; dynamic variables HOST and USER are used. + ;; Also uses the dynamic variable CMD0. + (efs-save-match-data + (if reverse + ;; This is never used as we only convert PWD (see below) output in + ;; this direction. However I will leave this here should it be + ;; required in the future. + (if (let ((case-fold-search t)) + (string-match + (concat "^\\([A-Z][A-Z0-9]*\\)" ; file + "\\(.[A-Z][A-Z0-9]*\\)" ; group + "\\(.[A-Z][A-Z0-9]*\\)$") ; account + path)) + (let (file group account) + (setq file (substring path 0 (match-end 1))) + (if (match-beginning 2) + (setq group (substring + path (1+ (match-beginning 2)) (match-end 2)))) + (if (match-beginning 3) + (setq account (substring + path (1+ (match-beginning 3)) + (match-end 3)))) + (concat (and account (concat "/" account "/")) + (and group (concat group "/")) + file)) + ;; handle PWD output + (if (let ((case-fold-search t)) + (string-match + (concat + "\\([A-Z][A-Z0-9]*\\)?" ; sessionname + ",[A-Z][A-Z0-9]*\.\\([A-Z][A-Z0-9]*\\)," ; username.account + "\\([A-Z][A-Z0-9]*\\)$") ; group + path)) + (concat "/" + (substring path (match-beginning 2) (match-end 2)) + "/" + (substring path (match-beginning 3) (match-end 3)) + "/") + (error "Invalid MPE (MPE->UNIX) filename: %s" path))) + (if (let ((case-fold-search t)) + (string-match + (concat + "^\\(/[A-Z][A-Z0-9]*/\\)" ; account + "\\([A-Z][A-Z0-9]*/\\)" ; group + "\\([A-Z][A-Z0-9]*\\)" ; file + "\\(;.*\\)?$") ; buildparms + path)) + (let ((for-put (and (boundp 'cmd0) (eq cmd0 'put))) + file group account buildparms) + (setq account (substring + path (1+ (match-beginning 1)) (1- (match-end 1)))) + (setq group (substring + path (match-beginning 2) (1- (match-end 2)))) + (setq file (substring path (match-beginning 3) (match-end 3))) + (if for-put + (setq buildparms + (efs-mpe-fix-buildparms + (and (match-beginning 4) + (substring path + (match-beginning 4) (match-end 4))) + host user path))) + (concat file + (and group (concat "." group )) + (and account (concat "." account )) + (and for-put buildparms))) + (error "Invalid MPE (UNIX->MPE) filename: *%s*" path))))) + +(efs-defun efs-fix-dir-path mpe (dir-path) + ;; Convert path from UNIX-ish to MPE ready for a DIRectory listing. MPE does + ;; not have directories as such. It does have GROUPS and ACCOUNTS, but the + ;; DIR command does not let you list just ACCOUNTs on the system or just + ;; GROUPs in the ACCOUNT - no you always get everything downwards + ;; i.e. ACCOUNTs + GROUPs + FILEs or GROUPs + FILEs or just FILEs + ;; depending on the level. + (efs-save-match-data + (message "Fixing listing %s ..." dir-path) + (cond + ;; Everything !?! might take a while. + ((string-equal dir-path "/") + (if efs-mpe-account-completion-confirm + (if (y-or-n-p "Continue with ACCOUNT name completion? ") + "@.@.@" + (error "Quit ACCOUNT name completion")) + "@.@.@")) + ;; specification starts with account + ((let ((case-fold-search t)) + (string-match + (concat + "^\\(/[A-Z][A-Z0-9]*/\\)" ; account + "\\([A-Z][A-Z0-9]*/\\)?" ; group + "\\([A-Z][A-Z0-9]*\\)?" ; file + "\\(;.*\\)?/?$") ; buildparms + dir-path)) + (let (file group account) + (setq account (substring dir-path + (1+ (match-beginning 1)) (1- (match-end 1)))) + (if (match-beginning 2) + (setq group (substring dir-path + (match-beginning 2) (1- (match-end 2)))) + (if efs-mpe-group-completion-confirm + (if (y-or-n-p "Continue with GROUP name completion? ") + (setq group "@") + (error "Quit GROUP name completion")) + (setq group "@"))) + (if (match-beginning 3) + ;;(setq file (substring dir-path + ;; (match-beginning 3) (1- (match-end 3)))) + ;; set the filename to something silly so that the DIR will fail + ;; and so force a DIR for the group instead. Either I've + ;; misunderstood something or you have to do it like this. + (setq file "~!#&*") + (setq file "@")) + (concat file "." group "." account))) + (t + (error "Invalid MPE (LISTF) filename: %s" dir-path))))) + +(defconst efs-mpe-acct-grp-line-regexp + "ACCOUNT= +\\([A-Z][A-Z0-9]*\\) +GROUP= +\\([A-Z][A-Z0-9]*\\)") +(defconst efs-mpe-file-line-regexp + (concat + "\\*? +\\([A-Z0-9]*\\) +\\([0-9]+\\)" + "\\([BW]\\) +\\([FV]\\)\\([AB]\\)\\([MCO]?\\) +\\([0-9]+\\)")) + +(efs-defun efs-parse-listing mpe + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be in + ;; mpe ftp dir format. + ;; HOST is the name of the remote host. + ;; USER is the user name. + ;; DIR is the directory as a full remote path + ;; PATH is the directory in full efs-syntax + ;; SWITCHES are the switches passed to ls (not relevant for mpe) + (goto-char (point-min)) + (efs-save-match-data + ;;Make sure this is a valid listing + (if (re-search-forward "ACCOUNT= +[A-Z]+ +GROUP=" nil t) + (let (acct-tbl grp-tbl file-tbl + account group file + acct-cur grp-cur) + (goto-char (point-min)) + ;; Look for something that could be a filename. + (while (re-search-forward "^[A-Z][A-Z0-9]*" nil t) + (goto-char (match-beginning 0)) + ;; Check to see if looking at an ACCOUNT= GROUP= line. Could + ;; be a continuation (cont). line or a change in account or group + (if (looking-at efs-mpe-acct-grp-line-regexp) + (progn + (setq account (buffer-substring (match-beginning 1) + (match-end 1))) + (setq group (buffer-substring (match-beginning 2) + (match-end 2))) + ;;Check for change of account + (if (not (string-equal acct-cur account)) + (progn + ;;Create table for account names and fill with + ;; "." entry. + (if (not acct-tbl) + (progn + (setq acct-tbl (efs-make-hashtable)) + (efs-put-hash-entry "." '(t) acct-tbl))) + (efs-put-hash-entry account '(t) acct-tbl) + ;;Store the current group table + (if grp-tbl + (progn + (efs-set-files + (efs-replace-path-component + path + (concat "/" acct-cur "/")) + grp-tbl ) + (setq grp-tbl nil))))) + ;;Check for change in group. Change in account is automatic + ;;change in group. + (if (or (not (string-equal acct-cur account)) + (not (string-equal grp-cur group))) + (progn + ;;Create table for group names and fill with + ;; "." and ".." entries. + (if (not grp-tbl) + (progn + (setq grp-tbl (efs-make-hashtable)) + (efs-put-hash-entry "." '(t) grp-tbl) + (efs-put-hash-entry ".." '(t) grp-tbl))) + (efs-put-hash-entry group '(t) grp-tbl) + ;;Store current file table + (if file-tbl + (progn + (efs-set-files + (efs-replace-path-component + path + (concat "/" acct-cur "/" grp-cur "/")) + file-tbl) + (setq file-tbl nil))))) + ;;Set new grp-cur and acct-cur incase one or both chnaged. + (setq grp-cur group acct-cur account) + ) + ;;Looking at either a file name, or the line + ;;"FILENAME CODE --....--LOGICAL.." + ;;Save the possible filename. + (setq file (buffer-substring (point) + (progn + (skip-chars-forward "A-Z0-9") + (point)))) + ;;Make sure its a file name. + ;;"\\*?" is for files in access. + ;; File codes can be numeric as well! CdS + (if (looking-at efs-mpe-file-line-regexp) + ;;Hack out the buildparms + (let* ((code (and + (/= (match-beginning 1) (match-end 1)) + (concat ";CODE=" + (buffer-substring + (match-beginning 1) (match-end 1))))) + (length (buffer-substring (match-beginning 2) + (match-end 2))) + (eof (buffer-substring (match-beginning 7) + (match-end 7))) + (bytes (* (string-to-int eof) + (string-to-int length))) + (word-byte (buffer-substring (match-beginning 3) + (match-end 3))) + (fix-var (buffer-substring (match-beginning 4) + (match-end 4))) + (ascii-binary (buffer-substring (match-beginning 5) + (match-end 5))) + (cir-msg (and (match-beginning 6) + (buffer-substring (match-beginning 6) + (match-end 6)))) + (rec ";REC=")) + (if (string-equal word-byte "B") + (setq rec (concat rec "-")) + (setq bytes (* 2 bytes))) + (setq rec (concat rec length ",," fix-var ",")) + (if (string-equal ascii-binary "A") + (setq rec (concat rec "ASCII")) + (setq rec (concat rec "BINARY"))) + (cond ((string-equal cir-msg "M") + (setq cir-msg ";MSG")) + ((string-equal cir-msg "O") + (setq cir-msg ";CIR")) + (t + (setq cir-msg nil))) + (if (not file-tbl) + (progn + (setq file-tbl (efs-make-hashtable)) + (efs-put-hash-entry "." '(t) file-tbl) + (efs-put-hash-entry ".." '(t) file-tbl))) + (message "Adding... %s" file) + (efs-put-hash-entry file (list nil bytes) file-tbl) + (efs-put-hash-entry (concat file rec code cir-msg) + (list nil bytes) file-tbl))) + ) ;if looking-at + (forward-line 1) + );while + ;;Check at what level the listing was done and return the + ;;corresponding table. System = acct-tbl, Account = grp-tbl, + ;;Group = file-tbl. + (if (let ((case-fold-search t)) + (string-match + "\\(/\\)\\([A-Z0-9]+/\\)?\\([A-Z0-9]+/\\)?\\([A-Z0-9]+/\\)?" + dir)) + ;;group level listing, just return table of files + (if (or (match-beginning 3) (match-beginning 4)) + file-tbl + ;;account level listing, return table of groups but do not + ;;forget to store current table of files. + (if (match-beginning 2) + (progn + (if file-tbl + (efs-set-files + (efs-replace-path-component + path + (concat "/" acct-cur "/" grp-cur "/")) + file-tbl)) + grp-tbl) + ;;System level listing, return table of accounts but do not + ;;forget to store current table of groups and files + (if (match-beginning 1) + (progn + (if file-tbl + (efs-set-files + (efs-replace-path-component + path + (concat "/" acct-cur "/" grp-cur "/")) + file-tbl)) + (if grp-tbl + (efs-set-files + (efs-replace-path-component + path + (concat "/" acct-cur "/")) + grp-tbl)) + acct-tbl) + (error "Parse listing 0 path %s" path)))) + (error "Parse listing 1 path %s" path)))))) + + +(efs-defun efs-really-file-p mpe (file ent) + ;; Doesn't treat the buildparm entry as a real file entry. + (efs-save-match-data + (not (string-match ";" file)))) + +(efs-defun efs-delete-file-entry mpe (path &optional dir-p) + ;; Deletes FILE and FILE;BUILDPARMS from file hashtable. + (let ((ignore-case (memq 'mpe efs-case-insensitive-host-types))) + (if dir-p + (let ((path (file-name-as-directory path)) + files) + (efs-del-hash-entry path efs-files-hashtable ignore-case) + (setq path (directory-file-name path) + files (efs-get-files-hashtable-entry + (file-name-directory path))) + (if files + (efs-del-hash-entry (efs-get-file-part path) + files ignore-case))) + (let ((file (efs-get-file-part path)) + (files (efs-get-files-hashtable-entry + (file-name-directory path)))) + (if files + (efs-save-match-data + (if (string-match ";" file) + (let ((root (substring file (match-beginning 0)))) + ;; delete ROOT from hashtable + (efs-del-hash-entry root files ignore-case) + ;; delete ROOT;BUILDPARAMS from hashtable + (efs-del-hash-entry file files ignore-case)) + ;; we've specified only a root. + (let* ((root (concat file ";")) + (completion-ignore-case ignore-case) + (extensions (all-completions root files))) + ;; Get rid of FILE. + (efs-del-hash-entry file files ignore-case) + ;; Get rid of all BUILDPARAMS versions + (while extensions + ;; all-completions will return names with the right case. + ;; Don't need to ignore-case now. + (efs-del-hash-entry (car extensions) files) + (setq extensions (cdr extensions))))))))) + (efs-del-from-ls-cache path t ignore-case))) + +(efs-defun efs-add-file-entry mpe (path dir-p size owner + &optional modes nlinks mdtm) + ;; Deletes FILE (if present) and FILE;BUILDPARMS (if present) from hashtable + ;; then adds FILE and FILE;BUILDPARMS (if specified) to hashtable. + (let ((ignore-case (memq 'mpe efs-case-insensitive-host-types)) + (ent (let ((dir-p (null (null dir-p)))) + (if mdtm + (list dir-p size owner nil nil mdtm) + (list dir-p size owner))))) + + (if dir-p + (let* ((path (directory-file-name path)) + (files (efs-get-files-hashtable-entry + (file-name-directory path)))) + (if files + (efs-put-hash-entry (efs-get-file-part path) ent files + ignore-case))) + + (let ((files (efs-get-files-hashtable-entry + (file-name-directory path)))) + (efs-save-match-data + (if files + (let* ((file (efs-get-file-part path)) + (root (substring file 0 (string-match ";" file)))) + (if (equal root file) + (setq file (concat file (efs-mpe-get-buildparms path)))) + ;; In case there is another entry with different buildparams, + ;; wipe it. + (efs-delete-file-entry 'mpe path nil) + (efs-put-hash-entry root ent files ignore-case) + (efs-put-hash-entry file ent files ignore-case)))))) + (efs-del-from-ls-cache path t ignore-case))) + +(efs-defun efs-allow-child-lookup mpe (host user dir file) + ;; Returns non-NIL if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. Note that DIR is in directory syntax i.e. /foo/bar/, not + ;; /foo/bar. + + ;; Subdirs in MPE are accounts or groups. + (string-match "^/\\([^/]+/\\)?$" dir)) + +(efs-defun efs-file-type mpe (path) + ;; Returns whether to treat an efs file as a text file or not. + (let ((buildparams (efs-mpe-get-buildparms path))) + (efs-save-match-data + (let ((case-fold-search t)) + (cond + ((string-match "BINARY" buildparams) + '8-binary) + (t + 'text)))))) + +;;; Tree dired support: + +(efs-defun efs-dired-manual-move-to-filename mpe + (&optional raise-error bol eol) + ;; In dired, move to first char of filename on this line. + ;; Returns position (point) or nil if no filename on this line. + ;; This is the MPE version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + ;; The "\\|ACCOUNT=\\|GROUP=" bit is to take care of the hacked account and + ;; group dired listings. + (if (looking-at + ". [A-Z][A-Z0-9]*\\*? +\\([A-Z]* +[0-9]+\\|ACCOUNT=\\|GROUP=\\)") + (progn + (forward-char 2) + (point)) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename mpe + (&optional no-error bol eol) + ;; Assumes point is at beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; On failure, signals an error or returns nil. + ;; This is the MPE version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "A-Z0-9") + (if (or (= opoint (point)) (not (memq (following-char) '(?\ ?*)))) + (if no-error + nil + (error "No file on this line")) + (point)))) + +(efs-defun efs-dired-ls-trim mpe () + ;; trim single file listings 1-line. + ;; This uses an evil dynamical binding of file. + (if (and (boundp 'file) (stringp file)) + (let ((f (file-name-nondirectory file))) + (or (zerop (length f)) + (progn + (goto-char (point-min)) + (if (search-forward (concat "\n" (upcase file) " ") nil t) + (progn + (beginning-of-line) + (delete-region (point-min) (point)) + (forward-line 1) + (delete-region (point) (point-max))))))))) + +(efs-defun efs-dired-fixup-listing mpe (file path &optional switches wildcard) + ;; File (group) listings stay pretty much as they are group (account) and + ;; account (system) listings get realy hacked. + (efs-save-match-data + (goto-char (point-max)) + (string-match + "\\(/\\)\\([A-Z0-9]+/\\)?\\([A-Z0-9]+/\\)?\\([A-Z0-9]+/\\)?" + path) + ;; group or file level listing. + (if (or (match-beginning 3) (match-beginning 4)) + ;; Hack out the continuation lines. + (while + (re-search-backward + "\n\nACCOUNT=.+GROUP=.+(CONT\\.)\n\n.*\n.*\n" nil t) + (replace-match "" nil nil)) + ;;account level listing, hack out everything apart from group names + (if (match-beginning 2) + (let ((group nil) + (grp-cur nil)) + (while + (re-search-backward + "GROUP= +\\([A-Z][A-Z0-9]*\\)\\(.\\|\n\\)*" + nil t) + (setq group + (buffer-substring (match-beginning 1) (match-end 1))) + ;;Continuation header or new group + (if (string-equal grp-cur group) + (replace-match "" nil nil) + (replace-match (format "\n\n%-10sGROUP=" group) nil nil)) + (forward-line -1) + (setq grp-cur group) + (narrow-to-region (point-min) (point))) + (widen) + (goto-char (point-max)) + (insert "\n\n")) + ;;System level listing, hack out everything apart from account names + (if (match-beginning 1) + (let (account acct-cur) + (while + (re-search-backward + "^ACCOUNT= +\\([A-Z][A-Z0-9]*\\)\\(.\\|\n\\)*" + nil t) + (setq account + (buffer-substring (match-beginning 1) (match-end 1))) + ;;Continuation header or new account + (if (string-equal acct-cur account) + (replace-match "" nil nil) + (replace-match (format "%-10sACCOUNT=" account) nil nil)) + (forward-line -1) + (setq acct-cur account) + (narrow-to-region (point-min) (point))) + (widen) + (goto-char (point-max)) + (insert "\n\n"))))))) + +;;; end of efs-mpe.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-ms-unix.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-ms-unix.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,165 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-ms-unix.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: efs support for the Microsoft PC FTP server in unix mode. +;; Author: Sandy Rutherford +;; Created: Thu Aug 19 08:31:15 1993 by sandy on ibm550 +;; Modified: Sun Nov 27 18:37:00 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide 'efs-ms-unix) +(require 'efs) + +(defconst efs-ms-unix-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +(defvar efs-ms-unix-month-and-time-regexp + (concat + " \\([0-9]+\\) +" ; file size + "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" + "\\|Nov\\|Dec\\) [ 0-3][0-9]" + " +\\([ 012][0-9]:[0-6][0-9]\\|[12][90][0-9][0-9]\\) +")) + +;;; entry points + +(efs-defun efs-fix-path ms-unix (path &optional reverse) + ;; Convert PATH from UNIX-ish to MS-UNIX. + (if reverse + (concat "/" path) + (substring path 1))) + +(efs-defun efs-fix-dir-path ms-unix (dirpath) + ;; Convert a path from UNIX-ish to MS-UNIX for a dir listing + (if (string-equal dirpath "/") + (error "Cannot grok disk names.") + (setq dirpath (substring dirpath 1)) + (efs-save-match-data + (if (string-match "/$" dirpath) + (concat dirpath "*") + dirpath)))) + +(defmacro efs-ms-unix-parse-file-line () + ;; Extract the filename, size, and permission string from the current + ;; line of a dired-like listing. Assumes that the point is at + ;; the beginning of the line, leaves it just before the size entry. + ;; Returns a list (name size perm-string nlinks owner). + ;; If there is no file on the line, returns nil. + (` (let ((eol (save-excursion (end-of-line) (point))) + name size modes nlinks owner) + (skip-chars-forward " 0-9" eol) + (and + (looking-at efs-modes-links-owner-regexp) + (setq modes (buffer-substring (match-beginning 1) + (match-end 1)) + nlinks (string-to-int (buffer-substring (match-beginning 2) + (match-end 2))) + owner (buffer-substring (match-beginning 3) (match-end 3))) + (re-search-forward efs-ms-unix-month-and-time-regexp eol t) + (setq name (buffer-substring (point) eol) + size (string-to-int (buffer-substring (match-beginning 1) + (match-end 1)))) + (list name size modes nlinks owner))))) + +(efs-defun efs-parse-listing ms-unix (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be output from + ;; the Microsoft FTP server in unix mode. + ;; Return a hashtable as the result. SWITCHES are never used, + ;; but they must be specified in the argument list for compatibility + ;; with the unix version of this function. + ;; HOST = remote host name + ;; USER = user name + ;; DIR = directory in as a full remote path + ;; PATH = directory in full efs path syntax + ;; SWITCHES = ls switches + (goto-char (point-min)) + (efs-save-match-data + (if (re-search-forward efs-ms-unix-month-and-time-regexp nil t) + (let ((tbl (efs-make-hashtable)) + size modes nlinks dir-p owner file) + (beginning-of-line) + (while (setq file (efs-ms-unix-parse-file-line)) + (setq size (nth 1 file) + modes (nth 2 file) + nlinks (nth 3 file) + owner (nth 4 file) + file (car file) + dir-p (= (string-to-char modes) ?d)) + (if (and dir-p + (string-match "/$" file)) + (setq file (substring file 0 -1))) + (efs-put-hash-entry file (list dir-p size owner modes nlinks) tbl) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl)))) + +;;; Tree Dired + +;; ms-unix does not have a total line + +(efs-defun efs-dired-insert-headerline ms-unix (dir) + ;; MTS has no total line, so we insert a blank line for + ;; aesthetics. + (insert "\n") + (forward-char -1) + (efs-real-dired-insert-headerline dir)) + +(efs-defun efs-dired-manual-move-to-filename ms-unix + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line. + ;; Returns (point) or nil if raise-error is nil, and there is no + ;; no filename on this line. + ;; This version is for ms-unix. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r") + (setq bol (point))) + (if (re-search-forward efs-ms-unix-month-and-time-regexp eol t) + (point) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename ms-unix + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + ;; This is the ms-unix version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit."))))) + (if (eolp) + (progn + (goto-char opoint) + (if no-error + nil + (error "No file on this line"))) + (end-of-line) + (if (char-equal (preceding-char) ?/) + (forward-char -1)) + (point)))) + +;;; end of efs-ms-unix.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-mts.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-mts.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,239 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-mts.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: MTS support for efs +;; Author: Sandy Rutherford +;; Created: Fri Oct 23 08:51:29 1992 +;; Modified: Sun Nov 27 18:37:18 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(provide 'efs-mts) +(require 'efs) + +(defconst efs-mts-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;; ------------------------------------------------------------ +;;;; MTS support +;;;; ------------------------------------------------------------ + +;;; efs has full support, including tree dired support, for hosts running +;;; the Michigan terminal system. It should be able to automatically +;;; recognize any MTS machine. We would be grateful if you +;;; would report any failures to automatically recognize a MTS host as a bug. +;;; +;;; Filename syntax: +;;; +;;; MTS filenames are entered in a UNIX-y way. For example, if your account +;;; was YYYY, the file FILE in the account XXXX: on mtsg.ubc.ca would be +;;; entered as +;;; /YYYY@mtsg.ubc.ca:/XXXX:/FILE +;;; In other words, MTS accounts are treated as UNIX directories. Of course, +;;; to access a file in another account, you must have access permission for +;;; it. If FILE were in your own account, then you could enter it in a +;;; relative path fashion as +;;; /YYYY@mtsg.ubc.ca:FILE +;;; MTS filenames can be up to 12 characters. Like UNIX, the structure of the +;;; filename does not contain a TYPE (i.e. it can have as many "."'s as you +;;; like.) MTS filenames are always in upper case, and hence be sure to enter +;;; them as such! MTS is not case sensitive, but an EMACS running under UNIX +;;; is. + + +(defconst efs-mts-date-regexp + (concat + " \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" + "\\|Nov\\|Dec\\) [ 123]?[0-9] ")) + +;;; The following two functions are entry points to this file. +;;; They are put into the appropriate alists in efs.el + +(efs-defun efs-fix-path mts (path &optional reverse) + ;; Convert PATH from UNIX-ish to MTS. + ;; If REVERSE given then convert from MTS to UNIX-ish. + (efs-save-match-data + (if reverse + (if (string-match "^\\([^:]+:\\)?\\(.*\\)$" path) + (let (acct file) + (if (match-beginning 1) + (setq acct (substring path 0 (match-end 1)))) + (if (match-beginning 2) + (setq file (substring path + (match-beginning 2) (match-end 2)))) + (concat (and acct (concat "/" acct "/")) + file)) + (error "path %s didn't match" path)) + (if (string-match "^/\\([^:]+:\\)/\\(.*\\)$" path) + (concat (substring path 1 (match-end 1)) + (substring path (match-beginning 2) (match-end 2))) + ;; Let's hope that mts will recognize it anyway. + path)))) + +(efs-defun efs-fix-dir-path mts (dir-path) +;; Convert path from UNIX-ish to MTS ready for a DIRectory listing. +;; Remember that there are no directories in MTS. + (if (string-equal dir-path "/") + (error "Cannot get listing for fictitious \"/\" directory.") + (let ((dir-path (efs-fix-path 'mts dir-path))) + (cond + ((string-equal dir-path "") + "?") + ((efs-save-match-data (string-match ":$" dir-path)) + (concat dir-path "?")) + (dir-path))))) ; It's just a single file. + + +(efs-defun efs-parse-listing mts + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be in + ;; mts ftp dir format. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = remote directory as a remote full path + ;; PATH = directory as an efs full path + ;; SWITCHES are never used here, but they + ;; must be specified in the argument list for compatibility + ;; with the unix version of this function. + (let ((tbl (efs-make-hashtable)) + perms) + (goto-char (point-min)) + (efs-save-match-data + (while (re-search-forward efs-mts-date-regexp nil t) + (beginning-of-line) + (if (looking-at "[rwed]+") + (setq perms (buffer-substring (match-beginning 0) (match-end 0))) + (setq perms nil)) + (end-of-line) + (skip-chars-backward " ") + (let ((end (point))) + (skip-chars-backward "-A-Z0-9_.!") + (efs-put-hash-entry (buffer-substring (point) end) + (list nil nil nil perms) tbl)) + (forward-line 1))) + ;; Don't need to bother with .. + (efs-put-hash-entry "." '(t) tbl) + tbl)) + +(efs-defun efs-allow-child-lookup mts (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + + ;; MTS file system is flat. Only "accounts" are subdirs. + (string-equal "/" dir)) + +(efs-defun efs-internal-file-writable-p mts (user owner modes) + (if (stringp modes) + (efs-save-match-data + (null (null (string-match "w" modes)))) + t)) ; guess + +(efs-defun efs-internal-file-readable-p mts (user owner modes) + (if (stringp modes) + (efs-save-match-data + (null (null (string-match "r" modes)))) + t)) ; guess + +;;; Tree dired support: + +;; There aren't too many systems left that use MTS. This dired support will +;; work for the implementation of ftp on mtsg.ubc.ca. I hope other mts systems +;; implement ftp in the same way. If not, it might be necessary to make the +;; following more flexible. + +(defconst efs-dired-mts-re-exe nil) + +(or (assq 'mts efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'mts efs-dired-mts-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-mts-re-dir nil) + +(or (assq 'mts efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'mts efs-dired-mts-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-manual-move-to-filename mts + (&optional raise-error bol eol) + ;; In dired, move to first char of filename on this line. + ;; Returns position (point) or nil if no filename on this line. + ;; This is the MTS version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + (if (re-search-forward efs-mts-date-regexp eol t) + (progn + (skip-chars-forward " ") ; Eat blanks after date + (skip-chars-forward "0-9:") ; Eat time or year + (skip-chars-forward " ") ; one space before filename + (point)) + (and raise-error (error "No file on this line")))) + +(efs-defun efs-dired-manual-move-to-end-of-filename mts + (&optional no-error bol eol) + ;; Assumes point is at beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; On failure, signals an error or returns nil. + ;; This is the MTS version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "-A-Z0-9._!") + (if (or (= opoint (point)) (not (memq (following-char) '(?\r ?\n)))) + (if no-error + nil + (error "No file on this line")) + (point)))) + +(efs-defun efs-dired-fixup-listing mts (file path &optional switches wildcard) + ;; If you're not listing your own account, MTS puts the + ;; account name in front of each filename. Scrape them off. + ;; PATH will have unix /'s on it. + ;; file-name-directory is in case of wildcards + (let ((len (length path))) + (if (> len 2) + (progn + (if (= (aref path (1- len)) ?/) + (setq path (substring path -2)) + (setq path (substring path -1))) + (goto-char (point-min)) + (while (search-forward path nil t) + (delete-region (match-beginning 0) (match-end 0))))))) + +(efs-defun efs-dired-insert-headerline mts (dir) + ;; MTS has no total line, so we insert a blank line for + ;; aesthetics. + (insert "\n") + (forward-char -1) + (efs-real-dired-insert-headerline dir)) + +;;; end of efs-mts.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-mvs.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-mvs.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,361 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-mvs.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: MVS support for efs +;; Author: Sandy Rutherford +;; Created: Sat Nov 14 02:04:54 1992 +;; Modified: Sun Nov 27 18:37:54 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;; -------------------------------------------------------- +;;; MVS support +;;; -------------------------------------------------------- + +(provide 'efs-mvs) +(require 'efs) + +(defconst efs-mvs-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;; What's the MVS character set for valid partitioned data sets? +;; I'll guess [-A-Z0-9_$+] + +;; The top level directory in MVS contains partitioned data sets. +;; We will view these as directories. The data sets within each +;; partitioned data set will be viewed as files. +;; +;; In MVS an entry for a "sub-dir" may have the same name as a plain +;; file. This is impossible in unix, so we retain the "dots" at the +;; end of subdir names, to distinuguish. +;; i.e. FOO.BAR --> /FOO./BAR + +(efs-defun efs-send-pwd mvs (host user &optional xpwd) + ;; Broken quoting for PWD output on some MVS servers. + (let* ((result (efs-send-cmd host user '(pwd) "Getting EXPLORER PWD")) + (line (nth 1 result)) + dir) + (and (car result) + (efs-save-match-data + (and (string-match " \"'?\\([0-9A-Z]+\\)'?\"" line) + (setq dir (substring line (match-beginning 1) + (match-end 1)))))) + (cons dir line))) + +(efs-defun efs-fix-path mvs (path &optional reverse) + ;; Convert PATH from UNIX-ish to MVS. + (efs-save-match-data + (if reverse + (let ((start 0) + (res "/")) + ;; MVS has only files, some of which are partitioned + ;; into smaller files (partitioned data sets). We will + ;; assume that path starts with a partitioned dataset. + (while (string-match "\\." path) + ;; grab the dot too, because in mvs prefixes and plain + ;; files can have the same name. + (setq res (concat res (substring path start (match-end 0)) "/") + start (match-end 0))) + (concat res (substring path start))) + (let ((start 1) + res) + (while (string-match "/" path start) + (setq res (concat res (substring path start (match-beginning 0))) + start (match-end 0))) + (concat res (substring path start)))))) + +(efs-defun efs-fix-dir-path mvs (dir-path) + ;; Convert path from UNIX-ish to MVS for a DIR listing. + (cond + ((string-equal "/" dir-path) + " ") + (t (concat (efs-fix-path 'mvs dir-path) "*")))) + +(efs-defun efs-allow-child-lookup mvs (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + ;; MVS file system is flat. Only partitioned data sets are "subdirs". + (efs-save-match-data + (string-match "\\.$" file))) + +(efs-defun efs-parse-listing mvs (host user dir path &optional switches) + ;; Guesses the type of mvs listings. + (efs-save-match-data + (goto-char (point-min)) + (cond + ((looking-at "Volume ") + (efs-add-listing-type 'mvs:tcp host user) + (efs-parse-listing 'mvs:tcp host user dir path switches)) + + ((looking-at "[-A-Z0-9_$.+]+ ") + (efs-add-listing-type 'mvs:nih host user) + (efs-parse-listing 'mvs:nih host user dir path switches)) + + (t + ;; Since MVS works on a template system, return an empty hashtable. + (let ((tbl (efs-make-hashtable))) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl))))) + +(efs-defun efs-ls-dumb-check mvs (line host file path lsargs msg noparse + noerror nowait cont) + ;; Because of the template structure of the MVS file system, empty + ;; directories are the same as non-existent. It's better for us to treat + ;; them as empty. + (and (string-match "^550 " line) + (let ((parse (or (null noparse) (eq noparse 'parse) + (efs-parsable-switches-p lsargs t)))) + (efs-add-to-ls-cache file lsargs "\n" parse) + (if parse + (efs-set-files file (let ((tbl (efs-make-hashtable))) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl))) + (if nowait + (progn + (if cont + (efs-call-cont cont "\n")) + t) + (if cont + (efs-call-cont cont "\n")) + "\n")))) + +;;;; ---------------------------------------------------- +;;;; Support for the NIH FTP server. +;;;; ---------------------------------------------------- + +(efs-defun efs-parse-listing mvs:nih + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be an MVS listing + ;; Based on the listing format of the NIH server. Hope that this format + ;; is widespread. If a directory doesn't exist, get a 426 ftp error. + ;; HOST = remote host name + ;; USER = user name + ;; DIR = directory as a remote full path + ;; PATH = directory in full efs-syntax + (let ((tbl (efs-make-hashtable)) + (top-p (string-equal "/" dir)) + ;; assume that everything top-level is a partitioned data set + ) + (goto-char (point-min)) + (efs-save-match-data + (while (re-search-forward "^[-A-Z0-9_$.+]+" nil t) + (efs-put-hash-entry + (concat (buffer-substring (match-beginning 0) (match-end 0)) + (and top-p ".")) + (list top-p) tbl) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (or top-p (efs-put-hash-entry ".." '(t) tbl))) + tbl)) + +;;; Tree dired support + +(defconst efs-dired-mvs-re-exe + "^. [-A-Z0-9_$+]+\\.EXE " + "Regular expression to use to search for MVS executables.") + +(or (assq 'mvs:nih efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'mvs:nih efs-dired-mvs-re-exe) + efs-dired-re-exe-alist))) + +(efs-defun efs-dired-insert-headerline mvs:nih (dir) + ;; MVS has no total line, so we insert a blank line for + ;; aesthetics. + (insert "\n") + (forward-char -1) + (efs-real-dired-insert-headerline dir)) + +(efs-defun efs-dired-manual-move-to-filename mvs:nih + (&optional raise-error bol eol) + ;; In dired, move to the first char of the filename on this line. + ;; This is the MVS version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r") + (setq bol (point))) + ;; MVS listings are pretty loose. Tough to tell when we've got a file line. + (if (and + (> (- eol bol) 2) + (progn + (forward-char 2) + (skip-chars-forward " \t") + (looking-at "[-A-Z0-9$_.+]+[ \n\r]"))) + (point) + (goto-char bol) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename mvs:nih + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; case-fold-search must be nil, at least for VMS. + ;; On failure, signals an error or returns nil. + ;; This is the MVS version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "-A-Z0-9$_.+" eol) + (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r ?\ )))) + (if no-error + nil + (error "No file on this line")) + (point)))) + +(efs-defun efs-dired-get-filename mvs:nih + (&optional localp no-error-if-not-filep) + (let ((name (efs-real-dired-get-filename localp no-error-if-not-filep)) + (parsed (efs-ftp-path (dired-current-directory)))) + (if (and name (string-equal "/" (nth 2 parsed))) + (concat name ".") + name))) + +(efs-defun efs-dired-fixup-listing mvs:nih + (file path &optional switches wildcard) + ;; MVS listings have trailing spaces to 80 columns. + ;; Can lead to a mess after indentation. + (goto-char (point-min)) + (while (re-search-forward " +$" nil t) + (replace-match ""))) + +;;;; ------------------------------------------------------- +;;;; Support for the TCPFTP MVS server +;;;; ------------------------------------------------------- +;;; +;;; For TCPFTP IBM MVS V2R2.1 Does it really work? + +(efs-defun efs-parse-listing mvs:tcp + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be an MVS listing + ;; Based on the listing format of the NIH server. Hope that this format + ;; is widespread. If a directory doesn't exist, get a 426 ftp error. + ;; HOST = remote host name + ;; USER = user name + ;; DIR = directory as a remote full path + ;; PATH = directory in full efs-syntax + (efs-save-match-data + (goto-char (point-min)) + (and (looking-at "Volume ") + (let ((top-tbl (efs-make-hashtable)) + (case-fold (memq 'mvs efs-case-insensitive-host-types)) + tbl-list file dn fn tbl dir-p) + (forward-line 1) + (while (not (eobp)) + (end-of-line) + (setq file (buffer-substring (point) + (progn (skip-chars-backward "^ ") + (point))) + dn path + dir-p (string-match "\\." file)) + (efs-put-hash-entry file '(nil) top-tbl) + (if dir-p + (progn + (setq dir-p (1+ dir-p) + fn (substring file 0 dir-p)) + (efs-put-hash-entry fn '(t) top-tbl) + (while dir-p + (setq dn (efs-internal-file-name-as-directory nil + (concat dn fn)) + file (substring file dir-p) + tbl (cdr (assoc dn tbl-list))) + (or tbl (setq tbl (efs-make-hashtable) + tbl-list (cons (cons dn tbl) tbl-list))) + (efs-put-hash-entry file '(nil) tbl) + (setq dir-p (string-match "\\." file)) + (if dir-p + (progn + (setq dir-p (1+ dir-p) + fn (substring file 0 dir-p)) + (efs-put-hash-entry fn '(t) tbl)))))) + (forward-line 1)) + (while tbl-list + (efs-put-hash-entry (car (car tbl-list)) (cdr (car tbl-list)) + efs-files-hashtable case-fold) + (setq tbl-list (cdr tbl-list))) + top-tbl)))) + +;;; Tree Dired + +(efs-defun efs-dired-manual-move-to-filename mvs:tcp + (&optional raise-error bol eol) + ;; In dired, move to the first char of the filename on this line. + ;; This is the MVS version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r") + (setq bol (point))) + (if (and (re-search-forward " [0-9][0-9]/[0-9][0-9]/[0-9][0-9] " eol t) + (progn + (goto-char eol) + (skip-chars-backward "-A-Z0-9$_.") + (char-equal (preceding-char) ?\ )) + (/= eol (point))) + (point) + (goto-char bol) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename mvs:tcp + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; case-fold-search must be nil, at least for VMS. + ;; On failure, signals an error or returns nil. + ;; This is the MVS version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "-A-Z0-9$_.+" eol) + (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r ?\ )))) + (if no-error + nil + (error "No file on this line")) + (point)))) + +;;; end of efs-mvs.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-netrc.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-netrc.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,391 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-netrc.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Parses ~/.netrc file, and does completion in /. +;; Author: Sandy Rutherford +;; Created: Fri Jan 28 19:32:47 1994 by sandy on ibm550 +;; Modified: Sun Nov 27 18:38:50 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;;; ------------------------------------------------------------ +;;;; Provisions and requirements. +;;;; ------------------------------------------------------------ + +(provide 'efs-netrc) +(require 'efs-cu) +(require 'efs-ovwrt) +(require 'passwd) +(require 'efs-fnh) + +;;;; ------------------------------------------------------------ +;;;; Internal Variables +;;;; ------------------------------------------------------------ + +(defconst efs-netrc-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;; Make the byte compiler happy. +(defvar dired-directory) + +;;;; ------------------------------------------------------------ +;;;; Use configuration variables. +;;;; ------------------------------------------------------------ + +(defvar efs-netrc-filename "~/.netrc" + "*File in .netrc format to search for passwords. +If you encrypt this file, name it something other than ~/.netrc. Otherwise, +ordinary FTP will bomb. + +If you have any cryption package running off of find-file-hooks +(such as crypt.el or crypt++.el), efs will use it to decrypt this file. +Encrypting this file is a good idea!") + +(defvar efs-disable-netrc-security-check nil + "*If non-nil avoid checking permissions for `efs-netrc-filename'.") + +;;;; ------------------------------------------------------------ +;;;; Host / User / Account mapping support. +;;;; ------------------------------------------------------------ + +(defun efs-set-passwd (host user passwd) + "For a given HOST and USER, set or change the associated PASSWORD." + (interactive (list (read-string "Host: ") + (read-string "User: ") + (read-passwd "Password: "))) + (efs-set-host-user-property host user 'passwd + (and passwd (efs-code-string passwd)))) + +(defun efs-set-account (host user minidisk account) + "Given HOST, USER, and MINIDISK, set or change the ACCOUNT password. +The minidisk is only relevant for CMS. If minidisk is irrelevant, +give the null string for it. In lisp programs, give the minidisk as nil." + (interactive (efs-save-match-data + (let* ((path (or buffer-file-name + (and (eq major-mode 'dired-mode) + dired-directory))) + (parsed (and path (efs-ftp-path path))) + (default-host (car parsed)) + (default-user (nth 1 parsed)) + (default-minidisk + (and parsed + (eq (efs-host-type default-host) 'cms) + (string-match "^/[^/]+/" (nth 2 parsed)) + (substring (nth 2 parsed) 1 + (1- (match-end 0))))) + (host (read-string "Host: " default-host)) + (user (read-string "User: " default-user)) + (minidisk + (read-string + "Minidisk (enter null string if inapplicable): " + default-minidisk)) + (account (read-passwd "Account password: "))) + (if (string-match "^ *$" minidisk) + (setq minidisk nil)) + (list host user minidisk account)))) + (and account (setq account (efs-code-string account))) + (if minidisk + (efs-put-hash-entry (concat (downcase host) "/" user "/" minidisk) + account efs-minidisk-hashtable) + (efs-set-host-user-property host user 'account account))) + +;;;; ------------------------------------------------------------ +;;;; Parsing the ~/.netrc. +;;;; ------------------------------------------------------------ + +(defconst efs-netrc-modtime nil) +;; Last modified time of the netrc file from file-attributes. + +(defun efs-netrc-next-token () + ;; Gets the next token plus it's value. + ;; Returns \(token value-1 value-2 ...\) + (skip-chars-forward " \t\n") + (while (char-equal (following-char) ?#) + (forward-line 1) + (skip-chars-forward " \t\n")) + (let ((tok (and (not (eobp)) + (downcase (buffer-substring + (point) + (progn + (skip-chars-forward "^ \n\t") + (point))))))) + (cond + ((null tok) nil) + ((string-equal tok "default") + (list tok)) + ((member tok (list "machine" "login" "password" "account")) + (list tok (efs-netrc-read-token-value))) + ((string-equal tok "minidisk") + (list tok (efs-netrc-read-token-value) + (efs-netrc-read-token-value))) + ((string-equal tok "include") + (let ((start (- (point) 7)) + (path (expand-file-name (efs-netrc-read-token-value)))) + (delete-region start (point)) + (save-excursion (insert (efs-netrc-get-include path)))) + (efs-netrc-next-token)) + ;; Deal with tokens that we skip + ((string-equal tok "macdef") + (efs-save-match-data + (search-forward "\n\n" nil 'move)) + (if (eobp) + nil + (efs-netrc-next-token))) + (t (error "efs netrc file error: Invalid token %s." tok))))) + +(defun efs-netrc-read-token-value () + ;; Read the following word as a token value. + (skip-chars-forward " \t\n") + (while (char-equal (following-char) ?#) + (forward-line 1) + (skip-chars-forward " \t\n")) + (if (eq (following-char) ?\") ;quoted token value + (prog2 + (forward-char 1) + (buffer-substring (point) + (progn (skip-chars-forward "^\"") (point))) + (forward-char 1)) + (buffer-substring (point) + (progn (skip-chars-forward "^ \n\t") (point))))) + +(defun efs-netrc-get-include (path) + ;; Returns the text of an include file. + (let ((buff (create-file-buffer path))) + (unwind-protect + (save-excursion + (set-buffer buff) + (setq buffer-file-name path + default-directory (file-name-directory path)) + (insert-file-contents path) + (normal-mode t) + (mapcar 'funcall find-file-hooks) + (setq buffer-file-name nil) + (buffer-string)) + (condition-case nil + ;; go through this rigamoroll, because who knows + ;; where an interrupt in find-file-hooks leaves us. + (save-excursion + (set-buffer buff) + (set-buffer-modified-p nil) + (passwd-kill-buffer buff)) + (error nil))))) + +(defun efs-parse-netrc-group (&optional machine) + ;; Extract the values for the tokens "machine", "login", "password", + ;; "account" and "minidisk" in the current buffer. If successful, + ;; record the information found. + (let (data login) + ;; Get a machine token. + (if (or machine (setq data (efs-netrc-next-token))) + (progn + (cond + (machine) ; noop + ((string-equal (car data) "machine") + (setq machine (nth 1 data))) + ((string-equal (car data) "default") + (setq machine 'default)) + (error + "efs netrc file error: %s" + "Token group must start with machine or default.")) + ;; Next look for a login token. + (setq data (efs-netrc-next-token)) + (cond + ((null data) + ;; This just interns in the hashtable for completion to + ;; work. The username gets set later by efs-get-user. + (if (stringp machine) (efs-set-user machine nil)) + nil) + ((string-equal (car data) "machine") + (if (stringp machine) (efs-set-user machine nil)) + (nth 1 data)) + ((string-equal (car data) "default") + 'default) + ((not (string-equal (car data) "login")) + (error "efs netrc file error: Expected login token for %s." + (if (eq machine 'default) + "default" + (format "machine %s" machine)))) + (t + (setq login (nth 1 data)) + (if (eq machine 'default) + (setq efs-default-user login) + (efs-set-user machine login) + ;; Since an explicit login entry is given, intern an entry + ;; in the efs-host-user-hashtable for completion purposes. + (efs-set-host-user-property machine login nil nil)) + (while (and (setq data (efs-netrc-next-token)) + (not (or (string-equal (car data) "machine") + (string-equal (car data) "default")))) + (cond + ((string-equal (car data) "password") + (if (eq machine 'default) + (setq efs-default-password (nth 1 data)) + (efs-set-passwd machine login (nth 1 data)))) + ((string-equal (car data) "account") + (if (eq machine 'default) + (setq efs-default-account (nth 1 data)) + (efs-set-account machine login nil (nth 1 data)))) + ((string-equal (car data) "minidisk") + (if (eq machine 'default) + (error "efs netrc file error: %s." + "Minidisk token is not allowed for default entry.") + (apply 'efs-set-account machine login (cdr data)))) + ((string-equal (car data) "login") + (error "efs netrc file error: Second login token for %s." + (if (eq machine 'default) + "default" + (format "machine %s" machine)))))) + (and data (if (string-equal (car data) "machine") + (nth 1 data) + 'default)))))))) + +(defun efs-parse-netrc () + "Parse the users ~/.netrc file, or file specified `by efs-netrc-filename'. +If the file exists and has the correct permissions then extract the +\`machine\', \`login\', \`password\', \`account\', and \`minidisk\' +information from within." + (interactive) + (and efs-netrc-filename + (let* ((file (expand-file-name efs-netrc-filename)) + ;; Set to nil to avoid an infinite recursion if the + ;; .netrc file is remote. + (efs-netrc-filename nil) + (file (efs-chase-symlinks file)) + (attr (file-attributes file)) + netrc-buffer next) + (if (or (interactive-p) ; If interactive, really do something. + (and attr ; file exists. + ;; file changed + (not (equal (nth 5 attr) efs-netrc-modtime)))) + (efs-save-match-data + (or efs-disable-netrc-security-check + (and (eq (nth 2 attr) (user-uid)) ; Same uids. + (string-match ".r..------" (nth 8 attr))) + (efs-netrc-scream-and-yell file attr)) + (unwind-protect + (save-excursion + ;; we are cheating a bit here. I'm trying to do the + ;; equivalent of find-file on the .netrc file, but + ;; then nuke it afterwards. + ;; with the bit of logic below we should be able to have + ;; encrypted .netrc files. + (set-buffer (setq netrc-buffer + (generate-new-buffer "*ftp-.netrc*"))) + (insert-file-contents file) + (setq buffer-file-name file) + (setq default-directory (file-name-directory file)) + (normal-mode t) + (mapcar 'funcall find-file-hooks) + (setq buffer-file-name nil) + (goto-char (point-min)) + (while (and (not (eobp)) + (setq next (efs-parse-netrc-group next))))) + (condition-case nil + ;; go through this rigamoroll, because we knows + ;; where an interrupt in find-file-hooks leaves us. + (save-excursion + (set-buffer netrc-buffer) + (set-buffer-modified-p nil) + (passwd-kill-buffer netrc-buffer)) + (error nil))) + (setq efs-netrc-modtime (nth 5 attr))))))) + +(defun efs-netrc-scream-and-yell (file attr) + ;; Complain about badly protected netrc files. + (let* ((bad-own (/= (nth 2 attr) (user-uid))) + (modes (nth 8 attr)) + (bad-protect (not (string-match ".r..------" modes)))) + (if (or bad-own bad-protect) + (save-window-excursion + (with-output-to-temp-buffer "*Help*" + (if bad-own + (princ + (format + "Beware that your .netrc file %s is not owned by you.\n" + file))) + (if bad-protect + (progn + (if bad-own + (princ "\nAlso,") + (princ "Beware that")) + (princ + " your .netrc file ") + (or bad-own (princ (concat file " "))) + (princ + (format + "has permissions\n %s.\n" modes)))) + (princ + "\nIf this is intentional, then setting \ +efs-disable-netrc-security-check +to t will inhibit this warning in the future.\n")) + (select-window (get-buffer-window "*Help*")) + (enlarge-window (- (count-lines (point-min) (point-max)) + (window-height) -1)) + (if (and bad-protect + (y-or-n-p (format "Set permissions on %s to 600? " file))) + (set-file-modes file 384)))))) + +;;;; ---------------------------------------------------------------- +;;;; Completion in the root directory. +;;;; ---------------------------------------------------------------- + +(defun efs-generate-root-prefixes () + "Return a list of prefixes of the form \"user@host:\". +Used when completion is done in the root directory." + (efs-parse-netrc) + (efs-save-match-data + (let (res) + (efs-map-hashtable + (function + (lambda (key value) + (if (string-match "^[^/]+\\(/\\).+$" key) + ;; efs-passwd-hashtable may have entries of the type + ;; "machine/" to indicate a password assigned to the default + ;; user for "machine". Don't use these entries for completion. + (let ((host (substring key 0 (match-beginning 1))) + (user (substring key (match-end 1)))) + (setq res (cons (list (format + efs-path-user-at-host-format + user host)) + res)))))) + efs-host-user-hashtable) + (efs-map-hashtable + (function (lambda (host user) + (setq res (cons (list (format efs-path-host-format + host)) + res)))) + efs-host-hashtable) + (if (and (null res) + (string-match "^1[0-8]\\.\\|^[0-9]\\." emacs-version)) + (list nil) + res)))) + +(defun efs-root-file-name-all-completions (file dir) + ;; Generates all completions in the root directory. + (let ((file-name-handler-alist (efs-file-name-handler-alist-sans-fn + 'efs-root-handler-function))) + (nconc (all-completions file (efs-generate-root-prefixes)) + (file-name-all-completions file dir)))) + + +(defun efs-root-file-name-completion (file dir) + ;; Calculates completions in the root directory to include remote hosts. + (let ((file-name-handler-alist (efs-file-name-handler-alist-sans-fn + 'efs-root-handler-function))) + (try-completion + file + (nconc (efs-generate-root-prefixes) + (mapcar 'list (file-name-all-completions file "/")))))) + + +;;; end of efs-netrc.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-netware.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-netware.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,196 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-netware.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: efs support for the Novell Netware FTP server +;; Author: Sandy Rutherford +;; Created: Fri Oct 15 00:30:50 1993 by sandy on gauss.math.ubc.ca +;; Modified: Tue Nov 22 00:11:46 1994 by sandy on gandalf +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;; Works for (at least) Novell NetWare v3.11. This is a DOS FTP server, +;;; however, it returns a unix-ish path format. + +(provide 'efs-netware) +(require 'efs) + +(defconst efs-netware-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;; Basic efs support + +(defconst efs-netware-date-regexp + (concat + "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|" + "Dec\\) [ 0-3][0-9] \\([0-9][0-9] \\)?[0-2][0-9]:[0-6][0-9] +")) + +(efs-defun efs-fix-path netware (path &optional reverse) + ;; Convert PATH from UNIX-ish to netware. + (efs-save-match-data + (if reverse + (cond ((string-match "^[^/][^:]*:" path) + (concat "/" path)) + ((string-match "^/" path) + path) + ((error "%s not a valid netware path." path))) + (if (string-match ":" path) + (substring path 1) + path)))) + +(efs-defun efs-fix-dir-path netware (dir-path) + ;; Convert DIR-PATH from UN*X-ish to Netware for a DIR listing. + (efs-fix-dir-path nil (efs-fix-path 'netware dir-path))) + +(defun efs-netware-bogus-listing-p (dir path) + (save-excursion + (and + (not (eobp)) + (save-excursion (forward-line 1) (eobp)) + (not (string-equal dir "/")) + (re-search-forward efs-netware-date-regexp nil t) + (search-forward "/.\n")))) + +(efs-defun efs-parse-listing netware (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a listing from + ;; a Novell Netware FTP server (runs under DOS). + ;; format, and return a hashtable as the result. SWITCHES are never used, + ;; but they must be specified in the argument list for compatibility + ;; with the unix version of this function. + ;; HOST = remote host name + ;; USER = user name + ;; DIR = directory in as a full remote path + ;; PATH = directory in full efs path syntax + ;; SWITCHES = ls switches (not relevant here) + (goto-char (point-min)) + (efs-save-match-data + (if (re-search-forward efs-netware-date-regexp nil t) + (progn + (beginning-of-line) + (and (not (efs-netware-bogus-listing-p dir path)) + (let ((tbl (efs-make-hashtable)) + dir-p file size) + (while (let ((eol (save-excursion (end-of-line) (point)))) + (setq dir-p (= (following-char) ?d)) + (re-search-forward efs-netware-date-regexp eol t)) + (setq file (buffer-substring (point) + (progn (end-of-line) (point))) + size (progn + (goto-char (match-beginning 0)) + (skip-chars-backward " ") + (buffer-substring (point) + (progn + (skip-chars-backward "0-9") + (point))))) + (if (string-equal size "") + (setq size nil) + (setq size (string-to-int size))) + (efs-put-hash-entry file (list dir-p size) tbl) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl)))))) + +;;; Sorting dir listings. + +(efs-fset 'efs-t-converter 'netware 'efs-unix-t-converter) + +;;; Dired support + +(defconst efs-dired-netware-re-exe "\\.\\(exe\\|EXE\\)$") +(or (assq 'netware efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'netware efs-dired-netware-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-netware-re-dir "^.[ \t]+d ") +(or (assq 'netware efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'netware efs-dired-netware-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-manual-move-to-filename netware + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line. + ;; Returns (point) or nil if raise-error is nil, and there is no + ;; no filename on this line. + ;; This is the Netware version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + ;; move over marker + (if (re-search-forward efs-netware-date-regexp eol t) + (goto-char (match-end 0)) ; returns (point) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename netware + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + ;; This is the Netware version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "^A-Z\n\r") + (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r ?\ )))) + (if no-error + nil + (error "No file on this line")) + (point)))) + +(efs-defun efs-dired-insert-headerline netware (dir) + ;; Insert a blank line for aesthetics. + (insert " \n") + (forward-char -2) + (efs-real-dired-insert-headerline dir)) + +(efs-defun efs-dired-fixup-listing netware + (file path &optional switches wildcard) + ;; listings come out in random order + (let (case-fold-search) + (if (or (null switches) + ;; In case efs is handling the switches itself. + (not (string-match "t" switches))) + (progn + (goto-char (point-max)) + (if (re-search-backward efs-netware-date-regexp nil t) + (save-restriction + (forward-line 1) + (narrow-to-region (point-min) (point)) + (forward-line -1) + ;; Count how many fields + (let ((fields 0)) + (skip-chars-forward " \t") + (while (not (eolp)) + (skip-chars-forward "^ \t\n") + (skip-chars-forward " \t") + (setq fields (1+ fields))) + (sort-fields fields (point-min) (point-max))))))))) + +;;; end of efs-netware.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-nos-ve.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-nos-ve.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,209 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-nos-ve.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: efs support for NOS/VE +;; Authors: Sandy Rutherford +;; Created: Fri Aug 19 04:57:09 1994 by sandy on ibm550 +;; Modified: Sun Nov 27 18:39:43 1994 by sandy on gandalf +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(provide 'efs-nos-ve) +(require 'efs) + +;;; Works for NOS/VE from CDC. NOS/VE runs on Cybers. + +;;; Thank you to Jost Krieger for +;;; providing imformation and testing. + +(defconst efs-nos-ve-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;;--------------------------------------------------------------- +;;;; NOS/VE support for efs +;;;;--------------------------------------------------------------- + +;;; A legal NOS/VE filename is of the form +;;; ........ +;;; where always starts with the char : and is followed by +;;; alphanumeric characters. Each or can be up to 31 +;;; characters. File names are case insensistive. +;;; eg. :FOO.DIR_1.DIR_2.BAR +;;; +;;; The character set consists of (single case) alphabet, the numerals, +;;; and the characters "@$_#". (Not the quotes ...) The characters +;;; "[\]{|}" will also occur in a misguided attempt at +;;; internationalization. A filename may not start with a numeral. + + +;;; entry points + +(efs-defun efs-fix-path nos-ve (path &optional reverse) + ;; Convert path from UNIX to NOS/VE. + ;; If REVERSE is non-nil, goes in the opposite direction. + (if reverse + (let* ((res (concat "." path)) + (len (length res)) + (n 0)) + (while (< n len) + (and (= (aref res n) ?.) (aset res n ?/)) + (setq n (1+ n))) + res) + (let* ((res (substring (efs-internal-directory-file-name path) 1)) + (len (length res)) + (n 0)) + (while (< n len) + (and (= (aref res n) ?/) (aset res n ?.)) + (setq n (1+ n))) + res))) + +(efs-defun efs-fix-dir-path nos-ve (dir-path) + ;; Converts DIR-PATH to NOS/VE format for a directory listing. + (efs-fix-path 'nos-ve dir-path)) + +;;; parser + +(defconst efs-nos-ve-file-line-regexp + (concat + " \\([>0-9,]+\\) bytes \\(in [0-9]+ \\(file\\|catalog\\)s?\\)?\\|" + "\\( -- empty catalog\\)\\| -- device")) + +(efs-defun efs-parse-listing nos-ve (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a NOS/VE listing. + ;; Returns a hashtable. + (goto-char (point-min)) + (efs-save-match-data + (if (and (re-search-forward efs-nos-ve-file-line-regexp + (save-excursion (end-of-line) (point)) t) + (or (match-beginning 2) (match-beginning 4))) + (let ((tbl (efs-make-hashtable)) + size dir-p file) + (forward-line 1) + (while (re-search-forward efs-nos-ve-file-line-regexp + (save-excursion (end-of-line) (point)) t) + (setq size (and (match-beginning 1) + (buffer-substring + (match-beginning 1) (match-end 1))) + dir-p (null (null (or (match-beginning 2) + (match-beginning 4))))) + (if size + (let ((start 0) + res) + (while (string-match "," size start) + (setq res (concat res (substring size start + (match-beginning 0))) + start (match-end 0))) + (setq size (string-to-int + (concat res (substring size start)))))) + (beginning-of-line) + (forward-char 2) + (setq file (buffer-substring + (point) + (progn (skip-chars-forward "^ \t\n") (point)))) + (efs-put-hash-entry file (list dir-p size) + (or tbl (setq tbl (efs-make-hashtable)))) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl)))) + +(efs-defun efs-allow-child-lookup nos-ve (host user dir file) + ;; Returns non-nil if in directory DIR, FILE could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. Note that DIR is in directory syntax. + ;; i.e. /foo/bar/, not /foo/bar. + ;; Deal with dired. Anything else? + (not (and (boundp 'dired-local-variables-file) + (stringp dired-local-variables-file) + (string-equal (downcase dired-local-variables-file) + (downcase file))))) + +;;; Tree Dired + +(defconst efs-dired-nos-ve-re-exe "^.[^ \t\n]") +;; Matches no lines. Should it match something? + +(or (assq 'nos-ve efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'nos-ve efs-dired-nos-ve-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-nos-ve-re-dir " [0-9,]+ bytes in [0-9]+ file") + +(or (assq 'nos-ve efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'nos-ve efs-dired-nos-ve-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-fixup-listing nos-ve (file path &optional switches + wildcard) + ;; Need to turn the header line into something to masquerading as a file + ;; line, and need to remove the indentation. Both upset dired. + (goto-char (point-min)) + (while (search-forward "\n " nil t) + (delete-char -2)) + (goto-char (point-min)) + (if (looking-at "\\([^ \n]+ +\\)[0-9,]+ bytes in [0-9]+ file") + (progn + (delete-region (match-beginning 1) (match-end 1)) + (insert " Total of ")))) + +(defconst efs-dired-nos-ve-file-line-regexp + (concat + ".[ \t]+\\([][{}|\\\\a-z0-9@$_#]+\\) +" + "\\([>0-9,]+ bytes\\|-- \\(empty\\|device\\)\\)")) + +(efs-defun efs-dired-manual-move-to-filename nos-ve + (&optional raise-error bol eol) + ;; In dired, move to first char of filename on this line. + ;; Returns position (point) or nil if no filename on this line. + ;; This is the NOS/VE version. + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + (if (looking-at efs-dired-nos-ve-file-line-regexp) + (goto-char (match-beginning 1)) + (and raise-error (error "No file on this line")))) + +(efs-defun efs-dired-manual-move-to-end-of-filename nos-ve + (&optional no-error bol eol) + ;; Assumes point is at beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; case-fold-search must be nil, at least for VMS. + ;; On failure, signals an error or returns nil. + ;; This is the NOS/VE version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "_a-z0-9$@#\\\\[]{}|") ; right char set? + (if (or (= opoint (point)) (/= (following-char) ?\ )) + (if no-error + nil + (error "No file on this line")) + (point)))) + +;;; end of efs-nos-ve.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-ovwrt.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-ovwrt.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,106 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-ovwrt.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Utilities for overwriting functions with new definitions. +;; Author: Andy Norman +;; Modified: Sun Nov 27 18:40:20 1994 by sandy on gandalf +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Although used by efs, these utilities could be of general use to other +;;; packages too. Keeping them separate from the main efs program +;;; makes it easier for other programs to require them. + +(provide 'efs-ovwrt) + +(defconst efs-ovwrt-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +(defvar efs-overwrite-fmt + "Note: This function has been modified to work with %s.") + +;; Make the byte compiler happy. +(defvar file-name-handler-alist) +(defvar inhibit-file-name-handlers) +(defvar inhibit-file-name-operation) + +(defun efs-safe-documentation (fun) + "A documentation function that isn't quite as fragile." + (condition-case () + (documentation fun) + (error nil))) + +(defun efs-overwrite-fn (package fun &optional newfun) + "Overwrites a function with a new definition from PACKAGE. +PACKAGE should be a string. The the function to be overwritten is FUN. +The new definition is obtained from the optional NEWFUN. If ommitted, +NEWFUN is taken to be PACKAGE-FUN. The original definition is stored in +PACKAGE-real-FUN. The original documentation is placed on the new +definition suitably augmented." + (let* ((name (symbol-name fun)) + (saved (intern (concat package "-real-" name))) + (new (or newfun (intern (concat package "-" name)))) + (nfun (symbol-function new)) + (exec-directory (if (or (equal (nth 3 command-line-args) "dump") + (equal (nth 4 command-line-args) "dump")) + "../etc/" + exec-directory))) + + (while (symbolp nfun) + (setq nfun (symbol-function nfun))) + + ;; Interpose the new function between the function symbol and the + ;; original definition of the function symbol AT TIME OF FIRST LOAD. + ;; We must only redefine the symbol-function of FUN the very first + ;; time, to avoid blowing away stuff that overloads FUN after this. + + ;; We direct the function symbol to the new function symbol + ;; rather than function definition to allow reloading of this file or + ;; redefining of the individual function (e.g., during debugging) + ;; later after some other code has been loaded on top of our stuff. + + (or (fboundp saved) + (progn + (fset saved (symbol-function fun)) + (fset fun new))) + + ;; Rewrite the doc string on the new function. This should + ;; be done every time the file is loaded (or a function is redefined), + ;; because the underlying overloaded function may have changed its doc + ;; string. + + (let* ((doc-str (efs-safe-documentation saved)) + (ndoc-str (concat doc-str (and doc-str "\n") + (format efs-overwrite-fmt package)))) + + (cond ((listp nfun) + ;; Probe to test whether function is in preloaded read-only + ;; memory, and if so make writable copy: + (condition-case nil + (setcar nfun (car nfun)) + (error + (setq nfun (copy-sequence nfun)) ; shallow copy only + (fset new nfun))) + (let ((ndoc-cdr (nthcdr 2 nfun))) + (if (stringp (car ndoc-cdr)) + ;; Replace the existing docstring. + (setcar ndoc-cdr ndoc-str) + ;; There is no docstring. Insert the overwrite msg. + (setcdr ndoc-cdr (cons (car ndoc-cdr) (cdr ndoc-cdr))) + (setcar ndoc-cdr (format efs-overwrite-fmt package))))) + (t + ;; it's an emacs19 compiled-code object + (let ((new-code (append nfun nil))) ; turn it into a list + (if (nthcdr 4 new-code) + (setcar (nthcdr 4 new-code) ndoc-str) + (setcdr (nthcdr 3 new-code) (cons ndoc-str nil))) + (fset new (apply 'make-byte-code new-code)))))))) + + +;;; end of efs-ovwrt.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-pc.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-pc.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,980 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-pc.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: PC support for efs +;; Author: Sandy Rutherford +;; Created: Thu Mar 18 13:06:25 1993 +;; Modified: Sun Nov 27 18:40:46 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;; Thanks to jrs@world.std.com (Rick Sladkey) for providing support for +;;; the Frontier Technologies Super-TCP server + +;;; Many thanks to the following people for beta testing: +;;; Mike Northam +;;; bagman@austin.ibm.com (Doug Bagley) +;;; Jens Petersen +;;; Jeff Morgenthaler + +(provide 'efs-pc) +(require 'efs) + +(defconst efs-pc-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;----------------------------------------------------------------- +;;; PC support for efs +;;;----------------------------------------------------------------- + +;;; Works for the DOS FTP servers: +;;; Novell LAN WorkPlace v4.01 (NetWare & EXOS) +;;; PC/TCP Version 2.05 pl2 FTP Server by FTP Software +;;; Microsoft FTP Server service (beta 2) +;;; NCSA DOS ftp server. +;;; Frontier Technologies super tcp server (runs under MS WINDOWS) +;;; Alun's Windows FTP daemon for Winsock, v1.8b +;;; +;;; Works for IBM OS/2 TCP/IP FTP Version 1.2 + +;;; Currently support for all of the above FTP servers are in this file. +;;; Should they live in separate files? + +;;; host and listing type hierarchy in this file +;;; +;;; dos: dos:novell, dos:ftp, dos:ncsa, dos:microsoft, dos:stcp, dos:winsock +;;; os2: + +;;; DOS and OS/2 have slightly different filename syntaxes. +;;; +;;; DOS only allows at most one extension (".") per filename. +;;; A directory name usually has the extension ".DIR" implicit, but +;;; it seems that other extensions can be used. +;;; +;;; OS/2 running the FAT file system uses the same 8.3 format for +;;; filenames as DOS, except that extensions are allowed in directory names. +;;; OS/2 running the HPFS (high performance file system allows an arbitrary +;;; number of extensions in a filename. +;;; Mostly these differences are unimportant here, except in the dos +;;; definition of efs-allow-child-lookup. + +;;;; ---------------------------------------------------- +;;;; Utility functions and macros +;;;; ---------------------------------------------------- + +(defun efs-fix-pc-path (path &optional reverse) + ;; Convert PATH from UNIX-ish to DOS or OS/2. + ;; If REVERSE do just that. + (efs-save-match-data + (if reverse + (let ((n 0) + len res) + (if (string-match "^[a-zA-Z0-9]:" path) + ;; there's a disk + (setq res (concat "\\" path)) + (setq res (copy-sequence path))) + (setq len (length res)) + (while (< n len) + (and (= (aref res n) ?\\ ) (aset res n ?/)) + (setq n (1+ n))) + res) + (let ((n 0) + len res) + (if (string-match "^/[a-zA-Z0-9]:" path) + (setq res (substring path 1)) + (setq res (copy-sequence path))) + (setq len (length res)) + (while (< n len) + (and (= (aref res n) ?/) (aset res n ?\\ )) + (setq n (1+ n))) + res)))) + +(defmacro efs-dired-pc-move-to-end-of-filename (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + ;; This is the DOS and OS/2 version. It is common to all of the PC ftp + ;; servers since it depends only on the file name character set. + (` + (let ((opoint (point))) + (and selective-display + (null (, no-error)) + (eq (char-after + (1- (or (, bol) (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "-_+=a-zA-Z0-9.$~") + (if (= opoint (point)) + (if (, no-error) + nil + (error "No file on this line")) + (point))))) + +(defun efs-dired-pc-insert-headerline (dir) + ;; Insert a blank line for aesthetics. + (insert " \n") + (forward-char -2) + (efs-real-dired-insert-headerline dir)) + + +;;;;----------------------------------------------------------- +;;;; General DOS support +;;;;----------------------------------------------------------- + +;;; Regexps to be used for host and listing-type identification. + +(defconst efs-dos:ftp-file-line-regexp + (concat + " *\\([0-9]+\\|\\) +\\([-_+=a-zA-Z0-9$~.]+\\)" + " +\\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\) " + "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|" + "Oct\\|Nov\\|Dec\\) [0-3][0-9] ")) + +(defconst efs-dos:microsoft-file-line-regexp + ;; matches all the way to the first char of the filename. + (concat + "[01][0-9]-[0-3][0-9]-[0-9][0-9] +[012][0-9]:[0-5][0-9][AP]M +" + "\\(\\|[0-9]+\\) +")) + +(defconst efs-dos:ncsa-file-line-regexp + "\\([-_+=a-zA-Z0-9$.~]+\\) +\\(\\|[0-9]+\\)[ \n]") + +(defconst efs-dos:stcp-file-line-regexp + (concat + "\\([-_+=a-zA-Z0-9$~.]+\\) +\\(\\|[0-9]+\\) " + "+[0-9][0-9]?-[0-3][0-9]-[12][90][0-9][0-9] +" + "[0-9][0-9]?:[0-5][0-9]")) + +(defconst efs-dos:winsock-date-and-size-regexp + (concat + " \\([0-9]+\\) " + "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct\\|Nov\\|" + "Dec\\) [ 0-3][0-9] \\( [12][0-9][0-9][0-9]\\|[0-2][0-9]:[0-6][0-9]\\) +")) + +(efs-defun efs-parse-listing dos + (host user dir path &optional switches) + ;; Examine the listing, which is assumed to be either a DOS or OS/2 + ;; listing, and determine the operating system type and FTP server. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a full remote path + ;; PATH = directory in full efs-path syntax + ;; No need to check for OS/2, as it gets ID'ed by a SYST in + ;; efs-guess-host-type. + (efs-save-match-data + (cond + + ;; Check for the Microsoft server + ((re-search-forward efs-dos:microsoft-file-line-regexp nil t) + (efs-add-listing-type 'dos:microsoft host user) + (efs-parse-listing 'dos:microsoft host user dir path switches)) + + ;; Check for the Novell FTP server + ((save-excursion + (goto-char (point-max)) + (forward-line -1) + (looking-at " [0-9]+ File(s)\n")) + (efs-add-listing-type 'dos:novell host user) + (efs-parse-listing 'dos:novell host user dir path switches)) + + ;; Check for FTP software's server + ((re-search-forward efs-dos:ftp-file-line-regexp nil t) + (efs-add-listing-type 'dos:ftp host user) + (efs-parse-listing 'dos:ftp host user dir path switches)) + + ;; Check for winsock + ((re-search-forward efs-dos:winsock-date-and-size-regexp nil t) + (efs-add-listing-type 'dos:winsock host user) + (efs-parse-listing 'dos:winsock host user dir path switches)) + + ;; Check for the NCSA FTP server + ((re-search-forward efs-dos:ncsa-file-line-regexp nil t) + (efs-add-listing-type 'dos:ncsa host user) + (efs-parse-listing 'dos:ncsa host user dir path switches)) + + ;; Check for Frontier's Super-TCP server + ((re-search-forward efs-dos:stcp-file-line-regexp nil t) + (efs-add-listing-type 'dos:stcp host user) + (efs-parse-listing 'dos:stcp host user dir path switches)) + + ((string-match "^/\\([A-Za-z0-9]:/\\)?$" dir) + ;; root always exists + (let ((tbl (efs-make-hashtable))) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl)) + (t + ;; an error message? + nil)))) + +;; Some DOS servers (NCSA), return a 501 message for an empty disk. +(efs-defun efs-ls-dumb-check dos (line host file path lsargs msg noparse + noerror nowait cont) + (and (string-match "^501 " line) + (string-match "^/[A-Za-z0-9]:/?$" path) + (let ((parse (or (null noparse) (eq noparse 'parse) + (efs-parsable-switches-p lsargs t)))) + (efs-add-to-ls-cache file lsargs "\n" parse) + (if parse + (efs-set-files file (let ((tbl (efs-make-hashtable))) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl))) + (if nowait + (progn + (if cont + (efs-call-cont cont "\n")) + t) + (if cont + (efs-call-cont cont "\n")) + "\n")))) + +(efs-defun efs-fix-path dos (path &optional reverse) + (efs-fix-pc-path path reverse)) + +(efs-defun efs-fix-dir-path dos (dir-path) + ;; Convert path from UNIX-ish to DOS for a DIRectory listing. + (cond ((string-match "^/\\(.:\\)?$" dir-path) + (error "Can't list DOS or OS/2 disks")) + ;; Neither DOS nor OS/2 allows us to end the name of a directory + ;; with an "\". + ;; Adding *.* to the end also allows us to distinguish plain files from + ;; directries. All DOS servers seem to understand this except + ;; Frontier Technologies' super-tcp server. + ((string-match "/$" dir-path) + (concat (efs-fix-pc-path dir-path) "*.*")) + (t (efs-fix-pc-path dir-path)))) + +(efs-defun efs-get-pwd dos (host user &optional xpwd) + ;; Parses PWD output for the current working directory. Hopefully this is + ;; DOS proof. + (let* ((result (efs-send-cmd host user (list 'quote + (if xpwd 'xpwd 'pwd)) + "Getting PWD")) + (line (nth 1 result)) + dir) + (if (car result) + (efs-save-match-data + (and (or (string-match "\"\\([^\"]*\\)\"" line) + ;; FTP software's output. They should know better... + (string-match "Current working directory is +\\([^ ]+\\)$" + line)) + (setq dir (substring line + (match-beginning 1) + (match-end 1)))))) + (cons dir line))) + +(efs-defun efs-allow-child-lookup dos (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + + ;; Subdirs in DOS usually don't have an extension. + (not (string-match "\\." file))) + +;;;;----------------------------------- +;;;; Support for the Novell FTP server +;;;;----------------------------------- + +(defconst efs-dos:novell-file-line-regexp + ;; Matches from the first character of the filename to the end of the date. + ;; Does not match parent directories which the server might decide + ;; to put in front of the filename. + (concat + "\\([-_+=a-zA-Z0-9$.~]+\\) +\\(\\|[0-9]+\\) +" + "[ 0-9][0-9]-[0-9][0-9]-[0-9][0-9] ")) + +(efs-defun efs-parse-listing dos:novell + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a Novell DOS FTP listing. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a full remote path + ;; PATH = directory in full efs-path syntax + (let ((tbl (efs-make-hashtable)) + file size dir-p) + (efs-save-match-data + ;; Can we check somehow if the listing is really for something + ;; that doesn't exist? + (goto-char (point-min)) + (while (re-search-forward efs-dos:novell-file-line-regexp + nil t) + (setq file (buffer-substring (match-beginning 1) + (match-end 1)) + size (buffer-substring (match-beginning 2) + (match-end 2))) + (if (string-equal size "") + (setq size nil + dir-p t) + (setq size (string-to-int size) + dir-p nil)) + (efs-put-hash-entry file (list dir-p size) tbl) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl))) + +;;; Tree Dired Support + +(defconst efs-dired-dos:novell-re-exe + "^. [ \t]+[-_+=a-zA-Z0-9$~]+\\.exe ") + +(or (assq 'dos:novell efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'dos:novell efs-dired-dos:novell-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-dos:novell-re-dir + "^. [ \t]+[-_+=a-zA-Z0-9$~]+ +") + +(or (assq 'dos:novell efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'dos:novell efs-dired-dos:novell-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-insert-headerline dos:novell (dir) + (efs-dired-pc-insert-headerline dir)) + +(efs-defun efs-dired-manual-move-to-filename dos:novell + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line. + ;; Returns (point) or nil if raise-error is nil, and there is no + ;; no filename on this line. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + ;; move over marker + (if (re-search-forward efs-dos:novell-file-line-regexp eol t) + (goto-char (match-beginning 0)) ; returns (point) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename dos:novell + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + (efs-dired-pc-move-to-end-of-filename no-error bol eol)) + +(efs-defun efs-dired-fixup-listing dos:novell + (file path &optional switches wildcard) + ;; DOS may insert the entire directory name in front of the file name. + ;; Scrape it off. The Novell server seems to do weird things when insert + ;; the full-path, so be liberal with the hatchet. + (goto-char (point-min)) + (while (re-search-forward efs-dos:novell-file-line-regexp nil t) + (beginning-of-line) + (delete-region (point) (match-beginning 0)) + (forward-line 1)) + ;; the novell server outputs lines in seemingly random order + ;; this isn't as good as sorting switches, but at least it's not random. + (sort-fields 1 (point-min) (progn (goto-char (point-max)) + (forward-line -1) + (point)))) + +(efs-defun efs-dired-ls-trim dos:novell () + (goto-char (point-min)) + (let (case-fold-search) + (forward-line 1) + (if (looking-at " [0-9]+ File(s)\n") + (delete-region (match-beginning 0) (match-end 0))))) + + +;;;;----------------------------------------------- +;;;; PC/TCP (by FTP software) support +;;;;----------------------------------------------- + +(efs-defun efs-parse-listing dos:ftp + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be an FTP Software DOS + ;; listing. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a full remote path + ;; PATH = directory in full efs-path syntax + (let ((tbl (efs-make-hashtable)) + file size dir-p) + (efs-save-match-data + ;; Can we check somehow if an empty directory is really + ;; a nonexistent directory? + (goto-char (point-min)) + (goto-char (point-min)) + (while (looking-at efs-dos:ftp-file-line-regexp) + (setq file (buffer-substring (match-beginning 2) + (match-end 2)) + size (buffer-substring (match-beginning 1) + (match-end 1))) + (if (string-equal size "") + (setq size nil + dir-p t) + (setq size (string-to-int size) + dir-p nil)) + (efs-put-hash-entry file (list dir-p size) tbl) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl))) + +;;; Tree Dired Support + +(defconst efs-dired-dos:ftp-re-exe + "^. [ \t]*[0-9]+ +[-_+=a-zA-Z0-9$~]+\\.exe ") + +(or (assq 'dos:ftp efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'dos:ftp efs-dired-dos:ftp-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-dos:ftp-re-dir + "^. [ \t]* ") + +(or (assq 'dos:ftp efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'dos:ftp efs-dired-dos:ftp-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-insert-headerline dos:ftp (dir) + (efs-dired-pc-insert-headerline dir)) + +;;; Because dos:ftp listings have the file names right justified, +;;; I have reversed what -move-to-filename and -move-to-end-of-filename +;;; actually do. This shouldn't confuse dired, and should make browsing +;;; a dos:ftp listing more aesthetically pleasing. + +(efs-defun efs-dired-manual-move-to-filename dos:ftp + (&optional raise-error bol eol) + ;; In dired, move to the *last* char of filename on this line. + ;; Returns (point) or nil if raise-error is nil, and there is no + ;; no filename on this line. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + (if (re-search-forward efs-dos:ftp-file-line-regexp eol t) + (goto-char (match-end 2)) ; returns (point) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename dos:ftp + (&optional no-error bol eol) + ;; Assumes point is at the *end* of filename. Really moves the + ;; point to the beginning of the filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + ;; This is the DOS version. It is common to all of the DOS ftp servers + ;; since it depends only on the file name character set. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-backward "-_+=a-zA-Z0-9.$~" bol) + (if (= opoint (point)) + (if no-error + nil + (error "No file on this line")) + (point)))) + +;;;;----------------------------------------------- +;;;; NCSA FTP support +;;;;----------------------------------------------- + +(efs-defun efs-parse-listing dos:ncsa + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a Novell DOS FTP listing. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a full remote path + ;; PATH = directory in full efs-path syntax + (let (tbl file size dir-p next) + (efs-save-match-data + (goto-char (point-min)) + (while (re-search-forward + efs-dos:ncsa-file-line-regexp + (setq next (save-excursion (forward-line 1) (point))) t) + (setq file (buffer-substring (match-beginning 1) + (match-end 1)) + size (buffer-substring (match-beginning 2) + (match-end 2))) + (if (string-equal size "") + (setq size nil + dir-p t) + (setq size (string-to-int size) + dir-p nil)) + (efs-put-hash-entry file (list dir-p size) + (or tbl (setq tbl (efs-make-hashtable)))) + (goto-char next)) + ;; DOS does not put . and .. in the root directory. + (if (or tbl + ;; root always exists + (string-match "^/\\([A-Za-z0-9]:/\\)?$" dir)) + (progn + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl))) + tbl))) + +;;; Tree Dired Support + +(defconst efs-dired-dos:ncsa-re-exe + "^. [ \t]+[-_+=a-zA-Z0-9$~]+\\.exe ") + +(or (assq 'dos:ncsa efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'dos:ncsa efs-dired-dos:ncsa-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-dos:ncsa-re-dir + "^. [ \t]+[-_+=a-zA-Z0-9$~]+ +") + +(or (assq 'dos:ncsa efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'dos:ncsa efs-dired-dos:ncsa-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-insert-headerline dos:ncsa (dir) + (efs-dired-pc-insert-headerline dir)) + +(efs-defun efs-dired-manual-move-to-filename dos:ncsa + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line. + ;; Returns (point) or nil if raise-error is nil, and there is no + ;; no filename on this line. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + (if (re-search-forward "[-_+=a-zA-Z0-9$.~]+ +\\(\\|[0-9]\\)" eol t) + (goto-char (match-beginning 0)) ; returns (point) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename dos:ncsa + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + (efs-dired-pc-move-to-end-of-filename no-error bol eol)) + +(efs-defun efs-dired-fixup-listing dos:ncsa + (file path &optional switches wildcard) + ;; DOS may insert the entire directory name in front of the file name. + ;; Scrape it off. + (let (bonl) + (goto-char (point-min)) + (while (re-search-forward + efs-dos:ncsa-file-line-regexp + (setq bonl (save-excursion (forward-line 1) (point))) t) + (goto-char (match-beginning 0)) + (delete-region (point) (progn (beginning-of-line) (point))) + (goto-char bonl))) + ;; sort the buffer + (sort-fields 1 (point-min) (point-max))) + +(efs-defun efs-dired-ls-trim dos:ncsa () + (goto-char (point-min)) + (if (re-search-forward efs-dos:ncsa-file-line-regexp nil t) + (delete-region (point-min) (match-beginning 0)))) + +;;;;----------------------------------------------- +;;;; Microsoft DOS FTP support +;;;;----------------------------------------------- + +(defconst efs-dos:microsoft-valid-listing-regexp + (concat efs-dos:microsoft-file-line-regexp "\\.")) + +(efs-defun efs-parse-listing dos:microsoft + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a Novell DOS FTP listing. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a full remote path + ;; PATH = directory in full efs-path syntax + + ;; Use the existence of a "." file as confirmation that it's really + ;; a directory listing. + (goto-char (point-min)) + (efs-save-match-data + (if (or (string-match "^/.:/$" dir) + (re-search-forward efs-dos:microsoft-valid-listing-regexp nil t)) + (let ((tbl (efs-make-hashtable)) + size dir-p) + (goto-char (point-min)) + (while (re-search-forward efs-dos:microsoft-file-line-regexp nil t) + (setq size (buffer-substring (match-beginning 1) (match-end 1))) + (if (string-equal size "") + (setq size nil + dir-p t) + (setq size (string-to-int size) + dir-p nil)) + (efs-put-hash-entry (buffer-substring (point) + (progn (end-of-line) + (point))) + (list dir-p size) tbl) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl)))) + +;;; Tree Dired Support + +(defconst efs-dired-dos:microsoft-re-exe + "^[^\n]+ +[-_+=a-zA-Z0-9$~]+\\.\\(EXE\\|exe\\)$") + +(or (assq 'dos:microsoft efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'dos:microsoft efs-dired-dos:microsoft-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-dos:microsoft-re-dir + "^[^\n]+ ") + +(or (assq 'dos:microsoft efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'dos:microsoft efs-dired-dos:microsoft-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-insert-headerline dos:microsoft (dir) + (efs-dired-pc-insert-headerline dir)) + +(efs-defun efs-dired-manual-move-to-filename dos:microsoft + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line. + ;; Returns (point) or nil if raise-error is nil, and there is no + ;; no filename on this line. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + (if (re-search-forward efs-dos:microsoft-file-line-regexp eol t) + (goto-char (match-end 0)) ; returns (point) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename dos:microsoft + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + (efs-dired-pc-move-to-end-of-filename no-error bol eol)) + +;;;;----------------------------------------------- +;;;; Frontier's Super-TCP FTP Server for Windows +;;;;----------------------------------------------- + +(efs-defun efs-parse-listing dos:stcp + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a Super-TCP FTP listing. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a full remote path + ;; PATH = directory in full efs-path syntax + + ;; Use the existence of a strict file line pattern as + ;; confirmation that it's really a directory listing. + (goto-char (point-min)) + (efs-save-match-data + (let ((regexp (concat "^" efs-dos:stcp-file-line-regexp))) + (if (let ((eol (save-excursion (end-of-line) (point)))) + (re-search-forward regexp eol t)) + (let ((tbl (efs-make-hashtable)) + size dir-p) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (setq size (buffer-substring (match-beginning 2) (match-end 2))) + (if (string-equal size "") + (setq size nil + dir-p t) + (setq size (string-to-int size) + dir-p nil)) + (efs-put-hash-entry (buffer-substring (match-beginning 1) + (match-end 1)) + (list dir-p size) tbl) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl))))) + +;;; Tree Dired Support + +(defconst efs-dired-dos:stcp-re-exe + "^[-_+=a-zA-Z0-9$~]+\\.\\(EXE\\|exe\\) ") + +(or (assq 'dos:stcp efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'dos:stcp efs-dired-dos:stcp-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-dos:stcp-re-dir + "^[^\n ]+ + ") + +(or (assq 'dos:stcp efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'dos:stcp efs-dired-dos:stcp-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-insert-headerline dos:stcp (dir) + (efs-dired-pc-insert-headerline dir)) + +(efs-defun efs-dired-manual-move-to-filename dos:stcp + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line. + ;; Returns (point) or nil if raise-error is nil, and there is no + ;; no filename on this line. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r") + (setq bol (point))) + (if (re-search-forward efs-dos:stcp-file-line-regexp eol t) + (goto-char (match-beginning 0)) ; returns (point) + (if raise-error + (error "No file on this line") + (goto-char bol))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename dos:stcp + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + (efs-dired-pc-move-to-end-of-filename no-error bol eol)) + +(efs-defun efs-dired-fixup-listing dos:stcp + (file path &optional switches wildcard) + ;; The Super-TCP server outputs lines in seemingly random order. + ;; This isn't as good as sorting switches, but at least it's not random. + (sort-fields 1 (point-min) (point-max))) + +;;;;---------------------------------------------------------- +;;;; Winsock DOS FTP server (Alun's FTP server) +;;;;---------------------------------------------------------- + +(efs-defun efs-parse-listing dos:winsock + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a DOS Winsock listing. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a full remote path + ;; PATH = directory in full efs-path syntax + + (goto-char (point-min)) + (efs-save-match-data + (if (re-search-forward efs-dos:winsock-date-and-size-regexp nil t) + (let ((tbl (efs-make-hashtable)) + size dirp) + (while + (progn + (setq size (string-to-int (buffer-substring (match-beginning 1) + (match-end 1))) + dirp (save-excursion + (beginning-of-line) + (skip-chars-forward " ") + (char-equal (following-char) ?d))) + (efs-put-hash-entry + (buffer-substring (point) (progn (end-of-line) (point))) + (list dirp size) tbl) + (re-search-forward efs-dos:winsock-date-and-size-regexp nil t))) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl)))) + +(defconst efs-dired-dos:winsock-re-exe "\\.exe$") + +(or (assq 'dos:winsock efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'dos:winsock efs-dired-dos:winsock-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-dos:winsock-re-dir "^. +d") + +(or (assq 'dos:winsock efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'dos:winsock efs-dired-dos:winsock-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-insert-headerline dos:winsock (dir) + (efs-dired-pc-insert-headerline dir)) + +(efs-defun efs-dired-manual-move-to-filename dos:winsock + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line. + ;; Returns (point) or nil if raise-error is nil, and there is no + ;; no filename on this line. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r") + (setq bol (point))) + (if (re-search-forward efs-dos:winsock-date-and-size-regexp eol t) + (point) + (if raise-error + (error "No file on this line") + (goto-char bol))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename dos:winsock + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + (efs-dired-pc-move-to-end-of-filename no-error bol eol)) + +(efs-defun efs-dired-fixup-listing dos:winsock + (file path &optional switches wildcard) + ;; The Winsock server outputs lines in seemingly random order. + ;; This isn't as good as sorting switches, but at least it's not random. + (sort-fields 9 (point-min) (point-max))) + +;;;;----------------------------------------------------------- +;;;; OS/2 Support +;;;;----------------------------------------------------------- + +;;; OS/2 has two types of file systems, FAT and HPFS. In the FAT file system +;;; filenames are restricted to the traditional DOS 8 + 3 syntax. In the +;;; HPFS file system, filenames can have arbitrarily many extensions (.'s). +;;; As well, file lines for "." and ".." are listed for HPFS. +;;; For the FAT FS, "." and ".." lines are only listed for sudirs, it seems. +;;; Go figure... + +(defconst efs-os2-file-line-regexp + (concat + " +\\([0-9]+\\) +\\([^ ]+\\)? +[01][0-9]-[0-3][0-9]-[0-9][0-9] +" + "[0-2][0-9]:[0-6][0-9] +")) + +(efs-defun efs-fix-path os2 (path &optional reverse) + (efs-fix-pc-path path reverse)) + +(efs-defun efs-fix-dir-path os2 (dir-path) + ;; Convert path from UNIX-ish to DOS for a DIRectory listing. + (cond ((string-match "^/\\(.:\\)?$" dir-path) + (error "Can't list DOS or OS/2 disks")) + ;; Neither DOS nor OS/2 allows us to end the name of a directory + ;; with an "\". + ;; Can't just hack it off, because if the dir is C:, we'll get the + ;; default dir. + ;; Don't apend the filename wildcard to distinguish + ;; plain files from directories, because OS/2 and DOS may + ;; not agree on what the wildcard is. Also, can't then tell + ;; the difference between plain files and empty directories. + ((string-match "/$" dir-path) + (concat (efs-fix-pc-path dir-path) ".")) + (t (efs-fix-pc-path dir-path)))) + +(defconst efs-os2-dot-line-regexp + (concat efs-os2-file-line-regexp "\\.\n")) + +(efs-defun efs-parse-listing os2 + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be an OS/2 listing. + ;; To make sure that it is really a directory listing and not a bogus + ;; listing of a single file, make sure that there is an entry for ".". + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a full remote path + ;; PATH = directory in full efs-path syntax + (efs-save-match-data + (if (or + (string-match "^/.:/$" dir) ; FAT proofing + (progn + (goto-char (point-min)) + (re-search-forward efs-os2-dot-line-regexp nil t))) + (let ((tbl (efs-make-hashtable))) + (goto-char (point-min)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + (while (looking-at efs-os2-file-line-regexp) + (end-of-line) + (efs-put-hash-entry + (buffer-substring (match-end 0) (point)) + (list (and + (match-beginning 2) + (string-equal "DIR" + (buffer-substring (match-beginning 2) + (match-end 2)))) + (string-to-int (buffer-substring (match-beginning 1) + (match-end 1)))) + tbl) + (forward-line 1)) + tbl)))) + +;;; Tree Dired + +(defconst efs-dired-os2-re-exe + "^[^\n]+\\.EXEC?$") + +(or (assq 'os2 efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'os2 efs-dired-os2-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-os2-re-dir + "^ +[0-9]+ +DIR ") + +(or (assq 'os2 efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'os2 efs-dired-os2-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-manual-move-to-filename os2 + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line. + ;; Returns (point) or nil if raise-error is nil, and there is no + ;; no filename on this line. + ;; This version is for OS/2 + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r") + (setq bol (point))) + (if (and + (> (- eol bol) 24) + (progn + (forward-char 2) + (looking-at efs-os2-file-line-regexp))) + (goto-char (match-end 0)) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename os2 + (&optional no-error bol eol) + (efs-dired-pc-move-to-end-of-filename no-error bol eol)) + +(efs-defun efs-dired-insert-headerline os2 (dir) + (efs-dired-pc-insert-headerline dir)) + +;; end of efs-pc.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-plan9.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-plan9.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,51 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-plan9.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: efs support for the Plan 9 FTP Server +;; Author: Sandy Rutherford +;; Created: Sat Jan 22 21:26:06 1994 by sandy on ibm550 +;; Modified: Sun Nov 27 18:41:05 1994 by sandy on gandalf +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;; Works for the plan 9 server plan9.att.com. Plan 9 is an +;;; AT&T operating system that is similar to unix. + +(provide 'efs-plan9) +(require 'efs) + +(defconst efs-plan9-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +(efs-defun efs-fix-dir-path plan9 (dir-path) + ;; Convert DIR-PATH from UN*X-ish to Plan 9. Does nothing actually. + ;; Avoids appending the "." that we do in unix. + dir-path) + +(efs-defun efs-allow-child-lookup plan9 (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + ;; Relies on the fact that directories can't have extensions in plan9, + ;; I think. + (and (not (and (string-equal dir "/") (string-equal file "."))) + (progn + ;; Makes sure that this is cached, before cd'ing + (efs-expand-tilde "~" 'plan9 host user) + (efs-raw-send-cd host user + (if (string-equal file ".") + (efs-internal-file-name-nondirectory + dir) + (concat dir file)) + t)))) + +;;; end of efs-plan9.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-report.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-report.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,215 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-report.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Function to report efs bugs in a usable way. +;; Author: Andy Norman, Dawn +;; Created: Tue May 18 08:34:45 1993 +;; Modified: Sun Nov 27 18:41:45 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide 'efs-report) +(require 'efs) +(autoload 'reporter-submit-bug-report "reporter") +(defvar reporter-version) ; For the byte-compiler + +;;; Variables + +(defconst efs-report-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +(defconst efs-report-salutations + ["Dear bug team:" + "Ciao bug team:" + "Salut bug team:" + "Gruss bug team:" + "To whom it may concern:" + "Fellow efs'ers:" + "Greetings earthlings:"]) + +(defvar efs-bug-address "efs-bugs@cuckoo.hpl.hp.com") + +(defconst efs-report-other-vars + ;; List of variables needed for efs-report, that aren't generated below. + '(efs-ftp-program-name + efs-ftp-program-args + efs-local-host-regexp + efs-ftp-local-host-regexp + efs-gateway-host + efs-gateway-type + reporter-version + features)) + +(defconst efs-report-avoid-vars + ;; List of variables we don't want to see. + '(efs-netrc-filename + efs-default-password + efs-default-account + efs-default-user)) + +;; Dynamically bound. Used to pass data to hooks. +(defvar efs-report-default-host nil) +(defvar efs-report-default-user nil) +(defvar efs-report-blurb nil) + +;;; Functions + +(defun efs-report-get-host-type-regexps () + "Return a list of host type regexp's which are non-nil." + (let ((list efs-host-type-alist) + ent result) + (while (setq ent (car list)) + (if (symbol-value (cdr ent)) + (setq result (cons (cdr ent) result))) + (setq list (cdr list))) + result)) + +(defun efs-report-get-versions () + ;; Return a list of efs versions variables. + (mapcar + 'intern + (sort + (let (completion-ignore-case) + (all-completions + "efs-" obarray + (function + (lambda (sym) + (and (boundp sym) + (let ((name (symbol-name sym))) + (and (>= (length name) 8) + (string-equal (substring name -8) "-version")))))))) + 'string-lessp))) + +(defun efs-report-get-user-vars () + ;; Return a list of efs user variables. + (mapcar + 'intern + (sort + (let (completion-ignore-case) + (all-completions "efs-" obarray 'user-variable-p)) + 'string-lessp))) + +(defun efs-report-pre-hook () + ;; efs-report-default-host, efs-report-default-user, and + ;; efs-report-blurb are dynamically bound. + (save-excursion + (let ((end (progn (mail-position-on-field "subject") (point)))) + (beginning-of-line) + (search-forward ":" end) + (delete-region (point) end) + (insert + " EFS " + (or (and (boundp 'efs-version) (string-match "/" efs-version) + (concat (substring efs-version 0 (match-beginning 0)) + " ")) + "") + "bug: "))) + (let ((host (read-string "Bug occurred for remote host: " + efs-report-default-host)) + (user (read-string "Logged in as: " + efs-report-default-user)) + buff-name) + (if (string-match "^ *$" host) (setq host nil)) + (if (string-match "^ *$" user) (setq user nil)) + (if host + (insert "\nefs believes that the host type of " host " is " + (symbol-name (efs-host-type host)) + ".\n")) + (if efs-report-blurb + (insert "\n" efs-report-blurb "\n")) + (if (and host + user + (get-buffer (setq buff-name (efs-ftp-process-buffer host user))) + (save-window-excursion + (y-or-n-p + (progn + (with-output-to-temp-buffer "*Help*" + (princ + (format + "The contents of %s +will likely very useful for identifying any bugs. + +You will be given a chance to edit out any sensitive information. +Passwords are never written into this buffer." buff-name))) + (format "Insert contents of %s? " + buff-name))))) + (let ((header-1 (concat "Contents of " buff-name ":")) + (header-2 "Please edit sensitive or irrelevant information.")) + (insert "\n" header-1 "\n" header-2 "\n") + (insert-char ?= (max (length header-1) (length header-2))) + (insert "\n\n") + (insert-buffer-substring buff-name) + (insert "\n"))))) + +(defun efs-report-post-hook () + ;; Post hook run by report-submit-bug-report. + (save-excursion + (mail-position-on-field "subject") + (let ((subj (read-string "Subject header: "))) + (if (string-equal subj "") + (subst-char-in-region + (point) + (progn + (insert + (if (or (fboundp 'yow) (load "yow" t t)) (yow) "")) + (point)) + ?\n ?\ ) + (insert subj))))) + +(defun efs-report-bug (&optional default-host default-user blurb no-confirm) + "Submit a bug report for efs." + (interactive) + (let (;; reporter-confirm-p and reporter-package-abbrev appeared once + ;; as fluid vars in reporter.el. They aren't used any longer, + ;; but we let-bind them anyway in case the user has an old version + ;; of reporter. + (reporter-confirm-p nil) + (reporter-prompt-for-summary-p nil) + (reporter-package-abbrev "efs")) + ;; Look out for old reporter versions. + (or (boundp 'reporter-version) + (setq reporter-version + "Your version of reporter is obsolete. Please upgrade.")) + (if (or no-confirm + (y-or-n-p "Do you want to submit a bug report on efs? ")) + (let ((efs-report-default-host default-host) + (efs-report-default-user default-user) + (efs-report-blurb blurb) + (vars (nconc (efs-report-get-versions) + (efs-report-get-user-vars) + efs-report-other-vars + (efs-report-get-host-type-regexps))) + (avoids efs-report-avoid-vars) + path) + (cond + ((or efs-report-default-host efs-report-default-user)) + (efs-process-host + (setq efs-report-default-host efs-process-host + efs-report-default-user efs-process-user)) + ((setq path (or buffer-file-name + (and (eq major-mode 'dired-mode) + dired-directory))) + (let ((parsed (efs-ftp-path path))) + (setq efs-report-default-host (car parsed) + efs-report-default-user (nth 1 parsed))))) + (while avoids + (setq vars (delq (car avoids) vars)) + (setq avoids (cdr avoids))) + (reporter-submit-bug-report + efs-bug-address + "efs" + vars + (function efs-report-pre-hook) + (function efs-report-post-hook) + (aref efs-report-salutations + (% (+ (% (random) 1000) 1000) + (length efs-report-salutations)))))))) + +;;; end of efs-report.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-ti-explorer.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-ti-explorer.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,371 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-ti-explorer.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Explorer support for efs +;; Author: Jamie Zawinski +;; Created: Thu Dec 17 15:04:14 1992 +;; Modified: Sun Nov 27 18:42:47 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(provide 'efs-ti-explorer) +(require 'efs) + +(defconst efs-ti-explorer-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;; ------------------------------------------------------------ +;;;; Explorer support. +;;;; ------------------------------------------------------------ + +;;; efs support for TI Explorer Lisp Machines. +;;; Symbolics Lispms use a different syntax, but I think that the +;;; MIT and LMI Lispms use the same syntax as Explorers. + +(defconst efs-ti-explorer-filename-regexp + (let* ((excluded-chars ":;<>.#\n\r\ta-z") + (token (concat "[^" excluded-chars "]+")) + (token* (concat "[^" excluded-chars "]*"))) + (concat "\\(" token ": *" "\\)?" ; optional device + "\\([^ " excluded-chars "]" token* "\\)" + "\\(\\." token "\\)*; *" ; directory + "\\(" token* "." token* "\\|\\) *" ; name and extension + "# *-?\\([0-9]+\\|>\\)"))) ; version + +(efs-defun efs-quote-string ti-explorer (string &optional not-space) + ;; ## This is an EVIL hack. Backslash is not what Explorers use to + ;; quote magic characters, and in addition, it is *incorrect* to quote + ;; spaces between the directory and filename: they are not a part of + ;; the filename, they are ignored. Quoting them would make them be + ;; significant. + (if not-space + string + (concat "\"" string "\""))) + +(efs-defun efs-send-pwd ti-explorer (host user &optional xpwd) +;; TI-EXPLORER output from pwd's needs to be specially parsed because +;; the fullpath syntax contains spaces. + (let* ((result (efs-send-cmd host user '(pwd) "Getting EXPLORER PWD")) + (line (nth 1 result)) + dir) + (if (car result) + (efs-save-match-data + (and (string-match "^257 " line) + (setq dir (substring line 4))))) + (cons dir line))) + +(efs-defun efs-fix-path ti-explorer (path &optional reverse) + ;; Convert PATH from UNIX-ish to Explorer. If REVERSE given then convert + ;; from Explorer to UNIX-ish. + (efs-save-match-data + (if reverse + (if (string-match + "^\\([^:]+:\\)? *\\([^:]+:\\)? *\\([^;]*\\); *\\(.*\\)$" + path) + (let (dir file) + ;; I don't understand how "devices" work, so I'm ignoring them. + ;; (if (match-beginning 2) + ;; (setq device (substring path + ;; (match-beginning 2) + ;; (1- (match-end 2))))) + (if (match-beginning 3) + (setq dir + (substring path (match-beginning 3) (match-end 3)))) + (if (match-beginning 4) + (setq file + (substring path (match-beginning 4) (match-end 4)))) + (cond (dir + (setq dir (apply (function concat) + (mapcar (function + (lambda (char) + (if (= char ?.) + (vector ?/) + (vector char)))) + dir))) + (if (string-match "^/" dir) + (setq dir (substring dir 1)) + (setq dir (concat "/" dir))))) + (concat + ;; (and device ":") device (and device ":") + dir (and dir "/") + file)) + (error "path %s didn't match explorer syntax" path)) + (let (dir file tmp) + ;; (if (string-match "^/[^:]+:" path) + ;; (setq device (substring path 1 + ;; (1- (match-end 0))) + ;; path (substring path (match-end 0)))) + (cond ((setq tmp (file-name-directory path)) + (setq dir (apply (function concat) + (mapcar (function + (lambda (char) + (if (= char ?/) + (vector ?.) + (vector char)))) + (substring tmp 0 -1)))) + (if (string-match "^[.]" dir) + (setq dir (substring dir 1)) + (error "explorer pathnames can't be relative") + (setq dir (concat "." dir))))) + (setq file (file-name-nondirectory path)) + (concat + ;; (and device ":") device (and device ":") + dir + (and dir ";") + file))))) + +;; (efs-fix-path-for-explorer "/PUBLIC/ZMACS/ZYMURG.LISP#1") +;; (efs-fix-path-for-explorer "PUBLIC.ZMACS;ZYMURG.LISP#1" t) + +(efs-defun efs-fix-dir-path ti-explorer (dir-path) + ;; Convert path from UNIX-ish to Explorer ready for a DIRectory listing. + (cond ((string-equal dir-path "/") + (efs-fix-path 'ti-explorer "/~/" nil)) + ((string-match "^/[-A-Z0-9_$]+:/" dir-path) + (error "Don't grok Explorer \"devices\" yet.")) + ((efs-fix-path 'ti-explorer dir-path nil)))) + +(defmacro efs-parse-ti-explorer-filename () + ;; Extract the next filename from an Explorer dired-like listing. + (` (if (re-search-forward + efs-ti-explorer-filename-regexp + nil t) + (buffer-substring (match-beginning 0) (match-end 0))))) + +(efs-defun efs-parse-listing ti-explorer + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be an Explorer directory + ;; listing, and return a hashtable as the result. + ;; HOST = remote host name + ;; USER = user name + ;; DIR = directory in as a full remote path + ;; PATH = directory in full efs path syntax + ;; SWITCHES = ls switches (not relevant here) + (let ((tbl (efs-make-hashtable)) + file) + (goto-char (point-min)) + (efs-save-match-data + (while (setq file (efs-parse-ti-explorer-filename)) + ;; Explorer/Twenex listings might come out in absolute form. + (if (string-match "^[^;]*; *" file) + (setq file (substring file (match-end 0)))) + (if (string-match "\\.\\(DIRECTORY\\|directory\\)#[0-9]+$" file) + ;; deal with directories + (efs-put-hash-entry + (substring file 0 (match-beginning 0)) '(t) tbl) + (efs-put-hash-entry file '(nil) tbl) + (if (string-match "#[0-9]+$" file) ; deal with extension + ;; sans extension + (efs-put-hash-entry + (substring file 0 (match-beginning 0)) '(nil) tbl))) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl)) + tbl)) + +(efs-defun efs-really-file-p ti-explorer (file ent) + ;; Eliminates the version entries + (or (car ent) ; file-directory-p + (efs-save-match-data + (string-match "#[0-9]+$" file)))) + +(efs-defun efs-delete-file-entry ti-explorer (path &optional dir-p) + (let ((ignore-case (memq 'ti-explorer efs-case-insensitive-host-types))) + (if dir-p + (let ((path (file-name-as-directory path)) + files) + (efs-del-hash-entry path efs-files-hashtable ignore-case) + (setq path (directory-file-name path) + files (efs-get-hash-entry (file-name-directory path) + efs-files-hashtable + ignore-case)) + (if files + (efs-del-hash-entry (efs-get-file-part path) + files ignore-case))) + (efs-save-match-data + (let ((file (efs-get-file-part path))) + (if (string-match "#[0-9]+$" file) + ;; Only delete entries with explicit version numbers. + (let ((files (efs-get-hash-entry + (file-name-directory path) + efs-files-hashtable ignore-case))) + (if files + (let ((root (substring file 0 + (match-beginning 0))) + (completion-ignore-case ignore-case) + (len (match-beginning 0))) + (efs-del-hash-entry file files ignore-case) + ;; Now we need to check if there are any + ;; versions left. If not, then delete the + ;; root entry. + (or (all-completions + root files + (function + (lambda (sym) + (string-match "#[0-9]+$" + (symbol-name sym) len)))) + (efs-del-hash-entry root files + ignore-case))))))))) + (efs-del-from-ls-cache path t ignore-case))) + +(efs-defun efs-add-file-entry ti-explorer + (path dir-p size owner &optional modes nlinks mdtm) + ;; The ti-explorer version of this function needs to keep track + ;; of file versions. + (let ((ignore-case (memq 'ti-explorer efs-case-insensitive-host-types)) + (ent (let ((dir-p (null (null dir-p)))) + (if mdtm + (list dir-p size owner nil nil mdtm) + (list dir-p size owner))))) + (if dir-p + (let* ((path (directory-file-name path)) + (files (efs-get-hash-entry (file-name-directory path) + efs-files-hashtable + ignore-case))) + (if files + (efs-put-hash-entry (efs-get-file-part path) + ent files ignore-case))) + (let ((files (efs-get-hash-entry + (file-name-directory path) + efs-files-hashtable ignore-case))) + (if files + (let ((file (efs-get-file-part path))) + (efs-save-match-data + (if (string-match "#[0-9]+$" file) + (efs-put-hash-entry + (substring file 0 (match-beginning 0)) + ent files ignore-case) + ;; Need to figure out what version of the file + ;; is being added. + (let* ((completion-ignore-case ignore-case) + (len (length file)) + (versions (all-completions + file files + (function + (lambda (sym) + (string-match "#[0-9]+$" + (symbol-name sym) len))))) + (N (1+ len)) + (max (apply + 'max + (cons 0 (mapcar + (function + (lambda (x) + (string-to-int (substring x N)))) + versions))))) + ;; No need to worry about case here. + (efs-put-hash-entry + (concat file "#" (int-to-string (1+ max))) ent files)))) + (efs-put-hash-entry file ent files ignore-case))))) + (efs-del-from-ls-cache path t ignore-case))) + +(efs-defun efs-internal-file-name-as-directory ti-explorer (name) + (efs-save-match-data + (if (string-match "\\.\\(DIRECTORY\\|directory\\)\\(#[0-9>]\\)?$" name) + (setq name (substring name 0 (match-beginning 0)))) + (let (file-name-handler-alist) + (file-name-as-directory name)))) + +(efs-defun efs-allow-child-lookup ti-explorer (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + + ;; Subdirs in EXPLORER can't have an extension (other than .DIRECTORY, + ;; which we have truncated). + (not (string-match "\\." file))) + +;;; Tree Dired + +(defconst efs-dired-ti-explorer-re-dir + "^. *[^;\n\r]+;[^;\n\r.]+\\.\\(DIRECTORY\\|directory\\) *#" + "Regular expression to use to search for Explorer directories.") + +(or (assq 'ti-explorer efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'ti-explorer efs-dired-ti-explorer-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-manual-move-to-filename ti-explorer + (&optional raise-error bol eol) + ;; In dired, move to first char of filename on this line. + ;; Returns position (point) or nil if no filename on this line. + ;; This is the Explorer version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + (if (re-search-forward efs-ti-explorer-filename-regexp eol t) + (progn + (goto-char (match-beginning 0)) + ;; Explorer listings might come out in absolute form. + (if (looking-at "[^;]*; *") + (goto-char (match-end 0)) + (point))) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename ti-explorer + (&optional no-error bol eol) + ;; Assumes point is at beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; On failure, signals an error or returns nil. + ;; This is the Explorer version. + (let (case-fold-search) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (if (looking-at efs-ti-explorer-filename-regexp) + (goto-char (match-end 0)) + (if no-error + nil + (error "No file on this line"))))) + +(efs-defun efs-dired-ls-trim ti-explorer () + (goto-char (point-min)) + (let ((case-fold-search nil)) + (re-search-forward efs-ti-explorer-filename-regexp)) + (beginning-of-line) + (delete-region (point-min) (point)) + (forward-line 1) + (delete-region (point) (point-max))) + +(efs-defun efs-internal-file-name-sans-versions ti-explorer + (name &optional keep-backup-version) + (efs-save-match-data + (if (string-match "#\\([0-9]+\\|>\\)$" name) + (substring name 0 (match-beginning 0)) + name))) + +;;; ### still need to ape these from vms: +;;; efs-dired-vms-clean-directory +;;; efs-dired-vms-collect-file-versions +;;; efs-dired-vms-trample-file-versions +;;; efs-dired-vms-flag-backup-files +;;; efs-dired-vms-backup-diff + +;;; end of efs-ti-explorer.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-ti-twenex.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-ti-twenex.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,341 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-ti-twenex.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Support for a TI lisp machine in Twenex emulation mode. +;; Author: Jamie Zawinski +;; Created: Thu Dec 17 15:04:14 1992 +;; Modified: Sun Nov 27 18:43:17 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(provide 'efs-ti-twenex) +(require 'efs) + +(defconst efs-ti-twenex-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;; ------------------------------------------------------------ +;;;; Twenex support. +;;;; ------------------------------------------------------------ +;;; Written for an explorer in ti-twenex mode. Twenex is supposed to be just +;;; MIT's name for tops-20, but an explorer emulating twenex is not the same +;;; thing. + +(defconst efs-ti-twenex-filename-regexp + (let* ((excluded-chars ":;<>.#\n\r\ta-z") + (token (concat "[^" excluded-chars "]+")) + (token* (concat "[^" excluded-chars "]*"))) + (concat "\\(" token ": *" "\\)?" ; optional device + "<\\(" token "\\)?\\(\\." token "\\)*> *" ; directory + "\\(" token* "." token* "\\|\\) *" ; name and extension + "\\(\\. *-?\\([0-9]+\\|>\\)\\)?"))) ; version + +;;; The above isn't entirely accurate, because "/" can quote any character +;;; anywhere in a pathname. + +(efs-defun efs-fix-path ti-twenex (path &optional reverse) + ;; Convert PATH from UNIX-ish to Twenex. If REVERSE given then convert + ;; from Twenex to UNIX-ish. + (efs-save-match-data + (if reverse + (if (string-match + "^\\([^:]+:\\)? *\\([^:]+:\\)? *<\\([^>]*\\)> *\\(.*\\)$" + path) + (let (dir file) + ;; I don't understand how "devices" work, so I'm ignoring them. + ;; (if (match-beginning 2) + ;; (setq device (substring path + ;; (match-beginning 2) + ;; (1- (match-end 2))))) + (if (match-beginning 3) + (setq dir + (substring path (match-beginning 3) (match-end 3)))) + (if (match-beginning 4) + (setq file + (substring path (match-beginning 4) (match-end 4)))) + (cond (dir + (setq dir (apply (function concat) + (mapcar (function + (lambda (char) + (if (= char ?.) + (vector ?/) + (vector char)))) + dir))) + (if (string-match "^/" dir) + (setq dir (substring dir 1)) + (setq dir (concat "/" dir))))) + (concat + ;; (and device ":") device (and device ":") + dir (and dir "/") + file)) + (error "path %s didn't match ti-twenex syntax" path)) + (let (dir file tmp) + ;; (if (string-match "^/[^:]+:" path) + ;; (setq device (substring path 1 + ;; (1- (match-end 0))) + ;; path (substring path (match-end 0)))) + (cond ((setq tmp (file-name-directory path)) + (setq dir (apply (function concat) + (mapcar (function + (lambda (char) + (if (= char ?/) + (vector ?.) + (vector char)))) + (substring tmp 0 -1)))) + (if (string-match "^[.]" dir) + (setq dir (substring dir 1)) + (setq dir (concat "." dir))))) + (setq file (file-name-nondirectory path)) + (concat + ;; (and device ":") device (and device ":") + (and dir "<") + dir + (and dir ">") + file))))) + +;; (efs-fix-path-for-twenex "/PUBLIC/ZMACS/ZYMURG.LISP.1") +;; (efs-fix-path-for-twenex "ZYMURG.LISP.1" t) + +(efs-defun efs-fix-dir-path ti-twenex (dir-path) + ;; Convert path from UNIX-ish to Explorer ready for a DIRectory listing. + (cond ((string-equal dir-path "/") + (efs-fix-path 'ti-twenex "/~/" nil)) + ((string-match "^/[-A-Z0-9_$]+:/" dir-path) + (error "Don't grok TWENEX \"devices\" yet.")) + ((efs-fix-path 'ti-twenex dir-path nil)))) + +(defmacro efs-parse-ti-twenex-filename () + ;; Extract the next filename from an Explorer dired-like listing. + (` (if (re-search-forward + efs-ti-twenex-filename-regexp + nil t) + (buffer-substring (match-beginning 0) (match-end 0))))) + +(efs-defun efs-parse-listing ti-twenex + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a TWENEX directory + ;; listing, and return a hashtable as the result. + ;; HOST = remote host name + ;; USER = user name + ;; DIR = directory in as a full remote path + ;; PATH = directory in full efs path syntax + ;; SWITCHES = ls switches (not relevant here) + (let ((tbl (efs-make-hashtable)) + file) + (goto-char (point-min)) + (efs-save-match-data + (while (setq file (efs-parse-ti-twenex-filename)) + ;; Explorer/Twenex listings might come out in absolute form. + (if (string-match "^[^>]*> *" file) + (setq file (substring file (match-end 0)))) + (if (string-match "\\.\\(DIRECTORY\\|directory\\).[0-9]+$" file) + ;; deal with directories + (efs-put-hash-entry + (substring file 0 (match-beginning 0)) '(t) tbl) + (efs-put-hash-entry file '(nil) tbl) + (if (string-match "\\.[0-9]+$" file) ; deal with extension + ;; sans extension + (efs-put-hash-entry + (substring file 0 (match-beginning 0)) '(nil) tbl))) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl)) + tbl)) + +(efs-defun efs-really-file-p ti-twenex (file ent) + ;; Eliminates the version entries + (or (car ent) ; file-directory-p + (efs-save-match-data + (string-match "\\.[0-9]+$" file)))) + +(efs-defun efs-delete-file-entry ti-twenex (path &optional dir-p) + (let ((ignore-case (memq 'ti-twenex efs-case-insensitive-host-types))) + (if dir-p + (let ((path (file-name-as-directory path)) + files) + (efs-del-hash-entry path efs-files-hashtable ignore-case) + (setq path (directory-file-name path) + files (efs-get-hash-entry (file-name-directory path) + efs-files-hashtable + ignore-case)) + (if files + (efs-del-hash-entry (efs-get-file-part path) + files ignore-case))) + (efs-save-match-data + (let ((file (efs-get-file-part path))) + (if (string-match "\\.[0-9]+$" file) + ;; Only delete versions with explicit version numbers. + (let ((files (efs-get-hash-entry + (file-name-directory path) + efs-files-hashtable ignore-case))) + (if files + (let ((root (substring file 0 + (match-beginning 0))) + (completion-ignore-case ignore-case) + (len (match-beginning 0))) + (efs-del-hash-entry file files ignore-case) + ;; Now we need to check if there are any + ;; versions left. If not, then delete the + ;; root entry. + (or (all-completions + root files + (function + (lambda (sym) + (string-match "\\.[0-9]+$" + (symbol-name sym) len)))) + (efs-del-hash-entry root files + ignore-case))))))))) + (efs-del-from-ls-cache path t ignore-case))) + +(efs-defun efs-add-file-entry ti-twenex + (path dir-p size owner &optional modes nlinks mdtm) + ;; The ti-twenex version of this function needs to keep track + ;; of ti-twenex's file versions. + (let ((ignore-case (memq 'ti-twenex efs-case-insensitive-host-types)) + (ent (let ((dir-p (null (null dir-p)))) + (if mdtm + (list dir-p size owner nil nil mdtm) + (list dir-p size owner))))) + (if dir-p + (let* ((path (directory-file-name path)) + (files (efs-get-hash-entry (file-name-directory path) + efs-files-hashtable + ignore-case))) + (if files + (efs-put-hash-entry (efs-get-file-part path) + ent files ignore-case))) + (let ((files (efs-get-hash-entry + (file-name-directory path) + efs-files-hashtable ignore-case))) + (if files + (let ((file (efs-get-file-part path))) + (efs-save-match-data + (if (string-match "\\.[0-9]+$" file) + (efs-put-hash-entry + (substring file 0 (match-beginning 0)) + ent files ignore-case) + ;; Need to figure out what version of the file + ;; is being added. + (let* ((completion-ignore-case ignore-case) + (len (length file)) + (versions (all-completions + file files + (function + (lambda (sym) + (string-match "\\.[0-9]+$" + (symbol-name sym) len))))) + (N (1+ len)) + (max (apply + 'max + (cons 0 (mapcar + (function + (lambda (x) + (string-to-int (substring x N)))) + versions))))) + ;; No need to worry about case here. + (efs-put-hash-entry + (concat file "." (int-to-string (1+ max))) ent files)))) + (efs-put-hash-entry file ent files ignore-case))))) + (efs-del-from-ls-cache path t ignore-case))) + +(efs-defun efs-internal-file-name-as-directory ti-twenex (name) + (efs-save-match-data + (if (string-match "\\.\\(DIRECTORY\\|directory\\)\\(\\.[0-9>]\\)?$" name) + (setq name (substring name 0 (match-beginning 0)))) + (let (file-name-handler-alist) + (file-name-as-directory name)))) + +(efs-defun efs-allow-child-lookup ti-twenex (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + + ;; Subdirs in TI-TWENEX can't have an extension (other than .DIRECTORY, + ;; which we have truncated). + (not (string-match "\\." file))) + +;;; Tree Dired + +(defconst efs-dired-ti-twenex-re-dir + "^. *[^>\n\r]+>[^>\n\r.]+\\.\\(DIRECTORY\\|directory\\)\\b" + "Regular expression to use to search for TWENEX directories.") + +(or (assq 'ti-twenex efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'ti-twenex efs-dired-ti-twenex-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-manual-move-to-filename ti-twenex + (&optional raise-error bol eol) + ;; In dired, move to first char of filename on this line. + ;; Returns position (point) or nil if no filename on this line. + ;; This is the Twenex version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + (if (re-search-forward efs-ti-twenex-filename-regexp eol t) + (progn + (goto-char (match-beginning 0)) + ;; Twenex listings might come out in absolute form. + (if (looking-at "[^>]*> *") + (goto-char (match-end 0)) + (point))) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename ti-twenex + (&optional no-error bol eol) + ;; Assumes point is at beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; On failure, signals an error or returns nil. + ;; This is the Explorer version. + (let (case-fold-search) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (if (looking-at efs-ti-twenex-filename-regexp) + (goto-char (match-end 0)) + (if no-error + nil + (error "No file on this line"))))) + +(efs-defun efs-internal-file-name-sans-versions ti-twenex + (name &optional keep-backup-version) + (efs-save-match-data + (if (string-match "\\.[0-9]+$" name) + (substring name 0 (match-beginning 0)) + name))) + +;;; ### still need to ape these from vms: +;;; efs-dired-vms-clean-directory +;;; efs-dired-vms-collect-file-versions +;;; efs-dired-vms-trample-file-versions +;;; efs-dired-vms-flag-backup-files +;;; efs-dired-vms-backup-diff + +;;; end of efs-ti-twenex.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-tops-20.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-tops-20.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,353 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-tops-20.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: TOPS-20 support for efs +;; Author: Sandy Rutherford +;; Created: Fri Oct 23 08:52:00 1992 +;; Modified: Sun Nov 27 18:43:45 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(require 'efs) +(provide 'efs-tops-20) + +(defconst efs-tops-20-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;; ------------------------------------------------------------ +;;;; TOPS-20 support +;;;; ------------------------------------------------------------ + +(efs-defun efs-send-pwd tops-20 (host user &optional xpwd) + ;; pwd doesn't work for tops-20. Need to get the cwd from a dir listing + ;; this function returns the cwd in tops-20 syntax + (let* ((temp (efs-make-tmp-name host nil)) + (cmd (concat "dir * " (cdr temp))) + dir u-dir full-dir result) + (unwind-protect + (if (null (and (car (setq result (efs-raw-send-cmd + (efs-get-process host user) + cmd + "Getting TOPS-20 PWD"))) + (progn + (condition-case () + (delete-file (car temp)) (error nil)) + (car (setq result + (efs-raw-send-cmd + (efs-get-process host user) + cmd + "Trying to get TOPS-20 PWD, again.")))))) + (save-excursion + (set-buffer (get-buffer-create + efs-data-buffer-name)) + (erase-buffer) + (if (or (file-readable-p (car temp)) + (sleep-for efs-retry-time) + (file-readable-p (car temp))) + ;; Try again. + (insert-file-contents (car temp)) + (efs-error host user + (format + "list data file %s not readable" (car temp)))) + ;; get the cwd + (goto-char (point-min)) + (efs-save-match-data + (if (looking-at "[^ /:]+:<[^<>/ ]+>") + (progn + (setq dir (buffer-substring (match-beginning 0) + (match-end 0)) + u-dir (efs-internal-directory-file-name + (efs-fix-path 'tops-20 dir t)) + full-dir (format efs-path-format-string + user host u-dir)) + ;; cache the files too + (efs-set-files full-dir + (efs-parse-listing + 'tops-20 host user u-dir full-dir)) + (efs-add-to-ls-cache full-dir nil (buffer-string) t)))))) + (efs-del-tmp-name (car temp))) + (cons dir (nth 1 result)))) + +(efs-defun efs-fix-path tops-20 (path &optional reverse) + ;; Convert PATH from UNIX-ish to tops-20. If REVERSE given, then + ;; do just that. + (efs-save-match-data + (if reverse + (if (string-match "^\\([^:]+:\\)?<\\([^>.][^>]*\\)>.*$" path) + (let ((device (and (match-beginning 1) + (substring path (match-beginning 1) + (match-end 1)))) + (dir (substring path (match-beginning 2) + (match-end 2))) + (file (substring path (1+ (match-end 2))))) + (while (string-match "\\." dir) + (setq dir (concat (substring dir 0 (match-beginning 0)) + "/" + (substring dir (match-end 0))))) + (if device + (setq dir (concat "/" device "/" dir))) + (concat dir file)) + (error "path %s didn't match tops-20 syntax" path)) + (if (string-match "^\\(/[^:/]+:/\\)?\\([^./]+/\\)*\\([^/]*\\)$" path) + (let ((device (and (match-beginning 1) + (substring path 1 (1- (match-end 1))))) + (dir (and (match-beginning 2) + (substring path (match-beginning 2) + (1- (match-end 2))))) + (file (substring path (match-beginning 3) + (match-end 3)))) + (if dir + (progn + (while (string-match "/" dir) + (setq dir (concat (substring dir 0 (match-beginning 0)) + "." + (substring dir (match-end 0))))) + (if device + (concat device "<" dir ">" file) + (concat "<" dir ">" file))) + (if device + (error "%s is invalid relative syntax for tops-20" path) + file))) + (error "path %s is invalid syntax for tops-20" path))))) + +(efs-defun efs-fix-dir-path tops-20 (dir-path) + ;; Convert a path from UNIX-ish to Tops-20 fir a dir listing. + (cond ((string-equal "/" dir-path) + (error "Can't list tops-20 devices")) + ((string-match "/[^:/]+:/$" dir-path) + (error "Can't list all root directories on a tops-20 device")) + ((efs-fix-path 'tops-20 dir-path nil)))) + + +;; In tops-20 listings, the filename starts immediatley after the date regexp. + +(defconst efs-tops-20-date-regexp + (concat + " [1-3]?[0-9]-\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" + "\\|Nov\\|Dec\\)-[0-9][0-9] [0-9][0-9]:[0-9][0-9]:[0-9][0-9] ")) + + +(efs-defun efs-parse-listing tops-20 + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a TOPS-20 directory + ;; listing, and return a hashtable as the result. + ;; HOST = remote host name + ;; USER = user name + ;; DIR = directory in as a full remote path + ;; PATH = directory in full efs path syntax + ;; SWITCHES = ls switches (not relevant here) + (let ((tbl (efs-make-hashtable)) + file) + (goto-char (point-min)) + (efs-save-match-data + (if (looking-at " *[^/:]+:<\\([^/.<>]+\\.\\)+> *$") + ;; looking at the directory name + (forward-line 1)) + (while (re-search-forward efs-tops-20-date-regexp nil t) + (setq file (buffer-substring (point) + (progn (end-of-line) (point)))) + (if (string-match "\\.DIRECTORY\\.[0-9]+$" file) + ;; deal with directories + (efs-put-hash-entry + (substring file 0 (match-beginning 0)) '(t) tbl) + (efs-put-hash-entry file '(nil) tbl) + ;; sans extension + (if (string-match "\\.[0-9]+$" file) + (efs-put-hash-entry + (substring file 0 (match-beginning 0)) '(nil) tbl))) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl)) + tbl)) + +(efs-defun efs-really-file-p tops-20 (file ent) + ;; Eliminates the version entries + (or (car ent) ; file-directory-p + (efs-save-match-data + (string-match "\\.[0-9]+$" file)))) + +(efs-defun efs-delete-file-entry tops-20 (path &optional dir-p) + (let ((ignore-case (memq 'tops-20 efs-case-insensitive-host-types))) + (if dir-p + (let ((path (file-name-as-directory path)) + files) + (efs-del-hash-entry path efs-files-hashtable ignore-case) + (setq path (directory-file-name path) + files (efs-get-hash-entry (file-name-directory path) + efs-files-hashtable + ignore-case)) + (if files + (efs-del-hash-entry (efs-get-file-part path) + files ignore-case))) + (efs-save-match-data + (let ((file (efs-get-file-part path))) + (if (string-match "\\.[0-9]+$" file) + ;; Only delete explicit versions + (let ((files (efs-get-hash-entry + (file-name-directory path) + efs-files-hashtable ignore-case))) + (if files + (let ((root (substring file 0 + (match-beginning 0))) + (completion-ignore-case ignore-case) + (len (match-beginning 0))) + (efs-del-hash-entry file files ignore-case) + ;; Now we need to check if there are any + ;; versions left. If not, then delete the + ;; root entry. + (or (all-completions + root files + (function + (lambda (sym) + (string-match "\\.[0-9]+$" + (symbol-name sym) len)))) + (efs-del-hash-entry root files + ignore-case))))))))) + (efs-del-from-ls-cache path t ignore-case))) + +(efs-defun efs-add-file-entry tops-20 + (path dir-p size owner &optional modes nlinks mdtm) + ;; The tops-20 version of this function needs to keep track + ;; of tops-20's file versions. + (let ((ignore-case (memq 'tops-20 efs-case-insensitive-host-types)) + (ent (let ((dir-p (null (null dir-p)))) + (if mdtm + (list dir-p size owner nil nil mdtm) + (list dir-p size owner))))) + (if dir-p + (let* ((path (directory-file-name path)) + (files (efs-get-hash-entry (file-name-directory path) + efs-files-hashtable + ignore-case))) + (if files + (efs-put-hash-entry (efs-get-file-part path) + ent files ignore-case))) + (let ((files (efs-get-hash-entry + (file-name-directory path) + efs-files-hashtable ignore-case))) + (if files + (let ((file (efs-get-file-part path))) + (efs-save-match-data + (if (string-match "\\.[0-9]+$" file) + (efs-put-hash-entry + (substring file 0 (match-beginning 0)) + ent files ignore-case) + ;; Need to figure out what version of the file + ;; is being added. + (let* ((completion-ignore-case ignore-case) + (len (length file)) + (versions (all-completions + file files + (function + (lambda (sym) + (string-match "\\.[0-9]+$" + (symbol-name sym) len))))) + (N (1+ len)) + (max (apply + 'max + (cons 0 (mapcar + (function + (lambda (x) + (string-to-int (substring x N)))) + versions))))) + ;; No need to worry about case here. + (efs-put-hash-entry + (concat file "." (int-to-string (1+ max))) ent files)))) + (efs-put-hash-entry file ent files ignore-case))))) + (efs-del-from-ls-cache path t ignore-case))) + +(efs-defun efs-internal-file-name-as-directory tops-20 (name) + (efs-save-match-data + (if (string-match "\\.DIRECTORY\\(\\.[0-9>]\\)?$" name) + (setq name (substring name 0 (match-beginning 0)))) + (let (file-name-handler-alist) + (file-name-as-directory name)))) + +;;; Tree Dired + +(defconst efs-dired-tops-20-re-dir + "^[^\n]+\\.DIRECTORY\\(\\.[0-9]+\\)?$") + +(or (assq 'tops-20 efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'tops-20 efs-dired-tops-20-re-dir) + efs-dired-re-dir-alist))) + + +(efs-defun efs-dired-manual-move-to-filename tops-20 + (&optional raise-error bol eol) + ;; In dired, move to first char of filename on this line. + ;; Returns position (point) or nil if no filename on this line. + ;; This is the Tops-20 version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + (if (re-search-forward efs-tops-20-date-regexp eol t) + (point) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename tops-20 + (&optional no-error bol eol) + ;; Assumes point is at beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; On failure, signals an error or returns nil. + ;; This is the Tops-20 version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + ;; Is this the right character set? + (skip-chars-forward "-_A-Z0-9$.;") + (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r)))) + (if no-error + nil + (error "No file on this line")) + (point)))) + +(efs-defun efs-internal--file-name-sans-versions tops-20 + (name &optional keep-backup-version) + (efs-save-match-data + (if (string-match "\\.[0-9]+$" name) + (substring name 0 (match-beginning 0)) + name))) + +(efs-defun efs-dired-insert-headerline tops-20 (dir) + ;; TOPS-20 inserts a headerline. I would prefer the headerline + ;; to be in efs format. This version tries to + ;; be careful, because we can't count on a headerline + ;; over ftp, and we wouldn't want to delete anything + ;; important. + (save-excursion + (if (looking-at "^ wildcard ") + (forward-line 1)) + (if (looking-at "^[ \n\t]*[^:/<>]+:<[^<>/]+> *\n") + (delete-region (point) (match-end 0))) + (insert " " (directory-file-name dir) ":\n\n"))) + +;;; end of efs-tops-20.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-vm.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-vm.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,342 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-vm.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Allows the VM mail reader to access folders using efs. +;; If you are looking for support for VM/CMS, see efs-cms.el. +;; Author: Sandy Rutherford +;; Created: Mon Nov 9 23:49:18 1992 by sandy on riemann +;; Modified: Sun Nov 27 18:44:07 1994 by sandy on gandalf +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; If vm-get-new-mail (usually bound to "g") is given a prefix, it +;; will prompt for a folder from which to collect mail. With +;; efs-vm, this folder can be in efs syntax. As is usual +;; with VM, this folder will not be deleted. If at the folder prompt, +;; you give "/user@host:", efs-vm will collect mail from the +;; spool file on the remote machine. The spool file will be deleted if +;; the mail is successfully collected. It is not necessary for +;; movemail, nor even emacs, to be installed on the remote machine. +;; The functionality of movemail is mimicked with FTP commands. Both +;; local and remote crashboxes are used, so that mail will not be lost +;; if the FTP connection is lost. +;; +;; To use efs-vm, put (require 'efs-vm) in your .vm file. +;; +;; Works for vm 5.56 through 5.72. May not work with older versions. +;; If vm grows some file-name-handler-alist support, we should use it. +;; Actually it has. I just haven't gotten around to this yet. + +;;; Known Bugs: +;; +;; 1. efs-vm will not be able to collect mail from a spool file if +;; you do not have write permission in the spool directory. +;; I think that this precludes HP-UX. +;; I hope to do something about this. +;; +;; 2. efs-vm is as clever as at can be about spool file locking. +;; i.e. not very clever at all. At least it uses a rename command +;; to minimize the window for problems. Use POP if you want to +;; be careful. +;; + +;;; Provisions, requirements, and autoloads + +(provide 'efs-vm) +(require 'efs-cu) +(require 'efs-ovwrt) +(require 'vm) +;(require 'vm-folder) ; not provided +(if (or (not (fboundp 'vm-get-new-mail)) + (eq (car-safe (symbol-function 'vm-get-new-mail)) 'autoload)) + (load-library "vm-folder")) +(autoload 'efs-make-tmp-name "efs") +(autoload 'efs-del-tmp-name "efs") +(autoload 'efs-send-cmd "efs") +(autoload 'efs-re-read-dir "efs") +(autoload 'efs-copy-file-internal "efs") + +;;; User variables + +(defvar efs-vm-spool-files nil + "Association list of \( USER@MACHINE . SPOOLFILES \) pairs that +specify the location of the default remote spool file for MACHINE. SPOOLFILES +is a list of remote spool files.") + +(defvar efs-vm-crash-box "~/EFS.INBOX.CRASH" + "Local file where efs keeps its local crash boxes.") + +;;; Internal variables + +(defconst efs-vm-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + + +(defun efs-vm-get-new-mail (&optional arg) + "Documented as original" + (interactive "P") + (vm-select-folder-buffer) + (vm-check-for-killed-summary) + (vm-error-if-virtual-folder) + (vm-error-if-folder-read-only) + (cond + ((null arg) + (if (not (eq major-mode 'vm-mode)) + (vm-mode)) + (if (consp (car (vm-spool-files))) + (message "Checking for new mail for %s..." buffer-file-name) + (message "Checking for new mail...")) + (let (new-messages totals-blurb) + (if (and (vm-get-spooled-mail) + (setq new-messages (vm-assimilate-new-messages t))) + (progn + (if vm-arrived-message-hook + (while new-messages + (vm-run-message-hook (car new-messages) + 'vm-arrived-message-hook) + (setq new-messages (cdr new-messages)))) + ;; say this NOW, before the non-previewers read + ;; a message, alter the new message count and + ;; confuse themselves. + (setq totals-blurb (vm-emit-totals-blurb)) + (vm-display nil nil '(vm-get-new-mail) '(vm-get-new-mail)) + (if (vm-thoughtfully-select-message) + (vm-preview-current-message) + (vm-update-summary-and-mode-line)) + (message totals-blurb)) + (if (consp (car (vm-spool-files))) + (message "No new mail for %s" buffer-file-name) + (message "No new mail.")) + (sit-for 4) + (message "")))) + (t + (let* ((buffer-read-only nil) + (folder (read-file-name "Gather mail from folder: " + vm-folder-directory t)) + (parsed (efs-ftp-path folder)) + mcount new-messages totals-blurb) + (if parsed + (if (string-equal (nth 2 parsed) "") + ;; a spool file + (if (not (and (efs-vm-get-remote-spooled-mail folder) + (setq new-messages + (vm-assimilate-new-messages t)))) + (progn + (message + "No new mail, or mail couldn't be retrieved by ftp.") + ;; don't let this message stay up forever... + (sit-for 4) + (message "")) + (if vm-arrived-message-hook + (while new-messages + (vm-run-message-hook (car new-messages) + 'vm-arrived-message-hook) + (setq new-messages (cdr new-messages)))) + ;; say this NOW, before the non-previewers read + ;; a message, alter the new message count and + ;; confuse themselves. + (setq totals-blurb (vm-emit-totals-blurb)) + (vm-display nil nil '(vm-get-new-mail) '(vm-get-new-mail)) + (if (vm-thoughtfully-select-message) + (vm-preview-current-message) + (vm-update-summary-and-mode-line)) + (message totals-blurb)) + + ;; a remote folder + (let ((tmp-file (car (efs-make-tmp-name nil (car parsed)))) + (folder (expand-file-name folder))) + (unwind-protect + (progn + (efs-copy-file-internal + folder parsed tmp-file nil t nil + (format "Getting %s" folder) + ;; asynch worries me here + nil nil) + (if (and vm-check-folder-types + (not (vm-compatible-folder-p tmp-file))) + (error + "Folder %s is not the same format as this folder." + folder)) + (save-excursion + (vm-save-restriction + (widen) + (goto-char (point-max)) + (insert-file-contents tmp-file))) + (setq mcount (length vm-message-list)) + (if (setq new-messages (vm-assimilate-new-messages)) + (progn + (if vm-arrived-message-hook + (while new-messages + (vm-run-message-hook (car new-messages) + 'vm-arrived-message-hook) + (setq new-messages (cdr new-messages)))) + ;; say this NOW, before the non-previewers read + ;; a message, alter the new message count and + ;; confuse themselves. + (setq totals-blurb (vm-emit-totals-blurb)) + (vm-display nil nil '(vm-get-new-mail) + '(vm-get-new-mail)) + (if (vm-thoughtfully-select-message) + (vm-preview-current-message) + (vm-update-summary-and-mode-line)) + (message totals-blurb) + ;; The gathered messages are actually still on disk + ;; unless the user deletes the folder himself. + ;; However, users may not understand what happened if + ;; the messages go away after a "quit, no save". + (setq vm-messages-not-on-disk + (+ vm-messages-not-on-disk + (- (length vm-message-list) + mcount)))) + (message "No messages gathered.")) + (efs-del-tmp-name tmp-file))))) + + ;; local + + (if (and vm-check-folder-types + (not (vm-compatible-folder-p folder))) + (error "Folder %s is not the same format as this folder." + folder)) + (save-excursion + (vm-save-restriction + (widen) + (goto-char (point-max)) + (insert-file-contents folder))) + (setq mcount (length vm-message-list)) + (if (setq new-messages (vm-assimilate-new-messages)) + (progn + (if vm-arrived-message-hook + (while new-messages + (vm-run-message-hook (car new-messages) + 'vm-arrived-message-hook) + (setq new-messages (cdr new-messages)))) + ;; say this NOW, before the non-previewers read + ;; a message, alter the new message count and + ;; confuse themselves. + (setq totals-blurb (vm-emit-totals-blurb)) + (vm-display nil nil '(vm-get-new-mail) '(vm-get-new-mail)) + (if (vm-thoughtfully-select-message) + (vm-preview-current-message) + (vm-update-summary-and-mode-line)) + (message totals-blurb) + ;; The gathered messages are actually still on disk + ;; unless the user deletes the folder himself. + ;; However, users may not understand what happened if + ;; the messages go away after a "quit, no save". + (setq vm-messages-not-on-disk + (+ vm-messages-not-on-disk + (- (length vm-message-list) + mcount)))) + (message "No messages gathered."))))))) + +(defun efs-vm-gobble-remote-crash-box (remote-crash-box) + (let ((remote-crash-box (expand-file-name remote-crash-box)) + (crash-box (expand-file-name efs-vm-crash-box)) + lsize) + (if (file-exists-p vm-crash-box) + (progn + ;; This should never happen, but let's make sure that we never + ;; clobber mail. + (message "Recovering messages from local crash box...") + (vm-gobble-crash-box efs-vm-crash-box) + (message "Recovering messages from local crash box... done"))) + (efs-copy-file-internal remote-crash-box (efs-ftp-path remote-crash-box) + crash-box nil nil nil + (format "Getting %s" remote-crash-box) + ;; asynch worries me here + nil nil) + ;; only delete the remote crash box if we are sure that we have everything + (if (and (setq lsize (nth 7 (file-attributes crash-box))) + (eq lsize (nth 7 (file-attributes remote-crash-box))) + (vm-compatible-folder-p crash-box)) + (progn + (vm-gobble-crash-box crash-box) + (delete-file remote-crash-box)) + ;; don't leave garbage in the local crash box + (condition-case () (delete-file crash-box) (error nil)) + (error "Problem reading remote crash box %s" remote-crash-box)))) + +(defun efs-vm-get-remote-spooled-mail (remote-path) + ;; remote-path is usually of the form /user@machine: + ;; Usually vm sets inhibit-quit to t for this. This is probably + ;; a bad idea if there is ftp activity. + ;; I don't want to assume that the remote machine has movemail. + ;; Try to mimic movemail with ftp commands as best as possible. + ;; For this to work, we need to be able to create a subdirectory + ;; in the spool directory. + (if vm-block-new-mail + (error "Can't get new mail until you save this folder.")) + (let* ((parsed (efs-ftp-path remote-path)) + (host (car parsed)) + (user (nth 1 parsed)) + (spool-files + (or (cdr (assoc (concat user "@" host) + efs-vm-spool-files)) + (list (concat "/usr/spool/mail/" user)))) + got-mail) + (while spool-files + (let* ((s-file (car spool-files)) + (spool-file (format efs-path-format-string user host s-file)) + ;; rmdir and mkdir bomb if this path ends in a /. + (c-dir (concat s-file ".CRASHBOX")) + (rc-file (concat c-dir "/CRASHBOX")) + (crash-dir (concat spool-file ".CRASHBOX/")) + (remote-crash-file (concat crash-dir "CRASHBOX")) + (crash-box (expand-file-name efs-vm-crash-box))) + (if (file-exists-p crash-box) + (progn + (message "Recovering messages from crash box...") + (vm-gobble-crash-box crash-box) + (message "Recovering messages from crash box... done") + (setq got-mail t))) + (if (let ((efs-allow-child-lookup nil)) + (file-exists-p remote-crash-file)) + (progn + (message "Recovering messages from remote crash box...") + (efs-vm-gobble-remote-crash-box remote-crash-file) + (message "Recovering messages from remote crash box... done") + (setq got-mail t))) + (if (file-exists-p crash-box) + (progn + (message "Recovering messages from crash box...") + (vm-gobble-crash-box crash-box) + (message "Recovering messages from crash box... done") + (setq got-mail t))) + (unwind-protect + (if (car + (efs-send-cmd + host user (list 'mkdir c-dir) + (format "Making crash directory %s" crash-dir))) + (progn + (efs-re-read-dir crash-dir) + (message "Unable to make crash directory %s" crash-dir) + (ding)) + (or (car + (efs-send-cmd host user (list 'rename s-file rc-file) + (format "Checking spool file %s" spool-file))) + (progn + (message "Getting new mail from %s..." spool-file) + ;; The rename above wouldn't have updated the cash. + (efs-re-read-dir crash-dir) + (efs-vm-gobble-remote-crash-box remote-crash-file) + (message "Getting new mail from %s... done" spool-file) + (setq got-mail t)))) + (condition-case nil + (efs-send-cmd + host user (list 'rmdir c-dir) + "Removing crash directory") + (error nil)))) + (setq spool-files (cdr spool-files))) + got-mail)) + +;;; Overwrite existing functions + +(efs-overwrite-fn "efs" 'vm-get-new-mail) + +;;; end of efs-vm.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-vms.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-vms.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,760 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-vms.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: VMS support for efs +;; Authors: Andy Norman, Joe Wells, Sandy Rutherford +;; Modified: Sun Nov 27 18:44:59 1994 by sandy on gandalf +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +(provide 'efs-vms) +(require 'efs) + +(defconst efs-vms-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;; ------------------------------------------------------------ +;;;; VMS support. +;;;; ------------------------------------------------------------ + +;;; efs has full support for VMS hosts, including tree dired support. It +;;; should be able to automatically recognize any VMS machine. However, if it +;;; fails to do this, you can use the command efs-add-vms-host. As well, +;;; you can set the variable efs-vms-host-regexp in your .emacs file. We +;;; would be grateful if you would report any failures to automatically +;;; recognize a VMS host as a bug. +;;; +;;; Filename Syntax: +;;; +;;; For ease of *implementation*, the user enters the VMS filename syntax in a +;;; UNIX-y way. For example: +;;; PUB$:[ANONYMOUS.SDSCPUB.NEXT]README.TXT;1 +;;; would be entered as: +;;; /PUB$$:/ANONYMOUS/SDSCPUB/NEXT/README.TXT;1 +;;; i.e. to log in as anonymous on ymir.claremont.edu and grab the file: +;;; [.CSV.POLICY]RULES.MEM +;;; you would type: +;;; C-x C-f /anonymous@ymir.claremont.edu:CSV/POLICY/RULES.MEM +;;; +;;; A legal VMS filename is of the form: FILE.TYPE;## +;;; where FILE can be up to 39 characters +;;; TYPE can be up to 39 characters +;;; ## is a version number (an integer between 1 and 32,767) +;;; Valid characters in FILE and TYPE are A-Z 0-9 _ - $ +;;; $ cannot begin a filename, and - cannot be used as the first or last +;;; character. +;;; +;;; Tips: +;;; 1. To access the latest version of file under VMS, you use the filename +;;; without the ";" and version number. You should always edit the latest +;;; version of a file. If you want to edit an earlier version, copy it to a +;;; new file first. This has nothing to do with efs, but is simply +;;; good VMS operating practice. Therefore, to edit FILE.TXT;3 (say 3 is +;;; latest version), do C-x C-f /ymir.claremont.edu:FILE.TXT. If you +;;; inadvertently do C-x C-f /ymir.claremont.edu:FILE.TXT;3, you will find +;;; that VMS will not allow you to save the file because it will refuse to +;;; overwrite FILE.TXT;3, but instead will want to create FILE.TXT;4, and +;;; attach the buffer to this file. To get out of this situation, M-x +;;; write-file /ymir.claremont.edu:FILE.TXT will attach the buffer to +;;; latest version of the file. For this reason, in tree dired "f" +;;; (dired-find-file), always loads the file sans version, whereas "v", +;;; (dired-view-file), always loads the explicit version number. The +;;; reasoning being that it reasonable to view old versions of a file, but +;;; not to edit them. +;;; 2. EMACS has a feature in which it does environment variable substitution +;;; in filenames. Therefore, to enter a $ in a filename, you must quote it +;;; by typing $$. There is a bug in EMACS, in that it neglects to quote the +;;; $'s in the default directory when it writes it in the minibuffer. You +;;; must edit the minibuffer to quote the $'s manually. Hopefully, this bug +;;; will be fixed in EMACS 19. If you use Sebastian Kremer's gmhist (V 4.26 +;;; or newer), you will not have this problem. + + +;; Because some VMS ftp servers convert filenames to lower case +;; we allow a-z in the filename regexp. + +(defconst efs-vms-filename-regexp + "\\([_A-Za-z0-9$][-_A-Za-z0-9$]*\\)?\\.\\([-_A-Za-z0-9$]*\\);[0-9]+") +;; Regular expression to match for a valid VMS file name in Dired buffer. + +(defvar efs-vms-month-alist + '(("JAN" . 1) ("FEB". 2) ("MAR" . 3) ("APR" . 4) ("MAY" . 5) ("JUN" . 6) + ("JUL" . 7) ("AUG" . 8) ("SEP" . 9) ("OCT" . 10) + ("NOV" . 11) ("DEC" . 12))) + +(defvar efs-vms-date-regexp + (concat + "\\([0-3]?[0-9]\\)-" + "\\(JAN\\|FEB\\|MAR\\|APR\\|MAY\\|JUN\\|" + "JUL\\|AUG\\|SEP\\|OCT\\|NOV\\|DEC\\)-" + "\\([0-9][0-9][0-9]?[0-9]?\\) \\(\\([0-5][0-9]\\):\\([0-5][0-9]\\)" + "\\(:[0-5][0-9]\\)?\\)? ")) + + +;;; The following two functions are entry points to this file. +;;; They are defined as efs-autoloads in efs.el + +(efs-defun efs-fix-path vms (path &optional reverse) + ;; Convert PATH from UNIX-ish to VMS. + ;; If REVERSE given then convert from VMS to UNIX-ish. + (efs-save-match-data + (if reverse + (if (string-match + "^\\([^:]+:\\)?\\(\\[[^]]+\\]\\)?\\([^][]*\\)$" path) + (let (drive dir file) + (if (match-beginning 1) + (setq drive (substring path + (match-beginning 1) + (match-end 1)))) + (if (match-beginning 2) + (setq dir + (substring path (match-beginning 2) (match-end 2)))) + (if (match-beginning 3) + (setq file + (substring path (match-beginning 3) (match-end 3)))) + (and dir + (setq dir (apply (function concat) + (mapcar (function + (lambda (char) + (if (= char ?.) + (vector ?/) + (vector char)))) + (substring dir 1 -1))))) + (concat (and drive + (concat "/" drive "/")) + dir (and dir "/") + file)) + (error "path %s didn't match" path)) + (let (drive dir file) + (if (string-match "^/[^:/]+:/" path) + (setq drive (substring path 1 (1- (match-end 0))) + path (substring path (1- (match-end 0))))) + (setq dir (file-name-directory path) + file (efs-internal-file-name-nondirectory path)) + (if dir + (let ((len (1- (length dir))) + (n 0)) + (if (<= len 0) + (setq dir nil) + (while (<= n len) + (and (char-equal (aref dir n) ?/) + (cond + ((zerop n) (aset dir n ?\[)) + ((= n len) (aset dir n ?\])) + (t (aset dir n ?.)))) + (setq n (1+ n)))))) + (concat drive dir file))))) + +;; It is important that this function barf for directories for which we know +;; that we cannot possibly get a directory listing, such as "/" and "/DEV:/". +;; This is because it saves an unnecessary FTP error, or possibly the listing +;; might succeed, but give erroneous info. This last case is particularly +;; likely for OS's (like MTS) for which we need to use a wildcard in order +;; to list a directory. + +(efs-defun efs-fix-dir-path vms (dir-path) + ;; Convert path from UNIX-ish to VMS ready for a DIRectory listing. + ;; Should there be entries for .. -> [-] and . -> [] below. Don't + ;; think so, because expand-filename should have already short-circuited + ;; them. + (cond ((string-equal dir-path "/") + (error "Cannot get listing for fictitious \"/\" directory.")) + ((string-match "^/[-A-Z0-9_$]+:/$" dir-path) + (error "Cannot get listing for device.")) + ((efs-fix-path 'vms dir-path)))) + +;; These parsing functions are as general as possible because the syntax +;; of ftp listings from VMS hosts is a bit erratic. What saves us is that +;; the VMS filename syntax is so rigid. If they bomb on a listing in the +;; standard VMS Multinet format, then this is a bug. If they bomb on a listing +;; from vms.weird.net, then too bad. + +(defmacro efs-parse-vms-filename () + "Extract the next filename from a VMS dired-like listing." + (` (if (re-search-forward + efs-vms-filename-regexp + nil t) + (buffer-substring (match-beginning 0) (match-end 0))))) + +(defun efs-parse-vms-listing () + ;; Parse the current buffer which is assumed to be a VMS DIR + ;; listing (either a short (NLIST) or long listing). + ;; Assumes that point is at the beginning of the buffer. + (let ((tbl (efs-make-hashtable)) + file) + (goto-char (point-min)) + (efs-save-match-data + (while (setq file (efs-parse-vms-filename)) + (if (string-match "\\.\\(DIR\\|dir\\);[0-9]+" file) + ;; deal with directories + (efs-put-hash-entry + (substring file 0 (match-beginning 0)) '(t) tbl) + (efs-put-hash-entry file '(nil) tbl) + (if (string-match ";[0-9]+$" file) ; deal with extension + ;; sans extension + (efs-put-hash-entry + (substring file 0 (match-beginning 0)) '(nil) tbl))) + (forward-line 1)) + ;; Would like to look for a "Total" line, or a "Directory" line to + ;; make sure that the listing isn't complete garbage before putting + ;; in "." and "..", but we can't even count on all VAX's giving us + ;; either of these. + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl)) + tbl)) + +(efs-defun efs-parse-listing vms + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a VMS FTP dir + ;; format, and return a hashtable as the result. SWITCHES are never used, + ;; but they must be specified in the argument list for compatibility + ;; with the unix version of this function. + ;; HOST = remote host name + ;; USER = user name + ;; DIR = directory in as a full remote path + ;; PATH = directory in full efs path syntax + ;; SWITCHES = ls switches (not relevant here) + (goto-char (point-min)) + (efs-save-match-data + ;; check for a DIR/FULL monstrosity + (if (search-forward "\nSize:" nil t) + (progn + (efs-add-listing-type 'vms:full host user) + ;; This will cause the buffer to be refilled with an NLIST + (let ((efs-ls-uncache t)) + (efs-ls path nil (format "Relisting %s" + (efs-relativize-filename path)) + t)) + (goto-char (point-min)) + (efs-parse-vms-listing)) + (efs-parse-vms-listing)))) + + +;;;; Sorting of listings + +(efs-defun efs-t-converter vms (&optional regexp reverse) + (if regexp + nil + (goto-char (point-min)) + (efs-save-match-data + (if (re-search-forward efs-vms-filename-regexp nil t) + (let (list-start start end list) + (beginning-of-line) + (setq list-start (point)) + (while (and (looking-at efs-vms-filename-regexp) + (progn + (setq start (point)) + (goto-char (match-end 0)) + (forward-line (if (eolp) 2 1)) + (setq end (point)) + (goto-char (match-end 0)) + (re-search-forward efs-vms-date-regexp nil t))) + (setq list + (cons + (cons + (nconc + (list (string-to-int (buffer-substring + (match-beginning 3) + (match-end 3))) ; year + (cdr (assoc + (buffer-substring (match-beginning 2) + (match-end 2)) + efs-vms-month-alist)) ; month + (string-to-int (buffer-substring + (match-beginning 1) + (match-end 1)))) ;day + (if (match-beginning 4) + (list + (string-to-int (buffer-substring + (match-beginning 5) + (match-end 5))) ; hour + (string-to-int (buffer-substring + (match-beginning 6) + (match-end 6))) ; minute + (if (match-beginning 7) + (string-to-int (buffer-substring + (1+ (match-beginning 7)) + (match-end 7))) ; seconds + 0)) + (list 0 0 0))) + (buffer-substring start end)) + list)) + (goto-char end)) + (if list + (progn + (setq list + (mapcar 'cdr + (sort list 'efs-vms-t-converter-sort-pred))) + (if reverse (setq list (nreverse list))) + (delete-region list-start (point)) + (apply 'insert list))) + t))))) + +(defun efs-vms-t-converter-sort-pred (elt1 elt2) + (let* ((data1 (car elt1)) + (data2 (car elt2)) + (year1 (car data1)) + (year2 (car data2)) + (month1 (nth 1 data1)) + (month2 (nth 1 data2)) + (day1 (nth 2 data1)) + (day2 (nth 2 data2)) + (hour1 (nth 3 data1)) + (hour2 (nth 3 data2)) + (minute1 (nth 4 data1)) + (minute2 (nth 4 data2))) + (or (> year1 year2) + (and (= year1 year2) + (or (> month1 month2) + (and (= month1 month2) + (or (> day1 day2) + (and (= day1 day2) + (or (> hour1 hour2) + (and (= hour1 hour2) + (or (> minute1 minute2) + (and (= minute1 minute2) + (or (> (nth 5 data1) + (nth 5 data2))) + )))))))))))) + + +(efs-defun efs-X-converter vms (&optional regexp reverse) + ;; Sorts by extension + (if regexp + nil + (goto-char (point-min)) + (efs-save-match-data + (if (re-search-forward efs-vms-filename-regexp nil t) + (let (list-start start list) + (beginning-of-line) + (setq list-start (point)) + (while (looking-at efs-vms-filename-regexp) + (setq start (point)) + (goto-char (match-end 0)) + (forward-line (if (eolp) 2 1)) + (setq list + (cons + (cons (buffer-substring (match-beginning 2) + (match-end 2)) + (buffer-substring start (point))) + list))) + (setq list + (mapcar 'cdr + (sort list + (if reverse + (function + (lambda (x y) + (string< (car y) (car x)))) + (function + (lambda (x y) + (string< (car x) (car y)))))))) + (delete-region list-start (point)) + (apply 'insert list) + t))))) + +;; This version only deletes file entries which have +;; explicit version numbers, because that is all VMS allows. + +(efs-defun efs-delete-file-entry vms (path &optional dir-p) + (let ((ignore-case (memq 'vms efs-case-insensitive-host-types))) + (if dir-p + (let ((path (file-name-as-directory path)) + files) + (efs-del-hash-entry path efs-files-hashtable ignore-case) + (setq path (directory-file-name path) + files (efs-get-hash-entry (file-name-directory path) + efs-files-hashtable + ignore-case)) + (if files + (efs-del-hash-entry (efs-get-file-part path) + files ignore-case))) + (efs-save-match-data + (let ((file (efs-get-file-part path))) + (if (string-match ";[0-9]+$" file) + ;; In VMS you can't delete a file without an explicit + ;; version number, or wild-card (e.g. FOO;*) + ;; For now, we give up on wildcards. + (let ((files (efs-get-hash-entry + (file-name-directory path) + efs-files-hashtable ignore-case))) + (if files + (let ((root (substring file 0 + (match-beginning 0))) + (completion-ignore-case ignore-case) + (len (match-beginning 0))) + (efs-del-hash-entry file files ignore-case) + ;; Now we need to check if there are any + ;; versions left. If not, then delete the + ;; root entry. + (or (all-completions + root files + (function + (lambda (sym) + (string-match ";[0-9]+$" + (symbol-name sym) len)))) + (efs-del-hash-entry root files + ignore-case))))))))) + (efs-del-from-ls-cache path t ignore-case))) + +(efs-defun efs-add-file-entry vms (path dir-p size owner + &optional modes nlinks mdtm) + ;; The vms version of this function needs to keep track + ;; of vms's file versions. + (let ((ignore-case (memq 'vms efs-case-insensitive-host-types)) + (ent (let ((dir-p (null (null dir-p)))) + (if mdtm + (list dir-p size owner nil nil mdtm) + (list dir-p size owner))))) + (if dir-p + (let* ((path (directory-file-name path)) + (files (efs-get-hash-entry (file-name-directory path) + efs-files-hashtable + ignore-case))) + (if files + (efs-put-hash-entry (efs-get-file-part path) + ent files ignore-case))) + (let ((files (efs-get-hash-entry + (file-name-directory path) + efs-files-hashtable ignore-case))) + (if files + (let ((file (efs-get-file-part path))) + (efs-save-match-data + ;; In VMS files must have an extension. If there isn't + ;; one, it will be added. + (or (string-match "^[^;]*\\." file) + (if (string-match ";" file) + (setq file (concat + (substring file 0 (match-beginning 0)) + ".;" + (substring file (match-end 0)))) + (setq file (concat file ".")))) + (if (string-match ";[0-9]+$" file) + (efs-put-hash-entry + (substring file 0 (match-beginning 0)) + ent files ignore-case) + ;; Need to figure out what version of the file + ;; is being added. + (let* ((completion-ignore-case ignore-case) + (len (length file)) + (versions (all-completions + file files + (function + (lambda (sym) + (string-match ";[0-9]+$" + (symbol-name sym) len))))) + (N (1+ len)) + (max (apply + 'max + (cons 0 (mapcar + (function + (lambda (x) + (string-to-int (substring x N)))) + versions))))) + ;; No need to worry about case here. + (efs-put-hash-entry + (concat file ";" (int-to-string (1+ max))) ent files)))) + (efs-put-hash-entry file ent files ignore-case))))) + (efs-del-from-ls-cache path t ignore-case))) + +(efs-defun efs-really-file-p vms (file ent) + ;; Returns whether the hash entry FILE with entry ENT is a real file. + (or (car ent) ; file-directory-p + (efs-save-match-data + (string-match ";" file)))) + +(efs-defun efs-internal-file-name-as-directory vms (name) + (efs-save-match-data + (if (string-match "\\.\\(DIR\\|dir\\)\\(;[0-9]+\\)?$" name) + (setq name (substring name 0 (match-beginning 0)))) + (let (file-name-handler-alist) + (file-name-as-directory name)))) + +(efs-defun efs-remote-directory-file-name vms (dir) + ;; Returns the VMS filename in unix directory syntax for directory DIR. + ;; This is something like /FM/SANDY/FOOBAR.DIR;1 + (efs-save-match-data + (setq dir (directory-file-name dir)) + (concat dir + (if (string-match "[a-z]" (nth 2 (efs-ftp-path dir))) + ".dir;1" + ".DIR;1")))) + +(efs-defun efs-allow-child-lookup vms (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + + ;; Subdirs in VMS can't have an extension (other than .DIR, which we + ;; have truncated). + (not (or (string-match "\\." file) + (and (boundp 'dired-local-variables-file) + (stringp dired-local-variables-file) + (string-equal dired-local-variables-file file))))) + +;;; Tree dired support: + +;; For this code I have borrowed liberally from Sebastian Kremer's +;; dired-vms.el + + +;; These regexps must be anchored to beginning of line. +;; Beware that the ftpd may put the device in front of the filename. + +(defconst efs-dired-vms-re-exe + "^. [^ \t.]+\\.\\(EXE\\|exe\\)[; ]") + +(or (assq 'vms efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'vms efs-dired-vms-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-vms-re-dir + "^. [^ \t.]+\\.\\(DIR\\|dir\\)[; ]") + +(or (assq 'vms efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'vms efs-dired-vms-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-insert-headerline vms (dir) + ;; VMS inserts a headerline. I would prefer the headerline + ;; to be in efs format. This version tries to + ;; be careful, because we can't count on a headerline + ;; over ftp, and we wouldn't want to delete anything + ;; important. + (save-excursion + (if (looking-at "^ \\(list \\)?wildcard ") + (forward-line 1)) + ;; This is really aggressive. Too aggressive? + (let ((start (point))) + (skip-chars-forward " \t\n") + (if (looking-at efs-vms-filename-regexp) + (beginning-of-line) + (forward-line 1) + (skip-chars-forward " \t\n") + (beginning-of-line)) + (delete-region start (point))) + (insert " \n")) + (efs-real-dired-insert-headerline dir)) + +(efs-defun efs-dired-fixup-listing vms (file path &optional switches wildcard) + ;; Some vms machines list the entire path. Scrape this off. + (setq path (efs-fix-path + 'vms + ;; Need the file-name-directory, in case of widcards. + ;; Note that path is a `local' path rel. the remote host. + ;; Lose on wildcards in parent dirs. Fix if somebody complains. + (let (file-name-handler-alist) + (file-name-directory path)))) + ;; Some machines put a Node name down too. + (let ((regexp (concat "^\\([_A-Za-z0-9][-_A-Za-z0-9]*\\$\\)?" + (regexp-quote path)))) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (delete-region (match-beginning 0) (match-end 0)))) + ;; Now need to deal with continuation lines. + (goto-char (point-min)) + (let (col start end) + (while (re-search-forward + ";[0-9]+[ \t]*\\(\n[ \t]+\\)[^; \t\n]+[^\n;]*\n" nil t) + (setq start (match-beginning 1) + end (match-end 1)) + ;; guess at the column dimensions + (or col + (save-excursion + (goto-char (point-min)) + (if (re-search-forward + (concat efs-vms-filename-regexp + "[ \t]+[^ \t\n\r]") nil t) + (setq col (- (goto-char (match-end 0)) + (progn (beginning-of-line) (point)) + 1)) + (setq col 0)))) + ;; join cont. lines. + (delete-region start end) + (goto-char start) + (insert-char ? (max (- col (current-column)) 2)))) + ;; Some vms dir listings put a triple null line before the total line. + (goto-char (point-min)) + (skip-chars-forward "\n") + (if (search-forward "\n\n\n" nil t) + (delete-char -1))) + +(efs-defun efs-dired-manual-move-to-filename vms + (&optional raise-error bol eol) + ;; In dired, move to first char of filename on this line. + ;; Returns position (point) or nil if no filename on this line. + ;; This is the VMS version. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + (if (re-search-forward efs-vms-filename-regexp eol t) + (goto-char (match-beginning 0)) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename vms + (&optional no-error bol eol) + ;; Assumes point is at beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t). + ;; case-fold-search must be nil, at least for VMS. + ;; On failure, signals an error or returns nil. + ;; This is the VMS version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "-_A-Za-z0-9$.;") + (if (or (= opoint (point)) (not (memq (following-char) '(?\ ?\t ?\n ?\r)))) + (if no-error + nil + (error "No file on this line")) + (point)))) + +(efs-defun efs-dired-ls-trim vms () + (goto-char (point-min)) + (let ((case-fold-search nil)) + (re-search-forward efs-vms-filename-regexp)) + (beginning-of-line) + (delete-region (point-min) (point)) + (forward-line 1) + (delete-region (point) (point-max))) + +(efs-defun efs-internal-file-name-sans-versions vms + (name &optional keep-backup-version) + (efs-save-match-data + (if (string-match ";[0-9]+$" name) + (substring name 0 (match-beginning 0)) + name))) + +(efs-defun efs-dired-collect-file-versions vms () + ;; If it looks like file FN has versions, return a list of the versions. + ;; That is a list of strings which are file names. + ;; The caller may want to flag some of these files for deletion. + (let ((completion-ignore-case (memq 'vms efs-case-insensitive-host-types)) + result) + (dired-map-dired-file-lines + (function + (lambda (fn) + (if (string-match ";[0-9]+$" fn) + (let* ((base-fn (substring fn 0 (match-beginning 0))) + (base-version (file-name-nondirectory + (substring fn 0 (1+ (match-beginning 0))))) + (bv-length (length base-version)) + (possibilities (and + (null (assoc base-fn result)) + (file-name-all-completions + base-version + (file-name-directory fn))))) + (if possibilities + (setq result + (cons (cons base-fn + ;; code this explicitly + ;; using backup-extract-version has a + ;; lot of function-call overhead. + (mapcar (function + (lambda (fn) + (string-to-int + (substring fn bv-length)))) + possibilities)) result)))))))) + result)) + +(efs-defun efs-dired-flag-backup-files vms (&optional unflag-p) + (interactive "P") + (let ((dired-kept-versions 1) + (kept-old-versions 0) + marker msg) + (if unflag-p + (setq marker ?\040 msg "Unflagging old versions") + (setq marker dired-del-marker msg "Purging old versions")) + (dired-clean-directory 1 marker msg))) + +(efs-defun efs-internal-diff-latest-backup-file vms (fn) + ;; For FILE;#, returns the filename FILE;N, where N + ;; is the largest number less than #, for which this file exists. + ;; Returns nil if none found. + (efs-save-match-data + (and (string-match ";[0-9]+$" fn) + (let ((base (substring fn 0 (1+ (match-beginning 0)))) + (num (1- (string-to-int (substring fn + (1+ (match-beginning 0)))))) + found file) + (while (and (setq found (> num 0)) + (not (file-exists-p + (setq file + (concat base (int-to-string num)))))) + (setq num (1- num))) + (and found file))))) + +;;;;-------------------------------------------------------------- +;;;; Support for VMS DIR/FULL listings. (listing type vms:full) +;;;;-------------------------------------------------------------- + +(efs-defun efs-parse-listing vms:full + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be a VMS FTP dir + ;; format, and return a hashtable as the result. SWITCHES are never used, + ;; but they must be specified in the argument list for compatibility + ;; with the unix version of this function. + ;; HOST = remote host name + ;; USER = user name + ;; DIR = directory in as a full remote path + ;; PATH = directory in full efs path syntax + ;; SWITCHES = ls switches (not relevant here) + (goto-char (point-min)) + (efs-save-match-data + (efs-parse-vms-listing))) + +;;; Tree Dired + +(or (assq 'vms:full efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'vms:full efs-dired-vms-re-exe) + efs-dired-re-exe-alist))) + +(or (assq 'vms:full efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'vms:full efs-dired-vms-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-insert-headerline vms:full (dir) + ;; Insert a blank line for aesthetics. + (insert " \n") + (forward-char -2) + (efs-real-dired-insert-headerline dir)) + +(efs-defun efs-dired-manual-move-to-filename vms:full + (&optional raise-error bol eol) + (let ((efs-dired-listing-type 'vms)) + (efs-dired-manual-move-to-filename raise-error bol eol))) + +(efs-defun efs-dired-manual-move-to-end-of-filename vms:full + (&optional no-error bol eol) + (let ((efs-dired-listing-type 'vms)) + (efs-dired-manual-move-to-end-of-filename no-error bol eol))) + +;;; end of efs-vms.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-vos.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-vos.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,285 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-vos.el +;; Description: VOS support for efs +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Author: Sandy Rutherford +;; Created: Sat Apr 3 03:05:00 1993 by sandy on ibm550 +;; Modified: Sun Nov 27 18:45:24 1994 by sandy on gandalf +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; This file is part of efs. See efs.el for copyright +;;; (it's copylefted) and warrranty (there isn't one) information. + +;;; The original ange-ftp VOS support was written by Joe Wells + +;;; Thank you to Jim Franklin for providing +;;; information on the VOS operating system. + +(provide 'efs-vos) +(require 'efs) + +(defconst efs-vos-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;;;--------------------------------------------------------------- +;;;; VOS support for efs +;;;;--------------------------------------------------------------- + +;;; A legal VOS pathname is of the form: +;;; %systemname#diskname>dirname>dirname>dir-or-filename +;;; +;;; Each of systemname, diskname, dirname, dir-or-filename can be +;;; at most 32 characters. +;;; Valid characters are all alpha, upper and lower case, all digits, +;;; plus: @[]\^`{|}~"$+,-./:_ +;;; restrictions: name cannot begin with hyphen (-) or period (.) +;;; name must not end with a period (.) +;;; name must not contain two adjacent periods (.) +;;; +;;; Invalid characters are: +;;; non-printing control characters +;;; SPACE and DEL +;;; !#%&'()*;<=>? +;;; all other ascii chars +;;; +;;; The full pathname must be less than or equal to 256 characters. +;;; VOS pathnames are CASE-SENSITIVE. +;;; The may be a directory depth limitation of 10 (newer versions may have +;;; eliminated this). + +;;; entry points + +(efs-defun efs-fix-path vos (path &optional reverse) + ;; Convert PATH from UNIX-ish to VOS. + ;; If REVERSE given then convert from VOS to UNIX-ish. + ;; Does crude checking for valid path syntax, but is by no means exhaustive. + (efs-save-match-data + (if reverse + (if (string-match "^\\(\\(%[^#>%]+\\)?#[^>#%]+\\)?>[^>#%]" path) + (let ((marker (1- (match-end 0))) + (result "/") + system drive) + (if (match-beginning 1) + (if (match-beginning 2) + (setq system (substring path 1 (match-end 2)) + drive (substring path (1+ (match-end 2)) + (match-end 1))) + (setq drive (substring 1 (match-end 1))))) + (while (string-match ">" path marker) + (setq result (concat result + (substring path marker + (match-beginning 0)) + "/") + marker (match-end 0))) + (if drive + (if system + (concat "/" system "/" drive result + (substring path marker)) + (concat "/" drive result (substring path marker))) + (concat result (substring path marker)))) + (error "Invalid VOS pathname %s" path)) + (if (string-match "^/\\([^/]+\\)/\\([^/]+\\)/[^/]" path) + (let ((marker (1- (match-end 0))) + (result (concat "%" + (substring path + (match-beginning 1) + (match-end 1)) + "#" + (substring path + (match-beginning 2) + (match-end 2)) + ">"))) + ;; I'm guessing that VOS doesn't have a directory syntax. + (setq path (efs-internal-directory-file-name path)) + (while (string-match "/" path marker) + (setq result + (concat result + (substring path marker + (match-beginning 0)) + ">") + marker (match-end 0))) + (concat result (substring path marker))) + (error "Cannot convert path %s to VOS." path))))) + +(efs-defun efs-fix-dir-path vos (dir-path) + ;; Convert path from UNIX-ish to VMS ready for a DIRectory listing. + (cond ((string-equal dir-path "/") + (error "Cannot gork VOS system names")) + ((string-match "^/[^/]/$" dir-path) + (error "Cannot grok VOS devices")) + ((efs-fix-path 'vos dir-path)))) + +(defconst efs-vos-date-and-time-regexp + (concat + "\\(^\\| \\)" ; For links, this must match at the beginning of the line. + "[678901][0-9]-[01][0-9]-[0-3][0-9] [012][0-9]:[0-6][0-9]:[0-6][0-9] ")) +;; Regexp to match a VOS file line. The end of the regexp must correspond +;; to the start of the filename. + +(defmacro efs-vos-parse-filename () + ;; Return the VOS filename on the current line of a listing. + ;; Assumes that the point is at the beginning of the line. + ;; Return nil if no filename is found. + (` (let ((eol (save-excursion (end-of-line) (point)))) + (and (re-search-forward efs-vos-date-and-time-regexp eol t) + (buffer-substring (point) eol))))) + +(efs-defun efs-parse-listing vos + (host user dir path &optional switches) + ;; Parse the current buffer which is assumed to be in MultiNet FTP dir + ;; format, and return a hashtable as the result. SWITCHES are never used, + ;; but they must be specified in the argument list for compatibility + ;; with the unix version of this function. + ;; HOST = remote host name + ;; USER = user name + ;; DIR = directory in as a full remote path + ;; PATH = directory in full efs path syntax + ;; SWITCHES = ls switches (not relevant here) + (goto-char (point-min)) + (efs-save-match-data + (let (tbl file) + ;; Look file files. + (if (search-forward "\nFiles: " nil t) + (progn + (setq tbl (efs-make-hashtable)) + (forward-line 1) + (skip-chars-forward "\n") + (while (setq file (efs-vos-parse-filename)) + (efs-put-hash-entry file '(nil) tbl) + (forward-line 1)))) + ;; Look for directories. + (if (search-forward "\nDirs: " nil t) + (progn + (or tbl (setq tbl (efs-make-hashtable))) + (forward-line 1) + (skip-chars-forward "\n") + (while (setq file (efs-vos-parse-filename)) + (efs-put-hash-entry file '(t) tbl) + (forward-line 1)))) + ;; Look for links + (if (search-forward "\nLinks: " nil t) + (let (link) + (or tbl (setq tbl (efs-make-hashtable))) + (forward-line 1) + (skip-chars-forward "\n") + (while (setq file (efs-vos-parse-filename)) + (if (string-match " -> \\([^ ]+\\)" file) + ;; VOS puts a trailing blank after the name of a symlink + ;; target. Go figure... + (setq link (substring file (match-beginning 1) (match-end 1)) + file (substring file 0 (match-beginning 0))) + (setq link "")) ; weird? + (efs-put-hash-entry file (list link) tbl) + (forward-line 1)))) + ;; This returns nil if no headings for files, dirs, or links + ;; are found. In this case, we're assuming that it isn't a valid + ;; listing. + (if tbl + (progn + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl))) + tbl))) + +(efs-defun efs-allow-child-lookup vos (host user dir file) + ;; Returns t if FILE in directory DIR could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. + ;; Directoried don't have a size. + (string-match ": not a file\\.$" + (cdr (efs-send-size host user (concat dir file))))) + +;;; Tree Dired Support + +(defconst efs-dired-vos-re-exe + "^. +e ") + +(or (assq 'vos efs-dired-re-exe-alist) + (setq efs-dired-re-exe-alist + (cons (cons 'vos efs-dired-vos-re-exe) + efs-dired-re-exe-alist))) + +(defconst efs-dired-vos-re-dir + "^. +[nsm] +[0-9]+ +[678901][0-9]-") + +(or (assq 'vos efs-dired-re-dir-alist) + (setq efs-dired-re-dir-alist + (cons (cons 'vos efs-dired-vos-re-dir) + efs-dired-re-dir-alist))) + +(efs-defun efs-dired-manual-move-to-filename vos + (&optional raise-error bol eol) + ;; In dired, move to the first char of filename on this line, where + ;; line can be delimited by either \r or \n. + ;; Returns (point) or nil if raise-error is nil and there is no + ;; filename on this line. In the later case, leaves the point at the + ;; beginning of the line. + ;; This version is for VOS. + (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point)))) + (let (case-fold-search) + (if bol + (goto-char bol) + (skip-chars-backward "^\n\r")) + (if (re-search-forward efs-vos-date-and-time-regexp eol t) + (point) + (and raise-error (error "No file on this line"))))) + +(efs-defun efs-dired-manual-move-to-end-of-filename vos + (&optional no-error bol eol) + ;; Assumes point is at the beginning of filename. + ;; So, it should be called only after (dired-move-to-filename t) + ;; On failure signals an error, or returns nil. + ;; This is the VOS version. + (let ((opoint (point))) + (and selective-display + (null no-error) + (eq (char-after + (1- (or bol (save-excursion + (skip-chars-backward "^\r\n") + (point))))) + ?\r) + ;; File is hidden or omitted. + (cond + ((dired-subdir-hidden-p (dired-current-directory)) + (error + (substitute-command-keys + "File line is hidden. Type \\[dired-hide-subdir] to unhide."))) + ((error + (substitute-command-keys + "File line is omitted. Type \\[dired-omit-toggle] to un-omit." + ))))) + (skip-chars-forward "-a-zA-Z0-9@[]\\^`{|}~\"$+,./:_") + (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r ?\ )))) + (if no-error + nil + (error "No file on this line")) + (point)))) + +(efs-defun efs-dired-fixup-listing vos (file path &optional switches wildcard) + ;; VOS listing contain some empty lines, which is inconvenient for dired. + (goto-char (point-min)) + (skip-chars-forward "\n") + (delete-region (point-min) (point)) + (while (search-forward "\n\n" nil t) + (forward-char -2) + (delete-char 1))) + +(efs-defun efs-dired-ls-trim vos () + ;; Trims VOS dir listings for single files, so that they are exactly one line + ;; long. + (goto-char (point-min)) + (let (case-fold-search) + (re-search-forward efs-vos-date-and-time-regexp)) + (beginning-of-line) + (delete-region (point-min) (point)) + (forward-line 1) + (delete-region (point) (point-max))) + +;;; end of efs-vos.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs-x19.15.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs-x19.15.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,69 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs-x19.15.el +;; Release: $efs release: 1.14 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: efs support for XEmacs, versions 19.15, and later. +;; Author: Sandy Rutherford +;; Created: Tue Aug 2 17:40:32 1994 by sandy on ibm550 +;; Modified: by Mike Sperber +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(provide 'efs-x19\.15) +(require 'efs-cu) +(require 'default-dir) +(require 'efs-ovwrt) + +(defconst efs-x19\.15-version + (concat (substring "$efs release: 1.14 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +;;; Functions requiring special defs. for these XEmacs versions. + +(defun efs-abbreviate-file-name (filename &optional hack-homedir) + ;; XEmacs version of abbreviate-file-name for remote files. + (let (file-name-handler-alist) + (if (and hack-homedir (efs-ftp-path filename)) + ;; Do replacements from directory-abbrev-alist + (apply 'efs-unexpand-parsed-filename + (efs-ftp-path (abbreviate-file-name filename nil))) + (abbreviate-file-name filename hack-homedir)))) + +(defun efs-set-buffer-file-name (filename) + ;; Sets the buffer local variables for filename appropriately. + ;; A special function because XEmacs and FSF do this differently. + (setq buffer-file-name filename) + (if (and efs-compute-remote-buffer-file-truename + (memq (efs-host-type (car (efs-ftp-path filename))) + efs-unix-host-types)) + (compute-buffer-file-truename) + (setq buffer-file-truename filename))) + +;; Only XEmacs has this function. Why do we need both this and +;; set-visited-file-modtime? + +(defun efs-set-buffer-modtime (buffer &optional time) + ;; For buffers visiting remote files, set the buffer modtime. + (or time + (progn + (setq time + (let* ((file (save-excursion + (set-buffer buffer) buffer-file-name)) + (parsed (efs-ftp-path file))) + (efs-get-file-mdtm (car parsed) (nth 1 parsed) + (nth 2 parsed) file))) + (if time + (setq time (cons (car time) (nth 1 time))) + (setq time '(0 . 0))))) + (let (file-name-handler-alist) + (set-buffer-modtime buffer time))) + +;;; For the file-name-handler-alist + +(put 'set-buffer-modtime 'efs 'efs-set-buffer-modtime) + +;;; end of efs-x19.15.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/efs.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/efs.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,10845 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: efs.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Transparent FTP support for the original GNU Emacs +;; from FSF and Lucid Emacs +;; Authors: Andy Norman , +;; Sandy Rutherford +;; Created: Thu Oct 12 14:00:05 1989 (as ange-ftp) +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; The following restrictions apply to all of the files in the efs +;;; distribution. +;;; +;;; Copyright (C) 1993 Andy Norman / Sandy Rutherford +;;; +;;; Authors: +;;; Andy Norman (ange@hplb.hpl.hp.com) +;;; Sandy Rutherford (sandy@ibm550.sissa.it) +;;; +;;; The authors of some of the sub-files of efs are different +;;; from the above. We are very grateful to people who have +;;; contributed code to efs. +;;; +;;; 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 1, 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. +;;; +;;; A copy of the GNU General Public License can be obtained from this +;;; program's authors (send electronic mail to ange@hplb.hpl.hp.com) or +;;; from the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, +;;; MA 02139, USA. + +;;; Description: +;;; +;;; This package attempts to make accessing files and directories on +;;; remote computers from within GNU Emacs as simple and transparent +;;; as possible. Currently all remote files are accessed using FTP. +;;; The goal is to make the entire internet accessible as a virtual +;;; file system. + +;;; Acknowledgements: << please add to this list >> +;;; +;;; Corny de Souza for writing efs-mpe.el. +;;; Jamie Zawinski for writing efs-ti-twenex.el and efs-ti-explorer.el +;;; Joe Wells for writing the first pass at vms support for ange-ftp.el. +;;; Sebastian Kremer for helping with dired support. +;;; Ishikawa Ichiro for MULE support. +;;; +;;; Many other people have contributed code, advice, and beta testing +;;; (sometimes without even realizing it) to both ange-ftp and efs: +;;; +;;; Rob Austein, Doug Bagley, Andy Caiger, Jim Franklin, Noah +;;; Friedman, Aksnes Knut-Havard, Elmar Heeb, John Interrante, Roland +;;; McGrath, Jeff Morgenthaler, Mike Northam, Jens Petersen, Jack +;;; Repenning, Joerg-Martin Schwarz, Michael Sperber, Svein Tjemsland, +;;; Andy Whitcroft, Raymond A. Wiker +;;; +;;; Also, thank you to all the people on the efs-testers mailing list. +;;; + +;;; -------------------------------------------------------------- +;;; Documentation: +;;; -------------------------------------------------------------- +;;; +;;; Currently efs does not have a tex info file, and what you are +;;; reading represents the only efs documentation. Please report any +;;; errors or omissions in this documentation to the "bugs" address +;;; below. Eventually, a tex info file should be written. If you have +;;; any problems with efs, please read this section *before* +;;; submitting a bug report. + +;;; Installation: +;;; +;;; For byte compiling the efs package, a Makefile is provided. +;;; You should follow the instructions at the top of the Makefile. +;;; If you have any problems, please let us know so that we can fix +;;; them for other users. Don't even consider using efs without +;;; byte compiling it. It will be far too slow. +;;; +;;; If you decide to byte compile efs by hand, it is important that +;;; the file efs-defun.el be byte compiled first, followed by efs.el. +;;; The other files may be byte compiled in any order. +;;; +;;; To use efs, simply put the byte compiled files in your load path +;;; and add +;;; +;;; (require 'efs) +;;; +;;; in your .emacs file. +;;; +;;; If you would like efs to be autoloaded when you attempt to access +;;; a remote file, put +;;; +;;; (require 'efs-auto) +;;; +;;; in your .emacs file. Note that there are some limitations associated +;;; with autoloading efs. A discussion of them is given at the top of +;;; efs-auto.el. + +;;; Configuration variables: +;;; +;;; It is important that you read through the section on user customization +;;; variables (search forward for the string ">>>"). If your local network +;;; is not fully connected to the internet, but accesses the internet only +;;; via a gateway, then it is vital to set the appropriate variables to +;;; inform efs about the geometry of your local network. Also, see the +;;; paragraph on gateways below. + +;;; Usage: +;;; +;;; Once installed, efs operates largely transparently. All files +;;; normally accessible to you on the internet, become part of a large +;;; virtual file system. These files are accessed using an extended +;;; file name syntax. To access file on remote host by +;;; logging in as user , you simply specify the full path of the +;;; file as /@:. Nearly all GNU Emacs file handling +;;; functions work for remote files. It is not possible to access +;;; remote files using shell commands in an emacs *shell* buffer, as such +;;; commands are passed directly to the shell, and not handled by emacs. +;;; FTP is the underlying utility that efs uses to operate on remote files. +;;; +;;; For example, if find-file is given a filename of: +;;; +;;; /ange@anorman:/tmp/notes +;;; +;;; then efs will spawn an FTP process, connect to the host 'anorman' as +;;; user 'ange', get the file '/tmp/notes' and pop up a buffer containing the +;;; contents of that file as if it were on the local file system. If efs +;;; needed a password to connect then it would prompt the user in the +;;; minibuffer. For further discussion of the efs path syntax, see the +;;; paragraph on extended file name syntax below. + +;;; Ports: +;;; +;;; efs supports the use of nonstandard ports on remote hosts. +;;; To specify that port should be used, give the host name as +;;; host#. Host names may be given in this form anywhere that efs +;;; normally expects a host name. This includes in the .netrc file. +;;; Logically, efs treats different ports to correspond to different +;;; remote hosts. + +;;; Extended filename syntax: +;;; +;;; The default full efs path syntax is +;;; +;;; /@#: +;;; +;;; Both the `#' and `@' may be omitted. +;;; +;;; If the `#' is omitted, then the default port is taken to be 21, +;;; the usual FTP port. For most users, the port syntax will only +;;; very rarely be necessary. +;;; +;;; If the `@' is omitted, then efs will use a default user. If a +;;; login token is specified in your .netrc file, then this will be used as +;;; the default user for . Otherwise, it is determined based on the +;;; value of the variable efs-default-user. +;;; +;;; This efs path syntax can be customised to a certain extent by +;;; changing a number of variables in the subsection Internal Variables. +;;; To undertake such a customization requires some knowledge about the +;;; internal workings of efs. + +;;; Passwords: +;;; +;;; A password is required for each host / user pair. This will be +;;; prompted for when needed, unless already set by calling +;;; efs-set-passwd, or specified in a *valid* ~/.netrc file. +;;; +;;; When efs prompts for a password, it provides defaults from its +;;; cache of currently known passwords. The defaults are ordered such +;;; that passwords for accounts which have the same user name as the +;;; login which is currently underway have priority. You can cycle +;;; through your list of defaults with C-n to cycle forwards and C-p +;;; to cycle backwards. The list is circular. + +;;; Passwords for user "anonymous": +;;; +;;; Passwords for the user "anonymous" (or "ftp") are handled +;;; specially. The variable efs-generate-anonymous-password controls +;;; what happens. If the value of this variable is a string, then this +;;; is used as the password; if non-nil, then a password is created +;;; from the name of the user and the hostname of the machine on which +;;; GNU Emacs is running; if nil (the default) then the user is +;;; prompted for a password as normal. + +;;; "Dumb" UNIX hosts: +;;; +;;; The FTP servers on some UNIX machines have problems if the "ls" +;;; command is used. efs will try to correct for this automatically, +;;; and send the "dir" command instead. If it fails, you can call the +;;; function efs-add-host, and give the host type as dumb-unix. Note +;;; that this change will take effect for the current GNU Emacs +;;; session only. To make this specification for future emacs +;;; sessions, put +;;; +;;; (efs-add-host 'dumb-unix "hostname") +;;; +;;; in your .emacs file. Also, please report any failure to automatically +;;; recognize dumb unix to the "bugs" address given below, so that we can +;;; fix the auto recognition code. + +;;; File name completion: +;;; +;;; Full file-name completion is supported on every type of remote +;;; host. To do filename completion, efs needs a listing from the +;;; remote host. Therefore, for very slow connections, it might not +;;; save any time. However, the listing is cached, so subsequent uses +;;; of file-name completion will be just as fast as for local file +;;; names. + +;;; FTP processes: +;;; +;;; When efs starts up an FTP process, it leaves it running for speed +;;; purposes. Some FTP servers will close the connection after a period of +;;; time, but efs should be able to quietly reconnect the next time that +;;; the process is needed. +;;; +;;; The FTP process will be killed should the associated "*ftp user@host*" +;;; buffer be deleted. This should not cause efs any grief. + +;;; Showing background FTP activity on the mode-line: +;;; +;;; After efs is loaded, the command efs-display-ftp-activity will cause +;;; background FTP activity to be displayed on the mode line. The variable +;;; efs-mode-line-format is used to determine how this data is displayed. +;;; efs does not continuously track the number of active sessions, as this +;;; would cause the display to change too rapidly. Rather, it uses a heuristic +;;; algorithm to determine when there is a significant change in FTP activity. + +;;; File types: +;;; +;;; By default efs will assume that all files are ASCII. If a file +;;; being transferred matches the value of efs-binary-file-name-regexp +;;; then the file will be assumed to be a binary file, and efs will +;;; transfer it using "type image". ASCII files will be transferred +;;; using a transfer type which efs computes to be correct according +;;; to its knowledge of the file system of the remote host. The +;;; command `efs-prompt-for-transfer-type' toggles the variable +;;; `efs-prompt-for-transfer-type'. When this variable is non-nil, efs +;;; will prompt the user for the transfer type to use for every FTP +;;; transfer. Having this set all the time is annoying, but it is +;;; useful to give special treatment to a small set of files. +;;; There is also variable efs-text-file-name-regexp. This is tested before +;;; efs-binary-file-name-regexp, so if you set efs-text-file-name-regexp +;;; to a non-trivial regular expression, and efs-binary-file-name-regexp +;;; to ".*", the result will to make image the default tranfer type. +;;; +;;; Also, if you set efs-treat-crlf-as-nl, then efs will use type image +;;; to transfer files between hosts whose file system differ only in that +;;; one specifies end of line as CR-LF, and the other as NL. This is useful +;;; if you are transferring files between UNIX and DOS machines, and have a +;;; package such as dos-mode.el, that handles the extra ^M's. + +;;; Account passwords: +;;; +;;; Some FTP servers require an additional password which is sent by +;;; the ACCOUNT command. efs will detect this and prompt the user for +;;; an account password if the server expects one. Also, an account +;;; password can be set by calling efs-set-account, or by specifying +;;; an account token in the .netrc file. +;;; +;;; Some operating systems, such as CMS, require that ACCOUNT be used to +;;; give a write access password for minidisks. efs-set-account can be used +;;; to set a write password for a specific minidisk. Also, tokens of the form +;;; minidisk +;;; may be added to host lines in your .netrc file. Minidisk tokens must be +;;; at the end of the host line, however there may be an arbitrary number of +;;; them for any given host. + +;;; Preloading: +;;; +;;; efs can be preloaded, but must be put in the site-init.el file and +;;; not the site-load.el file in order for the documentation strings for the +;;; functions being overloaded to be available. + +;;; Status reports: +;;; +;;; Most efs commands that talk to the FTP process output a status +;;; message on what they are doing. In addition, efs can take advantage +;;; of the FTP client's HASH command to display the status of transferring +;;; files and listing directories. See the documentation for the variables +;;; efs-hash-mark-size, efs-send-hash and efs-verbose for more details. + +;;; Caching of directory information: +;;; +;;; efs keeps an internal cache of file listings from remote hosts. +;;; If this cache gets out of synch, it can be renewed by reverting a +;;; dired buffer for the appropriate directory (dired-revert is usually +;;; bound to "g"). +;;; +;;; Alternatively, you can add the following two lines to your .emacs file +;;; if you want C-r to refresh efs's cache whilst doing filename +;;; completion. +;;; (define-key minibuffer-local-completion-map "\C-r" 'efs-re-read-dir) +;;; (define-key minibuffer-local-must-match-map "\C-r" 'efs-re-read-dir) + +;;; Gateways: +;;; +;;; Sometimes it is neccessary for the FTP process to be run on a different +;;; machine than the machine running GNU Emacs. This can happen when the +;;; local machine has restrictions on what hosts it can access. +;;; +;;; efs has support for running the ftp process on a different (gateway) +;;; machine. The way it works is as follows: +;;; +;;; 1) Set the variable 'efs-gateway-host' to the name of a machine +;;; that doesn't have the access restrictions. If you need to use +;;; a nonstandard port to access this host for gateway use, then +;;; specify efs-gateway-host as "#". +;;; +;;; 2) Set the variable 'efs-ftp-local-host-regexp' to a regular expression +;;; that matches hosts that can be contacted from running a local ftp +;;; process, but fails to match hosts that can't be accessed locally. For +;;; example: +;;; +;;; "\\.hp\\.com$\\|^[^.]*$" +;;; +;;; will match all hosts that are in the .hp.com domain, or don't have an +;;; explicit domain in their name, but will fail to match hosts with +;;; explicit domains or that are specified by their ip address. +;;; +;;; 3) Set the variable `efs-local-host-regexp' to machines that you have +;;; direct TCP/IP access. In other words, you must be able to ping these +;;; hosts. Usually, efs-ftp-local-host-regexp and efs-local-host-regexp +;;; will be the same. However, they will differ for so-called transparent +;;; gateways. See #7 below for more details. +;;; +;;; 4) Set the variable 'efs-gateway-tmp-name-template' to the name of +;;; a directory plus an identifying filename prefix for making temporary +;;; files on the gateway. For example: "/tmp/hplose/ange/efs" +;;; +;;; 5) If the gateway and the local host share cross-mounted directories, +;;; set the value of `efs-gateway-mounted-dirs-alist' accordingly. It +;;; is particularly useful, but not mandatory, that the directory +;;; of `efs-gateway-tmp-name-template' be cross-mounted. +;;; +;;; 6) Set the variable `efs-gateway-type' to the type gateway that you have. +;;; This variable is a list, the first element of which is a symbol +;;; denoting the type of gateway. Following elements give further +;;; data on the gateway. +;;; +;;; Supported gateway types: +;;; +;;; a) local: +;;; This means that your local host is itself the gateway. However, +;;; it is necessary to use a different FTP client to gain access to +;;; the outside world. If the name of the FTP client were xftp, you might +;;; set efs-gateway-type to +;;; +;;; (list 'local "xftp" efs-ftp-program-args) +;;; +;;; If xftp required special arguments, then give them in place of +;;; efs-ftp-program-args. See the documentation for efs-ftp-program-args +;;; for the syntax. +;;; +;;; b) proxy: +;;; This indicates that your gateway works by first FTP'ing to it, and +;;; then issuing a USER command of the form +;;; +;;; USER @ +;;; +;;; In this case, you might set efs-gateway-type to +;;; +;;; (list 'proxy "ftp" efs-ftp-program-args) +;;; +;;; If you need to use a nonstandard client, such as iftp, give this +;;; instead of "ftp". If this client needs to take special arguments, +;;; give them instead of efs-ftp-program-args. +;;; +;;; c) remsh: +;;; For this type of gateway, you need to start a remote shell on +;;; your gateway, using either remsh or rsh. You should set +;;; efs-gateway-type to something like +;;; +;;; (list 'remsh "remsh" nil "ftp" efs-ftp-program-args) +;;; +;;; If you use rsh instead of remsh, change the second element from +;;; "remsh" to "rsh". Note that the symbol indicating the gateway +;;; type should still be 'remsh. If you want to pass arguments +;;; to the remsh program, give them as the third element. For example, +;;; if you need to specify a user, make this (list "-l" "sandy"). +;;; If you need to use a nonstandard FTP client, specify that as the fourth +;;; element. If your FTP client needs to be given special arguments, +;;; give them instead of efs-ftp-program-args. +;;; +;;; d) interactive: +;;; This indicates that you need to establish a login on the gateway, +;;; using either telnet or rlogin. +;;; You should set efs-gateway-type to something like +;;; +;;; (list 'interactive "rlogin" nil "exec ftp" efs-ftp-program-args) +;;; +;;; If you need to use telnet, then give "telnet" in place of the second +;;; element "rlogin". If your login program needs to be given arguments, +;;; then they should be given in the third slot. The fourth element +;;; is for the name of the FTP client program. Giving this as "exec ftp", +;;; instead of "ftp", ensures that you are logged out if the FTP client +;;; dies. If the FTP client takes special arguments, give these instead +;;; of efs-ftp-program-args. Furthermore, you should see the documentation +;;; at the top of efs-gwp.el. You may need to set the variables +;;; efs-gwp-setup-term-command, and efs-gwp-prompt-pattern. +;;; +;;; e) raptor: +;;; This is a type of gateway where efs is expected to specify a gateway +;;; user, and send a password for this user using the ACCOUNT command. +;;; For example, to log in to foobar.edu as sandy, while using the account +;;; ange on the gateway, the following commands would be sent: +;;; +;;; open raptorgate.com +;;; quote USER sandy@foobar.edu ange +;;; quote pass +;;; quote account +;;; +;;; For such a gateway, you would set efs-gateway-type to +;;; +;;; (list 'raptor efs-ftp-program efs-ftp-program-args ) +;;; +;;; where is the name of your account on the gateway. In +;;; the above example, this would be "ange". You can set your gateway +;;; password by simply setting an account password for the gateway host. +;;; This can be done with either efs-set-account, or within your .netrc +;;; file. If no password is set, you will be prompted for one. +;;; +;;; f) interlock: +;;; This is a type of gateway where you are expected to send a PASS +;;; command after opening the connection to the gateway. +;;; The precise login sequence is +;;; +;;; open interlockgate +;;; quote PASS +;;; quote USER sandy@foobar.edu +;;; quote PASS +;;; +;;; For such a gateway, you should set efs-gateway-type to +;;; +;;; (list 'interlock efs-ftp-program efs-ftp-program-args) +;;; +;;; If you need to use a nonstandard name for your FTP client, +;;; then replace efs-ftp-program with this name. If your FTP client +;;; needs to take nonstandard arguments, then replace efs-ftp-program-args +;;; with these arguments. See efs-ftp-program-args for the required +;;; syntax. +;;; +;;; If your gateway returns both a 220 code and a 331 code to the +;;; "open interlockgate" command, then you should add a regular +;;; expression to efs-skip-msgs that matches the 220 response. +;;; Returning two response codes to a single FTP command is not permitted +;;; in RFC 959. It is not possible for efs to ignore the 220 by default, +;;; because than it would hang for interlock installations which do not +;;; require a password. +;;; +;;; g) kerberos: +;;; With this gateway, you need to authenticate yourself by getting a +;;; kerberos "ticket" first. Usually, this is done with the kinit program. +;;; Once authenticated, you connect to foobar.com as user sandy with the +;;; sequence: (Note that the "-n" argument inhibits automatic login. +;;; Although, in manual use you probably don't use it, efs always uses it.) +;;; +;;; iftp -n +;;; open foobar.com +;;; user sandy@foobar.com +;;; +;;; You should set efs-gateway-type to something like +;;; +;;; (list 'kerberos "iftp" efs-ftp-program-args "kinit" ) +;;; +;;; If you use an FTP client other than iftp, insert its name instead +;;; of "iftp" above. If your FTP client needs special arguments, give +;;; them as a list of strings in place of efs-ftp-program-args. If +;;; the program that you use to collect a ticket in not called "kinit", +;;; then give its name in place of "kinit" above. should be +;;; any arguments that you need to pass to your kinit program, given as a +;;; list of strings. Most likely, you will give this as nil. +;;; +;;; See the file efs-kerberos.el for more configuration variables. If you +;;; need to adjust any of these variables, please report this to us so that +;;; we can fix them for other users. +;;; +;;; If efs detects that you are not authenticated to use the gateway, it +;;; will run the kinit program automatically, prompting you for a password. +;;; If you give a password in your .netrc file for login the value of +;;; efs-gateway-host and user kerberos, then efs will use this to +;;; obtain gateway authentication. +;;; +;;; 7) Transparent gateways: +;;; +;;; If your gateway is completely transparent (for example it uses +;;; socks), then you should set efs-gateway-type to nil. Also, +;;; set efs-ftp-local-host-regexp to ".*". However, efs-local-host-regexp, +;;; must still be set to a regular expression matching hosts in your local +;;; domain. efs uses this to determine which machines that it can +;;; open-network-stream to. Furthermore, you should still set +;;; efs-gateway-host to the name of your gateway machine. That way efs +;;; will know that this is a special machine having direct TCP/IP access +;;; to both hosts in the outside world, and hosts in your local domain. +;;; +;;; 8) Common Problems with Gateways: +;;; +;;; a) Spurious 220 responses: +;;; Some proxy-style gateways (eg gateway type 'proxy or 'raptor), +;;; return two 3-digit FTP reply codes to the USER command. +;;; For example: +;;; +;;; open gateway.weird +;;; 220 Connected to gateway.weird +;;; quote USER sandy@foobar +;;; 220 Connected to foobar +;;; 331 Password required for sandy +;;; +;;; This is wrong, according to the FT Protocol. Each command must return +;;; exactly one 3-digit reply code. It may be preceded by continuation +;;; lines. What should really be returned is: +;;; +;;; quote USER sandy@foobar +;;; 331-Connected to foobar. +;;; 331 Password required for sandy. +;;; +;;; or even +;;; +;;; quote USER sandy@foobar +;;; 331-220 Connected to foobar. +;;; 331 Password required for sandy. +;;; +;;; Even though the "331-220" looks strange, it is correct protocol, and +;;; efs will parse it properly. +;;; +;;; If your gateway is returning a spurious 220 to USER, a work-around +;;; is to add a regular expression to `efs-skip-msgs' that matches +;;; this line. It must not match the 220 line returned to the open +;;; command. This work-around may not work, as some system FTP clients +;;; also get confused by the spurious 220. In this case, the only +;;; solution is to patch the gateway server. In either case, please +;;; send a bug report to the author of your gateway software. +;;; +;;; b) Case-sensitive parsing of FTP commands: +;;; Some gateway servers seem to treat FTP commands case-sensitively. +;;; This is incorrect, as RFC 959 clearly states that FTP commands +;;; are always to be case-insensitive. If this is a problem with your +;;; gateway server, you should send a bug report to its author. +;;; If efs is using a case for FTP commands that does not suit your server, +;;; a possible work-around is to edit the efs source so that the required +;;; case is used. However, we will not be making any changes to the +;;; standard efs distribution to support this type of server behaviour. +;;; If you need help changing the efs source, you should enquire with the +;;; efs-help mailing list. +;;; + +;;; --------------------------------------------------------------- +;;; Tips for using efs: +;;; --------------------------------------------------------------- + +;;; 1) Beware of compressing files on non-UNIX hosts. efs will do it by +;;; copying the file to the local machine, compressing it there, and then +;;; sending it back. Binary file transfers between machines of different +;;; architectures can be a risky business. Test things out first on some +;;; test files. See "Bugs" below. Also, note that efs sometimes +;;; copies files by moving them through the local machine. Again, +;;; be careful when doing this with binary files on non-Unix +;;; machines. +;;; +;;; 2) Beware that dired over ftp will use your setting of dired-no-confirm +;;; (list of dired commands for which confirmation is not asked). +;;; You might want to reconsider your setting of this variable, +;;; because you might want confirmation for more commands on remote +;;; direds than on local direds. For example, I strongly recommend +;;; that you not include compress in this list. If there is enough +;;; demand it might be a good idea to have an alist +;;; efs-dired-no-confirm of pairs ( TYPE . LIST ), where TYPE is an +;;; operating system type and LIST is a list of commands for which +;;; confirmation would be suppressed. Then remote dired listings +;;; would take their (buffer-local) value of dired-no-confirm from +;;; this alist. Who votes for this? +;;; +;;; 3) Some combinations of FTP clients and servers break and get out of sync +;;; when asked to list a non-existent directory. Some of the ai.mit.edu +;;; machines cause this problem for some FTP clients. Using +;;; efs-kill-ftp-process can be used to restart the ftp process, which +;;; should get things back in synch. +;;; +;;; 4) Some ftp servers impose a length limit on the password that can +;;; be sent. If this limit is exceeded they may bomb in an +;;; incomprehensible way. This sort of behaviour is common with +;;; MVS servers. Therefore, you should beware of this possibility +;;; if you are generating a long password (like an email address) +;;; with efs-generate-anonymous-password. +;;; +;;; 5) Some antiquated FTP servers hang when asked for an RNFR command. +;;; efs sometimes uses this to test whether its local cache is stale. +;;; If your server for HOST hangs when asked for this command, put +;;; (efs-set-host-property HOST 'rnfr-failed t) +;;; in your efs-ftp-startup-function-alist entry for HOST. +;;; + +;;; ----------------------------------------------------------------------- +;;; Where to get the latest version of efs: +;;; ----------------------------------------------------------------------- +;;; +;;; The authors are grateful to anyone or any organization which +;;; provides anonymous FTP distribution for efs. +;;; +;;; +;;; Europe: +;;; +;;; Switzerland +;;; /anonymous@itp.ethz.ch:/sandy/efs/ +;;; +;;; North America: +;;; +;;; Massachusetts, USA +;;; /anonymous@alpha.gnu.ai.mit.edu:/efs/ +;;; +;;; California, USA +;;; /anonymous@ftp.hmc.edu:/pub/emacs/packages/efs/ +;;; +;;; Australia and New Zealand: +;;; +;;; ???????????? +;;; +;;; Japan: +;;; +;;; ???????????? + +;;; --------------------------------------------------------------------- +;;; Non-UNIX support: +;;; --------------------------------------------------------------------- + +;;; efs has full support, incuding file name completion and tree dired +;;; for: +;;; +;;; VMS, CMS, MTS, MVS, ti-twenex, ti-explorer (the last two are lisp +;;; machines), TOPS-20, DOS (running the Distinct, Novell, FTP +;;; software, NCSA, Microsoft in both unix and DOS mode, Super TCP, and +;;; Hellsoft FTP servers), unix descriptive listings (dl), KA9Q, OS/2, +;;; VOS, NOS/VE, CMS running the KNET server, Tandem's Guardian OS, COKE +;;; +;;; efs should be able to automatically recognize any of the operating +;;; systems and FTP servers that it supports. Please report any +;;; failure to do so to the "bugs" address below. You can specify a +;;; certain host as being of a given host type with the command +;;; +;;; (efs-add-host ) +;;; +;;; is a symbol, is a string. If this command is +;;; used interactively, then is prompted for with +;;; completion. Some host types have regexps that can be used to +;;; specify a class of host names as being of a certain type. Note +;;; that if you specify a host as being of a certain type, efs does +;;; not verify that that is really the type of the host. This calls +;;; for caution when using regexps to specify host types, as an +;;; inadvertent match to a regexp might have unpleasant consequences. +;;; +;;; See the respective efs-TYPE.el files for more information. +;;; When or if we get a tex info file, it should contain some more +;;; details on the non-unix support. + +;;; ------------------------------------------------------------------ +;;; Bugs and other things that go clunk in the night: +;;; ------------------------------------------------------------------ + +;;; How to report a bug: +;;; -------------------- +;;; +;;; Type M-x efs-report-bug +;;; or +;;; send mail to efs-bugs@cuckoo.hpl.hp.com. +;;; +;;; efs is a "free" program. This means that you didn't (or shouldn't +;;; have) paid anything for it. It also means that nobody is paid to +;;; maintain it, and the authors weren't paid for writing it. +;;; Therefore, please try to write your bug report in a clear and +;;; complete fashion. It will greatly enhance the probability that +;;; something will be done about your problem. +;;; +;;; Note that efs relies heavily in cached information, so the bug may +;;; depend in a complicated fashion on commands that were performed on +;;; remote files from the beginning of your emacs session. Trying to +;;; reproduce your bug starting from a fresh emacs session is usually +;;; a good idea. +;;; + +;;; Fan/hate mail: +;;; -------------- +;;; +;;; efs has its own mailing list called efs-help. All users of efs +;;; are welcome to subscribe (see below) and to discuss aspects of +;;; efs. New versions of efs are posted periodically to the mailing +;;; list. +;;; +;;; To [un]subscribe to efs-help, or to report mailer problems with the +;;; list, please mail one of the following addresses: +;;; +;;; efs-help-request@cuckoo.hpl.hp.com +;;; or +;;; efs-help-request%cuckoo.hpl.hp.com@hplb.hpl.hp.com +;;; +;;; Please don't forget the -request part. +;;; +;;; For mail to be posted directly to efs-help, send to one of the +;;; following addresses: +;;; +;;; efs-help@cuckoo.hpl.hp.com +;;; or +;;; efs-help%cuckoo.hpl.hp.com@hplb.hpl.hp.com +;;; +;;; Alternatively, there is a mailing list that only gets +;;; announcements of new efs releases. This is called efs-announce, +;;; and can be subscribed to by e-mailing to the -request address as +;;; above. Please make it clear in the request which mailing list you +;;; wish to join. +;;; + +;;; Known bugs: +;;; ----------- +;;; +;;; If you hit a bug in this list, please report it anyway. Most of +;;; the bugs here remain unfixed because they are considered too +;;; esoteric to be a high priority. If one of them gets reported +;;; enough, we will likely change our view on that. +;;; +;;; 1) efs does not check to make sure that when creating a new file, +;;; you provide a valid filename for the remote operating system. +;;; If you do not, then the remote FTP server will most likely +;;; translate your filename in some way. This may cause efs to +;;; get confused about what exactly is the name of the file. +;;; +;;; 2) For CMS support, we send too many cd's. Since cd's are cheap, I haven't +;;; worried about this too much. Eventually, we should have some caching +;;; of the current minidisk. This is complicated by the fact that some +;;; CMS servers lie about the current minidisk, so sending redundant +;;; cd's helps us recover in this case. +;;; +;;; 3) The code to do compression of files over ftp is not as careful as it +;;; should be. It deletes the old remote version of the file, before +;;; actually checking if the local to remote transfer of the compressed +;;; file succeeds. Of course to delete the original version of the file +;;; after transferring the compressed version back is also dangerous, +;;; because some OS's have severe restrictions on the length of filenames, +;;; and when the compressed version is copied back the "-Z" or ".Z" may be +;;; truncated. Then, efs would delete the only remaining version of +;;; the file. Maybe efs should make backups when it compresses files +;;; (of course, the backup "~" could also be truncated off, sigh...). +;;; Suggestions? +;;; +;;; 4) If a dir listing is attempted for an empty directory on (at least +;;; some) VMS hosts, an ftp error is given. This is really an ftp bug, and +;;; I don't know how to get efs work to around it. +;;; +;;; 5) efs gets confused by directories containing file names with +;;; embedded newlines. A temporary solution is to add "q" to your +;;; dired listing switches. As long as your dired listing switches +;;; also contain "l" and either "a" or "A", efs will use these +;;; switches to get listings for its internal cache. The "q" switch +;;; should force listings to be exactly one file per line. You +;;; still will not be able to access a file with embedded newlines, +;;; but at least it won't mess up the parsing of the rest of the files. +;;; +;;; 6) efs cannot parse symlinks which have an embedded " -> " +;;; in their name. It's alright to have an embedded " -> " in the name +;;; of any other type of file. A fix is possible, but probably not worth +;;; the trouble. If you disagree, send us a bug report. +;;; +;;; 7) efs doesn't handle context-dep. files in H-switch listings on +;;; HP's. It wouldn't be such a big roaring deal to fix this. I'm +;;; waiting until I get an actual bug report though. +;;; +;;; 8) If a hard link is added or deleted, efs will not update its +;;; internal cache of the link count for other names of the file. +;;; This may cause file-nlinks to return incorrectly. Reverting +;;; any dired buffer containing other names for the file will +;;; cause the file data to be updated, including the link counts. +;;; A fix for this problem is known and will be eventually +;;; implemented. How it is implemented will depend on how we decide +;;; to handle inodes. See below. +;;; +;;; 9) efs is unable to parse R-switch listings from remote unix hosts. +;;; This is inefficient, because efs will insist on doing individual +;;; listings of the subdirectories to get its file information. +;;; This may be fixed if there is enough demand. +;;; +;;; 10) In file-attributes, efs returns a fake inode number. Of course +;;; this is necessary, but this inode number is not even necessarily +;;; unique. It is simply the sum of the characters (treated as +;;; integers) in the host name, user name, and file name. Possible +;;; ways to get a unique inode number are: +;;; a) Simply keep a count of all remote file in the cache, and +;;; return the file's position in this count as a negative number. +;;; b) For unix systems, we could actually get at the real inode +;;; number on the remote host, by adding an "i" to the ls switches. +;;; The inode numbers would then be removed from the listing +;;; returned by efs-ls, if the caller hadn't requested the "i" +;;; switch. We could then make a unique number out of the host name +;;; and the real inode number. +;;; +;;; 11) efs tries to determine if a file is readable or writable by comparing +;;; the file modes, file owner, and user name under which it is logged +;;; into the remote host. This does not take into account groups. +;;; We simply assume that the user belongs to all groups. As a result +;;; we may assume that a file is writable, when in fact it is not. +;;; Groups are tough to handle correctly over FTP. Suggestions? +;;; (For new FTP servers, can do a "QUOTE SITE EXEC groups" to +;;; handle this.) + +;;; ----------------------------------------------------------- +;;; Technical information on this package: +;;; ----------------------------------------------------------- + +;;; efs hooks onto the following functions using the +;;; file-name-handler-alist. Depending on which version of emacs you +;;; are using, not all of these functions may access this alist. In +;;; this case, efs overloads the definitions of these functions with +;;; versions that do access the file-name-handler-alist. These +;;; overloads are done in efs's version-specific files. +;;; +;;; abbreviate-file-name +;;; backup-buffer +;;; copy-file +;;; create-file-buffer +;;; delete-directory +;;; delete-file +;;; directory-file-name +;;; directory-files +;;; file-attributes +;;; file-directory-p +;;; file-exists-p +;;; file-local-copy +;;; file-modes +;;; file-name-all-completions +;;; file-name-as-directory +;;; file-name-completion +;;; file-name-directory +;;; file-name-nondirectory +;;; file-name-sans-versions +;;; file-newer-than-file-p +;;; file-readable-p +;;; file-executable-p +;;; file-accessible-directory-p +;;; file-symlink-p +;;; file-writable-p +;;; get-file-buffer +;;; insert-directory +;;; insert-file-contents +;;; list-directory +;;; make-directory-internal +;;; rename-file +;;; set-file-modes +;;; set-visited-file-modtime +;;; substitute-in-file-name +;;; verify-visited-file-modtime +;;; write-region +;;; +;;; The following functions are overloaded in efs.el, because they cannot +;;; be handled via the file-name-handler-alist. +;;; +;;; expand-file-name +;;; load +;;; read-file-name-internal (Emacs 18, only) +;;; require +;;; +;;; The following dired functions are handled by hooking them into the +;;; the file-name-handler-alist. This is done in efs-dired.el. +;;; +;;; efs-dired-compress-file +;;; eds-dired-print-file +;;; efs-dired-make-compressed-filename +;;; efs-compress-file +;;; efs-dired-print-file +;;; efs-dired-create-directory +;;; efs-dired-recursive-delete-directory +;;; efs-dired-uncache +;;; efs-dired-call-process +;;; +;;; In efs-dired.el, the following dired finctions are overloaded. +;;; +;;; dired-collect-file-versions +;;; dired-find-file +;;; dired-flag-backup-files +;;; dired-get-filename +;;; dired-insert-headerline +;;; dired-move-to-end-of-filename +;;; dired-move-to-filename +;;; dired-run-shell-command +;;; +;;; efs makes use of the following hooks +;;; +;;; diff-load-hook +;;; dired-before-readin-hook +;;; find-file-hooks +;;; dired-grep-load-hook + +;;; LISPDIR ENTRY for the Elisp Archive: +;;; +;;; LCD Archive Entry: +;;; efs|Andy Norman and Sandy Rutherford +;;; |ange@hplb.hpl.hp.com and sandy@ibm550.sissa.it +;;; |transparent FTP Support for GNU Emacs +;;; |$Date: 1997/02/11 05:05:14 $|$efs release: 1.15 beta $| + +;;; Host and listing type notation: +;;; +;;; The functions efs-host-type and efs-listing-type, and the +;;; variable efs-dired-host-type follow the following conventions +;;; for remote host types. +;;; +;;; nil = local host type, whatever that is (probably unix). +;;; Think nil as in "not a remote host". This value is used by +;;; efs-dired-host-type for local buffers. +;;; (efs-host-type nil) => nil +;;; +;;; 'type = a remote host of TYPE type. +;;; +;;; 'type:list = a remote host using listing type 'type:list. +;;; This is currently used for Unix dl (descriptive +;;; listings), when efs-dired-host-type is set to +;;; 'unix:dl, and to support the myriad of DOS FTP +;;; servers. + +;;; Supported host and listing types: +;;; +;;; unknown, unix, dumb-unix, bsd-unix, sysV-unix, next-unix, +;;; super-dumb-unix, dumb-apollo-unix, +;;; apollo-unix, unix:dl, dos-distinct, ka9q, dos, dos:ftp, dos:novell, +;;; dos:ncsa, dos:winsock, vos, hell, dos:microsoft, super-dumb-unix +;;; vms, cms, mts, mvs, mvs:tcp mvs:nih tops-20, mpe, ti-twenex, +;;; ti-explorer, os2, vos, +;;; vms:full, guardian, ms-unix (This is the Microsoft NT Windows server +;;; in unix mode.), plan9, unix:unknown, nos-ve (actually NOS/VE). + +;;; Host and listing type hierarchy: +;;; +;;; unknown: unix, dumb-unix, sysV-unix, bsd-unix, next-unix, apollo-unix, +;;; ka9q, dos-distinct, unix:dl, hell, +;;; super-dumb-unix, dumb-apollo-unix +;;; unix: sysV-unix, bsd-unix, next-unix, apollo-unix, unix:dl +;;; dos: dos:ftp, dos:novell, dos:ncsa, dos:microsoft, dos:winsock +;;; dumb-unix: +;;; bsd-unix: +;;; sysV-unix: +;;; next-unix: +;;; apollo-unix: +;;; dumb-apollo-unix: +;;; unix:dl: +;;; unix:unknown: unix:dl, unix +;;; super-dumb-unix: +;;; dos-distinct: +;;; dos:ftp: +;;; dos:novell: +;;; dos:microsoft +;;; ka9q: +;;; vms: vms:full +;;; cms: +;;; mts: +;;; mvs: mvs:tcp, mvs:nih +;;; mvs:tcp: +;;; mvs:nih: +;;; tops-20: +;;; ti-twenex: +;;; ti-explorer: +;;; os2: +;;; vos: +;;; vms:full: +;;; dos:ncsa: +;;; dos:winsock: +;;; vos: +;;; hell: +;;; guardian: +;;; ms-unix: +;;; plan9: +;;; nos-ve: +;;; coke: +;;; + + +;;;; ================================================================ +;;;; >0 +;;;; Table of Contents for efs.el +;;;; ================================================================ +;; +;; Each section of efs.el is labelled by >#, where # is the number of +;; the section. +;; +;; 1. Provisions, requirements, and autoloads. +;; 2. Variable definitions. +;; 3. Utilities. +;; 4. Hosts, users, accounts, and passwords. +;; 5. FTP client process and server responses. +;; 6. Sending commands to the FTP server. +;; 7. Parsing and storing remote file system data. +;; 8. Redefinitions of standard GNU Emacs functions. +;; 9. Multiple host type support. +;; 10. Attaching onto the appropriate emacs version. + + +;;;; ================================================================ +;;;; >1 +;;;; General provisions, requirements, and autoloads. +;;;; Host type, and local emacs type dependent loads, and autoloads +;;;; are in the last two sections of this file. +;;;; ================================================================ + +;;;; ---------------------------------------------------------------- +;;;; Provide the package (Do this now to avoid an infinite loop) +;;;; ---------------------------------------------------------------- + +(provide 'efs) + +;;;; ---------------------------------------------------------------- +;;;; Our requirements. +;;;; ---------------------------------------------------------------- + +(require 'backquote) +(require 'comint) +(require 'efs-defun) +(require 'efs-netrc) +(require 'efs-cu) +(require 'efs-ovwrt) +;; Do this last, as it installs efs into the file-name-handler-alist. +(require 'efs-fnh) + +(autoload 'efs-report-bug "efs-report" "Submit a bug report for efs." t) +(autoload 'efs-gwp-start "efs-gwp" ; For interactive gateways. + "Login to the gateway machine and fire up an FTP client.") +(autoload 'efs-kerberos-login "efs-kerberos") +(autoload 'efs-insert-directory "efs-dired" "Insert a directory listing.") +(autoload 'efs-set-mdtm-of "efs-cp-p") +(autoload 'diff-latest-backup-file "diff") +(autoload 'read-passwd "passwd" "Read a password from the minibuffer." t) + + +;;;; ============================================================ +;;;; >2 +;;;; Variable Definitions +;;;; **** The user configuration variables are in **** +;;;; **** the second subsection of this section. **** +;;;; ============================================================ + +;;;; ------------------------------------------------------------ +;;;; Constant Definitions +;;;; ------------------------------------------------------------ + +(defconst efs-version + (concat (substring "$efs release: 1.15 $" 14 -2) + "/" + (substring "$Revision: 1.1 $" 11 -2))) + +(defconst efs-time-zero 1970) ; we count time from midnight, Jan 1, 1970 GMT. + +(defconst efs-dumb-host-types + '(dumb-unix super-dumb-unix vms cms mts ti-twenex ti-explorer dos mvs + tops-20 mpe ka9q dos-distinct os2 vos hell guardian + netware cms-knet nos-ve coke dumb-apollo-unix) + "List of host types that can't take UNIX ls-style listing options.") +;; dos-distinct only ignores ls switches; it doesn't barf. +;; Still treat it as dumb. + +(defconst efs-unix-host-types + '(unix sysV-unix bsd-unix next-unix apollo-unix dumb-unix + dumb-apollo-unix super-dumb-unix) + "List of unix host types.") + +(defconst efs-version-host-types '(vms tops-20 ti-twenex ti-explorer) + "List of host-types which associated a version number to all files. +This is not the same as associating version numbers to only backup files.") +;; Note that on these systems, +;; (file-name-sans-versions EXISTING-FILE) does not exist as a file. + +(defconst efs-single-extension-host-types + '(vms tops-20 ti-twenex ti-explorer cms mvs dos ka9q dos-distinct hell + netware ms-unix plan9 cms-knet nos-ve) + "List of host types which allow at most one extension on a file name. +Extensions are deliminated by \".\". In addition, these host-types must +allow \"-\" in file names, because it will be used to add additional extensions +to indicate compressed files.") + +(defconst efs-idle-host-types + (append '(coke unknown) efs-unix-host-types)) +;; List of host types for which it is possible that the SITE IDLE command +;; is supported. + +(defconst efs-listing-types + '(unix:dl unix:unknown + dos:novell dos:ftp dos:ncsa dos:microsoft dos:stcp dos:winsock + mvs:nih mvs:tcp mvs:tcp + vms:full) + "List of supported listing types") + +(defconst efs-nlist-listing-types + '(vms:full)) +;; Listing types which give a long useless listing when asked for a +;; LIST. For these, use an NLST instead. This can only be done +;; when there is some way to distinguish directories from +;; plain files in an NLST. + +(defconst efs-opaque-gateways '(remsh interactive)) +;; List of gateway types for which we need to do explicit file handling on +;; the gateway machine. + +;;;; ------------------------------------------------------------------ +;;;; User customization variables. Please read through these carefully. +;;;; ------------------------------------------------------------------ + +;;;>>>> If you are not fully connected to the internet, <<<< +;;;>>>> and need to use a gateway (no matter how transparent) <<<< +;;;>>>> you will need to set some of the following variables. <<<< +;;;>>>> Read the documentation carefully. <<<< + +(defvar efs-local-host-regexp ".*" + "Regexp to match names of local hosts. +These are hosts to which it is possible to obtain a direct internet +connection. Even if the host is accessible by a very transparent FTP gateway, +it does not qualify as a local host. The test to determine if machine A is +local to your machine is if it is possible to ftp from A _back_ to your +local machine. Also, open-network-stream must be able to reach the host +in question.") + +(defvar efs-ftp-local-host-regexp ".*" + "Regexp to match the names of hosts reachable by a direct ftp connection. +This regexp should match the names of hosts which can be reached using ftp, +without requiring any explicit connection to a gateway. If you have a smart +ftp client which is able to transparently go through a gateway, this will +differ from `efs-local-host-regexp'.") + +(defvar efs-gateway-host nil + "If non-nil, this must be the name of your ftp gateway machine. +If your net world is divided into two domains according to +`efs-local-ftp-host-regexp', set this variable to the name of the +gateway machine.") + +(defvar efs-gateway-type nil + "Specifies which type of gateway you wish efs to use. +This should be a list, the first element of which is a symbol denoting the +gateway type, and following elements give data on how to use the gateway. + +The following possibilities are supported: + + '(local FTP-PROGRAM FTP-PROGRAM-ARGS) + This means that your local host is itself the gateway. However, + you need to run a special FTP client to access outside hosts. + FTP-PROGRAM should be the name of this FTP client, and FTP-PROGRAM-ARGS + is a list of arguments to pass to it \(probably set this to the value of + efs-ftp-program-args \). Note that if your gateway is of this type, + then you would set efs-gateway-host to nil. + + '(proxy FTP-PROGRAM FTP-PROGRAM-ARGS) + This indicates that your gateway works by first FTP'ing to it, and + then giving a USER command of the form \"USER @\". + FTP-PROGRAM is the FTP program to use to connect to the gateway; this + is most likely \"ftp\". FTP-PROGRAM-ARGS is a list of arguments to + pass to it. You likely want this to be set to the value of + efs-ftp-program-args . If the connection to the gateway FTP server + is to be on a port different from 21, set efs-gateway-host to + \"#\". + + '(raptor FTP-PROGRAM FTP-PROGRAM-ARGS USER) + This is for the gateway called raptor by Eagle. After connecting to the + the gateway, the command \"user @host USER\" is issued to login + as on , where USER is an authentication username for the + gateway. After issuing the password for the remote host, efs will + send the password for USER on efs-gateway-host as an account command. + + '(interlock FTP-PROGRAM FTP-PROGRAM-ARGS) + This is for the interlock gateway. The exact login sequence is to + connect to the gateway specified by efs-gateway-host , send the + gateway password with a PASS command, send the command + \"user @\" to connect to remote host as user , + and finally to send the password for on with a second + PASS command. + + '(kerberos FTP-PROGRAM FTP-PROGRAM-ARGS KINIT-PROGRAM KINIT-PROGRAM-ARGS) + This is for the kerberos gateway where you need to run a program (kinit) to + obtain a ticket for gateway authroization first. FTP-PROGRAM should be + the name of the FTP client that you use to connect to the gateway. This + may likely be \"iftp\". FTP-PROGRAM-ARGS are the arguments that you need + to pass to FTP-PROGRAM. This is probably the value of + efs-ftp-program-args . KINIT-PROGRAM is the name of the program to + run in order to obtain a ticket. This is probably \"kinit\". + KINIT-PROGRAM-ARGS is a list og strings indicating any arguments that you + need to pass to KINIT-PROGRAM. Most likely this is nil. + + '(remsh GATEWAY-PROGRAM GATEWAY-PROGRAM-ARGS FTP-PROGRAM FTP-PROGRAM-ARGS) + This indicates that you wish to run FTP on your gateway using a remote shell. + GATEWAY-PROGRAM is the name of the program to use to start a remote shell. + It is assumed that it is not necessary to provide a password to start + this remote shell. Likely values are \"remsh\" or \"rsh\". + GATEWAY-PROGRAM-ARGS is a list of arguments to pass to GATEWAY-PROGRAM. + FTP-PROGRAM is the name of the FTP program on the gateway. A likely setting + of this is \"ftp\". FTP-PROGRAM-ARGS is a list of arguments to pass to + FTP-PROGRAM. Most likely these should be set to the value of + efs-ftp-program-args . + + '(interactive GATEWAY-PROGRAM GATEWAY-PROGRAM-ARGS FTP-PROGRAM + FTP-PROGRAM-ARGS) + This indicates that you need to start an interactive login on your gatway, + using rlogin, telnet, or something similar. GATEWAY-PROGRAM is the name + of the program to use to log in to the gateway, and GATEWAY-PROGRAM-ARGS + is a list of arguments to pass to it. FTP-PROGRAM is the name of the FTP + program on the gateway. A likely setting for this variable would be + \"exec ftp\". FTP-PROGRAM-ARGS is a list of arguments to pass + to FTP-PROGRAM. You probably want to set these to the same value as + efs-ftp-program-args . If you are using this option, read the + documentation at the top of efs-gwp.el, and see + efs-gwp-setup-term-command .") + +(defvar efs-gateway-hash-mark-size nil + "*Value of `efs-hash-mark-size' for FTP clients on `efs-gateway-host'. +See the documentation of these variables for more information.") + +(defvar efs-gateway-incoming-binary-hm-size nil + "*Value of `efs-incoming-binary-hm-size' for `efs-gateway-host'. +See documentation of these variables for more information.") + +(defvar efs-gateway-tmp-name-template "/tmp/efs" + "Template used to create temporary files when ftp-ing through a gateway. +This should be the name of the file on the gateway, and not necessarily +the name on the local host.") + +(defvar efs-gateway-mounted-dirs-alist nil + "An alist of directories cross-mounted between the gateway and local host. +Each entry is of the form \( DIR1 . DIR2 \), where DIR1 is the name of the +directory on the local host, and DIR2 is its name on the remote host. Both +DIR1 and DIR2 must be specified in directory syntax, i.e. end in a slash. +Note that we will assume that subdirs of DIR1 and DIR2 are also accessible +on both machines.") + +(defvar efs-gateway-ftp-prompt-regexp "^\\(ftp\\|Ftp\\|FTP\\)> *" + "*Regular expression to match the prompt of the gateway FTP client.") + +;;; End of gateway config variables. + +(defvar efs-tmp-name-template "/tmp/efs" + "Template used to create temporary files. +If you are worried about security, make this a directory in some +bomb-proof cave somewhere. efs does clean up its temp files, but +they do live for short periods of time.") + +(defvar efs-generate-anonymous-password t + "*If t, use a password of `user@host' when logging in as the anonymous user. +`host' is generated by the function `efs-system-fqdn'. If `system name' returns +a fully qualified domain name, `efs-system-fqdn' will return this. Otherwise, +it will attempt to use nslookup to obtain a fully qualified domain name. If +this is unsuccessful, the returned value will be the same as `system-name', +whether this is a fully qualified domain name or not. + +If a string then use that as the password. + +If nil then prompt the user for a password. + +Beware that some operating systems, such as MVS, restrict substantially +the password length. The login will fail with a weird error message +if you exceed it.") + +(defvar efs-high-security-hosts nil + "*Indicates host user pairs for which passwords should not be cached. +If non-nil, should be a regexp matching user@host constructions for which +efs should not store passwords in its internal cache.") + +;; The following regexps are tested in the following order: +;; efs-binary-file-host-regexp, efs-36-bit-binary-file-name-regexp, +;; efs-binary-file-name-regexp, efs-text-file-name-regexp. +;; File names which match nothing are transferred in 'image mode. + +;; If we're not careful, we're going to blow the regexp stack here. +;; Probably should move to a list of regexps. Slower, but safer. +;; This is not a problem in Emacs 19. +(defvar efs-binary-file-name-regexp + (concat "\\." ; the dot + ;; extensions + "\\([zZ]\\|t?gz\\|lzh\\|arc\\|zip\\|zoo\\|ta[rz]\\|dvi\\|sit\\|" + "ps\\|elc\\|gif\\|Z-part-..\\|tpz\\|exe\\|[jm]pg\\|TZ[a-z]?\\|lib\\)" + "\\(~\\|~[0-9]+~\\)?$" ; backups + "\\|" + ;; UPPER CASE LAND + "\\." + "\\(ARC\\|ELC\\|TAGS\\|EXE\\|ZIP\\|DVI\|ZOO\\|GIF\\|T?GZ\\|" + "[JM]PG\\)" + "\\([.#;][0-9]+\\)?$" ; versions + ) + "*Files whose names match this regexp will be considered to be binary. +By binary here, we mean 8-bit binary files (the usual unix binary files). +If nil, no files will be considered to be binary.") + +(defvar efs-binary-file-host-regexp nil + "*All files on hosts matching this regexp are treated as 8-bit binary. +Setting this to nil, inhibits this feature.") + +(defvar efs-36-bit-binary-file-name-regexp nil + "*Files whose names match this regexp will be considered to PDP 10 binaries. +These are 36-bit word-aligned binary files. This is really only relevant for +files on PDP 10's, and similar machines. If nil, no files will be considered +to be PDP 10 binaries.") + +(defvar efs-text-file-name-regexp ".*" + "*Files whose names match this regexp will be considered to be text files.") + +(defvar efs-prompt-for-transfer-type nil + "*If non-nil, efs will prompt for the transfer type for each file transfer. +The command efs-prompt-for-transfer-type can be used to toggle its value.") + +(defvar efs-treat-crlf-as-nl nil + "*Controls how file systems using CRLF as end of line are treated. +If non-nil, such file systems will be considered equivalent to those which use +LF as end of line. This is particularly relevant to transfers between DOS +systems and UNIX. Setting this to be non-nil will cause all file transfers +between DOS and UNIX systems to use be image or binary transfers.") + +(defvar efs-send-hash t + "*If non-nil, send the HASH command to the FTP client.") + +(defvar efs-hash-mark-size nil + "*Default size, in bytes, between hash-marks when transferring a file. +If this is nil then efs will attempt to assign a value based on the +output of the HASH command. Also, if this variable is incorrectly set, +then efs will try to correct it based on the size of the last file +transferred, and the number hashes outputed by the client during the +transfer. + +The variable `efs-gateway-hash-mark-size' defines the corresponding value +for the FTP client on the gateway, if you are using a gateway. + +Some client-server combinations do not correctly compute the number of hash +marks for incoming binary transfers. In this case, a separate variable +`efs-incoming-binary-hm-size' can be used to set a default value of the +hash mark size for incoming binary transfers.") + +(defvar efs-incoming-binary-hm-size nil + "*Default hash mark size for incoming binary transfers. +If this is nil, incoming binary transfers will use `efs-hash-mark-size' as +the default. See the documentation of this variable for more details.") + +(defvar efs-verbose t + "*If non-NIL then be chatty about interaction with the FTP process. +If 0 do not give % transferred reports for asynchronous commands and status +reports for commands verifying file modtimes, but report on everything else.") + +(defvar efs-message-interval 0 + "*Defines the minimum time in seconds between status messages. +A new status message is not displayed, if one has already been given +within this period of time.") + +(defvar efs-max-ftp-buffer-size 3000 + "*Maximum size in characters of FTP process buffer, before it is trimmed. +The buffer is trimmed to approximately half this size. Setting this to nil +inhibits trimming of FTP process buffers.") + +(defvar efs-ls-cache-max 5 + "*Maximum number of directory listings to be cached in efs-ls-cache.") + +(defvar efs-mode-line-format " ftp(%d)" + "Format string used to determine how FTP activity is shown on the mode line. +It is passed to format, with second argument the number of active FTP +sessions as an integer.") + +(defvar efs-show-host-type-in-dired t + "If non-nil, show the system type on the mode line of remote dired buffers.") + +(defvar efs-ftp-activity-function nil + "Function called to indicate FTP activity. +It must have exactly one argument, the number of active FTP sessions as an +integer.") + +(defvar efs-ftp-program-name "ftp" + "Name of FTP program to run.") + +(defvar efs-ftp-program-args '("-i" "-n" "-g" "-v") + "*A list of arguments passed to the FTP program when started.") + +(defvar efs-ftp-prompt-regexp "^\\(ftp\\|Ftp\\|FTP\\)> *" + "*Regular expression to match the prompt of your FTP client.") + +(defvar efs-nslookup-program "nslookup" + "*If non-NIL then a string naming nslookup program." ) + +(defvar efs-nslookup-on-connect nil + "*If non-NIL then use nslookup to resolve the host name before connecting.") + +(defvar efs-nslookup-threshold 1000 + "How many iterations efs waits on the nslookup program. +Applies when nslookup is used to compute a fully qualified domain name +for the local host, in the case when `system-name' does not return one. +If you set this to nil, efs will wait an arbitrary amount of time to get +output.") + +(defvar efs-make-backup-files efs-unix-host-types + "*A list of operating systems for which efs will make Emacs backup files. +The backup files are made on the remote host. + +For example: +'\(unix sysV-unix bsd-unix apollo-unix dumb-unix\) makes sense, but +'\(unix vms\) would be silly, since vms makes its own backups.") + +;; Is this variable really useful? We should try to figure a way to +;; do local copies on a remote machine that doesn't take forever. +(defvar efs-backup-by-copying nil + "*Version of `backup by copying' for remote files. +If non-nil, remote files will be backed up by copying, instead of by renaming. +Note the copying will be done by moving the file through the local host -- a +very time consuming operation.") + +;;; Auto-save variables. Relevant for auto-save.el + +(defvar efs-auto-save 0 + "*If 1, allows efs files to be auto-saved. +If 0, suppresses auto-saving of efs files. +Don't use any other value.") + +(defvar efs-auto-save-remotely nil + "*Determines where remote files are auto-saved. + +If nil, auto-saves for remote files will be written in `auto-save-directory' +or `auto-save-directory-fallback' if this isn't defined. + +If non-nil, causes the auto-save file for an efs file to be written in +the remote directory containing the file, rather than in a local directory. +For remote files, this overrides a non-nil `auto-save-directory'. Local files +are unaffected. If you want to use this feature, you probably only want to +set this true in a few buffers, rather than globally. You might want to give +each buffer its own value using `make-variable-buffer-local'. It is usually +a good idea to auto-save remote files locally, because it is not only faster, +but provides protection against a connection going down. + +See also variable `efs-auto-save'.") + +(defvar efs-short-circuit-to-remote-root nil + "*Defines whether \"//\" short-circuits to the remote or local root.") + +;; Can we somehow grok this from system type? No. +(defvar efs-local-apollo-unix + (eq 0 (string-match "//" (or (getenv "HOME") (getenv "SHELL") ""))) + "*Defines whether the local machine is an apollo running Domain. +This variable has nothing to do with efs, and should be basic to all +of emacs.") + +(defvar efs-root-umask nil + "*umask to use for root logins.") + +(defvar efs-anonymous-umask nil + "*umask to use for anonymous logins.") + +(defvar efs-umask nil + "*umask to use for efs sessions. +If this is nil, then the setting of umask on the local host is used.") + +;; Eliminate these variables when Sun gets around to getting its FTP server +;; out of the stone age. +(defvar efs-ding-on-umask-failure t + "*Ring the bell if the umask command fails on a unix host. Many servers don't +support this command, so if you get a lot of annoying failures, set this +to nil.") + +(defvar efs-ding-on-chmod-failure t + "*Ring the bell if the chmod command fails on a unix host. Some servers don't +support this command, so if you get a lot of annoying failures, set this +to nil.") + +;; Please let us know if you can contribute more entries to this guessing game. +(defvar efs-nlist-cmd + (cond + ;; Covers Ultrix, SunOS, and NeXT. + ((eq system-type 'berkeley-unix) + "ls") + ((memq system-type '(hpux aix-v3 silicon-graphics-unix)) + "nlist") + ;; Blind guess + ("ls")) + "*FTP client command for getting a brief listing (NLST) from the FTP server. +We try to guess this based on the local system-type, but obviously if you +are using a gateway, you'll have to set it yourself.") + +(defvar efs-compute-remote-buffer-file-truename nil + "*If non-nil, `buffer-file-truename' will be computed for remote buffers. +In emacs 19, each buffer has a local variable, `buffer-file-truename', +which is used to ensure that symbolic links will not confuse emacs into +visiting the same file with two buffers. This variable is computed by +chasing all symbolic links in `buffer-file-name', both at the level of the +file and at the level of all parent directories. Since this operation can be +very time-consuming over FTP, this variable can be used to inhibit it.") + +(defvar efs-buffer-name-case nil + "*Selects the case used for buffer names of case-insensitive file names. +Case-insensitive file names are files on hosts whose host type is in +`efs-case-insensitive-host-types'. + +If this is 'up upper case is used, if it is 'down lower case is used. +If this has any other value, the case is inherited from the name used +to access the file.") + +(defvar efs-fancy-buffer-names "%s@%s" + "Format used to compute names of buffers attached to remote files. + +If this is nil, buffer names are computed in the usual way. + +If it is a string, then the it is passed to format with second and third +arguments the host name and file name. + +Otherwise, it is assumed to be function taking three arguments, the host name, +the user name, and the truncated file name. It should returns the name to +be used for the buffer.") + +(defvar efs-verify-anonymous-modtime nil + "*Determines if efs checks modtimes for remote files on anonymous logins. +If non-nil, efs runs `verify-visited-file-modtime' for remote files on +anonymous ftp logins. Since verify-visited-file-modtime slows things down, +and most people aren't editing files on anonymous ftp logins, this is nil +by default.") + +(defvar efs-verify-modtime-host-regexp ".*" + "*Regexp to match host names for which efs checks file modtimes. +If non-nil, efs will run `verify-visited-file-modtime' for remote +files on hosts matching this regexp. If nil, verify-visited-file-modtime +is supressed for all remote hosts. This is tested before +`efs-verify-anonymous-modtime'.") + +(defvar efs-maximize-idle nil + "*If non-nil, efs will attempt to maximize the idle time out period. +At some idle moment in the connection after login, efs will attempt to +set the idle time out period to the maximum amount allowed by the server. +It applies only to non-anonymous logins on unix hosts.") + +(defvar efs-expire-ftp-buffers t + "*If non-nil ftp buffers will be expired. +The buffers will be killed either after `efs-ftp-buffer-expire-time' has +elapsed with no activity, or the remote FTP server has timed out.") + +(defvar efs-ftp-buffer-expire-time nil + "*If non-nil, the time after which ftp buffers will be expired. +If nil, ftp buffers will be expired only when the remote server has timed out. +If an integer, ftp buffers will be expired either when the remote server +has timed out, or when this many seconds on inactivity has elapsed.") + +;; If you need to increase this variable much, it is likely that +;; the true problem is timing errors between the efs process filter +;; and the FTP server. This could either be caused by the server +;; not following RFC959 response codes, or a bug in efs. In either +;; case please report the problem to us. If it's a bug, we'll fix it. +;; If the server is at fault we may try to do something. Our rule +;; of thumb is that we will support non-RFC959 behaviour, as long as +;; it doesn't risk breaking efs for servers which behave properly. + +(defvar efs-retry-time 5 + "*Number of seconds to wait before retrying if data doesn't arrive. +The FTP command isn't retried, rather efs just takes a second look +for the data file. This might need to be increased for very slow FTP +clients.") + +(defvar efs-pty-check-threshold 1000 + "*How long efs waits before deciding that it doesn't have a pty. +Specifically it is the number of iterations through `accept-process-output' +that `efs-pty-p' waits before deciding that the pty is really a pipe. +Set this to nil to inhibit checking for pty's. If efs seems to be +mistaking some pty's for pipes, try increasing this number.") + +(defvar efs-pty-check-retry-time 5 + "*Number of seconds that efs waits before retrying a pty check. +This can be lengthened, if your FTP client is slow to start.") + +(defvar efs-suppress-abort-recursive-edit-and-then nil + "*If non-nil, `efs-abort-recursive-edit-and-then' will not run its function. +This means that when a recursive edit is in progress, automatic popping of the +FTP process buffer, and automatic popping of the bug report buffer will not +work. `efs-abort-recursive-edit-and-then' works by forking a \"sleep 0\" +process. On some unix implementations the forked process might be of the same +size as the original GNU Emacs process. Forking such a large process just to +do a \"sleep 0\" is probably not good.") + +(defvar efs-ftp-buffer-format "*ftp %s@%s*" + "Format to construct the name of FTP process buffers. +This string is fed to `format' with second and third arguments the user +name and host name.") +;; This does not affect the process name of the FTP client process. +;; That is always *ftp USER@HOST* + +(defvar efs-debug-ftp-connection nil + "*If non-nil, the user will be permitted to debug the FTP connection. +This means that typing a C-g to the FTP process filter will give the user +the option to type commands at the FTP connection. Normally, the connection +is killed first. Note that doing this may result in the FTP process filter +getting out of synch with the FTP client, so using this feature routinely +isn't recommended.") + +;;; Hooks and crooks. + +(defvar efs-ftp-startup-hook nil + "Hook to run immediately after starting the FTP client. +This hook is run before the FTP OPEN command is sent.") + +(defvar efs-ftp-startup-function-alist nil + "Association list of functions to running after FTP login. +This should be an alist of the form '\(\(REGEXP . FUNCTION\) ...\), where +REGEXP is a regular expression matched against the name of the remote host, +and FUNCTION is a function of two arguments, HOST and USER. REGEXP is +compared to the host name with `case-fold-search' bound to t. Only the first +match in the alist is run.") + +(defvar efs-load-hook nil + "Hook to run immediately after loading efs.el. +You can use it to alter definitions in efs.el, but why would you want +to do such a thing?") + +;;;; ----------------------------------------------------------- +;;;; Regexps for parsing FTP server responses. +;;;; ----------------------------------------------------------- +;;; +;;; If you have to tune these variables, please let us know, so that +;;; we can get them right in the next release. + +(defvar efs-multi-msgs + ;; RFC959 compliant codes + "^[1-5][0-5][0-7]-") +;; Regexp to match the start of an FTP server multiline reply. + +(defvar efs-skip-msgs + ;; RFC959 compliant codes + (concat + "^110 \\|" ; Restart marker reply. + "^125 \\|" ; Data connection already open; transfer starting. + "^150 ")) ; File status OK; about to open connection. +;; Regexp to match an FTP server response which we wish to ignore. + +(defvar efs-cmd-ok-msgs + ;; RFC959 compliant + "^200 \\|^227 ") +;; Regexp to match the server command OK response. +;; Because PORT commands return this we usually ignore it. However, it is +;; a valid response for TYPE, SITE, and a few other commands (cf. RFC 959). +;; If we are explicitly sending a PORT, or one of these other commands, +;; then we don't want to ignore this response code. Also use this to match +;; the return code for PASV, as some clients burp these things out at odd +;; times. + +(defvar efs-pending-msgs + ;; RFC959 compliant + "^350 ") ; Requested file action, pending further information. +;; Regexp to match the \"requested file action, pending further information\" +;; message. These are usually ignored, except if we are using RNFR to test for +;; file existence. + +(defvar efs-cmd-ok-cmds + (concat + "^quote port \\|^type \\|^quote site \\|^chmod \\|^quote noop\\|" + "^quote pasv")) +;; Regexp to match commands for which efs-cmd-ok-msgs is a valid server +;; response for success. + +(defvar efs-passwd-cmds + "^quote pass \\|^quote acct \\|^quote site gpass ") +;; Regexp to match commands for sending passwords. +;; All text following (match-end 0) will be replaced by "Turtle Power!" + +(defvar efs-bytes-received-msgs + ;; Strictly a client response + "^[0-9]+ bytes ") +;; Regexp to match the reply from the FTP client that it has finished +;; receiving data. + +(defvar efs-server-confused-msgs + ;; ka9q uses this to indicate an incorrectly set transfer mode, and + ;; then does send a second completion code for the command. This does + ;; *not* conform to RFC959. + "^100 Warning: type is ") +;; Regexp to match non-standard response from the FTP server. This can +;; sometimes be the result of an incorrectly set transfer mode. In this case +;; we do not rely on the server to tell us when the data transfer is complete, +;; but check with the client. + +(defvar efs-good-msgs + (concat + ;; RFC959 compliant codes + "^2[01345][0-7] \\|" ; 2yz = positive completion reply + "^22[02-7] \\|" ; 221 = successful logout + ; (Sometimes get this with a timeout, + ; so treat as fatal.) + "^3[0-5][0-7] \\|" ; 3yz = positive intermediate reply + ;; client codes + "^[Hh]ash mark ")) +;; Response to indicate that the requested action was successfully completed. + +(defvar efs-failed-msgs + (concat + ;; RFC959 compliant codes + "^120 \\|" ; Service ready in nnn minutes. + "^450 \\|" ; File action not taken; file is unavailable, or busy. + "^452 \\|" ; Insufficient storage space on system. + "^5[0-5][0-7] \\|" ; Permanent negative reply codes. + ;; When clients tell us that a file doesn't exist, or can't access. + "^\\(local: +\\)?/[^ ]* +" + "\\([Nn]o such file or directory\\|[Nn]ot a plain file\\|" + "The file access permissions do not allow \\|Is a directory\\b\\)")) +;; Regexp to match responses for failed commands. However, the ftp connection +;; is assumed to be good. + +(defvar efs-fatal-msgs + (concat + ;; RFC959 codes + "^221 \\|" ; Service closing control connection. + "^421 \\|" ; Service not available. + "^425 \\|" ; Can't open data connection. + "^426 \\|" ; Connection closed, transfer aborted. + "^451 \\|" ; Requested action aborted, local error in processing. + ;; RFC959 non-compliant codes + "^552 Maximum Idle Time Exceded\\.$\\|" ; Hellsoft server uses this to + ; indicate a timeout. 552 is + ; supposed to be used for exceeded + ; storage allocation. Note that + ; they also misspelled the error + ; message. + ;; client problems + "^ftp: \\|^Not connected\\|^rcmd: \\|^No control connection\\|" + "^unknown host\\|: unknown host$\\|^lost connection\\|" + "^[Ss]egmentation fault\\|" + ;; Make sure that the "local: " isn't just a message about a file. + "^local: [^/]\\|" + ;; Gateways + "^iftp: cannot authenticate to server\\b" + )) +;; Regexp to match responses that something has gone drastically wrong with +;; either the client, server, or connection. We kill the ftp process, and start +;; anew. + +(defvar efs-unknown-response-msgs + "^[0-9][0-9][0-9] ") +;; Regexp to match server response codes that we don't understand. This +;; is tested after all the other regexp, so it can match everything. + +(defvar efs-pasv-msgs + ;; According to RFC959. + "^227 .*(\\([0-9]+,[0-9]+,[0-9]+,[0-9]+,[0-9]+,[0-9]+\\))$") +;; Matches the output of a PASV. (match-beginning 1) and (match-end 1) +;; must bracket the IP address and port. + +(defvar efs-syst-msgs "^215 \\|^210 ") +;; 215 is RFC959. Plan 9 FTP server returns a 210. 210 is not assigned in +;; RFC 959. +;; The plan 9 people tell me that they fixed this. -- sr 18/4/94 +;; Matches the output of a SYST. + +(defvar efs-mdtm-msgs + (concat + "^213 [0-9][0-9][0-9][0-9][0-9][0-9][0-9]" + "[0-9][0-9][0-9][0-9][0-9][0-9][0-9]$")) +;; Regexp to match the output of a quote mdtm command. + +(defvar efs-idle-msgs + "^200 [^0-9]+ \\([0-9]+\\)[^0-9]* max \\([0-9]+\\)") +;; Regexp to match the output of a SITE IDLE command. +;; Match 1 should refer to the current idle time, and match 2 the maximum +;; idle time. + +(defvar efs-write-protect-msgs "^532 ") ; RFC959 +;; Regexp to match a server ressponse to indicate that a STOR failed +;; because of insufficient write privileges. + +(defvar efs-hash-mark-msgs + "[hH]ash mark [^0-9]*\\([0-9]+\\)") +;; Regexp matching the FTP client's output upon doing a HASH command. + +(defvar efs-xfer-size-msgs + (concat + ;; UN*X + "^150 .* connection for .* (\\([0-9]+\\) bytes)\\|" + ;; Wollongong VMS server. + "^125 .* transfer started for .* (\\([0-9]+\\) bytes)\\|" + ;; TOPS-20 server + "^150 .* retrieve of .* ([0-9]+ pages?, \\([0-9]+\\) 7-bit bytes)")) +;; Regular expression used to determine the number of bytes +;; in a FTP transfer. The first (match-beginning #) which is non-nil is assumed +;; to give the size. + +(defvar efs-expand-dir-msgs "^550 \\([^: ]+\\):") +;; Regexp to match the error response from a "get ~sandy". +;; By parsing the error, we can get a quick expansion of ~sandy +;; According to RFC 959, should be a 550. + +(defvar efs-gateway-fatal-msgs + "No route to host\\|Connection closed\\|No such host\\|Login incorrect") +;; Regular expression matching messages from the rlogin / telnet process that +;; indicates that logging in to the gateway machine has gone wrong. + +(defvar efs-too-many-users-msgs + ;; The test for "two many" is because some people can't spell. + ;; I allow for up to two adjectives before "users". + (concat + "\\b[Tt][wo]o many\\( +[^ \n]+\\)?\\( +[^ \n]+\\)? +users\\b\\|" + "\\btry back later\\b")) +;; Regular expresion to match what servers output when there are too many +;; anonymous logins. It is assumed that this is part of a 530 or 530- response +;; to USER or PASS. + +;;;; ------------------------------------------------------------- +;;;; Buffer local FTP process variables +;;;; ------------------------------------------------------------- + +;;; Variables buffer local to the process buffers are +;;; named with the prefix efs-process- + +(defvar efs-process-q nil) +;; List of functions to be performed asynch. +(make-variable-buffer-local 'efs-process-q) + +(defvar efs-process-cmd-waiting nil) +;; Set to t if a process has a synchronous cmd waiting to execute. +;; In this case, it will allow the synch. cmd to run before returning to +;; the cmd queue. +(make-variable-buffer-local 'efs-process-cmd-waiting) + +(defvar efs-process-server-confused nil) +(make-variable-buffer-local 'efs-process-server-confused) + +(defvar efs-process-cmd nil) +;; The command currently being executed, as a string. +(make-variable-buffer-local 'efs-process-cmd) + +(defvar efs-process-xfer-size 0) +(make-variable-buffer-local 'efs-process-xfer-size) + +(defvar efs-process-umask nil) +;; nil if the umask hash not been set +;; an integer (the umask) if the umask has been set +(make-variable-buffer-local 'efs-process-umask) + +(defvar efs-process-idle-time nil) +;; If non-nil, the idle time of the server in seconds. +(make-variable-buffer-local 'efs-process-idle-time) + +(defvar efs-process-busy nil) +(make-variable-buffer-local 'efs-process-busy) + +(defvar efs-process-result-line "") +(make-variable-buffer-local 'efs-process-result-line) + +(defvar efs-process-result nil) +(make-variable-buffer-local 'efs-process-result) + +(defvar efs-process-result-cont-lines "") +(make-variable-buffer-local 'efs-process-result-cont-lines) + +(defvar efs-process-msg "") +(make-variable-buffer-local 'efs-process-msg) + +(defvar efs-process-nowait nil) +(make-variable-buffer-local 'efs-process-nowait) + +(defvar efs-process-string "") +(make-variable-buffer-local 'efs-process-string) + +(defvar efs-process-continue nil) +(make-variable-buffer-local 'efs-process-continue) + +(defvar efs-process-hash-mark-count 0) +(make-variable-buffer-local 'efs-process-hash-mark-count) + +(defvar efs-process-hash-mark-unit nil) +(make-variable-buffer-local 'efs-process-hash-mark-unit) + +(defvar efs-process-last-percent -1) +(make-variable-buffer-local 'efs-process-last-percent) + +(defvar efs-process-host nil) +(make-variable-buffer-local 'efs-process-host) + +(defvar efs-process-user nil) +(make-variable-buffer-local 'efs-process-user) + +(defvar efs-process-host-type nil) +;; Holds the host-type as a string, for showing it on the mode line. +(make-variable-buffer-local 'efs-process-host-type) + +(defvar efs-process-xfer-type nil) +;; Set to one of 'ascii, 'ebcdic, 'image, 'tenex, or nil to indicate +;; the current setting of the transfer type for the connection. nil means +;; that we don't know. +(make-variable-buffer-local 'efs-process-xfer-type) + +(defvar efs-process-client-altered-xfer-type nil) +;; Sometimes clients alter the xfer type, such as doing +;; an ls it is changed to ascii. If we are using quoted commands +;; to do xfers the client doesn't get a chance to set it back. +(make-variable-buffer-local 'efs-process-client-altered-xfer-type) + +(defvar efs-process-prompt-regexp nil) +;; local value of prompt of FTP client. +(make-variable-buffer-local 'efs-process-prompt-regexp) + +(defvar efs-process-cmd-counter 0) +;; Counts FTP commands, mod 16. +(make-variable-buffer-local 'efs-process-cmd-counter) + +;;;; ------------------------------------------------------------ +;;;; General Internal Variables. +;;;; ------------------------------------------------------------ + +;;; For the byte compiler +;; +;; These variables are usually unbound. We are just notifying the +;; byte compiler that we know what we are doing. + +(defvar bv-length) ; getting file versions. +(defvar default-file-name-handler-alist) ; for file-name-handler-alist +(defvar efs-completion-dir) ; for file name completion predicates +(defvar dired-directory) ; for default actions in interactive specs +(defvar dired-local-variables-file) ; for inhibiting child look ups +(defvar dired-in-query) ; don't clobber dired queries with stat messages +(defvar after-load-alist) ; in case we're in emacs 18. +(defvar comint-last-input-start) +(defvar comint-last-input-end) +(defvar explicit-shell-file-name) + +;;; fluid vars + +(defvar efs-allow-child-lookup t) +;; let-bind to nil, if want to inhibit child lookups. + +(defvar efs-nested-cmd nil) +;; let-bound to t, when a cmd is executed by a cont or pre-cont. +;; Such cmds will never end by looking at the next item in the queue, +;; if they are run synchronously, but rely on their calling function +;; to do this. + +;;; polling ftp buffers + +(defvar efs-ftp-buffer-poll-time 300 + "Period, in seconds, which efs will poll ftp buffers for activity. +Used for expiring \(killing\) inactive ftp buffers.") + +(defconst efs-ftp-buffer-alist nil) +;; alist of ftp buffers, and the total number of seconds that they +;; have been idle. + +;;; load extensions + +(defvar efs-load-lisp-extensions '(".elc" ".el" "") + "List of extensions to try when loading lisp files.") + +;;; mode-line + +(defvar efs-mode-line-string "") +;; Stores the string that efs displays on the mode line. + +;;; data & temporary buffers + +(defvar efs-data-buffer-name " *ftp data*") +;; Buffer name to hold directory listing data received from ftp process. + +(defvar efs-data-buffer-name-2 " *ftp data-2*") +;; A second buffer name in which to hold directory listings. +;; Used for listings which are made during another directory listing. + +;;; process names + +(defvar efs-ctime-process-name-format "*efs ctime %s*") +;; Passed to format with second arg the host name. + +;;; For temporary files. + +;; This is a list of symbols. +(defconst efs-tmp-name-files ()) +;; Here is where these symbols live: +(defconst efs-tmp-name-obarray (make-vector 7 0)) +;; We put our version of the emacs PID here: +(defvar efs-pid nil) + +;;; For abort-recursive-edit + +(defvar efs-abort-recursive-edit-data nil) +(defvar efs-abort-recursive-edit-delay 5) +;; Number of seconds after which efs-abort-recursive-edit-and-then +;; will decide not to runs its sentinel. The assumption is that something +;; went wrong. + +;;; hashtables (Use defconst's to clobber any user silliness.) + +(defconst efs-files-hashtable (efs-make-hashtable 97)) +;; Hash table for storing directories and their respective files. + +(defconst efs-expand-dir-hashtable (efs-make-hashtable)) +;; Hash table of tilde expansions for remote directories. + +(defconst efs-ls-converter-hashtable (efs-make-hashtable 37)) +;; Hashtable for storing functions to convert listings from one +;; format to another. Keys are the required switches, and the values +;; are alist of the form ((SWITCHES . CONVERTER)...) where is SWITCHES +;; are the listing switches for the original listing, and CONVERTER is a +;; function of one-variable, the listing-type, to do the conversion +;; on data in the current buffer. SWITCHES is either a string, or nil. +;; nil means that the listing can be converted from cache in +;; efs-files-hashtable, a string from cache in efs-ls-cache. For the latter, +;; listings with no switches (dumb listings), represent SWITCHES as a string +;; consisting only of the ASCII null character. + +;;; cache variables (Use defconst's to clobber any user sillines.) + +(defconst efs-ls-cache nil + "List of results from efs-ls. +Each entry is a list of four elements, the file listed, the switches used +\(nil if none\), the listing string, and whether this string has already been +parsed.") + +(defvar efs-ls-uncache nil) +;; let-bind this to t, if you want to be sure that efs-ls will replace any +;; cache entries. + +;; This is a cache to see if the user has changed +;; completion-ignored-extensions. +(defconst efs-completion-ignored-extensions completion-ignored-extensions + "This variable is internal to efs. Do not set. +See completion-ignored-extensions, instead.") + +;; We cache the regexp we use for completion-ignored-extensions. This +;; saves building a string every time we do completion. String construction +;; is costly in emacs. +(defconst efs-completion-ignored-pattern + (mapconcat (function + (lambda (s) (if (stringp s) + (concat (regexp-quote s) "$") + "/"))) ; / never in filename + efs-completion-ignored-extensions + "\\|") + "This variable is internal to efs. Do not set. +See completion-ignored-extensions, instead.") + +(defvar efs-system-fqdn nil + "Cached value of the local systems' fully qualified domain name.") + +;;; The file-type-alist + +;; efs-file-type-alist is an alist indexed by host-type +;; which stores data on how files are structured on the given +;; host-type. Each entry is a list of three elements. The first is the +;; definition of a `byte', the second the native character representation, +;; and the third, the file structure. +;; +;; Meanings of the symbols: +;; ------------------------ +;; The byte symbols: +;; 8-bit = bytes of 8-bits +;; 36-bit-wa = 36-bit word aligned. Precisely, the addressing unit is that +;; of a PDP-10 using the "<440700,,0> byte pointer". +;; +;; The native character set symbols: +;; 8-ascii = 8-bit NVT-ASCII +;; 7-ascii = 7-bit ascii as on a PDP-10 +;; ebcdic = EBCDIC as on an IBM mainframe +;; lispm = the native character set on a lispm (Symbolics and LMI) +;; mts = native character representation in the Michigan Terminal System +;; (which runs on IBM and Amdal mainframes), similar to ebcdic +;; +;; The file structure symbols: +;; +;; file-nl = data is stored as a contiguous sequence of data bytes +;; with EOL denoted by . +;; file-crlf = data is stored as a contiguous sequence of data bytes +;; with EOL denoted by +;; record = data is stored as a sequence of records +;; file-lispm = data as stored on a lispm. i.e. a sequence of bits +;; with EOL denoted by character code 138 (?) +;; +;; If we've messed anything up here, please let us know. + +(defvar efs-file-type-alist + '((unix . (8-bit 8-ascii file-nl)) + (sysV-unix . (8-bit 8-ascii file-nl)) + (bsd-unix . (8-bit 8-ascii file-nl)) + (apollo-unix . (8-bit 8-ascii file-nl)) + (dumb-apollo-unix . (8-bit 8-ascii file-nl)) + (dumb-unix . (8-bit 8-ascii file-nl)) + (super-dumb-unix . (8-bit 8-ascii file-nl)) + (guardian . (8-bit ascii file-nl)) + (plan9 . (8-bit 8-ascii file-nl)) + (dos . (8-bit 8-ascii file-crlf)) + (ms-unix . (8-bit 8-ascii file-crlf)) + (netware . (8-bit 8-ascii file-crlf)) + (os2 . (8-bit 8-ascii file-crlf)) + (tops-20 . (36-bit-wa 7-ascii file-crlf)) + (mpe . (8-bit 8-ascii record)) + (mvs . (8-bit ebcdic record)) + (cms . (8-bit ebcdic record)) + (cms-knet . (8-bit ebcdic record)) + (mts . (8-bit mts record)) ; mts seems to have its own char rep. + ; Seems to be close to ebcdic, but not the same. + (dos-distinct . (8-bit 8-ascii file-crlf)) + (ka9q . (8-bit 8-ascii file-crlf)) + (vms . (8-bit 8-ascii record)) ; The mysteries of VMS's RMS. + (hell . (8-bit 8-ascii file-crlf)) + (vos . (8-bit 8-ascii record)) + (ti-explorer . (8-bit lispm file-lispm)) ; lispms use a file structure, but + ; use an out of range char to + ; indicate EOL. + (ti-twenex . (8-bit lispm file-lispm)) + (nos-ve . (8-bit 8-ascii record)) + (coke . (8-bit 8-ascii file-nl)) ; only support 8-bit beverages + (nil . (8-bit 8-ascii file-nl)))) ; the local host + +;;; Status messages + +(defvar efs-last-message-time -86400) ; yesterday +;; The time of the last efs status message. c.f. efs-message-interval + +;;; For handling dir listings + +;; This MUST match all the way to to the start of the filename. +;; This version corresponds to what dired now uses (sandy, 14.1.93) +(defvar efs-month-and-time-regexp + (concat + " \\([0-9]+\\) +" ; file size + "\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|June?\\|July?\\|Aug\\|Sep\\|Oct" + ; June and July are for HP-UX 9.0 + "\\|Nov\\|Dec\\) \\([ 0-3][0-9]\\)\\(" + " [012][0-9]:[0-6][0-9] \\|" ; time + " [12][90][0-9][0-9] \\|" ; year on IRIX, NeXT, SunOS, ULTRIX, Apollo + ; HP-UX, A/UX + " [12][90][0-9][0-9] \\)" ; year on AIX + )) + +(defvar efs-month-alist + '(("Jan" . 1) ("Feb". 2) ("Mar" . 3) ("Apr" . 4) ("May" . 5) ("Jun" . 6) + ("June" . 6) ("Jul" . 7) ("July" . 7) ("Aug" . 8) ("Sep" . 9) ("Oct" . 10) + ("Nov" . 11) ("Dec" . 12))) + +;; Matches the file modes, link number, and owner string. +;; The +/- is for extended file access permissions. +(defvar efs-modes-links-owner-regexp + (concat + "\\([^ ][-r][-w][^ ][-r][-w][^ ][-r][-w][^ ]\\)[-+]? *\\([0-9]+\\)" + " +\\([^ ]+\\) ")) + +;;;; --------------------------------------------------------------- +;;;; efs-dired variables +;;;; --------------------------------------------------------------- + +;; These variables must be here, instead of in efs-dired.el, because +;; the efs-HOST-TYPE.el files need to add to it. +(defvar efs-dired-re-exe-alist nil + "Association list of regexps which match file lines of executable files.") + +(defvar efs-dired-re-dir-alist nil + "Association list of regexps which match file lines of subdirectories.") + +(defvar efs-dired-host-type nil + "Host type of a dired buffer. \(buffer local\)") +(make-variable-buffer-local 'efs-dired-host-type) + +(defvar efs-dired-listing-type nil + "Listing type of a dired buffer. \(buffer local\)") +(make-variable-buffer-local 'efs-dired-listing-type) + +(defvar efs-dired-listing-type-string nil) +(make-variable-buffer-local 'efs-dired-listing-type-string) + +;;;; ------------------------------------------------------------- +;;;; New error symbols. +;;;; ------------------------------------------------------------- + +(put 'ftp-error 'error-conditions '(ftp-error file-error error)) +;; (put 'ftp-error 'error-message "FTP error") + + +;;;; ============================================================= +;;;; >3 +;;;; Utilities +;;;; ============================================================= + +;;; ------------------------------------------------------------------- +;;; General Macros (Make sure that macros are defined before they're +;;; used, for the byte compiler. +;;; ------------------------------------------------------------------- + +(defmacro efs-kbd-quit-protect (proc &rest body) + ;; When an efs function controlling an FTP connection gets a kbd-quit + ;; this tries to make sure that everything unwinds consistently. + (let ((temp (make-symbol "continue"))) + (list 'let + (list '(quit-flag nil) + '(inhibit-quit nil) + (list temp t)) + (list + 'while temp + (list 'setq temp nil) + (list + 'condition-case nil + (cons 'progn + body) + (list 'quit + (list 'setq temp + (list 'efs-kbd-quit-protect-cover-quit proc)))))))) + +(defun efs-kbd-quit-protect-cover-quit (proc) + ;; This function exists to keep the macro expansion of the + ;; efs-kbd-quit-protect down to a reasonable size. + (let ((pop-up-windows t) + (buff (get-buffer (process-buffer proc))) + res) + (if (save-window-excursion + (if buff + (progn + (pop-to-buffer buff) + (goto-char (point-max)) + (recenter (- (window-height) + 2)))) + (setq res (efs-kill-ftp-buffer-with-prompt proc buff))) + (progn + (if (eq res 0) + (if (eq (selected-window) + (minibuffer-window)) + (efs-abort-recursive-edit-and-then + (function + (lambda (buff) + (if (get-buffer buff) + (display-buffer buff)))) + buff) + (if (get-buffer buff) + (display-buffer buff)) + (signal 'quit nil)) + (if (eq (selected-window) (minibuffer-window)) + (abort-recursive-edit) + (signal (quote quit) nil))) + nil) + (sit-for 0) + (message "Waiting on %s..." (or (car (efs-parse-proc-name proc)) + "a whim")) + t))) + +(put 'efs-kbd-quit-protect 'lisp-indent-hook 1) + +(defmacro efs-save-buffer-excursion (&rest forms) + "Execute FORMS, restoring the current buffer afterwards. +Unlike, save-excursion, this does not restore the point." + (let ((temp (make-symbol "saved-buff"))) + (list 'let + (list (list temp '(current-buffer))) + (list 'unwind-protect + (cons 'progn forms) + (list 'condition-case nil + (list 'set-buffer temp) + '(error nil)))))) + +(put 'efs-save-buffer-excursion 'lisp-indent-hook 0) + +(defmacro efs-unquote-dollars (string) + ;; Unquote $$'s to $'s in STRING. + (` (let ((string (, string)) + (start 0) + new) + (while (string-match "\\$\\$" string start) + (setq new (concat new (substring + string start (1+ (match-beginning 0)))) + start (match-end 0))) + (if new + (concat new (substring string start)) + string)))) + +(defmacro efs-get-file-part (path) + ;; Given PATH, return the file part used for looking up the file's entry + ;; in a hashtable. + ;; This need not be the same thing as file-name-nondirectory. + (` (let ((file (file-name-nondirectory (, path)))) + (if (string-equal file "") + "." + file)))) + +(defmacro efs-ftp-path-macro (path) + ;; Just a macro version of efs-ftp-path, for speed critical + ;; situations. Could use (inline ...) instead, but not everybody + ;; uses the V19 byte-compiler. Also, doesn't call efs-save-match-data, + ;; but assumes that the calling function does it. + (` + (let ((path (, path))) + (or (string-equal path efs-ftp-path-arg) + (setq efs-ftp-path-res + (and (string-match efs-path-regexp path) + (let ((host (substring path (match-beginning 2) + (match-end 2))) + (user (and (match-beginning 1) + (substring path (match-beginning 1) + (1- (match-end 1))))) + (rpath (substring path (1+ (match-end 2))))) + (list (if (string-equal host "") + (setq host (system-name)) + host) + (or user (efs-get-user host)) + rpath))) + ;; Set this last, in case efs-get-user calls this function, + ;; which would modify an earlier setting. + efs-ftp-path-arg path)) + efs-ftp-path-res))) + +(defmacro efs-canonize-switches (switches) + ;; Converts a switches string, into a lexographically ordered string, + ;; omitting - and spaces. Should we remove duplicate characters too? + (` (if (, switches) + (mapconcat + 'char-to-string + (sort (delq ?- (delq ?\ (mapcar 'identity (, switches)))) '<) "") + ;; For the purpose of interning in a hashtable, represent the nil + ;; switches, as a string consisting of the ascii null character. + (char-to-string 0)))) + +(defmacro efs-canonize-file-name (fn) + ;; Canonizes the case of file names. + (` (let ((parsed (efs-ftp-path (, fn)))) + (if parsed + (let ((host (car parsed))) + (if (memq (efs-host-type host) efs-case-insensitive-host-types) + (downcase (, fn)) + (format efs-path-format-string (nth 1 parsed) (downcase host) + (nth 2 parsed)))) + (, fn))))) + +(defmacro efs-get-files-hashtable-entry (fn) + (` (efs-get-hash-entry (efs-canonize-file-name (, fn)) efs-files-hashtable))) + +;;;; ------------------------------------------------------------ +;;;; Utility Functions +;;;; ------------------------------------------------------------ + +(defun efs-kill-ftp-buffer-with-prompt (proc buffer) + ;; Does a 3-way prompt to kill a ftp PROC and BUFFER. + ;; Returns t if buffer was killed, 0 if only process, nil otherwise. + (let ((inhibit-quit t) + (cursor-in-echo-area t) + char) + (message + (if efs-debug-ftp-connection + "Kill ftp process and buffer (y[es], n[o], c[lose], d[ebug] ) " + "Kill ftp process and buffer? (y or n, c to only close process) ")) + (setq char (read-char)) + (prog1 + (cond + ((memq char '(?y ?Y ?\ )) + (set-process-sentinel proc nil) + (condition-case nil + (kill-buffer buffer) + (error nil)) + t) + ((memq char '(?c ?C)) + (set-process-sentinel proc nil) + (condition-case nil + (save-excursion + (set-buffer buffer) + (setq efs-process-busy nil + efs-process-q nil) + (delete-process proc)) + (error nil)) + 0) + ((memq char '(?n ?N)) + (message "") + nil) + ((and efs-debug-ftp-connection + (memq char '(?d ?D))) + (condition-case nil + (save-excursion + (set-buffer buffer) + (setq efs-process-busy nil + efs-process-q nil)) + (error nil)) + 0) + (t + (message + (if efs-debug-ftp-connection + "Type one of y, n, c or d." + "Type one of y, n or c.")) + (ding) + (sit-for 1) + (setq quit-flag nil) + (efs-kill-ftp-buffer-with-prompt proc buffer)))))) + +(defun efs-barf-if-not-directory (directory) + ;; Signal an error if DIRECTORY is not one. + (or (file-directory-p directory) + (signal 'file-error + (list "Opening directory" + (if (file-exists-p directory) + "not a directory" + "no such file or directory") + directory)))) + +(defun efs-call-cont (cont &rest args) + "Call the function specified by CONT. +CONT can be either a function or a list of a function and some args. +The first parameters passed to the function will be ARGS. The remaining +args will be taken from CONT if a list was passed." + (if cont + (let ((efs-nested-cmd t)) ; let-bound so that conts don't pop any queues + (efs-save-buffer-excursion + (if (and (listp cont) + (not (eq (car cont) 'lambda))) + (apply (car cont) (append args (cdr cont))) + (apply cont args)))))) + +(defun efs-replace-path-component (fullpath path) + "For FULLPATH matching efs-path-regexp replace the path component with PATH." + (efs-save-match-data + (if (string-match efs-path-root-regexp fullpath) + (concat (substring fullpath 0 (match-end 0)) path) + path))) + +(defun efs-abort-recursive-edit-and-then (fun &rest args) + ;; Does an abort-recursive-edit, and runs fun _after_ emacs returns to + ;; top level. + (if (get-process "efs-abort-recursive-edit") + ;; Don't queue these things. Clean them out. + (delete-process "efs-abort-recursive-edit")) + (or efs-suppress-abort-recursive-edit-and-then + (progn + (setq efs-abort-recursive-edit-data (cons (nth 1 (current-time)) + (cons fun args))) + (condition-case nil + (set-process-sentinel + (let ((default-directory exec-directory) + (process-connection-type nil)) + (start-process "efs-abort-recursive-edit" nil "sleep" "0")) + (function + (lambda (proc string) + (let ((data efs-abort-recursive-edit-data)) + (setq efs-abort-recursive-edit-data) + (if (and data + (integerp (car data)) + (<= (- (nth 1 (current-time)) (car data)) + efs-abort-recursive-edit-delay)) + (apply (nth 1 data) (nthcdr 2 data))))))) + (error nil)))) + (abort-recursive-edit)) + +(defun efs-occur-in-string (char string) + ;; Return the number of occurrences of CHAR in STRING. + (efs-save-match-data + (let ((regexp (regexp-quote (char-to-string char))) + (count 0) + (start 0)) + (while (string-match regexp string start) + (setq start (match-end 0) + count (1+ count))) + count))) + +(defun efs-parse-proc-name (proc) + ;; Parses the name of process to return a list \(host user\). + (efs-save-match-data + (let ((name (process-name proc))) + (and name + (string-match "^\\*ftp \\([^@]*\\)@\\([^*]+\\)\\*$" name) + (list (substring name (match-beginning 2) (match-end 2)) + (substring name (match-beginning 1) (match-end 1))))))) + +;;;; ------------------------------------------------------------ +;;;; Of Geography, connectivity, and the internet... Gateways. +;;;; ------------------------------------------------------------ + +(defun efs-use-gateway-p (host &optional opaque-p) +;; Returns whether to access this host via a gateway. +;; Returns the gateway type as a symbol. See efs-gateway-type . +;; If optional OPAQUE-P is non-nil, only returns non-nil if the gateway +;; type is in the list efs-opaque-gateways . + (and efs-gateway-type + host ;local host is nil + (efs-save-match-data + (and (not (string-match efs-ftp-local-host-regexp host)) + (let ((type (car efs-gateway-type))) + (if opaque-p + (and (memq type efs-opaque-gateways) type) + type)))))) + +(defun efs-local-to-gateway-filename (filename &optional reverse) + ;; Converts a FILENAME on the local host to its name on the gateway, + ;; using efs-gateway-mounted-dirs-alist. If REVERSE is non-nil, does just + ;; that. If the there is no corresponding name because non of its parent + ;; directories are mounted, returns nil. + (if efs-gateway-mounted-dirs-alist + (let ((len (length filename)) + (alist efs-gateway-mounted-dirs-alist) + result elt elt-len) + (if reverse + (while (setq elt (car alist)) + (if (and (>= len (setq elt-len (length (cdr elt)))) + (string-equal (cdr elt) (substring filename 0 elt-len))) + (setq result (concat (car elt) + (substring filename elt-len)) + alist nil) + (setq alist (cdr alist)))) + (while (setq elt (car alist)) + (if (and (>= len (setq elt-len (length (car elt)))) + (string-equal (car elt) (substring filename 0 elt-len))) + (setq result (concat (cdr elt) + (substring filename elt-len)) + alist nil) + (setq alist (cdr alist))))) + result))) + +;;; ------------------------------------------------------------ +;;; Enhanced message support. +;;; ------------------------------------------------------------ + +(defun efs-message (fmt &rest args) + "Output the given message, truncating to the size of the minibuffer window." + (let ((msg (apply (function format) fmt args)) + (max (window-width (minibuffer-window)))) + (if (>= (length msg) max) + (setq msg (concat "> " (substring msg (- 3 max))))) + (message "%s" msg))) + +(defun efs-message-p () + ;; Returns t, if efs is allowed to display a status message. + (not + (or (and (boundp 'dired-in-query) dired-in-query) + (boundp 'search-message) + cursor-in-echo-area + (and (/= efs-message-interval 0) + (let ((diff (- efs-last-message-time + (setq efs-last-message-time + (nth 1 (current-time)))))) + (and + (> diff (- efs-message-interval)) + (< diff 0))))))) ; in case the clock wraps. + +(efs-define-fun efs-relativize-filename (file &optional dir new) + "Abbreviate the given filename relative to DIR . +If DIR is nil, use the value of `default-directory' for the currently selected +window. If the optional parameter NEW is given and the +non-directory parts match, only return the directory part of the file." + (let* ((dir (or dir (save-excursion + (set-buffer (window-buffer (selected-window))) + default-directory))) + (dlen (length dir)) + (result file)) + (and (> (length file) dlen) + (string-equal (substring file 0 dlen) dir) + (setq result (substring file dlen))) + (and new + (string-equal (file-name-nondirectory result) + (file-name-nondirectory new)) + (or (setq result (file-name-directory result)) + (setq result "./"))) + (abbreviate-file-name result))) + +;;; ------------------------------------------------------------ +;;; Temporary file location and deletion... +;;; ------------------------------------------------------------ + +(defun efs-get-pid () + ;; Half-hearted attempt to get the current process's id. + (setq efs-pid (substring (make-temp-name "") 1))) + +(defun efs-make-tmp-name (host1 host2) + ;; Returns the name of a new temp file, for moving data between HOST1 + ;; and HOST2. This temp file must be directly accessible to the + ;; FTP client connected to HOST1. Using nil for either HOST1 or + ;; HOST2 means the local host. The return value is actually a list + ;; whose car is the name of the temp file wrto to the local host + ;; and whose cdr is the name of the temp file wrto to the host + ;; on which the client connected to HOST1 is running. If the gateway + ;; is only accessible by FTP, then the car of this may be in efs extended + ;; file name syntax. + (let ((pid (or efs-pid (efs-get-pid))) + (start ?a) + file entry template rem-template template-len) + ;; Compute the templates. + (if (null (and host1 (efs-use-gateway-p host1 t))) + ;; file must be local + (if (null (and host2 (efs-use-gateway-p host2 t))) + (setq template efs-tmp-name-template) + (setq template (or (efs-local-to-gateway-filename + efs-gateway-tmp-name-template t) + efs-tmp-name-template))) + ;; file must be on the gateway -- make sure that the gateway + ;; configuration is sensible. + (efs-save-match-data + (or (string-match efs-ftp-local-host-regexp efs-gateway-host) + (error "Gateway %s must be directly ftp accessible." + efs-gateway-host))) + (setq rem-template efs-gateway-tmp-name-template + template (or (efs-local-to-gateway-filename + efs-gateway-tmp-name-template t) + (format efs-path-format-string + (efs-get-user efs-gateway-host) + efs-gateway-host + efs-gateway-tmp-name-template)) + template-len (length template))) + ;; Compute a new file name. + (while (let (efs-verbose) + (setq file (format "%s%c%s" template start pid) + entry (intern file efs-tmp-name-obarray)) + (or (memq entry efs-tmp-name-files) + (file-exists-p file))) + (if (> (setq start (1+ start)) ?z) + (progn + (setq template (concat template "X")) + (setq start ?a)))) + (setq efs-tmp-name-files + (cons entry efs-tmp-name-files)) + (if rem-template + (cons file (concat rem-template (substring file template-len))) + (cons file file)))) + +(defun efs-del-tmp-name (temp) + ;; Deletes file TEMP, a string. + (setq efs-tmp-name-files + (delq (intern temp efs-tmp-name-obarray) + efs-tmp-name-files)) + (condition-case () + (let (efs-verbose) + (delete-file temp)) + (error nil))) + + +;;;; ============================================================== +;;;; >4 +;;;; Hosts, Users, Accounts, and Passwords +;;;; ============================================================== +;;; +;;; A lot of the support for this type of thing is in efs-netrc.el. + +;;;; ------------------------------------------------------------ +;;;; Password support. +;;;; ------------------------------------------------------------ + +(defun efs-lookup-passwd (host user) + ;; Look up the password for HOST and USER. + (let ((ent (efs-get-host-user-property host user 'passwd))) + (and ent (efs-code-string ent)))) + +(defun efs-system-fqdn () + "Returns a fully qualified domain name for the current host, if possible." + (or efs-system-fqdn + (setq efs-system-fqdn + (let ((sys (system-name))) + (if (string-match "\\." sys) + sys + (if efs-nslookup-program + (let ((proc (let ((default-directory exec-directory) + (process-connection-type nil)) + (start-process " *nslookup*" " *nslookup*" + efs-nslookup-program sys))) + (res sys) + (n 0)) + (process-kill-without-query proc) + (save-excursion + (set-buffer (process-buffer proc)) + (let ((quit-flag nil) + (inhibit-quit nil)) + (if efs-nslookup-threshold + (progn + (while (and (memq (process-status proc) + '(run open)) + (< n efs-nslookup-threshold)) + (accept-process-output) + (setq n (1+ n))) + (if (>= n efs-nslookup-threshold) + (progn + (with-output-to-temp-buffer "*Help*" + (princ (format "\ +efs is unable to determine a fully qualified domain name +for the local host to send as an anonymous ftp password. + +The function `system-name' is not returning a fully qualified +domain name. An attempt to obtain a fully qualified domain name +with `efs-nslookup-program' (currently set to \"%s\") has +elicited no response from that program. Consider setting +`efs-generate-anonymous-password' to an email address for anonymous +ftp passwords. + +For more information see the documentation (use C-h v) for the +variables `efs-nslookup-program' and `efs-nslookup-threshold'." + efs-nslookup-program))) + (error "No response from %s" + efs-nslookup-program)))) + (while (memq (process-status proc) '(run open)) + (accept-process-output proc))) + (goto-char (point-min)) + (if (re-search-forward + (format "^Name: *\\(%s\\.[^ \n\t]+\\)" + sys) nil t) + (setq res (buffer-substring + (match-beginning 1) + (match-end 1))) + (kill-buffer (current-buffer))))) + res) + sys)))))) + +(defun efs-passwd-unique-list (alist) + ;; Preserving the relative order of ALIST, remove all entries with duplicate + ;; cars. + (let (result) + (while alist + (or (assoc (car alist) result) + (setq result (cons (car alist) result))) + (setq alist (cdr alist))) + (nreverse result))) + +(defun efs-get-passwd-list (user host) + ;; Returns an alist of the form '((pass host user) ...). + ;; The order is essentially arbitrary, except that entries with user + ;; equal to USER will appear first. Followed by entries with host equal to + ;; HOST. Also, there will be no entries with duplicate values of pass. + (efs-parse-netrc) + (let* ((user-template (concat "/" user)) + (ulen (length user-template)) + (hlen (length host)) + primaries secondaries tertiaries) + (efs-save-match-data + (efs-map-hashtable + (function + (lambda (key passwd) + (cond ((null passwd) nil) + ((and (> (length key) ulen) + (string-equal user-template + (substring key (- ulen)))) + (setq primaries (cons (list (efs-code-string passwd) + (substring key 0 (- ulen)) + (substring user-template 1)) + primaries))) + ((and (> (length key) hlen) + (string-equal host (substring key 0 hlen)) + (memq (aref key hlen) '(?/ ?.))) + (if (string-match "/" key hlen) + (setq secondaries + (cons (list (efs-code-string passwd) + (substring key 0 (match-beginning 0)) + (substring key (match-end 0))) + secondaries)))) + ((string-match "/" key) + (setq tertiaries + (cons (list (efs-code-string passwd) + (substring key 0 (match-beginning 0)) + (substring key (match-end 0))) + tertiaries)))))) + efs-host-user-hashtable 'passwd)) + (efs-passwd-unique-list (nconc primaries secondaries tertiaries)))) + +(defun efs-get-passwd (host user) + "Given a HOST and USER, return the FTP password, prompting if it was not +previously set." + (efs-parse-netrc) + + ;; look up password in the hash table first; user might have overriden the + ;; defaults. + (cond ((efs-lookup-passwd host user)) + + ;; see if default user and password set from the .netrc file. + ((and (stringp efs-default-user) + efs-default-password + (string-equal user efs-default-user)) + (copy-sequence efs-default-password)) + + ;; anonymous ftp password is handled specially since there is an + ;; unwritten rule about how that is used on the Internet. + ((and (efs-anonymous-p user) + efs-generate-anonymous-password) + (if (stringp efs-generate-anonymous-password) + (copy-sequence efs-generate-anonymous-password) + (concat (user-login-name) "@" (efs-system-fqdn)))) + + ;; see if same user has logged in to other hosts; if so then prompt + ;; with the password that was used there. + (t + (let (others defaults passwd) + (unwind-protect + (progn + (setq others (efs-get-passwd-list user host) + defaults (mapcar + (function + (lambda (x) + (cons + (format + "Passwd for %s@%s (same as %s@%s): " + user host (nth 2 x) (nth 1 x)) + (car x)))) + others)) + (setq passwd + (read-passwd + (or defaults + (format "Password for %s@%s: " user host))))) + (while others + (fillarray (car (car others)) 0) + (setq others (cdr others)))) + (or (null passwd) + (and efs-high-security-hosts + (efs-save-match-data + (string-match efs-high-security-hosts + (format "%s@%s" user host)))) + (efs-set-passwd host user passwd)) + passwd)))) + +;;;; ------------------------------------------------------------ +;;;; Account support +;;;; ------------------------------------------------------------ + +(defun efs-get-account (host user &optional minidisk really) + "Given a HOST, USER, and optional MINIDISK return the FTP account password. +If the optional REALLY argument is given, prompts the user if it can't find +one." + (efs-parse-netrc) + (let ((account (if minidisk + (efs-get-hash-entry + (concat (downcase host) "/" user "/" minidisk) + efs-minidisk-hashtable + (memq (efs-host-type host) + efs-case-insensitive-host-types)) + (efs-get-host-user-property host user 'account)))) + (if account + (efs-code-string account) + ;; Do we really want to send the default-account passwd for all + ;; minidisks? + (if (and (stringp efs-default-user) + (string-equal user efs-default-user) + efs-default-account) + efs-default-account + (and really + (let ((acct + (read-passwd + (if minidisk + (format + "Write access password for minidisk %s on %s@%s: " + minidisk user host) + (format + "Account password for %s@%s: " user host))))) + (or (and efs-high-security-hosts + (efs-save-match-data + efs-high-security-hosts + (format "%s@%s" user host))) + (efs-set-account host user minidisk acct)) + acct)))))) + +;;;; ------------------------------------------------------------- +;;;; Special classes of users. +;;;; ------------------------------------------------------------- + +(defun efs-anonymous-p (user) + ;; Returns t if USER should be treated as an anonymous FTP login. + (let ((user (downcase user))) + (or (string-equal user "anonymous") (string-equal user "ftp")))) + + +;;;; ============================================================= +;;;; >5 +;;;; FTP client process, and server responses +;;;; ============================================================= + +;;;; --------------------------------------------------------- +;;;; Support for asynch process queues. +;;;; --------------------------------------------------------- + +(defun efs-add-to-queue (host user item) + "To the end of the command queue for HOST and USER, adds ITEM. +Does nothing if there is no process buffer for HOST and USER." + (let ((buff (efs-ftp-process-buffer host user))) + (if (get-buffer buff) + (save-excursion + (set-buffer buff) + (setq efs-process-q + (nconc efs-process-q (list item))))))) + +;;;; ------------------------------------------------------- +;;;; Error recovery for the process filter. +;;;; ------------------------------------------------------- + +;;; Could make this better, but it's such an unlikely error to hit. +(defun efs-process-scream-and-yell (line) + (let* ((buff (buffer-name (current-buffer))) + (host (and (string-match "@\\(.*\\)\\*$" buff) + (substring buff (match-beginning 1) (match-end 1))))) + (with-output-to-temp-buffer "*Help*" + (princ + (concat + "efs is unable to identify the following reply code +from the ftp server " host ":\n\n" line " + +Please send a bug report to ange@hplb.hpl.hp.com. +In your report include a transcript of your\n" +buff " buffer.")))) + (error "Unable to identify server code.")) + +(defun efs-error (host user msg) + "Signal \'ftp-error for the FTP connection for HOST and USER. +The error gives the string MSG as text. The process buffer for the FTP +is popped up in another window." + (let ((cur (selected-window)) + (pop-up-windows t) + (buff (get-buffer (efs-ftp-process-buffer host user)))) + (if buff + (progn + (pop-to-buffer buff) + (goto-char (point-max)) + (select-window cur)))) + (signal 'ftp-error (list (format "FTP Error: %s" msg)))) + +;;;; -------------------------------------------------------------------- +;;;; Process filter and supporting functions for handling FTP codes. +;;;; -------------------------------------------------------------------- + +(defun efs-process-handle-line (line proc) + ;; Look at the given LINE from the ftp process PROC and try to catagorize it. + (cond ((string-match efs-xfer-size-msgs line) + (let ((n 1)) + ;; this loop will bomb with an args out of range error at 10 + (while (not (match-beginning n)) + (setq n (1+ n))) + (setq efs-process-xfer-size + (ash (string-to-int (substring line + (match-beginning n) + (match-end n))) + -10)))) + + ((string-match efs-multi-msgs line) + (setq efs-process-result-cont-lines + (concat efs-process-result-cont-lines line "\n"))) + + ((string-match efs-skip-msgs line)) + + ((string-match efs-cmd-ok-msgs line) + (if (string-match efs-cmd-ok-cmds efs-process-cmd) + (setq efs-process-busy nil + efs-process-result nil + efs-process-result-line line))) + + ((string-match efs-pending-msgs line) + (if (string-match "^quote rnfr " efs-process-cmd) + (setq efs-process-busy nil + efs-process-result nil + efs-process-result-line line))) + + ((string-match efs-bytes-received-msgs line) + (if efs-process-server-confused + (setq efs-process-busy nil + efs-process-result nil + efs-process-result-line line))) + + ((string-match efs-server-confused-msgs line) + (setq efs-process-server-confused t)) + + ((string-match efs-good-msgs line) + (setq efs-process-busy nil + efs-process-result nil + efs-process-result-line line)) + + ((string-match efs-fatal-msgs line) + (set-process-sentinel proc nil) + (delete-process proc) + (setq efs-process-busy nil + efs-process-result 'fatal + efs-process-result-line line)) + + ((string-match efs-failed-msgs line) + (setq efs-process-busy nil + efs-process-result 'failed + efs-process-result-line line)) + + ((string-match efs-unknown-response-msgs line) + (setq efs-process-busy nil + efs-process-result 'weird + efs-process-result-line line) + (efs-process-scream-and-yell line)))) + +(efs-define-fun efs-process-log-string (proc str) + ;; For a given PROCESS, log the given STRING at the end of its + ;; associated buffer. + (let ((buff (get-buffer (process-buffer proc)))) + (if buff + (efs-save-buffer-excursion + (set-buffer buff) + (comint-output-filter proc str))))) + +(defun efs-process-filter (proc str) + ;; Build up a complete line of output from the ftp PROCESS and pass it + ;; on to efs-process-handle-line to deal with. + (let ((inhibit-quit t) + (buffer (get-buffer (process-buffer proc))) + (efs-default-directory default-directory)) + + ;; see if the buffer is still around... it could have been deleted. + (if buffer + (efs-save-buffer-excursion + (set-buffer (process-buffer proc)) + (efs-save-match-data + + ;; handle hash mark printing + (if efs-process-busy + (setq str (efs-process-handle-hash str) + efs-process-string (concat efs-process-string str))) + (efs-process-log-string proc str) + (while (and efs-process-busy + (string-match "\n" efs-process-string)) + (let ((line (substring efs-process-string + 0 + (match-beginning 0)))) + (setq efs-process-string (substring + efs-process-string + (match-end 0))) + ;; If we are in synch with the client, we should + ;; never get prompts in the wrong place. Just to be safe, + ;; chew them off. + (while (string-match efs-process-prompt-regexp line) + (setq line (substring line (match-end 0)))) + (efs-process-handle-line line proc))) + + ;; has the ftp client finished? if so then do some clean-up + ;; actions. + (if (not efs-process-busy) + (progn + (efs-correct-hash-mark-size) + ;; reset process-kill-without-query + (process-kill-without-query proc) + ;; issue the "done" message since we've finished. + (if (and efs-process-msg + (efs-message-p) + (null efs-process-result)) + (progn + + (efs-message "%s...done" efs-process-msg) + (setq efs-process-msg nil))) + + (if (and efs-process-nowait + (null efs-process-cmd-waiting)) + + (progn + ;; Is there a continuation we should be calling? + ;; If so, we'd better call it, making sure we + ;; only call it once. + (if efs-process-continue + (let ((cont efs-process-continue)) + (setq efs-process-continue nil) + (efs-call-cont + cont + efs-process-result + efs-process-result-line + efs-process-result-cont-lines))) + ;; If the cmd was run asynch, run the next + ;; cmd from the queue. For synch cmds, this + ;; is done by efs-send-cmd. For asynch + ;; cmds we don't care about + ;; efs-nested-cmd, since nothing is + ;; waiting for the cmd to complete. If + ;; efs-process-cmd-waiting is t, exit + ;; to let this command run. + (if (and efs-process-q + ;; Be careful to check efs-process-busy + ;; again, because the cont may have started + ;; some new ftp action. + ;; wheels within wheels... + (null efs-process-busy)) + (let ((next (car efs-process-q))) + (setq efs-process-q + (cdr efs-process-q)) + (apply 'efs-send-cmd + efs-process-host + efs-process-user + next)))) + + (if efs-process-continue + (let ((cont efs-process-continue)) + (setq efs-process-continue nil) + (efs-call-cont + cont + efs-process-result + efs-process-result-line + efs-process-result-cont-lines)))) + + ;; Update the mode line + ;; We can't test nowait to see if we changed the + ;; modeline in the first place, because conts + ;; may be running now, which will confuse the issue. + ;; The logic is simpler if we update the modeline + ;; before the cont, but then the user sees the + ;; modeline track the cont execution. It's dizzying. + (if (and (or efs-mode-line-format + efs-ftp-activity-function) + (null efs-process-busy)) + (efs-update-mode-line))))) + + ;; Trim buffer, if required. + (and efs-max-ftp-buffer-size + (zerop efs-process-cmd-counter) + (> (point-max) efs-max-ftp-buffer-size) + (= (point-min) 1) ; who knows, the user may have narrowed. + (null (get-buffer-window (current-buffer))) + (save-excursion + (goto-char (/ efs-max-ftp-buffer-size 2)) + (forward-line 1) + (delete-region (point-min) (point)))))))) + +;;;; ------------------------------------------------------------------ +;;;; Functions for counting hashes and reporting on bytes transferred. +;;;; ------------------------------------------------------------------ + +(defun efs-set-xfer-size (host user bytes) + ;; Set the size of the next FTP transfer in bytes. + (let ((proc (efs-get-process host user))) + (if proc + (let ((buf (process-buffer proc))) + (if buf + (save-excursion + (set-buffer buf) + (setq efs-process-xfer-size (ash bytes -10)))))))) + +(defun efs-guess-incoming-bin-hm-size () + ;; Guess at the hash mark size for incoming binary transfers by taking + ;; the average value for such transfers to other hosts. + (let ((total 0) + (n 0)) + (efs-map-hashtable + (function + (lambda (host hm-size) + (if hm-size (setq total (+ total hm-size) + n (1+ n))))) + efs-host-hashtable + 'incoming-bin-hm-size) + (and (> n 0) (/ total n)))) + +(defun efs-set-hash-mark-unit (host user &optional incoming) + ;; Sets the value of efs-process-hash-mark-unit according to the xfer-type. + ;; efs-hash-mark-unit is the number of bytes represented by a hash mark, + ;; in units of 16. If INCOMING is non-nil, the xfer will be a GET. + (if efs-send-hash + (let ((buff (efs-ftp-process-buffer host user)) + (gate-p (efs-use-gateway-p host t))) + (if buff + (save-excursion + (set-buffer buff) + (setq efs-process-hash-mark-unit + (ash (or + (and incoming (eq efs-process-xfer-type 'image) + (or (efs-get-host-property + host 'incoming-bin-hm-size) + (if gate-p + efs-gateway-incoming-binary-hm-size + efs-incoming-binary-hm-size) + (let ((guess + (efs-guess-incoming-bin-hm-size))) + (and guess + (efs-set-host-property + host 'incoming-bin-hm-size + guess))))) + (if gate-p + efs-gateway-hash-mark-size + efs-hash-mark-size) + 1024) ; make sure that we have some integer + -4))))))) + +(defun efs-correct-hash-mark-size () + ;; Corrects the value of efs-{ascii,binary}-hash-mark-size. + ;; Must be run in the process buffer. + (and efs-send-hash + efs-process-hash-mark-unit + (> efs-process-xfer-size 0) + (< efs-process-xfer-size 524288) ; 2^19, prevent overflows + (> efs-process-hash-mark-count 0) + (or (> efs-process-last-percent 100) + (< (ash (* efs-process-hash-mark-unit + (1+ efs-process-hash-mark-count )) -6) + efs-process-xfer-size)) + (let ((val (ash (/ (ash efs-process-xfer-size 6) + efs-process-hash-mark-count) 4))) + (if (and (eq efs-process-xfer-type 'image) + (>= (length efs-process-cmd) 4) + (string-equal (downcase (substring efs-process-cmd 0 4)) + "get ")) + (efs-set-host-property efs-process-host 'incoming-bin-hm-size val) + (set (if (efs-use-gateway-p efs-process-host t) + 'efs-gateway-hash-mark-size + 'efs-hash-mark-size) + val))))) + +(defun efs-process-handle-hash (str) + ;; Remove hash marks from STRING and display count so far. + (if (string-match "^#+$" str) + (progn + (setq efs-process-hash-mark-count + (+ efs-process-hash-mark-count + (- (match-end 0) (match-beginning 0)))) + (and + efs-process-msg + efs-process-hash-mark-unit + (not (and efs-process-nowait + (or (eq efs-verbose 0) + (eq (selected-window) (minibuffer-window))))) + (efs-message-p) + (let* ((big (> efs-process-hash-mark-count 65536)) ; 2^16 + (kbytes (if big + (* efs-process-hash-mark-unit + (ash efs-process-hash-mark-count -6)) + (ash (* efs-process-hash-mark-unit + efs-process-hash-mark-count) + -6)))) + (if (zerop efs-process-xfer-size) + (or (zerop kbytes) + (efs-message "%s...%dk" efs-process-msg kbytes)) + (let ((percent (if big + (/ (* 100 (ash kbytes -7)) + (ash efs-process-xfer-size -7)) + (/ (* 100 kbytes) efs-process-xfer-size)))) + ;; Don't display %'s betwwen 100 and 110 + (and (> percent 100) (< percent 110) (setq percent 100)) + ;; cut out the redisplay of identical %-age messages. + (or (eq percent efs-process-last-percent) + (progn + (setq efs-process-last-percent percent) + (efs-message "%s...%d%%" efs-process-msg percent))))))) + (concat (substring str 0 (match-beginning 0)) + (and (/= (length str) (match-end 0)) + (substring str (1+ (match-end 0)))))) + str)) + +;;;; ------------------------------------------------------------------ +;;;; Keeping track of the number of active background connections. +;;;; ------------------------------------------------------------------ + +(defun efs-ftp-processes-active () + ;; Return the number of FTP processes busy. + (save-excursion + (length + (delq nil + (mapcar + (function + (lambda (buff) + (set-buffer buff) + (and (boundp 'efs-process-busy) + efs-process-busy))) + (buffer-list)))))) + +(defun efs-update-mode-line () + ;; Updates the mode with FTP activity, and runs `efs-ftp-activity-function'. + (let ((num (efs-ftp-processes-active))) + (if efs-mode-line-format + (progn + (if (zerop num) + (setq efs-mode-line-string "") + (setq efs-mode-line-string (format efs-mode-line-format num))) + ;; fake emacs into re-calculating all the mode lines. + (save-excursion (set-buffer (other-buffer))) + (set-buffer-modified-p (buffer-modified-p)))) + (if efs-ftp-activity-function + (funcall efs-ftp-activity-function num)))) + +(defun efs-display-ftp-activity () + "Displays the number of active background ftp sessions. +Uses the variable `efs-mode-line-format' to determine how this will be +displayed." + (interactive) + (or (memq 'efs-mode-line-string global-mode-string) + (if global-mode-string + (nconc global-mode-string '(efs-mode-line-string)) + (setq global-mode-string '("" efs-mode-line-string))))) + +;;;; ------------------------------------------------------------------- +;;;; Expiring inactive ftp buffers. +;;;; ------------------------------------------------------------------- + +(defun efs-start-polling () + ;; Start polling FTP buffers, to look for idle ones. + (or (null efs-expire-ftp-buffers) + (let ((proc (get-process "efs poll"))) + (or (and proc (eq (process-status proc) 'run)))) + (let ((default-directory exec-directory) + (process-connection-type nil) + new-proc) + (condition-case nil + (delete-process "efs poll") + (error nil)) + (setq new-proc (start-process + "efs poll" nil + (concat exec-directory "wakeup") + (int-to-string efs-ftp-buffer-poll-time))) + (set-process-filter new-proc (function efs-expire-ftp-buffers-filter)) + (process-kill-without-query new-proc)))) + +(defun efs-connection-visited-p (host user) + ;; Returns t if there are any buffers visiting files on HOST and USER. + (save-excursion + (let ((list (buffer-list)) + (case-fold (memq (efs-host-type host) + efs-case-insensitive-host-types)) + (visited nil) + parsed) + (setq host (downcase host)) + (if case-fold (setq user (downcase user))) + (while list + (set-buffer (car list)) + (if (or (and buffer-file-name + (setq parsed (efs-ftp-path buffer-file-name)) + (string-equal host (downcase (car parsed))) + (string-equal user (if case-fold + (downcase (nth 1 parsed)) + (nth 1 parsed)))) + (and (boundp 'dired-directory) + (stringp dired-directory) + efs-dired-host-type + (setq parsed (efs-ftp-path dired-directory)) + (string-equal host (downcase (car parsed))) + (string-equal user (if case-fold + (downcase (nth 1 parsed)) + (nth 1 parsed))))) + (setq visited t + list nil) + (setq list (cdr list)))) + visited))) + +(defun efs-expire-ftp-buffers-filter (proc string) + ;; Check all ftp buffers, and kill them if they have been inactive + ;; for the minimum of efs-ftp-buffer-expire-time and their local + ;; time out time. + (if efs-expire-ftp-buffers + (let ((list (buffer-list)) + new-alist) + (save-excursion + (while list + (set-buffer (car list)) + (if (eq major-mode 'efs-mode) + (let* ((proc (get-buffer-process (current-buffer))) + (proc-p (and proc (memq (process-status proc) + '(run open))))) + (if (or efs-ftp-buffer-expire-time + efs-process-idle-time + (null proc-p)) + (let ((elt (assq (car list) efs-ftp-buffer-alist)) + (wind-p (get-buffer-window (car list)))) + (if (or (null elt) (buffer-modified-p) + efs-process-busy wind-p) + (progn + (setq new-alist (cons (cons (car list) 0) + new-alist)) + (or wind-p (set-buffer-modified-p nil))) + (let ((idle (+ (cdr elt) + efs-ftp-buffer-poll-time))) + (if (and proc-p + (< idle + (if efs-ftp-buffer-expire-time + (if efs-process-idle-time + (min efs-ftp-buffer-expire-time + efs-process-idle-time) + efs-ftp-buffer-expire-time) + efs-process-idle-time))) + (progn + (setq new-alist (cons (cons (car list) idle) + new-alist)) + (set-buffer-modified-p nil)) + ;; If there are still buffers for host & user, + ;; don't wipe the cache. + (and proc + (efs-connection-visited-p + efs-process-host efs-process-user) + (set-process-sentinel proc nil)) + (kill-buffer (car list))))))))) + (setq list (cdr list)))) + (setq efs-ftp-buffer-alist new-alist)) + (condition-case nil + (delete-process "efs poll") + (error nil)))) + +;;;; ------------------------------------------------------------------- +;;;; When the FTP client process dies... +;;;; ------------------------------------------------------------------- + +(defun efs-process-sentinel (proc str) + ;; When ftp process changes state, nuke all file-entries in cache. + (let ((buff (process-buffer proc))) + ;; If the client dies, make sure that efs doesn't think that + ;; there is a running process. + (save-excursion + (condition-case nil + (progn + (set-buffer buff) + (setq efs-process-busy nil)) + (error nil))) + (let ((parsed (efs-parse-proc-name proc))) + (if parsed + (progn + (apply 'efs-wipe-file-entries parsed) + (apply 'efs-wipe-from-ls-cache parsed)))) + (if (or efs-mode-line-format efs-ftp-activity-function) + (efs-update-mode-line)))) + +(defun efs-kill-ftp-process (buffer) + "Kill an FTP connection and its associated process buffer. +If the BUFFER's visited file name or default-directory is an efs remote +file name, it is the connection for that file name that is killed." + (interactive "bKill FTP process associated with buffer: ") + (or buffer (setq buffer (current-buffer))) + (save-excursion + (set-buffer buffer) + (if (eq major-mode 'efs-mode) + (kill-buffer buffer) + (let ((file (or (buffer-file-name) default-directory))) + (if file + (let ((parsed (efs-ftp-path (expand-file-name file)))) + (if parsed + (let ((host (nth 0 parsed)) + (user (nth 1 parsed))) + (kill-buffer + (efs-ftp-process-buffer host user)))))))))) + +(defun efs-close-ftp-process (buffer) + "Close an FTP connection. +This kills the FTP client process, but unlike `efs-kill-ftp-process' this +neither kills the process buffer, nor deletes cached data for the connection." + (interactive "bClose FTP process associated with buffer: ") + (or buffer (setq buffer (current-buffer))) + (save-excursion + (set-buffer buffer) + (if (eq major-mode 'efs-mode) + (let ((process (get-buffer-process buffer))) + (if process + (progn + (set-process-sentinel process nil) + (setq efs-process-busy nil + efs-process-q nil) + (if (or efs-mode-line-format efs-ftp-activity-function) + (efs-update-mode-line)) + (delete-process process)))) + (let ((file (or (buffer-file-name) default-directory))) + (if file + (let ((parsed (efs-ftp-path (expand-file-name file)))) + (if parsed + (let ((process (get-process + (format "*ftp %s@%s*" + (nth 1 parsed) (car parsed))))) + (if process + (progn + (set-buffer (process-buffer process)) + (set-process-sentinel process nil) + (setq efs-process-busy nil + efs-process-q nil) + (if (or efs-mode-line-format + efs-ftp-activity-function) + (efs-update-mode-line)) + (delete-process process))))))))))) + +(defun efs-ping-ftp-connection (buffer) + "Ping a connection by sending a NOOP command. +Useful for waking up a possible expired connection." + (interactive "bPing FTP connection associated with buffer: ") + (or buffer (setq buffer (current-buffer))) + (efs-save-buffer-excursion + (set-buffer buffer) + (let (file host user parsed) + (if (or (and (eq major-mode 'efs-mode) + (setq host efs-process-host + user efs-process-user)) + (and (setq file (or (buffer-file-name) default-directory)) + (setq parsed (efs-ftp-path file)) + (setq host (car parsed) + user (nth 1 parsed)))) + (or (car + (efs-send-cmd + host user '(quote noop) + (format "Pinging connection %s@%s" user host))) + (message "Connection %s@%s is alive." user host)))))) + +(defun efs-display-ftp-process-buffer (buffer) + "Displays the FTP process buffer associated with the current buffer." + (interactive "bDisplay FTP buffer associated with buffer: ") + (if (null buffer) (setq buffer (current-buffer))) + (let ((file (or (buffer-file-name) default-directory)) + parsed proc-buffer) + (if (and file (setq parsed (efs-ftp-path file)) + (setq proc-buffer (get-buffer (efs-ftp-process-buffer + (car parsed) + (nth 1 parsed))))) + (display-buffer proc-buffer) + (error "Buffer %s not associated with an FTP process" buffer)))) + +;;;; ------------------------------------------------------------------- +;;;; Starting the FTP client process +;;;; ------------------------------------------------------------------- + +(defun efs-ftp-process-buffer (host user) + "Return name of the process buffer for ftp process for HOST and USER." + ;; Host names on the internet are case-insensitive. + (format efs-ftp-buffer-format user (downcase host))) + +(defun efs-pty-check (proc threshold) + ;; Checks to see if PROC is a pty. Beware, it clobbers the process + ;; filter, so run this before you set the filter. + ;; THRESHOLD is an integer to tell it how long to wait for output. + (sit-for 0) ; Update the display before doing any waiting. + (let ((efs-pipe-p t) + (n 0)) + (set-process-filter proc (function (lambda (proc string) + (setq efs-pipe-p nil)))) + (while (and (< n threshold) efs-pipe-p) + (accept-process-output) + (setq n (1+ n))) + (if efs-pipe-p + (progn + (sit-for 0) ; update display + ;; Use a sleep-for as I don't want pty-checking to depend + ;; on pending input. + (sleep-for efs-pty-check-retry-time))) + (accept-process-output) + (if efs-pipe-p + (if (or noninteractive + (progn + ;; in case the user typed something during the wait. + (discard-input) + (y-or-n-p + (format "%s seems not a pty. Kill? " proc)))) + (progn + (kill-buffer (process-buffer proc)) + (if (eq (selected-window) (minibuffer-window)) + (abort-recursive-edit) + (signal 'quit nil)))) + ;; Need to send a \n to make sure, because sometimes we get the startup + ;; prompt from a pipe. + (sit-for 0) + (process-send-string proc "\n") + (setq efs-pipe-p t + n 0) + (while (and (< n threshold) efs-pipe-p) + (accept-process-output) + (setq n (1+ n))) + (if efs-pipe-p + (progn + (sit-for 0) + (sleep-for efs-pty-check-retry-time))) + (accept-process-output) + (if (and efs-pipe-p + (or noninteractive + (progn + ;; in case the user typed something during the wait. + (discard-input) + (y-or-n-p + (format "%s seems not a pty. Kill? " proc))))) + (progn + (kill-buffer (process-buffer proc)) + (if (eq (selected-window) (minibuffer-window)) + (abort-recursive-edit) + (signal 'quit nil))))))) + +(defun efs-start-process (host user name) + "Spawn a new ftp process ready to connect to machine HOST as USER. +If HOST is only ftp-able through a gateway machine then spawn a shell +on the gateway machine to do the ftp instead. NAME is the name of the +process." + (let* ((use-gateway (efs-use-gateway-p host)) + (buffer (get-buffer-create (efs-ftp-process-buffer host user))) + (process-connection-type t) + (opaque-p (memq use-gateway efs-opaque-gateways)) + proc) + (save-excursion + (set-buffer buffer) + (efs-mode host user (if opaque-p + efs-gateway-ftp-prompt-regexp + efs-ftp-prompt-regexp))) + (cond + ((null use-gateway) + (message "Opening FTP connection to %s..." host) + (setq proc (apply 'start-process name buffer efs-ftp-program-name + efs-ftp-program-args))) + ((eq use-gateway 'interactive) + (setq proc (efs-gwp-start host user name))) + ((eq use-gateway 'remsh) + (message "Opening FTP connection to %s via %s..." host efs-gateway-host) + (setq proc (apply 'start-process name buffer (nth 1 efs-gateway-type) + (append (list efs-gateway-host) + (nth 2 efs-gateway-type) + (list (nth 3 efs-gateway-type)) + (nth 4 efs-gateway-type))))) + ((memq use-gateway '(proxy raptor interlock kerberos)) + (message "Opening FTP connection to %s via %s..." host efs-gateway-host) + (setq proc (apply 'start-process name buffer (nth 1 efs-gateway-type) + (nth 2 efs-gateway-type)))) + ((eq use-gateway 'local) + (message "Opening FTP connection to %s..." host) + (setq proc (apply 'start-process name buffer (nth 1 efs-gateway-type) + (nth 2 efs-gateway-type)))) + ((error "Never heard of gateway type %s" use-gateway))) + (process-kill-without-query proc) + (if opaque-p + (accept-process-output proc) + (if efs-pty-check-threshold + (efs-pty-check proc efs-pty-check-threshold) + (accept-process-output proc))) + (set-process-sentinel proc (function efs-process-sentinel)) + (set-process-filter proc (function efs-process-filter)) + (efs-start-polling) + (save-excursion + (set-buffer buffer) + (goto-char (point-max)) + (set-marker (process-mark proc) (point))) + proc)) + +(defun efs-get-process-internal (host user) + ;; Get's the first process for HOST and USER. If HOST runs a + ;; a case insignificant OS, then case is not considered in USER. + (let ((list (process-list)) + (case-fold (memq (efs-host-type host) + efs-case-insensitive-host-types)) + (len (+ (length host) (length user) 7)) + fmt name found) + (setq host (downcase host)) + (if case-fold (setq user (downcase user))) + (while (and (not found) list) + (setq name (process-name (car list))) + (if (and (= (length name) len) + (string-equal (substring name 0 5) "*ftp ") + (string-equal + (if case-fold (downcase (substring name 5)) (substring name 5)) + (or fmt (setq fmt (format "%s@%s*" user host)))) + (memq (process-status (car list)) '(run open))) + (setq found (car list)) + (setq list (cdr list)))) + found)) + +;; efs-guess-host-type calls this +;; function recursively. The (if (and proc... avoids an infinite +;; loop. We should make sure that this won't hang things if the +;; connection goes wrong. + +(defun efs-get-process (host user) + "Return the process object for the FTP process for HOST and USER. +Create a new process if needed." + + (let ((proc (efs-get-process-internal host user))) + (if (and proc (memq (process-status proc) '(run open))) + proc + + ;; Make sure that the process isn't around in some strange state. + + (setq host (downcase host)) + (let ((name (concat "*ftp " user "@" host "*"))) + (if proc (condition-case nil (delete-process proc) (error nil))) + + ;; grab a suitable process. + (setq proc (efs-start-process host user name)) + + (efs-save-match-data + (efs-save-buffer-excursion + (set-buffer (process-buffer proc)) + + ;; Run any user-specified hooks. + (run-hooks 'efs-ftp-startup-hook) + + ;; login to FTP server. + (efs-login host user proc) + + ;; Beware, the process may have died if the login went bad. + (if (memq (process-status proc) '(run open)) + + (progn + ;; Tell client to send back hash-marks as progress. It isn't + ;; usually fatal if this command fails. + (efs-guess-hash-mark-size proc) + + ;; Run any user startup functions + (let ((alist efs-ftp-startup-function-alist) + (case-fold-search t)) + (while alist + (if (string-match (car (car alist)) host) + (progn + (funcall (cdr (car alist)) host user) + (setq alist nil)) + (setq alist (cdr alist))))) + + ;; Guess at the host type. + (efs-guess-host-type host user) + + ;; Check the idle time. + (efs-check-idle host user) + + proc) + + ;; Hopefully a recursive retry worked. + (or (efs-get-process-internal host user) + (error "No FTP process for %s@%s" user host))))))))) + +(defun efs-guess-hash-mark-size (proc) + ;; Doesn't run efs-save-match-data. You must do that yourself. + (if efs-send-hash + (save-excursion + (set-buffer (process-buffer proc)) + (let ((line (nth 1 (efs-raw-send-cmd proc "hash"))) + (gate-p (efs-use-gateway-p efs-process-host t))) + ;; Don't guess if the hash-mark-size is already set. + (or (if gate-p efs-gateway-hash-mark-size efs-hash-mark-size) + (if (string-match efs-hash-mark-msgs line) + (let ((size (substring line (match-beginning 1) + (match-end 1)))) + (if (string-match "^[0-9]+$" size) + (set (if gate-p + 'efs-gateway-hash-mark-size + 'efs-hash-mark-size) + (string-to-int size)))))))))) + +;;;; ------------------------------------------------------------ +;;;; Simple FTP process shell support. +;;;; ------------------------------------------------------------ + +(defun efs-mode (host user prompt) + "Major mode for interacting with an FTP process. +The user interface for sending commands to the FTP process is `comint-mode'. +For more information see the documentation for `comint-mode'. This command +is not intended for interactive use. +Takes arguments: HOST USER PROMPT + +Runs efs-mode-hook if it is not nil. + +Key map: +\\{comint-mode-map}" + (let ((proc (get-buffer-process (current-buffer)))) + ;; Running comint-mode will kill-all-local-variables. + (comint-mode) + ;; All these variables are buffer local. + (setq major-mode 'efs-mode + mode-name "efs" + default-directory (file-name-directory efs-tmp-name-template) + comint-prompt-regexp prompt + efs-process-host host + efs-process-user user + efs-process-prompt-regexp prompt) + (set (make-local-variable 'paragraph-start) comint-prompt-regexp) + ;; Old versions of comint don't have this. It does no harm for + ;; the newer ones. + (set (make-local-variable 'comint-last-input-start) (make-marker)) + (goto-char (point-max)) + ;; in case there is a running process + (if proc (set-marker (process-mark proc) (point))) + (run-hooks 'efs-mode-hook))) + + +;;;; ============================================================= +;;;; >6 +;;;; Sending commands to the FTP server. +;;;; ============================================================= + +;;;; ------------------------------------------------------------- +;;;; General purpose functions for sending commands. +;;;; ------------------------------------------------------------- + +(defun efs-raw-send-cmd (proc cmd &optional msg pre-cont cont nowait) +;; Low-level routine to send the given ftp CMD to the ftp PROCESS. +;; MSG is an optional message to output before and after the command. +;; If PRE-CONT is non-nil, it is called immediately after execution +;; of the command starts, but without waiting for it to finish. +;; If CONT is non-NIL then it is either a function or a list of function and +;; some arguments. The function will be called when the ftp command has +;; completed. +;; If CONT is NIL then this routine will return \( RESULT . LINE \) where +;; RESULT is whether the command was successful, and LINE is the line from +;; the FTP process that caused the command to complete. +;; If NOWAIT is nil then we will wait for the command to complete before +;; returning. If NOWAIT is 0, then we will wait until the command starts, +;; executing before returning. NOWAIT of 1 is like 0, except that the modeline +;; will indicate an asynch FTP command. +;; If NOWAIT has any other value, then we will simply queue the +;; command. In all cases, CONT will still be called + + (if (memq (process-status proc) '(run open)) + (efs-save-buffer-excursion + (set-buffer (process-buffer proc)) + + (if efs-process-busy + ;; This function will always wait on a busy process. + ;; Queueing is done by efs-send-cmd. + (let ((efs-process-cmd-waiting t)) + (efs-kbd-quit-protect proc + (while efs-process-busy + (accept-process-output))))) + + (setq efs-process-string "" + efs-process-result-line "" + efs-process-result-cont-lines "" + efs-process-busy t + efs-process-msg (and efs-verbose msg) + efs-process-continue cont + efs-process-server-confused nil + efs-process-nowait nowait + efs-process-hash-mark-count 0 + efs-process-last-percent -1 + efs-process-xfer-size 0 + efs-process-cmd-counter (% (1+ efs-process-cmd-counter) 16)) + (process-kill-without-query proc t) + (and efs-process-msg + (efs-message-p) + (efs-message "%s..." efs-process-msg)) + (goto-char (point-max)) + (move-marker comint-last-input-start (point)) + (move-marker comint-last-input-end (point)) + ;; don't insert the password into the buffer on the USER command. + (efs-save-match-data + (if (string-match efs-passwd-cmds cmd) + (insert (setq efs-process-cmd + (substring cmd 0 (match-end 0))) + " Turtle Power!\n") + (setq efs-process-cmd cmd) + (insert cmd "\n"))) + (process-send-string proc (concat cmd "\n")) + (set-marker (process-mark proc) (point)) + ;; Update the mode-line + (if (and (or efs-mode-line-format efs-ftp-activity-function) + (memq nowait '(t 1))) + (efs-update-mode-line)) + (if pre-cont + (let ((efs-nested-cmd t)) + (save-excursion + (apply (car pre-cont) (cdr pre-cont))))) + (prog1 + (if nowait + nil + ;; hang around for command to complete + ;; Some clients die after the command is sent, if the server + ;; times out. Don't wait on dead processes. + (efs-kbd-quit-protect proc + (while (and efs-process-busy + ;; Need to recheck nowait, since it may get reset + ;; in a cont. + (null efs-process-nowait) + (memq (process-status proc) '(run open))) + (accept-process-output proc))) + + ;; cont is called by the process filter + (if cont + ;; Return nil if a cont was called. + ;; Can't return process-result + ;; and process-line since executing + ;; the cont may have changed + ;; the state of the process buffer. + nil + (list efs-process-result + efs-process-result-line + efs-process-result-cont-lines))) + + ;; If the process died, the filter would have never got the chance + ;; to call the cont. Try to jump start things. + + (if (and (not (memq (process-status proc) '(run open))) + (string-equal efs-process-result-line "") + cont + (equal cont efs-process-continue)) + (progn + (setq efs-process-continue nil + efs-process-busy nil) + ;; The process may be in some strange state. Get rid of it. + (condition-case nil (delete-process proc) (error nil)) + (efs-call-cont cont 'fatal "" ""))))) + + (error "FTP process %s has died." (process-name proc)))) + +(efs-defun efs-quote-string nil (string &optional not-space) + "Quote any characters in STRING that may confuse the ftp process. +If NOT-SPACE is non-nil, then blank characters are not quoted, because +it is assumed that the string will be surrounded by \"'s." + (apply (function concat) + (mapcar (function + (lambda (char) + (if (or (< char ?\ ) + (and (null not-space) (= char ?\ )) + (> char ?\~) + (= char ?\") + (= char ?\\)) + (vector ?\\ char) + (vector char)))) + string))) + +(efs-defun efs-fix-path nil (path &optional reverse) + "Convert PATH from a unix format to a non-unix format. +If optional REVERSE, convert in the opposite direction." + (identity path)) + +(efs-defun efs-fix-dir-path nil (dir-path) + "Convert DIR-PATH from unix format to a non-unix format for a dir listing" + ;; The default def runs for dos-distinct, ka9q, and all the unix's. + ;; To be more careful about distinguishing dirs from plain files, + ;; we append a ".". + (let ((len (length dir-path))) + (if (and (not (zerop len)) (= (aref dir-path (1- len)) ?/)) + (concat dir-path ".") + dir-path))) + +(defun efs-send-cmd (host user cmd + &optional msg pre-cont cont nowait noretry) + "Find an ftp process connected to HOST logged in as USER and send it CMD. +MSG is an optional status message to be output before and after issuing the +command. + +See the documentation for efs-raw-send-cmd for a description of CONT, PRE-CONT +and NOWAIT. Normally, if the command fails it is retried. If NORETRY is +non-nil, this is not done." + ;; Handles conversion to remote pathname syntax and remote ls option + ;; capability. Also, sends umask if nec. + + (let ((proc (efs-get-process host user))) + + (if (and + (eq nowait t) + (save-excursion + (set-buffer (process-buffer proc)) + (or efs-process-busy + efs-process-cmd-waiting))) + + (progn + (efs-add-to-queue + host user + ;; Not nec. to store host and user, because the queue is for + ;; a specific host user pair anyway. Because the queue is always + ;; examined when efs-process-busy + ;; is nil, it should be impossible to get into a loop + ;; where we keep re-queueing over and over. To be on the safe + ;; side, store nowait as 1. + (list cmd msg pre-cont cont 1 noretry)) + nil) + + ;; Send a command. + + (let (cmd-string afsc-result afsc-line afsc-cont-lines) + + (let ((efs-nested-cmd t) + (cmd0 (car cmd)) + (cmd1 (nth 1 cmd)) + (cmd2 (nth 2 cmd)) + (cmd3 (nth 3 cmd))) + + (cond + + ((eq cmd0 'quote) + ;; QUOTEd commands + (cond + + ((eq cmd1 'site) + ;; SITE commands + (cond + ((memq cmd2 '(umask idle dos exec nfs group gpass)) + ;; For UMASK cmd3 = value of umask + ;; For IDLE cmd3 = idle setting, or nil if we're querying. + ;; For DOS and NFS cmd3 is nil. + ;; For EXEC cmd3 is the command to be exec'ed -- a string. + (if cmd3 (setq cmd3 (concat " " cmd3))) + (setq cmd-string (concat "quote site " (symbol-name cmd2) + cmd3))) + ((eq cmd2 'chmod) + (let* ((host-type (efs-host-type host user)) + (cmd4 (efs-quote-string + host-type (efs-fix-path host-type (nth 4 cmd))))) + (setq cmd-string (concat "quote site chmod " cmd3 " " + cmd4)))) + (t (error "efs: Don't know how to send %s %s %s %s" + cmd0 cmd1 cmd2 cmd3)))) + + ((memq cmd1 '(pwd xpwd syst pasv noop)) + (setq cmd-string (concat "quote " (symbol-name cmd1)))) + + ;; PORT command (cmd2 is IP + port address) + ((eq cmd1 'port) + (setq cmd-string (concat "quote port " cmd2))) + + ((memq cmd1 '(appe retr)) + (let ((host-type (efs-host-type host user))) + ;; Set an xfer type + (if cmd3 (efs-set-xfer-type host user cmd3 t)) + (setq cmd2 (efs-quote-string host-type + (efs-fix-path host-type cmd2)) + cmd-string (concat "quote " (symbol-name cmd1) " " + cmd2)))) + + ((eq cmd1 'stor) + (let ((host-type (efs-host-type host user))) + (if (memq host-type efs-unix-host-types) + (efs-set-umask host user)) + ;; Set an xfer type + (if cmd3 (efs-set-xfer-type host user cmd3 t)) + (setq cmd2 (efs-quote-string host-type + (efs-fix-path host-type cmd2)) + cmd-string (concat "quote stor " cmd2)))) + + ((memq cmd1 '(size mdtm rnfr)) + (let ((host-type (efs-host-type host user))) + (setq cmd2 (efs-quote-string host-type + (efs-fix-path host-type cmd2)) + cmd-string (concat "quote " + (symbol-name cmd1) " " cmd2)))) + + ((memq cmd1 '(pass user)) + (setq cmd-string (concat "quote " (symbol-name cmd1) " " cmd2))) + + (t + (error "efs: Don't know how to send %s %s %s %s" + cmd0 cmd1 cmd2 cmd3)))) + + ;; TYPE command + ((eq cmd0 'type) + (setq cmd-string (concat "type " (symbol-name cmd1)))) + + ;; DIR command + ;; cmd == 'dir "remote-path" "local-path" "ls-switches" + ((memq cmd0 '(dir nlist)) + (let ((host-type (efs-host-type host user)) + (listing-type (efs-listing-type host user))) + (setq cmd1 (efs-fix-dir-path host-type cmd1)) + (cond + ((memq listing-type efs-nlist-listing-types) + (setq cmd-string (concat efs-nlist-cmd " " + (efs-quote-string host-type cmd1) + " " cmd2))) + ((or (memq host-type efs-dumb-host-types) + (null cmd3)) + (setq cmd-string (format "%s %s %s" + (if (eq cmd0 'nlist) + efs-nlist-cmd + "dir") + (efs-quote-string host-type cmd1) + cmd2))) + ((setq cmd-string + (format "%s \"%s %s\" %s" + (if (eq cmd0 'nlist) + efs-nlist-cmd + "ls") + cmd3 (efs-quote-string host-type cmd1 t) + ;; cmd2 is a temp file, not nec. to quote. + cmd2)))))) + + ;; First argument is the remote pathname + ((memq cmd0 '(delete mkdir rmdir cd)) + (let ((host-type (efs-host-type host user))) + (setq cmd1 (efs-quote-string host-type + (efs-fix-path host-type cmd1)) + cmd-string (concat (symbol-name cmd0) " " cmd1)))) + + ;; GET command + ((eq cmd0 'get) + (let ((host-type (efs-host-type host user))) + (if cmd3 (efs-set-xfer-type host user cmd3)) + (efs-set-hash-mark-unit host user t) + (setq cmd1 (efs-quote-string host-type + (efs-fix-path host-type cmd1)) + cmd2 (efs-quote-string host-type cmd2) + cmd-string (concat "get " cmd1 " " cmd2)))) + + ;; PUT command + ((eq cmd0 'put) + (let ((host-type (efs-host-type host user))) + (if (memq host-type efs-unix-host-types) + (efs-set-umask host user)) + (if cmd3 (efs-set-xfer-type host user cmd3)) + (efs-set-hash-mark-unit host user) + (setq cmd2 (efs-quote-string host-type + (efs-fix-path host-type cmd2)) + cmd1 (efs-quote-string host-type cmd1) + cmd-string (concat "put " cmd1 " " cmd2)))) + + ;; APPEND command + ((eq cmd0 'append) + (let ((host-type (efs-host-type host user))) + (if cmd3 (efs-set-xfer-type host user cmd3)) + (efs-set-hash-mark-unit host user) + (setq cmd2 (efs-quote-string host-type + (efs-fix-path host-type cmd2)) + cmd1 (efs-quote-string host-type cmd1) + cmd-string (concat "append " cmd1 " " cmd2)))) + + ;; CHMOD command + ((eq cmd0 'chmod) + (let ((host-type (efs-host-type host user))) + (setq cmd2 (efs-quote-string host-type + (efs-fix-path host-type cmd2)) + cmd-string (concat "chmod " cmd1 " " cmd2)))) + + ;; Both arguments are remote pathnames + ((eq cmd0 'rename) + (let ((host-type (efs-host-type host user))) + (setq cmd1 (efs-quote-string host-type + (efs-fix-path host-type cmd1)) + cmd2 (efs-quote-string host-type + (efs-fix-path host-type cmd2)) + cmd-string (concat "rename " cmd1 " " cmd2)))) + + (t + (error "efs: Don't know how to send %s %s %s %s" + cmd0 cmd1 cmd2 cmd3)))) + + ;; Actually send the resulting command. + ;; Why do we use this complicated binding of afsc-{result,line}, + ;; rather then use the fact that efs-raw-send-cmd returns? + ;; Because efs-raw-send-cmd returns the result of the first + ;; attempt only. efs-send-cmd should return the result of + ;; the retry, if one was necessary. + ;; Maybe it would be better if efs-raw-send-cmd returned + ;; the result of cont, if nowait was nil? Or maybe still return + ;; \(result line \)? As long as nowait is nil, it should + ;; return something useful. + + ;; Beware, if some of the above FTP commands had to restart + ;; the process, PROC won't be set to the right process object. + (setq proc (efs-get-process host user)) + + (efs-raw-send-cmd + proc + cmd-string + msg + pre-cont + (efs-cont (result line cont-lines) (host user proc cmd msg pre-cont + cont nowait noretry) + (cond ((and (null noretry) (eq result 'fatal)) + (let ((retry + (efs-send-cmd + host user cmd msg pre-cont cont + (if (eq nowait t) 1 nowait) t))) + (or cont nowait + (setq afsc-result (car retry) + afsc-line (nth 1 retry) + afsc-cont-lines (nth 2 retry))))) + ((and (eq result 'failed) + (or (memq (car cmd) '(append rename put)) + (and (eq (car cmd) 'quote) + (eq (nth 1 cmd) 'stor))) + (efs-save-match-data + (string-match efs-write-protect-msgs line))) + (let ((retry (efs-write-recover + (efs-host-type host) + line cont-lines host user cmd msg pre-cont + cont nowait noretry))) + (or cont nowait + (setq afsc-result (car retry) + afsc-line (nth 1 retry) + afsc-cont-lines (nth 2 retry))))) + + (t (if cont + (efs-call-cont cont result line cont-lines) + (or nowait + (setq afsc-result result + afsc-line line + afsc-cont-lines cont-lines)))))) + nowait) + + (prog1 + (if (or nowait cont) + nil + (list afsc-result afsc-line afsc-cont-lines)) + + ;; Check the queue + (or nowait + efs-nested-cmd + (let ((buff (efs-ftp-process-buffer host user))) + (if (get-buffer buff) + (save-excursion + (set-buffer buff) + (if efs-process-q + (let ((next (car efs-process-q))) + (setq efs-process-q (cdr efs-process-q)) + (apply 'efs-send-cmd host user next)))))))))))) + +(efs-defun efs-write-recover nil + (line cont-lines host user cmd msg pre-cont cont nowait noretry) + "Called when a write command fails with `efs-write-protect-msgs'. +Should return \(result line cont-lines\), like `efs-raw-send-cmd'." + ;; This default version doesn't do anything. + (if cont + (progn + (efs-call-cont cont 'failed line cont-lines) + nil) + (if nowait nil (list 'failed line cont-lines)))) + +;;;; --------------------------------------------------------------------- +;;;; The login sequence. (The follows RFC959 rather tightly. If a server +;;;; can't even get the login codes right, it is +;;;; pretty much scrap metal.) +;;;; --------------------------------------------------------------------- + +(defun efs-nslookup-host (host) + "Attempt to resolve the given HOSTNAME using nslookup if possible." + (interactive "sHost: ") + (if efs-nslookup-program + (let* ((default-directory exec-directory) + (default-major-mode 'fundamental-mode) + (process-connection-type nil) + (proc (start-process " *nslookup*" " *nslookup*" + efs-nslookup-program host)) + (res host)) + (process-kill-without-query proc) + (save-excursion + (set-buffer (process-buffer proc)) + (let ((quit-flag nil) + (inhibit-quit nil)) + (while (memq (process-status proc) '(run open)) + (accept-process-output proc))) + (goto-char (point-min)) + (if (re-search-forward + "Name:.*\nAddress\\(es\\)?: *\\([.0-9]+\\)$" nil t) + (setq res (buffer-substring (match-beginning 2) + (match-end 2)))) + (kill-buffer (current-buffer))) + (if (interactive-p) + (message "%s: %s" host res)) + res) + (if (interactive-p) + (message + "No nslookup program. See the variable efs-nslookup-program.")) + host)) + +(defun efs-login (host user proc) + "Connect to the FTP-server on HOST as USER. +PROC is the process to the FTP-client. Doesn't call efs-save-match-data. +You must do that yourself." + (let ((gate (efs-use-gateway-p host))) + (if (eq gate 'kerberos) + (progn + (setq proc (efs-kerberos-login host user proc)) + (efs-login-send-user host user proc gate)) + (let ((to (if (memq gate '(proxy local raptor)) + efs-gateway-host + host)) + port cmd result) + (if (string-match "#" to) + (setq port (substring to (match-end 0)) + to (substring to 0 (match-beginning 0)))) + (and efs-nslookup-on-connect + (string-match "[^0-9.]" to) + (setq to (efs-nslookup-host to))) + (setq cmd (concat "open " to)) + (if port (setq cmd (concat cmd " " port))) + + ;; Send OPEN command. + (setq result (efs-raw-send-cmd proc cmd nil)) + + (and (eq gate 'interlock) (string-match "^331 " (nth 1 result)) + (setq result (efs-login-send-pass + efs-gateway-host + (efs-get-user efs-gateway-host) proc))) + + ;; Analyze result of OPEN. + (if (car result) + (progn + (condition-case nil (delete-process proc) (error nil)) + (efs-error host user (concat "OPEN request failed: " + (nth 1 result)))) + (efs-login-send-user host user proc gate)))))) + +(defun efs-login-send-user (host user proc &optional gate retry) + "Send user command to HOST and USER. PROC is the ftp client process. +Optional argument GATE specifies which type of gateway is being used. +RETRY argument specifies to try twice if we get a 421 response." + (let ((cmd (cond + ((memq gate '(local proxy interlock)) + (format "quote USER \"%s\"@%s" user + (if (and efs-nslookup-on-connect + (string-match "[^0-9.]" host)) + (efs-nslookup-host host) + host))) + ((eq gate 'raptor) + (format "quote USER \"%s\"@%s %s" user + (if (and efs-nslookup-on-connect + (string-match "[^0-9.]" host)) + (efs-nslookup-host host) + host) + (nth 3 efs-gateway-type))) + ((eq gate 'kerberos) + (let ((to host) + port) + (if (string-match "#" host) + (progn + (setq to (substring host 0 (match-beginning 0)) + port (substring host (match-end 0))) + (and efs-nslookup-on-connect + (string-match "[^0-9.]" to) + (efs-nslookup-host to)) + (setq to (concat to "@" port)))) + (format "quote user \"%s\"@%s" user to))) + (t + (format "quote user \"%s\"" user)))) + (msg (format "Logging in as user %s%s..." user + (if (memq gate '(proxy local raptor kerberos)) + (concat "@" host) ""))) + result code) + + ;; Send the message by hand so that we can report on the size + ;; of the MOTD. + (message msg) + + ;; Send USER command. + (setq result (efs-raw-send-cmd proc cmd nil)) + + ;; Analyze result of USER (this follows RFC959 strictly) + (if (< (length (nth 1 result)) 4) + (progn + (condition-case nil (delete-process proc) (error nil)) + (efs-error host user + (concat "USER request failed: " (nth 1 result)))) + + (setq code (substring (nth 1 result) 0 4)) + (cond + + ((string-equal "331 " code) + ;; Need password + (setq result (efs-login-send-pass host user proc gate))) + + ((string-equal "332 " code) + ;; Need an account, but no password + (setq result (efs-login-send-acct host user proc gate))) + + ((null (car result)) + ;; logged in proceed + nil) + + ((and (or (string-equal "530 " code) (string-equal "421 " code)) + (efs-anonymous-p user) + (or (string-match efs-too-many-users-msgs (nth 1 result)) + (string-match efs-too-many-users-msgs (nth 2 result)))) + (if (save-window-excursion + (condition-case nil + (display-buffer (process-buffer proc)) + (error nil)) + (y-or-n-p (format + "Too many users for %s@%s. Try again? " + user host))) + (progn + ;; Set result to nil if we are doing a retry, so done + ;; message only gets sent once. + (setq result nil) + (if (string-equal code "530 ") + (efs-login-send-user host user proc gate t) + (efs-get-process host user))) + (signal 'quit nil))) + + ((and retry (string-equal code "421 ")) + (setq result nil) + (efs-get-process host user)) + + (t ; bombed + (condition-case nil (delete-process proc) (error nil)) + ;; Wrong username? + (efs-set-user host nil) + (efs-error host user + (concat "USER request failed: " (nth 1 result))))) + (and (null (car result)) + (stringp (nth 2 result)) + (message "%sdone%s" msg + (let ((n (efs-occur-in-string ?\n (nth 2 result)))) + (if (> n 1) + (format "; MOTD of %d lines" n) + ""))))))) + +(defun efs-login-send-pass (host user proc &optional gate) + "Sends password to HOST and USER. PROC is the ftp client process. +Doesn't call efs-save-match data. You must do that yourself." + ;; Note that efs-get-password always returns something. + ;; It prompts the user if necessary. Even if the returned password is + ;; \"\", send it, because we wouldn't be running this function + ;; if the server wasn't insisting on a password. + (let* ((pass "") + (qpass "") + (cmd "") + (result (unwind-protect + (progn + (condition-case nil + (setq pass (efs-get-passwd host user)) + (quit (condition-case nil + (kill-buffer (process-buffer proc)) + (error nil)) + (signal 'quit nil))) + (setq cmd (concat + "quote pass " + (setq qpass (efs-quote-string nil pass t)))) + (efs-raw-send-cmd proc cmd)) + (fillarray pass 0) + (fillarray qpass 0) + (fillarray cmd 0))) + (code (and (>= (length (nth 1 result)) 4) + (substring (nth 1 result) 0 4)))) + (or code (setq code "")) + ;; Analyze the result. + (cond + ((string-equal code "332 ") + ;; require an account passwd + (setq result (efs-login-send-acct host user proc gate))) + ((null (car result)) + ;; logged in proceed + nil) + ((or (string-equal code "530 ") (string-equal code "421 ")) + ;; Give the user another chance + (condition-case nil + (if (efs-anonymous-p user) + (if (or (string-match efs-too-many-users-msgs (nth 1 result)) + (string-match efs-too-many-users-msgs (nth 2 result))) + (if (save-window-excursion + (condition-case nil + (display-buffer (process-buffer proc)) + (error nil)) + (y-or-n-p (format + "Too many users for %s@%s. Try again? " + user host))) + (progn + ;; Return nil if we are doing a retry, so done + ;; message only gets sent once. + (setq result nil) + (if (string-equal code "530 ") + (efs-login-send-user host user proc gate) + (efs-get-process host user))) + (signal 'quit nil)) + (unwind-protect + (efs-set-passwd + host user + (save-window-excursion + (condition-case nil + (display-buffer (process-buffer proc)) + (error nil)) + (setq pass + (read-passwd + (format + "Password for %s@%s failed. Try again: " + user host))))) + (fillarray pass 0)) + (setq result nil) + (efs-login-send-user host user proc gate)) + (unwind-protect + (efs-set-passwd + host user + (setq pass + (read-passwd + (format "Password for %s@%s failed. Try again: " + user host)))) + (fillarray pass 0)) + (setq result nil) + (efs-login-send-user host user proc gate)) + (quit (condition-case nil (delete-process proc) (error nil)) + (efs-set-user host nil) + (efs-set-passwd host user nil) + (signal 'quit nil)) + (error (condition-case nil (delete-process proc) (error nil)) + (efs-set-user host nil) + (efs-set-passwd host user nil) + (efs-error host user "PASS request failed.")))) + (t ; bombed for unexplained reasons + (condition-case nil (delete-process proc) (error nil)) + (efs-error host user (concat "PASS request failed: " (nth 1 result))))) + result)) + +(defun efs-login-send-acct (host user proc &optional gate) + "Sends account password to HOST and USER. PROC is the ftp client process. +Doesn't call efs-save-match data. You must do that yourself." + (let* ((acct "") + (qacct "") + (cmd "") + (result (unwind-protect + (progn + ;; The raptor gateway requires us to send a gateway + ;; authentication password for account. What if the + ;; remote server wants one too? + (setq acct (if (eq gate 'raptor) + (efs-get-account + efs-gateway-host + (nth 3 efs-gateway-type) nil t) + (efs-get-account host user nil t)) + qacct (efs-quote-string nil acct t) + cmd (concat "quote acct " qacct)) + (efs-raw-send-cmd proc cmd)) + (fillarray acct 0) + (fillarray qacct 0) + (fillarray cmd 0)))) + ;; Analyze the result + (cond + ((null (car result)) + ;; logged in proceed + nil) + ((eq (car result) 'failed) + ;; Give the user another chance + (condition-case nil + (progn + (unwind-protect + (progn + (setq acct (read-passwd + (format + "Account password for %s@%s failed. Try again: " + user host))) + (or (and efs-high-security-hosts + (string-match efs-high-security-hosts + (format "%s@%s" user host))) + (efs-set-account host user nil acct))) + (fillarray acct 0)) + (setq result (efs-login-send-user host user proc gate))) + (quit (condition-case nil (delete-process proc) (error nil))) + (error (condition-case nil (delete-process proc) (error nil)) + (efs-error host user "ACCT request failed.")))) + (t ; bombed for unexplained reasons + (condition-case nil (delete-process proc) (error nil)) + (efs-error host user (concat "ACCT request failed: " (nth 1 result))))) + result)) + +;;;; ---------------------------------------------------------------------- +;;;; Changing working directory. +;;;; ---------------------------------------------------------------------- + +(defun efs-raw-send-cd (host user dir &optional no-error) + ;; If NO-ERROR, doesn't barf, but just returns success (t) or failure (nil). + ;; This does not use efs-send-cmd. + ;; Also DIR must be in the syntax of the remote host-type. + (let* ((cmd (concat "cd " dir)) + cd-result cd-line) + (efs-raw-send-cmd + (efs-get-process host user) + cmd nil nil + (efs-cont (result line cont-lines) (cmd) + (if (eq result 'fatal) + (efs-raw-send-cmd + (efs-get-process host user) + cmd nil nil + (function (lambda (result line cont-lines) + (setq cd-result result + cd-line line)))) + (setq cd-result result + cd-line line)))) + (if no-error + (null cd-result) + (if cd-result + (efs-error host user (concat "CD failed: " cd-line)))))) + +;;;; -------------------------------------------------------------- +;;;; Getting a PWD. +;;;; -------------------------------------------------------------- + +(defun efs-unquote-quotes (string) + ;; Unquote \"\"'s in STRING to \". + (let ((start 0) + new) + (while (string-match "\"\"" string start) + (setq new (concat new (substring + string start (1+ (match-beginning 0)))) + start (match-end 0))) + (if new + (concat new (substring string start)) + string))) + +(efs-defun efs-send-pwd nil (host user &optional xpwd) + "Attempts to get the current working directory for the given HOST/USER pair. +Returns \( DIR . LINE \) where DIR is either the directory or NIL if not found, +and LINE is the relevant success or fail line from the FTP-server. If the +optional arg XPWD is given, uses this server command instead of PWD." + (let* ((result (efs-send-cmd host user + (list 'quote (if xpwd 'xpwd 'pwd)) + "Getting pwd")) + (line (nth 1 result)) + dir) + (or (car result) + (efs-save-match-data + (if (string-match "\"\\(.*\\)\"[^\"]*$" line) + (setq dir (efs-unquote-quotes (substring line (match-beginning 1) + (match-end 1)))) + (if (string-match " \\([^ ]+\\) " line) ; stone-age servers! + (setq dir (substring line + (match-beginning 1) + (match-end 1))))))) + (cons dir line))) + +(efs-defun efs-send-pwd super-dumb-unix (host user &optional xpwd) + ;; Guess at the pwd for a unix host that doesn't support pwd. + (if (efs-anonymous-p user) + ;; guess + (cons "/" "") + ;; Who knows? + (message "Can't obtain pwd for %s" host) + (ding) + (sleep-for 2) + (message "All file names must be specified as full paths.") + (cons nil ""))) + +;;;; -------------------------------------------------------- +;;;; Getting the SIZE of a remote file. +;;;; -------------------------------------------------------- + +(defun efs-send-size (host user file) + "For HOST and USER, get the size of FILE in bytes. +This returns a list \( SIZE . LINE \), where SIZE is the file size in bytes, +or nil if this couldn't be determined, and LINE is the output line of the +FTP server." + (efs-save-match-data + (let ((result (efs-send-cmd host user (list 'quote 'size file)))) + (setcar result + (and (null (car result)) + (string-match "^213 +\\([0-9]+\\)$" (nth 1 result)) + (string-to-int + (substring + (cdr result) + (match-beginning 1) (match-end 1))))) + result))) + +;;;; ------------------------------------------------------------ +;;;; umask support +;;;; ------------------------------------------------------------ + +(defun efs-umask (user) + "Returns the umask that efs will use for USER. +If USER is root or anonymous, then the values of efs-root-umask +and efs-anonymous-umask, respectively, take precedence, to be followed +by the value of efs-umask, and if this is nil, it returns your current +umask on the local machine. Returns nil if this can't be determined." + (or + (and (string-equal user "root") efs-root-umask) + (and (efs-anonymous-p user) + efs-anonymous-umask) + efs-umask + (let* ((shell (or (and (boundp 'explicit-shell-file-name) + explicit-shell-file-name) + (getenv "ESHELL") + (getenv "SHELL") + "/bin/sh")) + (default-major-mode 'fundamental-mode) + (default-directory exec-directory) + (buff (get-buffer-create " *efs-umask-data*"))) + (unwind-protect + (save-excursion + (set-buffer buff) + (call-process shell nil buff nil "-c" "umask") + (goto-char (point-min)) + (if (re-search-forward "[0-7]?[0-7]?[0-7]" nil t) + (string-to-int (buffer-substring (match-beginning 0) + (match-end 0))))) + (kill-buffer buff))))) + +(defun efs-send-umask (host user mask) + "Sets the umask on HOST for USER to MASK. +Returns t for success, nil for failure." + (interactive + (let* ((path (or buffer-file-name + (and (eq major-mode 'dired-mode) + dired-directory))) + (parsed (and path (efs-ftp-path path))) + (default-host (car parsed)) + (default-user (nth 1 parsed)) + (default-mask (efs-umask default-user))) + (list + (read-string "Host: " default-host) + (read-string "User: " default-user) + (read-string "Umask: " (int-to-string default-mask))))) + (let (int-mask) + (if (integerp mask) + (setq int-mask mask + mask (int-to-string mask)) + (setq int-mask (string-to-int mask))) + (or (string-match "^ *[0-7]?[0-7]?[0-7] *$" mask) + (error "Invalid umask %s" mask)) + (efs-send-cmd host user + (list 'quote 'site 'umask mask) + (concat "Setting umask to " mask) + (list + (function + (lambda (int-mask) + (let ((buff (efs-ftp-process-buffer host user))) + (if (get-buffer buff) + (save-excursion + (set-buffer buff) + (setq efs-process-umask int-mask)))))) + int-mask) + (efs-cont (result line cont-lines) (host user mask) + (if result + (let ((buff (efs-ftp-process-buffer host user))) + (efs-set-host-property host 'umask-failed t) + (if (get-buffer buff) + (save-excursion + (set-buffer buff) + (setq efs-process-umask nil))) + (message + "Unable to set umask to %s on %s" mask host) + (if efs-ding-on-umask-failure + (progn + (ding) + (sit-for 1)))))) + 0))) ; Do this NOWAIT = 0 + +(defun efs-set-umask (host user) + "Sets the umask for HOST and USER, if it has not already been set." + (save-excursion + (set-buffer (process-buffer (efs-get-process host user))) + (if (or efs-process-umask (efs-get-host-property host 'umask-failed)) + nil + (let ((umask (efs-umask user))) + (efs-send-umask host user umask) + t)))) ; Tell the caller that we did something. + +(defun efs-modes-from-umask (umask) + ;; Given the 3 digit octal integer umask, returns the decimal integer + ;; according to chmod that a file would be written with. + ;; Assumes only ordinary files, so ignores x bits. + (let* ((others (% umask 10)) + (umask (/ umask 10)) + (group (% umask 10)) + (umask (/ umask 10)) + (owner (% umask 10)) + (factor 1)) + (apply '+ + (mapcar + (function + (lambda (x) + (prog1 + (* factor (- 6 (- x (% x 2)))) + (setq factor (* factor 8))))) + (list others group owner))))) + +;;;; ------------------------------------------------------------ +;;;; Idle time manipulation. +;;;; ------------------------------------------------------------ + +(defun efs-check-idle (host user) + ;; We just toss it in the queue to run whenever there's time. + ;; Just fail quietly if this doesn't work. + (if (and (or efs-maximize-idle efs-expire-ftp-buffers) + (memq (efs-host-type host) efs-idle-host-types) + (null (efs-get-host-property host 'idle-failed))) + (let ((buffname (efs-ftp-process-buffer host user))) + (efs-add-to-queue + host user + (list '(quote site idle) + nil nil + (efs-cont (result line cont-lines) (host user buffname) + (efs-save-match-data + (if (and (null result) + (string-match efs-idle-msgs line)) + (let ((max (substring line (match-beginning 2) + (match-end 2)))) + (if (get-buffer buffname) + (save-excursion + (set-buffer buffname) + (setq efs-process-idle-time + (string-to-int + (substring line (match-beginning 1) + (match-end 1)))))) + (if (and efs-maximize-idle + (not (efs-anonymous-p user))) + (efs-add-to-queue + host user + (list + (list 'quote 'site 'idle max) + nil nil + (efs-cont (result line cont-lines) (buffname + max) + (and (null result) + (get-buffer buffname) + (save-excursion + (set-buffer buffname) + (setq efs-process-idle-time + (string-to-int max))))) + 0)))) + (efs-set-host-property host 'idle-failed t)))) + 0 nil))))) ; Using NOWAIT = 0 inhibits mode line toggling. + + +;;;; ------------------------------------------------------------ +;;;; Sending the SYST command for system type. +;;;; ------------------------------------------------------------ + +(defun efs-get-syst (host user) + "Use SYST to get the remote system type. +Returns the system type as a string if this succeeds, otherwise nil." + (let* ((result (efs-send-cmd host user '(quote syst))) + (line (nth 1 result))) + (efs-save-match-data + (and (null (car result)) + (string-match efs-syst-msgs line) + (substring line (match-end 0)))))) + +;;;; ------------------------------------------------------------ +;;;; File transfer representation type support +;;;; ------------------------------------------------------------ + +;;; Legal representation types are: image, ascii, ebcdic, tenex + +(efs-defun efs-file-type nil (path) + ;; Returns the file type for PATH, the full efs path, with filename FILE. + ;; The return value is one of 'text, '8-binary, or '36-binary. + (let ((parsed (efs-ftp-path path))) + (efs-save-match-data + (cond + ;; There is no special significance to temp names, but we assume that + ;; they exist on an 8-bit byte machine. + ((or (null path) + (let ((temp (intern-soft path efs-tmp-name-obarray))) + (and temp (memq temp efs-tmp-name-files)))) + '8-binary) + ((and (null parsed) (file-exists-p path)) + (efs-local-file-type path)) + ;; test special hosts + ((and parsed + efs-binary-file-host-regexp + (let ((case-fold-search t)) + (string-match efs-binary-file-host-regexp (car parsed)))) + '8-binary) + (t + ;; Test file names + (let ((file (efs-internal-file-name-nondirectory + (or (nth 2 parsed) path)))) + (cond + ;; test for PDP-10 binaries + ((and efs-36-bit-binary-file-name-regexp + (string-match efs-36-bit-binary-file-name-regexp file)) + '36-binary) + ((and efs-binary-file-name-regexp + (string-match efs-binary-file-name-regexp file)) + '8-binary) + ((and efs-text-file-name-regexp + (string-match efs-text-file-name-regexp file)) + 'text) + ;; by default + (t + '8-binary)))))))) + +(efs-define-fun efs-local-file-type (file) + ;; Looks at the beginning (magic-cookie) of a local file to determine + ;; if it is a text file or not. If it's not a text file, it doesn't care + ;; about what type of binary file, so this doesn't really look for a magic + ;; cookie. + ;; Doesn't call efs-save-match-data. The caller should do so. + (save-excursion + (set-buffer (get-buffer-create efs-data-buffer-name)) + (erase-buffer) + (insert-file-contents file nil 0 16) + (if (looking-at "[ -~\n\r\C-L]*\\'") + 'text + '8-binary))) + +(defun efs-rationalize-file-type (f-type t-type) + ;; When the original and new names for a file indicate + ;; different file types, this function applies an ad hoc heuristic + ;; to return a single file type. + (cond + ((eq f-type t-type) + f-type) + ((memq '36-binary (list f-type t-type)) + '36-binary) + ((memq '8-binary (list f-type t-type)) + '8-binary) + (t + 'text))) + +(defun efs-prompt-for-transfer-type (arg) + "Toggles value of efs-prompt-for-transfer-type. +With prefix arg, turns prompting on if arg is positive, otherwise turns +prompting off." + (interactive "P") + (if (if arg + (> (prefix-numeric-value arg) 0) + (null efs-prompt-for-transfer-type)) + ;; turn prompting on + (prog1 + (setq efs-prompt-for-transfer-type t) + (message "Prompting for FTP transfer TYPE is on.")) + (prog1 + (setq efs-prompt-for-transfer-type nil) + (message "Prompting for FTP transfer TYPE is off.")))) + +(defun efs-read-xfer-type (path) + ;; Prompt for the transfer type to use for PATH + (let ((type + (completing-read + (format "FTP transfer TYPE for %s: " (efs-relativize-filename path)) + '(("binary") ("image") ("ascii") ("ebcdic") ("tenex")) + nil t))) + (if (string-equal type "binary") + 'image + (intern type)))) + +(defun efs-xfer-type (f-host-type f-path t-host-type t-path + &optional via-local) + ;; Returns the transfer type for transferring a file. + ;; F-HOST-TYPE = the host type of the machine on which the file is from. + ;; F-PATH = path, in full efs-syntax, of the original file + ;; T-HOST-TYPE = host-type of the machine to which the file is being + ;; transferred. + ;; VIA-LOCAL = non-nil of the file is being moved through the local, or + ;; a gateway machine. + ;; Set F-PATH or T-PATH to nil, to indicate that the file is being + ;; transferred from/to a temporary file, whose name has no significance. + (let (temp) + (and f-path + (setq temp (intern-soft f-path efs-tmp-name-obarray)) + (memq temp efs-tmp-name-files) + (setq f-path nil)) + (and t-path + (setq temp (intern-soft t-path efs-tmp-name-obarray)) + (memq temp efs-tmp-name-files) + (setq t-path nil))) + (if (or (null (or f-host-type t-host-type)) (null (or f-path t-path))) + 'image ; local copy? + (if efs-prompt-for-transfer-type + (efs-read-xfer-type (if f-path f-path t-path)) + (let ((f-fs (cdr (assq f-host-type efs-file-type-alist))) + (t-fs (cdr (assq t-host-type efs-file-type-alist)))) + (if (and f-fs t-fs + (if efs-treat-crlf-as-nl + (and (eq (car f-fs) (car t-fs)) + (eq (nth 1 f-fs) (nth 1 t-fs)) + (let ((f2-fs (nth 2 f-fs)) + (t2-fs (nth 2 t-fs))) + (or (eq f2-fs t2-fs) + (and (memq f2-fs '(file-crlf file-nl)) + (memq t2-fs '(file-crlf file-nl)))))) + (equal f-fs t-fs))) + 'image + (let ((type (cond + ((and f-path t-path) + (efs-rationalize-file-type + (efs-file-type t-host-type t-path) + (efs-file-type f-host-type f-path))) + (f-path + (efs-file-type f-host-type f-path)) + (t-path + (efs-file-type t-host-type t-path))))) + (cond + ((eq type '36-binary) + 'image) + ((eq type '8-binary) + (if (or (eq (car f-fs) '36-bit-wa) + (eq (car t-fs) '36-bit-wa)) + 'tenex + 'image)) + (t ; handles 'text + (if (and t-fs f-fs (eq (nth 1 f-fs) 'ebcdic) + (eq (nth 1 t-fs) 'ebcdic) (null via-local)) + 'ebcdic + 'ascii))))))))) + +(defun efs-set-xfer-type (host user type &optional clientless) + ;; Sets the xfer type for HOST and USER to TYPE. + ;; If the connection is already using the required type, does nothing. + ;; If clientless is non-nil, we are using a quoted xfer command, and + ;; need to check if the client has changed things. + (save-excursion + (let ((buff (process-buffer (efs-get-process host user)))) + (set-buffer buff) + (or (if (and clientless efs-process-client-altered-xfer-type) + (or (eq type efs-process-client-altered-xfer-type) + (setq efs-process-client-altered-xfer-type nil)) + ;; We are sending a non-clientless command, so the client + ;; gets back in synch. + (setq efs-process-client-altered-xfer-type nil) + (and efs-process-xfer-type + (eq type efs-process-xfer-type))) + (let ((otype efs-process-xfer-type)) + ;; Set this now in anticipation that the TYPE command will work, + ;; in case other commands, such as efs-set-hash-mark-unit want to + ;; grok this before the TYPE command completes. + (setq efs-process-xfer-type type) + (efs-send-cmd + host user (list 'type type) + nil nil + (efs-cont (result line cont-lines) (host user type otype buff) + (if result + (unwind-protect + (efs-error host user (format "TYPE %s failed: %s" + (upcase (symbol-name type)) + line)) + (if (get-buffer buff) + (save-excursion + (set-buffer buff) + (setq efs-process-xfer-type otype)))))) + 0)))))) ; always send type commands NOWAIT = 0 + + +;;;; ------------------------------------------------------------ +;;;; Obtaining DIR listings. +;;;; ------------------------------------------------------------ + +(defun efs-ls-guess-switches () + ;; Tries to determine what would be the most useful switches + ;; to use for a DIR listing. + (if (and (boundp 'dired-listing-switches) + (stringp dired-listing-switches) + (efs-parsable-switches-p dired-listing-switches t)) + dired-listing-switches + "-al")) + +(efs-defun efs-ls-dumb-check nil (line host file path lsargs msg noparse + noerror nowait cont) + nil) + +(efs-defun efs-ls-dumb-check unknown (line host file path lsargs + msg noparse noerror nowait cont) + ;; Checks to see if the host type might be dumb unix. If so, returns the + ;; listing otherwise nil. + (and + lsargs + (string-match + ;; Some CMU servers return a 530 here. 550 is correct. + (concat "^5[35]0 \\(The file \\)?" + (regexp-quote (concat lsargs " " path))) + ;; 550 is for a non-accessible file -- RFC959 + line) + (progn + (if (eq (efs-host-type host) 'apollo-unix) + (efs-add-host 'dumb-apollo-unix host) + (efs-add-host 'dumb-unix host)) + ;; try again + (if nowait + t ; return t if asynch + ; This is because dumb-check can't run asynch. + ; This means that we can't recognize dumb hosts asynch. + ; Shouldn't be a problem. + (efs-ls file nil + (if (eq msg t) + (format "Relisting %s" (efs-relativize-filename file)) + msg) + noparse noerror nowait cont))))) + +;; With no-error nil, this function returns: +;; an error if file is not an efs-path +;; (This should never happen.) +;; an error if either the listing is unreadable or there is an ftp error. +;; the listing (a string), if everything works. +;; +;; With no-error t, it returns: +;; an error if not an efs-path +;; error if listing is unreable (most likely caused by a slow connection) +;; nil if ftp error (this is because although asking to list a nonexistent +;; directory on a remote unix machine usually (except +;; maybe for dumb hosts) returns an ls error, but no +;; ftp error, if the same is done on a VMS machine, +;; an ftp error is returned. Need to trap the error +;; so we can go on and try to list the parent.) +;; the listing, if everything works. + +(defun efs-ls (file lsargs msg &optional noparse noerror nowait cont nlist) + "Return the output of a `DIR' or `ls' command done over ftp. +FILE is the full name of the remote file, LSARGS is any args to pass to the +`ls' command. MSG is a message to be displayed while listing, if MSG is given +as t, a suitable message will be computed. If nil, no message will be +displayed. If NOPARSE is non-nil, then the listing will not be parsed and +stored in internal cache. Otherwise, the listing will be parsed, if LSARGS +allow it. If NOERROR is non-nil, then we return nil if the listing fails, +rather than signal an error. If NOWAIT is non-nil, we do the listing +asynchronously, returning nil. If CONT is non-nil it is called with first +argument the listing string." + ;; If lsargs are nil, this forces a one-time only dumb listing using dir. + (setq file (efs-expand-file-name file)) + (let ((parsed (efs-ftp-path file))) + (if parsed + (let* ((host (nth 0 parsed)) + (user (nth 1 parsed)) + (path (nth 2 parsed)) + (host-type (efs-host-type host user)) + (listing-type (efs-listing-type host user)) + (parse (cond + ((null noparse) + (efs-parsable-switches-p lsargs t)) + ((eq noparse 'parse) + t) + (t nil))) + (switches lsargs) + cache) + + (if (memq host-type efs-dumb-host-types) + (setq lsargs nil)) + (if (and (null efs-ls-uncache) + (setq cache + (or (efs-get-from-ls-cache file switches) + (and switches + (efs-convert-from-ls-cache + file switches host-type listing-type))))) + ;; The listing is in the mail, errr... cache. + (let (listing) + (if (stringp cache) + (setq listing cache) + (setq listing (car cache)) + (if (and parse (null (nth 1 cache))) + (save-excursion + (set-buffer + (let ((default-major-mode 'fundamental-mode)) + (get-buffer-create + efs-data-buffer-name))) + (erase-buffer) + (insert listing) + (goto-char (point-min)) + (efs-set-files + file + (efs-parse-listing listing-type + host user path + file lsargs)) + ;; Note that we have parsed it now. + (setcar (cdr cache) t)))) + (if cont (efs-call-cont cont listing)) + listing) + + (if cache + (efs-del-from-ls-cache file nil nil)) + ;; Need to get the listing via FTP. + (let* ((temp (efs-make-tmp-name host nil)) + (temp-file (car temp)) + listing-result) + (efs-send-cmd + host user + (list (if nlist 'nlist 'dir) path (cdr temp) lsargs) + (if (eq msg t) + (format "Listing %s" (efs-relativize-filename file)) + msg) + nil + (efs-cont (result line cont-lines) + (host-type listing-type host user temp-file path + switches file lsargs noparse parse noerror + msg nowait cont) + ;; The client flipped to ascii, remember this. + (let ((buff (get-buffer + (efs-ftp-process-buffer host user)))) + (if buff + (efs-save-buffer-excursion + (set-buffer buff) + (setq efs-process-client-altered-xfer-type + 'ascii)))) + (unwind-protect + (if result + (or (setq listing-result + (efs-ls-dumb-check + (and (or (eq host-type 'unknown) + (eq listing-type 'unix:unknown)) + 'unknown) + line host file path lsargs msg + noparse noerror nowait cont)) + ;; If dumb-check returns non-nil + ;; then it would have handled any error recovery + ;; and conts. listing-result would only be set to + ;; t if nowait was non-nil. Therefore, the final + ;; return for efs-ls could never be t, even if I + ;; set listing-result to t here. + (if noerror + (if cont + (efs-call-cont cont nil)) + (efs-error host user + (concat "DIR failed: " + line)))) + + ;; listing worked + (if (efs-ftp-path temp-file) + (efs-add-file-entry (efs-host-type efs-gateway-host) + temp-file nil nil nil)) + (save-excursion + ;; A hack to get around a jka-compr problem. + ;; Do we still need it? + (let ((default-major-mode 'fundamental-mode) + efs-verbose jka-compr-enabled) + (set-buffer (get-buffer-create + efs-data-buffer-name)) + (erase-buffer) + (if (or (file-readable-p temp-file) + (sleep-for efs-retry-time) + (file-readable-p temp-file)) + (insert-file-contents temp-file) + (efs-error host user + (format + "list data file %s not readable" + temp-file)))) + (if parse + (progn + (efs-set-files + file + (efs-parse-listing listing-type host user path + file lsargs)) + ;; Parsing may update the host type. + (and lsargs (memq (efs-host-type host) + efs-dumb-host-types) + (setq lsargs nil)))) + (let ((listing (buffer-string))) + (efs-add-to-ls-cache file lsargs listing parse) + (if (and (null lsargs) switches) + ;; Try to convert + (let ((conv (efs-get-ls-converter switches))) + (and conv + (setq conv (assoc + (char-to-string 0) + conv)) + (funcall (cdr conv) listing-type nil) + (setq listing (buffer-string))))) + (or nowait (setq listing-result listing)) + ;; Call the ls cont, with first arg the + ;; listing string. + (if cont + (efs-call-cont cont listing))))) + (efs-del-tmp-name temp-file))) + nowait) + (and (null nowait) listing-result)))) + (error "Attempt to get a remote listing for the local file %s" file)))) + + +;;;; =============================================================== +;;;; >7 +;;;; Parsing and storing remote file system data. +;;;; =============================================================== + +;;; The directory listing parsers do some host type guessing. +;;; Most of the host type guessing is done when the PWD output +;;; is parsed. A bit is done when the error codes for DIR are +;;; analyzed. + +;;;; ----------------------------------------------------------- +;;;; Caching directory listings. +;;;; ----------------------------------------------------------- + +;;; Aside from storing files data in a hashtable, a limited number +;;; of listings are stored in complete form in `efs-ls-cache'. + +(defun efs-del-from-ls-cache (file &optional parent-p dir-p) + ;; Deletes from the ls cache the listing for FILE. + ;; With optional PARENT-P, deletes any entry for the parent + ;; directory of FILE too. + ;; If DIR-P is non-nil, then the directory listing of FILE is to be deleted. + (if dir-p + (setq file (file-name-as-directory file)) + (setq file (directory-file-name file))) + (setq file (efs-canonize-file-name file)) + (if parent-p + (setq parent-p (file-name-directory + (if dir-p + (directory-file-name file) + file)))) + (setq efs-ls-cache + (delq nil + (mapcar + (if parent-p + (function + (lambda (x) + (let ((f-ent (car x))) + (and (not (string-equal file f-ent)) + (not (string-equal parent-p f-ent)) + x)))) + (function + (lambda (x) + (and (not (string-equal file (car x))) + x)))) + efs-ls-cache)))) + +(defun efs-wipe-from-ls-cache (host user) + ;; Remove from efs-ls-cache all listings for HOST and USER. + (let ((host (downcase host)) + (case-insens (memq (efs-host-type host) + efs-case-insensitive-host-types))) + (if case-insens (setq user (downcase user))) + (setq efs-ls-cache + (delq nil + (mapcar + (function + (lambda (x) + (let ((parsed (efs-ftp-path (car x)))) + (and (not + (and (string-equal (car parsed) host) + (string-equal (if case-insens + (downcase (nth 1 parsed)) + (nth 1 parsed)) + user))) + x)))) + efs-ls-cache))))) + +(defun efs-get-from-ls-cache (file switches) + ;; Returns the value in `ls-cache' for FILE and SWITCHES. + ;; Returns a list consisting of the listing string, and whether its + ;; already been parsed. This list is eq to the nthcdr 2 of the actual + ;; cache entry, so you can setcar it. + ;; For dumb listings, SWITCHES will be nil. + (let ((list efs-ls-cache) + (switches (efs-canonize-switches switches)) + (file (efs-canonize-file-name file))) + (catch 'done + (while list + (if (and (string-equal file (car (car list))) + (string-equal switches (nth 1 (car list)))) + (throw 'done (nthcdr 2 (car list))) + (setq list (cdr list))))))) + +(defun efs-add-to-ls-cache (file switches listing parsed) + ;; Only call after efs-get-from-cache returns nil, to avoid duplicate + ;; entries. PARSED should be t, if the listing has already been parsed. + (and (> efs-ls-cache-max 0) + (let ((switches (efs-canonize-switches switches)) + (file (efs-canonize-file-name file))) + (if (= efs-ls-cache-max 1) + (setq efs-ls-cache + (list (list file switches listing parsed))) + (if (>= (length efs-ls-cache) efs-ls-cache-max) + (setcdr (nthcdr (- efs-ls-cache-max 2) efs-ls-cache) nil)) + (setq efs-ls-cache (cons (list file switches listing parsed) + efs-ls-cache)))))) + +;;;; -------------------------------------------------------------- +;;;; Converting listings from cache. +;;;; -------------------------------------------------------------- + +(defun efs-get-ls-converter (to-switches) + ;; Returns converter alist for TO-SWITCHES + (efs-get-hash-entry (efs-canonize-switches to-switches) + efs-ls-converter-hashtable)) + +(defun efs-add-ls-converter (to-switches from-switches converter) + ;; Adds an entry to `efs-ls-converter-hashtable'. + ;; If from-switches is t, the converter converts from internal files + ;; hashtable. + (let* ((to-switches (efs-canonize-switches to-switches)) + (ent (efs-get-hash-entry to-switches efs-ls-converter-hashtable)) + (add (cons (or (eq from-switches t) + (efs-canonize-switches from-switches)) + converter))) + (if ent + (or (member add ent) + (nconc ent (list add))) + (efs-put-hash-entry to-switches (list add) efs-ls-converter-hashtable)))) + +(defun efs-convert-from-ls-cache (file switches host-type listing-type) + ;; Returns a listing by converting the switches from a cached listing. + (let ((clist (efs-get-ls-converter switches)) + (dir-p (= ?/ (aref file (1- (length file))))) + elt listing result regexp alist) + (while file ; this loop will iterate at most twice. + (setq alist clist) + (while alist + (setq elt (car alist)) + (if (eq (car elt) t) + (if (and dir-p (setq result (funcall (cdr elt) host-type + (let ((efs-ls-uncache t)) + (efs-get-files file)) + regexp))) + (setq alist nil + file nil) + (setq alist (cdr alist))) + (if (and (setq listing + (efs-get-from-ls-cache file (car elt))) + (save-excursion + (set-buffer + (let ((default-major-mode 'fundamental-mode)) + (get-buffer-create efs-data-buffer-name))) + (erase-buffer) + (insert (car listing)) + (and (funcall (cdr elt) listing-type regexp) + (setq result (buffer-string))))) + (setq alist nil + file nil) + (setq alist (cdr alist))))) + ;; Look for wildcards. + (if (and file (null dir-p) (null regexp)) + (setq regexp (efs-shell-regexp-to-regexp + (file-name-nondirectory file)) + file (file-name-directory file) + dir-p t) + (setq file nil))) + result)) + +;;; Define some converters + +(defun efs-unix-t-converter-sort-pred (elt1 elt2) + (let* ((data1 (car elt1)) + (data2 (car elt2)) + (year1 (car data1)) + (year2 (car data2)) + (month1 (nth 1 data1)) + (month2 (nth 1 data2)) + (day1 (nth 2 data1)) + (day2 (nth 2 data2)) + (hour1 (nth 3 data1)) + (hour2 (nth 3 data2)) + (minutes1 (nth 4 data1)) + (minutes2 (nth 4 data2))) + (if year1 + (and year2 + (or (> year1 year2) + (and (= year1 year2) + (or (> month1 month2) + (and (= month1 month2) + (> day1 day2)))))) + (if year2 + t + (or (> month1 month2) + (and (= month1 month2) + (or (> day1 day2) + (and (= day1 day2) + (or (> hour1 hour2) + (and (= hour1 hour2) + (> minutes1 minutes2))))))))))) + +(defun efs-unix-t-converter (&optional regexp reverse) + (if regexp + nil + (goto-char (point-min)) + (efs-save-match-data + (if (re-search-forward efs-month-and-time-regexp nil t) + (let ((current-month (cdr (assoc (substring + (current-time-string) 4 7) + efs-month-alist))) + list-start start end list year month day hour minutes) + (beginning-of-line) + (setq list-start (point)) + (while (progn + (setq start (point)) + (forward-line 1) + (setq end (point)) + (goto-char start) + (re-search-forward efs-month-and-time-regexp end t)) + ;; Need to measure wrto the current month + ;; There is a bug here if because of time-zone shifts, the + ;; local machine and the remote one are on different months. + (setq month (% (+ (- 11 current-month) + (cdr (assoc + (buffer-substring (match-beginning 2) + (match-end 2)) + efs-month-alist))) 12) + day (string-to-int + (buffer-substring (match-beginning 3) (match-end 3))) + year (buffer-substring (match-beginning 4) (match-end 4))) + (if (string-match ":" year) + (setq hour (string-to-int (substring year 0 + (match-beginning 0))) + minutes (string-to-int (substring year (match-end 0))) + year nil) + (setq hour nil + minutes nil + year (string-to-int year))) + (setq list (cons + (cons + (list year month day hour minutes) + (buffer-substring start end)) + list)) + (goto-char end)) + (setq list + (mapcar 'cdr + (sort list 'efs-unix-t-converter-sort-pred))) + (if reverse (setq list (nreverse list))) + (delete-region list-start (point)) + (apply 'insert list) + t))))) + +(efs-defun efs-t-converter nil (&optional regexp reverse) + ;; Converts listing without the t-switch, to ones with it. + nil) ; by default assume that we cannot work. + +(efs-fset 'efs-t-converter 'unix 'efs-unix-t-converter) +(efs-fset 'efs-t-converter 'sysV-unix 'efs-unix-t-converter) +(efs-fset 'efs-t-converter 'apollo-unix 'efs-unix-t-converter) +(efs-fset 'efs-t-converter 'bsd-unix 'efs-unix-t-converter) +(efs-fset 'efs-t-converter 'dumb-unix 'efs-unix-t-converter) +(efs-fset 'efs-t-converter 'dumb-apollo-unix 'efs-unix-t-converter) +(efs-fset 'efs-t-converter 'super-dumb-unix 'efs-unix-t-converter) + +(defun efs-rt-converter (listing-type &optional regexp) + ;; Reverse time sorting + (efs-t-converter listing-type regexp t)) + +(defun efs-unix-alpha-converter (&optional regexp reverse) + (if regexp + nil + (goto-char (point-min)) + (efs-save-match-data + (if (re-search-forward efs-month-and-time-regexp nil t) + (let (list list-start end start next) + (beginning-of-line) + (setq list-start (point)) + (while (progn + (setq start (point)) + (end-of-line) + (setq end (point) + next (1+ end)) + (goto-char start) + (re-search-forward efs-month-and-time-regexp end t)) + ;; Need to measure wrto the current month + ;; There is a bug here if because of time-zone shifts, the + ;; local machine and the remote one are on different months. + (setq list + (cons + (cons (buffer-substring (point) end) + (buffer-substring start next)) + list)) + (goto-char next)) + (delete-region list-start (point)) + (apply 'insert + (mapcar 'cdr + (sort list (if reverse + (function + (lambda (x y) + (string< (car y) (car x)))) + (function + (lambda (x y) + (string< (car x) (car y)))))))) + t))))) + +(efs-defun efs-alpha-converter nil (&optional regexp reverse) + ;; Converts listing to lexigraphical order. + nil) ; by default assume that we cannot work. + +(efs-fset 'efs-alpha-converter 'unix 'efs-unix-alpha-converter) +(efs-fset 'efs-alpha-converter 'sysV-unix 'efs-unix-alpha-converter) +(efs-fset 'efs-alpha-converter 'apollo-unix 'efs-unix-alpha-converter) +(efs-fset 'efs-alpha-converter 'bsd-unix 'efs-unix-alpha-converter) +(efs-fset 'efs-alpha-converter 'dumb-unix 'efs-unix-alpha-converter) +(efs-fset 'efs-alpha-converter 'dumb-apollo-unix 'efs-unix-alpha-converter) +(efs-fset 'efs-alpha-converter 'super-dumb-unix 'efs-unix-alpha-converter) + +(defun efs-ralpha-converter (listing-type &optional regexp) + ;; Reverse alphabetic + (efs-alpha-converter listing-type regexp t)) + +(defun efs-unix-S-converter (&optional regexp reverse) + (if regexp + nil + (goto-char (point-min)) + (efs-save-match-data + (if (re-search-forward efs-month-and-time-regexp nil t) + (let (list list-start start next) + (beginning-of-line) + (setq list-start (point)) + (while (progn + (setq start (point)) + (forward-line 1) + (setq next (point)) + (goto-char start) + (re-search-forward efs-month-and-time-regexp next t)) + ;; Need to measure wrto the current month + ;; There is a bug here if because of time-zone shifts, the + ;; local machine and the remote one are on different months. + (setq list + (cons + (cons (string-to-int + (buffer-substring (match-beginning 1) + (match-end 1))) + (buffer-substring start next)) + list)) + (goto-char next)) + (delete-region list-start (point)) + (apply 'insert + (mapcar 'cdr + (sort list (if reverse + (function + (lambda (x y) + (< (car x) (car y)))) + (function + (lambda (x y) + (> (car x) (car y)))))))) + t))))) + +(efs-defun efs-S-converter nil (&optional regexp reverse) + ;; Converts listing without the S-switch, to ones with it. + nil) ; by default assume that we cannot work. + +(efs-fset 'efs-S-converter 'unix 'efs-unix-S-converter) +(efs-fset 'efs-S-converter 'sysV-unix 'efs-unix-S-converter) +(efs-fset 'efs-S-converter 'apollo-unix 'efs-unix-S-converter) +(efs-fset 'efs-S-converter 'bsd-unix 'efs-unix-S-converter) +(efs-fset 'efs-S-converter 'dumb-unix 'efs-unix-S-converter) +(efs-fset 'efs-S-converter 'dumb-apollo-unix 'efs-unix-S-converter) +(efs-fset 'efs-S-converter 'super-dumb-unix 'efs-unix-S-converter) + +(defun efs-rS-converter (listing-type &optional regexp) + ;; Reverse S switch. + (efs-S-converter listing-type regexp t)) + +(defun efs-unix-X-converter (&optional regexp reverse) + (if regexp + nil + (goto-char (point-min)) + (efs-save-match-data + (if (re-search-forward efs-month-and-time-regexp nil t) + (let (next list list-start fnstart eol start end link-p) + (beginning-of-line) + (setq list-start (point)) + (while (progn + (setq start (point)) + (skip-chars-forward "0-9 ") + (setq link-p (= (following-char) ?l)) + (end-of-line) + (setq eol (point) + next (1+ eol)) + (goto-char start) + (re-search-forward efs-month-and-time-regexp eol t)) + ;; Need to measure wrto the current month + ;; There is a bug here if because of time-zone shifts, the + ;; local machine and the remote one are on different months. + (setq fnstart (point)) + (or (and link-p (search-forward " -> " eol t) + (goto-char (match-beginning 0))) + (goto-char eol)) + (setq end (point)) + (skip-chars-backward "^." fnstart) + (setq list + (cons + (cons + (if (= (point) fnstart) + "" + (buffer-substring (point) end)) + (buffer-substring start next)) + list)) + (goto-char next)) + (delete-region list-start (point)) + (apply 'insert + (mapcar 'cdr + (sort list (if reverse + (function + (lambda (x y) + (string< (car y) (car x)))) + (function + (lambda (x y) + (string< (car x) (car y)))))))) + t))))) + +(efs-defun efs-X-converter nil (&optional regexp reverse) + ;; Sort on file name extension. By default do nothing + nil) + +(defun efs-rX-converter (listing-type &optional regexp) + (efs-X-converter listing-type regexp t)) + +(efs-fset 'efs-X-converter 'unix 'efs-unix-X-converter) +(efs-fset 'efs-X-converter 'sysV-unix 'efs-unix-X-converter) +(efs-fset 'efs-X-converter 'apollo-unix 'efs-unix-X-converter) +(efs-fset 'efs-X-converter 'bsd-unix 'efs-unix-X-converter) +(efs-fset 'efs-X-converter 'dumb-unix 'efs-unix-X-converter) +(efs-fset 'efs-X-converter 'dumb-apollo-unix 'efs-unix-X-converter) +(efs-fset 'efs-X-converter 'super-dumb-unix 'efs-unix-X-converter) + +;;; Brief listings + +;;; The following functions do a heap better at packing than +;;; the usual ls listing. A variable column width is used. +(defun efs-column-widths (columns list &optional across) + ;; Returns the column widths for breaking LIST into + ;; COLUMNS number of columns. + (cond + ((null list) + nil) + ((= columns 1) + (list (apply 'max (mapcar 'length list)))) + ((let* ((len (length list)) + (col-length (/ len columns)) + (remainder (% len columns)) + (i 0) + (j 0) + (max-width 0) + widths padding) + (if (zerop remainder) + (setq padding 0) + (setq col-length (1+ col-length) + padding (- columns remainder))) + (setq list (nconc (copy-sequence list) (make-list padding nil))) + (setcdr (nthcdr (1- (+ len padding)) list) list) + (while (< i columns) + (while (< j col-length) + (setq max-width (max max-width (length (car list))) + list (if across (nthcdr columns list) (cdr list)) + j (1+ j))) + (setq widths (cons (+ max-width 2) widths) + max-width 0 + j 0 + i (1+ i)) + (if across (setq list (cdr list)))) + (setcar widths (- (car widths) 2)) + (nreverse widths))))) + +(defun efs-calculate-columns (list &optional across) + ;; Returns a list of integers which are the column widths that best pack + ;; LIST, a list of strings, onto the screen. + (and list + (let* ((width (1- (window-width))) + (columns (max 1 (/ width + (+ 2 (apply 'max (mapcar 'length list)))))) + col-list last-col-list) + (while (<= (apply '+ (setq col-list + (efs-column-widths columns list across))) + width) + (setq columns (1+ columns) + last-col-list col-list)) + (or last-col-list col-list)))) + +(defun efs-format-columns-of-files (files &optional across) + ;; Returns the number of lines used. + ;; If ACROSS is non-nil, sorts across rather than down the buffer, like + ;; ls -x + ;; A beefed up version of the function in dired. Thanks Sebastian. + (and files + (let* ((columns (efs-calculate-columns files across)) + (ncols (length columns)) + (ncols1 (1- ncols)) + (nfiles (length files)) + (nrows (+ (/ nfiles ncols) + (if (zerop (% nfiles ncols)) 0 1))) + (space-left (- (window-width) (apply '+ columns) 1)) + (stretch (/ space-left ncols1)) + (float-stretch (if (zerop ncols1) 0 (% space-left ncols1))) + (i 0) + (j 0) + (result "") + file padding) + (setq files (nconc (copy-sequence files) ; fill up with empty fns + (make-list (- (* ncols nrows) nfiles) ""))) + (setcdr (nthcdr (1- (length files)) files) files) ; make circular + (while (< j nrows) + (while (< i ncols) + (setq result (concat result (setq file (car files)))) + (setq padding (- (nth i columns) (length file))) + (or (= i ncols1) + (progn + (setq padding (+ padding stretch)) + (if (< i float-stretch) (setq padding (1+ padding))))) + (setq result (concat result (make-string padding ?\ ))) + (setq files (if across (cdr files) (nthcdr nrows files)) + i (1+ i))) + (setq result (concat result "\n")) + (setq i 0 + j (1+ j)) + (or across (setq files (cdr files)))) + result))) + +(defun efs-brief-converter (host-type file-table F a A p x C &optional regexp) + ;; Builds a brief directory listing for file cache, with + ;; possible switches F, a, A, p, x. + (efs-save-match-data + (let (list ent modes) + (efs-map-hashtable + (function + (lambda (key val) + (if (and + (efs-really-file-p host-type key val) + (or a + (and A (not (or (string-equal "." key) + (string-equal ".." key)))) + (/= (string-to-char key) ?.)) + (or (null regexp) + (string-match regexp key))) + (setq ent (car val) + modes (nth 3 val) + list (cons + (cond ((null (or F p)) + key) + ((eq t ent) + (concat key "/")) + ((cond + ((null F) + key) + ((stringp ent) + (concat key "@")) + ((null modes) + key) + ((eq (string-to-char modes) ?s) + ;; a socket + (concat key "=")) + ((or + (memq (elt modes 3) '(?x ?s ?t)) + (memq (elt modes 6) '(?x ?s ?t)) + (memq (elt modes 9) '(?x ?s ?t))) + (concat key "*")) + (t + key)))) + list))))) + file-table) + (setq list (sort list 'string<)) + (if (or C x) + (efs-format-columns-of-files list x) + (concat (mapconcat 'identity list "\n") "\n"))))) + +;;; Store converters. + +;; The cheaters. +(efs-add-ls-converter "-al" nil (function + (lambda (listing-type &optional regexp) + (null regexp)))) +(efs-add-ls-converter "-Al" nil (function + (lambda (listing-type &optional regexp) + (null regexp)))) +(efs-add-ls-converter "-alF" nil (function + (lambda (listing-type &optional regexp) + (null regexp)))) +(efs-add-ls-converter "-AlF" nil (function + (lambda (listing-type &optional regexp) + (null regexp)))) + +(efs-add-ls-converter "-alt" "-al" 'efs-t-converter) +(efs-add-ls-converter "-Alt" "-Al" 'efs-t-converter) +(efs-add-ls-converter "-lt" "-l" 'efs-t-converter) +(efs-add-ls-converter "-altF" "-alF" 'efs-t-converter) +(efs-add-ls-converter "-AltF" "-AlF" 'efs-t-converter) +(efs-add-ls-converter "-ltF" "-lF" 'efs-t-converter) +(efs-add-ls-converter "-alt" nil 'efs-t-converter) +(efs-add-ls-converter "-altF" nil 'efs-t-converter) +(efs-add-ls-converter "-Alt" nil 'efs-t-converter) ; cheating a bit +(efs-add-ls-converter "-AltF" nil 'efs-t-converter) ; cheating a bit + +(efs-add-ls-converter "-altr" "-al" 'efs-rt-converter) +(efs-add-ls-converter "-Altr" "-Al" 'efs-rt-converter) +(efs-add-ls-converter "-ltr" "-l" 'efs-rt-converter) +(efs-add-ls-converter "-altFr" "-alF" 'efs-rt-converter) +(efs-add-ls-converter "-AltFr" "-AlF" 'efs-rt-converter) +(efs-add-ls-converter "-ltFr" "-lF" 'efs-rt-converter) +(efs-add-ls-converter "-altr" nil 'efs-rt-converter) +(efs-add-ls-converter "-Altr" nil 'efs-rt-converter) + +(efs-add-ls-converter "-alr" "-alt" 'efs-alpha-converter) +(efs-add-ls-converter "-Alr" "-Alt" 'efs-alpha-converter) +(efs-add-ls-converter "-lr" "-lt" 'efs-alpha-converter) +(efs-add-ls-converter "-alFr" "-alFt" 'efs-alpha-converter) +(efs-add-ls-converter "-AlFr" "-AlFt" 'efs-alpha-converter) +(efs-add-ls-converter "-lFr" "-lFt" 'efs-alpha-converter) + +(efs-add-ls-converter "-al" "-alt" 'efs-alpha-converter) +(efs-add-ls-converter "-Al" "-Alt" 'efs-alpha-converter) +(efs-add-ls-converter "-l" "-lt" 'efs-alpha-converter) +(efs-add-ls-converter "-alF" "-alFt" 'efs-alpha-converter) +(efs-add-ls-converter "-AlF" "-AlFt" 'efs-alpha-converter) +(efs-add-ls-converter "-lF" "-lFt" 'efs-alpha-converter) +(efs-add-ls-converter nil "-alt" 'efs-alpha-converter) + +(efs-add-ls-converter "-alr" "-al" 'efs-ralpha-converter) +(efs-add-ls-converter "-Alr" "-Al" 'efs-ralpha-converter) +(efs-add-ls-converter "-lr" "-l" 'efs-ralpha-converter) +(efs-add-ls-converter "-alFr" "-alF" 'efs-ralpha-converter) +(efs-add-ls-converter "-lAFr" "-lAF" 'efs-ralpha-converter) +(efs-add-ls-converter "-lFr" "-lF" 'efs-ralpha-converter) +(efs-add-ls-converter "-alr" nil 'efs-ralpha-converter) + +(efs-add-ls-converter "-alr" "-alt" 'efs-ralpha-converter) +(efs-add-ls-converter "-Alr" "-Alt" 'efs-ralpha-converter) +(efs-add-ls-converter "-lr" "-lt" 'efs-ralpha-converter) +(efs-add-ls-converter "-alFr" "-alFt" 'efs-ralpha-converter) +(efs-add-ls-converter "-lAFr" "-lAFt" 'efs-ralpha-converter) +(efs-add-ls-converter "-lFr" "-lFt" 'efs-ralpha-converter) + +(efs-add-ls-converter "-alS" "-al" 'efs-S-converter) +(efs-add-ls-converter "-AlS" "-Al" 'efs-S-converter) +(efs-add-ls-converter "-lS" "-l" 'efs-S-converter) +(efs-add-ls-converter "-alSF" "-alF" 'efs-S-converter) +(efs-add-ls-converter "-AlSF" "-AlF" 'efs-S-converter) +(efs-add-ls-converter "-lSF" "-lF" 'efs-S-converter) +(efs-add-ls-converter "-alS" nil 'efs-S-converter) + +(efs-add-ls-converter "-alSr" "-al" 'efs-rS-converter) +(efs-add-ls-converter "-AlSr" "-Al" 'efs-rS-converter) +(efs-add-ls-converter "-lSr" "-l" 'efs-rS-converter) +(efs-add-ls-converter "-alSFr" "-alF" 'efs-rS-converter) +(efs-add-ls-converter "-AlSFr" "-AlF" 'efs-rS-converter) +(efs-add-ls-converter "-lSFr" "-lF" 'efs-rS-converter) +(efs-add-ls-converter "-alSr" nil 'efs-rS-converter) + +(efs-add-ls-converter "-alS" "-alt" 'efs-S-converter) +(efs-add-ls-converter "-AlS" "-Alt" 'efs-S-converter) +(efs-add-ls-converter "-lS" "-lt" 'efs-S-converter) +(efs-add-ls-converter "-alSF" "-alFt" 'efs-S-converter) +(efs-add-ls-converter "-AlSF" "-AlFt" 'efs-S-converter) +(efs-add-ls-converter "-lSF" "-lFt" 'efs-S-converter) + +(efs-add-ls-converter "-alSr" "-alt" 'efs-rS-converter) +(efs-add-ls-converter "-AlSr" "-Alt" 'efs-rS-converter) +(efs-add-ls-converter "-lSr" "-lt" 'efs-rS-converter) +(efs-add-ls-converter "-alSFr" "-alFt" 'efs-rS-converter) +(efs-add-ls-converter "-AlSFr" "-AlFt" 'efs-rS-converter) +(efs-add-ls-converter "-lSFr" "-lFt" 'efs-rS-converter) + +(efs-add-ls-converter "-AlX" nil 'efs-X-converter) +(efs-add-ls-converter "-alX" nil 'efs-X-converter) +(efs-add-ls-converter "-AlXr" nil 'efs-rX-converter) +(efs-add-ls-converter "-alXr" nil 'efs-rX-converter) + +(efs-add-ls-converter "-alX" "-al" 'efs-X-converter) +(efs-add-ls-converter "-AlX" "-Al" 'efs-X-converter) +(efs-add-ls-converter "-lX" "-l" 'efs-X-converter) +(efs-add-ls-converter "-alXF" "-alF" 'efs-X-converter) +(efs-add-ls-converter "-AlXF" "-AlF" 'efs-X-converter) +(efs-add-ls-converter "-lXF" "-lF" 'efs-X-converter) + +(efs-add-ls-converter "-alXr" "-al" 'efs-rX-converter) +(efs-add-ls-converter "-AlXr" "-Al" 'efs-rX-converter) +(efs-add-ls-converter "-lXr" "-l" 'efs-rX-converter) +(efs-add-ls-converter "-alXFr" "-alF" 'efs-rX-converter) +(efs-add-ls-converter "-AlXFr" "-AlF" 'efs-rX-converter) +(efs-add-ls-converter "-lXFr" "-lF" 'efs-rX-converter) + +;;; Converters for efs-files-hashtable + +(efs-add-ls-converter + "" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files + nil nil nil nil nil nil regexp)))) +(efs-add-ls-converter + "-C" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files + nil nil nil nil nil t regexp)))) +(efs-add-ls-converter + "-F" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files + t nil nil nil nil nil regexp)))) +(efs-add-ls-converter + "-p" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files + nil nil nil t nil nil regexp)))) +(efs-add-ls-converter + "-CF" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files + t nil nil nil nil t regexp)))) +(efs-add-ls-converter + "-Cp" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files nil nil nil t nil t regexp)))) +(efs-add-ls-converter + "-x" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files + nil nil nil nil t nil regexp)))) +(efs-add-ls-converter + "-xF" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files t nil nil nil t nil regexp)))) +(efs-add-ls-converter + "-xp" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files nil nil nil t t nil regexp)))) +(efs-add-ls-converter + "-Ca" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files nil t nil nil nil t regexp)))) +(efs-add-ls-converter + "-CFa" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files t t nil nil nil t regexp)))) +(efs-add-ls-converter + "-Cpa" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files nil t nil t nil t regexp)))) +(efs-add-ls-converter + "-xa" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files nil t nil nil t nil regexp)))) +(efs-add-ls-converter + "-xFa" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files t t nil nil t nil regexp)))) +(efs-add-ls-converter + "-xpa" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files nil t nil t t nil regexp)))) +(efs-add-ls-converter + "-CA" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files nil nil t nil nil t regexp)))) +(efs-add-ls-converter + "-CFA" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files t nil t nil nil t regexp)))) +(efs-add-ls-converter + "-CpA" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files nil nil t t nil t regexp)))) +(efs-add-ls-converter + "-xA" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files nil nil t nil t nil regexp)))) +(efs-add-ls-converter + "-xFA" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files t nil t nil t nil regexp)))) +(efs-add-ls-converter + "-xpA" t (function + (lambda (host-type files &optional regexp) + (efs-brief-converter host-type files nil nil t t t nil regexp)))) + +;;;; ------------------------------------------------------------ +;;;; Directory Listing Parsers +;;;; ------------------------------------------------------------ + +(defconst efs-unix:dl-listing-regexp + "^[^ \n\t]+\n? +\\([0-9]+\\|-\\|=\\) ") + +;; Note to progammers: +;; Below are a series of macros and functions used for parsing unix +;; file listings. They are intended only to be used together, so be careful +;; about using them out of context. + +(defmacro efs-ls-parse-file-line () + ;; Extract the filename, size, and permission string from the current + ;; line of a dired-like listing. Assumes that the point is at + ;; the beginning of the line, leaves it just before the size entry. + ;; Returns a list (name size perm-string nlinks owner). + ;; If there is no file on the line, returns nil. + (` (let ((eol (save-excursion (end-of-line) (point))) + name size modes nlinks owner) + (skip-chars-forward " 0-9" eol) + (and + (looking-at efs-modes-links-owner-regexp) + (setq modes (buffer-substring (match-beginning 1) + (match-end 1)) + nlinks (string-to-int (buffer-substring (match-beginning 2) + (match-end 2))) + owner (buffer-substring (match-beginning 3) (match-end 3))) + (re-search-forward efs-month-and-time-regexp eol t) + (setq name (buffer-substring (point) eol) + size (string-to-int (buffer-substring (match-beginning 1) + (match-end 1)))) + (list name size modes nlinks owner))))) + +(defun efs-relist-symlink (host user symlink path switches) + ;; Does a re-list of a single symlink in efs-data-buffer-name-2, + ;; HOST = remote host + ;; USER = remote username + ;; SYMLINK = symbolic link name as a remote fullpath + ;; PATH = efs full path syntax for the dir. being listed + ;; SWITCHES = ls switches to use for the re-list + ;; Returns (symlink-name symlink-target), as given by the listing. Returns + ;; nil if the listing fails. + ;; Does NOT correct for any symlink marking. + (let* ((temp (efs-make-tmp-name host nil)) + (temp-file (car temp)) + (default-major-mode 'fundamental-mode) + spot) + (unwind-protect + (and + (prog1 + (null + (car + (efs-send-cmd host user + (list 'dir symlink (cdr temp) switches) + (format "Listing %s" + (efs-relativize-filename + (efs-replace-path-component + path symlink)))))) + ;; Put the old message back. + (if (and efs-verbose + (not (and (boundp 'dired-in-query) dired-in-query))) + (message "Listing %s..." + (efs-relativize-filename path)))) + (save-excursion + (if (efs-ftp-path temp-file) + (efs-add-file-entry (efs-host-type efs-gateway-host) + temp-file nil nil nil)) + (set-buffer (get-buffer-create efs-data-buffer-name-2)) + (erase-buffer) + (if (or (file-readable-p temp-file) + (sleep-for efs-retry-time) + (file-readable-p temp-file)) + (let (efs-verbose) + (insert-file-contents temp-file)) + (efs-error host user + (format + "list data file %s not readable" temp-file))) + (skip-chars-forward " 0-9") + (and + (eq (following-char) ?l) + (re-search-forward efs-month-and-time-regexp nil t) + (setq spot (point)) + (re-search-forward " -> " nil t) + (progn + (end-of-line) + (list + ;; We might get the full path in the listing. + (file-name-nondirectory + (buffer-substring spot (match-beginning 0))) + (buffer-substring (match-end 0) (point))))))) + (efs-del-tmp-name temp-file)))) + +(defun efs-ls-sysV-p (host user dir linkname path) + ;; Returns t if the symlink is listed in sysV style. i.e. The + ;; symlink name is marked with an @. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory being listed as a remote full path. + ;; LINKNAME = relative name of symbolic link as derived from an ls -..F... + ;; this is assumed to end with an @ + ;; PATH = efs full path synatx for the directory + (let ((link (car (efs-relist-symlink + host user + (concat dir (substring linkname 0 -1)) + path "-lFd" )))) + (and link (string-equal link linkname)))) + +(defun efs-ls-next-p (host user dir linkname target path) + ;; Returns t is the symlink is marked in the NeXT style. + ;; i.e. The symlink destination is marked with an @. + ;; This assumes that the host-type has already been identified + ;; as NOT sysV-unix, and that target ends in an "@". + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = remote directory being listed, as a remore full path + ;; LINKNAME = relative name of symbolic link + ;; Since we've eliminated sysV, it won't be marked with an @ + ;; TARGET = target of symbolic link, as derived from an ls -..F.. + ;; PATH = directory being listed in full efs path syntax. + (let ((no-F-target (nth 1 (efs-relist-symlink + host user + (concat dir linkname) + path "-ld")))) + (and no-F-target + (string-equal (concat no-F-target "@") target)))) + +;; This deals with the F switch. Should also do something about +;; unquoting names obtained with the SysV b switch and the GNU Q +;; switch. See Sebastian's dired-get-filename. + +(defun efs-ls-parser (host-type host user dir path switches) + ;; Meant to be called by efs-parse-listing. + ;; Assumes that point is at the beginning of the first file line. + ;; Assumes that SWITCHES has already been bound to nil for a dumb host. + ;; HOST-TYPE is the remote host-type + ;; HOST is the remote host name + ;; USER is the remote user name + ;; DIR is the remote directory as a full path + ;; PATH is the directory in full efs syntax, and directory syntax. + ;; SWITCHES is the ls listing switches + (let ((tbl (efs-make-hashtable)) + (used-F (and switches (string-match "F" switches))) + (old-tbl (efs-get-files-hashtable-entry path)) + file-type symlink directory file size modes nlinks owner) + (while (setq file (efs-ls-parse-file-line)) + (setq size (nth 1 file) + modes (nth 2 file) + nlinks (nth 3 file) + owner (nth 4 file) + file (car file) + file-type (string-to-char modes) + directory (eq file-type ?d)) + (if (eq file-type ?l) + (if (string-match " -> " file) + (setq symlink (substring file (match-end 0)) + file (substring file 0 (match-beginning 0))) + ;; Shouldn't happen + (setq symlink "")) + (setq symlink nil)) + (if used-F + ;; The F-switch jungle + (let ((socket (eq file-type ?s)) + (fifo (eq file-type ?p)) + (executable + (and (not symlink) ; x bits don't mean a thing for symlinks + (or (memq (elt modes 3) '(?x ?s ?t)) + (memq (elt modes 6) '(?x ?s ?t)) + (memq (elt modes 9) '(?x ?s ?t)))))) + ;; Deal with marking of directories, executables, and sockets. + (if (or (and executable (string-match "*$" file)) + (and socket (string-match "=$" file)) + (and fifo (string-match "|$" file))) + (setq file (substring file 0 -1)) + ;; Do the symlink dance. + (if symlink + (let ((fat-p (string-match "@$" file)) + (sat-p (string-match "@$" symlink))) + (cond + ;; Those that mark the file + ((and (memq host-type '(sysV-unix apollo-unix)) fat-p) + (setq file (substring file 0 -1))) + ;; Those that mark nothing + ((memq host-type '(bsd-unix dumb-unix))) + ;; Those that mark the target + ((and (eq host-type 'next-unix) sat-p) + (setq symlink (substring symlink 0 -1))) + ;; We don't know + ((eq host-type 'unix) + (if fat-p + (cond + ((efs-ls-sysV-p host user dir + file path) + (setq host-type 'sysV-unix + file (substring file 0 -1)) + (efs-add-host 'sysV-unix host) + (efs-add-listing-type 'sysV-unix host user)) + ((and sat-p + (efs-ls-next-p host user dir file symlink + path)) + (setq host-type 'next-unix + symlink (substring symlink 0 -1)) + (efs-add-host 'next-unix host) + (efs-add-listing-type 'next-unix host user)) + (t + (setq host-type 'bsd-unix) + (efs-add-host 'bsd-unix host) + (efs-add-listing-type 'bsd-unix host user))) + (if (and sat-p + (efs-ls-next-p host user dir file + symlink path)) + (progn + (setq host-type 'next-unix + symlink (substring symlink 0 -1)) + (efs-add-host 'next-unix host) + (efs-add-listing-type 'next-unix host user)) + (setq host-type 'bsd-unix) + (efs-add-host 'bsd-unix host) + (efs-add-listing-type 'bsd-unix host user))))) + ;; Look out for marking of symlink + ;; If we really wanted to, at this point we + ;; could distinguish aix from hp-ux, ultrix, irix and a/ux, + ;; allowing us to skip the re-list in the future, for the + ;; later 4 host types. Another version... + (if (string-match "[=|*]$" symlink) + (let ((relist (efs-relist-symlink + host user (concat dir file) + path "-dl"))) + (if relist (setq symlink (nth 1 relist)))))))))) + ;; Strip / off the end unconditionally. It's not a valid file character + ;; anyway. + (if (string-match "/$" file) (setq file (substring file 0 -1))) + (let ((mdtm (and old-tbl (nth 5 (efs-get-hash-entry file old-tbl))))) + (if mdtm + (efs-put-hash-entry file (list (or symlink directory) size owner + modes nlinks mdtm) tbl) + (efs-put-hash-entry file (list (or symlink directory) size owner + modes nlinks) tbl))) + (forward-line 1)) + (efs-put-hash-entry "." '(t) tbl) + (efs-put-hash-entry ".." '(t) tbl) + tbl)) + +(efs-defun efs-parse-listing nil (host user dir path &optional switches) + ;; Parse the a listing which is assumed to be from some type of unix host. + ;; Note that efs-key will be bound to the actual host type. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a remote full path + ;; PATH = directory in full efs path syntax + ;; SWITCHES = ls switches used for the listing + (efs-save-match-data + (cond + ;; look for total line + ((looking-at "^total [0-9]+$") + (forward-line 1) + ;; Beware of machines that put a blank line after the totals line. + (skip-chars-forward " \t\n") + (efs-ls-parser efs-key host user dir path switches)) + ;; look for errors + ((looking-at "[^\n]+\\( not found\\|: Not a directory\\)\n\\'") + ;; It's an ls error message. + nil) + ((eobp) ; i.e. zerop buffer-size + nil) ; assume an ls error message + ;; look for listings without total lines + ((re-search-forward efs-month-and-time-regexp nil t) + (beginning-of-line) + (efs-ls-parser efs-key host user dir path switches)) + (t nil)))) + +(efs-defun efs-parse-listing unix:unknown + (host user dir path &optional switches) + ;; Parse the a listing which is assumed to be from some type of unix host, + ;; possibly one doing a dl listing. + ;; HOST = remote host name + ;; USER = remote user name + ;; DIR = directory as a remote full path + ;; PATH = directory in full efs path syntax + ;; SWITCHES = ls switches used for the listing + (efs-save-match-data + (cond + ;; look for total line + ((looking-at "^total [0-9]+$") + (forward-line 1) + ;; Beware of machines that put a blank line after the totals line. + (skip-chars-forward " \t\n") + ;; This will make the listing-type track the host-type. + (efs-add-listing-type nil host user) + (efs-ls-parser 'unix host user dir path switches)) + ;; look for errors + ((looking-at "[^\n]+\\( not found\\|: Not a directory\\)\n\\'") + ;; It's an ls error message. + nil) + ((eobp) ; i.e. zerop buffer-size + nil) ; assume an ls error message + ;; look for listings without total lines + ((and (re-search-forward efs-month-and-time-regexp nil t) + (progn + (beginning-of-line) + (looking-at efs-modes-links-owner-regexp))) + (efs-add-listing-type nil host user) + (efs-ls-parser 'unix host user dir path switches)) + ;; look for dumb listings + ((re-search-forward + (concat (regexp-quote switches) + " not found\\|\\(^ls: +illegal option -- \\)") + (save-excursion (end-of-line) (point)) t) + (if (eq (efs-host-type host) 'apollo-unix) + (progn + (efs-add-host 'dumb-apollo-unix host) + (efs-add-listing-type 'dumb-apollo-unix host user)) + (efs-add-host 'dumb-unix host) + (efs-add-listing-type 'dumb-unix host user)) + (if (match-beginning 1) + ;; Need to try to list again. + (let ((efs-ls-uncache t)) + (efs-ls + path nil (format "Relisting %s" (efs-relativize-filename path)) t) + (goto-char (point-min)) + (efs-parse-listing nil host user dir path switches)) + (if (re-search-forward "^total [0-9]+$" nil t) + (progn + (beginning-of-line) + (delete-region (point-min) (point)) + (forward-line 1) + (efs-ls-parser 'dumb-unix host user dir path switches))))) + ;; Look for dl listings. + ((re-search-forward efs-unix:dl-listing-regexp nil t) + (efs-add-host 'unix host) + (efs-add-listing-type 'unix:dl host user) + (efs-parse-listing 'unix:dl host user dir path switches)) + ;; don't know, return nil + (t nil)))) + +(defun efs-ls-parse-1-liner (filename buffer &optional symlink) + ;; Parse a 1-line listing for FILENAME in BUFFER, and update + ;; the cached info for FILENAME. + ;; Optional SYMLINK arg gives the expected target of a symlink. + ;; Since one-line listings are usually used to update info for + ;; newly created files, we usually know what sort of a file to expect. + ;; Actually trying to parse out the symlink target could be impossible + ;; for some types of switches. + (efs-save-buffer-excursion + (set-buffer buffer) + (goto-char (point-min)) + (skip-chars-forward " 0-9") + (efs-save-match-data + (let (modes nlinks owner size) + (and + (looking-at efs-modes-links-owner-regexp) + (setq modes (buffer-substring (match-beginning 1) (match-end 1)) + nlinks (string-to-int (buffer-substring (match-beginning 2) + (match-end 2))) + owner (buffer-substring (match-beginning 3) (match-end 3))) + (re-search-forward efs-month-and-time-regexp nil t) + (setq size (string-to-int (buffer-substring (match-beginning 1) + (match-end 1)))) + (let* ((filename (directory-file-name filename)) + (files (efs-get-files-hashtable-entry + (file-name-directory filename)))) + (if files + (let* ((key (efs-get-file-part filename)) + (ignore-case (memq (efs-host-type + (car (efs-ftp-path filename))) + efs-case-insensitive-host-types)) + (ent (efs-get-hash-entry key files ignore-case)) + (mdtm (nth 5 ent)) + type) + (if (= (string-to-char modes) ?l) + (setq type + (cond + ((stringp symlink) + symlink) + ((stringp (car ent)) + (car ent)) + (t ; something weird happened. + ""))) + (if (= (string-to-char modes) ?d) + (setq type t))) + (efs-put-hash-entry + key (list type size owner modes nlinks mdtm) + files ignore-case))))))))) + +(efs-defun efs-update-file-info nil (file buffer &optional symlink) + "For FILE, update cache information from a single file listing in BUFFER." + ;; By default, this does nothing. + nil) + +(efs-defun efs-update-file-info unix (file buffer &optional symlink) + (efs-ls-parse-1-liner file buffer)) +(efs-defun efs-update-file-info sysV-unix (file buffer &optional symlink) + (efs-ls-parse-1-liner file buffer)) +(efs-defun efs-update-file-info bsd-unix (file buffer &optional symlink) + (efs-ls-parse-1-liner file buffer)) +(efs-defun efs-update-file-info next-unix (file buffer &optional symlink) + (efs-ls-parse-1-liner file buffer)) +(efs-defun efs-update-file-info apollo-unix (file buffer &optional symlink) + (efs-ls-parse-1-liner file buffer)) +(efs-defun efs-update-file-info dumb-unix (file buffer &optional symlink) + (efs-ls-parse-1-liner file buffer)) +(efs-defun efs-update-file-info dumb-apollo-unix + (file buffer &optional symlink) + (efs-ls-parse-1-liner file buffer)) +(efs-defun efs-update-file-info super-dumb-unix (file buffer &optional symlink) + (efs-ls-parse-1-liner file buffer)) + +;;;; ---------------------------------------------------------------- +;;;; The 'unknown listing parser. This does some host-type guessing. +;;;; ---------------------------------------------------------------- + +;;; Regexps for host and listing type guessing from the listing syntax. + +(defconst efs-ka9q-listing-regexp + (concat + "^\\([0-9,.]+\\|No\\) files\\. [0-9,.]+ bytes free\\. " + "Disk size [0-9,]+ bytes\\.$")) +;; This version of the regexp is really for hosts which allow some switches, +;; but not ours. Rather than determine which switches we could be using +;; we just assume that it's dumb. +(defconst efs-dumb-unix-listing-regexp + (concat + "^[Uu]sage: +ls +-[a-zA-Z0-9]+[ \n]\\|" + ;; Unitree server + "^Error getting stats for \"-[a-zA-Z0-9]+\"")) + +(defconst efs-dos-distinct-date-and-time-regexp + (concat + " \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct" + "\\|Nov\\|Dec\\) [ 0-3][0-9],[12][90][0-9][0-9] " + "[ 12][0-9]:[0-5][0-9] ")) +;; Regexp to match the output from the hellsoft ftp server to an +;; ls -al. Unfortunately, this looks a lot like some unix ls error +;; messages. +(defconst efs-hell-listing-regexp + (concat + "ls: file or directory not found\n\\'\\|" + "[-d]\\[[-A-Z][-A-Z][-A-Z][-A-Z][-A-Z][-A-Z][-A-Z]\\]")) + +(efs-defun efs-parse-listing unknown + (host user dir path &optional switches) + "Parse the current buffer which is assumed to contain a dir listing. +Return a hashtable as the result. If the listing is not really a +directory listing, then return nil. + +HOST is the remote host's name. +USER is the remote user name. +DIR is the directory as a full remote path. +PATH is the directory in full efs path synatx. +SWITCHES are the switches passed to ls. If SWITCHES is nil, then a +dumb \(with dir\) listing has been done." + (efs-save-match-data + (cond + + ;; look for total line + ((looking-at "^total [0-9]+$") + (efs-add-host 'unix host) + (forward-line 1) + ;; Beware of machines that put a blank line after the totals line. + (skip-chars-forward " \t\n") + (efs-ls-parser 'unix host user dir path switches)) + + ;; Look for hellsoft. Need to do this before looking + ;; for ls errors, since the hellsoft output looks a lot like an ls error. + ((looking-at efs-hell-listing-regexp) + (if (null (car (efs-send-cmd host user '(quote site dos)))) + (let* ((key (concat host "/" user "/~")) + (tilde (efs-get-hash-entry + key efs-expand-dir-hashtable))) + (efs-add-host 'hell host) + ;; downcase the expansion of ~ + (if (and tilde (string-match "^[^a-z]+$" tilde)) + (efs-put-hash-entry key (downcase tilde) + efs-expand-dir-hashtable)) + ;; Downcase dir, in case its got some upper case stuff in it. + (setq dir (downcase dir) + path (efs-replace-path-component path dir)) + (let ((efs-ls-uncache t)) + ;; This will force the data buffer to be re-filled + (efs-ls path nil (format "Relisting %s" + (efs-relativize-filename path)) + t)) + (efs-parse-listing 'hell host user dir path)) + ;; Don't know, give unix a try. + (efs-add-host 'unix host) + nil)) + + ;; look for ls errors + ((looking-at "[^\n]+\\( not found\\|: Not a directory\\)\n\\'") + ;; It's an ls error message. + (efs-add-host 'unix host) + nil) + + ((eobp) ; i.e. (zerop (buffer-size)) + ;; This could be one of: + ;; (1) An Ultrix ls error message + ;; (2) A listing with the A switch of an empty directory + ;; on a machine which doesn't give a total line. + ;; (3) The result of an attempt at an nlist. (This would mean a + ;; dumb host.) + ;; (4) The twilight zone. + (cond + ((save-excursion + (set-buffer (process-buffer + (efs-get-process host user))) + (save-excursion + (goto-char (point-max)) + (and + ;; The dir ftp output starts with a 200 cmd. + (re-search-backward "^150 " nil t) + ;; We never do an nlist (it's a short listing). + ;; If the machine thinks that we did, it's dumb. + (looking-at "[^\n]+ NLST ")))) + ;; It's dumb-unix or ka9q. Anything else? + ;; This will re-fill the data buffer with a dumb listing. + (let ((efs-ls-uncache t)) + (efs-ls path nil (format "Relisting %s" + (efs-relativize-filename path)) + t)) + (cond + ;; check for dumb-unix + ((re-search-forward efs-month-and-time-regexp nil t) + (efs-add-host 'dumb-unix host) + (beginning-of-line) + (efs-parse-listing 'dumb-unix host user dir path)) + ;; check for ka9q + ((save-excursion + (goto-char (point-max)) + (forward-line -1) + (looking-at efs-ka9q-listing-regexp)) + (efs-add-host 'ka9q host) + (efs-parse-listing 'ka9q host user dir path)) + (t ; Don't know, try unix. + (efs-add-host 'unix host) + nil))) + ;; check for Novell Netware + ((null (car (efs-send-cmd host user '(quote site nfs)))) + (efs-add-host 'netware host) + (let ((efs-ls-uncache t)) + (efs-ls path nil (format "Relisting %s" + (efs-relativize-filename path)) + t)) + (efs-parse-listing 'netware host user dir path)) + (t + ;; Assume (1), an Ultrix error message. + (efs-add-host 'unix host) + nil))) + + ;; unix without a total line + ((re-search-forward efs-month-and-time-regexp nil t) + (efs-add-host 'unix host) + (beginning-of-line) + (efs-ls-parser 'unix host user dir path switches)) + + ;; Now we look for host-types, or listing-types which are auto-rec + ;; by the listing parser, because it's not possible to pick them out + ;; from a pwd. + + ;; check for dumb-unix + ;; (Guessing of dumb-unix hosts which return an ftp error message is + ;; done in efs-ls.) + ((re-search-forward efs-dumb-unix-listing-regexp nil t) + (efs-add-host 'dumb-unix host) + ;; This will force the data buffer to be re-filled + (let ((efs-ls-uncache t)) + (efs-ls path nil (format "Relisting %s" + (efs-relativize-filename path)) + t)) + (efs-parse-listing 'dumb-unix host user dir path)) + + ;; check for Distinct's DOS ftp server + ((re-search-forward efs-dos-distinct-date-and-time-regexp nil t) + (efs-add-host 'dos-distinct host) + (efs-parse-listing 'dos-distinct host user dir path)) + + ;; check for KA9Q pseudo-unix (LINUX?) + ((save-excursion + (goto-char (point-max)) + (forward-line -1) + (looking-at efs-ka9q-listing-regexp)) + (efs-add-host 'ka9q host) + ;; This will re-fill the data buffer. + ;; Need to do this because ka9q is a dumb host. + (let ((efs-ls-uncache t)) + (efs-ls path nil (format "Relisting %s" + (efs-relativize-filename path)) + t)) + (efs-parse-listing 'ka9q host user dir path)) + + ;; Check for a unix descriptive (dl) listing + ;; Do this last, because it's hard to guess. + ((re-search-forward efs-unix:dl-listing-regexp nil t) + (efs-add-host 'unix host) + (efs-add-listing-type 'unix:dl host user) + (efs-parse-listing 'unix:dl host user dir path switches)) + + ;; Don't know what's going on. Return nil, and assume unix. + (t + (efs-add-host 'unix host) + nil)))) + +;;;; ------------------------------------------------------------ +;;;; Directory information hashtable. +;;;; ------------------------------------------------------------ + +(efs-defun efs-really-file-p nil (file ent) + ;; efs-files-hashtable sometimes contains fictitious entries, when + ;; some OS's allow a file to be accessed by another name. For example, + ;; in VMS the highest version of a file may be accessed by omitting the + ;; the file version number. This function should return t if the + ;; filename FILE is really a file. ENT is the hash entry of the file. + t) + +(efs-defun efs-add-file-entry nil (path type size owner + &optional modes nlinks mdtm) + ;; Add a new file entry for PATH + ;; TYPE is nil for a plain file, t for a directory, and a string + ;; (the target of the link) for a symlink. + ;; SIZE is the size of the file in bytes. + ;; OWNER is the owner of the file, as a string. + ;; MODES is the file modes, as a string. In Unix, this will be 10 cars. + ;; NLINKS is the number of links for the file. + ;; MDTM is the last modtime obtained for the file. This is for + ;; short-term cache only, as emacs often has sequences of functions + ;; doing modtime lookup. If you really want to be sure of the modtime, + ;; use efs-get-file-mdtm, which asks the remote server. + + (and (eq type t) + (setq path (directory-file-name path))) + (let ((files (efs-get-files-hashtable-entry (file-name-directory path)))) + (if files + (efs-put-hash-entry + (efs-get-file-part path) + (cond (mdtm + (list type size owner modes nlinks + mdtm)) + (nlinks + (list type size owner modes nlinks)) + (modes (list type size owner modes)) + (t (list type size owner))) + files + (memq efs-key efs-case-insensitive-host-types))) + (efs-del-from-ls-cache path t nil))) + +(efs-defun efs-delete-file-entry nil (path &optional dir-p) + "Delete the file entry for PATH, if its directory info exists." + (if dir-p + (progn + (setq path (file-name-as-directory path)) + (efs-del-hash-entry (efs-canonize-file-name path) + efs-files-hashtable) + ;; Note that file-name-as-directory followed by + ;; (substring path 0 -1) + ;; serves to canonicalize directory file names to their unix form. + ;; i.e. in VMS, FOO.DIR -> FOO/ -> FOO + ;; PATH is supposed to be s fully expanded efs-style path. + (setq path (substring path 0 -1)))) + (let ((files (efs-get-files-hashtable-entry (file-name-directory path)))) + (if files + (efs-del-hash-entry + (efs-get-file-part path) + files + (memq (efs-host-type (car (efs-ftp-path path))) + efs-case-insensitive-host-types)))) + (efs-del-from-ls-cache path t nil) + (if dir-p (efs-del-from-ls-cache path nil t))) + +(defun efs-set-files (directory files) + "For DIRECTORY, set or change the associated FILES hashtable." + (if files + (efs-put-hash-entry + (efs-canonize-file-name (file-name-as-directory directory)) + files efs-files-hashtable))) + +(defun efs-parsable-switches-p (switches &optional full-dir) + ;; Returns non-nil if SWITCHES would give an ls listing suitable for parsing + ;; If FULL-DIR is non-nil, the switches must be suitable for parsing a full + ;; ditectory. + (or (null switches) + (efs-save-match-data + (and (string-match "[aA]" switches) + ;; g is not good enough, need l or o for owner. + (string-match "[lo]" switches) + ;; L shows link target, rather than link. We need both. + (not (string-match "[RfL]" switches)) + (not (and full-dir (string-match "d" switches))))))) + +(defun efs-get-files (directory &optional no-error) + "For DIRECTORY, return a hashtable of file entries. +This will give an error or return nil, depending on the value of +NO-ERROR, if a listing for DIRECTORY cannot be obtained." + (let ((directory (file-name-as-directory directory))) + (or (efs-get-files-hashtable-entry directory) + (and (efs-ls directory (efs-ls-guess-switches) t 'parse no-error) + (efs-get-files-hashtable-entry directory))))) + +(efs-defun efs-allow-child-lookup nil (host user dir file) + ;; Returns non-nil if in directory DIR, FILE could possibly be a subdir + ;; according to its file-name syntax, and therefore a child listing should + ;; be attempted. Note that DIR is in directory syntax. + ;; i.e. /foo/bar/, not /foo/bar. + ;; Deal with dired. Anything else? + (not (and (boundp 'dired-local-variables-file) + (stringp dired-local-variables-file) + (string-equal dired-local-variables-file file)))) + +(defmacro efs-ancestral-check (host-type path ignore-case) + ;; Checks to see if something in a path's ancient parentage + ;; would make it impossible for the path to exist in the directory + ;; tree. In this case it returns nil. Otherwise returns t (there + ;; is essentially no information returned in this case, the file + ;; may exist or not). + ;; This macro should make working with RCS more efficient. + ;; It also helps with FTP servers that go into fits if we ask to + ;; list a non-existent dir. + ;; Yes, I know that the function mapped over the hashtable can + ;; be written more cleanly with a concat, but this is faster. + ;; concat's cause a lot of consing. So do regexp-quote's, but we can't + ;; avoid it. + ;; Probably doesn't make much sense for this to be an efs-defun, since + ;; the host-type dependence is very mild. + (` + (let ((path (, path)) ; expand once + (ignore-case (, ignore-case)) + str) + ;; eliminate flat file systems -- should have a constant for this + (or (memq (, host-type) '(mts cms mvs cms-knet)) + (efs-save-match-data + (catch 'foo + (efs-map-hashtable + (function + (lambda (key val) + (and (eq (string-match (regexp-quote key) path) 0) + (setq str (substring path (match-end 0))) + (string-match "^[^/]+" str) + (not (efs-hash-entry-exists-p + (substring str 0 (match-end 0)) + val ignore-case)) + (throw 'foo nil)))) + efs-files-hashtable) + t)))))) + +(defun efs-file-entry-p (path) + ;; Return whether there is a file entry for PATH. + ;; Under no circumstances does this cause FTP activity. + (let* ((path (directory-file-name (efs-canonize-file-name path))) + (dir (file-name-directory path)) + (file (efs-get-file-part path)) + (tbl (efs-get-files-hashtable-entry dir))) + (and tbl (efs-hash-entry-exists-p + file tbl + (memq (efs-host-type (car (efs-ftp-path dir))) + efs-case-insensitive-host-types)) t))) + +(defun efs-get-file-entry (path) + "Return the given file entry for PATH. +This is a list of the form \(type size owner modes nlinks modtm\), +where type is nil for a normal file, t for a directory, and a string for a +symlink, size is the size of the file in bytes, if known, and modes are +the permission modes of the file as a string. modtm is short-term the +cache of the file modtime. It is not used by `verify-visited-file-modtime'. +If the file isn't in the hashtable, this returns nil." + (let* ((path (directory-file-name (efs-canonize-file-name path))) + (dir (file-name-directory path)) + (file (efs-get-file-part path)) + (parsed (efs-ftp-path dir)) + (host (car parsed)) + (host-type (efs-host-type host)) + (ent (efs-get-files-hashtable-entry dir)) + (ignore-case (memq host-type efs-case-insensitive-host-types))) + (if ent + (efs-get-hash-entry file ent ignore-case) + (let ((user (nth 1 parsed)) + (r-dir (nth 2 parsed))) + (and (efs-ancestral-check host-type path ignore-case) + (or (and efs-allow-child-lookup + (efs-allow-child-lookup host-type + host user r-dir file) + (setq ent (efs-get-files path t)) + (efs-get-hash-entry "." ent)) + ;; i.e. it's a directory by child lookup + (efs-get-hash-entry + file (efs-get-files dir) ignore-case))))))) + +(defun efs-wipe-file-entries (host user) + "Remove cache data for all files on HOST and USER. +This replaces the file entry information hashtable with one that +doesn't have any entries for the given HOST, USER pair." + (let ((new-tbl (efs-make-hashtable (length efs-files-hashtable))) + (host (downcase host)) + (case-fold (memq (efs-host-type host) + efs-case-insensitive-host-types))) + (if case-fold (setq user (downcase user))) + (efs-map-hashtable + (function + (lambda (key val) + (let ((parsed (efs-ftp-path key))) + (if parsed + (let ((h (nth 0 parsed)) + (u (nth 1 parsed))) + (or (and (string-equal host (downcase h)) + (string-equal user (if case-fold (downcase u) u))) + (efs-put-hash-entry key val new-tbl))))))) + efs-files-hashtable) + (setq efs-files-hashtable new-tbl))) + + +;;;; ============================================================ +;;;; >8 +;;;; Redefinitions of standard GNU Emacs functions. +;;;; ============================================================ + +;;;; ------------------------------------------------------------ +;;;; expand-file-name and friends... +;;;; ------------------------------------------------------------ + +;; New filename expansion code for efs. +;; The overall structure is based around the following internal +;; functions and macros. Since these are internal, they do NOT +;; call efs-save-match-data. This is done by their calling +;; function. +;; +;; efs-expand-tilde +;; - expands all ~ constructs, both local and remote. +;; efs-short-circuit-file-name +;; - short-circuits //'s and /~'s, for both local and remote paths. +;; efs-de-dot-file-name +;; - canonizes /../ and /./'s in both local and remote paths. +;; +;; The following two functions overload existing emacs functions. +;; They are the entry points to this filename expansion code, and as such +;; call efs-save-match-data. +;; +;; efs-expand-file-name +;; efs-substitute-in-file-name + +;;; utility macros + +(defmacro efs-short-circuit-file-name (filename) + ;; Short-circuits //'s and /~'s in filenames. + ;; Returns a list consisting of the local path, + ;; host-type, host, user. For local hosts, + ;; host-type, host, and user are all nil. + (` + (let ((start 0) + (string (, filename)) + backskip regexp lbackskip + lregexp parsed host-type host user) + + (if efs-local-apollo-unix + (setq lregexp ".//+" + lbackskip 2) + (setq lregexp "//+" + lbackskip 1)) + + ;; Short circuit /user@mach: roots. It is important to do this + ;; now to avoid unnecessary ftp connections. + + (while (string-match efs-path-root-short-circuit-regexp string start) + (setq start (1+ (match-beginning 0)))) + (or (zerop start) (setq string (substring string start) + start 0)) + + ;; identify remote root + + (if (setq parsed (efs-ftp-path-macro string)) + (if (memq (setq string (nth 2 parsed) + host-type + (efs-host-type (setq host (car parsed)) + (setq user (nth 1 parsed)))) + '(apollo-unix dumb-apollo-unix)) + (setq regexp ".//+" + backskip 2) + (setq regexp "//+" + backskip 1)) + (setq regexp lregexp + backskip lbackskip)) + + ;; Now short-circuit in an apollo and efs sensitive way. + + (while (cond ((string-match regexp string start) + (setq start (- (match-end 0) backskip))) + ((string-match "/~" string start) + (setq start (1- (match-end 0))))) + + (and host-type + (null efs-short-circuit-to-remote-root) + (setq host-type nil + regexp lregexp + backskip lbackskip))) + (or (zerop start) (setq string (substring string start))) + (list string host-type (and host-type host) (and host-type user))))) + +(defmacro efs-expand-tilde (tilde host-type host user) + ;; Expands a TILDE (~ or ~sandy type construction) + ;; Takes as an arg a filename (not directory name!) + ;; and returns a filename. HOST-TYPE is the type of remote host. + ;; nil is the type of the local host. + (` + (if (, host-type) ; nil host-type is the local machine + (let* ((host (downcase (, host))) + (host-type (, host-type)) + (ignore-case (memq host-type + efs-case-insensitive-host-types)) + (tilde (, tilde)) + (user (, user)) + (key (concat host "/" user "/" tilde)) + (res (efs-get-hash-entry + key efs-expand-dir-hashtable ignore-case))) + (or res + ;; for real accounts on unix systems, use the get trick + (and (not (efs-anonymous-p user)) + (memq host-type efs-unix-host-types) + (let ((line (nth 1 (efs-send-cmd + host user + (list 'get tilde "/dev/null") + (format "expanding %s" tilde))))) + (setq res + (and (string-match efs-expand-dir-msgs line) + (substring line + (match-beginning 1) + (match-end 1)))) + (if res + (progn + (setq res (efs-internal-directory-file-name res)) + (efs-put-hash-entry + key res efs-expand-dir-hashtable ignore-case) + res)))) + (progn + (setq res + (if (string-equal tilde "~") + (car (efs-send-pwd + host-type host user)) + (let* ((home-key (concat host "/" user "/~")) + (home (efs-get-hash-entry + home-key efs-expand-dir-hashtable + ignore-case)) + pwd-result) + (if home + (setq home + (efs-fix-path + host-type + (efs-internal-file-name-as-directory + host-type home))) + (if (setq home + (car + (setq pwd-result + (efs-send-pwd + host-type + host user)))) + (efs-put-hash-entry + home-key + (efs-internal-directory-file-name + (efs-fix-path host-type home 'reverse)) + efs-expand-dir-hashtable ignore-case) + (efs-error host user + (concat "PWD failed: " + (cdr pwd-result))))) + (unwind-protect + (and (efs-raw-send-cd host user + (efs-fix-path + host-type tilde) t) + (car + (efs-send-pwd + host-type host user))) + (efs-raw-send-cd host user home))))) + (if res + (progn + (setq res (efs-internal-directory-file-name + (efs-fix-path host-type res 'reverse))) + (efs-put-hash-entry + key res efs-expand-dir-hashtable ignore-case) + res))) + (if (string-equal tilde "~") + (error "Cannot get home directory on %s" host) + (error "User %s is not known on %s" (substring tilde 1) host)))) + ;; local machine + (efs-real-expand-file-name (, tilde))))) + +(defmacro efs-de-dot-file-name (string) + ;; Takes a string as arguments, and removes /../'s and /./'s. + (` + (let ((string (, string)) + (start 0) + new make-dir) + ;; to make the regexp's simpler, canonicalize to directory name. + (if (setq make-dir (string-match "/\\.\\.?$" string)) + (setq string (concat string "/"))) + (while (string-match "/\\./" string start) + (setq new (concat new + (substring string + start (match-beginning 0))) + start (1- (match-end 0)))) + + (if new (setq string (concat new (substring string start)))) + + (while (string-match "/[^/]+/\\.\\./" string) + ;; Is there a way to avoid all this concating and copying? + (setq string (concat (substring string 0 (1+ (match-beginning 0))) + (substring string (match-end 0))))) + + ;; Do /../ and //../ special cases. They should expand to + ;; / and //, respectively. + (if (string-match "^\\(/+\\)\\.\\./" string) + (setq string (concat (substring string 0 (match-end 1)) + (substring string (match-end 0))))) + + (if (and make-dir + (not (string-match "^/+$" string))) + (substring string 0 -1) + string)))) + +(defun efs-substitute-in-file-name (string) + "Documented as original." + ;; Because of the complicated interaction between short-circuiting + ;; and environment variable substitution, this can't call the macro + ;; efs-short-circuit-file-name. + (efs-save-match-data + (let ((start 0) + var new root backskip regexp lbackskip + lregexp parsed fudge-host-type rstart error) + + (if efs-local-apollo-unix + (setq lregexp ".//+" + lbackskip 2) + (setq lregexp "//+" + lbackskip 1)) + + ;; Subst. existing env variables + (while (string-match "\\$" string start) + (setq new (concat new (substring string start (match-beginning 0))) + start (match-end 0)) + (cond ((eq (string-match "\\$" string start) start) + (setq start (1+ start) + new (concat new "$$"))) + ((eq (string-match "{" string start) start) + (if (and (string-match "}" string start) + (setq var (getenv + (substring string (1+ start) + (1- (match-end 0)))))) + (setq start (match-end 0) + new (concat new var)) + (setq new (concat new "$")))) + ((eq (string-match "[a-zA-Z0-9]+" string start) start) + (if (setq var (getenv + (substring string start (match-end 0)))) + (setq start (match-end 0) + new (concat new var)) + (setq new (concat new "$")))) + ((setq new (concat new "$"))))) + (if new (setq string (concat new (substring string start)) + start 0)) + + ;; Short circuit /user@mach: roots. It is important to do this + ;; now to avoid unnecessary ftp connections. + + (while (string-match efs-path-root-short-circuit-regexp + string start) + (setq start (1+ (match-beginning 0)))) + (or (zerop start) (setq string (substring string start) + start 0)) + + ;; Look for invalid environment variables in the root. If one is found, + ;; we set the host-type to 'unix. Since we can't login in to determine + ;; it. There is a good chance that we will bomb later with an error, + ;; but the day may yet be saved if the root is short-circuited off. + + (if (string-match efs-path-root-regexp string) + (progn + (setq root (substring string 0 (match-end 0)) + start (match-end 0)) + (if (string-match "[^$]\\(\\$\\$\\)*\\$[^$]" root) + (progn + (setq rstart (1- (match-end 0)) + fudge-host-type t) + (cond + ((eq (elt root rstart) ?{) + (setq + error + (if (string-match "}" root rstart) + (concat + "Subsituting non-existent environment variable " + (substring root (1+ rstart) (match-beginning 0))) + "Missing \"}\" in environment-variable substitution"))) + ((eq (string-match "[A-Za-z0-9]+" root rstart) rstart) + (setq + error + (concat + "Subsituting non-existent environment variable " + (substring root rstart (match-beginning 0))))) + (t + (setq + error + "Bad format environment-variable substitution"))))) + (setq root (efs-unquote-dollars root) + parsed (efs-ftp-path root)) + + (if (and (not fudge-host-type) + ;; This may trigger an FTP connection + (memq (efs-host-type (car parsed) (nth 1 parsed)) + '(apollo-unix dumb-apollo-unix))) + (setq regexp ".//+" + backskip 2) + (setq regexp "//+" + backskip 1))) + ;; no root, we're local + (setq regexp lregexp + backskip lbackskip)) + + ;; Now short-circuit in an apollo and efs sensitive way. + + (while (cond ((string-match regexp string start) + (setq start (- (match-end 0) backskip))) + ((string-match "/~" string start) + (setq start (1- (match-end 0))))) + + (and root + (null efs-short-circuit-to-remote-root) + (setq root nil + regexp lregexp + backskip lbackskip))) + + ;; If we still have a bad root, barf. + (if (and root error) (error error)) + + ;; look for non-existent evironment variables in the path + + (if (string-match + "\\([^$]\\|^\\)\\(\\$\\$\\)*\\$\\([^$]\\|$\\)" string start) + (progn + (setq start (match-beginning 3)) + (cond + ((eq (length string) start) + (error "Empty string is an invalid environment variable")) + ((eq (elt string start) ?{) + (if (string-match "}" string start) + (error + "Subsituting non-existent environment variable %s" + (substring string (1+ start) (match-end 0))) + (error + "Missing \"}\" in environment-variable substitution"))) + ((eq (string-match "[A-Za-z0-9]+" string start) start) + (error + "Subsituting non-existent environment variable %s" + (substring string start (match-end 0)))) + (t + (error + "Bad format environment-variable substitution"))))) + + (if root + (concat root + (efs-unquote-dollars + (if (zerop start) + string + (substring string start)))) + (efs-unquote-dollars + (if (zerop start) + string + (substring string start))))))) + +(defun efs-expand-file-name (name &optional default) + "Documented as original." + (let (s-c-res path host user host-type) + (efs-save-match-data + (or (file-name-absolute-p name) + (setq name (concat + (file-name-as-directory + (or default default-directory)) + name))) + (setq s-c-res (efs-short-circuit-file-name name) + path (car s-c-res) + host-type (nth 1 s-c-res) + host (nth 2 s-c-res) + user (nth 3 s-c-res)) + (cond ((string-match "^~[^/]*" path) + (let ((start (match-end 0))) + (setq path (concat + (efs-expand-tilde + (substring path 0 start) + host-type host user) + (substring path start))))) + ((and host-type (not (file-name-absolute-p path))) + ;; We expand the empty string to a directory. + ;; This can be more efficient for filename + ;; completion. It's also consistent with non-unix. + (let ((tilde (efs-expand-tilde + "~" host-type host user))) + (if (string-equal tilde "/") + (setq path (concat "/" path)) + (setq path (concat tilde "/" path)))))) + + (setq path (efs-de-dot-file-name path)) + (if host-type + (format efs-path-format-string user host path) + path)))) + +;;;; ------------------------------------------------------------ +;;;; Other functions for manipulating file names. +;;;; ------------------------------------------------------------ + +(defun efs-internal-file-name-extension (filename) + ;; Returns the extension for file name FN. + (save-match-data + (let ((file (file-name-sans-versions (file-name-nondirectory filename)))) + (if (string-match "\\.[^.]*\\'" file) + (substring file (match-beginning 0)) + "")))) + +(defun efs-file-name-as-directory (name) + ;; version of file-name-as-directory for remote files. + ;; Usually just appends a / if there isn't one already. + ;; For some systems, it may also remove .DIR like extensions. + (let* ((parsed (efs-ftp-path name)) + (file (nth 2 parsed))) + (if (string-equal file "") + name + (efs-internal-file-name-as-directory + (efs-host-type (car parsed) (nth 1 parsed)) name)))) + +(efs-defun efs-internal-file-name-as-directory nil (name) + ;; By default, simply adds a trailing /, if there isn't one. + ;; Note that for expanded filenames, it pays to call this rather + ;; than efs-file-name-as-directory. + (let (file-name-handler-alist) + (file-name-as-directory name))) + +(defun efs-file-name-directory (name) + ;; file-name-directory for remote files. Takes care not to + ;; turn /user@host: into /. + (let ((path (nth 2 (efs-ftp-path name))) + file-name-handler-alist) + (if (or (string-equal path "") + (and (= (string-to-char path) ?~) + (not + (efs-save-match-data + (string-match "/" path 1))))) + name + (if (efs-save-match-data + (not (string-match "/" path))) + (efs-replace-path-component name "") + (file-name-directory name))))) + +(defun efs-file-name-nondirectory (name) + ;; Computes file-name-nondirectory for remote files. + ;; For expanded filenames, can just call efs-internal-file-name-nondirectory. + (let ((file (nth 2 (efs-ftp-path name)))) + (if (or (string-equal file "") + (and (= (string-to-char file) ?~) + (not + (efs-save-match-data + (string-match "/" file 1))))) + "" + (if (efs-save-match-data + (not (string-match "/" file))) + file + (efs-internal-file-name-nondirectory name))))) + +(defun efs-internal-file-name-nondirectory (name) + ;; Version of file-name-nondirectory, without the efs-file-handler-function. + ;; Useful to call this, if we have already decomposed the filename. + (let (file-name-handler-alist) + (file-name-nondirectory name))) + +(defun efs-directory-file-name (dir) + ;; Computes directory-file-name for remote files. + ;; Needs to be careful not to turn /foo@bar:/ into /foo@bar: + (let ((parsed (efs-ftp-path dir))) + (if (string-equal "/" (nth 2 parsed)) + dir + (efs-internal-directory-file-name dir)))) + +(defun efs-internal-directory-file-name (dir) + ;; Call this if you want to apply directory-file-name to the remote + ;; part of a efs-style path. Don't call for non-efs-style paths, + ;; as this short-circuits the file-name-handler-alist completely. + (let (file-name-handler-alist) + (directory-file-name dir))) + +(efs-defun efs-remote-directory-file-name nil (dir) + "Returns the file name on the remote system of directory DIR. +If the remote system is not unix, this may not be the same as the file name +of the directory in efs's internal cache." + (directory-file-name dir)) + +(defun efs-file-name-sans-versions (filename &optional keep-backup-versions) + ;; Version of file-name-sans-versions for remote files. + (or (file-name-absolute-p filename) + (setq filename (expand-file-name filename))) + (let ((parsed (efs-ftp-path filename))) + (efs-internal-file-name-sans-versions + (efs-host-type (car parsed) (nth 1 parsed)) + filename keep-backup-versions))) + +(efs-defun efs-internal-file-name-sans-versions nil + (filename &optional keep-backup-versions) + (let (file-name-handler-alist) + (file-name-sans-versions filename keep-backup-versions))) + +(defun efs-diff-latest-backup-file (fn) + ;; Version of diff latest backup file for remote files. + ;; Accomodates non-unix. + ;; Returns the latest backup for fn, according to the numbering + ;; of the backups. Does not check file-newer-than-file-p. + (let ((parsed (efs-ftp-path fn))) + (efs-internal-diff-latest-backup-file + (efs-host-type (car parsed) (nth 1 parsed)) fn))) + +(efs-defun efs-internal-diff-latest-backup-file nil (fn) + ;; Default behaviour is the behaviour in diff.el + (let (file-name-handler-alist) + (diff-latest-backup-file fn))) + +(defun efs-unhandled-file-name-directory (filename) + ;; Calculate a default unhandled directory for an efs buffer. + ;; This is used to compute directories in which to execute + ;; processes. This is relevant to V19 only. Doesn't do any harm for + ;; older versions though. It would be nice if this wasn't such a + ;; kludge. + (file-name-directory efs-tmp-name-template)) + +(defun efs-file-truename (filename) + ;; Calculates a remote file's truename, if this isn't inhibited. + (let ((filename (expand-file-name filename))) + (if (and efs-compute-remote-buffer-file-truename + (memq (efs-host-type (car (efs-ftp-path filename))) + efs-unix-host-types)) + (efs-internal-file-truename filename) + filename))) + +(defun efs-internal-file-truename (filename) + ;; Internal function so that we don't keep checking + ;; efs-compute-remote-buffer-file-truename, etc, as we recurse. + (let ((dir (efs-file-name-directory filename)) + target dirfile) + ;; Get the truename of the directory. + (setq dirfile (efs-directory-file-name dir)) + ;; If these are equal, we have the (or a) root directory. + (or (string= dir dirfile) + (setq dir (efs-file-name-as-directory + (efs-internal-file-truename dirfile)))) + (if (equal ".." (efs-file-name-nondirectory filename)) + (efs-directory-file-name (efs-file-name-directory + (efs-directory-file-name dir))) + (if (equal "." (efs-file-name-nondirectory filename)) + (efs-directory-file-name dir) + ;; Put it back on the file name. + (setq filename (concat dir (efs-file-name-nondirectory filename))) + ;; Is the file name the name of a link? + (setq target (efs-file-symlink-p filename)) + (if target + ;; Yes => chase that link, then start all over + ;; since the link may point to a directory name that uses links. + ;; We can't safely use expand-file-name here + ;; since target might look like foo/../bar where foo + ;; is itself a link. Instead, we handle . and .. above. + (if (file-name-absolute-p target) + (efs-internal-file-truename target) + (efs-internal-file-truename (concat dir target))) + ;; No, we are done! + filename))))) + + +;;;; ---------------------------------------------------------------- +;;;; I/O functions +;;;; ---------------------------------------------------------------- + +(efs-define-fun efs-set-buffer-file-name (filename) + ;; Sets the buffer local variables for filename appropriately. + ;; A special function because Lucid and FSF do this differently. + ;; This default behaviour is the lowest common denominator. + (setq buffer-file-name filename)) + +(defun efs-write-region (start end filename &optional append visit &rest args) + ;; write-region for remote files. + ;; This version accepts the V19 interpretation for the arg VISIT. + ;; However, making use of this within V18 may cause errors to crop up. + ;; ARGS should catch the MULE coding-system argument. + (if (stringp visit) (setq visit (expand-file-name visit))) + (setq filename (expand-file-name filename)) + (let ((parsed (efs-ftp-path filename)) + ;; Make sure that the after-write-region-hook isn't called inside + ;; the file-handler-alist + (after-write-region-hook nil)) + (if parsed + (let* ((host (car parsed)) + (user (nth 1 parsed)) + (host-type (efs-host-type host user)) + (temp (car (efs-make-tmp-name nil host))) + (type (efs-xfer-type nil nil host-type filename)) + (abbr (and (or (stringp visit) (eq t visit) (null visit)) + (efs-relativize-filename + (if (stringp visit) visit filename)))) + (buffer (current-buffer)) + (b-file-name buffer-file-name) + (mod-p (buffer-modified-p))) + (unwind-protect + (progn + (condition-case err + (progn + (unwind-protect + (let ((executing-macro t)) + ;; let-bind executing-macro to inhibit messaging. + ;; Setting VISIT to 'quiet is more elegant. + ;; But in Emacs 18, doing it this way allows + ;; us to modify the visited file modtime, so + ;; that undo's show the buffer modified. + (apply 'write-region start end + temp nil visit args)) + ;; buffer-modified-p is now correctly set + (setq buffer-file-name b-file-name) + ;; File modtime is bogus, so clear. + (clear-visited-file-modtime)) + (efs-copy-file-internal + temp nil filename parsed (if append 'append t) + nil (and abbr (format "Writing %s" abbr)) + ;; cont + (efs-cont (result line cont-lines) (filename buffer + visit) + (if result + (signal 'ftp-error + (list "Opening output file" + (format "FTP Error: \"%s\"" line) + filename))) + ;; The new file entry will be added by + ;; efs-copy-file-internal. + (cond + ((eq visit t) + ;; This will run asynch. + (efs-save-buffer-excursion + (set-buffer buffer) + (efs-set-buffer-file-name filename) + (efs-set-visited-file-modtime))) + ((stringp visit) + (efs-save-buffer-excursion + (set-buffer buffer) + (efs-set-buffer-file-name visit) + (set-visited-file-modtime))))) + nil type)) + (error + ;; restore buffer-modified-p + (let (file-name-handler-alist) + (set-buffer-modified-p mod-p)) + (signal (car err) (cdr err)))) + (if (or (eq visit t) + (and (stringp visit) + (efs-ftp-path visit))) + (efs-set-buffer-mode))) + (efs-del-tmp-name temp)) + (and abbr (efs-message "Wrote %s" abbr))) + (if (and (stringp visit) (efs-ftp-path visit)) + (progn + (apply 'write-region start end filename append visit args) + (efs-set-buffer-file-name visit) + (efs-set-visited-file-modtime) + (efs-set-buffer-mode)) + (error "efs-write-region called for a local file"))))) + +(defun efs-insert-file-contents (filename &optional visit &rest args) + ;; Inserts file contents for remote files. + ;; The additional ARGS covers V19 BEG and END. Should also handle the + ;; CODING-SYSTEM arg for mule. Hope the two don't trip over each other. + (barf-if-buffer-read-only) + (unwind-protect + (let* ((filename (expand-file-name filename)) + (parsed (efs-ftp-path filename)) + (host (car parsed)) + (host-type (efs-host-type host)) + (user (nth 1 parsed)) + (path (nth 2 parsed)) + (buffer (current-buffer))) + + (if (or (file-exists-p filename) + (let* ((res (and + (not (efs-get-host-property host 'rnfr-failed)) + (efs-send-cmd + host user (list 'quote 'rnfr path)))) + (line (nth 1 res))) + ;; RNFR returns a 550 if the file doesn't exist. + (if (and line (>= (length line) 4) + (string-equal "550 " (substring line 0 4))) + nil + (if (car res) (efs-set-host-property host 'rnfr-failed t)) + (efs-del-from-ls-cache filename t nil) + (efs-del-hash-entry + (efs-canonize-file-name (file-name-directory filename)) + efs-files-hashtable) + (file-exists-p filename)))) + + (let ((temp (concat + (car (efs-make-tmp-name nil host)) + (efs-internal-file-name-extension filename))) + (type (efs-xfer-type host-type filename nil nil)) + (abbr (efs-relativize-filename filename)) + (temp (concat (car (efs-make-tmp-name nil host)) + (or (substring abbr (string-match "\\." abbr)) ""))) + (i-f-c-size 0)) + + (unwind-protect + (efs-copy-file-internal + filename parsed temp nil t nil + (format "Retrieving %s" abbr) + (efs-cont (result line cont-lines) (filename visit buffer + host-type + temp args) + (if result + (signal 'ftp-error + (list "Opening input file" + (format "FTP Error: \"%s\"" + line) + filename)) + (if (eq host-type 'coke) + (efs-coke-insert-beverage-contents buffer filename + line) + (efs-save-buffer-excursion + (set-buffer buffer) + (if (or (file-readable-p temp) + (sleep-for efs-retry-time) + ;; Wait for file to hopefully appear. + (file-readable-p temp)) + + (setq i-f-c-size + (nth 1 (apply 'insert-file-contents + temp visit args))) + (signal 'ftp-error + (list + "Opening input file:" + (format + "FTP Error: %s not arrived or readable" + filename)))) + ;; This is done asynch + (if visit + (let ((buffer-file-name filename)) + (efs-set-visited-file-modtime))))))) + nil type) + (efs-del-tmp-name temp)) + ;; Return (FILENAME SIZE) + (list filename i-f-c-size)) + (signal 'file-error (list "Opening input file" filename)))) + ;; Set buffer-file-name at the very last, so if anything bombs, we're + ;; not visiting. + (if visit + (efs-set-buffer-file-name filename)))) + +(defun efs-revert-buffer (arg noconfirm) + "Revert this buffer from a remote file using ftp." + (let ((opoint (point))) + (cond ((null buffer-file-name) + (error "Buffer does not seem to be associated with any file")) + ((or noconfirm + (yes-or-no-p (format "Revert buffer from file %s? " + buffer-file-name))) + (let ((buffer-read-only nil)) + ;; Set buffer-file-name to nil + ;; so that we don't try to lock the file. + (let ((buffer-file-name nil)) + (unlock-buffer) + (erase-buffer)) + (insert-file-contents buffer-file-name t)) + (goto-char (min opoint (point-max))) + (after-find-file nil) + t)))) + +(defun efs-recover-file (file) + ;; Version of recover file for remote files, and remote autosave files too. + (if (auto-save-file-name-p file) (error "%s is an auto-save file" file)) + (let* ((file-name (let ((buffer-file-name file)) (make-auto-save-file-name))) + (file-name-parsed (efs-ftp-path file-name)) + (file-parsed (efs-ftp-path file)) + (efs-ls-uncache t)) + (cond ((not (file-newer-than-file-p file-name file)) + (error "Auto-save file %s not current" file-name)) + ((save-window-excursion + (or (eq system-type 'vax-vms) + (progn + (with-output-to-temp-buffer "*Directory*" + (buffer-disable-undo standard-output) + (if file-parsed + (progn + (princ (format "On the host %s:\n" + (car file-parsed))) + (princ + (let ((default-directory exec-directory)) + (efs-ls file (if (file-symlink-p file) + "-lL" "-l") + t t)))) + (princ "On the local host:\n") + (let ((default-directory exec-directory)) + (call-process "ls" nil standard-output nil + (if (file-symlink-p file) "-lL" "-l") + file))) + (princ "\nAUTO SAVE FILE on the ") + (if file-name-parsed + (progn + (princ (format "host %s:\n" + (car file-name-parsed))) + (princ + (efs-ls file-name + (if (file-symlink-p file-name) "-lL" "-l") + t t))) + (princ "local host:\n") + (let ((default-directory exec-directory)) + (call-process "ls" nil standard-output nil + "-l" file-name))) + (princ "\nFile modification times are given in ") + (princ "the local time of each host.\n")) + (save-excursion + (set-buffer "*Directory*") + (goto-char (point-min)) + (while (not (eobp)) + (end-of-line) + (if (> (current-column) (window-width)) + (progn + (skip-chars-backward " \t") + (skip-chars-backward "^ \t\n") + (if (> (current-column) 12) + (progn + (delete-horizontal-space) + (insert "\n "))))) + (forward-line 1)) + (set-buffer-modified-p nil) + (goto-char (point-min))))) + (yes-or-no-p (format "Recover using this auto save file? "))) + (switch-to-buffer (find-file-noselect file t)) + (let ((buffer-read-only nil)) + (erase-buffer) + (insert-file-contents file-name nil)) + (after-find-file nil)) + (t (error "Recover-file cancelled.")))) + ;; This is no longer done in V19. However, I like the caution for + ;; remote files, where file-newer-than-file-p may lie. + (setq buffer-auto-save-file-name nil) + (message "Auto-save off in this buffer till you do M-x auto-save-mode.")) + +;;;; ------------------------------------------------------------------ +;;;; Attributes of files. +;;;; ------------------------------------------------------------------ + +(defun efs-file-symlink-p (file) + ;; Version of file-symlink-p for remote files. + ;; Call efs-expand-file-name rather than the normal + ;; expand-file-name to stop loops when using a package that + ;; redefines both file-symlink-p and expand-file-name. + ;; Do not use efs-get-file-entry, because a child-lookup won't do. + (let* ((file (efs-expand-file-name file)) + (ignore-case (memq (efs-host-type (car (efs-ftp-path file))) + efs-case-insensitive-host-types)) + (file-type (car (efs-get-hash-entry + (efs-get-file-part file) + (efs-get-files (file-name-directory file)) + ignore-case)))) + (and (stringp file-type) + (if (file-name-absolute-p file-type) + (efs-replace-path-component file file-type) + file-type)))) + +(defun efs-file-exists-p (path) + ;; file-exists-p for remote file. Uses the cache if possible. + (let* ((path (expand-file-name path)) + (parsed (efs-ftp-path path))) + (efs-internal-file-exists-p (efs-host-type (car parsed) (nth 1 parsed)) + path))) + +(efs-defun efs-internal-file-exists-p nil (path) + (and (efs-get-file-entry path) t)) + +(defun efs-file-directory-p (file) + (let* ((file (expand-file-name file)) + (parsed (efs-ftp-path file))) + (efs-internal-file-directory-p (efs-host-type (car parsed) (nth 1 parsed)) + file))) + +(efs-defun efs-internal-file-directory-p nil (path) + ;; Version of file-directory-p for remote files. + (let ((parsed (efs-ftp-path path))) + (or (string-equal (nth 2 parsed) "/") ; root is always a directory + (let ((file-ent (car (efs-get-file-entry + (efs-internal-file-name-as-directory + (efs-host-type (car parsed) (nth 1 parsed)) + path))))) + ;; We do a file-name-as-directory on path here because some + ;; machines (VMS) use a .DIR to indicate the filename associated + ;; with a directory. This needs to be canonicalized. + (if (stringp file-ent) + (efs-internal-file-directory-p + nil + (efs-chase-symlinks + ;; efs-internal-directory-file-name + ;; only loses for paths where the remote file + ;; is /. This has been eliminated. + (efs-internal-directory-file-name path))) + file-ent))))) + +(defun efs-file-attributes (file) + ;; Returns file-file-attributes for a remote file. + ;; For the file modtime does not return efs's cached value, as that + ;; corresponds to buffer-file-modtime (i.e. the modtime of the file + ;; the last time the buffer was vsisted or saved). Caching modtimes + ;; does not make much sense, as they are usually used to determine + ;; if a cache is stale. The modtime if a remote file can be obtained with + ;; efs-get-file-mdtm. This is _not_ returned for the 5th entry here, + ;; because it requires an FTP transaction, and a priori we don't know + ;; if the caller actually cares about this info. Having file-attributes + ;; return such a long list of info is not well suited to remote files, + ;; as some of this info may be costly to obtain. + (let* ((file (expand-file-name file)) + (ent (efs-get-file-entry file))) + (if ent + (let* ((parsed (efs-ftp-path file)) + (host (nth 0 parsed)) + (user (nth 1 parsed)) + (path (nth 2 parsed)) + (type (car ent)) + (size (or (nth 1 ent) -1)) + (owner (nth 2 ent)) + (modes (nth 3 ent)) + ;; Hack to give remote files a "unique" "inode number". + ;; It's actually the sum of the characters in its name. + ;; It's not even really unique. + (inode (apply '+ + (nconc (mapcar 'identity host) + (mapcar 'identity user) + (mapcar 'identity + (efs-internal-directory-file-name + path))))) + (nlinks (or (nth 4 ent) -1))) ; return -1 if we don't know + (list + (if (and (stringp type) (file-name-absolute-p type)) + (efs-replace-path-component file type) + type) ;0 file type + nlinks ;1 link count + (if owner ;2 uid + ;; Not really a unique integer, + ;; just a half-hearted attempt + (apply '+ (mapcar 'identity owner)) + -1) + -1 ;3 gid + '(0 0) ;4 atime + '(0 0) ;5 mtime + '(0 0) ;6 ctime + size ;7 size + (or modes ;8 mode + (concat + (cond ((stringp type) "l") + (type "d") + (t "-")) + "?????????")) + nil ;9 gid weird (Who knows if the gid + ; would be changed?) + inode ;10 inode + -1 ;11 device number [v19 only] + ))))) + +(defun efs-file-writable-p (file) + ;; file-writable-p for remote files. + ;; Does not attempt to open the file, but just looks at the cached file + ;; modes. + (let* ((file (expand-file-name file)) + (ent (efs-get-file-entry file))) + (if (and ent (or (not (stringp (car ent))) + (setq file (efs-chase-symlinks file) + ent (efs-get-file-entry file)))) + (let* ((owner (nth 2 ent)) + (modes (nth 3 ent)) + (parsed (efs-ftp-path file)) + (host-type (efs-host-type (car parsed))) + (user (nth 1 parsed))) + (if (memq host-type efs-unix-host-types) + (setq host-type 'unix)) + (efs-internal-file-writable-p host-type user owner modes)) + (let ((dir (file-name-directory file))) + (and + (not (string-equal dir file)) + (file-directory-p dir) + (file-writable-p dir)))))) + +(efs-defun efs-internal-file-writable-p nil (user owner modes) + ;; By default, we'll just guess yes. + t) + +(efs-defun efs-internal-file-writable-p unix (user owner modes) + (if (and modes + (not (string-equal user "root"))) + (null + (null + (if (string-equal user owner) + (memq ?w (list (aref modes 2) (aref modes 5) + (aref modes 8))) + (memq ?w (list (aref modes 5) (aref modes 8)))))) + t)) ; guess + +(defun efs-file-readable-p (file) + ;; Version of file-readable-p that works for remote files. + ;; Works by checking efs's cache of the file modes. + (let* ((file (expand-file-name file)) + (ent (efs-get-file-entry file))) + (and ent + (or (not (stringp (car ent))) + (setq ent (efs-get-file-entry (efs-chase-symlinks file)))) + ;; file exists + (let* ((parsed (efs-ftp-path file)) + (owner (nth 2 ent)) + (modes (nth 3 ent)) + (host-type (efs-host-type (car parsed))) + (user (nth 1 parsed))) + (if (memq host-type efs-unix-host-types) + (setq host-type 'unix)) + (efs-internal-file-readable-p host-type user owner modes))))) + +(efs-defun efs-internal-file-readable-p nil (user owner modes) + ;; Guess t by default + t) + +(efs-defun efs-internal-file-readable-p unix (user owner modes) + (if (and modes + (not (string-equal user "root"))) + (null + (null + (if (string-equal user owner) + (memq ?r (list (aref modes 1) (aref modes 4) + (aref modes 7))) + (memq ?r (list (aref modes 4) (aref modes 7)))))) + t)) ; guess + +(defun efs-file-executable-p (file) + ;; Version of file-executable-p for remote files. + (let ((ent (efs-get-file-entry file))) + (and ent + (or (not (stringp (car ent))) + (setq ent (efs-get-file-entry (efs-chase-symlinks file)))) + ;; file exists + (let* ((parsed (efs-ftp-path file)) + (owner (nth 2 ent)) + (modes (nth 3 ent)) + (host-type (efs-host-type (car parsed))) + (user (nth 1 parsed))) + (if (memq host-type efs-unix-host-types) + (setq host-type 'unix)) + (efs-internal-file-executable-p host-type user owner modes))))) + +(efs-defun efs-internal-file-executable-p nil (user owner modes) + ;; Guess t by default + t) + +(efs-defun efs-internal-file-executable-p unix (user owner modes) + (if (and modes + (not (string-equal user "root"))) + (null + (null + (if (string-equal user owner) + (memq ?x (list (aref modes 3) (aref modes 6) + (aref modes 9))) + (memq ?x (list (aref modes 6) (aref modes 9)))))) + t)) ; guess + +(defun efs-file-accessible-directory-p (dir) + ;; Version of file-accessible-directory-p for remote directories. + (let ((file (directory-file-name dir))) + (and (efs-file-directory-p file) (efs-file-executable-p file)))) + +;;;; -------------------------------------------------------------- +;;;; Listing directories. +;;;; -------------------------------------------------------------- + +(defun efs-shell-regexp-to-regexp (regexp) + ;; Converts a shell regexp to an emacs regexp. + ;; Probably full of bugs. Tries to follow csh globbing. + (let ((curly 0) + backslash) + (concat "^" + (mapconcat + (function + (lambda (char) + (cond + (backslash + (setq backslash nil) + (regexp-quote (char-to-string char))) + ((and (> curly 0) (eq char ?,)) + "\\|") + ((memq char '(?[ ?])) + (char-to-string char)) + ((eq char ??) + ".") + ((eq char ?\\) + (setq backslash t) + "") + ((eq char ?*) + ".*") + ((eq char ?{) + (setq curly (1+ curly)) + "\\(") + ((and (eq char ?}) (> curly 0)) + (setq curly (1- curly)) + "\\)") + (t (regexp-quote (char-to-string char)))))) + regexp nil) + "$"))) + + +;;; Getting directory listings. + +(defun efs-directory-files (directory &optional full match nosort) + ;; Returns directory-files for remote directories. + ;; NOSORT is a V19 arg. + (let* ((directory (expand-file-name directory)) + (parsed (efs-ftp-path directory)) + (directory (efs-internal-file-name-as-directory + (efs-host-type (car parsed) (nth 1 parsed)) directory)) + files) + (efs-barf-if-not-directory directory) + (setq files (efs-hash-table-keys (efs-get-files directory) nosort)) + (cond + ((null (or full match)) + files) + (match ; this is slow case + (let (res f) + (efs-save-match-data + (while files + (setq f (if full (concat directory (car files)) (car files)) + files (cdr files)) + (if (string-match match f) + (setq res (nconc res (list f)))))) + res)) + (full + (mapcar (function + (lambda (fn) + (concat directory fn))) + files))))) + +(defun efs-list-directory (dirname &optional verbose) + ;; Version of list-directory for remote directories. + ;; If verbose is nil, it gets its information from efs's + ;; internal cache. + (let* ((dirname (expand-file-name (or dirname default-directory))) + header) + (if (file-directory-p dirname) + (setq dirname (file-name-as-directory dirname))) + (setq header dirname) + (with-output-to-temp-buffer "*Directory*" + (buffer-disable-undo standard-output) + (princ "Directory ") + (princ header) + (terpri) + (princ + (efs-ls dirname (if verbose + list-directory-verbose-switches + list-directory-brief-switches) + t))))) + +;;;; ------------------------------------------------------------------- +;;;; Manipulating buffers. +;;;; ------------------------------------------------------------------- + +(defun efs-get-file-buffer (file) + ;; Version of get-file-buffer for remote files. Needs to fuss over things + ;; like OS's which are case-insens. for file names. + (let ((file (efs-canonize-file-name (expand-file-name file))) + (buff-list (buffer-list)) + buff-name) + (catch 'match + (while buff-list + (and (setq buff-name (buffer-file-name (car buff-list))) + (= (length buff-name) (length file)) ; efficiency hack + (string-equal (efs-canonize-file-name buff-name) file) + (throw 'match (car buff-list))) + (setq buff-list (cdr buff-list)))))) + +(defun efs-create-file-buffer (filename) + ;; Version of create-file-buffer for remote file names. + (let* ((parsed (efs-ftp-path (expand-file-name filename))) + (file (nth 2 parsed)) + (host (car parsed)) + (host-type (efs-host-type host)) + (buff (cond + ((null efs-fancy-buffer-names) + (if (string-equal file "/") + "/" + (efs-internal-file-name-nondirectory + (efs-internal-directory-file-name file)))) + ((stringp efs-fancy-buffer-names) + (format efs-fancy-buffer-names + (if (string-equal file "/") + "/" + (efs-internal-file-name-nondirectory + (efs-internal-directory-file-name file))) + (substring host 0 (string-match "\\." host 1)))) + (t ; efs-fancy-buffer-names had better be a function + (funcall efs-fancy-buffer-names host + (nth 1 parsed) file))))) + (if (memq host-type efs-case-insensitive-host-types) + (cond ((eq efs-buffer-name-case 'down) + (setq buff (downcase buff))) + ((eq efs-buffer-name-case 'up) + (setq buff (upcase buff))))) + (get-buffer-create (generate-new-buffer-name buff)))) + +(defun efs-set-buffer-mode () + "Set correct modes for the current buffer if it is visiting a remote file." + (if (and (stringp buffer-file-name) + (efs-ftp-path buffer-file-name)) + (progn + (auto-save-mode efs-auto-save) + (set (make-local-variable 'revert-buffer-function) + 'efs-revert-buffer) + (set (make-local-variable 'default-directory-function) + 'efs-default-dir-function)))) + +;;;; --------------------------------------------------------- +;;;; Functions for doing backups. +;;;; --------------------------------------------------------- + +(defun efs-backup-buffer () + ;; Version of backup-buffer for buffers visiting remote files. + (if efs-make-backup-files + (let* ((parsed (efs-ftp-path buffer-file-name)) + (host (car parsed)) + (host-type (efs-host-type (car parsed)))) + (if (or (not (listp efs-make-backup-files)) + (memq host-type efs-make-backup-files)) + (efs-internal-backup-buffer + host host-type (nth 1 parsed) (nth 2 parsed)))))) + +(defun efs-internal-backup-buffer (host host-type user remote-path) + ;; This is almost a copy of the function in files.el, modified + ;; to check to see if the backup file exists, before deleting it. + ;; It also supports efs-backup-by-copying, and tries to do the + ;; right thing about backup-by-copying-when-mismatch. Only called + ;; for remote files. + ;; Set the umask now, so that `setmodes' knows about it. + (efs-set-umask host user) + (let ((ent (efs-get-file-entry (expand-file-name buffer-file-name))) + ;; Never do version-control if the remote operating system is doing it. + (version-control (if (memq host-type efs-version-host-types) + 'never + version-control)) + modstring) + (and make-backup-files + (not buffer-backed-up) + ent ; i.e. file-exists-p + (not (eq t (car ent))) + (or (null (setq modstring (nth 3 ent))) + (not (memq host-type efs-unix-host-types)) + (memq (aref modstring 0) '(?- ?l))) + (or (< (length remote-path) 5) + (not (string-equal "/tmp/" (substring remote-path 0 5)))) + (condition-case () + (let* ((backup-info (find-backup-file-name buffer-file-name)) + (backupname (car backup-info)) + (targets (cdr backup-info)) + (links (nth 4 ent)) + setmodes) + (condition-case () + (if (or file-precious-flag + (stringp (car ent)) ; symlinkp + efs-backup-by-copying + (and backup-by-copying-when-linked + links (> links 1)) + (and backup-by-copying-when-mismatch + (not + (if (memq + host-type + efs-case-insensitive-host-types) + (string-equal + (downcase user) (downcase (nth 2 ent))) + (string-equal user (nth 2 ent)))))) + (copy-file buffer-file-name backupname t t) + (condition-case () + (if (file-exists-p backupname) + (delete-file backupname)) + (file-error nil)) + (rename-file buffer-file-name backupname t) + (setq setmodes (file-modes backupname))) + (file-error + ;; If trouble writing the backup, write it in ~. + (setq backupname (expand-file-name "~/%backup%~")) + (message + "Cannot write backup file; backing up in ~/%%backup%%~") + (sleep-for 1) + (copy-file buffer-file-name backupname t t))) + (setq buffer-backed-up t) + ;; Starting with 19.26, trim-versions-without-asking + ;; has been renamed to delete-old-verions. + (if (and targets + (or (if (boundp 'trim-versions-without-asking) + trim-versions-without-asking + (and + (boundp 'delete-old-versions) + delete-old-versions)) + (y-or-n-p (format + "Delete excess backup versions of %s? " + buffer-file-name)))) + (while targets + (condition-case () + (delete-file (car targets)) + (file-error nil)) + (setq targets (cdr targets)))) + ;; If the file was already written with the right modes, + ;; don't return set-modes. + (and setmodes + (null + (let ((buff (get-buffer + (efs-ftp-process-buffer host user)))) + (and buff + (save-excursion + (set-buffer buff) + (and (integerp efs-process-umask) + (= (efs-modes-from-umask efs-process-umask) + setmodes)))))) + setmodes)) + (file-error nil))))) + +;;;; ------------------------------------------------------------ +;;;; Redefinition for Emacs file mode support +;;;; ------------------------------------------------------------ + +(defmacro efs-build-mode-string-element (int suid-p sticky-p) + ;; INT is between 0 and 7. + ;; If SUID-P is non-nil, we are building the 3-char string for either + ;; the owner or group, and the s[ug]id bit is set. + ;; If STICKY-P is non-nil, we are building the string for other perms, + ;; and the sticky bit is set. + ;; It doesn't make sense for both SUID-P and STICKY-P be non-nil! + (` (let* ((int (, int)) + (suid-p (, suid-p)) + (sticky-p (, sticky-p)) + (read-bit (if (memq int '(4 5 6 7)) "r" "-")) + (write-bit (if (memq int '(2 3 6 7)) "w" "-")) + (x-bit (if (memq int '(1 3 5 7)) + (cond (suid-p "s") (sticky-p "t") ("x")) + (cond (suid-p "S") (sticky-p "T") ("-"))))) + (concat read-bit write-bit x-bit)))) + +(defun efs-mode-string (int) + ;; Takes an octal integer between 0 and 7777, and returns the 9 character + ;; mode string. + (let* ((other-int (% int 10)) + (int (/ int 10)) + (group-int (% int 10)) + (int (/ int 10)) + (owner-int (% int 10)) + (int (/ int 10)) + (suid (memq int '(4 5 6 7))) + (sgid (memq int '(2 3 6 7))) + (sticky (memq int '(1 3 5 7)))) + (concat (efs-build-mode-string-element owner-int suid nil) + (efs-build-mode-string-element group-int sgid nil) + (efs-build-mode-string-element other-int nil sticky)))) + +(defun efs-set-file-modes (file mode) + ;; set-file-modes for remote files. + ;; For remote files, if mode is nil, does nothing. + ;; This is because efs-file-modes returns nil if the modes + ;; of a remote file couldn't be determined, even if the file exists. + (and mode + (let* ((file (expand-file-name file)) + (parsed (efs-ftp-path file)) + (host (car parsed)) + (user (nth 1 parsed)) + (r-file (nth 2 parsed)) + ;; convert to octal, and keep only 12 lowest order bits. + (omode (format "%o" (- mode (lsh (lsh mode -12) 12))))) + (if (or (efs-get-host-property host 'chmod-failed) + (null (memq (efs-host-type host user) efs-unix-host-types))) + (message "Unable to set file modes for %s to %s." file omode) + (efs-send-cmd + host user + (list 'quote 'site 'chmod omode r-file) + nil nil + (efs-cont (result line cont-lines) (host file r-file omode) + (if result + (progn + (efs-set-host-property host 'chmod-failed t) + (message "CHMOD %s failed for %s on %s." omode r-file host) + (if efs-ding-on-chmod-failure + (progn (ding) (sit-for 1)))) + (let ((ent (efs-get-file-entry file))) + (if ent + (let* ((type + (cond + ((null (car ent)) "-") + ((eq (car ent) t) "d") + ((stringp (car ent)) "s") + (t + (error + "Weird error in efs-set-file-modes")))) + (mode-string (concat + type + (efs-mode-string + (string-to-int omode)))) + (tail (nthcdr 3 ent))) + (if (consp tail) + (setcar tail mode-string) + (efs-add-file-entry nil file (car ent) (nth 1 ent) + (nth 2 ent) mode-string))))))) + 0)))) ; It should be safe to do this NOWAIT = 0 + ;; set-file-modes returns nil + nil) + +(defmacro efs-parse-mode-element (modes) + ;; Parses MODES, a string of three chars, and returns an integer + ;; between 0 and 7 according to how unix file modes are represented + ;; for chmod. + (` (if (= (length (, modes)) 3) + (let ((list (mapcar + (function (lambda (char) + (if (memq char '( ?- ?S ?T)) 0 1))) + (, modes)))) + ;; Convert to octal + (+ (* (car list) 4) (* (nth 1 list) 2) (nth 2 list))) + (error "Can't parse modes %s" (, modes))))) + +(defun efs-parse-mode-string (string) + ;; Parse a 9-character mode string, and return what it represents + ;; as a decimal integer. + (let ((owner (efs-parse-mode-element (substring string 0 3))) + (group (efs-parse-mode-element (substring string 3 6))) + (other (efs-parse-mode-element (substring string 6 9))) + (owner-x (elt string 2)) + (group-x (elt string 5)) + (other-x (elt string 8))) + (+ (* (+ (if (memq owner-x '(?s ?S)) 4 0) + (if (memq group-x '(?s ?S)) 2 0) + (if (memq other-x '(?t ?T)) 1 0)) + 512) + (* owner 64) + (* group 8) + other))) + +(defun efs-file-modes (file) + ;; Version of file-modes for remote files. + ;; Returns nil if the file modes can't be determined, either because + ;; the file doesn't exist, or for any other reason. + (let* ((file (expand-file-name file)) + (parsed (efs-ftp-path file))) + (and (memq (efs-host-type (car parsed)) efs-unix-host-types) + ;; Someday we should cache mode strings for non-unix, but they + ;; won't be in unix format. Also, CHMOD doesn't work for non-unix + ;; hosts, so returning this info to emacs is a waste. + (let* ((ent (efs-get-file-entry file)) + (modes (nth 3 ent))) + (and modes + (efs-parse-mode-string (substring modes 1))))))) + +;;;; ------------------------------------------------------------ +;;;; Redefinition of Emacs file modtime support. +;;;; ------------------------------------------------------------ + +(defun efs-day-number (year month day) + ;; Returns the day number within year of date. Taken from calendar.el, + ;; by Edward Reingold. Thanks. + ;; An explanation of the calculation can be found in PascAlgorithms by + ;; Edward and Ruth Reingold, Scott-Foresman/Little, Brown, 1988. + (let ((day-of-year (+ day (* 31 (1- month))))) + (if (> month 2) + (progn + (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10))) + (if (zerop (% year 4)) + (setq day-of-year (1+ day-of-year))))) + day-of-year)) + +(defun efs-days-elapsed (year month day) + ;; Number of days elapsed since Jan 1, `efs-time-zero' + (+ (efs-day-number year month day) ; days this year + (* 365 (- year efs-time-zero)) ; days in prior years + (- (/ (max (1- year) efs-time-zero) 4) + (/ efs-time-zero 4)) ; leap years + -1 )) ; don't count today + +;; 2^16 = 65536 +;; Use this to avoid overflows + +(defun efs-seconds-elapsed (year month day hours minutes seconds) + ;; Computes the seconds elapsed from `efs-time-zero', in emacs' + ;; format of a list of two integers, the first the higher 16-bits, + ;; the second the lower 16-bits. + (let* ((days (efs-days-elapsed year month day)) + ;; compute hours + (hours (+ (* 24 days) hours)) + (high (lsh hours -16)) + (low (- hours (lsh high 16))) + ;; compute minutes + (low (+ (* low 60) minutes)) + (carry (lsh low -16)) + (high (+ (* high 60) carry)) + (low (- low (lsh carry 16))) + ;; compute seconds + (low (+ (* low 60) seconds)) + (carry (lsh low -16)) + (high (+ (* high 60) carry)) + (low (- low (lsh carry 16)))) + (list high low))) + +(defun efs-parse-mdtime (string) + ;; Parse a string, which is assumed to be the result of an ftp MDTM command. + (efs-save-match-data + (if (string-match efs-mdtm-msgs string) + (efs-seconds-elapsed + (string-to-int (substring string 4 8)) + (string-to-int (substring string 8 10)) + (string-to-int (substring string 10 12)) + (string-to-int (substring string 12 14)) + (string-to-int (substring string 14 16)) + (string-to-int (substring string 16 18)))))) + +(defun efs-parse-ctime (string) + ;; Parse STRING which is assumed to be the result of a query over port 37. + ;; Returns the number of seconds since the turn of the century, as a + ;; list of two 16-bit integers. + (and (= (length string) 4) + (list (+ (lsh (aref string 0) 8) (aref string 1)) + (+ (lsh (aref string 2) 8) (aref string 3))))) + +(defun efs-time-minus (time1 time2) + ;; Subtract 32-bit integers, represented as two 16-bit integers. + (let ((high (- (car time1) (car time2))) + (low (- (nth 1 time1) (nth 1 time2)))) + (cond + ((and (< high 0) (> low 0)) + (setq high (1+ high) + low (- low 65536))) + ((and (> high 0) (< low 0)) + (setq high (1- high) + low (+ 65536 low)))) + (list high low))) + +(defun efs-time-greater (time1 time2) + ;; Compare two 32-bit integers, each represented as a list of two 16-bit + ;; integers. + (or (> (car time1) (car time2)) + (and (= (car time1) (car time2)) + (> (nth 1 time1) (nth 1 time2))))) + +(defun efs-century-time (host &optional nowait cont) + ;; Treat nil as the local host. + ;; Returns the # of seconds since the turn of the century, according + ;; to the system clock on host. + ;; CONT is called with first arg HOST and second the # of seconds. + (or host (setq host (system-name))) + (efs-set-host-property host 'last-ctime nil) + (efs-set-host-property host 'ctime-cont cont) + (let ((name (format efs-ctime-process-name-format host)) + proc) + (condition-case nil (delete-process name) (error nil)) + (if (and + (or (efs-save-match-data (string-match efs-local-host-regexp host)) + (string-equal host (system-name))) + (setq proc (condition-case nil + (open-network-stream name nil host 37) + (error nil)))) + (progn + (set (intern name) "") + (set-process-filter + proc + (function + (lambda (proc string) + (let ((name (process-name proc)) + result) + (set (intern name) (concat (symbol-value (intern name)) + string)) + (setq result (efs-parse-ctime + (symbol-value (intern name)))) + (if result + (let* ((host (substring name 11 -1)) + (cont (efs-get-host-property host 'ctime-cont))) + (efs-set-host-property host 'last-ctime result) + (condition-case nil (delete-process proc) (error nil)) + (if cont + (progn + (efs-set-host-property host 'ctime-cont nil) + (efs-call-cont cont host result))))))))) + (set-process-sentinel + proc + (function + (lambda (proc state) + (let* ((name (process-name proc)) + (host (substring name 11 -1)) + (cont (efs-get-host-property host 'ctime-cont))) + (makunbound (intern name)) + (or (efs-get-host-property host 'last-ctime) + (if cont + (progn + (efs-set-host-property host 'ctime-cont nil) + (efs-call-cont cont host 'failed)))))))) + (if nowait + nil + (let ((quit-flag nil) + (inhibit-quit nil)) + (while (memq (process-status proc) '(run open)) + (accept-process-output))) + (accept-process-output) + (or (efs-get-host-property host 'last-ctime) + 'failed))) + (if cont + (progn + (efs-set-host-property host 'ctime-cont nil) + (efs-call-cont cont host 'failed))) + (if nowait nil 'failed)))) + +(defun efs-clock-difference (host &optional nowait) + ;; clock difference with the local host + (let ((result (efs-get-host-property host 'clock-diff))) + (or + result + (progn + (efs-century-time + host nowait + (efs-cont (host result) (nowait) + (if (eq result 'failed) + (efs-set-host-property host 'clock-diff 'failed) + (efs-century-time + nil nowait + (efs-cont (lhost lresult) (host result) + (if (eq lresult 'failed) + (efs-set-host-property host 'clock-diff 'failed) + (efs-set-host-property host 'clock-diff + (efs-time-minus result lresult)))))))) + (and (null nowait) + (or (efs-get-host-property host 'clock-diff) + 'failed)))))) + +(defun efs-get-file-mdtm (host user file path) + "For HOST and USER, return FILE's last modification time. +PATH is the file name in full efs syntax. +Returns a list of two six-digit integers which represent the 16 high order +bits, and 16 low order bits of the number of elapsed seconds since +`efs-time-zero'" + (and (null (efs-get-host-property host 'mdtm-failed)) + (let ((result (efs-send-cmd host user (list 'quote 'mdtm file) + (and (eq efs-verbose t) + "Getting modtime"))) + parsed) + (if (and (null (car result)) + (setq parsed (efs-parse-mdtime (nth 1 result)))) + (let ((ent (efs-get-file-entry path))) + (if ent + (setcdr ent (list (nth 1 ent) (nth 2 ent) + (nth 3 ent) (nth 4 ent) + parsed))) + parsed) + (efs-save-match-data + ;; The 550 error is for a nonexistent file. Actually implies + ;; that MDTM works. + (if (string-match "^550 " (nth 1 result)) + '(0 0) + (efs-set-host-property host 'mdtm-failed t) + nil)))))) + +(efs-define-fun efs-set-emacs-bvf-mdtm (buffer mdtm) + ;; Sets cached value for the buffer visited file modtime. + (if (get-buffer buffer) + (save-excursion + (set-buffer buffer) + (let (file-name-handler-alist) + (set-visited-file-modtime mdtm))))) + +;; (defun efs-set-visited-file-modtime (&optional time) +;; ;; For remote files sets the modtime for a buffer to be that of the +;; ;; visited file. With arg TIME sets the modtime to TIME. TIME must be a list +;; ;; of two 16-bit integers. +;; ;; The function set-visited-file-modtime is for emacs-19. It doesn't +;; ;; exist in emacs 18. If you're running efs, it will work in emacs 18 for +;; ;; remote files only. +;; (if time +;; (efs-set-emacs-bvf-mdtm (current-buffer) time) +;; (let* ((path buffer-file-name) +;; (parsed (efs-ftp-path path)) +;; (host (car parsed)) +;; (user (nth 1 parsed)) +;; (file (nth 2 parsed)) +;; (buffer (current-buffer))) +;; (if (efs-save-match-data +;; (and efs-verify-modtime-host-regexp +;; (string-match efs-verify-modtime-host-regexp host) +;; (or efs-verify-anonymous-modtime +;; (not (efs-anonymous-p user))) +;; (not (efs-get-host-property host 'mdtm-failed)))) +;; (efs-send-cmd +;; host user (list 'quote 'mdtm file) +;; nil nil +;; (efs-cont (result line cont-lines) (host user path buffer) +;; (let (modtime) +;; (if (and (null result) +;; (setq modtime (efs-parse-mdtime line))) +;; (let ((ent (efs-get-file-entry path))) +;; (if ent +;; (setcdr ent (list (nth 1 ent) (nth 2 ent) +;; (nth 3 ent) (nth 4 ent) +;; modtime))) +;; (setq buffer (and (setq buffer (get-buffer buffer)) +;; (buffer-name buffer))) +;; ;; Beware that since this is happening asynch, the buffer +;; ;; may have disappeared. +;; (and buffer (efs-set-emacs-bvf-mdtm buffer modtime))) +;; (efs-save-match-data +;; (or (string-match "^550 " line) +;; (efs-set-host-property host 'mdtm-failed t))) +;; (efs-set-emacs-bvf-mdtm buffer 0)))) ; store dummy values +;; 0) ; Always do this NOWAIT = 0 +;; (efs-set-emacs-bvf-mdtm buffer 0)) +;; nil) ; return NIL +;; )) + +(defvar efs-set-modtimes-synchronously nil + "*Whether efs uses a synchronous FTP command to set the visited file modtime. +Setting this variable to non-nil means that efs will set visited file modtimes +synchronously. + +Asynchronous setting of visited file modtimes leaves a very small +window where Emacs may fail to detect a super session. However, it gives +faster user access to newly visited files.") + + +(defun efs-set-visited-file-modtime (&optional time) + ;; For remote files sets the modtime for a buffer to be that of the + ;; visited file. With arg TIME sets the modtime to TIME. TIME must be a list + ;; of two 16-bit integers. + ;; The function set-visited-file-modtime is for emacs-19. It doesn't + ;; exist in emacs 18. If you're running efs, it will work in emacs 18 for + ;; remote files only. + (if time + (efs-set-emacs-bvf-mdtm (current-buffer) time) + (let* ((path buffer-file-name) + (parsed (efs-ftp-path path)) + (host (car parsed)) + (user (nth 1 parsed)) + (file (nth 2 parsed)) + (buffer (current-buffer))) + (if (efs-save-match-data + (and efs-verify-modtime-host-regexp + (string-match efs-verify-modtime-host-regexp host) + (or efs-verify-anonymous-modtime + (not (efs-anonymous-p user))) + (not (efs-get-host-property host 'mdtm-failed)))) + (progn + (or efs-set-modtimes-synchronously (clear-visited-file-modtime)) + (efs-send-cmd + host user (list 'quote 'mdtm file) + nil nil + (efs-cont (result line cont-lines) (host user path buffer) + (let (modtime) + (if (and (null result) + (setq modtime (efs-parse-mdtime line))) + (let ((ent (efs-get-file-entry path))) + (if ent + (setcdr ent (list (nth 1 ent) (nth 2 ent) + (nth 3 ent) (nth 4 ent) + modtime))) + (setq buffer (and (setq buffer (get-buffer buffer)) + (buffer-name buffer))) + ;; Beware that since might be happening asynch, + ;; the buffer may have disappeared. + (and buffer (efs-set-emacs-bvf-mdtm buffer modtime))) + (efs-save-match-data + (or (string-match "^550 " line) + (efs-set-host-property host 'mdtm-failed t))) + (efs-set-emacs-bvf-mdtm buffer '(0 0))))) ; store dummy values + (and (null efs-set-modtimes-synchronously) 0))) + (efs-set-emacs-bvf-mdtm buffer '(0 0))) + nil))) ; return NIL + +(defun efs-file-newer-than-file-p (file1 file2) + ;; Version of file-newer-than-file-p for remote files. + (let* ((file1 (expand-file-name file1)) + (file2 (expand-file-name file2)) + (parsed1 (efs-ftp-path file1)) + (parsed2 (efs-ftp-path file2)) + (host1 (car parsed1)) + (host2 (car parsed2)) + (user1 (nth 1 parsed1)) + (user2 (nth 1 parsed2))) + (cond + ;; If the first file doedn't exist, or is remote but + ;; we're not supposed to check modtimes on it, return nil. + ((or (null (file-exists-p file1)) + (and parsed1 + (or + (null efs-verify-modtime-host-regexp) + (efs-get-host-property host1 'mdtm-failed) + (not (string-match efs-verify-modtime-host-regexp host1)) + (and (null efs-verify-anonymous-modtime) + (efs-anonymous-p user1))))) + nil) + ;; If the same is true for the second file, return t. + ((or (null (file-exists-p file2)) + (and parsed2 + (or + (null efs-verify-modtime-host-regexp) + (efs-get-host-property host2 'mdtm-failed) + (not (string-match efs-verify-modtime-host-regexp host2)) + (and (null efs-verify-anonymous-modtime) + (efs-anonymous-p user2))))) + t) + ;; Calculate modtimes. If we get here, any remote files should + ;; have a file entry. + (t + (let (mod1 mod2 shift1 shift2) + (if parsed1 + (let ((ent (efs-get-file-entry file1))) + (setq mod1 (nth 5 ent) + shift1 (efs-clock-difference host1)) + (or mod1 + (setq mod1 (efs-get-file-mdtm + host1 user1 (nth 2 parsed1) file1)))) + (setq mod1 (nth 5 (file-attributes file1)))) + (if parsed2 + (let ((ent (efs-get-file-entry file2))) + (setq mod2 (nth 5 ent) + shift2 (efs-clock-difference host2)) + (or mod2 + (setq mod2 (efs-get-file-mdtm + host2 user2 (nth 2 parsed2) file2)))) + (setq mod2 (nth 5 (file-attributes file2)))) + ;; If we can't compute clock shifts, we act as if we don't + ;; even know the modtime. Should we have more faith in ntp? + (cond + ((or (null mod1) (eq shift1 'failed)) + nil) + ((or (null mod2) (eq shift2 'failed)) + t) + ;; We get to compute something! + (t + (efs-time-greater + (if shift1 (efs-time-minus mod1 shift1) mod1) + (if shift2 (efs-time-minus mod2 shift2) mod2))))))))) + +(defun efs-verify-visited-file-modtime (buff) + ;; Verifies the modtime for buffers visiting remote files. + ;; Won't get called for buffer not visiting any file. + (let ((buff (get-buffer buff))) + (null + (and buff ; return t if no buffer? Need to beware of multi-threading. + (buffer-file-name buff) ; t if no file + (let ((mdtm (save-excursion + (set-buffer buff) + (visited-file-modtime)))) + (and + (not (eq mdtm 0)) + (not (equal mdtm '(0 0))) + efs-verify-modtime-host-regexp + (let* ((path (buffer-file-name buff)) + (parsed (efs-ftp-path path)) + (host (car parsed)) + (user (nth 1 parsed)) + nmdtm) + (and + (null (efs-get-host-property host 'mdtm-failed)) + (efs-save-match-data + (string-match + efs-verify-modtime-host-regexp host)) + (or efs-verify-anonymous-modtime + (not (efs-anonymous-p user))) + (setq nmdtm (efs-get-file-mdtm host user (nth 2 parsed) path)) + (progn + (or (equal nmdtm '(0 0)) + (file-exists-p path) ; Make sure that there is an entry. + (null + (efs-get-files + (file-name-directory + (efs-internal-directory-file-name path)))) + (efs-add-file-entry + (efs-host-type host) path nil nil nil nil nil nmdtm)) + (null (and (eq (cdr mdtm) (nth 1 nmdtm)) + (eq (car mdtm) (car nmdtm))))))))))))) + +;;;; ----------------------------------------------------------- +;;;; Redefinition of Emacs file name completion +;;;; ----------------------------------------------------------- + +(defmacro efs-set-completion-ignored-pattern () + ;; Set regexp efs-completion-ignored-pattern + ;; to use for filename completion. + (` + (or (equal efs-completion-ignored-extensions + completion-ignored-extensions) + (setq efs-completion-ignored-extensions + completion-ignored-extensions + efs-completion-ignored-pattern + (mapconcat (function + (lambda (s) (if (stringp s) + (concat (regexp-quote s) "$") + "/"))) ; / never in filename + efs-completion-ignored-extensions + "\\|"))))) + +(defun efs-file-entry-active-p (sym) + ;; If the file entry is a symlink, returns whether the file pointed to + ;; exists. + ;; Note that DIR is dynamically bound. + (let ((file-type (car (get sym 'val)))) + (or (not (stringp file-type)) + (file-exists-p (efs-chase-symlinks + (expand-file-name file-type efs-completion-dir)))))) + +(defun efs-file-entry-not-ignored-p (sym) + ;; If the file entry is not a directory (nor a symlink pointing to a + ;; directory) returns whether the file (or file pointed to by the symlink) + ;; is ignored by completion-ignored-extensions. + (let ((file-type (car (get sym 'val))) + (symname (symbol-name sym))) + (if (stringp file-type) + ;; Maybe file-truename would be better here, but it is very costly + ;; to chase symlinks at every level over FTP. + (let ((file (efs-chase-symlinks (expand-file-name + file-type efs-completion-dir)))) + (or (file-directory-p file) + (and (file-exists-p file) + (not (string-match efs-completion-ignored-pattern + symname))))) + (or file-type ; is a directory name + (not (string-match efs-completion-ignored-pattern symname)))))) + +(defun efs-file-name-all-completions (file dir) + ;; Does file-name-all-completions in remote directories. + (efs-barf-if-not-directory dir) + (let* ((efs-completion-dir (file-name-as-directory (expand-file-name dir))) + (completion-ignore-case + (memq (efs-host-type (car (efs-ftp-path efs-completion-dir))) + efs-case-insensitive-host-types)) + (tbl (efs-get-files efs-completion-dir)) + (completions + (all-completions file tbl + (function efs-file-entry-active-p)))) + ;; see whether each matching file is a directory or not... + (mapcar + ;; Since the entries in completions will match the case + ;; of the entries in tbl, don't need to case-fold + ;; in efs-get-hash-entry below. + (function + (lambda (file) + (let ((ent (car (efs-get-hash-entry file tbl)))) + (if (or (eq ent t) + (and (stringp ent) + (file-directory-p (efs-chase-symlinks + (expand-file-name + ent efs-completion-dir))))) + (concat file "/") + file)))) + completions))) + +(defun efs-file-name-completion (file dir) + ;; Does file name expansion in remote directories. + (efs-barf-if-not-directory dir) + (if (equal file "") + "" + (let* ((efs-completion-dir (file-name-as-directory (expand-file-name dir))) + (completion-ignore-case + (memq (efs-host-type (car (efs-ftp-path efs-completion-dir))) + efs-case-insensitive-host-types)) + (tbl (efs-get-files efs-completion-dir))) + (efs-set-completion-ignored-pattern) + (efs-save-match-data + (or (efs-file-name-completion-1 + file tbl efs-completion-dir + (function efs-file-entry-not-ignored-p)) + (efs-file-name-completion-1 + file tbl efs-completion-dir + (function efs-file-entry-active-p))))))) + +(defun efs-file-name-completion-1 (file tbl dir predicate) + ;; Internal subroutine for efs-file-name-completion. Do not call this. + (let ((bestmatch (try-completion file tbl predicate))) + (if bestmatch + (if (eq bestmatch t) + (if (file-directory-p (expand-file-name file dir)) + (concat file "/") + t) + (if (and (eq (try-completion bestmatch tbl predicate) t) + (file-directory-p + (expand-file-name bestmatch dir))) + (concat bestmatch "/") + bestmatch))))) + +;;;; ---------------------------------------------------------- +;;;; Functions for loading lisp. +;;;; ---------------------------------------------------------- + +;;; jka-load provided ideas here. Thanks, Jay. + +(defun efs-load-openp (str suffixes) + ;; Given STR, searches load-path and efs-load-lisp-extensions + ;; for the name of a file to load. Returns the full path, or nil + ;; if none found. + (let ((path-list (if (file-name-absolute-p str) t load-path)) + root result) + ;; If there is no load-path, at least try the default directory. + (or path-list + (setq path-list (list default-directory))) + (while (and path-list (null result)) + (if (eq path-list t) + (setq path-list nil + root str) + (setq root (expand-file-name str (car path-list)) + path-list (cdr path-list)) + (or (file-name-absolute-p root) + (setq root (expand-file-name root default-directory)))) + (let ((suff-list suffixes)) + (while (and suff-list (null result)) + (let ((try (concat root (car suff-list)))) + (if (or (not (file-readable-p try)) + (file-directory-p try)) + (setq suff-list (cdr suff-list)) + (setq result try)))))) + result)) + +(defun efs-load (file &optional noerror nomessage nosuffix) + "Documented as original." + (let ((filename (efs-load-openp + file + (if nosuffix '("") efs-load-lisp-extensions)))) + (if (not filename) + (and (null noerror) (error "Cannot open load file %s" file)) + (let ((parsed (efs-ftp-path filename)) + (after-load (and (boundp 'after-load-alist) + (assoc file after-load-alist)))) + (if parsed + (let ((temp (car (efs-make-tmp-name nil (car parsed))))) + (unwind-protect + (progn + (efs-copy-file-internal + filename parsed temp nil t nil + (format "Getting %s" filename)) + (or (file-readable-p temp) + (error + "efs-load: temp file %s is unreadable" temp)) + (or nomessage + (message "Loading %s..." file)) + ;; temp is an absolute filename, so load path + ;; won't be searched. + (let (after-load-alist) + (efs-real-load temp t t t)) + (or nomessage + (message "Loading %s...done" file)) + (if after-load (mapcar 'eval (cdr after-load))) + t) ; return t if everything worked + (efs-del-tmp-name temp))) + (prog2 + (or nomessage + (message "Loading %s..." file)) + (let (after-load-alist) + (or (efs-real-load filename noerror t t) + (setq after-load nil))) + (or nomessage + (message "Loading %s...done" file)) + (if after-load (mapcar 'eval (cdr after-load))))))))) + +(defun efs-require (feature &optional filename) + "Documented as original." + (if (eq feature 'ange-ftp) (efs-require-scream-and-yell)) + (if (featurep feature) + feature + (or filename (setq filename (symbol-name feature))) + (let ((fullpath (efs-load-openp filename + efs-load-lisp-extensions))) + (if (not fullpath) + (error "Cannot open load file: %s" filename) + (let ((parsed (efs-ftp-path fullpath))) + (if parsed + (let ((temp (car (efs-make-tmp-name nil (car parsed))))) + (unwind-protect + (progn + (efs-copy-file-internal + fullpath parsed temp nil t nil + (format "Getting %s" fullpath)) + (or (file-readable-p temp) + (error + "efs-require: temp file %s is unreadable" temp)) + (efs-real-require feature temp)) + (efs-del-tmp-name temp))) + (efs-real-require feature fullpath))))))) + +(defun efs-require-scream-and-yell () + ;; Complain if something attempts to load ange-ftp. + (with-output-to-temp-buffer "*Help*" + (princ + "Something tried to load ange-ftp. +EFS AND ANGE-FTP DO NOT WORK TOGETHER. + +If the culprit package does need to access ange-ftp internal functions, +then it should be adequate to simply remove the \(require 'ange-ftp\) +line and let efs handle remote file access. Otherwise, it will need to +be ported to efs. This may already have been done, and you can find out +by sending an enquiry to efs-help@cuckoo.hpl.hp.com. + +Signalling an error with backtrace will allow you to determine which +package was requiring ange-ftp.\n")) + (select-window (get-buffer-window "*Help*")) + (enlarge-window (- (count-lines (point-min) (point-max)) + (window-height) -1)) + (if (y-or-n-p "Signal error with backtrace? ") + (let ((stack-trace-on-error t)) + (error "Attempt to require ange-ftp")))) + +;;;; ----------------------------------------------------------- +;;;; Redefinition of Emacs functions for reading file names. +;;;; ----------------------------------------------------------- + +(defun efs-unexpand-parsed-filename (host user path) + ;; Replaces the home directory in path with "~". Returns the unexpanded + ;; full-path. + (let* ((path-len (length path)) + (def-user (efs-get-user host)) + (host-type (efs-host-type host user)) + (ignore-case (memq host-type efs-case-insensitive-host-types))) + (if (> path-len 1) + (let* ((home (efs-expand-tilde "~" host-type host user)) + (home-len (length home))) + (if (and (> path-len home-len) + (if ignore-case (string-equal (downcase home) + (downcase + (substring path + 0 home-len))) + (string-equal home (substring path 0 home-len))) + (= (aref path home-len) ?/)) + (setq path (concat "~" (substring path home-len)))))) + (if (if ignore-case (string-equal (downcase user) + (downcase def-user)) + (string-equal user def-user)) + (format efs-path-format-without-user host path) + (format efs-path-format-string user host path)))) + +(efs-define-fun efs-abbreviate-file-name (filename) + ;; Version of abbreviate-file-name for remote files. + (efs-save-match-data + (let ((tail directory-abbrev-alist)) + (while tail + (if (string-match (car (car tail)) filename) + (setq filename + (concat (cdr (car tail)) + (substring filename (match-end 0))))) + (setq tail (cdr tail))) + (apply 'efs-unexpand-parsed-filename (efs-ftp-path filename))))) + +(defun efs-default-dir-function () + (let ((parsed (efs-ftp-path default-directory)) + (dd default-directory)) + (if parsed + (efs-save-match-data + (let ((tail directory-abbrev-alist)) + (while tail + (if (string-match (car (car tail)) dd) + (setq dd (concat (cdr (car tail)) + (substring dd (match-end 0))) + parsed nil)) + (setq tail (cdr tail))) + (apply 'efs-unexpand-parsed-filename + (or parsed (efs-ftp-path dd))))) + default-directory))) + +(defun efs-re-read-dir (&optional dir) + "Forces a re-read of the directory DIR. +If DIR is omitted then it defaults to the directory part of the contents +of the current buffer. This is so this function can be caled from the +minibuffer." + (interactive) + (if dir + (setq dir (expand-file-name dir)) + (setq dir (file-name-directory (expand-file-name (buffer-string))))) + (let ((parsed (efs-ftp-path dir))) + (if parsed + (let ((efs-ls-uncache t)) + (efs-del-hash-entry (efs-canonize-file-name dir) + efs-files-hashtable) + (efs-get-files dir t))))) + +;;;; --------------------------------------------------------------- +;;;; Creation and deletion of files and directories. +;;;; --------------------------------------------------------------- + +(defun efs-delete-file (file) + ;; Deletes remote files. + (let* ((file (expand-file-name file)) + (parsed (efs-ftp-path file)) + (host (car parsed)) + (user (nth 1 parsed)) + (host-type (efs-host-type host user)) + (path (nth 2 parsed)) + (abbr (efs-relativize-filename file)) + (result (efs-send-cmd host user (list 'delete path) + (format "Deleting %s" abbr)))) + (if (car result) + (signal 'ftp-error + (list "Removing old name" + (format "FTP Error: \"%s\"" (nth 1 result)) + file))) + (efs-delete-file-entry host-type file))) + +(defun efs-make-directory-internal (dir) + ;; version of make-directory-internal for remote directories. + (if (file-exists-p dir) + (error "Cannot make directory %s: file already exists" dir) + (let* ((parsed (efs-ftp-path dir)) + (host (nth 0 parsed)) + (user (nth 1 parsed)) + (host-type (efs-host-type host user)) + ;; Some ftp's on unix machines (at least on Suns) + ;; insist that mkdir take a filename, and not a + ;; directory-name name as an arg. Argh!! This is a bug. + ;; Non-unix machines will probably always insist + ;; that mkdir takes a directory-name as an arg + ;; (as the ftp man page says it should). + (path (if (or (memq host-type efs-unix-host-types) + (memq host-type '(os2 dos))) + (efs-internal-directory-file-name (nth 2 parsed)) + (efs-internal-file-name-as-directory + host-type (nth 2 parsed)))) + (abbr (efs-relativize-filename dir)) + (result (efs-send-cmd host user + (list 'mkdir path) + (format "Making directory %s" + abbr)))) + (if (car result) + (efs-error host user + (format "Could not make directory %s: %s" dir + (nth 1 result)))) + (efs-add-file-entry host-type dir t nil user)))) + +;; V19 calls this function delete-directory. It used to be called +;; remove-directory. + +(defun efs-delete-directory (dir) + ;; Version of delete-directory for remote directories. + (if (file-directory-p dir) + (let* ((parsed (efs-ftp-path dir)) + (host (nth 0 parsed)) + (user (nth 1 parsed)) + (host-type (efs-host-type host user)) + ;; Some ftp's on unix machines (at least on Suns) + ;; insist that rmdir take a filename, and not a + ;; directory-name name as an arg. Argh!! This is a bug. + ;; Non-unix machines will probably always insist + ;; that rmdir takes a directory-name as an arg + ;; (as the ftp man page says it should). + (path + (if (or (memq host-type efs-unix-host-types) + (memq host-type '(os2 dos))) + (efs-internal-directory-file-name (nth 2 parsed)) + (efs-internal-file-name-as-directory + host-type (nth 2 parsed)))) + (abbr (efs-relativize-filename dir)) + (result (efs-send-cmd host user + (list 'rmdir path) + (format "Deleting directory %s" abbr)))) + (if (car result) + (efs-error host user + (format "Could not delete directory %s: %s" + dir (nth 1 result)))) + (efs-delete-file-entry host-type dir t)) + (error "Not a directory: %s" dir))) + +(defun efs-file-local-copy (file) + ;; internal function for diff.el (dired 6.3 or later) + ;; Makes a temp file containing the contents of file. + ;; returns the name of the tmp file created, or nil if none is. + ;; This function should have optional cont and nowait args. + (let* ((file (expand-file-name file)) + (tmp (car (efs-make-tmp-name nil (car (efs-ftp-path file)))))) + (efs-copy-file-internal file (efs-ftp-path file) + tmp nil t nil (format "Getting %s" file)) + tmp)) + +(defun efs-diff/grep-del-temp-file (temp) + ;; internal function for diff.el and grep.el + ;; if TEMP is non-nil, deletes the temp file TEMP. + ;; if TEMP is nil, does nothing. + (and temp + (efs-del-tmp-name temp))) + +;;;; ------------------------------------------------------------ +;;;; File copying support... +;;;; ------------------------------------------------------------ + +;;; - totally re-written 6/24/92. +;;; - re-written again 9/3/93 +;;; - and again 14/4/93 +;;; - and again 17/8/93 + +(defun efs-barf-or-query-if-file-exists (absname querystring interactive) + (if (file-exists-p absname) + (if (not interactive) + (signal 'file-already-exists (list absname)) + (if (not (yes-or-no-p (format "File %s already exists; %s anyway? " + absname querystring))) + (signal 'file-already-exists (list absname)))))) + +(defun efs-concatenate-files (file1 file2) + ;; Concatenates file1 to file2. Both must be local files. + ;; Needed because the efs version of copy-file understands + ;; ok-if-already-exists = 'append + (or (file-readable-p file1) + (signal 'file-error + (list (format "Input file %s not readable." file1)))) + (or (file-writable-p file2) + (signal 'file-error + (list (format "Output file %s not writable." file2)))) + (let ((default-directory exec-directory)) + (call-process "sh" nil nil nil "-c" (format "cat %s >> %s" file1 file2)))) + +(defun efs-copy-add-file-entry (newname host-type user size append) + ;; Add an entry in `efs-files-hashtable' for a file newly created via a copy. + (if (eq size -1) (setq size nil)) + (if append + (let ((ent (efs-get-file-entry newname))) + (if (and ent (null (car ent))) + (if (and size (numberp (nth 1 ent))) + (setcar (cdr ent) (+ size (nth 1 ent))) + (setcar (cdr ent) nil)) + ;; If the ent is a symlink or directory, don't overwrite that entry. + (if (null ent) + (efs-add-file-entry host-type newname nil nil nil)))) + (efs-add-file-entry host-type newname nil size user))) + +(defun efs-copy-remote-to-remote (f-host-type f-host f-user f-path filename + t-host-type t-host t-user + t-path newname append msg cont + nowait xfer-type) +;; Use a 3rd data connection to copy from F-HOST for F-USER to T-HOST +;; for T-USER. + (if (efs-get-host-property t-host 'pasv-failed) + ;; PASV didn't work before, don't try again. + (if cont (efs-call-cont cont 'failed "" "")) + (or xfer-type + (setq xfer-type (efs-xfer-type f-host-type filename + t-host-type newname))) + (efs-send-cmd + t-host t-user '(quote pasv) nil nil + (efs-cont (pasv-result pasv-line pasv-cont-lines) + (cont nowait f-host-type f-host f-user f-path filename + t-host-type t-host t-user t-path newname xfer-type msg append) + (efs-save-match-data + (if (or pasv-result + (not (string-match efs-pasv-msgs pasv-line))) + (progn + (efs-set-host-property t-host 'pasv-failed t) + (if cont + (efs-call-cont + cont (or pasv-result 'failed) pasv-line pasv-cont-lines))) + (let ((address (substring pasv-line (match-beginning 1) + (match-end 1)))) + (efs-send-cmd + f-host f-user + (list 'quote 'port address) nil nil + (efs-cont (port-result port-line port-cont-lines) + (cont f-host f-user f-host-type f-path filename + xfer-type msg) + (if port-result + (if cont + (efs-call-cont + cont port-result port-line port-cont-lines) + (efs-error f-host f-user + (format "PORT failed for %s: %s" + filename port-line))) + (efs-send-cmd + f-host f-user + (list 'quote 'retr f-path xfer-type) + msg nil + (efs-cont (retr-result retr-line retr-cont-lines) + (cont f-host f-user f-path) + (and retr-result + (null cont) + (efs-error + f-host f-user + (format "RETR failed for %s: %s" + f-path retr-line))) + (if cont (efs-call-cont + cont retr-result retr-line retr-cont-lines))) + (if (eq nowait t) 1 nowait)))) + 1) ; can't ever wait on this command. + (efs-send-cmd + t-host t-user + (list 'quote (if append 'appe 'stor) t-path xfer-type) + nil nil + (efs-cont (stor-result stor-line stor-cont-lines) + (t-host t-user t-path t-host-type newname filename + append) + (if stor-result + (efs-error + t-host t-user (format "%s failed for %s: %s" + (if append "APPE" "STOR") + t-path stor-line)) + (efs-copy-add-file-entry + newname t-host-type t-user + (nth 1 (efs-get-file-entry filename)) append))) + (if (eq nowait t) 1 nowait)))))) + nowait))) + +(defun efs-copy-on-remote (host user host-type filename newname filename-parsed + newname-parsed keep-date append-p msg cont + nowait xfer-type) + ;; Uses site exec to copy the file on a remote host + (let ((exec-cp (efs-get-host-property host 'exec-cp))) + (if (or append-p + (not (memq host-type efs-unix-host-types)) + (efs-get-host-property host 'exec-failed) + (eq exec-cp 'failed)) + (efs-copy-via-temp filename filename-parsed newname newname-parsed + append-p keep-date msg cont nowait xfer-type) + (if (eq exec-cp 'works) + (efs-send-cmd + host user + (list 'quote 'site 'exec + (format "cp %s%s %s" (if keep-date "-p " "") + (nth 2 filename-parsed) (nth 2 newname-parsed))) + msg nil + (efs-cont (result line cont-lines) (host user filename newname + host-type filename-parsed + newname-parsed + keep-date append-p msg cont + xfer-type nowait) + (if result + (progn + (efs-set-host-property host 'exec-failed t) + (efs-copy-via-temp filename filename-parsed newname + newname-parsed append-p keep-date + nil cont nowait xfer-type)) + (efs-save-match-data + (if (string-match "\n200-\\([^\n]*\\)" cont-lines) + (let ((err (substring cont-lines (match-beginning 1) + (match-end 1)))) + (if cont + (efs-call-cont cont 'failed err cont-lines) + (efs-error host user err))) + (efs-copy-add-file-entry + newname host-type user + (nth 7 (efs-file-attributes filename)) nil) + (if cont (efs-call-cont cont nil line cont-lines)))))) + nowait) + (message "Checking for cp executable on %s..." host) + (efs-send-cmd + host user (list 'quote 'site 'exec "cp / /") nil nil + (efs-cont (result line cont-lines) (host user filename newname + host-type filename-parsed + newname-parsed + keep-date append-p msg cont + xfer-type nowait) + (efs-save-match-data + (if (string-match "\n200-" cont-lines) + (efs-set-host-property host 'exec-cp 'works) + (efs-set-host-property host 'exec-cp 'failed))) + (efs-copy-on-remote host user host-type filename newname + filename-parsed newname-parsed keep-date + append-p msg cont nowait xfer-type)) + nowait))))) + +(defun efs-copy-via-temp (filename filename-parsed newname newname-parsed + append keep-date msg cont nowait xfer-type) + ;; Copies from FILENAME to NEWNAME via a temp file. + (let* ((temp (car (if (efs-use-gateway-p (car filename-parsed) t) + (efs-make-tmp-name (car filename-parsed) + (car newname-parsed)) + (efs-make-tmp-name (car newname-parsed) + (car filename-parsed))))) + (temp-parsed (efs-ftp-path temp))) + (or xfer-type (setq xfer-type + (efs-xfer-type + (efs-host-type (car filename-parsed)) filename + (efs-host-type (car newname-parsed)) newname + t))) + (efs-copy-file-internal + filename filename-parsed temp temp-parsed t nil (if (eq 0 msg) 2 msg) + (efs-cont (result line cont-lines) (newname newname-parsed temp + temp-parsed append msg cont + nowait xfer-type) + (if result + (progn + (efs-del-tmp-name temp) + (if cont + (efs-call-cont cont result line cont-lines) + (signal 'ftp-error + (list "Opening input file" + (format "FTP Error: \"%s\" " line) filename)))) + (efs-copy-file-internal + temp temp-parsed newname newname-parsed (if append 'append t) nil + (if (eq msg 0) 1 msg) + (efs-cont (result line cont-lines) (temp newname cont) + (efs-del-tmp-name temp) + (if cont + (efs-call-cont cont result line cont-lines) + (if result + (signal 'ftp-error + (list "Opening output file" + (format "FTP Error: \"%s\" " line) newname))))) + nowait xfer-type))) + nowait xfer-type))) + +(defun efs-copy-file-internal (filename filename-parsed newname newname-parsed + ok-if-already-exists keep-date + &optional msg cont nowait xfer-type) + ;; Internal function for copying a file from FILENAME to NEWNAME. + ;; FILENAME-PARSED and NEWNAME-PARSED are the lists obtained by parsing + ;; FILENAME and NEWNAME with efs-ftp-path. + ;; If OK-IF-ALREADY-EXISTS is nil, then existing files will not be + ;; overwritten. + ;; If it is a number, then the user will be prompted about overwriting. + ;; If it eq 'append, then an existing file will be appended to. + ;; If it has anyother value, then existing files will be silently + ;; overwritten. + ;; If KEEP-DATE is t then we will attempt to reatin the date of the + ;; original copy of the file. If this is a string, the modtime of the + ;; NEWNAME will be set to this date. Must be in touch -t format. + ;; If MSG is nil, then the copying will be done silently. + ;; If it is a string, then that will be the massage displayed while copying. + ;; If it is 0, then a suitable default message will be computed. + ;; If it is 1, then a suitable default will be computed, assuming + ;; that FILENAME is a temporary file, whose name is not suitable to use + ;; in a status message. + ;; If it is 2, then a suitable default will be used, assuming that + ;; NEWNAME is a temporary file. + ;; CONT is a continuation to call after completing the copy. + ;; The first two args are RESULT and LINE, the result symbol and status + ;; line of the FTP command. If more than one ftp command has been used, + ;; then these values for the last FTP command are given. + ;; NOWAIT can be either nil, 0, 1, t. See `efs-send-cmd' for an explanation. + ;; XFER-TYPE is the transfer type to use for transferring the files. + ;; If this is nil, than a suitable transfer type is computed. + ;; Does not call expand-file-name. Do that yourself. + + ;; check to see if we can overwrite + (if (or (not ok-if-already-exists) + (numberp ok-if-already-exists)) + (efs-barf-or-query-if-file-exists + newname "copy to it" (numberp ok-if-already-exists))) + (if (null (or filename-parsed newname-parsed)) + ;; local to local copy + (progn + (if (eq ok-if-already-exists 'append) + (efs-concatenate-files filename newname) + (copy-file filename newname ok-if-already-exists keep-date)) + (if cont + (efs-call-cont cont nil "Copied locally" ""))) + (let* ((f-host (car filename-parsed)) + (f-user (nth 1 filename-parsed)) + (f-path (nth 2 filename-parsed)) + (f-host-type (efs-host-type f-host f-user)) + (f-gate-p (efs-use-gateway-p f-host t)) + (t-host (car newname-parsed)) + (t-user (nth 1 newname-parsed)) + (t-path (nth 2 newname-parsed)) + (t-host-type (efs-host-type t-host t-user)) + (t-gate-p (efs-use-gateway-p t-host t)) + (append-p (eq ok-if-already-exists 'append)) + gatename) + + (if (and (eq keep-date t) (null newname-parsed)) + ;; f-host must be remote now. + (setq keep-date filename)) + + (cond + + ;; Check to see if we can do a PUT + ((or + (and (null f-host) + (or (null t-gate-p) + (setq gatename (efs-local-to-gateway-filename filename)))) + (and t-gate-p + f-host + (string-equal (downcase f-host) (downcase efs-gateway-host)) + (if (memq f-host-type efs-case-insensitive-host-types) + (string-equal (downcase f-user) + (downcase (efs-get-user efs-gateway-host))) + (string-equal f-user (efs-get-user efs-gateway-host))))) + (or f-host (let (file-name-handler-alist) + (if (file-exists-p filename) + (cond + ((file-directory-p filename) + (signal 'file-error + (list "Non-regular file" + "is a directory" filename))) + ((not (file-readable-p filename)) + (signal 'file-error + (list "Opening input file" + "permission denied" filename)))) + (signal 'file-error + (list "Opening input file" + "no such file or directory" filename))))) + (or xfer-type + (setq xfer-type + (efs-xfer-type f-host-type filename t-host-type newname))) + (let ((size (and (or (null f-host-type) + (efs-file-entry-p filename)) + (nth 7 (file-attributes filename))))) + ;; -1 is a bogus size for remote files + (if (eq size -1) (setq size nil)) + (efs-send-cmd + t-host t-user + (list (if append-p 'append 'put) + (if f-host + f-path + (or gatename filename)) + t-path + xfer-type) + (cond ((eq msg 2) + (concat (if append-p "Appending " "Putting ") + (efs-relativize-filename filename))) + ((eq msg 1) + (concat (if append-p "Appending " "Putting ") + (efs-relativize-filename newname))) + ((eq msg 0) + (concat (if append-p "Appending " "Copying ") + (efs-relativize-filename filename) + " to " + (efs-relativize-filename + newname (file-name-directory filename) filename))) + (t msg)) + (and size (list 'efs-set-xfer-size t-host t-user size)) + (efs-cont (result line cont-lines) (newname t-host-type t-user size + append-p cont) + (if result + (if cont + (efs-call-cont cont result line cont-lines) + (signal 'ftp-error + (list "Opening output file" + (format "FTP Error: \"%s\" " line) newname))) + ;; add file entry + (efs-copy-add-file-entry newname t-host-type t-user + size append-p) + (if cont + (efs-call-cont cont result line cont-lines)))) + nowait))) + + ;; Check to see if we can do a GET + ((and + ;; I think that giving the append arg, will cause this function + ;; to make a temp file, recursively call itself, and append the temp + ;; file to the local file. Hope it works out... + (null append-p) + (or + (and (null t-host) + (or (null f-gate-p) + (setq gatename (efs-local-to-gateway-filename newname)))) + (and f-gate-p + t-host + (string-equal (downcase t-host) (downcase efs-gateway-host)) + (if (memq t-host-type efs-case-insensitive-host-types) + (string-equal (downcase t-user) + (downcase (efs-get-user efs-gateway-host))) + (string-equal t-user (efs-get-user efs-gateway-host)))))) + (or t-host (let (file-name-handler-alist) + (cond ((not (file-writable-p newname)) + (signal 'file-error + (list "Opening output file" + "permission denied" newname))) + ((file-directory-p newname) + (signal 'file-error + (list "Opening output file" + "is a directory" newname)))))) + (or xfer-type + (setq xfer-type + (efs-xfer-type f-host-type filename t-host-type newname))) + (let ((size (and (or (null f-host-type) + (efs-file-entry-p filename)) + (nth 7 (file-attributes filename))))) + ;; -1 is a bogus size for remote files. + (if (eq size -1) (setq size nil)) + (efs-send-cmd + f-host f-user + (list 'get + f-path + (if t-host + t-path + (or gatename newname)) + xfer-type) + (cond ((eq msg 0) + (concat "Copying " + (efs-relativize-filename filename) + " to " + (efs-relativize-filename + newname (file-name-directory filename) filename))) + ((eq msg 2) + (concat "Getting " (efs-relativize-filename filename))) + ((eq msg 1) + (concat "Getting " (efs-relativize-filename newname))) + (t msg)) + ;; If the server emits a efs-xfer-size-msgs, it will over-ride this. + ;; With no xfer msg, this is will do the job. + (and size (list 'efs-set-xfer-size f-host f-user size)) + (efs-cont (result line cont-lines) (filename newname size + t-host-type t-user + cont keep-date) + (if result + (if cont + (efs-call-cont cont result line cont-lines) + (signal 'ftp-error + (list "Opening input file" + (format "FTP Error: \"%s\" " line) filename))) + ;; Add a new file entry, if relevant. + (if t-host-type + ;; t-host will be equal to efs-gateway-host, if t-host-type + ;; is non-nil. + (efs-copy-add-file-entry newname t-host-type + t-user size nil)) + (if (and (null t-host-type) (stringp keep-date)) + (efs-set-mdtm-of + filename newname + (and cont + (efs-cont (result1 line1 cont-lines1) (result + line cont-lines + cont) + (efs-call-cont cont result line cont-lines)))) + (if cont + (efs-call-cont cont result line cont-lines))))) + nowait))) + + ;; Can we do a EXEC cp? + ((and t-host f-host + (string-equal (downcase t-host) (downcase f-host)) + (if (memq t-host-type efs-case-insensitive-host-types) + (string-equal (downcase t-user) (downcase f-user)) + (string-equal t-user f-user))) + (efs-copy-on-remote + t-host t-user t-host-type filename newname filename-parsed + newname-parsed keep-date append-p + (cond ((eq msg 0) + (concat "Copying " + (efs-relativize-filename filename) + " to " + (efs-relativize-filename + newname (file-name-directory filename) filename))) + ((eq msg 1) + (concat "Copying " (efs-relativize-filename newname))) + ((eq msg 2) + (concat "Copying " (efs-relativize-filename filename))) + (t msg)) + cont nowait xfer-type)) + + ;; Try for a copy with PASV + ((and t-host f-host + (not (and (string-equal (downcase t-host) (downcase f-host)) + (if (memq t-host-type efs-case-insensitive-host-types) + (string-equal (downcase t-user) (downcase f-user)) + (string-equal t-user f-user)))) + (or + (and efs-gateway-host + ;; The gateway should be able to talk to anything. + (let ((gh (downcase efs-gateway-host))) + (or (string-equal (downcase t-host) gh) + (string-equal (downcase f-host) gh)))) + (efs-save-match-data + (eq (null (string-match efs-local-host-regexp t-host)) + (null (string-match efs-local-host-regexp f-host)))))) + (efs-copy-remote-to-remote + f-host-type f-host f-user f-path filename + t-host-type t-host t-user t-path newname + append-p + (cond ((eq msg 0) + (concat "Copying " + (efs-relativize-filename filename) + " to " + (efs-relativize-filename + newname (file-name-directory filename) filename))) + ((eq msg 1) + (concat "Copying " (efs-relativize-filename newname))) + ((eq msg 2) + (concat "Copying " (efs-relativize-filename filename))) + (t msg)) + (efs-cont (result line cont-lines) + (filename filename-parsed newname newname-parsed + append-p keep-date msg cont nowait xfer-type) + (if result + ;; PASV didn't work. Do things the old-fashioned + ;; way. + (efs-copy-via-temp + filename filename-parsed newname newname-parsed + append-p keep-date msg cont nowait xfer-type) + (if cont + (efs-call-cont cont result line cont-lines)))) + nowait xfer-type)) + + ;; Can't do anything direct. Divide and conquer. + (t + (efs-copy-via-temp filename filename-parsed newname newname-parsed + append-p keep-date msg cont nowait xfer-type)))))) + +(defun efs-copy-file (filename newname &optional ok-if-already-exists + keep-date nowait) + ;; Version of copy file for remote files. Actually, will also work + ;; for local files too, since efs-copy-file-internal can copy anything. + ;; If called interactively, copies asynchronously. + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) + (if (eq ok-if-already-exists 'append) + (setq ok-if-already-exists t)) + (efs-copy-file-internal filename (efs-ftp-path filename) + newname (efs-ftp-path newname) + ok-if-already-exists keep-date 0 nil nowait)) + +;;;; ------------------------------------------------------------ +;;;; File renaming support. +;;;; ------------------------------------------------------------ + +(defun efs-rename-get-file-list (dir ent) + ;; From hashtable ENT for DIR returns a list of all files except "." + ;; and "..". + (let (list) + (efs-map-hashtable + (function + (lambda (key val) + (or (string-equal "." key) (string-equal ".." key) + (setq list + (cons (expand-file-name key dir) list))))) + ent) + list)) + +(defun efs-rename-get-files (dir cont nowait) + ;; Obtains a list of files in directory DIR (except . and ..), and applies + ;; CONT to the list. Doesn't return anything useful. + (let* ((dir (file-name-as-directory dir)) + (ent (efs-get-files-hashtable-entry dir))) + (if ent + (efs-call-cont cont (efs-rename-get-file-list dir ent)) + (efs-ls + dir (efs-ls-guess-switches) t nil t nowait + (efs-cont (listing) (dir cont) + (efs-call-cont + cont (and listing + (efs-rename-get-file-list + dir (efs-get-files-hashtable-entry dir))))))))) + +(defun efs-rename-get-local-file-tree (dir) + ;; Returns a list of the full directory tree under DIR, for DIR on the + ;; local host. The list is in tree order. + (let ((res (list dir))) + (mapcar + (function + (lambda (file) + (if (file-directory-p file) + (nconc res (delq nil (mapcar + (function + (lambda (f) + (and (not (string-equal "." f)) + (not (string-equal ".." f)) + (expand-file-name f file)))) + (directory-files file))))))) + res) + res)) + +(defun efs-rename-get-remote-file-tree (next curr total cont nowait) + ;; Builds a hierarchy of files. + ;; NEXT is the next level so far. + ;; CURR are unprocessed files in the current level. + ;; TOTAL is the processed files so far. + ;; CONT is a cont. function called on the total list after all files + ;; are processed. + ;; NOWAIT non-nil means run asynch. + (or curr (setq curr next + next nil)) + (if curr + (let ((file (car curr))) + (setq curr (cdr curr) + total (cons file total)) + (if (file-directory-p file) + (efs-rename-get-files + file + (efs-cont (list) (next curr total cont nowait) + (efs-rename-get-remote-file-tree (nconc next list) + curr total cont nowait)) + nowait) + (efs-rename-get-remote-file-tree next curr total cont nowait))) + (efs-call-cont cont (nreverse total)))) + +(defun efs-rename-make-targets (files from-dir-len to-dir host user host-type + cont nowait) + ;; Make targets (copy a file or make a subdir) on local or host + ;; for the files in list. Afterwhich, call CONT. + (if files + (let* ((from (car files)) + (files (cdr files)) + (to (concat to-dir (substring from from-dir-len)))) + (if (file-directory-p from) + (if host-type + (let ((dir (nth 2 (efs-ftp-path to)))) + (or (memq host-type efs-unix-host-types) + (memq host-type '(dos os2)) + (setq dir (efs-internal-file-name-as-directory nil dir))) + (efs-send-cmd + host user (list 'mkdir dir) + (format "Making directory %s" (efs-relativize-filename to)) + nil + (efs-cont (res line cont-lines) (to files from-dir-len + to-dir host user + host-type cont nowait) + (if res + (if cont + (efs-call-cont cont res line cont-lines) + (signal 'ftp-error + (list "Making directory" + (format "FTP Error: \"%s\"" line) + to))) + (efs-rename-make-targets + files from-dir-len to-dir host user + host-type cont nowait))) + nowait)) + (condition-case nil + (make-directory-internal to) + (error (efs-call-cont + cont 'failed (format "Failed to mkdir %s" to) ""))) + (efs-rename-make-targets + files from-dir-len to-dir host user host-type cont nowait)) + (efs-copy-file-internal + from (efs-ftp-path from) to (and host-type (efs-ftp-path to)) nil t + (format "Renaming %s to %s" (efs-relativize-filename from) + (efs-relativize-filename to)) + (efs-cont (res line cont-lines) (from to files from-dir-len to-dir + host user host-type cont + nowait) + (if res + (if cont + (efs-call-cont cont res line cont-lines) + (signal 'ftp-error + (list "Renaming" + (format "FTP Error: \"%s\"" line) from to))) + (efs-rename-make-targets + files from-dir-len to-dir host user host-type cont nowait))) + nowait))) + (if cont (efs-call-cont cont nil "" "")))) + +(defun efs-rename-delete-on-local (files) + ;; Delete the files FILES, and then run CONT. + ;; FILES are assumed to be in inverse tree order. + (message "Deleting files...") + (mapcar + (function + (lambda (f) + (condition-case nil + (if (file-directory-p f) + (delete-directory f) + (delete-file f)) + (file-error nil)))) ; don't complain if the file is already gone. + files) + (message "Deleting files...done")) + +(defun efs-rename-delete-on-remote (files host user host-type cont nowait) + ;; Deletes the list FILES on a remote host. When done calls CONT. + ;; FILES is assumed to be in reverse tree order. + (if files + (let* ((f (car files)) + (rf (nth 2 (efs-ftp-path f)))) + (progn + (setq files (cdr files)) + (if (file-directory-p f) + (let ((rf (if (memq host-type (append efs-unix-host-types + '(dos os2))) + (efs-internal-directory-file-name f) + (efs-internal-file-name-as-directory nil f)))) + + (efs-send-cmd + host user (list 'rmdir rf) + (concat "Deleting directory " (efs-relativize-filename f)) + nil + (efs-cont (res line cont-lines) (f files host user host-type + cont nowait) + (if (and res + (efs-save-match-data + (not (string-match "^550 " line)))) + (if cont + (efs-call-cont cont res line cont-lines) + (signal 'ftp-error + (list "Deleting directory" + (format "FTP Error: \"%s\"" line) + f))) + (efs-rename-delete-on-remote + files host user host-type cont nowait))) + nowait)) + (efs-send-cmd + host user (list 'delete rf) + (concat "Deleting " rf) + nil + (efs-cont (res line cont-lines) (f files host user host-type + cont nowait) + (if (and res + (efs-save-match-data + (not (string-match "^550 " line)))) + (if cont + (efs-call-cont cont res line cont-lines) + (signal 'ftp-error + (list "Deleting" + (format "FTP Error: \"%s\"" line) + f))) + (efs-rename-delete-on-remote + files host user host-type cont nowait))) + nowait)))) + (if cont (efs-call-cont cont nil "" "")))) + +(defun efs-rename-on-remote (host user old-path new-path old-file new-file + msg nowait cont) + ;; Run a rename command on the remote server. + ;; OLD-PATH and NEW-PATH are in full efs syntax. + ;; OLD-FILE and NEW-FILE are the remote full pathnames, not in efs syntax. + (efs-send-cmd + host user (list 'rename old-file new-file) msg nil + (efs-cont (result line cont-lines) (cont old-path new-path host) + (if result + (progn + (or (and (>= (length line) 4) + (string-equal "550 " (substring line 0 4))) + (efs-set-host-property host 'rnfr-failed t)) + (if cont + (efs-call-cont cont result line cont-lines) + (signal 'ftp-error + (list "Renaming" + (format "FTP Error: \"%s\"" line) + old-path new-path)))) + (let ((entry (efs-get-file-entry old-path)) + (host-type (efs-host-type host)) + ;; If no file entry, do extra work on the hashtable, + ;; rather than force a listing. + (dir-p (or (not (efs-file-entry-p old-path)) + (file-directory-p old-path)))) + (apply 'efs-add-file-entry host-type new-path + (eq (car entry) t) (cdr entry)) + (efs-delete-file-entry host-type old-path) + (if dir-p + (let* ((old (efs-canonize-file-name + (file-name-as-directory old-path))) + (new (efs-canonize-file-name + (file-name-as-directory new-path))) + (old-len (length old)) + (new-tbl (efs-make-hashtable + (length efs-files-hashtable)))) + (efs-map-hashtable + (function + (lambda (key val) + (if (and (>= (length key) old-len) + (string-equal (substring key 0 old-len) + old)) + (efs-put-hash-entry + (concat new (substring key old-len)) val new-tbl) + (efs-put-hash-entry key val new-tbl)))) + efs-files-hashtable) + (setq efs-files-hashtable new-tbl))) + (if cont (efs-call-cont cont result line cont-lines))))) + nowait)) + +(defun efs-rename-local-to-remote (filename newname newname-parsed + msg cont nowait) + ;; Renames a file from the local host to a remote host. + (if (file-directory-p filename) + (let* ((files (efs-rename-get-local-file-tree filename)) + (to-dir (directory-file-name newname)) + (filename (directory-file-name filename)) + (len (length filename)) + (t-parsed (efs-ftp-path to-dir)) + (host (car t-parsed)) + (user (nth 1 t-parsed)) + (host-type (efs-host-type host))) + ;; MSG is never passed here, instead messages are constructed + ;; internally. I don't know how to use a single message + ;; in a function which sends so many FTP commands. + (efs-rename-make-targets + files len to-dir host user host-type + (efs-cont (result line cont-lines) (files filename newname cont) + (if result + (if cont + (efs-call-cont cont result line cont-lines) + (signal 'ftp-error + (list "Renaming" (format "FTP Error: \"%s\"" line) + filename newname))) + (efs-rename-delete-on-local (nreverse files)) + (if cont (efs-call-cont cont result line cont-lines)))) + nowait)) + (efs-copy-file-internal + filename nil newname newname-parsed t t msg + (efs-cont (result line cont-lines) (filename cont) + (if result + (if cont + (efs-call-cont cont result line cont-lines) + (signal 'ftp-error + (list "Renaming" + (format "FTP Error: \"%s\"" line) + filename newname))) + (condition-case nil + (delete-file filename) + (error nil)) + (if cont (efs-call-cont cont result line cont-lines)))) + nowait))) + +(defun efs-rename-from-remote (filename filename-parsed newname newname-parsed + msg cont nowait) + (let ((f-host (car filename-parsed)) + (f-user (nth 1 filename-parsed)) + (fast-nowait (if (eq nowait t) 1 nowait))) + (if (file-directory-p filename) + (let* ((t-host (car newname-parsed)) + (t-user (nth 1 newname-parsed)) + (t-host-type (and t-host (efs-host-type t-host))) + (f-host-type (efs-host-type f-host))) + (efs-rename-get-remote-file-tree + nil (list filename) nil + (efs-cont (list) (filename filename-parsed newname t-host t-user + t-host-type f-host f-user f-host-type + cont fast-nowait) + (efs-rename-make-targets + list (length filename) newname t-host t-user t-host-type + (efs-cont (res line cont-lines) (filename newname f-host f-user + f-host-type list cont + fast-nowait) + (if res + (if cont + (efs-call-cont cont res line cont-lines) + (signal 'ftp-error + (list "Renaming" + (format "FTP Error: \"%s\"" line) + filename newname))) + (efs-rename-delete-on-remote + (nreverse list) f-host f-user f-host-type cont + fast-nowait))) + fast-nowait)) nowait)) + ;; Do things the simple way. + (let ((f-path (nth 2 filename-parsed)) + (f-abbr (efs-relativize-filename filename))) + (efs-copy-file-internal + filename filename-parsed newname newname-parsed t t msg + (efs-cont (result line cont-lines) (filename newname f-host f-user + f-path f-abbr + cont fast-nowait) + (if result + (if cont + (efs-call-cont cont result line cont-lines) + (signal 'ftp-error + (list "Renaming" + (format "FTP Error: \"%s\"" line) + filename newname))) + (efs-send-cmd + f-host f-user (list 'delete f-path) + (format "Removing %s" f-abbr) nil + (efs-cont (result line cont-lines) (filename f-host cont) + (if result + (if cont + (efs-call-cont cont result line cont-lines) + (signal 'ftp-error + (list "Renaming" + (format "Failed to remove %s" + filename) + "FTP Error: \"%s\"" line))) + (efs-delete-file-entry (efs-host-type f-host) + filename) + (if cont + (efs-call-cont cont result line cont-lines)))) + fast-nowait))) nowait))))) + +(defun efs-rename-file-internal (filename newname ok-if-already-exists + &optional msg cont nowait) + ;; Internal version of rename-file for remote files. + ;; Takes CONT and NOWAIT args. + (let ((filename (expand-file-name filename)) + (newname (expand-file-name newname))) + (let ((f-parsed (efs-ftp-path filename)) + (t-parsed (efs-ftp-path newname))) + (if (null (or f-parsed t-parsed)) + (progn + ;; local rename + (rename-file filename newname ok-if-already-exists) + (if cont + (efs-call-cont cont nil "Renamed locally" ""))) + + ;; check to see if we can overwrite + (if (or (not ok-if-already-exists) + (numberp ok-if-already-exists)) + (efs-barf-or-query-if-file-exists + newname "rename to it" (numberp ok-if-already-exists))) + + (let ((f-abbr (efs-relativize-filename filename)) + (t-abbr (efs-relativize-filename newname + (file-name-directory filename) + filename))) + (or msg (setq msg (format "Renaming %s to %s" f-abbr t-abbr))) + (if f-parsed + (let* ((f-host (car f-parsed)) + (f-user (nth 1 f-parsed)) + (f-path (nth 2 f-parsed)) + (f-host-type (efs-host-type f-host))) + (if (and t-parsed + (string-equal (downcase f-host) + (downcase (car t-parsed))) + (not (efs-get-host-property f-host 'rnfr-failed)) + (if (memq f-host-type efs-case-insensitive-host-types) + (string-equal (downcase f-user) + (downcase (nth 1 t-parsed))) + (string-equal f-user (nth 1 t-parsed)))) + ;; Can run a RENAME command on the server. + (efs-rename-on-remote + f-host f-user filename newname f-path (nth 2 t-parsed) + msg nowait + (efs-cont (result line cont-lines) (f-host + filename + newname + ok-if-already-exists + msg cont nowait) + (if result + (progn + (efs-set-host-property f-host 'rnfr-failed t) + (efs-rename-file-internal + filename newname ok-if-already-exists msg cont + (if (eq nowait t) 1 nowait))) + (if cont + (efs-call-cont cont result line cont-lines))))) + ;; remote to remote + (efs-rename-from-remote filename f-parsed newname t-parsed + msg cont nowait))) + ;; local to remote + (efs-rename-local-to-remote + filename newname t-parsed msg cont nowait))))))) + +(defun efs-rename-file (filename newname &optional ok-if-already-exists nowait) + ;; Does file renaming for remote files. + (efs-rename-file-internal filename newname ok-if-already-exists + nil nil nowait)) + +;;;; ------------------------------------------------------------ +;;;; Making symbolic and hard links. +;;;; ------------------------------------------------------------ + +;;; These functions require that the remote FTP server understand +;;; SITE EXEC and that ln is in its the ftp-exec path. + +(defun efs-try-ln (host user cont nowait) + ;; Do some preemptive testing to see if exec ln works + (if (efs-get-host-property host 'exec-failed) + (signal 'ftp-error (list "Unable to exec ln on host" host))) + (let ((exec-ln (efs-get-host-property host 'exec-ln))) + (cond + ((eq exec-ln 'failed) + (signal 'ftp-error (list "ln is not in FTP exec path on host" host))) + ((eq exec-ln 'works) + (efs-call-cont cont)) + (t + (message "Checking for ln executable on %s..." host) + (efs-send-cmd + host user '(quote site exec "ln / /") + nil nil + (efs-cont (result line cont-lines) (host user cont) + (if result + (progn + (efs-set-host-property host 'exec-failed t) + (efs-error host user (format "exec: %s" line))) + ;; Look for an error message + (if (efs-save-match-data + (string-match "\n200-" cont-lines)) + (progn + (efs-set-host-property host 'exec-ln 'works) + (efs-call-cont cont)) + (efs-set-host-property host 'exec-ln 'failed) + (efs-error host user + (format "ln not in FTP exec path on host %s" host))))) + nowait))))) + +(defun efs-make-symbolic-link-internal + (target linkname &optional ok-if-already-exists cont nowait) + ;; Makes remote symbolic links. Assumes that linkname is already expanded. + (let* ((parsed (efs-ftp-path linkname)) + (host (car parsed)) + (user (nth 1 parsed)) + (linkpath (nth 2 parsed)) + (abbr (efs-relativize-filename linkname + (file-name-directory target) target)) + (tparsed (efs-ftp-path target)) + (com-target target) + cmd-string) + (if (null (file-directory-p + (file-name-directory linkname))) + (if cont + (efs-call-cont cont 'failed + (format "no such file or directory, %s" linkname) + "") + (signal 'file-error (list "no such file or directory" linkname))) + (if (or (not ok-if-already-exists) + (numberp ok-if-already-exists)) + (efs-barf-or-query-if-file-exists + linkname "make symbolic link" (numberp ok-if-already-exists))) + ;; Do this after above, so that hopefully the host type is sorted out + ;; by now. + (let ((host-type (efs-host-type host))) + (if (or (not (memq host-type efs-unix-host-types)) + (memq host-type efs-dumb-host-types) + (efs-get-host-property host 'exec-failed)) + (error "Unable to make symbolic links on %s." host))) + ;; Be careful not to spoil relative links, or symlinks to other + ;; machines, which maybe symlink-fix.el can sort out. + (if (and tparsed + (string-equal (downcase (car tparsed)) (downcase host)) + (string-equal (nth 1 tparsed) user)) + (setq com-target (nth 2 tparsed))) + ;; symlinks only work for unix, so don't need to + ;; convert pathnames. What about VOS? + (setq cmd-string (concat "ln -sf " com-target " " linkpath)) + (efs-try-ln + host user + (efs-cont () (host user cmd-string target linkname com-target + abbr cont nowait) + (efs-send-cmd + host user (list 'quote 'site 'exec cmd-string) + (format "Symlinking %s to %s" target abbr) + nil + (efs-cont (result line cont-lines) (host user com-target linkname + cont) + (if result + (progn + (efs-set-host-property host 'exec-failed t) + (efs-error host user (format "exec: %s" line))) + (efs-save-match-data + (if (string-match "\n200-\\([^\n]*\\)" cont-lines) + (let ((err (substring cont-lines (match-beginning 1) + (match-end 1)))) + (if cont + (efs-call-cont cont 'failed err cont-lines) + (efs-error host user err))) + (efs-add-file-entry nil linkname com-target nil user) + (if cont (efs-call-cont cont nil line cont-lines)))))) + nowait)) + nowait)))) + +(defun efs-make-symbolic-link (target linkname &optional ok-if-already-exists) + ;; efs version of make-symbolic-link + (let* ((linkname (expand-file-name linkname)) + (parsed (efs-ftp-path linkname))) + (if parsed + (efs-make-symbolic-link-internal target linkname ok-if-already-exists) + ;; Handler will match on either target or linkname. We are only + ;; interested in the linkname. + (let ((file-name-handler-alist (efs-file-name-handler-alist-sans-fn + 'efs-file-handler-function))) + (make-symbolic-link target linkname ok-if-already-exists))))) + +(defun efs-add-name-to-file-internal + (file newname &optional ok-if-already-exists cont nowait) + ;; Makes remote symbolic links. Assumes that linkname is already expanded. + (let* ((parsed (efs-ftp-path file)) + (host (car parsed)) + (user (nth 1 parsed)) + (path (nth 2 parsed)) + (nparsed (efs-ftp-path newname)) + (nhost (car nparsed)) + (nuser (nth 1 nparsed)) + (npath (nth 2 nparsed)) + (abbr (efs-relativize-filename newname + (file-name-directory file))) + (ent (efs-get-file-entry file)) + cmd-string) + (or (and (string-equal (downcase host) (downcase nhost)) + (string-equal user nuser)) + (error "Cannot create hard links between different host user pairs.")) + (if (or (null ent) (stringp (car ent)) + (not (file-directory-p + (file-name-directory newname)))) + (if cont + (efs-call-cont cont 'failed + (format "no such file or directory, %s %s" + file newname) "") + (signal 'file-error + (list "no such file or directory" + file newname))) + (if (or (not ok-if-already-exists) + (numberp ok-if-already-exists)) + (efs-barf-or-query-if-file-exists + newname "make hard link" (numberp ok-if-already-exists))) + ;; Do this last, so that hopefully the host type is known. + (let ((host-type (efs-host-type host))) + (if (or (not (memq host-type efs-unix-host-types)) + (memq host-type efs-dumb-host-types) + (efs-get-host-property host 'exec-failed)) + (error "Unable to make hard links on %s." host))) + (setq cmd-string (concat "ln -f " path " " npath)) + (efs-try-ln + host user + (efs-cont () (host user cmd-string file newname abbr cont nowait) + (efs-send-cmd + host user (list 'quote 'site 'exec cmd-string) + (format "Adding to %s name %s" file abbr) + nil + (efs-cont (result line cont-lines) (host user file newname cont) + (if result + (progn + (efs-set-host-property host 'exec-failed t) + (efs-error host user (format "exec: %s" line))) + (efs-save-match-data + (if (string-match "\n200-\\([^\n]*\\)" cont-lines) + (let ((err (substring cont-lines (match-beginning 1) + (match-end 1)))) + (if cont + (efs-call-cont cont 'failed err cont-lines) + (efs-error host user err))) + (let ((ent (efs-get-file-entry file))) + (if ent + (let ((nlinks (nthcdr 4 ent)) + new-nlinks) + (and (integerp (car nlinks)) + (setq new-nlinks (1+ (car nlinks))) + (setcar nlinks new-nlinks)) + (apply 'efs-add-file-entry nil newname ent) + (if cont (efs-call-cont cont nil line cont-lines))) + (let ((tbl (efs-get-files-hashtable-entry + (file-name-directory + (directory-file-name newname))))) + (if tbl + (efs-ls + newname + (concat (efs-ls-guess-switches) "d") t t nil + nowait + (efs-cont (listing) (newname cont line cont-lines) + (efs-update-file-info + newname efs-data-buffer-name) + (if cont + (efs-call-cont cont nil line cont-lines)))) + (if cont + (efs-call-cont cont nil line cont-lines)))))))))) + nowait)) + nowait)))) + +(defun efs-add-name-to-file (file newname &optional ok-if-already-exists) + ;; efs version of add-name-to-file + (efs-add-name-to-file-internal file newname ok-if-already-exists)) + + +;;;; ============================================================== +;;;; >9 +;;;; Multiple Host Type Support. +;;;; The initial host type guessing is done in the PWD code below. +;;;; If necessary, further guessing is done in the listing parser. +;;;; ============================================================== + + +;;;; -------------------------------------------------------------- +;;;; Functions for setting and retrieving host types. +;;;; -------------------------------------------------------------- + +(defun efs-add-host (type host) + "Sets the TYPE of the remote host HOST. +The host type is read with completion so this can be used to obtain a +list of supported host types. HOST must be a string, giving the name of +the host, exactly as given in file names. Setting the host type with +this function is preferable to setting the efs-TYPE-host-regexp, as look up +will be faster. Returns TYPE." + ;; Since internet host names are always case-insensitive, we will cache + ;; them in lower case. + (interactive + (list + (intern + (completing-read "Host type: " + (mapcar + (function (lambda (elt) + (list (symbol-name (car elt))))) + efs-host-type-alist) + nil t)) + (read-string "Host: " + (let ((name (or (buffer-file-name) + (and (eq major-mode 'dired-mode) + dired-directory)))) + (and name (car (efs-ftp-path name))))))) + (setq host (downcase host)) + (efs-set-host-property host 'host-type type) + (prog1 + (setq efs-host-cache host + efs-host-type-cache type) + (efs-set-process-host-type host))) + +(defun efs-set-process-host-type (host &optional user) + ;; Sets the value of efs-process-host-type so that it is shown + ;; on the mode-line. + (let ((buff-list (buffer-list))) + (save-excursion + (while buff-list + (set-buffer (car buff-list)) + (if (equal efs-process-host host) + (setq efs-process-host-type (concat " " (symbol-name + (efs-host-type host)))) + (and efs-show-host-type-in-dired + (eq major-mode 'dired-mode) + efs-dired-host-type + (string-equal (downcase + (car (efs-ftp-path default-directory))) + (downcase host)) + (if user + (setq efs-dired-listing-type-string + (concat + " " + (symbol-name (efs-listing-type host user)))) + (or efs-dired-listing-type-string + (setq efs-dired-listing-type-string + (concat " " (symbol-name (efs-host-type host)))))))) + (setq buff-list (cdr buff-list)))))) + +;;;; ---------------------------------------------------------------- +;;;; Functions for setting and retrieving listings types. +;;;; ---------------------------------------------------------------- + +;;; listing types?? +;;; These are distinguished from host types, in case some OS's have two +;;; breeds of listings. e.g. Unix descriptive listings. +;;; We also use this to support the myriad of DOS ftp servers. + + +(defun efs-listing-type (host user) + "Returns the type of listing used on HOST by USER. +If there is no entry for a specialized listing, returns the host type." + (or + (efs-get-host-user-property host user 'listing-type) + (efs-host-type host user))) + +(defun efs-add-listing-type (type host user) + "Interactively adds the specialized listing type TYPE for HOST and USER +to the listing type cache." + (interactive + (let ((name (or (buffer-file-name) + (and (eq major-mode 'dired-mode) + dired-directory)))) + (list + (intern + (completing-read "Listing type: " + (mapcar + (function (lambda (elt) + (list (symbol-name elt)))) + efs-listing-types) + nil t)) + (read-string "Host: " + (and name (car (efs-ftp-path name)))) + (read-string "User: " + (and name (nth 1 (efs-ftp-path name))))))) + (efs-set-host-user-property host user 'listing-type type) + (efs-set-process-host-type host user)) + +;;;; -------------------------------------------------------------- +;;;; Auotomagic bug reporting for unrecognized host types. +;;;; -------------------------------------------------------------- + +(defun efs-scream-and-yell-1 (host user) + ;; Internal for efs-scream-and-yell. + (with-output-to-temp-buffer "*Help*" + (princ + (format + "efs is unable to identify the remote host type of %s. + +Please report this as a bug. It would be very helpful +if your bug report contained at least the PWD command +within the *ftp %s@%s* buffer. +If you know them, also send the operating system +and ftp server types of the remote host." host user host))) + (if (y-or-n-p "Would you like to submit a bug report now? ") + (efs-report-bug host user + "Bug occurred during efs-guess-host-type." t))) + +(defun efs-scream-and-yell (host user) + ;; Advertises that something has gone wrong in identifying the host type. + (if (eq (selected-window) (minibuffer-window)) + (efs-abort-recursive-edit-and-then 'efs-scream-and-yell-1 host user) + (efs-scream-and-yell-1 host user) + (error "Unable to identify remote host type"))) + +;;;; -------------------------------------------------------- +;;;; Guess at the host type using PWD syntax. +;;;; -------------------------------------------------------- + +;; host-type path templates. These should match a pwd performed +;; as the first command after connecting. They should be as tight +;; as possible + +(defconst efs-unix-path-template "^/") +(defconst efs-apollo-unix-path-template "^//") +(defconst efs-cms-path-template + (concat + "^[-A-Z0-9$*][-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?" + "[-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?\\.[0-9][0-9][0-9A-Z]$\\|" + ;; For the SFS version of CMS + "^[-A-Z0-9]+:[-A-Z0-9$*]+\\.$")) + +(defconst efs-mvs-path-template "^'?[A-Z][0-9][0-9]?[0-9]?[0-9]?[0-9]?\\.'?") + +(defconst efs-guardian-path-template + (concat + "^\\(" + "\\\\[A-Z0-9][A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?\\." + "\\)?" + "\\$[A-Z0-9][A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?\\." + "[A-Z][A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?$")) +;; guardian and cms are very close to overlapping (they don't). Be careful. +(defconst efs-vms-path-template + "^[-A-Z0-9_$]+:\\[[-A-Z0-9_$]+\\(\\.[-A-Z0-9_$]+\\)*\\]$") +(defconst efs-mts-path-template + "^[A-Z0-9._][A-Z0-9._][A-Z0-9._][A-Z0-9._]:$") +(defconst efs-ms-unix-path-template "^[A-Za-z0-9]:/") + +;; Following two are for TI lisp machines. Note that lisp machines +;; do not have a default directory, but only a default pathname against +;; which relative pathnames are merged (Jamie tells me). +(defconst efs-ti-explorer-pwd-line-template + (let* ((excluded-chars ":;<>.#\n\r\t\\/a-z ") + (token (concat "[^" excluded-chars "]+"))) + (concat "^250 " + token ": " ; host name + token "\\(\\." token "\\)*; " ; directory + "\\(\\*.\\*\\|\\*\\)#\\(\\*\\|>\\)" ; name, ext, version + "$"))) ; "*.*#*" or "*.*#>" or "*#*" or "*#>" or "#*" ... +(defconst efs-ti-twenex-path-template + (let* ((excluded-chars ":;<>.#\n\r\t\\/a-z ") + (token (concat "[^" excluded-chars "]+"))) + (concat "^" + token ":" ; host name + "<\\(" token "\\)?\\(\\." token "\\)*>" ; directory + "\\(\\*.\\*\\|\\*\\)" ; name and extension + "$"))) + +(defconst efs-tops-20-path-template + "^[-A-Z0-9_$]+:<[-A-Z0-9_$]\\(.[-A-Z0-9_$]+\\)*>$") +(defconst efs-pc-path-template + "^[a-zA-Z0-9]:\\\\\\([-_+=a-zA-Z0-9.]+\\\\\\)*[-_+=a-zA-Z0-9.]*$") +(defconst efs-mpe-path-template + (let ((token (concat "[A-Z][A-Z0-9]?[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?" + "[A-Z0-9]?[A-Z0-9]?[A-Z0-9]?"))) + (concat + ;; optional session name + "^\\(" token "\\)?," + ;; username + token "." + ;; account + token "," + ;; group + token "$"))) +(defconst efs-vos-path-template + (let ((token "[][@\\^`{}|~\"$+,---./:_a-zA-Z0-9]+")) + (concat + "%" token ; host + "#" token ; disk + "\\(>" token "\\)+" ; directories + ))) +(defconst efs-netware-path-template "^[-A-Z0-9_][-A-Z0-9_/]*:/") +;; Sometimes netware doesn't return a device to a PWD. Then it will be +;; recognized by the listing parser. + +(defconst efs-nos-ve-path-template "^:[A-Z0-9]") +;; Matches the path for NOS/VE + +(defconst efs-mvs-pwd-line-template + ;; Not sure how the PWD parser will do with empty strings, so treate + ;; this as a line regexp. + "^257 \\([Nn]o prefix defined\\|\"\" is working directory\\)") +(defconst efs-cms-pwd-line-template + "^450 No current working directory defined$") +(defconst efs-tops-20-pwd-line-template + "^500 I never heard of the \\(XPWD\\|PWD\\) command\\. Try HELP\\.$") +(defconst efs-dos:ftp-pwd-line-template + "^250 Current working directory is +") +(defconst efs-coke-pwd-line-template "^257 Current balance \\$[0-9]") + +(defconst efs-super-dumb-unix-tilde-regexp + "^550 /.*: No such file or directory\\.?$") +(defconst efs-cms-knet-tilde-regexp + "^501 Invalid CMS fileid: ~$") + + +;; It might be nice to message users about the host type identified, +;; but there is so much other messaging going on, it would not be +;; seen. No point in slowing things down just so users can read +;; a host type message. + +(defun efs-guess-host-type (host user) + "Guess the host type of HOST. +Does a PWD and examines the directory syntax. The PWD is then cached for use +in file name expansion." + (let ((host-type (efs-host-type host)) + (key (concat host "/" user "/~")) + syst) + (efs-save-match-data + (if (eq host-type 'unknown) + ;; Note that efs-host-type returns unknown as the default. + ;; Since we don't yet know the host-type, we use the default + ;; version of efs-send-pwd. We compensate if necessary + ;; by looking at the entire line of output. + (let* ((result (efs-send-pwd nil host user)) + (dir (car result)) + (line (cdr result))) + (cond + + ;; First sift through process lines to see if we recognize + ;; any pwd errors, or full line messages. + + ;; CMS + ((string-match efs-cms-pwd-line-template line) + (setq host-type (efs-add-host 'cms host) + dir (concat "/" (if (> (length user) 8) + (substring user 0 8) + user) + ".191")) + (message + "Unable to determine a \"home\" CMS minidisk. Assuming %s" + dir) + (sit-for 1)) + + ;; TOPS-20 + ((string-match efs-tops-20-pwd-line-template line) + (setq host-type (efs-add-host 'tops-20 host) + dir (car (efs-send-pwd 'tops-20 host user)))) + + ;; TI-EXPLORER lisp machine. pwd works here, but the output + ;; needs to be specially parsed since spaces separate + ;; hostnames from dirs from filenames. + ((string-match efs-ti-explorer-pwd-line-template line) + (setq host-type (efs-add-host 'ti-explorer host) + dir (substring line 4))) + + ;; FTP Software's DOS Server + ((string-match efs-dos:ftp-pwd-line-template line) + (setq host-type (efs-add-host 'dos host) + dir (substring line (match-end 0))) + (efs-add-listing-type 'dos:ftp host user)) + + ;; MVS + ((string-match efs-mvs-pwd-line-template line) + (setq host-type (efs-add-host 'mvs host) + dir "")) ; "" will convert to /, which is always + ; the mvs home dir. + + ;; COKE + ((string-match efs-coke-pwd-line-template line) + (setq host-type (efs-add-host 'coke host) + dir "/")) + + ;; Try to get tilde. + ((null dir) + (let ((tilde (nth 1 (efs-send-cmd + host user (list 'get "~" "/dev/null"))))) + (cond + ;; super dumb unix + ((string-match efs-super-dumb-unix-tilde-regexp tilde) + (setq dir (car (efs-send-pwd 'super-dumb-unix host user)) + host-type (efs-add-host 'super-dumb-unix host))) + + ;; Try for cms-knet + ((string-match efs-cms-knet-tilde-regexp tilde) + (setq dir (car (efs-send-pwd 'cms-knet host user)) + host-type (efs-add-host 'cms-knet host))) + + ;; We don't know. Scream and yell. + (efs-scream-and-yell host user)))) + + ;; Now look at dir to determine host type + + ;; try for UN*X-y type stuff + ((string-match efs-unix-path-template dir) + (if + ;; Check for apollo, so we know not to short-circuit //. + (string-match efs-apollo-unix-path-template dir) + (progn + (setq host-type (efs-add-host 'apollo-unix host)) + (efs-add-listing-type 'unix:unknown host user)) + ;; could be ka9q, dos-distinct, plus any of the unix breeds, + ;; except apollo. + (if (setq syst (efs-get-syst host user)) + (let ((case-fold-search t)) + (cond + ((string-match "\\bNetware\\b" syst) + (setq host-type (efs-add-host 'netware host))) + ((string-match "^Plan 9" syst) + (setq host-type (efs-add-host 'plan9 host))) + ((string-match "^UNIX" syst) + (setq host-type (efs-add-host 'unix host)) + (efs-add-listing-type 'unix:unknown host user))))))) + + ;; try for VMS + ((string-match efs-vms-path-template dir) + (setq host-type (efs-add-host 'vms host))) + + ;; try for MTS + ((string-match efs-mts-path-template dir) + (setq host-type (efs-add-host 'mts host))) + + ;; try for CMS + ((string-match efs-cms-path-template dir) + (setq host-type (efs-add-host 'cms host))) + + ;; try for Tandem's guardian OS + ((string-match efs-guardian-path-template dir) + (setq host-type (efs-add-host 'guardian host))) + + ;; Try for TOPS-20. pwd doesn't usually work for tops-20 + ;; But who knows??? + ((string-match efs-tops-20-path-template dir) + (setq host-type (efs-add-host 'tops-20 host))) + + ;; Try for DOS or OS/2. + ((string-match efs-pc-path-template dir) + (let ((syst (efs-get-syst host user)) + (case-fold-search t)) + (if (and syst (string-match "^OS/2 " syst)) + (setq host-type (efs-add-host 'os2 host)) + (setq host-type (efs-add-host 'dos host))))) + + ;; try for TI-TWENEX lisp machine + ((string-match efs-ti-twenex-path-template dir) + (setq host-type (efs-add-host 'ti-twenex host))) + + ;; try for MPE + ((string-match efs-mpe-path-template dir) + (setq host-type (efs-add-host 'mpe host))) + + ;; try for VOS + ((string-match efs-vos-path-template dir) + (setq host-type (efs-add-host 'vos host))) + + ;; try for the microsoft server in unix mode + ((string-match efs-ms-unix-path-template dir) + (setq host-type (efs-add-host 'ms-unix host))) + + ;; Netware? + ((string-match efs-netware-path-template dir) + (setq host-type (efs-add-host 'netware host))) + + ;; Try for MVS + ((string-match efs-mvs-path-template dir) + (if (string-match "^'.+'$" dir) + ;; broken MVS PWD quoting + (setq dir (substring dir 1 -1))) + (setq host-type (efs-add-host 'mvs host))) + + ;; Try for NOS/VE + ((string-match efs-nos-ve-path-template dir) + (setq host-type (efs-add-host 'nos-ve host))) + + ;; We don't know. Scream and yell. + (t + (efs-scream-and-yell host user))) + + ;; Now that we have done a pwd, might as well put it in + ;; the expand-dir hashtable. + (if dir + (efs-put-hash-entry + key + (efs-internal-directory-file-name + (efs-fix-path host-type dir 'reverse)) + efs-expand-dir-hashtable + (memq host-type efs-case-insensitive-host-types)))) + + ;; host-type has been identified by regexp, set the mode-line. + (efs-set-process-host-type host user) + + ;; Some special cases, where we need to store the cwd on login. + (if (not (efs-hash-entry-exists-p + key efs-expand-dir-hashtable)) + (cond + ;; CMS: We will be doing cd's, so we'd better make sure that + ;; we know where home is. + ((eq host-type 'cms) + (let* ((res (efs-send-pwd 'cms host user)) + (dir (car res)) + (line (cdr res))) + (if (and dir (not (string-match + efs-cms-pwd-line-template line))) + (setq dir (concat "/" dir)) + (setq dir (concat "/" (if (> (length user) 8) + (substring user 0 8) + user) + ".191")) + (message + "Unable to determine a \"home\" CMS minidisk. Assuming %s" + dir)) + (efs-put-hash-entry + key dir efs-expand-dir-hashtable + (memq 'cms efs-case-insensitive-host-types)))) + ;; MVS: pwd doesn't work in the root directory, so we stuff this + ;; into the hashtable manually. + ((eq host-type 'mvs) + (efs-put-hash-entry key "/" efs-expand-dir-hashtable)) + )))))) + + +;;;; ----------------------------------------------------------- +;;;; efs-autoloads +;;;; These provide the entry points for the non-unix packages. +;;;; ----------------------------------------------------------- + +(efs-autoload 'efs-fix-path vms "efs-vms") +(efs-autoload 'efs-fix-path mts "efs-mts") +(efs-autoload 'efs-fix-path cms "efs-cms") +(efs-autoload 'efs-fix-path ti-explorer "efs-ti-explorer") +(efs-autoload 'efs-fix-path ti-twenex "efs-ti-twenex") +(efs-autoload 'efs-fix-path dos "efs-pc") +(efs-autoload 'efs-fix-path mvs "efs-mvs") +(efs-autoload 'efs-fix-path tops-20 "efs-tops-20") +(efs-autoload 'efs-fix-path mpe "efs-mpe") +(efs-autoload 'efs-fix-path os2 "efs-pc") +(efs-autoload 'efs-fix-path vos "efs-vos") +(efs-autoload 'efs-fix-path ms-unix "efs-ms-unix") +(efs-autoload 'efs-fix-path netware "efs-netware") +(efs-autoload 'efs-fix-path cms-knet "efs-cms-knet") +(efs-autoload 'efs-fix-path guardian "efs-guardian") +(efs-autoload 'efs-fix-path nos-ve "efs-nos-ve") + +(efs-autoload 'efs-fix-dir-path vms "efs-vms") +(efs-autoload 'efs-fix-dir-path mts "efs-mts") +(efs-autoload 'efs-fix-dir-path cms "efs-cms") +(efs-autoload 'efs-fix-dir-path ti-explorer "efs-ti-explorer") +(efs-autoload 'efs-fix-dir-path ti-twenex "efs-ti-twenex") +(efs-autoload 'efs-fix-dir-path dos "efs-pc") +(efs-autoload 'efs-fix-dir-path mvs "efs-mvs") +(efs-autoload 'efs-fix-dir-path tops-20 "efs-tops-20") +(efs-autoload 'efs-fix-dir-path mpe "efs-mpe") +(efs-autoload 'efs-fix-dir-path os2 "efs-pc") +(efs-autoload 'efs-fix-dir-path vos "efs-vos") +(efs-autoload 'efs-fix-dir-path hell "efs-hell") +(efs-autoload 'efs-fix-dir-path ms-unix "efs-ms-unix") +(efs-autoload 'efs-fix-dir-path netware "efs-netware") +(efs-autoload 'efs-fix-dir-path plan9 "efs-plan9") +(efs-autoload 'efs-fix-dir-path cms-knet "efs-cms-knet") +(efs-autoload 'efs-fix-dir-path guardian "efs-guardian") +(efs-autoload 'efs-fix-dir-path nos-ve "efs-nos-ve") +(efs-autoload 'efs-fix-dir-path coke "efs-coke") + +;; A few need to autoload a pwd function +(efs-autoload 'efs-send-pwd tops-20 "efs-tops-20") +(efs-autoload 'efs-send-pwd cms-knet "efs-cms-knet") +(efs-autoload 'efs-send-pwd ti-explorer "efs-ti-explorer") +(efs-autoload 'efs-send-pwd hell "efs-hell") +(efs-autoload 'efs-send-pwd mvs "efs-mvs") +(efs-autoload 'efs-send-pwd coke "efs-coke") + +;; A few packages are loaded by the listing parser. +(efs-autoload 'efs-parse-listing ka9q "efs-ka9q") +(efs-autoload 'efs-parse-listing unix:dl "efs-dl") +(efs-autoload 'efs-parse-listing dos-distinct "efs-dos-distinct") +(efs-autoload 'efs-parse-listing hell "efs-hell") +(efs-autoload 'efs-parse-listing netware "efs-netware") + +;; Packages that need to autoload for child-lookup +(efs-autoload 'efs-allow-child-lookup plan9 "efs-plan9") +(efs-autoload 'efs-allow-child-lookup coke "efs-coke") + +;; Packages that need to autoload for file-exists-p and file-directory-p +(efs-autoload 'efs-internal-file-exists-p guardian "efs-guardian") +(efs-autoload 'efs-internal-file-directory-p guardian "efs-guardian") + + + +;;;; ============================================================ +;;;; >10 +;;;; Attaching onto the appropriate Emacs version +;;;; ============================================================ + +;;;; ------------------------------------------------------------------- +;;;; Connect to various hooks. +;;;; ------------------------------------------------------------------- + +(or (memq 'efs-set-buffer-mode find-file-hooks) + (setq find-file-hooks + (cons 'efs-set-buffer-mode find-file-hooks))) + +;;; We are using our own dired.el, so this doesn't depend on Emacs flavour. + +(if (featurep 'dired) + (require 'efs-dired) + (add-hook 'dired-load-hook (function + (lambda () + (require 'efs-dired))))) + +;;;; ------------------------------------------------------------ +;;;; Add to minor-mode-alist. +;;;; ------------------------------------------------------------ + +(or (assq 'efs-process-host-type minor-mode-alist) + (if (assq 'dired-sort-mode minor-mode-alist) + (let ((our-list + (nconc + (delq nil + (list (assq 'dired-sort-mode minor-mode-alist) + (assq 'dired-subdir-omit minor-mode-alist) + (assq 'dired-marker-stack minor-mode-alist))) + (list '(efs-process-host-type efs-process-host-type) + '(efs-dired-listing-type + efs-dired-listing-type-string)))) + (old-list (delq + (assq 'efs-process-host-type minor-mode-alist) + (delq + (assq 'efs-dired-listing-type minor-mode-alist) + minor-mode-alist)))) + (setq minor-mode-alist nil) + (while old-list + (or (assq (car (car old-list)) our-list) + (setq minor-mode-alist (nconc minor-mode-alist + (list (car old-list))))) + (setq old-list (cdr old-list))) + (setq minor-mode-alist (nconc our-list minor-mode-alist))) + (setq minor-mode-alist + (nconc + (list '(efs-process-host-type efs-process-host-type) + '(efs-dired-listing-type efs-dired-listing-type-string)) + minor-mode-alist)))) + +;;;; ------------------------------------------------------------ +;;;; File name handlers +;;;; ------------------------------------------------------------ + +(defun efs-file-handler-function (operation &rest args) + "Function to call special file handlers for remote files." + (let ((handler (get operation 'efs))) + (if handler + (apply handler args) + (let ((inhibit-file-name-handlers + (cons 'efs-file-handler-function + (and (eq inhibit-file-name-operation operation) + inhibit-file-name-handlers))) + (inhibit-file-name-operation operation)) + (apply operation args))))) + +(defun efs-sifn-handler-function (operation &rest args) + ;; Handler function for substitute-in-file-name + (if (eq operation 'substitute-in-file-name) + (apply 'efs-substitute-in-file-name args) + (let ((inhibit-file-name-handlers + (cons 'efs-sifn-handler-function + (and (eq operation inhibit-file-name-operation) + inhibit-file-name-handlers))) + (inhibit-file-name-operation operation)) + (apply operation args)))) + +;; Yes, this is what it looks like. I'm defining the handler to run our +;; version whenever there is an environment variable. + +(nconc file-name-handler-alist + (list + (cons "\\(^\\|[^$]\\)\\(\\$\\$\\)*\\$[{a-zA-Z0-9]" + 'efs-sifn-handler-function))) + +;;;; ------------------------------------------------------------ +;;;; Necessary overloads. +;;;; ------------------------------------------------------------ + +;;; The following functions are overloaded, instead of extended via +;;; the file-name-handler-alist. For various reasons, the +;;; file-name-handler-alist doesn't work for them. It would be nice if +;;; this list could be shortened in the future. + +;; File name exansion. It is not until _after_ a file name has been +;; expanded that it is reasonable to test it for a file name handler. +(efs-overwrite-fn "efs" 'expand-file-name) + +;; Loading lisp files. The problem with using the file-name-handler-alist +;; here is that we don't know what is to be handled, until after searching +;; the load-path. The solution is to change the C code for Fload. +;; A patch to do this has been written by Jay Adams . +(efs-overwrite-fn "efs" 'load) +(efs-overwrite-fn "efs" 'require) + +;;;; ------------------------------------------------------------ +;;;; Install the file handlers for efs-file-handler-function. +;;;; ------------------------------------------------------------ + +;; I/O +(put 'insert-file-contents 'efs 'efs-insert-file-contents) +(put 'write-region 'efs 'efs-write-region) +(put 'directory-files 'efs 'efs-directory-files) +(put 'list-directory 'efs 'efs-list-directory) +(put 'insert-directory 'efs 'efs-insert-directory) +(put 'recover-file 'efs 'efs-recover-file) +;; file properties +(put 'file-directory-p 'efs 'efs-file-directory-p) +(put 'file-writable-p 'efs 'efs-file-writable-p) +(put 'file-readable-p 'efs 'efs-file-readable-p) +(put 'file-executable-p 'efs 'efs-file-executable-p) +(put 'file-symlink-p 'efs 'efs-file-symlink-p) +(put 'file-attributes 'efs 'efs-file-attributes) +(put 'file-exists-p 'efs 'efs-file-exists-p) +(put 'file-accessible-directory-p 'efs 'efs-file-accessible-directory-p) +;; manipulating file names +(put 'file-name-directory 'efs 'efs-file-name-directory) +(put 'file-name-nondirectory 'efs 'efs-file-name-nondirectory) +(put 'file-name-as-directory 'efs 'efs-file-name-as-directory) +(put 'directory-file-name 'efs 'efs-directory-file-name) +(put 'abbreviate-file-name 'efs 'efs-abbreviate-file-name) +(put 'file-name-sans-versions 'efs 'efs-file-name-sans-versions) +(put 'unhandled-file-name-directory 'efs 'efs-unhandled-file-name-directory) +(put 'diff-latest-backup-file 'efs 'efs-diff-latest-backup-file) +(put 'file-truename 'efs 'efs-file-truename) +;; modtimes +(put 'verify-visited-file-modtime 'efs 'efs-verify-visited-file-modtime) +(put 'file-newer-than-file-p 'efs 'efs-file-newer-than-file-p) +(put 'set-visited-file-modtime 'efs 'efs-set-visited-file-modtime) +;; file modes +(put 'set-file-modes 'efs 'efs-set-file-modes) +(put 'file-modes 'efs 'efs-file-modes) +;; buffers +(put 'backup-buffer 'efs 'efs-backup-buffer) +(put 'get-file-buffer 'efs 'efs-get-file-buffer) +(put 'create-file-buffer 'efs 'efs-create-file-buffer) +;; creating and removing files +(put 'delete-file 'efs 'efs-delete-file) +(put 'copy-file 'efs 'efs-copy-file) +(put 'rename-file 'efs 'efs-rename-file) +(put 'file-local-copy 'efs 'efs-file-local-copy) +(put 'make-directory-internal 'efs 'efs-make-directory-internal) +(put 'delete-directory 'efs 'efs-delete-directory) +(put 'add-name-to-file 'efs 'efs-add-name-to-file) +(put 'make-symbolic-link 'efs 'efs-make-symbolic-link) +;; file name completion +(put 'file-name-completion 'efs 'efs-file-name-completion) +(put 'file-name-all-completions 'efs 'efs-file-name-all-completions) + +;;;; ------------------------------------------------------------ +;;;; Finally run any load-hooks. +;;;; ------------------------------------------------------------ + +(run-hooks 'efs-load-hook) + +;;; end of efs.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/emacs-19.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/emacs-19.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,484 @@ +;;;; Emacs 19 compatibility functions for use in Emacs 18. +;;;; Based on: $Id: emacs-19.el,v 1.1 1997/02/11 05:05:14 steve Exp $ +;;;; +;;;; Rewritten by sandy@ibm550.sissa.it after gnu emacs 19 was +;;;; released to make it closer to V19. +;;;; Last modified: Sun Jun 12 00:06:06 1994 by sandy on ibm550 + +;;; 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 1, 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. +;;; +;;; A copy of the GNU General Public License can be obtained from this +;;; program's author (send electronic mail to roland@ai.mit.edu) or from +;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA +;;; 02139, USA. + +;; These functions are used in dired.el, but are also of general +;; interest, so you may want to add this to your .emacs: +;; +;; (autoload 'make-directory "emacs-19" "Make a directory." t) +;; (autoload 'delete-directory "emacs-19" "Remove a directory." t) +;; (autoload 'member "emacs-19" "Like memq, but uses `equal' instead of `eq'.") +;; (autoload 'compiled-function-p "emacs-19" "Emacs 18 doesn't have these.") + +(provide 'emacs-19) + +;;; Variables + +(defvar insert-directory-program "ls" + "Absolute or relative name of the `ls' program used by `insert-directory'.") + +(defvar bv-length) ; make the byte compiler a happy camper + +(defconst directory-abbrev-alist + nil + "*Alist of abbreviations for file directories. +A list of elements of the form (FROM . TO), each meaning to replace +FROM with TO when it appears in a directory name. This replacement is +done when setting up the default directory of a newly visited file. +*Every* FROM string should start with `^'. + +Use this feature when you have directories which you normally refer to +via absolute symbolic links. Make TO the name of the link, and FROM +the name it is linked to.") + +(defconst automount-dir-prefix "^/tmp_mnt/" + "Regexp to match the automounter prefix in a directory name.") + +(defvar abbreviated-home-dir nil + "The the user's homedir abbreviated according to `directory-abbrev-list'.") + +;;; Autoloads + +(autoload 'diff "diff" "Diff two files." t) +(autoload 'diff-backup "diff" "Diff a file with its most recent backup.") + +;;; Functions which are subroutines in Emacs 19. + +;; Provide a non-working version of find-file-name-handler. +;; If you want it to work, require 'fn-handler. + +(or (fboundp 'find-file-name-handler) (fset 'find-file-name-handler 'ignore)) +(or (boundp 'file-name-handler-alist) (defvar file-name-handler-alist nil)) + +;; The name of buffer-flush-undo has changed in V19. +(fset 'buffer-disable-undo 'buffer-flush-undo) + +(defun current-time () + "Returns the number of seconds since midnight. +A poor man's version of the the function `current-time' in emacs 19." + (let ((string (current-time-string))) + (list + 0 + (+ (* 3600 (string-to-int (substring string 11 13))) + (* 60 (string-to-int (substring string 14 16))) + (string-to-int (substring string 17 19))) + 0))) + +;; call-process below may lose if filename starts with a `-', but I +;; fear not all mkdir or rmdir implementations understand `--'. + +(defun delete-directory (fn) + "Delete a directory. +This is a subr in Emacs 19." + (interactive + (list (read-file-name "Delete directory: " nil nil 'confirm))) + (setq fn (expand-file-name fn)) + (if (file-directory-p fn) + (call-process "rmdir" nil nil nil fn) + (error "Not a directory: %s" fn)) + (if (file-exists-p fn) + (error "Could not remove directory %s" fn))) + +(defun make-directory (dir &optional parents) + "Create the directory DIR and any nonexistent parent dirs." + (interactive "FMake directory: \nP") + (if (not parents) + (make-directory-internal dir) + (let ((dir (directory-file-name (expand-file-name dir))) + create-list) + (while (not (file-exists-p dir)) + (setq create-list (cons dir create-list) + dir (directory-file-name (file-name-directory dir)))) + (while create-list + (make-directory-internal (car create-list)) + (setq create-list (cdr create-list)))))) + +(defun make-directory-internal (fn) + ;; This is a subroutine in emacs 19. + (let* ((fn (expand-file-name fn)) + (handler (find-file-name-handler fn 'make-directory-internal))) + (if handler + (funcall handler 'make-directory-internal fn) + (setq fn (directory-file-name fn)) + (if (file-exists-p fn) + (error "Cannot make directory %s: file already exists" fn) + (call-process "mkdir" nil nil nil fn)) + (or (file-directory-p fn) + (error "Could not make directory %s" fn))))) + +(defun kill-new (string) + "Save STRING as if killed in a buffer." + (setq kill-ring (cons string kill-ring)) + (if (> (length kill-ring) kill-ring-max) + (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil)) + (setq kill-ring-yank-pointer kill-ring)) + +(defun insert-directory (file switches &optional wildcard full-directory-p) + "Insert directory listing for FILE, formatted according to SWITCHES. +Leaves point after the inserted text. +SWITCHES may be a string of options, or a list of strings. +Optional third arg WILDCARD means treat FILE as shell wildcard. +Optional fourth arg FULL-DIRECTORY-P means file is a directory and +switches do not contain `d', so that a full listing is expected. + +This works by running a directory listing program +whose name is in the variable `insert-directory-program'. +If WILDCARD, it also runs the shell specified by `shell-file-name'." + ;; We need the directory in order to find the right handler. + (let ((handler (find-file-name-handler (expand-file-name file) + 'insert-directory))) + (if handler + (funcall handler 'insert-directory file switches + wildcard full-directory-p) + (if (eq system-type 'vax-vms) + (vms-read-directory file switches (current-buffer)) + (if wildcard + ;; Run ls in the directory of the file pattern we asked for. + (let ((default-directory + (if (file-name-absolute-p file) + (file-name-directory file) + (file-name-directory (expand-file-name file)))) + (pattern (file-name-nondirectory file)) + (beg 0)) + ;; Quote some characters that have special meanings in shells; + ;; but don't quote the wildcards--we want them to be special. + ;; We also currently don't quote the quoting characters + ;; in case people want to use them explicitly to quote + ;; wildcard characters. + (while (string-match "[ \t\n;<>&|()#$]" pattern beg) + (setq pattern + (concat (substring pattern 0 (match-beginning 0)) + "\\" + (substring pattern (match-beginning 0))) + beg (1+ (match-end 0)))) + (call-process shell-file-name nil t nil + "-c" (concat insert-directory-program + " -d " + (if (stringp switches) + switches + (mapconcat 'identity switches " ")) + " " + pattern))) + ;; SunOS 4.1.3, SVr4 and others need the "." to list the + ;; directory if FILE is a symbolic link. + (apply 'call-process + insert-directory-program nil t nil + (let (list) + (if (listp switches) + (setq list switches) + (if (not (equal switches "")) + (progn + ;; Split the switches at any spaces + ;; so we can pass separate options as separate args. + (while (string-match " " switches) + (setq list (cons (substring switches 0 + (match-beginning 0)) + list) + switches (substring switches + (match-end 0)))) + (setq list (cons switches list))))) + (append list + (list + (if full-directory-p + (concat (file-name-as-directory file) ".") + file)))))))))) + +(defun file-local-copy (file) + "Copy the file FILE into a temporary file on this machine. +Returns the name of the local copy, or nil, if FILE is directly +accessible." + (let* ((file (expand-file-name file)) + (handler (find-file-name-handler file 'file-local-copy))) + ;; Does nothing, if no handler. + (if handler + (funcall handler 'file-local-copy file)))) + +(defun file-truename (filename) + "Return the truename of FILENAME, which should be absolute. +The truename of a file name is found by chasing symbolic links +both at the level of the file and at the level of the directories +containing it, until no links are left at any level." + (if (or (string= filename "~") + (and (string= (substring filename 0 1) "~") + (string-match "~[^/]*" filename))) + (progn + (setq filename (expand-file-name filename)) + (if (string= filename "") + (setq filename "/")))) + (let ((handler (find-file-name-handler filename 'file-truename))) + ;; For file name that has a special handler, call handler. + ;; This is so that ange-ftp can save time by doing a no-op. + (if handler + (funcall handler 'file-truename filename) + (let ((dir (file-name-directory filename)) + target dirfile file-name-handler-alist) + ;; Get the truename of the directory. + (setq dirfile (directory-file-name dir)) + ;; If these are equal, we have the (or a) root directory. + (or (string= dir dirfile) + (setq dir (file-name-as-directory (file-truename dirfile)))) + (if (equal ".." (file-name-nondirectory filename)) + (directory-file-name (file-name-directory + (directory-file-name dir))) + (if (equal "." (file-name-nondirectory filename)) + (directory-file-name dir) + ;; Put it back on the file name. + (setq filename (concat dir (file-name-nondirectory filename))) + ;; Is the file name the name of a link? + (setq target (file-symlink-p filename)) + (if target + ;; Yes => chase that link, then start all over + ;; since the link may point to a directory name that uses links. + ;; We can't safely use expand-file-name here + ;; since target might look like foo/../bar where foo + ;; is itself a link. Instead, we handle . and .. above. + (if (file-name-absolute-p target) + (file-truename target) + (file-truename (concat dir target))) + ;; No, we are done! + filename))))))) + +(defun generate-new-buffer-name (name) + "Return a string which is the name of no existing buffer based on +NAME. If there is no live buffer named NAME, return NAME. Otherwise, +modify name by appending `', incrementing NUMBER until an +unused name is found. Return that name." + (if (get-buffer name) + (let ((num 2) + attempt) + (while (progn + (setq attempt (concat name "<" (int-to-string num) ">")) + (get-buffer attempt)) + (setq num (1+ num))) + attempt) + name)) + +(defun abbreviate-file-name (filename) + "Return a version of FILENAME shortened using `directory-abbrev-alist'. +This also substitutes \"~\" for the user's home directory. +Type \\[describe-variable] directory-abbrev-alist RET for more information." + ;; Get rid of the prefixes added by the automounter. + (if (and (string-match automount-dir-prefix filename) + (file-exists-p (file-name-directory + (substring filename (1- (match-end 0)))))) + (setq filename (substring filename (1- (match-end 0))))) + (let ((tail directory-abbrev-alist)) + ;; If any elt of directory-abbrev-alist matches this name, + ;; abbreviate accordingly. + (while tail + (if (string-match (car (car tail)) filename) + (setq filename + (concat (cdr (car tail)) (substring filename (match-end 0))))) + (setq tail (cdr tail))) + ;; Compute and save the abbreviated homedir name. + ;; We defer computing this until the first time it's needed, to + ;; give time for directory-abbrev-alist to be set properly. + (or abbreviated-home-dir + (setq abbreviated-home-dir + (let ((abbreviated-home-dir "$foo")) + (concat "^" (abbreviate-file-name (expand-file-name "~")))))) + ;; If FILENAME starts with the abbreviated homedir, + ;; make it start with `~' instead. + (if (string-match abbreviated-home-dir filename) + (setq filename + (concat "~" + ;; If abbreviated-home-dir ends with a slash, + ;; don't remove the corresponding slash from + ;; filename. On MS-DOS and OS/2, you can have + ;; home directories like "g:/", in which it is + ;; important not to remove the slash. And what + ;; about poor root on Unix systems? + (if (eq ?/ (aref abbreviated-home-dir + (1- (length abbreviated-home-dir)))) + "/" + "") + (substring filename (match-end 0))))) + filename)) + +(defun file-newest-backup (filename) + "Return most recent backup file for FILENAME or nil if no backups exist." + (let* ((filename (expand-file-name filename)) + (file (file-name-nondirectory filename)) + (dir (file-name-directory filename)) + (comp (file-name-all-completions file dir)) + newest) + (while comp + (setq file (concat dir (car comp)) + comp (cdr comp)) + (if (and (backup-file-name-p file) + (or (null newest) (file-newer-than-file-p file newest))) + (setq newest file))) + newest)) + +;; This is used in various files. +;; The usage of bv-length is not very clean, +;; but I can't see a good alternative, +;; so as of now I am leaving it alone. +(defun backup-extract-version (fn) + "Given the name of a numeric backup file, return the backup number. +Uses the free variable `bv-length', whose value should be +the index in the name where the version number begins." + (if (and (string-match "[0-9]+~$" fn bv-length) + (= (match-beginning 0) bv-length)) + (string-to-int (substring fn bv-length -1)) + 0)) + +;; The standard V18 version of this function doesn't support +;; the arg KEEP-BACKUP-VERSION +(defun file-name-sans-versions (name &optional keep-backup-version) + "Return FILENAME sans backup versions or strings. +This is a separate procedure so your site-init or startup file can +redefine it. +If the optional argument KEEP-BACKUP-VERSION is non-nil, +we do not remove backup version numbers, only true file version numbers." + (let ((handler (find-file-name-handler name 'file-name-sans-versions))) + (if handler + (funcall handler 'file-name-sans-versions name keep-backup-version) + (substring name 0 + (if (eq system-type 'vax-vms) + ;; VMS version number is (a) semicolon, optional + ;; sign, zero or more digits or (b) period, option + ;; sign, zero or more digits, provided this is the + ;; second period encountered outside of the + ;; device/directory part of the file name. + (or (string-match ";[-+]?[0-9]*\\'" name) + (if (string-match "\\.[^]>:]*\\(\\.[-+]?[0-9]*\\)\\'" + name) + (match-beginning 1)) + (length name)) + (if keep-backup-version + (length name) + (or (string-match "\\.~[0-9]+~\\'" name) + (string-match "~\\'" name) + (length name)))))))) + +(defun member (x y) + "Like memq, but uses `equal' for comparison. +This is a subr in Emacs 19." + (while (and y (not (equal x (car y)))) + (setq y (cdr y))) + y) + +(defun compiled-function-p (x) + "Emacs 18 doesn't have these." + nil) + +;; punt -- this will at least allow handlers to work for this. +(defun set-visited-file-modtime (&optional time) + (error "set-visited-file-modtime not defined in emacs 18.")) + +(defun add-hook (hook function &optional append) + "Add to the value of HOOK the function FUNCTION. +FUNCTION is not added if already present. +FUNCTION is added (if necessary) at the beginning of the hook list +unless the optional argument APPEND is non-nil, in which case +FUNCTION is added at the end. + +HOOK should be a symbol, and FUNCTION may be any valid function. If +HOOK is void, it is first set to nil. If HOOK's value is a single +function, it is changed to a list of functions." + (or (boundp hook) (set hook nil)) + ;; If the hook value is a single function, turn it into a list. + (let ((old (symbol-value hook))) + (if (or (not (listp old)) (eq (car old) 'lambda)) + (set hook (list old)))) + (or (if (consp function) + ;; Clever way to tell whether a given lambda-expression + ;; is equal to anything in the hook. + (let ((tail (assoc (cdr function) (symbol-value hook)))) + (equal function tail)) + (memq function (symbol-value hook))) + (set hook + (if append + (nconc (symbol-value hook) (list function)) + (cons function (symbol-value hook)))))) + +;;; after-save.el (Now part of files.el in Gnu Emacs V19) + +;;; Copyright (C) 1990 Roland McGrath +;;; + +(or (fboundp 'real-save-buffer) + (fset 'real-save-buffer (symbol-function 'save-buffer))) + +(defvar after-save-hook nil + "A function or list of functions to be run after saving the current buffer.") + +(defun save-buffer (&optional args) + "Save the current buffer, and then run `after-save-buffer-hook'. +The hooks are only run if the buffer was actually written. +For more documentation, do \\[describe-function] real-save-buffer RET." + (interactive "p") + (let ((modp (buffer-modified-p))) + (real-save-buffer args) + (if modp + (run-hooks 'after-save-hook)))) + +;;; end of after-save + +;;;; +;;;; Correcting for V18 bugs, and hacking around stupidities. +;;;; + +;; The 18.57 version has a bug that causes C-x C-v RET (which usually +;; re-visits the current buffer) to fail on dired buffers. +;; Only the last statement was changed to avoid killing the current +;; buffer. +(defun find-alternate-file (filename) + "Find file FILENAME, select its buffer, kill previous buffer. +If the current buffer now contains an empty file that you just visited +\(presumably by mistake), use this command to visit the file you really want." + (interactive "FFind alternate file: ") + (and (buffer-modified-p) + (not buffer-read-only) + (not (yes-or-no-p (format "Buffer %s is modified; kill anyway? " + (buffer-name)))) + (error "Aborted")) + (let ((obuf (current-buffer)) + (ofile buffer-file-name) + (oname (buffer-name))) + (rename-buffer " **lose**") + (setq buffer-file-name nil) + (unwind-protect + (progn + (unlock-buffer) + (find-file filename)) + (cond ((eq obuf (current-buffer)) + (setq buffer-file-name ofile) + (lock-buffer) + (rename-buffer oname)))) + (or (eq (current-buffer) obuf) + (kill-buffer obuf)))) + +;; At least in Emacs 18.55 this defvar has been forgotten to be copied +;; from lpr.el into loaddefs.el + +(defvar lpr-command (if (eq system-type 'usg-unix-v) + "lp" "lpr") + "Shell command for printing a file") + + +;; buffer-disable-undo used to be called buffer-flush-undo in Emacs +;; 18.55: +(or (fboundp 'buffer-disable-undo) + (fset 'buffer-disable-undo 'buffer-flush-undo)) + +;;; end of emacs-19.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/fixup.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/fixup.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,38 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: fixup.el +;; Release: $efs release: 1.15 $ +;; Version: $Revision: 1.1 $ +;; RCS: +;; Description: Fix up the load path for batch byte compilation of efs. +;; Author: Andy Norman, Dawn +;; Created: Sat Jan 30 00:21:33 1993 +;; Modified: Fri Sep 16 20:01:50 1994 by sandy on ibm550 +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(setq load-path + (append (list (substitute-in-file-name "$CWD") + (substitute-in-file-name "$BDIR") + (substitute-in-file-name "$VMDIR") + ) + load-path)) + +(setq byte-compile-warnings t) + +;; If the V18 btye-compiler is being used, this won't be around, so don't +;; complain if we can't find it. +(load "bytecomp-runtime" t t) + +(load "bytecomp" nil t) + +;; It seems efs causes the standard byte compiler some grief here. +(setq max-lisp-eval-depth (* 2 max-lisp-eval-depth)) + +;; If the user has the standard dired loaded, having dired +;; featurep will cause efs-dired.el to attempt to do overloads. +(delq 'dired features) + +;;; end of fixup.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/efs/fn-handler.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/efs/fn-handler.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,656 @@ +;; -*-Emacs-Lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; File: fn-handler.el +;; Description: enhanced file-name-handler-alist support for pre-19.23 Emacs +;; Author: Sandy Rutherford +;; Created: Sat Mar 19 00:50:10 1994 by sandy on ibm550 +;; Modified: Tue Sep 13 20:59:19 1994 by sandy on ibm550 +;; Language: Emacs-Lisp +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;; One of the problems with the file-name-handler-alist, is that when +;;; a handler gets called, and it has nothing to do for that function, +;;; the usual procedure is to remove the handler from the alist, and +;;; re-call the function. This is necessary to avoid an infinite +;;; recursion. However, if the function calling +;;; find-file-name-handler is not a primitive, there may be other lisp +;;; functions inside of it for which the handler does have some +;;; special actions specified. They won't run, because the let-bound +;;; value of file-name-handler-alist doesn't contain the handler. +;;; +;;; This problem was solved in Emacs 19.23 with the variables +;;; inhibit-file-name-handlers and inhibit-file-name-operation +;;; This file provides this solution to older versions of emacs. + + +(provide 'fn-handler) +(require 'efs-ovwrt) + +(or (boundp 'file-name-handler-alist) + (defvar file-name-handler-alist nil + "Association list of regexps for special file names and handlers.")) + +(defvar inhibit-file-name-handlers nil + "List of handlers \(symbols\) to be avoided by `find-file-name-handler'.") + +(defvar inhibit-file-name-operation nil + "Defines to which operation `inhibit-file-name-handlers applies' +Must be a synbol.") + +(defun find-file-name-handler (filename &optional operation) + "Return FILENAME1's handler function, if its syntax is handled specially. +Does not return handlers in `inhibit-file-name-handlers' list. +If there is no handler for FILENAME1, searches for one for FILENAME2. +Returns nil, if there is no handler for either file name. +A file name is handles specially if one of the regular expressions in +`file-name-handler-alist' matches it." + (let ((match-data (match-data))) + (unwind-protect + (catch 'handler + (mapcar (function + (lambda (x) + (and + (not + (and + (or (null operation) + (eq operation inhibit-file-name-operation)) + (memq (cdr x) inhibit-file-name-handlers))) + (string-match (car x) filename) + (throw 'handler (cdr x))))) + file-name-handler-alist) + nil) + (store-match-data match-data)))) + +;;; Overloads to supply the file-name-handler-alist + +(defun fn-handler-insert-file-contents (filename &optional visit &rest args) + "Documented as original." + (let* ((filename (expand-file-name filename)) + (handler (find-file-name-handler filename 'insert-file-contents))) + (if handler + (apply handler 'insert-file-contents filename visit args) + (let (file-name-handler-alist) + (apply 'fn-handler-real-insert-file-contents filename visit args))))) + +(efs-overwrite-fn "fn-handler" 'insert-file-contents + 'fn-handler-insert-file-contents) + +(defun fn-handler-directory-files (directory &optional full match &rest nosort) + "Documented as original." + (let ((handler (find-file-name-handler directory 'directory-files))) + (if handler + (apply handler 'directory-files directory full match nosort) + (let (file-name-handler-alist) + (apply 'fn-handler-real-directory-files + directory full match nosort))))) + +(efs-overwrite-fn "fn-handler" 'directory-files 'fn-handler-directory-files) + +(defun fn-handler-list-directory (dirname &optional verbose) + "Documented as original." + (interactive (let ((pfx current-prefix-arg)) + (list (read-file-name (if pfx "List directory (verbose): " + "List directory (brief): ") + nil default-directory nil) + pfx))) + (let ((handler (find-file-name-handler dirname 'list-directory))) + (if handler + (funcall handler 'list-directory dirname verbose) + (let (file-name-handler-alist) + (fn-handler-real-list-directory dirname verbose))))) + +(efs-overwrite-fn "fn-handler" 'list-directory 'fn-handler-list-directory) + +(defun fn-handler-file-directory-p (filename) + "Documented as original." + (let* ((filename (expand-file-name filename)) + (handler (find-file-name-handler filename 'file-directory-p))) + (if handler + (funcall handler 'file-directory-p filename) + (let (file-name-handler-alist) + (fn-handler-real-file-directory-p filename))))) + +(efs-overwrite-fn "fn-handler" ' file-directory-p 'fn-handler-file-directory-p) + +(defun fn-handler-file-writable-p (filename) + "Documented as original." + (let* ((filename (expand-file-name filename)) + (handler (find-file-name-handler filename 'file-writable-p))) + (if handler + (funcall handler 'file-writable-p filename) + (let (file-name-handler-alist) + (fn-handler-real-file-writable-p filename))))) + +(efs-overwrite-fn "fn-handler" 'file-writable-p 'fn-handler-file-writable-p) + +(defun fn-handler-file-readable-p (filename) + "Documented as original." + (let* ((filename (expand-file-name filename)) + (handler (find-file-name-handler filename 'file-readable-p))) + (if handler + (funcall handler 'file-readable-p filename) + (let (file-name-handler-alist) + (fn-handler-real-file-readable-p filename))))) + +(efs-overwrite-fn "fn-handler" 'file-readable-p 'fn-handler-file-readable-p) + +(defun fn-handler-file-symlink-p (filename) + "Documented as original." + (let* ((filename (expand-file-name filename)) + (handler (find-file-name-handler filename 'file-symlink-p))) + (if handler + (funcall handler 'file-symlink-p filename) + (let (file-name-handler-alist) + (fn-handler-real-file-symlink-p filename))))) + +(efs-overwrite-fn "fn-handler" 'file-symlink-p 'fn-handler-file-symlink-p) + +(defun fn-handler-delete-file (file) + "Documented as original" + (interactive (list (read-file-name "Delete-file: " nil nil t))) + (let* ((file (expand-file-name file)) + (handler (find-file-name-handler file 'delete-file))) + (if handler + (funcall handler 'delete-file file) + (let (file-name-handler-alist) + (fn-handler-real-delete-file file))))) + +(efs-overwrite-fn "fn-handler" 'delete-file 'fn-handler-delete-file) + +(defun fn-handler-file-exists-p (filename) + "Documented as original" + (let* ((filename (expand-file-name filename)) + (handler (find-file-name-handler filename 'file-exists-p))) + (if handler + (funcall handler 'file-exists-p filename) + (let (file-name-handler-alist) + (fn-handler-real-file-exists-p filename))))) + +(efs-overwrite-fn "fn-handler" 'file-exists-p 'fn-handler-file-exists-p) + +(defun fn-handler-write-region (start end filename &optional append visit) + "Documented as original" + ;; Use read-file-name, rather then interactive spec, + ;; to make it easier to get decent initial contents in the minibuffer. + (interactive + (progn + (or (mark) (error "The mark is not set now.")) + (list (min (point) (mark)) + (max (point) (mark)) + (read-file-name "Write region to file: ")))) + (let* ((filename (expand-file-name filename)) + (handler (or (find-file-name-handler filename 'write-region) + (and (stringp visit) + (find-file-name-handler (expand-file-name visit) + 'write-region))))) + (if handler + (funcall handler 'write-region start end filename append visit) + (let (file-name-handler-alist) + (fn-handler-real-write-region start end filename append visit))))) + +(efs-overwrite-fn "fn-handler" 'write-region + 'fn-handler-write-region) + +(defun fn-handler-verify-visited-file-modtime (buffer) + "Documented as original" + (let* ((file (buffer-file-name buffer)) + (handler (and file (find-file-name-handler + file + 'verify-visited-file-modtime)))) + (if handler + (funcall handler 'verify-visited-file-modtime buffer) + (let (file-name-handler-alist) + (fn-handler-real-verify-visited-file-modtime buffer))))) + +(efs-overwrite-fn "fn-handler" 'verify-visited-file-modtime + 'fn-handler-verify-visited-file-modtime) + +(defun fn-handler-backup-buffer () + "Documented as original" + (let ((handler (and buffer-file-name + (find-file-name-handler buffer-file-name + 'backup-buffer)))) + (if handler + (funcall handler 'backup-buffer) + ;; Don't let-bind file-name-handler-alist to nil, as backup-buffer + ;; is a lisp function and I want handlers to be available inside it. + (fn-handler-real-backup-buffer)))) + +(efs-overwrite-fn "fn-handler" 'backup-buffer 'fn-handler-backup-buffer) + +(defun fn-handler-copy-file (filename newname &optional ok-if-already-exists + keep-date) + "Documented as original" + ;; handler for filename takes precedence over the handler for newname. + (interactive + (let* ((from (read-file-name "Copy file: " nil nil t)) + (to (read-file-name (format "Copy %s to: " (abbreviate-file-name + from))))) + (list from to 0 current-prefix-arg))) + (let* ((filename (expand-file-name filename)) + (newname (expand-file-name newname)) + (handler (or (find-file-name-handler filename 'copy-file) + (find-file-name-handler newname 'copy-file)))) + (if handler + ;; Using the NOWAIT arg is a bit risky for other users of the + ;; handler-alist + (funcall handler 'copy-file filename newname ok-if-already-exists + keep-date) + (let (file-name-handler-alist) + (fn-handler-real-copy-file filename newname ok-if-already-exists + keep-date))))) + +(efs-overwrite-fn "fn-handler" 'copy-file 'fn-handler-copy-file) + +(defun fn-handler-file-newer-than-file-p (file1 file2) + "Documented as original" + ;; The handler for file2 takes precedence over the handler for file1. + (let* ((file1 (expand-file-name file1)) + (file2 (expand-file-name file2)) + (handler (or (find-file-name-handler file2 'file-newer-than-file-p) + (find-file-name-handler file1 'file-newer-than-file-p)))) + (if handler + (funcall handler 'file-newer-than-file-p file1 file2) + (let (file-name-handler-alist) + (fn-handler-real-file-newer-than-file-p file1 file2))))) + +(efs-overwrite-fn "fn-handler" 'file-newer-than-file-p + 'fn-handler-file-newer-than-file-p) + +(defun fn-handler-file-attributes (file) + "Documented as original" + (let* ((file (expand-file-name file)) + (handler (find-file-name-handler file 'file-attributes))) + (if handler + (funcall handler 'file-attributes file) + (let (file-name-handler-alist) + (fn-handler-real-file-attributes file))))) + +(efs-overwrite-fn "fn-handler" 'file-attributes 'fn-handler-file-attributes) + +(defun fn-handler-file-name-directory (file) + "Documented as original" + (let ((handler (find-file-name-handler file 'file-name-directory))) + (if handler + (funcall handler 'file-name-directory file) + (let (file-name-handler-alist) + (fn-handler-real-file-name-directory file))))) + +(efs-overwrite-fn "fn-handler" 'file-name-directory + 'fn-handler-file-name-directory) + +(defun fn-handler-rename-file (filename newname &optional ok-if-already-exists) + "Documented as original" + (interactive + (let* ((from (read-file-name "Rename file: " nil nil t)) + (to (read-file-name (format "Rename %s to: " (abbreviate-file-name + from))))) + (list from to 0))) + (let* ((filename (expand-file-name filename)) + (newname (expand-file-name newname)) + (handler (or (find-file-name-handler filename 'rename-file) + (find-file-name-handler newname 'rename-file)))) + (if handler + (funcall handler 'rename-file filename newname ok-if-already-exists) + (let (file-name-handler-alist) + (fn-handler-real-rename-file filename newname ok-if-already-exists))))) + +(efs-overwrite-fn "fn-handler" 'rename-file 'fn-handler-rename-file) + +(defun fn-handler-insert-directory (file switches + &optional wildcard full-directory-p) + "Documented as original" + (let* ((file (expand-file-name file)) + (handler (find-file-name-handler file 'insert-directory))) + (if handler + (funcall handler 'insert-directory file switches wildcard + full-directory-p) + (let (file-name-handler-alist) + (fn-handler-real-insert-directory file switches wildcard + full-directory-p))))) + +(efs-overwrite-fn "fn-handler" 'insert-directory 'fn-handler-insert-directory) + +(defun fn-handler-set-visited-file-modtime (&optional time) + "Sets the buffer's record of file modtime to the modtime of buffer-file-name. +With optional TIME, sets the modtime to TIME. This is an emacs 19 function. +In emacs 18, efs will make this work for remote files only." + (if buffer-file-name + (let ((handler (find-file-name-handler buffer-file-name + 'set-visited-file-modtime))) + (if handler + (funcall handler 'set-visited-file-modtime time) + (let (file-name-handler-alist) + (fn-handler-real-set-visited-file-modtime time)))))) + +(efs-overwrite-fn "fn-handler" 'set-visited-file-modtime + 'fn-handler-set-visited-file-modtime) + +(defun fn-handler-file-name-nondirectory (name) + "Documented as original" + (let ((handler (find-file-name-handler name 'file-name-nondirectory))) + (if handler + (funcall handler 'file-name-nondirectory name) + (let (file-name-handler-alist) + (fn-handler-real-file-name-nondirectory name))))) + +(efs-overwrite-fn "fn-handler" 'file-name-nondirectory + 'fn-handler-file-name-nondirectory) + +(defun fn-handler-file-name-as-directory (name) + "Documented as original" + (let ((handler (find-file-name-handler name 'file-name-as-directory))) + (if handler + (funcall handler 'file-name-as-directory name) + (let (file-name-handler-alist) + (fn-handler-real-file-name-as-directory name))))) + +(efs-overwrite-fn "fn-handler" 'file-name-as-directory + 'fn-handler-file-name-as-directory) + +(defun fn-handler-directory-file-name (directory) + "Documented as original" + (let ((handler (find-file-name-handler directory 'directory-file-name))) + (if handler + (funcall handler 'directory-file-name directory) + (let (file-name-handler-alist) + (fn-handler-real-directory-file-name directory))))) + +(efs-overwrite-fn "fn-handler" 'directory-file-name + 'fn-handler-directory-file-name) + +(defun fn-handler-get-file-buffer (file) + "Documented as original" + (let ((handler (find-file-name-handler file 'get-file-buffer))) + (if handler + (funcall handler 'get-file-buffer file) + (let (file-name-handler-alist) + (fn-handler-real-get-file-buffer file))))) + +(efs-overwrite-fn "fn-handler" 'get-file-buffer 'fn-handler-get-file-buffer) + +(defun fn-handler-create-file-buffer (file) + "Documented as original" + (let ((handler (find-file-name-handler file 'create-file-buffer))) + (if handler + (funcall handler 'create-file-buffer file) + (let (file-name-handler-alist) + (fn-handler-real-create-file-buffer file))))) + +(efs-overwrite-fn "fn-handler" 'create-file-buffer + 'fn-handler-create-file-buffer) + +(defun fn-handler-set-file-modes (file mode) + "Documented as original" + (let* ((file (expand-file-name file)) + (handler (find-file-name-handler file 'set-file-modes))) + (if handler + (funcall handler 'set-file-modes file mode) + (let (file-name-handler-alist) + (fn-handler-real-set-file-modes file mode))))) + +(efs-overwrite-fn "fn-handler" 'set-file-modes 'fn-handler-set-file-modes) + +(defun fn-handler-file-modes (file) + "Documented as original" + (let* ((file (expand-file-name file)) + (handler (find-file-name-handler file 'file-modes))) + (if handler + (funcall handler 'file-modes file) + (let (file-name-handler-alist) + (fn-handler-real-file-modes file))))) + +(efs-overwrite-fn "fn-handler" 'file-modes 'fn-handler-file-modes) + +(if (string-match emacs-version "Lucid") + + (progn + (defun fn-handler-abbreviate-file-name (filename &optional hack-homedir) + "Documented as original" + (let ((handler (find-file-name-handler filename + 'abbreviate-file-name))) + (if handler + (funcall handler 'abbreviate-file-name filename hack-homedir) + (let (file-name-handler-alist) + (fn-handler-real-abbreviate-file-name filename hack-homedir)))))) + + (defun fn-handler-abbreviate-file-name (filename) + "Documented as original" + (let ((handler (find-file-name-handler filename 'abbreviate-file-name))) + (if handler + (funcall handler 'abbreviate-file-name filename) + (let (file-name-handler-alist) + (fn-handler-real-abbreviate-file-name filename)))))) + +(efs-overwrite-fn "fn-handler" 'abbreviate-file-name + 'fn-handler-abbreviate-file-name) + +(defun fn-handler-file-name-sans-versions (filename + &optional keep-backup-version) + "Documented as original" + (let ((handler (find-file-name-handler filename 'file-name-sans-versions))) + (if handler + (funcall handler 'file-name-sans-versions filename + keep-backup-version) + (let (file-name-handler-alist) + (fn-handler-real-file-name-sans-versions filename + keep-backup-version))))) + +(efs-overwrite-fn "fn-handler" 'file-name-sans-versions + 'fn-handler-file-name-sans-versions) + +(if (fboundp 'make-directory-internal) ; not defined in lemacs 19.[67] + (progn + (defun fn-handler-make-directory-internal (dirname) + "Documented as original" + (let* ((dirname (expand-file-name dirname)) + (handler (find-file-name-handler dirname + 'make-directory-internal))) + (if handler + (funcall handler 'make-directory-internal dirname) + (let (file-name-handler-alist) + (fn-handler-real-make-directory-internal dirname))))) + + (efs-overwrite-fn "fn-handler" 'make-directory-internal + 'fn-handler-make-directory-internal))) + +(defun fn-handler-delete-directory (dirname) + "Documented as original" + (let* ((dirname (expand-file-name dirname)) + (handler (find-file-name-handler dirname 'delete-directory))) + (if handler + (funcall handler 'delete-directory dirname) + (let (file-name-handler-alist) + (fn-handler-real-delete-directory dirname))))) + +(efs-overwrite-fn "fn-handler" 'delete-directory 'fn-handler-delete-directory) + +(defun fn-handler-make-symbolic-link (target linkname + &optional ok-if-already-exists) + "Documented as original" + (interactive + (let (target) + (list + (setq target (read-string "Make symbolic link to file: ")) + (read-file-name (format "Make symbolic link to file %s: " target)) + 0))) + (let* ((linkname (expand-file-name linkname)) + (handler (or (find-file-name-handler linkname 'make-symbolic-link) + (find-file-name-handler target 'make-symbolic-link)))) + (if handler + (funcall handler 'make-symbolic-link + target linkname ok-if-already-exists) + (let (file-name-handler-alist) + (fn-handler-real-make-symbolic-link target linkname + ok-if-already-exists))))) + +(efs-overwrite-fn "fn-handler" 'make-symbolic-link + 'fn-handler-make-symbolic-link) + +(defun fn-handler-add-name-to-file (file newname &optional + ok-if-already-exists) + "Documented as original" + (interactive + (let (file) + (list + (setq file (read-file-name "Add name to file: " nil nil t)) + (read-file-name (format "Name to add to %s: " file)) + 0))) + (let* ((file (expand-file-name file)) + (newname (expand-file-name newname)) + (handler (or (find-file-name-handler newname 'add-name-to-file) + (find-file-name-handler file 'add-name-to-file)))) + (if handler + (funcall handler 'add-name-to-file file newname ok-if-already-exists) + (let (file-name-handler-alist) + (fn-handler-real-add-name-to-file file newname + ok-if-already-exists))))) + +(efs-overwrite-fn "fn-handler" 'add-name-to-file 'fn-handler-add-name-to-file) + +(defun fn-handler-recover-file (file) + "Documented as original" + (interactive "FRecover file: ") + (let* ((file (expand-file-name file)) + (handler (or (find-file-name-handler file 'recover-file) + (find-file-name-handler (let ((buffer-file-name file)) + (make-auto-save-file-name)) + 'recover-file)))) + (if handler + (funcall handler 'recover-file file) + (let (file-name-handler-alist) + (fn-handler-real-recover-file file))))) + +(efs-overwrite-fn "fn-handler" 'recover-file 'fn-handler-recover-file) + +(defun fn-handler-file-name-completion (file dir) + "Documented as original." + (let* ((dir (expand-file-name dir)) + (handler (find-file-name-handler dir 'file-name-completion))) + (if handler + (funcall handler 'file-name-completion file dir) + (let (file-name-handler-alist) + (fn-handler-real-file-name-completion file dir))))) + +(efs-overwrite-fn "fn-handler" 'file-name-completion + 'fn-handler-file-name-completion) + +(defun fn-handler-file-name-all-completions (file dir) + "Documented as original." + (let* ((dir (expand-file-name dir)) + (handler (find-file-name-handler dir 'file-name-all-completions))) + (if handler + (funcall handler 'file-name-all-completions file dir) + (let (file-name-handler-alist) + (fn-handler-real-file-name-all-completions file dir))))) + +(efs-overwrite-fn "fn-handler" 'file-name-all-completions + 'fn-handler-file-name-all-completions) + +(if (fboundp 'file-truename) + (progn + (defun fn-handler-file-truename (filename) + "Documented as original" + (let* ((fn (expand-file-name filename)) + (handler (find-file-name-handler filename 'file-truename))) + (if handler + (funcall handler 'file-truename filename) + (let (file-name-handler-alist) + (fn-handler-real-file-truename filename))))) + (efs-overwrite-fn "fn-handler" 'file-truename + 'fn-handler-file-truename))) + +(if (fboundp 'unhandled-file-name-directory) + (progn + (defun fn-handler-unhandled-file-name-directory (filename) + "Documented as original" + (let ((handler (find-file-name-handler + filename 'unhandled-file-name-directory))) + (if handler + (funcall handler 'unhandled-file-name-directory filename) + (let (file-name-handler-alist) + (fn-handler-real-unhandled-file-name-directory filename))))) + + (efs-overwrite-fn "fn-handler" 'unhandled-file-name-directory + 'fn-handler-unhandled-file-name-directory))) + + +;; We don't need the file-name-handler-alist for these. Inhibit it to +;; avoid an infinite recursion. Hope that this doesn't step +;; on any other packages' toes. +(defun fn-handler-expand-file-name (filename &optional default) + "Documented as original." + (let (file-name-handler-alist) + (fn-handler-real-expand-file-name filename default))) + +(efs-overwrite-fn "fn-handler" 'expand-file-name 'fn-handler-expand-file-name) + +(defun fn-handler-substitute-in-file-name (filename) + "Documented as original." + (let ((handler (find-file-name-handler filename 'substitute-in-file-name))) + (if handler + (funcall handler 'substitute-in-file-name filename) + (let (file-name-handler-alist) + (fn-handler-real-substitute-in-file-name filename))))) + +(efs-overwrite-fn "fn-handler" 'substitute-in-file-name + 'fn-handler-substitute-in-file-name) + +(if (fboundp 'file-executable-p) + (progn + (defun fn-handler-file-executable-p (file) + (let ((handler (find-file-name-handler file 'file-executable-p))) + (if handler + (funcall handler 'file-executable-p file) + (let (file-name-handler-alist) + (fn-handler-real-file-executable-p file))))) + (efs-overwrite-fn "fn-handler" 'file-executable-p + 'fn-handler-file-executable-p))) + +(if (fboundp 'file-accessible-directory-p) + (progn + (defun fn-handler-file-accessible-directory-p (file) + (let ((handler (find-file-name-handler file + 'file-accessible-directory-p))) + (if handler + (funcall handler 'file-accessible-directory-p file) + (let (file-name-handler-alist) + (fn-handler-real-file-accessible-directory-p file))))) + (efs-overwrite-fn "fn-handler" 'file-accessible-directory-p + 'fn-handler-file-accessible-directory-p))) + +(defun fn-handler-load (file &optional noerror nomessage nosuffix) + (let ((handler (find-file-name-handler file 'load))) + (if handler + (funcall handler 'load file noerror nomessage nosuffix) + (let (file-name-handler-alist) + (fn-handler-real-load file noerror nomessage nosuffix))))) + +(efs-overwrite-fn "fn-handler" 'load 'fn-handler-load) + +;; We don't need file-name-handlers for do-auto-save. +;; If it does try to access them there is a risk of an infinite recursion. +(defun fn-handler-do-auto-save (&rest args) + "Documented as original." + (let (file-name-handler-alist) + (apply 'fn-handler-real-do-auto-save args))) + +(efs-overwrite-fn "fn-handler" 'do-auto-save 'fn-handler-do-auto-save) + +(if (fboundp 'vc-registered) + (progn + (defun fn-handler-vc-registered (file) + "Documented as original." + (let ((handler (find-file-name-handler file 'vc-registered))) + (if handler + (funcall handler 'vc-registered file) + (let (file-name-handler-alist) + (fn-handler-real-vc-registered file))))) + + (efs-overwrite-fn "fn-handler" 'vc-registered + 'fn-handler-vc-registered))) + +;;; end of fn-handler.el diff -r b88636d63495 -r 8fc7fe29b841 lisp/eos/sun-eos-common.el --- a/lisp/eos/sun-eos-common.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/eos/sun-eos-common.el Mon Aug 13 08:50:29 2007 +0200 @@ -358,7 +358,7 @@ (graphics (eos::annotation-get-glyph type device-type)) (face (eos::annotation-get-face type device-type)) ) - (setq anot (make-annotation graphics (point) 'whitespace)) + (setq anot (make-annotation graphics (point) 'outside-margin)) (set-annotation-data anot uid) (set-extent-face anot face) (eos::add-to-annotation-list anot type) diff -r b88636d63495 -r 8fc7fe29b841 lisp/games/mine.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/games/mine.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,1190 @@ +;;; mine.el --- Mine game for GNU Emacs + +;; Author: Jacques Duthen +;; Keywords: games +;; Time-stamp: <97/01/20 14:37:36 duthen> +;; Version: 1.17 + +(defconst mine-version-number "1.17" "Emacs Mine version number.") +(defconst mine-version (format "Emacs Mine v%s by Jacques Duthen © 1997" + mine-version-number) + "Full Emacs Mine version number.") + +;; This file is not yet part of GNU Emacs. + +;; GNU Emacs 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 2, or (at your option) +;; any later version. + +;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; The object of this classical game is to locate the hidden mines. +;; To do this, you hit the squares on the game board that do not +;; contain mines, and you mark the squares that do contain mines. + +;; The number of hidden mines remaining in the mine field is indicated +;; inside the buffer. Every time you mark a square as a mine, this +;; number decreases by one, even if you incorrectly mark a square. + +;; To hit a square: Point to the square, and click the left button. +;; If the square is a mine, you loose. +;; If the square isn't a mine, a number appears, which represents +;; the number of mines in the surrounding eight squares. + +;; To mark a square as a mine: Point to the square, and click +;; the right button. + +;; To play Mine, compile it if you want, load it, and type `M-x mine'. + +;; To get help and doc, see the functions `mine' and `mine-help' +;; (ie. type `?' in the *Mine* buffer or type `C-h f mine') + +;; This module has been developed and tested with GNU Emacs 19.31.1, +;; but it should run with any GNU Emacs 19.* (at least with versions +;; superior to 19.31). + +;; This module has not been tested (yet) with XEmacs. It may or may +;; not run (can anybody tell me?). + +;; Send any comment or bug report (do you expect to find any? ;-) to me: +;; duthen@cegelec-red.fr (Jacques Duthen) + +;; Good luck. + +;; 1.17 Thanks to Vladimir Alexiev . +;; Fix bug: (void-function unless), add minimal support for xemacs. +;; (mine-xemacs-p): Added. +;; (event-point): New function. +;; (mine-mouse-hit, mine-mouse-mark): Use (interactive "@e") and `event-point' +;; (mine-init-mode-map): Support xemacs mouse binding. +;; (mine-make-face): Support xemacs get-face. +;; (mine-goto): Support `auto-show-make-point-visible' as well as +;; `hscroll-point-visible'. + +;; 1.16 Initial released version. + +;;; Code: + +(defvar mine-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version)) + +;;; ================================================================ +;;; User Variables: + +;;; -1- size + +;;; The mine field is a rectangle (mine-xmax x mine-ymax), which is +;;; duplicated to fill a bigger rectangle periodically tiled with the +;;; smaller one, the period being (mine-xmax x mine-ymax). + +(defvar mine-xmax 16 "*The logical width of the mine field.") +(defvar mine-ymax 24 "*The logical height of the mine field.") + +(defvar mine-mines-% 16 + "*Percentage (between 0 and 100) of mines in the mine field.") + +(defvar mine-torus 't + "*Non-nil (the default) to play the game on a periodic board (a torus).") + +(defvar mine-nb-tiles-x 2 + "*Number of duplications in the x direction, when `mine-torus' is non-nil. +Indicate the number of times the original mine field is duplicated +in the x direction. +It's better looking when it's an integer. +nil means fill exactly the whole window. +0 means fill the whole window with the biggest integer that fits. +a negative number means use exactly the opposite number. If it's +too big, the rows are truncated by emacs. Automatic horizontal +scrolling will occur if you move to an invisible point. +a positive float means limit to the window width if needed. +a positive integer means limit to the window width if needed, +with the biggest possible integer value anyway. +") + +(defvar mine-nb-tiles-y 2 + "*Number of duplications in the y direction, when `mine-torus' is non-nil. +Indicate the number of times the original mine field is duplicated +in the y direction. +It's better looking when it's an integer. +nil means fill exactly the whole window. +0 means fill the whole window with the biggest integer that fits. +a negative number means use exactly the opposite number. If it's +too big, the rows will be simply scrolled up or down by emacs. +a positive float means limit to the window height if needed. +a positive integer means limit to the window height if needed, +with the biggest possible integer value anyway. +") + +;;; -2- square characters + +;;; All these characters may be changed but the first three ones +;;; `unmarked' `marked' `zero' must differ from each other. + +(defvar mine-char-unmarked ?- + "*Character for a square not yet marked nor hit.") +(defvar mine-char-marked ?@ + "*Character for a square marked as containing a mine.") +(defvar mine-char-zero ?\ + "*Character for a square hit with no adjacent mine.") + +(defvar mine-char-pad ?\ + "*Character to pad in the x direction or nil (not yet implemented).") +(defvar mine-char-not-found ?o + "*Character for a square marked but with no mine.") +(defvar mine-char-bogus ?x + "*Character for a square not marked but with a mine.") + +;;; -3- colors + +(defvar mine-colorp (if window-system 't 'nil) + "*Non-nil means with colors. Nil means in black and white.") + +(defvar mine-colors nil + "*Set this variable to override the colors defined by +`mine-default-colors' (use the same format).") + +(defconst mine-default-colors + '((mine-face-unmarked . "LightBlue") + (mine-face-marked . "Red") + (0 . nil) + (1 . "Cyan") + (2 . "Green") + (3 . "Yellow") + (4 . "Orange") + (5 . "OrangeRed") + (6 . "Red") + (7 . "Red") + (8 . "Red") + (mine-face-pad . nil) + (mine-face-not-found . "Red") + (mine-face-bogus . "Red") + ) + "A-list of default colors for Mine faces. Don't change its value. +You can override these settings with `mine-colors' using the same format.") + +;;; -4- redisplay + +(defvar mine-level 2 + "*Redisplay speed. 0 is the slowest redisplay, 5 is the fastest one. +0 means redisplay when every single square changes. +1 means redisplay when one square and its periodic images change. +2 means redisplay every `mine-count1-max' change. +3 means redisplay every `mine-count1-max'*`mine-count2-max' change. +-1 or nil means redisplay only when all the changes are done. +") + +(defvar mine-count1-max 16 + "*See `mine-level'. +Redisplay when the number of empty squares which have changed +is greater than `mine-count1-max'. +8 means redisplay each time 8 squares have been changed. +-1 means redisplay only when all the changes are done.") + +(defvar mine-count2-max 4 + "*See `mine-level'. +Redisplay when the number of empty squares which have changed +is greater than `mine-count1-max'. +8 means redisplay each time 8 squares have been changed. +-1 means redisplay only when all the changes are done.") + +(defvar mine-hscroll-step 4 + "*Local value for `hscroll-step'") + +(defvar mine-mode-hook nil + "*Hook called by `mine-mode-hook'.") + +;;; ================================================================ +;;; Internal variables: + +(defvar mine-user-variables + '("Size" + mine-xmax mine-ymax mine-mines-% + mine-torus mine-nb-tiles-x mine-nb-tiles-y + "Square characters" + mine-char-unmarked mine-char-marked mine-char-zero + mine-char-pad mine-char-not-found mine-char-bogus + "Colors" + mine-colorp mine-colors + "Redisplay" + mine-level mine-count1-max mine-count2-max + "Scrolling" + mine-hscroll-step + "Hook" + mine-mode-hook)) + +(defvar mine-user-commands + '("Help" + mine mine-help mine-help-bindings mine-help-variables + "Mouse control" + mine-mouse-hit mine-mouse-mark + "Move" + mine-left mine-right mine-up mine-down + mine-bol mine-eol mine-top mine-bottom + "Hit and mark" + mine-hit-curpoint mine-mark-curpoint + "Quit" + mine-quit)) + +;; pad x factor == (if mine-char-pad 2 1) +(defvar mine-padx*) + +(defvar mine-width) +(defvar mine-height) + +;; (x y) of current point +(defvar mine-x) ;; 1 <= mine-x <= mine-width +(defvar mine-y) ;; 1 <= mine-y <= mine-height + +;; limits of the playable part of the board +(defvar mine-point-min) +(defvar mine-point-max) + +(defvar mine-point-remaining-mines) +(defvar mine-point-mines-hit) + +(defvar mine-mode-map nil) + +(defvar mine-real-mines) + +(defvar mine-nb-remaining-mines) +(defvar mine-nb-remaining-marks) +(defvar mine-nb-mines-hit) + +(defvar mine-faces) + +;;; This variable is more special rather than global. +(defvar mine-adjacent-points) + +(defvar mine-count1) +(defvar mine-count2) + +;;; ================================================================ +;;; Macros (stolen from "cl.el" (soon in "subr.el" (thanks to rms))) + +(eval-when-compile +(or (fboundp 'when) +(defmacro when (cond &rest body) + "(when COND BODY...): if COND yields non-nil, do BODY, else return nil." + (list 'if cond (cons 'progn body))))) + +;;; ================================================================ +;;; User commands + +;;;###autoload +(defun mine (num) + "Play Mine. Optional prefix argument is the number of mines. + +To play Mine, type `\\[mine]' or `\\[universal-argument] NUM \\[mine]'. + +An optional prefix argument specifies the number of mines to be hidden +in the field. If no prefix argument is given, a percentage +`mine-mines-%' of the field will contain mines. + +What is Mine?\\ + +Mine is a classical game of hide and seek played on a rectangular grid +containing `mine-xmax' by `mine-ymax' squares (the mine field). + +Your opponent (Emacs, in this case) has hidden several mines within +this field. The object of the game is to find every hidden mine. + +When you're sure a square does NOT contain a mine, you can hit it: +move the mouse over the square and press `\\[mine-mouse-hit]' or +move the cursor with the usual keys and press `\\[mine-hit-curpoint]'. + +If the square is a mine, you loose. +If the square isn't a mine, a number appears which represents +the number of mines in the surrounding eight squares. + +When you think a square DOES contain a mine, you can mark it: +move the mouse over the square and press `\\[mine-mouse-mark]' or +move the cursor with the usual keys and press `\\[mine-mark-curpoint]'. + +The number of hidden mines remaining in the mine field is indicated +inside the buffer. Every time you mark a square as a mine, this +number decreases by one, even if you incorrectly mark a square. + +If `mine-torus' is non-nil (the default), the Mine game is played over +a periodic field (like a torus). Each mine is hidden periodically +over the mine board `mine-nb-tiles-x' times in the x direction and +`mine-nb-tiles-y' times in the y direction. + +If `mine-colorp' is non-nil (the default, if the system allows it), +the game is displayed with colors. The colors can be chosen with the +variable `mine-colors'. + +If the redisplay is not fast enough, increase `mine-level'. If you +want to see a smoother (slower) redisplay, decrease `mine-level', +`mine-count1-max' and `mine-count2-max'. + +You can get help on `mine-mode' and its key bindings by pressing `\\[mine-help]' +while in the *Mine* buffer. +" + (interactive "P") + (switch-to-buffer "*Mine*") + (mine-mode) + (setq buffer-read-only 't) + (buffer-disable-undo (current-buffer)) + (setq mine-nb-remaining-mines + (or num (round (/ (* mine-xmax mine-ymax mine-mines-%) 100))) + mine-nb-remaining-marks mine-nb-remaining-mines) + (if (> mine-nb-remaining-mines (* mine-xmax mine-ymax)) + (error "Too many mines: %d" mine-nb-remaining-mines)) + (mine-init-faces) + (setq mine-real-mines (mine-init-mines mine-nb-remaining-mines)) + (setq mine-nb-mines-hit 0) + (mine-init-board) + (mine-reset-counters) + (mine-update-remaining-mines) + (setq hscroll-step mine-hscroll-step) + ;; initial position + (setq mine-x 1) + (setq mine-y 1) + (mine-goto mine-x mine-y) +) + +;; Mine mode is suitable only for specially formatted data. +(put 'mine-mode 'mode-class 'special) + +(defun mine-mode () + "Major mode for playing Mine. To learn how to play Mine, see `mine'. + +If you have a mouse, you can do:\\ + +`\\[mine-mouse-hit]' -- hit point +`\\[mine-mouse-mark]' -- mark or unmark a mine at point + +If you don't have a mouse, you can move the cursor over the mine +field with the usual mnemonic keys and: + +`\\[mine-hit-curpoint]' -- hit point +`\\[mine-mark-curpoint]' -- mark or unmark a mine at point + +`\\[mine-quit]' -- give up and see the hidden mines + +You can get help with: + +`\\[mine-help-variables]' -- get help on Mine variables +`\\[mine-help-bindings]' -- get help on Mine bindings + +\\{mine-mode-map} +" + (interactive) + (kill-all-local-variables) + (make-local-variable 'hscroll-step) + (use-local-map mine-mode-map) + (setq truncate-lines 't) + (setq major-mode 'mine-mode) + (setq mode-name "Mine") + (run-hooks 'mine-mode-hook) +) + +;;;###autoload +(defun mine-version () + "Return string describing the current version of Mine. +When called interactively, displays the version." + (interactive) + (if (interactive-p) + (message (mine-version)) + mine-version)) + +;;;###autoload +(defun mine-help () + "*Get help on `mine-mode'." + (interactive) + (save-excursion + (switch-to-buffer "*Mine*") + (mine-mode) + (describe-mode))) + +(defun mine-help-variables () + "*Get help on Mine variables." + (interactive) + (save-excursion + (switch-to-buffer "*Mine*") + (mine-mode) + (apropos-symbols mine-user-variables 't))) + +(defun mine-help-bindings () + "*Get help on Mine bindings." + (interactive) + (save-excursion + (switch-to-buffer "*Mine*") + (mine-mode) + (apropos-symbols mine-user-commands 't))) + +(defun mine-print-settings () + "*Print the current Mine settings (value of all the user variables)." + (interactive) + (with-output-to-temp-buffer "*scratch*" + (mine-print-variables mine-user-variables))) + +;;; ================================================================ +;;; Click events - nop hit mark + +;;; [jack] The elisp manual says: +;;; If you want to take action as soon as a button is pressed, +;;; you need to handle "button-down" events. +;;; The global map (cf. `mouse.el') has, by default, the binding: +;;; (define-key global-map [down-mouse-1] 'mouse-drag-region) +;;; It seems that this function "eats" the final event [mouse-1]. +;;; So, we need a local binding for [down-mouse-1] which shadows +;;; the global one and prevents `mouse-drag-region' from being called. +;;; Hence, in `mine-init-mode-map' I use the following binding: +;;; (define-key mine-mode-map [down-mouse-1] 'mine-mouse-nop) +;;; I found a better binding in "apropos.el" +;;; (define-key mine-mode-map [down-mouse-1] nil) +;;; but, as it does not work, let's go back to nop... + +(or (fboundp 'event-point) + (defun event-point (event) + (posn-point (event-end event)))) + +(defun mine-mouse-nop (event) + "Nop" + (interactive "e")) + +(defun mine-mouse-hit (event) + "Move point to the position clicked on with the mouse and hit this point." + (interactive "@e") + (if (mine-goto-point (event-point event)) + (mine-hit-curpoint) + (mine-message 'mine-msg-click-precisely))) + +(defun mine-mouse-mark (event) + "Move point to the position clicked on with the mouse and mark or unmark +this point." + (interactive "@e") + (if (mine-goto-point (event-point event)) + (mine-mark-curpoint) + (mine-message 'mine-msg-click-precisely))) + +;;; ================================================================ +;;; Key events - hit mark quit + +(defun mine-hit-curpoint () + "Hit point" + (interactive) + (mine-reset-counters) + (let ((c (following-char))) + (save-excursion + (cond + ((eq c mine-char-marked) + (mine-message 'mine-msg-unmark-before-hit)) + ((not (eq c mine-char-unmarked)) + (mine-message 'mine-msg-point-already-hit)) + ((mine-mine-at-point-p (point) 'slowp) + (setq mine-nb-mines-hit (1+ mine-nb-mines-hit)) + (mine-update-mines-hit) + (mine-message 'mine-msg-loose) + (mine-quit)) + (t ;; the real job... + (let* ((x.y (mine-top-left (mine-point-to-x.y (point)))) + (pxy (cons (point) x.y)) + (mine-adjacent-points (list pxy))) ; special variable + (while mine-adjacent-points + (setq pxy (car mine-adjacent-points) + mine-adjacent-points (cdr mine-adjacent-points)) + (mine-deep-hit pxy)))))))) + +(defun mine-mark-curpoint () + "Mark or unmark current position" + (interactive) + (mine-reset-counters) + (let ((c (following-char))) + (save-excursion + (cond + ((eq c mine-char-unmarked) + (mine-mark-board (point)) + (setq mine-nb-remaining-marks + (1- mine-nb-remaining-marks)) + (if (mine-mine-at-point-p (point) 'slowp) + (setq mine-nb-remaining-mines + (1- mine-nb-remaining-mines)))) + ((eq c mine-char-marked) + (mine-unmark-board (point)) + (setq mine-nb-remaining-marks + (1+ mine-nb-remaining-marks)) + (if (mine-mine-at-point-p (point) 'slowp) + (setq mine-nb-remaining-mines + (1+ mine-nb-remaining-mines)))) + (t + (mine-message 'mine-msg-cannot-mark))) + (mine-update-remaining-mines)))) + +(defun mine-quit () + "*Display hidden and bogus mines." + (interactive) + (when (y-or-n-p "Do you want to see the remaining and bogus mines? ") + (mine-show-bogus-mines))) + +(defun mine-show-bogus-mines () + (mine-reset-counters) + (let ((nrb 0) (nbb 0) + (x.y (cons nil nil)) + (y 1) x + point c) + (while (<= y mine-ymax) + (setq x 1) + (setcdr x.y y) + (while (<= x mine-xmax) + (setq point (mine-xy-to-point x y) + c (char-after point)) + (cond + ((eq c mine-char-unmarked) + (setcar x.y x) + (when (mine-mine-at-xy-p x.y) + (setq nrb (1+ nrb)) + (mine-update-board point mine-char-not-found 'mine-face-not-found))) + ((eq c mine-char-marked) + (setcar x.y x) + (when (not (mine-mine-at-xy-p x.y)) + (setq nbb (1+ nbb)) + (mine-update-board point mine-char-bogus 'mine-face-bogus)))) + (setq x (1+ x))) + (setq y (1+ y))) + (mine-update-bogus-mines nrb nbb))) + +;;; ================================================================ +;;; Key events - moves + +(defun mine-left () + "Move left" + (interactive) + (setq mine-x (1- mine-x)) + (when (<= mine-x 0) + (while (<= mine-x mine-width) + (setq mine-x (+ mine-x mine-xmax))) + (setq mine-x (- mine-x mine-xmax))) + (mine-goto mine-x mine-y)) + +(defun mine-right () + "Move right" + (interactive) + (setq mine-x (1+ mine-x)) + (when (> mine-x mine-width) + (while (>= mine-x 0) + (setq mine-x (- mine-x mine-xmax))) + (setq mine-x (+ mine-x mine-xmax))) + (mine-goto mine-x mine-y)) + +(defun mine-up () + "Move up" + (interactive) + (setq mine-y (1- mine-y)) + (when (<= mine-y 0) + (while (<= mine-y mine-height) + (setq mine-y (+ mine-y mine-ymax))) + (setq mine-y (- mine-y mine-ymax))) + (mine-goto mine-x mine-y)) + +(defun mine-down () + "Move down" + (interactive) + (setq mine-y (1+ mine-y)) + (when (> mine-y mine-height) + (while (>= mine-y 0) + (setq mine-y (- mine-y mine-ymax))) + (setq mine-y (+ mine-y mine-ymax))) + (mine-goto mine-x mine-y)) + + +(defun mine-bol () + "Move to the beginning of the row" + (interactive) + (setq mine-x 1) + (mine-goto mine-x mine-y)) + +(defun mine-eol () + "Move to the end of the row" + (interactive) + (setq mine-x mine-width) + (mine-goto mine-x mine-y)) + +(defun mine-top () + "Move to the top of the column" + (interactive) + (setq mine-y 1) + (mine-goto mine-x mine-y)) + +(defun mine-bottom () + "Move to the bottom of the column" + (interactive) + (setq mine-y mine-height) + (mine-goto mine-x mine-y)) + +;;; ================================================================ +;;; Internal model functions + +(defun mine-init-mines (num-mines) + (random t) + (let ((mines (list)) (n num-mines) x y x.y) + (while (> n 0) + (setq n (1- n) + x (1+ (random mine-xmax)) + y (1+ (random mine-ymax)) + x.y (cons x y)) + (while (mine-member x.y mines 'nil) + ;; replace by the point to the right (or next row if eol) + (if (< x mine-xmax) + (setcar x.y (setq x (1+ x))) + (setcar x.y (setq x 1)) + (setcdr x.y (setq y (if (< y mine-ymax) (1+ y) 1))))) + (setq mines (cons x.y mines))) + mines)) + +(defun mine-mine-at-point-p (point slowp) + (mine-member (mine-top-left (mine-point-to-x.y point)) + mine-real-mines slowp)) + +(defun mine-mine-at-xy-p (x.y) + (mine-member x.y mine-real-mines 'nil)) + +;;; Returns non-nil if ELT is an element of LIST. +;;; Constant time execution if slowp is non-nil. +(defun mine-member (x.y list slowp) + (let ((found 'nil)) + (while (and list (or slowp (not found))) + (if (equal x.y (car list)) + (setq found 't)) + (setq list (cdr list))) + found)) + +;;; ================================================================ +;;; Internal model & interface functions + +(defun mine-pxy (x y) + (cons (mine-xy-to-point x y) (cons x y))) + +;; pxy == (point . (x . y)) +;; with 1 <= {xy} <= mine-{xy}max +(defun mine-deep-hit (pxy) + (interactive) + (let (point x.y c) + (setq point (car pxy) + x.y (cdr pxy) + c (char-after point)) + (cond + ((eq c mine-char-marked)) ;; free but marked (user bug) + ((not (eq c mine-char-unmarked))) ;; already done + ((mine-mine-at-xy-p x.y) + (error "Internal error: mine-deep-hit mine at %s" point)) + (t ;; the real job... + (let* ((adjacent-points (mine-adjacent-points point x.y)) + (nb-adjacent-mines (mine-nb-adjacent-mines adjacent-points))) + (mine-display-nb-adjacent-mines point nb-adjacent-mines) + (when (zerop nb-adjacent-mines) + ;; Stack overflow: "Lisp nesting exceeds max-lisp-eval-depth" + ;;(mapc 'mine-deep-hit adjacent-points) + (setq mine-adjacent-points + (nconc adjacent-points mine-adjacent-points)))))))) + +;; return == ((point . (x . y))*) +;; with 1 <= {xy} <= mine-{xy}max +(defun mine-adjacent-points (point x.y) + (mine-random-permut + (if mine-torus + (mine-adjacent-points-on-torus point x.y) + (mine-adjacent-points-no-torus point x.y)))) + +(defun mine-random-permut (l) + (let ((ll (nthcdr (random (length l)) l))) + (nconc ll l) + (prog1 (cdr ll) (setcdr ll ())))) + +(defun mine-adjacent-points-no-torus (point x.y) + (let ((x (car x.y)) (y (cdr x.y)) (points (list)) xx yy) + ;; left column + (when (not (= x 1)) + (setq xx (1- x)) + (when (not (= y 1)) + (setq yy (1- y)) + (setq points (cons (mine-pxy xx yy) points))) + (setq points (cons (mine-pxy xx y) points)) + (when (not (= y mine-ymax)) + (setq yy (1+ y)) + (setq points (cons (mine-pxy xx yy) points)))) + ;; middle column + (setq xx x) + (when (not (= y 1)) + (setq yy (1- y)) + (setq points (cons (mine-pxy xx yy) points))) + (when (not (= y mine-ymax)) + (setq yy (1+ y)) + (setq points (cons (mine-pxy xx yy) points))) + ;; right column + (when (not (= x mine-xmax)) + (setq xx (1+ x)) + (when (not (= y 1)) + (setq yy (1- y)) + (setq points (cons (mine-pxy xx yy) points))) + (setq points (cons (mine-pxy xx y) points)) + (when (not (= y mine-ymax)) + (setq yy (1+ y)) + (setq points (cons (mine-pxy xx yy) points)))) + (nreverse points))) + +(defun mine-adjacent-points-on-torus (point x.y) + (let ((x (car x.y)) (y (cdr x.y)) (points (list)) xx yy) + ;; left column + (setq xx (if (= x 1) mine-xmax (1- x))) + (setq yy (if (= y 1) mine-ymax (1- y))) + (setq points (cons (mine-pxy xx yy) points)) + (setq points (cons (mine-pxy xx y) points)) + (setq yy (if (= y mine-ymax) 1 (1+ y))) + (setq points (cons (mine-pxy xx yy) points)) + ;; middle column + (setq xx x) + (setq yy (if (= y 1) mine-ymax (1- y))) + (setq points (cons (mine-pxy xx yy) points)) + (setq yy (if (= y mine-ymax) 1 (1+ y))) + (setq points (cons (mine-pxy xx yy) points)) + ;; right column + (setq xx (if (= x mine-xmax) 1 (1+ x))) + (setq yy (if (= y 1) mine-ymax (1- y))) + (setq points (cons (mine-pxy xx yy) points)) + (setq points (cons (mine-pxy xx y) points)) + (setq yy (if (= y mine-ymax) 1 (1+ y))) + (setq points (cons (mine-pxy xx yy) points)) + (nreverse points))) + +;; l == ((p . (x . y))*) +(defun mine-nb-adjacent-mines (l) + (let ((nb 0) pxy x.y) + (while l + (setq pxy (car l) l (cdr l) x.y (cdr pxy)) + (if (mine-mine-at-xy-p x.y) + (setq nb (1+ nb)))) + nb)) + +;;; ================================================================ +;;; Mode map + +(defun mine-init-mode-map () + (let ((map (make-keymap)) (gm global-map)) + ;; All normally self-inserting keys (except digits) are undefined + (suppress-keymap map 'nil) + ;; Help + (define-key map "?" 'mine-help) + (define-key map "h" 'mine-help) + (define-key map "b" 'mine-help-bindings) + (define-key map "v" 'mine-help-variables) + (cond + (mine-xemacs-p + ;; Mouse control + (define-key map [mouse-1] 'mine-mouse-hit) + (define-key map [mouse-3] 'mine-mouse-mark) + ;; Mouse control to prevent problems + (define-key map [mouse-2] 'mine-mouse-nop)) + (t + ;; Mouse control + (define-key map [mouse-1] 'mine-mouse-hit) + (define-key map [mouse-3] 'mine-mouse-mark) + ;; Mouse control to prevent problems + (define-key map [mouse-2] 'mine-mouse-nop) + (define-key map [down-mouse-1] 'mine-mouse-nop) + (define-key map [down-mouse-2] 'mine-mouse-nop) + (define-key map [down-mouse-3] 'mine-mouse-nop) + (define-key map [drag-mouse-1] 'mine-mouse-nop) + (define-key map [drag-mouse-2] 'mine-mouse-nop) + (define-key map [drag-mouse-3] 'mine-mouse-nop) + (define-key map [mouse-2] 'mine-mouse-nop))) + ;; Move + (substitute-key-definition 'backward-char 'mine-left map gm) + (substitute-key-definition 'forward-char 'mine-right map gm) + (substitute-key-definition 'previous-line 'mine-up map gm) + (substitute-key-definition 'next-line 'mine-down map gm) + + (substitute-key-definition 'beginning-of-line 'mine-bol map gm) + (substitute-key-definition 'backward-word 'mine-bol map gm) + (substitute-key-definition 'backward-sexp 'mine-bol map gm) + (substitute-key-definition 'end-of-line 'mine-eol map gm) + (substitute-key-definition 'forward-word 'mine-eol map gm) + (substitute-key-definition 'forward-sexp 'mine-eol map gm) + (define-key map "\M-p" 'mine-top) + (define-key map "\M-n" 'mine-bottom) + ;; Hit and mark + (define-key map " " 'mine-hit-curpoint) + (define-key map "\C-m" 'mine-mark-curpoint) + (define-key map [kp-enter] 'mine-mark-curpoint) + (define-key map "m" 'mine-mark-curpoint) + (define-key map "q" 'mine-quit) + + (setq mine-mode-map map))) + +;;; ================================================================ +;;; Faces + +(defun mine-init-faces () + (setq mine-faces (list)) + (when mine-colorp + (let ((l (append mine-colors mine-default-colors)) + key.col key col name) + (while l + (setq key.col (car l) + l (cdr l) + key (car key.col) + col (cdr key.col)) + (when (null (assoc key mine-faces)) + (setq name + (cond + ((null key) nil) + ((symbolp key) (mine-make-face key col)) + ((not (integerp key)) + (error "Key should be a symbol or a number: '%s'" key)) + ((or (< key 0) (> key 8)) + (error "Key should be a number between 0 and 8: '%s'" key)) + (t + (setq name (intern (concat "mine-face-" key))) + (mine-make-face name col)))) + (setq mine-faces (cons (cons key name) mine-faces)))) + (setq mine-faces (nreverse mine-faces))))) + +(defun mine-make-face (name col) + (or (if (fboundp 'internal-find-face) + (internal-find-face name) + (find-face name)) + (let ((face (make-face name))) + (unless (or (not mine-xemacs-p) col) + (setq col (cdr (face-background 'default 'global)))) + (set-face-background face col) + face)) + name) + +(defun mine-get-face (key) + (cdr (assoc key mine-faces))) + +;;; ================================================================ +;;; Init board + +(defun mine-init-board () + (setq mine-padx* (if mine-char-pad 2 1)) + (if (not mine-torus) + (setq mine-width mine-xmax + mine-height mine-ymax) + (let (window-xmax window-nb-tiles-x window-xmax-int + window-ymax window-nb-tiles-y window-ymax-int) + (setq window-xmax (/ (window-width) mine-padx*) + window-nb-tiles-x (/ window-xmax mine-xmax) + window-xmax-int (* window-nb-tiles-x window-xmax)) + (setq mine-width + (max mine-xmax ; at least mine-xmax + (cond + ((null mine-nb-tiles-x) window-xmax) + ((not (numberp mine-nb-tiles-x)) + (error "mine-nb-tiles-x should be nil or a number: %s" + mine-nb-tiles-x)) + ((zerop mine-nb-tiles-x) window-xmax-int) + ((< mine-nb-tiles-x 0) + (floor (* mine-xmax (- mine-nb-tiles-x)))) + ((floatp mine-nb-tiles-x) + (min window-xmax (floor (* mine-xmax mine-nb-tiles-x)))) + (t (min window-xmax-int (* mine-xmax mine-nb-tiles-x)))))) + (setq window-ymax (- (window-height) 5) + window-nb-tiles-y (/ window-ymax mine-ymax) + window-ymax-int (* window-nb-tiles-y window-ymax)) + (setq mine-height + (max mine-ymax + (cond + ((null mine-nb-tiles-y) window-ymax) + ((not (numberp mine-nb-tiles-y)) + (error "mine-nb-tiles-y should be nil or a number: %s" + mine-nb-tiles-y)) + ((zerop mine-nb-tiles-y) window-ymax-int) + ((< mine-nb-tiles-y 0) + (floor (* mine-ymax (- mine-nb-tiles-y)))) + ((floatp mine-nb-tiles-y) + (min window-ymax (floor (* mine-ymax mine-nb-tiles-y)))) + (t (min window-ymax-int (* mine-ymax mine-nb-tiles-y)))))))) + (let ((buffer-read-only 'nil) + (face-unmarked (mine-get-face 'mine-face-unmarked)) + (face-pad (mine-get-face 'mine-face-pad)) + row col) + (erase-buffer) + (mine-insert-copyright) + (mine-insert-remaining-mines) + (mine-insert-mines-hit) + (setq mine-point-min (point)) + (setq row mine-height) + (while (>= (setq row (1- row)) 0) + (setq col (1- mine-width)) + (insert mine-char-unmarked) + (when face-unmarked + (put-text-property (1- (point)) (point) 'face face-unmarked)) + (while (>= (setq col (1- col)) 0) + (when mine-char-pad + (insert mine-char-pad) + (when face-pad + (put-text-property (1- (point)) (point) 'face face-pad))) + (insert mine-char-unmarked) + (when face-unmarked + (put-text-property (1- (point)) (point) 'face face-unmarked))) + (insert ?\n)) + (setq mine-point-max (1- (point))) + (mine-update-remaining-mines) + (mine-update-mines-hit) + (set-buffer-modified-p 'nil))) + +;;; ================================================================ +;;; Internal moves + +(defun mine-goto-point (point) + (let ((x.y (mine-point-to-x.y point))) + (setq mine-x (car x.y) mine-y (cdr x.y)) + (mine-goto mine-x mine-y) + (= point (point)))) + +(defun mine-goto (x y) + (goto-char (mine-xy-to-point x y)) + (cond ((fboundp 'hscroll-point-visible) + (hscroll-point-visible)) + ((fboundp 'auto-show-make-point-visible) + (auto-show-make-point-visible)))) + +;;; ================================================================ +;;; Conversions + +(defun mine-xy-to-point (x y) + ;; p = pmin + 2*w*(y-1) + 2*(x-1) + (+ mine-point-min + (* mine-padx* mine-width (1- y)) + (* mine-padx* (1- x)))) + +;;; Returns the topleft equivalent of point, +;;; on the periodic board, ie. converts point to model coordinates. +(defun mine-top-left (x.y) + (setcar x.y (1+ (mod (1- (car x.y)) mine-xmax))) + (setcdr x.y (1+ (mod (1- (cdr x.y)) mine-ymax))) + x.y) + +(defun mine-point-to-x.y (point) + (let (x y (p0 (- point mine-point-min))) + (cond + ((<= p0 0) + (setq x 1 y 1)) + ((>= point mine-point-max) + (setq x mine-width y mine-height)) + (t + ;; p = pmin + 2*w*(y-1) + 2*(x-1) + ;; y = (p - pmin)/2w + 1 + ;; x = (p - pmin - 2*w*(y-1)) / 2 + 1 + (setq y (1+ (/ p0 mine-width mine-padx*)) + x (1+ (/ (- p0 (* mine-padx* mine-width (1- y))) mine-padx*))))) + (cons x y))) + +;;; ================================================================ +;;; Screen display + +(defun mine-mark-board (point) + (mine-update-board point mine-char-marked 'mine-face-marked)) + +(defun mine-unmark-board (point) + (mine-update-board point mine-char-unmarked 'mine-face-unmarked)) + +(defun mine-display-nb-adjacent-mines (point nb) + (mine-update-board point + (if (zerop nb) mine-char-zero (+ ?0 nb)) + nb)) + +;; todo: enumerer tous les points periodiques +(defun mine-update-board (point c key) + (let ((buffer-read-only 'nil) + (face (mine-get-face key)) + (x.y (mine-top-left (mine-point-to-x.y point))) + x y) + (setq x (car x.y)) + (while (<= x mine-width) + (setq y (cdr x.y)) + (while (<= y mine-height) + (mine-update-point (mine-xy-to-point x y) c face) + (setq y (+ y mine-ymax))) + (setq x (+ x mine-xmax))) + (mine-reach-level 1) ; redisplay point and its periodic images + (set-buffer-modified-p 'nil))) + +(defun mine-update-point (point c face) + (goto-char point) + (delete-char 1) + (insert c) + (when face + (put-text-property point (point) 'face face)) + (mine-reach-level 0)) ; redisplay point + +(defun mine-reach-level (level) + (cond + ((null mine-level)) ; no update at all + ((< mine-level 0)) ; no update at all + ((zerop mine-level) ; unconditional update + (sit-for 0)) + ((zerop level)) ; wait for level 1 + ((= level 1) + (cond + ((= mine-level level) + (sit-for 0)) + ((= mine-count1 mine-count1-max) + (setq mine-count1 0) + (mine-reach-level (1+ level))) + (t (setq mine-count1 (1+ mine-count1))))) + ((= level 2) + (setq mine-count1 0) + (cond + ((= mine-level level) + (sit-for 0)) + ((= mine-count2 mine-count2-max) + (setq mine-count2 0) + (mine-reach-level (1+ level))) + (t (setq mine-count2 (1+ mine-count2))))) + ((= level 3) + (setq mine-count1 0) + (setq mine-count2 0) + (cond + ((= mine-level level) + (sit-for 0)))))) + +(defun mine-reset-counters () + (setq mine-count1 0 + mine-count2 0)) + +;;; ================================================================ +;;; Messages - init board + +(defun mine-insert-copyright () + (insert mine-version "\n\n")) + +(defun mine-insert-remaining-mines () + (insert (format "%16s" "Remaining mines") ":") + (setq mine-point-remaining-mines (point)) + (insert " \n")) + +(defun mine-insert-mines-hit () + (insert (format "%16s" "mines hit") ":") + (setq mine-point-mines-hit (point)) + (insert " \n\n")) + +;;; ================================================================ +;;; Messages - update board + +(defun mine-update-remaining-mines () + (let ((buffer-read-only 'nil)) + (save-excursion + (goto-char mine-point-remaining-mines) + (delete-char 3) + (insert (format "%3d" mine-nb-remaining-marks))) + (set-buffer-modified-p 'nil)) + (sit-for 0) + (message "mines remaining to find...%d" mine-nb-remaining-marks) + (when (and (zerop mine-nb-remaining-mines) + (zerop mine-nb-remaining-marks)) + (mine-message 'mine-msg-win))) + +(defun mine-update-mines-hit () + (let ((buffer-read-only 'nil)) + (save-excursion + (goto-char mine-point-mines-hit) + (delete-char 3) + (insert (format "%3d" mine-nb-mines-hit))) + (set-buffer-modified-p 'nil))) + +(defun mine-update-bogus-mines (nrb nbb) + (let ((buffer-read-only 'nil) + (msg (format "There were %d remaining mines and %d bogus mines" + nrb nbb))) + (save-excursion + (goto-char (point-max)) + (insert "\n" msg)) + (set-buffer-modified-p 'nil) + (message msg))) + +;;; ================================================================ +;;; Messages - write minibuffer + +(defun mine-message (msg) + (ding) + (cond + ((eq msg 'mine-msg-click-precisely) + (message "Please, click more precisely")) + ((eq msg 'mine-msg-unmark-before-hit) + (message "You must unmark point before hitting it.")) + ((eq msg 'mine-msg-point-already-hit) + (message "Point has already been hit.")) + ((eq msg 'mine-msg-cannot-mark) + (message "Can't (un)mark point...")) + ((eq msg 'mine-msg-loose) + (message "Sorry... There's a mine here...") + (sit-for 1) + (message "Sorry... There's a mine here... You lost!")) + ((eq msg 'mine-msg-win) + (message "Congratulations...") + (sit-for 1) + (message "Congratulations... You won!")) + (t + (message (format "%s" msg))))) + +(mine-init-mode-map) + +;;; ================================================================ + +(defun mine-print-variables (l) + (let (var) + (princ "(setq ") + (while l + (setq var (car l) l (cdr l)) + (cond + ((stringp var) (princ (format ";; %s\n " var))) + ((not (symbolp var)) (error "Not a symbol: %s" var)) + ((not (boundp var)) (error "Unboundp symbol: %s" var)) + (t (princ (format "%-20s'%s" var (symbol-value var))) + (when l (princ "\n "))))) + (princ "))\n"))) + +;;; ================================================================ + +;;(autoload 'apropos-print "apropos") +;;(autoload 'apropos-do-all "apropos") + +(if (not (boundp 'apropos-accumulator)) + (load "apropos")) + +(if (boundp 'apropos-item) +;; (Daniel.Pfeiffer's) old official version of apropos +(defun apropos-symbols (l &optional do-all) + (let ((ll (list))) + (while l + (when (not (stringp (car l))) + (setq ll (cons (car l) ll))) + (setq l (cdr l))) + (setq apropos-accumulator (nreverse ll))) + (or do-all (setq do-all apropos-do-all)) + (apropos-print + t + (lambda (p) + (let (doc symbol) + (while p + (setcar p + (list ; (s f v p) + (setq symbol (car p)) + (if (commandp symbol) + (if (setq doc (documentation symbol t)) + (substring doc 0 (string-match "\n" doc)) + "(not documented)")) + (and do-all + (user-variable-p symbol) + (if (setq doc (documentation-property + symbol 'variable-documentation t)) + (substring doc 0 (string-match "\n" doc)))))) + (setq p (cdr p))))) + t))) + +(provide 'mine) + +;;; mine.el ends here diff -r b88636d63495 -r 8fc7fe29b841 lisp/gnus/ChangeLog --- a/lisp/gnus/ChangeLog Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/gnus/ChangeLog Mon Aug 13 08:50:29 2007 +0200 @@ -1,3 +1,113 @@ +Mon Feb 10 14:19:55 1997 Lars Magne Ingebrigtsen + + * gnus.el: Gnus v5.4.12 is released. + +Mon Feb 10 12:47:41 1997 Lars Magne Ingebrigtsen + + * message.el (message-fetch-field): Accept an optional param. + (message-reply): Only fetch the first Message-ID. + + * gnus-score.el (gnus-summary-score-effect): Update mode line. + +Mon Feb 10 12:32:38 1997 Hrvoje Niksic + + * gnus-art.el: Simplify. + +Mon Feb 10 12:23:48 1997 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-prev-page): Don't scroll when the + article buffer isn't visible. + + * gnus.el ((featurep 'gnus-xmas)): Removed + `gnus-make-local-hook'. + +Mon Feb 10 12:08:31 1997 Adrian Aichner + + * gnus-util.el (gnus-turn-off-edit-menu): Doc fix. + +Mon Feb 10 07:42:37 1997 Lars Magne Ingebrigtsen + + * gnus-sum.el (gnus-summary-prepare-unthreaded): Make sure point + is at bol. + + * gnus-srvr.el (gnus-browse-mode-map): Define gnus-bug. + (gnus-server-mode-map): Ditto. + + * gnus-sum.el (gnus-summary-edit-article-done): Update original + article buffer. + + * gnus-uu.el (gnus-uu-digest-mail-forward): Restore window + config. + + * nnmail.el (nnmail-move-inbox): Make sure tofile exists before + setting modes. + + * gnus-xmas.el (gnus-xmas-region-active-p): New function. + + * gnus-ems.el (gnus-region-active-p): New function. + +Mon Feb 10 07:40:45 1997 Hrvoje Niksic + + * gnus-sum.el (gnus-summary-work-articles): Use zmacs-region. + +Mon Feb 10 07:06:44 1997 Lars Magne Ingebrigtsen + + * message.el (message-mode): Nix out all local variables. + + * gnus-art.el (gnus-summary-save-in-mail): Don't ask. + + * gnus-sum.el (gnus-ps-print-hook): New hook. + (gnus-summary-print-article): Use it. + + * message.el (message-reply): Make sure there is something + inserted as a To. + +Mon Feb 10 05:54:28 1997 Paul Franklin + + * gnus-group.el (gnus-group-edit-group): Ignore errors while + closing group. + +Mon Feb 10 05:22:09 1997 Steven L. Baur + + * messagexmas.el (message-xmas-maybe-fontify): New function. + (message-mode-hook): Use it. + +Sat Feb 8 21:18:25 1997 Lars Magne Ingebrigtsen + + * message.el (message-user-organization): Only use string values + of `gnus-local-organization'. + +Tue Feb 4 20:26:20 1997 Paul Franklin + + * nnmail.el (nnmail-get-spool-files): Don't call file-directory-p + on pop spool specifiers. + +Wed Feb 5 01:56:07 1997 Lars Magne Ingebrigtsen + + * message.el (message-delete-mh-headers): Changed default. + (message-send-mail-with-mh): Use it. + (message-mh-deletable-headers): Renamed. + + * gnus-sum.el (gnus-read-header): Don't do anything if the article + can't be requested. + +Wed Feb 5 01:51:07 1997 Joev Dubach + + * gnus-sum.el (gnus-select-newsgroup): Update group line. + +Tue Feb 4 20:23:30 1997 Lars Magne Ingebrigtsen + + * gnus-util.el (gnus-output-to-mail): Insert a newline before the + "From ". + + * nnml.el (nnml-request-move-article): Update active ranges. + (nnml-nov-delete-article): Update active ranges. + +Tue Feb 4 17:54:09 1997 HISASHIGE Kenji + + * gnus-msg.el (gnus-summary-reply-with-original): Pass on the + `wide' param. + Tue Feb 4 03:49:59 1997 Lars Magne Ingebrigtsen * gnus.el: Gnus v5.4.11 is released. diff -r b88636d63495 -r 8fc7fe29b841 lisp/gnus/gnus-art.el --- a/lisp/gnus/gnus-art.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/gnus/gnus-art.el Mon Aug 13 08:50:29 2007 +0200 @@ -179,10 +179,11 @@ '(("_" "_" underline) ("/" "/" italic) ("\\*" "\\*" bold) - ("_/" "/_" underline-italic) - ("_\\*" "\\*_" underline-bold) + ;;("_/" "/_" underline-italic) + ;;("_\\*" "\\*_" underline-bold) ("\\*/" "/\\*" bold-italic) - ("_\\*/" "/\\*_" underline-bold-italic)))) + ;;("_\\*/" "/\\*_" underline-bold-italic) + ))) `(("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)" 2 3 gnus-emphasis-underline) ,@(mapcar @@ -1458,7 +1459,7 @@ (if (and (file-readable-p filename) (mail-file-babyl-p filename)) (gnus-output-to-rmail filename t) - (gnus-output-to-mail filename t))))) + (gnus-output-to-mail filename))))) ;; Remember the directory name to save articles. (setq gnus-newsgroup-last-mail filename))) diff -r b88636d63495 -r 8fc7fe29b841 lisp/gnus/gnus-ems.el --- a/lisp/gnus/gnus-ems.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/gnus/gnus-ems.el Mon Aug 13 08:50:29 2007 +0200 @@ -195,6 +195,12 @@ (insert " " gnus-tmp-subject-or-nil "\n")) ))) +(defun gnus-region-active-p () + "Say whether the region is active." + (and (boundp 'transient-mark-mode) + transient-mark-mode + (boundp 'mark-active) + mark-active)) (provide 'gnus-ems) diff -r b88636d63495 -r 8fc7fe29b841 lisp/gnus/gnus-gl.el --- a/lisp/gnus/gnus-gl.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/gnus/gnus-gl.el Mon Aug 13 08:50:29 2007 +0200 @@ -810,9 +810,9 @@ (if (null arg) (not gnus-grouplens-mode) (> (prefix-numeric-value arg) 0))) (when gnus-grouplens-mode - (gnus-make-local-hook 'gnus-select-article-hook) + (make-local-hook 'gnus-select-article-hook) (gnus-add-hook 'gnus-select-article-hook 'grouplens-do-time nil 'local) - (gnus-make-local-hook 'gnus-exit-group-hook) + (make-local-hook 'gnus-exit-group-hook) (gnus-add-hook 'gnus-exit-group-hook 'bbb-exit-group nil 'local) (make-local-variable 'gnus-score-find-score-files-function) diff -r b88636d63495 -r 8fc7fe29b841 lisp/gnus/gnus-group.el --- a/lisp/gnus/gnus-group.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/gnus/gnus-group.el Mon Aug 13 08:50:29 2007 +0200 @@ -762,7 +762,7 @@ (gnus-set-default-directory) (gnus-update-format-specifications nil 'group 'group-mode) (gnus-update-group-mark-positions) - (gnus-make-local-hook 'post-command-hook) + (make-local-hook 'post-command-hook) (gnus-add-hook 'post-command-hook 'gnus-clear-inboxes-moved nil t) (when gnus-use-undo (gnus-undo-mode 1)) @@ -1871,7 +1871,8 @@ (error "No group on current line")) (unless (setq info (gnus-get-info group)) (error "Killed group; can't be edited")) - (gnus-close-group group) + (ignore-errors + (gnus-close-group group)) (gnus-edit-form ;; Find the proper form to edit. (cond ((eq part 'method) diff -r b88636d63495 -r 8fc7fe29b841 lisp/gnus/gnus-msg.el --- a/lisp/gnus/gnus-msg.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/gnus/gnus-msg.el Mon Aug 13 08:50:29 2007 +0200 @@ -175,7 +175,7 @@ (gnus-configure-windows ,config t)))) (defun gnus-inews-add-send-actions (winconf buffer article) - (gnus-make-local-hook 'message-sent-hook) + (make-local-hook 'message-sent-hook) (gnus-add-hook 'message-sent-hook 'gnus-inews-do-gcc nil t) (setq message-post-method `(lambda (arg) @@ -594,7 +594,7 @@ "Start composing a reply mail to the current message. The original article will be yanked." (interactive "P") - (gnus-summary-reply (gnus-summary-work-articles n))) + (gnus-summary-reply (gnus-summary-work-articles n) wide)) (defun gnus-summary-wide-reply (&optional yank) "Start composing a wide reply mail to the current message. diff -r b88636d63495 -r 8fc7fe29b841 lisp/gnus/gnus-score.el --- a/lisp/gnus/gnus-score.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/gnus/gnus-score.el Mon Aug 13 08:50:29 2007 +0200 @@ -829,7 +829,8 @@ regexp) (string-match regexp content)) (gnus-summary-raise-score score)))) - (beginning-of-line 2))))) + (beginning-of-line 2)))) + (gnus-set-mode-line 'summary)) (defun gnus-summary-score-crossposting (score date) ;; Enter score file entry for current crossposting. diff -r b88636d63495 -r 8fc7fe29b841 lisp/gnus/gnus-srvr.el --- a/lisp/gnus/gnus-srvr.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/gnus/gnus-srvr.el Mon Aug 13 08:50:29 2007 +0200 @@ -129,7 +129,8 @@ "g" gnus-server-regenerate-server - "\C-c\C-i" gnus-info-find-node)) + "\C-c\C-i" gnus-info-find-node + "\C-c\C-b" gnus-bug)) (defun gnus-server-mode () "Major mode for listing and editing servers. @@ -512,7 +513,8 @@ "\C-c\C-c" gnus-browse-exit "?" gnus-browse-describe-briefly - "\C-c\C-i" gnus-info-find-node)) + "\C-c\C-i" gnus-info-find-node + "\C-c\C-b" gnus-bug)) (defun gnus-browse-make-menu-bar () (gnus-turn-off-edit-menu 'browse) diff -r b88636d63495 -r 8fc7fe29b841 lisp/gnus/gnus-sum.el --- a/lisp/gnus/gnus-sum.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/gnus/gnus-sum.el Mon Aug 13 08:50:29 2007 +0200 @@ -647,6 +647,11 @@ :group 'gnus-group-select :type 'hook) +(defcustom gnus-ps-print-hook nil + "*A hook run before ps-printing something from Gnus." + :group 'gnus-summary + :type 'hook) + (defcustom gnus-summary-selected-face 'gnus-summary-selected-face "Face used for highlighting the current article in the summary buffer." :group 'gnus-summary-visual @@ -701,6 +706,7 @@ :type '(repeat (cons (sexp :tag "Form" nil) face))) + ;;; Internal variables (defvar gnus-scores-exclude-files nil) @@ -1888,7 +1894,7 @@ (make-local-variable 'gnus-summary-line-format) (make-local-variable 'gnus-summary-line-format-spec) (make-local-variable 'gnus-summary-mark-positions) - (gnus-make-local-hook 'post-command-hook) + (make-local-hook 'post-command-hook) (gnus-add-hook 'post-command-hook 'gnus-clear-inboxes-moved nil t) (run-hooks 'gnus-summary-mode-hook) (gnus-update-format-specifications nil 'summary 'summary-mode 'summary-dummy) @@ -3530,6 +3536,8 @@ "Generate an unthreaded summary buffer based on HEADERS." (let (header number mark) + (beginning-of-line) + (while headers ;; We may have to root out some bad articles... (when (memq (setq number (mail-header-number @@ -3604,6 +3612,10 @@ (setq gnus-newsgroup-processable nil) + (gnus-update-read-articles group gnus-newsgroup-unreads) + (unless (gnus-ephemeral-group-p gnus-newsgroup-name) + (gnus-group-update-group group)) + (setq articles (gnus-articles-to-read group read-all)) (cond @@ -4407,10 +4419,7 @@ (gnus-summary-find-next nil article))) (decf n))) (nreverse articles))) - ((and (boundp 'transient-mark-mode) - transient-mark-mode - (boundp 'mark-active) - mark-active) + ((gnus-region-active-p) ;; Work on the region between point and mark. (let ((max (max (point) (mark))) articles article) @@ -5421,7 +5430,8 @@ Argument LINES specifies lines to be scrolled down." (interactive "P") (gnus-set-global-variables) - (let ((article (gnus-summary-article-number))) + (let ((article (gnus-summary-article-number)) + (article-window (get-buffer-window gnus-article-buffer))) (gnus-configure-windows 'article) (if (or (null gnus-current-article) (null gnus-article-current) @@ -5430,8 +5440,9 @@ ;; Selected subject is different from current article's. (gnus-summary-display-article article) (gnus-summary-recenter) - (gnus-eval-in-buffer-window gnus-article-buffer - (gnus-article-prev-page lines)))) + (when article-window + (gnus-eval-in-buffer-window gnus-article-buffer + (gnus-article-prev-page lines))))) (gnus-summary-position-point)) (defun gnus-summary-scroll-up (lines) @@ -6367,6 +6378,7 @@ (copy-to-buffer buffer (point-min) (point-max)) (set-buffer buffer) (gnus-article-delete-invisible-text) + (run-hooks 'gnus-ps-print-hook) (ps-print-buffer-with-faces filename)) (kill-buffer buffer))))) @@ -6622,6 +6634,13 @@ (memq article gnus-newsgroup-dormant) (memq article gnus-newsgroup-unreads))) + (when (and (equal to-group gnus-newsgroup-name) + (not (memq article gnus-newsgroup-unreads))) + ;; Mark this article as read in this group. + (push (cons to-article gnus-read-mark) gnus-newsgroup-reads) + (setcdr (gnus-active to-group) to-article) + (setcdr gnus-newsgroup-active to-article)) + (while marks (when (memq article (symbol-value (intern (format "gnus-newsgroup-%s" @@ -6634,7 +6653,7 @@ (symbol-value (intern (format "gnus-newsgroup-%s" (caar marks))))))) - ;; Copy mark to other group. + ;; Copy the marks to other group. (gnus-add-marked-articles to-group (cdar marks) (list to-article) info)) (setq marks (cdr marks))))) @@ -6942,7 +6961,10 @@ ;; Prettify the article buffer again. (save-excursion (set-buffer gnus-article-buffer) - (run-hooks 'gnus-article-display-hook)) + (run-hooks 'gnus-article-display-hook) + (set-buffer gnus-original-article-buffer) + (gnus-request-article + (cdr gnus-article-current) (car gnus-article-current) (current-buffer))) ;; Prettify the summary buffer line. (when (gnus-visual-p 'summary-highlight 'highlight) (run-hooks 'gnus-visual-mark-article-hook)))) @@ -8367,7 +8389,8 @@ (t gnus-reffed-article-number)) (current-buffer)) (insert " Article retrieved.\n")) - (if (not (setq header (car (gnus-get-newsgroup-headers nil t)))) + (if (or (not where) + (not (setq header (car (gnus-get-newsgroup-headers nil t))))) () ; Malformed head. (unless (gnus-summary-article-sparse-p (mail-header-number header)) (when (and (stringp id) diff -r b88636d63495 -r 8fc7fe29b841 lisp/gnus/gnus-topic.el --- a/lisp/gnus/gnus-topic.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/gnus/gnus-topic.el Mon Aug 13 08:50:29 2007 +0200 @@ -399,7 +399,7 @@ (point-max (point-max)) (unread 0) (topic (car type)) - info entry end active) + info entry end active tick) ;; Insert any sub-topics. (while topicl (incf unread @@ -429,13 +429,17 @@ (not (member (gnus-info-group (setq info (nth 2 entry))) gnus-topic-tallied-groups))) (push (gnus-info-group info) gnus-topic-tallied-groups) - (incf unread (car entry)))) + (incf unread (car entry))) + (when (and (listp entry) + (numberp (car entry))) + (setq tick t))) (goto-char beg) ;; Insert the topic line. (when (and (not silent) - (or gnus-topic-display-empty-topics - (not (zerop unread)) - (/= point-max (point-max)))) + (or gnus-topic-display-empty-topics ;We want empty topics + (not (zerop unread)) ;Non-empty + tick ;Ticked articles + (/= point-max (point-max)))) ;Unactivated groups (gnus-extent-start-open (point)) (gnus-topic-insert-topic-line (car type) visiblep @@ -929,7 +933,7 @@ 'gnus-group-sort-topic) (setq gnus-group-change-level-function 'gnus-topic-change-level) (setq gnus-goto-missing-group-function 'gnus-topic-goto-missing-group) - (gnus-make-local-hook 'gnus-check-bogus-groups-hook) + (make-local-hook 'gnus-check-bogus-groups-hook) (add-hook 'gnus-check-bogus-groups-hook 'gnus-topic-clean-alist) (setq gnus-topology-checked-p nil) ;; We check the topology. diff -r b88636d63495 -r 8fc7fe29b841 lisp/gnus/gnus-undo.el --- a/lisp/gnus/gnus-undo.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/gnus/gnus-undo.el Mon Aug 13 08:50:29 2007 +0200 @@ -96,7 +96,7 @@ (unless (assq 'gnus-undo-mode minor-mode-map-alist) (push (cons 'gnus-undo-mode gnus-undo-mode-map) minor-mode-map-alist)) - (gnus-make-local-hook 'post-command-hook) + (make-local-hook 'post-command-hook) (gnus-add-hook 'post-command-hook 'gnus-undo-boundary nil t) (add-hook 'gnus-summary-exit-hook 'gnus-undo-boundary) (run-hooks 'gnus-undo-mode-hook))) diff -r b88636d63495 -r 8fc7fe29b841 lisp/gnus/gnus-util.el --- a/lisp/gnus/gnus-util.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/gnus/gnus-util.el Mon Aug 13 08:50:29 2007 +0200 @@ -567,7 +567,7 @@ `(,(car funs) t1 t2))) (defun gnus-turn-off-edit-menu (type) - "Turn off edit meny in `gnus-TYPE-mode-map'." + "Turn off edit menu in `gnus-TYPE-mode-map'." (define-key (symbol-value (intern (format "gnus-%s-mode-map" type))) [menu-bar edit] 'undefined)) @@ -764,7 +764,7 @@ (when (and (not (get-file-buffer filename)) (not (file-exists-p filename))) (if (or (not ask) - (gnus-yes-or-no-p + (gnus-y-or-n-p (concat "\"" filename "\" does not exist, create it? "))) (let ((file-buffer (create-file-buffer filename))) (save-excursion @@ -782,11 +782,24 @@ ;; Decide whether to append to a file or to an Emacs buffer. (let ((outbuf (get-file-buffer filename))) (if (not outbuf) - (append-to-file (point-min) (point-max) filename) + (let ((buffer-read-only nil)) + (save-excursion + (goto-char (point-max)) + (forward-char -2) + (unless (looking-at "\n\n") + (goto-char (point-max)) + (unless (bolp) + (insert "\n")) + (insert "\n")) + (goto-char (point-max)) + (append-to-file (point-min) (point-max) filename))) ;; File has been visited, in buffer OUTBUF. (set-buffer outbuf) (let ((buffer-read-only nil)) (goto-char (point-max)) + (unless (eobp) + (insert "\n")) + (insert "\n") (insert-buffer-substring tmpbuf))))) (kill-buffer tmpbuf))) diff -r b88636d63495 -r 8fc7fe29b841 lisp/gnus/gnus-uu.el --- a/lisp/gnus/gnus-uu.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/gnus/gnus-uu.el Mon Aug 13 08:50:29 2007 +0200 @@ -505,43 +505,43 @@ (let ((gnus-uu-save-in-digest t) (file (make-temp-name (nnheader-concat gnus-uu-tmp-dir "forward"))) buf subject from newsgroups) - (setq gnus-uu-digest-from-subject nil) - (gnus-uu-decode-save n file) - (setq buf (switch-to-buffer (get-buffer-create " *gnus-uu-forward*"))) - (gnus-add-current-to-buffer-list) - (erase-buffer) - (delete-other-windows) - (insert-file file) - (let ((fs gnus-uu-digest-from-subject)) - (when fs - (setq from (caar fs) - subject (gnus-simplify-subject-fuzzy (cdar fs)) - fs (cdr fs)) - (while (and fs (or from subject)) - (when from - (unless (string= from (caar fs)) - (setq from nil))) - (when subject - (unless (string= (gnus-simplify-subject-fuzzy (cdar fs)) - subject) - (setq subject nil))) - (setq fs (cdr fs)))) - (unless subject - (setq subject "Digested Articles")) - (unless from - (setq from - (if (gnus-news-group-p gnus-newsgroup-name) - gnus-newsgroup-name - "Various")))) - (goto-char (point-min)) - (when (re-search-forward "^Subject: ") - (delete-region (point) (gnus-point-at-eol)) - (insert subject)) - (goto-char (point-min)) - (when (re-search-forward "^From: ") - (delete-region (point) (gnus-point-at-eol)) - (insert from)) - (message-forward post) + (gnus-setup-message 'forward + (setq gnus-uu-digest-from-subject nil) + (gnus-uu-decode-save n file) + (setq buf (switch-to-buffer (get-buffer-create " *gnus-uu-forward*"))) + (gnus-add-current-to-buffer-list) + (erase-buffer) + (insert-file file) + (let ((fs gnus-uu-digest-from-subject)) + (when fs + (setq from (caar fs) + subject (gnus-simplify-subject-fuzzy (cdar fs)) + fs (cdr fs)) + (while (and fs (or from subject)) + (when from + (unless (string= from (caar fs)) + (setq from nil))) + (when subject + (unless (string= (gnus-simplify-subject-fuzzy (cdar fs)) + subject) + (setq subject nil))) + (setq fs (cdr fs)))) + (unless subject + (setq subject "Digested Articles")) + (unless from + (setq from + (if (gnus-news-group-p gnus-newsgroup-name) + gnus-newsgroup-name + "Various")))) + (goto-char (point-min)) + (when (re-search-forward "^Subject: ") + (delete-region (point) (gnus-point-at-eol)) + (insert subject)) + (goto-char (point-min)) + (when (re-search-forward "^From: ") + (delete-region (point) (gnus-point-at-eol)) + (insert from)) + (message-forward post)) (delete-file file) (kill-buffer buf) (setq gnus-uu-digest-from-subject nil))) diff -r b88636d63495 -r 8fc7fe29b841 lisp/gnus/gnus-xmas.el --- a/lisp/gnus/gnus-xmas.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/gnus/gnus-xmas.el Mon Aug 13 08:50:29 2007 +0200 @@ -434,6 +434,9 @@ (color-instance-rgb-components (make-color-instance color)))))) +(defun gnus-xmas-region-active-p () + (and (fboundp 'region-active-p) + (region-active-p))) (defun gnus-xmas-redefine () "Redefine lots of Gnus functions for XEmacs." @@ -450,13 +453,13 @@ (fset 'gnus-appt-select-lowest-window 'gnus-xmas-appt-select-lowest-window) (fset 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names) - (fset 'gnus-make-local-hook 'make-local-variable) (fset 'gnus-add-hook 'gnus-xmas-add-hook) (fset 'gnus-character-to-event 'character-to-event) (fset 'gnus-mode-line-buffer-identification 'gnus-xmas-mode-line-buffer-identification) (fset 'gnus-key-press-event-p 'key-press-event-p) - + (fset 'gnus-region-active-p 'gnus-xmas-region-active-p) + (add-hook 'gnus-group-mode-hook 'gnus-xmas-group-menu-add) (add-hook 'gnus-summary-mode-hook 'gnus-xmas-summary-menu-add) (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add) diff -r b88636d63495 -r 8fc7fe29b841 lisp/gnus/gnus.el --- a/lisp/gnus/gnus.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/gnus/gnus.el Mon Aug 13 08:50:29 2007 +0200 @@ -198,7 +198,7 @@ :link '(custom-manual "(gnus)Exiting Gnus") :group 'gnus) -(defconst gnus-version-number "5.4.11" +(defconst gnus-version-number "5.4.12" "Version number for this version of Gnus.") (defconst gnus-version (format "Gnus v%s" gnus-version-number) @@ -230,7 +230,6 @@ (defalias 'gnus-topic-remove-excess-properties 'ignore) (defalias 'gnus-appt-select-lowest-window 'appt-select-lowest-window) (defalias 'gnus-mail-strip-quoted-names 'mail-strip-quoted-names) - (defalias 'gnus-make-local-hook 'make-local-hook) (defalias 'gnus-add-hook 'add-hook) (defalias 'gnus-character-to-event 'identity) (defalias 'gnus-add-text-properties 'add-text-properties) diff -r b88636d63495 -r 8fc7fe29b841 lisp/gnus/message.el --- a/lisp/gnus/message.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/gnus/message.el Mon Aug 13 08:50:29 2007 +0200 @@ -247,6 +247,7 @@ (defvar gnus-local-organization) (defcustom message-user-organization (or (and (boundp 'gnus-local-organization) + (stringp gnus-local-organization) gnus-local-organization) (getenv "ORGANIZATION") t) @@ -583,7 +584,7 @@ 'message-mail 'message-send-and-exit 'message-kill-buffer 'message-send-hook)) -(defvar message-delete-mh-headers t +(defvar message-mh-deletable-headers '(Message-ID Date Lines Sender) "If non-nil, delete the deletable headers before feeding to mh.") ;;; Internal variables. @@ -794,9 +795,9 @@ (setq paren nil)))) (nreverse elems))))) -(defun message-fetch-field (header) +(defun message-fetch-field (header &optional not-all) "The same as `mail-fetch-field', only remove all newlines." - (let ((value (mail-fetch-field header nil t))) + (let ((value (mail-fetch-field header nil (not not-all)))) (when value (nnheader-replace-chars-in-string value ?\n ? )))) @@ -1052,10 +1053,10 @@ (kill-all-local-variables) (make-local-variable 'message-reply-buffer) (setq message-reply-buffer nil) - (make-local-variable 'message-send-actions) - (make-local-variable 'message-exit-actions) - (make-local-variable 'message-kill-actions) - (make-local-variable 'message-postpone-actions) + (set (make-local-variable 'message-send-actions) nil) + (set (make-local-variable 'message-exit-actions) nil) + (set (make-local-variable 'message-kill-actions) nil) + (set (make-local-variable 'message-postpone-actions) nil) (set-syntax-table message-mode-syntax-table) (use-local-map message-mode-map) (setq local-abbrev-table message-mode-abbrev-table) @@ -1766,8 +1767,8 @@ "msg.")))) (setq buffer-file-name name) ;; MH wants to generate these headers itself. - (when message-delete-mh-headers - (let ((headers message-deletable-headers)) + (when message-mh-deletable-headers + (let ((headers message-mh-deletable-headers)) (while headers (goto-char (point-min)) (and (re-search-forward @@ -1945,7 +1946,7 @@ ;; Check the Message-ID header. (message-check 'message-id (let* ((case-fold-search t) - (message-id (message-fetch-field "message-id"))) + (message-id (message-fetch-field "message-id" t))) (or (not message-id) (and (string-match "@" message-id) (string-match "@[^\\.]*\\." message-id)) @@ -2840,7 +2841,7 @@ mct (message-fetch-field "mail-copies-to") reply-to (unless ignore-reply-to (message-fetch-field "reply-to")) references (message-fetch-field "references") - message-id (message-fetch-field "message-id")) + message-id (message-fetch-field "message-id" t)) ;; Remove any (buggy) Re:'s that are present and make a ;; proper one. (when (string-match "^[ \t]*[Rr][Ee]:[ \t]*" subject) @@ -2875,6 +2876,9 @@ (insert (prog1 (rmail-dont-reply-to (buffer-string)) (erase-buffer))) (goto-char (point-min)) + ;; Perhaps Mail-Copies-To: never removed the only address? + (when (eobp) + (insert (or reply-to from ""))) (setq ccalist (mapcar (lambda (addr) @@ -2938,7 +2942,7 @@ date (message-fetch-field "date") subject (or (message-fetch-field "subject") "none") references (message-fetch-field "references") - message-id (message-fetch-field "message-id") + message-id (message-fetch-field "message-id" t) followup-to (message-fetch-field "followup-to") newsgroups (message-fetch-field "newsgroups") reply-to (message-fetch-field "reply-to") @@ -3034,7 +3038,7 @@ (message-narrow-to-head) (setq from (message-fetch-field "from") newsgroups (message-fetch-field "newsgroups") - message-id (message-fetch-field "message-id") + message-id (message-fetch-field "message-id" t) distribution (message-fetch-field "distribution"))) ;; Make sure that this article was written by the user. (unless (string-equal diff -r b88636d63495 -r 8fc7fe29b841 lisp/gnus/messagexmas.el --- a/lisp/gnus/messagexmas.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/gnus/messagexmas.el Mon Aug 13 08:50:29 2007 +0200 @@ -92,6 +92,13 @@ (fset 'message-exchange-point-and-mark 'message-xmas-exchange-point-and-mark) +(defun message-xmas-maybe-fontify () + (when (and (featurep 'font-lock) + font-lock-auto-fontify) + (turn-on-font-lock))) + +(add-hook 'message-mode-hook 'message-xmas-maybe-fontify) + (provide 'messagexmas) ;;; messagexmas.el ends here diff -r b88636d63495 -r 8fc7fe29b841 lisp/gnus/nnmail.el --- a/lisp/gnus/nnmail.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/gnus/nnmail.el Mon Aug 13 08:50:29 2007 +0200 @@ -556,7 +556,8 @@ ;; No output => movemail won (progn (unless popmail - (set-file-modes tofile nnmail-default-file-modes)) + (when (file-exists-p tofile) + (set-file-modes tofile nnmail-default-file-modes))) (push inbox nnmail-moved-inboxes)) (set-buffer errors) ;; There may be a warning about older revisions. We @@ -565,7 +566,8 @@ (if (search-forward "older revision" nil t) (progn (unless popmail - (set-file-modes tofile nnmail-default-file-modes)) + (when (file-exists-p tofile) + (set-file-modes tofile nnmail-default-file-modes))) (push inbox nnmail-moved-inboxes)) ;; Probably a real error. (subst-char-in-region (point-min) (point-max) ?\n ?\ ) @@ -1254,19 +1256,19 @@ 'nconc (mapcar (lambda (file) - (if (file-directory-p file) + (if (and (not (string-match "^po:" file)) + (file-directory-p file)) (nnheader-directory-regular-files file) (list file))) nnmail-spool-file)) procmails)) - ((and (stringp nnmail-spool-file) - (not (file-directory-p nnmail-spool-file))) - (cons nnmail-spool-file procmails)) - ((and (stringp nnmail-spool-file) - (file-directory-p nnmail-spool-file)) - (nconc - (nnheader-directory-regular-files nnmail-spool-file) - procmails)) + ((stringp nnmail-spool-file) + (if (and (not (string-match "^po:" nnmail-spool-file)) + (file-directory-p nnmail-spool-file)) + (nconc + (nnheader-directory-regular-files nnmail-spool-file) + procmails) + (cons nnmail-spool-file procmails))) ((eq nnmail-spool-file 'pop) (cons (format "po:%s" (user-login-name)) procmails)) (t diff -r b88636d63495 -r 8fc7fe29b841 lisp/gnus/nnml.el --- a/lisp/gnus/nnml.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/gnus/nnml.el Mon Aug 13 08:50:29 2007 +0200 @@ -318,7 +318,9 @@ (int-to-string article))) (file-error nil)) (nnml-nov-delete-article group article) - (and last (nnml-save-nov)))) + (when last + (nnml-save-nov) + (nnmail-save-active nnml-group-alist nnml-active-file)))) result)) (deffoo nnml-request-accept-article (group &optional server last) @@ -774,9 +776,17 @@ (defun nnml-nov-delete-article (group article) (save-excursion (set-buffer (nnml-open-nov group)) - (goto-char (point-min)) - (when (re-search-forward (concat "^" (int-to-string article) "\t") nil t) - (delete-region (match-beginning 0) (progn (forward-line 1) (point)))) + (when (nnheader-find-nov-line article) + (delete-region (point) (progn (forward-line 1) (point))) + (when (bobp) + (let ((active (cadr (assoc group nnml-group-alist))) + num) + (when active + (if (eobp) + (setf (car active) (1+ (cdr active))) + (when (and (setq num (ignore-errors (read (current-buffer)))) + (numberp num)) + (setf (car active) num))))))) t)) (provide 'nnml) diff -r b88636d63495 -r 8fc7fe29b841 lisp/gnus/nntp.el --- a/lisp/gnus/nntp.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/gnus/nntp.el Mon Aug 13 08:50:29 2007 +0200 @@ -548,8 +548,7 @@ (defun nntp-send-authinfo-from-file () "Send the AUTHINFO to the nntp server. -This function is supposed to be called from `nntp-server-opened-hook'. -It will prompt for a password." +This function is supposed to be called from `nntp-server-opened-hook'." (when (file-exists-p "~/.nntp-authinfo") (nnheader-temp-write nil (insert-file-contents "~/.nntp-authinfo") diff -r b88636d63495 -r 8fc7fe29b841 lisp/hm--html-menus/ANNOUNCEMENT --- a/lisp/hm--html-menus/ANNOUNCEMENT Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/hm--html-menus/ANNOUNCEMENT Mon Aug 13 08:50:29 2007 +0200 @@ -1,9 +1,9 @@ Hello, -I've written a new version (5.0) of my html package for the XEmacs +I've written a new version (5.1) of my html package for the XEmacs and the GNU Emacs 19. The name of the package is: - hm--html-menus-5.0.tar.gz + hm--html-menus-5.1.tar.gz With this package it is very easy to write html pages for the World Wide Web (WWW). Eg: In most cases the user gets help to construct a specific @@ -12,17 +12,19 @@ source and destination (drag and drop feature). The biggest new features in this release are: -- drag and drop functions to insert links with the mouse -- a minor mode to extent other html modes like the psgml mode -- some new html tags, like the tags -- fixed some old html tags -- the pulldown menu in the Emacs 19 is no longer a global menu -- the popup menus in the Emacs 19 are now much fastere -- the name of the mode has changed from html-mode to hm--html-mode -- the package is longer based on the package of Marc Andreessen +- a better drag and drop interface to insert links with the mouse +- help feature for the drag and drop commands +- there's now also a default drag and drop table for other modes +- a better interface for inserting template files +- indentation +- better font lock stuff +- a site specific configuration file + (look at the variable hm--html-site-config-file) +- a better syntax table from Bob Weiner +- a lot of bug fixes Read the NEWS file to see news in detail... -You should find hm--html-menus-5.0.tar.gz on the following ftp server: +You should find hm--html-menus-5.1.tar.gz on the following ftp server: sunsite.unc.edu in /pub/Linux/apps/editors/emacs/ ftp.rrzn.uni-hannover.de in /pub/unix/editors/lemacs/contrib ftp.tnt.uni-hannover.de in /pub/editors/xemacs/contrib @@ -31,7 +33,11 @@ from the incoming directories to the above listed directories. There is also a html documentation about the package. You can find it on: -http://www.tnt.uni-hannover.de:80/data/info/www/tnt/soft/info/www/html-editors/hm--html-menus/overview.html +http://www.tnt.uni-hannover.de/~muenkel/software/own/hm--html-menus/overview.html + +NOTE: This version is not tested with the Emacs 19. One of the next +releases in the near future will be a bug fix only release for the +Emacs 19. So please report any bugs to muenkel@tnt.uni-hannover.de. The package provides functions to insert the following stuff in html-pages: 1. Anchors: @@ -78,7 +84,9 @@ menu interactively. With the pulldown menu, you can do the following things: -- select the pulldown menu +- select the popup menu +- start a drag and drop command +- get help on a drag and drop command - remove numeric names - quotify hrefs - reload the config files @@ -113,7 +121,8 @@ The html specification is under development and therefore this package is also under development. So, if you have any ideas to -extend the package, feel free to email them to muenkel@tnt.uni-hannover.de. +extend the package, feel free to email them to +muenkel@tnt.uni-hannover.de. Heiko diff -r b88636d63495 -r 8fc7fe29b841 lisp/hm--html-menus/NEWS --- a/lisp/hm--html-menus/NEWS Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/hm--html-menus/NEWS Mon Aug 13 08:50:29 2007 +0200 @@ -1,3 +1,96 @@ +12.02.97 + Renamed command-description.tmpl to command-description.html.tmpl. + The indentation stuff can now be disabled by setting the + variable `hm--html-disable-indentation' to t. + Fixed the long annoying bug, that the directory in the pop up + frame for selecting the template file was wrong in most cases. + -- BUILDED the version 5.1 of the package +11.02.97: + Changed the whole indentation stuff. It is now all working - + with the exceptions, that the list `hm--html-tag-name-alist' + contains not all "one element tags", and also text between + pre tags will be intended. +09.02.97: + Fixed a bug in the template stuff. + Moved the whole indentation stuff to the new file + hm--html-indentation.el. +06.02.97: + The indentation of two tag elements are now working. +03.02.97: + It is now possible to use an own site specific configuration file. + For that the variable `hm--html-site-config-file' was added. + Added some code from Bob Weiner to modify the syntax table, + change the comment start and end and the sentence end. + Started to add the indentation. + The indentation in comments is now working. +01.02.97: + In the source and destination description of a drag and drop + are now used marks instead of points. This fixed bugs, which + occured, if the source and the destination buffer are the same. + A help feature was implemented. +30.01.97: + Added some new features to the drag and drop interface, like + the macro `idd-start-mouse-drag-and-drop', which is usefull to + define action functions. The event is now also stored in the source + and destination description. + Changed the order of the arguments destination and source + to source and destination. + Changed the name of all idd specification type functions + to idd-if-*-p. +27.01.97: + Changed the source and destination in the drag and drop functions, + so that they are now used in a standard way. + Added the command `idd-start-mouse-drag-and-drop', which could + be used to start a drag and drop command without a button-press-event. + Used the command `idd-start-mouse-drag-and-drop' in the hm--html + menus. +26.01.97: + Renamed the function `tmpl-insert-template-file' to + `tmpl-insert-template-file-from-fixed-dirs'. + Added a function `tmpl-insert-template-file', which doesn't use + a file filter and a list of directories. + Changed both functions, so that they now use the variables + `tmpl-template-dir-list', `tmpl-automatic-expand', + `tmpl-filter-regexp' and `tmpl-history-variable-name' + instead of optional arguments. + Changed the name of the file frame.html to frame.html.tmpl. This is + usefull, if you've templates for multiple modes in one directory and + you want to use the new filter feature of the command + `tmpl-insert-template-file-from-fixed-dirs'. + Changed the function `hm--html-insert-template' and added + the function `hm--html-insert-template-from-fixed-dirs'. They are + using the functions `tmpl-insert-template-file' and + `tmpl-insert-template-file-from-fixed-dirs'. + The function `hm--html-insert-created-comment' is no longer + called in this functions. If needed, then this function must be + inserted in the template file. This is done now with the file + frame.html.tmpl. +22.01.97: + Changed the function `tmpl-insert-template-file': + It is now possible to use a file filter and a list + of directories, in which template files could be. +19.01.97: + Applied a patch from Andreas Ernst to fix bugs in the table stuff. + Added a '(let ((case-fold-seach t))' in all functions of hm--html.el, + which are call a search function with lowercase letters. + The functions to insert ordered, normal and dired list are fixed to + use
    • tags instead of only
  • . + Fixed a keybind bug for C-c C-s i. + Fixed a wrong call to `hm--html-add-only-description-entry'. + Fixed a bug in the argument list of hm--html-add-tags-to-region. + Fixed a bug in `hm--html-add-tags-to-region', which was caused by the + indentation. + Fixed a bug in `hm--html-add-relative-link-to-region' and + `hm--html-add-relative-link'. + Replaced `hm--html-file-relative-name' with `file-relative-name'. + Changed the font-lock stuff. It uses now the property list of + `font-lock-defaults' and the three keyword lists + 'html-font-lock-keywords', `html-font-lock-keywords-1' and + `html-font-lock-keywords-2'. + Fixed a bug in the drag and drop variables. + Changed the drag and drop command, so that it could be called + also from a menu. + Added the drag and drop command to the pop up menus. 15.08.96: The items of the menu "Set popup menu" are now radio items. -- BUILDED the version 5.0 of the package diff -r b88636d63495 -r 8fc7fe29b841 lisp/hm--html-menus/README --- a/lisp/hm--html-menus/README Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/hm--html-menus/README Mon Aug 13 08:50:29 2007 +0200 @@ -1,4 +1,4 @@ -This README file describes the emacs lisp package hm--html-menus-5.0. +This README file describes the emacs lisp package hm--html-menus-5.1. The package provides functions and various popup and pulldown menus for a html mode called hm--html-mode, a mode for writing html pages. @@ -9,11 +9,8 @@ interface, which makes it very easy to insert links or images, by just clicking on them. -Look at the file NEWS, to see what is new in this release. One of the -main changes is, that it is no longer based on the html-mode.el -package from Marc Andreessen. Therefore the name of the mode has -changed to hm--html-mode and also the way to install the package is a -little bit different. So please read the installtion hints CAREFULLY! +Look at the file NEWS, to see what is new in this release. Some +of the major changes are also listed in the ANNOUNCEMENT file. You should (but don't need) also get the w3 package from: @@ -23,17 +20,24 @@ and epoch. -This package is tested with the xemacs 19.14 and the emacs 19.30 on -Suns with SunOS 4.1.3 and 5.5 and on PC's with linux. But it should -work also on other (possibly only UNIX ?) platforms. +This package is tested with the xemacs 19.15 on Suns with SunOS 5.5 +and on PC's with linux. But it should work also on other (possibly +only UNIX ?) platforms. -Read the file README-EMACS-19, if you want to use this package with -GNU Emacs 19. +NOTE: The current release isn't tested with the Emacs 19 (5.0 is but +5.1 isn't). One of the next releases in the near future :-) will be a +bug fix only release for the Emacs 19. So please report any bugs to +muenkel@tnt.uni-hannover.de to shorten the time until the Emacs 19 +related bugs are fixed. + +Read the file README-EMACS-19, if you want to use this package with +GNU Emacs 19. Thanks to Richard Stallman, who has helped me to port this package to the Emacs 19 and thanks to John Ladwig, who has corrected a lot of the -text and comments in this package and to all the other people, who had -provided code, ideas, bug fixes or bug reports for this package. +text and comments in this package and to all the other people like +Jerry G. DeLapp, Andreas Ernst and so on, who had provided code, +ideas, bug fixes or bug reports for this package. The package consists of the following files: @@ -48,6 +52,7 @@ hm--html.el : provides functions to write html pages; some of these functions are similar to functions of the html-mode.el; +hm--html-indentation.el : provides the indentation stuff; hm--html-keys.el : provides the new keybindings; hm--html-menu.el : provides the menus; hm--html-mode.el : provides the functions for the definition @@ -57,6 +62,8 @@ choose this as system configuration file; hm--html-drag-and-drop.el : defines the HTML- specific functions for the drag and drop interface; +hm--html-indentation.el : defines functions for the indentation of + HTML elements; hm--date.el : defines the function hm--date, which returns the date in the format "day-month-year" like "30-Jun-1993". @@ -72,14 +79,15 @@ with this mode you can expand templates, which are described in the file templates-syntax.doc (look at the files - command-description.tmpl and frame.tmpl for - examples); + command-description.tmpl and + frame.html.tmpl for examples); templates can be expanded automatically, if you include a file with templates via the - html pulldown menu item "Templates ..."; -command-description.tmpl : Templatefile for the use with the + html pulldown menu item "Templates ..." + or with the item "Templates (fixed dirs)..."; +command-description.html.tmpl : Templatefile for the use with the tmpl-minor-mode; -frame.tmpl : Templatefile, provides a simple frame; +frame.html.tmpl : Templatefile, provides a simple frame; @@ -146,8 +154,8 @@ It could also be, that you've already the autoload lines for the w3 package in your emacs. -3. Set the environment variable HTML_CONFIG_FILE to the html system - configuration file i.e.: +3. Set (if you want) the environment variable HTML_CONFIG_FILE + to the html system configuration file i.e.: setenv HTML_CONFIG_FILE /usr/xemacs/lisp/hm--html-configuration.el 4. Set (if you want) the environment variable HTML_USER_CONFIG_FILE to @@ -158,11 +166,20 @@ 5. Check the files hm--html-configuration.el and .hm--html-configuration.el whether all variables are set suitable for - you and your site or not. You can make changes in both of these files. + you and your site or not. You can make changes in both of these files + and you can also create a site specific configuration file, called + hm--html-site-config-file.el and specified by the lisp variable + hm--html-site-config-file or the environment variable + HTML_SITE_CONFIG_FILE, and put your site specific settings in this + file. A site specific configuration file is useful, if you're a + system administrator and want to make site specific settings + without changing a file of this package or use the normal emacs + configuration files. Note that .hm--html-configuration.el precedes the settings in - hm--html-configuration.el, because it is the user specific - configuration file. So you should made site specific changes in - hm--html-configuration.el. + hm--html-site-config-file.el, which precedes the settings in + hm--html-configuration.el (user specific configuration overwrites + site specific configuration and site specific configuration + overwrites the settings made by the package). Look at first at the following variables: @@ -176,7 +193,7 @@ 6. If you want to use templatefiles, you should put these files in the directory to which `hm--html-template-dir' points. - You can use the file command-description.tmpl as + You can use the file command-description.html.tmpl as an example. 7. If you don't want to use the feature of adding html comments @@ -237,8 +254,9 @@ it should be, but at the moment I've not the time to make a better one. -There is also a html documentation about the package. You can find it on: -http://www.tnt.uni-hannover.de:80/data/info/www/tnt/soft/info/www/html-editors/hm--html-menus/overview.html +There is also a (small) html documentation about the package. You can +find it on: +http://www.tnt.uni-hannover.de/~muenkel/software/own/hm--html-menus/overview.html Please send any bug reports, fixes or comments to diff -r b88636d63495 -r 8fc7fe29b841 lisp/hm--html-menus/adapt.el --- a/lisp/hm--html-menus/adapt.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/hm--html-menus/adapt.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,4 +1,4 @@ -;;; $Id: adapt.el,v 1.1.1.2 1996/12/18 03:46:45 steve Exp $ +;;; $Id: adapt.el,v 1.2 1997/02/16 01:29:07 steve Exp $ ;;; ;;; Copyright (C) 1993, 1994, 1995 Heiko Muenkel ;;; email: muenkel@tnt.uni-hannover.de @@ -312,6 +312,10 @@ minor-mode-map-alist)))) )) ) + + (if (not (fboundp 'redraw-modeline)) + (defalias 'redraw-modeline 'force-mode-line-update)) + )) diff -r b88636d63495 -r 8fc7fe29b841 lisp/hm--html-menus/command-description.html.tmpl Binary file lisp/hm--html-menus/command-description.html.tmpl has changed diff -r b88636d63495 -r 8fc7fe29b841 lisp/hm--html-menus/frame.html.tmpl Binary file lisp/hm--html-menus/frame.html.tmpl has changed diff -r b88636d63495 -r 8fc7fe29b841 lisp/hm--html-menus/hm--html-configuration.el --- a/lisp/hm--html-menus/hm--html-configuration.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/hm--html-menus/hm--html-configuration.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,8 +1,8 @@ ;;; hm--html-configuration.el - Configurationfile for the html-mode ;;; -;;; $Id: hm--html-configuration.el,v 1.1.1.2 1996/12/18 03:46:47 steve Exp $ +;;; $Id: hm--html-configuration.el,v 1.2 1997/02/16 01:29:08 steve Exp $ ;;; -;;; Copyright (C) 1993, 1994, 1995, 1996 Heiko Muenkel +;;; Copyright (C) 1993 - 1997 Heiko Muenkel ;;; email: muenkel@tnt.uni-hannover.de ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -49,6 +49,11 @@ \"HTML_USER_CONFIG_FILE\" is set. Example value: \"~/.hm--html-configuration.el\".") +;;; The site specific config file +(defvar hm--html-site-config-file nil + "*The location of a site specific config file. +This variable will only be used, if no environment variable +\"HTML_SITE_CONFIG_FILE\" is set.") ;;; Chose the initial popup menu (defvar hm--html-expert nil @@ -309,15 +314,25 @@ ;;; For the Templates (defvar hm--html-template-dir "/data/info/www/tnt/guide/templates" - "*A directory with templatefiles") + "*A directory with templatefiles. +It is now also possible to use it as a list of directories. +Look at the variable `tmpl-template-dir-list' for further descriptions.") -(if (not (file-exists-p hm--html-template-dir)) +(if (listp hm--html-template-dir) + (unless (file-exists-p (car hm--html-template-dir)) + ;; Use a system directory, if the above one doesn't exist + ;; This may only be useful, in the XEmacs >= 19.12 + (setq hm--html-template-dir (cons (concat data-directory + "../lisp/hm--html-menus/") + hm--html-template-dir))) + (unless (file-exists-p hm--html-template-dir) ;; Use a system directory, if the above one doesn't exist - ;; This is only useful, in the XEmacs 19.12 + ;; This may only be useful, in the XEmacs >= 19.12 (setq hm--html-template-dir (concat data-directory - "../lisp/hm--html-menus/"))) + "../lisp/hm--html-menus/")))) -(defvar hm--html-frame-template-file (concat hm--html-template-dir +(defvar hm--html-frame-template-file (concat data-directory + "../lisp/hm--html-menus/" "frame.tmpl") "File, which is used as template for a html frame.") @@ -326,6 +341,8 @@ tmpl-minor-mode.el from Heiko Muenkel (muenkel@tnt.uni-hannover.de), which is distributed with the package hm--html-menus.") +(defvar hm--html-template-filter-regexp ".*\\.html\\.tmpl$" + "*Regexp for filtering out non template files in a directory.") ;;; for deleting the automounter path-prefix (defvar hm--html-delete-wrong-path-prefix '("/tmp_mnt" "/phys/[^/]+") @@ -371,36 +388,50 @@ drag and drop.") (defvar hm--html-idd-actions - '((nil (((idd-major-mode-p . dired-mode) - (idd-dired-file-on-line-p . ".*\\.\\(gif\\)\\|\\(jpq\\)")) + '((nil (((idd-if-major-mode-p . dired-mode) + (idd-if-dired-file-on-line-p . ".*\\.\\(gif\\)\\|\\(jpg\\)")) hm--html-idd-add-include-image-from-dired-line) - (((idd-major-mode-p . dired-mode) - (idd-dired-no-file-on-line-p . nil)) + (((idd-if-major-mode-p . dired-mode) + (idd-if-dired-no-file-on-line-p . nil)) hm--html-idd-add-file-link-to-file-on-dired-line) - (((idd-major-mode-p . dired-mode) - (idd-dired-no-file-on-line-p . t)) + (((idd-if-major-mode-p . dired-mode) + (idd-if-dired-no-file-on-line-p . t)) hm--html-idd-add-file-link-to-directory-of-buffer) - (((idd-major-mode-p . w3-mode) - (idd-url-at-point-p . t)) + (((idd-if-major-mode-p . w3-mode) + (idd-if-url-at-point-p . t)) hm--html-idd-add-html-link-from-w3-buffer-point) - (((idd-major-mode-p . w3-mode)) + (((idd-if-major-mode-p . w3-mode)) hm--html-idd-add-html-link-to-w3-buffer) - (((idd-local-file-p . t)) + (((idd-if-local-file-p . t)) hm--html-idd-add-file-link-to-buffer))) - "The action list for the source mode `hm--html-mode'. + "The action list for the destination mode `hm--html-mode'. Look at the description of the variable idd-actions") ;;; The font lock keywords -(defvar hm--html-font-lock-keywords +(defconst hm--html-font-lock-keywords-1 (list - '("\\(\\)\\|\\(<[^>]*>\\)+" . font-lock-comment-face) - '("[Hh][Rr][Ee][Ff]=\"\\([^\"]*\\)\"" 1 font-lock-string-face t) - '("[Ss][Rr][Cc]=\"\\([^\"]*\\)\"" 1 font-lock-string-face t)) + '("" . font-lock-comment-face) + '("<[^>]*>" . font-lock-keyword-face) + '("<[^>=]*href[ \t\n]*=[ \t\n]*\"\\([^\"]*\\)\"" 1 font-lock-string-face t) + '("<[^>=]src[ \t\n]*=[ \t\n]*\"\\([^\"]*\\)\"" 1 font-lock-string-face t)) + "Subdued level highlighting for hm--html-mode.") + +(defconst hm--html-font-lock-keywords-2 + (append hm--html-font-lock-keywords-1 + (list + '(">\\([^<]*\\)" 1 font-lock-reference-face) + '("\\([^<]*\\)" 1 bold) + '("\\([^<]*\\)" 1 italic) + )) + "Gaudy level highlighting for hm--html-mode.") + +(defvar hm--html-font-lock-keywords hm--html-font-lock-keywords-1 "Default expressions to highlight in the hm--html-mode.") + ;;; The Prefix- Key for the keytables (defvar hm--html-minor-mode-prefix-key "\C-z" "The prefix key for the keytables in the `hm--html-minor-mode'.") @@ -440,6 +471,34 @@ Linux : (setq html-sigusr1-signal-value 10))") +;;; indentation + +(defvar hm--html-disable-indentation nil + "*Set this to t, if you want to disable the indentation in the hm--html-mode. +And may be send me (muenkel@tnt.uni-hannover.de) a note, why you've +done this.") + +(defvar hm--html-inter-tag-indent 2 + "*The indentation after a start tag.") + +(defvar hm--html-comment-indent 5 + "*The indentation of a comment.") + +(defvar hm--html-intra-tag-indent 2 + "*The indentation after the start of a tag.") + +(defvar hm--html-tag-name-alist + '(("!--" (:hm--html-one-element-tag t)) + ) + "An alist with tag names known by the `hm--html-mode'. +CURRENTLY THIS LIST CONTAINS NOT ALL TAGS!!!!. + +It is used to determine, if a tag is a one element tag or not. + +In the future it should also be used to get possible parameters of +the tag.") + + ;;; Announce the feature hm--html-configuration (provide 'hm--html-configuration) diff -r b88636d63495 -r 8fc7fe29b841 lisp/hm--html-menus/hm--html-drag-and-drop.el --- a/lisp/hm--html-menus/hm--html-drag-and-drop.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/hm--html-menus/hm--html-drag-and-drop.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,6 +1,6 @@ -;;; $Id: hm--html-drag-and-drop.el,v 1.1.1.1 1996/12/18 03:46:48 steve Exp $ +;;; $Id: hm--html-drag-and-drop.el,v 1.2 1997/02/16 01:29:08 steve Exp $ ;;; -;;; Copyright (C) 1996 Heiko Muenkel +;;; Copyright (C) 1996, 1997 Heiko Muenkel ;;; email: muenkel@tnt.uni-hannover.de ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -35,133 +35,133 @@ (require 'internal-drag-and-drop) (require 'cl) -(defun hm--html-first-non-matching-position (string1 string2) - "Compares both strings and returns the first position, which is not equal." - (let ((n 0) - (max-n (min (length string1) (length string2))) - (continue t)) - (while (and continue (< n max-n)) - (when (setq continue (= (aref string1 n) (aref string2 n))) - (setq n (1+ n)))) - n)) +;(defun hm--html-first-non-matching-position (string1 string2) +; "Compares both strings and returns the first position, which is not equal." +; (let ((n 0) +; (max-n (min (length string1) (length string2))) +; (continue t)) +; (while (and continue (< n max-n)) +; (when (setq continue (= (aref string1 n) (aref string2 n))) +; (setq n (1+ n)))) +; n)) -(defun hm--html-count-subdirs (directory) - "Returns the number of subdirectories of DIRECTORY." - (let ((n 0) - (max-n (1- (length directory))) - (count 0)) - (while (< n max-n) - (when (= ?/ (aref directory n)) - (setq count (1+ count))) - (setq n (1+ n))) - (when (and (not (= 0 (length directory))) - (not (= ?/ (aref directory 0)))) - (setq count (1+ count))) - count)) +;(defun hm--html-count-subdirs (directory) +; "Returns the number of subdirectories of DIRECTORY." +; (let ((n 0) +; (max-n (1- (length directory))) +; (count 0)) +; (while (< n max-n) +; (when (= ?/ (aref directory n)) +; (setq count (1+ count))) +; (setq n (1+ n))) +; (when (and (not (= 0 (length directory))) +; (not (= ?/ (aref directory 0)))) +; (setq count (1+ count))) +; count)) -(defun hm--html-return-n-backwards (n) - "Returns a string with N ../" - (cond ((= n 0) "") - (t (concat "../" (hm--html-return-n-backwards (1- n)))))) +;(defun hm--html-return-n-backwards (n) +; "Returns a string with N ../" +; (cond ((= n 0) "") +; (t (concat "../" (hm--html-return-n-backwards (1- n)))))) -(defun* hm--html-file-relative-name (file-name - &optional (directory default-directory)) - "Convert FILENAME to be relative to DIRECTORY (default: default-directory)." - (let* ((pos (hm--html-first-non-matching-position file-name directory)) - (backwards (hm--html-count-subdirs (substring directory pos))) - (relative-name (concat (hm--html-return-n-backwards backwards) - (substring file-name pos)))) - (if (= 0 (length relative-name)) - "./" - (if (= ?/ (aref relative-name 0)) - (if (= 1 (length relative-name)) - "./" - (substring relative-name 1)) - relative-name)))) +;(defun* hm--html-file-relative-name (file-name +; &optional (directory default-directory)) +; "Convert FILENAME to be relative to DIRECTORY (default: default-directory)." +; (let* ((pos (hm--html-first-non-matching-position file-name directory)) +; (backwards (hm--html-count-subdirs (substring directory pos))) +; (relative-name (concat (hm--html-return-n-backwards backwards) +; (substring file-name pos)))) +; (if (= 0 (length relative-name)) +; "./" +; (if (= ?/ (aref relative-name 0)) +; (if (= 1 (length relative-name)) +; "./" +; (substring relative-name 1)) +; relative-name)))) (defun hm--html-idd-add-include-image-from-dired-line (source destination) - "Inserts an include image tag at the SOURCE. + "Inserts an include image tag at the DESTINATION. The name of the image is on a line in a dired buffer. It is specified by the -destination." - (idd-set-point source) +SOURCE." + (idd-set-point destination) (if hm--html-idd-create-relative-links - (hm--html-add-image-top (hm--html-file-relative-name - (idd-get-dired-filename-from-line destination)) + (hm--html-add-image-top (file-relative-name + (idd-get-dired-filename-from-line source)) (file-name-nondirectory - (idd-get-dired-filename-from-line destination))) - (hm--html-add-image-top (idd-get-dired-filename-from-line destination) + (idd-get-dired-filename-from-line source))) + (hm--html-add-image-top (idd-get-dired-filename-from-line source) (file-name-nondirectory - (idd-get-dired-filename-from-line destination))))) + (idd-get-dired-filename-from-line source))))) -(defun hm--html-idd-add-link-to-region (link-object source) - "Inserts a link with the LINK-OBJECT in the SOURCE. +(defun hm--html-idd-add-link-to-region (link-object destination) + "Inserts a link with the LINK-OBJECT in the DESTINATION. It uses the region as the name of the link." - (idd-set-region source) + (idd-set-region destination) (hm--html-add-normal-link-to-region link-object) ) -(defun hm--html-idd-add-link (link-object source) - "Inserts a link with the LINK-OBJECT in the SOURCE." - (idd-set-point source) +(defun hm--html-idd-add-link (link-object destination) + "Inserts a link with the LINK-OBJECT in the DESTINATION." + (idd-set-point destination) (hm--html-add-normal-link link-object)) -(defun hm--html-idd-add-link-to-point-or-region (link-object source) - "Inserts a link with the LINK-OBJECT in the SOURCE. +(defun hm--html-idd-add-link-to-point-or-region (link-object destination) + "Inserts a link with the LINK-OBJECT in the DESTINATION. It uses the region as the name of the link, if the region was active -in the SOURCE." - (if (cdr (assoc ':region-active source)) - (hm--html-idd-add-link-to-region link-object source) - (hm--html-idd-add-link link-object source))) +in the DESTINATION." + (if (cdr (assoc ':region-active destination)) + (hm--html-idd-add-link-to-region link-object destination) + (hm--html-idd-add-link link-object destination))) (defun hm--html-idd-add-file-link-to-file-on-dired-line (source destination) - "Inserts a file link in SOURCE to the file on the dired line of DESTINATION." - (idd-set-point source) + "Inserts a file link in DESTINATION to the file on the dired line of SOURCE." + (idd-set-point destination) (if hm--html-idd-create-relative-links (hm--html-idd-add-link-to-point-or-region - (hm--html-file-relative-name - (idd-get-dired-filename-from-line destination)) - source) + (file-relative-name + (idd-get-dired-filename-from-line source)) + destination) (hm--html-idd-add-link-to-point-or-region - (concat "file://" (idd-get-dired-filename-from-line destination)) - source))) + (concat "file://" (idd-get-dired-filename-from-line source)) + destination))) (defun hm--html-idd-add-file-link-to-buffer (source destination) - "Inserts a file link at SOURCE to the file of DESTINATION." - (idd-set-point source) + "Inserts a file link at DESTINATION to the file of the SOURCE buffer." + (idd-set-point destination) (if hm--html-idd-create-relative-links (hm--html-idd-add-link-to-point-or-region - (hm--html-file-relative-name (idd-get-local-filename destination)) - source) + (file-relative-name (idd-get-local-filename source)) + destination) (hm--html-idd-add-link-to-point-or-region - (concat "file://" (idd-get-local-filename destination)) - source))) + (concat "file://" (idd-get-local-filename source)) + destination))) (defun hm--html-idd-add-file-link-to-directory-of-buffer (source destination) - "Inserts a file link at SOURCE to the directory of the DESTINATION buffer." - (idd-set-point source) + "Inserts a file link at DESTINATION to the directory of the SOURCE buffer." + (idd-set-point destination) (if hm--html-idd-create-relative-links (hm--html-idd-add-link-to-point-or-region - (hm--html-file-relative-name (idd-get-directory-of-buffer destination)) - source) + (file-relative-name (idd-get-directory-of-buffer source)) + destination) (hm--html-idd-add-link-to-point-or-region - (concat "file://" (idd-get-directory-of-buffer destination)) - source))) + (concat "file://" (idd-get-directory-of-buffer source)) + destination))) (defun hm--html-idd-add-html-link-to-w3-buffer (source destination) - "Inserts a link at SOURCE to the w3 buffer specified by the DESTINATION. + "Inserts a link at DESTINATION to the w3 buffer specified by the SOURCE. Note: Relative links are currently not supported for this function." - (idd-set-point source) - (hm--html-idd-add-link-to-point-or-region (idd-get-buffer-url destination) - source)) + (idd-set-point destination) + (hm--html-idd-add-link-to-point-or-region (idd-get-buffer-url source) + destination)) (defun hm--html-idd-add-html-link-from-w3-buffer-point (source destination) - "Inserts a link at SOURCE to a lin in the w3 buffer. -The link in the w3-buffer is specified by the DESTINATION. + "Inserts a link at DESTINATION to a lin in the w3 buffer. +The link in the w3-buffer is specified by the SOURCE. Note: Relative links are currently not supported for this function." - (idd-set-point source) - (hm--html-idd-add-link-to-point-or-region (idd-get-url-at-point destination) - source)) + (idd-set-point destination) + (hm--html-idd-add-link-to-point-or-region (idd-get-url-at-point source) + destination)) ;;; Announce the feature hm--html-drag-and-drop (provide 'hm--html-drag-and-drop) diff -r b88636d63495 -r 8fc7fe29b841 lisp/hm--html-menus/hm--html-indentation.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/hm--html-menus/hm--html-indentation.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,251 @@ +;;; hm--html-indentation.el +;;; v1.00; 9-Feb-1997 +;;; Copyright (C) 1997 Heiko Muenkel +;;; email: muenkel@tnt.uni-hannover.de +;;; +;;; 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 1, 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; if not, write to the Free Software +;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +;;; +;;; +;;; Description: +;;; +;;; Defines functions for the indentation. +;;; +;;; Installation: +;;; +;;; Put this file in one of your load path directories. +;;; + +(defun hm--html-point-between-strings-p (string-1 + string-2 + &optional boundary) + "Returns non nil, if the current point is between STRING-1 and STRING-2." + (when (and (re-search-backward (concat "\\(" + (regexp-quote string-1) + "\\)\\|\\(" + (regexp-quote string-2) + "\\)") + boundary + t) + (match-string 1)) + (point))) + +(defun hm--html-in-comment-p () + "Checks if the current point is in a comment block. +If this is the case, then the start point of the comment is returned. +Otherwise nil is returned." + (save-excursion + (hm--html-point-between-strings-p comment-start comment-end))) + +(defun hm--html-previous-line-start () + "Returns the start of the previous non blank line." + (save-excursion + (beginning-of-line) + (skip-chars-backward " \t\n") + (beginning-of-line) + (point))) + +(defun hm--html-look-at-comment-end-p () + "T, if the current line starts with the comment end." + (looking-at (regexp-quote comment-end))) + +(defun hm--html-column-of-previous-regexp (regexp) + "Returns the column of the start of the previous REGEXP. +It searches backward until the REGEXP is found. If no +REGEXP is found, then it returns 0." + (save-excursion + (if (re-search-backward regexp nil t) + (current-column) + 0))) + +(defun hm--html-look-at-end-tag-p () + "Returns the end tag name if the point is at the start of an end tag. +nil is returned otherwise." + (when (looking-at "\\(<[ \t\n]*/[ \t\n]*\\)\\([^ \t\n>]+\\)") + (match-string 2))) + + +(defun hm--html-previous-line-indentation () + "Returns the indentation of the previous non blank line." + (save-excursion + (beginning-of-line) + (skip-chars-backward " \t\n") + (back-to-indentation) + (current-column))) + +(defun hm--html-in-tag-p () + "Checks if the current point is in a tag. +If this is the case, then the start point of the tag is returned. +Otherwise nil is returned." + (save-excursion + (let ((start (re-search-backward "\\(<\\)\\|\\(>\\)" nil t))) + (when (match-string 1) + start)))) + +(defun hm--html-return-beginning-of-line () + "Returns the beginning of the current line." + (save-excursion + (beginning-of-line) + (point))) + +(defun hm--html-return-end-of-line () + "Returns the end of the current line." + (save-excursion + (end-of-line) + (point))) + +(defun hm--html-paramter-column-in-line-after-point (point) + "Returns the column where the second non blank text after POINT starts. +This point must be in the line with POINT otherwise it returns nil." + (save-excursion + (goto-char point) + (when (re-search-forward "<[ \t]*[^ \t]+[ \t]" + (hm--html-return-end-of-line) + t) + (when (looking-at "[^\n]") + (current-column))))) + +(defun hm--html-column-of-point (point) + "Returns the column of the POINT." + (save-excursion + (goto-char point) + (current-column))) + +(defun hm--html-search-previous-tag-in-current-line () + "Searches tags from the `(point)' to the beginning of the line. +It returns nil, if there is no tag and the tag name, if there is +a tag. The tag name contains a leading /, if it is an end tag." + (when (re-search-backward ">" (hm--html-return-beginning-of-line) t) + (when (re-search-backward + "\\(<[ \t\n]*\\(/?\\)\\([ \t\n]*[^> \t\n]+\\)[^>]*\\)" + nil + t) + (concat (match-string 2) (match-string 3))))) + +(defun hm--html-search-start-tag (tag-name until) + "Searches start tag backwards from the current point until the point UNTIL. +The name of the tag is TAG-NAME. After this function the point is at UNTIL + (then it returns nil) or at the start of the tag, then it returns t." + (if (re-search-backward (concat "\\(<[ \t\n]*\\)\\(/?\\)\\(" + tag-name + "\\)\\([^>]*>\\)") until t) + (if (string= "/" (match-string 2)) + (progn + (hm--html-search-start-tag tag-name until) + (hm--html-search-start-tag tag-name until)) + t) + (goto-char until) + nil)) + +(defun hm--html-is-one-element-tag-p (tag-name) + "Returns t, if the tag with the tag-name is a one element tag." + (assoc :hm--html-one-element-tag + (cdr (assoc* tag-name hm--html-tag-name-alist :test 'string=)))) + +(defun hm--html-calculate-indent-according-to-previous-tags () + "Calculate the indent according to the previous tags in this line. +If no tags are found, then nil is returned." + (save-excursion + (let ((tag (hm--html-search-previous-tag-in-current-line))) + (cond ((not tag) nil) + + ((eq ?/ (elt tag 0)) ; end tag found + (if (hm--html-search-start-tag + (substring tag 1) + (point-min)) + (or (hm--html-calculate-indent-according-to-previous-tags) + (progn + (backward-to-indentation 0) + (current-column))) + 0)) ; it may be that the current indentation is better here + + ((hm--html-is-one-element-tag-p tag) ; one element tag + (or (hm--html-calculate-indent-according-to-previous-tags) + (progn + (backward-to-indentation 0) + (current-column)))) + + (t ; start tag found + (+ (current-column) hm--html-inter-tag-indent)))))) + + +(defun hm--html-calculate-indent () + "Calculate the indentation of the current line." + (let ((match-point) + (tag)) + (save-excursion + (beginning-of-line) + (back-to-indentation) + (cond ((eq (count-lines (point-min) (point)) 0) 0) ; Filestart + + ((setq match-point (hm--html-in-comment-p)) ; in a comment + (if (>= match-point (hm--html-previous-line-start)) ; 1. line + (if (hm--html-look-at-comment-end-p) + (hm--html-column-of-previous-regexp + (regexp-quote comment-start)) + (+ (hm--html-column-of-previous-regexp + (regexp-quote comment-start)) + hm--html-comment-indent)) + (if (hm--html-look-at-comment-end-p) + (- (hm--html-previous-line-indentation) + hm--html-comment-indent) + (hm--html-previous-line-indentation)))) + + ((setq tag (hm--html-look-at-end-tag-p)) ; look at end tag + (hm--html-search-start-tag tag (point-min)) + (current-column)) + + ((looking-at ">") + (hm--html-column-of-previous-regexp "<")) + + ((setq match-point (hm--html-in-tag-p)) + (if (>= match-point (hm--html-previous-line-start)) ; 1. line + (or (hm--html-paramter-column-in-line-after-point match-point) + (+ (hm--html-column-of-point match-point) + hm--html-intra-tag-indent)) + (hm--html-previous-line-indentation))) + + (t (or (save-excursion ; check previous line + (skip-chars-backward " \t\n") + (hm--html-calculate-indent-according-to-previous-tags)) + (hm--html-previous-line-indentation))) + )))) + +(defun hm--html-indent-line () + "Indent the current line line." + (interactive) + (unless hm--html-disable-indentation + (indent-line-to (max 0 (hm--html-calculate-indent))))) + +;;; Indentation + +(defun hm--html-indent-region (begin end) + "Indents the region between BEGIN and END according to the major mode." + (interactive "d\nm") + (when (< end begin) + (let ((a end)) + (setq end begin) + (setq begin a))) + (save-excursion + (goto-char begin) + (let ((old-point)) + (while (and (<= (point) end) + (not (eq (point) old-point))) + (setq old-point (point)) + (indent-according-to-mode) + (forward-line) + )))) + + +(provide 'hm--html-indentation) diff -r b88636d63495 -r 8fc7fe29b841 lisp/hm--html-menus/hm--html-keys.el --- a/lisp/hm--html-menus/hm--html-keys.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/hm--html-menus/hm--html-keys.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,11 +1,11 @@ -;;; $Id: hm--html-keys.el,v 1.1.1.2 1996/12/18 03:46:48 steve Exp $ +;;; $Id: hm--html-keys.el,v 1.2 1997/02/16 01:29:08 steve Exp $ ;;; -;;; Copyright (C) 1995, 1996 Heiko Muenkel +;;; Copyright (C) 1995, 1996, 1997 Heiko Muenkel ;;; email: muenkel@tnt.uni-hannover.de ;;; ;;; 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 1, or (at your option) +;;; the Free Software Foundation; either version 2, or (at your option) ;;; any later version. ;;; ;;; This program is distributed in the hope that it will be useful, @@ -27,7 +27,6 @@ ;;; Put this file in one of your load path directories. ;;; -;; This is necessary to get the definition of hm--html-mode-prefix-key. (require 'hm--html-configuration) (if (adapt-emacs19p) @@ -192,7 +191,7 @@ (if hm--html-region-structure-map () (setq hm--html-region-structure-map (make-sparse-keymap)) - (define-key hm--html-noregion-structure-map + (define-key hm--html-region-structure-map "i" 'hm--html-add-list-or-menu-item-to-region) (define-key hm--html-region-structure-map "m" 'hm--html-add-menu-to-region) (define-key hm--html-region-structure-map "u" 'hm--html-add-list-to-region) diff -r b88636d63495 -r 8fc7fe29b841 lisp/hm--html-menus/hm--html-menu.el --- a/lisp/hm--html-menus/hm--html-menu.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/hm--html-menus/hm--html-menu.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,8 +1,8 @@ ;;; hm--html-menu --- A menu for the hm--html-mode. ;;; -;;; $Id: hm--html-menu.el,v 1.1.1.2 1996/12/18 03:46:46 steve Exp $ +;;; $Id: hm--html-menu.el,v 1.2 1997/02/16 01:29:08 steve Exp $ ;;; -;;; Copyright (C) 1993, 1994, 1995, 1996 Heiko Muenkel +;;; Copyright (C) 1993 - 1997 Heiko Muenkel ;;; email: muenkel@tnt.uni-hannover.de ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -60,6 +60,10 @@ ("Anchors" ["Relative link..." hm--html-add-relative-link t] ["General link..." hm--html-add-normal-link t] + ["Drag & Drop" + idd-start-mouse-drag-and-drop + :active t + :keys "\\[idd-mouse-drag-and-drop]"] "----" ["Html link..." hm--html-add-html-link t] ["Info link..." hm--html-add-info-link t] @@ -206,6 +210,10 @@ ["Top aligned image..." hm--html-add-image-top t] ["Middle aligned image..." hm--html-add-image-middle t] ["Bottom aligned image..." hm--html-add-image-bottom t] + ["Drag & Drop" + idd-start-mouse-drag-and-drop + :active t + :keys "\\[idd-mouse-drag-and-drop]"] "----" ["Applet..." hm--html-add-applet t] ["Parameter..." hm--html-add-applet-parameter t] @@ -248,6 +256,10 @@ '("HTML No-region Novice Menu" ("Anchors" ["Relative link..." hm--html-add-relative-link t] + ["Drag & Drop" + idd-start-mouse-drag-and-drop + :active t + :keys "\\[idd-mouse-drag-and-drop]"] "----" ["Html link..." hm--html-add-html-link t] ["File link..." hm--html-add-file-link t] @@ -280,6 +292,10 @@ ("Anchors" ["Relative link..." hm--html-add-relative-link-to-region t] ["General link..." hm--html-add-normal-link-to-region t] + ["Drag & Drop" + idd-start-mouse-drag-and-drop + :active t + :keys "\\[idd-mouse-drag-and-drop]"] "----" ["Html link..." hm--html-add-html-link-to-region t] ["Info link..." hm--html-add-info-link-to-region t] @@ -411,6 +427,10 @@ '("HTML Region Novice Menu" ("Anchors" ["Relative link..." hm--html-add-relative-link-to-region t] + ["Drag & Drop" + idd-start-mouse-drag-and-drop + :active t + :keys "\\[idd-mouse-drag-and-drop]"] "----" ["Html link..." hm--html-add-html-link-to-region t] ["File link..." hm--html-add-file-link-to-region t] @@ -454,7 +474,18 @@ ; ["Marcs menu" hm--html-use-marcs-menu t] ) ["Reload config files" hm--html-load-config-files t] + ["Templates (fixed dirs) ..." + hm--html-insert-template-from-fixed-dirs + t] ["Templates ..." hm--html-insert-template t] + ["Drag & Drop" + idd-start-mouse-drag-and-drop + :active t + :keys "\\[idd-mouse-drag-and-drop]"] + ["Drag & Drop Help" + idd-start-help-mouse-drag-and-drop + :active t + :keys "\\[idd-help-mouse-drag-and-drop]"] "----" ["Remove numeric names" hm--html-remove-numeric-names t] ["Quotify hrefs" hm--html-quotify-hrefs t] diff -r b88636d63495 -r 8fc7fe29b841 lisp/hm--html-menus/hm--html-mode.el --- a/lisp/hm--html-menus/hm--html-mode.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/hm--html-menus/hm--html-mode.el Mon Aug 13 08:50:29 2007 +0200 @@ -2,14 +2,14 @@ ;;; ;;; Keywords: hypermedia languages help docs wp ;;; -;;; $Id: hm--html-mode.el,v 1.1.1.1 1996/12/18 03:46:48 steve Exp $ +;;; $Id: hm--html-mode.el,v 1.2 1997/02/16 01:29:10 steve Exp $ ;;; -;;; Copyright (C) 1996 Heiko Muenkel +;;; Copyright (C) 1996, 1997 Heiko Muenkel ;;; email: muenkel@tnt.uni-hannover.de ;;; ;;; 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 1, or (at your option) +;;; the Free Software Foundation; either version 2, or (at your option) ;;; any later version. ;;; ;;; This program is distributed in the hope that it will be useful, @@ -64,6 +64,7 @@ (require 'hm--date) (require 'hm--html) (hm--html-load-config-files) +(require 'hm--html-indentation) (require 'hm--html-menu) (require 'hm--html-drag-and-drop) ;(hm--html-load-config-files) ; Load the system and user configuration files @@ -75,7 +76,7 @@ (defconst hm--html-menus-package-name "hm--html-menus") -(defconst hm--html-menus-package-version "5.0") +(defconst hm--html-menus-package-version "5.1") ;;; Generate the help buffer faces @@ -89,9 +90,15 @@ (if hm--html-mode-syntax-table () (setq hm--html-mode-syntax-table (make-syntax-table)) - (modify-syntax-entry ?\" ". " hm--html-mode-syntax-table) - (modify-syntax-entry ?\\ ". " hm--html-mode-syntax-table) - (modify-syntax-entry ?' "w " hm--html-mode-syntax-table)) +; (modify-syntax-entry ?\" ". " hm--html-mode-syntax-table) +; (modify-syntax-entry ?\\ ". " hm--html-mode-syntax-table) +; (modify-syntax-entry ?' "w " hm--html-mode-syntax-table) + (modify-syntax-entry ?\\ "." hm--html-mode-syntax-table) + (modify-syntax-entry ?' "w" hm--html-mode-syntax-table) + (modify-syntax-entry ?< "(>" hm--html-mode-syntax-table) + (modify-syntax-entry ?> ")<" hm--html-mode-syntax-table) + (modify-syntax-entry ?\" "\"" hm--html-mode-syntax-table) + (modify-syntax-entry ?= "." hm--html-mode-syntax-table)) ;;; abbreviation table @@ -119,12 +126,27 @@ (setq major-mode 'hm--html-mode) (setq local-abbrev-table hm--html-mode-abbrev-table) (set-syntax-table hm--html-mode-syntax-table) + (make-local-variable 'comment-start) + (make-local-variable 'comment-end) + (setq comment-start "") + (make-local-variable 'sentence-end) + (setq sentence-end "[<>.?!][]\"')}]*\\($\\| $\\|\t\\| \\)[ \t\n]*") + (setq indent-line-function 'hm--html-indent-line) (setq idd-actions hm--html-idd-actions) (hm--install-html-menu hm--html-mode-pulldown-menu-name) (make-variable-buffer-local 'write-file-hooks) (add-hook 'write-file-hooks 'hm--html-maybe-new-date-and-changed-comment) - (make-local-variable 'font-lock-keywords) - (setq font-lock-keywords hm--html-font-lock-keywords) +; (make-local-variable 'font-lock-keywords) +; (setq font-lock-keywords-case-fold-search t) +; (setq font-lock-keywords hm--html-font-lock-keywords) + (put major-mode 'font-lock-defaults '((hm--html-font-lock-keywords + hm--html-font-lock-keywords-1 + hm--html-font-lock-keywords-2) + t + t + nil + nil + )) (run-hooks 'hm--html-mode-hook)) ;;;; Minor Modes diff -r b88636d63495 -r 8fc7fe29b841 lisp/hm--html-menus/hm--html.el --- a/lisp/hm--html-menus/hm--html.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/hm--html-menus/hm--html.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,6 +1,6 @@ -;;; $Id: hm--html.el,v 1.1.1.2 1996/12/18 03:46:47 steve Exp $ +;;; $Id: hm--html.el,v 1.2 1997/02/16 01:29:10 steve Exp $ ;;; -;;; Copyright (C) 1993, 1994, 1995, 1996 Heiko Muenkel +;;; Copyright (C) 1993 - 1997 Heiko Muenkel ;;; email: muenkel@tnt.uni-hannover.de ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -31,24 +31,14 @@ ;(require 'adapt) -;;; Indentation - -(defun hm--html-indent-region (begin end) - "Indents the region between BEGIN and END according to the major mode." - (when (< end begin) - (let ((a end)) - (setq end start) - (setq start a))) - (save-excursion - (goto-char begin) - (let ((old-point)) - (while (and (<= (point) end) - (not (eq (point) old-point))) - (setq old-point (point)) - (indent-according-to-mode) - (forward-line) - )))) - +(defun hm--html-set-marker-at-position (&optional position) + "Creates a new marker and set the marker at the POSITION. +If POSITION is nil, then the marker is set at the current point. +The return value is the marker." + (let ((marker (make-marker))) + (if position + (set-marker marker position) + (set-marker marker (point))))) ;;; Functions for adding html commands which consists of a start and a ;;; end tag and some text between them. (Basicfunctions) @@ -68,16 +58,12 @@ The second parameter is the string for the start tag and the fourth parameter is the string for the end tag. The third and fourth parameters are optional. The fifth parameter is optional. If it exists, it specifies a function which -inserts the sixth parameter (the middle-start-tag) between the start and the end -tag." -; (interactive "aFunction, which adds the HTML start tag: \n\ -;aFunction, which adds the HTML end tag: \n\ -;sThe HTML start tag: \n\ -;sThe HTML end tag: ") +inserts the sixth parameter (the middle-start-tag) between the start and the +end tag." (eval (list function-insert-start-tag start-tag)) (if function-insert-middle-start-tag (eval (list function-insert-middle-start-tag middle-start-tag))) - (let ((position (point))) + (let ((position (hm--html-set-marker-at-position (point)))) (if function-insert-middle-end-tag (eval (list function-insert-middle-end-tag middle-end-tag))) (if function-insert-end-tag @@ -89,8 +75,9 @@ start-tag function-insert-end-tag end-tag - &optional function-insert-middle-tag - &optional middle-tag) + &optional + function-insert-middle-tag + middle-tag) "Adds the start and the end html tag to the active region. The first parameter specifies the funtion which insert the start tag and the third parameter specifies the function which insert the end tag. @@ -99,16 +86,13 @@ The fifth parameter is optional. If it exists, it specifies a function which inserts the sixth parameter (the middle-tag) between the start and the end tag." -; (interactive "aFunction, which adds the html start tag: \n\ -;aFunction, which adds the html end tag: \n\ -;sThe HTML start tag: \n\ -;sThe HTML end tag: ") (save-window-excursion - (let ((start (region-beginning)) + (let ((start (hm--html-set-marker-at-position (region-beginning))) (end (region-end))) (goto-char end) (eval (list function-insert-end-tag end-tag)) (goto-char start) +; (backward-char (+ (length end-tag) (- end start))) (eval (list function-insert-start-tag start-tag)) (if function-insert-middle-tag (eval (list function-insert-middle-tag middle-tag))) @@ -140,7 +124,6 @@ (insert tag) (hm--html-indent-region start (point)) ) -; (html-maybe-deemphasize-region start (- (point) 1))) (insert "\n")) @@ -151,7 +134,6 @@ (let ((start (point))) (insert tag) (hm--html-indent-region start (point)))) -; (html-maybe-deemphasize-region start (- (point) 1)))) @@ -1177,7 +1159,9 @@ 'hm--html-insert-end-tag-with-newline "" 'hm--html-insert-start-tag - "
  • ")) + "
  • " + 'hm--html-insert-end-tag + "
    • ")) (defun hm--html-add-numberlist-to-region () "Adds the HTML tags for a numbered list to the region." @@ -1185,9 +1169,9 @@ (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline "
      " 'hm--html-insert-end-tag-with-newline - "
    " - 'hm--html-insert-start-tag - "
  • ")) + "")) +; 'hm--html-insert-start-tag +; "
  • ")) (defun hm--html-add-directory-list () @@ -1198,7 +1182,9 @@ 'hm--html-insert-end-tag-with-newline "" 'hm--html-insert-start-tag - "
  • ")) + "
  • " + 'hm--html-insert-end-tag + "
    • ")) (defun hm--html-add-directorylist-to-region () "Adds the HTML tags for a directory list to the region." @@ -1206,9 +1192,9 @@ (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline "" 'hm--html-insert-end-tag-with-newline - "" - 'hm--html-insert-start-tag - "
  • ")) + "")) +; 'hm--html-insert-start-tag +; "
  • ")) (defun hm--html-add-list () @@ -1219,7 +1205,9 @@ 'hm--html-insert-end-tag-with-newline "" 'hm--html-insert-start-tag - "
  • ")) + "
  • " + 'hm--html-insert-end-tag + "
    • ")) (defun hm--html-add-list-to-region () @@ -1228,20 +1216,20 @@ (hm--html-add-tags-to-region 'hm--html-insert-start-tag-with-newline "
      " 'hm--html-insert-end-tag-with-newline - "
    " - 'hm--html-insert-start-tag - "
  • ")) - - -(defun hm--html-add-menu () - "Adds the HTML tags for a menu." - (interactive) - (hm--html-add-tags 'hm--html-insert-start-tag-with-newline - "" - 'hm--html-insert-end-tag-with-newline - "" - 'hm--html-insert-start-tag - "
  • ")) + "")) +; 'hm--html-insert-start-tag +; "
  • ")) + + +;(defun hm--html-add-menu () +; "Adds the HTML tags for a menu." +; (interactive) +; (hm--html-add-tags 'hm--html-insert-start-tag-with-newline +; "" +; 'hm--html-insert-end-tag-with-newline +; "" +; 'hm--html-insert-start-tag +; "
  • ")) (defun hm--html-add-menu () @@ -1274,9 +1262,10 @@ Assumes we're at the end of a previous entry." (interactive) (hm--html-add-description-title) - (let ((position (point))) - (search-forward "") - (hm--html-add-only-description-entry) + (let ((position (point)) + (case-fold-search t)) + (search-forward "") + (hm--html-add-description-entry) (goto-char position))) @@ -1378,18 +1367,19 @@ "Searches for the old signature and deletes it, if the user want it" (save-excursion (goto-char (point-min)) - (if (search-forward (concat "
    " - "" nil t) - (point)))) - (if (yes-or-no-p "Delete the old signature (yes or no) ?") - (delete-region signature-start signature-end)))))) + (let ((case-fold-search t)) + (if (search-forward (concat "
    " + "" nil t) + (point)))) + (if (yes-or-no-p "Delete the old signature (yes or no) ?") + (delete-region signature-start signature-end))))))) (defun hm--html-set-point-for-signature () @@ -1398,17 +1388,18 @@ tries to use the point before the tag then the point before the tag and the the end of the file." (goto-char (point-max)) - (cond ((search-backward "" nil t) - (end-of-line 0) - (if (> (current-column) 0) - (newline 2))) - ((search-backward "" nil t) - (end-of-line 0) - (if (> (current-column) 0) - (newline 2))) - ((> (current-column) 0) - (newline 2)) - (t))) + (let ((case-fold-search t)) + (cond ((search-backward "" nil t) + (end-of-line 0) + (if (> (current-column) 0) + (newline 2))) + ((search-backward "" nil t) + (end-of-line 0) + (if (> (current-column) 0) + (newline 2))) + ((> (current-column) 0) + (newline 2)) + (t)))) (defun hm--html-add-signature () @@ -1467,10 +1458,11 @@ the tag . If this tag exists, the point is set to the position after this tag or the beginning of the file otherwise." (goto-char (point-min)) - (cond ((search-forward-regexp "" nil t) (newline)) - ((search-forward-regexp "" nil t) (newline)) - ((search-forward-regexp "" nil t) (newline)) - (t))) + (let ((case-fold-search t)) + (cond ((search-forward-regexp "" nil t) (newline)) + ((search-forward-regexp "" nil t) (newline)) + ((search-forward-regexp "" nil t) (newline)) + (t)))) (defun hm--html-add-title (title) @@ -1478,32 +1470,34 @@ (interactive "sTitle: ") (save-excursion (goto-char (point-min)) - (if (search-forward "" nil t) - (let ((point-after-start-tag (point))) - (if (not (search-forward "" nil t)) - nil - (goto-char (- (point) 8)) - (delete-backward-char (- (point) point-after-start-tag)) - (let ((start (point))) - (insert title " (" (hm--date) ")") - (goto-char start)))) - ;; Noch kein im Buffer vorhanden - (hm--html-set-point-for-title) - (hm--html-add-tags 'hm--html-insert-start-tag - "<TITLE>" - 'hm--html-insert-end-tag - "" - 'insert - (concat title " (" (hm--date) ")")) - (forward-char 8) - (newline 1) - ))) + (let ((case-fold-search t)) + (if (search-forward "" nil t) + (let ((point-after-start-tag (point))) + (if (not (search-forward "" nil t)) + nil + (goto-char (- (point) 8)) + (delete-backward-char (- (point) point-after-start-tag)) + (let ((start (point))) + (insert title " (" (hm--date) ")") + (goto-char start)))) + ;; Noch kein im Buffer vorhanden + (hm--html-set-point-for-title) + (hm--html-add-tags 'hm--html-insert-start-tag + "<TITLE>" + 'hm--html-insert-end-tag + "" + 'insert + (concat title " (" (hm--date) ")")) + (forward-char 8) + (newline 1) + )))) (defun hm--html-add-title-to-region () "Adds the HTML tags for a title to the region." (interactive) - (let ((title (buffer-substring (region-beginning) (region-end)))) + (let ((title (buffer-substring (region-beginning) (region-end))) + (case-fold-search t)) (save-excursion (goto-char (point-min)) (if (search-forward "" nil t) @@ -1531,7 +1525,8 @@ The tag <HTML> will be inserted at the beginning and </HTML> at the end of the file." (interactive) - (let ((new-cursor-position nil)) + (let ((new-cursor-position nil) + (case-fold-search t)) (save-excursion (goto-char (point-min)) (if (search-forward "<html>" nil t) @@ -1553,6 +1548,7 @@ The tags will be inserted after <HTML> or at the beginning of the file. The function also looks for the tags <BODY> and ." (interactive) + (let ((case-fold-search t)) (goto-char (point-min)) (if (search-forward "" nil t) (if (search-forward "" nil t) @@ -1586,7 +1582,7 @@ (hm--html-add-tags 'hm--html-insert-start-tag-with-newline "" 'hm--html-insert-end-tag-with-newline - ""))))) + "")))))) (defun hm--html-add-head-to-region () @@ -1602,6 +1598,7 @@ "Adds the HTML tags and in the buffer. The tags will be inserted before or at the end of the file." (interactive) + (let ((case-fold-search t)) (goto-char (point-max)) (if (search-backward "" nil t) (progn @@ -1626,7 +1623,7 @@ (if (not (= (current-column) 0)) (newline)) (hm--html-add-tags 'hm--html-insert-start-tag-with-newline "" - 'hm--html-insert-end-tag-with-newline "")))) + 'hm--html-insert-end-tag-with-newline ""))))) (defun hm--html-add-body-to-region () @@ -1644,21 +1641,22 @@ ; (if (> size 6) ; (message "The size must be a number from 1 to 6 !") (interactive "sTitle and Header String: ") - (hm--html-add-title title) - (save-excursion - (goto-char (point-min)) - (search-forward "" nil t) - (if (search-forward "" nil t) - (progn - (search-forward "" nil t) - (newline 1)) - (if (search-forward "" nil t) - (newline 1) - (if (string= (what-line) "Line 1") - (progn - (end-of-line) - (newline 1))))) - (hm--html-add-header 1 title))) + (let ((case-fold-search t)) + (hm--html-add-title title) + (save-excursion + (goto-char (point-min)) + (search-forward "" nil t) + (if (search-forward "" nil t) + (progn + (search-forward "" nil t) + (newline 1)) + (if (search-forward "" nil t) + (newline 1) + (if (string= (what-line) "Line 1") + (progn + (end-of-line) + (newline 1))))) + (hm--html-add-header 1 title)))) (defun hm--html-add-title-and-header-to-region () @@ -1679,17 +1677,18 @@ header and the signature. The parameter TITLE specifies the title and the header of the document." (interactive "sTitle and Header String: ") - (hm--html-add-html) - (hm--html-add-head) - (hm--html-add-body) - (hm--html-add-title-and-header title) - (if hm--html-signature-file - (hm--html-add-signature)) - (goto-char (point-min)) - (search-forward "" nil t) - (forward-line 1) - (if hm--html-automatic-created-comment - (hm--html-insert-created-comment))) + (let ((case-fold-search t)) + (hm--html-add-html) + (hm--html-add-head) + (hm--html-add-body) + (hm--html-add-title-and-header title) + (if hm--html-signature-file + (hm--html-add-signature)) + (goto-char (point-min)) + (search-forward "" nil t) + (forward-line 1) + (if hm--html-automatic-created-comment + (hm--html-insert-created-comment)))) (defun hm--html-add-full-html-frame-with-region () @@ -1734,14 +1733,15 @@ (defun hm--html-mark-example (parameter-list) "Marks the example of the parameterlist in the current buffer. It returns the example extent." - (if (hm--html-get-example-from-parameter-list parameter-list) - (progn - (search-forward (hm--html-get-example-from-parameter-list - parameter-list)) - (let ((extent (make-extent (match-beginning 0) - (match-end 0)))) - (set-extent-face extent 'hm--html-help-face) - extent)))) + (let ((case-fold-search t)) + (if (hm--html-get-example-from-parameter-list parameter-list) + (progn + (search-forward (hm--html-get-example-from-parameter-list + parameter-list)) + (let ((extent (make-extent (match-beginning 0) + (match-end 0)))) + (set-extent-face extent 'hm--html-help-face) + extent))))) (defun hm--html-unmark-example (extent) @@ -2420,7 +2420,8 @@ (file-exists-p proggate-allowed-file)) (save-window-excursion (let ((alist nil) - (buffername (find-file-noselect proggate-allowed-file))) + (buffername (find-file-noselect proggate-allowed-file)) + (case-fold-search t)) (set-buffer buffername) (toggle-read-only) (goto-char (point-min)) @@ -2575,7 +2576,8 @@ '(("")) (save-window-excursion (let ((alist nil) - (buffername (find-file-noselect newsrc-file))) + (buffername (find-file-noselect newsrc-file)) + (case-fold-search t)) (set-buffer buffername) (toggle-read-only) (goto-char (point-min)) @@ -2730,11 +2732,14 @@ (defun hm--html-add-relative-link (relative-file-path) "Adds the HTML tags for a relative link at the current point." - (interactive (list (read-file-name "Relative Filename: " - nil - nil - nil - ""))) + (interactive (list (file-relative-name + (read-file-name "Relative Filename: " + nil + nil + nil + "") + default-directory) + )) (hm--html-add-tags 'hm--html-insert-start-tag (concat ""))) + (concat "" + (mapconcat '(lambda (entry) + (concat "") + " "))) (defun hm--html-add-first-table-row (no-of-cells) @@ -3494,17 +3549,18 @@ (error "ERROR: There must be at least one cell in a row!")) (hm--html-add-tags 'hm--html-insert-end-tag-with-newline - (concat "" (if (<= no-of-cells 1) - "" + "" (concat (mapconcat '(lambda (entry) (concat ""))))) + " ") + " "))))) (defun hm--html-table-get-previous-alignments () @@ -3513,12 +3569,15 @@ An example for the return list: '(\"left\" \"default\" \"center\" \"right\")" (save-excursion (let* ((point-of-view (point)) - (end-of-last-row (search-backward "" nil t)) - (begin-of-last-row (progn (search-backward "" (point-min) t)) + (begin-of-last-row (progn (search-backward " (point) begin-of-last-row) @@ -3550,13 +3609,13 @@ (no-of-cells (length old-alignment-list))) (hm--html-add-tags 'hm--html-insert-end-tag-with-newline - (concat "" (if (<= no-of-cells 1) - "" + "" (concat (mapconcat '(lambda (entry) (concat "")))))) + " ") + " ")))))) (defun hm--html-add-row-entry (alignment) @@ -3632,34 +3691,36 @@ "Adds a colspawn attribute to a table cell. A prefix arg is used as no of COLUMNS." (interactive "NNo of columns, spaned by this cell: ") - (save-excursion - (if (and (search-backward "<" nil t) - (search-forward-regexp "<[ \t\n]*\\(th\\)\\|\\(td\\)" nil t)) - (if (search-forward-regexp "\\([ \t\n]+colspan=\\)\\([^ \t\n>]*\\)" - nil - t) - (progn - (delete-region (match-beginning 2) (match-end 2)) - (insert (format "\"%d\"" columns))) - (insert (format " colspan=\"%d\"" columns))) - (error "ERROR: Point not in a table cell!")))) + (let ((case-fold-search t)) + (save-excursion + (if (and (search-backward "<" nil t) + (search-forward-regexp "<[ \t\n]*\\(th\\)\\|\\(td\\)" nil t)) + (if (search-forward-regexp "\\([ \t\n]+colspan=\\)\\([^ \t\n>]*\\)" + nil + t) + (progn + (delete-region (match-beginning 2) (match-end 2)) + (insert (format "\"%d\"" columns))) + (insert (format " colspan=\"%d\"" columns))) + (error "ERROR: Point not in a table cell!"))))) (defun hm--html-table-add-rowspan-attribute (rows) "Adds a rowspan attribute to a table cell. A prefix arg is used as no of ROWS." (interactive "NNo of rows, spaned by this cell: ") - (save-excursion - (if (and (search-backward "<" nil t) - (search-forward-regexp "<[ \t\n]*\\(th\\)\\|\\(td\\)" nil t)) - (if (search-forward-regexp "\\([ \t\n]+rowspan=\\)\\([^ \t\n>]*\\)" - nil - t) - (progn - (delete-region (match-beginning 2) (match-end 2)) - (insert (format "\"%d\"" rows))) - (insert (format " rowspan=\"%d\"" rows))) - (error "ERROR: Point not in a table cell!")))) + (let ((case-fold-search t)) + (save-excursion + (if (and (search-backward "<" nil t) + (search-forward-regexp "<[ \t\n]*\\(th\\)\\|\\(td\\)" nil t)) + (if (search-forward-regexp "\\([ \t\n]+rowspan=\\)\\([^ \t\n>]*\\)" + nil + t) + (progn + (delete-region (match-beginning 2) (match-end 2)) + (insert (format "\"%d\"" rows))) + (insert (format " rowspan=\"%d\"" rows))) + (error "ERROR: Point not in a table cell!"))))) ;;; ISO-Characters for Emacs HTML-mode (Berthold Crysmann) @@ -4171,6 +4232,7 @@ 'hm--html-template-dir 'hm--html-url-alist 'hm--html-user-config-file + 'hm--html-site-config-file 'hm--html-username 'hm--html-wais-hostname:port-alist 'hm--html-wais-hostname:port-default @@ -4243,8 +4305,11 @@ (defun hm--html-load-config-files () "Load the html configuration files. First, the system config file (detemined by the environment variable -HTML_CONFIG_FILE; normaly hm--html-configuration.el(c)) is loaded and -after that the user config file (determined by the environment variable +HTML_CONFIG_FILE; normaly hm--html-configuration.el(c)) is loaded. +At second a site config file is loaded, if the environment variable +HTML_SITE_CONFIG_FILE or the lisp variable `hm--html-site-config-file' +is set to such a file. +At least the user config file (determined by the environment variable HTML_USER_CONFIG_FILE; normaly the file ~/.hm--html-configuration.el(c)). If no HTML_CONFIG_FILE exists, then the file hm--html-configuration.el(c) is searched in one of the lisp load path directories. @@ -4259,6 +4324,17 @@ (getenv "HTML_CONFIG_FILE")))) (load-library (expand-file-name (getenv "HTML_CONFIG_FILE"))) (load-library "hm--html-configuration")) + + ;; at second the site config file + (if (and (stringp (getenv "HTML_SITE_CONFIG_FILE")) + (file-exists-p + (expand-file-name + (getenv "HTML_SITE_CONFIG_FILE")))) + (load-file (expand-file-name (getenv "HTML_SITE_CONFIG_FILE"))) + (when (and (boundp 'hm--html-site-config-file) + (stringp hm--html-site-config-file) + (file-exists-p (expand-file-name hm--html-site-config-file))) + (load-file (expand-file-name hm--html-site-config-file)))) ;; and now the user config file (cond ((and (stringp (getenv "HTML_USER_CONFIG_FILE")) diff -r b88636d63495 -r 8fc7fe29b841 lisp/hm--html-menus/internal-drag-and-drop.el --- a/lisp/hm--html-menus/internal-drag-and-drop.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/hm--html-menus/internal-drag-and-drop.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,6 +1,6 @@ -;;; $Id: internal-drag-and-drop.el,v 1.1.1.1 1996/12/18 03:46:48 steve Exp $ +;;; $Id: internal-drag-and-drop.el,v 1.2 1997/02/16 01:29:11 steve Exp $ ;;; -;;; Copyright (C) 1996 Heiko Muenkel +;;; Copyright (C) 1996, 1997 Heiko Muenkel ;;; email: muenkel@tnt.uni-hannover.de ;;; ;;; This program is free software; you can redistribute it and/or modify @@ -24,27 +24,28 @@ ;;; drag and drop actions in the emacs. One could start such an ;;; action by clicking with the mouse in the source buffer and ;;; then in the destination buffer. The action could depend on -;;; the points where youve clicked with the mouse, on the state +;;; the points where you've clicked with the mouse, on the state ;;; of the region, the point, the mark and any other properties ;;; of the source and the destination buffers. The actions are ;;; defined by the variable `idd-actions', which is a buffer local -;;; variable. The following is an example for the html-mode: -;;; (defvar html-idd-actions -;;; '((nil (((idd-major-mode-p . dired-mode) -;;; (idd-dired-file-on-line-p . ".*\\.\\(gif\\)\\|\\(jpq\\)")) +;;; variable. The following is an example for the hm--html-mode: +;;; (defvar hm--html-idd-actions +;;; '((nil (((idd-if-major-mode-p . dired-mode) +;;; (idd-if-dired-file-on-line-p +;;; . ".*\\.\\(gif\\)\\|\\(jpq\\)")) ;;; hm--html-idd-add-include-image-from-dired-line) -;;; (((idd-major-mode-p . dired-mode) -;;; (idd-dired-no-file-on-line-p . nil)) +;;; (((idd-if-major-mode-p . dired-mode) +;;; (idd-if-dired-no-file-on-line-p . nil)) ;;; hm--html-idd-add-file-link-to-file-on-dired-line) -;;; (((idd-major-mode-p . dired-mode) -;;; (idd-dired-no-file-on-line-p . t)) +;;; (((idd-if-major-mode-p . dired-mode) +;;; (idd-if-dired-no-file-on-line-p . t)) ;;; hm--html-idd-add-file-link-to-directory-of-buffer) -;;; (((idd-major-mode-p . w3-mode) -;;; (idd-url-at-point-p . t)) +;;; (((idd-if-major-mode-p . w3-mode) +;;; (idd-if-url-at-point-p . t)) ;;; hm--html-idd-add-html-link-from-w3-buffer-point) -;;; (((idd-major-mode-p . w3-mode)) +;;; (((idd-if-major-mode-p . w3-mode)) ;;; hm--html-idd-add-html-link-to-w3-buffer) -;;; (((idd-local-file-p . t)) +;;; (((idd-if-local-file-p . t)) ;;; hm--html-idd-add-file-link-to-buffer))) ;;; Look at the variable `idd-actions' for further descriptions. ;;; @@ -60,45 +61,146 @@ ;;; At first you must click on the source and ;;; after that on the destination." ;;; t) -;;; (define-key global-map [(meta button1)] 'idd-mouse-drag-and-drop) ;;; ;;; Define actions in the variable `idd-actions'. ;;; +;;; The variable `idd-global-mouse-keys' defines the mouse keys, +;;; which are bound to the drag and drop command. +;;; +;;; The variable `idd-drag-and-drop-mouse-binding-type' determines +;;; if you've to hold a mouse button down during moving the mouse +;;; from the source to the destination or not. +;;; -(defvar idd-actions nil +(require 'adapt) +(require 'cl) + +(defvar idd-global-mouse-keys (if (adapt-emacs19p) + [(meta control mouse-1)] + [(meta control button1)]) + "The mouse keys for the command `idd-mouse-drag-and-drop'. +The command `idd-mouse-drag-and-drop' is bound during the loading +of the package internal-drag-and-drop to this keys in the global +key map. + +Set it to nil, if you don't want to bind this function during loading. + +If the command is already bound in the global keymap during loading, +then this key sequence will not be bind.") + +(defvar idd-global-help-mouse-keys (if (adapt-emacs19p) + [(meta control mouse-3)] + [(meta control button3)]) + "The mouse keys for the command `idd-help-mouse-drag-and-drop'. +The command `idd-mouse-drag-and-drop' is bound during the loading +of the package internal-drag-and-drop to this keys in the global +key map. + +Set it to nil, if you don't want to bind this function during loading. + +If the command is already bound in the global keymap during loading, +then this key sequence will not be bind.") + +(defvar idd-drag-and-drop-mouse-binding-type 'click + "*The type of the drag and drop mouse binding. +The value maybe `click or 'press-button-during-move. +A value of `click means, that you've to click over the source, leave +the button and click it again over the destination. +A value of 'press-button-during-move means, that you've to press +the button down over the source and hold it until the mouse pointer +is over the destination. + +The disadvantage of the `press-button-during-move' type compared with +the `click' type is, that you can't select a destination region and +therefore a drag and drop action depending on a selected region can't +be started with that type of mouse binding.") + +(defvar idd-actions '((((idd-if-region-active-p . nil)) + (((idd-if-region-active-p . t)) + idd-action-copy-region)) + + (((idd-if-region-active-p . t)) + (((idd-if-region-active-p . t)) + idd-action-copy-replace-region)) + + (((idd-if-region-active-p . nil) + (idd-if-modifiers-p . nil)) + (((idd-if-region-active-p . t)) + idd-action-move-region)) + + (((idd-if-region-active-p . t) + (idd-if-modifiers-p . nil)) + (((idd-if-region-active-p . t)) + idd-action-move-replace-region)) + ) "The list with actions, depending on the source and the destination. The list looks like: - '(( ( ) - ( ) - : + '(( ( ) + ( ) + : ) - ( ( ) - ( ) - : + ( ( ) + ( ) + : ) : ) The looks like the following: '([( )]) -with :== idd-minor-mode-p | idd-buffer-name-p - | idd-region-active-p ... - -The looks like , except -that a valid is also idd-major-mode-p. +with :== idd-if-minor-mode-p | idd-if-buffer-name-p + | idd-if-region-active-p | idd-if-url-at-point-p + | idd-if-major-mode-p | idd-if-variable-non-nil-p + | idd-if-dired-file-on-line-p + | idd-if-dired-no-file-on-line-p + | idd-if-local-file-p | idd-if-buffer-name-p + | idd-if-modifiers-p | ... -If or is set to -nil, then every source or destination matches. `idd-actions' is a +The - functions must have two arguments, the first one +is the source or destination and the second is the . It must return +nil, if the test wasn't successfull and a number (in general 1), which +specifies the weight of the test function. The weights of all single tests +are added to a summary weight and assigned to the action. The action +with the highest weight is called from the action handler. Look at +the definition of `idd-if-major-mode-p', `idd-if-minor-mode-p' and so on for +examples. Look at the function `idd-get-source-or-destination-alist', if +you wan't to know the structure of the 'source-or-destination' argument +of these functions. + +The looks like , +but in general it could be set to nil in mode specific idd-action +lists. + +If or is set to +nil, then every source or source matches. `idd-actions' is a buffer local variable, which should be at least mode depended. So if -the is set to nil it says, that the source +the is set to nil it says, that the destination buffer must only have a specific mode. But however, it's also possible -to define a general `idd-actions' list, where the source mode is -specified by idd-major-mode-p. +to define a general `idd-actions' list, where the destination mode is +specified by `idd-if-major-mode-p'. - ist a function, which has two arguments, the specifies the -source and the second the destination.") + ist a function, which has two arguments, the first specifies the +source and the second the destination. Look at the function definition +of `idd-action-copy-region' and `idd-action-copy-replace-region'. They are +examples for such actions.") (make-variable-buffer-local 'idd-actions) +(defvar idd-help-instead-of-action nil + "*If this variable is t, then a help buffer is displayed. +No action will be performed if this variable is t.") + +(defvar idd-help-start-action-keymap nil + "Keymap used in an extent in the help buffer to start the action.") + +(defvar idd-help-source nil + "Contains the source of an action. Used only in the help buffer.") + +(defvar idd-help-destination nil + "Contains the destination of an action. Used only in the help buffer.") + +(defvar idd-help-start-extent nil + "The start extent in the help buffer.") + (defun idd-compare-a-specification (source-or-destination specification) "Tests if SOURCE-OR-DESTINATION matches the SPECIFICATION. @@ -108,8 +210,8 @@ '(cdr specification)))) (defun idd-compare-specifications-1 (source-or-destination - specifications - value) + specifications + value) "Internal function of `idd-compare-specifications'. VALUE is the value of the last matches." (cond ((not specifications) value) @@ -121,37 +223,37 @@ (+ value match)))))))) (defun idd-compare-specifications (source-or-destination - specifications) + specifications) "Determines how good SOURCE-OR-DESTINATION and SPECIFICATIONS are matching. A return value of zero means, that they don't match. The higher the return value the better is the matching." (cond ((not specifications) 1) (t (idd-compare-specifications-1 source-or-destination - specifications - 0)))) + specifications + 0)))) -(defun idd-get-action-depending-on-destination (destination - actions-depending-on-dest - source-value - value-action-pair) +(defun idd-get-action-depending-on-source (source + actions-depending-on-source + destination-value + value-action-pair) "Internal function of `idd-get-action-depending-on-source-and-destination'." - (let ((destination-value (idd-compare-specifications - destination - (car (car actions-depending-on-dest))))) - (cond ((not actions-depending-on-dest) value-action-pair) - ((or (= destination-value 0) - (<= (+ source-value destination-value) (car value-action-pair))) - (idd-get-action-depending-on-destination - destination - (cdr actions-depending-on-dest) - source-value + (let ((source-value (idd-compare-specifications + source + (car (car actions-depending-on-source))))) + (cond ((not actions-depending-on-source) value-action-pair) + ((or (= source-value 0) + (<= (+ destination-value source-value) (car value-action-pair))) + (idd-get-action-depending-on-source + source + (cdr actions-depending-on-source) + destination-value value-action-pair)) - (t (idd-get-action-depending-on-destination - destination - (cdr actions-depending-on-dest) - source-value - (cons (+ source-value destination-value) - (second (car actions-depending-on-dest)))))))) + (t (idd-get-action-depending-on-source + source + (cdr actions-depending-on-source) + destination-value + (cons (+ destination-value source-value) + (second (car actions-depending-on-source)))))))) (defun idd-get-action-depending-on-source-and-destination (source destination @@ -161,9 +263,10 @@ VALUE-ACTION-PAIR is a list like ( ). It returns VALUE-ACTION-PAIR, if no other action is found, which has a value higher than (car VALUE-ACTION-PAIR)." - (let ((source-value (idd-compare-specifications source (car (car actions))))) + (let ((destination-value + (idd-compare-specifications destination (car (car actions))))) (cond ((not actions) value-action-pair) - ((= source-value 0) + ((= destination-value 0) (idd-get-action-depending-on-source-and-destination source destination @@ -173,10 +276,10 @@ source destination (cdr actions) - (idd-get-action-depending-on-destination - destination + (idd-get-action-depending-on-source + source (cdr (car actions)) - source-value + destination-value value-action-pair)))))) (defun idd-get-action (source destination actions) @@ -188,6 +291,35 @@ actions '(0 . nil))) +(autoload 'ange-ftp-ftp-path "ange-ftp" + "Parse PATH according to ange-ftp-path-format (which see). +Returns a list (HOST USER PATH), or nil if PATH does not match the format.") + +(defun idd-set-point (source-or-destination) + "Sets the point and buffer to SOURCE-OR-DESTINATION." + (set-buffer (cdr (assoc ':buffer source-or-destination))) + (goto-char (cdr (assoc ':drag-or-drop-point source-or-destination)))) + +(defun idd-set-region (source-or-destination) + "Sets the point, mark and buffer to SOURCE-OR-DESTINATION. +The region is active after this function is called." + (set-buffer (cdr (assoc ':buffer source-or-destination))) + (goto-char (car (cdr (assoc ':region-active source-or-destination)))) + (set-mark (cdr (cdr (assoc ':region-active source-or-destination)))) + (activate-region)) + + +;;; Specification type functions for the list `idd-actions' + +(defun idd-if-region-active-p (source-or-destination value) + "Checks if the region in the SOURCE-OR-DESTINATION was active. +It returns 1, if the region was active and VALUE is t, or if +the region was not active and VALUE is nil. Otherwise it returns +nil." + (if (cdr (assoc ':region-active source-or-destination)) + (if value 1 nil) + (if value nil 1))) + (defun idd-get-buffer-url (source-or-destination) "Returns the URL of the buffer specified by SOURCE-OR-DESTINATION." (save-excursion @@ -201,7 +333,7 @@ (idd-set-point source-or-destination) (w3-view-this-url t))) -(defun idd-url-at-point-p (source-or-destination value) +(defun idd-if-url-at-point-p (source-or-destination value) "Checks if there is an URL at the point of SOURCE-OR-DESTINATION. If that is t and VALUE is t, or that is nil and VALUE is nil, then 1 is returned. Otherwise nil is returned." @@ -213,7 +345,7 @@ nil 1))) -(defun idd-major-mode-p (source-or-destination mode) +(defun idd-if-major-mode-p (source-or-destination mode) "Checks, if the major mode of SOURCE-OR-DESTINATION is MODE. It returns 1, if that is t and nil otherwise." (save-excursion @@ -222,18 +354,19 @@ 1 nil))) -(defun idd-set-point (source-or-destination) - "Sets the point and buffer to SOURCE-OR-DESTINATION." - (set-buffer (cdr (assoc ':buffer source-or-destination))) - (goto-char (cdr (assoc ':drag-or-drop-point source-or-destination)))) +(defun idd-if-variable-non-nil-p (source-or-destination variable) + "Checks, if the variable named VARIABLE isn't t in SOURCE-OR-DESTINATION. +It returns 1, if this is t." + (save-excursion + (set-buffer (cdr (assoc ':buffer source-or-destination))) + (if (eval variable) + 1 + nil))) -(defun idd-set-region (source-or-destination) - "Sets the point, mark and buffer to SOURCE-OR-DESTINATION. -The region is active after this function is called." - (set-buffer (cdr (assoc ':buffer source-or-destination))) - (goto-char (car (cdr (assoc ':region-active source-or-destination)))) - (set-mark (cdr (cdr (assoc ':region-active source-or-destination)))) - (activate-region)) +(defun idd-if-minor-mode-p (source-or-destination minor-mode-variable) + "Checks, if the variable MINOR-MODE-VARIABLE is t in SOURCE-OR-DESTINATION. +MINOR-MODE-VARIABLE is the name of the variable!." + (idd-variable-non-nil-p source-or-destination minor-mode-variable)) (defun idd-get-dired-filename-from-line (source-or-destination) "Returns the filename form the line in a dired buffer. @@ -242,7 +375,7 @@ (idd-set-point source-or-destination) (dired-get-filename nil t))) -(defun idd-dired-file-on-line-p (source-or-destination filename-regexp) +(defun idd-if-dired-file-on-line-p (source-or-destination filename-regexp) "Checks, if the filename on the line match FILENAME-REGEXP. The function `dired-get-filename' is used, to get the filename from the SOURCE-OR-DESTINATION. It returns 1, if it matchs or nil." @@ -254,7 +387,7 @@ 1 nil))) -(defun idd-dired-no-file-on-line-p (source-or-destination value) +(defun idd-if-dired-no-file-on-line-p (source-or-destination value) "Checks, if a filename is in the dired buffer of SOURCE-OR-DESTINATION. It returns 1, if a filename is on the line and if VALUE is t, or if no filename is on the line and VALUE is nil, otherwise it returns @@ -263,10 +396,6 @@ (if value nil 1) (if value 1 nil))) -(autoload 'ange-ftp-ftp-path "ange-ftp" - "Parse PATH according to ange-ftp-path-format (which see). -Returns a list (HOST USER PATH), or nil if PATH does not match the format.") - (defun idd-get-local-filename (source-or-destination) "Returns the filename of a local file specified by SOURCE-OR-DESTINATION." (buffer-file-name (cdr (assoc ':buffer source-or-destination)))) @@ -277,7 +406,7 @@ (idd-set-point source-or-destination) default-directory)) -(defun idd-local-file-p (source-or-destination value) +(defun idd-if-local-file-p (source-or-destination value) "Checks, if SOURCE-OR-DESTINATION has a file on the local filesystem. If that is t and VALUE is t, or that is nil and VALUE is nil, then 1 is returned. Otherwise nil is returned." @@ -287,6 +416,137 @@ (if value 1 nil) (if value nil 1)))) +(defun idd-if-buffer-name-p (source-or-destination buffer-name) + "Checks, if SOURCE-OR-DESTINATION has a buffer called BUFFER-NAME. +It returns 1 if this is the case or nil otherwise." + (if (string= buffer-name + (buffer-name (cdr (assoc ':buffer source-or-destination)))) + 1 + nil)) + +(defun idd-list-1-subset-of-list-2 (list-1 list-2) + "Returns t, if LIST-1 is a subset of LIST-2." + (cond ((not list-1)) + ((member (car list-1 list-2)) + (idd-list-1-subset-of-list-2 (cdr list-1) list-2)) + (t nil))) + +(defun idd-same-modifiers (list-1 list-2) + "Returns t, if both list have the same modifiers." + (and (length list-1 list-2) + (idd-list-1-subset-of-list-2 list-1-list-2))) + +(defun idd-if-modifiers-p (source-or-destination modifiers) + "Checks, if the MODIFIERS hold during selecting the SOURCE-OR-DESTINATION. +Returns 1, if the list MODIFIERS contains the same modifiers, +or if any modyfiers are hold and MODIFIERS is t, +or if no modyfiers are hold and MODIFIERS is nil. +Otherwise nil is returned." + (let ((event-modifiers (event-modifiers + (cdr (assoc ':event source-or-destination))))) + (cond ((not modifiers) + (if event-modifiers nil 1)) + ((listp modifiers) + (if (idd-same-elements modifiers event-modifiers) + 1 + nil)) + (t (if event-modifiers 1 nil))))) + +;;; action functions + +(defun idd-action-copy-region (source destination) + "Copy the region from DESTINATION to SOURCE." + (idd-set-region source) + (let ((region-contents (buffer-substring (point) (mark)))) + (idd-set-point destination) + (insert region-contents))) + +(defun idd-action-copy-replace-region (source destination) + "Copy the region from SOURCE and replace the DESTINATION region with it." + (idd-set-region source) + (let ((region-contents (buffer-substring (point) (mark)))) + (idd-set-region destination) + (delete-region (point) (mark)) + (insert region-contents))) + +(defmacro* idd-with-source-and-destination (source + destination + &key + do-in-source + do-in-destination) + "Macro, usefull for the definition of action functions. +Look at the example `idd-action-move-region'." + `(progn + (if (idd-if-region-active-p ,source t) + (idd-set-region ,source) + (idd-set-point ,source)) + ,(when do-in-source + (cons 'progn do-in-source)) + (if (idd-if-region-active-p ,destination t) + (idd-set-region ,destination) + (idd-set-point ,destination)) + ,(when do-in-destination + (cons 'progn do-in-destination)))) + +(defun idd-action-move-region (source destination) + "Move the region from SOURCE to DESTINATION." + (let ((region)) + (idd-with-source-and-destination + source destination + :do-in-source ((setq region (buffer-substring (point) (mark))) + (delete-region (point) (mark))) + :do-in-destination ((insert region))))) + + +(defun idd-action-move-replace-region (source destination) + "Delete the region at SOURCE and overwrite the DESTINATION region with it." + (let ((region)) + (idd-with-source-and-destination + source destination + :do-in-source ((setq region (buffer-substring (point) (mark))) + (delete-region (point) (mark))) + :do-in-destination ((delete-region (point) (mark)) + (insert region))))) + + +;;; Performing the drag and drop + +(defun idd-display-help-about-action (action source destination) + "Display a help buffer with information about the action." + (if (> (car action) 0) + (if (symbol-function (cdr action)) + (progn + (with-displaying-help-buffer + '(lambda () + (set-buffer "*Help*") + (setq idd-help-source source) + (setq idd-help-destination destination) + (insert "Drag and drop action: `") + (let ((start (point))) + (insert (format "%s" (cdr action))) + (setq idd-help-start-extent (make-extent start (point))) + (set-extent-mouse-face idd-help-start-extent 'highlight) + (set-extent-face idd-help-start-extent 'bold) + (set-extent-keymap idd-help-start-extent + idd-help-start-action-keymap) + ) + (insert "'\n") + (insert (format "Source buffer : `%s'\n" + (buffer-name (cdr (assoc ':buffer source))))) + (insert (format "Destination buffer : `%s'\n" + (buffer-name (cdr (assoc ':buffer destination)) + ))) + (insert "==================================================" + "====================\n") + (insert "Look at `idd-actions' in the " + "destination buffer for other actions!\n") + (insert (format "The documentation of `%s':\n\n" + (cdr action))) + (insert (documentation (cdr action))))) + ) + (error "Error: Action %s isn't a valid function!" (cdr action))) + (message "No valid action defined for this source and this destination!"))) + (defun idd-call-action (action source destination) "Calls the drag and drop ACTION with its arguments SOURCE and DESTINATION." (if (> (car action) 0) @@ -295,35 +555,170 @@ (error "Error: Action %s isn't a valid function!" (cdr action))) (message "No valid action defined for this source and this destination!"))) +(defun idd-start-help-mouse-drag-and-drop () + "Starts help on `idd-start-mouse-drag-and-drop'." + (interactive) + (let ((idd-help-instead-of-action t)) + (idd-start-mouse-drag-and-drop))) + +(defun idd-start-mouse-drag-and-drop () + "Starts a drag and drop command. +This command could be used to start a drag and drop command without a +button event. Therefore this should not be bind direct to a mouse button." + (interactive) + (let ((destination-event) + (drag-and-drop-message "Drag&Drop: Click on the source!")) + (message drag-and-drop-message) + (setq source-event + (next-command-event nil drag-and-drop-message)) + (if (button-press-event-p source-event) + (idd-mouse-drag-and-drop source-event) + (message "Wrong event! Exit drag and drop.")))) + +(defun idd-help-mouse-drag-and-drop (source-event) + "Displays help about the drag and drop action." + (interactive "@e") + (let ((idd-help-instead-of-action t)) + (idd-mouse-drag-and-drop source-event))) + (defun idd-mouse-drag-and-drop (source-event) "Performs a drag and drop action. -At first you must click on the source and after that on the destination." +It calls the command `idd-mouse-drag-and-drop-click' or +`idd-mouse-drag-and-drop-press-button-during-move' depending on +the value of `idd-drag-and-drop-mouse-binding-type'." (interactive "@e") - (let ((source (list (cons ':buffer (current-buffer)) - (cons ':drag-or-drop-point - (event-closest-point source-event)) - (cons ':region-active (if (region-active-p) - (cons (point) - (mark)))))) + (if (eq idd-drag-and-drop-mouse-binding-type 'click) + (idd-mouse-drag-and-drop-click source-event) + (idd-mouse-drag-and-drop-press-button-during-move source-event))) + +(defun idd-get-source-or-destination-alist (event) + "Returns an alist with the description of a source or destination point. +The EVENT must be the button event, which has selected the source or +destination of the drag and drop command. + +The alist has the following structure: + '((:buffer . ) + (:drag-or-drop-point . ) + (:region-active . ) + (:event . EVENT)) + +Note: is (event-closest-point EVENT), +if the EVENT is a mouse event and if it isn't nil. Otherwise the +point is used." +; (set-buffer (event-buffer event)) + (list (cons ':buffer (event-buffer event)) + (cons ':drag-or-drop-point (set-marker + (make-marker) + (if (mouse-event-p event) + (or (event-closest-point event) + (point)) + (point)))) + (cons ':region-active (if (region-active-p) + (cons (set-marker (make-marker) (point)) + (set-marker (make-marker) (mark))))) + (cons ':event event)) + ) + +(defun idd-mouse-drag-and-drop-press-button-during-move (source-event) + "Performs a drag and drop action. +At first you must press the button down over the source and then +move with the pressed button to the destination, where you must leave +the button up. +This must be bind to a mouse button. The SOURCE-EVENT must be a +button-press-event. + +The disadvantage of this command compared with the command +`idd-mouse-drag-and-drop-click' is, that you can't select a +destination region." + (interactive "@e") + (let ((drag-and-drop-message + "Drag&Drop: Leave the button over the destination!") + (source (idd-get-source-or-destination-alist source-event)) (destination nil) (destination-event)) - (if (adapt-xemacsp) + (message drag-and-drop-message) + (setq destination-event + (next-command-event nil drag-and-drop-message)) + (message "") + (cond ((button-release-event-p destination-event) + (setq destination (idd-get-source-or-destination-alist + destination-event)) + (idd-set-point destination) + (if idd-help-instead-of-action + (idd-display-help-about-action (idd-get-action source + destination + idd-actions) + source + destination) + (idd-call-action (idd-get-action source destination idd-actions) + source + destination))) + (t (message "Wrong event! Exit drag and drop.") nil)))) + +(defun idd-mouse-drag-and-drop-click (source-event) + "Performs a drag and drop action. +At first you must click on the source and after that on the destination. +This must be bind to a mouse button. The SOURCE-EVENT must be a +button-press-event." + (interactive "@e") + (let ((drag-and-drop-message "Drag&Drop: Click on the destination!") + (source (idd-get-source-or-destination-alist source-event)) + (destination nil) + (destination-event)) + (message drag-and-drop-message) + (if (and (adapt-xemacsp) (mouse-event-p source-event)) (dispatch-event (next-command-event))) (setq destination-event - (next-command-event nil "Drag&Drop: Click on the destination!")) + (next-command-event nil drag-and-drop-message)) +(setq heiko source-event) + (message "") (cond ((button-press-event-p destination-event) - (setq destination (list (cons ':buffer - (event-buffer destination-event)) - (cons ':drag-or-drop-point - (event-closest-point - destination-event)) - (cons ':region-active nil))) + (mouse-track destination-event) + (setq destination (idd-get-source-or-destination-alist + destination-event)) + (idd-set-point destination) (if (adapt-emacs19p) (while (not (button-release-event-p (next-command-event))))) - (idd-call-action (idd-get-action source destination idd-actions) - source - destination)) - (t (setq action "Wrong event") nil)))) + (if idd-help-instead-of-action + (idd-display-help-about-action (idd-get-action source + destination + idd-actions) + source + destination) + (idd-call-action (idd-get-action source destination idd-actions) + source + destination))) + (t (message "Wrong event! Exit drag and drop.") nil)))) + +(defun idd-help-start-action (event) + "Used to start the action from the help buffer." + (interactive "@e") + (idd-set-point idd-help-destination) + (idd-call-action (idd-get-action idd-help-source + idd-help-destination + idd-actions) + idd-help-source + idd-help-destination) + (delete-extent idd-help-start-extent)) + +;; keymap for help buffer extents +(if (not idd-help-start-action-keymap) + (progn + (setq idd-help-start-action-keymap + (make-sparse-keymap 'idd-help-start-action-keymap)) + (if (adapt-emacs19p) + (define-key idd-help-start-action-keymap [(mouse-2)] + 'idd-help-start-action) + (define-key idd-help-start-action-keymap "[(button2)]" + 'idd-help-start-action)))) + +;; global key bindings +(when idd-global-mouse-keys + (unless (where-is-internal 'idd-mouse-drag-and-drop global-map t) + (define-key global-map idd-global-mouse-keys 'idd-mouse-drag-and-drop)) + (unless (where-is-internal 'idd-help-mouse-drag-and-drop global-map t) + (define-key global-map + idd-global-help-mouse-keys 'idd-help-mouse-drag-and-drop))) (provide 'internal-drag-and-drop) diff -r b88636d63495 -r 8fc7fe29b841 lisp/hm--html-menus/tmpl-minor-mode.el Binary file lisp/hm--html-menus/tmpl-minor-mode.el has changed diff -r b88636d63495 -r 8fc7fe29b841 lisp/modes/executable.el --- a/lisp/modes/executable.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/modes/executable.el Mon Aug 13 08:50:29 2007 +0200 @@ -211,7 +211,8 @@ (y-or-n-p (concat "Replace magic number by `" executable-prefix argument "'? ")))) (progn - (replace-match argument t t nil 1) + (replace-match (concat executable-prefix argument) + t t nil 1) (message "Magic number changed to `%s'" (concat executable-prefix argument))))) (insert executable-prefix argument ?\n) diff -r b88636d63495 -r 8fc7fe29b841 lisp/modes/python-mode.el --- a/lisp/modes/python-mode.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/modes/python-mode.el Mon Aug 13 08:50:29 2007 +0200 @@ -2,12 +2,12 @@ ;; Copyright (C) 1992,1993,1994 Tim Peters -;; Author: 1995-1996 Barry A. Warsaw +;; Author: 1995-1997 Barry A. Warsaw ;; 1992-1994 Tim Peters ;; Maintainer: python-mode@python.org ;; Created: Feb 1992 -;; Version: 2.83 -;; Last Modified: 1996/10/23 20:44:59 +;; Version: 2.89 +;; Last Modified: 1997/01/30 20:16:18 ;; Keywords: python languages oop ;; This software is provided as-is, without express or implied @@ -275,6 +275,9 @@ (and (fboundp 'make-obsolete-variable) (make-obsolete-variable 'py-mode-hook 'python-mode-hook)) +(defvar py-delete-function 'backward-delete-char-untabify + "*Function called by `py-delete-char' when deleting characters.") + (defvar py-mode-map () "Keymap used in `python-mode' buffers.") @@ -407,6 +410,26 @@ If you change this, you probably have to change `py-current-defun' as well. This is only used by `py-current-defun' to find the name for add-log.el.") +;; As of 30-Jan-1997, Emacs 19.34 works but XEmacs 19.15b90 and +;; previous does not. It is suspected that Emacsen before 19.34 are +;; also broken. +(defvar py-parse-partial-sexp-works-p + (let ((buf (get-buffer-create " ---*---pps---*---")) + state status) + (save-excursion + (set-buffer buf) + (erase-buffer) + (insert "(line1\n line2)\nline3") + (lisp-mode) + (goto-char (point-min)) + (setq state (parse-partial-sexp (point) (save-excursion + (forward-line 1) + (point)))) + (parse-partial-sexp (point) (point-max) 0 nil state) + (setq status (not (= (point) (point-max)))) + (kill-buffer buf) + status)) + "Does `parse-partial-sexp' work in this Emacs?") ;; Menu definitions, only relevent if you have the easymenu.el package @@ -424,8 +447,8 @@ (easy-menu-define py-menu py-mode-map "Python Mode menu" '("Python" - ["Comment Out Region" comment-region (mark)] - ["Uncomment Region" (comment-region (point) (mark) '(4)) (mark)] + ["Comment Out Region" py-comment-region (mark)] + ["Uncomment Region" (py-comment-region (point) (mark) '(4)) (mark)] "-" ["Mark current block" py-mark-block t] ["Mark current def" mark-python-def-or-class t] @@ -682,6 +705,7 @@ (make-local-variable 'paragraph-start) (make-local-variable 'require-final-newline) (make-local-variable 'comment-start) + (make-local-variable 'comment-end) (make-local-variable 'comment-start-skip) (make-local-variable 'comment-column) (make-local-variable 'indent-region-function) @@ -697,6 +721,7 @@ paragraph-start "^[ \t]*$" require-final-newline t comment-start "# " + comment-end "" comment-start-skip "# *" comment-column 40 indent-region-function 'py-indent-region @@ -990,7 +1015,10 @@ ;; Functions for Python style indentation (defun py-delete-char (count) "Reduce indentation or delete character. + If point is at the leftmost column, deletes the preceding newline. +Deletion is performed by calling the function in `py-delete-function' +with a single argument (the number of characters to delete). Else if point is at the leftmost non-blank character of a line that is neither a continuation line nor a non-indenting comment line, or if @@ -1009,7 +1037,7 @@ (py-continuation-line-p) (not py-honor-comment-indentation) (looking-at "#[^ \t\n]")) ; non-indenting # - (backward-delete-char-untabify count) + (funcall py-delete-function count) ;; else indent the same as the colon line that opened the block ;; force non-blank so py-goto-block-up doesn't ignore it @@ -2195,9 +2223,9 @@ (if (and (not (zerop (car state))) (not (eobp))) (progn - ;; BUG ALERT: I could swear, from reading the docs, that - ;; the 3rd argument should be plain 0 - (parse-partial-sexp (point) (point-max) (- 0 (car state)) + (parse-partial-sexp (point) (point-max) + (if py-parse-partial-sexp-works-p + 0 (- 0 (car state))) nil state) (forward-line 1)))))) @@ -2361,6 +2389,15 @@ (set-buffer cbuf)) (sit-for 0)) +;; older Emacsen don't have this function +(if (not (fboundp 'match-string)) + (defun match-string (n) + (let ((beg (match-beginning n)) + (end (match-end n))) + (if (and beg end) + (buffer-substring beg end) + nil)))) + (defun py-current-defun () ;; tell add-log.el how to find the current function/method/variable (save-excursion @@ -2374,7 +2411,7 @@ nil))) -(defconst py-version "2.83" +(defconst py-version "2.89" "`python-mode' version number.") (defconst py-help-address "python-mode@python.org" "Address accepting submission of bug reports.") diff -r b88636d63495 -r 8fc7fe29b841 lisp/modes/verilog-mode.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/modes/verilog-mode.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,3078 @@ +;;; verilog-mode.el --- major mode for editing verilog source in Emacs + +;; Copyright (C) 1996 Free Software Foundation, Inc. + +;; Author: Michael McNamara (mac@silicon-sorcery.com) +;; President, Silicon Sorcery +;; Keywords: languages + +;; This file is part of GNU Emacs. + +;; 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 2 of the License, 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; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: + +;; $Header: /afs/informatik.uni-tuebingen.de/local/web/xemacs/xemacs-cvs/XEmacs/xemacs-19/lisp/modes/verilog-mode.el,v 1.1 1997/02/13 18:53:08 steve Exp $ +;; For help figuring out what to do with this file, visit +;; + +;; This mode borrows heavily from the pascal-mode and the cc-mode of emacs + +;; USAGE +;; ===== + +;; A major mode for editing Verilog HDL source code. When you have +;; entered Verilog mode, you may get more info by pressing C-h m. You +;; may also get online help describing various functions by: C-h f +;; + +;; To set up automatic verilog mode, put this file in your load path, +;; and include stuff like this in your .emacs: + +;; (autoload 'verilog-mode "verilog-mode" "Verilog mode" t ) +;; (setq auto-mode-alist (cons '("\\.v\\'" . verilog-mode) auto-mode-alist)) +;; (setq auto-mode-alist (cons '("\\.dv\\'" . verilog-mode) auto-mode-alist)) + +;; If you want to customize Verilog mode to fit your needs better, +;; you may add these lines (the values of the variables presented +;; here are the defaults): +;; +;; ;; User customization for Verilog mode +;; (setq verilog-indent-level 3 +;; verilog-case-indent 2 +;; verilog-auto-newline t +;; verilog-auto-indent-on-newline t +;; verilog-tab-always-indent t +;; verilog-auto-endcomments t +;; verilog-minimum-comment-distance 40 +;; verilog-indent-begin-after-if t +;; verilog-auto-lineup '(all)) + +;; I've put in the common support for colored displays for older +;; emacs-19 behaviour, and newer emacs-19 behaviour, as well as +;; support for xemacs. After that, customizing according to your +;; particular emacs version is up to you. I've used the following +;; for emacs 19.27 and emacs 19.30; also xemacs seems to work for me +;; as well. I must caution that since the font-lock package doesn't +;; have a version number, I've had to key off the emacs version +;; number, which might not corrolate with the font-lock package you +;; happen to be using... + +;; Cut the following (From ";;;; - HERE - " to ";;;; - THERE -") and +;; place the text in your .emacs file. The delete all the single ; +;; at the beginning of the lines. + +;; (If you set the mark at the word HERE, (get cursor of the word +;; and type C-@) and point at word THERE, and then type C-u M-x +;; comment-region it will magically delete all the ; for you) + +;; As coded this should work for modern versions of emacs, and also +;; should be a basis where you could build from to get colors for +;; other modes. It owes a fair bit to the excellent sample.emacs +;; from Xemacs. + + +;; ;;; - HERE - +;;(defvar background-mode 'light) +;;(defvar display-type 'color) +;; ;; figure out background color. We could ask the user, but that would be too easy +;;(cond +;; ((and +;; (fboundp 'device-type) +;; (string= "x" (device-type))) +;; (setq display-type (device-class) +;; background-mode +;; (condition-case nil +;; (let ((bg-resource (x-get-resource ".backgroundMode" "BackgroundMode" 'string)) +;; (params (frame-parameters))) +;; (cond (bg-resource (intern (downcase bg-resource))) +;; ((and (cdr (assq 'background-color params)) +;; (< (apply '+ (x-color-values +;; (cdr (assq 'background-color params)))) +;; (/ (apply '+ (x-color-values "white")) 3))) +;; 'dark) +;; ((and (cdr (assq 'border-color params)) +;; (> (apply '+ (color-instance-rgb-components +;; (make-color-instance (cdr (assq 'border-color params))))) +;; (/ 255 3))) +;; 'dark) +;; (t 'light))) +;; (error 'light)) +;; ) +;; ) +;; ((and +;; (boundp 'window-system) +;; (string= window-system "x")) +;; (setq display-type +;; (condition-case nil +;; (let ((display-resource (x-get-resource ".displayType" "DisplayType"))) +;; (cond (display-resource (intern (downcase display-resource))) +;; ((x-display-color-p) 'color) +;; ((x-display-grayscale-p) 'grayscale) +;; (t 'mono))) +;; (error 'mono)) +;; ) +;; (setq background-mode +;; (condition-case nil +;; (let ((bg-resource (x-get-resource ".backgroundMode" +;; "BackgroundMode" )) +;; (params (frame-parameters))) +;; (cond (bg-resource (intern (downcase bg-resource))) +;; ((and (cdr (assq 'background-color params)) +;; (< (apply '+ (x-color-values +;; (cdr (assq 'background-color params)))) +;; (/ (apply '+ (x-color-values "white")) 3))) +;; 'dark) +;; ((and (fboundp 'color-instance-rgb-components ) +;; (cdr (assq 'border-color params)) +;; (> (apply '+ (color-instance-rgb-components +;; (make-color-instance (cdr (assq 'border-color params))))) +;; (/ 255 3))) +;; 'dark) +;; (t 'light))) +;; (error 'light)) +;; ) +;; )) + +;;(message "It appears you have a %s background" background-mode) + +;; ; Now do emacs version specific color setup +;;(cond +;; ((and (string-match "XEmacs" emacs-version) +;; (boundp 'emacs-major-version) +;; (= emacs-major-version 19) +;; (>= emacs-minor-version 12)) + +;; ;; If you want the default colors, you could do this: +;; ;; (setq font-lock-use-default-fonts nil) +;; ;; (setq font-lock-use-default-colors t) +;; ;; but I want to specify my own colors, so I turn off all +;; ;; default values. +;; (setq font-lock-use-default-fonts nil) +;; (setq font-lock-use-default-colors nil) +;; (require 'font-lock) + +;; ;; Mess around with the faces a bit. Note that you have +;; ;; to change the font-lock-use-default-* variables *before* +;; ;; loading font-lock, and wait till *after* loading font-lock +;; ;; to customize the faces. + +;; ;; (use copy-face instead of make-face-italic/make-face-bold because +;; ;; the startup code does intelligent things to the 'italic and 'bold +;; ;; faces to ensure that they are different from the default face. +;; ;; For example, if the default face is bold, then the 'bold face +;; ;; will be unbold.) +;; ;; Underling comments looks terrible on tty's +;; (set-face-underline-p 'font-lock-comment-face nil 'global 'tty) +;; (set-face-highlight-p 'font-lock-comment-face t 'global 'tty) + +;; (make-face-unitalic 'font-lock-comment-face) +;; (make-face-unitalic 'font-lock-string-face) +;; (copy-face 'bold 'font-lock-function-name-face) +;; (cond +;; ((eq background-mode 'light) +;; (set-face-foreground 'font-lock-comment-face "orchid") +;; (set-face-foreground 'font-lock-function-name-face "red") +;; (set-face-foreground 'font-lock-keyword-face "blue") +;; (set-face-foreground 'font-lock-string-face "steelblue") +;; (set-face-foreground 'font-lock-type-face "darkgreen") +;; ) +;; ((eq background-mode 'dark) +;; (set-face-foreground 'font-lock-comment-face "#efc80c") +;; (set-face-foreground 'font-lock-function-name-face "red") +;; (set-face-foreground 'font-lock-keyword-face "tan") +;; (set-face-foreground 'font-lock-string-face "lightskyblue") +;; (set-face-foreground 'font-lock-type-face "Aquamarine") +;; ) +;; ) +;; ;; misc. faces +;; (and (find-face 'font-lock-preprocessor-face) ; 19.13 and above +;; (copy-face 'bold 'font-lock-preprocessor-face)) +;; ) +;; ((> emacs-minor-version 29) +;; (if (eq background-mode 'light) +;; (setq font-lock-face-attributes +;; '( +;; (font-lock-comment-face "orchid" nil nil t nil) +;; (font-lock-function-name-face "red" nil t nil nil) +;; (font-lock-keyword-face "blue" nil nil nil nil) +;; (font-lock-reference-face "indianred" nil t nil nil ) +;; (font-lock-string-face "steelblue" nil nil nil nil) +;; (font-lock-type-face "darkgreen" nil nil nil nil) +;; (font-lock-variable-name-face "brown") +;; ) +;; ) +;; (setq font-lock-face-attributes +;; '( +;; (font-lock-comment-face "#efc80c" nil nil t nil) +;; (font-lock-function-name-face "red" nil t nil nil) +;; (font-lock-keyword-face "tan" nil nil nil nil) +;; (font-lock-reference-face "indianred" nil t nil nil ) +;; (font-lock-string-face "lightskyblue" nil nil nil nil) +;; (font-lock-type-face "Aquamarine" nil nil nil nil) +;; (font-lock-variable-name-face "LightGoldenrod") +;; ) +;; ) +;; ) +;; ) +;; (t +;; (if (eq background-mode 'dark) +;; (progn +;; (make-face 'my-font-lock-function-name-face) +;; (set-face-foreground 'my-font-lock-function-name-face "red") +;; (setq font-lock-function-name-face 'my-font-lock-function-name-face) + +;; (make-face 'my-font-lock-keyword-face) +;; (set-face-foreground 'my-font-lock-keyword-face "tan") +;; (setq font-lock-keyword-face 'my-font-lock-keyword-face) + +;; (make-face 'my-font-lock-string-face) +;; (set-face-foreground 'my-font-lock-string-face "lightskyblue") +;; (setq font-lock-string-face 'my-font-lock-string-face) + +;; (make-face 'my-font-lock-type-face) +;; (set-face-foreground 'my-font-lock-type-face "#efc80c") ; yellow +;; (setq font-lock-type-face 'my-font-lock-type-face) + +;; (make-face 'my-font-lock-variable-name-face) +;; (set-face-foreground 'my-font-lock-variable-name-face "LightGoldenrod") +;; (setq font-lock-variable-name-face 'my-font-lock-variable-name-face) +;; ) +;; (progn +;; (make-face 'my-font-lock-function-name-face) +;; (set-face-foreground 'my-font-lock-function-name-face "DarkGreen") +;; (setq font-lock-function-name-face 'my-font-lock-function-name-face) + +;; (make-face 'my-font-lock-keyword-face) +;; (set-face-foreground 'my-font-lock-keyword-face "indianred") +;; (setq font-lock-keyword-face 'my-font-lock-keyword-face) + +;; (make-face 'my-font-lock-string-face) +;; (set-face-foreground 'my-font-lock-string-face "RoyalBlue") +;; (setq font-lock-string-face 'my-font-lock-string-face) + +;; (make-face 'my-font-lock-type-face) +;; (set-face-foreground 'my-font-lock-type-face "#003800") ; yellow +;; (setq font-lock-type-face 'my-font-lock-type-face) + +;; (make-face 'my-font-lock-variable-name-face) +;; (set-face-foreground 'my-font-lock-variable-name-face "LightGoldenrod") +;; (setq font-lock-variable-name-face 'my-font-lock-variable-name-face) +;; ) +;; ) +;; ) +;; ) + +;;(cond +;; ((eq display-type 'color) +;; ;; Pretty Colors in source windows. +;; (require 'font-lock) +;; (autoload 'turn-on-fast-lock "fast-lock" +;; "Unconditionally turn on Fast Lock mode.") +;; (add-hook 'c-mode-hook 'font-lock-mode) +;; (add-hook 'verilog-mode-hook 'font-lock-mode) +;; (add-hook 'perl-mode-hook 'font-lock-mode) +;; (add-hook 'elisp-mode-hook 'font-lock-mode) +;; (add-hook 'asm-mode-hook 'font-lock-mode) +;; (setq fast-lock-cache-directories '("~/.backups" ".")) +;; (setq c-font-lock-keywords c-font-lock-keywords-2) +;; (setq c++-font-lock-keywords c++-font-lock-keywords-2) +;; (autoload 'verilog-make-faces "verilog-mode" "Set up faces for verilog") +;; (if (not (string-match "XEmacs" emacs-version)) +;; (progn +;; (cond +;; ((eq background-mode 'dark) +;; ;; Make background a light gray +;; (set-face-background (quote region) "gray30")) +;; ;; Make background a dark gray +;; ((eq background-mode 'light) +;; (set-face-background (quote region) "gray70")) +;; ) +;; ) +;; ) +;; ) +;; ((eq display-type 'mono) +;; (progn +;; ;; Frames are too expensive to create +;; ;; on my NCD running x-remote, which happens +;; ;; to be the only place I run X mono color +;; (setq vm-frame-per-composition nil +;; vm-frame-per-folder nil) +;; ) +;; ) +;; ) +;; ;;; - THERE - + +;; KNOWN BUGS / BUGREPORTS +;; ======================= This is beta code, and likely has +;; bugs. Please report any and all bugs to me at mac@silicon-sorcery.com. +;; + +;;; Code: + +(provide 'verilog-mode) + +;; This variable will always hold the version number of the mode +(defconst verilog-mode-version "$$Revision: 1.1 $$" + "Version of this verilog mode.") + +(defvar verilog-indent-level 3 + "*Indentation of Verilog statements with respect to containing block.") + +(defvar verilog-cexp-indent 1 + "*Indentation of Verilog statements split across lines.") + +(defvar verilog-case-indent 2 + "*Indentation for case statements.") + +(defvar verilog-auto-newline t + "*Non-nil means automatically newline after semicolons") + +(defvar verilog-auto-indent-on-newline t + "*Non-nil means automatically indent line after newline") + +(defvar verilog-tab-always-indent t + "*Non-nil means TAB in Verilog mode should always reindent the current line, +regardless of where in the line point is when the TAB command is used.") + +(defvar verilog-indent-begin-after-if t + "*If true, indent begin statements following if, else, while, for and repeat. +otherwise, line them up.") + +(defvar verilog-auto-endcomments t + "*Non-nil means a comment /* ... */ is set after the ends which ends cases and +functions. The name of the function or case will be set between the braces.") + +(defvar verilog-minimum-comment-distance 40 + "*Minimum distance between begin and end required before a comment will be inserted. +Setting this variable to zero results in every end aquiring a comment; the default avoids +too many redundanet comments in tight quarters") + +(defvar verilog-auto-lineup '(all) "*List of contexts where auto + lineup of :'s or ='s should be done. Elements can be of type: + 'declaration' or 'case', which will do auto lineup in declarations + or case-statements respectively. The word 'all' will do all + lineups. '(case declaration) for instance will do lineup in + case-statements and parameterlist, while '(all) will do all + lineups." ) + +(defvar verilog-mode-abbrev-table nil + "Abbrev table in use in Verilog-mode buffers.") + +(defvar verilog-font-lock-keywords-after-1930 + '( + ("^[ \t]*\\(function\\|task\\|module\\|macromodule\\|primitive\\)\\>[ \t]*" + 1 font-lock-keyword-face) + ("^[ \t]*\\(function\\|task\\|module\\|macromodule\\|primitive\\)\\>[ \t]*\\(\\sw+\\)" + 2 font-lock-function-name-face nil t) + ("\\\\[^ \t]*" 0 'font-lock-function-name-face) ( + "\\(@\\)\\|\\(#\[ \t\]*\\(\\(\[0-9\]+\\('[hdxbo][0-9_xz]*\\)?\\)\\|\\((\[^)\]*)\\)\\)\\)" + 0 font-lock-type-face) + ("\\(`[ \t]*[A-Za-z][A-Za-z0-9_]*\\)" 0 font-lock-type-face) + ("\\<\\(in\\(teger\\|put\\|out\\)\\|parameter\\|defparam\\|output\\|supply[01]?\\|event\\|tri\\(0\\|1\\|reg\\|and\\|or\\)?\\|w\\(ire\\|or\\|and\\)\\|time\\|re\\(al\\(time\\)?\\|g\\)\\)\\>" + 0 font-lock-type-face) + ("\\(\\$[a-zA-Z][a-zA-Z0-9_\\$]*\\)\\|\\(\\<\\(begin\\|case[xz]?\\|end\\(case\\|function\\|task\\|module\\|table\\|primitive\\|specify\\)?\\|a\\(ssign\\|lways\\)\\|default\\|initial\\|table\\|\\(pos\\|neg\\)edge\\|else\\|for\\(ever\\|k\\)?\\|join\\|if\\|repeat\\|then\\|while\\|specify\\)\\>\\)" + 0 font-lock-keyword-face) + ) +) +(defvar verilog-font-lock-keywords nil) +(defvar verilog-font-lock-keywords-before-1930 + '( + ("^[ \t]*\\(function\\|task\\|module\\|macromodule\\|primitive\\)\\>[ \t]*" . 1) + ("^[ \t]*\\(function\\|task\\|module\\|macromodule\\|primitive\\)\\>[ \t]*\\(\\sw+\\)" + 2 font-lock-function-name-face nil t) + ("\\(\\\\[^ \t]*\\)\\|\\(`[ \t]*[A-Za-z][A-Za-z0-9_]*\\)" 0 font-lock-function-name-face) + ("[@#]" . font-lock-type-face) + ("\\<\\(in\\(teger\\|put\\|out\\)\\|parameter\\|defparam\\|output\\|supply[01]?\\|event\\|tri\\(0\\|1\\|reg\\|and\\|or\\)?\\|w\\(ire\\|or\\|and\\)\\|time\\|re\\(al\\(time\\)?\\|g\\)\\)\\>" + 0 font-lock-type-face) + ("\\(\\$[a-zA-Z][a-zA-Z0-9_\\$]*\\)\\|\\(\\<\\(begin\\|case[xz]?\\|end\\(case\\|function\\|task\\|module\\|table\\|primitive\\|specify\\)?\\|a\\(ssign\\|lways\\)\\|default\\|initial\\|table\\|\\(pos\\|neg\\)edge\\|else\\|for\\(ever\\|k\\)?\\|join\\|if\\|repeat\\|then\\|while\\|specify\\)\\>\\)" . font-lock-keyword-face) + ) +) + +(defvar verilog-imenu-generic-expression + '("^[ \t]*\\(module\\|macromodule\\|primitive\\)[ \t\n]+\\([a-zA-Z0-9_.:]+\\)" . (2)) + "Imenu expression for Verilog-mode. See `imenu-generic-expression'.") + +(defvar verilog-mode-abbrev-table nil + "Abbrev table in use in Verilog-mode buffers.") + + +(define-abbrev-table 'verilog-mode-abbrev-table ()) + +(defvar verilog-mode-map () + "Keymap used in Verilog mode.") +(if verilog-mode-map + () + (setq verilog-mode-map (make-sparse-keymap)) + (define-key verilog-mode-map ";" 'electric-verilog-semi) + (define-key verilog-mode-map ":" 'electric-verilog-colon) + (define-key verilog-mode-map "=" 'electric-verilog-equal) + (define-key verilog-mode-map "\`" 'electric-verilog-tick) + (define-key verilog-mode-map "\t" 'electric-verilog-tab) + (define-key verilog-mode-map "\r" 'electric-verilog-terminate-line) + (define-key verilog-mode-map "\M-\C-b" 'electric-verilog-backward-sexp) + (define-key verilog-mode-map "\M-\C-f" 'electric-verilog-forward-sexp) + (define-key verilog-mode-map "\M-\r" (function (lambda () + (interactive) (electric-verilog-terminate-line 1)))) + (define-key verilog-mode-map "\177" 'backward-delete-char-untabify) + (define-key verilog-mode-map "\M-\t" 'verilog-complete-word) + (define-key verilog-mode-map "\M-?" 'verilog-show-completions) + (define-key verilog-mode-map "\M-\C-h" 'verilog-mark-defun) + (define-key verilog-mode-map "\C-c\C-b" 'verilog-insert-block) + (define-key verilog-mode-map "\C-cb" 'verilog-label-be) + (define-key verilog-mode-map "\M-*" 'verilog-star-comment) + (define-key verilog-mode-map "\C-c\C-c" 'verilog-comment-area) + (define-key verilog-mode-map "\C-c\C-u" 'verilog-uncomment-area) + (define-key verilog-mode-map "\M-\C-a" 'verilog-beg-of-defun) + (define-key verilog-mode-map "\M-\C-e" 'verilog-end-of-defun) + (define-key verilog-mode-map "\C-c\C-d" 'verilog-goto-defun) + ) + + + +;;; +;;; Regular expressions used to calculate indent, etc. +;;; +(defconst verilog-symbol-re "\\<[a-zA-Z_][a-zA-Z_0-9.]*\\>") +(defconst verilog-case-re "\\(\\[^:]\\)") +;; Want to match +;; aa : +;; aa,bb : +;; a[34:32] : +;; a, +;; b : +(defconst verilog-no-indent-begin-re "\\<\\(if\\|else\\|while\\|for\\|repeat\\|always\\)\\>") +(defconst verilog-endcomment-reason-re + (concat + "\\(\\\\)\\|\\(\\\\)\\|\\(\\\\)\\|\\(\\\\)\\|" + "\\(\\\\)\\|\\(\\\\)\\|\\(\\\\)\\|\\(\\\\(\[ \t\]*@\\)?\\)\\|" + "\\(\\\\)\\|\\(\\\\)\\|\\(\\\\)\\|\\(\\\\)\\|" + "#")) + +(defconst verilog-named-block-re "begin[ \t]*:") +(defconst verilog-beg-block-re "\\<\\(begin\\|case\\|casex\\|casez\\|fork\\|table\\|specify\\)\\>") +(defconst verilog-beg-block-re-1 "\\<\\(begin\\)\\|\\(case[xz]?\\)\\|\\(fork\\)\\|\\(table\\)\\|\\(specify\\)\\|\\(function\\)\\|\\(task\\)\\>") +(defconst verilog-end-block-re "\\<\\(end\\|join\\|endcase\\|endtable\\|endspecify\\)\\>") +(defconst verilog-end-block-re-1 "\\(\\\\)\\|\\(\\\\)\\|\\(\\\\)\\|\\(\\\\)\\|\\(\\\\)\\|\\(\\\\)\\|\\(\\\\)") +(defconst verilog-declaration-re + (concat "\\(\\\\|" + "\\\\|\\\\|\\\\|\\\\|" + "\\\\|" + "\\\\|\\\\|" + "\\\\|\\\\)")) +(defconst verilog-declaration-re-1 (concat "^[ \t]*" verilog-declaration-re "[ \t]*\\(\\[[^]]*\\][ \t]*\\)?")) +(defconst verilog-defun-re "\\<\\(module\\|macromodule\\|primitive\\)\\>") +(defconst verilog-end-defun-re "\\<\\(endmodule\\|endprimitive\\)\\>") +(defconst verilog-zero-indent-re + (concat verilog-defun-re "\\|" verilog-end-defun-re)) +(defconst verilog-directive-re + "\\(`else\\)\\|\\(`ifdef\\)\\|\\(`endif\\)\\|\\(`define\\)\\|\\(`undef\\)\\|\\(`include\\)") +(defconst verilog-autoindent-lines-re + (concat + "\\<\\(\\(macro\\)?module\\|primitive\\|end\\(case\\|function\\|task\\|module\\|primitive\\|specify\\|table\\)?\\|join\\|begin\\|else\\)\\>\\|`\\(else\\|ifdef\\|endif\\)\\|" + verilog-directive-re + "\\>")) +(defconst verilog-behavorial-block-beg-re + "\\(\\\\|\\\\|\\\\|\\\\)") +(defconst verilog-indent-reg + (concat "\\(\\\\|\\[^:]\\|\\\\|\\\\|\\\\)\\|" + "\\(\\\\|\\\\|\\\\|\\\\|\\\\)\\|" + "\\(\\\\|\\\\|\\\\|\\\\|\\\\)\\|" + "\\(\\\\|\\\\)\\|" + "\\(\\\\|\\\\)\\|" + "\\(\\\\|\\\\)" +;; "\\|\\(\\\\|\\\\)" + )) +(defconst verilog-complete-reg + "\\(\\\\)\\|\\(\\\\)\\|\\(\\[^:]\\)\\|\\(\\\\)\\|\\(\\\\)\\|\\(\\\\)") +(defconst verilog-end-statement-re + (concat "\\(" verilog-beg-block-re "\\)\\|\\(" + verilog-end-block-re "\\)")) +(defconst verilog-endcase-re + (concat verilog-case-re "\\|" + "\\(endcase\\)\\|" + verilog-defun-re + )) +;;; Strings used to mark beginning and end of excluded text +(defconst verilog-exclude-str-start "/* -----\\/----- EXCLUDED -----\\/-----") +(defconst verilog-exclude-str-end " -----/\\----- EXCLUDED -----/\\----- */") + +(defconst verilog-emacs-features + (let ((major (and (boundp 'emacs-major-version) + emacs-major-version)) + (minor (and (boundp 'emacs-minor-version) + emacs-minor-version)) + flavor comments) + ;; figure out version numbers if not already discovered + (and (or (not major) (not minor)) + (string-match "\\([0-9]+\\).\\([0-9]+\\)" emacs-version) + (setq major (string-to-int (substring emacs-version + (match-beginning 1) + (match-end 1))) + minor (string-to-int (substring emacs-version + (match-beginning 2) + (match-end 2))))) + (if (not (and major minor)) + (error "Cannot figure out the major and minor version numbers.")) + ;; calculate the major version + (cond + ((= major 18) (setq major 'v18)) ;Emacs 18 + ((= major 4) (setq major 'v18)) ;Epoch 4 + ((= major 19) (setq major 'v19 ;Emacs 19 + flavor (if (or (string-match "Lucid" emacs-version) + (string-match "XEmacs" emacs-version)) + 'XEmacs 'FSF))) + ((= major 20) (setq major 'v20 ;XEmacs 20 + flavor 'XEmacs)) + ;; I don't know + (t (error "Cannot recognize major version number: %s" major))) + ;; All XEmacs 19's (formerly Lucid) use 8-bit modify-syntax-entry + ;; flags, as do all patched (obsolete) Emacs 19, Emacs 18, + ;; Epoch 4's. Only vanilla Emacs 19 uses 1-bit flag. Lets be + ;; as smart as we can about figuring this out. + (if (or (eq major 'v20) (eq major 'v19)) + (let ((table (copy-syntax-table))) + (modify-syntax-entry ?a ". 12345678" table) + (cond + ;; XEmacs pre 20 and Emacs pre 19.30 use vectors for syntax tables. + ((vectorp table) + (if (= (logand (lsh (aref table ?a) -16) 255) 255) + (setq comments '8-bit) + (setq comments '1-bit))) + ;; XEmacs 20 is known to be 8-bit + ((eq flavor 'XEmacs) (setq comments '8-bit)) + ;; Emacs 19.30 and beyond are known to be 1-bit + ((eq flavor 'FSF) (setq comments '1-bit)) + ;; Don't know what this is + (t (error "Couldn't figure out syntax table format.")) + )) + ;; Emacs 18 has no support for dual comments + (setq comments 'no-dual-comments)) + ;; lets do some minimal sanity checking. + (if (or + ;; Lemacs before 19.6 had bugs + (and (eq major 'v19) (eq flavor 'XEmacs) (< minor 6)) + ;; Emacs 19 before 19.21 has known bugs + (and (eq major 'v19) (eq flavor 'FSF) (< minor 21)) + ) + (with-output-to-temp-buffer "*verilog-mode warnings*" + (print (format + "The version of Emacs that you are running, %s, +has known bugs in its syntax parsing routines which will affect the +performance of verilog-mode. You should strongly consider upgrading to the +latest available version. verilog-mode may continue to work, after a +fashion, but strange indentation errors could be encountered." + emacs-version)))) + ;; Emacs 18, with no patch is not too good + (if (and (eq major 'v18) (eq comments 'no-dual-comments)) + (with-output-to-temp-buffer "*verilog-mode warnings*" + (print (format + "The version of Emacs 18 you are running, %s, +has known deficiencies in its ability to handle the dual verilog +(and C++) comments, (e.g. the // and /* */ comments). This will +not be much of a problem for you if you only use the /* */ comments, +but you really should strongly consider upgrading to one of the latest +Emacs 19's. In Emacs 18, you may also experience performance degradations. +Emacs 19 has some new built-in routines which will speed things up for you. +Because of these inherent problems, verilog-mode is not supported +on emacs-18." + emacs-version)))) + ;; Emacs 18 with the syntax patches are no longer supported + (if (and (eq major 'v18) (not (eq comments 'no-dual-comments))) + (with-output-to-temp-buffer "*verilog-mode warnings*" + (print (format + "You are running a syntax patched Emacs 18 variant. While this should +work for you, you may want to consider upgrading to Emacs 19. +The syntax patches are no longer supported either for verilog-mode.")))) + (list major comments)) + "A list of features extant in the Emacs you are using. +There are many flavors of Emacs out there, each with different +features supporting those needed by verilog-mode. Here's the current +supported list, along with the values for this variable: + + Vanilla Emacs 18/Epoch 4: (v18 no-dual-comments) + Emacs 18/Epoch 4 (patch2): (v18 8-bit) + XEmacs (formerly Lucid) 19: (v19 8-bit) + Emacs 19: (v19 1-bit).") + +(defconst verilog-comment-start-regexp "//\\|/\\*" + "Dual comment value for `comment-start-regexp'.") + +(defun verilog-populate-syntax-table (table) + ;; Populate the syntax TABLE + ;; DO NOT TRY TO SET _ (UNDERSCORE) TO WORD CLASS! + (modify-syntax-entry ?\\ "\\" table) + (modify-syntax-entry ?+ "." table) + (modify-syntax-entry ?- "." table) + (modify-syntax-entry ?= "." table) + (modify-syntax-entry ?% "." table) + (modify-syntax-entry ?< "." table) + (modify-syntax-entry ?> "." table) + (modify-syntax-entry ?& "." table) + (modify-syntax-entry ?| "." table) + (modify-syntax-entry ?_ "w" table) + (modify-syntax-entry ?\' "." table) +) + +(defun verilog-setup-dual-comments (table) + ;; Set up TABLE to handle block and line style comments + (cond + ((memq '8-bit verilog-emacs-features) + ;; XEmacs (formerly Lucid) has the best implementation + (modify-syntax-entry ?/ ". 1456" table) + (modify-syntax-entry ?* ". 23" table) + (modify-syntax-entry ?\n "> b" table) + ;; Give CR the same syntax as newline, for selective-display + (modify-syntax-entry ?\^m "> b" table)) + ((memq '1-bit verilog-emacs-features) + ;; Emacs 19 does things differently, but we can work with it + (modify-syntax-entry ?/ ". 124b" table) + (modify-syntax-entry ?* ". 23" table) + (modify-syntax-entry ?\n "> b" table) + ;; Give CR the same syntax as newline, for selective-display + (modify-syntax-entry ?\^m "> b" table)) + )) + +(defvar verilog-mode-syntax-table nil + "Syntax table used in verilog-mode buffers.") +(if verilog-mode-syntax-table + () + (setq verilog-mode-syntax-table (make-syntax-table)) + (verilog-populate-syntax-table verilog-mode-syntax-table) + ;; add extra comment syntax + (verilog-setup-dual-comments verilog-mode-syntax-table) + ) +;;; +;;; Macros +;;; + +(defsubst verilog-re-search-forward (REGEXP BOUND NOERROR) + "Like re-search-forward, but skips over matches in comments or strings" + (set-match-data '(nil nil)) + (while (and + (re-search-forward REGEXP BOUND NOERROR) + (and (verilog-skip-forward-comment-or-string) + (progn + (store-match-data '(nil nil)) + (if BOUND + (< (point) BOUND) + t) + ) + ) + ) + ) + (match-end 0)) + +(defsubst verilog-re-search-backward (REGEXP BOUND NOERROR) + "Like re-search-backward, but skips over matches in comments or strings" + (set-match-data '(nil nil)) + (while (and + (re-search-backward REGEXP BOUND NOERROR) + (verilog-skip-backward-comment-or-string) + (not (set-match-data '(nil nil)))) + ()) + (match-end 0)) + +(defsubst verilog-get-beg-of-line (&optional arg) + (save-excursion + (beginning-of-line arg) + (point))) + +(defsubst verilog-get-end-of-line (&optional arg) + (save-excursion + (end-of-line arg) + (point))) + +(defun verilog-declaration-end () + (search-forward ";")) + +(defun electric-verilog-backward-sexp () + "Move backward over a sexp" + (interactive) + ;; before that see if we are in a comment + (verilog-backward-sexp) +) +(defun electric-verilog-forward-sexp () + "Move backward over a sexp" + (interactive) + ;; before that see if we are in a comment + (verilog-forward-sexp) +) + +(defun verilog-backward-sexp () + (let ((reg) + (elsec 1) + (found nil) + ) + (if (not (looking-at "\\<")) + (forward-word -1)) + (cond + ((verilog-skip-backward-comment-or-string) + ) + ((looking-at "\\") + (setq reg (concat + verilog-end-block-re + "\\|\\(\\\\)" + "\\|\\(\\\\)" + )) + (while (and (not found) + (verilog-re-search-backward reg nil 'move)) + (cond + ((match-end 1) ; endblock + ; try to leap back to matching outward block by striding across + ; indent level changing tokens then immediately + ; previous line governs indentation. + (verilog-leap-to-head) + ) + ((match-end 2) ; else, we're in deep + (setq elsec (1+ elsec)) + ) + ((match-end 3) ; found it + (setq elsec (1- elsec)) + (if (= 0 elsec) + ;; Now previous line describes syntax + (setq found 't) + )) + ) + ) + ) + ((looking-at verilog-end-block-re-1);; end|join|endcase|endtable|endspecify + (verilog-leap-to-head) + ) + ((looking-at "\\(endmodule\\>\\)\\|\\(\\\\)") + (cond + ((match-end 1) + (verilog-re-search-backward "\\<\\(macro\\)?module\\>" nil 'move)) + ((match-end 2) + (verilog-re-search-backward "\\" nil 'move)) + (t + (backward-sexp 1)))) + (t + (backward-sexp)) + ) ;; cond + ) + ) +(defun verilog-forward-sexp () + (let ((reg) + (st (point))) + (if (not (looking-at "\\<")) + (forward-word -1)) + (cond + ((verilog-skip-forward-comment-or-string) + (verilog-forward-syntactic-ws) + ) + ((looking-at verilog-beg-block-re-1);; begin|fork|case|table|specify + (cond + ((match-end 1) ; end + ;; Search forward for matching begin + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 2) ; endcase + ;; Search forward for matching case + (setq reg "\\(\\[^:]\\)\\|\\(\\\\)" ) + ) + ((match-end 3) ; join + ;; Search forward for matching fork + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 4) ; endtable + ;; Search forward for matching table + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 5) ; endspecify + ;; Search forward for matching specify + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 6) ; endfunction + ;; Search forward for matching function + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 7) ; endspecify + ;; Search forward for matching task + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ) + (if (forward-word 1) + (catch 'skip + (let ((nest 1)) + (while (verilog-re-search-forward reg nil 'move) + (cond + ((match-end 2) ; end + (setq nest (1- nest)) + (if (= 0 nest) + (throw 'skip 1))) + ((match-end 1) ; begin + (setq nest (1+ nest))))) + ) + ) + ) + ) + ((looking-at "\\(\\<\\(macro\\)?module\\>\\)\\|\\(\\\\)") + (cond + ((match-end 1) + (verilog-re-search-forward "\\" nil 'move)) + ((match-end 2) + (verilog-re-search-forward "\\" nil 'move)) + (t + (goto-char st) + (if (= (following-char) ?\) ) + (forward-char 1) + (forward-sexp 1))))) + (t + (goto-char st) + (if (= (following-char) ?\) ) + (forward-char 1) + (forward-sexp 1))) + ) ;; cond + ) + ) + + +(defun verilog-declaration-beg () + (verilog-re-search-backward verilog-declaration-re (bobp) t)) + +(defsubst verilog-within-string () + (save-excursion + (nth 3 (parse-partial-sexp (verilog-get-beg-of-line) (point))))) + + +;;;###autoload +(defun verilog-mode () +"Major mode for editing Verilog code. \\ +NEWLINE, TAB indents for Verilog code. +Delete converts tabs to spaces as it moves back. +Supports highlighting. + +Variables controlling indentation/edit style: + + verilog-indent-level (default 3) + Indentation of Verilog statements with respect to containing block. + verilog-cexp-indent (default 1) + Indentation of Verilog statements broken across lines. + verilog-case-indent (default 2) + Indentation for case statements. + verilog-auto-newline (default nil) + Non-nil means automatically newline after simcolons and the punctation mark + after an end. + verilog-auto-indent-on-newline (default t) + Non-nil means automatically indent line after newline + verilog-tab-always-indent (default t) + Non-nil means TAB in Verilog mode should always reindent the current line, + regardless of where in the line point is when the TAB command is used. + verilog-indent-begin-after-if (default t) + Non-nil means to indent begin statements following a preceeding + if, else, while, for and repeat statements, if any. otherwise, + the begin is lined up with the preceeding token. If t, you get: + if (a) + begin + otherwise you get: + if (a) + begin + verilog-auto-endcomments (default t) + Non-nil means a comment /* ... */ is set after the ends which ends cases, tasks, functions and modules. + The type and name of the object will be set between the braces. + verilog-auto-lineup (default `(all)) + List of contexts where auto lineup of :'s or ='s should be done. + +Turning on Verilog mode calls the value of the variable verilog-mode-hook with +no args, if that value is non-nil. +Other useful functions are: +\\[verilog-complete-word]\t-complete word with appropriate possibilities (functions, verilog keywords...) +\\[verilog-comment-area]\t- Put marked area in a comment, fixing nested comments. +\\[verilog-uncomment-area]\t- Uncomment an area commented with \ +\\[verilog-comment-area]. +\\[verilog-insert-block]\t- insert begin ... end; +\\[verilog-star-comment]\t- insert /* ... */ +\\[verilog-mark-defun]\t- Mark function. +\\[verilog-beg-of-defun]\t- Move to beginning of current function. +\\[verilog-end-of-defun]\t- Move to end of current function. +\\[verilog-label-be]\t- Label matching begin ... end, fork ... join and case ... endcase statements; +" + (interactive) + (kill-all-local-variables) + (use-local-map verilog-mode-map) + (setq major-mode 'verilog-mode) + (setq mode-name "Verilog") + (setq local-abbrev-table verilog-mode-abbrev-table) + (set-syntax-table verilog-mode-syntax-table) + (make-local-variable 'indent-line-function) + (setq indent-line-function 'verilog-indent-line) + (setq comment-indent-function 'verilog-indent-comment) + (make-local-variable 'parse-sexp-ignore-comments) + (setq parse-sexp-ignore-comments nil) + (make-local-variable 'comment-start) + (make-local-variable 'comment-end) + (make-local-variable 'comment-multi-line) + (make-local-variable 'comment-start-skip) + (setq comment-start "// " + comment-end "" + comment-start-skip "/\\*+ *\\|// *" + comment-multi-line nil) + ;; Imenu support + (make-local-variable 'imenu-generic-expression) + (setq imenu-generic-expression verilog-imenu-generic-expression) + ;; Font lock support + (make-local-variable 'font-lock-keywords) + (if (string-match "XEmacs\\|Lucid" emacs-version) + (setq verilog-font-lock-keywords verilog-font-lock-keywords-after-1930 ) + (cond ((> emacs-minor-version 29) + (setq verilog-font-lock-keywords verilog-font-lock-keywords-after-1930 )) + ('t + (setq verilog-font-lock-keywords verilog-font-lock-keywords-before-1930 )) + )) + (setq font-lock-keywords verilog-font-lock-keywords) + (run-hooks 'verilog-mode-hook)) + + +;;; +;;; Electric functions +;;; +(defun electric-verilog-terminate-line (&optional arg) + "Terminate line and indent next line." + (interactive) + ;; before that see if we are in a comment + (let ((state + (save-excursion + (parse-partial-sexp (point-min) (point))))) + (cond + ((nth 7 state) ; Inside // comment + (if (eolp) + (progn + (delete-horizontal-space) + (newline)) + (progn + (newline) + (insert-string "// ") + (beginning-of-line) + )) + (verilog-indent-line) + ) + ((nth 4 state) ; Inside any comment (hence /**/) + (newline) + (beginning-of-line) + + (verilog-indent-comment t) + (insert-string "* ") + ) + ((eolp) + ;; First, check if current line should be indented + (if (save-excursion + (delete-horizontal-space) + (beginning-of-line) + (skip-chars-forward " \t") + (if (looking-at verilog-autoindent-lines-re) + (let ((indent-str (verilog-indent-line))) + ;; Maybe we should set some endcomments + (if verilog-auto-endcomments + (verilog-set-auto-endcomments indent-str arg)) + (end-of-line) + (delete-horizontal-space) + (if arg + () + (newline)) + nil) + (progn + (end-of-line) + (delete-horizontal-space) + (newline)))) + (newline) + (forward-line 1)) + ;; Indent next line + (if verilog-auto-indent-on-newline + (verilog-indent-line)) + ) + (t + (newline) + ) + ) + ) + ) + +(defun electric-verilog-semi () + "Insert `;' character and reindent the line." + (interactive) + (insert last-command-char) + (save-excursion + (beginning-of-line) + (verilog-indent-line)) + (if (and verilog-auto-newline + (= 0 (verilog-parenthesis-depth))) + (electric-verilog-terminate-line))) + +(defun electric-verilog-colon () + "Insert `:' and do all indentions except line indent on this line." + (interactive) + (insert last-command-char) + ;; Do nothing if within string. + (if (or + (verilog-within-string) + (not (verilog-in-case-region-p))) + () + (save-excursion + (let ((p (point)) + (lim (progn (verilog-beg-of-statement) (point)))) + (goto-char p) + (verilog-backward-case-item lim) + (verilog-indent-line))) +;; (let ((verilog-tab-always-indent nil)) +;; (verilog-indent-line)) + ) + ) + +(defun electric-verilog-equal () + "Insert `=', and do indention if within block." + (interactive) + (insert last-command-char) +;; Could auto line up expressions, but not yet +;; (if (eq (car (verilog-calculate-indent)) 'block) +;; (let ((verilog-tab-always-indent nil)) +;; (verilog-indent-command))) +) + + +(defun electric-verilog-tick () + "Insert back-tick, and indent to coulmn 0 if this is a CPP directive." + (interactive) + (insert last-command-char) + (if (save-excursion (beginning-of-line) (looking-at "^[ \t]*\`\\(\\\\|\\\\\|\\\\|\\\\)")) + (save-excursion (beginning-of-line) + (delete-horizontal-space)))) + +(defun electric-verilog-tab () + "Function called when TAB is pressed in Verilog mode." + (interactive) + ;; If verilog-tab-always-indent, indent the beginning of the line. + (if verilog-tab-always-indent + (let* ((boi-point (save-excursion + (beginning-of-line) + (skip-chars-forward " \t") + (let (type state ) + (setq type (verilog-indent-line)) + (setq state (car type)) + (cond + ((eq state 'block) + (if (looking-at verilog-behavorial-block-beg-re ) + (error (concat "The reserved word \"" + (buffer-substring (match-beginning 0) (match-end 0)) + "\" must be at the behavorial level!")))) + )) + (back-to-indentation) + (point)))) + (if (< (point) boi-point) + (back-to-indentation))) + (progn (insert "\t")) + ) + ) + + + +;;; +;;; Interactive functions +;;; +(defun verilog-insert-block () + "Insert Verilog begin ... end; block in the code with right indentation." + (interactive) + (verilog-indent-line) + (insert "begin") + (electric-verilog-terminate-line) + (save-excursion + (electric-verilog-terminate-line) + (insert "end") + (beginning-of-line) + (verilog-indent-line))) + +(defun verilog-star-comment () + "Insert Verilog star comment at point." + (interactive) + (verilog-indent-line) + (insert "/*") + (save-excursion + (newline) + (insert " */")) + (newline) + (insert " * ")) + +(defun verilog-mark-defun () + "Mark the current verilog function (or procedure). +This puts the mark at the end, and point at the beginning." + (interactive) + (push-mark (point)) + (verilog-end-of-defun) + (push-mark (point)) + (verilog-beg-of-defun) + (if (fboundp 'zmacs-activate-region) + (zmacs-activate-region))) + +(defun verilog-comment-area (start end) + "Put the region into a Verilog comment. +The comments that are in this area are \"deformed\": +`*)' becomes `!(*' and `}' becomes `!{'. +These deformed comments are returned to normal if you use +\\[verilog-uncomment-area] to undo the commenting. + +The commented area starts with `verilog-exclude-str-start', and ends with +`verilog-include-str-end'. But if you change these variables, +\\[verilog-uncomment-area] won't recognize the comments." + (interactive "r") + (save-excursion + ;; Insert start and endcomments + (goto-char end) + (if (and (save-excursion (skip-chars-forward " \t") (eolp)) + (not (save-excursion (skip-chars-backward " \t") (bolp)))) + (forward-line 1) + (beginning-of-line)) + (insert verilog-exclude-str-end) + (setq end (point)) + (newline) + (goto-char start) + (beginning-of-line) + (insert verilog-exclude-str-start) + (newline) + ;; Replace end-comments within commented area + (goto-char end) + (save-excursion + (while (re-search-backward "\\*/" start t) + (replace-match "!/*" t t))) + ) +) + +(defun verilog-uncomment-area () + "Uncomment a commented area; change deformed comments back to normal. +This command does nothing if the pointer is not in a commented +area. See also `verilog-comment-area'." + (interactive) + (save-excursion + (let ((start (point)) + (end (point))) + ;; Find the boundaries of the comment + (save-excursion + (setq start (progn (search-backward verilog-exclude-str-start nil t) + (point))) + (setq end (progn (search-forward verilog-exclude-str-end nil t) + (point)))) + ;; Check if we're really inside a comment + (if (or (equal start (point)) (<= end (point))) + (message "Not standing within commented area.") + (progn + ;; Remove endcomment + (goto-char end) + (beginning-of-line) + (let ((pos (point))) + (end-of-line) + (delete-region pos (1+ (point)))) + ;; Change comments back to normal + (save-excursion + (while (re-search-backward "!/\\*" start t) + (replace-match "*/" t t))) + ;; Remove startcomment + (goto-char start) + (beginning-of-line) + (let ((pos (point))) + (end-of-line) + (delete-region pos (1+ (point))))))))) + +(defun verilog-beg-of-defun () + "Move backward to the beginning of the current function or procedure." + (interactive) + (verilog-re-search-backward verilog-defun-re nil 'move) + ) +(defun verilog-end-of-defun () + (interactive) + (verilog-re-search-forward verilog-end-defun-re nil 'move) + ) + +(defun verilog-label-be (&optional arg) + "Label matching begin ... end, fork ... join and case ... endcase statements in this module; +With argument, first kill any existing labels." + (interactive) + (let ((cnt 0) + (oldpos (point)) + (b (progn + (verilog-beg-of-defun) + (point-marker))) + (e (progn + (verilog-end-of-defun) + (point-marker))) + ) + (goto-char (marker-position b)) + (if (> (- e b) 200) + (message "Relabeling module...")) + (while (and + (> (marker-position e) (point)) + (verilog-re-search-forward + (concat + "\\" + "\\|\\(`endif\\)\\|\\(`else\\)") + nil 'move)) + (goto-char (match-beginning 0)) + (let ((indent-str (verilog-indent-line))) + (verilog-set-auto-endcomments indent-str 't) + (end-of-line) + (delete-horizontal-space) + ) + (setq cnt (1+ cnt)) + (if (= 9 (% cnt 10)) + (message "%d..." cnt)) + ) + (goto-char oldpos) + (if (or + (> (- e b) 200) + (> cnt 20)) + (message "%d lines autocommented" cnt)) + ) + ) + +(defun verilog-beg-of-statement () + "Move backward to beginning of statement" + (interactive) + (while (save-excursion + (and + (not (looking-at verilog-complete-reg)) + (skip-chars-backward " \t") + (not (or (bolp) (= (preceding-char) ?\;))) + ) + ) + (skip-chars-backward " \t") + (verilog-backward-token)) + (let ((last (point))) + (while (progn + (setq last (point)) + (and (not (looking-at verilog-complete-reg)) + (verilog-continued-line)))) + (goto-char last) + (verilog-forward-syntactic-ws) + ) + ) +(defun verilog-end-of-statement () + "Move forward to end of current statement." + (interactive) + (let ((nest 0) pos) + (if (not (looking-at "[ \t\n]")) (forward-sexp -1)) + (or (looking-at verilog-beg-block-re) + ;; Skip to end of statement + (setq pos (catch 'found + (while t + (forward-sexp 1) + (verilog-skip-forward-comment-or-string) + (cond ((looking-at "[ \t]*;") + (skip-chars-forward "^;") + (forward-char 1) + (throw 'found (point))) + ((save-excursion + (forward-sexp -1) + (looking-at verilog-beg-block-re)) + (goto-char (match-beginning 0)) + (throw 'found nil)) + ((eobp) + (throw 'found (point)))))))) + (if (not pos) + ;; Skip a whole block + (catch 'found + (while t + (verilog-re-search-forward verilog-end-statement-re nil 'move) + (setq nest (if (match-end 1) + (1+ nest) + (1- nest))) + (cond ((eobp) + (throw 'found (point))) + ((= 0 nest) + (throw 'found (verilog-end-of-statement)))))) + pos))) +(defun verilog-in-case-region-p () + "Return TRUE if in a case region: more specifically, point @ in the line foo : @ begin" + (interactive) + (save-excursion + (if (and + (progn (verilog-forward-syntactic-ws) + (looking-at "\\")) + (progn (verilog-backward-syntactic-ws) + (= (preceding-char) ?\:))) + (catch 'found + (let ((nest 1)) + (while t + (verilog-re-search-backward "\\(\\\\)\\|\\(\\[^:]\\)\\|\\(\\\\)\\>" nil 'move) + (cond + ((match-end 3) + (setq nest (1+ nest))) + ((match-end 2) + (if (= nest 1) + (throw 'found 1)) + (setq nest (1- nest)) + ) + ( t + (throw 'found (= nest 0))) + ) + ) + ) + ) + nil) + ) + ) +(defun verilog-backward-case-item (lim) + "Skip backward to nearest enclosing case item" + (interactive) + (let ( + (str 'nil) + (lim1 (progn + (save-excursion (verilog-re-search-backward verilog-endcomment-reason-re lim 'move) + (point))))) + ;; Try to find the real : + (if (save-excursion (search-backward ":" lim1 t)) + (let ((colon 0) + b e ) + (while (and (< colon 1) + (verilog-re-search-backward "\\(\\[\\)\\|\\(\\]\\)\\|\\(:\\)" lim1 'move)) + (cond + ((match-end 1) ;; [ + (setq colon (1+ colon)) + (if (>= colon 0) + (error "unbalanced ["))) + ((match-end 2) ;; ] + (setq colon (1- colon))) + + ((match-end 3) ;; : + (setq colon (1+ colon))) + + ) + ) + ;; Skip back to begining of case item + (skip-chars-backward "\t ") + (verilog-skip-backward-comment-or-string) + (setq e (point)) + (setq b (progn + (if (verilog-re-search-backward "\\<\\(case[zx]?\\)\\>\\|;\\|\\" nil 'move) + (progn + (cond + ((match-end 1) + (goto-char (match-end 1)) + (verilog-forward-ws&directives) + (if (looking-at "(") + (progn + (forward-sexp) + (verilog-forward-ws&directives) + )) + (point)) + (t + (goto-char (match-end 0)) + (verilog-forward-ws&directives) + (point)) + )) + (error "Malformed case item") + ) + ) + ) + (setq str (buffer-substring b e)) + (if (setq e (string-match "[ \t]*\\(\\(\n\\)\\|\\(//\\)\\|\\(/\\*\\)\\)" str)) + (setq str (concat (substring str 0 e) "..."))) + str) + 'nil) + ) + ) + + +;;; +;;; Other functions +;;; + +(defun kill-existing-comment () + "kill autocomment on this line" + (save-excursion + (let* ( + (e (progn + (end-of-line) + (point))) + (b (progn + (beginning-of-line) + (search-forward "//" e t)))) + (if b + (delete-region (- b 2) e)) + ) + ) + ) + +(defun verilog-set-auto-endcomments (indent-str kill-existing-comment) + "Insert `// case: 7 ' or `// NAME ' on this line if appropriate. +Insert `// case expr ' if this line ends a case block. +Insert `// ifdef FOO ' if this line ends code conditional on FOO. +Insert `// NAME ' if this line ends a module or primitive named NAME." + (save-excursion + (cond + (; Comment close preprocessor directives + (and + (looking-at "\\(`endif\\)\\|\\(`else\\)") + (or kill-existing-comment + (not (save-excursion + (end-of-line) + (search-backward "//" (verilog-get-beg-of-line) t))))) + (let ( (reg "\\(`else\\)\\|\\(`ifdef\\)\\|\\(`endif\\)") + (nest 1) + b e + (else (if (match-end 2) + 1 + 0)) + ) + (end-of-line) + (if kill-existing-comment + (kill-existing-comment)) + (delete-horizontal-space) + (save-excursion + (backward-sexp 1) + (while (and (/= nest 0) + (verilog-re-search-backward reg nil 'move)) + (cond + ((match-end 1) ; `else + (if (= nest 1) + (setq else 1))) + ((match-end 2) ; `ifdef + (setq nest (1- nest))) + ((match-end 3) ; `endif + (setq nest (1+ nest))) + )) + (if (match-end 0) + (setq b (progn + (skip-chars-forward "^ \t") + (verilog-forward-syntactic-ws) + (point)) + e (progn + (skip-chars-forward "a-zA-Z0-9_") + (point) + )))) + (if b + (if (> (- (point) b) verilog-minimum-comment-distance) + (insert (concat (if + (= else 0) + " // ifdef " + " // !ifdef ") + (buffer-substring b e)))) + (progn + (insert " // unmatched `endif") + (ding 't)) + ))) + + (; Comment close case/function/task/module and named block + (and (looking-at "\\\\)\\|\\(\\\\)\\|\\(\\\\)") + (cond + (;- This is a case block; search back for the start of this case + (match-end 1) + + (let ((err 't) + (str "UNMATCHED!!")) + (save-excursion + (verilog-leap-to-head) + (if (match-end 0) + (progn + (goto-char (match-end 1)) + (setq str (concat (buffer-substring (match-beginning 1) (match-end 1)) + (verilog-get-expr))) + (setq err nil)))) + (end-of-line) + (if kill-existing-comment + (kill-existing-comment)) + (delete-horizontal-space) + (insert (concat " // " str )) + (if err (ding 't)) + )) + + (;- This is a begin..end block + (match-end 2) + (let ((str " // UNMATCHED !!") + (err 't) + (here (point)) + there + cntx + ) + (save-excursion + (verilog-leap-to-head) + (setq there (point)) + (if (not (match-end 0)) + (progn + (goto-char here) + (end-of-line) + (if kill-existing-comment + (kill-existing-comment)) + (delete-horizontal-space) + (insert str) + (ding 't) + ) + (let ( sp + (lim (save-excursion (verilog-beg-of-defun) (point))) + (here (point)) + ) + (cond + (;-- handle named block differently + (looking-at verilog-named-block-re) + (search-forward ":") + (setq there (point)) + (setq str (verilog-get-expr)) + (setq err nil) + (setq str (concat " // block: " str ))) + + ((verilog-in-case-region-p) ;-- handle case item differently + (goto-char here) + (setq str (verilog-backward-case-item lim)) + (setq there (point)) + (setq err nil) + (setq str (concat " // case: " str )) + ) + (;- try to find "reason" for this begin + (cond + (; + (eq here (progn (verilog-beg-of-statement) (point))) + (setq err nil) + (setq str "")) + ((looking-at verilog-endcomment-reason-re) + (setq there (match-end 0)) + (setq cntx (concat + (buffer-substring (match-beginning 0) (match-end 0)) " ")) + (cond + (; + (match-end 2) + (setq err nil) + (save-excursion + (goto-char sp) + (if (and (verilog-continued-line) + (looking-at "\\\\|\\\\|\\")) + (progn + (goto-char (match-end 0)) + (setq there (point)) + (setq str + (concat " // " + (buffer-substring (match-beginning 0) (match-end 0)) " " + (verilog-get-expr)))) + (setq str "") + ) + ) + ) + (;- else + (match-end 4) + (let ((nest 0) + ( reg "\\(\\\\)\\|\\(\\\\)\\|\\(\\\\)") + ) + (catch 'skip + (while (verilog-re-search-backward reg nil 'move) + (cond + ((match-end 1) ; begin + (setq nest (1- nest))) + ((match-end 2) ; end + (setq nest (1+ nest))) + ((match-end 3) + (if (= 0 nest) + (progn + (goto-char (match-end 0)) + (setq there (point)) + (setq err nil) + (setq str (verilog-get-expr)) + (setq str (concat " // else: !if" str )) + (throw 'skip 1)) + ))) + ) + ) + ) + ) + (;- task/function/initial et cetera + t + (match-end 0) + (goto-char (match-end 0)) + (setq there (point)) + (setq err nil) + (setq str (verilog-get-expr)) + (setq str (concat " // " cntx str ))) + + (;-- otherwise... + (setq str " // auto-endcomment confused ") + ) + ) + ) + ((and + (verilog-in-case-region-p) ;-- handle case item differently + (progn + (setq there (point)) + (goto-char here) + (setq str (verilog-backward-case-item lim)))) + (setq err nil) + (setq str (concat " // case: " str )) + ) + ) + ) + ) + ) + (goto-char here) + (end-of-line) + (if kill-existing-comment + (kill-existing-comment)) + (delete-horizontal-space) + (if (or err + (> (- here there) verilog-minimum-comment-distance)) + (insert str)) + (if err (ding 't)) + ) + ) + ) + ) + + + (;- this is end{function,task,module} + t + (let (string reg (width nil)) + (end-of-line) + (if kill-existing-comment + (kill-existing-comment)) + (delete-horizontal-space) + (backward-sexp) + (cond + ((match-end 5) + (setq reg "\\(\\\\)\\|\\(\\<\\(endfunction\\|task\\|\\(macro\\)?module\\|primitive\\)\\>\\)") + (setq width "\\([ \t]*\\[[^]]*\\]\\)?") + ) + ((match-end 6) + (setq reg "\\(\\\\)\\|\\(\\<\\(endtask\\|function\\|\\(macro\\)?module\\|primitive\\)\\>\\)")) + ((match-end 7) + (setq reg "\\(\\<\\(macro\\)?module\\>\\)\\|\\")) + ((match-end 8) + (setq reg "\\(\\\\)\\|\\(\\<\\(endprimitive\\|function\\|task\\|\\(macro\\)?module\\)\\>\\)")) + ) + (let (b e) + (save-excursion + (verilog-re-search-backward reg nil 'move) + (cond + ((match-end 1) + (setq b (progn + (skip-chars-forward "^ \t") + (verilog-forward-ws&directives) + (if (and width (looking-at width)) + (progn + (goto-char (match-end 0)) + (verilog-forward-ws&directives) + )) + (point)) + e (progn + (skip-chars-forward "a-zA-Z0-9_") + (point))) + (setq string (buffer-substring b e))) + (t + (ding 't) + (setq string "unmactched end(function|task|module|primitive)"))))) + (end-of-line) + (insert (concat " // " string ))) + ) + ) + ) + ) + ) + ) + ) + ) + ) + +(defun verilog-get-expr() + "Grab expression at point, e.g, case ( a | b & (c ^d))" + (let* ((b (progn + (verilog-forward-syntactic-ws) + (skip-chars-forward " \t") + (point))) + (e (let ((par 1)) + (cond + ((looking-at "(") + (forward-char 1) + (while (and (/= par 0) + (verilog-re-search-forward "\\((\\)\\|\\()\\)" nil 'move)) + (cond + ((match-end 1) + (setq par (1+ par))) + ((match-end 2) + (setq par (1- par))))) + (point)) + ((looking-at "\\[") + (forward-char 1) + (while (and (/= par 0) + (verilog-re-search-forward "\\(\\[\\)\\|\\(\\]\\)" nil 'move)) + (cond + ((match-end 1) + (setq par (1+ par))) + ((match-end 2) + (setq par (1- par))))) + (verilog-forward-syntactic-ws) + (skip-chars-forward "^ \t\n") + (point)) + ((looking-at "/[/\\*]") + b) + ('t + (skip-chars-forward "^: \t\n") + (point) + )))) + (str (buffer-substring b e))) + (if (setq e (string-match "[ \t]*\\(\\(\n\\)\\|\\(//\\)\\|\\(/\\*\\)\\)" str)) + (setq str (concat (substring str 0 e) "..."))) + str) + ) + + +;;; +;;; Indentation +;;; +(defconst verilog-indent-alist + '((block . (+ ind verilog-indent-level)) + (case . (+ ind verilog-case-indent)) + (cparenexp . (+ ind verilog-indent-level)) + (cexp . (+ ind verilog-indent-level)) + (defun . verilog-indent-level) + (declaration . verilog-indent-level) + (tf . verilog-indent-level) + (behavorial . verilog-indent-level) + (statement . ind) + (cpp . 0) + (comment . (verilog-indent-comment)) + (unknown . 3) + (string . 0))) + +(defun verilog-calculate-indent () + "Calculate the indent of the current Verilog line, through examination +of previous lines. Once a line is found that is definitive as to the +type of the current line, return that lines' indent level and it's +type. Return a list of two elements: (INDENT-TYPE INDENT-LEVEL)." + (save-excursion + (let* ((starting_position (point)) + (par 0) + (begin (looking-at "[ \t]*begin\\>")) + (type (catch 'nesting + ;; Keep working backwards until we can figure out + ;; what type of statement this is. + ;; Basically we need to figure out + ;; 1) if this is a continuation of the previous line; + ;; 2) are we in a block scope (begin..end) + + ;; if we are in a comment, done. + (if (verilog-in-star-comment-p) (throw 'nesting 'comment)) + + ;; if we are in a parenthesized list, done. + (if (verilog-in-paren) (progn (setq par 1) (throw 'nesting 'block))) + + ;; See if we are continuing a previous line + (while t + ;; trap out if we crawl off the top of the buffer + (if (bobp) (throw 'nesting 'cpp)) + + (if (verilog-continued-line) + (let ((sp (point))) + (if (and + (not (looking-at verilog-complete-reg)) + (verilog-continued-line)) + (progn (goto-char sp) + (throw 'nesting 'cexp)) + (goto-char sp)) + (if (and begin + (not verilog-indent-begin-after-if) + (looking-at verilog-no-indent-begin-re)) + (throw 'nesting 'statement) + (throw 'nesting 'cexp))) + + ;; not a continued line + (goto-char starting_position)) + + (if (looking-at "\\") + ;; search back for governing if, striding across begin..end pairs + ;; appropriately + (let ((reg (concat + verilog-end-block-re + "\\|\\(\\\\)" + "\\|\\(\\\\)" + )) + (elsec 1) + ) + (while (verilog-re-search-backward reg nil 'move) + (cond + ((match-end 1) ; endblock + ; try to leap back to matching outward block by striding across + ; indent level changing tokens then immediately + ; previous line governs indentation. + (let ((reg)(nest 1)) + (looking-at verilog-end-block-re-1);; end|join|endcase|endtable|endspecify + (cond + ((match-end 1) ; end + ;; Search back for matching begin + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 2) ; endcase + ;; Search back for matching case + (setq reg "\\(\\[^:]\\)\\|\\(\\\\)" ) + ) + ((match-end 3) ; join + ;; Search back for matching fork + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 4) ; endtable + ;; Search back for matching table + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 5) ; endspecify + ;; Search back for matching specify + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 6) ; endfunction + ;; Search back for matching function + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 7) ; endspecify + ;; Search back for matching task + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ) + (catch 'skip + (while (verilog-re-search-backward reg nil 'move) + (cond + ((match-end 1) ; begin + (setq nest (1- nest)) + (if (= 0 nest) + (throw 'skip 1))) + ((match-end 2) ; end + (setq nest (1+ nest))))) + ) + ) + ) + ((match-end 2) ; else, we're in deep + (setq elsec (1+ elsec)) + ) + ((match-end 3) ; found it + (setq elsec (1- elsec)) + (if (= 0 elsec) + ;; Now previous line describes syntax + (throw 'nesting 'statement) + ))) + ) + ) + ) + (while (verilog-re-search-backward verilog-indent-reg nil 'move) + (cond + ((match-end 1) ; beg-block + (looking-at verilog-beg-block-re-1) + (cond + ((match-end 2) (throw 'nesting 'case)) + (t (throw 'nesting 'block)))) + + ((match-end 2) ;; end-block + (verilog-leap-to-head) + (if (verilog-in-case-region-p) + (progn + (verilog-leap-to-case-head) + (if (looking-at verilog-case-re) + (throw 'nesting 'case)) + ))) + + ((or (match-end 3) ;; module.. primitive + (match-end 5)) ;; endtask.. + (throw 'nesting 'defun)) + + ((match-end 4) ;; endmodule + (throw 'nesting 'cpp)) + + ((match-end 6) ;; function/task + (throw 'nesting 'behavorial)) + + ((bobp) + (throw 'nesting 'cpp)) + ) + ) + ) + ) + ) + ) + ;; Return type of block and indent level. + (if (not type) + (setq type 'cpp)) + (if (> par 0) ; Unclosed Parenthesis + (list 'cparenexp par) + (if (eq type 'case) + (list type (verilog-case-indent-level)) + (list type (verilog-indent-level))))))) +(defun verilog-leap-to-case-head () "" + (let ((nest 1)) + (while (/= 0 nest) + (verilog-re-search-backward "\\(\\[^:]\\)\\|\\(\\\\)" nil 'move) + (cond + ((match-end 1) + (setq nest (1- nest))) + ((match-end 2) + (setq nest (1+ nest))) + ((bobp) + (ding 't) + (setq nest 0)) + ) + ) + ) + ) + +(defun verilog-leap-to-head () "foo" + (let (reg + snest + (nest 1)) + (if (looking-at verilog-end-block-re-1);; end|join|endcase|endtable|endspecify + (progn + (cond + ((match-end 1) ; end + ;; Search back for matching begin + (setq reg (concat "\\(\\\\)\\|\\(\\\\)\\|" + "\\(\\\\)\\|\\(\\\\)" ))) + + ((match-end 2) ; endcase + ;; Search back for matching case + (setq reg "\\(\\[^:]\\)\\|\\(\\\\)" ) + ) + ((match-end 3) ; join + ;; Search back for matching fork + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 4) ; endtable + ;; Search back for matching table + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 5) ; endspecify + ;; Search back for matching specify + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 6) ; endfunction + ;; Search back for matching function + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ((match-end 7) ; endspecify + ;; Search back for matching task + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ) + (catch 'skip + (let (sreg) + (while (verilog-re-search-backward reg nil 'move) + + (cond + ((match-end 1) ; begin + (setq nest (1- nest)) + (if (= 0 nest) + ;; Now previous line describes syntax + (throw 'skip 1)) + (if (and snest + (= snest nest)) + (setq reg sreg)) + ) + ((match-end 2) ; end + (setq nest (1+ nest)) + ) + ((match-end 3) + ;; endcase, jump to case + (setq snest nest) + (setq nest (1+ nest)) + (setq sreg reg) + (setq reg "\\(\\[^:]\\)\\|\\(\\\\)" ) + ) + ((match-end 4) + ;; join, jump to fork + (setq snest nest) + (setq nest (1+ nest)) + (setq sreg reg) + (setq reg "\\(\\\\)\\|\\(\\\\)" ) + ) + ) + ) + ) + ) + ) + ) + ) + ) +(defun verilog-continued-line () + "Return true if this is a continued line. + Set point to where line starts" + (let ((continued 't)) + (if (eq 0 (forward-line -1)) + (progn + (end-of-line) + (verilog-backward-ws&directives) + (if (bobp) + (setq continued nil) + (while (and continued + (save-excursion + (skip-chars-backward " \t") + (not (bolp)))) + (setq continued (verilog-backward-token)) + ) ;; while + ) + ) + (setq continued nil) + ) + continued) + ) + +(defun verilog-backward-token () + "step backward token, returning true if we are now at an end of line token" + (verilog-backward-syntactic-ws) + (cond + ((bolp) + nil) + (;-- Anything ending in a ; is complete + (= (preceding-char) ?\;) + nil) +;; (;-- Anything ending in a , is deemed complete +;; (= (preceding-char) ?\,) +;; nil) + + (;-- Could be 'case (foo)' or 'always @(bar)' which is complete + (= (preceding-char) ?\)) + (progn + (backward-char) + (backward-up-list 1) + (verilog-backward-syntactic-ws) + (forward-word -1) + (not (looking-at "\\[^:]")))) + + (;-- any of begin|initial|while are complete statements; 'begin : foo' is also complete + t + (forward-word -1) + (cond + ( + (looking-at "\\(initial\\>\\)\\|\\(always\\>\\)") + t) + ( + (looking-at verilog-indent-reg) + nil) + (t + (let + ((back (point))) + (verilog-backward-syntactic-ws) + (cond + ((= (preceding-char) ?\:) + (backward-char) + (verilog-backward-syntactic-ws) + (backward-sexp) + (if (looking-at "begin") + nil + t) + ) + ((= (preceding-char) ?\#) + (backward-char) + t) + + (t + (goto-char back) + t) + ) + ) + ) + ) + ) + ) +) + +(defun verilog-backward-syntactic-ws (&optional lim) + ;; Backward skip over syntactic whitespace for Emacs 19. + (save-restriction + (let* ((lim (or lim (point-min))) + (here lim) + bol + ) + (if (< lim (point)) + (progn + (narrow-to-region lim (point)) + (while (/= here (point)) + (setq here (point)) + (forward-comment (-(buffer-size))) + (save-excursion + (setq bol (progn (beginning-of-line) (point)))) + (search-backward "//" bol t) + ))) + ))) + +(defun verilog-forward-syntactic-ws (&optional lim) + ;; forward skip over syntactic whitespace for Emacs 19. + (save-restriction + (let* ((lim (or lim (point-max))) + (here lim) + ) + (if (> lim (point)) + (progn + (narrow-to-region (point) lim) + (while (/= here (point)) + (setq here (point)) + (forward-comment (buffer-size)) + ))) + ))) + +(defun verilog-backward-ws&directives (&optional lim) + ;; Backward skip over syntactic whitespace and compiler directives for Emacs 19. + (save-restriction + (let* ((lim (or lim (point-min))) + (here lim) + jump + ) + (if (< lim (point)) + (progn + (let ((state + (save-excursion + (parse-partial-sexp (point-min) (point))))) + (cond + ((nth 4 state) ;; in /* */ comment + (verilog-re-search-backward "/\*" nil 'move) + ) + ((nth 7 state) ;; in // comment + (verilog-re-search-backward "//" nil 'move) + ))) + (narrow-to-region lim (point)) + (while (/= here (point)) + (setq here (point)) + (forward-comment (-(buffer-size))) + (save-excursion + (beginning-of-line) + (if (looking-at "[ \t]*\\(`define\\)\\|\\(`ifdef\\)\\|\\(`else\\)\\|\\(`endif\\)\\|\\(`timescale\\)\\|\\(`include\\)") + (setq jump t) + (setq jump nil))) + (if jump + (beginning-of-line)) + ))) + ))) + +(defun verilog-forward-ws&directives (&optional lim) + ;; forward skip over syntactic whitespace and compiler directives for Emacs 19. + (save-restriction + (let* ((lim (or lim (point-max))) + (here lim) + jump + ) + (if (> lim (point)) + (progn + (let ((state + (save-excursion + (parse-partial-sexp (point-min) (point))))) + (cond + ((nth 4 state) ;; in /* */ comment + (verilog-re-search-forward "/\*" nil 'move) + ) + ((nth 7 state) ;; in // comment + (verilog-re-search-forward "//" nil 'move) + ))) + (narrow-to-region (point) lim) + (while (/= here (point)) + (setq here (point)) + (forward-comment (buffer-size)) + (save-excursion + (beginning-of-line) + (if (looking-at "[ \t]*\\(`define\\)\\|\\(`ifdef\\)\\|\\(`else\\)\\|\\(`endif\\)\\|\\(`timescale\\)") + (setq jump t))) + (if jump + (beginning-of-line 2)) + ))) + ))) +(defun verilog-parenthesis-depth () + "Return non zero if in parenthetical-expression" + (save-excursion + (car (parse-partial-sexp (point-min) (point))))) + +(defun verilog-in-comment-or-string-p () + "Return true if in a string or comment" + (let ((state + (save-excursion + (parse-partial-sexp (point-min) (point))))) + (or (nth 3 state) (nth 4 state) (nth 7 state))) ; Inside string or comment + ) + +(defun verilog-in-star-comment-p () + "Return true if in a star comment" + (let ((state + (save-excursion + (parse-partial-sexp (point-min) (point))))) + (nth 4 state)) + ) + +(defun verilog-in-paren () + "Return true if in a parenthetical expression" + (let ((state + (save-excursion + (parse-partial-sexp (point-min) (point))))) + (/= 0 (nth 0 state))) + ) + +(defun verilog-skip-forward-comment-or-string () + "Return true if in a string or comment" + (let ((state + (save-excursion + (parse-partial-sexp (point-min) (point))))) + (cond + ((nth 3 state) ;Inside string + (goto-char (nth 3 state)) + t) + ((nth 7 state) ;Inside // comment + (forward-line 1) + t) + ((nth 4 state) ;Inside any comment (hence /**/) + (search-forward "*/")) + (t + nil) + ) + ) + ) + +(defun verilog-skip-backward-comment-or-string () + "Return true if in a string or comment" + (let ((state + (save-excursion + (parse-partial-sexp (point-min) (point))))) + (cond + ((nth 3 state) ;Inside string + (search-backward "\"") + t) + ((nth 7 state) ;Inside // comment + (search-backward "//") + t) + ((nth 4 state) ;Inside /* */ comment + (search-backward "/*") + t) + (t + nil) + ) + ) + ) + +(defun verilog-skip-forward-comment-p () + "If in comment, move to end and return true" + (let (state) + (progn + (setq state + (save-excursion + (parse-partial-sexp (point-min) (point)))) + (cond + ((nth 3 state) + t) + ((nth 7 state) ;Inside // comment + (end-of-line) + (forward-char 1) + t) + ((nth 4 state) ;Inside any comment + t) + (t + nil) + ) + ) + ) + ) + +(defun verilog-indent-line-relative () + "Cheap version of indent line that only looks at + a few lines to determine indent level" + (interactive) + (let ((indent-str)) + (save-excursion + (beginning-of-line) + (if (looking-at "^[ \t]*$") + (cond ;- A blank line; No need to be too smart. + ((bobp) + (setq indent-str (list 'cpp 0))) + ((verilog-continued-line) + (let ((sp (point))) + (if (verilog-continued-line) + (progn (goto-char sp) + (setq indent-str (list 'statement (verilog-indent-level)))) + (goto-char sp) + (setq indent-str (list 'block (verilog-indent-level)))))) + (t + (setq indent-str (verilog-calculate-indent)))) + (setq indent-str (verilog-calculate-indent)) + ) + ) + (verilog-do-indent indent-str) + ) + ) +(defun verilog-indent-line () + "Indent for special part of code." + (if (looking-at verilog-directive-re) + ;; We could nicely nest `ifdef's, but... + (progn + (delete-horizontal-space) + (indent-to 0) + (list 'cpp 0)) ; Return verilog-calculate-indent data + (verilog-do-indent (verilog-calculate-indent))) + ) + +(defun verilog-do-indent (indent-str) + "" + (let ((type (car indent-str)) + (ind (car (cdr indent-str)))) + (delete-horizontal-space) + (cond + (; handle comma continued exp + (eq type 'cexp) + (let ((here (point))) + (if (progn (verilog-backward-syntactic-ws) + (= (preceding-char) ?\,)) + (let* ( fst + (column + (save-excursion + (backward-char 1) + (verilog-beg-of-statement) + (setq fst (point)) + (if (looking-at verilog-declaration-re) + (progn ;; we have multiple words + (goto-char (match-end 0)) + (skip-chars-forward " \t") + (if (= (following-char) ?\[) + (progn + (forward-char 1) + (backward-up-list -1) + (skip-chars-forward " \t") + ) + ) + ) + (;; we have a single word + goto-char fst) + ) + (current-column) + ) + ) + ) + (goto-char here) + (beginning-of-line) + (delete-horizontal-space) + (indent-to column)) + (progn + (goto-char here) + (let ((val (eval (cdr (assoc type verilog-indent-alist))))) + ;; (verilog-comment-depth type val) + (delete-horizontal-space) + (indent-to val) + )) + ) + ) + ) + (;-- Declaration -- maybe line 'em up + (and (not (or + (eq type 'cpp) + (eq type 'comment))) + (looking-at verilog-declaration-re) + (or (memq 'all verilog-auto-lineup) + (memq 'declaration verilog-auto-lineup))) + (verilog-indent-declaration (cond ((eq type 'defun) 0) + (t ind))) + ) + (; handle inside parenthetical expressions + (eq type 'cparenexp) + (let ((column (save-excursion + (backward-up-list 1) + (forward-char 1) + (skip-chars-forward " \t") + (current-column)))) + (beginning-of-line) + (delete-horizontal-space) + (indent-to column))) + + (;-- Case -- maybe line 'em up + (and (eq type 'case) (not (looking-at "^[ \t]*$"))) + (progn + (cond + ((looking-at "\\") + (indent-to ind)) + (t + (indent-to (eval (cdr (assoc type verilog-indent-alist)))) + )))) + + (;-- Handle the ends + (looking-at verilog-end-block-re) + (if (eq type 'statement) + (indent-to (- ind verilog-indent-level)) + (indent-to ind))) + (;-- defun + (and (eq type 'defun) + (looking-at verilog-zero-indent-re)) + (indent-to 0)) + + (;-- Everything else + t + (let ((val (eval (cdr (assoc type verilog-indent-alist))))) + ;; (verilog-comment-depth type val) + (delete-horizontal-space) + (indent-to val) + )) + ) + (if (looking-at "[ \t]+$") + (skip-chars-forward " \t")) + indent-str ; Return verilog-calculate-indent data + ) +) + +(defun verilog-indent-level () + "Return the indent-level the current statement has." + (save-excursion + (beginning-of-line) + (skip-chars-forward " \t") + (current-column))) + + +(defun verilog-case-indent-level () + "Return the indent-level the current statement has. +Do not count named blocks or case-statements." + (save-excursion + (beginning-of-line) + (skip-chars-forward " \t") + (cond + ((looking-at verilog-named-block-re) + (current-column)) + ((and (not (looking-at verilog-case-re)) + (looking-at "[^:;]+[ \t]*:")) + (search-forward ":" nil t) + (skip-chars-forward " \t") + (current-column)) + (t + (current-column))))) + +(defun verilog-indent-comment (&optional arg) + "Indent current line as comment. +If optional arg is non-nil, just return the +column number the line should be indented to." + (let* ((stcol + (cond + ((verilog-in-star-comment-p) + (save-excursion + (re-search-backward "/\\*" nil t) + (1+(current-column)))) + ( comment-column + comment-column ) + (t + (save-excursion + (re-search-backward "//" nil t) + (current-column))) + ) + )) + (if arg + (progn + (delete-horizontal-space) + (indent-to stcol)) + stcol + ) + ) + ) + +;;; + + +(defun verilog-indent-declaration (base-ind &optional arg start end) + "Indent current lines as declaration, lining up the variable names" + (interactive) + (let ((pos (point-marker)) + (lim (save-excursion (progn (end-of-line) (point-marker)))) + ) + (if (and (not (or arg start)) (not (verilog-re-search-forward verilog-declaration-re lim t))) + () + (progn + (beginning-of-line) + (delete-horizontal-space) + (indent-to (+ base-ind (eval (cdr (assoc 'declaration verilog-indent-alist))))) + (let* ((pos2 (point-marker)) + (more 1) + here + (stpos (if start start + (save-excursion + + (goto-char pos2) + (catch 'first + (while more + (setq here (point)) + (verilog-backward-syntactic-ws) + (if (= (preceding-char) ?\;) + (backward-char)) + (verilog-beg-of-statement) + (if (bobp) + (throw 'first (point-marker))) + (if (looking-at verilog-declaration-re) + (setq more (/= (point) here)) + (throw 'first (point-marker)))) + (throw 'first (point-marker))) + ) + ) + ) + (edpos (if end + (set-marker (make-marker) end) + lim)) + ind) + (goto-char stpos) + ;; Indent lines in declaration block + (if arg + (while (<= (point) (marker-position edpos)) + (beginning-of-line) + (delete-horizontal-space) + (cond + ((looking-at "^[ \t]*$") + ()) + ((not (looking-at verilog-declaration-re)) + (indent-to arg)) + (t + (indent-to (+ arg verilog-indent-level)))) + (forward-line 1))) + + ;; Do lineup + (setq ind (verilog-get-lineup-indent stpos edpos)) + (goto-char stpos) + (if (> (- edpos stpos) 100) + (message "Lining up declarations..(please stand by)")) + (let (e) + (while (progn (setq e (marker-position edpos)) + (< (point) e)) + (if (verilog-re-search-forward verilog-declaration-re-1 e 'move) + (just-one-space)) +;; (forward-char -1)) + (save-excursion + (let ((p (point))) + (beginning-of-line) + (if (verilog-re-search-forward "\\[" p 'move) + (progn + (forward-char -1) + (just-one-space))) + )) + (delete-horizontal-space) + (indent-to ind) + (beginning-of-line) + (delete-horizontal-space) + (indent-to (+ base-ind (eval (cdr (assoc 'declaration verilog-indent-alist))))) + (forward-line 1))))) + + ;; If arg - move point + (message "") + (if arg (forward-line -1) + (goto-char (marker-position pos)))))) + +; "Return the indent level that will line up several lines within the region +;from b to e nicely. The lineup string is str." +(defun verilog-get-lineup-indent (b edpos) + (save-excursion + (let ((ind 0) e) + (goto-char b) + ;; Get rightmost position + (while (progn (setq e (marker-position edpos)) + (< (point) e)) + (if (verilog-re-search-forward verilog-declaration-re-1 e 'move) + (progn + (goto-char (match-end 0)) + (verilog-backward-syntactic-ws) + (if (> (current-column) ind) + (setq ind (current-column))) + (goto-char (match-end 0))))) + (if (> ind 0) + (1+ ind) + ;; No lineup-string found + (goto-char b) + (end-of-line) + (skip-chars-backward " \t") + (1+ (current-column)))))) + +;; A useful mode debugging aide +(defun verilog-comment-depth (type val) + "" + (save-excursion + (let + ((b (prog2 + (beginning-of-line) + (point-marker) + (end-of-line))) + (e (point-marker))) + (if (re-search-backward " /\\* \[#-\]# \[a-z\]+ \[0-9\]+ ## \\*/" b t) + (progn + (replace-match " /* -# ## */") + (end-of-line)) + (progn + (end-of-line) + (insert " /* ## ## */")))) + (backward-char 6) + (insert + (format "%s %d" type val)) + ) + ) +;;; +;;; +;;; Completion +;;; +(defvar verilog-str nil) +(defvar verilog-all nil) +(defvar verilog-pred nil) +(defvar verilog-buffer-to-use nil) +(defvar verilog-flag nil) +(defvar verilog-toggle-completions nil + "*Non-nil means \\\\[verilog-complete-word] should try all possible completions one by one. +Repeated use of \\[verilog-complete-word] will show you all of them. +Normally, when there is more than one possible completion, +it displays a list of all possible completions.") + + +(defvar verilog-type-keywords + '("buf" "bufif0" "bufif1" "cmos" "defparam" "inout" "input" + "integer" "nand" "nmos" "nor" "not" "notif0" "notif1" "or" "output" "parameter" + "pmos" "pull0" "pull1" "pullup" "rcmos" "real" "realtime" "reg" "rnmos" "rpmos" "rtran" + "rtranif0" "rtranif1" "time" "tran" "tranif0" "tranif1" "tri" "tri0" "tri1" + "triand" "trior" "trireg" "wand" "wire" "wor" "xnor" "xor" ) + "*Keywords for types used when completing a word in a declaration or parmlist. +\(eg. integer, real, char.) The types defined within the Verilog program +will be completed runtime, and should not be added to this list.") + +(defvar verilog-defun-keywords + '("begin" "function" "task" "initial" "always" "assign" "posedge" "negedge" "endmodule") + "*Keywords to complete when standing at first word of a line in declarative scope. +\(eg. initial, always, begin, assign.) +The procedures and variables defined within the Verilog program +will be completed runtime and should not be added to this list.") + +(defvar verilog-block-keywords + '("begin" "fork" "join" "case" "end" "if" "else" "for" "while" "repeat") + "*Keywords to complete when standing at first word of a line in behavorial scope. +\(eg. begin, if, then, else, for, fork.) +The procedures and variables defined within the Verilog program +will be completed runtime and should not be added to this list.") + +(defvar verilog-tf-keywords + '("begin" "fork" "join" "case" "end" "endtask" "endfunction" "if" "else" "for" "while" "repeat") + "*Keywords to complete when standing at first word of a line in a task or function scope. +\(eg. begin, if, then, else, for, fork.) +The procedures and variables defined within the Verilog program +will be completed runtime and should not be added to this list.") + +(defvar verilog-case-keywords + '("begin" "fork" "join" "case" "end" "endcase" "if" "else" "for" "repeat") + "*Keywords to complete when standing at first word of a line in behavorial scope. +\(eg. begin, if, then, else, for, fork.) +The procedures and variables defined within the Verilog program +will be completed runtime and should not be added to this list.") + +(defvar verilog-separator-keywords + '("else" "then" "begin") + "*Keywords to complete when NOT standing at the first word of a statement. +\(eg. else, then.) +Variables and function names defined within the +Verilog program are completed runtime and should not be added to this list.") + +(defun verilog-string-diff (str1 str2) + "Return index of first letter where STR1 and STR2 differs." + (catch 'done + (let ((diff 0)) + (while t + (if (or (> (1+ diff) (length str1)) + (> (1+ diff) (length str2))) + (throw 'done diff)) + (or (equal (aref str1 diff) (aref str2 diff)) + (throw 'done diff)) + (setq diff (1+ diff)))))) + +;; Calculate all possible completions for functions if argument is `function', +;; completions for procedures if argument is `procedure' or both functions and +;; procedures otherwise. + +(defun verilog-func-completion (type) + ;; Build regular expression for module/task/function names + (if (string= verilog-str "") + (setq verilog-str "[a-zA-Z_]")) + (let ((verilog-str (concat (cond + ((eq type 'module) "\\<\\(module\\)\\s +") + ((eq type 'tf) "\\<\\(task\\|function\\)\\s +") + (t "\\<\\(task\\|function\\|module\\)\\s +")) + "\\<\\(" verilog-str "[a-zA-Z0-9_.]*\\)\\>")) + match) + + (if (not (looking-at verilog-defun-re)) + (verilog-re-search-backward verilog-defun-re nil t)) + (forward-char 1) + + ;; Search through all reachable functions + (goto-char (point-min)) + (while (verilog-re-search-forward verilog-str (point-max) t) + (progn (setq match (buffer-substring (match-beginning 2) + (match-end 2))) + (if (or (null verilog-pred) + (funcall verilog-pred match)) + (setq verilog-all (cons match verilog-all))))) + (if (match-beginning 0) + (goto-char (match-beginning 0))))) + +(defun verilog-get-completion-decl () + ;; Macro for searching through current declaration (var, type or const) + ;; for matches of `str' and adding the occurence tp `all' + (let ((end (save-excursion (verilog-declaration-end) + (point))) + match) + ;; Traverse lines + (while (< (point) end) + (if (verilog-re-search-forward verilog-declaration-re-1 (verilog-get-end-of-line) t) + ;; Traverse current line + (while (and (verilog-re-search-forward + (concat "\\((\\|\\<\\(var\\|type\\|const\\)\\>\\)\\|" + verilog-symbol-re) + (verilog-get-beg-of-line) t) + (not (match-end 1))) + (setq match (buffer-substring (match-beginning 0) (match-end 0))) + (if (string-match (concat "\\<" verilog-str) match) + (if (or (null verilog-pred) + (funcall verilog-pred match)) + (setq verilog-all (cons match verilog-all)))))) + (if (verilog-re-search-forward "\\" (verilog-get-end-of-line) t) + (verilog-declaration-end) + (forward-line 1))))) + +(defun verilog-type-completion () + "Calculate all possible completions for types." + (let ((start (point)) + goon) + ;; Search for all reachable type declarations + (while (or (verilog-beg-of-defun) + (setq goon (not goon))) + (save-excursion + (if (and (< start (prog1 (save-excursion (verilog-end-of-defun) + (point)) + (forward-char 1))) + (verilog-re-search-forward + "\\\\|\\<\\(begin\\|function\\|procedure\\)\\>" + start t) + (not (match-end 1))) + ;; Check current type declaration + (verilog-get-completion-decl)))))) + +(defun verilog-var-completion () + "Calculate all possible completions for variables (or constants)." + nil) +; Not done yet; in 1.99 perhaps +; (let ((start (point)) +; goon twice) +; ;; Search for all reachable var declarations +; (while (or (verilog-beg-of-defun) +; (setq goon (not goon))) +; (save-excursion +; (if (> start (prog1 (save-excursion (verilog-end-of-defun) +; (point)))) +; () ; Declarations not reacable +; (cond ((and (verilog-re-search-forward verilog-declaration-re start t) +; ;; Check var/const declarations +; (verilog-get-completion-decl))))))))) + + +(defun verilog-keyword-completion (keyword-list) + "Give list of all possible completions of keywords in KEYWORD-LIST." + (mapcar '(lambda (s) + (if (string-match (concat "\\<" verilog-str) s) + (if (or (null verilog-pred) + (funcall verilog-pred s)) + (setq verilog-all (cons s verilog-all))))) + keyword-list)) + +;; Function passed to completing-read, try-completion or +;; all-completions to get completion on STR. If predicate is non-nil, +;; it must be a function to be called for every match to check if this +;; should really be a match. If flag is t, the function returns a list +;; of all possible completions. If it is nil it returns a string, the +;; longest possible completion, or t if STR is an exact match. If flag +;; is 'lambda, the function returns t if STR is an exact match, nil +;; otherwise. + +(defun verilog-completion (verilog-str verilog-pred verilog-flag) + (save-excursion + (let ((verilog-all nil)) + ;; Set buffer to use for searching labels. This should be set + ;; within functins which use verilog-completions + (set-buffer verilog-buffer-to-use) + + ;; Determine what should be completed + (let ((state (car (verilog-calculate-indent)))) + (cond ((eq state 'defun) + (save-excursion (verilog-var-completion)) + (verilog-func-completion 'module) + (verilog-keyword-completion verilog-defun-keywords)) + + ((eq state 'block) + (save-excursion (verilog-var-completion)) + (verilog-func-completion 'tf) + (verilog-keyword-completion verilog-block-keywords)) + + ((eq state 'case) + (save-excursion (verilog-var-completion)) + (verilog-func-completion 'tf) + (verilog-keyword-completion verilog-case-keywords)) + + ((eq state 'tf) + (save-excursion (verilog-var-completion)) + (verilog-func-completion 'tf) + (verilog-keyword-completion verilog-tf-keywords)) + + (t;--Anywhere else + (save-excursion (verilog-var-completion)) + (verilog-func-completion 'both) + (verilog-keyword-completion verilog-separator-keywords)))) + + ;; Now we have built a list of all matches. Give response to caller + (verilog-completion-response)))) + +(defun verilog-completion-response () + (cond ((or (equal verilog-flag 'lambda) (null verilog-flag)) + ;; This was not called by all-completions + (if (null verilog-all) + ;; Return nil if there was no matching label + nil + ;; Get longest string common in the labels + (let* ((elm (cdr verilog-all)) + (match (car verilog-all)) + (min (length match)) + tmp) + (if (string= match verilog-str) + ;; Return t if first match was an exact match + (setq match t) + (while (not (null elm)) + ;; Find longest common string + (if (< (setq tmp (verilog-string-diff match (car elm))) min) + (progn + (setq min tmp) + (setq match (substring match 0 min)))) + ;; Terminate with match=t if this is an exact match + (if (string= (car elm) verilog-str) + (progn + (setq match t) + (setq elm nil)) + (setq elm (cdr elm))))) + ;; If this is a test just for exact match, return nil ot t + (if (and (equal verilog-flag 'lambda) (not (equal match 't))) + nil + match)))) + ;; If flag is t, this was called by all-completions. Return + ;; list of all possible completions + (verilog-flag + verilog-all))) + +(defvar verilog-last-word-numb 0) +(defvar verilog-last-word-shown nil) +(defvar verilog-last-completions nil) + +(defun verilog-complete-word () + "Complete word at current point. +\(See also `verilog-toggle-completions', `verilog-type-keywords', +`verilog-start-keywords' and `verilog-separator-keywords'.)" + (interactive) + (let* ((b (save-excursion (skip-chars-backward "a-zA-Z0-9_") (point))) + (e (save-excursion (skip-chars-forward "a-zA-Z0-9_") (point))) + (verilog-str (buffer-substring b e)) + ;; The following variable is used in verilog-completion + (verilog-buffer-to-use (current-buffer)) + (allcomp (if (and verilog-toggle-completions + (string= verilog-last-word-shown verilog-str)) + verilog-last-completions + (all-completions verilog-str 'verilog-completion))) + (match (if verilog-toggle-completions + "" (try-completion + verilog-str (mapcar '(lambda (elm) + (cons elm 0)) allcomp))))) + ;; Delete old string + (delete-region b e) + + ;; Toggle-completions inserts whole labels + (if verilog-toggle-completions + (progn + ;; Update entry number in list + (setq verilog-last-completions allcomp + verilog-last-word-numb + (if (>= verilog-last-word-numb (1- (length allcomp))) + 0 + (1+ verilog-last-word-numb))) + (setq verilog-last-word-shown (elt allcomp verilog-last-word-numb)) + ;; Display next match or same string if no match was found + (if (not (null allcomp)) + (insert "" verilog-last-word-shown) + (insert "" verilog-str) + (message "(No match)"))) + ;; The other form of completion does not necessarly do that. + + ;; Insert match if found, or the original string if no match + (if (or (null match) (equal match 't)) + (progn (insert "" verilog-str) + (message "(No match)")) + (insert "" match)) + ;; Give message about current status of completion + (cond ((equal match 't) + (if (not (null (cdr allcomp))) + (message "(Complete but not unique)") + (message "(Sole completion)"))) + ;; Display buffer if the current completion didn't help + ;; on completing the label. + ((and (not (null (cdr allcomp))) (= (length verilog-str) + (length match))) + (with-output-to-temp-buffer "*Completions*" + (display-completion-list allcomp)) + ;; Wait for a keypress. Then delete *Completion* window + (momentary-string-display "" (point)) + (delete-window (get-buffer-window (get-buffer "*Completions*"))) + ))))) + +(defun verilog-show-completions () + "Show all possible completions at current point." + (interactive) + (let* ((b (save-excursion (skip-chars-backward "a-zA-Z0-9_") (point))) + (e (save-excursion (skip-chars-forward "a-zA-Z0-9_") (point))) + (verilog-str (buffer-substring b e)) + ;; The following variable is used in verilog-completion + (verilog-buffer-to-use (current-buffer)) + (allcomp (if (and verilog-toggle-completions + (string= verilog-last-word-shown verilog-str)) + verilog-last-completions + (all-completions verilog-str 'verilog-completion)))) + ;; Show possible completions in a temporary buffer. + (with-output-to-temp-buffer "*Completions*" + (display-completion-list allcomp)) + ;; Wait for a keypress. Then delete *Completion* window + (momentary-string-display "" (point)) + (delete-window (get-buffer-window (get-buffer "*Completions*"))))) + + +(defun verilog-get-default-symbol () + "Return symbol around current point as a string." + (save-excursion + (buffer-substring (progn + (skip-chars-backward " \t") + (skip-chars-backward "a-zA-Z0-9_") + (point)) + (progn + (skip-chars-forward "a-zA-Z0-9_") + (point))))) + +(defun verilog-build-defun-re (str &optional arg) + "Return function/task/module starting with STR as regular expression. +With optional second arg non-nil, STR is the complete name of the instruction." + (if arg + (concat "^\\(function\\|task\\|module\\)[ \t]+\\(" str "\\)\\>") + (concat "^\\(function\\|task\\|module\\)[ \t]+\\(" str "[a-zA-Z0-9_]*\\)\\>"))) + +;; Function passed to completing-read, try-completion or +;; all-completions to get completion on any function name. If +;; predicate is non-nil, it must be a function to be called for every +;; match to check if this should really be a match. If flag is t, the +;; function returns a list of all possible completions. If it is nil +;; it returns a string, the longest possible completion, or t if STR +;; is an exact match. If flag is 'lambda, the function returns t if +;; STR is an exact match, nil otherwise. + + +(defun verilog-comp-defun (verilog-str verilog-pred verilog-flag) + (save-excursion + (let ((verilog-all nil) + match) + + ;; Set buffer to use for searching labels. This should be set + ;; within functins which use verilog-completions + (set-buffer verilog-buffer-to-use) + + (let ((verilog-str verilog-str)) + ;; Build regular expression for functions + (if (string= verilog-str "") + (setq verilog-str (verilog-build-defun-re "[a-zA-Z_]")) + (setq verilog-str (verilog-build-defun-re verilog-str))) + (goto-char (point-min)) + + ;; Build a list of all possible completions + (while (verilog-re-search-forward verilog-str nil t) + (setq match (buffer-substring (match-beginning 2) (match-end 2))) + (if (or (null verilog-pred) + (funcall verilog-pred match)) + (setq verilog-all (cons match verilog-all))))) + + ;; Now we have built a list of all matches. Give response to caller + (verilog-completion-response)))) + +(defun verilog-goto-defun () + "Move to specified Verilog module/task/function. +The default is a name found in the buffer around point." + (interactive) + (let* ((default (verilog-get-default-symbol)) + ;; The following variable is used in verilog-comp-function + (verilog-buffer-to-use (current-buffer)) + (default (if (verilog-comp-defun default nil 'lambda) + default "")) + (label (if (not (string= default "")) + ;; Do completion with default + (completing-read (concat "Label: (default " default ") ") + 'verilog-comp-defun nil t "") + ;; There is no default value. Complete without it + (completing-read "Label: " + 'verilog-comp-defun nil t "")))) + ;; If there was no response on prompt, use default value + (if (string= label "") + (setq label default)) + ;; Goto right place in buffer if label is not an empty string + (or (string= label "") + (progn + (goto-char (point-min)) + (re-search-forward (verilog-build-defun-re label t)) + (beginning-of-line))))) +(defun verilog-showscopes () + "list all scopes in this module" + (interactive) + (let ( + (buffer (current-buffer)) + (linenum 1) + (nlines 0) + (first 1) + (prevpos (point-min)) + (final-context-start (make-marker)) + (regexp "\\(module\\s-+\\w+\\s-*(\\)\\|\\(\\w+\\s-+\\w+\\s-*(\\)") + ) + (with-output-to-temp-buffer "*Occur*" + (save-excursion + (message (format "Searching for %s ..." regexp)) + ;; Find next match, but give up if prev match was at end of buffer. + (while (and (not (= prevpos (point-max))) + (verilog-re-search-forward regexp nil t)) + (goto-char (match-beginning 0)) + (beginning-of-line) + (save-match-data + (setq linenum (+ linenum (count-lines prevpos (point))))) + (setq prevpos (point)) + (goto-char (match-end 0)) + (let* ((start (save-excursion + (goto-char (match-beginning 0)) + (forward-line (if (< nlines 0) nlines (- nlines))) + (point))) + (end (save-excursion + (goto-char (match-end 0)) + (if (> nlines 0) + (forward-line (1+ nlines)) + (forward-line 1)) + (point))) + (tag (format "%3d" linenum)) + (empty (make-string (length tag) ?\ )) + tem) + (save-excursion + (setq tem (make-marker)) + (set-marker tem (point)) + (set-buffer standard-output) + (setq occur-pos-list (cons tem occur-pos-list)) + (or first (zerop nlines) + (insert "--------\n")) + (setq first nil) + (insert-buffer-substring buffer start end) + (backward-char (- end start)) + (setq tem (if (< nlines 0) (- nlines) nlines)) + (while (> tem 0) + (insert empty ?:) + (forward-line 1) + (setq tem (1- tem))) + (let ((this-linenum linenum)) + (set-marker final-context-start + (+ (point) (- (match-end 0) (match-beginning 0)))) + (while (< (point) final-context-start) + (if (null tag) + (setq tag (format "%3d" this-linenum))) + (insert tag ?:))))))) + (set-buffer-modified-p nil)))) +;;; verilog.el ends here diff -r b88636d63495 -r 8fc7fe29b841 lisp/packages/apropos.el --- a/lisp/packages/apropos.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/packages/apropos.el Mon Aug 13 08:50:29 2007 +0200 @@ -563,7 +563,8 @@ "Variable" do-keys) (apropos-print-doc 'apropos-describe-plist 3 "Plist" nil)))) - (shrink-window-if-larger-than-buffer (get-buffer-window "*Apropos*"))) + (when temp-buffer-shrink-to-fit + (shrink-window-if-larger-than-buffer (get-buffer-window "*Apropos*")))) (prog1 apropos-accumulator (setq apropos-accumulator ()))) ; permit gc diff -r b88636d63495 -r 8fc7fe29b841 lisp/packages/balloon-help.el --- a/lisp/packages/balloon-help.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/packages/balloon-help.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,5 +1,5 @@ ;;; Balloon help for XEmacs (requires 19.12 or later) -;;; Copyright (C) 1995 Kyle E. Jones +;;; Copyright (C) 1995, 1997 Kyle E. Jones ;;; ;;; 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 @@ -18,8 +18,6 @@ ;;; ;;; Send bug reports to kyle@wonderworks.com -;;; Synched up with: Not in FSF. - ;; Balloon help pops up a small frame to display help text ;; relating to objects that the mouse cursor passes over. ;; @@ -59,7 +57,7 @@ (provide 'balloon-help) -(defvar balloon-help-version "1.02" +(defvar balloon-help-version "1.03" "Version string for Balloon Help.") (defvar balloon-help-mode t @@ -96,6 +94,10 @@ (defvar balloon-help-frame-name nil "*The frame name to use for the frame to display the balloon help.") +(defvar balloon-help-aggressively-follow-mouse nil + "*Non-nil means the balloon should move with the mouse even if the mouse +is over the same object as the last mouse motion event.") + ;;; ;;; End of user variables. ;;; @@ -219,7 +221,8 @@ (event-y-pixel event)))) (cond ((eq frame balloon-help-frame) t) ((eq object balloon-help-help-object) - (if (balloon-help-displayed) + (if (and (balloon-help-displayed) + balloon-help-aggressively-follow-mouse) (balloon-help-move-help-frame))) ((balloon-help-displayed) (setq balloon-help-help-object object) diff -r b88636d63495 -r 8fc7fe29b841 lisp/packages/blink-cursor.el --- a/lisp/packages/blink-cursor.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/packages/blink-cursor.el Mon Aug 13 08:50:29 2007 +0200 @@ -38,15 +38,29 @@ (or blink-cursor-last-selected-window (setq blink-cursor-last-selected-window window)) (if (eq window blink-cursor-last-selected-window) - (set-specifier text-cursor-visible-p - (not (specifier-instance text-cursor-visible-p - window)) - window) + + (if (specifier-instance text-cursor-visible-p window) + (if (let ((current-time (current-time))) + (or (> (car current-time) (car last-input-time)) + (> (cadr current-time) (cdr last-input-time)))) + ;; turn cursor off only if more than a second since + ;; last input + (set-specifier text-cursor-visible-p nil window)) + (set-specifier text-cursor-visible-p t window)) + (remove-specifier text-cursor-visible-p blink-cursor-last-selected-window) (setq blink-cursor-last-selected-window window) (set-specifier text-cursor-visible-p nil window))))) +; Turn on cursor after every command +(defun blink-cursor-post-command-hook () + (let ((inhibit-quit t) + (window (selected-window))) + (if blink-cursor-lost-focus + nil + (set-specifier text-cursor-visible-p t window)))) + (defun blink-cursor-reenable-cursor () (if blink-cursor-last-selected-window (progn @@ -63,6 +77,7 @@ (add-hook 'deselect-frame-hook 'blink-cursor-deselect-frame-hook) (add-hook 'select-frame-hook 'blink-cursor-select-frame-hook) +(add-hook 'post-command-hook 'blink-cursor-post-command-hook) (defvar blink-cursor-timeout 1.0) (defvar blink-cursor-timeout-id nil) @@ -96,4 +111,11 @@ (if blink-cursor-mode (setq blink-cursor-timeout-id (add-timeout (/ (float timeout) 2) 'blink-cursor-callback nil - (/ (float timeout) 2))))) + (/ (float timeout) 2)))) + ; initialize last-input-time + (if (not last-input-time) + (setq last-input-time (cons 0 0)))) + +(provide 'blink-cursor) + +;;; blink-cursor.el ends here diff -r b88636d63495 -r 8fc7fe29b841 lisp/packages/fast-lock.el --- a/lisp/packages/fast-lock.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/packages/fast-lock.el Mon Aug 13 08:50:29 2007 +0200 @@ -4,27 +4,25 @@ ;; Author: Simon Marshall ;; Keywords: faces files -;; Version: 3.10.01 +;; Version: 3.10.02 + +;;; This file is part of GNU Emacs. -;; This file is part of XEmacs. -;; -;; XEmacs is free software; you can redistribute it and/or modify +;; GNU Emacs 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 2 of the License, or -;; (at your option) any later version. -;; -;; XEmacs is distributed in the hope that it will be useful, +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs 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 XEmacs; see the file COPYING. If not, write to the +;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. -;;; Synched up with: FSF 19.34. - ;;; Commentary: ;; Purpose: @@ -55,14 +53,7 @@ ;; ;; Version control packages are likely to stamp all over file modification ;; times. Therefore the act of checking out may invalidate a cache. - -;; Feedback: -;; -;; Feedback is welcome. -;; To submit a bug report (or make comments) please use the mechanism provided: -;; -;; M-x fast-lock-submit-bug-report RET - +;;;;;^L ;; History: ;; ;; 0.02--1.00: @@ -166,7 +157,10 @@ ;; - Wrap with `save-buffer-state' (Ray Van Tassle report) ;; - Made `fast-lock-mode' wrap `font-lock-support-mode' ;; 3.10--3.11: - +;; - Made `fast-lock-get-face-properties' cope with face lists +;; - Added `fast-lock-verbose' +;; - XEmacs: Add `font-lock-value-in-major-mode' if necessary +;;;;;^L (require 'font-lock) ;; Make sure fast-lock.el is supported. @@ -194,15 +188,29 @@ (,@ body) (when (and (not modified) (buffer-modified-p)) (set-buffer-modified-p nil))))) - (put 'save-buffer-state 'lisp-indent-function 1)) + (put 'save-buffer-state 'lisp-indent-function 1) + ;; + ;; We use this to verify that a face should be saved. + (defmacro fast-lock-save-facep (face) + "Return non-nil if FACE matches `fast-lock-save-faces'." + (` (or (null fast-lock-save-faces) + (if (symbolp (, face)) + (memq (, face) fast-lock-save-faces) + (let ((list (, face)) found) + (while list + (if (memq (car list) fast-lock-save-faces) + (setq list nil found t) + (setq list (cdr list)))) + found)))))) (defun fast-lock-submit-bug-report () "Submit via mail a bug report on fast-lock.el." (interactive) (let ((reporter-prompt-for-summary-p t)) - (reporter-submit-bug-report "simon@gnu.ai.mit.edu" "fast-lock 3.10.01" + (reporter-submit-bug-report "simon@gnu.ai.mit.edu" "fast-lock 3.10.02" '(fast-lock-cache-directories fast-lock-minimum-size - fast-lock-save-others fast-lock-save-events fast-lock-save-faces) + fast-lock-save-others fast-lock-save-events fast-lock-save-faces + fast-lock-verbose) nil nil (concat "Hi Si., @@ -216,7 +224,7 @@ (defvar fast-lock-mode nil) (defvar fast-lock-cache-timestamp nil) ; for saving/reading (defvar fast-lock-cache-filename nil) ; for deleting - +;;;;;^L ;; User Variables: (defvar fast-lock-cache-directories '("." "~/.emacs-flc") @@ -266,7 +274,11 @@ font-lock-face-list) "Faces that will be saved in a Font Lock cache file. If nil, means information for all faces will be saved.") - + +(defvar fast-lock-verbose font-lock-verbose + "*If non-nil, means show status messages for cache processing. +If a number, only buffers greater than this size have processing messages.") +;;;;;^L ;; User Functions: ;;;###autoload @@ -293,9 +305,7 @@ Various methods of control are provided for the Font Lock cache. In general, see variable `fast-lock-cache-directories' and function `fast-lock-cache-name'. For saving, see variables `fast-lock-minimum-size', `fast-lock-save-events', -`fast-lock-save-others' and `fast-lock-save-faces'. - -Use \\[fast-lock-submit-bug-report] to send bug reports or feedback." +`fast-lock-save-others' and `fast-lock-save-faces'." (interactive "P") ;; Only turn on if we are visiting a file. We could use `buffer-file-name', ;; but many packages temporarily wrap that to nil when doing their own thing. @@ -403,7 +413,7 @@ (defun turn-on-fast-lock () "Unconditionally turn on Fast Lock mode." (fast-lock-mode t)) - +;;;;;^L ;;; API Functions: (defun fast-lock-after-fontify-buffer () @@ -417,7 +427,7 @@ (defalias 'fast-lock-after-unfontify-buffer 'ignore) - +;;;;;^L ;; Miscellaneous Functions: (defun fast-lock-save-cache-after-save-file () @@ -496,7 +506,7 @@ (file-name-as-directory (expand-file-name directory)) (mapconcat 'char-to-string (apply 'append (mapcar mapchars bufile)) "") ".flc")))) - +;;;;;^L ;; Font Lock Cache Processing Functions: (defun fast-lock-save-cache-1 (file timestamp) @@ -504,8 +514,11 @@ ;; (fast-lock-cache-data Version=2 TIMESTAMP font-lock-keywords PROPERTIES). ;; Returns non-nil if a save was attempted to a writable cache file. (let ((tpbuf (generate-new-buffer " *fast-lock*")) - (buname (buffer-name)) (saved t)) - (message "Saving %s font lock cache..." buname) + (verbose (if (numberp fast-lock-verbose) + (> (buffer-size) fast-lock-verbose) + fast-lock-verbose)) + (saved t)) + (if verbose (message "Saving %s font lock cache..." (buffer-name))) (condition-case nil (save-excursion (print (list 'fast-lock-cache-data 2 @@ -519,10 +532,10 @@ fast-lock-cache-filename file)) (error (setq saved 'error)) (quit (setq saved 'quit))) (kill-buffer tpbuf) - (message "Saving %s font lock cache...%s" buname - (cond ((eq saved 'error) "failed") - ((eq saved 'quit) "aborted") - (t "done"))) + (if verbose (message "Saving %s font lock cache...%s" (buffer-name) + (cond ((eq saved 'error) "failed") + ((eq saved 'quit) "aborted") + (t "done")))) ;; We return non-nil regardless of whether a failure occurred. saved)) @@ -539,23 +552,26 @@ ;; the current buffer's file timestamp matches the TIMESTAMP, and the current ;; buffer's font-lock-keywords are the same as KEYWORDS. (let ((buf-timestamp (visited-file-modtime)) - (buname (buffer-name)) (loaded t)) + (verbose (if (numberp fast-lock-verbose) + (> (buffer-size) fast-lock-verbose) + fast-lock-verbose)) + (loaded t)) (if (or (/= version 2) (buffer-modified-p) (not (equal timestamp buf-timestamp)) (not (equal keywords font-lock-keywords))) (setq loaded nil) - (message "Loading %s font lock cache..." buname) + (if verbose (message "Loading %s font lock cache..." (buffer-name))) (condition-case nil (fast-lock-set-face-properties properties) (error (setq loaded 'error)) (quit (setq loaded 'quit))) - (message "Loading %s font lock cache...%s" buname - (cond ((eq loaded 'error) "failed") - ((eq loaded 'quit) "aborted") - (t "done")))) + (if verbose (message "Loading %s font lock cache...%s" (buffer-name) + (cond ((eq loaded 'error) "failed") + ((eq loaded 'quit) "aborted") + (t "done"))))) (setq font-lock-fontified (eq loaded t) fast-lock-cache-timestamp (and (eq loaded t) timestamp)))) - +;;;;;^L ;; Text Properties Processing Functions: ;; This is faster, but fails if adjacent characters have different `face' text @@ -578,24 +594,47 @@ ; (setq start (next-single-property-change end 'face))) ; properties))) +;; This copes if adjacent characters have different `face' text properties, but +;; fails if they are lists. +;(defun fast-lock-get-face-properties () +; "Return a list of all `face' text properties in the current buffer. +;Each element of the list is of the form (VALUE START1 END1 START2 END2 ...) +;where VALUE is a `face' property value and STARTx and ENDx are positions. +;Only those `face' VALUEs in `fast-lock-save-faces' are returned." +; (save-restriction +; (widen) +; (let ((faces (or fast-lock-save-faces (face-list))) (limit (point-max)) +; properties regions face start end) +; (while faces +; (setq face (car faces) faces (cdr faces) regions () end (point-min)) +; ;; Make a list of start/end regions with `face' property face. +; (while (setq start (text-property-any end limit 'face face)) +; (setq end (or (text-property-not-all start limit 'face face) limit) +; regions (cons start (cons end regions)))) +; ;; Add `face' face's regions, if any, to properties. +; (when regions +; (push (cons face regions) properties))) +; properties))) + (defun fast-lock-get-face-properties () "Return a list of all `face' text properties in the current buffer. Each element of the list is of the form (VALUE START1 END1 START2 END2 ...) -where VALUE is a `face' property value and STARTx and ENDx are positions. -Only those `face' VALUEs in `fast-lock-save-faces' are returned." +where VALUE is a `face' property value and STARTx and ENDx are positions." (save-restriction (widen) - (let ((faces (or fast-lock-save-faces (face-list))) (limit (point-max)) - properties regions face start end) - (while faces - (setq face (car faces) faces (cdr faces) regions () end (point-min)) - ;; Make a list of start/end regions with `face' property face. - (while (setq start (text-property-any end limit 'face face)) - (setq end (or (text-property-not-all start limit 'face face) limit) - regions (cons start (cons end regions)))) - ;; Add `face' face's regions, if any, to properties. - (when regions - (push (cons face regions) properties))) + (let ((start (text-property-not-all (point-min) (point-max) 'face nil)) + (limit (point-max)) end properties value cell) + (while start + (setq end (next-single-property-change start 'face nil limit) + value (get-text-property start 'face)) + ;; Make, or add to existing, list of regions with same `face'. + (cond ((setq cell (assoc value properties)) + (setcdr cell (cons start (cons end (cdr cell))))) + ((fast-lock-save-facep value) + (push (list value start end) properties))) + (setq start (if (get-text-property end 'face) + end + (next-single-property-change end 'face)))) properties))) (defun fast-lock-set-face-properties (properties) @@ -614,7 +653,7 @@ (while regions (set-text-properties (nth 0 regions) (nth 1 regions) plist) (setq regions (nthcdr 2 regions))))))) - +;;;;;^L ;; Functions for XEmacs: (when (save-match-data (string-match "XEmacs" (emacs-version))) @@ -633,13 +672,12 @@ (function (lambda (extent ignore) (let ((value (extent-face extent))) ;; We're only interested if it's one of `fast-lock-save-faces'. - (when (and value (or (null fast-lock-save-faces) - (memq value fast-lock-save-faces))) + (when (and value (fast-lock-save-facep value)) (let ((start (extent-start-position extent)) (end (extent-end-position extent))) ;; Make or add to existing list of regions with the same ;; `face' property value. - (if (setq cell (assq value properties)) + (if (setq cell (assoc value properties)) (setcdr cell (cons start (cons end (cdr cell)))) (push (list value start end) properties)))) ;; Return nil to keep `map-extents' going. @@ -680,7 +718,7 @@ (unless (fboundp 'font-lock-compile-keywords) (defalias 'font-lock-compile-keywords 'identity)) - +;;;;;^L ;; Install ourselves: (add-hook 'after-save-hook 'fast-lock-save-cache-after-save-file) diff -r b88636d63495 -r 8fc7fe29b841 lisp/packages/info.el --- a/lisp/packages/info.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/packages/info.el Mon Aug 13 08:50:29 2007 +0200 @@ -1826,11 +1826,11 @@ (interactive) (if Info-standalone (save-buffers-kill-emacs) - (switch-to-buffer (prog1 (other-buffer (current-buffer)) - (bury-buffer (current-buffer)) - (if (featurep 'toolbar) - (if (frame-live-p toolbar-info-frame) - (delete-frame toolbar-info-frame))))))) + (bury-buffer (current-buffer)) + (if (and (featurep 'toolbar) + (eq toolbar-info-frame (selected-frame))) + (delete-frame toolbar-info-frame) + (switch-to-buffer (other-buffer (current-buffer)))))) (defun Info-undefined () "Make command be undefined in Info." diff -r b88636d63495 -r 8fc7fe29b841 lisp/packages/webjump.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/packages/webjump.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,493 @@ +;;; webjump.el --- programmable Web hotlist + +;; Copyright (C) 1996 Free Software Foundation + +;; Author: Neil W. Van Dyke +;; Created: Fri 09 Aug 1996 +;; Version: 1.4 +;; Keywords: webjump web www browse-url +;; X-URL: http://www.cs.brown.edu/people/nwv/ + +;; This file is not yet part of GNU Emacs. + +;; This 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 2, or (at your option) any later version. + +;; This 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 +;; GNU Emacs; see the file COPYING. If not, write to the Free Software +;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +;;; Change Log: + +;; [Version 1.4, Tue 17 Sep 1995, nwv] Removed the evil "defconst-TEST" that +;; slipped into 1.3. Organized webjump-sample-sites and modified the content a +;; bit. + +;; [Version 1.3, Fri 30 Aug 1996, nwv] Fixed broken `if' function in +;; `webjump-to-javaapi' (bugfix already posted). Added `webjump-to-iwin'. +;; Added comment on purpose of `webjump-sample-sites'. Added +;; `webjump-read-choice'. + +;; [Version 1.2, Fri 16 Aug 1996, nwv] Oops, got Gamelan mixed up with Digital +;; Espresso somehow. Added `mirrors' builtin and used it for the sample GNU +;; Archive site. Added some other sample sites. Split sample sites out into +;; separate constant. Misc. small changes. Copyright has been transferred to +;; the FSF. + +;; [Version 1.1, Sat 10 Aug 1996, nwv] Added missing call to `webjump-url-fix' +;; (thanks to Istvan Marko for pointing this out). Added +;; ``builtins'' concept in order to support `simple-query' builtin for covering +;; the majority of cases. Added a couple more sample sites. + +;; [Version 1.0, Fri 09 Aug 1996, nwv] Wrote initial version and posted to +;; gnu.emacs.sources. + +;;; Commentary: + +;; WebJump provides a sort of ``programmable hotlist'' of Web sites that can +;; quickly be invoked in your Web browser. Each Web site in the hotlist has a +;; name, and you select the desired site name via a completing string prompt in +;; the minibuffer. The URL for each Web site is defined as a static string or +;; a built-in or custom function, allowing interactive prompting for +;; site-specific queries and options. + +;; Note that WebJump was originally intended to complement your conventional +;; browser-based hotlist, not replace it. (Though there's no reason you +;; couldn't use WebJump for your entire hotlist if you were so inclined.) + +;; The `webjump-sites' variable, which defines the hotlist, defaults to some +;; example sites. You'll probably want to override it with your own favorite +;; sites. The documentation for the variable describes the syntax. + +;; You may wish to add something like the following to your `.emacs' file: +;; +;; (load "webjump") +;; (global-set-key "\C-c\C-j" 'webjump) +;; (setq webjump-sites +;; (append '( +;; ("My Home Page" . "www.someisp.net/users/joebobjr/") +;; ("Pop's Site" . "www.joebob-and-son.com/") +;; ) +;; webjump-sample-sites)) +;; +;; The above loads this package, binds `C-c C-j' to invoke WebJump, and adds +;; your personal favorite sites to the hotlist. + +;; The `webjump-sample-sites' constant mostly contains sites that are expected +;; to be generally useful to Emacs users or that have some sort of query which +;; can be coded in WebJump. There are two main goals of this sample site list: +;; (1) demonstrate WebJump capabilities and usage; (2) provide definitions for +;; many popular sites so that people don't have to reinvent the wheel. A few +;; assorted other sites have been thrown in on a whim. No commercial sites are +;; included unless they provide a free, generally-useful service. Inclusion of +;; a site does not represent an endorsement. Please contact the maintainer +;; with change requests. + +;; The `browse-url' package is used to submit URLs to the browser, so any +;; browser-specific configuration should be done there. + +;; WebJump inherits a small amount code from my `altavista.el' package, and is +;; intended to obsolete that package. + +;;; Code: + +;;-------------------------------------------------------- Package Dependencies + +(require 'browse-url) + +;;------------------------------------------------------ Package Identification + +(defconst webjump-version "1.4") +(defconst webjump-author "Neil W. Van Dyke ") +(defconst webjump-maintainer-address "nwv@acm.org") +(defconst webjump-vc-id + "$Id: webjump.el,v 1.1 1997/02/14 19:21:45 steve Exp $") + +;;------------------------------------------------------------------- Constants + +(defconst webjump-sample-sites + '( + + ;; FSF, not including Emacs-specific. + ("GNU Project FTP Archive". + [mirrors "ftp://prep.ai.mit.edu/pub/gnu/" + ;; ASIA: + "ftp://ftp.cs.titech.ac.jp" + "ftp://tron.um.u-tokyo.ac.jp/pub/GNU/prep" + "ftp://cair-archive.kaist.ac.kr/pub/gnu" + "ftp://ftp.nectec.or.th/pub/mirrors/gnu" + ;; AUSTRALIA: + "ftp://archie.au/gnu" + "ftp://archie.oz/gnu" + "ftp://archie.oz.au/gnu" + ;; AFRICA: + "ftp://ftp.sun.ac.za/pub/gnu" + ;; MIDDLE-EAST: + "ftp://ftp.technion.ac.il/pub/unsupported/gnu" + ;; EUROPE: + "ftp://irisa.irisa.fr/pub/gnu" + "ftp://ftp.univ-lyon1.fr/pub/gnu" + "ftp://ftp.mcc.ac.uk" + "ftp://unix.hensa.ac.uk/mirrors/uunet/systems/gnu" + "ftp://src.doc.ic.ac.uk/gnu" + "ftp://ftp.ieunet.ie/pub/gnu" + "ftp://ftp.eunet.ch" + "ftp://nic.switch.ch/mirror/gnu" + "ftp://ftp.informatik.rwth-aachen.de/pub/gnu" + "ftp://ftp.informatik.tu-muenchen.de" + "ftp://ftp.win.tue.nl/pub/gnu" + "ftp://ftp.nl.net" + "ftp://ftp.etsimo.uniovi.es/pub/gnu" + "ftp://ftp.funet.fi/pub/gnu" + "ftp://ftp.denet.dk" + "ftp://ftp.stacken.kth.se" + "ftp://isy.liu.se" + "ftp://ftp.luth.se/pub/unix/gnu" + "ftp://ftp.sunet.se/pub/gnu" + "ftp://archive.eu.net" + ;; SOUTH AMERICA: + "ftp://ftp.inf.utfsm.cl/pub/gnu" + "ftp://ftp.unicamp.br/pub/gnu" + ;; WESTERN CANADA: + "ftp://ftp.cs.ubc.ca/mirror2/gnu" + ;; USA: + "ftp://wuarchive.wustl.edu/systems/gnu" + "ftp://labrea.stanford.edu" + "ftp://ftp.digex.net/pub/gnu" + "ftp://ftp.kpc.com/pub/mirror/gnu" + "ftp://f.ms.uky.edu/pub3/gnu" + "ftp://jaguar.utah.edu/gnustuff" + "ftp://ftp.hawaii.edu/mirrors/gnu" + "ftp://uiarchive.cso.uiuc.edu/pub/gnu" + "ftp://ftp.cs.columbia.edu/archives/gnu/prep" + "ftp://gatekeeper.dec.com/pub/GNU" + "ftp://ftp.uu.net/systems/gnu"]) + ("GNU Project Home Page" . "www.fsf.org") + ;"www.gnu.ai.mit.edu" + ;"agnes.dida.physik.uni-essen.de/~gnu" + + ;; Emacs. + ("Eieio" . "ftp.ultranet.com/pub/zappo/") + ("Emacs Lisp Archive" . + "ftp://archive.cis.ohio-state.edu/pub/gnu/emacs/elisp-archive/") + ("Insidious Big Brother Database" . "home.netscape.com/people/jwz/bbdb/") + ;"ftp.xemacs.org/pub/bbdb/" + ("Mailcrypt" . "cag-www.lcs.mit.edu/mailcrypt/") + ("XEmacs Home" . "www.xemacs.org") ; Doesn't hurt to have this here. :) + ("Yahoo: Emacs" . + "www.yahoo.com/Computers_and_Internet/Software/Editors/Emacs/") + + ;; General interest. + ("AltaVista" . + [simple-query + "www.altavista.digital.com" + "www.altavista.digital.com/cgi-bin/query?pg=aq&what=web&fmt=.&q=" + "&r=&d0=&d1="]) + ("Archie" . + [simple-query "http://hoohoo.ncsa.uiuc.edu/cgi-bin/AA.pl" + "http://hoohoo.ncsa.uiuc.edu/cgi-bin/AA.pl?query=" ""]) + ("Interactive Weather Information Network" . webjump-to-iwin) + ("Lycos" . + [simple-query "www.lycos.com" "www.lycos.com/cgi-bin/pursuit?query=" ""]) + ("Usenet FAQs" . + [simple-query "www.cis.ohio-state.edu/hypertext/faq/usenet/FAQ-List.html" + "www.cis.ohio-state.edu/htbin/search-usenet-faqs/form?find=" + ""]) + ("RTFM Usenet FAQs by Group" . + "ftp://rtfm.mit.edu/pub/usenet-by-group/") + ("RTFM Usenet FAQs by Hierachy" . + "ftp://rtfm.mit.edu/pub/usenet-by-hierarchy/") + ("Webster" . + [simple-query "c.gp.cs.cmu.edu:5103/prog/webster" + "gs213.sp.cs.cmu.edu/prog/webster?" ""]) + ("X Consortium Archive". "ftp.x.org") + ("Yahoo" . + [simple-query "www.yahoo.com" "search.yahoo.com/bin/search?p=" ""]) + ("Yahoo: Reference" "www.yahoo.com/Reference/") + + ;; Computer privacy and social issues. + ("Computer Professionals for Social Responsibility" . "www.cpsr.org/dox/") + ("Electronic Frontier Foundation" . "www.eff.org") + ("Pretty Good Privacy" . "web.mit.edu/network/pgp.html") + ("Risks Digest" . webjump-to-risks) + + ;; Java. + ("Digital Espresso" . + [simple-query "www.io.org/~mentor/DigitalEspresso.html" + "www.jars.com/cgi-bin/aglimpse/01?query=" + "&case=on&whole=on&errors=0&maxfiles=100&maxlines=30"]) + ("Java API" . webjump-to-javaapi) + + ;; Fun. + ("Bastard Operator from Hell" . "www.replay.com/bofh/") + ("Dilbert" . "www.unitedmedia.com/comics/dilbert/") + ("Playboy" . (if (webjump-adult-p) "www.playboy.com" "www.whitehouse.gov")) + + ;; Author's indulgence. + ("Brown University" . + [simple-query "www.brown.edu" "www.brown.edu/cgi-local/bsearch?" ""]) + + ) + "Sample hotlist for WebJump.") + +(defconst webjump-state-to-postal-alist + '(("Alabama" . "al") ("Alaska" . "ak") ("Arizona" . "az") ("Arkansas" . "ar") + ("California" . "ca") ("Colorado" . "co") ("Connecticut" . "ct") + ("Delaware" . "de") ("Florida" . "fl") ("Georgia" . "ga") ("Hawaii" . "hi") + ("Idaho" . "id") ("Illinois" . "il") ("Indiana" . "in") ("Iowa" . "ia") + ("Kansas" . "ks") ("Kentucky" . "ky") ("Louisiana" . "la") ("Maine" . "me") + ("Maryland" . "md") ("Massachusetts" . "ma") ("Michigan" . "mi") + ("Minnesota" . "mn") ("Mississippi" . "ms") ("Missouri" . "mo") + ("Montana" . "mt") ("Nebraska" . "ne") ("Nevada" . "nv") + ("New Hampshire" . "nh") ("New Jersey" . "nj") ("New Mexico" . "nm") + ("New York" . "ny") ("North Carolina" . "nc") ("North Dakota" . "nd") + ("Ohio" . "oh") ("Oklahoma" . "ok") ("Oregon" . "or") + ("Pennsylvania" . "pa") ("Rhode Island" . "ri") ("South Carolina" . "sc") + ("South Dakota" . "sd") ("Tennessee" . "tn") ("Texas" . "tx") + ("Utah" . "ut") ("Vermont" . "vt") ("Virginia" . "va") + ("Washington" . "wa") ("West Virginia" . "wv") ("Wisconsin" . "wi") + ("Wyoming" . "wy"))) + +;;------------------------------------------------------------ Option Variables + +(defvar webjump-sites + webjump-sample-sites + "*Hotlist for WebJump. + +The hotlist is represented as an association list, with the CAR of each cell +being the name of the Web site, and the CDR being the definition for the URL of +that site. The URL definition can be a string (the URL), a vector (specifying +a special \"builtin\" which returns a URL), a symbol (name of a function which +returns a URL), or a list (which when `eval'ed yields a URL). + +If the URL definition is a vector, then a \"builtin\" is used. A builtin has a +Lisp-like syntax, with the name as the first element of the vector, and any +arguments as the following elements. The three current builtins are `name', +which returns the name of the site as the URL, `simple-query', which +returns a URL that is a function of a query entered by the user, and `mirrors', +which allows the user to select from among multiple mirror sites for the same +content. + +The first argument to the `simple-query' builtin is a static URL to use if the +user enters a blank query. The second and third arguments are the prefix and +suffix, respectively, to add to the encoded query the user enters. This +builtin covers Web sites that have single-string searches with the query +embedded in the URL. + +The arguments to the `mirrors' builtin are URLs of mirror sites. + +If the symbol of a function is given, then the function will be called with the +Web site name (the one you specified in the CAR of the alist cell) as a +parameter. This might come in handy for various kludges. + +For convenience, if the `http://', `ftp://', or `file://' prefix is missing +from a URL, WebJump will make a guess at what you wanted and prepend it before +submitting the URL.") + +;;------------------------------------------------------- Sample Site Functions + +(defun webjump-to-iwin (name) + (let ((prefix "http://iwin.nws.noaa.gov/") + (state (webjump-read-choice name "state" + (append '(("Puerto Rico" . "pr")) + webjump-state-to-postal-alist)))) + (if state + (concat prefix "iwin/" state "/" + (webjump-read-choice name "option" + '(("Hourly Report" . "hourly") + ("State Forecast" . "state") + ("Local Forecast" . "local") + ("Zone Forecast" . "zone") + ("Short-Term Forecast" . "shortterm") + ("Weather Summary" . "summary") + ("Public Information" . "public") + ("Climatic Data" . "climate") + ("Aviation Products" . "aviation") + ("Hydro Products" . "hydro") + ("Special Weather" . "special") + ("Watches and Warnings" . "warnings")) + "zone") + ".html") + prefix))) + +(defun webjump-to-javaapi (name) + (let* ((prefix "http://www.javasoft.com/products/JDK/CurrentRelease/api/") + (packages '(("java.applet") ("java.awt") ("java.awt.image") + ("java.awt.peer") ("java.io") ("java.lang") ("java.net") + ("java.util") ("sun.tools.debug"))) + (completion-ignore-case t) + (package (completing-read (concat name " package: ") packages nil t))) + (if (webjump-null-or-blank-string-p package) + (concat prefix "packages.html") + (concat prefix "Package-" package ".html")))) + +(defun webjump-to-risks (name) + (let (issue volume) + (if (and (setq volume (webjump-read-number (concat name " volume"))) + (setq issue (webjump-read-number (concat name " issue")))) + (format "catless.ncl.ac.uk/Risks/%d.%02d.html" volume issue) + "catless.ncl.ac.uk/Risks/"))) + +;;-------------------------------------------------------------- Core Functions + +;;;###autoload +(defun webjump () + "Jumps to a Web site from a programmable hotlist. + +See the documentation for the `webjump-sites' variable for how to customize the +hotlist. + +Feedback on WebJump can be sent to the author, Neil W. Van Dyke , +or submitted via `\\[webjump-submit-bug-report]'. The latest version can be +gotten from `http://www.cs.brown.edu/people/nwv/'." + (interactive) + (let* ((completion-ignore-case t) + (item (assoc (completing-read "WebJump to site: " webjump-sites nil t) + webjump-sites)) + (name (car item)) + (expr (cdr item))) + (funcall browse-url-browser-function + (webjump-url-fix + (cond ((not expr) "") + ((stringp expr) expr) + ((vectorp expr) (webjump-builtin expr name)) + ((listp expr) (eval expr)) + ((symbolp expr) + (if (fboundp expr) + (funcall expr name) + (error "WebJump URL function \"%s\" undefined." expr))) + (t (error "WebJump URL expression for \"%s\" invalid." + name))))))) + +(defun webjump-adult-p () + (and (boundp 'age) (integerp age) (>= age 21))) + +(defun webjump-builtin (expr name) + (if (< (length expr) 1) + (error "WebJump URL builtin for \"%s\" empty." name)) + (let ((builtin (aref expr 0))) + (cond + ((eq builtin 'mirrors) + (if (= (length expr) 1) + (error + "WebJump URL builtin \"mirrors\" for \"%s\" needs at least 1 arg.")) + (webjump-choose-mirror name (cdr (append expr nil)))) + ((eq builtin 'name) + name) + ((eq builtin 'simple-query) + (webjump-builtin-check-args expr name 3) + (webjump-do-simple-query name (aref expr 1) (aref expr 2) (aref expr 3))) + (t (error "WebJump URL builtin \"%s\" for \"%s\" invalid." + builtin name))))) + +(defun webjump-builtin-check-args (expr name count) + (or (= (length expr) (1+ count)) + (error "WebJump URL builtin \"%s\" for \"%s\" needs %d args." + (aref expr 0) name count))) + +(defun webjump-choose-mirror (name urls) + (webjump-read-url-choice (concat name " mirror") + urls + (webjump-mirror-default urls))) + +(defun webjump-do-simple-query (name noquery-url query-prefix query-suffix) + (let ((query (webjump-read-string (concat name " query")))) + (if query + (concat query-prefix (webjump-url-encode query) query-suffix) + noquery-url))) + +(defun webjump-mirror-default (urls) + ;; Note: This should be modified to apply some simple kludges/heuristics to + ;; pick a site which is likely "close". As a tie-breaker among candidates + ;; judged equally desirable, randomness should be used. + (car urls)) + +(defun webjump-read-choice (name what choices &optional default) + (let* ((completion-ignore-case t) + (choice (completing-read (concat name " " what ": ") choices nil t))) + (if (webjump-null-or-blank-string-p choice) + default + (cdr (assoc choice choices))))) + +(defun webjump-read-number (prompt) + ;; Note: I should make this more robust someday. + (let ((input (webjump-read-string prompt))) + (if input (string-to-number input)))) + +(defun webjump-read-string (prompt) + (let ((input (read-string (concat prompt ": ")))) + (if (webjump-null-or-blank-string-p input) nil input))) + +(defun webjump-read-url-choice (what urls &optional default) + ;; Note: Convert this to use `webjump-read-choice' someday. + (let* ((completions (mapcar (function (lambda (n) (cons n n))) + urls)) + (input (completing-read (concat what + ;;(if default " (RET for default)" "") + ": ") + completions + nil + t))) + (if (webjump-null-or-blank-string-p input) + default + (car (assoc input completions))))) + +(defun webjump-null-or-blank-string-p (str) + (or (null str) (string-match "^[ \t]*$" str))) + +(defun webjump-submit-bug-report () + "Submit via mail a bug report on WebJump." + (interactive) + (require 'reporter) + (reporter-submit-bug-report + webjump-maintainer-address + (concat "webjump.el " webjump-version " " webjump-vc-id) + '(webjump-sites) + nil + nil + (concat + "[Dear bug report submitter: Please ensure that the variable dumps\n" + "below do not contain any information you consider private.]\n"))) + +(defun webjump-url-encode (str) + (mapconcat '(lambda (c) + (cond ((= c 32) "+") + ((or (and (>= c ?a) (<= c ?z)) + (and (>= c ?A) (<= c ?Z)) + (and (>= c ?0) (<= c ?9))) + (char-to-string c)) + (t (upcase (format "%%%02x" c))))) + str + "")) + +(defun webjump-url-fix (url) + (if (webjump-null-or-blank-string-p url) + "" + (webjump-url-fix-trailing-slash + (cond + ((string-match "^[a-zA-Z]+:" url) url) + ((string-match "^/" url) (concat "file://" url)) + ((string-match "^\\([^\\./]+\\)" url) + (concat (if (string= (downcase (match-string 1 url)) "ftp") + "ftp" + "http") + "://" + url)) + (t url))))) + +(defun webjump-url-fix-trailing-slash (url) + (if (string-match "^[a-zA-Z]+://[^/]+$" url) + (concat url "/") + url)) + +;;----------------------------------------------------------------------------- + +(provide 'webjump) + +;; webjump.el ends here diff -r b88636d63495 -r 8fc7fe29b841 lisp/prim/auto-autoloads.el --- a/lisp/prim/auto-autoloads.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/prim/auto-autoloads.el Mon Aug 13 08:50:29 2007 +0200 @@ -889,7 +889,10 @@ ;;;*** -;;;### (autoloads nil "custom" "custom/custom.el") +;;;### (autoloads (widget-browse-at) "widget-browse" "custom/widget-browse.el") + +(autoload 'widget-browse-at "widget-browse" "\ +Browse the widget under point." t nil) ;;;*** @@ -923,239 +926,6 @@ ;;;*** -;;;### (autoloads (ange-ftp-hook-function) "ange-ftp" "dired/ange-ftp.el") - -(defvar ange-ftp-path-format '("^/\\(\\([^@/:]*\\)@\\)?\\([^@/:]*\\):\\(.*\\)" 3 2 4) "\ -*Format of a fully expanded remote pathname. This is a cons -\(REGEXP . (HOST USER PATH)), where REGEXP is a regular expression matching -the full remote pathname, and HOST, USER, and PATH are the numbers of -parenthesized expressions in REGEXP for the components (in that order).") - -(autoload 'ange-ftp-hook-function "ange-ftp" nil nil nil) - -(or (assoc (car ange-ftp-path-format) file-name-handler-alist) (setq file-name-handler-alist (cons (cons (car ange-ftp-path-format) 'ange-ftp-hook-function) file-name-handler-alist))) - -;;;*** - -;;;### (autoloads (dired-make-permissions-interactive) "dired-chmod" "dired/dired-chmod.el") - -(autoload 'dired-make-permissions-interactive "dired-chmod" nil nil nil) - -;;;*** - -;;;### (autoloads (dired-cwd-make-magic) "dired-cwd" "dired/dired-cwd.el") - -(autoload 'dired-cwd-make-magic "dired-cwd" "\ -Modify COMMAND so that it's working directory is the current dired directory. -This works by binding `default-directory' to `(default-directory)'s value. -See also function `default-directory'." t nil) - -;;;*** - -;;;### (autoloads (dired-do-rename-list dired-do-rename-numeric) "dired-num" "dired/dired-num.el") - -(autoload 'dired-do-rename-numeric "dired-num" "\ -Rename all marked (or next ARG) files using numbers. -You are prompted for a format string, e.g \"part_%d_of_8\", and a starting -number, e.g. 1. If there are 8 marked files, this example will rename them to - - part_1_of_8 - part_2_of_8 - ... - part_8_of_8" t nil) - -(autoload 'dired-do-rename-list "dired-num" "\ -Rename all marked (or next ARG) files using elements from LIST. -You are prompted for a format string, e.g \"x_%s\", and the list, -e.g. '(foo bar zod). This example will rename the marked files to - - x_foo - x_bar - x_zod - -It is an error if LIST has not as many elements as there are files." t nil) - -;;;*** - -;;;### (autoloads (dired-rcs-mark-rcs-files dired-rcs-mark-rcs-locked-files) "dired-rcs" "dired/dired-rcs.el") - -(autoload 'dired-rcs-mark-rcs-locked-files "dired-rcs" "\ -Mark all files that are under RCS control and RCS-locked. -With prefix argument, unflag all those files. -Mentions RCS files for which a working file was not found in this buffer. -Type \\[dired-why] to see them again." t nil) - -(autoload 'dired-rcs-mark-rcs-files "dired-rcs" "\ -Mark all files that are under RCS control. -With prefix argument, unflag all those files. -Mentions RCS files for which a working file was not found in this buffer. -Type \\[dired-why] to see them again." t nil) - -;;;*** - -;;;### (autoloads (dired-extra-startup) "dired-x" "dired/dired-x.el") - -(autoload 'dired-extra-startup "dired-x" "\ -Automatically put on dired-mode-hook to get extra dired features: -\\ - \\[dired-vm] -- VM on folder - \\[dired-rmail] -- Rmail on folder - \\[dired-do-insert-subdir] -- insert all marked subdirs - \\[dired-do-find-file] -- visit all marked files simultaneously - \\[dired-set-marker-char], \\[dired-restore-marker-char] -- change and display dired-marker-char dynamically. - \\[dired-omit-toggle] -- toggle omitting of files - \\[dired-mark-sexp] -- mark by lisp expression - \\[dired-do-unmark] -- replace existing marker with another. - \\[dired-mark-rcs-files] -- mark all RCS controlled files - \\[dired-mark-files-compilation-buffer] -- mark compilation files - \\[dired-copy-filename-as-kill] -- copy the file or subdir names into the kill ring. - You can feed it to other commands using \\[yank]. - -For more features, see variables - - dired-omit-files - dired-omit-extenstions - dired-dangerous-shell-command - dired-mark-keys - dired-local-variables-file - dired-find-subdir - dired-guess-have-gnutar - dired-auto-shell-command-alist - -See also functions - - dired-sort-on-size - dired-do-relsymlink - dired-flag-extension - dired-virtual - dired-jump-back - dired-jump-back-other-window -" t nil) - -;;;*** - -;;;### (autoloads (dired-noselect dired-other-window dired) "dired" "dired/dired.el") - -(defvar dired-listing-switches (purecopy "-al") "\ -*Switches passed to ls for dired. MUST contain the `l' option. -Can contain even `F', `b', `i' and `s'.") - -(defvar dired-chown-program (purecopy (if (memq system-type '(dgux-unix hpux usg-unix-v silicon-graphics-unix irix)) "chown" "/etc/chown")) "\ -*Name of chown command (usully `chown' or `/etc/chown').") - -(defvar dired-ls-program (purecopy "ls") "\ -*Absolute or relative name of the ls program used by dired.") - -(defvar dired-ls-F-marks-symlinks t "\ -*Informs dired about how ls -lF marks symbolic links. -Set this to t if `dired-ls-program' with -lF marks the symbolic link -itself with a trailing @ (usually the case under Ultrix). - -Example: if `ln -s foo bar; ls -F bar' gives `bar -> foo', set it to -nil, if it gives `bar@ -> foo', set it to t. - -Dired checks if there is really a @ appended. Thus, if you have a -marking ls program on one host and a non-marking on another host, and -don't care about symbolic links which really end in a @, you can -always set this variable to t.") - -(defvar dired-trivial-filenames (purecopy "^\\.\\.?$\\|^#") "\ -*Regexp of files to skip when moving point to the first file of a new directory listing. -Nil means move to the subdir line, t means move to first file.") - -(defvar dired-keep-marker-move t "\ -If t, moved marked files are marked if their originals were. -If a character, those files (marked or not) are marked with that character.") - -(defvar dired-keep-marker-copy 67 "\ -If t, copied files are marked if their source files were. -If a character, those files are always marked with that character.") - -(defvar dired-keep-marker-hardlink 72 "\ -If t, hard-linked files are marked if the linked-to files were. -If a character, those files are always marked with that character.") - -(defvar dired-keep-marker-symlink 89 "\ -If t, symlinked marked files are marked if the linked-to files were. -If a character, those files are always marked with that character.") - -(defvar dired-dwim-target nil "\ -*If non-nil, dired tries to guess a default target directory: -If there is a dired buffer displayed in the next window, use -its current subdir, instead of the current subdir of this dired -buffer. - -The target is used in the prompt for file copy, move etc.") - -(defvar dired-copy-preserve-time nil "\ -*If non-nil, Dired preserves the last-modified time in a file copy. -\(This works on only some systems.)\\ -Use `\\[dired-do-copy]' with a zero prefix argument to toggle its value.") - -(define-key ctl-x-map "d" 'dired) - -(autoload 'dired "dired" "\ -\"Edit\" directory DIRNAME--delete, rename, print, etc. some files in it. -With an optional prefix argument you can specify the ls SWITCHES that are used. -Dired displays a list of files in DIRNAME (which may also have - shell wildcards appended to select certain files). -You can move around in it with the usual commands. -You can flag files for deletion with \\\\[dired-flag-file-deleted] and then delete them by - typing \\[dired-do-deletions]. -Type \\[describe-mode] after entering dired for more info. - -If DIRNAME is already in a dired buffer, that buffer is used without refresh." t nil) - -(define-key ctl-x-4-map "d" 'dired-other-window) - -(autoload 'dired-other-window "dired" "\ -\"Edit\" directory DIRNAME. Like `dired' but selects in another window." t nil) - -(autoload 'dired-noselect "dired" "\ -Like `dired' but returns the dired buffer as value, does not select it." nil nil) - -;;;*** - -;;;### (autoloads (find-grep-dired find-name-dired find-dired) "find-dired" "dired/find-dired.el") - -(defvar find-ls-option (purecopy (if (eq system-type 'berkeley-unix) '("-ls" . "-gilsb") '("-exec ls -ld {} \\;" . "-ld"))) "\ -*Description of the option to `find' to produce an `ls -l'-type listing. -This is a cons of two strings (FIND-OPTION . LS-SWITCHES). FIND-OPTION -gives the option (or options) to `find' that produce the desired output. -LS-SWITCHES is a list of `ls' switches to tell dired how to parse the output.") - -(defvar find-grep-options (purecopy (if (eq system-type 'berkeley-unix) "-s" "-q")) "\ -*Option to grep to be as silent as possible. -On Berkeley systems, this is `-s'; on Posix, and with GNU grep, `-q' does it. -On other systems, the closest you can come is to use `-l'.") - -(defvar find-dired-multiple-buffers nil "\ -*If non-nil, generates a new buffer for each find") - -(autoload 'find-dired "find-dired" "\ -Run `find' and go into dired-mode on a buffer of the output. -The command run (after changing into DIR) is - - find . \\( ARGS \\) -ls" t nil) - -(autoload 'find-name-dired "find-dired" "\ -Search DIR recursively for files matching the globbing pattern PATTERN, -and run dired on those files. -PATTERN is a shell wildcard (not an Emacs regexp) and need not be quoted. -The command run (after changing into DIR) is - - find . -name 'PATTERN' -ls" t nil) - -(autoload 'find-grep-dired "find-dired" "\ -Find files in DIR containing a regexp ARG and start Dired on output. -The command run (after changing into DIR) is - - find . -type f -exec test -r {} \\; -exec egrep -s ARG {} \\; -ls - -Thus ARG can also contain additional grep options." t nil) - -;;;*** - ;;;### (autoloads (edebug-eval-top-level-form def-edebug-spec) "edebug" "edebug/edebug.el") (autoload 'def-edebug-spec "edebug" "\ @@ -1352,6 +1122,202 @@ ;;;*** +;;;### (autoloads nil "default-dir" "efs/default-dir.el") + +(defvar default-directory-function nil "\ +A function to call to compute the default-directory for the current buffer. +If this is nil, the function default-directory will return the value of the +variable default-directory. +Buffer local.") + +;;;*** + +;;;### (autoloads (dired-jump-back-other-frame dired-jump-back-other-window dired-jump-back dired-noselect dired-other-frame dired-other-window dired) "dired" "efs/dired.el") + +(defvar dired-compression-method 'compress "\ +*Type of compression program to use. +Give as a symbol. +Currently-recognized methods are: gzip pack compact compress. +To change this variable use \\[dired-do-compress] with a zero prefix.") + +(defvar dired-compression-method-alist '((gzip ".gz" ("gzip") ("gzip" "-d") "-f") (compress ".Z" ("compress" "-f") ("compress" "-d") "-f") (pack ".z" ("pack" "-f") ("unpack")) (compact ".C" ("compact") ("uncompact"))) "\ +*Association list of compression method descriptions. + Each element of the table should be a list of the form + + (compress-type extension (compress-args) (decompress-args) force-flag) + + where + `compress-type' is a unique symbol in the alist to which + `dired-compression-method' can be set; + `extension' is the file extension (as a string) used by files compressed + by this method; + `compress-args' is a list of the path of the compression program and + flags to pass as separate arguments; + `decompress-args' is a list of the path of the decompression + program and flags to pass as separate arguments. + `force-flag' is the switch to pass to the command to force overwriting + of existing files. + + For example: + + (setq dired-compresssion-method-alist + (cons '(frobnicate \".frob\" (\"frob\") (\"frob\" \"-d\") \"-f\") + dired-compression-method-alist)) + => ((frobnicate \".frob\" (\"frob\") (\"frob\" \"-d\")) + (gzip \".gz\" (\"gzip\") (\"gunzip\")) + ...) + + See also: dired-compression-method ") + +(defvar dired-ls-program "ls" "\ +*Absolute or relative name of the ls program used by dired.") + +(defvar dired-listing-switches "-al" "\ +*Switches passed to ls for dired. MUST contain the `l' option. +Can contain even `F', `b', `i' and `s'.") + +(defvar dired-chown-program (if (memq system-type '(hpux dgux usg-unix-v)) "chown" "/etc/chown") "\ +*Name of chown command (usully `chown' or `/etc/chown').") + +(defvar dired-gnutar-program nil "\ +*If non-nil, name of the GNU tar executable (e.g. \"tar\" or \"gnutar\"). +GNU tar's `z' switch is used for compressed tar files. +If you don't have GNU tar, set this to nil: a pipe using `zcat' is then used.") + +(defvar dired-unshar-program nil "\ +*Set to the name of the unshar program, if you have it.") + +(defvar dired-local-variables-file ".dired" "\ +*If non-nil, filename for local variables for Dired. +If Dired finds a file with that name in the current directory, it will +temporarily insert it into the dired buffer and run `hack-local-variables'. + +Type \\[info] and `g' `(emacs)File Variables' `RET' for more info on +local variables.") + +(defvar dired-kept-versions 2 "\ +*When cleaning directory, number of versions to keep.") + +(defvar dired-find-subdir nil "\ +*Determines whether dired tries to lookup a subdir in existing buffers. +If non-nil, dired does not make a new buffer for a directory if it can be +found (perhaps as subdir) in some existing dired buffer. If there are several +dired buffers for a directory, then the most recently used one is chosen. + +Dired avoids switching to the current buffer, so that if you have +a normal and a wildcard buffer for the same directory, C-x d RET will +toggle between those two.") + +(defvar dired-use-file-transformers t "\ +*Determines whether dired uses file transformers. +If non-nil `dired-do-shell-command' will apply file transformers to file names. +See \\[describe-function] for dired-do-shell-command for more information.") + +(defvar dired-dwim-target nil "\ +*If non-nil, dired tries to guess a default target directory. +This means that if there is a dired buffer displayed in the next window, +use its current subdir, instead of the current subdir of this dired buffer. +The target is put in the prompt for file copy, rename, etc.") + +(defvar dired-copy-preserve-time nil "\ +*If non-nil, Dired preserves the last-modified time in a file copy. +\(This works on only some systems.)\\ +Use `\\[dired-do-copy]' with a zero prefix argument to toggle its value.") + +(defvar dired-no-confirm nil "\ +*If non-nil, a list of symbols for commands dired should not confirm. +It can be a sublist of + + '(byte-compile chgrp chmod chown compress copy delete hardlink load + move print shell symlink uncompress recursive-delete kill-file-buffer + kill-dired-buffer patch create-top-dir revert-subdirs) + +The meanings of most of the symbols are obvious. A few exceptions: + + 'compress applies to compression or decompression by any of the + compression program in `dired-compression-method-alist'. + + 'kill-dired-buffer applies to offering to kill dired buffers for + directories which have been deleted. + + 'kill-file-buffer applies to offering to kill buffers visiting files + which have been deleted. + + 'recursive-delete applies to recursively deleting non-empty + directories, and all of their contents. + + 'create-top-dir applies to `dired-up-directory' creating a new top level + directory for the dired buffer. + + 'revert-subdirs applies to re-reading subdirectories which have + been modified on disk. + +Note that this list also applies to remote files accessed with efs +or ange-ftp.") + +(defvar dired-backup-if-overwrite nil "\ +*Non-nil if Dired should ask about making backups before overwriting files. +Special value 'always suppresses confirmation.") + +(defvar dired-omit-files nil "\ +*If non-nil un-interesting files will be omitted from this dired buffer. +Use \\[dired-omit-toggle] to see these files. (buffer local)") + +(defvar dired-mail-reader 'rmail "\ +*Mail reader used by dired for dired-read-mail (\\[dired-read-mail]). +The symbols 'rmail and 'vm are the only two allowed values.") + +(define-key ctl-x-map "d" 'dired) + +(autoload 'dired "dired" "\ +\"Edit\" directory DIRNAME--delete, rename, print, etc. some files in it. +Optional second argument SWITCHES specifies the `ls' options used. +\(Interactively, use a prefix argument to be able to specify SWITCHES.) +Dired displays a list of files in DIRNAME (which may also have +shell wildcards appended to select certain files). If DIRNAME is a cons, +its first element is taken as the directory name and the resr as an explicit +list of files to make directory entries for. +\\You can move around in it with the usual commands. +You can flag files for deletion with \\[dired-flag-file-deletion] and then +delete them by typing \\[dired-expunge-deletions]. +Type \\[dired-describe-mode] after entering dired for more info. + +If DIRNAME is already in a dired buffer, that buffer is used without refresh." t nil) + +(define-key ctl-x-4-map "d" 'dired-other-window) + +(autoload 'dired-other-window "dired" "\ +\"Edit\" directory DIRNAME. Like `dired' but selects in another window." t nil) + +(define-key ctl-x-5-map "d" 'dired-other-frame) + +(autoload 'dired-other-frame "dired" "\ +\"Edit\" directory DIRNAME. Like `dired' but makes a new frame." t nil) + +(autoload 'dired-noselect "dired" "\ +Like `dired' but returns the dired buffer as value, does not select it." nil nil) + +(define-key ctl-x-map "\C-j" 'dired-jump-back) + +(autoload 'dired-jump-back "dired" "\ +Jump back to dired. +If in a file, dired the current directory and move to file's line. +If in dired already, pop up a level and goto old directory's line. +In case the proper dired file line cannot be found, refresh the dired + buffer and try again." t nil) + +(define-key ctl-x-4-map "\C-j" 'dired-jump-back-other-window) + +(autoload 'dired-jump-back-other-window "dired" "\ +Like \\[dired-jump-back], but to other window." t nil) + +(define-key ctl-x-5-map "\C-j" 'dired-jump-back-other-frame) + +(autoload 'dired-jump-back-other-frame "dired" "\ +Like \\[dired-jump-back], but in another frame." t nil) + +;;;*** + ;;;### (autoloads (electric-buffer-list) "ebuff-menu" "electric/ebuff-menu.el") (autoload 'electric-buffer-list "ebuff-menu" "\ @@ -1848,6 +1814,67 @@ ;;;*** +;;;### (autoloads (mine-help mine-version mine) "mine" "games/mine.el") + +(autoload 'mine "mine" "\ +Play Mine. Optional prefix argument is the number of mines. + +To play Mine, type `\\[mine]' or `\\[universal-argument] NUM \\[mine]'. + +An optional prefix argument specifies the number of mines to be hidden +in the field. If no prefix argument is given, a percentage +`mine-mines-%' of the field will contain mines. + +What is Mine?\\ + +Mine is a classical game of hide and seek played on a rectangular grid +containing `mine-xmax' by `mine-ymax' squares (the mine field). + +Your opponent (Emacs, in this case) has hidden several mines within +this field. The object of the game is to find every hidden mine. + +When you're sure a square does NOT contain a mine, you can hit it: +move the mouse over the square and press `\\[mine-mouse-hit]' or +move the cursor with the usual keys and press `\\[mine-hit-curpoint]'. + +If the square is a mine, you loose. +If the square isn't a mine, a number appears which represents +the number of mines in the surrounding eight squares. + +When you think a square DOES contain a mine, you can mark it: +move the mouse over the square and press `\\[mine-mouse-mark]' or +move the cursor with the usual keys and press `\\[mine-mark-curpoint]'. + +The number of hidden mines remaining in the mine field is indicated +inside the buffer. Every time you mark a square as a mine, this +number decreases by one, even if you incorrectly mark a square. + +If `mine-torus' is non-nil (the default), the Mine game is played over +a periodic field (like a torus). Each mine is hidden periodically +over the mine board `mine-nb-tiles-x' times in the x direction and +`mine-nb-tiles-y' times in the y direction. + +If `mine-colorp' is non-nil (the default, if the system allows it), +the game is displayed with colors. The colors can be chosen with the +variable `mine-colors'. + +If the redisplay is not fast enough, increase `mine-level'. If you +want to see a smoother (slower) redisplay, decrease `mine-level', +`mine-count1-max' and `mine-count2-max'. + +You can get help on `mine-mode' and its key bindings by pressing `\\[mine-help]' +while in the *Mine* buffer. +" t nil) + +(autoload 'mine-version "mine" "\ +Return string describing the current version of Mine. +When called interactively, displays the version." t nil) + +(autoload 'mine-help "mine" "\ +*Get help on `mine-mode'." t nil) + +;;;*** + ;;;### (autoloads (mpuz) "mpuz" "games/mpuz.el") (autoload 'mpuz "mpuz" "\ @@ -2224,6 +2251,43 @@ ;;;*** +;;;### (autoloads (tmpl-insert-template-file tmpl-insert-template-file-from-fixed-dirs tmpl-expand-templates-in-buffer tmpl-expand-templates-in-region) "tmpl-minor-mode" "hm--html-menus/tmpl-minor-mode.el") + +(autoload 'tmpl-expand-templates-in-region "tmpl-minor-mode" "\ +Expand the templates in the region from BEGIN to END. +If BEGIN and and are nil, then the current region is used." t nil) + +(autoload 'tmpl-expand-templates-in-buffer "tmpl-minor-mode" "\ +Expand all templates in the current buffer." t nil) + +(autoload 'tmpl-insert-template-file-from-fixed-dirs "tmpl-minor-mode" "\ +Inserts a template FILE and expands it, if `tmpl-automatic-expand' is t. +This command tries to read the template file from a list of +predefined directries (look at `tmpl-template-dir-list') and it filters +the contents of this directories with the regular expression +`tmpl-filter-regexp' (look also at this variable). +The command uses a history variable, which could be changed with the +variable `tmpl-history-variable-name'. + +The user of the command is able to change interactive to another +directory by entering at first the string \"Change the directory\". +This maybe to difficult for the user. Therefore another command +called `tmpl-insert-template-file' exist, which doesn't use fixed +directories and filters." t nil) + +(autoload 'tmpl-insert-template-file "tmpl-minor-mode" "\ +Insert a template FILE and expand it, if `tmpl-automatic-expand' is t. +Look also at `tmpl-template-dir-list', to specify a default template directory. +You should also take a look at `tmpl-insert-template-file-from-fixed-dirs' +which has additional advantages (and disadvantages :-). + +ATTENTION: The interface of this function has changed. The old +function had the argument list (&optional TEMPLATE-DIR AUTOMATIC-EXPAND). +The variables `tmpl-template-dir-list' and `tmpl-automatic-expand' must +now be used instead of the args TEMPLATE-DIR and AUTOMATIC-EXPAND." t nil) + +;;;*** + ;;;### (autoloads (hmail:compose) "hmail" "hyperbole/hmail.el") (autoload 'hmail:compose "hmail" "\ @@ -3546,7 +3610,7 @@ ;;;### (autoloads (ksh-mode) "ksh-mode" "modes/ksh-mode.el") (autoload 'ksh-mode "ksh-mode" "\ -ksh-mode $Revision: 1.6 $ - Major mode for editing (Bourne, Korn or Bourne again) +ksh-mode $Revision: 1.7 $ - Major mode for editing (Bourne, Korn or Bourne again) shell scripts. Special key bindings and commands: \\{ksh-mode-map} @@ -4759,11 +4823,66 @@ ;;;*** +;;;### (autoloads (verilog-mode) "verilog-mode" "modes/verilog-mode.el") + +(autoload 'verilog-mode "verilog-mode" "\ +Major mode for editing Verilog code. \\ +NEWLINE, TAB indents for Verilog code. +Delete converts tabs to spaces as it moves back. +Supports highlighting. + +Variables controlling indentation/edit style: + + verilog-indent-level (default 3) + Indentation of Verilog statements with respect to containing block. + verilog-cexp-indent (default 1) + Indentation of Verilog statements broken across lines. + verilog-case-indent (default 2) + Indentation for case statements. + verilog-auto-newline (default nil) + Non-nil means automatically newline after simcolons and the punctation mark + after an end. + verilog-auto-indent-on-newline (default t) + Non-nil means automatically indent line after newline + verilog-tab-always-indent (default t) + Non-nil means TAB in Verilog mode should always reindent the current line, + regardless of where in the line point is when the TAB command is used. + verilog-indent-begin-after-if (default t) + Non-nil means to indent begin statements following a preceeding + if, else, while, for and repeat statements, if any. otherwise, + the begin is lined up with the preceeding token. If t, you get: + if (a) + begin + otherwise you get: + if (a) + begin + verilog-auto-endcomments (default t) + Non-nil means a comment /* ... */ is set after the ends which ends cases, tasks, functions and modules. + The type and name of the object will be set between the braces. + verilog-auto-lineup (default `(all)) + List of contexts where auto lineup of :'s or ='s should be done. + +Turning on Verilog mode calls the value of the variable verilog-mode-hook with +no args, if that value is non-nil. +Other useful functions are: +\\[verilog-complete-word] -complete word with appropriate possibilities (functions, verilog keywords...) +\\[verilog-comment-area] - Put marked area in a comment, fixing nested comments. +\\[verilog-uncomment-area] - Uncomment an area commented with \\[verilog-comment-area]. +\\[verilog-insert-block] - insert begin ... end; +\\[verilog-star-comment] - insert /* ... */ +\\[verilog-mark-defun] - Mark function. +\\[verilog-beg-of-defun] - Move to beginning of current function. +\\[verilog-end-of-defun] - Move to end of current function. +\\[verilog-label-be] - Label matching begin ... end, fork ... join and case ... endcase statements; +" t nil) + +;;;*** + ;;;### (autoloads (vhdl-mode) "vhdl-mode" "modes/vhdl-mode.el") (autoload 'vhdl-mode "vhdl-mode" "\ Major mode for editing VHDL code. -vhdl-mode $Revision: 1.6 $ +vhdl-mode $Revision: 1.7 $ To submit a problem report, enter `\\[vhdl-submit-bug-report]' from a vhdl-mode buffer. This automatically sets up a mail buffer with version information already added. You just need to add a description of the @@ -5879,9 +5998,7 @@ Various methods of control are provided for the Font Lock cache. In general, see variable `fast-lock-cache-directories' and function `fast-lock-cache-name'. For saving, see variables `fast-lock-minimum-size', `fast-lock-save-events', -`fast-lock-save-others' and `fast-lock-save-faces'. - -Use \\[fast-lock-submit-bug-report] to send bug reports or feedback." t nil) +`fast-lock-save-others' and `fast-lock-save-faces'." t nil) (autoload 'turn-on-fast-lock "fast-lock" "\ Unconditionally turn on Fast Lock mode." nil nil) @@ -7337,6 +7454,20 @@ ;;;*** +;;;### (autoloads (webjump) "webjump" "packages/webjump.el") + +(autoload 'webjump "webjump" "\ +Jumps to a Web site from a programmable hotlist. + +See the documentation for the `webjump-sites' variable for how to customize the +hotlist. + +Feedback on WebJump can be sent to the author, Neil W. Van Dyke , +or submitted via `\\[webjump-submit-bug-report]'. The latest version can be +gotten from `http://www.cs.brown.edu/people/nwv/'." t nil) + +;;;*** + ;;;### (autoloads (webster-spell webster-endings webster) "webster" "packages/webster.el") (autoload 'webster "webster" "\ @@ -7516,7 +7647,7 @@ ;;;*** -;;;### (autoloads (apply-macro-to-region-lines kbd-macro-query insert-kbd-macro name-last-kbd-macro) "macros" "prim/macros.el") +;;;### (autoloads (apply-macro-to-region-lines kbd-macro-query name-last-kbd-macro) "macros" "prim/macros.el") (autoload 'name-last-kbd-macro "macros" "\ Assign a name to the last keyboard macro defined. @@ -7525,20 +7656,6 @@ Such a \"function\" cannot be called from Lisp, but it is a valid editor command." t nil) -(autoload 'insert-kbd-macro "macros" "\ -Insert in buffer the definition of kbd macro NAME, as Lisp code. -Optional second argument KEYS means also record the keys it is on -\(this is the prefix argument, when calling interactively). - -This Lisp code will, when executed, define the kbd macro with the -same definition it has now. If you say to record the keys, -the Lisp code will also rebind those keys to the macro. -Only global key bindings are recorded since executing this Lisp code -always makes global bindings. - -To save a kbd macro, visit a file of Lisp code such as your `~/.emacs', -use this command, and then save the file." t nil) - (autoload 'kbd-macro-query "macros" "\ Query user during kbd macro execution. With prefix argument, enters recursive edit, @@ -7836,9 +7953,11 @@ (autoload 'load-sound-file "sound" "\ Read in an audio-file and add it to the sound-alist. -You can only play sound files if you are running on display 0 of the console -of a Sun SparcStation, SGI machine, or HP9000s700, or running a NetAudio -server. The sound file must be in the Sun/NeXT U-LAW format." t nil) +You can only play sound files if you are running on display 0 of the +console of a machine with native sound support or running a NetAudio +server and XEmacs has the necessary sound support compiled in. + +The sound file must be in the Sun/NeXT U-LAW format." t nil) (autoload 'load-default-sounds "sound" "\ Load and install some sound files as beep-types. @@ -8542,6 +8661,93 @@ ;;;*** +;;;### (autoloads (insert-kbd-macro format-kbd-macro read-kbd-macro edit-named-kbd-macro edit-last-kbd-macro edit-kbd-macro) "edmacro" "utils/edmacro.el") + +(define-key ctl-x-map "\C-k" 'edit-kbd-macro) + +(defvar edmacro-eight-bits nil "\ +*Non-nil if edit-kbd-macro should leave 8-bit characters intact. +Default nil means to write characters above \\177 in octal notation.") + +(autoload 'edit-kbd-macro "edmacro" "\ +Edit a keyboard macro. +At the prompt, type any key sequence which is bound to a keyboard macro. +Or, type `C-x e' or RET to edit the last keyboard macro, `C-h l' to edit +the last 100 keystrokes as a keyboard macro, or `M-x' to edit a macro by +its command name. +With a prefix argument, format the macro in a more concise way." t nil) + +(autoload 'edit-last-kbd-macro "edmacro" "\ +Edit the most recently defined keyboard macro." t nil) + +(autoload 'edit-named-kbd-macro "edmacro" "\ +Edit a keyboard macro which has been given a name by `name-last-kbd-macro'." t nil) + +(autoload 'read-kbd-macro "edmacro" "\ +Read the region as a keyboard macro definition. +The region is interpreted as spelled-out keystrokes, e.g., \"M-x abc RET\". +See documentation for `edmacro-mode' for details. +Leading/trailing \"C-x (\" and \"C-x )\" in the text are allowed and ignored. +The resulting macro is installed as the \"current\" keyboard macro. + +In Lisp, may also be called with a single STRING argument in which case +the result is returned rather than being installed as the current macro. +The result will be a string if possible, otherwise an event vector. +Second argument NEED-VECTOR means to return an event vector always." t nil) + +(autoload 'format-kbd-macro "edmacro" "\ +Return the keyboard macro MACRO as a human-readable string. +This string is suitable for passing to `read-kbd-macro'. +Second argument VERBOSE means to put one command per line with comments. +If VERBOSE is `1', put everything on one line. If VERBOSE is omitted +or nil, use a compact 80-column format." nil nil) + +(autoload 'insert-kbd-macro "edmacro" "\ +Insert in buffer the definition of kbd macro NAME, as Lisp code. +Optional second arg KEYS means also record the keys it is on +\(this is the prefix argument, when calling interactively). + +This Lisp code will, when executed, define the kbd macro with the same +definition it has now. If you say to record the keys, the Lisp code +will also rebind those keys to the macro. Only global key bindings +are recorded since executing this Lisp code always makes global +bindings. + +To save a kbd macro, visit a file of Lisp code such as your `~/.emacs', +use this command, and then save the file." t nil) + +;;;*** + +;;;### (autoloads (turn-on-eldoc-mode eldoc-mode) "eldoc" "utils/eldoc.el") + +(defvar eldoc-mode nil "\ +*If non-nil, show the defined parameters for the elisp function near point. + +For the emacs lisp function at the beginning of the sexp which point is +within, show the defined parameters for the function in the echo area. +This information is extracted directly from the function or macro if it is +in pure lisp. If the emacs function is a subr, the parameters are obtained +from the documentation string if possible. + +If point is over a documented variable, print that variable's docstring +instead. + +This variable is buffer-local.") + +(autoload 'eldoc-mode "eldoc" "\ +*Enable or disable eldoc mode. +See documentation for the variable of the same name for more details. + +If called interactively with no prefix argument, toggle current condition +of the mode. +If called with a positive or negative prefix argument, enable or disable +the mode, respectively." t nil) + +(autoload 'turn-on-eldoc-mode "eldoc" "\ +Unequivocally turn on eldoc-mode (see variable documentation)." t nil) + +;;;*** + ;;;### (autoloads (elp-submit-bug-report elp-results elp-instrument-package elp-instrument-list elp-restore-function elp-instrument-function) "elp" "utils/elp.el") (autoload 'elp-instrument-function "elp" "\ @@ -8673,6 +8879,33 @@ ;;;*** +;;;### (autoloads (floating-toolbar-from-extent-or-popup-mode-menu floating-toolbar-or-popup-mode-menu floating-toolbar) "floating-toolbar" "utils/floating-toolbar.el") + +(autoload 'floating-toolbar "floating-toolbar" "\ +Popup a toolbar near the current mouse position. +The toolbar instantiator used is taken from the 'floating-toolbar +property of any extent under the mouse. If no such non-nil +property exists for any extent under the mouse, then the value of the +variable `floating-toolbar' is checked. If its value si nil, then +no toolbar will be displayed. + +This command should be bound to a button press event. + +When called from a program, first arg EVENT should be the button +press event. Optional second arg EXTENT-LOCAL-ONLY specifies +that only extent local toolbars should be used; this means the +`floating-toolbar' variable will not be consulted." t nil) + +(autoload 'floating-toolbar-or-popup-mode-menu "floating-toolbar" "\ +Like floating-toolbar, but if no toolbar is displayed +run popup-mode-menu." t nil) + +(autoload 'floating-toolbar-from-extent-or-popup-mode-menu "floating-toolbar" "\ +Like floating-toolbar-or-popup-mode-menu, but search only for an +extent local toolbar." t nil) + +;;;*** + ;;;### (autoloads (enable-flow-control-on enable-flow-control) "flow-ctrl" "utils/flow-ctrl.el") (autoload 'enable-flow-control "flow-ctrl" "\ @@ -9318,16 +9551,12 @@ (autoload 'w3-open-local "w3" "\ Find a local file, and interpret it as a hypertext document. It will prompt for an existing file or directory, and retrieve it as a -hypertext document. If it is a directory, and url-use-hypertext-dired -is non-nil, then an HTML directory listing is created on the fly. -Otherwise, dired-mode is used to visit the buffer." t nil) +hypertext document." t nil) (autoload 'w3-find-file "w3" "\ Find a local file, and interpret it as a hypertext document. It will prompt for an existing file or directory, and retrieve it as a -hypertext document. If it is a directory, and url-use-hypertext-dired -is non-nil, then an HTML directory listing is created on the fly. -Otherwise, dired-mode is used to visit the buffer." t nil) +hypertext document." t nil) (autoload 'w3-fetch-other-frame "w3" "\ Attempt to follow the hypertext reference under point in a new frame. diff -r b88636d63495 -r 8fc7fe29b841 lisp/prim/case-table.el --- a/lisp/prim/case-table.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/prim/case-table.el Mon Aug 13 08:50:29 2007 +0200 @@ -17,7 +17,7 @@ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Free Software Foundation, 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ;;; Synched up with: Not synched with FSF. @@ -33,30 +33,29 @@ (defun describe-buffer-case-table () "Describe the case table of the current buffer." (interactive) - (let ((vector (make-vector 256 nil)) - (case-table (current-case-table)) - (ch 0)) + (let ((ch 0)) (with-displaying-help-buffer - (set-buffer standard-output) - (while (< ch 256) - (cond ((/= ch (downcase ch)) - (insert (text-char-description ch)) - (indent-to 16) - (insert "uppercase, matches " - (text-char-description (downcase ch)) - "\n")) - ((/= ch (upcase ch)) - (insert (text-char-description ch)) - (indent-to 16) - (insert "lowercase, matches " - (text-char-description (upcase ch)) - "\n")) + (lambda () + (set-buffer standard-output) + (while (< ch 256) + (cond ((/= ch (downcase ch)) + (insert (text-char-description ch)) + (indent-to 16) + (insert "uppercase, matches " + (text-char-description (downcase ch)) + "\n")) + ((/= ch (upcase ch)) + (insert (text-char-description ch)) + (indent-to 16) + (insert "lowercase, matches " + (text-char-description (upcase ch)) + "\n")) ;; (t ;; (insert (text-char-description ch)) ;; (indent-to 16) ;; (insert "case-invariant\n")) ) - (setq ch (1+ ch)))))) + (setq ch (1+ ch))))))) (defun invert-case (count) "Change the case of the character just after point and move over it. diff -r b88636d63495 -r 8fc7fe29b841 lisp/prim/files.el --- a/lisp/prim/files.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/prim/files.el Mon Aug 13 08:50:29 2007 +0200 @@ -2572,7 +2572,10 @@ files (buffer (get-buffer-create " *recover*"))) ;; #### dired-do-flagged-delete in FSF. - (dired-do-deletions t) + ;; This version is for ange-ftp + ;;(dired-do-deletions t) + ;T This version is for efs + (dired-expunge-deletions) (unwind-protect (save-excursion ;; Read in the auto-save-list file. @@ -3003,6 +3006,14 @@ filename (error "Apparently circular symlink path")))) +;; Suggested by Michael Kifer +(defun file-remote-p (file) + "Test whether file resides on the local system. +The special value 'unknown is returned if no remote file access package +has been loaded." + (cond ((fboundp 'efs-ftp-path) (efs-ftp-path name)) + ((fboundp 'ange-ftp-ftp-name) (ange-ftp-ftp-name name)) + (t 'unknown))) ;; Written in C in FSF (defun insert-file-contents (filename &optional visit beg end replace) diff -r b88636d63495 -r 8fc7fe29b841 lisp/prim/frame.el --- a/lisp/prim/frame.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/prim/frame.el Mon Aug 13 08:50:29 2007 +0200 @@ -1010,6 +1010,9 @@ (append (list save-frame) frames) frames))) +(defvar temp-buffer-shrink-to-fit t + "*When non-nil resize temporary output buffers to minimize blank lines.") + (defun show-temp-buffer-in-current-frame (buffer) "For use as the value of temp-buffer-show-function: always displays the buffer in the current frame, regardless of the behavior @@ -1023,7 +1026,8 @@ (setq minibuffer-scroll-window window) (set-window-start window 1) ; obeys narrowing (set-window-point window 1) - (shrink-window-if-larger-than-buffer window) + (when temp-buffer-shrink-to-fit + (shrink-window-if-larger-than-buffer window)) nil))) (setq pre-display-buffer-function 'get-frame-for-buffer) diff -r b88636d63495 -r 8fc7fe29b841 lisp/prim/glyphs.el --- a/lisp/prim/glyphs.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/prim/glyphs.el Mon Aug 13 08:50:29 2007 +0200 @@ -599,13 +599,15 @@ ,@(if (featurep 'xpm) '(("^/\\* XPM \\*/" [xpm :data nil] 2))) ,@(if (featurep 'xface) '(("^X-Face:" [xface :data nil] 2))) ,@(if (featurep 'gif) '(("\.gif$" [gif :file nil] 2))) - ,@(if (featurep 'gif) '(("^GIF87" [gif :data nil] 2))) + ,@(if (featurep 'gif) '(("^GIF8[79]" [gif :data nil] 2))) ,@(if (featurep 'jpeg) '(("\.jpeg$" [jpeg :file nil] 2))) ,@(if (featurep 'jpeg) '(("\.jpg$" [jpeg :file nil] 2))) ;; all of the JFIF-format JPEG's that I've seen begin with ;; the following. I have no idea if this is standard. ,@(if (featurep 'jpeg) '(("^\377\330\340\000\020JFIF" [jpeg :data nil] 2))) + ,@(if (featurep 'png) '(("\.png$" [png :file nil] 2))) + ,@(if (featurep 'png) '(("^\211PNG" [png :data nil] 2))) ("" [autodetect :data nil] 2)))) ;; #### this should really be formatted-string, not string but we ;; don't have it implemented yet diff -r b88636d63495 -r 8fc7fe29b841 lisp/prim/help.el --- a/lisp/prim/help.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/prim/help.el Mon Aug 13 08:50:29 2007 +0200 @@ -382,7 +382,8 @@ (t (message (substitute-command-keys "Type \\[switch-to-buffer-other-window] to restore the other window, \\[scroll-other-window] to scroll the help.")))) - (shrink-window-if-larger-than-buffer helpwin))))))) + (when temp-buffer-shrink-to-fit + (shrink-window-if-larger-than-buffer helpwin)))))))) (defun describe-key (key) "Display documentation of the function invoked by KEY. diff -r b88636d63495 -r 8fc7fe29b841 lisp/prim/lisp.el --- a/lisp/prim/lisp.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/prim/lisp.el Mon Aug 13 08:50:29 2007 +0200 @@ -327,8 +327,9 @@ (setq list (nreverse new)))) (with-output-to-temp-buffer "*Completions*" (display-completion-list list)) - (shrink-window-if-larger-than-buffer - (get-buffer-window "*Completions*"))) + (when temp-buffer-shrink-to-fit + (shrink-window-if-larger-than-buffer + (get-buffer-window "*Completions*")))) (message "Making completion list...%s" "done"))))) ;;; lisp.el ends here diff -r b88636d63495 -r 8fc7fe29b841 lisp/prim/macros.el --- a/lisp/prim/macros.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/prim/macros.el Mon Aug 13 08:50:29 2007 +0200 @@ -31,6 +31,8 @@ ;; lisp corresponding to a macro, query the user from within a macro, ;; or apply a macro to each line in the reason. +;; This file is largely superseded by edmacro.el as of XEmacs 20.1. -sb + ;;; Code: ;;;###autoload @@ -50,91 +52,91 @@ symbol)) (fset symbol last-kbd-macro)) -(defun insert-kbd-macro-pretty-string (string) - ;; Convert control characters to the traditional readable representation: - ;; put the four characters \M-x in the buffer instead of the one char \370, - ;; which would deceptively print as `oslash' with the default settings. - (save-restriction - (narrow-to-region (point) (point)) - (prin1 string (current-buffer)) - (goto-char (1+ (point-min))) - (while (not (eobp)) - (cond ((= (following-char) 0) (insert "\\C-@") (delete-char 1)) - ((= (following-char) ?\n) (insert "\\n") (delete-char 1)) - ((= (following-char) ?\r) (insert "\\r") (delete-char 1)) - ((= (following-char) ?\t) (insert "\\t") (delete-char 1)) - ((= (following-char) ?\e) (insert "\\e") (delete-char 1)) - ((= (following-char) 127) (insert "\\C-?") (delete-char 1)) - ((= (following-char) 128) (insert "\\M-\\C-@") (delete-char 1)) - ((= (following-char) 255) (insert "\\M-\\C-?") (delete-char 1)) - ((and (> (following-char) 127) (< (following-char) 155)) - (insert "\\M-\\C-") - (insert (- (following-char) 32)) - (delete-char 1) - (forward-char -1)) - ((and (>= (following-char) 155) (< (following-char) 160)) - (insert "\\M-\\C-") - (insert (- (following-char) 64)) - (delete-char 1) - (forward-char -1)) - ((>= (following-char) 160) - (insert "\\M-") - (insert (- (following-char) 128)) - (delete-char 1) - (forward-char -1)) - ((< (following-char) 27) - ;;(insert "\\^") (insert (+ (following-char) 64)) - (insert "\\C-") (insert (+ (following-char) 96)) - (delete-char 1) - (forward-char -1)) - ((< (following-char) 32) - ;;(insert "\\^") (insert (+ (following-char) 64)) - (insert "\\C-") (insert (+ (following-char) 64)) - (delete-char 1) - (forward-char -1)) - (t - (forward-char 1)))))) +;(defun insert-kbd-macro-pretty-string (string) +; ;; Convert control characters to the traditional readable representation: +; ;; put the four characters \M-x in the buffer instead of the one char \370, +; ;; which would deceptively print as `oslash' with the default settings. +; (save-restriction +; (narrow-to-region (point) (point)) +; (prin1 string (current-buffer)) +; (goto-char (1+ (point-min))) +; (while (not (eobp)) +; (cond ((= (following-char) 0) (insert "\\C-@") (delete-char 1)) +; ((= (following-char) ?\n) (insert "\\n") (delete-char 1)) +; ((= (following-char) ?\r) (insert "\\r") (delete-char 1)) +; ((= (following-char) ?\t) (insert "\\t") (delete-char 1)) +; ((= (following-char) ?\e) (insert "\\e") (delete-char 1)) +; ((= (following-char) 127) (insert "\\C-?") (delete-char 1)) +; ((= (following-char) 128) (insert "\\M-\\C-@") (delete-char 1)) +; ((= (following-char) 255) (insert "\\M-\\C-?") (delete-char 1)) +; ((and (> (following-char) 127) (< (following-char) 155)) +; (insert "\\M-\\C-") +; (insert (- (following-char) 32)) +; (delete-char 1) +; (forward-char -1)) +; ((and (>= (following-char) 155) (< (following-char) 160)) +; (insert "\\M-\\C-") +; (insert (- (following-char) 64)) +; (delete-char 1) +; (forward-char -1)) +; ((>= (following-char) 160) +; (insert "\\M-") +; (insert (- (following-char) 128)) +; (delete-char 1) +; (forward-char -1)) +; ((< (following-char) 27) +; ;;(insert "\\^") (insert (+ (following-char) 64)) +; (insert "\\C-") (insert (+ (following-char) 96)) +; (delete-char 1) +; (forward-char -1)) +; ((< (following-char) 32) +; ;;(insert "\\^") (insert (+ (following-char) 64)) +; (insert "\\C-") (insert (+ (following-char) 64)) +; (delete-char 1) +; (forward-char -1)) +; (t +; (forward-char 1)))))) -;;;###autoload -(defun insert-kbd-macro (macroname &optional keys) - "Insert in buffer the definition of kbd macro NAME, as Lisp code. -Optional second argument KEYS means also record the keys it is on -\(this is the prefix argument, when calling interactively). +;; ;;;###autoload +;(defun insert-kbd-macro (macroname &optional keys) +; "Insert in buffer the definition of kbd macro NAME, as Lisp code. +;Optional second argument KEYS means also record the keys it is on +;\(this is the prefix argument, when calling interactively). -This Lisp code will, when executed, define the kbd macro with the -same definition it has now. If you say to record the keys, -the Lisp code will also rebind those keys to the macro. -Only global key bindings are recorded since executing this Lisp code -always makes global bindings. +;This Lisp code will, when executed, define the kbd macro with the +;same definition it has now. If you say to record the keys, +;the Lisp code will also rebind those keys to the macro. +;Only global key bindings are recorded since executing this Lisp code +;always makes global bindings. -To save a kbd macro, visit a file of Lisp code such as your `~/.emacs', -use this command, and then save the file." - (interactive "CInsert kbd macro (name): \nP") - (let (definition) - (if (string= (symbol-name macroname) "") - (progn - (setq macroname 'last-kbd-macro - definition last-kbd-macro) - (insert "(setq ")) - (progn - (setq definition (symbol-function macroname)) - (insert "(fset '"))) - (prin1 macroname (current-buffer)) - (insert "\n ") - (let ((string (events-to-keys definition t))) - (if (stringp string) - (insert-kbd-macro-pretty-string string) - (prin1 string (current-buffer)))) - (insert ")\n") - (if keys - (let ((keys (where-is-internal macroname))) - (while keys - (insert "(global-set-key ") - (prin1 (car keys) (current-buffer)) - (insert " '") - (prin1 macroname (current-buffer)) - (insert ")\n") - (setq keys (cdr keys))))))) +;To save a kbd macro, visit a file of Lisp code such as your `~/.emacs', +;use this command, and then save the file." +; (interactive "CInsert kbd macro (name): \nP") +; (let (definition) +; (if (string= (symbol-name macroname) "") +; (progn +; (setq macroname 'last-kbd-macro +; definition last-kbd-macro) +; (insert "(setq ")) +; (progn +; (setq definition (symbol-function macroname)) +; (insert "(fset '"))) +; (prin1 macroname (current-buffer)) +; (insert "\n ") +; (let ((string (events-to-keys definition t))) +; (if (stringp string) +; (insert-kbd-macro-pretty-string string) +; (prin1 string (current-buffer)))) +; (insert ")\n") +; (if keys +; (let ((keys (where-is-internal macroname))) +; (while keys +; (insert "(global-set-key ") +; (prin1 (car keys) (current-buffer)) +; (insert " '") +; (prin1 macroname (current-buffer)) +; (insert ")\n") +; (setq keys (cdr keys))))))) ;;;###autoload (defun kbd-macro-query (flag) diff -r b88636d63495 -r 8fc7fe29b841 lisp/prim/modeline.el --- a/lisp/prim/modeline.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/prim/modeline.el Mon Aug 13 08:50:29 2007 +0200 @@ -394,7 +394,7 @@ (defvar modeline-modified-map (make-sparse-keymap 'modeline-modified-map) "Keymap consulted for mouse-clicks on the modeline-modified string.") (define-key modeline-modified-map 'button2 - (make-modeline-command-wrapper 'toggle-read-only)) + (make-modeline-command-wrapper 'vc-toggle-read-only)) (defvar modeline-modified-extent (make-extent nil nil) "Extent covering the modeline-modified string.") diff -r b88636d63495 -r 8fc7fe29b841 lisp/prim/obsolete.el --- a/lisp/prim/obsolete.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/prim/obsolete.el Mon Aug 13 08:50:29 2007 +0200 @@ -38,6 +38,13 @@ (define-function oldfun newfun) (make-obsolete oldfun newfun)) +(defsubst define-compatible-function-alias (oldfun newfun) + "Define OLDFUN as a compatible alias for function NEWFUN. +This makes calling OLDFUN equivalent to calling NEWFUN and marks OLDFUN +as provided for compatibility only." + (define-function oldfun newfun) + (make-compatible oldfun newfun)) + (defsubst define-obsolete-variable-alias (oldvar newvar) "Define OLDVAR as an obsolete alias for varction NEWVAR. This makes referencing or setting OLDVAR equivalent to referencing or @@ -45,6 +52,13 @@ (defvaralias oldvar newvar) (make-obsolete-variable oldvar newvar)) +(defsubst define-compatible-variable-alias (oldvar newvar) + "Define OLDVAR as a compatible alias for varction NEWVAR. +This makes referencing or setting OLDVAR equivalent to referencing or +setting NEWVAR and marks OLDVAR as provided for compatibility only." + (defvaralias oldvar newvar) + (make-compatible-variable oldvar newvar)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;; device stuff (make-obsolete-variable 'window-system "use (console-type)") @@ -54,24 +68,24 @@ (defun x-display-color-p (&optional device) "Returns non-nil if DEVICE is a color device." (eq 'color (device-class device))) -(make-obsolete 'x-display-color-p 'device-class) +(make-compatible 'x-display-color-p 'device-class) (define-function 'x-color-display-p 'x-display-color-p) -(make-obsolete 'x-display-color-p 'device-class) +(make-compatible 'x-display-color-p 'device-class) (defun x-display-grayscale-p (&optional device) "Returns non-nil if DEVICE is a grayscale device." (eq 'grayscale (device-class device))) -(make-obsolete 'x-display-grayscale-p 'device-class) +(make-compatible 'x-display-grayscale-p 'device-class) (define-function 'x-grayscale-display-p 'x-display-grayscale-p) -(make-obsolete 'x-display-grayscale-p 'device-class) +(make-compatible 'x-display-grayscale-p 'device-class) -(define-obsolete-function-alias 'x-display-pixel-width 'device-pixel-width) -(define-obsolete-function-alias 'x-display-pixel-height +(define-compatible-function-alias 'x-display-pixel-width 'device-pixel-width) +(define-compatible-function-alias 'x-display-pixel-height 'device-pixel-height) -(define-obsolete-function-alias 'x-display-planes 'device-bitplanes) -(define-obsolete-function-alias 'x-display-color-cells 'device-color-cells) +(define-compatible-function-alias 'x-display-planes 'device-bitplanes) +(define-compatible-function-alias 'x-display-color-cells 'device-color-cells) (define-obsolete-function-alias 'baud-rate 'device-baud-rate) @@ -246,7 +260,7 @@ (define-obsolete-variable-alias 'default-tty-frame-alist 'default-tty-frame-plist) -(make-obsolete 'frame-parameters 'frame-property) +(make-compatible 'frame-parameters 'frame-property) (defun frame-parameters (&optional frame) "Return the parameters-alist of frame FRAME. It is a list of elements of the form (PARM . VALUE), where PARM is a symbol. @@ -265,7 +279,7 @@ ;; future. (destructive-plist-to-alist (frame-properties frame))) -(make-obsolete 'modify-frame-parameters 'set-frame-properties) +(make-compatible 'modify-frame-parameters 'set-frame-properties) (defun modify-frame-parameters (frame alist) "Modify the properties of frame FRAME according to ALIST. ALIST is an alist of properties to change and their new values. @@ -308,7 +322,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;; insertion and deletion (define-obsolete-function-alias 'insert-and-inherit 'insert) -(define-obsolete-function-alias 'insert-before-markers-and-inerhit +(define-obsolete-function-alias 'insert-before-markers-and-inherit 'insert-before-markers) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; keymaps @@ -379,20 +393,20 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;; modeline -(define-obsolete-function-alias 'redraw-mode-line 'redraw-modeline) -(define-obsolete-function-alias 'force-mode-line-update +(define-compatible-function-alias 'redraw-mode-line 'redraw-modeline) +(define-compatible-function-alias 'force-mode-line-update 'redraw-modeline) ;; FSF compatibility -(define-obsolete-variable-alias 'mode-line-map 'modeline-map) -(define-obsolete-variable-alias 'mode-line-buffer-identification +(define-compatible-variable-alias 'mode-line-map 'modeline-map) +(define-compatible-variable-alias 'mode-line-buffer-identification 'modeline-buffer-identification) -(define-obsolete-variable-alias 'mode-line-process 'modeline-process) -(define-obsolete-variable-alias 'mode-line-modified 'modeline-modified) -(make-obsolete-variable 'mode-line-inverse-video +(define-compatible-variable-alias 'mode-line-process 'modeline-process) +(define-compatible-variable-alias 'mode-line-modified 'modeline-modified) +(make-compatible-variable 'mode-line-inverse-video "use set-face-highlight-p and set-face-reverse-p") -(define-obsolete-variable-alias 'default-mode-line-format +(define-compatible-variable-alias 'default-mode-line-format 'default-modeline-format) -(define-obsolete-variable-alias 'mode-line-format 'modeline-format) -(define-obsolete-variable-alias 'mode-line-menu 'modeline-menu) +(define-compatible-variable-alias 'mode-line-format 'modeline-format) +(define-compatible-variable-alias 'mode-line-menu 'modeline-menu) ;;;;;;;;;;;;;;;;;;;;;;;;;;;; mouse diff -r b88636d63495 -r 8fc7fe29b841 lisp/prim/overlay.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/prim/overlay.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,210 @@ +;;; overlay.el --- overlay support. + +;;;; Copyright (C) 1997 Free Software Foundation, Inc. + +;; Maintainer: XEmacs +;; Keywords: internal + +;; This file is part of XEmacs. + +;; XEmacs 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 2, or (at your option) +;; any later version. + +;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +(defun overlayp (object) + "Return t if OBJECT is an overlay." + (and (extentp object) + (extent-property object 'overlay))) + +(defun make-overlay (beg end &optional buffer front-advance rear-advance) + "Create a new overlay with range BEG to END in BUFFER. +If omitted, BUFFER defaults to the current buffer. +BEG and END may be integers or markers. +The fourth arg FRONT-ADVANCE, if non-nil, makes the +front delimiter advance when text is inserted there. +The fifth arg REAR-ADVANCE, if non-nil, makes the +rear delimiter advance when text is inserted there." + (let (overlay temp) + (if (null buffer) + (setq buffer (current-buffer)) + (check-argument-type 'bufferp buffer)) + + (if (> beg end) + (setq temp beg + beg end + end temp)) + + (setq overlay (make-extent beg end buffer)) + (set-extent-property overlay 'overlay t) + + (if front-advance + (set-extent-property overlay 'start-open t) + (set-extent-property overlay 'start-closed t)) + + (if rear-advance + (set-extent-property overlay 'end-closed t) + (set-extent-property overlay 'end-open t)) + + overlay)) + +(defun move-overlay (overlay beg end &optional buffer) + "Set the endpoints of OVERLAY to BEG and END in BUFFER. +If BUFFER is omitted, leave OVERLAY in the same buffer it inhabits now. +If BUFFER is omitted, and OVERLAY is in no buffer, put it in the current +buffer." + (let (temp) + (check-argument-type 'overlayp overlay) + (if (null buffer) + (setq buffer (extent-object overlay))) + + (if (null buffer) + (setq buffer (current-buffer))) + + (check-argument-type 'bufferp buffer) + + (if (and (= beg end) + (not (null (extent-property overlay 'evaporate)))) + (delete-overlay overlay) + + (if (> beg end) + (setq temp beg + beg end + end temp)) + + (set-extent-endpoints overlay beg end buffer) + overlay))) + +(defun delete-overlay (overlay) + "Delete the overlay OVERLAY from its buffer." + (check-argument-type 'overlayp overlay) + (detach-extent overlay) + nil) + +(defun overlay-start (overlay) + "Return the position at which OVERLAY starts." + (check-argument-type 'overlayp overlay) + (extent-start-position overlay)) + +(defun overlay-end (overlay) + "Return the position at which OVERLAY ends." + (check-argument-type 'overlayp overlay) + (extent-end-position overlay)) + +(defun overlay-buffer (overlay) + "Return the buffer OVERLAY belongs to." + (check-argument-type 'overlayp overlay) + (extent-object overlay)) + +(defun overlay-properties (overlay) + "Return a list of the properties on OVERLAY. +This is a copy of OVERLAY's plist; modifying its conses has no effect on +OVERLAY." + (check-argument-type 'overlayp overlay) + (extent-properties overlay)) + +(defun overlays-at (pos) + "Return a list of the overlays that contain position POS." + (overlays-in pos pos)) + +(defun overlays-in (beg end) + "Return a list of the overlays that overlap the region BEG ... END. +Overlap means that at least one character is contained within the overlay +and also contained within the specified region. +Empty overlays are included in the result if they are located at BEG +or between BEG and END." + (let (lst) + (mapcar (function + (lambda (overlay) + (and (extent-property overlay 'overlay) + (setq lst (append lst (list overlay)))))) + (extent-list nil beg end)) + lst)) + +(defun next-overlay-change (pos) + "Return the next position after POS where an overlay starts or ends. +If there are no more overlay boundaries after POS, return (point-max)." + (let ((next (point-max)) + end) + (mapcar (function + (lambda (overlay) + (if (< (setq end (extent-end-position overlay)) next) + (setq next end)))) + (overlays-in pos end)) + next)) + +(defun previous-overlay-change (pos) + "Return the previous position before POS where an overlay starts or ends. +If there are no more overlay boundaries before POS, return (point-min)." + (let ((prev (point-min)) + beg) + (mapcar (function + (lambda (overlay) + (if (and (> (setq beg (extent-start-position overlay)) prev) + (< beg pos)) + (setq prev beg)))) + (overlays-in prev pos)) + prev)) + +(defun overlay-lists () + "Return a pair of lists giving all the overlays of the current buffer. +The car has all the overlays before the overlay center; +the cdr has all the overlays after the overlay center. +Recentering overlays moves overlays between these lists. +The lists you get are copies, so that changing them has no effect. +However, the overlays you get are the real objects that the buffer uses." + (if (not (boundp 'xemacs-internal-overlay-center-pos)) + (overlay-recenter (/ (- (point-max) (point-min)) 2))) + (let ((pos xemacs-internal-overlay-center-pos) + before after) + (mapcar + (function + (lambda (overlay) + (if (extent-property overlay 'overlay) + (if (> pos (extent-end-position overlay)) + (setq before (append before (list overlay))) + (setq after (append after (list overlay))))))) + (extent-list)) + (list before after))) + +(defun overlay-recenter (pos) + "Recenter the overlays of the current buffer around position POS." + (set (make-local-variable 'xemacs-internal-overlay-center-pos) pos)) + +(defun overlay-get (overlay prop) + "Get the property of overlay OVERLAY with property name PROP." + (check-argument-type 'overlayp overlay) + (extent-property overlay prop)) + +(defun overlay-put (overlay prop value) + "Set one property of overlay OVERLAY: give property PROP value VALUE." + (check-argument-type 'overlayp overlay) + (cond ((eq prop 'evaporate) + (set-extent-property overlay 'detachable value)) + ((eq prop 'before-string) + (set-extent-property overlay 'begin-glyph + (make-glyph (vector 'string :data value)))) + ((eq prop 'after-string) + (set-extent-property overlay 'end-glyph + (make-glyph (vector 'string :data value)))) + ((memq prop '(window insert-in-front-hooks insert-behind-hooks + modification-hooks)) + (error "cannot support overlay '%s property under XEmacs" + prop))) + (set-extent-property overlay prop value)) + +(provide 'overlay) + +;;; overlay.el ends here diff -r b88636d63495 -r 8fc7fe29b841 lisp/prim/simple.el --- a/lisp/prim/simple.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/prim/simple.el Mon Aug 13 08:50:29 2007 +0200 @@ -1570,7 +1570,9 @@ (if (interactive-p) (condition-case nil (line-move arg) - ((beginning-of-buffer end-of-buffer) (ding nil 'buffer-bound))) + ((beginning-of-buffer end-of-buffer) + (when signal-error-on-buffer-boundary + (ding nil 'buffer-bound)))) (line-move arg))) nil) @@ -1591,7 +1593,9 @@ (if (interactive-p) (condition-case nil (line-move (- arg)) - ((beginning-of-buffer end-of-buffer) (ding nil 'buffer-bound))) + ((beginning-of-buffer end-of-buffer) + (when signal-error-on-buffer-boundary ; XEmacs + (ding nil 'buffer-bound)))) (line-move (- arg))) nil) @@ -1614,7 +1618,7 @@ (eval-when-compile (defvar inhibit-point-motion-hooks)) -(defvar line-move-ignore-invisible nil +(defvar line-move-ignore-invisible t "*Non-nil means \\[next-line] and \\[previous-line] ignore invisible lines. Outline mode sets this.") diff -r b88636d63495 -r 8fc7fe29b841 lisp/prim/sound.el --- a/lisp/prim/sound.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/prim/sound.el Mon Aug 13 08:50:29 2007 +0200 @@ -31,9 +31,11 @@ (defun load-sound-file (filename sound-name &optional volume) "Read in an audio-file and add it to the sound-alist. -You can only play sound files if you are running on display 0 of the console -of a Sun SparcStation, SGI machine, or HP9000s700, or running a NetAudio -server. The sound file must be in the Sun/NeXT U-LAW format." +You can only play sound files if you are running on display 0 of the +console of a machine with native sound support or running a NetAudio +server and XEmacs has the necessary sound support compiled in. + +The sound file must be in the Sun/NeXT U-LAW format." (interactive "fSound file name: \n\ SSymbol to name this sound: \n\ nVolume (0 for default): ") diff -r b88636d63495 -r 8fc7fe29b841 lisp/tl/emu-e19.el --- a/lisp/tl/emu-e19.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/tl/emu-e19.el Mon Aug 13 08:50:29 2007 +0200 @@ -3,7 +3,7 @@ ;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko -;; Version: $Id: emu-e19.el,v 1.3 1997/02/02 05:06:16 steve Exp $ +;; Version: $Id: emu-e19.el,v 1.4 1997/02/16 01:29:29 steve Exp $ ;; Keywords: emulation, compatibility, mule, Latin-1 ;; This file is part of emu. @@ -157,6 +157,21 @@ t) +;;; @ binary access +;;; + +(defun insert-binary-file-contents-literally + (filename &optional visit beg end replace) + "Like `insert-file-contents-literally', q.v., but don't code conversion. +A buffer may be modified in several ways after reading into the buffer due +to advanced Emacs features, such as file-name-handlers, format decoding, +find-file-hooks, etc. + This function ensures that none of these modifications will take place." + (let ((emx-binary-mode t)) + (insert-file-contents-literally filename visit beg end replace) + )) + + ;;; @ MIME charset ;;; diff -r b88636d63495 -r 8fc7fe29b841 lisp/tl/emu-x20.el --- a/lisp/tl/emu-x20.el Mon Aug 13 08:50:06 2007 +0200 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,244 +0,0 @@ -;;; emu-x20.el --- emu API implementation for XEmacs 20 with mule - -;; Copyright (C) 1995 Free Software Foundation, Inc. -;; Copyright (C) 1994,1995,1996 MORIOKA Tomohiko - -;; Author: MORIOKA Tomohiko -;; Version: $Id: emu-x20.el,v 1.3 1997/02/02 05:06:17 steve Exp $ -;; Keywords: emulation, compatibility, Mule, XEmacs - -;; This file is part of tl (Tiny Library). - -;; 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 2, 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 GNU XEmacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Code: - -(require 'cyrillic) -(require 'emu-xemacs) - -(defvar xemacs-beta-version - (if (string-match "(beta\\([0-9]+\\))" emacs-version) - (string-to-number - (substring emacs-version (match-beginning 1)(match-end 1)) - ))) - - -;;; @ graphic character set -;;; - -(defalias 'charset-description 'charset-doc-string) - -(defalias 'find-charset-string 'charsets-in-string) -(defalias 'find-charset-region 'charsets-in-region) - -(defun find-non-ascii-charset-string (string) - "Return a list of charsets in the STRING except ascii. -\[emu-x20.el; Mule emulating function]" - (delq 'ascii (charsets-in-string string)) - ) - -(defun find-non-ascii-charset-region (start end) - "Return a list of charsets except ascii -in the region between START and END. -\[emu-x20.el; Mule emulating function]" - (delq 'ascii (charsets-in-region start end)) - ) - - -;;; @ coding-system -;;; - -(defconst *noconv* 'no-conversion) -(defconst *ctext* 'ctext) -(defconst *hz* 'hz) -(defconst *big5* 'big5) -(defconst *euc-kr* 'euc-kr) -(defconst *koi8* 'koi8) - -(defalias 'set-buffer-file-coding-system 'set-file-coding-system) - -(defmacro as-binary-process (&rest body) - `(let (selective-display ; Disable ^M to nl translation. - process-input-coding-system - process-output-coding-system) - ,@body)) - -(defmacro as-binary-input-file (&rest body) - `(let ((file-coding-system-for-read 'no-conversion)) - ,@body)) - - -;;; @ MIME charset -;;; - -(defvar charsets-mime-charset-alist - '(((ascii) . us-ascii) - ((ascii latin-iso8859-1) . iso-8859-1) - ((ascii latin-iso8859-2) . iso-8859-2) - ((ascii latin-iso8859-3) . iso-8859-3) - ((ascii latin-iso8859-4) . iso-8859-4) -;;; ((ascii cyrillic-iso8859-5) . iso-8859-5) - ((ascii cyrillic-iso8859-5) . koi8-r) - ((ascii arabic-iso8859-6) . iso-8859-6) - ((ascii greek-iso8859-7) . iso-8859-7) - ((ascii hebrew-iso8859-8) . iso-8859-8) - ((ascii latin-iso8859-9) . iso-8859-9) - ((ascii japanese-jisx0208-1978 japanese-jisx0208) . iso-2022-jp) - ((ascii korean-ksc5601) . euc-kr) - ((ascii chinese-big5-1 chinese-big5-2) . big5) - ((ascii japanese-jisx0208-1978 chinese-gb - japanese-jisx0208 korean-ksc5601 - japanese-jisx0212 latin-iso8859-1 - greek-iso8859-7) . iso-2022-jp-2) - ((ascii japanese-jisx0208-1978 chinese-gb2312 - japanese-jisx0208 korean-ksc5601 - japanese-jisx0212 - chinese-cns11643-1 chinese-cns11643-2 - latin-iso8859-1 greek-iso8859-7) . iso-2022-int-1) - )) - -(defvar default-mime-charset 'iso-2022-int-1) - -(defvar mime-charset-coding-system-alist - '((iso-8859-1 . ctext) - (gb2312 . euc-china) - (koi8-r . koi8) - (iso-2022-jp-2 . iso-2022-ss2-7) - (x-iso-2022-jp-2 . iso-2022-ss2-7) - (shift_jis . sjis) - (x-shiftjis . sjis) - )) - -(defun mime-charset-to-coding-system (charset) - "Return coding-system by MIME charset. [emu-x20.el]" - (if (stringp charset) - (setq charset (intern (downcase charset))) - ) - (or (cdr (assq charset mime-charset-coding-system-alist)) - (and (memq charset (coding-system-list)) charset) - )) - -(defun detect-mime-charset-region (start end) - "Return MIME charset for region between START and END. -\[emu-x20.el]" - (charsets-to-mime-charset (charsets-in-region start end))) - -(defun encode-mime-charset-region (start end charset) - "Encode the text between START and END as MIME CHARSET. -\[emu-x20.el]" - (let ((cs (mime-charset-to-coding-system charset))) - (if cs - (encode-coding-region start end cs) - ))) - -(defun decode-mime-charset-region (start end charset) - "Decode the text between START and END as MIME CHARSET. -\[emu-x20.el]" - (let ((cs (mime-charset-to-coding-system charset))) - (if cs - (decode-coding-region start end cs) - ))) - -(defun encode-mime-charset-string (string charset) - "Encode the STRING as MIME CHARSET. [emu-x20.el]" - (let ((cs (mime-charset-to-coding-system charset))) - (if cs - (encode-coding-string string cs) - string))) - -(defun decode-mime-charset-string (string charset) - "Decode the STRING as MIME CHARSET. [emu-x20.el]" - (let ((cs (mime-charset-to-coding-system charset))) - (if cs - (decode-coding-string string cs) - string))) - - -;;; @ character -;;; - -;(defun char-bytes (chr) 1) - -;(defun char-length (character) -; "Return number of elements a CHARACTER occupies in a string or buffer. -;\[emu-x20.el]" -; 1) - -;(defun char-columns (character) -; "Return number of columns a CHARACTER occupies when displayed. -;\[emu-x20.el]" -; (charset-columns (char-charset character)) -; ) - -;;; @@ Mule emulating aliases -;;; -;;; You should not use them. - -;(defalias 'char-width 'char-columns) - -(defalias 'char-leading-char 'char-charset) - -(defun char-category (character) - "Return string of category mnemonics for CHAR in TABLE. -CHAR can be any multilingual character -TABLE defaults to the current buffer's category table. -\[emu-x20.el; Mule emulating function]" - (mapconcat (lambda (chr) - (char-to-string (int-char chr)) - ) - (char-category-list character) - "")) - - -;;; @ string -;;; - -;(defun string-columns (string) -; "Return number of columns STRING occupies when displayed. -;\[emu-x20.el]" -; (let ((col 0) -; (len (length string)) -; (i 0)) -; (while (< i len) -; (setq col (+ col (char-columns (aref string i)))) -; (setq i (1+ i)) -; ) -; col)) - -;(defalias 'string-width 'string-columns) - -(defun string-to-int-list (str) - (mapcar #'char-int str) - ) - -;(defalias 'sref 'aref) - -;(defun truncate-string (str width &optional start-column) -; "Truncate STR to fit in WIDTH columns. -;Optional non-nil arg START-COLUMN specifies the starting column. -;\[emu-x20.el; Mule 2.3 emulating function]" -; (or start-column -; (setq start-column 0)) -; (substring str start-column width) -; ) - - -;;; @ end -;;; - -(provide 'emu-x20) - -;;; emu-x20.el ends here diff -r b88636d63495 -r 8fc7fe29b841 lisp/tl/emu.el --- a/lisp/tl/emu.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/tl/emu.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,9 +1,9 @@ ;;; emu.el --- Emulation module for each Emacs variants -;; Copyright (C) 1995,1996 Free Software Foundation, Inc. +;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko -;; Version: $Id: emu.el,v 1.2 1996/12/22 00:29:31 steve Exp $ +;; Version: $Id: emu.el,v 1.3 1997/02/16 01:29:29 steve Exp $ ;; Keywords: emulation, compatibility, NEmacs, MULE, Emacs/mule, XEmacs ;; This file is part of emu. @@ -91,22 +91,6 @@ )) -;;; @ binary access -;;; - -(defun insert-binary-file-contents-literally - (filename &optional visit beg end replace) - "Like `insert-file-contents-literally', q.v., but don't code conversion. -A buffer may be modified in several ways after reading into the buffer due -to advanced Emacs features, such as file-name-handlers, format decoding, -find-file-hooks, etc. - This function ensures that none of these modifications will take place. -\[emu.el]" - (as-binary-input-file - (insert-file-contents-literally filename visit beg end replace) - )) - - ;;; @ MIME charset ;;; diff -r b88636d63495 -r 8fc7fe29b841 lisp/tm/tm-def.el --- a/lisp/tm/tm-def.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/tm/tm-def.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,9 +1,9 @@ ;;; tm-def.el --- definition module for tm -;; Copyright (C) 1995,1996 Free Software Foundation, Inc. +;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko -;; Version: $Id: tm-def.el,v 1.4 1997/02/02 05:06:19 steve Exp $ +;; Version: $Id: tm-def.el,v 1.5 1997/02/16 01:29:30 steve Exp $ ;; Keywords: mail, news, MIME, multimedia, definition ;; This file is part of tm (Tools for MIME). @@ -170,6 +170,46 @@ )) +;;; @ PGP +;;; + +(defvar pgp-function-alist + '( + ;; for tm-pgp + (verify mc-verify "mc-toplev") + (decrypt mc-decrypt "mc-toplev") + (fetch-key mc-pgp-fetch-key "mc-pgp") + (snarf-keys mc-snarf-keys "mc-toplev") + ;; for tm-edit + (mime-sign tm:mc-pgp-sign-region "tm-edit-mc") + (traditional-sign mc-pgp-sign-region "mc-pgp") + (encrypt tm:mc-pgp-encrypt-region "tm-edit-mc") + (insert-key mc-insert-public-key "mc-toplev") + ) + "Alist of service names vs. corresponding functions and its filenames. +Each element looks like (SERVICE FUNCTION FILE). + +SERVICE is a symbol of PGP processing. It allows `verify', `decrypt', +`fetch-key', `snarf-keys', `mime-sign', `traditional-sign', `encrypt' +or `insert-key'. + +Function is a symbol of function to do specified SERVICE. + +FILE is string of filename which has definition of corresponding +FUNCTION.") + +(defmacro pgp-function (method) + "Return function to do service METHOD." + (` (car (cdr (assq (, method) (symbol-value 'pgp-function-alist))))) + ) + +(mapcar (function + (lambda (method) + (autoload (second method)(third method)) + )) + pgp-function-alist) + + ;;; @ definitions about MIME ;;; diff -r b88636d63495 -r 8fc7fe29b841 lisp/tm/tm-edit.el --- a/lisp/tm/tm-edit.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/tm/tm-edit.el Mon Aug 13 08:50:29 2007 +0200 @@ -6,7 +6,7 @@ ;; MORIOKA Tomohiko ;; Maintainer: MORIOKA Tomohiko ;; Created: 1994/08/21 renamed from mime.el -;; Version: $Revision: 1.5 $ +;; Version: $Revision: 1.6 $ ;; Keywords: mail, news, MIME, multimedia, multilingual ;; This file is part of tm (Tools for MIME). @@ -120,7 +120,7 @@ ;;; (defconst mime-editor/RCS-ID - "$Id: tm-edit.el,v 1.5 1997/02/02 05:06:19 steve Exp $") + "$Id: tm-edit.el,v 1.6 1997/02/16 01:29:32 steve Exp $") (defconst mime-editor/version (get-version-string mime-editor/RCS-ID)) @@ -433,16 +433,6 @@ (defvar mime-editor/encrypting-type 'pgp-elkins "*PGP encrypting type (pgp-elkins, pgp-kazu or nil). [tm-edit.el]") -(defvar mime-editor/pgp-sign-function 'tm:mc-pgp-sign-region) -(defvar mime-editor/pgp-encrypt-function 'tm:mc-pgp-encrypt-region) -(defvar mime-editor/traditional-pgp-sign-function 'mc-pgp-sign-region) -(defvar mime-editor/pgp-insert-public-key-function 'mc-insert-public-key) - -(autoload mime-editor/pgp-sign-function "tm-edit-mc") -(autoload mime-editor/pgp-encrypt-function "tm-edit-mc") -(autoload mime-editor/traditional-pgp-sign-function "mc-pgp") -(autoload mime-editor/pgp-insert-public-key-function "mc-toplev") - ;;; @@ about tag ;;; @@ -880,7 +870,7 @@ (defun mime-editor/insert-text () "Insert a text message. -Charset is automatically obtained from the `mime/lc-charset-alist'." +Charset is automatically obtained from the `charsets-mime-charset-alist'." (interactive) (let ((ret (mime-editor/insert-tag "text" nil nil))) (if ret @@ -1558,7 +1548,7 @@ (insert (format "Content-Transfer-Encoding: %s\n" encoding)) ) (insert "\n") - (or (funcall mime-editor/pgp-sign-function + (or (funcall (pgp-function 'mime-sign) (point-min)(point-max) nil nil pgp-boundary) (throw 'mime-editor/error 'pgp-error) ) @@ -1622,7 +1612,7 @@ (insert (format "Content-Transfer-Encoding: %s\n" encoding)) ) (insert "\n") - (or (funcall mime-editor/pgp-encrypt-function + (or (funcall (pgp-function 'encrypt) recipients (point-min) (point-max) from) (throw 'mime-editor/error 'pgp-error) ) @@ -1659,7 +1649,7 @@ ) (insert "\n") (or (as-binary-process - (funcall mime-editor/traditional-pgp-sign-function + (funcall (pgp-function 'traditional-sign) beg (point-max))) (throw 'mime-editor/error 'pgp-error) ) @@ -1693,7 +1683,7 @@ ) (insert "\n") (or (as-binary-process - (funcall mime-editor/pgp-encrypt-function + (funcall (pgp-function 'encrypt) recipients beg (point-max) nil 'maybe) ) (throw 'mime-editor/error 'pgp-error) @@ -2074,7 +2064,7 @@ (interactive "P") (mime-editor/insert-tag "application" "pgp-keys") (mime-editor/define-encoding "7bit") - (funcall mime-editor/pgp-insert-public-key-function) + (funcall (pgp-function 'insert-key)) ) @@ -2444,7 +2434,10 @@ (setq type ctype) ) (cond - ((string-equal type "multipart") + ((string= ctype "application/pgp-signature") + (delete-region (point-min)(point-max)) + ) + ((string= type "multipart") (let* ((boundary (assoc-value "boundary" params)) (boundary-pat (concat "\n--" (regexp-quote boundary) "[ \t]*\n")) diff -r b88636d63495 -r 8fc7fe29b841 lisp/tm/tm-ew-e.el --- a/lisp/tm/tm-ew-e.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/tm/tm-ew-e.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,9 +1,9 @@ ;;; tm-ew-e.el --- RFC 2047 based encoded-word encoder for GNU Emacs -;; Copyright (C) 1995,1996 Free Software Foundation, Inc. +;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko -;; Version: $Revision: 1.2 $ +;; Version: $Revision: 1.3 $ ;; Keywords: encoded-word, MIME, multilingual, header, mail, news ;; This file is part of tm (Tools for MIME). @@ -35,7 +35,7 @@ ;;; (defconst tm-ew-e/RCS-ID - "$Id: tm-ew-e.el,v 1.2 1996/12/22 00:29:39 steve Exp $") + "$Id: tm-ew-e.el,v 1.3 1997/02/16 01:29:32 steve Exp $") (defconst mime-eword/encoder-version (get-version-string tm-ew-e/RCS-ID)) @@ -316,8 +316,7 @@ ) (t (setq string (car rword)) - (let* ((sl (length string)) - (p 0) np + (let* ((p 0) np (str "") nstr) (while (and (< p len) (progn diff -r b88636d63495 -r 8fc7fe29b841 lisp/tm/tm-ftp.el --- a/lisp/tm/tm-ftp.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/tm/tm-ftp.el Mon Aug 13 08:50:29 2007 +0200 @@ -5,7 +5,7 @@ ;; Author: MASUTANI Yasuhiro ;; MORIOKA Tomohiko ;; Created: 1994/11/5 -;; Version: $Id: tm-ftp.el,v 1.4 1997/02/04 02:36:06 steve Exp $ +;; Version: $Id: tm-ftp.el,v 1.5 1997/02/16 01:29:33 steve Exp $ ;; Keywords: anonymous ftp, MIME, multimedia, mail, news ;; This file is part of tm (Tools for MIME). @@ -28,7 +28,15 @@ ;;; Code: (require 'tm-view) -(require 'ange-ftp) + +(defvar mime-view-ftp-module + (if (< emacs-major-version 19) + 'ange-ftp) + "*Module for ftp file access.") + +(and mime-view-ftp-module + (require mime-view-ftp-module) + ) (defvar mime-article/dired-function (if mime/use-multi-frame diff -r b88636d63495 -r 8fc7fe29b841 lisp/tm/tm-image.el --- a/lisp/tm/tm-image.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/tm/tm-image.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,17 +1,17 @@ ;;; tm-image.el --- tm-view filter to display images in XEmacs or MULE buffers -;; Copyright (C) 1995,1996 MORIOKA Tomohiko +;; Copyright (C) 1995,1996,1997 MORIOKA Tomohiko ;; Copyright (C) 1996 Dan Rich ;; Author: MORIOKA Tomohiko ;; Dan Rich ;; Maintainer: MORIOKA Tomohiko ;; Created: 1995/12/15 -;; Version: $Id: tm-image.el,v 1.4 1997/02/09 23:51:47 steve Exp $ +;; Version: $Id: tm-image.el,v 1.5 1997/02/16 01:29:33 steve Exp $ -;; Keywords: mail, news, MIME, multimedia, image, picture, X-Face +;; Keywords: image, picture, X-Face, MIME, multimedia, mail, news -;; This file is part of tm (Tools for MIME). +;; This file is part of XEmacs. ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License as @@ -24,8 +24,8 @@ ;; 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., 59 Temple Place - Suite 330, +;; along with GNU XEmacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. ;;; Commentary: @@ -37,113 +37,105 @@ (require 'tm-view) (cond (running-xemacs - (require 'annotations) - - (set-alist 'mime-viewer/content-filter-alist - "image/jpeg" - (if (featurep 'jpeg) ; Use built-in suport if available - (function mime-preview/filter-for-inline-image) - (function mime-preview/filter-for-image) - )) - - (set-alist 'mime-viewer/content-filter-alist - "image/gif" - (if (featurep 'gif) ; Use built-in suport if available - (function mime-preview/filter-for-inline-image) - (function mime-preview/filter-for-image) - )) + (require 'images) - (set-alist 'mime-viewer/content-filter-alist - "image/x-xpixmap" - (if (featurep 'xpm) ; Use built-in suport if available - (function mime-preview/filter-for-inline-image) - (function mime-preview/filter-for-image) - )) - - (set-alist 'mime-viewer/content-filter-alist - "image/tiff" (function mime-preview/filter-for-image)) - (set-alist 'mime-viewer/content-filter-alist - "image/x-tiff" (function mime-preview/filter-for-image)) + (defun-maybe image-inline-p (format) + (or (memq format image-native-formats) + (find-if (function + (lambda (native) + (image-converter-chain format native) + )) + image-native-formats) + )) - (set-alist 'mime-viewer/content-filter-alist - "image/x-pic" (function mime-preview/filter-for-image)) - - (set-alist 'mime-viewer/content-filter-alist - "image/x-mag" (function mime-preview/filter-for-image)) - - (defvar tm-image/inline-image-types - (if (featurep 'gif) - (nconc - '("image/jpeg" "image/gif" "image/tiff" - "image/x-tiff" "image/x-pic" "image/x-mag" - "image/x-xbm" "image/x-xpixmap") - (if (featurep 'gif) - '("application/postscript") - ) - ))) + (image-register-netpbm-utilities) + (image-register-converter 'pic 'ppm "pictoppm") + (image-register-converter 'mag 'ppm "magtoppm") (defun bitmap-insert-xbm-file (file) - (let (gl) - (while (progn - (setq gl (make-glyph file)) - (eq (image-instance-type (glyph-image-instance gl)) - 'text) - )) - (make-annotation gl (point) 'text) + (let ((gl (make-glyph (list (cons 'x file)))) + (e (make-extent (point) (point))) + ) + (set-extent-end-glyph e gl) )) - (defvar mime-viewer/image-converter-alist - '(("image/jpeg" . jpeg) - ("image/gif" . gif) - ("image/x-png" . png) - ("image/x-xpixmap" . xpm) - )) - - (defvar mime-preview/x-face-function - (function mime-preview/x-face-function-use-highlight-headers)) - + ;; + ;; X-Face + ;; (autoload 'highlight-headers "highlight-headers") (defun mime-preview/x-face-function-use-highlight-headers () (highlight-headers (point-min) (re-search-forward "^$" nil t) t) ) + + (add-hook 'mime-viewer/content-header-filter-hook + 'mime-preview/x-face-function-use-highlight-headers) + ) ((featurep 'mule) ;; for MULE 2.* or mule merged EMACS (require 'x-face-mule) + + (defvar image-native-formats '(xbm)) - (defvar tm-image/inline-image-types '("image/x-mag" "image/x-xbm")) + (defun-maybe image-inline-p (format) + (memq format image-native-formats) + ) - (defvar mime-preview/x-face-function - (function x-face-decode-message-header)) + (defun-maybe image-normalize (format data) + (and (eq format 'xbm) + (vector 'xbm ':data data) + )) + + ;; + ;; X-Face + ;; + (if (file-installed-p uncompface-program exec-path) + (add-hook 'mime-viewer/content-header-filter-hook + 'x-face-decode-message-header) + ) )) -(defvar mime-viewer/shell-command "/bin/sh") -(defvar mime-viewer/shell-arguments '("-c")) +(or (fboundp 'image-invalid-glyph-p) + (defsubst image-invalid-glyph-p (glyph) + (or (null (aref glyph 0)) + (null (aref glyph 2)) + (equal (aref glyph 2) "") + )) + ) + +(defvar mime-viewer/image-converter-alist nil) + +(mapcar (function + (lambda (rule) + (let ((ctype (car rule)) + (format (cdr rule)) + ) + (if (image-inline-p format) + (progn + (set-alist 'mime-viewer/content-filter-alist + ctype + (function mime-preview/filter-for-image)) + (set-alist 'mime-viewer/image-converter-alist + ctype format) + (add-to-list + 'mime-viewer/default-showing-Content-Type-list + ctype) + ) + )))) + '(("image/jpeg" . jpeg) + ("image/gif" . gif) + ("image/tiff" . tiff) + ("image/x-tiff" . tiff) + ("image/xbm" . xbm) + ("image/x-xbm" . xbm) + ("image/x-xpixmap" . xpm) + ("image/x-pic" . pic) + ("image/x-mag" . mag) + )) (defvar mime-viewer/ps-to-gif-command "pstogif") -(defvar mime-viewer/graphic-converter-alist - '(("image/jpeg" . "djpeg -color 256 < %s | ppmtoxpm > %s") - ("image/gif" . "giftopnm < %s | ppmtoxpm > %s") - ("image/tiff" . "tifftopnm < %s | ppmquant 256 | ppmtoxpm > %s") - ("image/x-tiff" . "tifftopnm < %s | ppmquant 256 | ppmtoxpm > %s") - ("image/x-pic" . "pictoppm < %s | ppmquant 256 | ppmtoxpm > %s") - ("image/x-mag" . "magtoppm < %s | ppmtoxpm > %s") - )) - - -;;; @ X-Face -;;; - -(defvar mime-viewer/x-face-to-xbm-command - (concat mime-viewer/x-face-to-pbm-command " | pbmtoxbm")) - -(if mime-preview/x-face-function - (add-hook 'mime-viewer/content-header-filter-hook - mime-preview/x-face-function) - ) - ;;; @ content filter for images ;;; @@ -152,87 +144,38 @@ (defun mime-preview/filter-for-image (ctype params encoding) (let* ((mode mime::preview/original-major-mode) (m (assq mode mime-viewer/code-converter-alist)) - (filter (assoc-value ctype mime-viewer/graphic-converter-alist)) - ) - (if filter - (let* ((beg (point-min)) (end (point-max)) - (orig-file - (make-temp-name (expand-file-name "tm" mime/tmp-dir))) - (xbm-file (concat orig-file ".xbm")) - gl annot) - ;;(remove-text-properties beg end '(face nil)) - (mime-decode-region beg end encoding) - (write-region (point-min)(point-max) orig-file) - (delete-region (point-min)(point-max)) - (message "Now translating, please wait...") - (apply (function call-process) - mime-viewer/shell-command nil nil nil - (append mime-viewer/shell-arguments - (list (format filter orig-file xbm-file))) - ) - (setq gl (make-glyph xbm-file)) - (setq annot (make-annotation gl (point) 'text)) - (unwind-protect - (delete-file orig-file) - (condition-case nil - (delete-file xbm-file) - (error nil))) - (goto-char (point-max)) - (insert "\n") - (message "Translation done.") - ) - (message (format "%s is not supported." ctype)) - ))) - - -;;; @ content filter for xbm -;;; - -(defun mime-preview/filter-for-image/xbm (ctype params encoding) - (let* ((mode mime::preview/original-major-mode) - (m (assq mode mime-viewer/code-converter-alist)) - (charset (assoc "charset" params)) - (beg (point-min)) (end (point-max)) - (xbm-file (make-temp-name (expand-file-name "tm" mime/tmp-dir))) - ) - (remove-text-properties beg end '(face nil)) - (mime-decode-region beg end encoding) - (write-region (point-min)(point-max) xbm-file) - (delete-region (point-min)(point-max)) - (bitmap-insert-xbm-file xbm-file) - (delete-file xbm-file) - )) - -(set-alist 'mime-viewer/content-filter-alist - "image/xbm" (function mime-preview/filter-for-image/xbm)) - -(set-alist 'mime-viewer/content-filter-alist - "image/x-xbm" (function mime-preview/filter-for-image/xbm)) - - -;;; @ content filter for support in-line image types -;;; -;; (for XEmacs 19.14 or later) - -(defun mime-preview/filter-for-inline-image (ctype params encoding) - (let* ((mode mime::preview/original-major-mode) - (m (assq mode mime-viewer/code-converter-alist)) (charset (assoc "charset" params)) (beg (point-min)) (end (point-max)) ) (remove-text-properties beg end '(face nil)) + (message "Decoding image...") (mime-decode-region beg end encoding) - (let ((data (buffer-string)) - (minor (assoc-value ctype mime-viewer/image-converter-alist)) - gl e) + (let* ((minor (assoc-value ctype mime-viewer/image-converter-alist)) + (gl (image-normalize minor (buffer-string))) + e) (delete-region (point-min)(point-max)) - (while (progn - (setq gl (make-glyph (vector minor :data data))) - (eq (image-instance-type (glyph-image-instance gl)) - 'text) - )) - (setq e (make-extent (point) (point))) - (set-extent-end-glyph e gl) + (cond ((image-invalid-glyph-p gl) + (setq gl nil) + (message "Invalid glyph!") + ) + ((eq (aref gl 0) 'xbm) + (let ((xbm-file + (make-temp-name (expand-file-name "tm" mime/tmp-dir)))) + (insert (aref gl 2)) + (write-region (point-min)(point-max) xbm-file) + (message "Decoding image...") + (delete-region (point-min)(point-max)) + (bitmap-insert-xbm-file xbm-file) + (delete-file xbm-file) + ) + (message "Decoding image... done") + ) + (t + (setq gl (make-glyph gl)) + (setq e (make-extent (point) (point))) + (set-extent-end-glyph e gl) + (message "Decoding image... done") + )) ) (insert "\n") )) @@ -251,18 +194,15 @@ (gif-file (concat file-base ".gif")) ) (remove-text-properties beg end '(face nil)) + (message "Decoding Postscript...") (mime-decode-region beg end encoding) (write-region (point-min)(point-max) ps-file) + (message "Decoding Postscript...") (delete-region (point-min)(point-max)) (call-process mime-viewer/ps-to-gif-command nil nil nil ps-file) - (let (gl) - (while (progn - (setq gl (make-glyph (vector 'gif :file gif-file))) - (eq (image-instance-type (glyph-image-instance gl)) - 'text) - )) - (make-annotation gl (point) 'text) - ) + (set-extent-end-glyph (make-extent (point) (point)) + (make-glyph (vector 'gif :file gif-file))) + (message "Decoding Postscript... done") (delete-file ps-file) (delete-file gif-file) )) @@ -271,18 +211,10 @@ "application/postscript" (function mime-preview/filter-for-application/postscript)) - -;;; @ setting -;;; - -(mapcar - (lambda (ctype) - (or (member ctype mime-viewer/default-showing-Content-Type-list) - (setq mime-viewer/default-showing-Content-Type-list - (cons ctype - mime-viewer/default-showing-Content-Type-list)) - )) - tm-image/inline-image-types) +(if (featurep 'gif) + (add-to-list 'mime-viewer/default-showing-Content-Type-list + "application/postscript") + ) ;;; @ end diff -r b88636d63495 -r 8fc7fe29b841 lisp/tm/tm-pgp.el --- a/lisp/tm/tm-pgp.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/tm/tm-pgp.el Mon Aug 13 08:50:29 2007 +0200 @@ -4,7 +4,7 @@ ;; Author: MORIOKA Tomohiko ;; Created: 1995/12/7 -;; Version: $Id: tm-pgp.el,v 1.4 1997/02/02 05:06:20 steve Exp $ +;; Version: $Id: tm-pgp.el,v 1.5 1997/02/16 01:29:33 steve Exp $ ;; Keywords: mail, news, MIME, multimedia, PGP, security ;; This file is part of tm (Tools for MIME). @@ -42,23 +42,6 @@ (require 'tm-play) -(defvar pgp-verify-function - 'mc-verify "*PGP verify function.") - -(defvar pgp-decrypt-function - 'mc-decrypt "*PGP decrypt function.") - -(defvar pgp-fetch-key-function - 'mc-pgp-fetch-key "*PGP fetch key function.") - -(defvar pgp-snarf-keys-function - 'mc-snarf-keys "*PGP snarf keys function.") - -(autoload pgp-verify-function "mc-toplev") -(autoload pgp-decrypt-function "mc-toplev") -(autoload pgp-fetch-key-function "mc-toplev") -(autoload pgp-snarf-keys-function "mc-toplev") - ;;; @ internal method for application/pgp ;;; @@ -67,20 +50,22 @@ (defun mime-article/view-application/pgp (beg end cal) (let* ((cnum (mime-article/point-content-number beg)) (cur-buf (current-buffer)) + (p-win (or (get-buffer-window mime::article/preview-buffer) + (get-largest-window))) (new-name (format "%s-%s" (buffer-name) cnum)) (mother mime::article/preview-buffer) (mode major-mode) code-converter (str (buffer-substring beg end)) ) - (switch-to-buffer new-name) + (set-buffer (get-buffer-create new-name)) (erase-buffer) (insert str) (cond ((progn (goto-char (point-min)) (re-search-forward "^-+BEGIN PGP SIGNED MESSAGE-+$" nil t) ) - (funcall pgp-verify-function) + (funcall (pgp-function 'verify)) (goto-char (point-min)) (delete-region (point-min) @@ -106,7 +91,7 @@ (goto-char (point-min)) (re-search-forward "^-+BEGIN PGP MESSAGE-+$" nil t) ) - (as-binary-process (funcall pgp-decrypt-function)) + (as-binary-process (funcall (pgp-function 'decrypt))) (goto-char (point-min)) (delete-region (point-min) (and @@ -116,7 +101,8 @@ )) (setq major-mode 'mime/show-message-mode) (setq mime::article/code-converter code-converter) - (mime/viewer-mode mother) + (save-window-excursion (mime/viewer-mode mother)) + (set-window-buffer p-win mime::article/preview-buffer) )) (set-atype 'mime/content-decoding-condition @@ -241,7 +227,7 @@ (format "Key %s not found; attempt to fetch? " pgp-id)) ) (progn - (funcall pgp-fetch-key-function (cons nil pgp-id)) + (funcall (pgp-function 'fetch-key) (cons nil pgp-id)) (mime::article/call-pgp-to-check-signature mime/output-buffer-name orig-file) )) @@ -309,7 +295,7 @@ (delete-region (point-min) (match-end 0)) ) (mime-decode-region (point-min)(point-max) encoding) - (funcall pgp-snarf-keys-function) + (funcall (pgp-function 'snarf-keys)) (kill-buffer (current-buffer)) )) diff -r b88636d63495 -r 8fc7fe29b841 lisp/tm/tm-rmail.el --- a/lisp/tm/tm-rmail.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/tm/tm-rmail.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,11 +1,11 @@ ;;; tm-rmail.el --- MIME extension for RMAIL -;; Copyright (C) 1994,1995,1996 Free Software Foundation, Inc. +;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko ;; modified by KOBAYASHI Shuhei ;; Created: 1994/8/30 -;; Version: $Revision: 1.2 $ +;; Version: $Revision: 1.3 $ ;; Keywords: mail, MIME, multimedia, multilingual, encoded-word ;; This file is not part of tm (Tools for MIME). @@ -40,7 +40,7 @@ ;;; (defconst tm-rmail/RCS-ID - "$Id: tm-rmail.el,v 1.2 1996/12/22 00:29:42 steve Exp $") + "$Id: tm-rmail.el,v 1.3 1997/02/16 01:29:34 steve Exp $") (defconst tm-rmail/version (get-version-string tm-rmail/RCS-ID)) (defvar tm-rmail/decode-all nil) @@ -189,8 +189,16 @@ (defun tm-rmail/quitting-method-to-article () (setq tm-rmail/decode-all nil) - (mime-viewer/kill-buffer) - ) + (let ((buffer + (mime::preview-content-info/buffer + (mime-preview/point-pcinfo (point)))) + ) + (mime-viewer/kill-buffer) + + ;; Make sure we return to RMAIL buffer + (if buffer + (switch-to-buffer buffer)) + )) (defalias 'tm-rmail/quitting-method 'tm-rmail/quitting-method-to-article) diff -r b88636d63495 -r 8fc7fe29b841 lisp/tm/tm-setup.el --- a/lisp/tm/tm-setup.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/tm/tm-setup.el Mon Aug 13 08:50:29 2007 +0200 @@ -3,7 +3,7 @@ ;; Copyright (C) 1994,1995,1996,1997 Free Software Foundation, Inc. ;; Author: MORIOKA Tomohiko -;; Version: $Id: tm-setup.el,v 1.4 1997/02/04 02:36:07 steve Exp $ +;; Version: $Id: tm-setup.el,v 1.5 1997/02/16 01:29:34 steve Exp $ ;; Keywords: mail, news, MIME, multimedia, multilingual, encoded-word ;; This file is part of tm (Tools for MIME). @@ -98,14 +98,15 @@ ;;; @ for RMAIL ;;; -(or running-xemacs-with-mule - (call-after-loaded 'rmail - (function - (lambda () - (require 'tm-rmail) - )) - 'rmail-mode-hook) - ) +(defun tm-setup/load-rmail () + (or (and (boundp 'rmail-support-mime) + rmail-support-mime) + (require 'tm-rmail) + ) + (remove-hook 'rmail-mode-hook 'tm-setup/load-rmail) + ) + +(call-after-loaded 'rmail 'tm-setup/load-rmail 'rmail-mode-hook) ;;; @ for mh-e diff -r b88636d63495 -r 8fc7fe29b841 lisp/tm/tm-view.el --- a/lisp/tm/tm-view.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/tm/tm-view.el Mon Aug 13 08:50:29 2007 +0200 @@ -4,7 +4,7 @@ ;; Author: MORIOKA Tomohiko ;; Created: 1994/7/13 (1994/8/31 obsolete tm-body.el) -;; Version: $Revision: 1.3 $ +;; Version: $Revision: 1.4 $ ;; Keywords: mail, news, MIME, multimedia ;; This file is part of tm (Tools for MIME). @@ -42,7 +42,7 @@ ;;; (defconst mime-viewer/RCS-ID - "$Id: tm-view.el,v 1.3 1997/02/02 05:06:20 steve Exp $") + "$Id: tm-view.el,v 1.4 1997/02/16 01:29:34 steve Exp $") (defconst mime-viewer/version (get-version-string mime-viewer/RCS-ID)) (defconst mime/viewer-version mime-viewer/version) @@ -1007,8 +1007,14 @@ )) (mime/decode-message-header) ) - (funcall (cdr (assq mode mime-viewer/following-method-alist)) - new-buf) + (let ((f (cdr (assq mode mime-viewer/following-method-alist)))) + (if (functionp f) + (funcall f new-buf) + (message + (format + "Sorry, following method for %s is not implemented yet." + mode)) + )) )))) (defun mime-viewer/display-x-face () diff -r b88636d63495 -r 8fc7fe29b841 lisp/tm/tm-vm.el --- a/lisp/tm/tm-vm.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/tm/tm-vm.el Mon Aug 13 08:50:29 2007 +0200 @@ -9,7 +9,7 @@ ;; Oscar Figueiredo ;; Maintainer: Oscar Figueiredo ;; Created: 1994/10/29 -;; Version: $Revision: 1.4 $ +;; Version: $Revision: 1.5 $ ;; Keywords: mail, MIME, multimedia, multilingual, encoded-word ;; This file is part of tm (Tools for MIME). @@ -103,7 +103,7 @@ ;;; @@ System/Information variables (defconst tm-vm/RCS-ID - "$Id: tm-vm.el,v 1.4 1997/02/09 23:51:48 steve Exp $") + "$Id: tm-vm.el,v 1.5 1997/02/16 01:29:35 steve Exp $") (defconst tm-vm/version (get-version-string tm-vm/RCS-ID)) ; Ensure vm-menu-mail-menu gets properly defined *before* tm-vm/vm-emulation-map @@ -311,27 +311,18 @@ (cdr ret)) ret))) -(or (fboundp 'tm:vm-su-subject) - (fset 'tm:vm-su-subject (symbol-function 'vm-su-subject)) - ) -(defun vm-su-subject (m) - (mime-eword/decode-string (tm:vm-su-subject m)) - ) +(defadvice vm-su-subject (after tm activate) + "MIME decoding support through TM added." + (setq ad-return-value (mime-eword/decode-string ad-return-value))) -(or (fboundp 'tm:vm-su-full-name) - (fset 'tm:vm-su-full-name (symbol-function 'vm-su-full-name)) - ) -(defun vm-su-full-name (m) - (mime-eword/decode-string (tm:vm-su-full-name m)) - ) +(defadvice vm-su-full-name (after tm activate) + "MIME decoding support through TM added." + (setq ad-return-value (mime-eword/decode-string ad-return-value))) -(or (fboundp 'tm:vm-su-to-names) - (fset 'tm:vm-su-to-names (symbol-function 'vm-su-to-names)) - ) -(defun vm-su-to-names (m) - (mime-eword/decode-string (tm:vm-su-to-names m)) - ) -;;; +(defadvice vm-su-to-names (after tm activate) + "MIME decoding support through TM added." + (setq ad-return-value (mime-eword/decode-string ad-return-value))) + )) (defun tm-vm/decode-message-header (&optional count) @@ -564,8 +555,7 @@ ) (t ;; don't display if neither mwin nor pwin was displayed before. - ))) - (set-buffer mbuf))) + ))))) (defun tm-vm/preview-current-message () "Either preview message (view first lines only) or MIME-Preview it. @@ -823,7 +813,8 @@ (select-window pwin) (set-buffer pbuf) (if (pos-visible-in-window-p (point-max) pwin) - (vm-next-message) + (if vm-auto-next-message + (vm-next-message)) ;; not at the end of message. scroll preview buffer only. (scroll-up) (tm-vm/howl-if-eom)) @@ -887,22 +878,22 @@ (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) - (let ((mbuf (current-buffer)) - (pbuf (and mime::article/preview-buffer + (let ((pbuf (and mime::article/preview-buffer (get-buffer mime::article/preview-buffer)))) (if (null pbuf) (progn (tm-vm/preview-current-message) (setq pbuf (get-buffer mime::article/preview-buffer)) )) - (vm-display mbuf t '(vm-beginning-of-message) + (vm-display (current-buffer) t '(vm-beginning-of-message) '(vm-beginning-of-message reading-message)) (tm-vm/display-preview-buffer) - (set-buffer pbuf) (tm-vm/save-window-excursion - (select-window (vm-get-buffer-window pbuf)) + (select-window (vm-get-visible-buffer-window pbuf)) (push-mark) (goto-char (point-min)) + (vm-display (current-buffer) t '(vm-beginning-of-message) + '(vm-beginning-of-message reading-message)) )))) (defadvice vm-end-of-message (around tm-aware activate) @@ -914,22 +905,22 @@ (vm-select-folder-buffer) (vm-check-for-killed-summary) (vm-error-if-folder-empty) - (let ((mbuf (current-buffer)) - (pbuf (and mime::article/preview-buffer + (let ((pbuf (and mime::article/preview-buffer (get-buffer mime::article/preview-buffer)))) (if (null pbuf) (progn (tm-vm/preview-current-message) (setq pbuf (get-buffer mime::article/preview-buffer)) )) - (vm-display mbuf t '(vm-end-of-message) + (vm-display (current-buffer) t '(vm-end-of-message) '(vm-end-of-message reading-message)) (tm-vm/display-preview-buffer) - (set-buffer pbuf) (tm-vm/save-window-excursion (select-window (vm-get-buffer-window pbuf)) (push-mark) (goto-char (point-max)) + (vm-display (current-buffer) t '(vm-end-of-message) + '(vm-end-of-message reading-message)) )))) ;;; based on vm-howl-if-eom [vm-page.el] @@ -1493,6 +1484,8 @@ 'f22 [f22]) 'tm-vm/print-message) + (make-local-variable 'ps-header-lines) + (make-local-variable 'ps-left-header) (setq ps-header-lines 3) (setq ps-left-header (list 'ps-article-subject 'ps-article-author 'buffer-name))) diff -r b88636d63495 -r 8fc7fe29b841 lisp/utils/browse-cltl2.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/utils/browse-cltl2.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,383 @@ +; -*- Mode: Emacs-Lisp -*- +;;; browse-cltl2.el --- browse the hypertext-version of +;;; "Common Lisp the Language, 2nd. Edition" + +;; Revision 1.1.1 +;; last edited on 29.1.1997 + +;; Copyright (C) 1997 Holger Schauer + +;; Author: Holger Schauer +;; Keywords: utils lisp ilisp + +;; This file is not part of Emacs. + +;; Developed under XEmacs 19.14. Also tested on Emacs 19.32 and +;; XEmacs 19.11. Should work with newer versions, too. +;; Required: browse-url.el +;; Recommended: url.el + +;; 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 2 of the License, 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; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: +;; This gives you two top-level-functions useful when programming lisp: +;; cltl2-view-function-definition and cltl2-view-index +;; cltl2-view-function-definition asks you for a name of a lisp +;; function (or variable) and will open up your favourite browser +;; (as specified by `browse-url-browser-function') loading the page +;; which documents it. + +;;; Installation: (as usual) +;; Put browse-cltl2.el somewhere where emacs can find it. +;; browse-cltl2.el requires a working browse-url, url and cl. +;; Insert the following lines in your .emacs: +;; +;; (autoload 'cltl2-view-function-definition "browse-cltl2") +;; (autoload 'cltl2-view-index "browse-cltl2") +;; (autoload 'cltl2-lisp-mode-install "browse-cltl2") +;; (add-hook 'lisp-mode-hook 'cltl2-lisp-mode-install) +;; (add-hook 'ilisp-mode-hook 'cltl2-lisp-mode-install) +;; +;; This should also add the needed hooks to lisp-mode (and ilisp-mode). + +;; Gnu Emacs: +;; For Gnu Emacs there doesn't seem to be a lisp-mode-hook so you're +;; on your own with the key-settings. +;; No url.el: +;; If you don't have url.el set *cltl2-use-url* to nil +;; and set *cltl2-fetch-method* to 'local or 'local-index-only. +;; This implies that you need a local copy of the index page of +;; CLtL2 (which you can get from the normal hypertext-version at CMU), +;; so you need to point *cltl2-local-file-pos* and *cltl2-index-file-name* +;; to the place where you put it. +;; Old versions of Emacs (XEmacs 19.11 for example): +;; When you want to use a local copy (or a local copy of the index file) +;; check the documentation on find-file-noselect. If it doesn't mention +;; an option called RAWFILE set *cltl2-old-find-file-noselect* to 't. + + +;;; Customization: +;; By default, browse-cltl2 will use a local copy of CLtL2, looking +;; for it in /usr/doc/html/cltl. This can be modified with the help +;; of the following variables: +;; *cltl2-fetch-method*, *cltl2-url*, *cltl-local-file-pos* +;; See the documentation on this variables for more info. +;; +;;; TODO: +;; In this version we can't separate between functions, variables, +;; constants and loop clauses. This is not that hard to change, +;; but it is more difficult to distinguish what the user is +;; looking for. Until I receive several requests for it, I won't +;; implement it, because there are not that much constructs like * and + +;; which have two (or more) semantics. + +;;; Changes: +;; 28-01-97: HS: now we're using cl-puthash all over the place because +;; this is common on XEmacs 19.11 and upwards and Gnu Emacs. +;; Added information on how to install without url.el +;; +;; 29-01-97 HS: included conditionalized versions of the required +;; functions match-string and buffer-live-p. +;; Suggested by Simon Marshall . +;; Included new variable *cltl2-use-url* with which one can +;; specify if he has url.el or not. Introduced variable +;; *cltl2-old-find-file-noselect*. +(defvar *cltl2-use-url* 'nil + "Enables or disables retrieval of the index-file via WWW (or more + exactly by the use of the function url-retrieve from url.el). + Default is 't.") + +;; needed things +(require 'cl) +(require 'browse-url) + +(when (not *cltl2-use-url*) + (require 'url)) + +;;; ****************************** +;;; Some variable and constant definitions +;;; ****************************** +(defvar *cltl2-fetch-method* 'local + "This sets the method by which the index-file will be fetched. Three + methods are possible: 'local assumes that all files are local. + 'local-index-only assumes that just the index-file is locally but + all other files will be fetched via www. 'www means that the index-file + will be fetched via WWW, too. Don't change the value of this variable + after loading.") + +(defvar *cltl2-url* + "http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/" + "The url where the hypertext-version of Common Lisp the Language + can be found. Note that this assumes to be the top-level of the + directory structure which should be the same as in the hypertext + version as provided by the CMU AI Repository. Defaults to + http://www.cs.cmu.edu/afs/cs.cmu.edu/project/ai-repository/ai/html/cltl/ + Note the / at the end.") + +(defvar *cltl2-local-file-pos* "/usr/doc/html/cltl/" + "A directory where the CLtl2 can be found. Note that this assumes + to be the top-level of the directory structure which should be the + same as in the hypertext version as provided by the CMU AI Repository. + Defaults to /usr/doc/html/cltl/ Note the / at the end.") + +(defconst *cltl2-index-file-name* "clm/index.html" + "The name of the index-file, typically with directory on front. + Defaults to clm/index.html, as this is the momentary position from + the top-level directory of the CLtL2-home. Defaults to clm/index.html. + Note that there is no leading /.") + +(defvar *cltl2-index-home* + (concatenate 'string + (case *cltl2-fetch-method* + ('local *cltl2-local-file-pos*) + ('local-index-only *cltl2-local-file-pos*) + ('www *cltl2-url*)) + *cltl2-index-file-name*) + "The absolute path which will be used to fetch the index.") + +(defvar *cltl2-home* + (concatenate + 'string + (case *cltl2-fetch-method* + ('local *cltl2-local-file-pos*) + ('local-index-only *cltl2-url*) + ('www *cltl2-url*)) + "clm/") + "This specifies the home-position of the CLtL2. The value of this variable + will be concatenated with the name of the nodes of the CLtL2.") + +(defvar *cltl2-index-buffer-name* "*cltl2-index*" + "The name of the buffer which holds the index for CLtL2.") + +(defvar *cltl2-old-find-file-noselect* 'nil + "Older versions of Emacs (at least XEmacs 19.11) don't support the + option RAWFILE with the function FIND-FILE-NO-SELECT. Set this variable + to 't if you have such an old version. It will cause fontification and + other useless stuff on the buffer in which the index is fetched. If + you don't use a local copy (of the index) this won't bother you.") + +(defvar *browse-cltl2-ht* (make-hash-table 0)) +(defconst *cltl2-search-regexpr* + "\\(.+\\)" + "A regular expression how to check for entries in the index-file + of CLtL2. Note that you have to modify this and the + prepare-get-entry*-functions if you want to change the search.") + +;;; ****************************** +;;; First of all: Compatibility stuff +;;; ****************************** +; no match-string in old versions +(if (not (fboundp (function match-string))) + (defun match-string (num &optional string) + "Return string of text matched by last search. + NUM specifies which parenthesized expression in the last regexp. + Value is nil if NUMth pair didn't match, or there were less than NUM pairs. + Zero means the entire text matched by the whole regexp or whole string. + STRING should be given if the last search was by `string-match' on STRING." + (if (match-beginning num) + (if string + (substring string (match-beginning num) (match-end num)) + (buffer-substring + (match-beginning num) (match-end num)))))) + +; no buffer-live-p in old versions + (if (not (fboundp (function buffer-live-p))) + (defun buffer-live-p (buf-or-name) + "Checks if BUF-OR-NAME is a live buffer. Returns non-nil + if BOF-OR-NAME is an editor buffer which has not been deleted. + Imitating a built-in function from newer Emacs versions." + (let ((object (if (bufferp buf-or-name) + buf-or-name + (get-buffer buf-or-name)))) + (and (bufferp object) (buffer-name object))))) + +; no add-submenu in old versions of XEmacs +(if (and (string-match "XEmacs\\|Lucid" emacs-version) + (not (fboundp 'add-submenu))) + (defun add-submenu (menu-path submenu &optional before) + "Add a menu to the menubar or one of its submenus. +If the named menu exists already, it is changed. +MENU-PATH identifies the menu under which the new menu should be inserted. + It is a list of strings; for example, (\"File\") names the top-level \"File\" + menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". + If MENU-PATH is nil, then the menu will be added to the menubar itself. +SUBMENU is the new menu to add. + See the documentation of `current-menubar' for the syntax. +BEFORE, if provided, is the name of a menu before which this menu should + be added, if this menu is not on its parent already. If the menu is already + present, it will not be moved." + (add-menu menu-path (car submenu) (cdr submenu) before))) + +; old find-file-noselect has no RAWFILE argument +(if *cltl2-old-find-file-noselect* + (unless (boundp 'cltl2-old-find-file-noselect-func) + (setf (symbol-value 'cltl2-old-find-file-noselect-func) + (symbol-function 'find-file-noselect)) + (setf (symbol-function 'find-file-noselect) + #'(lambda (file &optional nowarn rawfile) + (funcall cltl2-old-find-file-noselect-func file nowarn))))) + +;;; ****************************** +;;; Functions for fetching the index file +;;; ****************************** +(defun cltl2-fetch-index () + "Fetches the index page of the CLtl2 and puts it in its own + buffer called *cltl2-index*." + ;; if the index isn't here load it into a buffer + (when (or (not (get-buffer *cltl2-index-buffer-name*)) + (not (buffer-live-p *cltl2-index-buffer-name*))) + (message "Fetching the CLtL2 index file ...") + (case *cltl2-fetch-method* + ('local + (cltl2-fetch-index-by-file)) + ('local-index-only + (cltl2-fetch-index-by-file)) + ('www + (cltl2-fetch-index-by-www)))) + + (cltl2-prepare-index) +) + +;; fetch methods +(defun cltl2-fetch-index-by-file () + "Fetch the index from disk." + (setf *cltl2-index-buffer-name* + (find-file-noselect *cltl2-index-home* 'nil 't)) +) + +(defun cltl2-fetch-index-by-www () + "Fetch the index via WWW." + (save-excursion + (let ((old-url-working-buffer url-working-buffer)) + (setf url-working-buffer *cltl2-index-buffer-name*) + (url-retrieve *cltl2-index-home*) + (setf url-working-buffer old-url-working-buffer)))) + + +;;; ****************************** +;;; Main functions for viewing +;;; ****************************** +(defun cltl2-view-function-definition (entry) + "First checks if function can be found in the CLtL2-index-file. + If it can be found, uses the function browse-url to have a look + at the corresponding documentation from CLtL2." + (interactive "sCLtL2-Entry to lookup:") + (when (cltl2-index-unprepared-p) + (cltl2-fetch-index)) + + (let ((entry-url (cltl2-find-url-for-function (intern entry)))) + (when entry-url + (message "Loading found entry for %s into browser.." entry) + (browse-url + (concatenate 'string *cltl2-home* entry-url))))) + +(defun cltl2-find-url-for-function (entry) + "Checks if we can find a page for function ENTRY and + constructs an URL from it." + (let ((entry-url (gethash entry *browse-cltl2-ht*))) + (when (not entry-url) + (error "No entry in CLtL2 for %s" entry)) + entry-url)) + +(defun cltl2-view-index () + "Browse-urls the index file." + (interactive) + (browse-url *cltl2-index-home*)) + +;;; ****************************** +;;; Preparing the index (the hashtable) +;;; ****************************** +(defun cltl2-prepare-index () + "Jumps to the *cltl2-index* buffer and scans it, creating a hashtable + for all entries." + (message "Preparing CLtL2 index.") + (save-excursion + (set-buffer *cltl2-index-buffer-name*) + (goto-char (point-min)) + + ; search for entry + (do ((point (re-search-forward + *cltl2-search-regexpr* + nil t) + (re-search-forward + *cltl2-search-regexpr* + nil t))) + ; until we can't find anymore + ((null point)); (format "Index-preparation done.")) + ; put found entry in hash-table + (cl-puthash + (cltl2-prepare-get-entry-name) + (cltl2-prepare-get-entry-url) + *browse-cltl2-ht*)))) + +(defun cltl2-prepare-get-entry-name () + "Get the enrty name from the last match of regexp-search for entries." + (let ((name-string (intern (match-string 2)))) + (format "%s" name-string) + name-string)) + +(defun cltl2-prepare-get-entry-url () + "Get the enrty url from the last match of regexp-search for entries." + (let ((url (match-string 1))) + (format "%s" url) + url)) + +(defun cltl2-index-unprepared-p () + "Check if the index is already prepared." + ; If the hashtable has entries the index is prepared. + (not (and (hash-table-p *browse-cltl2-ht*) + (>= (hash-table-count *browse-cltl2-ht*) 1)))) + +;;; ****************************** +;;; Hooking into lisp mode and ilisp-mode +;;; ****************************** +(defun cltl2-lisp-mode-install () + "Not to be called by the user - just for lisp-mode-hook and ilisp-mode-hook. + + Adds browse-cltl2 to lisp-mode. If you use ilisp (installed via a hook + on lisp-mode) add browse-cltl2 to ilisp. Under Ilisp we use C-zb and C-zB + and without Ilisp we use C-cb and C-cB for calling the cltl2-view-functions. + Under XEmacs we will add ourself to the corresponding menus if there exists + one.." + ; set key bindings + (cond ((featurep 'ilisp) + (local-set-key "\C-zb" 'cltl2-view-function-definition) + (local-set-key "\C-zB" 'cltl2-view-index)) + (t + (local-set-key "\C-cb" 'cltl2-view-function-definition) + (local-set-key "\C-cB" 'cltl2-view-index))) + ; under XEmacs hook ourself into the menu if there is one + (when (string-match "XEmacs\\|Lucid" emacs-version) + ; this is for the menu as provided by ilisp-easy-menu + (cond ((not (null (car (find-menu-item current-menubar '("ILisp"))))) + (add-submenu + '("ILisp" "Documentation") + '("Browse CLtL2" + [ "View entry" cltl2-view-function-definition t] + [ "View index" cltl2-view-index t] ))) + ((not (null (car (find-menu-item current-menubar '("Lisp"))))) + (add-submenu + '("Lisp") + '("Browse CLtL2" + [ "View entry" cltl2-view-function-definition t] + [ "View index" cltl2-view-index t] ))))) +) + +(add-hook 'lisp-mode-hook 'cltl2-lisp-mode-install) +(add-hook 'ilisp-mode-hook 'cltl2-lisp-mode-install) + +;;; Providing ourself. +(provide 'ilisp-browse-cltl2) +;;; browse-cltl2.el ends here. diff -r b88636d63495 -r 8fc7fe29b841 lisp/utils/edmacro.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/utils/edmacro.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,715 @@ +;;; edmacro.el --- keyboard macro editor + +;; Copyright (C) 1993, 1994 Free Software Foundation, Inc. + +;; Author: Dave Gillespie +;; Maintainer: Dave Gillespie +;; Version: 2.01 +;; Keywords: abbrev + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 2, or (at your option) +;; any later version. + +;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;;; Usage: +;; +;; The `C-x C-k' (`edit-kbd-macro') command edits a keyboard macro +;; in a special buffer. It prompts you to type a key sequence, +;; which should be one of: +;; +;; * RET or `C-x e' (call-last-kbd-macro), to edit the most +;; recently defined keyboard macro. +;; +;; * `M-x' followed by a command name, to edit a named command +;; whose definition is a keyboard macro. +;; +;; * `C-h l' (view-lossage), to edit the 100 most recent keystrokes +;; and install them as the "current" macro. +;; +;; * any key sequence whose definition is a keyboard macro. +;; +;; This file includes a version of `insert-kbd-macro' that uses the +;; more readable format defined by these routines. +;; +;; Also, the `read-kbd-macro' command parses the region as +;; a keyboard macro, and installs it as the "current" macro. +;; This and `format-kbd-macro' can also be called directly as +;; Lisp functions. + +;; Type `C-h m', or see the documentation for `edmacro-mode' below, +;; for information about the format of written keyboard macros. + +;; `edit-kbd-macro' formats the macro with one command per line, +;; including the command names as comments on the right. If the +;; formatter gets confused about which keymap was used for the +;; characters, the command-name comments will be wrong but that +;; won't hurt anything. + +;; With a prefix argument, `edit-kbd-macro' will format the +;; macro in a more concise way that omits the comments. + +;; This package requires GNU Emacs 19 or later, and daveg's CL +;; package 2.02 or later. (CL 2.02 comes standard starting with +;; Emacs 19.18.) This package does not work with Emacs 18 or +;; Lucid Emacs. + +;; You bet it does. -hniksic + +;;; Code: + +(eval-when-compile + (require 'cl)) + +;;; The user-level commands for editing macros. + +;;;###autoload (define-key ctl-x-map "\C-k" 'edit-kbd-macro) + +;;;###autoload +(defvar edmacro-eight-bits nil + "*Non-nil if edit-kbd-macro should leave 8-bit characters intact. +Default nil means to write characters above \\177 in octal notation.") + +(defvar edmacro-mode-map nil) +(unless edmacro-mode-map + (setq edmacro-mode-map (make-sparse-keymap)) + (define-key edmacro-mode-map "\C-c\C-c" 'edmacro-finish-edit) + (define-key edmacro-mode-map "\C-c\C-q" 'edmacro-insert-key)) + +(defvar edmacro-store-hook) +(defvar edmacro-finish-hook) +(defvar edmacro-original-buffer) + +;;;###autoload +(defun edit-kbd-macro (keys &optional prefix finish-hook store-hook) + "Edit a keyboard macro. +At the prompt, type any key sequence which is bound to a keyboard macro. +Or, type `C-x e' or RET to edit the last keyboard macro, `C-h l' to edit +the last 100 keystrokes as a keyboard macro, or `M-x' to edit a macro by +its command name. +With a prefix argument, format the macro in a more concise way." + (interactive "kKeyboard macro to edit (C-x e, M-x, C-h l, or keys): \nP") + (when keys + (let ((cmd (if (arrayp keys) (key-binding keys) keys)) + (mac nil)) + (cond (store-hook + (setq mac keys) + (setq cmd nil)) + ((or (eq cmd 'call-last-kbd-macro) + (member keys '("\r" [return]))) + (or last-kbd-macro + (y-or-n-p "No keyboard macro defined. Create one? ") + (keyboard-quit)) + (setq mac (or last-kbd-macro "")) + (setq cmd 'last-kbd-macro)) + ((eq cmd 'execute-extended-command) + (setq cmd (read-command "Name of keyboard macro to edit: ")) + (if (string-equal cmd "") + (error "No command name given")) + (setq mac (symbol-function cmd))) + ((eq cmd 'view-lossage) + (setq mac (recent-keys)) + (setq cmd 'last-kbd-macro)) + ((null cmd) + (error "Key sequence %s is not defined" (key-description keys))) + ((symbolp cmd) + (setq mac (symbol-function cmd))) + (t + (setq mac cmd) + (setq cmd nil))) + (unless (arrayp mac) + (error "Key sequence %s is not a keyboard macro" + (key-description keys))) + (message "Formatting keyboard macro...") + (let* ((oldbuf (current-buffer)) + (mmac (edmacro-fix-menu-commands mac)) + (fmt (edmacro-format-keys mmac 1)) + (fmtv (edmacro-format-keys mmac (not prefix))) + (buf (get-buffer-create "*Edit Macro*"))) + (message "Formatting keyboard macro...done") + (switch-to-buffer buf) + (kill-all-local-variables) + (use-local-map edmacro-mode-map) + (setq buffer-read-only nil) + (setq major-mode 'edmacro-mode) + (setq mode-name "Edit Macro") + (set (make-local-variable 'edmacro-original-buffer) oldbuf) + (set (make-local-variable 'edmacro-finish-hook) finish-hook) + (set (make-local-variable 'edmacro-store-hook) store-hook) + (erase-buffer) + (insert ";; Keyboard Macro Editor. Press C-c C-c to finish; " + "press C-x k RET to cancel.\n") + (insert ";; Original keys: " fmt "\n") + (unless store-hook + (insert "\nCommand: " (if cmd (symbol-name cmd) "none") "\n") + (let ((keys (where-is-internal (or cmd mac)))) + (if keys + (while keys + (insert "Key: " (edmacro-format-keys (pop keys) 1) "\n")) + (insert "Key: none\n")))) + (insert "\nMacro:\n\n") + (save-excursion + (insert fmtv "\n")) + (recenter '(4)) + (when (eq mac mmac) + (set-buffer-modified-p nil)) + (run-hooks 'edmacro-format-hook))))) + +;;; The next two commands are provided for convenience and backward +;;; compatibility. + +;;;###autoload +(defun edit-last-kbd-macro (&optional prefix) + "Edit the most recently defined keyboard macro." + (interactive "P") + (edit-kbd-macro 'call-last-kbd-macro prefix)) + +;;;###autoload +(defun edit-named-kbd-macro (&optional prefix) + "Edit a keyboard macro which has been given a name by `name-last-kbd-macro'." + (interactive "P") + (edit-kbd-macro 'execute-extended-command prefix)) + +;;;###autoload +(defun read-kbd-macro (start &optional end) + "Read the region as a keyboard macro definition. +The region is interpreted as spelled-out keystrokes, e.g., \"M-x abc RET\". +See documentation for `edmacro-mode' for details. +Leading/trailing \"C-x (\" and \"C-x )\" in the text are allowed and ignored. +The resulting macro is installed as the \"current\" keyboard macro. + +In Lisp, may also be called with a single STRING argument in which case +the result is returned rather than being installed as the current macro. +The result will be a string if possible, otherwise an event vector. +Second argument NEED-VECTOR means to return an event vector always." + (interactive "r") + (if (stringp start) + (edmacro-parse-keys start end) + (setq last-kbd-macro (edmacro-parse-keys (buffer-substring start end))))) + +;;;###autoload +(defun format-kbd-macro (&optional macro verbose) + "Return the keyboard macro MACRO as a human-readable string. +This string is suitable for passing to `read-kbd-macro'. +Second argument VERBOSE means to put one command per line with comments. +If VERBOSE is `1', put everything on one line. If VERBOSE is omitted +or nil, use a compact 80-column format." + (and macro (symbolp macro) (setq macro (symbol-function macro))) + (edmacro-format-keys (or macro last-kbd-macro) verbose)) + +;;; Commands for *Edit Macro* buffer. + +(defun edmacro-finish-edit () + (interactive) + (unless (eq major-mode 'edmacro-mode) + (error + "This command is valid only in buffers created by `edit-kbd-macro'")) + (run-hooks 'edmacro-finish-hook) + (let ((cmd nil) (keys nil) (no-keys nil) + (top (point-min))) + (goto-char top) + (let ((case-fold-search nil)) + (while (cond ((looking-at "[ \t]*\\($\\|;;\\|REM[ \t\n]\\)") + t) + ((looking-at "Command:[ \t]*\\([^ \t\n]*\\)[ \t]*$") + (when edmacro-store-hook + (error "\"Command\" line not allowed in this context")) + (let ((str (buffer-substring (match-beginning 1) + (match-end 1)))) + (unless (equal str "") + (setq cmd (and (not (equal str "none")) + (intern str))) + (and (fboundp cmd) (not (arrayp (symbol-function cmd))) + (not (y-or-n-p + (format "Command %s is already defined; %s" + cmd "proceed? "))) + (keyboard-quit)))) + t) + ((looking-at "Key:\\(.*\\)$") + (when edmacro-store-hook + (error "\"Key\" line not allowed in this context")) + (let ((key (edmacro-parse-keys + (buffer-substring (match-beginning 1) + (match-end 1))))) + (unless (equal key "") + (if (equal key "none") + (setq no-keys t) + (push key keys) + (let ((b (key-binding key))) + (and b (commandp b) (not (arrayp b)) + (or (not (fboundp b)) + (not (arrayp (symbol-function b)))) + (not (y-or-n-p + (format "Key %s is already defined; %s" + (edmacro-format-keys key 1) + "proceed? "))) + (keyboard-quit)))))) + t) + ((looking-at "Macro:[ \t\n]*") + (goto-char (match-end 0)) + nil) + ((eobp) nil) + (t (error "Expected a `Macro:' line"))) + (forward-line 1)) + (setq top (point))) + (let* ((buf (current-buffer)) + (str (buffer-substring top (point-max))) + (modp (buffer-modified-p)) + (obuf edmacro-original-buffer) + (store-hook edmacro-store-hook) + (finish-hook edmacro-finish-hook)) + (unless (or cmd keys store-hook (equal str "")) + (error "No command name or keys specified")) + (when modp + (when (buffer-name obuf) + (set-buffer obuf)) + (message "Compiling keyboard macro...") + (let ((mac (edmacro-parse-keys str))) + (message "Compiling keyboard macro...done") + (if store-hook + (funcall store-hook mac) + (when (eq cmd 'last-kbd-macro) + (setq last-kbd-macro (and (> (length mac) 0) mac)) + (setq cmd nil)) + (when cmd + (if (= (length mac) 0) + (fmakunbound cmd) + (fset cmd mac))) + (if no-keys + (when cmd + (loop for key in (where-is-internal cmd '(keymap)) do + (global-unset-key key))) + (when keys + (if (= (length mac) 0) + (loop for key in keys do (global-unset-key key)) + (loop for key in keys do + (global-set-key key (or cmd mac))))))))) + (kill-buffer buf) + (when (buffer-name obuf) + (switch-to-buffer obuf)) + (when finish-hook + (funcall finish-hook))))) + +(defun edmacro-insert-key (key) + "Insert the written name of a key in the buffer." + (interactive "kKey to insert: ") + (if (bolp) + (insert (edmacro-format-keys key t) "\n") + (insert (edmacro-format-keys key) " "))) + +(defun edmacro-mode () + "\\Keyboard Macro Editing mode. Press +\\[edmacro-finish-edit] to save and exit. +To abort the edit, just kill this buffer with \\[kill-buffer] RET. + +Press \\[edmacro-insert-key] to insert the name of any key by typing the key. + +The editing buffer contains a \"Command:\" line and any number of +\"Key:\" lines at the top. These are followed by a \"Macro:\" line +and the macro itself as spelled-out keystrokes: `C-x C-f foo RET'. + +The \"Command:\" line specifies the command name to which the macro +is bound, or \"none\" for no command name. Write \"last-kbd-macro\" +to refer to the current keyboard macro (as used by \\[call-last-kbd-macro]). + +The \"Key:\" lines specify key sequences to which the macro is bound, +or \"none\" for no key bindings. + +You can edit these lines to change the places where the new macro +is stored. + + +Format of keyboard macros during editing: + +Text is divided into \"words\" separated by whitespace. Except for +the words described below, the characters of each word go directly +as characters of the macro. The whitespace that separates words +is ignored. Whitespace in the macro must be written explicitly, +as in \"foo SPC bar RET\". + + * The special words RET, SPC, TAB, DEL, LFD, ESC, and NUL represent + special control characters. The words must be written in uppercase. + + * A word in angle brackets, e.g., , , or , represents + a function key. (Note that in the standard configuration, the + function key and the control key RET are synonymous.) + You can use angle brackets on the words RET, SPC, etc., but they + are not required there. + + * Keys can be written by their ASCII code, using a backslash followed + by up to six octal digits. This is the only way to represent keys + with codes above \\377. + + * One or more prefixes M- (meta), C- (control), S- (shift), A- (alt), + H- (hyper), and s- (super) may precede a character or key notation. + For function keys, the prefixes may go inside or outside of the + brackets: C- = . The prefixes may be written in + any order: M-C-x = C-M-x. + + Prefixes are not allowed on multi-key words, e.g., C-abc, except + that the Meta prefix is allowed on a sequence of digits and optional + minus sign: M--123 = M-- M-1 M-2 M-3. + + * The `^' notation for control characters also works: ^M = C-m. + + * Double angle brackets enclose command names: <> is + shorthand for M-x next-line RET. + + * Finally, REM or ;; causes the rest of the line to be ignored as a + comment. + +Any word may be prefixed by a multiplier in the form of a decimal +number and `*': 3* = , and +10*foo = foofoofoofoofoofoofoofoofoofoo. + +Multiple text keys can normally be strung together to form a word, +but you may need to add whitespace if the word would look like one +of the above notations: `; ; ;' is a keyboard macro with three +semicolons, but `;;;' is a comment. Likewise, `\\ 1 2 3' is four +keys but `\\123' is a single key written in octal, and `< right >' +is seven keys but `' is a single function key. When in +doubt, use whitespace." + (interactive) + (error "This mode can be enabled only by `edit-kbd-macro'")) +(put 'edmacro-mode 'mode-class 'special) + + +(defun edmacro-int-char (int) + (if (fboundp 'char-to-int) + (char-to-int int) + int)) + +;;; Formatting a keyboard macro as human-readable text. + +;; Changes for XEmacs -- these two functions re-written from scratch. +;; edmacro-parse-keys always returns a vector. edmacro-format-keys +;; accepts a vector (but works with a string too). Vector may contain +;; keypress events. -hniksic +(defun edmacro-parse-keys (string &optional ignored) + (let ((pos 0) + (case-fold-search nil) + (word-to-sym '(("NUL" . (control space)) + ("RET" . return) + ("LFD" . linefeed) + ("TAB" . tab) + ("ESC" . escape) + ("SPC" . space) + ("BS" . backspace) + ("DEL" . delete))) + (char-to-word '((?\0 . "NUL") + (?\r . "RET") + (?\n . "LFD") + (?\t . "TAB") + (?\e . "ESC") + (?\ . "SPC") + (?\C-? . "DEL"))) + ;; string-to-symbol-or-char converter + (conv #'(lambda (arg) + (if (= (length arg) 1) + (aref arg 0) + (if (string-match "^<\\([^>]+\\)>$" arg) + (setq arg (match-string 1 arg))) + (let ((match (assoc arg word-to-sym))) + (if match + (cdr match) + (intern arg)))))) + (conv-chars #'(lambda (arg) + (let ((match (assoc arg char-to-word))) + (if match + (cdr (assoc (cdr match) word-to-sym)) + arg)))) + (force-sym nil) + res word found) + (while (and (< pos (length string)) + (string-match "[^ \t\n\f]+" string pos)) + (let ((word (substring string (match-beginning 0) (match-end 0))) + (times 1) + (add nil)) + (setq pos (match-end 0)) + (when (string-match "\\([0-9]+\\)\\*." word) + (setq times (string-to-int (substring word 0 (match-end 1)))) + (setq word (substring word (1+ (match-end 1))))) + (when (string-match "^<\\([^>]+\\)>$" word) + (setq word (match-string 1 word)) + (setq force-sym t)) + (setq match (assoc word word-to-sym)) + ;; Add an element. + (cond ((string-match "^\\\\[0-7]+" word) + ;; Octal value of character. + (setq add + (list + (edmacro-int-char (string-to-int (substring word 1)))))) + ((string-match "^<<.+>>$" word) + ;; Extended command. + (setq add + (nconc + (list + (if (eq (key-binding [(meta x)]) + 'execute-extended-command) + '(meta x) + (or (car (where-is-internal + 'execute-extended-command)) + '(meta x)))) + (mapcar conv-chars (concat (substring word 2 -2) "\r"))) + )) + ((or (equal word "REM") (string-match "^;;" word)) + ;; Comment. + (setq pos (string-match "$" string pos))) + (match + ;; Convert to symbol. + (setq add (list (cdr match)))) + ((string-match "^\\^" word) + ;; ^X == C-x + (if (/= (length word) 2) + (error "^ must be followed by one character")) + (setq add `((control ,(aref word 0))))) + ((string-match "^[MCSsAH]-" word) + ;; Parse C-* + (setq + add + (list + (let ((pos1 0) + (r1 nil) + follow) + (while (string-match "^[MCSsAH]-" (substring word pos1)) + (setq r1 (nconc + r1 + (list + (cdr (assq (aref word pos1) + '((?C . control) + (?M . meta) + (?S . shift) + (?A . alt) + (?H . hyper) + (?s . super))))))) + (setq pos1 (+ pos1 2))) + (setq follow (substring word pos1)) + (if (equal follow "") + (error "%s must precede a string" + (substring word 0 pos1))) + (nconc r1 (list (funcall conv follow))))))) + (force-sym + ;; This must be a symbol + (setq add (list (intern word)))) + (t + ;; Characters + (setq add (mapcar conv-chars word)))) + (let ((new nil)) + (loop repeat times do (setq new (append new add))) + (setq add new)) + (setq res (nconc res add)))) + (mapvector 'identity res))) + +(defun edmacro-conv (char-or-sym add-<>) + (let ((char-to-word '((?\0 . "NUL") + (?\r . "RET") + (?\n . "LFD") + (?\t . "TAB") + (?\e . "ESC") + (?\ . "SPC") + (?\C-? . "DEL"))) + (symbol-to-char '((return . ?\r) + (space . ?\ ) + (delete . ?\C-?) + (tab . ?\t) + (escape . ?\e)))) + (if (symbolp char-or-sym) + (if (= (length (symbol-name char-or-sym)) 1) + (setq char-or-sym (aref (symbol-name char-or-sym) 0)) + (let ((found (assq char-or-sym symbol-to-char))) + (if found + (setq char-or-sym (cdr found)))))) + ;; Return: + (cons (symbolp char-or-sym) + (if (symbolp char-or-sym) + (if add-<> + (concat "<" (symbol-name char-or-sym) ">") + (symbol-name char-or-sym)) + (let ((found (assq char-or-sym char-to-word))) + (if found + (cdr found) + (single-key-description char-or-sym))))))) + +(defun edmacro-format-1 (keys command times togetherp) + (let ((res "") + (start keys) + el) + (while keys + (unless (or (eq start keys) togetherp) + (callf concat res " ")) + (if (> times 1) + (setq res (concat (format "%d*" times) res))) + (setq el (car keys)) + (callf concat res + (cond ((listp el) + (let ((my "")) + (if (or + (let (cnv) + (while el + (let ((found (assq (car el) + '((control . "C-") + (meta . "M-") + (shift . "S-") + (alt . "A-") + (hyper . "H-") + (super . "s-"))))) + (callf concat my + (if found + (cdr found) + (setq cnv (edmacro-conv (car el) nil)) + (cdr cnv)))) + (setq el (cdr el))) + (car cnv)) + (> times 1)) + (concat "<" my ">") + my))) + (t + (cdr (edmacro-conv el t))))) + (setq keys (cdr keys))) + (if command + (callf concat res + (concat + (make-string (max (- 3 (/ (length res) tab-width)) 1) ?\t) + ";; " + (symbol-name command) + (if togetherp (format " * %d" (length start)))))) + res)) + +(defun edmacro-format-keys (macro &optional verbose) + (let ((cnt 0) + (res "")) + ;; XEmacs: + ;; If we're dealing with events, convert them to symbols first. + (and (fboundp 'events-to-keys) + (eventp (aref macro 0)) + (setq macro (events-to-keys macro t))) + + ;; I'm not sure I understand the original code, but this seems to + ;; work. + (and (eq verbose 1) + (setq verbose nil)) + + ;; Oh come on -- I want a list! Much easier to process... + (setq macro (mapcar 'identity macro)) + + (while macro + (let (key lookup (times 1) self-insert-p) + (loop do + (setq key (nconc key (list (car macro))) + macro (cdr macro) + lookup (lookup-key global-map (mapvector 'identity key))) + while + (and lookup (not (commandp lookup)))) + (if (and (eq lookup 'self-insert-command) + (= (length key) 1) + (not (memq (car key) + '(?\ ?\r ?\n space return linefeed tab)))) + (while (and (< (length key) 23) + (eq (lookup-key global-map (car macro)) + 'self-insert-command) + (not (memq (car macro) + '(?\ ?\r ?\n space return linefeed tab)))) + (setq key (nconc key (list (car macro))) + macro (cdr macro) + self-insert-p t)) + (while (edmacro-seq-equal key macro) + (setq macro (nthcdr (length key) macro)) + (incf times))) + (if (or self-insert-p + (null (cdr key)) + (= times 1)) + (callf concat res (edmacro-format-1 key (if verbose lookup + nil) + times self-insert-p) + (if verbose "\n" " ")) + (loop repeat times + do + (callf concat res + (edmacro-format-1 key (if verbose lookup + nil) + 1 self-insert-p) + (if verbose "\n" " ")))) + )) + res)) + +(defun edmacro-seq-equal (seq1 seq2) + (while (and seq1 seq2 + (equal (car seq1) (car seq2))) + (setq seq1 (cdr seq1) + seq2 (cdr seq2))) + (not seq1)) + +(defun edmacro-fix-menu-commands (macro) + (when (vectorp macro) + (let ((i 0) ev) + (while (< i (length macro)) + (when (consp (setq ev (aref macro i))) + (cond ((equal (cadadr ev) '(menu-bar)) + (setq macro (vconcat (edmacro-subseq macro 0 i) + (vector 'menu-bar (car ev)) + (edmacro-subseq macro (1+ i)))) + (incf i)) + ;; It would be nice to do pop-up menus, too, but not enough + ;; info is recorded in macros to make this possible. + (t + (error "Macros with mouse clicks are not %s" + "supported by this command")))) + (incf i)))) + macro) + +;;; Parsing a human-readable keyboard macro. + + + +;;; The following probably ought to go in macros.el: + +;;;###autoload +(defun insert-kbd-macro (macroname &optional keys) + "Insert in buffer the definition of kbd macro NAME, as Lisp code. +Optional second arg KEYS means also record the keys it is on +\(this is the prefix argument, when calling interactively). + +This Lisp code will, when executed, define the kbd macro with the same +definition it has now. If you say to record the keys, the Lisp code +will also rebind those keys to the macro. Only global key bindings +are recorded since executing this Lisp code always makes global +bindings. + +To save a kbd macro, visit a file of Lisp code such as your `~/.emacs', +use this command, and then save the file." + (interactive "CInsert kbd macro (name): \nP") + (let (definition) + (if (string= (symbol-name macroname) "") + (progn + (setq definition (format-kbd-macro)) + (insert "(setq last-kbd-macro")) + (setq definition (format-kbd-macro macroname)) + (insert (format "(defalias '%s" macroname))) + (if (> (length definition) 50) + (insert " (read-kbd-macro\n") + (insert "\n (read-kbd-macro ")) + (prin1 definition (current-buffer)) + (insert "))\n") + (if keys + (let ((keys (where-is-internal macroname '(keymap)))) + (while keys + (insert (format "(global-set-key %S '%s)\n" (car keys) macroname)) + (setq keys (cdr keys))))))) + +(provide 'edmacro) + +;;; edmacro.el ends here diff -r b88636d63495 -r 8fc7fe29b841 lisp/utils/eldoc.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/utils/eldoc.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,533 @@ +;;; eldoc.el --- show function arglist or variable docstring in echo area + +;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. + +;; Author: Noah Friedman +;; Maintainer: friedman@prep.ai.mit.edu +;; Keywords: extensions +;; Created: 1995-10-06 + +;; $Id: eldoc.el,v 1.1 1997/02/14 20:00:10 steve Exp $ + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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 2, or (at your option) +;; any later version. + +;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This program was inspired by the behavior of the "mouse documentation +;; window" on many Lisp Machine systems; as you type a function's symbol +;; name as part of a sexp, it will print the argument list for that +;; function. Behavior is not identical; for example, you need not actually +;; type the function name, you need only move point around in a sexp that +;; calls it. Also, if point is over a documented variable, it will print +;; the one-line documentation for that variable instead, to remind you of +;; that variable's meaning. + +;; One useful way to enable this minor mode is to put the following in your +;; .emacs: +;; +;; (autoload 'turn-on-eldoc-mode "eldoc" nil t) +;; (add-hook 'emacs-lisp-mode-hook 'turn-on-eldoc-mode) +;; (add-hook 'lisp-interaction-mode-hook 'turn-on-eldoc-mode) + +;;; Code: + +;; Use idle timers if available in the version of emacs running. +;; Please don't change this to use `require'; this package works as-is in +;; XEmacs (which doesn't have timer.el as of 19.14), and I would like to +;; maintain compatibility with that since I must use it sometimes. --Noah +(or (featurep 'timer) + (load "timer" t)) + +;;;###autoload +(defvar eldoc-mode nil + "*If non-nil, show the defined parameters for the elisp function near point. + +For the emacs lisp function at the beginning of the sexp which point is +within, show the defined parameters for the function in the echo area. +This information is extracted directly from the function or macro if it is +in pure lisp. If the emacs function is a subr, the parameters are obtained +from the documentation string if possible. + +If point is over a documented variable, print that variable's docstring +instead. + +This variable is buffer-local.") +(make-variable-buffer-local 'eldoc-mode) + +(defconst eldoc-idle-delay 0.50 + "*Number of seconds of idle time to wait before printing. +If user input arrives before this interval of time has elapsed after the +last input, no documentation will be printed. + +If this variable is set to 0, no idle time is required.") + +(defconst eldoc-minor-mode-string " ElDoc" + "*String to display in mode line when Eldoc Mode is enabled.") + +;; Put this minor mode on the global minor-mode-alist. +(or (assq 'eldoc-mode (default-value 'minor-mode-alist)) + (setq-default minor-mode-alist + (append (default-value 'minor-mode-alist) + '((eldoc-mode eldoc-minor-mode-string))))) + +(defconst eldoc-argument-case 'upcase + "Case to display argument names of functions, as a symbol. +This has two preferred values: `upcase' or `downcase'. +Actually, any name of a function which takes a string as an argument and +returns another string is acceptable.") + +(defvar eldoc-message-commands nil + "*Commands after which it is appropriate to print in the echo area. + +Eldoc does not try to print function arglists, etc. after just any command, +because some commands print their own messages in the echo area and these +functions would instantly overwrite them. But self-insert-command as well +as most motion commands are good candidates. + +This variable contains an obarray of symbols; it is probably best to +manipulate this data structure with the commands `eldoc-add-command' and +`eldoc-remove-command'.") + +(cond ((null eldoc-message-commands) + ;; If you increase the number of buckets, keep it a prime number. + (setq eldoc-message-commands (make-vector 31 0)) + (let ((list '("self-insert-command" + "next-" "previous-" + "forward-" "backward-" + "beginning-of-" "end-of-" + "goto-" + "recenter" + "scroll-" + "mouse-set-point")) + (syms nil)) + (while list + (setq syms (all-completions (car list) obarray 'fboundp)) + (setq list (cdr list)) + (while syms + (set (intern (car syms) eldoc-message-commands) t) + (setq syms (cdr syms))))))) + +;; Bookkeeping; the car contains the last symbol read from the buffer. +;; The cdr contains the string last displayed in the echo area, so it can +;; be printed again if necessary without reconsing. +(defvar eldoc-last-data '(nil . nil)) + +;; Idle timers are supported in Emacs 19.31 and later. +(defconst eldoc-use-idle-timer-p (fboundp 'run-with-idle-timer)) + +;; eldoc's timer object, if using idle timers +(defvar eldoc-timer nil) + +;; idle time delay currently in use by timer. +;; This is used to determine if eldoc-idle-delay is changed by the user. +(defvar eldoc-current-idle-delay eldoc-idle-delay) + +;; In emacs 19.29 and later, and XEmacs 19.13 and later, all messages are +;; recorded in a log. Do not put eldoc messages in that log since +;; they are Legion. +(defmacro eldoc-message (&rest args) + (if (fboundp 'display-message) + ;; XEmacs 19.13 way of preventing log messages. + (list 'display-message '(quote no-log) (apply 'list 'format args)) + (list 'let (list (list 'message-log-max 'nil)) + (apply 'list 'message args)))) + + +;;;###autoload +(defun eldoc-mode (&optional prefix) + "*Enable or disable eldoc mode. +See documentation for the variable of the same name for more details. + +If called interactively with no prefix argument, toggle current condition +of the mode. +If called with a positive or negative prefix argument, enable or disable +the mode, respectively." + (interactive "P") + + (cond (eldoc-use-idle-timer-p + (add-hook 'post-command-hook 'eldoc-schedule-timer)) + (t + ;; Use post-command-idle-hook if defined, otherwise use + ;; post-command-hook. The former is only proper to use in Emacs + ;; 19.30; that is the first version in which it appeared, but it + ;; was obsolesced by idle timers in Emacs 19.31. + (add-hook (if (boundp 'post-command-idle-hook) + 'post-command-idle-hook + 'post-command-hook) + 'eldoc-print-current-symbol-info))) + + (setq eldoc-mode (if prefix + (>= (prefix-numeric-value prefix) 0) + (not eldoc-mode))) + + (and (interactive-p) + (if eldoc-mode + (message "eldoc-mode is enabled") + (message "eldoc-mode is disabled"))) + eldoc-mode) + +;;;###autoload +(defun turn-on-eldoc-mode () + "Unequivocally turn on eldoc-mode (see variable documentation)." + (interactive) + (eldoc-mode 1)) + +(defun eldoc-add-command (cmd) + "Add COMMAND to the list of commands which causes function arg display. +If called interactively, completion on defined commands is available. + +When point is in a sexp, the function args are not reprinted in the echo +area after every possible interactive command because some of them print +their own messages in the echo area; the eldoc functions would instantly +overwrite them unless it is more restrained." + (interactive "CAdd function to eldoc message commands list: ") + (and (fboundp cmd) + (set (intern (symbol-name cmd) eldoc-message-commands) t))) + +(defun eldoc-remove-command (cmd) + "Remove COMMAND from the list of commands which causes function arg display. +If called interactively, completion matches only those functions currently +in the list. + +When point is in a sexp, the function args are not reprinted in the echo +area after every possible interactive command because some of them print +their own messages in the echo area; the eldoc functions would instantly +overwrite them unless it is more restrained." + (interactive (list (completing-read + "Remove function from eldoc message commands list: " + eldoc-message-commands 'boundp t))) + (and (symbolp cmd) + (setq cmd (symbol-name cmd))) + (if (fboundp 'unintern) + (unintern cmd eldoc-message-commands) + (let ((s (intern-soft cmd eldoc-message-commands))) + (and s + (makunbound s))))) + +;; Idle timers are part of Emacs 19.31 and later. +(defun eldoc-schedule-timer () + (or (and eldoc-timer + (memq eldoc-timer timer-idle-list)) + (setq eldoc-timer + (run-with-idle-timer eldoc-idle-delay t + 'eldoc-print-current-symbol-info))) + + ;; If user has changed the idle delay, update the timer. + (cond ((not (= eldoc-idle-delay eldoc-current-idle-delay)) + (setq eldoc-current-idle-delay eldoc-idle-delay) + (timer-set-idle-time eldoc-timer eldoc-idle-delay t)))) + + +(defun eldoc-print-current-symbol-info () + (and eldoc-mode + (not executing-kbd-macro) + + ;; Having this mode operate in an active minibuffer makes it + ;; impossible to see what you're doing. + (not (eq (selected-window) (minibuffer-window))) + + (cond (eldoc-use-idle-timer-p + (and (symbolp last-command) + (intern-soft (symbol-name last-command) + eldoc-message-commands))) + (t + ;; If we don't have idle timers, this function is + ;; running on post-command-hook directly; that means the + ;; user's last command is still on `this-command', and we + ;; must wait briefly for input to see whether to do display. + (and (symbolp this-command) + (intern-soft (symbol-name this-command) + eldoc-message-commands) + (sit-for eldoc-idle-delay)))) + + (let ((current-symbol (eldoc-current-symbol)) + (current-fnsym (eldoc-fnsym-in-current-sexp))) + (cond ((eq current-symbol current-fnsym) + (eldoc-print-fnsym-args current-fnsym)) + (t + (or (eldoc-print-var-docstring current-symbol) + (eldoc-print-fnsym-args current-fnsym))))))) + +(defun eldoc-print-fnsym-args (&optional symbol) + (interactive) + (let ((sym (or symbol (eldoc-fnsym-in-current-sexp))) + (args nil)) + (cond ((not (and (symbolp sym) + (fboundp sym)))) + ((eq sym (car eldoc-last-data)) + (setq args (cdr eldoc-last-data))) + ((subrp (eldoc-symbol-function sym)) + (setq args (or (eldoc-function-argstring-from-docstring sym) + (eldoc-docstring-first-line (documentation sym t)))) + (setcar eldoc-last-data sym) + (setcdr eldoc-last-data args)) + (t + (setq args (eldoc-function-argstring sym)) + (setcar eldoc-last-data sym) + (setcdr eldoc-last-data args))) + (and args + (eldoc-message "%s: %s" sym args)))) + +(defun eldoc-fnsym-in-current-sexp () + (let* ((p (point)) + (sym (progn + (while (and (eldoc-forward-sexp-safe -1) + (> (point) (point-min)))) + (cond ((or (= (point) (point-min)) + (memq (or (char-after (point)) 0) + '(?\( ?\")) + ;; If we hit a quotation mark before a paren, we + ;; are inside a specific string, not a list of + ;; symbols. + (eq (or (char-after (1- (point))) 0) ?\")) + nil) + (t (condition-case nil + (read (current-buffer)) + (error nil))))))) + (goto-char p) + (and (symbolp sym) + sym))) + +(defun eldoc-function-argstring (fn) + (let* ((prelim-def (eldoc-symbol-function fn)) + (def (if (eq (car-safe prelim-def) 'macro) + (cdr prelim-def) + prelim-def)) + (arglist (cond ((null def) nil) + ((byte-code-function-p def) + (if (fboundp 'compiled-function-arglist) + (funcall 'compiled-function-arglist def) + (aref def 0))) + ((eq (car-safe def) 'lambda) + (nth 1 def)) + (t t)))) + (eldoc-function-argstring-format arglist))) + +(defun eldoc-function-argstring-format (arglist) + (cond ((not (listp arglist)) + (setq arglist nil)) + ((symbolp (car arglist)) + (setq arglist + (mapcar (function (lambda (s) + (if (memq s '(&optional &rest)) + (symbol-name s) + (funcall eldoc-argument-case + (symbol-name s))))) + arglist))) + ((stringp (car arglist)) + (setq arglist + (mapcar (function (lambda (s) + (if (member s '("&optional" "&rest")) + s + (funcall eldoc-argument-case s)))) + arglist)))) + (concat "(" (mapconcat 'identity arglist " ") ")")) + + +(defun eldoc-print-var-docstring (&optional sym) + (or sym (setq sym (eldoc-current-symbol))) + (eldoc-print-docstring sym (documentation-property + sym 'variable-documentation t))) + +;; Print the brief (one-line) documentation string for the symbol. +(defun eldoc-print-docstring (symbol doc) + (and doc + (eldoc-message "%s" (eldoc-docstring-message symbol doc)))) + +;; If the entire line cannot fit in the echo area, the variable name may be +;; truncated or eliminated entirely from the output to make room. +;; Any leading `*' in the docstring (which indicates the variable is a user +;; option) is not printed." +(defun eldoc-docstring-message (symbol doc) + (and doc + (let ((name (symbol-name symbol))) + (setq doc (eldoc-docstring-first-line doc)) + (save-match-data + (let* ((doclen (+ (length name) (length ": ") (length doc))) + ;; Subtract 1 from window width since emacs seems not to + ;; write any chars to the last column, at least for some + ;; terminal types. + (strip (- doclen (1- (window-width (minibuffer-window)))))) + (cond ((> strip 0) + (let* ((len (length name))) + (cond ((>= strip len) + (format "%s" doc)) + (t + (setq name (substring name 0 (- len strip))) + (format "%s: %s" name doc))))) + (t + (format "%s: %s" symbol doc)))))))) + +(defun eldoc-docstring-first-line (doc) + (save-match-data + (and (string-match "\n" doc) + (setq doc (substring doc 0 (match-beginning 0)))) + (and (string-match "^\\*" doc) + (setq doc (substring doc 1)))) + doc) + + +;; Alist of predicate/action pairs. +;; Each member of the list is a sublist consisting of a predicate function +;; used to determine if the arglist for a function can be found using a +;; certain pattern, and a function which returns the actual arglist from +;; that docstring. +;; +;; The order in this table is significant, since later predicates may be +;; more general than earlier ones. +;; +;; Compiler note for Emacs 19.29 and later: these functions will be +;; compiled to bytecode, but can't be lazy-loaded even if you set +;; byte-compile-dynamic; to do that would require making them named +;; top-level defuns, and that's not particularly desirable either. +(defconst eldoc-function-argstring-from-docstring-method-table + (list + ;; Try first searching for args starting with symbol name. + ;; This is to avoid matching parenthetical remarks in e.g. sit-for. + (list (function (lambda (doc fn) + (string-match (format "^(%s[^\n)]*)$" fn) doc))) + (function (lambda (doc) + ;; end does not include trailing ")" sequence. + (let ((end (- (match-end 0) 1))) + (if (string-match " +" doc (match-beginning 0)) + (substring doc (match-end 0) end) + ""))))) + + ;; Try again not requiring this symbol name in the docstring. + ;; This will be the case when looking up aliases. + (list (function (lambda (doc fn) + (string-match "^([^\n)]+)$" doc))) + (function (lambda (doc) + ;; end does not include trailing ")" sequence. + (let ((end (- (match-end 0) 1))) + (and (string-match " +" doc (match-beginning 0)) + (substring doc (match-end 0) end)))))) + + ;; Emacs subr docstring style: + ;; (fn arg1 arg2 ...): description... + (list (function (lambda (doc fn) + (string-match "^([^\n)]+):" doc))) + (function (lambda (doc) + ;; end does not include trailing "):" sequence. + (let ((end (- (match-end 0) 2))) + (and (string-match " +" doc (match-beginning 0)) + (substring doc (match-end 0) end)))))) + + ;; XEmacs subr docstring style: + ;; "arguments: (arg1 arg2 ...) + (list (function (lambda (doc fn) + (string-match "^arguments: (\\([^\n)]+\\))" doc))) + (function (lambda (doc) + ;; also skip leading paren, but the first word is + ;; actually an argument, not the function name. + (substring doc (match-beginning 1) (match-end 1))))) + + ;; This finds the argstring for `condition-case'. Any others? + (list (function (lambda (doc fn) + (string-match + (format "^Usage looks like \\((%s[^\n)]*)\\)\\.$" fn) + doc))) + (function (lambda (doc) + ;; end does not include trailing ")" sequence. + (let ((end (- (match-end 1) 1))) + (and (string-match " +" doc (match-beginning 1)) + (substring doc (match-end 0) end)))))) + + ;; This finds the argstring for `setq-default'. Any others? + (list (function (lambda (doc fn) + (string-match (format "^[ \t]+\\((%s[^\n)]*)\\)$" fn) + doc))) + (function (lambda (doc) + ;; end does not include trailing ")" sequence. + (let ((end (- (match-end 1) 1))) + (and (string-match " +" doc (match-beginning 1)) + (substring doc (match-end 0) end)))))) + + ;; This finds the argstring for `start-process'. Any others? + (list (function (lambda (doc fn) + (string-match "^Args are +\\([^\n]+\\)$" doc))) + (function (lambda (doc) + (substring doc (match-beginning 1) (match-end 1))))) + )) + +(defun eldoc-function-argstring-from-docstring (fn) + (let ((docstring (documentation fn 'raw)) + (table eldoc-function-argstring-from-docstring-method-table) + (doc nil) + (doclist nil)) + (save-match-data + (while table + (cond ((funcall (car (car table)) docstring fn) + (setq doc (funcall (car (cdr (car table))) docstring)) + (setq table nil)) + (t + (setq table (cdr table))))) + + (cond ((not (stringp doc)) + nil) + ((string-match "&" doc) + (let ((p 0) + (l (length doc))) + (while (< p l) + (cond ((string-match "[ \t\n]+" doc p) + (setq doclist + (cons (substring doc p (match-beginning 0)) + doclist)) + (setq p (match-end 0))) + (t + (setq doclist (cons (substring doc p) doclist)) + (setq p l)))) + (eldoc-function-argstring-format (nreverse doclist)))) + (t + (concat "(" (funcall eldoc-argument-case doc) ")")))))) + + +;; forward-sexp calls scan-sexps, which returns an error if it hits the +;; beginning or end of the sexp. This returns nil instead. +(defun eldoc-forward-sexp-safe (&optional count) + "Move forward across one balanced expression (sexp). +With argument, do it that many times. Negative arg -COUNT means +move backward across COUNT balanced expressions. +Return distance in buffer moved, or nil." + (or count (setq count 1)) + (condition-case err + (- (- (point) (progn + (let ((parse-sexp-ignore-comments t)) + (forward-sexp count)) + (point)))) + (error nil))) + +;; Do indirect function resolution if possible. +(defun eldoc-symbol-function (fsym) + (let ((defn (and (fboundp fsym) + (symbol-function fsym)))) + (and (symbolp defn) + (condition-case err + (setq defn (indirect-function fsym)) + (error (setq defn nil)))) + defn)) + +(defun eldoc-current-symbol () + (let ((c (char-after (point)))) + (and c + (memq (char-syntax c) '(?w ?_)) + (intern-soft (current-word))))) + +(provide 'eldoc) + +;;; eldoc.el ends here diff -r b88636d63495 -r 8fc7fe29b841 lisp/utils/floating-toolbar.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/utils/floating-toolbar.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,378 @@ +;;; floating-toolbar.el -- popup toolbar support for XEmacs. +;; Copyright (C) 1997 Kyle E. Jones + +;; Author: Kyle Jones +;; Keywords: lisp + +;; This file is part of XEmacs. + +;; XEmacs 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 1, or (at your option) +;; any later version. + +;; XEmacs 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. + +;; A copy of the GNU General Public License can be obtained from this +;; program's author (send electronic mail to kyle@uunet.uu.net) or from +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; Popup toolbar for XEmacs (probably require XEmacs 19.14 or later) +;; Send bug reports to kyle_jones@wonderworks.com + +;; The command `floating-toolbar' pops up a small frame +;; containing a toolbar. The command should be bound to a +;; button-press event. If the mouse press happens over an +;; extent that has a non-nil 'floating-toolbar property, the +;; value of that property is the toolbar instantiator that will +;; be displayed. Otherwise the toolbar displayed is taken from +;; the variable `floating-toolbar'. This variable can be made +;; buffer local to produce buffer local floating toolbars. +;; +;; `floating-toolbar-or-popup-mode-menu' works like `floating-toolbar' +;; except that if no toolbar is found, `popup-mode-menu' is called. +;; +;; `floating-toolbar-from-extent-or-popup-mode-menu' works like +;; `floating-toolbar-or-popup-mode-menu' except only extent local +;; toolbars are used; the value of floating-toolbar is not used. +;; +;; Installation: +;; +;; Byte-compile the file floating-toolbar.el (with M-x byte-compile-file) +;; and put the .elc file in a directory in your load-path. Add the +;; following line to your .emacs: +;; +;; (require 'floating-toolbar) +;; +;; You will also need to bind a mouse click to `floating-toolbar' or to +;; `floating-toolbar-or-popup-mode-menu'. +;; +;; For 19.12 users: +;; If you are using fvwm, [tv]twm or ol[v]wm, you can also add +;; the following lines to various configuration file to use +;; minimal decorations on the toolbar frame. +;; +;; In .emacs: +;; (setq floating-toolbar-frame-name "floating-toolbar") +;; +;; For ol[v]wm use this in .Xdefaults: +;; olvwm.NoDecor: floating-toolbar +;; or +;; olwm.MinimalDecor: floating-toolbar +;; +;; For fvvm use this in your .fvwmrc: +;; NoTitle floating-toolbar +;; or +;; Style "floating-toolbar" NoTitle, NoHandles, BorderWidth 0 +;; +;; For twm use this in your .twmrc: +;; NoTitle { "floating-toolbar" } +;; +;; Under 19.13 and later versions the floating-toolbar frame uses a +;; transient window that is not normally decorated by window +;; managers. So the window manager directives should not be +;; needed for XEmacs 19.13 and beyond. + +;;; Code: + +(provide 'floating-toolbar) + +(require 'toolbar) +(require 'x) + +(defvar floating-toolbar-version "1.01" + "Version string for the floating-toolbar package.") + +(defvar floating-toolbar-use-sound nil + "*Non-nil value means play a sound to herald the appearance +and disappearance of the floating toolbar. + +`floating-toolbar-appears' will be played when the toolbar appears. +`floating-toolbar-disappears' will be played when the toolbar disappears. + +See the documentation for the function `load-sound-file' to see how +define sounds.") + +(defvar floating-toolbar nil + "*Toolbar instantiator used if mouse event is not over an extent +with a non-nil 'floating-toolbar property. This variable can be +made local to a buffer to have buffer local floating toolbars.") + +(defvar floating-toolbar-help-font nil + "*Non-nil value should be a font to be used to display toolbar help +messages. The floating toolbar frame will have a minibuffer window +so that it can display any help text that is attached to the toolbar +buttons.") + +(defvar floating-toolbar-frame-name nil + "*The frame name for the frame used to display the floating toolbar.") + +;;; +;;; End of user variables. +;;; + +(defvar floating-toolbar-frame nil + "The floating toolbar is displayed in this frame.") + +(defvar floating-toolbar-display-pending nil + "Non-nil value means the toolbar frame will be visible as soon +as the X server gets around to displaying it. Nil means it +will be invisible as soon as the X server decides to hide it.") + +(defun floating-toolbar-displayed () + (and (frame-live-p floating-toolbar-frame) + (frame-visible-p floating-toolbar-frame))) + +;;;###autoload +(defun floating-toolbar (event &optional extent-local-only) + "Popup a toolbar near the current mouse position. +The toolbar instantiator used is taken from the 'floating-toolbar +property of any extent under the mouse. If no such non-nil +property exists for any extent under the mouse, then the value of the +variable `floating-toolbar' is checked. If its value si nil, then +no toolbar will be displayed. + +This command should be bound to a button press event. + +When called from a program, first arg EVENT should be the button +press event. Optional second arg EXTENT-LOCAL-ONLY specifies +that only extent local toolbars should be used; this means the +`floating-toolbar' variable will not be consulted." + (interactive "_e") + (if (not (mouse-event-p event)) + nil + (let* ((buffer (event-buffer event)) + (window (event-window event)) + (frame (event-frame event)) + (point (and buffer (event-point event))) + (glyph-extent (event-glyph-extent event)) + (glyph-extent (if (and glyph-extent + (extent-property glyph-extent + 'floating-toolbar)) + glyph-extent)) + (extent (or glyph-extent + (and point + (extent-at point buffer 'floating-toolbar)))) + (toolbar (or (and extent (get extent 'floating-toolbar)) + (and (not extent-local-only) + (symbol-value-in-buffer 'floating-toolbar + buffer nil)))) + (x nil) + (y nil) + (echo-keystrokes 0) + (awaiting-release t) + (done nil)) + (if (not (consp toolbar)) + nil + ;; event-[xy]-pixel are relative to the top left corner + ;; of the frame. The presence of top and left toolbar + ;; and the menubar can move this position down and + ;; leftward, but XEmacs doesn't compensate for this in + ;; the values returned. So we do it here, as best we + ;; can. + (let* ((params (frame-parameters frame)) + (top (cdr (assq 'top params))) + (left (cdr (assq 'left params))) + (xtop-toolbar-height + (if (specifier-instance top-toolbar) + (specifier-instance top-toolbar-height) + 0)) + (xleft-toolbar-width + (if (specifier-instance left-toolbar) + (specifier-instance left-toolbar-width) + 0)) + ;; better than nothing + (menubar-height (if current-menubar 22 0))) + (setq x (+ left xleft-toolbar-width (event-x-pixel event)) + y (+ top xtop-toolbar-height menubar-height + (event-y-pixel event)))) + ;; for toolbar spec buffer local variable values + (and buffer (set-buffer buffer)) + (floating-toolbar-display-toolbar toolbar x y) + (while (not done) + (setq event (next-command-event)) + (cond ((and awaiting-release (button-release-event-p event)) + (setq awaiting-release nil)) + ((and (button-release-event-p event) + (event-over-toolbar-p event) + (eq floating-toolbar-frame (event-frame event))) + (floating-toolbar-undisplay-toolbar) + (and window (select-frame (window-frame window))) + (and window (select-window window)) + (dispatch-event event) + (setq done t)) + ((and (button-press-event-p event) + (event-over-toolbar-p event) + (eq floating-toolbar-frame (event-frame event))) + (setq awaiting-release nil) + (dispatch-event event)) + (t + ;; push back the event if it was in another frame. + ;; eat it if it was in the toolbar frame. + (if (and (event-frame event) + (not (eq floating-toolbar-frame + (event-frame event)))) + (setq unread-command-events + (cons event unread-command-events))) + (floating-toolbar-undisplay-toolbar) + (setq done t)))) + t )))) + +;;;###autoload +(defun floating-toolbar-or-popup-mode-menu (event) + "Like floating-toolbar, but if no toolbar is displayed +run popup-mode-menu." + (interactive "_e") + (or (floating-toolbar event) (popup-mode-menu))) + +;;;###autoload +(defun floating-toolbar-from-extent-or-popup-mode-menu (event) + "Like floating-toolbar-or-popup-mode-menu, but search only for an +extent local toolbar." + (interactive "_e") + (or (floating-toolbar event t) (popup-mode-menu))) + +(defun floating-toolbar-display-toolbar (toolbar x y) + (if (not (frame-live-p floating-toolbar-frame)) + (setq floating-toolbar-frame (floating-toolbar-make-toolbar-frame x y))) + (set-specifier top-toolbar + (cons (window-buffer + (frame-selected-window floating-toolbar-frame)) + toolbar)) + (floating-toolbar-resize-toolbar-frame toolbar) + ;; fiddle with the x value to try to center the toolbar relative to + ;; the mouse position. + (setq x (max 0 (- x (/ (frame-pixel-width floating-toolbar-frame) 2)))) + (floating-toolbar-set-toolbar-frame-position x y) + (floating-toolbar-expose-toolbar-frame)) + +(defun floating-toolbar-undisplay-toolbar () + (floating-toolbar-hide-toolbar-frame)) + +(defun floating-toolbar-hide-toolbar-frame () + (if (floating-toolbar-displayed) + (progn + (make-frame-invisible floating-toolbar-frame) + (if (and floating-toolbar-use-sound floating-toolbar-display-pending) + (play-sound 'floating-toolbar-disappears)) + (setq floating-toolbar-display-pending nil)))) + +(defun floating-toolbar-expose-toolbar-frame () + (if (not (floating-toolbar-displayed)) + (progn + (make-frame-visible floating-toolbar-frame) + (if (and floating-toolbar-use-sound + (null floating-toolbar-display-pending)) + (play-sound 'floating-toolbar-appears)) + (setq floating-toolbar-display-pending t)))) + +(defun floating-toolbar-resize-toolbar-frame (toolbar) + (let ((width 0) + (height nil) + (bevel (* 2 (or (cdr (assq 'toolbar-shadow-thickness (frame-parameters))) + 0))) + (captioned (specifier-instance toolbar-buttons-captioned-p)) + button glyph glyph-list) + (while toolbar + (setq button (car toolbar)) + (cond ((null button) + (setq width (+ width 8))) + ((eq (elt button 0) ':size) + (setq width (+ width (elt button 1)))) + ((and (eq (elt button 0) ':style) + (= (length button) 4) + (eq (elt button 2) ':size)) + (setq width (+ width bevel (elt button 3)))) + (t + (setq glyph-list (elt button 0)) + (if (symbolp glyph-list) + (setq glyph-list (symbol-value glyph-list))) + (if (and captioned (> (length glyph-list) 3)) + (setq glyph (or (nth 3 glyph-list) + (nth 4 glyph-list) + (nth 5 glyph-list))) + (setq glyph (car glyph-list))) + (setq width (+ width bevel (glyph-width glyph))) + (or height (setq height (+ bevel (glyph-height glyph)))))) + (setq toolbar (cdr toolbar))) + (set-specifier top-toolbar-height height floating-toolbar-frame) + (set-frame-width floating-toolbar-frame + (1+ (/ width (font-width (face-font 'default) + floating-toolbar-frame)))))) + +(defun floating-toolbar-set-toolbar-frame-position (x y) + (set-frame-position floating-toolbar-frame x y)) + +(defun floating-toolbar-make-junk-frame () + (let ((window-min-height 1) + (window-min-width 1)) + (make-frame '(minibuffer t initially-unmapped t width 1 height 1)))) + +(defun floating-toolbar-make-toolbar-frame (x y) + (save-excursion + (let ((window-min-height 1) + (window-min-width 1) + (bg-color (or (x-get-resource "backgroundToolBarColor" + "BackgroundToolBarColor" + 'string + 'global + (selected-device) + t) + "grey75")) + (buffer (get-buffer-create " *floating-toolbar-buffer*")) + (frame nil)) + (set-buffer buffer) + (set-buffer-menubar nil) + (if floating-toolbar-help-font + (progn (set-buffer (window-buffer (minibuffer-window))) + (set-buffer-menubar nil))) + (setq frame (make-frame (list + '(initially-unmapped . t) + ;; try to evade frame decorations + (cons 'name (or floating-toolbar-frame-name + "xclock")) + '(border-width . 2) + (cons 'border-color bg-color) + (cons 'top y) + (cons 'left x) + (cons 'popup + (floating-toolbar-make-junk-frame)) + (if floating-toolbar-help-font + '(minibuffer . only) + '(minibuffer . nil)) + '(width . 3) + '(height . 1)))) + (set-specifier text-cursor-visible-p (cons frame nil)) + (if floating-toolbar-help-font + (set-face-font 'default floating-toolbar-help-font frame) + (set-face-font 'default "nil2" frame)) + (set-face-background 'default bg-color frame) + (set-face-background 'modeline bg-color frame) + (set-specifier modeline-shadow-thickness (cons frame 1)) + (set-specifier has-modeline-p (cons frame nil)) + (set-face-background-pixmap 'default "" frame) + (set-window-buffer (frame-selected-window frame) buffer) + (set-specifier top-toolbar-height (cons frame 0)) + (set-specifier left-toolbar-width (cons frame 0)) + (set-specifier right-toolbar-width (cons frame 0)) + (set-specifier bottom-toolbar-height (cons frame 0)) + (set-specifier top-toolbar (cons frame nil)) + (set-specifier left-toolbar (cons frame nil)) + (set-specifier right-toolbar (cons frame nil)) + (set-specifier bottom-toolbar (cons frame nil)) + (set-specifier scrollbar-width (cons frame 0)) + (set-specifier scrollbar-height (cons frame 0)) + frame ))) + +;; first popup should be faster if we go ahead and make the frame now. +(or floating-toolbar-frame + (not (eq (device-type) 'x)) + (setq floating-toolbar-frame (floating-toolbar-make-toolbar-frame 0 0))) + +;;; floating-toolbar.el ends here diff -r b88636d63495 -r 8fc7fe29b841 lisp/utils/redo.el --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/utils/redo.el Mon Aug 13 08:50:29 2007 +0200 @@ -0,0 +1,187 @@ +;;; redo.el -- Redo/undo system for XEmacs + +;; Copyright (C) 1985, 1986, 1987, 1993-1995 Free Software Foundation, Inc. +;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. +;; Copyright (C) 1997 Kyle E. Jones + +;; Author: Kyle E. Jones, February 1997 +;; Keywords: lisp, extensions + +;; This file is part of XEmacs. + +;; XEmacs 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 2, or (at your option) +;; any later version. + +;; XEmacs 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 XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +;; 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +;;; Commentary: + +;; Derived partly from lisp/prim/simple.el in XEmacs. + +;; Emacs' normal undo system allows you to undo an arbitrary +;; number of buffer changes. These undos are recorded as ordinary +;; buffer changes themselves. So when you break the chain of +;; undos by issuing some other command, you can then undo all +;; the undos. The chain of recorded buffer modifications +;; therefore grows without bound, truncated only at garbage +;; collection time. +;; +;; The redo/undo system is different in two ways: +;; 1. The undo/redo command chain is only broken by a buffer +;; modification. You can move around the buffer or switch +;; buffers and still come back and do more undos or redos. +;; 2. The `redo' command rescinds the most recent undo without +;; recording the change as a _new_ buffer change. It +;; completely reverses the effect of the undo, which +;; includes making the chain of buffer modification records +;; shorter by one, to counteract the effect of the undo +;; command making the record list longer by one. +;; +;; Installation: +;; +;; Save this file as redo.el, byte compile it and put the +;; resulting redo.elc file in a directory that is listed in +;; load-path. +;; +;; In your .emacs file, add +;; (require 'redo) +;; and the system will be enabled. + +;;; Code: + +(provide 'redo) + +(defvar redo-version "1.00" + "Version number for the Redo package.") + +(defvar last-buffer-undo-list nil + "The head of buffer-undo-list at the last time an undo or redo was done.") +(make-variable-buffer-local 'last-buffer-undo-list) + +(defun redo (&optional count) + "Redo the the most recent undo. +Prefix arg COUNT means redo the COUNT most recent undos. +If you have modified the buffer since the last redo or undo, +then you cannot redo any undos before then." + (interactive "*p") + (if (eq buffer-undo-list t) + (error "No undo information in this buffer")) + (if (eq last-buffer-undo-list nil) + (error "No undos to redo")) + (or (eq last-buffer-undo-list buffer-undo-list) + (and (null (car-safe buffer-undo-list)) + (eq last-buffer-undo-list (cdr-safe buffer-undo-list))) + (error "Buffer modified since last undo/redo, cannot redo")) + (and (or (eq buffer-undo-list pending-undo-list) + (eq (cdr buffer-undo-list) pending-undo-list)) + (error "No further undos to redo in this buffer")) + (or (eq (selected-window) (minibuffer-window)) + (message "Redo...")) + (let ((modified (buffer-modified-p)) + (recent-save (recent-auto-save-p)) + (old-undo-list buffer-undo-list) + (p (cdr buffer-undo-list)) + (records-between 0)) + ;; count the number of undo records between the head of teh + ;; undo chain and the pointer to the next change. Note that + ;; by `record' we mean clumps of change records, not the + ;; boundary records. The number of records will always be a + ;; multiple of 2, because an undo moves the pending pointer + ;; forward one record and prepend a record to the head of the + ;; chain. Thus the separation always increases by two. WHen + ;; we decrease it we will decrease it by a multiple of 2 + ;; also. + (while p + (cond ((eq p pending-undo-list) + (setq p nil)) + ((null (car p)) + (setq records-between (1+ records-between)) + (setq p (cdr p))) + (t + (setq p (cdr p))))) + ;; we're off by one if pending pointer is nil, because there + ;; was no boundary record in front of it to count. + (and (null pending-undo-list) + (setq records-between (1+ records-between))) + ;; don't allow the user to redo more undos than exist. + ;; only half the records between the list head and the pending + ;; pointer are undos that are a part of this command chain. + (setq count (min (/ records-between 2) count) + p (primitive-undo (1+ count) buffer-undo-list)) + (if (eq p old-undo-list) + nil ;; nothing happened + ;; set buffer-undo-list to the new undo list. if has been + ;; shortened by `count' records. + (setq buffer-undo-list p) + ;; primitive-undo returns a list without a leading undo + ;; boundary. add one. + (undo-boundary) + ;; now move the pending pointer backward in the undo list + ;; to reflect the redo. sure would be nice if this list + ;; were doubly linked, but no... so we have to run down the + ;; list from the head and stop at the right place. + (let ((n (- records-between count))) + (setq p (cdr old-undo-list)) + (while (and p (> n 0)) + (if (null (car p)) + (setq n (1- n))) + (setq p (cdr p))) + (setq pending-undo-list p))) + (and modified (not (buffer-modified-p)) + (delete-auto-save-file-if-necessary recent-save)) + (or (eq (selected-window) (minibuffer-window)) + (message "Redo!")) + (setq last-buffer-undo-list buffer-undo-list))) + +(defun undo (&optional arg) + "Undo some previous changes. +Repeat this command to undo more changes. +A numeric argument serves as a repeat count." + (interactive "*p") + (let ((modified (buffer-modified-p)) + (recent-save (recent-auto-save-p))) + (or (eq (selected-window) (minibuffer-window)) + (message "Undo...")) + (or (eq last-buffer-undo-list buffer-undo-list) + (and (null (car-safe buffer-undo-list)) + (eq last-buffer-undo-list (cdr-safe buffer-undo-list))) + (progn (undo-start) + (undo-more 1))) + (undo-more (or arg 1)) + ;; Don't specify a position in the undo record for the undo command. + ;; Instead, undoing this should move point to where the change is. + ;; + ;;;; The old code for this was mad! It deleted all set-point + ;;;; references to the position from the whole undo list, + ;;;; instead of just the cells from the beginning to the next + ;;;; undo boundary. This does what I think the other code + ;;;; meant to do. + (let ((list buffer-undo-list) + (prev nil)) + (while (and list (not (null (car list)))) + (if (integerp (car list)) + (if prev + (setcdr prev (cdr list)) + ;; impossible now, but maybe not in the future + (setq buffer-undo-list (cdr list)))) + (setq prev list + list (cdr list)))) + (and modified (not (buffer-modified-p)) + (delete-auto-save-file-if-necessary recent-save))) + (or (eq (selected-window) (minibuffer-window)) + (message "Undo!")) + (setq last-buffer-undo-list buffer-undo-list)) + +;;; redo.el ends here diff -r b88636d63495 -r 8fc7fe29b841 lisp/version.el --- a/lisp/version.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/version.el Mon Aug 13 08:50:29 2007 +0200 @@ -26,7 +26,7 @@ (defconst emacs-version "19.15" "\ Version numbers of this version of Emacs.") -(setq emacs-version (purecopy (concat emacs-version " XEmacs Lucid (beta93)"))) +(setq emacs-version (purecopy (concat emacs-version " XEmacs Lucid (beta94)"))) (defconst emacs-major-version (progn (or (string-match "^[0-9]+" emacs-version) diff -r b88636d63495 -r 8fc7fe29b841 lisp/w3/ChangeLog --- a/lisp/w3/ChangeLog Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/w3/ChangeLog Mon Aug 13 08:50:29 2007 +0200 @@ -1,3 +1,97 @@ +Fri Feb 14 09:34:35 1997 William M. Perry + +* w3.txi: Lots of documentation about stylesheets, chapter layout + changes. + +Thu Feb 13 07:01:59 1997 William M. Perry + +* Synch'd up to widget 1.38 + +* w3-forms.el (w3-form-resurrect-widgets): For now, don't use the nice new + GUI pushbuttons - they appear to suffer badly on long lines. + +* w3-mouse.el (w3-running-FSF19): Use new w3-popup-menu-on-mouse-3 variable + +* w3-vars.el: Removed _lots_ of obsolete variables +(w3-popup-menu-on-mouse-3): New variable to control whether W3 should + override mouse-3 or not. + +* Emacs-W3 3.0.58 released + +* w3.txi: Added stubs for stylesheet chapters and supported URLs + +* images.el (image-register-netpbm-utilities): This is now safe to call + multiple times again. + +Wed Feb 12 06:26:55 1997 William M. Perry + +* w3-forms.el (w3-form-keymap): When binding widget-end-of-line, make sure + that we do not overwrite Emacspeak's prefix-key. Now does a + where-is-internal to find the correct binding in global-map to + override. + +* w3-display.el (w3-display-node): bind :emacspeak-help to 'w3-widget-echo + in all the hypertext links. + +* w3-vars.el (w3-mode-map): New binding for \M-\t - this _should_ have + been taken care of by the [(meta tab)] definition, but evidently it + doesn't. *sigh* + +Tue Feb 11 07:33:50 1997 William M. Perry + +* w3-forms.el (w3-form-create-option-list): Specify :menu-tag-get so that + keyboard-based-completion doesn't get confused by the fact that some + items will have spaces slapped in at the end. + +* ssl.el (ssl-program-arguments): New variable - a list of command line + switches to send to the SSL program in a subprocess, before the hostname + and port number. + (open-ssl-stream): Use it. + +Mon Feb 10 07:45:31 1997 William M. Perry + +* url-file.el (url-file): Removed refs to variable url-use-hypertext-dired + +* url-vars.el: Removed obsolete variable url-use-hypertext-dired + +* url-file.el (url-dired-find-file-mouse): fixed bad typo of + (interactive...) spec, added documentation to a few functions. + (url-file): Removed refs to obsolete variable url-use-hypertext-dired + +* w3-xemac.el (w3-setup-version-specifics): Workaround for users of XEmacs + 19.14 or 20.0 with the bad bad bad lossage with text properties that + have null values. This bug is fixed in XEmacs 19.15, and will be in + 20.1 as well. This bug would cause you to get errors like: + internal error: no text-prop <#extent ....> start-open + +* w3.el (w3-widget-button-click): Deal with new image capabilities of the + widget checkbox/radio-button stuff. + +* Synch'ed up to widget 1.31 + +Sun Feb 9 15:39:19 1997 William M. Perry + +* Emacs-W3 3.0.57 released + +* url-file.el (url-dired-minor-mode): New minor mode that overrides a few + of direds keybindings to use Emacs-W3 instead of straight find-file. + (url-format-directory): Now just uses dired to display directory + listings, much more powerful than the old way. Can copy files, act on + multiple files, you all know the drill. + +* w3.txi: Added more chapters, reorg of others. + +* w3-display.el (w3-maybe-start-image-download): Fixed handling of bad + images in the cache again. Duh. + No longer log to the warnings buffer if we fail to load an image. Just + use message - much less intrusive. We just usually don't care that much + about failed image loads. + +* url-gw.el (url-open-stream): fixed typo - was calling old + url-nslookup-host instead of url-gateway-nslookup-host + +* w3.el (w3-insert-formatted-url): Now inserts markup in lowercase. + Sat Feb 8 13:54:43 1997 William M. Perry * Emacs-W3 3.0.56 released. Getting closer! diff -r b88636d63495 -r 8fc7fe29b841 lisp/w3/images.el --- a/lisp/w3/images.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/w3/images.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,7 +1,7 @@ ;;; images.el --- Automatic image converters ;; Author: wmperry -;; Created: 1997/02/06 15:26:06 -;; Version: 1.7 +;; Created: 1997/02/13 15:01:57 +;; Version: 1.8 ;; Keywords: images ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -167,7 +167,7 @@ (defun image-register-netpbm-utilities () "Register all the netpbm utility packages converters." (interactive) - (if (image-converter-registered-p 'xpm 'gif) + (if (image-converter-registered-p 'pgm 'pbm) nil (image-register-converter 'pgm 'pbm "pgmtopbm") (image-register-converter 'ppm 'pgm "ppmtopgm") diff -r b88636d63495 -r 8fc7fe29b841 lisp/w3/ssl.el --- a/lisp/w3/ssl.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/w3/ssl.el Mon Aug 13 08:50:29 2007 +0200 @@ -26,10 +26,13 @@ ;;; Boston, MA 02111-1307, USA. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar ssl-program-name "ssl %s %s" - "*The program to run in a subprocess to open an SSL connection. -This is run through `format' with two strings, the hostname and port # -to connect to.") +(defvar ssl-program-name "ssl" + "*The program to run in a subprocess to open an SSL connection.") + +(defvar ssl-program-arguments nil + "*Arguments that should be passed to the program `ssl-program-name'. +This should be used if your SSL program needs command line switches to +specify any behaviour (certificate file locations, etc).") (defun open-ssl-stream (name buffer host service) "Open a SSL connection for a service to a host. @@ -45,13 +48,15 @@ Third arg is name of the host to connect to, or its IP address. Fourth arg SERVICE is name of the service desired, or an integer specifying a port number to connect to." - (let ((proc (start-process name buffer - "/bin/sh" - "-c" - (format ssl-program-name host - (if (stringp service) - service - (int-to-string service)))))) + (let ((proc (apply 'start-process + name + buffer + ssl-program-name + (append ssl-program-arguments + (list host + (if (stringp service) + service + (int-to-string service))))))) (process-kill-without-query proc) proc)) diff -r b88636d63495 -r 8fc7fe29b841 lisp/w3/url-file.el --- a/lisp/w3/url-file.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/w3/url-file.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,7 +1,7 @@ ;;; url-file.el --- File retrieval code ;; Author: wmperry -;; Created: 1997/02/07 14:29:24 -;; Version: 1.10 +;; Created: 1997/02/10 16:16:46 +;; Version: 1.13 ;; Keywords: comm, data, processes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -83,101 +83,135 @@ (apply 'insert-file-contents fname args) (set-buffer-modified-p nil))) +(defvar url-dired-minor-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-m" 'url-dired-find-file) + (if url-running-xemacs + (define-key map [button2] 'url-dired-find-file-mouse) + (define-key map [mouse-2] 'url-dired-find-file-mouse)) + map) + "Keymap used when browsing directories.") + +(defvar url-dired-minor-mode nil + "Whether we are in url-dired-minor-mode") + +(make-variable-buffer-local 'url-dired-minor-mode) + +(defun url-dired-find-file () + "In dired, visit the file or directory named on this line, using Emacs-W3." + (interactive) + (w3-open-local (dired-get-filename))) + +(defun url-dired-find-file-mouse (event) + "In dired, visit the file or directory name you click on, using Emacs-W3." + (interactive "@e") + (if (event-point event) + (progn + (goto-char (event-point event)) + (url-dired-find-file)))) + +(defun url-dired-minor-mode (&optional arg) + "Minor mode for directory browsing with Emacs-W3." + (interactive "P") + (cond + ((null arg) + (setq url-dired-minor-mode (not url-dired-minor-mode))) + ((equal 0 arg) + (setq url-dired-minor-mode nil)) + (t + (setq url-dired-minor-mode t)))) + +(add-minor-mode 'url-dired-minor-mode " URL" url-dired-minor-mode-map) + (defun url-format-directory (dir) ;; Format the files in DIR into hypertext - (let ((files (directory-files dir nil)) file - div attr mod-time size typ title) - (if (and url-directory-index-file - (file-exists-p (expand-file-name url-directory-index-file dir)) - (file-readable-p (expand-file-name url-directory-index-file dir))) - (save-excursion - (set-buffer url-working-buffer) - (erase-buffer) - (insert-file-contents-literally - (expand-file-name url-directory-index-file dir))) + (if (and url-directory-index-file + (file-exists-p (expand-file-name url-directory-index-file dir)) + (file-readable-p (expand-file-name url-directory-index-file dir))) (save-excursion - (if (string-match "/\\([^/]+\\)/$" dir) - (setq title (concat ".../" (url-match dir 1) "/")) - (setq title "/")) - (setq div (1- (length files))) (set-buffer url-working-buffer) (erase-buffer) - (insert "\n" - " \n" - " " title "\n" - " \n" - " \n" - "
    \n" - "

    Index of " title "

    \n" - " 
    \n"
-		"       Name                     Last modified                Size\n
    " - "
    \n 
    \n")
-	(while files
-	  (url-lazy-message "Building directory list... (%d%%)"
-			    (/ (* 100 (- div (length files))) div))
-	  (setq file (expand-file-name (car files) dir)
-		attr (file-attributes file)
-		file (car files)
-		mod-time (nth 5 attr)
-		size (nth 7 attr)
-		typ (or (mm-extension-to-mime (url-file-extension file)) ""))
-	  (setq file (url-hexify-string file))
-	  (if (equal '(0 0) mod-time) ; Set to null if unknown or
-	      (setq mod-time "Unknown                 ")
-	    (setq mod-time (current-time-string mod-time)))
-	  (if (or (equal size 0) (equal size -1) (null size))
-	      (setq size "   -")
-	    (setq size
-		  (cond
-		   ((< size 1024) (concat "   " "1K"))
-		   ((< size 1048576) (concat "   "
-					     (int-to-string
-					      (max 1 (/ size 1024))) "K"))
-		   (t
-		    (let* ((megs (max 1 (/ size 1048576)))
-			   (kilo (/ (- size (* megs 1048576)) 1024)))
-		      (concat "   "  (int-to-string megs)
-			      (if (> kilo 0)
-				  (concat "." (int-to-string kilo))
-				"") "M"))))))
-	  (cond
-	   ((or (equal "." (car files))
-		(equal "/.." (car files)))
-	    nil)
-	   ((equal ".." (car files))
-	    (if (not (= ?/ (aref file (1- (length file)))))
-		(setq file (concat file "/"))))
-	   ((stringp (nth 0 attr))	; Symbolic link handling
-	    (insert "[LNK] " (car files) ""
-		    (make-string (max 0 (- 25 (length (car files)))) ? )
-		    mod-time size "\n"))
-	   ((nth 0 attr)		; Directory handling
-	    (insert "[DIR] " (car files) ""
-		    (make-string (max 0 (- 25 (length (car files)))) ? )
-		    mod-time size "\n"))
-	   ((string-match "image" typ)
-	    (insert "[IMG] " (car files) ""
-		    (make-string (max 0 (- 25 (length (car files)))) ? )
-		    mod-time size "\n"))
-	   ((string-match "application" typ)
-	    (insert "[APP] " (car files) ""
-		    (make-string (max 0 (- 25 (length (car files)))) ? )
-		    mod-time size "\n"))
-	   ((string-match "text" typ)
-	    (insert "[TXT] " (car files) ""
-		    (make-string (max 0 (- 25 (length (car files)))) ? )
-		    mod-time size "\n"))
-	   (t
-	    (insert "[UNK] " (car files) ""
-		    (make-string (max 0 (- 25 (length (car files)))) ? )
-		    mod-time size "\n")))
-	  (setq files (cdr files)))
-	(insert "
    \n" - "
    \n" - " \n" - "\n" - "\n"))))) + (insert-file-contents-literally + (expand-file-name url-directory-index-file dir))) + (kill-buffer (current-buffer)) + (find-file dir) + (url-dired-minor-mode t))) +; (let ((files (directory-files dir nil)) file +; div attr mod-time size typ title desc) +; (save-excursion +; (if (string-match "/\\([^/]+\\)/$" dir) +; (setq title (concat ".../" (url-match dir 1) "/")) +; (setq title "/")) +; (setq div (1- (length files))) +; (set-buffer url-working-buffer) +; (erase-buffer) +; (insert "\n" +; " \n" +; " " title "\n" +; " \n" +; " \n" +; "

    Index of " title "

    \n" +; " \n" +; " \n" +; " \n") +; (while files +; (url-lazy-message "Building directory list... (%d%%)" +; (/ (* 100 (- div (length files))) div)) +; (setq file (expand-file-name (car files) dir) +; attr (file-attributes file) +; file (car files) +; mod-time (nth 5 attr) +; size (nth 7 attr) +; typ (or (mm-extension-to-mime (url-file-extension file)) "")) +; (setq file (url-hexify-string file)) +; (if (equal '(0 0) mod-time) ; Set to null if unknown or +; (setq mod-time "Unknown") +; (setq mod-time (current-time-string mod-time))) +; (if (or (equal size 0) (equal size -1) (null size)) +; (setq size "-") +; (setq size +; (cond +; ((< size 1024) "1K") +; ((< size 1048576) (concat (int-to-string +; (max 1 (/ size 1024))) "K")) +; (t +; (let* ((megs (max 1 (/ size 1048576))) +; (kilo (/ (- size (* megs 1048576)) 1024))) +; (concat (int-to-string megs) +; (if (> kilo 0) +; (concat "." (int-to-string kilo)) +; "") "M")))))) +; (cond +; ((or (equal "." (car files)) +; (equal "/.." (car files))) +; (setq desc nil)) +; ((equal ".." (car files)) +; (if (not (= ?/ (aref file (1- (length file))))) +; (setq file (concat file "/")))) +; ((stringp (nth 0 attr)) ; Symbolic link handling +; (setq desc "[LNK]")) +; ((nth 0 attr) ; Directory handling +; (setq desc "[DIR]")) +; ((string-match "image" typ) +; (setq desc "[IMG]")) +; ((string-match "application" typ) +; (setq desc "[APP]")) +; ((string-match "text" typ) +; (setq desc "[TXT]")) +; ((auto-save-file-name-p (car files)) +; (setq desc "[BAK]")) +; (t +; (setq desc "[UNK]"))) +; (if desc +; (insert "\n")) +; (setq files (cdr files))) +; (insert "
    NameLast ModifiedSize
    " desc " " (car files) +; "" mod-time "

    " size +; "

    \n" +; " \n" +; "\n" +; "\n"))) (defun url-host-is-local-p (host) "Return t iff HOST references our local machine." @@ -226,20 +260,14 @@ nil))) (cond ((file-directory-p filename) - (if url-use-hypertext-dired - (progn - (if (string-match "/$" filename) - nil - (setq filename (concat filename "/"))) - (if (string-match "/$" file) - nil - (setq file (concat file "/"))) - (url-set-filename urlobj file) - (url-format-directory filename)) - (progn - (if (get-buffer url-working-buffer) - (kill-buffer url-working-buffer)) - (find-file filename)))) + (if (string-match "/$" filename) + nil + (setq filename (concat filename "/"))) + (if (string-match "/$" file) + nil + (setq file (concat file "/"))) + (url-set-filename urlobj file) + (url-format-directory filename)) ((and (boundp 'w3-dump-to-disk) (symbol-value 'w3-dump-to-disk)) (cond ((file-exists-p filename) nil) diff -r b88636d63495 -r 8fc7fe29b841 lisp/w3/url-gw.el --- a/lisp/w3/url-gw.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/w3/url-gw.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,7 +1,7 @@ ;;; url-gw.el --- Gateway munging for URL loading ;; Author: wmperry -;; Created: 1997/02/08 05:29:07 -;; Version: 1.4 +;; Created: 1997/02/10 01:00:01 +;; Version: 1.5 ;; Keywords: comm, data, processes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -195,7 +195,7 @@ ;; If the user told us to do DNS for them, do it. (if url-gateway-broken-resolution - (setq host (url-nslookup-host host))) + (setq host (url-gateway-nslookup-host host))) (condition-case errobj (setq conn (case gw-method diff -r b88636d63495 -r 8fc7fe29b841 lisp/w3/url-vars.el --- a/lisp/w3/url-vars.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/w3/url-vars.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,7 +1,7 @@ ;;; url-vars.el --- Variables for Uniform Resource Locator tool ;; Author: wmperry -;; Created: 1997/02/08 05:29:30 -;; Version: 1.26 +;; Created: 1997/02/10 16:15:19 +;; Version: 1.27 ;; Keywords: comm, data, processes, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -447,19 +447,6 @@ (defvar url-running-xemacs (string-match "XEmacs" emacs-version) "*In XEmacs?.") -(defvar url-use-hypertext-dired t - "*How to format directory listings. - -If value is non-nil, use directory-files to list them out and -transform them into a hypertext document, then pass it through the -parse like any other document. - -If value nil, just pass the directory off to dired using find-file.") - -(defconst monthabbrev-alist - '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4) ("May" . 5) ("Jun" . 6) - ("Jul" . 7) ("Aug" . 8) ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12))) - (defvar url-default-ports '(("http" . "80") ("gopher" . "70") ("telnet" . "23") diff -r b88636d63495 -r 8fc7fe29b841 lisp/w3/w3-display.el --- a/lisp/w3/w3-display.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/w3/w3-display.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3-display.el --- display engine v99999 ;; Author: wmperry -;; Created: 1997/02/08 06:51:44 -;; Version: 1.123 +;; Created: 1997/02/14 17:51:17 +;; Version: 1.127 ;; Keywords: faces, help, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -32,6 +32,7 @@ (require 'w3-widget) (require 'w3-imap) +(define-widget-keywords :emacspeak-help) (autoload 'sentence-ify "flame") (autoload 'string-ify "flame") (autoload '*flame "flame") @@ -369,8 +370,7 @@ 'start-open t 'end-open t 'rear-nonsticky t - 'duplicable t - 'read-only t)) + 'duplicable t)) (if (car w3-active-voices) (add-text-properties w3-scratch-start-point (point) (list 'personality (car w3-active-voices)))) @@ -635,7 +635,7 @@ (eq (device-type) 'tty)) ; Why bother? (w3-add-delayed-graphic widget)) ((not (w3-image-loadable-p src nil)) ; Hey, we can't load it! - (w3-warn 'images (format "Skipping image %s" (url-basepath src t))) + (message "Skipping image %s" (url-basepath src t)) (w3-add-delayed-graphic widget)) (t ; Grab the images (let ( @@ -679,7 +679,7 @@ (cond ((w3-image-invalid-glyph-p glyph) (setq glyph nil) - (w3-warn 'image (format "Reading of %s failed." url))) + (message "Reading of %s failed." url)) ((eq (aref glyph 0) 'xbm) (let ((temp-fname (url-generate-unique-filename "%s.xbm"))) (save-excursion @@ -1216,7 +1216,7 @@ (save-restriction (narrow-to-region (point) (point)) (setq fill-column avgwidth - inhibit-read-only t + ;; inhibit-read-only t w3-last-fill-pos (point-min) i 0) ;; skip over columns that have leftover content @@ -1492,7 +1492,7 @@ (content-stack (list (list node))) (right-margin-stack (list fill-column)) (left-margin-stack (list 0)) - (inhibit-read-only t) + ;; (inhibit-read-only t) node insert-before insert-after @@ -1612,9 +1612,9 @@ (list 'link :args nil :value "" :tag "" :action 'w3-follow-hyperlink - :from - (set-marker (make-marker) st) + :from (set-marker (make-marker) st) :help-echo 'w3-widget-echo + :emacspeak-help 'w3-widget-echo ) (alist-to-plist args)))) (w3-handle-content node) @@ -1763,7 +1763,8 @@ (or w3-maximum-line-length (window-width))) fill-prefix "") - (set (make-local-variable 'inhibit-read-only) t)) + ;; (set (make-local-variable 'inhibit-read-only) t) + ) (w3-handle-content node) ) (*invisible diff -r b88636d63495 -r 8fc7fe29b841 lisp/w3/w3-forms.el --- a/lisp/w3/w3-forms.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/w3/w3-forms.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3-forms.el --- Emacs-w3 forms parsing code for new display engine ;; Author: wmperry -;; Created: 1997/02/09 06:39:43 -;; Version: 1.65 +;; Created: 1997/02/13 23:10:23 +;; Version: 1.70 ;; Keywords: faces, help, comm, data, languages ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -45,24 +45,28 @@ (define-widget-keywords :emacspeak-help :w3-form-data) -(defvar w3-form-keymap (copy-keymap global-map)) -(if (and w3-form-keymap widget-keymap) - (cl-map-keymap (function - (lambda (key binding) - (define-key w3-form-keymap - (if (vectorp key) key (vector key)) - (case binding - (widget-backward 'w3-widget-backward) - (widget-forward 'w3-widget-forward) - (otherwise binding))))) - widget-keymap)) -(define-key w3-form-keymap [return] 'w3-form-maybe-submit-by-keypress) -(define-key w3-form-keymap "\r" 'w3-form-maybe-submit-by-keypress) -(define-key w3-form-keymap "\n" 'w3-form-maybe-submit-by-keypress) -(define-key w3-form-keymap "\t" 'w3-widget-forward) -(define-key w3-form-keymap "\C-k" 'widget-kill-line) -(define-key w3-form-keymap "\C-a" 'widget-beginning-of-line) -(define-key w3-form-keymap "\C-e" 'widget-end-of-line) +(defvar w3-form-keymap + (let ((map (copy-keymap global-map)) + (eol-loc (where-is-internal 'end-of-line nil t))) + (if widget-keymap + (cl-map-keymap (function + (lambda (key binding) + (define-key map + (if (vectorp key) key (vector key)) + (case binding + (widget-backward 'w3-widget-backward) + (widget-forward 'w3-widget-forward) + (otherwise binding))))) + widget-keymap)) + (define-key map [return] 'w3-form-maybe-submit-by-keypress) + (define-key map "\r" 'w3-form-maybe-submit-by-keypress) + (define-key map "\n" 'w3-form-maybe-submit-by-keypress) + (define-key map "\t" 'w3-widget-forward) + (define-key map "\C-k" 'widget-kill-line) + (define-key map "\C-a" 'widget-beginning-of-line) + (if eol-loc + (define-key map eol-loc 'widget-end-of-line)) + map)) ;; A form entry area is a vector ;; [ type name default-value value maxlength options widget plist] @@ -152,6 +156,8 @@ (defun w3-form-resurrect-widgets () (let ((st (point-min)) + ;; FIXME! For some reason this loses on long lines right now. + (widget-push-button-gui nil) info nd node action face) (while st (if (setq info (get-text-property st 'w3-form-info)) @@ -382,6 +388,7 @@ (lambda (x) (list 'choice-item :format "%[%t%]" :emacspeak-help 'w3-form-summarize-field + :menu-tag-get (` (lambda (zed) (, (car x)))) :tag (mule-truncate-string (car x) size ? ) :button-face face :value-face face diff -r b88636d63495 -r 8fc7fe29b841 lisp/w3/w3-menu.el --- a/lisp/w3/w3-menu.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/w3/w3-menu.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3-menu.el --- Menu functions for emacs-w3 ;; Author: wmperry -;; Created: 1997/02/08 05:30:56 -;; Version: 1.27 +;; Created: 1997/02/13 23:04:55 +;; Version: 1.29 ;; Keywords: menu, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -636,10 +636,7 @@ url-privacy-level url-proxy-services url-standalone-mode - url-use-hypertext-dired url-use-hypertext-gopher - w3-color-filter - w3-color-use-reducing w3-default-homepage w3-default-stylesheet w3-delay-image-loads diff -r b88636d63495 -r 8fc7fe29b841 lisp/w3/w3-mouse.el --- a/lisp/w3/w3-mouse.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/w3/w3-mouse.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3-xemac.el --- XEmacs specific functions for emacs-w3 ;; Author: wmperry -;; Created: 1997/01/18 00:42:22 -;; Version: 1.6 +;; Created: 1997/02/13 23:05:39 +;; Version: 1.7 ;; Keywords: mouse, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -81,7 +81,9 @@ (if w3-running-FSF19 (progn - (define-key w3-mode-map [down-mouse-3] 'w3-popup-menu) - (define-key w3-mode-map [mouse-movement] 'w3-mouse-handler))) + (define-key w3-mode-map [mouse-movement] 'w3-mouse-handler) + (if w3-popup-menu-on-mouse-3 + (define-key w3-mode-map [down-mouse-3] 'w3-popup-menu)))) + (provide 'w3-mouse) diff -r b88636d63495 -r 8fc7fe29b841 lisp/w3/w3-speak.el --- a/lisp/w3/w3-speak.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/w3/w3-speak.el Mon Aug 13 08:50:29 2007 +0200 @@ -168,15 +168,10 @@ delimiters. We then turn on voice-lock-mode. Interactive prefix arg does the opposite. " (interactive "P") - (declare (special w3-delimit-links w3-delimit-emphasis w3-echo-link)) + (declare (special w3-echo-link)) (setq w3-echo-link 'text) (if arg - (progn - (setq w3-delimit-links 'guess - w3-delimit-emphasis 'guess) - (remove-hook 'w3-mode-hook 'w3-speak-mode-hook)) - (setq w3-delimit-links nil - w3-delimit-emphasis nil) + (remove-hook 'w3-mode-hook 'w3-speak-mode-hook) (add-hook 'w3-mode-hook 'w3-speak-mode-hook))) (defun w3-speak-browse-page () diff -r b88636d63495 -r 8fc7fe29b841 lisp/w3/w3-vars.el --- a/lisp/w3/w3-vars.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/w3/w3-vars.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3-vars.el,v --- All variable definitions for emacs-w3 ;; Author: wmperry -;; Created: 1997/02/09 06:46:59 -;; Version: 1.82 +;; Created: 1997/02/14 17:57:21 +;; Version: 1.89 ;; Keywords: comm, help, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -30,7 +30,7 @@ ;;; Variable definitions for w3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defconst w3-version-number - (let ((x "p3.0.56")) + (let ((x "p3.0.59")) (if (string-match "State:[ \t\n]+.\\([^ \t\n]+\\)" x) (setq x (substring x (match-beginning 1) (match-end 1))) (setq x (substring x 1))) @@ -38,7 +38,7 @@ (function (lambda (x) (if (= x ?-) "." (char-to-string x)))) x "")) "Version # of w3-mode.") -(defconst w3-version-date (let ((x "1997/02/09 06:46:59")) +(defconst w3-version-date (let ((x "1997/02/14 17:57:21")) (if (string-match "Date: \\([^ \t\n]+\\)" x) (substring x (match-beginning 1) (match-end 1)) x)) @@ -71,42 +71,18 @@ (defvar w3-default-configuration-file nil "*Where per-user customizations of w3 are kept.") -(defvar w3-default-action 'w3-prepare-buffer - "*A lisp symbol specifying what action to take for files with -extensions that are not mapped to a MIME type in `mm-mime-extensions'. -This is useful in case you ever run across files with weird extensions -\(.foo, .README, .READMEFIRST, etc). This should not be required -anymore. - -Possible values: any lisp symbol. Should be a function that takes no -arguments. The return value does not matter, it is ignored. Some examples -are: - -Action Value ----------------------------------------------- -Parse as HTML 'w3-prepare-buffer -View as text 'indented-text-mode") - (defvar w3-default-homepage nil - "*The url to open at startup. It can be any valid URL. This will -default to the environment variable WWW_HOME if you do not set it in -your .emacs file. If WWW_HOME is undefined, then it will default to -the hypertext documentation for W3 at Indiana University.") + "*The url to open at startup. It can be any valid URL. +This will default to the environment variable WWW_HOME if you do not +set it in your .emacs file. If WWW_HOME is undefined, then it will +default to the hypertext documentation for W3 at Indiana University.") (defvar w3-default-stylesheet nil "*The filename of the users default stylesheet.") -(defvar w3-do-blinking nil - "*Whether emacs-w3 should display blinking text.") - (defvar w3-do-incremental-display nil "*Whether to do incremental display of pages or not.") -(defvar w3-documents-menu-file nil - "*Where the Mosaic documents-menu file is located. This is a file -that has extra menus for the 'Navigate' menu. This should be in the same -format as the Mosaic extra documents.menu.") - (defvar w3-dump-to-disk nil "*If non-nil, all W3 pages loaded will be dumped to disk.") @@ -157,32 +133,12 @@ files in LaTeX. Good defaults are: {article}, [psfig,twocolumn]{article}, etc.") -(defvar w3-link-info-display-function nil - "*A function to call to get extra information about a link and -include it in a buffer. Will be placed after the link and any other -delimiters.") - (defvar w3-mail-command 'mail "*This function will be called whenever w3 needs to send mail. It should enter a mail-mode-like buffer in the current window. -`w3-mail-other-window-command' will be used if w3-mutable-windows is t. The commands `mail-to' and `mail-subject' should still work in this buffer, and it should use mail-header-separator if possible.") -(defvar w3-mail-other-window-command 'mail-other-window - "*This function will be called whenever w3 needs to send mail in -another window. It should enter a mail-mode-like buffer in a -different window. The commands `mail-to' and `mail-subject' should still -work in this buffer, and it should use mail-header-separator if -possible.") - -(defvar w3-max-inlined-image-size nil - "*The maximum byte size of a file to transfer as an inlined image. -If an image is being retrieved and exceeds this size, then it will be -cancelled. This works best on HTTP/1.0 servers that send a -Content-length header, otherwise the image is retrieved up until the -max number of bytes is retrieved, then killed.") - (defvar w3-max-menu-length 35 "*The maximum length of a pulldown menu before it will be split into smaller chunks, with the first part as a submenu, followed by the rest @@ -206,12 +162,6 @@ (defvar w3-mule-attribute 'underline "*How to highlight items in Mule (Multi-Linugual Emacs).") -(defvar w3-mutable-windows nil - "*Controls how new WWW documents are displayed. If this is set to -non-nil and pop-up-windows is non-nil, then new buffers will be shown -in another window. If either is nil, then it will replace the document -in the current window.") - (defvar w3-netscape-configuration-file nil "*A Netscape-for-X style configuration file. This file will only be read if and only if `w3-use-netscape-configuration-file' is non-nil.") @@ -235,14 +185,9 @@ Any other value of `w3-notify' is equivalent to `meek'.") -(defvar w3-ppmtoxbm-command "ppmtopgm | pgmtopbm | pbmtoxbm" - "*The command used to convert from the portable-pixmap graphics format -to an x bitmap. This will only ever be used if XEmacs doesn't have support -for XPM.") - -(defvar w3-ppmtoxpm-command "ppmtoxpm" - "*The command used to convert from the portable-pixmap graphics format -to XPM. The XPM _MUST_ be in version 3 format.") +(defvar w3-popup-menu-on-mouse-3 t + "*Non-nil value means W3 should provide context-sensitive menus on mouse-3. +A nil value means W3 should not change the binding of mouse-3.") (defvar w3-print-command "lpr -h -d" "*Print command for dvi files. @@ -268,29 +213,7 @@ (defvar w3-maximum-line-length nil "*Maximum length of a line. If nil, then lines can extend all the way to -the window margin. If a number, the smaller of this and -(- (window-width) w3-right-margin) is used.") - -(defvar w3-right-justify-address t - "*Whether to make address fields right justified, like Arena.") - -(defvar w3-show-headers nil - "*This is a list of regexps that match HTTP/1.0 headers to show at -the end of a buffer. All the headers being matched against will be -in lowercase. All matching headers will be inserted at the end of the -buffer in a
      list.") - -(defvar w3-show-status t - "*Whether to show a running total of bytes transferred. Can cause a -large hit if using a remote X display over a slow link, or a terminal -with a slow modem.") - -(defvar w3-starting-documents - '(("Internet Starting Points" "http://www.ncsa.uiuc.edu/SDG/Software/Mosaic/StartingPoints/NetworkStartingPoints.html") - ("Internet Resources Meta-index" "http://www.ncsa.uiuc.edu/SDG/Software/Mosaic/MetaIndex.html") - ("NCSA's What's New" "http://www.ncsa.uiuc.edu/SDG/Software/Mosaic/Docs/whats-new.html")) - "*An assoc list of titles and URLs for quick access. These are just -defaults so that new users have somewhere to go.") +the window margin.") (defvar w3-temporary-directory "/tmp" "*Where temporary files go.") @@ -301,11 +224,6 @@ (defvar w3-track-mouse t "*Whether to track the mouse and message the url under the mouse.") -(defvar w3-use-forms-index t - "*Non-nil means translate tags into a hypertext form. -A single text entry box will be drawn where the ISINDEX tag appears. -If t, the isindex handling will be the same as Mosaic for X.") - (defvar w3-use-netscape-configuration-file nil "*Whether to use a netscape configuration file to determine things like home pages, link colors, etc. If non-nil, then `w3-netscape-configuration-file' @@ -349,35 +267,8 @@ "*In FSF v19 emacs?") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Link delimiting -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar w3-delimit-emphasis 'guess - "*Whether to use characters at the start and end of each bold/italic -region. Obsolete variable (almost) - all this should be specified by the -default stylesheet.") - -(defvar w3-link-start-delimiter '("[[" . "{{") - "*Put this at front of link if w3-delimit-links is t.") - -(defvar w3-link-end-delimiter '("]]" . "}}") - "*Put this at end of link if w3-delimit-links is t.") - -(defvar w3-delimit-links 'guess - "*Put brackets around links? If this variable is eq to 'linkname, then -it will put the link # in brackets after the link text. If it is nil, then -it will not put anything. If it is non-nil and not eq to 'linkname, then -it will put [[ & ]] around the entire text of the link. Is initially set -to be t iff in normal emacs. Nil if in XEmacs or lucid emacs, since links -should be in different colors/fonts.") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Graphics parsing stuff ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar w3-graphics-always-show-entities t - "*Set to t to always show graphic entities, regardless of the value of -w3-delay-image-loads. Useful if you keep the entities locally and aren't -worried about the transfer time on something that small.") - (defvar w3-graphics-list nil "*List of graphics already read in.") @@ -412,45 +303,6 @@ ("image/tiff" . tiff) ) "*How to map MIME types to image types for the `image' package.") -(defvar w3-color-use-reducing 'guess - "*Whether to use ppmquant/ppmdither to do color reducing for inlined images. -If you are using a 24bit display, you should set this to nil.") - -(defvar w3-color-max-red 4 - "*Max # of red cells to allocate for inlined images.") - -(defvar w3-color-max-green 4 - "*Max # of green cells to allocate for inlined images.") - -(defvar w3-color-max-blue 4 - "*Max # of blue cells to allocate for inlined images.") - -(defvar w3-color-filter 'ppmdither - "*How to do color reducing on inlined images. -This should be a symbol, either ppmdither or ppmquant. -This variable only has any meaning if w3-color-use-reducing is non-nil. -Possible values are: - -ppmquant :== Use the ppmquant program to reduce colors. The product - of w3-color-max-[red|green|blue] is used as the maximum - number of colors. -ppmdither :== Use the ppmdither program to reduce colors. - -any string :== Use this string as the filter. No interpretation of it - is done at all. Example is: - ppmquant -fs -map ~/pixmaps/colormap.ppm") - -(defvar w3-ppmdither-is-buggy t - "*The ppmdither which comes with pbmplus/netpbm releases through -1mar1994 at least ignores the 'maxval' in its input. This can cause -trouble viewing black-and-white gifs. If this variable is set, a -(harmless) 'pnmdepth 255' step is inserted to work around this bug. -You can test your ppmdither by doing - ppmmake white 100 100 | pnmdepth 1 | ppmdither | pnmdepth 255 | ppmhist -If the output has a single line like this: - 255 255 255 255 10000 -then it's safe to set this variable to nil.") - ;; Store the database of HTML general entities. (defvar w3-html-entities '( @@ -685,7 +537,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Menu definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar w3-navigate-menu nil) (defvar w3-popup-menu '("Emacs-W3 Commands" ["Back" w3-history-backward (car (w3-history-find-url-internal (url-view-url t)))] @@ -693,9 +544,6 @@ ) "The shorter popup menu.") -(defvar w3-documentation-root "http://www.cs.indiana.edu/elisp/w3/docs/" - "*Where the w3 documentation lives. This MUST end in a slash.") - (defvar w3-graphlink-menu '(("Open this Image (%s)" . w3-fetch) ("Save this Image As..." . w3-download-url) @@ -720,6 +568,9 @@ the link. Each label can have exactly one `%s' that will be replaced by the URL of the link.") +(defvar w3-documentation-root "http://www.cs.indiana.edu/elisp/w3/docs/" + "*Where the w3 documentation lives. This MUST end in a slash.") + (defvar w3-defined-link-types ;; This is the HTML3.0 list (downcased) plus "made". '("previous" "next" "up" "down" "home" "toc" "index" "glossary" @@ -734,52 +585,6 @@ (defvar w3-form-radio-elements nil "Internal variable - do not touch!") (defvar w3-form-elements nil "Internal variable - do not touch!") -(defvar w3-invisible-href-list nil - "A list of 'invisible' graphic links in the current buffer.") - -(defconst w3-state-locator-variable - '( - :align - :background - :center - :depth - :figalt - :figdata - :fillcol - :form - :formnum - :header-start - :href - :link-args - :image - :lists - :map - :name - :needspace - :next-break - :nofill - :nowrap - :optarg - :options - :pre-start - :select - :secret - :table - :text-mangler - :title - :link-title - :w3-graphic - :zone - :label-text - :seen-this-url - ) - "A list of all the various state kept in the drawing engine. -This is used by the `w3-get-state' and `w3-put-state' macros.") - -(defvar w3-state-vector - (make-vector (1+ (length w3-state-locator-variable)) nil) - "Various state shit kept by emacs-w3.") - (defvar w3-user-stylesheet nil "The global stylesheet for this user.") @@ -803,23 +608,11 @@ "An internal variable for the new display engine that specifies the last tag processed.") -(defvar w3-table-info nil - "An internal variable for the new display engine for keeping table data -during the pre-pass parsing.") - -(defvar w3-current-formatter nil - "Current formatter function.") - -(defvar w3-draw-buffer nil - "Where we are currently drawing into. This _must_ be a buffer object -when it is referenced.") - (defvar w3-active-faces nil "The list of active faces.") (defvar w3-active-voices nil "The list of active voices.") (defvar w3-netscape-variable-mappings '(("PRINT_COLOR" . ps-print-color-p) - ("DITHER_IMAGES" . w3-color-use-reducing) ("SOCKS_HOST" . url-socks-host) ("ORGANIZATION" . url-user-organization) ("EMAIL_ADDRESS" . url-personal-mail-address) @@ -907,8 +700,6 @@ w3-current-source w3-delayed-images w3-hidden-forms - w3-invisible-href-list - w3-state-vector w3-current-stylesheet w3-form-labels w3-id-positions @@ -917,18 +708,6 @@ "A list of variables that should be preserved when entering w3-mode.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Syntax stuff -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defvar w3-parse-args-syntax-table - (copy-syntax-table emacs-lisp-mode-syntax-table) - "A syntax table for parsing sgml attributes.") - -(modify-syntax-entry ?' "\"" w3-parse-args-syntax-table) -(modify-syntax-entry ?` "\"" w3-parse-args-syntax-table) -(modify-syntax-entry ?< "(>" w3-parse-args-syntax-table) -(modify-syntax-entry ?> ")<" w3-parse-args-syntax-table) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Emulation stuff ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar w3-netscape-emulation-minor-mode nil @@ -949,16 +728,11 @@ (lambda (var) (if (boundp var) (make-variable-buffer-local var)))) w3-persistent-variables) -(make-variable-buffer-local 'w3-state-vector) -(make-variable-buffer-local 'w3-current-stylesheet) + (make-variable-buffer-local 'w3-base-alist) (make-variable-buffer-local 'w3-last-tag) (make-variable-buffer-local 'w3-last-fill-pos) -(make-variable-buffer-local 'w3-table-info) -(make-variable-buffer-local 'w3-draw-buffer) -(make-variable-buffer-local 'w3-current-formatter) (make-variable-buffer-local 'w3-active-faces) -(make-variable-buffer-local 'w3-default-style) (make-variable-buffer-local 'w3-netscape-emulation-minor-mode) (make-variable-buffer-local 'w3-lynx-emulation-minor-mode) (make-variable-buffer-local 'w3-last-search-item) @@ -1036,17 +810,12 @@ (define-key w3-mode-map [(control meta t)] 'url-list-processes) ;; Widget navigation -(define-key w3-mode-map "\t" 'w3-widget-forward) +(define-key w3-mode-map [tab] 'w3-widget-forward) +(define-key w3-mode-map "\M-\t" 'w3-widget-backward) (define-key w3-mode-map [backtab] 'w3-widget-backward) (define-key w3-mode-map [(shift tab)] 'w3-widget-backward) (define-key w3-mode-map [(meta tab)] 'w3-widget-backward) -;;; This is so we can use a consistent method of checking for mule support -;;; Emacs-based mule uses (boundp 'MULE), but XEmacs-based mule uses -;;; (featurep 'mule) - I choose to use the latter. - -(if (boundp 'MULE) - (provide 'mule)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Keyword definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff -r b88636d63495 -r 8fc7fe29b841 lisp/w3/w3-xemac.el --- a/lisp/w3/w3-xemac.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/w3/w3-xemac.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3-xemac.el --- XEmacs specific functions for emacs-w3 ;; Author: wmperry -;; Created: 1997/01/19 20:06:02 -;; Version: 1.12 +;; Created: 1997/02/10 16:08:10 +;; Version: 1.14 ;; Keywords: faces, help, mouse, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -80,6 +80,24 @@ (if current-menubar (add-submenu '("Help") (cons "WWW" (cdr w3-menu-help-menu)))))) + ;; FIXME FIXME: Do sexy things to the default modeline for Emacs-W3 + + ;; The following is a workaround for XEmacs 19.14 and XEmacs 20.0 + ;; The text property implementation is badly broken - you could not have + ;; a text property with a `nil' value. Bad bad bad. + (if (or (and (= emacs-major-version 20) + (= emacs-minor-version 0)) + (and (= emacs-major-version 19) + (= emacs-minor-version 14))) + (defun text-prop-extent-paste-function (ext from to) + (let ((prop (extent-property ext 'text-prop nil)) + (val nil)) + (if (null prop) + (error "Internal error: no text-prop")) + (setq val (extent-property ext prop nil)) + (put-text-property from to prop val nil) + nil)) + ) ) (defun w3-store-in-clipboard (str) diff -r b88636d63495 -r 8fc7fe29b841 lisp/w3/w3.el --- a/lisp/w3/w3.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/w3/w3.el Mon Aug 13 08:50:29 2007 +0200 @@ -1,7 +1,7 @@ ;;; w3.el --- Main functions for emacs-w3 on all platforms/versions ;; Author: wmperry -;; Created: 1997/02/08 00:49:52 -;; Version: 1.72 +;; Created: 1997/02/13 23:05:56 +;; Version: 1.77 ;; Keywords: faces, help, comm, news, mail, processes, mouse, hypermedia ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -127,60 +127,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Functions for compatibility with XMosaic -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Parse out the Mosaic documents-menu file -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun w3-parse-docs-menu () - ;; Parse the Mosaic documents menu - (let ((tmp-menu (append '((separator)) w3-starting-documents - '((separator)))) - real-menu x y name url) - (if (or (not (file-exists-p w3-documents-menu-file)) - (not (file-readable-p w3-documents-menu-file))) - nil - (save-excursion - (set-buffer (get-buffer-create " *w3-temp*")) - (erase-buffer) - (insert-file-contents w3-documents-menu-file) - (goto-char (point-min)) - (while (not (eobp)) - (if (not (looking-at "-+$")) - (setq x (progn (beginning-of-line) (point)) - y (progn (end-of-line) (point)) - name (prog1 - (buffer-substring x y) - (delete-region x (min (1+ y) (point-max)))) - x (progn (beginning-of-line) (point)) - y (progn (end-of-line) (point)) - url (prog1 - (buffer-substring x y) - (delete-region x (min (1+ y) (point-max)))) - tmp-menu (if (rassoc url tmp-menu) tmp-menu - (cons (cons name url) tmp-menu))) - (setq tmp-menu (cons '(separator) tmp-menu)) - (delete-region (point-min) (min (1+ (progn (end-of-line) - (point))) - (point-max))))) - (kill-buffer (current-buffer)))) - (if (equal (car (car tmp-menu)) "") (setq tmp-menu (cdr tmp-menu))) - (while tmp-menu - (setq real-menu (cons (if (equal 'separator (car (car tmp-menu))) - "--------" - (vector (car (car tmp-menu)) - (list 'w3-fetch - (if (listp (cdr (car tmp-menu))) - (car (cdr (car tmp-menu))) - (cdr (car tmp-menu)))) t)) - real-menu) - tmp-menu (cdr tmp-menu))) - (setq w3-navigate-menu (append w3-navigate-menu real-menu - (list "-----"))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Functions to pass files off to external viewers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun w3-start-viewer (fname cmd &optional view) @@ -384,9 +330,7 @@ (defun w3-open-local (fname) "Find a local file, and interpret it as a hypertext document. It will prompt for an existing file or directory, and retrieve it as a -hypertext document. If it is a directory, and url-use-hypertext-dired -is non-nil, then an HTML directory listing is created on the fly. -Otherwise, dired-mode is used to visit the buffer." +hypertext document." (interactive "FLocal file: ") (setq fname (expand-file-name fname)) (if (not w3-setup-done) (w3-do-setup)) @@ -396,9 +340,7 @@ (defun w3-find-file (fname) "Find a local file, and interpret it as a hypertext document. It will prompt for an existing file or directory, and retrieve it as a -hypertext document. If it is a directory, and url-use-hypertext-dired -is non-nil, then an HTML directory listing is created on the fly. -Otherwise, dired-mode is used to visit the buffer." +hypertext document." (interactive "FLocal file: ") (w3-open-local fname)) @@ -765,18 +707,6 @@ string (concat (substring string 0 w3-max-menu-width) "$"))) -(defun w3-use-starting-documents () - "Use the list of predefined starting documents from w3-starting-documents" - (interactive) - (let ((w3-hotlist w3-starting-documents)) - (w3-use-hotlist))) - -(defun w3-show-starting-documents () - "Show the list of predefined starting documents from w3-starting-documents" - (interactive) - (if (not w3-setup-done) (w3-do-setup)) - (w3-fetch "www://auto/starting-points")) - (defun w3-insert-formatted-url (p) "Insert a formatted url into a buffer. With prefix arg, insert the url under point." @@ -786,13 +716,13 @@ (p (setq p (widget-at (point))) (or p (error "No url under point")) - (setq str (format "%s" (widget-get p 'href) + (setq str (format "%s" (widget-get p 'href) (read-string "Link text: " (buffer-substring (widget-get p :from) (widget-get p :to)))))) (t - (setq str (format "%s" (url-view-url t) + (setq str (format "%s" (url-view-url t) (read-string "Link text: " (buffer-name)))))) (setq buff (read-buffer "Insert into buffer: " nil t)) (if buff @@ -819,8 +749,14 @@ (defun w3-widget-button-click (e) (interactive "@e") - (if (widget-at (event-point e)) - (widget-button-click e))) + (cond + ((and (event-point e) + (widget-at (event-point e))) + (widget-button-click e)) + ((and (fboundp 'event-glyph) + (event-glyph e) + (glyph-property (event-glyph e) 'widget)) + (widget-button-click e)))) (defun w3-breakup-menu (menu-desc max-len) (if (> (length menu-desc) max-len) @@ -887,8 +823,6 @@ (x 0) (args command-line-args-left) (w3-strict-width 80) - (w3-delimit-emphasis nil) - (w3-delimit-links nil) (retrieval-function 'w3-fetch) (file-format "text") (header "") @@ -1095,19 +1029,12 @@ (setq content-type "application/x-latex; charset=iso-8859-1") (w3-parse-tree-to-latex w3-current-parse url))) (buffer-string)))) - (cond - ((and w3-mutable-windows (fboundp w3-mail-other-window-command)) - (funcall w3-mail-other-window-command)) - ((fboundp w3-mail-command) - (funcall w3-mail-command)) - (w3-mutable-windows (mail-other-window)) - (t (mail))) + (funcall w3-mail-command) (mail-subject) (insert format " from URL " url "\n" "Mime-Version: 1.0\n" "Content-transfer-encoding: 8bit\n" "Content-type: " content-type) - (re-search-forward mail-header-separator nil) (forward-char 1) (insert (if (equal "HTML Source" format) @@ -1176,7 +1103,7 @@ (mm-extension-to-mime extn)) nil 5))) (if url-current-mime-viewer (setq cont (append cont '(w3-pass-to-viewer))) - (setq cont (append cont (list w3-default-action)))) + (setq cont (append cont (list 'w3-prepare-buffer)))) cont))) (defun w3-use-links () @@ -1193,17 +1120,11 @@ (cond ((and (or (null url-current-type) (equal url-current-type "file")) (eq major-mode 'w3-mode)) - (if w3-mutable-windows - (find-file-other-window url-current-file) - (find-file url-current-file))) + (find-file url-current-file)) ((equal url-current-type "ftp") - (if w3-mutable-windows - (find-file-other-window - (format "/%s@%s:%s" url-current-user url-current-server - url-current-file)) - (find-file - (format "/%s@%s:%s" url-current-user url-current-server - url-current-file)))) + (find-file + (format "/%s@%s:%s" url-current-user url-current-server + url-current-file))) (t (message "Sorry, I can't get that file so you can alter it.")))) (defun w3-insert-this-url (pref-arg) @@ -1487,27 +1408,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Functions to handle formatting an html buffer ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun w3-insert-headers () - ;; Insert some HTTP/1.0 headers if necessary - (url-lazy-message "Inserting HTTP/1.0 headers...") - (let ((hdrs (if (eq t w3-show-headers) (mapcar 'car url-current-mime-headers) - w3-show-headers)) - x y) - (goto-char (setq y (point-max))) - (while hdrs - (if (setq x (w3-in-assoc (car hdrs) url-current-mime-headers)) - (insert "
    • " (car x) ": " (url-insert-entities-in-string - (if (numberp (cdr x)) - (int-to-string (cdr x)) - (cdr x))))) - (setq hdrs (cdr hdrs))) - (if (= y (point-max)) - nil - (insert "
    ") - (goto-char y) - (url-lazy-message "Inserting HTTP/1.0 headers... done.") - (insert "
      ")))) - (defun w3-add-delayed-graphic (widget) ;; Add a delayed image for the current buffer. (setq w3-delayed-images (cons widget w3-delayed-images))) @@ -1723,18 +1623,6 @@ (car (car tmp))) "\n") (setq tmp (cdr tmp))) (insert "\n\t\t\t\n\t\t\n\t\n\n"))) - ((equal type "starting-points") - (let ((tmp w3-starting-documents)) - (insert "\n\t\n\t\t" - " Starting Points \n\t\n" - "\t\n\t\t
      \n\t\t\t

      Starting Point on the Web" - "

      \n\t\t\t
        \n") - (while tmp - (insert (format "\t\t\t\t
      1. %s
        2. \n" - (car (cdr (car tmp))) - (car (car tmp)))) - (setq tmp (cdr tmp))) - (insert "\n\t\t\t
      \n\t\t
      \n\t\n\n"))) ((equal type "history") (if (not url-history-list) (url-retrieve "www://error/nohist") @@ -2227,49 +2115,21 @@ url-package-name "Emacs-W3") (w3-emit-image-warnings-if-necessary) - (if (eq w3-color-use-reducing 'guess) - (setq w3-color-use-reducing - (cond - ((eq (device-type) 'tty) nil) - ((fboundp 'device-class) - (not (and (memq (device-class) '(TrueColor true-color)) - (<= 16 (or (device-bitplanes) 0))))) - (t t)))) (cond ((memq system-type '(ms-dos ms-windows)) - (setq w3-documents-menu-file (or w3-documents-menu-file - (expand-file-name "~/mosaic.mnu")) - w3-hotlist-file (or w3-hotlist-file + (setq w3-hotlist-file (or w3-hotlist-file (expand-file-name "~/mosaic.hot")) )) ((memq system-type '(axp-vms vax-vms)) - (setq w3-documents-menu-file - (or w3-documents-menu-file - (expand-file-name "decw$system_defaults:documents.menu")) - w3-hotlist-file (or w3-hotlist-file + (setq w3-hotlist-file (or w3-hotlist-file (expand-file-name "~/mosaic.hotlist-default")) )) (t - (setq w3-documents-menu-file - (or w3-documents-menu-file - (expand-file-name "/usr/local/lib/mosaic/documents.menu")) - w3-hotlist-file (or w3-hotlist-file + (setq w3-hotlist-file (or w3-hotlist-file (expand-file-name "~/.mosaic-hotlist-default")) ))) - (if (eq w3-delimit-emphasis 'guess) - (setq w3-delimit-emphasis - (and (not w3-running-xemacs) - (not (and w3-running-FSF19 - (memq (device-type) '(x ns pm))))))) - - (if (eq w3-delimit-links 'guess) - (setq w3-delimit-links - (and (not w3-running-xemacs) - (not (and w3-running-FSF19 - (memq (device-type) '(x ns pm))))))) - ; Set up a hook that will save the history list when ; exiting emacs (add-hook 'kill-emacs-hook 'w3-kill-emacs-func) @@ -2287,9 +2147,6 @@ (or (getenv "WWW_HOME") "http://www.cs.indiana.edu/elisp/w3/docs.html"))) - ; Set up the documents menu - (w3-parse-docs-menu) - ; Set up the entity definition for PGP and PEM authentication (run-hooks 'w3-load-hook) diff -r b88636d63495 -r 8fc7fe29b841 lisp/x11/x-toolbar.el --- a/lisp/x11/x-toolbar.el Mon Aug 13 08:50:06 2007 +0200 +++ b/lisp/x11/x-toolbar.el Mon Aug 13 08:50:29 2007 +0200 @@ -24,52 +24,85 @@ ;; order to get different behaviour. ;; +(defvar toolbar-open-function 'find-file + "*Function to call when the open icon is selected.") + (defun toolbar-open () (interactive) - (call-interactively 'find-file)) + (call-interactively toolbar-open-function)) + +(defvar toolbar-dired-function 'dired + "*Function to call when the dired icon is selected.") (defun toolbar-dired () (interactive) - (call-interactively 'dired)) + (call-interactively toolbar-dired-function)) + +(defvar toolbar-save-function 'save-buffer + "*Function to call when the save icon is selected.") (defun toolbar-save () (interactive) - (call-interactively 'save-buffer)) + (call-interactively toolbar-save-function)) + +(defvar toolbar-print-function 'lpr-buffer + "*Function to call when the print icon is selected.") (defun toolbar-print () (interactive) - (call-interactively 'lpr-buffer)) + (call-interactively toolbar-print-function)) + +(defvar toolbar-cut-function 'x-kill-primary-selection + "*Function to call when the cut icon is selected.") (defun toolbar-cut () (interactive) - (call-interactively 'x-kill-primary-selection)) + (call-interactively toolbar-cut-function)) + +(defvar toolbar-copy-function 'x-copy-primary-selection + "*Function to call when the copy icon is selected.") (defun toolbar-copy () (interactive) - (call-interactively 'x-copy-primary-selection)) + (call-interactively toolbar-copy-function)) + +(defvar toolbar-paste-function 'x-yank-clipboard-selection + "*Function to call when the paste icon is selected.") (defun toolbar-paste () (interactive) - (call-interactively 'x-yank-clipboard-selection)) + (call-interactively toolbar-paste-function)) + +(defvar toolbar-undo-function 'undo + "*Function to call when the undo icon is selected.") (defun toolbar-undo () (interactive) - (call-interactively 'undo)) + (call-interactively toolbar-undo-function)) + +(defvar toolbar-replace-function 'query-replace + "*Function to call when the replace icon is selected.") (defun toolbar-replace () (interactive) - (call-interactively 'query-replace)) + (call-interactively toolbar-replace-function)) ;; ;; toolbar ispell variables and defuns ;; +(defvar toolbar-ispell-function + (lambda () + (interactive) + (if (region-active-p) + (ispell-region (region-beginning) (region-end)) + (ispell-buffer))) + "*Function to call when the ispell icon is selected.") + (defun toolbar-ispell () "Intelligently spell the region or buffer." (interactive) - (if (region-active-p) - (ispell-region (region-beginning) (region-end)) - (ispell-buffer))) + (call-interactively toolbar-ispell-function)) ;; ;; toolbar mail variables and defuns @@ -94,7 +127,7 @@ used to start it.") (defvar toolbar-mail-reader 'vm - "Mail reader toolbar will invoke. + "*Mail reader toolbar will invoke. The legal values are `vm' and `gnus', but you can add your own values by customizing `toolbar-mail-commands-alist'.") @@ -162,6 +195,28 @@ ;; toolbar news variables and defuns ;; +(defvar toolbar-news-commands-alist + `((gnus . gnus) ; M-x all-hail-gnus + (rn . ,(toolbar-external "xterm" "-e" "rn")) + (nn . ,(toolbar-external "xterm" "-e" "nn")) + (trn . ,(toolbar-external "xterm" "-e" "trn")) + (xrn . ,(toolbar-external "xrn")) + (slrn . ,(toolbar-external "xterm" "-e" "slrn")) + (pine . ,(toolbar-external "xterm" "-e" "pine")) ; *gag* + (tin . ,(toolbar-external "xterm" "-e" "tin")) ; *gag* + (netscape . ,(toolbar-external "netscape" "news:"))) + "Alist of news readers and their commands. +Each list element is a pair. The car of the pair is the mail +reader, and the cdr is the form used to start it.") + +(defvar toolbar-news-reader 'gnus + "*News reader toolbar will invoke. +The legal values are gnus, rn, nn, trn, xrn, slrn, pine and netscape. +You can add your own values by customizing `toolbar-news-commands-alist'.") + +(defvar toolbar-news-use-separate-frame t + "*Whether Gnus is invoked in a separate frame.") + (defvar toolbar-news-frame nil "The frame in which news is displayed.") @@ -188,29 +243,6 @@ (select-frame toolbar-news-frame) (raise-frame toolbar-news-frame)) -;; -;; toolbar printing variable and defun -;; -(defvar toolbar-print-command 'lpr-buffer - "Command to run when the Print Icon is selected from the toolbar. -Set this to `ps-print-buffer-with-faces' if you primarily print with -a postscript printer.") - -(defun toolbar-print () - "Print current buffer." - (funcall toolbar-print-command)) - -;; -;; toolbar replacement variable and defun -;; -(defvar toolbar-replace-command 'query-replace - "Command to run when the Replace Icon is selected from the toolbar. -One possibility for a different value would be `query-replace-regexp'.") - -(defun toolbar-replace () - "Run a query-replace -type function on the current buffer." - (funcall toolbar-replace-command)) - (defvar toolbar-last-win-icon nil "A `last-win' icon set.") (defvar toolbar-next-win-icon nil "A `next-win' icon set.") (defvar toolbar-file-icon nil "A `file' icon set.") @@ -327,3 +359,5 @@ (x-init-specifier-from-resources right-toolbar-width 'natnum locale '("rightToolBarWidth" . "RightToolBarWidth"))) + +;;; x-toolbar.el ends here diff -r b88636d63495 -r 8fc7fe29b841 man/Makefile --- a/man/Makefile Mon Aug 13 08:50:06 2007 +0200 +++ b/man/Makefile Mon Aug 13 08:50:29 2007 +0200 @@ -32,7 +32,7 @@ makeinfo -o $@ $< # hyperbole and oo-browser manuals broken - do not TeX properly -srcs = ange-ftp cc-mode cl custom dired ediff external-widget forms gnus \ +srcs = cc-mode cl custom ediff external-widget forms gnus \ hyperbole ilisp info ispell mailcrypt message mh-e oo-browser \ pcl-cvs psgml psgml-api rmail standards supercite term \ termcap texinfo vhdl-mode viper vm w3 widget xemacs-faq diff -r b88636d63495 -r 8fc7fe29b841 man/custom.texi --- a/man/custom.texi Mon Aug 13 08:50:06 2007 +0200 +++ b/man/custom.texi Mon Aug 13 08:50:29 2007 +0200 @@ -13,7 +13,7 @@ @comment node-name, next, previous, up @top The Customization Library -Version: 1.30 +Version: 1.40 @menu * Introduction:: @@ -653,6 +653,12 @@ Command to check if there are any customization options that does not belong to an existing group. +@item +Optionally disable the point-cursor and instead highlight the selected +item in XEmacs. This is like the *Completions* buffer in XEmacs. +Suggested by Jens Lautenbacher +@samp{}.@refill + @end itemize @contents diff -r b88636d63495 -r 8fc7fe29b841 man/gnus.texi --- a/man/gnus.texi Mon Aug 13 08:50:06 2007 +0200 +++ b/man/gnus.texi Mon Aug 13 08:50:29 2007 +0200 @@ -2855,7 +2855,6 @@ @item H f @kindex H f (Group) -@itemx M-f @findex gnus-group-fetch-faq @vindex gnus-group-faq-directory @cindex FAQ @@ -6203,9 +6202,11 @@ @cindex PostScript @cindex printing @kindex A P (Summary) +@vindex gnus-ps-print-hook @findex gnus-summary-print-article Generate and print a PostScript image of the article buffer -(@code{gnus-summary-print-article}). +(@code{gnus-summary-print-article}). @code{gnus-ps-print-hook} will be +run just before printing the buffer. @end table @@ -7578,8 +7579,9 @@ Gnus provides a few different methods for storing the mail you send. The default method is to use the @dfn{archive virtual server} to store -the mail. If you want to disable this completely, you should set -@code{gnus-message-archive-group} to @code{nil}. +the mail. If you want to disable this completely, the +@code{gnus-message-archive-group} variable should be @code{nil}, which +is the default. @vindex gnus-message-archive-method @code{gnus-message-archive-method} says what virtual server Gnus is to @@ -8687,6 +8689,8 @@ @code{t} and be prompted for the password, or set @code{nnmail-pop-password} to the password itself. +@code{nnmail-spool-file} can also be a list of mailboxes. + Your Emacs has to have been configured with @samp{--with-pop} before compilation. This is the default, but some installations have it switched off. @@ -13790,9 +13794,10 @@ D. Hall, Magnus Hammerin, Raja R. Harinath, +Hisashige Kenji, @c Hisashige Marc Horowitz, +François Felix Ingrand, Ishikawa Ichiro, @c Ishikawa -Francois Felix Ingrand, Lee Iverson, Rajappa Iyer, Randell Jesup, diff -r b88636d63495 -r 8fc7fe29b841 man/lispref/extents.texi --- a/man/lispref/extents.texi Mon Aug 13 08:50:06 2007 +0200 +++ b/man/lispref/extents.texi Mon Aug 13 08:50:29 2007 +0200 @@ -84,12 +84,12 @@ property controls whether the extent is highlighted when the mouse moves over it. @xref{Extents and Events}. - An extent can optionally have a @dfn{start-glyph} or @dfn{end-glyph} -(but not both at one time) associated with it. A start-glyph or + An extent can optionally have a @dfn{begin-glyph} or @dfn{end-glyph} +(but not both at one time) associated with it. A begin-glyph or end-glyph is a pixmap or string that will be displayed either at the start or end of an extent or in the margin of the line that the start or end of the extent lies in, depending on the extent's layout policy. -Start-glyphs and end-glyphs are used to implement annotations, and you +Begin-glyphs and end-glyphs are used to implement annotations, and you should use the annotation API functions in preference to the lower-level extent functions. For more information, @xref{Annotations}. diff -r b88636d63495 -r 8fc7fe29b841 man/w3.texi --- a/man/w3.texi Mon Aug 13 08:50:06 2007 +0200 +++ b/man/w3.texi Mon Aug 13 08:50:29 2007 +0200 @@ -94,6 +94,7 @@ * Compatibility:: Explanation of compatibility with other browsers. * Stylesheets:: How to control the look of web pages +* Supported URLs:: What @sc{URL} schemes are supported. * MIME Support:: Support for @sc{mime} * Security:: Various security methods supported * Non-Unix Operating Systems:: Special considerations necessary to get @@ -106,13 +107,16 @@ * Future Directions:: Plans for future revisions Appendices: -* Reporting Bugs:: How to report a bug in Emacs-W3 -* Installing SSL:: Turning on @sc{ssl} support -* Mailcap Files:: An explanation of Mailcap files +* Reporting Bugs:: How to report a bug in Emacs-W3. +* Dealing with Firewalls:: How to get around your firewall. +* Proxy Gateways:: Using a proxy gateway with Emacs-W3. +* Installing SSL:: Turning on @sc{ssl} support. +* Mailcap Files:: An explanation of Mailcap files. +* Down with DoubleClick:: Annoyed by advertisements? Read this! Indices: -* General Index:: General Index -* Key Index:: Menus of command keys and their references +* General Index:: General Index. +* Key Index:: Menus of command keys and their references. @end menu @end ifinfo @@ -132,219 +136,25 @@ to do some customization. @menu -* Using the Network:: Tell Emacs about your network setup. -* Proxy Gateways:: Using an @sc{http} proxy +* Downloading:: Where to download Emacs-W3. +* Building and Installing:: Compiling and installing from source. * Startup Files:: What is where, and why. * Preferences Panel:: Quick configuration of common options. @end menu -@node Using the Network, Proxy Gateways, Getting Started, Getting Started -@section Using the Network -By default, Emacs can support standard @sc{tcp}/@sc{ip} network -connections on almost all the platforms it runs on (Unix, @sc{vms}, -Windows, etc). However, there are several situations where it is not -sufficient. - -@table @b -@cindex Firewalls -@item Firewalls -It is becoming more and more common to be behind a firewall or some -other system that restricts your outbound network activity, especially -if you are like me and away from the wonderful world of academia. -Emacs-W3 has several different methods to get around firewalls (not to -worry though - none of them should get you in trouble with the local -@sc{mis} department.) - -@item Emacs cannot resolve hostnames. -@cindex Faulty hostname resolvers -@cindex Broken SunOS libc -@cindex Hostname resolution -This happens quite often on SunOS workstations and some ULTRIX machines. -Some C libraries do not include the hostname resolver routines in their -static libraries. If Emacs was linked statically, and was not linked -with the resolver libraries, it wil not be able to get to any machines -off the local network. This is characterized by being able to reach -someplace with a raw ip number, but not its hostname -(@url{http://129.79.254.191/} works, but -@url{http://www.cs.indiana.edu/} doesn't). - -The best solution for this problem is to recompile Emacs, making sure to -either link dynamically (if available on your operating system), or -include the @file{-lresolv}. - -@cindex url-gateway-broken-resolution -If you do not have the disk space or the appropriate permissions to -recompile Emacs, another alternative is using the @file{nslookup} -program to do hostname resolution. To turn this on, set the variable -@code{url-gateway-broken-resolution} in your @file{~/.emacs} file. This -runs the program specified by @code{url-gateway-nslookup-program} (by -default "@code{nslookup}" to do hostname resolution. This program should -expect a single argument on the command line - the hostname to resolve, -and should produce output similar to the standard Unix @file{nslookup} -program: - -@example -Name: www.cs.indiana.ed -Address: 129.79.254.191 -@end example - -@cindex @sc{term} -@item Using @sc{term} (or @sc{term}-like) Networking Software -@sc{term} @footnote{@sc{term} is a user-level protocol for emulating -@sc{ip} over a serial line. More information is available at -@url{ftp://sunsite.unc.edu/pub/Linux/apps/comm/term}} for slip-like -access to the internet. - -@sc{note}: XEmacs and Emacs 19.22 or later have patches to enable native -@sc{term} networking. To enable it, @code{#define TERM} in the -appropriate s/*.h file for the operating system, then change the -@code{SYSTEM_LIBS} definition to include the @file{termnet} library that -comes with the latest versions of @sc{term}. - -If you run into any problems with the native @sc{term} networking -support in Emacs or XEmacs, please let @t{wmperry@@cs.indiana.edu} know, -as he is responsible for the original support. -@end table - -@vindex url-gateway-local-host-regexp -Emacs-W3 has support for using the gateway mechanism for certain -domains, and directly connecting to others. The variable -@code{url-gateway-local-host-regexp} controls this behaviour. This is a -regular expression @footnote{Please see the full Emacs distribution for -a description of regular expressions} that matches local hosts that do -not require the use of a gateway. If @code{nil}, then all connections -are made through the gateway. - -@vindex url-gateway-method -Emacs-W3 supports several methods of getting around gateways. The -variable @code{url-gateway-method} controls which of these methods is -used. This variable can have several values (use these as symbol names, -not strings), ie: @samp{(setq url-gateway-method 'telnet)}. Possible -values are: - -@table @dfn -@item telnet -Use this method if you must first telnet and log into a gateway host, -and then run telnet from that host to connect to outside machines. - -:: WORK :: document telnet gw variables -This section needs more information, specifically documenting the -following variables. For now, please do @key{C-h v} on the variable for -more information. - -@table @code -@item url-gateway-telnet-host -@item url-gateway-telnet-parameters -@item url-gateway-telnet-password-prompt -@item url-gateway-telnet-puser-name -@item url-gateway-prompt-pattern -@end table +@node Downloading, Building and Installing, Getting Started, Getting Started +@section Downloading +:: WORK :: What you need, and why +:: WORK :: Where to download Emacs, XEmacs, various platforms +:: WORK :: Where to download Emacs-W3 +:: WORK :: Where to download related utilities (netpbm, xv, gimp, etc.) -@item rlogin -This method is identical to the @code{telnet} method, but uses -@file{rlogin} to log into the remote machine without having to send the -username and password over the wire every time. - -:: WORK :: document rlogin gw variables -This section needs more information, specifically documenting the -following variables. For now, please do @key{C-h v} on the variable for -more information. - -@table @code -@item url-gateway-rlogin-host -@item url-gateway-rlogin-parameters -@item url-gateway-rlogin-user-name -@item url-gateway-prompt-pattern -@end table - -@item tcp -Masanobu UMEDA (@i{umerin@@mse.kyutech.ac.jp}) has written a very small -application that you can run in a subprocess to do the network -connections. - -@item @sc{socks} -Use if the firewall has a @sc{socks} gateway running on it. - -:: WORK :: document socks variables -This section needs more information, specifically documenting the -following variables. For now, please do @key{C-h v} on the variable for -more information. - -@table @code -@item socks-host -@item socks-password -@item socks-username -@item socks-port -@item socks-timeout -@end table - -@c @item ssl -@c This probably shouldn't be documented - -@item native -This means that Emacs-W3 should use the builtin networking code of -Emacs. This should be used only if there is no firewall, or the Emacs -source has already been hacked to get around the firewall. -@end table +@node Building and Installing, Startup Files, Downloading, Getting Started +@section Building and Installing +:: WORK :: Document makefile variables +:: WORK :: Document what gets installed where, why -Emacs-W3 should now be able to get outside the local network. If none -of this makes sense, its probably my fault. Please check with the -network administrators to see if they have a program that does most of -this already, since somebody somewhere at the company has probably been -through something similar to this before, and would be much more -helpful/knowledgeable about the local setup than I would be. But feel -free to mail me as a last resort. -@node Proxy Gateways, Startup Files , Using the Network, Getting Started -@section Proxy Gateways -@vindex url-proxy-services -@cindex Proxy Servers -@cindex Proxies -@cindex Proxies, environment variables -@cindex HTTP Proxy - -In late January 1993, Kevin Altis and Lou Montulli proposed and -implemented a new proxy service. This service requires the use of -environment variables to specify a gateway server/port # to send -protocol requests to. Each protocol (@sc{http}, @sc{wais}, gopher, -@sc{ftp}, etc.) can have a different gateway server. The environment -variables are @code{PROTOCOL}_proxy, where @code{PROTOCOL} is one of the -supported network protocols (gopher, file, @sc{http}, @sc{ftp}, etc.) - -@cindex No Proxy -@cindex Proxies, exclusion lists -@vindex NO_PROXY -For companies with internal intranets, it will usually be helpful to -define a list of hosts that should be contacted directly, @b{not} sent -through the proxy. The @code{NO_PROXY} environment variable controls -what hosts are able to be contacted directly. This should be a comma -separated list of hostnames, domain names, or a mixture of both. -Asterisks can be used as a wildcard. For example: - -@example -NO_PROXY=*.aventail.com,home.com,*.seanet.com -@end example - -tells Emacs-W3 to contact all machines in the @b{aventail.com} and -@b{seanet.com} domains directly, as well as the machine named -@b{home.com}. - -@vindex url-proxy-services -@cindex Proxies, setting from lisp -For those adventurous souls who enjoy writing regular expressions, all -the proxy settings can be manipulated from Emacs-Lisp. The variable -@code{url-proxy-services} controls this. This is an assoc list, keyed -on the protocol type (@sc{http}, gopher, etc) in all lowercase. The -@code{cdr} of each entry should be the fully-specified @sc{url} of the proxy -server to contact, or, in the case of the special "no_proxy" entry, a -regular expression that matches any hostnames that should be contacted -directly. - -@example -(setq url-proxy-services '(("http" . "http://proxy.aventail.com/") - ("no_proxy" . "^.*\\(aventail\\|seanet\\)\.com"))) -@end example - -@node Startup Files, Preferences Panel, Proxy Gateways, Getting Started +@node Startup Files, Preferences Panel, Building and Installing, Getting Started @section Startup Files @cindex Startup files @cindex Default stylesheet @@ -355,9 +165,9 @@ @node Preferences Panel, , Startup Files, Getting Started @section Preferences Panel @cindex Preferences -@kindex M-x w3-edit-preferences +@kindex M-x w3-preferences-edit :: WORK :: pref panel -This should document the quick preferences panel. M-x w3-edit-preferences +This should document the quick preferences panel. M-x w3-preferences-edit @node Basic Usage, Movement , Getting Started, Top @chapter Basic Usage @@ -650,7 +460,7 @@ effect if at the end of the session history. @end table -@node Miscellaneous, , Action, Basic Usage +@node Miscellaneous, Compatibility, Action, Basic Usage @section Miscellaneous @table @kbd @kindex M-m @@ -753,7 +563,7 @@ relationship. @end table -@node Compatibility, , , Top +@node Compatibility, Emulation, Miscellaneous, Top @chapter Compatibility with other Browsers Due to the popularity of several other browsers, Emacs-W3 offers an easy transition to its much better way of life. This ranges from being able @@ -1007,7 +817,7 @@ document. To go forward, use the function @code{w3-forward-in-history}, to go backward, use the function @code{w3-backward-in-history}. -@node Global History, , Session History, Compatibility +@node Global History, Stylesheets, Session History, Compatibility @section Global History :: WORK :: Document that the global history can have diff. formats Most web browsers also support the idea of a ``history'' of @sc{url}s the @@ -1038,286 +848,924 @@ are not in a hotlist, or for seeing all the pages from a particular web site before choosing which to retrieve. -@node Stylesheets, General Formatting, Top, Top +@node Stylesheets, Terminology, Global History, Top @chapter Stylesheets -@cindex Customizing formatting -@cindex Specifying Fonts -@cindex Fonts -@cindex Stylesheets -@cindex Colors -How Emacs-W3 formats a document is very customizable. All control over +The way in which Emacs-W3 formats a document is very customizable. All formatting is now controlled by a default stylesheet set by the user -with the @code{w3-default-stylesheet} variable. +with the @code{w3-default-stylesheet} variable. Emacs-W3 currently +supports the @sc{W3C} recommendation for Cascading Style Sheets, Level 1 +(commonly known as @sc{CSS1}) with a few experimental items from other +W3C proposals. Wherever Emacs-W3 diverges from the specification, it +will be clearly documented, and will be changed once a full standard is +available. -The following sections describe in more detail how to change the -formatting of a document. +Support for @sc{DSSSL} is progressing, but spare time is at an all-time +low. If anyone would like to help, please contact the author. + +The following sections closely parallel the @sc{CSS1} specification so +it should be very easy to look up what Emacs-W3 supports when browsing +through the @sc{CSS1} specification. Please note that a lot of the text +in the following sections comes directly from the specification as +well. @ifinfo @menu -* General Formatting:: Changing general things about a - document. -* Character based terminals:: Changing how a document is - displayed on a non-graphics - terminal (vt100, etc.@:) or if - @code{w3-delimit-emphasis} is @code{t}. -* Graphics workstations:: Changing how a document is - displayed on a graphics terminal - (Xwindows, Windows, NeXTstep, - OS/2, etc.) -* Inlined images:: How to specify how Emacs-W3 - handles inlined images/mpegs. +* Terminology:: Terms used in the rest of this chapter. +* Basic Concepts:: Why are stylesheets useful? Getting started. +* Pseudo-Classes/Elements:: Special classes for elements. +* The Cascade:: How stylesheets are combined. +* Properties:: What properties you can set on elements. +* Units:: What you can set them to. @end menu @end ifinfo -@node General Formatting, Character based terminals, Stylesheets, Stylesheets -@section General formatting conventions -@iftex -@heading Setting the fill column -@end iftex -@ifinfo -@center -------------------- -@center Setting the right margin -@center -------------------- -@end ifinfo -@cindex Margins -@vindex fill-column -@vindex w3-right-border -Each time a document is parsed, the right margin is recalculated -using the width of the current window and @code{w3-right-border}. -@code{w3-right-border} is an integer specifying how much room at the -right edge of the screen to leave blank. The @code{fill-column} is set -to @code{(- (window-width) @code{w3-right-border})}. -@iftex -@heading Formatting of directory listings -@end iftex -@ifinfo -@center -------------------- -@center Formatting of directory listings -@center -------------------- -@end ifinfo -@vindex url-use-hypertext-dired -When Emacs-W3 encounters a link to a directory (whether by local file access -or via @sc{ftp}), it can either create an @sc{html} document on the fly, or use -@code{dired-mode} to peruse the listing. The variable -@code{url-use-hypertext-dired} controls this behavior. + +@node Terminology, Basic Concepts, Stylesheets, Stylesheets +@section Terminology -If the value is @code{t}, Emacs-W3 uses @code{directory-files} to list them -out and transform the directory into a hypertext document, then pass it -through the parser like any other document. - -If the value is @code{nil}, just pass the directory off to dired using -@code{find-file}. Using this option loses all the hypertext abilities -of Emacs-W3, and the users is unable to load documents in the directory -directly into Emacs-W3 by clicking with the mouse, etc. +@table @dfn +@item attribute +HTML attribute, ie: @samp{align=center} - align is the attribute. +@item author +The author of an HTML document. +@item block-level element +An element which has a line break before and after (e.g. 'H1' in @sc{HTML}). +@item canvas +The part of the UA's drawing surface onto which documents are rendered. +@item child element +A subelement in @sc{sgml} terminology. +@item contextual selector +A selector that matches elements based on their position in the document +structure. A contextual selector consists of several simple +selectors. E.g., the contextual selector 'H1.initial B' consists of two +simple selectors, 'H1.initial' and 'B'. +@item @sc{css} +Cascading Style Sheets. +@item declaration +A property (e.g. 'font-size') and a corresponding value (e.g. '12pt'). +@item designer +The designer of a style sheet. +@item document +@sc{html} document. +@item element +@sc{html} element. +@item element type +A generic identifier in @sc{sgml} terminology. +@item fictional tag sequence +A tool for describing the behavior of pseudo-classes and pseudo-elements. +@item font size +The size for which a font is designed. Typically, the size of a font is +approximately equal to the distance from the bottom of the lowest letter +with a descender to the top of the tallest letter with an ascender and +(optionally) with a diacritical mark. +@item @sc{html} extension +Markup introduced by UA vendors, most often to support certain visual +effects. The @sc{font}, @sc{center} and @sc{blink} elements are examples +of HTML extensions, as is the @sc{bgcolor} attribute. One of the goals +of @sc{css} is to provide an alternative to @sc{html} extensions. +@item inline element +An element which does not have a line break before and after +(e.g. '@sc{strong}' in @sc{html}) +@item intrinsic dimensions +The width and height as defined by the element itself, not imposed by +the surroundings. In this specification it is assumed that all replaced +elements -- and only replaced elements -- come with intrinsic +dimensions. +@item parent element +The containing element in @sc{sgml} terminology. +@item pseudo-element +Pseudo-elements are used in @sc{css} selectors to address typographical +items (e.g. the first line of an element) rather than structural +elements. +@item pseudo-class +Pseudo-classes are used in @sc{css} selectors to allow information +external to the @sc{html} source (e.g. the fact that an anchor has been +visited or not) to classify elements. +@item property +A stylistic parameter that can be influenced through @sc{css}. +@item reader +The person for whom the document is rendered. +@item replaced element +An element that the @sc{css} formatter only knows the intrinsic +dimensions of. In @sc{html}, @sc{img}, @sc{input}, @sc{textarea}, +@sc{select} and @sc{object} elements can be examples of replaced +elements. E.g., the content of the @sc{img} element is often replaced by +the image that the @sc{src} attribute points to. @sc{css1} does not +define how the intrinsic dimensions are found. +@item rule +A declaration (e.g. 'font-family: helvetica') and its selector +(e.g. @sc{'H1'}). +@item selector +A string that identifies what elements the corresponding rule applies +to. A selector can either be a simple selector (e.g. 'H1') or a +contextual selector (e.g. @sc{'h1 b'}) which consists of several simple +selectors. +@item @sc{sgml} +Standard Generalized Markup Language, of which @sc{html} is an +application. +@item simple selector +A selector that matches elements based on the element type and/or +attributes, and not he element's position in the document +structure. E.g., 'H1.initial' is a simple selector. +@item style sheet +A collection of rules. +@item @sc{ua} +User Agent, often a web browser or web client. +@item user +Synonymous with reader. +@item weight +The priority of a rule. +@end table -@iftex -@heading Formatting of gopher directories -@end iftex -@ifinfo -@center -------------------- -@center Formatting of gopher directories -@center -------------------- -@end ifinfo -@vindex w3-use-hypertext-gopher -@cindex Gopher+ -@cindex ASK blocks -There are two different ways of viewing gopher links. The built-in -support that converts gopher directories into @sc{html}, or the -@file{gopher.el} package by Scott Snyder (@i{snyder@@fnald0.fnal.gov}). -The variable that controls this is @code{w3-use-hypertext-gopher}. If -set to @code{nil}, then @file{gopher.el} is used. Any other value -causes Emacs-W3 to use its internal gopher support. If using -@file{gopher.el}, all the hypertext capabilities of Emacs-W3 are lost. -All the functionality of @file{gopher.el} is now available in the -hypertext version, and the hypertext version supports Gopher+ and ASK -blocks. +@node Basic Concepts, Pseudo-Classes/Elements, Terminology, Stylesheets +@section Basic Concepts +Designing simple style sheets is easy. One needs only to know a little +HTML and some basic desktop publishing terminology. E.g., to set the +text color of 'H1' elements to blue, one can say: + +@example + H1 @{ color: blue @} +@end example + +The example above is a simple CSS rule. A rule consists of two main +parts: selector ('H1') and declaration ('color: blue'). The declaration +has two parts: property ('color') and value ('blue'). While the example +above tries to influence only one of the properties needed for rendering +an HTML document, it qualifies as a style sheet on its own. Combined +with other style sheets (one fundamental feature of CSS is that style +sheets are combined) it will determine the final presentation of the +document. + +The selector is the link between the HTML document and the style sheet, and +all HTML element types are possible selectors. + +@node Pseudo-Classes/Elements, The Cascade, Basic Concepts, Stylesheets +@section Pseudo-Classes/Elements +In @sc{css1}, style is normally attached to an element based on its +position in the document structure. This simple model is sufficient for +a wide variety of styles, but doesn't cover some common effects. The +concept of pseudo-classes and pseudo-elements extend addressing in +@sc{css1} to allow external information to influence the formatting +process. -@vindex w3-gopher-labels -The main way to control the display of gopher directories is by the -variable @code{w3-gopher-labels}. This variable controls the text that -is inserted at the front of each item. This is an assoc list of gopher -types (as one character strings), and a string to insert just after the -list item. All the normal gopher types are defined. Entries should be -similar to: @samp{("0" . "(TXT)")}. I have tried to keep all the tags -to three characters plus two parentheses. -@iftex -@heading Creating a horizontal rule -@end iftex -@ifinfo -@center -------------------- -@center Creating a horizontal rule -@center -------------------- -@end ifinfo -@vindex w3-horizontal-rule-char -Horizontal rules (@b{
      } tags in @sc{html}[+]) are used to separate chunks -of a document, and is meant to be rendered as a solid line across the -page. Some terminals display characters differently, so the variable -@code{w3-horizontal-rule-char} controls which character is used to draw -a horizontal bar. This variable must be the ASCII value of the -character, @b{not a string}. The variable is passed through -@code{make-string} whenever a horizontal rule of a certain width is -necessary. +Pseudo-classes and pseudo-elements can be used in @sc{css} selectors, +but do not exist in the @sc{html} source. Rather, they are "inserted" by +the @sc{ua} under certain conditions to be used for addressing in style +sheets. They are referred to as "classes" and "elements" since this is a +convenient way of describing their behavior. More specifically, their +behavior is defined by a fictional tag sequence. + +Pseudo-elements are used to address sub-parts of elements, while +pseudo-classes allow style sheets to differentiate between different +element types. + +The only support pseudo-classes in Emacs-W3 are on the anchor tag +(...). + +User agents commonly display newly visited anchors differently from +older ones. In @sc{css1}, this is handled through pseudo-classes on the +'A' element: + +@example + A:link @{ color: red @} /* unvisited link */ + A:visited @{ color: blue @} /* visited links */ + A:active @{ color: lime @} /* active links */ +@end example + +All 'A' elements with an 'HREF' attribute will be put into one and only +one of these groups (i.e. target anchors are not affected). UAs may +choose to move an element from 'visited' to 'link' after a certain +time. An 'active' link is one that is currently being selected (e.g. by +a mouse button press) by the reader. -@node Character based terminals, Graphics workstations, General Formatting, Stylesheets -@section On character based terminals -@vindex w3-delimit-emphasis -On character based terminals, there is no easy way to show that a -certain range of text is in bold or italics. If the variable -@code{w3-delimit-emphasis} is non-@code{nil}, then Emacs-W3 can insert -characters before and after character formatting commands in @sc{html} -documents. The defaul value of @code{w3-delimit-emphasis} is -automatically set based on the type of window system and version of -Emacs being used. +The formatting of an anchor pseudo-class is as if the class had been +inserted manually. A @sc{ua} is not required to reformat a currently +displayed document due to anchor pseudo-class transitions. E.g., a style +sheet can legally specify that the 'font-size' of an 'active' link +should be larger that a 'visited' link, but the UA is not required to +dynamically reformat the document when the reader selects the 'visited' +link. + +Pseudo-class selectors do not match normal classes, and vice versa. The +style rule in the example below will therefore not have any influence: + +@example + A:link @{ color: red @} + + ... +@end example -@vindex w3-header-chars-assoc -:: WORK :: +In @sc{css1}, anchor pseudo-classes have no effect on elements other +than 'A'. Therefore, the element type can be omitted from the selector: + +@example + A:link @{ color: red @} + :link @{ color: red @} +@end example + +The two selectors above will select the same elements in CSS1. + +Pseudo-class names are case-insensitive. + +Pseudo-classes can be used in contextual selectors: + +@example + A:link IMG @{ border: solid blue @} +@end example -@findex w3-upcase-region -@code{w3-header-chars-assoc} is an assoc list of header tags and a list -of formatting instructions. The @code{car} of the list is the level of -the header (1--6). The rest of the list should contain three items. -The first item is text to insert before the header. The second item is -text to insert after the header. Both should have reserved characters -converted to their @sc{html}[+] entity definitions. The third item is a -function to call on the area the header is in. This function is called -with arguments specifying the start and ending character positions of -the header. The starting point is always first. To convert a region to -upper case, please use @code{w3-upcase-region} instead of -@code{upcase-region}, so that entities are converted properly. +Also, pseudo-classes can be combined with normal classes: + +@example + A.external:visited @{ color: blue @} + + external link +@end example + +If the link in the above example has been visited, it will be rendered +in blue. Note that normal class names precede pseudo-classes in the +selector. -@node Graphics workstations, Inlined images, Character based terminals, Stylesheets -@section With graphics workstations -Starting with the first public release of version 2.3.0, all formatting -is controlled by the use of stylesheets. +@node The Cascade, Properties, Pseudo-Classes/Elements, Stylesheets +@section The Cascade + +In @sc{css}, more than one style sheet can influence the presentation +simultaneously. There are two main reasons for this feature: modularity +and author/reader balance. -:: WORK :: Graphic workstation stuff - redo for stylesheets +@table @i +@item modularity +A style sheet designer can combine several (partial) style sheets to +reduce redundancy: + +@example + @@import url(http://www.style.org/pastoral); + @@import url(http://www.style.org/marine); -@node Inlined images, , Graphics workstations, Stylesheets -@cindex Inlined images -@cindex Images -@cindex Movies -@cindex Inlined MPEGs -@cindex MPEGs -When running in Lucid Emacs 19.10 or XEmacs 19.11 and higher, Emacs-W3 can -display inlined images and MPEG movies. There are several variables that -control how and when the images are displayed. + H1 @{ color: red @} /* override imported sheets */ +@end example +@item author/reader balance +Both readers and authors can influence the presentation through style +sheets. To do so, they use the same style sheet language thus reflecting +a fundamental feature of the web: everyone can become a publisher. The +@sc{ua} is free to choose the mechanism for referencing personal style +sheets. +@end table + +Sometimes conflicts will arise between the style sheets that influence +the presentation. Conflict resolution is based on each style rule having +a weight. By default, the weights of the reader's rules are less than +the weights of rules in the author's documents. I.e., if there are +conflicts between the style sheets of an incoming document and the +reader's personal sheets, the author's rules will be used. Both reader +and author rules override the @sc{ua}'s default values. -@cindex Netpbm -@cindex Pbmplus -@vindex w3-graphic-converter-alist -Since Lucid/XEmacs only natively understands XPixmaps and XBitmaps, GIFs -and other image types must first be converted to one of these formats. -To do this, the @b{netpbm utilities}@footnote{Available via anonymous -ftp from ftp.x.org:/R5contrib/netpbm-1mar1994.tar.gz, and most large ftp -sites.} programs are normally used. This is a suite of freeware image -conversion tools. The variable @code{w3-graphic-converter-alist} -controls how each image type is converted. This is an assoc list, keyed -on the @sc{mime} content-type. The @code{car} is the content-type, and -the @code{cdr} is a string suitable to pass to @code{format}. A %s in -this string will be replaced with a converter from the ppm image format -to an XPixmap (or XBitmap, if being run on a monochrome display). By -default, the Emacs-W3 browser has converters for: +The imported style sheets also cascade with each other, in the order +they are imported, according to the cascading rules defined below. Any +rules specified in the style sheet itself override rules in imported +style sheets. That is, imported style sheets are lower in the cascading +order than rules in the style sheet itself. Imported style sheets can +themselves import and override other style sheets, recursively. + +In @sc{css1}, all '@@import' statements must occur at the start of a +style sheet, before any declarations. This makes it easy to see that +rules in the style sheet itself override rules in the imported style +sheets. + +NOTE: The use of !important in @sc{css} stylesheets is unsupported at +this time. + +Conflicting rules are intrinsic to the CSS mechanism. To find the value +for an element/property combination, the following algorithm must be +followed: @enumerate @item -image/x-xbitmap -@item -image/xbitmap -@item -image/xbm -@item -image/gif +Find all declarations that apply to the element/property in +question. Declarations apply if the selector matches the element in +question. If no declarations apply, the inherited value is used. If +there is no inherited value (this is the case for the 'HTML' element and +for properties that do not inherit), the initial value is used. +@item +Sort the declarations by explicit weight: declarations marked +'!important' carry more weight than unmarked (normal) declarations. @item -image/jpeg -@item -image/x-fax -@item -image/x-raster -@item -image/windowdump +Sort by origin: the author's style sheets override the reader's style +sheet which override the UA's default values. An imported style sheet +has the same origin as the style sheet from which it is imported. @item -image/x-icon -@item -image/portable-graymap -@item -image/portable-pixmap -@item -image/x-pixmap +Sort by specificity of selector: more specific selectors will override +more general ones. To find the specificity, count the number of ID +attributes in the selector (a), the number of CLASS attributes in the +selector (b), and the number of tag names in the selector +(c). Concatenating the three numbers (in a number system with a large +base) gives the specificity. Some examples: +@example + LI @{...@} /* a=0 b=0 c=1 -> specificity = 1 */ + UL LI @{...@} /* a=0 b=0 c=2 -> specificity = 2 */ + UL OL LI @{...@} /* a=0 b=0 c=3 -> specificity = 3 */ + LI.red @{...@} /* a=0 b=1 c=1 -> specificity = 11 */ + UL OL LI.red @{...@} /* a=0 b=1 c=3 -> specificity = 13 */ + #x34y @{...@} /* a=1 b=0 c=0 -> specificity = 100 */ +@end example +Pseudo-elements and pseudo-classes are counted as normal elements and +classes, respectively. @item -image/x-xpixmap -@item -image/pict -@item -image/x-macpaint -@item -image/x-targa -@item -image/tiff +Sort by order specified: if two rules have the same weight, the latter +specified wins. Rules in imported style sheets are considered to be +before any rules in the style sheet itself. @end enumerate -@vindex w3-color-max-blue -@vindex w3-color-max-green -@vindex w3-color-max-red -@vindex w3-color-use-reducing -@vindex w3-color-filter -Since most displays are (sadly) not 24-bit, Emacs-W3 can automatically -dither an image, so that it does not fill up the application' colormap too -quickly. If @code{w3-color-use-reducing} is non-@code{nil}, then the -images will use reduced colors. If @code{w3-color-filter} is @code{eq} to -@code{'ppmquant}, then the ppmquant program will be used. If @code{eq} to -@code{'ppmdither}, then the ppmdither program will be used. The ppmdither -program tends to give better results. The values of -@code{w3-color-max-red}, @code{w3-color-max-blue}, and -@code{w3-color-max-green} control how many colors the inlined images can -use. If using ppmquant, then the product of these three variables is used -as the maximum number of colors per image. If using ppmdither, then only -the set number of color cells can be allocated per image. See the man -pages for ppmdither and ppmquant for more information on how the dithering -is actually done. @code{w3-color-filter} may also be a string, specifying -exactly what external filter to use. An example is: @samp{ppmquant -fs --map ~/pixmaps/colormap.ppm}. +The search for the property value can be terminated whenever one rule +has a higher weight than the other rules that apply to the same +element/property combination. + +This strategy gives author's style sheets considerably higher weight +than those of the reader. It is therefore important that the reader has +the ability to turn off the influence of a certain style sheet, +e.g. through a pull-down menu. + +A declaration in the 'STYLE' attribute of an element has the same weight +as a declaration with an ID-based selector that is specified at the end +of the style sheet: + +@example + + +

      +@end example + +In the above example, the color of the 'P' element would be +red. Although the specificity is the same for both declarations, the +declaration in the 'STYLE' attribute will override the one in the +'STYLE' element because of cascading rule number 5. + +The UA may choose to honor other stylistic HTML attributes, for example +'ALIGN'. If so, these attributes are translated to the corresponding CSS +rules with specificity equal to 1. The rules are assumed to be at the +start of the author style sheet and may be overridden by subsequent +style sheet rules. In a transition phase, this policy will make it +easier for stylistic attributes to coexist with style sheets. + +@node Properties, Font Properties, The Cascade, Stylesheets +@section Properties +@ifinfo +@menu +* Font Properties:: Selecting fonts, styles, and sizes. +* Colors and Backgrounds:: Controlling colors, front and back. +* Text Properties:: Alignment, decoration, and more! +* Box Properties:: Borders, padding, and margins, oh my! +* Classification:: Changing whitespace and display policies. +* Media Selection:: +* Speech Properties:: +@end menu +@end ifinfo + +@node Font Properties, font-family, Properties, Properties +@subsection Font Properties +Setting font properties will be among the most common uses of style +sheets. Unfortunately, there exists no well-defined and universally +accepted taxonomy for classifying fonts, and terms that apply to one +font family may not be appropriate for others. E.g. 'italic' is commonly +used to label slanted text, but slanted text may also be labeled as +being @b{Oblique}, @b{Slanted}, @b{Incline}, @b{Cursive} or +@b{Kursiv}. Therefore it is not a simple problem to map typical font +selection properties to a specific font. + +The properties defined by CSS1 are described in the following sections. +@ifinfo +@menu +* font-family:: Groups of fonts. +* font-style:: Normal, italic, or oblique? +* font-variant:: Small-caps, etc. +* font-weight:: How bold can you go? +* font-size:: How big is yours? +* font:: Shorthand for all of the above. +@end menu +@end ifinfo + +@node font-family, font-style, Font Properties, Font Properties +@subsubsection font-family + +@multitable @columnfractions .20 .8 +@item Supported Values: @tab [[ | ],]* [ | ] +@item Initial: @tab User specific +@item Applies to: @tab all elements +@item Inherited: @tab yes +@item Percentage values: @tab N/A +@end multitable +The value is a prioritized list of font family names and/or generic +family names. Unlike most other CSS1 properties, values are separated +by a comma to indicate that they are alternatives: + +@example + BODY @{ font-family: gill, helvetica, sans-serif @} +@end example + +There are two types of list values: + +@table @b +@item +The name of a font family of choice. In the last example, "gill" and +"helvetica" are font families. +@item +In the example above, the last value is a generic family name. The +following generic families are defined: +@itemize @bullet +@item +'serif' (e.g. Times) +@item +'sans-serif' (e.g. Helvetica) +@item +'cursive' (e.g. Zapf-Chancery) +@item +'fantasy' (e.g. Western) +@item +'monospace' (e.g. Courier) +@end itemize +@end table -@cindex MPEGs -@cindex Inlined animations -When running in XEmacs 19.11 or XEmacs 19.12, Emacs-W3 can insert an -MPEG movie in the middle of a buffer. +Style sheet designers are encouraged to offer a generic font family as a +last alternative. + +Font names containing whitespace should be quoted: + +@example + BODY @{ font-family: "new century schoolbook", serif @} + + +@end example + +If quoting is omitted, any whitespace characters before and after the +font name are ignored and any sequence of whitespace characters inside +the font name is converted to a single space. + +@node font-style, font-variant, font-family, Font Properties +@subsubsection font-style + +@multitable @columnfractions .2 .8 +@item Supported Values: @tab normal | italic | oblique +@item Initial: @tab normal +@item Applies to: @tab all elements +@item Inherited: @tab yes +@item Percentage values: @tab N/A +@end multitable + +The 'font-style' property selects between normal (sometimes referred to +as "roman" or "upright"), italic and oblique faces within a font family. + +A value of 'normal' selects a font that is classified as 'normal' in the +UA's font database, while 'oblique' selects a font that is labeled +'oblique'. A value of 'italic' selects a font that is labeled 'italic', +or, if that is not available, one labeled 'oblique'. + +The font that is labeled 'oblique' in the UA's font database may +actually have been generated by electronically slanting a normal font. + +Fonts with Oblique, Slanted or Incline in their names will typically be +labeled 'oblique' in the UA's font database. Fonts with Italic, Cursive +or Kursiv in their names will typically be labeled 'italic'. + +@example + H1, H2, H3 @{ font-style: italic @} + H1 EM @{ font-style: normal @} +@end example + +In the example above, emphasized text within 'H1' will appear in a +normal face. + +@node font-variant, font-weight, font-style, Font Properties +@subsubsection font-variant -:: WORK :: Need a pointer to the new EMBED Internet Draft :: +@multitable @columnfractions .2 .8 +@item Value: @tab normal | small-caps +@item Initial: @tab normal +@item Applies to: @tab all elements +@item Inherited: @tab yes +@item Percentage values: @tab N/A +@end multitable + +Another type of variation within a font family is the small-caps. In a +small-caps font the lower case letters look similar to the uppercase +ones, but in a smaller size and with slightly different proportions. The +'font-variant' property selects that font. + +A value of 'normal' selects a font that is not a small-caps font, +'small-caps' selects a small-caps font. It is acceptable (but not +required) in CSS1 if the small-caps font is a created by taking a normal +font and replacing the lower case letters by scaled uppercase +characters. As a last resort, uppercase letters will be used as +replacement for a small-caps font. + +The following example results in an 'H3' element in small-caps, with +emphasized words in oblique small-caps: + +@example + H3 @{ font-variant: small-caps @} + EM @{ font-style: oblique @} +@end example -The basic syntax is: +There may be other variants in the font family as well, such as fonts +with old-style numerals, small-caps numerals, condensed or expanded +letters, etc. CSS1 has no properties that select those. + +@node font-weight, font-size, font-variant, Font Properties +@subsubsection font-weight + +@multitable @columnfractions .2 .8 +@item Supported Values: @tab normal | bold | 100 | 200 | 300 | 400 | 500 | 600 | 700 | 800 | 900 +@item Unsupported Values: @tab bolder | lighter +@item Initial: @tab normal +@item Applies to: @tab all elements +@item Inherited: @tab yes +@item Percentage values: @tab N/A +@end multitable + +The 'font-weight' property selects the weight of the font. The values +'100' to '900' form an ordered sequence, where each number indicates a +weight that is at least as dark as its predecessor. The keyword 'normal' +is synonymous with '400', and 'bold' is synonymous with '700'. Keywords +other than 'normal' and 'bold' have been shown to be often confused with +font names and a numerical scale was therefore chosen for the 9-value +list. + @example - + P @{ font-weight: normal @} /* 400 */ + H1 @{ font-weight: 700 @} /* bold */ +@end example + +The 'bolder' and 'lighter' values select font weights that are relative +to the weight inherited from the parent: + +@example + STRONG @{ font-weight: bolder @} @end example -@vindex w3-mpeg-args -@vindex w3-mpeg-program -This requires a special version of the standard @file{mpeg_play} mpeg -player. Patches against the 2.0 version are available at -ftp://ftp.cs.indiana.edu/pub/elisp/w3/mpeg_patch. The variable -@code{w3-mpeg-program} should point to this executable, and -@code{w3-mpeg-args} should be a list of any additional arguments to be -passed to the player. By default, this includes @var{-loop}, so the -mpeg plays continuously. +There is no guarantee that there will be a darker face for each of the +'font-weight' values; for example, some fonts may have only a normal and +a bold face, others may have eight different face weights. There is no +guarantee on how a UA will map font faces within a family to weight +values. The only guarantee is that a face of a given value will be no +less dark than the faces of lighter values. + +@node font-size, font, font-weight, Font Properties +@subsubsection font-size + +@multitable @columnfractions .2 .8 +@item Supported Values: @tab | +@item Unsupported Values: @tab | +@item Initial: @tab medium +@item Applies to: @tab all elements +@item Inherited: @tab yes +@item Percentage values: @tab relative to parent element's font size +@end multitable + +@table @b +@item +An keyword is an index to a table of font sizes computed +and kept by the UA. Possible values are: +@itemize @bullet +@item +xx-small +@item +x-small +@item +small +@item +medium +@item +large +@item +x-large +@item +xx-large +@end itemize + +On a computer screen a scaling factor of 1.5 is suggested between +adjacent indexes; if the 'medium' font is 10pt, the 'large' font could +be 15pt. Different media may need different scaling factors. Also, the +UA should take the quality and availability of fonts into account when +computing the table. The table may be different from one font family to +another. +@item +A keyword is interpreted relative to the table of font +sizes and the font size of the parent element. Possible values are +@b{larger} or @b{smaller}. For example, if the parent element has a font +size of 'medium', a value of 'larger' will make the font size of the +current element be 'large'. If the parent element's size is not close to +a table entry, the UA is free to interpolate between table entries or +round off to the closest one. The UA may have to extrapolate table +values if the numerical value goes beyond the keywords. +@end table + +Length and percentage values should not take the font size table into +account when calculating the font size of the element. + +Negative values are not allowed. + +On all other properties, 'em' and 'ex' length values refer to the font +size of the current element. On the 'font-size' property, these length +units refer to the font size of the parent element. + +Note that an application may reinterpret an explicit size, depending on +the context. E.g., inside a VR scene a font may get a different size +because of perspective distortion. + +Examples: + +@example + P @{ font-size: 12pt; @} + BLOCKQUOTE @{ font-size: larger @} + EM @{ font-size: 150% @} + EM @{ font-size: 1.5em @} +@end example + +If the suggested scaling factor of 1.5 is used, the last three +declarations are identical. + +@node font, Colors and Backgrounds, font-size, Font Properties +@subsubsection font + +@multitable @columnfractions .2 .8 +@item Value: @tab [ || || ]? [ / ]? +@item Initial: @tab not defined for shorthand properties +@item Applies to: @tab all elements +@item Inherited: @tab yes +@item Percentage values: @tab allowed on and +@end multitable +The 'font' property is a shorthand property for setting 'font-style' +'font-variant' 'font-weight' 'font-size', 'line-height' and +'font-family' at the same place in the style sheet. The syntax of this +property is based on a traditional typographical shorthand notation to +set multiple properties related to fonts. + +For a definition of allowed and initial values, see the previously +defined properties. Properties for which no values are given are set to +their initial value. + +@example + P @{ font: 12pt/14pt sans-serif @} + P @{ font: 80% sans-serif @} + P @{ font: x-large/110% "new century schoolbook", serif @} + P @{ font: bold italic large Palatino, serif @} + P @{ font: normal small-caps 120%/120% fantasy @} +@end example + +In the second rule, the font size percentage value ('80%') refers to the +font size of the parent element. In the third rule, the line height +percentage refers to the font size of the element itself. + +In the first three rules above, the 'font-style', 'font-variant' and +'font-weight' are not explicitly mentioned, which means they are all +three set to their initial value ('normal'). The fourth rule sets the +'font-weight' to 'bold', the 'font-style' to 'italic' and implicitly +sets 'font-variant' to 'normal'. + +The fifth rule sets the 'font-variant' ('small-caps'), the 'font-size' +(120% of the parent's font), the 'line-height' (120% times the font +size) and the 'font-family' ('fantasy'). It follows that the keyword +'normal' applies to the two remaining properties: 'font-style' and +'font-weight'. + +@node Colors and Backgrounds, color, font, Properties +@subsection Colors and Backgrounds +These properties describe the color (often called foreground color) and +background of an element (i.e. the surface onto which the content is +rendered). One can set a background color and/or a background image. The +position of the image, if/how it is repeated, and whether it is fixed or +scrolled relative to the canvas can also be set. + +The 'color' property inherits normally. The background properties do not +inherit, but the parent element's background will shine through by +default because of the initial 'transparent' value on +'background-color'. + +NOTE: Currently, Emacs-W3 can only show background images under XEmacs. +Emacs 19 doesn't have the support in its display code yet. + +@ifinfo +@menu +* color:: Foreground colors. +* background-color:: Background colors. +* background-image:: Background images. +* background-repeat:: Controlling repeating of background images. +* background-attachment:: Where background images are drawn. +* background-position:: Where background images are drawn. +* background:: Shorthand for all background properties. +@end menu +@end ifinfo + +@node color, background-color, Colors and Backgrounds, Colors and Backgrounds +@subsubsection color +@multitable @columnfractions .2 .8 +@item Value: @tab +@item Initial: @tab User specific +@item Applies to: @tab all elements +@item Inherited: @tab yes +@item Percentage values: @tab N/A +@end multitable + +This property describes the text color of an element (often referred to +as the foreground color). There are different ways to specify red: + +@example + EM @{ color: red @} /* natural language */ + EM @{ color: rgb(255,0,0) @} /* RGB range 0-255 */ +@end example + +See @ref{Color Units} for a description of possible color values. -@cindex Delaying inlined images -@cindex Delaying inlined animations -@vindex w3-delay-image-loads -@vindex w3-delay-mpeg-loads -Because images and movies can take up an incredible amount of bandwidth, -it is useful to be able to control whether they are loaded or not. By -default, images and movies are loaded automatically, but the variables -@code{w3-delay-image-loads} and @code{w3-delay-mpeg-loads} control this. -If set to non-@code{nil}, then the images or movies are not -loaded until explicitly requested by the user. +@node background-color, background-image, color, Colors and Backgrounds +@subsubsection background-color +@multitable @columnfractions .2 .8 +@item Value: @tab | transparent +@item Initial: @tab transparent +@item Applies to: @tab all elements +@item Inherited: @tab no +@item Percentage values: @tab N/A +@end multitable + +This property sets the background color of an element. + +@example + H1 @{ background-color: #F00 @} +@end example + +@node background-image, background-repeat, background-color, Colors and Backgrounds +@subsubsection background-image +@multitable @columnfractions .2 .8 +@item Value: @tab | none +@item Initial: @tab none +@item Applies to: @tab all elements +@item Inherited: @tab no +@item Percentage values: @tab N/A +@end multitable + +This property sets the background image of an element. When setting a +background image, one should also set a background color that will be +used when the image is unavailable. When the image is available, it is +overlaid on top of the background color. + +@example + BODY @{ background-image: url(marble.gif) @} + P @{ background-image: none @} +@end example + +@node background-repeat, background-attachment, background-image, Colors and Backgrounds +@subsubsection background-repeat +This property is not supported at all under Emacs-W3. + +@node background-attachment, background-position, background-repeat, Colors and Backgrounds +@subsubsection background-attachment +This property is not supported at all under Emacs-W3. + +@node background-position, background, background-attachment, Colors and Backgrounds +@subsubsection background-position +This property is not supported at all under Emacs-W3. + +@node background, Text Properties, background-position, Colors and Backgrounds +@subsubsection background +@multitable @columnfractions .2 .8 +@item Value: @tab || || || || +@item Initial: @tab not defined for shorthand properties +@item Applies to: @tab all elements +@item Inherited: @tab no +@item Percentage values: @tab allowed on +@end multitable + +The 'background' property is a shorthand property for setting the +individual background properties (i.e., 'background-color', +'background-image', 'background-repeat', 'background-attachment' and +'background-position') at the same place in the style sheet. + +Possible values on the 'background' properties are the set of all +possible values on the individual properties. + +@example + BODY @{ background: red @} + P @{ background: url(chess.png) gray 50% repeat fixed @} +@end example + +The 'background' property always sets all the individual background +properties. In the first rule of the above example, only a value for +'background-color' has been given and the other individual properties +are set to their initial value. In the second rule, all individual +properties have been specified. + +@node Text Properties, word-spacing, background, Properties +@subsection Text Properties + +@ifinfo +@menu +* word-spacing:: +* letter-spacing:: +* text-decoration:: +* vertical-align:: +* text-transform:: +* text-align:: +* text-indent:: +* line-height:: +@end menu +@end ifinfo -@cindex Loading delayed images -@cindex Loading delayed movies -@findex w3-load-delayed-images -@findex w3-load-delayed-mpegs -To load any delayed images, use the function -@code{w3-load-delayed-images}. Its counterpart for delayed movies is -@code{w3-load-delayed-mpegs} +@node word-spacing, letter-spacing, Text Properties, Text Properties +@subsubsection word-spacing +@multitable @columnfractions .2 .8 +@end multitable + +@node letter-spacing, text-decoration, word-spacing, Text Properties +@subsubsection letter-spacing +@multitable @columnfractions .2 .8 +@end multitable + +@node text-decoration, vertical-align, letter-spacing , Text Properties +@subsubsection text-decoration +@multitable @columnfractions .2 .8 +@end multitable + +@node vertical-align, text-transform, text-decoration, Text Properties +@subsubsection vertical-align +@multitable @columnfractions .2 .8 +@end multitable + +@node text-transform, text-align, vertical-align, Text Properties +@subsubsection text-transform +@multitable @columnfractions .2 .8 +@end multitable + +@node text-align, text-indent, text-transform, Text Properties +@subsubsection text-align +@multitable @columnfractions .2 .8 +@end multitable + +@node text-indent, line-height, text-align, Text Properties +@subsubsection +@multitable @columnfractions .2 .8 +@end multitable + +@node line-height, Box Properties, text-indent, Text Properties +@subsubsection +@multitable @columnfractions .2 .8 +@end multitable + +@node Box Properties, Classification, line-height, Properties +@subsection Box Properties +@multitable @columnfractions .2 .8 +@end multitable -@node MIME Support, Adding MIME types based on file extensions, , Top +@node Classification, Media Selection, Box Properties, Properties +@subsection Classification +@multitable @columnfractions .2 .8 +@end multitable + +@node Media Selection, Speech Properties, Classification, Properties +@subsection Media Selection +@multitable @columnfractions .2 .8 +@end multitable + +@node Speech Properties, Units, Media Selection, Properties +@subsection Speech Properties +@multitable @columnfractions .2 .8 +@end multitable + +@node Units, Length Units, Speech Properties, Stylesheets +@section Units + +@ifinfo +@menu +* Length Units:: +* Percentage Units:: +* Color Units:: +* URLs:: +* Angle Units:: +* Time Units:: +@end menu +@end ifinfo + +@node Length Units, Percentage Units, Units, Units +@subsection Length Units + +@node Percentage Units, Color Units, Length Units, Units +@subsection Percentage Units + +@node Color Units, URLs, Percentage Units, Units +@subsection color Units + +@node URLs, Angle Units, Color Units, Units +@subsection URLs + +@node Angle Units, Time Units, URLs, Units +@subsection Angle Units + +@node Time Units, Supported URLs, Angle Units, Units +@subsection Time Units + +@node Supported URLs, MIME Support, Time Units, Top +@chapter Supported URLs + +::WORK:: List supported URL types, specific RFCs, etc. + +@node MIME Support, Adding MIME types based on file extensions, Supported URLs, Top @chapter MIME Support @sc{mime} is an emerging standard for multimedia mail. It offers a very flexible typing mechanism. The type of a file or message is specified @@ -1962,7 +2410,7 @@ :: WORK :: Revamp the todo list -@node Reporting Bugs, Installing SSL, Future Directions, Top +@node Reporting Bugs, Dealing with Firewalls, Future Directions, Top @appendix Reporting Bugs @cindex Reporting Bugs @cindex Bugs @@ -2007,7 +2455,214 @@ painful if I don't have to waste a round-trip email exchange saying 'what are you talking about'. -@node Installing SSL, Mailcap Files, Reporting Bugs, Top +@node Dealing with Firewalls, Proxy Gateways, Reporting Bugs, Top +@appendix Dealing with Firewalls +By default, Emacs can support standard @sc{tcp}/@sc{ip} network +connections on almost all the platforms it runs on (Unix, @sc{vms}, +Windows, etc). However, there are several situations where it is not +sufficient. + +@table @b +@cindex Firewalls +@item Firewalls +It is becoming more and more common to be behind a firewall or some +other system that restricts your outbound network activity, especially +if you are like me and away from the wonderful world of academia. +Emacs-W3 has several different methods to get around firewalls (not to +worry though - none of them should get you in trouble with the local +@sc{mis} department.) + +@item Emacs cannot resolve hostnames. +@cindex Faulty hostname resolvers +@cindex Broken SunOS libc +@cindex Hostname resolution +This happens quite often on SunOS workstations and some ULTRIX machines. +Some C libraries do not include the hostname resolver routines in their +static libraries. If Emacs was linked statically, and was not linked +with the resolver libraries, it wil not be able to get to any machines +off the local network. This is characterized by being able to reach +someplace with a raw ip number, but not its hostname +(@url{http://129.79.254.191/} works, but +@url{http://www.cs.indiana.edu/} doesn't). + +The best solution for this problem is to recompile Emacs, making sure to +either link dynamically (if available on your operating system), or +include the @file{-lresolv}. + +@cindex url-gateway-broken-resolution +If you do not have the disk space or the appropriate permissions to +recompile Emacs, another alternative is using the @file{nslookup} +program to do hostname resolution. To turn this on, set the variable +@code{url-gateway-broken-resolution} in your @file{~/.emacs} file. This +runs the program specified by @code{url-gateway-nslookup-program} (by +default "@code{nslookup}" to do hostname resolution. This program should +expect a single argument on the command line - the hostname to resolve, +and should produce output similar to the standard Unix @file{nslookup} +program: + +@example +Name: www.cs.indiana.ed +Address: 129.79.254.191 +@end example + +@cindex @sc{term} +@item Using @sc{term} (or @sc{term}-like) Networking Software +@sc{term} @footnote{@sc{term} is a user-level protocol for emulating +@sc{ip} over a serial line. More information is available at +@url{ftp://sunsite.unc.edu/pub/Linux/apps/comm/term}} for slip-like +access to the internet. + +@sc{note}: XEmacs and Emacs 19.22 or later have patches to enable native +@sc{term} networking. To enable it, @code{#define TERM} in the +appropriate s/*.h file for the operating system, then change the +@code{SYSTEM_LIBS} definition to include the @file{termnet} library that +comes with the latest versions of @sc{term}. + +If you run into any problems with the native @sc{term} networking +support in Emacs or XEmacs, please let @t{wmperry@@cs.indiana.edu} know, +as he is responsible for the original support. +@end table + +@vindex url-gateway-local-host-regexp +Emacs-W3 has support for using the gateway mechanism for certain +domains, and directly connecting to others. The variable +@code{url-gateway-local-host-regexp} controls this behaviour. This is a +regular expression @footnote{Please see the full Emacs distribution for +a description of regular expressions} that matches local hosts that do +not require the use of a gateway. If @code{nil}, then all connections +are made through the gateway. + +@vindex url-gateway-method +Emacs-W3 supports several methods of getting around gateways. The +variable @code{url-gateway-method} controls which of these methods is +used. This variable can have several values (use these as symbol names, +not strings), ie: @samp{(setq url-gateway-method 'telnet)}. Possible +values are: + +@table @dfn +@item telnet +Use this method if you must first telnet and log into a gateway host, +and then run telnet from that host to connect to outside machines. + +:: WORK :: document telnet gw variables +This section needs more information, specifically documenting the +following variables. For now, please do @key{C-h v} on the variable for +more information. + +@table @code +@item url-gateway-telnet-host +@item url-gateway-telnet-parameters +@item url-gateway-telnet-password-prompt +@item url-gateway-telnet-puser-name +@item url-gateway-prompt-pattern +@end table + +@item rlogin +This method is identical to the @code{telnet} method, but uses +@file{rlogin} to log into the remote machine without having to send the +username and password over the wire every time. + +:: WORK :: document rlogin gw variables +This section needs more information, specifically documenting the +following variables. For now, please do @key{C-h v} on the variable for +more information. + +@table @code +@item url-gateway-rlogin-host +@item url-gateway-rlogin-parameters +@item url-gateway-rlogin-user-name +@item url-gateway-prompt-pattern +@end table + +@item tcp +Masanobu UMEDA (@i{umerin@@mse.kyutech.ac.jp}) has written a very small +application that you can run in a subprocess to do the network +connections. + +@item @sc{socks} +Use if the firewall has a @sc{socks} gateway running on it. + +:: WORK :: document socks variables +This section needs more information, specifically documenting the +following variables. For now, please do @key{C-h v} on the variable for +more information. + +@table @code +@item socks-host +@item socks-password +@item socks-username +@item socks-port +@item socks-timeout +@end table + +@c @item ssl +@c This probably shouldn't be documented + +@item native +This means that Emacs-W3 should use the builtin networking code of +Emacs. This should be used only if there is no firewall, or the Emacs +source has already been hacked to get around the firewall. +@end table + +Emacs-W3 should now be able to get outside the local network. If none +of this makes sense, its probably my fault. Please check with the +network administrators to see if they have a program that does most of +this already, since somebody somewhere at the company has probably been +through something similar to this before, and would be much more +helpful/knowledgeable about the local setup than I would be. But feel +free to mail me as a last resort. + +@node Proxy Gateways, Installing SSL, Dealing with Firewalls, Top +@appendix Proxy Gateways +@vindex url-proxy-services +@cindex Proxy Servers +@cindex Proxies +@cindex Proxies, environment variables +@cindex HTTP Proxy + +In late January 1993, Kevin Altis and Lou Montulli proposed and +implemented a new proxy service. This service requires the use of +environment variables to specify a gateway server/port # to send +protocol requests to. Each protocol (@sc{http}, @sc{wais}, gopher, +@sc{ftp}, etc.) can have a different gateway server. The environment +variables are @code{PROTOCOL}_proxy, where @code{PROTOCOL} is one of the +supported network protocols (gopher, file, @sc{http}, @sc{ftp}, etc.) + +@cindex No Proxy +@cindex Proxies, exclusion lists +@vindex NO_PROXY +For companies with internal intranets, it will usually be helpful to +define a list of hosts that should be contacted directly, @b{not} sent +through the proxy. The @code{NO_PROXY} environment variable controls +what hosts are able to be contacted directly. This should be a comma +separated list of hostnames, domain names, or a mixture of both. +Asterisks can be used as a wildcard. For example: + +@example +NO_PROXY=*.aventail.com,home.com,*.seanet.com +@end example + +tells Emacs-W3 to contact all machines in the @b{aventail.com} and +@b{seanet.com} domains directly, as well as the machine named +@b{home.com}. + +@vindex url-proxy-services +@cindex Proxies, setting from lisp +For those adventurous souls who enjoy writing regular expressions, all +the proxy settings can be manipulated from Emacs-Lisp. The variable +@code{url-proxy-services} controls this. This is an assoc list, keyed +on the protocol type (@sc{http}, gopher, etc) in all lowercase. The +@code{cdr} of each entry should be the fully-specified @sc{url} of the proxy +server to contact, or, in the case of the special "no_proxy" entry, a +regular expression that matches any hostnames that should be contacted +directly. + +@example +(setq url-proxy-services '(("http" . "http://proxy.aventail.com/") + ("no_proxy" . "^.*\\(aventail\\|seanet\\)\.com"))) +@end example + +@node Installing SSL, Mailcap Files, Proxy Gateways, Top @appendix Installing SSL @cindex HTTP/1.0 Authentication @cindex Secure Sockets Layer @@ -2043,7 +2698,7 @@ be distributing a set of patches to Emacs 19.xx and XEmacs 19.xx to SSL-enable them, for the sake of speed. -@node Mailcap Files, General Index, Installing SSL, Top +@node Mailcap Files, Down with DoubleClick, Installing SSL, Top @appendix Mailcap Files NCSA Mosaic and almost all other WWW browsers rely on a separate file for mapping MIME types to external viewing programs. This takes some of @@ -2177,7 +2832,12 @@ document. @end itemize -@node General Index, Key Index, Mailcap Files, Top +@node Down with DoubleClick, General Index, Mailcap Files, Top +@appendix Down with DoubleClick +:: WORK :: Document why doubleclick is evil +:: WORK :: Document how you can never see another ad from them again + +@node General Index, Key Index, Down with DoubleClick, Top @appendix General Index @printindex fn @node Key Index, , General Index, Top @@ -2186,143 +2846,6 @@ @contents @bye -@c @ifinfo -@c Here is some more specific information about what languages and -@c protocols Emacs-W3 supports. -@c @menu -@c * Markup Languages Supported:: Markup languages supported by Emacs-W3 -@c * Stylesheets:: Stylesheet languages supported by Emacs-W3 -@c * Supported Protocols:: Network protocols supported by Emacs-W3 -@c @end menu -@c @end ifinfo -@c @node Markup Languages Supported, Stylesheets, Introduction, Introduction -@c @chapter Supported Markup Languages -@c Several different markup languages, and various extensions to those -@c languages, are supported by Emacs-W3. -@c @ifinfo -@c @center ---------- -@c @center HTML 2.0 -@c @center ---------- -@c @end ifinfo -@c @iftex -@c @section HTML 2.0 -@c @end iftex -@c @cindex HTML 2.0 - -@c :: WORK :: Reference to the HTML 2.0 RFC -@c :: WORK :: Basic explanation of HTML, tag structure, etc. - -@c @ifinfo -@c @center ---------- -@c @center HTML 3.2 -@c @center ---------- -@c @end ifinfo -@c @iftex -@c @section HTML 3.2 -@c @end iftex -@c @cindex HTML 3.2 -@c The HTML 3.2 language is an extension of HTML, with a large degree of -@c backward compatibility with HTML 2.0. This basically documents current -@c practice as of January, 1996. - -@c @ifinfo -@c @center ---------- -@c @center SGML Features -@c @center ---------- -@c @end ifinfo -@c @iftex -@c @section SGML Features -@c @end iftex -@c @cindex SGML Features -@c @cindex Entity Definitions -@c @cindex Marked Sections - -@c :: WORK :: Document marked sections, SGML features - -@c @ifinfo -@c @center ---------- -@c @center Extras -@c @center ---------- -@c @end ifinfo -@c @iftex -@c @section Extra Markup -@c @end iftex -@c @cindex Easter Eggs -@c @cindex Fluff -@c @cindex Pomp & Circumstance -@c There are several different markup elements that are not officially part -@c of HTML or HTML 3.2 that Emacs-W3 supports. These are either items that -@c were dropped from HTML 3.@var{x} after I had implemented them, things I -@c find just completely hilarious, or experimental parts of HTML that -@c should not be counted as "official" or long lived. -@c @itemize @bullet -@c @item -@c FLAME support. For truly interesting dynamic documents. This is -@c replaced with a random quote from Mr. Angry (see @kbd{M-x flame} for a -@c sample). -@c @item -@c The top ten tags that did not make it into netscape. These tags were -@c posted to the newsgroup comp.infosystems.www.misc by Laura Lemay -@c (@i{lemay@@netcom.com}). Much thanks to her for the humor. -@c @table @b -@c @item ... -@c Renders the enclosed text in a suitably ugly font/color combination. If -@c no default has been set up by the user, this is the default font, with -@c red text on a yellow background. -@c @item ... -@c When selected, the enclosed text runs and hides under the nearest -@c window. OR, giggles a lot and demands nachos, depending on the -@c definition of "roach." (the formal definition, of course, to be -@c determined by the Official Honorary Internet Standards Committee For -@c Moving Really Slowly.) -@c @item -@c Inserts "zippyisms" into the enclosed text. Perfect for those professional -@c documents. This is sure to be a favorite of mine! -@c @item ... -@c Must use secret spy decoder glasses (available direct from Netscape for -@c a reasonable fee) in order to read the enclosed text. Can also be read -@c by holding the computer in front of a full moon during the autumn -@c solstice. - -@c In Emacs-W3, this displays the text using rot13 encoding. -@c @item -@c Causes Marc Andreesen to magically appear and grant an interview (wanted -@c or not). Please use this tag sparingly. -@c @item .... -@c @item ... -@c Need more control over screen layout in HTML? Well, here ya go. -@c n -@c Actually, could almost be considered useful. The VARIABLE -@c attribute can be used to insert the value of an emacs variable into the -@c current document. Things like 'Welcome to my page, ' can be useful in spreading fear, -@c uncertainty, and doubt among users. -@c @item -@c @cindex Gates Bill -@c @cindex Yogsothoth -@c Summons the elder gods to suck away your immortal soul. Or Bill Gates, -@c if the elder gods are busy. Unpredictable (but amusing) results occur -@c when the and tags are used in close proximity. - -@c @item ... -@c Causes the enclosed text to .... ooops that one made it in. -@c @end table -@c @end itemize - -@c @node Stylesheets, Supported Protocols, Markup Languages Supported,Introduction -@c @chapter Stylesheets -@c @cindex Stylesheets -@c @cindex Cascading Style Sheets -@c @cindex Aural Cascading Style Sheets -@c @cindex CSS -@c @cindex DSSSL -@c :: WORK :: Document CSS support -@c CSS Information at http://www.w3.org/pub/WWW/TR/REC-CSS1 -@c Style guide at http://www.htmlhelp.com/reference/css/ -@c :: WORK :: Document ACSS support -@c ACSS Information at http://www.w3.org/pub/WWW/Style/CSS/Speech/NOTE-ACSS -@c :: WORK :: Document DSSSL support - @c @node Supported Protocols, , Stylesheets, Introduction @c @chapter Supported Protocols @c @cindex Network Protocols diff -r b88636d63495 -r 8fc7fe29b841 man/widget.texi --- a/man/widget.texi Mon Aug 13 08:50:06 2007 +0200 +++ b/man/widget.texi Mon Aug 13 08:50:29 2007 +0200 @@ -1,6 +1,6 @@ \input texinfo.tex -@c $Id: widget.texi,v 1.2 1997/02/09 23:52:13 steve Exp $ +@c $Id: widget.texi,v 1.3 1997/02/16 01:29:52 steve Exp $ @c %**start of header @setfilename widget @@ -15,7 +15,7 @@ @comment node-name, next, previous, up @top The Emacs Widget Library -Version: 1.30 +Version: 1.40 @menu * Introduction:: @@ -236,8 +236,8 @@ selected and the previous selected radio button will become unselected. @item The @samp{@b{[Apply Form]}} @samp{@b{[Reset Form]}} buttons. These are explicit buttons made with the @code{push-button} widget. The main -difference from the @code{link} widget is that the buttons are intended -to be displayed more like buttons in a GUI, once Emacs grows powerful +difference from the @code{link} widget is that the buttons are will be +displayed as GUI buttons when possible. enough. @end table @@ -483,6 +483,10 @@ The string inserted by the @samp{%t} escape in the format string. +@item :tag-glyph +Name of image to use instead of the string specified by `:tag' on +Emacsen that supports it. + @item :help-echo Message displayed whenever you move to the widget with either @code{widget-forward} or @code{widget-backward}. @@ -531,6 +535,17 @@ @code{editable-list} widget). @end table +@deffn {User Option} widget-glyph-directory +Directory where glyphs are found. +Widget will look here for a file with the same name as specified for the +image, with either a @samp{.xpm} (if supported) or @samp{.xbm} extension. +@end deffn + +@deffn{User Option} widget-glyph-enable +If non-nil, allow glyphs to appear on displayes where they are supported. +@end deffn + + @menu * link:: * url-link:: @@ -815,12 +830,12 @@ String representing the `on' state. By default the string @samp{on}. @item :off String representing the `off' state. By default the string @samp{off}. -@item :on-type -Type representing the `on' state. By default an `item' widget displaying -the string specified with the @code{:on} keyword. -@item :off-type -Type representing the `off' state. By default an `item' widget -displaying the string specified with the @code{:off} keyword. +@item :on-glyph +Name of a glyph to be used instead of the `:on' text string, on emacsen +that supports it. +@item :off-glyph +Name of a glyph to be used instead of the `:off' text string, on emacsen +that supports it. @end table @node checkbox, checklist, toggle, Basic Types @@ -1144,7 +1159,7 @@ Occasionally it can be useful to know which kind of widget you have, i.e. the name of the widget type you gave when the widget was created. -@defun widget-name widget +@defun widget-type widget Return the name of @var{widget}, a symbol. @end defun @@ -1257,9 +1272,6 @@ @section Wishlist. @itemize @bullet -@item -A Smalltalk style widget browser. - @item It should be possible to add or remove items from a list with @kbd{C-k} and @kbd{C-o} (suggested by @sc{rms}). @@ -1271,14 +1283,6 @@ the ugly buttons, the dash is my idea). @item -Use graphical versions of the widgets for emacsen that can do that. -I.e. real radio buttons and checkmarks instead of their @sc{ascii} -equivalents. - -@item -There should be support for browsing the widget documentation. - -@item Widgets such as @code{file} and @code{symbol} should prompt with completion. @item @@ -1304,12 +1308,9 @@ Document `helper' functions for defining new widgets. @item -Show button menus on mouse down. - -@item Activate the item this is below the mouse when the button is released, not the item this is below the mouse when the button is -pressed. Dired and grep gets this right. +pressed. Dired and grep gets this right. Give feedback if possible. @item Use @samp{@@deffn Widget} to document widgets. @@ -1325,6 +1326,22 @@ Split, when needed, keywords into those useful for normal customization, those primarily useful when deriving, and those who represent runtime information. + +@item +Figure out terminology and @sc{api} for the class/type/object/super +stuff. + +Perhaps the correct model is delegation? + +@item +Document @code{widget-browse}. + +@item +Make indentation work with glyphs and propertional fonts. + +@item +Add object and class hierarchies to the browser. + @end itemize @contents diff -r b88636d63495 -r 8fc7fe29b841 man/xemacs-faq.texi --- a/man/xemacs-faq.texi Mon Aug 13 08:50:06 2007 +0200 +++ b/man/xemacs-faq.texi Mon Aug 13 08:50:29 2007 +0200 @@ -10,7 +10,7 @@ @subtitle Frequently asked questions about XEmacs @subtitle Last Modified: 1997/01/16 @sp 1 -@author Anthony Rossini +@author Tony Rossini @author Ben Wing @author Chuck Thompson @author Steve Baur @@ -314,11 +314,11 @@ @example Web: http://www.xemacs.com - E-mail: + E-mail: Tel: +1 408 243 3300 @end example -@node Q1.1.1, Q1.1.2, Q1.0.13, Introduction +@node Q1.1.1, Q1.1.2, Q1.0.14, Introduction @section What is the FAQ editorial policy? The FAQ is actively maintained and modified regularly. All links should @@ -3714,7 +3714,7 @@ technical people. It is developed and supported by InfoDock Associates, a firm that offers custom support and development for InfoDock, XEmacs and GNU Emacs. (http://www.infodock.com, -, +1 408 243 3300). +, +1 408 243 3300). InfoDock is built atop the XEmacs variant of GNU Emacs and so has all of the power of Emacs, but with an easier to use and more comprehensive diff -r b88636d63495 -r 8fc7fe29b841 src/Makefile.in.in --- a/src/Makefile.in.in Mon Aug 13 08:50:06 2007 +0200 +++ b/src/Makefile.in.in Mon Aug 13 08:50:29 2007 +0200 @@ -314,7 +314,7 @@ # define SOUND_LIBS -lAlib # define SOUND_OBJS hpplay.o # else /* !HP9000S800 */ -# if defined (LINUX) +# if defined (LINUX) || defined(__FreeBSD__) # define SOUND_CFLAGS # define SOUND_LIBS # define SOUND_OBJS linuxplay.o diff -r b88636d63495 -r 8fc7fe29b841 src/cmds.c --- a/src/cmds.c Mon Aug 13 08:50:06 2007 +0200 +++ b/src/cmds.c Mon Aug 13 08:50:29 2007 +0200 @@ -41,11 +41,15 @@ /* This is the command that set up Vself_insert_face. */ Lisp_Object Vself_insert_face_command; +/* t means beep when movement would take point past (point-min) or */ +/* (point-max) */ +int signal_error_on_buffer_boundary; DEFUN ("forward-char", Fforward_char, 0, 2, "_p", /* Move point right ARG characters (left if ARG negative). On reaching end of buffer, stop and signal error. -If BUFFER is nil, the current buffer is assumed. +Error signaling is suppressed if `signal-error-on-buffer-boundary' +is nil. If BUFFER is nil, the current buffer is assumed. */ (arg, buffer)) { @@ -67,12 +71,18 @@ if (new_point < BUF_BEGV (buf)) { BUF_SET_PT (buf, BUF_BEGV (buf)); - Fsignal (Qbeginning_of_buffer, Qnil); + if (signal_error_on_buffer_boundary) + Fsignal (Qbeginning_of_buffer, Qnil); + else + return Qnil; } if (new_point > BUF_ZV (buf)) { BUF_SET_PT (buf, BUF_ZV (buf)); - Fsignal (Qend_of_buffer, Qnil); + if (signal_error_on_buffer_boundary) + Fsignal (Qend_of_buffer, Qnil); + else + return Qnil; } BUF_SET_PT (buf, new_point); @@ -84,7 +94,8 @@ DEFUN ("backward-char", Fbackward_char, 0, 2, "_p", /* Move point left ARG characters (right if ARG negative). On attempt to pass beginning or end of buffer, stop and signal error. -If BUFFER is nil, the current buffer is assumed. +Error signaling is suppressed if `signal-error-on-buffer-boundary' +is nil. If BUFFER is nil, the current buffer is assumed. */ (arg, buffer)) { @@ -479,4 +490,10 @@ More precisely, a char with closeparen syntax is self-inserted. */ ); Vblink_paren_function = Qnil; + + DEFVAR_BOOL ("signal-error-on-buffer-boundary", &signal_error_on_buffer_boundary /* +t means beep when movement would take point past (point-min) or +\(point-max). +*/ ); + signal_error_on_buffer_boundary = 1; } diff -r b88636d63495 -r 8fc7fe29b841 src/event-Xt.c --- a/src/event-Xt.c Mon Aug 13 08:50:06 2007 +0200 +++ b/src/event-Xt.c Mon Aug 13 08:50:29 2007 +0200 @@ -592,18 +592,8 @@ /* X to Emacs event conversion */ /************************************************************************/ -#if (defined(sun) || defined(__sun)) && defined(__GNUC__) -# define SUNOS_GCC_L0_BUG -#endif - -#ifdef SUNOS_GCC_L0_BUG -static void -x_to_emacs_keysym_sunos_bug (Lisp_Object *return_value_sunos_bug, /* #### */ - XEvent *event, int simple_p) -#else /* !SUNOS_GCC_L0_BUG */ static Lisp_Object x_to_emacs_keysym (XKeyPressedEvent *event, int simple_p) -#endif /* !SUNOS_GCC_L0_BUG */ /* simple_p means don't try too hard (ASCII only) */ { char *name; @@ -612,11 +602,6 @@ passing in 0) to avoid crashes on German IRIX */ char dummy[256]; -#ifdef SUNOS_GCC_L0_BUG -# define return(lose) \ - do {*return_value_sunos_bug = (lose); goto return_it; } while (0) -#endif - /* ### FIX this by replacing with calls to XmbLookupString. XLookupString should never be called. --mrb */ XLookupString (event, dummy, 200, &keysym, 0); @@ -682,24 +667,8 @@ } return KEYSYM (name); } -#ifdef SUNOS_GCC_L0_BUG -# undef return - return_it: - return; -#endif } -#ifdef SUNOS_GCC_L0_BUG -/* #### */ -static Lisp_Object -x_to_emacs_keysym (XEvent *event, int simple_p) -{ - Lisp_Object return_value_sunos_bug; - x_to_emacs_keysym_sunos_bug (&return_value_sunos_bug, event, simple_p); - return (return_value_sunos_bug); -} -#endif - static void set_last_server_timestamp (struct device *d, XEvent *x_event) { diff -r b88636d63495 -r 8fc7fe29b841 src/extents.c --- a/src/extents.c Mon Aug 13 08:50:06 2007 +0200 +++ b/src/extents.c Mon Aug 13 08:50:29 2007 +0200 @@ -5138,7 +5138,8 @@ `inside-margin', or `outside-margin') of the extent's begin glyph. - end-glyph-layout The layout policy of the extent's end glyph. */ + end-glyph-layout The layout policy of the extent's end glyph. +*/ (extent, property, value)) { /* This function can GC if property is `keymap' */ diff -r b88636d63495 -r 8fc7fe29b841 src/frame.c --- a/src/frame.c Mon Aug 13 08:50:06 2007 +0200 +++ b/src/frame.c Mon Aug 13 08:50:29 2007 +0200 @@ -460,7 +460,10 @@ the frame-specific version of the buffer-alist unless the frame is accessible from the device. */ +#if 0 DEVICE_FRAME_LIST (d) = nconc2 (DEVICE_FRAME_LIST (d), Fcons (frame, Qnil)); +#endif + DEVICE_FRAME_LIST (d) = Fcons (frame, DEVICE_FRAME_LIST (d)); RESET_CHANGED_SET_FLAGS; /* Now make sure that the initial cached values are set correctly. diff -r b88636d63495 -r 8fc7fe29b841 src/keymap.c --- a/src/keymap.c Mon Aug 13 08:50:06 2007 +0200 +++ b/src/keymap.c Mon Aug 13 08:50:29 2007 +0200 @@ -228,6 +228,9 @@ Lisp_Object Qbutton0up, Qbutton1up, Qbutton2up, Qbutton3up, Qbutton4up, Qbutton5up, Qbutton6up, Qbutton7up; Lisp_Object Qmenu_selection; +/* Emacs compatibility */ +Lisp_Object Qdown_mouse_1, Qdown_mouse_2, Qdown_mouse_3; +Lisp_Object Qmouse_1, Qmouse_2, Qmouse_3; /* Kludge kludge kludge */ Lisp_Object QLFD, QTAB, QRET, QESC, QDEL, QSPC, QBS; @@ -1282,6 +1285,19 @@ strlen(temp)), Qnil); } + /* Emacs compatibility */ + else if (EQ(*keysym, Qdown_mouse_1)) + *keysym = Qbutton1; + else if (EQ(*keysym, Qdown_mouse_2)) + *keysym = Qbutton2; + else if (EQ(*keysym, Qdown_mouse_3)) + *keysym = Qbutton3; + else if (EQ(*keysym, Qmouse_1)) + *keysym = Qbutton1up; + else if (EQ(*keysym, Qmouse_2)) + *keysym = Qbutton2up; + else if (EQ(*keysym, Qmouse_3)) + *keysym = Qbutton3up; } } @@ -4180,6 +4196,12 @@ defsymbol (&Qbutton5up, "button5up"); defsymbol (&Qbutton6up, "button6up"); defsymbol (&Qbutton7up, "button7up"); + defsymbol (&Qmouse_1, "mouse-1"); + defsymbol (&Qmouse_2, "mouse-2"); + defsymbol (&Qmouse_3, "mouse-3"); + defsymbol (&Qdown_mouse_1, "down-mouse-1"); + defsymbol (&Qdown_mouse_2, "down-mouse-2"); + defsymbol (&Qdown_mouse_3, "down-mouse-3"); defsymbol (&Qmenu_selection, "menu-selection"); defsymbol (&QLFD, "LFD"); defsymbol (&QTAB, "TAB"); diff -r b88636d63495 -r 8fc7fe29b841 src/linuxplay.c --- a/src/linuxplay.c Mon Aug 13 08:50:06 2007 +0200 +++ b/src/linuxplay.c Mon Aug 13 08:50:29 2007 +0200 @@ -61,7 +61,11 @@ #include #include -#include +#ifdef __FreeBSD__ +# include +#else +# include +#endif #include #include #include @@ -88,8 +92,8 @@ #define __inline__ #endif -static __sighandler_t sighup_handler; -static __sighandler_t sigint_handler; +static void (*sighup_handler)(int); +static void (*sigint_handler)(int); /* Maintain global variable for keeping parser state information; this struct is set to zero before the first invocation of the parser. The use of a @@ -982,8 +986,8 @@ this could lead to problems, when multiple sound cards are installed */ mix_fd = audio_fd; - sighup_handler = signal(SIGHUP,(__sighandler_t)sighandler); - sigint_handler = signal(SIGINT,(__sighandler_t)sighandler); + sighup_handler = signal(SIGHUP, sighandler); + sigint_handler = signal(SIGINT, sighandler); if (!audio_init(mix_fd,audio_fd,fmt,speed,tracks,&volume,&sndcnv)) goto END_OF_PLAY; diff -r b88636d63495 -r 8fc7fe29b841 src/s/sol2.h --- a/src/s/sol2.h Mon Aug 13 08:50:06 2007 +0200 +++ b/src/s/sol2.h Mon Aug 13 08:50:29 2007 +0200 @@ -43,7 +43,7 @@ /* The standard Solaris library nsl has this function in it which is supposed to only be in the BSD compat stuff. Yuck. Of course, there isn't a prototype for it other than in /usr/ucbinclude. */ -int gethostname (char *, int); +int gethostname (char *, size_t); /* XEmacs: Solaris include files miss this. */ struct timeval; diff -r b88636d63495 -r 8fc7fe29b841 src/window.c --- a/src/window.c Mon Aug 13 08:50:06 2007 +0200 +++ b/src/window.c Mon Aug 13 08:50:29 2007 +0200 @@ -4041,15 +4041,23 @@ } +extern int signal_error_on_buffer_boundary; + DEFUN ("scroll-up", Fscroll_up, 0, 1, "_P", /* Scroll text of current window upward ARG lines; or near full screen if no ARG. A near full screen is `next-screen-context-lines' less than a full screen. Negative ARG means scroll downward. When calling from a program, supply a number as argument or nil. + +If `signal-error-on-buffer-boundary' is nil, the usual error and +loss of zmacs region is suppressed when moving past end of buffer. */ (n)) { - window_scroll (Fselected_window (Qnil), n, 1, ERROR_ME); + Error_behavior errb = + signal_error_on_buffer_boundary ? ERROR_ME : ERROR_ME_NOT; + + window_scroll (Fselected_window (Qnil), n, 1, errb); return Qnil; } @@ -4058,10 +4066,16 @@ A near full screen is `next-screen-context-lines' less than a full screen. Negative ARG means scroll upward. When calling from a program, supply a number as argument or nil. + +If `signal-error-on-buffer-boundary' is nil, the usual error and +loss of zmacs region is suppressed when moving past end of buffer. */ (n)) { - window_scroll (Fselected_window (Qnil), n, -1, ERROR_ME); + Error_behavior errb = + signal_error_on_buffer_boundary ? ERROR_ME : ERROR_ME_NOT; + + window_scroll (Fselected_window (Qnil), n, -1, errb); return Qnil; }