1:45 a.m.
print.c cleanups + files.el synch with FSF 20.3
C ChangeLog:
1998-05-01 Hrvoje Niksic <hniksic(a)srce.hr>
* print.c (Fwrite_char): Don't touch Vprint_gensym.
(print_error_message): Don't gcpro TAIL.
(Fdisplay_error): Simplify.
1998-04-30 Hrvoje Niksic <hniksic(a)srce.hr>
* print.c (print_internal): Use long_to_string().
* redisplay.c (decode_mode_spec): Remove bogus calculation of the
number of digits.
* print.c (Fprin1): Removed THE_STREAM.
(Fprinc): Ditto.
(Fprint): Ditto.
(Fdisplay_error): Canonicalize STREAM here.
(print_error_message): Don't canonicalize STREAM.
(print_error_message): Use print_internal() instead of Fprin1 and
Fprinc.
* print.c: (Fprin1_to_string): Delete internal stream explicitly.
(Ferror_message_string): Ditto.
(Fterpri): Use write_char_internal.
Lisp ChangeLog:
1998-05-01 Hrvoje Niksic <hniksic(a)srce.hr>
* files.el (find-file-noselect): Update docstring.
(find-file-noselect): Signal an error if found an unreadable file.
(file-chase-links): Save the match data.
(normal-mode): Use `lwarn' and `error-message-string'.
(interpreter-mode-alist): Change defconst to defvar.
(inhibit-first-line-modes-regexps): Ditto.
(inhibit-first-line-modes-regexps): Added .tgz.
(inhibit-first-line-modes-suffixes): Change defconst to defvar.
(change-major-mode-with-file-name): New user-option.
(set-visited-file-name): Synched with FSF.
(file-name-extension): New function, from FSF 20.3.
(file-relative-name): Synched with FSF.
(save-some-buffers): Support the C-r feature.
(recover-session): Synched with FSF.
(kill-some-buffers): Ditto.
(set-auto-mode): New argument JUST-FROM-FILE-NAME.
--- src/print.c.orig Thu Apr 30 21:53:10 1998
+++ src/print.c Fri May 1 00:41:34 1998
＠＠ -45,8 +45,6 ＠＠
#define DBL_DIG 16
#endif
-static void print_error_message (Lisp_Object data, Lisp_Object stream);
-
Lisp_Object Vstandard_output, Qstandard_output;
/* The subroutine object for external-debugging-output is kept here
＠＠ -220,7 +218,7 ＠＠
else if (FRAMEP (function))
{
/* This gets used by functions not invoking print_prepare(),
- such as Fwrite_char. */
+ such as Fwrite_char, Fterpri, etc.. */
struct frame *f = XFRAME (function);
CHECK_LIVE_FRAME (function);
＠＠ -337,21 +335,21 ＠＠
Lstream_delete (str);
}
}
-
-/* Used for printing a character. STRING_OF_LENGTH_1 must contain a
- single-byte character, not just any emchar. */
+
+/* Used for printing a single-byte character (*not* any Emchar). */
#define write_char_internal(string_of_length_1, stream) \
- output_string ((stream), (CONST Bufbyte *) (string_of_length_1), \
+ output_string (stream, (CONST Bufbyte *) (string_of_length_1), \
Qnil, 0, 1)
-/* NOTE: Do not call this with the data of a Lisp_String,
- * as printcharfun might cause a GC, which might cause
- * the string's data to be relocated.
- * Use print_internal (string, printcharfun, 0)
- * to princ a Lisp_String
- * Note: "stream" should be the result of
"canonicalize_printcharfun"
- * (ie Qnil means stdout, not Vstandard_output, etc)
- */
+/* NOTE: Do not call this with the data of a Lisp_String, as
+ printcharfun might cause a GC, which might cause the string's data
+ to be relocated. To princ a Lisp string, use:
+
+ print_internal (string, printcharfun, 0);
+
+ Also note that STREAM should be the result of
+ canonicalize_printcharfun() (i.e. Qnil means stdout, not
+ Vstandard_output, etc.) */
void
write_string_1 (CONST Bufbyte *str, Bytecount size, Lisp_Object stream)
{
＠＠ -381,10 +379,8 ＠＠
Bytecount len;
CHECK_CHAR_COERCE_INT (ch);
- RESET_PRINT_GENSYM;
len = set_charptr_emchar (str, XCHAR (ch));
output_string (canonicalize_printcharfun (stream), str, Qnil, 0, len);
- RESET_PRINT_GENSYM;
return ch;
}
＠＠ -478,9 +474,7 ＠＠
(stream))
{
/* This function can GC */
- Bufbyte str[1];
- str[0] = '\n';
- output_string (canonicalize_printcharfun (stream), str, Qnil, 0, 1);
+ write_char_internal ("\n", canonicalize_printcharfun (stream));
return Qt;
}
＠＠ -493,14 +487,15 ＠＠
(object, stream))
{
/* This function can GC */
- Lisp_Object the_stream = Qnil, frame = Qnil;
- struct gcpro gcpro1, gcpro2, gcpro3;
+ Lisp_Object frame = Qnil;
+ struct gcpro gcpro1, gcpro2;
+ GCPRO2 (object, stream);
- GCPRO3 (object, stream, the_stream);
print_depth = 0;
- the_stream = print_prepare (stream, &frame);
- print_internal (object, the_stream, 1);
- print_finish (the_stream, frame);
+ stream = print_prepare (stream, &frame);
+ print_internal (object, stream, 1);
+ print_finish (stream, frame);
+
UNGCPRO;
return object;
}
＠＠ -514,23 +509,23 ＠＠
(object, noescape))
{
/* This function can GC */
- Lisp_Object stream;
- Lstream *str;
- struct gcpro gcpro1, gcpro2;
-
- stream = make_resizing_buffer_output_stream ();
- str = XLSTREAM (stream);
+ Lisp_Object result = Qnil;
+ Lisp_Object stream = make_resizing_buffer_output_stream ();
+ Lstream *str = XLSTREAM (stream);
+ /* gcpro OBJECT in case a caller forgot to do so */
+ struct gcpro gcpro1, gcpro2, gcpro3;
+ GCPRO3 (object, stream, result);
- /* Protect OBJECT, in case a caller forgot to protect. */
- GCPRO2 (object, stream);
print_depth = 0;
RESET_PRINT_GENSYM;
print_internal (object, stream, NILP (noescape));
RESET_PRINT_GENSYM;
Lstream_flush (str);
UNGCPRO;
- return make_string (resizing_buffer_stream_ptr (str),
- Lstream_byte_count (str));
+ result = make_string (resizing_buffer_stream_ptr (str),
+ Lstream_byte_count (str));
+ Lstream_delete (str);
+ return result;
}
DEFUN ("princ", Fprinc, 1, 2, 0, /*
＠＠ -539,19 +534,19 ＠＠
the contents of strings.
Output stream is STREAM, or value of standard-output (which see).
*/
- (obj, stream))
+ (object, stream))
{
/* This function can GC */
- Lisp_Object the_stream = Qnil, frame = Qnil;
- struct gcpro gcpro1, gcpro2, gcpro3;
+ Lisp_Object frame = Qnil;
+ struct gcpro gcpro1, gcpro2;
- GCPRO3 (obj, stream, the_stream);
- the_stream = print_prepare (stream, &frame);
+ GCPRO2 (object, stream);
+ stream = print_prepare (stream, &frame);
print_depth = 0;
- print_internal (obj, the_stream, 0);
- print_finish (the_stream, frame);
+ print_internal (object, stream, 0);
+ print_finish (stream, frame);
UNGCPRO;
- return obj;
+ return object;
}
DEFUN ("print", Fprint, 1, 2, 0, /*
＠＠ -560,62 +555,40 ＠＠
can handle, whenever this is possible.
Output stream is STREAM, or value of `standard-output' (which see).
*/
- (obj, stream))
+ (object, stream))
{
/* This function can GC */
- Lisp_Object the_stream = Qnil, frame = Qnil;
- struct gcpro gcpro1, gcpro2, gcpro3;
+ Lisp_Object frame = Qnil;
+ struct gcpro gcpro1, gcpro2;
- GCPRO3 (obj, stream, the_stream);
- the_stream = print_prepare (stream, &frame);
+ GCPRO2 (object, stream);
+ stream = print_prepare (stream, &frame);
print_depth = 0;
- write_char_internal ("\n", the_stream);
- print_internal (obj, the_stream, 1);
- write_char_internal ("\n", the_stream);
- print_finish (the_stream, frame);
+ write_char_internal ("\n", stream);
+ print_internal (object, stream, 1);
+ write_char_internal ("\n", stream);
+ print_finish (stream, frame);
UNGCPRO;
- return obj;
+ return object;
}
+/* Print an error message for the error DATA to STREAM. This is a
+ complete implementation of `display-error', which used to be in
+ Lisp (see prim/cmdloop.el). It was ported to C so it can be used
+ efficiently by Ferror_message_string. Fdisplay_error and
+ Ferror_message_string are trivial wrappers around this function.
-/* Synched with Emacs 19.34 -- underlying implementation (incarnated
- in print_error_message) is completely divergent, though. */
-DEFUN ("error-message-string", Ferror_message_string, 1, 1, 0, /*
-Convert an error value (ERROR-SYMBOL . DATA) to an error message.
-*/
- (data))
-{
- /* This function can GC */
- Lisp_Object stream = make_resizing_buffer_output_stream ();
- struct gcpro gcpro1;
- GCPRO1 (stream);
-
- print_error_message (data, stream);
- Lstream_flush (XLSTREAM (stream));
- UNGCPRO;
- return make_string (resizing_buffer_stream_ptr (XLSTREAM (stream)),
- Lstream_byte_count (XLSTREAM (stream)));
-}
-
-/* Print an error message for the error DATA onto Lisp output stream
- STREAM (suitable for the print functions).
-
- This is a complete implementation of `display-error', which used to
- be in Lisp (see prim/cmdloop.el). It was ported to C so we can use
- it in Ferror_message_string. Fdisplay_error and
- Ferror_message_string are trivial wrappers to this function. */
+ STREAM should be the result of canonicalize_printcharfun(). */
static void
print_error_message (Lisp_Object error_object, Lisp_Object stream)
{
/* This function can GC */
- Lisp_Object type;
+ Lisp_Object type = Fcar_safe (error_object);
Lisp_Object method = Qnil;
- Lisp_Object tail = Qnil;
- struct gcpro gcpro1;
+ Lisp_Object tail;
- GCPRO1 (tail);
-
- type = Fcar_safe (error_object);
+ /* No need to GCPRO anything under the assumption that ERROR_OBJECT
+ is GCPRO'd. */
if (! (CONSP (error_object) && SYMBOLP (type)
&& CONSP (Fget (type, Qerror_conditions, Qnil))))
＠＠ -645,44 +618,40 ＠＠
/* Default method */
{
int first = 1;
- Lisp_Object printcharfun = canonicalize_printcharfun (stream);
int speccount = specpdl_depth ();
specbind (Qprint_message_label, Qerror);
tail = Fcdr (error_object);
if (EQ (type, Qerror))
{
- Fprinc (Fcar (tail), stream);
+ print_internal (Fcar (tail), stream, 0);
tail = Fcdr (tail);
}
else
{
Lisp_Object errmsg = Fget (type, Qerror_message, Qnil);
if (NILP (errmsg))
- Fprinc (type, stream);
+ print_internal (type, stream, 0);
else
- Fprinc (errmsg, stream);
+ print_internal (LISP_GETTEXT (errmsg), stream, 0);
}
while (!NILP (tail))
{
- write_c_string (first ? ": " : ", ", printcharfun);
- Fprin1 (Fcar (tail), stream);
+ write_c_string (first ? ": " : ", ", stream);
+ print_internal (Fcar (tail), stream, 1);
tail = Fcdr (tail);
first = 0;
}
unbind_to (speccount, Qnil);
- UNGCPRO;
return;
- /* Unreached */
+ /* not reached */
}
error_throw:
- UNGCPRO;
if (NILP (method))
{
- write_c_string ("Peculiar error ",
- canonicalize_printcharfun (stream));
- Fprin1 (error_object, stream);
+ write_c_string (GETTEXT ("Peculiar error "), stream);
+ print_internal (error_object, stream, 1);
return;
}
else
＠＠ -691,13 +660,38 ＠＠
}
}
+DEFUN ("error-message-string", Ferror_message_string, 1, 1, 0, /*
+Convert ERROR-OBJECT to an error message, and return it.
+
+The format of ERROR-OBJECT should be (ERROR-SYMBOL . DATA). The
+message is equivalent to the one that would be issued by
+`display-error' with the same argument.
+*/
+ (error_object))
+{
+ /* This function can GC */
+ Lisp_Object result = Qnil;
+ Lisp_Object stream = make_resizing_buffer_output_stream ();
+ struct gcpro gcpro1;
+ GCPRO1 (stream);
+
+ print_error_message (error_object, stream);
+ Lstream_flush (XLSTREAM (stream));
+ result = make_string (resizing_buffer_stream_ptr (XLSTREAM (stream)),
+ Lstream_byte_count (XLSTREAM (stream)));
+ Lstream_delete (XLSTREAM (stream));
+
+ UNGCPRO;
+ return result;
+}
+
DEFUN ("display-error", Fdisplay_error, 2, 2, 0, /*
-Display an error message for ERROR-OBJECT to STREAM.
+Display ERROR-OBJECT on STREAM in a user-friendly way.
*/
(error_object, stream))
{
/* This function can GC */
- print_error_message (error_object, stream);
+ print_error_message (error_object, canonicalize_printcharfun (stream));
return Qnil;
}
＠＠ -707,8 +701,6 ＠＠
Lisp_Object Vfloat_output_format;
Lisp_Object Qfloat_output_format;
-void
-float_to_string (char *buf, double data)
/*
* This buffer should be at least as large as the max string size of the
* largest float, printed in the biggest notation. This is undoubtably
＠＠ -722,6 +714,8 ＠＠
* re-writing _doprnt to be more sane)?
* -wsr
*/
+void
+float_to_string (char *buf, double data)
{
Bufbyte *cp, c;
int width;
＠＠ -797,12 +791,15 ＠＠
/* Print NUMBER to BUFFER. The digits are first written in reverse
order (the least significant digit first), and are then reversed.
This is equivalent to sprintf(buffer, "%ld", number), only much
- faster. */
+ faster.
+
+ BUFFER should accept 24 bytes. This should suffice for the longest
+ numbers on 64-bit machines. */
void
long_to_string (char *buffer, long number)
{
char *p;
- int i, l;
+ int i, len;
if (number < 0)
{
＠＠ -810,6 +807,7 ＠＠
number = -number;
}
p = buffer;
+
/* Print the digits to the string. */
do
{
＠＠ -817,15 +815,16 ＠＠
number /= 10;
}
while (number);
+
/* And reverse them. */
- l = p - buffer - 1;
- for (i = l/2; i >= 0; i--)
+ len = p - buffer - 1;
+ for (i = len / 2; i >= 0; i--)
{
char c = buffer[i];
- buffer[i] = buffer[l - i];
- buffer[l - i] = c;
+ buffer[i] = buffer[len - i];
+ buffer[len - i] = c;
}
- buffer[l + 1] = '\0';
+ buffer[len + 1] = '\0';
}
static void
＠＠ -877,7 +876,7 ＠＠
{
obj = XCAR (XCDR (obj));
GCPRO2 (obj, printcharfun);
- write_char_internal ("'", printcharfun);
+ write_char_internal ("\'", printcharfun);
UNGCPRO;
print_internal (obj, printcharfun, escapeflag);
return;
＠＠ -885,6 +884,7 ＠＠
GCPRO2 (obj, printcharfun);
write_char_internal ("(", printcharfun);
+
{
int i = 0;
int max = 0;
＠＠ -1028,7 +1028,6 ＠＠
print_internal (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
{
/* This function can GC */
- char buf[256];
QUIT;
＠＠ -1055,13 +1054,14 ＠＠
for (i = 0; i < print_depth; i++)
if (EQ (obj, being_printed[i]))
{
- sprintf (buf, "#%d", i);
+ char buf[32];
+ *buf = '#';
+ long_to_string (buf + 1, i);
write_c_string (buf, printcharfun);
return;
}
}
-
being_printed[print_depth] = obj;
print_depth++;
＠＠ -1077,6 +1077,7 ＠＠
case Lisp_Type_Int:
#endif
{
+ char buf[24];
long_to_string (buf, XINT (obj));
write_c_string (buf, printcharfun);
break;
＠＠ -1085,6 +1086,7 ＠＠
case Lisp_Type_Char:
{
/* God intended that this be #\..., you know. */
+ char buf[16];
Emchar ch = XCHAR (obj);
char *p = buf;
*p++ = '?';
＠＠ -1209,8 +1211,9 ＠＠
default:
{
- /* We're in trouble if this happens!
- Probably should just abort () */
+ char buf[128];
+ /* We're in trouble if this happens! Probably should just
+ abort () */
if (print_readably)
error ("printing illegal data type #o%03o",
(int) XTYPE (obj));
＠＠ -1436,8 +1439,13 ＠＠
}
/* #ifdef DEBUG_XEMACS */
-/* I don't like seeing `Note: Strange doc (not fboundp) for function */
-/* alternate-debugging-output ＠ 429542' -slb */
+
+/* I don't like seeing `Note: Strange doc (not fboundp) for function
+ alternate-debugging-output ＠ 429542' -slb */
+/* #### Eek! Any clue how to get rid of it? In fact, how about
+ getting rid of this function altogether? Does anything actually
+ *use* it? --hniksic */
+
int alternate_do_pointer;
char alternate_do_string[5000];
＠＠ -1462,7 +1470,7 ＠＠
alternate_do_string[alternate_do_pointer] = 0;
return character;
}
-/* #endif /* DEBUG_XEMACS */
+/* #endif / * DEBUG_XEMACS */
DEFUN ("external-debugging-output", Fexternal_debugging_output, 1, 3, 0, /*
Write CHAR-OR-STRING to stderr or stdout.
--- src/redisplay.c.orig Thu Apr 30 22:19:52 1998
+++ src/redisplay.c Thu Apr 30 22:20:45 1998
＠＠ -6319,18 +6319,11 ＠＠
/* print the current column */
case 'c':
{
- int col = current_column (b) + (column_number_start_at_one != 0);
+ int col = current_column (b) + !!column_number_start_at_one;
int temp = col;
int size = 2;
- char *buf;
+ char buf[32];
- while (temp >= 10)
- {
- temp /= 10;
- size++;
- }
-
- buf = alloca_array (char, size);
long_to_string (buf, col);
Dynarr_add_many (mode_spec_bufbyte_string,
--- lisp/files.el.orig Fri May 1 00:57:07 1998
+++ lisp/files.el Fri May 1 02:24:15 1998
＠＠ -23,7 +23,7 ＠＠
;; Software Foundation, Inc. 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.
-;;; Synched up with: FSF 19.34 [Partial].
+;;; Synched up with: FSF 20.3 (but diverging)
;;; Warning: Merging this file is tough. Beware.
;;; Commentary:
＠＠ -496,85 +496,7 ＠＠
; We have this in C and use the realpath() system call.
;(defun file-truename (filename &optional counter prev-dirs)
-; "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.
-;
-;The arguments COUNTER and PREV-DIRS are used only in recursive calls.
-;Do not specify them in other calls."
-; ;; COUNTER can be a cons cell whose car is the count of how many more links
-; ;; to chase before getting an error.
-; ;; PREV-DIRS can be a cons cell whose car is an alist
-; ;; of truenames we've just recently computed.
-; ;; The last test looks dubious, maybe `+' is meant here? --simon.
-; (if (or (string= filename "") (string= filename "~")
-; (and (string= (substring filename 0 1) "~")
-; (string-match "~[^/]*" filename)))
-; (progn
-; (setq filename (expand-file-name filename))
-; (if (string= filename "")
-; (setq filename "/"))))
-; (or counter (setq counter (list 100)))
-; (let (done
-; ;; For speed, remove the ange-ftp completion handler from the list.
-; ;; We know it's not needed here.
-; ;; For even more speed, do this only on the outermost call.
-; (file-name-handler-alist
-; (if prev-dirs file-name-handler-alist
-; (let ((tem (copy-sequence file-name-handler-alist)))
-; (delq (rassq 'ange-ftp-completion-hook-function tem) tem)))))
-; (or prev-dirs (setq prev-dirs (list nil)))
-; ;; If this file directly leads to a link, process that iteratively
-; ;; so that we don't use lots of stack.
-; (while (not done)
-; (setcar counter (1- (car counter)))
-; (if (< (car counter) 0)
-; (error "Apparent cycle of symbolic links for %s" 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
-; (setq filename (funcall handler 'file-truename filename)
-; done t)
-; (let ((dir (or (file-name-directory filename) default-directory))
-; target dirfile)
-; ;; 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)
-; ;; If this is the same dir we last got the truename for,
-; ;; save time--don't recalculate.
-; (if (assoc dir (car prev-dirs))
-; (setq dir (cdr (assoc dir (car prev-dirs))))
-; (let ((old dir)
-; (new (file-name-as-directory (file-truename dirfile counter prev-dirs))))
-; (setcar prev-dirs (cons (cons old new) (car prev-dirs)))
-; (setq dir new))))
-; (if (equal ".." (file-name-nondirectory filename))
-; (setq filename
-; (directory-file-name (file-name-directory (directory-file-name dir)))
-; done t)
-; (if (equal "." (file-name-nondirectory filename))
-; (setq filename (directory-file-name dir)
-; done t)
-; ;; 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.
-; (setq filename
-; (if (file-name-absolute-p target)
-; target
-; (concat dir target))
-; done nil)
-; ;; No, we are done!
-; (setq done t))))))))
+; [... lots of code snipped ...]
; filename))
;; XEmacs addition. Called from `insert-file-contents-internal'
＠＠ -610,28 +532,29 ＠＠
unlike `file-truename'."
(let (tem (count 100) (newname filename))
(while (setq tem (file-symlink-p newname))
- (if (= count 0)
- (error "Apparent cycle of symbolic links for %s" filename))
- ;; In the context of a link, `//' doesn't mean what XEmacs thinks.
- (while (string-match "//+" tem)
- (setq tem (concat (substring tem 0 (1+ (match-beginning 0)))
- (substring tem (match-end 0)))))
- ;; Handle `..' by hand, since it needs to work in the
- ;; target of any directory symlink.
- ;; This code is not quite complete; it does not handle
- ;; embedded .. in some cases such as ./../foo and foo/bar/../../../lose.
- (while (string-match "\\`\\.\\./" tem) ;#### Unix specific
- (setq tem (substring tem 3))
- (setq newname (file-name-as-directory
- ;; Do the .. by hand.
- (directory-file-name
- (file-name-directory
- ;; Chase links in the default dir of the symlink.
- (file-chase-links
- (directory-file-name
- (file-name-directory newname))))))))
- (setq newname (expand-file-name tem (file-name-directory newname)))
- (setq count (1- count)))
+ (save-match-data
+ (if (= count 0)
+ (error "Apparent cycle of symbolic links for %s" filename))
+ ;; In the context of a link, `//' doesn't mean what XEmacs thinks.
+ (while (string-match "//+" tem)
+ (setq tem (concat (substring tem 0 (1+ (match-beginning 0)))
+ (substring tem (match-end 0)))))
+ ;; Handle `..' by hand, since it needs to work in the
+ ;; target of any directory symlink.
+ ;; This code is not quite complete; it does not handle
+ ;; embedded .. in some cases such as ./../foo and foo/bar/../../../lose.
+ (while (string-match "\\`\\.\\./" tem) ;#### Unix specific
+ (setq tem (substring tem 3))
+ (setq newname (file-name-as-directory
+ ;; Do the .. by hand.
+ (directory-file-name
+ (file-name-directory
+ ;; Chase links in the default dir of the symlink.
+ (file-chase-links
+ (directory-file-name
+ (file-name-directory newname))))))))
+ (setq newname (expand-file-name tem (file-name-directory newname)))
+ (setq count (1- count))))
newname))
(defun switch-to-other-buffer (arg)
＠＠ -913,6 +836,7 ＠＠
;; This function is needed by FSF vc.el. I hope somebody can make it
;; work for XEmacs. -sb.
+;; #### In what way does it not work? --hniksic
(defun find-buffer-visiting (filename)
"Return the buffer visiting file FILENAME (a string).
This is like `get-file-buffer', except that it checks for any buffer
＠＠ -974,20 +898,18 ＠＠
If a buffer exists visiting FILENAME, return that one, but
verify that the file has not changed since visited or saved.
The buffer is not selected, just returned to the caller.
-If NOWARN is non-nil, warning messages about several potential
-problems will be suppressed."
+If NOWARN is non-nil, warning messages will be suppressed.
+If RAWFILE is non-nil, the file is read literally."
(setq filename (abbreviate-file-name (expand-file-name filename)))
(if (file-directory-p filename)
(if (and (fboundp 'dired-noselect) find-file-run-dired)
(dired-noselect (if find-file-use-truenames
(abbreviate-file-name (file-truename filename))
filename))
- (error "%s is a directory." filename))
+ (error "%s is a directory" filename))
(let* ((buf (get-file-buffer filename))
(truename (abbreviate-file-name (file-truename filename)))
- (number (nthcdr 10 (file-attributes (file-truename filename))))
-; (number (and buffer-file-truename
-; (nthcdr 10 (file-attributes buffer-file-truename))))
+ (number (nthcdr 10 (file-attributes truename)))
; ;; Find any buffer for a file which has same truename.
; (other (and (not buf) (find-buffer-visiting filename)))
(error nil))
＠＠ -1022,10 +944,9 ＠＠
;; Certain files should be reverted automatically
;; if they have changed on disk and not in the buffer.
((and (not (buffer-modified-p buf))
- (let (found)
- (dolist (rx revert-without-query found)
- (when (string-match rx filename)
- (setq found t)))))
+ (dolist (rx revert-without-query nil)
+ (when (string-match rx filename)
+ (return t))))
(with-current-buffer buf
(message "Reverting file %s..." filename)
(revert-buffer t t)
＠＠ -1044,8 +965,7 ＠＠
(gettext "File %s changed on disk. Reread from disk into %s? "))
(file-name-nondirectory filename)
(buffer-name buf))))
- (save-excursion
- (set-buffer buf)
+ (with-current-buffer buf
(revert-buffer t t)))))
;; Else: we must create a new buffer for filename
(save-excursion
＠＠ -1064,15 +984,23 ＠＠
(condition-case ()
(insert-file-contents-literally filename t)
(file-error
+ (when (and (file-exists-p filename)
+ (not (file-readable-p filename)))
+ (kill-buffer buf)
+ (signal 'file-error (list "File is not readable" filename)))
;; Unconditionally set error
(setq error t)))
- (condition-case e
+ (condition-case ()
(insert-file-contents filename t)
(file-error
+ (when (and (file-exists-p filename)
+ (not (file-readable-p filename)))
+ (kill-buffer buf)
+ (signal 'file-error (list "File is not readable" filename)))
;; Run find-file-not-found-hooks until one returns non-nil.
(or (run-hook-with-args-until-success 'find-file-not-found-hooks)
;; If they fail too, set error.
- (setq error e)))))
+ (setq error t)))))
;; Find the file's truename, and maybe use that as visited name.
;; automatically computed in XEmacs, unless jka-compr was used!
(unless buffer-file-truename
＠＠ -1087,10 +1015,6 ＠＠
0 (match-beginning 0))))
(not (member logical find-file-not-true-dirname-list)))
(setq buffer-file-name buffer-file-truename))
-; (if find-file-visit-truename
-; (setq buffer-file-name
-; (setq filename
-; (expand-file-name buffer-file-truename))))
(and find-file-use-truenames
;; This should be in C. Put pathname abbreviations that have
;; been explicitly requested back into the pathname. Most
＠＠ -1106,11 +1030,16 ＠＠
(make-local-variable 'backup-inhibited)
(setq backup-inhibited t)))
(if rawfile
+ ;; #### FSF 20.3 sets buffer-file-coding-system to
+ ;; `no-conversion' here. Should we copy? It also makes
+ ;; `find-file-literally' a local variable and sets it to t.
nil
(after-find-file error (not nowarn))
(setq buf (current-buffer)))))
buf)))
+;; FSF has `insert-file-literally' and `find-file-literally' here.
+
(defvar after-find-file-from-revert-buffer nil)
(defun after-find-file (&optional error warn noauto
＠＠ -1195,8 +1124,9 ＠＠
nil))
(condition-case err
(hack-local-variables (not find-file))
- (error (message "File local-variables error: %s"
- (prin1-to-string err))))))
+ (error (lwarn 'local-variables 'warning
+ "File local-variables error: %s"
+ (error-message-string err))))))
(defvar auto-mode-alist
'(("\\.te?xt\\'" . text-mode)
＠＠ -1288,7 +1218,7 ＠＠
calling FUNCTION (if it's not nil), we delete the suffix that matched
REGEXP and search the list again for another match.")
-(defconst interpreter-mode-alist
+(defvar interpreter-mode-alist
'(("^#!.*csh" . sh-mode)
("^#!.*sh\\b" . sh-mode)
("^#!.*\\b\\(scope\\|wish\\|tcl\\|expect\\)" . tcl-mode)
＠＠ -1312,10 +1242,10 ＠＠
with the name of the interpreter specified in the first line.
If it matches, mode MODE is selected.")
-(defconst inhibit-first-line-modes-regexps (purecopy '("\\.tar\\'"))
+(defvar inhibit-first-line-modes-regexps (purecopy '("\\.tar\\'"
"\\.tgz\\'"))
"List of regexps; if one matches a file name, don't look for
`-*-'.")
-(defconst inhibit-first-line-modes-suffixes nil
+(defvar inhibit-first-line-modes-suffixes nil
"List of regexps for what to ignore, for `inhibit-first-line-modes-regexps'.
When checking `inhibit-first-line-modes-regexps', we first discard
from the end of the file name anything that matches one of these regexps.")
＠＠ -1324,7 +1254,7 ＠＠
"" ; set by command-line
"File name including directory of user's initialization file.")
-(defun set-auto-mode ()
+(defun set-auto-mode (&optional just-from-file-name)
"Select major mode appropriate for current buffer.
This checks for a -*- mode tag in the buffer's text,
compares the filename against the entries in `auto-mode-alist',
＠＠ -1335,7 +1265,11 ＠＠
Local Variables section of the file; for that, use `hack-local-variables'.
If `enable-local-variables' is nil, this function does not check for a
--*- mode tag."
+-*- mode tag.
+
+If the optional argument JUST-FROM-FILE-NAME is non-nil,
+then we do not set anything but the major mode,
+and we don't even do that unless it would come from the file name."
(save-excursion
;; Look for -*-MODENAME-*- or -*- ... mode: MODENAME; ... -*-
;; Do this by calling the hack-local-variables helper to avoid redundancy.
＠＠ -1370,24 +1304,25 ＠＠
(setq mode (cdr (car alist))
keep-going nil)))
(setq alist (cdr alist))))
- ;; If we can't deduce a mode from the file name,
- ;; look for an interpreter specified in the first line.
- (if (and (null mode)
- (save-excursion ; XEmacs
- (goto-char (point-min))
- (looking-at "#!")))
- (let ((firstline
- (buffer-substring
- (point-min)
- (save-excursion
- (goto-char (point-min)) (end-of-line) (point)))))
- (setq alist interpreter-mode-alist)
- (while alist
- (if (string-match (car (car alist)) firstline)
- (progn
- (setq mode (cdr (car alist)))
- (setq alist nil))
- (setq alist (cdr alist))))))
+ (unless just-from-file-name
+ ;; If we can't deduce a mode from the file name,
+ ;; look for an interpreter specified in the first line.
+ (if (and (null mode)
+ (save-excursion ; XEmacs
+ (goto-char (point-min))
+ (looking-at "#!")))
+ (let ((firstline
+ (buffer-substring
+ (point-min)
+ (save-excursion
+ (goto-char (point-min)) (end-of-line) (point)))))
+ (setq alist interpreter-mode-alist)
+ (while alist
+ (if (string-match (car (car alist)) firstline)
+ (progn
+ (setq mode (cdr (car alist)))
+ (setq alist nil))
+ (setq alist (cdr alist)))))))
(if mode
(if (not (fboundp mode))
(progn
＠＠ -1401,8 +1336,13 ＠＠
(message "Mode %s either doesn't exist or is not a known package"
mode))
(sit-for 2)
(error "%s" mode)))
- (funcall mode)))
- ))))))
+ (unless (and just-from-file-name
+ (or
+ ;; Don't reinvoke major mode.
+ (eq mode major-mode)
+ ;; Don't lose on minor modes.
+ (assq mode minor-mode-alist)))
+ (funcall mode))))))))))
(defvar hack-local-variables-hook nil
"Normal hook run after processing a file's local variables specs.
＠＠ -1718,12 +1658,28 ＠＠
(t (make-local-variable var)
(set var val))))
-(defun set-visited-file-name (filename)
+(defcustom change-major-mode-with-file-name t
+ "*Non-nil means \\[write-file] should set the major mode from the file name.
+However, the mode will not be changed if
+\(1) a local variables list or the `-*-' line specifies a major mode, or
+\(2) the current major mode is a \"special\" mode,
+\ not suitable for ordinary files, or
+\(3) the new file name does not particularly specify any mode."
+ :type 'boolean
+ :group 'editing-basics)
+
+(defun set-visited-file-name (filename &optional no-query along-with-file)
"Change name of file visited in current buffer to FILENAME.
The next time the buffer is saved it will go in the newly specified file.
nil or empty string as argument means make buffer not be visiting any file.
Remember to delete the initial contents of the minibuffer
-if you wish to pass an empty string as the argument."
+if you wish to pass an empty string as the argument.
+
+The optional second argument NO-QUERY, if non-nil, inhibits asking for
+confirmation in the case where another buffer is already visiting FILENAME.
+
+The optional third argument ALONG-WITH-FILE, if non-nil, means that
+the old visited file has been renamed to the new name FILENAME."
(interactive "FSet visited file name: ")
(if (buffer-base-buffer)
(error "An indirect buffer cannot visit a file"))
＠＠ -1739,6 +1695,12 ＠＠
;; #### Do we need to check if truename is non-nil?
(if find-file-use-truenames
(setq filename truename))))
+ (let ((buffer (and filename (find-buffer-visiting filename))))
+ (and buffer (not (eq buffer (current-buffer)))
+ (not no-query)
+ (not (y-or-n-p (message "A buffer is visiting %s; proceed? "
+ filename)))
+ (error "Aborted")))
(or (equal filename buffer-file-name)
(progn
(and filename (lock-buffer filename))
＠＠ -1754,7 +1716,8 ＠＠
(or (string= new-name (buffer-name))
(rename-buffer new-name t))))
(setq buffer-backed-up nil)
- (clear-visited-file-modtime)
+ (or along-with-file
+ (clear-visited-file-modtime))
(compute-buffer-file-truename) ; insert-file-contents does this too.
; ;; Abbreviate the file names of the buffer.
; (if truename
＠＠ -1777,12 +1740,14 ＠＠
(kill-local-variable 'backup-inhibited)
;; If buffer was read-only because of version control,
;; that reason is gone now, so make it writable.
- (if (and (boundp 'vc-mode) vc-mode)
- (setq buffer-read-only nil))
- (kill-local-variable 'vc-mode)
+ (when (boundp 'vc-mode)
+ (if vc-mode
+ (setq buffer-read-only nil))
+ (kill-local-variable 'vc-mode))
;; Turn off backup files for certain file names.
;; Since this is a permanent local, the major mode won't eliminate it.
- (and (not (funcall backup-enable-predicate buffer-file-name))
+ (and buffer-file-name
+ (not (funcall backup-enable-predicate buffer-file-name))
(progn
(make-local-variable 'backup-inhibited)
(setq backup-inhibited t)))
＠＠ -1803,7 +1768,17 ＠＠
(file-exists-p oauto)
(rename-file oauto buffer-auto-save-file-name t)))
(if buffer-file-name
+ (not along-with-file)
(set-buffer-modified-p t))
+ ;; Update the major mode, if the file name determines it.
+ (condition-case nil
+ ;; Don't change the mode if it is special.
+ (or (not change-major-mode-with-file-name)
+ (get major-mode 'mode-class)
+ ;; Don't change the mode if the local variable list specifies it.
+ (hack-local-variables t)
+ (set-auto-mode t))
+ (error nil))
;; #### ??
(run-hooks 'after-set-visited-file-name-hooks))
＠＠ -1994,6 +1969,22 ＠＠
(substring file 0 (match-beginning 0)))
filename))))
+(defun file-name-extension (filename &optional period)
+ "Return FILENAME's final \"extension\".
+The extension, in a file name, is the part that follows the last `.'.
+Return nil for extensionless file names such as `foo'.
+Return the empty string for file names such as `foo.'.
+
+If PERIOD is non-nil, then the returned value includes the period
+that delimits the extension, and if FILENAME has no extension,
+the value is \"\"."
+ (save-match-data
+ (let ((file (file-name-sans-versions (file-name-nondirectory filename))))
+ (if (string-match "\\.[^.]*\\'" file)
+ (substring file (+ (match-beginning 0) (if period 0 1)))
+ (if period
+ "")))))
+
(defun make-backup-file-name (file)
"Create the non-numeric backup file name for FILE.
This is a separate function so you can redefine it for customization."
＠＠ -2081,15 +2072,43 ＠＠
(car (cdr (file-attributes filename))))
(defun file-relative-name (filename &optional directory)
- "Convert FILENAME to be relative to DIRECTORY (default: default-directory)."
- (setq filename (expand-file-name filename)
- directory (file-name-as-directory (expand-file-name
- (or directory default-directory))))
- (let ((ancestor ""))
- (while (not (string-match (concat "^" (regexp-quote directory)) filename))
- (setq directory (file-name-directory (substring directory 0 -1))
- ancestor (concat "../" ancestor)))
- (concat ancestor (substring filename (match-end 0)))))
+ "Convert FILENAME to be relative to DIRECTORY (default: default-directory).1
+This function returns a relative file name which is equivalent to FILENAME
+when used with that default directory as the default.
+If this is impossible (which can happen on MSDOS and Windows
+when the file name and directory use different drive names)
+then it returns FILENAME."
+ (save-match-data
+ (let ((fname (expand-file-name filename)))
+ (setq directory (file-name-as-directory
+ (expand-file-name (or directory default-directory))))
+ ;; On Microsoft OSes, if FILENAME and DIRECTORY have different
+ ;; drive names, they can't be relative, so return the absolute name.
+ (if (and (or (eq system-type 'ms-dos)
+ (eq system-type 'windows-nt))
+ (not (string-equal (substring fname 0 2)
+ (substring directory 0 2))))
+ filename
+ (let ((ancestor ".")
+ (fname-dir (file-name-as-directory fname)))
+ (while (and (not (string-match (concat "^" (regexp-quote directory))
fname-dir))
+ (not (string-match (concat "^" (regexp-quote directory)) fname)))
+ (setq directory (file-name-directory (substring directory 0 -1))
+ ancestor (if (equal ancestor ".")
+ ".."
+ (concat "../" ancestor))))
+ ;; Now ancestor is empty, or .., or ../.., etc.
+ (if (string-match (concat "^" (regexp-quote directory)) fname)
+ ;; We matched within FNAME's directory part.
+ ;; Add the rest of FNAME onto ANCESTOR.
+ (let ((rest (substring fname (match-end 0))))
+ (if (and (equal ancestor ".")
+ (not (equal rest "")))
+ ;; But don't bother with ANCESTOR if it would give us `./'.
+ rest
+ (concat (file-name-as-directory ancestor) rest)))
+ ;; We matched FNAME's directory equivalent.
+ ancestor))))))
(defun save-buffer (&optional args)
"Save current buffer in visited file if modified. Versions described below.
＠＠ -2419,16 +2438,20 ＠＠
;; (it makes the dialog box too big, and you get an error
;; "wrong type argument: framep, nil" when you hit q after
;; choosing the option from the dialog box)
-; (list (list ?\C-r (lambda (buf)
-; (view-buffer buf)
-; (setq view-exit-action
-; '(lambda (ignore)
-; (exit-recursive-edit)))
-; (recursive-edit)
-; ;; Return nil to ask about BUF again.
-; nil)
-; "display the current buffer"))
- ))
+
+ ;; We should fix the dialog box rather than disabling
+ ;; this! --hniksic
+ (list (list ?\C-r (lambda (buf)
+ ;; FSF has an EXIT-ACTION argument to
+ ;; `view-buffer'.
+ (view-buffer buf)
+ (setq view-exit-action
+ (lambda (ignore)
+ (exit-recursive-edit)))
+ (recursive-edit)
+ ;; Return nil to ask about BUF again.
+ nil)
+ "display the current buffer"))))
(abbrevs-done
(and save-abbrevs abbrevs-changed
(progn
＠＠ -2623,10 +2646,11 ＠＠
the files modes. Normally we reinitialize them using `normal-mode'.
If the value of `revert-buffer-function' is non-nil, it is called to
-do the work.
+do all the work for this command. Otherwise, the hooks
+`before-revert-hook' and `after-revert-hook' are run at the beginning
+and the end, and if `revert-buffer-insert-file-contents-function' is
+non-nil, it is called instead of rereading visited file contents."
-The default revert function runs the hook `before-revert-hook' at the
-beginning and `after-revert-hook' at the end."
;; I admit it's odd to reverse the sense of the prefix argument, but
;; there is a lot of code out there which assumes that the first
;; argument should be t to avoid consulting the auto-save file, and
＠＠ -2752,6 +2776,9 ＠＠
(interactive)
(unless (fboundp 'dired)
(error "recover-session requires dired"))
+ (if (null auto-save-list-file-prefix)
+ (error
+ "You set `auto-save-list-file-prefix' to disable making session
files"))
(dired (concat auto-save-list-file-prefix "*"))
(goto-char (point-min))
(or (looking-at "Move to the session you want to recover,")
＠＠ -2839,23 +2866,25 ＠＠
(message "No files can be recovered from this session now")))
(kill-buffer buffer))))
-(defun kill-some-buffers ()
- "For each buffer, ask whether to kill it."
+(defun kill-some-buffers (&optional list)
+ "For each buffer in LIST, ask whether to kill it.
+LIST defaults to all existing live buffers."
(interactive)
- (let ((list (buffer-list)))
- (while list
- (let* ((buffer (car list))
- (name (buffer-name buffer)))
- (and (not (string-equal name ""))
- (/= (aref name 0) ? )
- (yes-or-no-p
- (format
- (if (buffer-modified-p buffer)
- (gettext "Buffer %s HAS BEEN EDITED. Kill? ")
- (gettext "Buffer %s is unmodified. Kill? "))
- name))
- (kill-buffer buffer)))
- (setq list (cdr list)))))
+ (if (null list)
+ (setq list (buffer-list)))
+ (while list
+ (let* ((buffer (car list))
+ (name (buffer-name buffer)))
+ (and (not (string-equal name ""))
+ (/= (aref name 0) ?\ )
+ (yes-or-no-p
+ (format
+ (if (buffer-modified-p buffer)
+ (gettext "Buffer %s HAS BEEN EDITED. Kill? ")
+ (gettext "Buffer %s is unmodified. Kill? "))
+ name))
+ (kill-buffer buffer)))
+ (setq list (cdr list))))
(defun auto-save-mode (arg)
"Toggle auto-saving of contents of current buffer.
＠＠ -3226,5 +3255,7 ＠＠
((featurep 'ange-ftp) (ange-ftp-ftp-path file-name))
((fboundp 'efs-ftp-path) (efs-ftp-path file-name))
(t nil)))
+
+;; #### FSF has file-name-non-special here.
;;; files.el ends here
--
Hrvoje Niksic <hniksic(a)srce.hr> | Student at FER Zagreb, Croatia
--------------------------------+--------------------------------
Personifiers Unite! You have nothing to lose but Mr. Dignity!