2 Copyright (C) 1985-1988, 1992-1995 Free Software Foundation, Inc.
3 Copyright (C) 1996 Ben Wing.
5 This file is part of XEmacs.
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 /* Synched up with: Mule 2.0, FSF 19.30. */
23 /* More syncing: FSF Emacs 19.34.6 by Marc Paquette <marcpa@cam.org> */
33 #include "redisplay.h"
35 #include "window.h" /* minibuf_level */
37 #include "file-coding.h"
40 #ifdef HAVE_LIBGEN_H /* Must come before sysfile.h */
53 #endif /* HPUX_PRE_8_0 */
56 #if defined(WIN32_NATIVE) || defined(CYGWIN)
57 #define WIN32_FILENAMES
60 #endif /* WIN32_NATIVE */
61 #define IS_DRIVE(x) isalpha (x)
62 /* Need to lower-case the drive letter, or else expanded
63 filenames will sometimes compare inequal, because
64 `expand-file-name' doesn't always down-case the drive letter. */
65 #define DRIVE_LETTER(x) tolower (x)
66 #ifndef CORRECT_DIR_SEPS
67 #define CORRECT_DIR_SEPS(s) \
68 normalize_filename(s, DIRECTORY_SEP)
69 /* Default implementation that coerces a file to use path_sep. */
71 normalize_filename (Bufbyte *fp, Bufbyte path_sep)
73 /* Always lower-case drive letters a-z, even if the filesystem
74 preserves case in filenames.
75 This is so filenames can be compared by string comparison
76 functions that are case-sensitive. Even case-preserving filesystems
77 do not distinguish case in drive letters. */
78 if (fp[1] == ':' && *fp >= 'A' && *fp <= 'Z')
86 if (*fp == '/' || *fp == '\\')
91 #endif /* CORRECT_DIR_SEPS */
92 #endif /* WIN32_NATIVE || CYGWIN */
94 int lisp_to_time (Lisp_Object, time_t *);
95 Lisp_Object time_to_lisp (time_t);
97 /* Nonzero during writing of auto-save files */
98 static int auto_saving;
100 /* Set by auto_save_1 to mode of original file so Fwrite_region_internal
101 will create a new file with the same mode as the original */
102 static int auto_save_mode_bits;
104 /* Alist of elements (REGEXP . HANDLER) for file names
105 whose I/O is done with a special handler. */
106 Lisp_Object Vfile_name_handler_alist;
108 /* Format for auto-save files */
109 Lisp_Object Vauto_save_file_format;
111 /* Lisp functions for translating file formats */
112 Lisp_Object Qformat_decode, Qformat_annotate_function;
114 /* Functions to be called to process text properties in inserted file. */
115 Lisp_Object Vafter_insert_file_functions;
117 /* Functions to be called to create text property annotations for file. */
118 Lisp_Object Vwrite_region_annotate_functions;
120 /* During build_annotations, each time an annotation function is called,
121 this holds the annotations made by the previous functions. */
122 Lisp_Object Vwrite_region_annotations_so_far;
124 /* File name in which we write a list of all our auto save files. */
125 Lisp_Object Vauto_save_list_file_name;
127 /* Prefix used to construct Vauto_save_list_file_name. */
128 Lisp_Object Vauto_save_list_file_prefix;
130 /* When non-nil, it prevents auto-save list file creation. */
131 int inhibit_auto_save_session;
133 int disable_auto_save_when_buffer_shrinks;
135 Lisp_Object Vdirectory_sep_char;
137 /* These variables describe handlers that have "already" had a chance
138 to handle the current operation.
140 Vinhibit_file_name_handlers is a list of file name handlers.
141 Vinhibit_file_name_operation is the operation being handled.
142 If we try to handle that operation, we ignore those handlers. */
144 static Lisp_Object Vinhibit_file_name_handlers;
145 static Lisp_Object Vinhibit_file_name_operation;
147 Lisp_Object Qfile_error, Qfile_already_exists;
149 Lisp_Object Qauto_save_hook;
150 Lisp_Object Qauto_save_error;
151 Lisp_Object Qauto_saving;
153 Lisp_Object Qcar_less_than_car;
155 Lisp_Object Qcompute_buffer_file_truename;
157 EXFUN (Frunning_temacs_p, 0);
159 /* signal a file error when errno contains a meaningful value. */
162 report_file_error (const char *string, Lisp_Object data)
164 /* #### dmoore - This uses current_buffer, better make sure no one
165 has GC'd the current buffer. File handlers are giving me a headache
166 maybe I'll just always protect current_buffer around all of those
169 signal_error (Qfile_error,
170 Fcons (build_translated_string (string),
171 Fcons (lisp_strerror (errno), data)));
175 maybe_report_file_error (const char *string, Lisp_Object data,
176 Lisp_Object class, Error_behavior errb)
179 if (ERRB_EQ (errb, ERROR_ME_NOT))
182 maybe_signal_error (Qfile_error,
183 Fcons (build_translated_string (string),
184 Fcons (lisp_strerror (errno), data)),
188 /* signal a file error when errno does not contain a meaningful value. */
191 signal_file_error (const char *string, Lisp_Object data)
193 signal_error (Qfile_error,
194 list2 (build_translated_string (string), data));
198 maybe_signal_file_error (const char *string, Lisp_Object data,
199 Lisp_Object class, Error_behavior errb)
202 if (ERRB_EQ (errb, ERROR_ME_NOT))
204 maybe_signal_error (Qfile_error,
205 list2 (build_translated_string (string), data),
210 signal_double_file_error (const char *string1, const char *string2,
213 signal_error (Qfile_error,
214 list3 (build_translated_string (string1),
215 build_translated_string (string2),
220 maybe_signal_double_file_error (const char *string1, const char *string2,
221 Lisp_Object data, Lisp_Object class,
225 if (ERRB_EQ (errb, ERROR_ME_NOT))
227 maybe_signal_error (Qfile_error,
228 list3 (build_translated_string (string1),
229 build_translated_string (string2),
235 signal_double_file_error_2 (const char *string1, const char *string2,
236 Lisp_Object data1, Lisp_Object data2)
238 signal_error (Qfile_error,
239 list4 (build_translated_string (string1),
240 build_translated_string (string2),
245 maybe_signal_double_file_error_2 (const char *string1, const char *string2,
246 Lisp_Object data1, Lisp_Object data2,
247 Lisp_Object class, Error_behavior errb)
250 if (ERRB_EQ (errb, ERROR_ME_NOT))
252 maybe_signal_error (Qfile_error,
253 list4 (build_translated_string (string1),
254 build_translated_string (string2),
260 /* Just like strerror(3), except return a lisp string instead of char *.
261 The string needs to be converted since it may be localized.
262 Perhaps this should use strerror-coding-system instead? */
264 lisp_strerror (int errnum)
266 return build_ext_string (strerror (errnum), Qnative);
270 close_file_unwind (Lisp_Object fd)
274 if (INTP (XCAR (fd)))
275 close (XINT (XCAR (fd)));
277 free_cons (XCONS (fd));
286 delete_stream_unwind (Lisp_Object stream)
288 Lstream_delete (XLSTREAM (stream));
292 /* Restore point, having saved it as a marker. */
295 restore_point_unwind (Lisp_Object point_marker)
297 BUF_SET_PT (current_buffer, marker_position (point_marker));
298 return Fset_marker (point_marker, Qnil, Qnil);
301 /* Versions of read() and write() that allow quitting out of the actual
302 I/O. We don't use immediate_quit (i.e. direct longjmp() out of the
303 signal handler) because that's way too losing.
305 (#### Actually, longjmp()ing out of the signal handler may not be
306 as losing as I thought. See sys_do_signal() in sysdep.c.) */
309 read_allowing_quit (int fildes, void *buf, size_t size)
312 return sys_read_1 (fildes, buf, size, 1);
316 write_allowing_quit (int fildes, const void *buf, size_t size)
319 return sys_write_1 (fildes, buf, size, 1);
323 Lisp_Object Qexpand_file_name;
324 Lisp_Object Qfile_truename;
325 Lisp_Object Qsubstitute_in_file_name;
326 Lisp_Object Qdirectory_file_name;
327 Lisp_Object Qfile_name_directory;
328 Lisp_Object Qfile_name_nondirectory;
329 Lisp_Object Qunhandled_file_name_directory;
330 Lisp_Object Qfile_name_as_directory;
331 Lisp_Object Qcopy_file;
332 Lisp_Object Qmake_directory_internal;
333 Lisp_Object Qdelete_directory;
334 Lisp_Object Qdelete_file;
335 Lisp_Object Qrename_file;
336 Lisp_Object Qadd_name_to_file;
337 Lisp_Object Qmake_symbolic_link;
338 Lisp_Object Qfile_exists_p;
339 Lisp_Object Qfile_executable_p;
340 Lisp_Object Qfile_readable_p;
341 Lisp_Object Qfile_symlink_p;
342 Lisp_Object Qfile_writable_p;
343 Lisp_Object Qfile_directory_p;
344 Lisp_Object Qfile_regular_p;
345 Lisp_Object Qfile_accessible_directory_p;
346 Lisp_Object Qfile_modes;
347 Lisp_Object Qset_file_modes;
348 Lisp_Object Qfile_newer_than_file_p;
349 Lisp_Object Qinsert_file_contents;
350 Lisp_Object Qwrite_region;
351 Lisp_Object Qverify_visited_file_modtime;
352 Lisp_Object Qset_visited_file_modtime;
354 /* If FILENAME is handled specially on account of its syntax,
355 return its handler function. Otherwise, return nil. */
357 DEFUN ("find-file-name-handler", Ffind_file_name_handler, 1, 2, 0, /*
358 Return FILENAME's handler function for OPERATION, if it has one.
359 Otherwise, return nil.
360 A file name is handled if one of the regular expressions in
361 `file-name-handler-alist' matches it.
363 If OPERATION equals `inhibit-file-name-operation', then we ignore
364 any handlers that are members of `inhibit-file-name-handlers',
365 but we still do run any other handlers. This lets handlers
366 use the standard functions without calling themselves recursively.
368 (filename, operation))
370 /* This function does not GC */
371 /* This function can be called during GC */
372 /* This function must not munge the match data. */
373 Lisp_Object chain, inhibited_handlers;
375 CHECK_STRING (filename);
377 if (EQ (operation, Vinhibit_file_name_operation))
378 inhibited_handlers = Vinhibit_file_name_handlers;
380 inhibited_handlers = Qnil;
382 EXTERNAL_LIST_LOOP (chain, Vfile_name_handler_alist)
384 Lisp_Object elt = XCAR (chain);
387 Lisp_Object string = XCAR (elt);
389 && (fast_lisp_string_match (string, filename) >= 0))
391 Lisp_Object handler = XCDR (elt);
392 if (NILP (Fmemq (handler, inhibited_handlers)))
402 call2_check_string (Lisp_Object fn, Lisp_Object arg0, Lisp_Object arg1)
404 /* This function can call lisp */
405 Lisp_Object result = call2 (fn, arg0, arg1);
406 CHECK_STRING (result);
411 call2_check_string_or_nil (Lisp_Object fn, Lisp_Object arg0, Lisp_Object arg1)
413 /* This function can call lisp */
414 Lisp_Object result = call2 (fn, arg0, arg1);
416 CHECK_STRING (result);
421 call3_check_string (Lisp_Object fn, Lisp_Object arg0,
422 Lisp_Object arg1, Lisp_Object arg2)
424 /* This function can call lisp */
425 Lisp_Object result = call3 (fn, arg0, arg1, arg2);
426 CHECK_STRING (result);
431 DEFUN ("file-name-directory", Ffile_name_directory, 1, 1, 0, /*
432 Return the directory component in file name FILENAME.
433 Return nil if FILENAME does not include a directory.
434 Otherwise return a directory spec.
435 Given a Unix syntax file name, returns a string ending in slash.
439 /* This function can GC. GC checked 2000-07-28 ben */
444 CHECK_STRING (filename);
446 /* If the file name has special constructs in it,
447 call the corresponding file handler. */
448 handler = Ffind_file_name_handler (filename, Qfile_name_directory);
450 return call2_check_string_or_nil (handler, Qfile_name_directory, filename);
452 #ifdef FILE_SYSTEM_CASE
453 filename = FILE_SYSTEM_CASE (filename);
455 beg = XSTRING_DATA (filename);
456 p = beg + XSTRING_LENGTH (filename);
458 while (p != beg && !IS_ANY_SEP (p[-1])
459 #ifdef WIN32_FILENAMES
460 /* only recognize drive specifier at beginning */
461 && !(p[-1] == ':' && p == beg + 2)
468 /* Expansion of "c:" to drive and default directory. */
469 /* (NT does the right thing.) */
470 if (p == beg + 2 && beg[1] == ':')
472 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
473 Bufbyte *res = (Bufbyte*) alloca (MAXPATHLEN + 1);
474 if (_getdcwd (toupper (*beg) - 'A' + 1, (char *)res, MAXPATHLEN))
476 char *c=((char *) res) + strlen ((char *) res);
477 if (!IS_DIRECTORY_SEP (*c))
479 *c++ = DIRECTORY_SEP;
483 p = beg + strlen ((char *) beg);
486 #endif /* WIN32_NATIVE */
487 return make_string (beg, p - beg);
490 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory, 1, 1, 0, /*
491 Return file name FILENAME sans its directory.
492 For example, in a Unix-syntax file name,
493 this is everything after the last slash,
494 or the entire name if it contains no slash.
498 /* This function can GC. GC checked 2000-07-28 ben */
499 Bufbyte *beg, *p, *end;
502 CHECK_STRING (filename);
504 /* If the file name has special constructs in it,
505 call the corresponding file handler. */
506 handler = Ffind_file_name_handler (filename, Qfile_name_nondirectory);
508 return call2_check_string (handler, Qfile_name_nondirectory, filename);
510 beg = XSTRING_DATA (filename);
511 end = p = beg + XSTRING_LENGTH (filename);
513 while (p != beg && !IS_ANY_SEP (p[-1])
514 #ifdef WIN32_FILENAMES
515 /* only recognize drive specifier at beginning */
516 && !(p[-1] == ':' && p == beg + 2)
520 return make_string (p, end - p);
523 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory, 1, 1, 0, /*
524 Return a directly usable directory name somehow associated with FILENAME.
525 A `directly usable' directory name is one that may be used without the
526 intervention of any file handler.
527 If FILENAME is a directly usable file itself, return
528 \(file-name-directory FILENAME).
529 The `call-process' and `start-process' functions use this function to
530 get a current directory to run processes in.
534 /* This function can GC. GC checked 2000-07-28 ben */
537 /* If the file name has special constructs in it,
538 call the corresponding file handler. */
539 handler = Ffind_file_name_handler (filename, Qunhandled_file_name_directory);
541 return call2 (handler, Qunhandled_file_name_directory,
544 return Ffile_name_directory (filename);
549 file_name_as_directory (char *out, char *in)
551 /* This function cannot GC */
552 int size = strlen (in);
557 out[1] = DIRECTORY_SEP;
563 /* Append a slash if necessary */
564 if (!IS_ANY_SEP (out[size-1]))
566 out[size] = DIRECTORY_SEP;
567 out[size + 1] = '\0';
573 DEFUN ("file-name-as-directory", Ffile_name_as_directory, 1, 1, 0, /*
574 Return a string representing file FILENAME interpreted as a directory.
575 This operation exists because a directory is also a file, but its name as
576 a directory is different from its name as a file.
577 The result can be used as the value of `default-directory'
578 or passed as second argument to `expand-file-name'.
579 For a Unix-syntax file name, just appends a slash,
580 except for (file-name-as-directory \"\") => \"./\".
584 /* This function can GC. GC checked 2000-07-28 ben */
588 CHECK_STRING (filename);
590 /* If the file name has special constructs in it,
591 call the corresponding file handler. */
592 handler = Ffind_file_name_handler (filename, Qfile_name_as_directory);
594 return call2_check_string (handler, Qfile_name_as_directory, filename);
596 buf = (char *) alloca (XSTRING_LENGTH (filename) + 10);
597 return build_string (file_name_as_directory
598 (buf, (char *) XSTRING_DATA (filename)));
602 * Convert from directory name to filename.
603 * On UNIX, it's simple: just make sure there isn't a terminating /
605 * Value is nonzero if the string output is different from the input.
609 directory_file_name (const char *src, char *dst)
611 /* This function cannot GC */
612 long slen = strlen (src);
613 /* Process as Unix format: just remove any final slash.
614 But leave "/" unchanged; do not change it to "". */
617 && IS_DIRECTORY_SEP (dst[slen - 1])
618 #ifdef WIN32_FILENAMES
619 && !IS_ANY_SEP (dst[slen - 2])
620 #endif /* WIN32_FILENAMES */
626 DEFUN ("directory-file-name", Fdirectory_file_name, 1, 1, 0, /*
627 Return the file name of the directory named DIRECTORY.
628 This is the name of the file that holds the data for the directory.
629 This operation exists because a directory is also a file, but its name as
630 a directory is different from its name as a file.
631 In Unix-syntax, this function just removes the final slash.
635 /* This function can GC. GC checked 2000-07-28 ben */
639 CHECK_STRING (directory);
641 #if 0 /* #### WTF? */
642 if (NILP (directory))
646 /* If the file name has special constructs in it,
647 call the corresponding file handler. */
648 handler = Ffind_file_name_handler (directory, Qdirectory_file_name);
650 return call2_check_string (handler, Qdirectory_file_name, directory);
651 buf = (char *) alloca (XSTRING_LENGTH (directory) + 20);
652 directory_file_name ((char *) XSTRING_DATA (directory), buf);
653 return build_string (buf);
656 /* Fmake_temp_name used to be a simple wrapper around mktemp(), but it
657 proved too broken for our purposes (it supported only 26 or 62
658 unique names under some implementations). For example, this
659 arbitrary limit broke generation of Gnus Incoming* files.
661 This implementation is better than what one usually finds in libc.
664 static unsigned int temp_name_rand;
666 DEFUN ("make-temp-name", Fmake_temp_name, 1, 1, 0, /*
667 Generate a temporary file name starting with PREFIX.
668 The Emacs process number forms part of the result, so there is no
669 danger of generating a name being used by another process.
671 In addition, this function makes an attempt to choose a name that
672 does not specify an existing file. To make this work, PREFIX should
673 be an absolute file name.
677 static const char tbl[64] =
679 'A','B','C','D','E','F','G','H',
680 'I','J','K','L','M','N','O','P',
681 'Q','R','S','T','U','V','W','X',
682 'Y','Z','a','b','c','d','e','f',
683 'g','h','i','j','k','l','m','n',
684 'o','p','q','r','s','t','u','v',
685 'w','x','y','z','0','1','2','3',
686 '4','5','6','7','8','9','-','_'
693 CHECK_STRING (prefix);
695 /* I was tempted to apply Fexpand_file_name on PREFIX here, but it's
698 1) It might change the prefix, so the resulting string might not
699 begin with PREFIX. This violates the principle of least
702 2) It breaks under many unforeseeable circumstances, such as with
703 the code that uses (make-temp-name "") instead of
704 (make-temp-name "./").
706 3) It might yield unexpected (to stat(2)) results in the presence
707 of EFS and file name handlers. */
709 len = XSTRING_LENGTH (prefix);
710 val = make_uninit_string (len + 6);
711 data = XSTRING_DATA (val);
712 memcpy (data, XSTRING_DATA (prefix), len);
715 /* VAL is created by adding 6 characters to PREFIX. The first three
716 are the PID of this process, in base 64, and the second three are
717 a pseudo-random number seeded from process startup time. This
718 ensures 262144 unique file names per PID per PREFIX per machine. */
721 unsigned int pid = (unsigned int) getpid ();
722 *p++ = tbl[(pid >> 0) & 63];
723 *p++ = tbl[(pid >> 6) & 63];
724 *p++ = tbl[(pid >> 12) & 63];
727 /* Here we try to minimize useless stat'ing when this function is
728 invoked many times successively with the same PREFIX. We achieve
729 this by using a very pseudo-random number generator to generate
730 file names unique to this process, with a very long cycle. */
736 p[0] = tbl[(temp_name_rand >> 0) & 63];
737 p[1] = tbl[(temp_name_rand >> 6) & 63];
738 p[2] = tbl[(temp_name_rand >> 12) & 63];
740 /* Poor man's congruential RN generator. Replace with ++count
742 temp_name_rand += 25229;
743 temp_name_rand %= 225307;
747 if (xemacs_stat ((const char *) data, &ignored) < 0)
749 /* We want to return only if errno is ENOENT. */
753 /* The error here is dubious, but there is little else we
754 can do. The alternatives are to return nil, which is
755 as bad as (and in many cases worse than) throwing the
756 error, or to ignore the error, which will likely result
758 report_file_error ("Cannot create temporary name for prefix",
760 return Qnil; /* not reached */
766 DEFUN ("expand-file-name", Fexpand_file_name, 1, 2, 0, /*
767 Convert filename NAME to absolute, and canonicalize it.
768 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative
769 (does not start with slash); if DEFAULT-DIRECTORY is nil or missing,
770 the current buffer's value of `default-directory' is used.
771 File name components that are `.' are removed, and
772 so are file name components followed by `..', along with the `..' itself;
773 note that these simplifications are done without checking the resulting
774 file names in the file system.
775 An initial `~/' expands to your home directory.
776 An initial `~USER/' expands to USER's home directory.
777 See also the function `substitute-in-file-name'.
779 (name, default_directory))
781 /* This function can GC. GC-checked 2000-11-18 */
784 Bufbyte *newdir, *p, *o;
787 #ifdef WIN32_FILENAMES
789 int collapse_newdir = 1;
793 #endif /* WIN32_FILENAMES */
795 Lisp_Object handler = Qnil;
799 struct gcpro gcpro1, gcpro2, gcpro3;
801 /* both of these get set below */
802 GCPRO3 (name, default_directory, handler);
806 /* If the file name has special constructs in it,
807 call the corresponding file handler. */
808 handler = Ffind_file_name_handler (name, Qexpand_file_name);
810 RETURN_UNGCPRO (call3_check_string (handler, Qexpand_file_name,
811 name, default_directory));
813 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
814 if (NILP (default_directory))
815 default_directory = current_buffer->directory;
816 if (! STRINGP (default_directory))
817 default_directory = build_string ("/");
819 if (!NILP (default_directory))
821 handler = Ffind_file_name_handler (default_directory, Qexpand_file_name);
823 RETURN_UNGCPRO (call3 (handler, Qexpand_file_name,
824 name, default_directory));
827 o = XSTRING_DATA (default_directory);
829 /* Make sure DEFAULT_DIRECTORY is properly expanded.
830 It would be better to do this down below where we actually use
831 default_directory. Unfortunately, calling Fexpand_file_name recursively
832 could invoke GC, and the strings might be relocated. This would
833 be annoying because we have pointers into strings lying around
834 that would need adjusting, and people would add new pointers to
835 the code and forget to adjust them, resulting in intermittent bugs.
836 Putting this call here avoids all that crud.
838 The EQ test avoids infinite recursion. */
839 if (! NILP (default_directory) && !EQ (default_directory, name)
840 /* Save time in some common cases - as long as default_directory
841 is not relative, it can be canonicalized with name below (if it
842 is needed at all) without requiring it to be expanded now. */
843 #ifdef WIN32_FILENAMES
844 /* Detect Windows file names with drive specifiers. */
845 && ! (IS_DRIVE (o[0]) && (IS_DEVICE_SEP (o[1]) && IS_DIRECTORY_SEP (o[2])))
846 /* Detect Windows file names in UNC format. */
847 && ! (IS_DIRECTORY_SEP (o[0]) && IS_DIRECTORY_SEP (o[1]))
848 #endif /* not WIN32_FILENAMES */
850 /* Detect Unix absolute file names (/... alone is not absolute on
852 && ! (IS_DIRECTORY_SEP (o[0]))
853 #endif /* not WIN32_NATIVE */
856 default_directory = Fexpand_file_name (default_directory, Qnil);
858 #ifdef FILE_SYSTEM_CASE
859 name = FILE_SYSTEM_CASE (name);
862 /* #### dmoore - this is ugly, clean this up. Looks like nm pointing
863 into name should be safe during all of this, though. */
864 nm = XSTRING_DATA (name);
866 #ifdef WIN32_FILENAMES
867 /* We will force directory separators to be either all \ or /, so make
868 a local copy to modify, even if there ends up being no change. */
869 nm = (Bufbyte *) strcpy ((char *) alloca (strlen ((char *) nm) + 1),
872 /* Find and remove drive specifier if present; this makes nm absolute
873 even if the rest of the name appears to be relative. */
875 Bufbyte *colon = (Bufbyte *) strrchr ((char *)nm, ':');
879 /* Only recognize colon as part of drive specifier if there is a
880 single alphabetic character preceding the colon (and if the
881 character before the drive letter, if present, is a directory
882 separator); this is to support the remote system syntax used by
883 ange-ftp, and the "po:username" syntax for POP mailboxes. */
887 else if (IS_DRIVE (colon[-1])
888 && (colon == nm + 1 || IS_DIRECTORY_SEP (colon[-2])))
895 while (--colon >= nm)
902 /* If we see "c://somedir", we want to strip the first slash after the
903 colon when stripping the drive letter. Otherwise, this expands to
905 if (drive && IS_DIRECTORY_SEP (nm[0]) && IS_DIRECTORY_SEP (nm[1]))
907 #endif /* WIN32_FILENAMES */
909 /* If nm is absolute, look for /./ or /../ sequences; if none are
910 found, we can probably return right away. We will avoid allocating
911 a new string if name is already fully expanded. */
913 IS_DIRECTORY_SEP (nm[0])
915 && (drive || IS_DIRECTORY_SEP (nm[1]))
919 /* If it turns out that the filename we want to return is just a
920 suffix of FILENAME, we don't need to go through and edit
921 things; we just need to construct a new string using data
922 starting at the middle of FILENAME. If we set lose to a
923 non-zero value, that means we've discovered that we can't do
930 /* Since we know the name is absolute, we can assume that each
931 element starts with a "/". */
933 /* "." and ".." are hairy. */
934 if (IS_DIRECTORY_SEP (p[0])
936 && (IS_DIRECTORY_SEP (p[2])
938 || (p[2] == '.' && (IS_DIRECTORY_SEP (p[3])
945 #ifdef WIN32_FILENAMES
946 if (drive || IS_DIRECTORY_SEP (nm[1]))
948 /* Make sure directories are all separated with / or \ as
949 desired, but avoid allocation of a new string when not
951 CORRECT_DIR_SEPS (nm);
952 if (IS_DIRECTORY_SEP (nm[1]))
954 if (strcmp ((char *) nm, (char *) XSTRING_DATA (name)) != 0)
955 name = build_string ((Bufbyte *) nm);
957 /* drive must be set, so this is okay */
958 else if (strcmp ((char *) nm - 2,
959 (char *) XSTRING_DATA (name)) != 0)
961 name = make_string (nm - 2, p - nm + 2);
962 XSTRING_DATA (name)[0] = DRIVE_LETTER (drive);
963 XSTRING_DATA (name)[1] = ':';
965 RETURN_UNGCPRO (name);
967 #endif /* not WIN32_FILENAMES */
969 if (nm == XSTRING_DATA (name))
970 RETURN_UNGCPRO (name);
971 RETURN_UNGCPRO (build_string ((char *) nm));
972 #endif /* not WIN32_NATIVE */
976 /* At this point, nm might or might not be an absolute file name. We
977 need to expand ~ or ~user if present, otherwise prefix nm with
978 default_directory if nm is not absolute, and finally collapse /./
979 and /foo/../ sequences.
981 We set newdir to be the appropriate prefix if one is needed:
982 - the relevant user directory if nm starts with ~ or ~user
983 - the specified drive's working dir (DOS/NT only) if nm does not
985 - the value of default_directory.
987 Note that these prefixes are not guaranteed to be absolute (except
988 for the working dir of a drive). Therefore, to ensure we always
989 return an absolute name, if the final prefix is not absolute we
990 append it to the current working directory. */
994 if (nm[0] == '~') /* prefix ~ */
996 if (IS_DIRECTORY_SEP (nm[1])
997 || nm[1] == 0) /* ~ by itself */
999 Extbyte *newdir_external = get_home_directory ();
1001 if (newdir_external == NULL)
1002 newdir = (Bufbyte *) "";
1004 TO_INTERNAL_FORMAT (C_STRING, newdir_external,
1005 C_STRING_ALLOCA, (* ((char **) &newdir)),
1009 #ifdef WIN32_FILENAMES
1010 collapse_newdir = 0;
1013 else /* ~user/filename */
1015 for (p = nm; *p && (!IS_DIRECTORY_SEP (*p)); p++)
1017 o = (Bufbyte *) alloca (p - nm + 1);
1018 memcpy (o, (char *) nm, p - nm);
1021 /* #### While NT is single-user (for the moment) you still
1022 can have multiple user profiles users defined, each with
1023 its HOME. So maybe possibly we should think about handling
1025 #ifndef WIN32_NATIVE
1027 if ((user = user_login_name (NULL)) != NULL)
1029 /* Does the user login name match the ~name? */
1030 if (strcmp (user, (char *) o + 1) == 0)
1032 newdir = (Bufbyte *) get_home_directory();
1039 /* Jamie reports that getpwnam() can get wedged by SIGIO/SIGALARM
1040 occurring in it. (It can call select()). */
1041 slow_down_interrupts ();
1042 pw = (struct passwd *) getpwnam ((char *) o + 1);
1043 speed_up_interrupts ();
1046 newdir = (Bufbyte *) pw -> pw_dir;
1052 #endif /* not WIN32_NATIVE */
1054 /* If we don't find a user of that name, leave the name
1055 unchanged; don't move nm forward to p. */
1059 #ifdef WIN32_FILENAMES
1060 /* On DOS and Windows, nm is absolute if a drive name was specified;
1061 use the drive's current directory as the prefix if needed. */
1062 if (!newdir && drive)
1065 /* Get default directory if needed to make nm absolute. */
1066 if (!IS_DIRECTORY_SEP (nm[0]))
1068 newdir = (Bufbyte *) alloca (MAXPATHLEN + 1);
1069 if (!_getdcwd (toupper (drive) - 'A' + 1, newdir, MAXPATHLEN))
1072 #endif /* WIN32_NATIVE */
1075 /* Either nm starts with /, or drive isn't mounted. */
1076 newdir = (Bufbyte *) alloca (4);
1077 newdir[0] = DRIVE_LETTER (drive);
1083 #endif /* WIN32_FILENAMES */
1085 /* Finally, if no prefix has been specified and nm is not absolute,
1086 then it must be expanded relative to default_directory. */
1089 #ifndef WIN32_NATIVE
1090 /* /... alone is not absolute on DOS and Windows. */
1091 && !IS_DIRECTORY_SEP (nm[0])
1093 #ifdef WIN32_FILENAMES
1094 && !(IS_DIRECTORY_SEP (nm[0]) && IS_DIRECTORY_SEP (nm[1]))
1098 newdir = XSTRING_DATA (default_directory);
1101 #ifdef WIN32_FILENAMES
1104 /* First ensure newdir is an absolute name. */
1106 /* Detect Windows file names with drive specifiers. */
1107 ! (IS_DRIVE (newdir[0])
1108 && IS_DEVICE_SEP (newdir[1]) && IS_DIRECTORY_SEP (newdir[2]))
1109 /* Detect Windows file names in UNC format. */
1110 && ! (IS_DIRECTORY_SEP (newdir[0]) && IS_DIRECTORY_SEP (newdir[1]))
1111 /* Detect drive spec by itself */
1112 && ! (IS_DEVICE_SEP (newdir[1]) && newdir[2] == 0)
1113 /* Detect unix format. */
1114 #ifndef WIN32_NATIVE
1115 && ! (IS_DIRECTORY_SEP (newdir[0]))
1119 /* Effectively, let newdir be (expand-file-name newdir cwd).
1120 Because of the admonition against calling expand-file-name
1121 when we have pointers into lisp strings, we accomplish this
1122 indirectly by prepending newdir to nm if necessary, and using
1123 cwd (or the wd of newdir's drive) as the new newdir. */
1125 if (IS_DRIVE (newdir[0]) && newdir[1] == ':')
1130 if (!IS_DIRECTORY_SEP (nm[0]))
1132 Bufbyte *tmp = (Bufbyte *) alloca (strlen ((char *) newdir) +
1133 strlen ((char *) nm) + 2);
1134 file_name_as_directory ((char *) tmp, (char *) newdir);
1135 strcat ((char *) tmp, (char *) nm);
1138 newdir = (Bufbyte *) alloca (MAXPATHLEN + 1);
1142 if (!_getdcwd (toupper (drive) - 'A' + 1, newdir, MAXPATHLEN))
1144 newdir = (Bufbyte *) "/";
1147 getcwd ((char *) newdir, MAXPATHLEN);
1150 /* Strip off drive name from prefix, if present. */
1151 if (IS_DRIVE (newdir[0]) && newdir[1] == ':')
1157 /* Keep only a prefix from newdir if nm starts with slash
1158 (/ /server/share for UNC, nothing otherwise). */
1159 if (IS_DIRECTORY_SEP (nm[0])
1160 #ifndef WIN32_NATIVE
1161 && IS_DIRECTORY_SEP (nm[1])
1165 if (IS_DIRECTORY_SEP (newdir[0]) && IS_DIRECTORY_SEP (newdir[1]))
1169 strcpy ((char *) alloca (strlen ((char *) newdir) + 1),
1172 while (*p && !IS_DIRECTORY_SEP (*p)) p++;
1174 while (*p && !IS_DIRECTORY_SEP (*p)) p++;
1178 newdir = (Bufbyte *) "";
1181 #endif /* WIN32_FILENAMES */
1185 /* Get rid of any slash at the end of newdir, unless newdir is
1186 just // (an incomplete UNC name). */
1187 length = strlen ((char *) newdir);
1188 if (length > 1 && IS_DIRECTORY_SEP (newdir[length - 1])
1189 #ifdef WIN32_FILENAMES
1190 && !(length == 2 && IS_DIRECTORY_SEP (newdir[0]))
1194 Bufbyte *temp = (Bufbyte *) alloca (length);
1195 memcpy (temp, newdir, length - 1);
1196 temp[length - 1] = 0;
1204 /* Now concatenate the directory and name to new space in the stack frame */
1205 tlen += strlen ((char *) nm) + 1;
1206 #ifdef WIN32_FILENAMES
1207 /* Add reserved space for drive name. (The Microsoft x86 compiler
1208 produces incorrect code if the following two lines are combined.) */
1209 target = (Bufbyte *) alloca (tlen + 2);
1211 #else /* not WIN32_FILENAMES */
1212 target = (Bufbyte *) alloca (tlen);
1213 #endif /* not WIN32_FILENAMES */
1218 if (nm[0] == 0 || IS_DIRECTORY_SEP (nm[0]))
1219 strcpy ((char *) target, (char *) newdir);
1221 file_name_as_directory ((char *) target, (char *) newdir);
1224 strcat ((char *) target, (char *) nm);
1226 /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */
1228 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1235 if (!IS_DIRECTORY_SEP (*p))
1239 else if (IS_DIRECTORY_SEP (p[0])
1241 && (IS_DIRECTORY_SEP (p[2])
1244 /* If "/." is the entire filename, keep the "/". Otherwise,
1245 just delete the whole "/.". */
1246 if (o == target && p[2] == '\0')
1250 else if (IS_DIRECTORY_SEP (p[0]) && p[1] == '.' && p[2] == '.'
1251 /* `/../' is the "superroot" on certain file systems. */
1253 && (IS_DIRECTORY_SEP (p[3]) || p[3] == 0))
1255 while (o != target && (--o) && !IS_DIRECTORY_SEP (*o))
1257 /* Keep initial / only if this is the whole name. */
1258 if (o == target && IS_ANY_SEP (*o) && p[3] == 0)
1262 #ifdef WIN32_FILENAMES
1263 /* if drive is set, we're not dealing with an UNC, so
1264 multiple dir-seps are redundant (and reportedly cause trouble
1266 else if (drive && IS_DIRECTORY_SEP (p[0]) && IS_DIRECTORY_SEP (p[1]))
1275 #ifdef WIN32_FILENAMES
1276 /* At last, set drive name, except for network file name. */
1280 target[0] = DRIVE_LETTER (drive);
1286 assert (IS_DIRECTORY_SEP (target[0]) && IS_DIRECTORY_SEP (target[1]));
1289 CORRECT_DIR_SEPS (target);
1290 #endif /* WIN32_FILENAMES */
1292 RETURN_UNGCPRO (make_string (target, o - target));
1295 DEFUN ("file-truename", Ffile_truename, 1, 2, 0, /*
1296 Return the canonical name of FILENAME.
1297 Second arg DEFAULT is directory to start with if FILENAME is relative
1298 (does not start with slash); if DEFAULT is nil or missing,
1299 the current buffer's value of `default-directory' is used.
1300 No component of the resulting pathname will be a symbolic link, as
1301 in the realpath() function.
1303 (filename, default_))
1305 /* This function can GC. GC checked 2000-07-28 ben. */
1306 Lisp_Object expanded_name;
1307 struct gcpro gcpro1;
1309 CHECK_STRING (filename);
1311 expanded_name = Fexpand_file_name (filename, default_);
1313 if (!STRINGP (expanded_name))
1316 GCPRO1 (expanded_name);
1319 Lisp_Object handler =
1320 Ffind_file_name_handler (expanded_name, Qfile_truename);
1322 if (!NILP (handler))
1324 (call2_check_string (handler, Qfile_truename, expanded_name));
1328 char resolved_path[MAXPATHLEN];
1333 TO_EXTERNAL_FORMAT (LISP_STRING, expanded_name,
1334 ALLOCA, (path, elen),
1337 if (elen > MAXPATHLEN)
1340 /* Try doing it all at once. */
1341 /* !! Does realpath() Mule-encapsulate?
1342 Answer: Nope! So we do it above */
1343 if (!xrealpath ((char *) path, resolved_path))
1345 /* Didn't resolve it -- have to do it one component at a time. */
1346 /* "realpath" is a typically useless, stupid un*x piece of crap.
1347 It claims to return a useful value in the "error" case, but since
1348 there is no indication provided of how far along the pathname
1349 the function went before erring, there is no way to use the
1350 partial result returned. What a piece of junk.
1352 The above comment refers to historical versions of
1353 realpath(). The Unix98 specs state:
1355 "On successful completion, realpath() returns a
1356 pointer to the resolved name. Otherwise, realpath()
1357 returns a null pointer and sets errno to indicate the
1358 error, and the contents of the buffer pointed to by
1359 resolved_name are undefined."
1361 Since we depend on undocumented semantics of various system realpath()s,
1362 we just use our own version in realpath.c. */
1367 #ifdef WIN32_FILENAMES
1368 if (IS_DRIVE (p[0]) && IS_DEVICE_SEP (p[1])
1369 && IS_DIRECTORY_SEP (p[2]))
1370 /* don't test c: on windows */
1372 else if (IS_DIRECTORY_SEP (p[0]) && IS_DIRECTORY_SEP (p[1]))
1373 /* start after // */
1376 for (pos = p + 1; pos < path + elen; pos++)
1377 if (IS_DIRECTORY_SEP (*pos))
1385 if (xrealpath ((char *) path, resolved_path))
1393 else if (errno == ENOENT || errno == EACCES)
1395 /* Failed on this component. Just tack on the rest of
1396 the string and we are done. */
1397 int rlen = strlen (resolved_path);
1399 /* "On failure, it returns NULL, sets errno to indicate
1400 the error, and places in resolved_path the absolute pathname
1401 of the path component which could not be resolved." */
1405 int plen = elen - (p - path);
1407 if (rlen > 1 && IS_DIRECTORY_SEP (resolved_path[rlen - 1]))
1410 if (plen + rlen + 1 > countof (resolved_path))
1413 resolved_path[rlen] = DIRECTORY_SEP;
1414 memcpy (resolved_path + rlen + 1, p + 1, plen + 1 - 1);
1424 Lisp_Object resolved_name;
1425 int rlen = strlen (resolved_path);
1426 if (elen > 0 && IS_DIRECTORY_SEP (XSTRING_BYTE (expanded_name, elen - 1))
1427 && !(rlen > 0 && IS_DIRECTORY_SEP (resolved_path[rlen - 1])))
1429 if (rlen + 1 > countof (resolved_path))
1431 resolved_path[rlen++] = DIRECTORY_SEP;
1432 resolved_path[rlen] = '\0';
1434 TO_INTERNAL_FORMAT (DATA, (resolved_path, rlen),
1435 LISP_STRING, resolved_name,
1437 RETURN_UNGCPRO (resolved_name);
1441 errno = ENAMETOOLONG;
1444 report_file_error ("Finding truename", list1 (expanded_name));
1446 RETURN_UNGCPRO (Qnil);
1450 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name, 1, 1, 0, /*
1451 Substitute environment variables referred to in FILENAME.
1452 `$FOO' where FOO is an environment variable name means to substitute
1453 the value of that variable. The variable name should be terminated
1454 with a character, not a letter, digit or underscore; otherwise, enclose
1455 the entire variable name in braces.
1456 If `/~' appears, all of FILENAME through that `/' is discarded.
1460 /* This function can GC. GC checked 2000-07-28 ben. */
1463 Bufbyte *s, *p, *o, *x, *endp;
1464 Bufbyte *target = 0;
1466 int substituted = 0;
1468 Lisp_Object handler;
1470 CHECK_STRING (filename);
1472 /* If the file name has special constructs in it,
1473 call the corresponding file handler. */
1474 handler = Ffind_file_name_handler (filename, Qsubstitute_in_file_name);
1475 if (!NILP (handler))
1476 return call2_check_string_or_nil (handler, Qsubstitute_in_file_name,
1479 nm = XSTRING_DATA (filename);
1480 endp = nm + XSTRING_LENGTH (filename);
1482 /* If /~ or // appears, discard everything through first slash. */
1484 for (p = nm; p != endp; p++)
1487 #if defined (WIN32_FILENAMES)
1488 /* // at start of file name is meaningful in WindowsNT systems */
1489 || (IS_DIRECTORY_SEP (p[0]) && p - 1 != nm)
1490 #else /* not (WIN32_FILENAMES) */
1491 || IS_DIRECTORY_SEP (p[0])
1492 #endif /* not (WIN32_FILENAMES) */
1495 && (IS_DIRECTORY_SEP (p[-1])))
1500 #ifdef WIN32_FILENAMES
1501 /* see comment in expand-file-name about drive specifiers */
1502 else if (IS_DRIVE (p[0]) && p[1] == ':'
1503 && p > nm && IS_DIRECTORY_SEP (p[-1]))
1508 #endif /* WIN32_FILENAMES */
1511 /* See if any variables are substituted into the string
1512 and find the total length of their values in `total' */
1514 for (p = nm; p != endp;)
1524 /* "$$" means a single "$" */
1533 while (p != endp && *p != '}') p++;
1534 if (*p != '}') goto missingclose;
1540 while (p != endp && (isalnum (*p) || *p == '_')) p++;
1544 /* Copy out the variable name */
1545 target = (Bufbyte *) alloca (s - o + 1);
1546 strncpy ((char *) target, (char *) o, s - o);
1549 strupr (target); /* $home == $HOME etc. */
1550 #endif /* WIN32_NATIVE */
1552 /* Get variable value */
1553 o = (Bufbyte *) egetenv ((char *) target);
1554 if (!o) goto badvar;
1555 total += strlen ((char *) o);
1562 /* If substitution required, recopy the filename and do it */
1563 /* Make space in stack frame for the new copy */
1564 xnm = (Bufbyte *) alloca (XSTRING_LENGTH (filename) + total + 1);
1567 /* Copy the rest of the name through, replacing $ constructs with values */
1584 while (p != endp && *p != '}') p++;
1585 if (*p != '}') goto missingclose;
1591 while (p != endp && (isalnum (*p) || *p == '_')) p++;
1595 /* Copy out the variable name */
1596 target = (Bufbyte *) alloca (s - o + 1);
1597 strncpy ((char *) target, (char *) o, s - o);
1600 strupr (target); /* $home == $HOME etc. */
1601 #endif /* WIN32_NATIVE */
1603 /* Get variable value */
1604 o = (Bufbyte *) egetenv ((char *) target);
1608 strcpy ((char *) x, (char *) o);
1609 x += strlen ((char *) o);
1614 /* If /~ or // appears, discard everything through first slash. */
1616 for (p = xnm; p != x; p++)
1618 #if defined (WIN32_FILENAMES)
1619 || (IS_DIRECTORY_SEP (p[0]) && p - 1 != xnm)
1620 #else /* not WIN32_FILENAMES */
1621 || IS_DIRECTORY_SEP (p[0])
1622 #endif /* not WIN32_FILENAMES */
1624 /* don't do p[-1] if that would go off the beginning --jwz */
1625 && p != nm && p > xnm && IS_DIRECTORY_SEP (p[-1]))
1627 #ifdef WIN32_FILENAMES
1628 else if (IS_DRIVE (p[0]) && p[1] == ':'
1629 && p > nm && IS_DIRECTORY_SEP (p[-1]))
1633 return make_string (xnm, x - xnm);
1636 syntax_error ("Bad format environment-variable substitution", filename);
1638 syntax_error ("Missing \"}\" in environment-variable substitution",
1641 syntax_error_2 ("Substituting nonexistent environment variable",
1642 filename, build_string ((char *) target));
1645 return Qnil; /* suppress compiler warning */
1648 /* A slightly faster and more convenient way to get
1649 (directory-file-name (expand-file-name FOO)). */
1652 expand_and_dir_to_file (Lisp_Object filename, Lisp_Object defdir)
1654 /* This function can call Lisp. GC checked 2000-07-28 ben */
1655 Lisp_Object abspath;
1656 struct gcpro gcpro1;
1658 abspath = Fexpand_file_name (filename, defdir);
1660 /* Remove final slash, if any (unless path is root).
1661 stat behaves differently depending! */
1662 if (XSTRING_LENGTH (abspath) > 1
1663 && IS_DIRECTORY_SEP (XSTRING_BYTE (abspath, XSTRING_LENGTH (abspath) - 1))
1664 && !IS_DEVICE_SEP (XSTRING_BYTE (abspath, XSTRING_LENGTH (abspath) - 2)))
1665 /* We cannot take shortcuts; they might be wrong for magic file names. */
1666 abspath = Fdirectory_file_name (abspath);
1671 /* Signal an error if the file ABSNAME already exists.
1672 If INTERACTIVE is nonzero, ask the user whether to proceed,
1673 and bypass the error if the user says to go ahead.
1674 QUERYSTRING is a name for the action that is being considered
1676 *STATPTR is used to store the stat information if the file exists.
1677 If the file does not exist, STATPTR->st_mode is set to 0. */
1680 barf_or_query_if_file_exists (Lisp_Object absname, const char *querystring,
1681 int interactive, struct stat *statptr)
1683 /* This function can call Lisp. GC checked 2000-07-28 ben */
1684 struct stat statbuf;
1686 /* stat is a good way to tell whether the file exists,
1687 regardless of what access permissions it has. */
1688 if (xemacs_stat ((char *) XSTRING_DATA (absname), &statbuf) >= 0)
1695 struct gcpro gcpro1;
1697 prompt = emacs_doprnt_string_c
1698 ((const Bufbyte *) GETTEXT ("File %s already exists; %s anyway? "),
1699 Qnil, -1, XSTRING_DATA (absname),
1700 GETTEXT (querystring));
1703 tem = call1 (Qyes_or_no_p, prompt);
1710 Fsignal (Qfile_already_exists,
1711 list2 (build_translated_string ("File already exists"),
1719 statptr->st_mode = 0;
1724 DEFUN ("copy-file", Fcopy_file, 2, 4,
1725 "fCopy file: \nFCopy %s to file: \np\nP", /*
1726 Copy FILENAME to NEWNAME. Both args must be strings.
1727 Signals a `file-already-exists' error if file NEWNAME already exists,
1728 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.
1729 A number as third arg means request confirmation if NEWNAME already exists.
1730 This is what happens in interactive use with M-x.
1731 Fourth arg KEEP-TIME non-nil means give the new file the same
1732 last-modified time as the old one. (This works on only some systems.)
1733 A prefix arg makes KEEP-TIME non-nil.
1735 (filename, newname, ok_if_already_exists, keep_time))
1737 /* This function can call Lisp. GC checked 2000-07-28 ben */
1739 char buf[16 * 1024];
1740 struct stat st, out_st;
1741 Lisp_Object handler;
1742 int speccount = specpdl_depth ();
1743 struct gcpro gcpro1, gcpro2;
1744 /* Lisp_Object args[6]; */
1745 int input_file_statable_p;
1747 GCPRO2 (filename, newname);
1748 CHECK_STRING (filename);
1749 CHECK_STRING (newname);
1750 filename = Fexpand_file_name (filename, Qnil);
1751 newname = Fexpand_file_name (newname, Qnil);
1753 /* If the input file name has special constructs in it,
1754 call the corresponding file handler. */
1755 handler = Ffind_file_name_handler (filename, Qcopy_file);
1756 /* Likewise for output file name. */
1758 handler = Ffind_file_name_handler (newname, Qcopy_file);
1759 if (!NILP (handler))
1762 return call5 (handler, Qcopy_file, filename, newname,
1763 ok_if_already_exists, keep_time);
1766 /* When second argument is a directory, copy the file into it.
1767 (copy-file "foo" "bar/") == (copy-file "foo" "bar/foo")
1769 if (!NILP (Ffile_directory_p (newname)))
1771 Lisp_Object args[3];
1772 struct gcpro ngcpro1;
1776 args[1] = Qnil; args[2] = Qnil;
1779 if (!IS_DIRECTORY_SEP (XSTRING_BYTE (newname,
1780 XSTRING_LENGTH (newname) - 1)))
1782 args[i++] = Fchar_to_string (Vdirectory_sep_char);
1783 args[i++] = Ffile_name_nondirectory (filename);
1784 newname = Fconcat (i, args);
1788 if (NILP (ok_if_already_exists)
1789 || INTP (ok_if_already_exists))
1790 barf_or_query_if_file_exists (newname, "copy to it",
1791 INTP (ok_if_already_exists), &out_st);
1792 else if (xemacs_stat ((const char *) XSTRING_DATA (newname), &out_st) < 0)
1795 ifd = interruptible_open ((char *) XSTRING_DATA (filename), O_RDONLY | OPEN_BINARY, 0);
1797 report_file_error ("Opening input file", list1 (filename));
1799 record_unwind_protect (close_file_unwind, make_int (ifd));
1801 /* We can only copy regular files and symbolic links. Other files are not
1803 input_file_statable_p = (fstat (ifd, &st) >= 0);
1805 #ifndef WIN32_NATIVE
1806 if (out_st.st_mode != 0
1807 && st.st_dev == out_st.st_dev && st.st_ino == out_st.st_ino)
1810 report_file_error ("Input and output files are the same",
1811 list2 (filename, newname));
1815 #if defined (S_ISREG) && defined (S_ISLNK)
1816 if (input_file_statable_p)
1818 if (!(S_ISREG (st.st_mode))
1819 /* XEmacs: have to allow S_ISCHR in order to copy /dev/null */
1821 && !(S_ISCHR (st.st_mode))
1823 && !(S_ISLNK (st.st_mode)))
1825 #if defined (EISDIR)
1826 /* Get a better looking error message. */
1829 report_file_error ("Non-regular file", list1 (filename));
1832 #endif /* S_ISREG && S_ISLNK */
1834 ofd = open( (char *) XSTRING_DATA (newname),
1835 O_WRONLY | O_CREAT | O_TRUNC | OPEN_BINARY, CREAT_MODE);
1837 report_file_error ("Opening output file", list1 (newname));
1840 Lisp_Object ofd_locative = noseeum_cons (make_int (ofd), Qnil);
1842 record_unwind_protect (close_file_unwind, ofd_locative);
1844 while ((n = read_allowing_quit (ifd, buf, sizeof (buf))) > 0)
1846 if (write_allowing_quit (ofd, buf, n) != n)
1847 report_file_error ("I/O error", list1 (newname));
1850 /* Closing the output clobbers the file times on some systems. */
1851 if (close (ofd) < 0)
1852 report_file_error ("I/O error", list1 (newname));
1854 if (input_file_statable_p)
1856 if (!NILP (keep_time))
1858 EMACS_TIME atime, mtime;
1859 EMACS_SET_SECS_USECS (atime, st.st_atime, 0);
1860 EMACS_SET_SECS_USECS (mtime, st.st_mtime, 0);
1861 if (set_file_times (newname, atime, mtime))
1862 report_file_error ("I/O error", list1 (newname));
1864 chmod ((const char *) XSTRING_DATA (newname),
1865 st.st_mode & 07777);
1868 /* We'll close it by hand */
1869 XCAR (ofd_locative) = Qnil;
1872 unbind_to (speccount, Qnil);
1879 DEFUN ("make-directory-internal", Fmake_directory_internal, 1, 1, 0, /*
1880 Create a directory. One argument, a file name string.
1884 /* This function can GC. GC checked 1997.04.06. */
1885 char dir [MAXPATHLEN];
1886 Lisp_Object handler;
1887 struct gcpro gcpro1;
1889 CHECK_STRING (dirname_);
1890 dirname_ = Fexpand_file_name (dirname_, Qnil);
1893 handler = Ffind_file_name_handler (dirname_, Qmake_directory_internal);
1895 if (!NILP (handler))
1896 return (call2 (handler, Qmake_directory_internal, dirname_));
1898 if (XSTRING_LENGTH (dirname_) > (Bytecount) (sizeof (dir) - 1))
1900 return Fsignal (Qfile_error,
1901 list3 (build_translated_string ("Creating directory"),
1902 build_translated_string ("pathname too long"),
1905 strncpy (dir, (char *) XSTRING_DATA (dirname_),
1906 XSTRING_LENGTH (dirname_) + 1);
1908 if (dir [XSTRING_LENGTH (dirname_) - 1] == '/')
1909 dir [XSTRING_LENGTH (dirname_) - 1] = 0;
1911 if (mkdir (dir, 0777) != 0)
1912 report_file_error ("Creating directory", list1 (dirname_));
1917 DEFUN ("delete-directory", Fdelete_directory, 1, 1, "FDelete directory: ", /*
1918 Delete a directory. One argument, a file name or directory name string.
1922 /* This function can GC. GC checked 1997.04.06. */
1923 Lisp_Object handler;
1924 struct gcpro gcpro1;
1926 CHECK_STRING (dirname_);
1929 dirname_ = Fexpand_file_name (dirname_, Qnil);
1930 dirname_ = Fdirectory_file_name (dirname_);
1932 handler = Ffind_file_name_handler (dirname_, Qdelete_directory);
1934 if (!NILP (handler))
1935 return (call2 (handler, Qdelete_directory, dirname_));
1937 if (rmdir ((char *) XSTRING_DATA (dirname_)) != 0)
1938 report_file_error ("Removing directory", list1 (dirname_));
1943 DEFUN ("delete-file", Fdelete_file, 1, 1, "fDelete file: ", /*
1944 Delete the file named FILENAME (a string).
1945 If FILENAME has multiple names, it continues to exist with the other names.
1949 /* This function can GC. GC checked 1997.04.06. */
1950 Lisp_Object handler;
1951 struct gcpro gcpro1;
1953 CHECK_STRING (filename);
1954 filename = Fexpand_file_name (filename, Qnil);
1957 handler = Ffind_file_name_handler (filename, Qdelete_file);
1959 if (!NILP (handler))
1960 return call2 (handler, Qdelete_file, filename);
1962 if (0 > unlink ((char *) XSTRING_DATA (filename)))
1963 report_file_error ("Removing old name", list1 (filename));
1968 internal_delete_file_1 (Lisp_Object ignore, Lisp_Object ignore2)
1973 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */
1976 internal_delete_file (Lisp_Object filename)
1978 /* This function can GC. GC checked 1997.04.06. */
1979 return NILP (condition_case_1 (Qt, Fdelete_file, filename,
1980 internal_delete_file_1, Qnil));
1983 DEFUN ("rename-file", Frename_file, 2, 3,
1984 "fRename file: \nFRename %s to file: \np", /*
1985 Rename FILENAME as NEWNAME. Both args must be strings.
1986 If file has names other than FILENAME, it continues to have those names.
1987 Signals a `file-already-exists' error if a file NEWNAME already exists
1988 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
1989 A number as third arg means request confirmation if NEWNAME already exists.
1990 This is what happens in interactive use with M-x.
1992 (filename, newname, ok_if_already_exists))
1994 /* This function can GC. GC checked 1997.04.06. */
1995 Lisp_Object handler;
1996 struct gcpro gcpro1, gcpro2;
1998 GCPRO2 (filename, newname);
1999 CHECK_STRING (filename);
2000 CHECK_STRING (newname);
2001 filename = Fexpand_file_name (filename, Qnil);
2002 newname = Fexpand_file_name (newname, Qnil);
2004 /* If the file name has special constructs in it,
2005 call the corresponding file handler. */
2006 handler = Ffind_file_name_handler (filename, Qrename_file);
2008 handler = Ffind_file_name_handler (newname, Qrename_file);
2009 if (!NILP (handler))
2012 return call4 (handler, Qrename_file,
2013 filename, newname, ok_if_already_exists);
2016 /* When second argument is a directory, rename the file into it.
2017 (rename-file "foo" "bar/") == (rename-file "foo" "bar/foo")
2019 if (!NILP (Ffile_directory_p (newname)))
2021 Lisp_Object args[3];
2022 struct gcpro ngcpro1;
2026 args[1] = Qnil; args[2] = Qnil;
2029 if (XSTRING_BYTE (newname, XSTRING_LENGTH (newname) - 1) != '/')
2030 args[i++] = build_string ("/");
2031 args[i++] = Ffile_name_nondirectory (filename);
2032 newname = Fconcat (i, args);
2036 if (NILP (ok_if_already_exists)
2037 || INTP (ok_if_already_exists))
2038 barf_or_query_if_file_exists (newname, "rename to it",
2039 INTP (ok_if_already_exists), 0);
2041 /* Syncing with FSF 19.34.6 note: FSF does not have conditional code for
2042 WIN32_NATIVE here; I've removed it. --marcpa */
2044 /* We have configure check for rename() and emulate using
2045 link()/unlink() if necessary. */
2046 if (0 > rename ((char *) XSTRING_DATA (filename),
2047 (char *) XSTRING_DATA (newname)))
2051 Fcopy_file (filename, newname,
2052 /* We have already prompted if it was an integer,
2053 so don't have copy-file prompt again. */
2054 (NILP (ok_if_already_exists) ? Qnil : Qt),
2056 Fdelete_file (filename);
2060 report_file_error ("Renaming", list2 (filename, newname));
2067 DEFUN ("add-name-to-file", Fadd_name_to_file, 2, 3,
2068 "fAdd name to file: \nFName to add to %s: \np", /*
2069 Give FILENAME additional name NEWNAME. Both args must be strings.
2070 Signals a `file-already-exists' error if a file NEWNAME already exists
2071 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2072 A number as third arg means request confirmation if NEWNAME already exists.
2073 This is what happens in interactive use with M-x.
2075 (filename, newname, ok_if_already_exists))
2077 /* This function can GC. GC checked 1997.04.06. */
2078 Lisp_Object handler;
2079 struct gcpro gcpro1, gcpro2;
2081 GCPRO2 (filename, newname);
2082 CHECK_STRING (filename);
2083 CHECK_STRING (newname);
2084 filename = Fexpand_file_name (filename, Qnil);
2085 newname = Fexpand_file_name (newname, Qnil);
2087 /* If the file name has special constructs in it,
2088 call the corresponding file handler. */
2089 handler = Ffind_file_name_handler (filename, Qadd_name_to_file);
2090 if (!NILP (handler))
2091 RETURN_UNGCPRO (call4 (handler, Qadd_name_to_file, filename,
2092 newname, ok_if_already_exists));
2094 /* If the new name has special constructs in it,
2095 call the corresponding file handler. */
2096 handler = Ffind_file_name_handler (newname, Qadd_name_to_file);
2097 if (!NILP (handler))
2098 RETURN_UNGCPRO (call4 (handler, Qadd_name_to_file, filename,
2099 newname, ok_if_already_exists));
2101 if (NILP (ok_if_already_exists)
2102 || INTP (ok_if_already_exists))
2103 barf_or_query_if_file_exists (newname, "make it a new name",
2104 INTP (ok_if_already_exists), 0);
2105 /* Syncing with FSF 19.34.6 note: FSF does not report a file error
2106 on NT here. --marcpa */
2107 /* But FSF #defines link as sys_link which is supplied in nt.c. We can't do
2108 that because sysfile.h defines sys_link depending on ENCAPSULATE_LINK.
2109 Reverted to previous behavior pending a working fix. (jhar) */
2110 #if defined(WIN32_NATIVE)
2111 /* Windows does not support this operation. */
2112 report_file_error ("Adding new name", Flist (2, &filename));
2113 #else /* not defined(WIN32_NATIVE) */
2115 unlink ((char *) XSTRING_DATA (newname));
2116 if (0 > link ((char *) XSTRING_DATA (filename),
2117 (char *) XSTRING_DATA (newname)))
2119 report_file_error ("Adding new name",
2120 list2 (filename, newname));
2122 #endif /* defined(WIN32_NATIVE) */
2128 DEFUN ("make-symbolic-link", Fmake_symbolic_link, 2, 3,
2129 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np", /*
2130 Make a symbolic link to FILENAME, named LINKNAME. Both args strings.
2131 Signals a `file-already-exists' error if a file LINKNAME already exists
2132 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2133 A number as third arg means request confirmation if LINKNAME already exists.
2134 This happens for interactive use with M-x.
2136 (filename, linkname, ok_if_already_exists))
2138 /* This function can GC. GC checked 1997.06.04. */
2139 /* XEmacs change: run handlers even if local machine doesn't have symlinks */
2140 Lisp_Object handler;
2141 struct gcpro gcpro1, gcpro2;
2143 GCPRO2 (filename, linkname);
2144 CHECK_STRING (filename);
2145 CHECK_STRING (linkname);
2146 /* If the link target has a ~, we must expand it to get
2147 a truly valid file name. Otherwise, do not expand;
2148 we want to permit links to relative file names. */
2149 if (XSTRING_BYTE (filename, 0) == '~')
2150 filename = Fexpand_file_name (filename, Qnil);
2151 linkname = Fexpand_file_name (linkname, Qnil);
2153 /* If the file name has special constructs in it,
2154 call the corresponding file handler. */
2155 handler = Ffind_file_name_handler (filename, Qmake_symbolic_link);
2156 if (!NILP (handler))
2157 RETURN_UNGCPRO (call4 (handler, Qmake_symbolic_link, filename, linkname,
2158 ok_if_already_exists));
2160 /* If the new link name has special constructs in it,
2161 call the corresponding file handler. */
2162 handler = Ffind_file_name_handler (linkname, Qmake_symbolic_link);
2163 if (!NILP (handler))
2164 RETURN_UNGCPRO (call4 (handler, Qmake_symbolic_link, filename,
2165 linkname, ok_if_already_exists));
2168 if (NILP (ok_if_already_exists)
2169 || INTP (ok_if_already_exists))
2170 barf_or_query_if_file_exists (linkname, "make it a link",
2171 INTP (ok_if_already_exists), 0);
2173 unlink ((char *) XSTRING_DATA (linkname));
2174 if (0 > symlink ((char *) XSTRING_DATA (filename),
2175 (char *) XSTRING_DATA (linkname)))
2177 report_file_error ("Making symbolic link",
2178 list2 (filename, linkname));
2180 #endif /* S_IFLNK */
2188 DEFUN ("sysnetunam", Fsysnetunam, 2, 2, 0, /*
2189 Open a network connection to PATH using LOGIN as the login string.
2194 const char *path_ext;
2195 const char *login_ext;
2197 CHECK_STRING (path);
2198 CHECK_STRING (login);
2200 /* netunam, being a strange-o system call only used once, is not
2203 LISP_STRING_TO_EXTERNAL (path, path_ext, Qfile_name);
2204 LISP_STRING_TO_EXTERNAL (login, login_ext, Qnative);
2206 netresult = netunam (path_ext, login_ext);
2208 return netresult == -1 ? Qnil : Qt;
2210 #endif /* HPUX_NET */
2212 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p, 1, 1, 0, /*
2213 Return t if file FILENAME specifies an absolute path name.
2214 On Unix, this is a name starting with a `/' or a `~'.
2218 /* This function does not GC */
2221 CHECK_STRING (filename);
2222 ptr = XSTRING_DATA (filename);
2223 return (IS_DIRECTORY_SEP (*ptr) || *ptr == '~'
2224 #ifdef WIN32_FILENAMES
2225 || (IS_DRIVE (*ptr) && ptr[1] == ':' && IS_DIRECTORY_SEP (ptr[2]))
2230 /* Return nonzero if file FILENAME exists and can be executed. */
2233 check_executable (char *filename)
2237 if (xemacs_stat (filename, &st) < 0)
2239 return ((st.st_mode & S_IEXEC) != 0);
2240 #else /* not WIN32_NATIVE */
2242 return eaccess (filename, X_OK) >= 0;
2244 /* Access isn't quite right because it uses the real uid
2245 and we really want to test with the effective uid.
2246 But Unix doesn't give us a right way to do it. */
2247 return access (filename, X_OK) >= 0;
2248 #endif /* HAVE_EACCESS */
2249 #endif /* not WIN32_NATIVE */
2252 /* Return nonzero if file FILENAME exists and can be written. */
2255 check_writable (const char *filename)
2258 return (eaccess (filename, W_OK) >= 0);
2260 /* Access isn't quite right because it uses the real uid
2261 and we really want to test with the effective uid.
2262 But Unix doesn't give us a right way to do it.
2263 Opening with O_WRONLY could work for an ordinary file,
2264 but would lose for directories. */
2265 return (access (filename, W_OK) >= 0);
2269 DEFUN ("file-exists-p", Ffile_exists_p, 1, 1, 0, /*
2270 Return t if file FILENAME exists. (This does not mean you can read it.)
2271 See also `file-readable-p' and `file-attributes'.
2275 /* This function can call lisp; GC checked 2000-07-11 ben */
2276 Lisp_Object abspath;
2277 Lisp_Object handler;
2278 struct stat statbuf;
2279 struct gcpro gcpro1;
2281 CHECK_STRING (filename);
2282 abspath = Fexpand_file_name (filename, Qnil);
2284 /* If the file name has special constructs in it,
2285 call the corresponding file handler. */
2287 handler = Ffind_file_name_handler (abspath, Qfile_exists_p);
2289 if (!NILP (handler))
2290 return call2 (handler, Qfile_exists_p, abspath);
2292 return xemacs_stat ((char *) XSTRING_DATA (abspath), &statbuf) >= 0 ? Qt : Qnil;
2295 DEFUN ("file-executable-p", Ffile_executable_p, 1, 1, 0, /*
2296 Return t if FILENAME can be executed by you.
2297 For a directory, this means you can access files in that directory.
2302 /* This function can GC. GC checked 07-11-2000 ben. */
2303 Lisp_Object abspath;
2304 Lisp_Object handler;
2305 struct gcpro gcpro1;
2307 CHECK_STRING (filename);
2308 abspath = Fexpand_file_name (filename, Qnil);
2310 /* If the file name has special constructs in it,
2311 call the corresponding file handler. */
2313 handler = Ffind_file_name_handler (abspath, Qfile_executable_p);
2315 if (!NILP (handler))
2316 return call2 (handler, Qfile_executable_p, abspath);
2318 return check_executable ((char *) XSTRING_DATA (abspath)) ? Qt : Qnil;
2321 DEFUN ("file-readable-p", Ffile_readable_p, 1, 1, 0, /*
2322 Return t if file FILENAME exists and you can read it.
2323 See also `file-exists-p' and `file-attributes'.
2327 /* This function can GC */
2328 Lisp_Object abspath = Qnil;
2329 Lisp_Object handler;
2330 struct gcpro gcpro1;
2333 CHECK_STRING (filename);
2334 abspath = Fexpand_file_name (filename, Qnil);
2336 /* If the file name has special constructs in it,
2337 call the corresponding file handler. */
2338 handler = Ffind_file_name_handler (abspath, Qfile_readable_p);
2339 if (!NILP (handler))
2340 RETURN_UNGCPRO (call2 (handler, Qfile_readable_p, abspath));
2342 #if defined(WIN32_FILENAMES)
2343 /* Under MS-DOS and Windows, open does not work for directories. */
2345 if (access (XSTRING_DATA (abspath), 0) == 0)
2349 #else /* not WIN32_FILENAMES */
2351 int desc = interruptible_open ((char *) XSTRING_DATA (abspath), O_RDONLY | OPEN_BINARY, 0);
2358 #endif /* not WIN32_FILENAMES */
2361 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2363 DEFUN ("file-writable-p", Ffile_writable_p, 1, 1, 0, /*
2364 Return t if file FILENAME can be written or created by you.
2368 /* This function can GC. GC checked 1997.04.10. */
2369 Lisp_Object abspath, dir;
2370 Lisp_Object handler;
2371 struct stat statbuf;
2372 struct gcpro gcpro1;
2374 CHECK_STRING (filename);
2375 abspath = Fexpand_file_name (filename, Qnil);
2377 /* If the file name has special constructs in it,
2378 call the corresponding file handler. */
2380 handler = Ffind_file_name_handler (abspath, Qfile_writable_p);
2382 if (!NILP (handler))
2383 return call2 (handler, Qfile_writable_p, abspath);
2385 if (xemacs_stat ((char *) XSTRING_DATA (abspath), &statbuf) >= 0)
2386 return (check_writable ((char *) XSTRING_DATA (abspath))
2391 dir = Ffile_name_directory (abspath);
2393 return (check_writable (!NILP (dir) ? (char *) XSTRING_DATA (dir)
2398 DEFUN ("file-symlink-p", Ffile_symlink_p, 1, 1, 0, /*
2399 Return non-nil if file FILENAME is the name of a symbolic link.
2400 The value is the name of the file to which it is linked.
2401 Otherwise returns nil.
2405 /* This function can GC. GC checked 1997.04.10. */
2406 /* XEmacs change: run handlers even if local machine doesn't have symlinks */
2413 Lisp_Object handler;
2414 struct gcpro gcpro1;
2416 CHECK_STRING (filename);
2417 filename = Fexpand_file_name (filename, Qnil);
2419 /* If the file name has special constructs in it,
2420 call the corresponding file handler. */
2422 handler = Ffind_file_name_handler (filename, Qfile_symlink_p);
2424 if (!NILP (handler))
2425 return call2 (handler, Qfile_symlink_p, filename);
2431 buf = xnew_array_and_zero (char, bufsize);
2432 valsize = readlink ((char *) XSTRING_DATA (filename),
2434 if (valsize < bufsize) break;
2435 /* Buffer was not long enough */
2444 val = make_string ((Bufbyte *) buf, valsize);
2447 #else /* not S_IFLNK */
2449 #endif /* not S_IFLNK */
2452 DEFUN ("file-directory-p", Ffile_directory_p, 1, 1, 0, /*
2453 Return t if file FILENAME is the name of a directory as a file.
2454 A directory name spec may be given instead; then the value is t
2455 if the directory so specified exists and really is a directory.
2459 /* This function can GC. GC checked 1997.04.10. */
2460 Lisp_Object abspath;
2462 Lisp_Object handler;
2463 struct gcpro gcpro1;
2465 GCPRO1 (current_buffer->directory);
2466 abspath = expand_and_dir_to_file (filename,
2467 current_buffer->directory);
2470 /* If the file name has special constructs in it,
2471 call the corresponding file handler. */
2473 handler = Ffind_file_name_handler (abspath, Qfile_directory_p);
2475 if (!NILP (handler))
2476 return call2 (handler, Qfile_directory_p, abspath);
2478 if (xemacs_stat ((char *) XSTRING_DATA (abspath), &st) < 0)
2480 return (st.st_mode & S_IFMT) == S_IFDIR ? Qt : Qnil;
2483 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p, 1, 1, 0, /*
2484 Return t if file FILENAME is the name of a directory as a file,
2485 and files in that directory can be opened by you. In order to use a
2486 directory as a buffer's current directory, this predicate must return true.
2487 A directory name spec may be given instead; then the value is t
2488 if the directory so specified exists and really is a readable and
2489 searchable directory.
2493 /* This function can GC. GC checked 1997.04.10. */
2494 Lisp_Object handler;
2496 /* If the file name has special constructs in it,
2497 call the corresponding file handler. */
2498 handler = Ffind_file_name_handler (filename, Qfile_accessible_directory_p);
2499 if (!NILP (handler))
2500 return call2 (handler, Qfile_accessible_directory_p,
2503 #if !defined(WIN32_NATIVE)
2504 if (NILP (Ffile_directory_p (filename)))
2507 return Ffile_executable_p (filename);
2511 struct gcpro gcpro1;
2512 /* It's an unlikely combination, but yes we really do need to gcpro:
2513 Suppose that file-accessible-directory-p has no handler, but
2514 file-directory-p does have a handler; this handler causes a GC which
2515 relocates the string in `filename'; and finally file-directory-p
2516 returns non-nil. Then we would end up passing a garbaged string
2517 to file-executable-p. */
2519 tem = (NILP (Ffile_directory_p (filename))
2520 || NILP (Ffile_executable_p (filename)));
2522 return tem ? Qnil : Qt;
2524 #endif /* !defined(WIN32_NATIVE) */
2527 DEFUN ("file-regular-p", Ffile_regular_p, 1, 1, 0, /*
2528 Return t if file FILENAME is the name of a regular file.
2529 This is the sort of file that holds an ordinary stream of data bytes.
2533 /* This function can GC. GC checked 1997.04.10. */
2534 Lisp_Object abspath;
2536 Lisp_Object handler;
2537 struct gcpro gcpro1;
2539 GCPRO1 (current_buffer->directory);
2540 abspath = expand_and_dir_to_file (filename, current_buffer->directory);
2543 /* If the file name has special constructs in it,
2544 call the corresponding file handler. */
2546 handler = Ffind_file_name_handler (abspath, Qfile_regular_p);
2548 if (!NILP (handler))
2549 return call2 (handler, Qfile_regular_p, abspath);
2551 if (xemacs_stat ((char *) XSTRING_DATA (abspath), &st) < 0)
2553 return (st.st_mode & S_IFMT) == S_IFREG ? Qt : Qnil;
2556 DEFUN ("file-modes", Ffile_modes, 1, 1, 0, /*
2557 Return mode bits of file named FILENAME, as an integer.
2561 /* This function can GC. GC checked 1997.04.10. */
2562 Lisp_Object abspath;
2564 Lisp_Object handler;
2565 struct gcpro gcpro1;
2567 GCPRO1 (current_buffer->directory);
2568 abspath = expand_and_dir_to_file (filename,
2569 current_buffer->directory);
2572 /* If the file name has special constructs in it,
2573 call the corresponding file handler. */
2575 handler = Ffind_file_name_handler (abspath, Qfile_modes);
2577 if (!NILP (handler))
2578 return call2 (handler, Qfile_modes, abspath);
2580 if (xemacs_stat ((char *) XSTRING_DATA (abspath), &st) < 0)
2582 /* Syncing with FSF 19.34.6 note: not in FSF, #if 0'ed out here. */
2585 if (check_executable (XSTRING_DATA (abspath)))
2586 st.st_mode |= S_IEXEC;
2587 #endif /* WIN32_NATIVE */
2590 return make_int (st.st_mode & 07777);
2593 DEFUN ("set-file-modes", Fset_file_modes, 2, 2, 0, /*
2594 Set mode bits of file named FILENAME to MODE (an integer).
2595 Only the 12 low bits of MODE are used.
2599 /* This function can GC. GC checked 1997.04.10. */
2600 Lisp_Object abspath;
2601 Lisp_Object handler;
2602 struct gcpro gcpro1;
2604 GCPRO1 (current_buffer->directory);
2605 abspath = Fexpand_file_name (filename, current_buffer->directory);
2610 /* If the file name has special constructs in it,
2611 call the corresponding file handler. */
2613 handler = Ffind_file_name_handler (abspath, Qset_file_modes);
2615 if (!NILP (handler))
2616 return call3 (handler, Qset_file_modes, abspath, mode);
2618 if (chmod ((char *) XSTRING_DATA (abspath), XINT (mode)) < 0)
2619 report_file_error ("Doing chmod", list1 (abspath));
2624 DEFUN ("set-default-file-modes", Fset_default_file_modes, 1, 1, 0, /*
2625 Set the file permission bits for newly created files.
2626 The argument MODE should be an integer; if a bit in MODE is 1,
2627 subsequently created files will not have the permission corresponding
2628 to that bit enabled. Only the low 9 bits are used.
2629 This setting is inherited by subprocesses.
2635 umask ((~ XINT (mode)) & 0777);
2640 DEFUN ("default-file-modes", Fdefault_file_modes, 0, 0, 0, /*
2641 Return the default file protection for created files.
2642 The umask value determines which permissions are enabled in newly
2643 created files. If a permission's bit in the umask is 1, subsequently
2644 created files will not have that permission enabled.
2653 return make_int ((~ mode) & 0777);
2656 DEFUN ("unix-sync", Funix_sync, 0, 0, "", /*
2657 Tell Unix to finish all pending disk updates.
2661 #ifndef WIN32_NATIVE
2668 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p, 2, 2, 0, /*
2669 Return t if file FILE1 is newer than file FILE2.
2670 If FILE1 does not exist, the answer is nil;
2671 otherwise, if FILE2 does not exist, the answer is t.
2675 /* This function can GC. GC checked 1997.04.10. */
2676 Lisp_Object abspath1, abspath2;
2679 Lisp_Object handler;
2680 struct gcpro gcpro1, gcpro2, gcpro3;
2682 CHECK_STRING (file1);
2683 CHECK_STRING (file2);
2688 GCPRO3 (abspath1, abspath2, current_buffer->directory);
2689 abspath1 = expand_and_dir_to_file (file1, current_buffer->directory);
2690 abspath2 = expand_and_dir_to_file (file2, current_buffer->directory);
2692 /* If the file name has special constructs in it,
2693 call the corresponding file handler. */
2694 handler = Ffind_file_name_handler (abspath1, Qfile_newer_than_file_p);
2696 handler = Ffind_file_name_handler (abspath2, Qfile_newer_than_file_p);
2698 if (!NILP (handler))
2699 return call3 (handler, Qfile_newer_than_file_p, abspath1,
2702 if (xemacs_stat ((char *) XSTRING_DATA (abspath1), &st) < 0)
2705 mtime1 = st.st_mtime;
2707 if (xemacs_stat ((char *) XSTRING_DATA (abspath2), &st) < 0)
2710 return (mtime1 > st.st_mtime) ? Qt : Qnil;
2714 /* Stack sizes > 2**16 is a good way to elicit compiler bugs */
2715 /* #define READ_BUF_SIZE (2 << 16) */
2716 #define READ_BUF_SIZE (1 << 15)
2718 DEFUN ("insert-file-contents-internal", Finsert_file_contents_internal,
2720 Insert contents of file FILENAME after point; no coding-system frobbing.
2721 This function is identical to `insert-file-contents' except for the
2722 handling of the CODESYS and USED-CODESYS arguments under
2723 XEmacs/Mule. (When Mule support is not present, both functions are
2724 identical and ignore the CODESYS and USED-CODESYS arguments.)
2726 If support for Mule exists in this Emacs, the file is decoded according
2727 to CODESYS; if omitted, no conversion happens. If USED-CODESYS is non-nil,
2728 it should be a symbol, and the actual coding system that was used for the
2729 decoding is stored into it. It will in general be different from CODESYS
2730 if CODESYS specifies automatic encoding detection or end-of-line detection.
2732 Currently START and END refer to byte positions (as opposed to character
2733 positions), even in Mule. (Fixing this is very difficult.)
2735 (filename, visit, start, end, replace, codesys, used_codesys))
2737 /* This function can call lisp */
2741 Charcount inserted = 0;
2743 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
2744 Lisp_Object handler = Qnil, val;
2746 Bufbyte read_buf[READ_BUF_SIZE];
2748 struct buffer *buf = current_buffer;
2750 int not_regular = 0;
2752 if (buf->base_buffer && ! NILP (visit))
2753 error ("Cannot do file visiting in an indirect buffer");
2755 /* No need to call Fbarf_if_buffer_read_only() here.
2756 That's called in begin_multiple_change() or wherever. */
2760 /* #### dmoore - should probably check in various places to see if
2761 curbuf was killed and if so signal an error? */
2763 XSETBUFFER (curbuf, buf);
2765 GCPRO5 (filename, val, visit, handler, curbuf);
2767 mc_count = (NILP (replace)) ?
2768 begin_multiple_change (buf, BUF_PT (buf), BUF_PT (buf)) :
2769 begin_multiple_change (buf, BUF_BEG (buf), BUF_Z (buf));
2771 speccount = specpdl_depth (); /* begin_multiple_change also adds
2772 an unwind_protect */
2774 filename = Fexpand_file_name (filename, Qnil);
2776 /* If the file name has special constructs in it,
2777 call the corresponding file handler. */
2778 handler = Ffind_file_name_handler (filename, Qinsert_file_contents);
2779 if (!NILP (handler))
2781 val = call6 (handler, Qinsert_file_contents, filename,
2782 visit, start, end, replace);
2787 if (!NILP (used_codesys))
2788 CHECK_SYMBOL (used_codesys);
2791 if ( (!NILP (start) || !NILP (end)) && !NILP (visit) )
2792 error ("Attempt to visit less than an entire file");
2796 if (xemacs_stat ((char *) XSTRING_DATA (filename), &st) < 0)
2798 if (fd >= 0) close (fd);
2801 report_file_error ("Opening input file", list1 (filename));
2807 /* Signal an error if we are accessing a non-regular file, with
2808 REPLACE, START or END being non-nil. */
2809 if (!S_ISREG (st.st_mode))
2816 if (!NILP (replace) || !NILP (start) || !NILP (end))
2818 end_multiple_change (buf, mc_count);
2821 (Fsignal (Qfile_error,
2822 list2 (build_translated_string("not a regular file"),
2826 #endif /* S_IFREG */
2838 if ((fd = interruptible_open ((char *) XSTRING_DATA (filename),
2839 O_RDONLY | OPEN_BINARY, 0)) < 0)
2843 /* Replacement should preserve point as it preserves markers. */
2844 if (!NILP (replace))
2845 record_unwind_protect (restore_point_unwind, Fpoint_marker (Qnil, Qnil));
2847 record_unwind_protect (close_file_unwind, make_int (fd));
2849 /* Supposedly happens on VMS. */
2851 error ("File size is negative");
2857 end = make_int (st.st_size);
2858 if (XINT (end) != st.st_size)
2859 error ("Maximum buffer size exceeded");
2863 /* If requested, replace the accessible part of the buffer
2864 with the file contents. Avoid replacing text at the
2865 beginning or end of the buffer that matches the file contents;
2866 that preserves markers pointing to the unchanged parts. */
2867 #if !defined (FILE_CODING)
2868 /* The replace-mode code currently only works when the assumption
2869 'one byte == one char' holds true. This fails Mule because
2870 files may contain multibyte characters. It holds under Windows NT
2871 provided we convert CRLF into LF. */
2872 # define FSFMACS_SPEEDY_INSERT
2873 #endif /* !defined (FILE_CODING) */
2875 #ifndef FSFMACS_SPEEDY_INSERT
2876 if (!NILP (replace))
2878 buffer_delete_range (buf, BUF_BEG (buf), BUF_Z (buf),
2879 !NILP (visit) ? INSDEL_NO_LOCKING : 0);
2881 #else /* FSFMACS_SPEEDY_INSERT */
2882 if (!NILP (replace))
2884 char buffer[1 << 14];
2885 Bufpos same_at_start = BUF_BEGV (buf);
2886 Bufpos same_at_end = BUF_ZV (buf);
2889 /* Count how many chars at the start of the file
2890 match the text at the beginning of the buffer. */
2895 nread = read_allowing_quit (fd, buffer, sizeof buffer);
2897 error ("IO error reading %s: %s",
2898 XSTRING_DATA (filename), strerror (errno));
2899 else if (nread == 0)
2902 while (bufpos < nread && same_at_start < BUF_ZV (buf)
2903 && BUF_FETCH_CHAR (buf, same_at_start) == buffer[bufpos])
2904 same_at_start++, bufpos++;
2905 /* If we found a discrepancy, stop the scan.
2906 Otherwise loop around and scan the next bufferful. */
2907 if (bufpos != nread)
2910 /* If the file matches the buffer completely,
2911 there's no need to replace anything. */
2912 if (same_at_start - BUF_BEGV (buf) == st.st_size)
2915 unbind_to (speccount, Qnil);
2916 /* Truncate the buffer to the size of the file. */
2917 buffer_delete_range (buf, same_at_start, same_at_end,
2918 !NILP (visit) ? INSDEL_NO_LOCKING : 0);
2921 /* Count how many chars at the end of the file
2922 match the text at the end of the buffer. */
2925 int total_read, nread;
2926 Bufpos bufpos, curpos, trial;
2928 /* At what file position are we now scanning? */
2929 curpos = st.st_size - (BUF_ZV (buf) - same_at_end);
2930 /* If the entire file matches the buffer tail, stop the scan. */
2933 /* How much can we scan in the next step? */
2934 trial = min (curpos, (Bufpos) sizeof (buffer));
2935 if (lseek (fd, curpos - trial, 0) < 0)
2936 report_file_error ("Setting file position", list1 (filename));
2939 while (total_read < trial)
2941 nread = read_allowing_quit (fd, buffer + total_read,
2942 trial - total_read);
2944 report_file_error ("IO error reading file", list1 (filename));
2945 total_read += nread;
2947 /* Scan this bufferful from the end, comparing with
2948 the Emacs buffer. */
2949 bufpos = total_read;
2950 /* Compare with same_at_start to avoid counting some buffer text
2951 as matching both at the file's beginning and at the end. */
2952 while (bufpos > 0 && same_at_end > same_at_start
2953 && BUF_FETCH_CHAR (buf, same_at_end - 1) ==
2955 same_at_end--, bufpos--;
2956 /* If we found a discrepancy, stop the scan.
2957 Otherwise loop around and scan the preceding bufferful. */
2960 /* If display current starts at beginning of line,
2961 keep it that way. */
2962 if (XBUFFER (XWINDOW (Fselected_window (Qnil))->buffer) == buf)
2963 XWINDOW (Fselected_window (Qnil))->start_at_line_beg =
2964 !NILP (Fbolp (make_buffer (buf)));
2967 /* Don't try to reuse the same piece of text twice. */
2968 overlap = same_at_start - BUF_BEGV (buf) -
2969 (same_at_end + st.st_size - BUF_ZV (buf));
2971 same_at_end += overlap;
2973 /* Arrange to read only the nonmatching middle part of the file. */
2974 start = make_int (same_at_start - BUF_BEGV (buf));
2975 end = make_int (st.st_size - (BUF_ZV (buf) - same_at_end));
2977 buffer_delete_range (buf, same_at_start, same_at_end,
2978 !NILP (visit) ? INSDEL_NO_LOCKING : 0);
2979 /* Insert from the file at the proper position. */
2980 BUF_SET_PT (buf, same_at_start);
2982 #endif /* FSFMACS_SPEEDY_INSERT */
2986 total = XINT (end) - XINT (start);
2988 /* Make sure point-max won't overflow after this insertion. */
2989 if (total != XINT (make_int (total)))
2990 error ("Maximum buffer size exceeded");
2993 /* For a special file, all we can do is guess. The value of -1
2994 will make the stream functions read as much as possible. */
2997 if (XINT (start) != 0
2998 #ifdef FSFMACS_SPEEDY_INSERT
2999 /* why was this here? asked jwz. The reason is that the replace-mode
3000 connivings above will normally put the file pointer other than
3001 where it should be. */
3003 #endif /* !FSFMACS_SPEEDY_INSERT */
3006 if (lseek (fd, XINT (start), 0) < 0)
3007 report_file_error ("Setting file position", list1 (filename));
3011 Bufpos cur_point = BUF_PT (buf);
3012 struct gcpro ngcpro1;
3013 Lisp_Object stream = make_filedesc_input_stream (fd, 0, total,
3017 Lstream_set_buffering (XLSTREAM (stream), LSTREAM_BLOCKN_BUFFERED, 65536);
3019 stream = make_decoding_input_stream
3020 (XLSTREAM (stream), Fget_coding_system (codesys));
3021 Lstream_set_character_mode (XLSTREAM (stream));
3022 Lstream_set_buffering (XLSTREAM (stream), LSTREAM_BLOCKN_BUFFERED, 65536);
3023 #endif /* FILE_CODING */
3025 record_unwind_protect (delete_stream_unwind, stream);
3027 /* No need to limit the amount of stuff we attempt to read. (It would
3028 be incorrect, anyway, when Mule is enabled.) Instead, the limiting
3029 occurs inside of the filedesc stream. */
3032 Lstream_data_count this_len;
3033 Charcount cc_inserted;
3036 this_len = Lstream_read (XLSTREAM (stream), read_buf,
3046 cc_inserted = buffer_insert_raw_string_1 (buf, cur_point, read_buf,
3049 ? INSDEL_NO_LOCKING : 0);
3050 inserted += cc_inserted;
3051 cur_point += cc_inserted;
3054 if (!NILP (used_codesys))
3057 XCODING_SYSTEM_NAME (decoding_stream_coding_system (XLSTREAM (stream))));
3059 #endif /* FILE_CODING */
3063 /* Close the file/stream */
3064 unbind_to (speccount, Qnil);
3068 error ("IO error reading %s: %s",
3069 XSTRING_DATA (filename), strerror (saverrno));
3075 end_multiple_change (buf, mc_count);
3079 if (!EQ (buf->undo_list, Qt))
3080 buf->undo_list = Qnil;
3083 buf->modtime = st.st_mtime;
3084 buf->filename = filename;
3085 /* XEmacs addition: */
3086 /* This function used to be in C, ostensibly so that
3087 it could be called here. But that's just silly.
3088 There's no reason C code can't call out to Lisp
3089 code, and it's a lot cleaner this way. */
3090 /* Note: compute-buffer-file-truename is called for
3091 side-effect! Its return value is intentionally
3093 if (!NILP (Ffboundp (Qcompute_buffer_file_truename)))
3094 call1 (Qcompute_buffer_file_truename, make_buffer (buf));
3096 BUF_SAVE_MODIFF (buf) = BUF_MODIFF (buf);
3097 buf->auto_save_modified = BUF_MODIFF (buf);
3098 buf->saved_size = make_int (BUF_SIZE (buf));
3099 #ifdef CLASH_DETECTION
3102 if (!NILP (buf->file_truename))
3103 unlock_file (buf->file_truename);
3104 unlock_file (filename);
3106 #endif /* CLASH_DETECTION */
3108 RETURN_UNGCPRO (Fsignal (Qfile_error,
3109 list2 (build_string ("not a regular file"),
3112 /* If visiting nonexistent file, return nil. */
3113 if (buf->modtime == -1)
3114 report_file_error ("Opening input file",
3118 /* Decode file format */
3121 Lisp_Object insval = call3 (Qformat_decode,
3122 Qnil, make_int (inserted), visit);
3124 inserted = XINT (insval);
3130 struct gcpro ngcpro1;
3133 EXTERNAL_LIST_LOOP (p, Vafter_insert_file_functions)
3135 Lisp_Object insval =
3136 call1 (XCAR (p), make_int (inserted));
3139 CHECK_NATNUM (insval);
3140 inserted = XINT (insval);
3152 return (list2 (filename, make_int (inserted)));
3156 static int a_write (Lisp_Object outstream, Lisp_Object instream, int pos,
3157 Lisp_Object *annot);
3158 static Lisp_Object build_annotations (Lisp_Object start, Lisp_Object end);
3160 /* If build_annotations switched buffers, switch back to BUF.
3161 Kill the temporary buffer that was selected in the meantime. */
3164 build_annotations_unwind (Lisp_Object buf)
3168 if (XBUFFER (buf) == current_buffer)
3170 tembuf = Fcurrent_buffer ();
3172 Fkill_buffer (tembuf);
3176 DEFUN ("write-region-internal", Fwrite_region_internal, 3, 7,
3177 "r\nFWrite region to file: ", /*
3178 Write current region into specified file; no coding-system frobbing.
3179 This function is identical to `write-region' except for the handling
3180 of the CODESYS argument under XEmacs/Mule. (When Mule support is not
3181 present, both functions are identical and ignore the CODESYS argument.)
3182 If support for Mule exists in this Emacs, the file is encoded according
3183 to the value of CODESYS. If this is nil, no code conversion occurs.
3185 (start, end, filename, append, visit, lockname, codesys))
3187 /* This function can call lisp. GC checked 2000-07-28 ben */
3192 Lisp_Object fn = Qnil;
3193 int speccount = specpdl_depth ();
3194 int visiting_other = STRINGP (visit);
3195 int visiting = (EQ (visit, Qt) || visiting_other);
3196 int quietly = (!visiting && !NILP (visit));
3197 Lisp_Object visit_file = Qnil;
3198 Lisp_Object annotations = Qnil;
3199 struct buffer *given_buffer;
3200 Bufpos start1, end1;
3201 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
3202 struct gcpro ngcpro1, ngcpro2;
3205 XSETBUFFER (curbuf, current_buffer);
3207 /* start, end, visit, and append are never modified in this fun
3208 so we don't protect them. */
3209 GCPRO5 (visit_file, filename, codesys, lockname, annotations);
3210 NGCPRO2 (curbuf, fn);
3212 /* [[ dmoore - if Fexpand_file_name or handlers kill the buffer,
3213 we should signal an error rather than blissfully continuing
3214 along. ARGH, this function is going to lose lose lose. We need
3215 to protect the current_buffer from being destroyed, but the
3216 multiple return points make this a pain in the butt. ]] we do
3217 protect curbuf now. --ben */
3220 codesys = Fget_coding_system (codesys);
3221 #endif /* FILE_CODING */
3223 if (current_buffer->base_buffer && ! NILP (visit))
3224 invalid_operation ("Cannot do file visiting in an indirect buffer",
3227 if (!NILP (start) && !STRINGP (start))
3228 get_buffer_range_char (current_buffer, start, end, &start1, &end1, 0);
3231 Lisp_Object handler;
3234 visit_file = Fexpand_file_name (visit, Qnil);
3236 visit_file = filename;
3237 filename = Fexpand_file_name (filename, Qnil);
3239 if (NILP (lockname))
3240 lockname = visit_file;
3242 /* We used to UNGCPRO here. BAD! visit_file is used below after
3243 more Lisp calling. */
3244 /* If the file name has special constructs in it,
3245 call the corresponding file handler. */
3246 handler = Ffind_file_name_handler (filename, Qwrite_region);
3247 /* If FILENAME has no handler, see if VISIT has one. */
3248 if (NILP (handler) && STRINGP (visit))
3249 handler = Ffind_file_name_handler (visit, Qwrite_region);
3251 if (!NILP (handler))
3253 Lisp_Object val = call8 (handler, Qwrite_region, start, end,
3254 filename, append, visit, lockname, codesys);
3257 BUF_SAVE_MODIFF (current_buffer) = BUF_MODIFF (current_buffer);
3258 current_buffer->saved_size = make_int (BUF_SIZE (current_buffer));
3259 current_buffer->filename = visit_file;
3260 MARK_MODELINE_CHANGED;
3268 #ifdef CLASH_DETECTION
3270 lock_file (lockname);
3271 #endif /* CLASH_DETECTION */
3273 /* Special kludge to simplify auto-saving. */
3276 start1 = BUF_BEG (current_buffer);
3277 end1 = BUF_Z (current_buffer);
3280 record_unwind_protect (build_annotations_unwind, Fcurrent_buffer ());
3282 given_buffer = current_buffer;
3283 annotations = build_annotations (start, end);
3284 if (current_buffer != given_buffer)
3286 start1 = BUF_BEGV (current_buffer);
3287 end1 = BUF_ZV (current_buffer);
3294 desc = open ((char *) XSTRING_DATA (fn), O_WRONLY | OPEN_BINARY, 0);
3298 desc = open ((char *) XSTRING_DATA (fn),
3299 O_WRONLY | O_TRUNC | O_CREAT | OPEN_BINARY,
3300 auto_saving ? auto_save_mode_bits : CREAT_MODE);
3305 #ifdef CLASH_DETECTION
3307 if (!auto_saving) unlock_file (lockname);
3309 #endif /* CLASH_DETECTION */
3310 report_file_error ("Opening output file", list1 (filename));
3314 Lisp_Object desc_locative = Fcons (make_int (desc), Qnil);
3315 Lisp_Object instream = Qnil, outstream = Qnil;
3316 struct gcpro nngcpro1, nngcpro2;
3317 /* need to gcpro; QUIT could happen out of call to write() */
3318 NNGCPRO2 (instream, outstream);
3320 record_unwind_protect (close_file_unwind, desc_locative);
3324 if (lseek (desc, 0, 2) < 0)
3326 #ifdef CLASH_DETECTION
3327 if (!auto_saving) unlock_file (lockname);
3328 #endif /* CLASH_DETECTION */
3329 report_file_error ("Lseek error",
3336 /* Note: I tried increasing the buffering size, along with
3337 various other tricks, but nothing seemed to make much of
3338 a difference in the time it took to save a large file.
3339 (Actually that's not true. With a local disk, changing
3340 the buffer size doesn't seem to make much difference.
3341 With an NFS-mounted disk, it could make a lot of difference
3342 because you're affecting the number of network requests
3343 that need to be made, and there could be a large latency
3344 for each request. So I've increased the buffer size
3346 outstream = make_filedesc_output_stream (desc, 0, -1, 0);
3347 Lstream_set_buffering (XLSTREAM (outstream),
3348 LSTREAM_BLOCKN_BUFFERED, 65536);
3351 make_encoding_output_stream (XLSTREAM (outstream), codesys);
3352 Lstream_set_buffering (XLSTREAM (outstream),
3353 LSTREAM_BLOCKN_BUFFERED, 65536);
3354 #endif /* FILE_CODING */
3355 if (STRINGP (start))
3357 instream = make_lisp_string_input_stream (start, 0, -1);
3361 instream = make_lisp_buffer_input_stream (current_buffer, start1, end1,
3363 LSTR_IGNORE_ACCESSIBLE);
3364 failure = (0 > (a_write (outstream, instream, start1,
3367 /* Note that this doesn't close the desc since we created the
3368 stream without the LSTR_CLOSING flag, but it does
3369 flush out any buffered data. */
3370 if (Lstream_close (XLSTREAM (outstream)) < 0)
3375 Lstream_close (XLSTREAM (instream));
3378 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
3379 Disk full in NFS may be reported here. */
3380 /* mib says that closing the file will try to write as fast as NFS can do
3381 it, and that means the fsync here is not crucial for autosave files. */
3382 if (!auto_saving && fsync (desc) < 0
3383 /* If fsync fails with EINTR, don't treat that as serious. */
3389 #endif /* HAVE_FSYNC */
3391 /* Spurious "file has changed on disk" warnings used to be seen on
3392 systems where close() can change the modtime. This is known to
3393 happen on various NFS file systems, on Windows, and on Linux.
3394 Rather than handling this on a per-system basis, we
3395 unconditionally do the xemacs_stat() after the close(). */
3397 /* NFS can report a write failure now. */
3398 if (close (desc) < 0)
3404 /* Discard the close unwind-protect. Execute the one for
3405 build_annotations (switches back to the original current buffer
3407 XCAR (desc_locative) = Qnil;
3408 unbind_to (speccount, Qnil);
3413 xemacs_stat ((char *) XSTRING_DATA (fn), &st);
3415 #ifdef CLASH_DETECTION
3417 unlock_file (lockname);
3418 #endif /* CLASH_DETECTION */
3420 /* Do this before reporting IO error
3421 to avoid a "file has changed on disk" warning on
3422 next attempt to save. */
3424 current_buffer->modtime = st.st_mtime;
3429 report_file_error ("Writing file", list1 (fn));
3434 BUF_SAVE_MODIFF (current_buffer) = BUF_MODIFF (current_buffer);
3435 current_buffer->saved_size = make_int (BUF_SIZE (current_buffer));
3436 current_buffer->filename = visit_file;
3437 MARK_MODELINE_CHANGED;
3449 message ("Wrote %s", XSTRING_DATA (visit_file));
3452 Lisp_Object fsp = Qnil;
3453 struct gcpro nngcpro1;
3456 fsp = Ffile_symlink_p (fn);
3458 message ("Wrote %s", XSTRING_DATA (fn));
3460 message ("Wrote %s (symlink to %s)",
3461 XSTRING_DATA (fn), XSTRING_DATA (fsp));
3470 /* #### This is such a load of shit!!!! There is no way we should define
3471 something so stupid as a subr, just sort the fucking list more
3473 DEFUN ("car-less-than-car", Fcar_less_than_car, 2, 2, 0, /*
3474 Return t if (car A) is numerically less than (car B).
3478 Lisp_Object objs[2];
3481 return Flss (2, objs);
3484 /* Heh heh heh, let's define this too, just to aggravate the person who
3485 wrote the above comment. */
3486 DEFUN ("cdr-less-than-cdr", Fcdr_less_than_cdr, 2, 2, 0, /*
3487 Return t if (cdr A) is numerically less than (cdr B).
3491 Lisp_Object objs[2];
3494 return Flss (2, objs);
3497 /* Build the complete list of annotations appropriate for writing out
3498 the text between START and END, by calling all the functions in
3499 write-region-annotate-functions and merging the lists they return.
3500 If one of these functions switches to a different buffer, we assume
3501 that buffer contains altered text. Therefore, the caller must
3502 make sure to restore the current buffer in all cases,
3503 as save-excursion would do. */
3506 build_annotations (Lisp_Object start, Lisp_Object end)
3508 /* This function can GC */
3509 Lisp_Object annotations;
3511 struct gcpro gcpro1, gcpro2;
3512 Lisp_Object original_buffer;
3514 XSETBUFFER (original_buffer, current_buffer);
3517 p = Vwrite_region_annotate_functions;
3518 GCPRO2 (annotations, p);
3521 struct buffer *given_buffer = current_buffer;
3522 Vwrite_region_annotations_so_far = annotations;
3523 res = call2 (Fcar (p), start, end);
3524 /* If the function makes a different buffer current,
3525 assume that means this buffer contains altered text to be output.
3526 Reset START and END from the buffer bounds
3527 and discard all previous annotations because they should have
3528 been dealt with by this function. */
3529 if (current_buffer != given_buffer)
3531 start = make_int (BUF_BEGV (current_buffer));
3532 end = make_int (BUF_ZV (current_buffer));
3535 Flength (res); /* Check basic validity of return value */
3536 annotations = merge (annotations, res, Qcar_less_than_car);
3540 /* Now do the same for annotation functions implied by the file-format */
3541 if (auto_saving && (!EQ (Vauto_save_file_format, Qt)))
3542 p = Vauto_save_file_format;
3544 p = current_buffer->file_format;
3547 struct buffer *given_buffer = current_buffer;
3548 Vwrite_region_annotations_so_far = annotations;
3549 res = call4 (Qformat_annotate_function, Fcar (p), start, end,
3551 if (current_buffer != given_buffer)
3553 start = make_int (BUF_BEGV (current_buffer));
3554 end = make_int (BUF_ZV (current_buffer));
3558 annotations = merge (annotations, res, Qcar_less_than_car);
3565 /* Write to stream OUTSTREAM the characters from INSTREAM (it is read until
3566 EOF is encountered), assuming they start at position POS in the buffer
3567 of string that STREAM refers to. Intersperse with them the annotations
3568 from *ANNOT that fall into the range of positions we are reading from,
3569 each at its appropriate position.
3571 Modify *ANNOT by discarding elements as we output them.
3572 The return value is negative in case of system call failure. */
3574 /* 4K should probably be fine. We just need to reduce the number of
3575 function calls to reasonable level. The Lstream stuff itself will
3576 batch to 64K to reduce the number of system calls. */
3578 #define A_WRITE_BATCH_SIZE 4096
3581 a_write (Lisp_Object outstream, Lisp_Object instream, int pos,
3586 unsigned char largebuf[A_WRITE_BATCH_SIZE];
3587 Lstream *instr = XLSTREAM (instream);
3588 Lstream *outstr = XLSTREAM (outstream);
3590 while (LISTP (*annot))
3592 tem = Fcar_safe (Fcar (*annot));
3594 nextpos = XINT (tem);
3598 /* If there are annotations left and we have Mule, then we
3599 have to do the I/O one emchar at a time so we can
3600 determine when to insert the annotation. */
3604 while (pos != nextpos && (ch = Lstream_get_emchar (instr)) != EOF)
3606 if (Lstream_put_emchar (outstr, ch) < 0)
3614 while (pos != nextpos)
3616 /* Otherwise there is no point to that. Just go in batches. */
3617 int chunk = min (nextpos - pos, A_WRITE_BATCH_SIZE);
3619 chunk = Lstream_read (instr, largebuf, chunk);
3622 if (chunk == 0) /* EOF */
3624 if (Lstream_write (outstr, largebuf, chunk) < chunk)
3631 tem = Fcdr (Fcar (*annot));
3634 if (Lstream_write (outstr, XSTRING_DATA (tem),
3635 XSTRING_LENGTH (tem)) < 0)
3638 *annot = Fcdr (*annot);
3649 #include <des_crypt.h>
3651 #define CRYPT_BLOCK_SIZE 8 /* bytes */
3652 #define CRYPT_KEY_SIZE 8 /* bytes */
3654 DEFUN ("encrypt-string", Fencrypt_string, 2, 2, 0, /*
3655 Encrypt STRING using KEY.
3659 char *encrypted_string, *raw_key;
3660 int rounded_size, extra, key_size;
3662 /* !!#### May produce bogus data under Mule. */
3663 CHECK_STRING (string);
3666 extra = XSTRING_LENGTH (string) % CRYPT_BLOCK_SIZE;
3667 rounded_size = XSTRING_LENGTH (string) + extra;
3668 encrypted_string = alloca (rounded_size + 1);
3669 memcpy (encrypted_string, XSTRING_DATA (string), XSTRING_LENGTH (string));
3670 memset (encrypted_string + rounded_size - extra, 0, extra + 1);
3672 key_size = min (CRYPT_KEY_SIZE, XSTRING_LENGTH (key))
3674 raw_key = alloca (CRYPT_KEY_SIZE + 1);
3675 memcpy (raw_key, XSTRING_DATA (key), key_size);
3676 memset (raw_key + key_size, 0, (CRYPT_KEY_SIZE + 1) - key_size);
3678 ecb_crypt (raw_key, encrypted_string, rounded_size,
3679 DES_ENCRYPT | DES_SW);
3680 return make_string (encrypted_string, rounded_size);
3683 DEFUN ("decrypt-string", Fdecrypt_string, 2, 2, 0, /*
3684 Decrypt STRING using KEY.
3688 char *decrypted_string, *raw_key;
3689 int string_size, key_size;
3691 CHECK_STRING (string);
3694 string_size = XSTRING_LENGTH (string) + 1;
3695 decrypted_string = alloca (string_size);
3696 memcpy (decrypted_string, XSTRING_DATA (string), string_size);
3697 decrypted_string[string_size - 1] = '\0';
3699 key_size = min (CRYPT_KEY_SIZE, XSTRING_LENGTH (key))
3701 raw_key = alloca (CRYPT_KEY_SIZE + 1);
3702 memcpy (raw_key, XSTRING_DATA (key), key_size);
3703 memset (raw_key + key_size, 0, (CRYPT_KEY_SIZE + 1) - key_size);
3706 ecb_crypt (raw_key, decrypted_string, string_size, D | DES_SW);
3707 return make_string (decrypted_string, string_size - 1);
3712 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime, 1, 1, 0, /*
3713 Return t if last mod time of BUFFER's visited file matches what BUFFER records.
3714 This means that the file has not been changed since it was visited or saved.
3718 /* This function can call lisp; GC checked 2000-07-11 ben */
3721 Lisp_Object handler;
3723 CHECK_BUFFER (buffer);
3724 b = XBUFFER (buffer);
3726 if (!STRINGP (b->filename)) return Qt;
3727 if (b->modtime == 0) return Qt;
3729 /* If the file name has special constructs in it,
3730 call the corresponding file handler. */
3731 handler = Ffind_file_name_handler (b->filename,
3732 Qverify_visited_file_modtime);
3733 if (!NILP (handler))
3734 return call2 (handler, Qverify_visited_file_modtime, buffer);
3736 if (xemacs_stat ((char *) XSTRING_DATA (b->filename), &st) < 0)
3738 /* If the file doesn't exist now and didn't exist before,
3739 we say that it isn't modified, provided the error is a tame one. */
3740 if (errno == ENOENT || errno == EACCES || errno == ENOTDIR)
3745 if (st.st_mtime == b->modtime
3746 /* If both are positive, accept them if they are off by one second. */
3747 || (st.st_mtime > 0 && b->modtime > 0
3748 && (st.st_mtime == b->modtime + 1
3749 || st.st_mtime == b->modtime - 1)))
3754 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime, 0, 0, 0, /*
3755 Clear out records of last mod time of visited file.
3756 Next attempt to save will certainly not complain of a discrepancy.
3760 current_buffer->modtime = 0;
3764 DEFUN ("visited-file-modtime", Fvisited_file_modtime, 0, 0, 0, /*
3765 Return the current buffer's recorded visited file modification time.
3766 The value is a list of the form (HIGH . LOW), like the time values
3767 that `file-attributes' returns.
3771 return time_to_lisp ((time_t) current_buffer->modtime);
3774 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime, 0, 1, 0, /*
3775 Update buffer's recorded modification time from the visited file's time.
3776 Useful if the buffer was not read from the file normally
3777 or if the file itself has been changed for some known benign reason.
3778 An argument specifies the modification time value to use
3779 \(instead of that of the visited file), in the form of a list
3780 \(HIGH . LOW) or (HIGH LOW).
3784 /* This function can call lisp */
3785 if (!NILP (time_list))
3788 lisp_to_time (time_list, &the_time);
3789 current_buffer->modtime = (int) the_time;
3793 Lisp_Object filename = Qnil;
3795 Lisp_Object handler;
3796 struct gcpro gcpro1, gcpro2, gcpro3;
3798 GCPRO3 (filename, time_list, current_buffer->filename);
3799 filename = Fexpand_file_name (current_buffer->filename, Qnil);
3801 /* If the file name has special constructs in it,
3802 call the corresponding file handler. */
3803 handler = Ffind_file_name_handler (filename, Qset_visited_file_modtime);
3805 if (!NILP (handler))
3806 /* The handler can find the file name the same way we did. */
3807 return call2 (handler, Qset_visited_file_modtime, Qnil);
3808 else if (xemacs_stat ((char *) XSTRING_DATA (filename), &st) >= 0)
3809 current_buffer->modtime = st.st_mtime;
3816 auto_save_error (Lisp_Object condition_object, Lisp_Object ignored)
3818 /* This function can call lisp */
3821 /* Don't try printing an error message after everything is gone! */
3822 if (preparing_for_armageddon)
3824 clear_echo_area (selected_frame (), Qauto_saving, 1);
3825 Fding (Qt, Qauto_save_error, Qnil);
3826 message ("Auto-saving...error for %s", XSTRING_DATA (current_buffer->name));
3827 Fsleep_for (make_int (1));
3828 message ("Auto-saving...error!for %s", XSTRING_DATA (current_buffer->name));
3829 Fsleep_for (make_int (1));
3830 message ("Auto-saving...error for %s", XSTRING_DATA (current_buffer->name));
3831 Fsleep_for (make_int (1));
3836 auto_save_1 (Lisp_Object ignored)
3838 /* This function can call lisp */
3839 /* #### I think caller is protecting current_buffer? */
3841 Lisp_Object fn = current_buffer->filename;
3842 Lisp_Object a = current_buffer->auto_save_file_name;
3847 /* Get visited file's mode to become the auto save file's mode. */
3849 xemacs_stat ((char *) XSTRING_DATA (fn), &st) >= 0)
3850 /* But make sure we can overwrite it later! */
3851 auto_save_mode_bits = st.st_mode | 0600;
3853 /* default mode for auto-save files of buffers with no file is
3854 readable by owner only. This may annoy some small number of
3855 people, but the alternative removes all privacy from email. */
3856 auto_save_mode_bits = 0600;
3859 /* !!#### need to deal with this 'escape-quoted everywhere */
3860 Fwrite_region_internal (Qnil, Qnil, a, Qnil, Qlambda, Qnil,
3862 current_buffer->buffer_file_coding_system
3870 auto_save_expand_name_error (Lisp_Object condition_object, Lisp_Object ignored)
3872 /* #### this function should spew an error message about not being
3873 able to open the .saves file. */
3878 auto_save_expand_name (Lisp_Object name)
3880 struct gcpro gcpro1;
3882 /* note that caller did NOT gc protect name, so we do it. */
3883 /* #### dmoore - this might not be necessary, if condition_case_1
3884 protects it. but I don't think it does. */
3886 RETURN_UNGCPRO (Fexpand_file_name (name, Qnil));
3891 do_auto_save_unwind (Lisp_Object fd)
3898 do_auto_save_unwind_2 (Lisp_Object old_auto_saving)
3900 auto_saving = XINT (old_auto_saving);
3904 /* Fdo_auto_save() checks whether a GC is in progress when it is called,
3905 and if so, tries to avoid touching lisp objects.
3907 The only time that Fdo_auto_save() is called while GC is in progress
3908 is if we're going down, as a result of an abort() or a kill signal.
3909 It's fairly important that we generate autosave files in that case!
3912 DEFUN ("do-auto-save", Fdo_auto_save, 0, 2, "", /*
3913 Auto-save all buffers that need it.
3914 This is all buffers that have auto-saving enabled
3915 and are changed since last auto-saved.
3916 Auto-saving writes the buffer into a file
3917 so that your editing is not lost if the system crashes.
3918 This file is not the file you visited; that changes only when you save.
3919 Normally we run the normal hook `auto-save-hook' before saving.
3921 Non-nil first argument means do not print any message if successful.
3922 Non-nil second argument means save only current buffer.
3924 (no_message, current_only))
3926 /* This function can call lisp */
3928 Lisp_Object tail, buf;
3930 int do_handled_files;
3931 Lisp_Object oquit = Qnil;
3932 Lisp_Object listfile = Qnil;
3935 int speccount = specpdl_depth ();
3936 struct gcpro gcpro1, gcpro2, gcpro3;
3938 XSETBUFFER (old, current_buffer);
3939 GCPRO3 (oquit, listfile, old);
3940 check_quit (); /* make Vquit_flag accurate */
3941 /* Ordinarily don't quit within this function,
3942 but don't make it impossible to quit (in case we get hung in I/O). */
3946 /* No further GCPRO needed, because (when it matters) all Lisp_Object
3947 variables point to non-strings reached from Vbuffer_alist. */
3949 if (minibuf_level != 0 || preparing_for_armageddon)
3952 run_hook (Qauto_save_hook);
3954 if (STRINGP (Vauto_save_list_file_name))
3955 listfile = condition_case_1 (Qt,
3956 auto_save_expand_name,
3957 Vauto_save_list_file_name,
3958 auto_save_expand_name_error, Qnil);
3960 /* Make sure auto_saving is reset. */
3961 record_unwind_protect (do_auto_save_unwind_2, make_int (auto_saving));
3965 /* First, save all files which don't have handlers. If Emacs is
3966 crashing, the handlers may tweak what is causing Emacs to crash
3967 in the first place, and it would be a shame if Emacs failed to
3968 autosave perfectly ordinary files because it couldn't handle some
3970 for (do_handled_files = 0; do_handled_files < 2; do_handled_files++)
3972 for (tail = Vbuffer_alist;
3976 buf = XCDR (XCAR (tail));
3979 if (!NILP (current_only)
3980 && b != current_buffer)
3983 /* Don't auto-save indirect buffers.
3984 The base buffer takes care of it. */
3988 /* Check for auto save enabled
3989 and file changed since last auto save
3990 and file changed since last real save. */
3991 if (STRINGP (b->auto_save_file_name)
3992 && BUF_SAVE_MODIFF (b) < BUF_MODIFF (b)
3993 && b->auto_save_modified < BUF_MODIFF (b)
3994 /* -1 means we've turned off autosaving for a while--see below. */
3995 && XINT (b->saved_size) >= 0
3996 && (do_handled_files
3997 || NILP (Ffind_file_name_handler (b->auto_save_file_name,
4000 EMACS_TIME before_time, after_time;
4002 EMACS_GET_TIME (before_time);
4003 /* If we had a failure, don't try again for 20 minutes. */
4004 if (!preparing_for_armageddon
4005 && b->auto_save_failure_time >= 0
4006 && (EMACS_SECS (before_time) - b->auto_save_failure_time <
4010 if (!preparing_for_armageddon &&
4011 (XINT (b->saved_size) * 10
4012 > (BUF_Z (b) - BUF_BEG (b)) * 13)
4013 /* A short file is likely to change a large fraction;
4014 spare the user annoying messages. */
4015 && XINT (b->saved_size) > 5000
4016 /* These messages are frequent and annoying for `*mail*'. */
4017 && !NILP (b->filename)
4018 && NILP (no_message)
4019 && disable_auto_save_when_buffer_shrinks)
4021 /* It has shrunk too much; turn off auto-saving here.
4022 Unless we're about to crash, in which case auto-save it
4026 ("Buffer %s has shrunk a lot; auto save turned off there",
4027 XSTRING_DATA (b->name));
4028 /* Turn off auto-saving until there's a real save,
4029 and prevent any more warnings. */
4030 b->saved_size = make_int (-1);
4031 if (!gc_in_progress)
4032 Fsleep_for (make_int (1));
4035 set_buffer_internal (b);
4036 if (!auto_saved && NILP (no_message))
4038 static const unsigned char *msg
4039 = (const unsigned char *) "Auto-saving...";
4040 echo_area_message (selected_frame (), msg, Qnil,
4041 0, strlen ((const char *) msg),
4045 /* Open the auto-save list file, if necessary.
4046 We only do this now so that the file only exists
4047 if we actually auto-saved any files. */
4048 if (!auto_saved && !inhibit_auto_save_session
4049 && !NILP (Vauto_save_list_file_prefix)
4050 && STRINGP (listfile) && listdesc < 0)
4052 listdesc = open ((char *) XSTRING_DATA (listfile),
4053 O_WRONLY | O_TRUNC | O_CREAT | OPEN_BINARY,
4056 /* Arrange to close that file whether or not we get
4059 record_unwind_protect (do_auto_save_unwind,
4060 make_int (listdesc));
4063 /* Record all the buffers that we are auto-saving in
4064 the special file that lists them. For each of
4065 these buffers, record visited name (if any) and
4069 const Extbyte *auto_save_file_name_ext;
4070 Extcount auto_save_file_name_ext_len;
4072 TO_EXTERNAL_FORMAT (LISP_STRING, b->auto_save_file_name,
4073 ALLOCA, (auto_save_file_name_ext,
4074 auto_save_file_name_ext_len),
4076 if (!NILP (b->filename))
4078 const Extbyte *filename_ext;
4079 Extcount filename_ext_len;
4081 TO_EXTERNAL_FORMAT (LISP_STRING, b->filename,
4082 ALLOCA, (filename_ext,
4085 write (listdesc, filename_ext, filename_ext_len);
4087 write (listdesc, "\n", 1);
4088 write (listdesc, auto_save_file_name_ext,
4089 auto_save_file_name_ext_len);
4090 write (listdesc, "\n", 1);
4093 /* dmoore - In a bad scenario we've set b=XBUFFER(buf)
4094 based on values in Vbuffer_alist. auto_save_1 may
4095 cause lisp handlers to run. Those handlers may kill
4096 the buffer and then GC. Since the buffer is killed,
4097 it's no longer in Vbuffer_alist so it might get reaped
4098 by the GC. We also need to protect tail. */
4099 /* #### There is probably a lot of other code which has
4100 pointers into buffers which may get blown away by
4103 struct gcpro ngcpro1, ngcpro2;
4104 NGCPRO2 (buf, tail);
4105 condition_case_1 (Qt,
4107 auto_save_error, Qnil);
4110 /* Handler killed our saved current-buffer! Pick any. */
4111 if (!BUFFER_LIVE_P (XBUFFER (old)))
4112 XSETBUFFER (old, current_buffer);
4114 set_buffer_internal (XBUFFER (old));
4117 /* Handler killed their own buffer! */
4118 if (!BUFFER_LIVE_P(b))
4121 b->auto_save_modified = BUF_MODIFF (b);
4122 b->saved_size = make_int (BUF_SIZE (b));
4123 EMACS_GET_TIME (after_time);
4124 /* If auto-save took more than 60 seconds,
4125 assume it was an NFS failure that got a timeout. */
4126 if (EMACS_SECS (after_time) - EMACS_SECS (before_time) > 60)
4127 b->auto_save_failure_time = EMACS_SECS (after_time);
4132 /* Prevent another auto save till enough input events come in. */
4134 record_auto_save ();
4136 /* If we didn't save anything into the listfile, remove the old
4137 one because nothing needed to be auto-saved. Do this afterwards
4138 rather than before in case we get a crash attempting to autosave
4139 (in that case we'd still want the old one around). */
4140 if (listdesc < 0 && !auto_saved && STRINGP (listfile))
4141 unlink ((char *) XSTRING_DATA (listfile));
4143 /* Show "...done" only if the echo area would otherwise be empty. */
4144 if (auto_saved && NILP (no_message)
4145 && NILP (clear_echo_area (selected_frame (), Qauto_saving, 0)))
4147 static const unsigned char *msg
4148 = (const unsigned char *)"Auto-saving...done";
4149 echo_area_message (selected_frame (), msg, Qnil, 0,
4150 strlen ((const char *) msg), Qauto_saving);
4155 RETURN_UNGCPRO (unbind_to (speccount, Qnil));
4158 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved, 0, 0, 0, /*
4159 Mark current buffer as auto-saved with its current text.
4160 No auto-save file will be written until the buffer changes again.
4164 current_buffer->auto_save_modified = BUF_MODIFF (current_buffer);
4165 current_buffer->saved_size = make_int (BUF_SIZE (current_buffer));
4166 current_buffer->auto_save_failure_time = -1;
4170 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure, 0, 0, 0, /*
4171 Clear any record of a recent auto-save failure in the current buffer.
4175 current_buffer->auto_save_failure_time = -1;
4179 DEFUN ("recent-auto-save-p", Frecent_auto_save_p, 0, 0, 0, /*
4180 Return t if buffer has been auto-saved since last read in or saved.
4184 return (BUF_SAVE_MODIFF (current_buffer) <
4185 current_buffer->auto_save_modified) ? Qt : Qnil;
4189 /************************************************************************/
4190 /* initialization */
4191 /************************************************************************/
4194 syms_of_fileio (void)
4196 defsymbol (&Qexpand_file_name, "expand-file-name");
4197 defsymbol (&Qfile_truename, "file-truename");
4198 defsymbol (&Qsubstitute_in_file_name, "substitute-in-file-name");
4199 defsymbol (&Qdirectory_file_name, "directory-file-name");
4200 defsymbol (&Qfile_name_directory, "file-name-directory");
4201 defsymbol (&Qfile_name_nondirectory, "file-name-nondirectory");
4202 defsymbol (&Qunhandled_file_name_directory, "unhandled-file-name-directory");
4203 defsymbol (&Qfile_name_as_directory, "file-name-as-directory");
4204 defsymbol (&Qcopy_file, "copy-file");
4205 defsymbol (&Qmake_directory_internal, "make-directory-internal");
4206 defsymbol (&Qdelete_directory, "delete-directory");
4207 defsymbol (&Qdelete_file, "delete-file");
4208 defsymbol (&Qrename_file, "rename-file");
4209 defsymbol (&Qadd_name_to_file, "add-name-to-file");
4210 defsymbol (&Qmake_symbolic_link, "make-symbolic-link");
4211 defsymbol (&Qfile_exists_p, "file-exists-p");
4212 defsymbol (&Qfile_executable_p, "file-executable-p");
4213 defsymbol (&Qfile_readable_p, "file-readable-p");
4214 defsymbol (&Qfile_symlink_p, "file-symlink-p");
4215 defsymbol (&Qfile_writable_p, "file-writable-p");
4216 defsymbol (&Qfile_directory_p, "file-directory-p");
4217 defsymbol (&Qfile_regular_p, "file-regular-p");
4218 defsymbol (&Qfile_accessible_directory_p, "file-accessible-directory-p");
4219 defsymbol (&Qfile_modes, "file-modes");
4220 defsymbol (&Qset_file_modes, "set-file-modes");
4221 defsymbol (&Qfile_newer_than_file_p, "file-newer-than-file-p");
4222 defsymbol (&Qinsert_file_contents, "insert-file-contents");
4223 defsymbol (&Qwrite_region, "write-region");
4224 defsymbol (&Qverify_visited_file_modtime, "verify-visited-file-modtime");
4225 defsymbol (&Qset_visited_file_modtime, "set-visited-file-modtime");
4226 defsymbol (&Qcar_less_than_car, "car-less-than-car"); /* Vomitous! */
4228 defsymbol (&Qauto_save_hook, "auto-save-hook");
4229 defsymbol (&Qauto_save_error, "auto-save-error");
4230 defsymbol (&Qauto_saving, "auto-saving");
4232 defsymbol (&Qformat_decode, "format-decode");
4233 defsymbol (&Qformat_annotate_function, "format-annotate-function");
4235 defsymbol (&Qcompute_buffer_file_truename, "compute-buffer-file-truename");
4236 DEFERROR_STANDARD (Qfile_error, Qio_error);
4237 DEFERROR_STANDARD (Qfile_already_exists, Qfile_error);
4239 DEFSUBR (Ffind_file_name_handler);
4241 DEFSUBR (Ffile_name_directory);
4242 DEFSUBR (Ffile_name_nondirectory);
4243 DEFSUBR (Funhandled_file_name_directory);
4244 DEFSUBR (Ffile_name_as_directory);
4245 DEFSUBR (Fdirectory_file_name);
4246 DEFSUBR (Fmake_temp_name);
4247 DEFSUBR (Fexpand_file_name);
4248 DEFSUBR (Ffile_truename);
4249 DEFSUBR (Fsubstitute_in_file_name);
4250 DEFSUBR (Fcopy_file);
4251 DEFSUBR (Fmake_directory_internal);
4252 DEFSUBR (Fdelete_directory);
4253 DEFSUBR (Fdelete_file);
4254 DEFSUBR (Frename_file);
4255 DEFSUBR (Fadd_name_to_file);
4256 DEFSUBR (Fmake_symbolic_link);
4258 DEFSUBR (Fsysnetunam);
4259 #endif /* HPUX_NET */
4260 DEFSUBR (Ffile_name_absolute_p);
4261 DEFSUBR (Ffile_exists_p);
4262 DEFSUBR (Ffile_executable_p);
4263 DEFSUBR (Ffile_readable_p);
4264 DEFSUBR (Ffile_writable_p);
4265 DEFSUBR (Ffile_symlink_p);
4266 DEFSUBR (Ffile_directory_p);
4267 DEFSUBR (Ffile_accessible_directory_p);
4268 DEFSUBR (Ffile_regular_p);
4269 DEFSUBR (Ffile_modes);
4270 DEFSUBR (Fset_file_modes);
4271 DEFSUBR (Fset_default_file_modes);
4272 DEFSUBR (Fdefault_file_modes);
4273 DEFSUBR (Funix_sync);
4274 DEFSUBR (Ffile_newer_than_file_p);
4275 DEFSUBR (Finsert_file_contents_internal);
4276 DEFSUBR (Fwrite_region_internal);
4277 DEFSUBR (Fcar_less_than_car); /* Vomitous! */
4278 DEFSUBR (Fcdr_less_than_cdr); /* Yeah oh yeah bucko .... */
4280 DEFSUBR (Fencrypt_string);
4281 DEFSUBR (Fdecrypt_string);
4283 DEFSUBR (Fverify_visited_file_modtime);
4284 DEFSUBR (Fclear_visited_file_modtime);
4285 DEFSUBR (Fvisited_file_modtime);
4286 DEFSUBR (Fset_visited_file_modtime);
4288 DEFSUBR (Fdo_auto_save);
4289 DEFSUBR (Fset_buffer_auto_saved);
4290 DEFSUBR (Fclear_buffer_auto_save_failure);
4291 DEFSUBR (Frecent_auto_save_p);
4295 vars_of_fileio (void)
4297 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format /*
4298 *Format in which to write auto-save files.
4299 Should be a list of symbols naming formats that are defined in `format-alist'.
4300 If it is t, which is the default, auto-save files are written in the
4301 same format as a regular save would use.
4303 Vauto_save_file_format = Qt;
4305 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist /*
4306 *Alist of elements (REGEXP . HANDLER) for file names handled specially.
4307 If a file name matches REGEXP, then all I/O on that file is done by calling
4310 The first argument given to HANDLER is the name of the I/O primitive
4311 to be handled; the remaining arguments are the arguments that were
4312 passed to that primitive. For example, if you do
4313 (file-exists-p FILENAME)
4314 and FILENAME is handled by HANDLER, then HANDLER is called like this:
4315 (funcall HANDLER 'file-exists-p FILENAME)
4316 The function `find-file-name-handler' checks this list for a handler
4319 Vfile_name_handler_alist = Qnil;
4321 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions /*
4322 A list of functions to be called at the end of `insert-file-contents'.
4323 Each is passed one argument, the number of bytes inserted. It should return
4324 the new byte count, and leave point the same. If `insert-file-contents' is
4325 intercepted by a handler from `file-name-handler-alist', that handler is
4326 responsible for calling the after-insert-file-functions if appropriate.
4328 Vafter_insert_file_functions = Qnil;
4330 DEFVAR_LISP ("write-region-annotate-functions",
4331 &Vwrite_region_annotate_functions /*
4332 A list of functions to be called at the start of `write-region'.
4333 Each is passed two arguments, START and END, as for `write-region'.
4334 It should return a list of pairs (POSITION . STRING) of strings to be
4335 effectively inserted at the specified positions of the file being written
4336 \(1 means to insert before the first byte written). The POSITIONs must be
4337 sorted into increasing order. If there are several functions in the list,
4338 the several lists are merged destructively.
4340 Vwrite_region_annotate_functions = Qnil;
4342 DEFVAR_LISP ("write-region-annotations-so-far",
4343 &Vwrite_region_annotations_so_far /*
4344 When an annotation function is called, this holds the previous annotations.
4345 These are the annotations made by other annotation functions
4346 that were already called. See also `write-region-annotate-functions'.
4348 Vwrite_region_annotations_so_far = Qnil;
4350 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers /*
4351 A list of file name handlers that temporarily should not be used.
4352 This applies only to the operation `inhibit-file-name-operation'.
4354 Vinhibit_file_name_handlers = Qnil;
4356 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation /*
4357 The operation for which `inhibit-file-name-handlers' is applicable.
4359 Vinhibit_file_name_operation = Qnil;
4361 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name /*
4362 File name in which we write a list of all auto save file names.
4364 Vauto_save_list_file_name = Qnil;
4366 DEFVAR_LISP ("auto-save-list-file-prefix", &Vauto_save_list_file_prefix /*
4367 Prefix for generating auto-save-list-file-name.
4368 Emacs's pid and the system name will be appended to
4369 this prefix to create a unique file name.
4371 Vauto_save_list_file_prefix = build_string ("~/.saves-");
4373 DEFVAR_BOOL ("inhibit-auto-save-session", &inhibit_auto_save_session /*
4374 When non-nil, inhibit auto save list file creation.
4376 inhibit_auto_save_session = 0;
4378 DEFVAR_BOOL ("disable-auto-save-when-buffer-shrinks",
4379 &disable_auto_save_when_buffer_shrinks /*
4380 If non-nil, auto-saving is disabled when a buffer shrinks too much.
4381 This is to prevent you from losing your edits if you accidentally
4382 delete a large chunk of the buffer and don't notice it until too late.
4383 Saving the buffer normally turns auto-save back on.
4385 disable_auto_save_when_buffer_shrinks = 1;
4387 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char /*
4388 Directory separator character for built-in functions that return file names.
4389 The value should be either ?/ or ?\\ (any other value is treated as ?\\).
4390 This variable affects the built-in functions only on Windows,
4391 on other platforms, it is initialized so that Lisp code can find out
4392 what the normal separator is.
4395 Vdirectory_sep_char = make_char ('\\');
4397 Vdirectory_sep_char = make_char ('/');
4400 reinit_vars_of_fileio ();
4404 reinit_vars_of_fileio (void)
4406 /* We want temp_name_rand to be initialized to a value likely to be
4407 unique to the process, not to the executable. The danger is that
4408 two different XEmacs processes using the same binary on different
4409 machines creating temp files in the same directory will be
4410 unlucky enough to have the same pid. If we randomize using
4411 process startup time, then in practice they will be unlikely to
4412 collide. We use the microseconds field so that scripts that start
4413 simultaneous XEmacs processes on multiple machines will have less
4414 chance of collision. */
4418 EMACS_GET_TIME (thyme);
4419 temp_name_rand = (unsigned int) (EMACS_SECS (thyme) ^ EMACS_USECS (thyme));