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 Otherwise, OPERATION is the name of a funcall'able function.
370 (filename, operation))
372 /* This function does not GC */
373 /* This function can be called during GC */
374 /* This function must not munge the match data. */
375 Lisp_Object chain, inhibited_handlers;
377 CHECK_STRING (filename);
379 if (EQ (operation, Vinhibit_file_name_operation))
380 inhibited_handlers = Vinhibit_file_name_handlers;
382 inhibited_handlers = Qnil;
384 EXTERNAL_LIST_LOOP (chain, Vfile_name_handler_alist)
386 Lisp_Object elt = XCAR (chain);
389 Lisp_Object string = XCAR (elt);
391 && (fast_lisp_string_match (string, filename) >= 0))
393 Lisp_Object handler = XCDR (elt);
394 if (NILP (Fmemq (handler, inhibited_handlers)))
404 call2_check_string (Lisp_Object fn, Lisp_Object arg0, Lisp_Object arg1)
406 /* This function can call lisp */
407 Lisp_Object result = call2 (fn, arg0, arg1);
408 CHECK_STRING (result);
413 call2_check_string_or_nil (Lisp_Object fn, Lisp_Object arg0, Lisp_Object arg1)
415 /* This function can call lisp */
416 Lisp_Object result = call2 (fn, arg0, arg1);
418 CHECK_STRING (result);
423 call3_check_string (Lisp_Object fn, Lisp_Object arg0,
424 Lisp_Object arg1, Lisp_Object arg2)
426 /* This function can call lisp */
427 Lisp_Object result = call3 (fn, arg0, arg1, arg2);
428 CHECK_STRING (result);
433 DEFUN ("file-name-directory", Ffile_name_directory, 1, 1, 0, /*
434 Return the directory component in file name FILENAME.
435 Return nil if FILENAME does not include a directory.
436 Otherwise return a directory spec.
437 Given a Unix syntax file name, returns a string ending in slash.
441 /* This function can GC. GC checked 2000-07-28 ben */
446 CHECK_STRING (filename);
448 /* If the file name has special constructs in it,
449 call the corresponding file handler. */
450 handler = Ffind_file_name_handler (filename, Qfile_name_directory);
452 return call2_check_string_or_nil (handler, Qfile_name_directory, filename);
454 #ifdef FILE_SYSTEM_CASE
455 filename = FILE_SYSTEM_CASE (filename);
457 beg = XSTRING_DATA (filename);
458 p = beg + XSTRING_LENGTH (filename);
460 while (p != beg && !IS_ANY_SEP (p[-1])
461 #ifdef WIN32_FILENAMES
462 /* only recognize drive specifier at beginning */
463 && !(p[-1] == ':' && p == beg + 2)
470 /* Expansion of "c:" to drive and default directory. */
471 /* (NT does the right thing.) */
472 if (p == beg + 2 && beg[1] == ':')
474 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
475 Bufbyte *res = (Bufbyte*) alloca (MAXPATHLEN + 1);
476 if (_getdcwd (toupper (*beg) - 'A' + 1, (char *)res, MAXPATHLEN))
478 char *c=((char *) res) + strlen ((char *) res);
479 if (!IS_DIRECTORY_SEP (*c))
481 *c++ = DIRECTORY_SEP;
485 p = beg + strlen ((char *) beg);
488 #endif /* WIN32_NATIVE */
489 return make_string (beg, p - beg);
492 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory, 1, 1, 0, /*
493 Return file name FILENAME sans its directory.
494 For example, in a Unix-syntax file name,
495 this is everything after the last slash,
496 or the entire name if it contains no slash.
500 /* This function can GC. GC checked 2000-07-28 ben */
501 Bufbyte *beg, *p, *end;
504 CHECK_STRING (filename);
506 /* If the file name has special constructs in it,
507 call the corresponding file handler. */
508 handler = Ffind_file_name_handler (filename, Qfile_name_nondirectory);
510 return call2_check_string (handler, Qfile_name_nondirectory, filename);
512 beg = XSTRING_DATA (filename);
513 end = p = beg + XSTRING_LENGTH (filename);
515 while (p != beg && !IS_ANY_SEP (p[-1])
516 #ifdef WIN32_FILENAMES
517 /* only recognize drive specifier at beginning */
518 && !(p[-1] == ':' && p == beg + 2)
522 return make_string (p, end - p);
525 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory, 1, 1, 0, /*
526 Return a directly usable directory name somehow associated with FILENAME.
527 A `directly usable' directory name is one that may be used without the
528 intervention of any file handler.
529 If FILENAME is a directly usable file itself, return
530 \(file-name-directory FILENAME).
531 The `call-process' and `start-process' functions use this function to
532 get a current directory to run processes in.
536 /* This function can GC. GC checked 2000-07-28 ben */
539 /* If the file name has special constructs in it,
540 call the corresponding file handler. */
541 handler = Ffind_file_name_handler (filename, Qunhandled_file_name_directory);
543 return call2 (handler, Qunhandled_file_name_directory,
546 return Ffile_name_directory (filename);
551 file_name_as_directory (char *out, char *in)
553 /* This function cannot GC */
554 int size = strlen (in);
559 out[1] = DIRECTORY_SEP;
565 /* Append a slash if necessary */
566 if (!IS_ANY_SEP (out[size-1]))
568 out[size] = DIRECTORY_SEP;
569 out[size + 1] = '\0';
575 DEFUN ("file-name-as-directory", Ffile_name_as_directory, 1, 1, 0, /*
576 Return a string representing file FILENAME interpreted as a directory.
577 This operation exists because a directory is also a file, but its name as
578 a directory is different from its name as a file.
579 The result can be used as the value of `default-directory'
580 or passed as second argument to `expand-file-name'.
581 For a Unix-syntax file name, just appends a slash,
582 except for (file-name-as-directory \"\") => \"./\".
586 /* This function can GC. GC checked 2000-07-28 ben */
590 CHECK_STRING (filename);
592 /* If the file name has special constructs in it,
593 call the corresponding file handler. */
594 handler = Ffind_file_name_handler (filename, Qfile_name_as_directory);
596 return call2_check_string (handler, Qfile_name_as_directory, filename);
598 buf = (char *) alloca (XSTRING_LENGTH (filename) + 10);
599 return build_string (file_name_as_directory
600 (buf, (char *) XSTRING_DATA (filename)));
604 * Convert from directory name to filename.
605 * On UNIX, it's simple: just make sure there isn't a terminating /
607 * Value is nonzero if the string output is different from the input.
611 directory_file_name (const char *src, char *dst)
613 /* This function cannot GC */
614 long slen = strlen (src);
615 /* Process as Unix format: just remove any final slash.
616 But leave "/" unchanged; do not change it to "". */
619 && IS_DIRECTORY_SEP (dst[slen - 1])
620 #ifdef WIN32_FILENAMES
621 && !IS_ANY_SEP (dst[slen - 2])
622 #endif /* WIN32_FILENAMES */
628 DEFUN ("directory-file-name", Fdirectory_file_name, 1, 1, 0, /*
629 Return the file name of the directory named DIRECTORY.
630 This is the name of the file that holds the data for the directory.
631 This operation exists because a directory is also a file, but its name as
632 a directory is different from its name as a file.
633 In Unix-syntax, this function just removes the final slash.
637 /* This function can GC. GC checked 2000-07-28 ben */
641 CHECK_STRING (directory);
643 #if 0 /* #### WTF? */
644 if (NILP (directory))
648 /* If the file name has special constructs in it,
649 call the corresponding file handler. */
650 handler = Ffind_file_name_handler (directory, Qdirectory_file_name);
652 return call2_check_string (handler, Qdirectory_file_name, directory);
653 buf = (char *) alloca (XSTRING_LENGTH (directory) + 20);
654 directory_file_name ((char *) XSTRING_DATA (directory), buf);
655 return build_string (buf);
658 /* Fmake_temp_name used to be a simple wrapper around mktemp(), but it
659 proved too broken for our purposes (it supported only 26 or 62
660 unique names under some implementations). For example, this
661 arbitrary limit broke generation of Gnus Incoming* files.
663 This implementation is better than what one usually finds in libc.
666 static unsigned int temp_name_rand;
668 DEFUN ("make-temp-name", Fmake_temp_name, 1, 1, 0, /*
669 Generate a temporary file name starting with PREFIX.
670 The Emacs process number forms part of the result, so there is no
671 danger of generating a name being used by another process.
673 In addition, this function makes an attempt to choose a name that
674 does not specify an existing file. To make this work, PREFIX should
675 be an absolute file name.
679 static const char tbl[64] =
681 'A','B','C','D','E','F','G','H',
682 'I','J','K','L','M','N','O','P',
683 'Q','R','S','T','U','V','W','X',
684 'Y','Z','a','b','c','d','e','f',
685 'g','h','i','j','k','l','m','n',
686 'o','p','q','r','s','t','u','v',
687 'w','x','y','z','0','1','2','3',
688 '4','5','6','7','8','9','-','_'
695 CHECK_STRING (prefix);
697 /* I was tempted to apply Fexpand_file_name on PREFIX here, but it's
700 1) It might change the prefix, so the resulting string might not
701 begin with PREFIX. This violates the principle of least
704 2) It breaks under many unforeseeable circumstances, such as with
705 the code that uses (make-temp-name "") instead of
706 (make-temp-name "./").
708 3) It might yield unexpected (to stat(2)) results in the presence
709 of EFS and file name handlers. */
711 len = XSTRING_LENGTH (prefix);
712 val = make_uninit_string (len + 6);
713 data = XSTRING_DATA (val);
714 memcpy (data, XSTRING_DATA (prefix), len);
717 /* VAL is created by adding 6 characters to PREFIX. The first three
718 are the PID of this process, in base 64, and the second three are
719 a pseudo-random number seeded from process startup time. This
720 ensures 262144 unique file names per PID per PREFIX per machine. */
723 unsigned int pid = (unsigned int) getpid ();
724 *p++ = tbl[(pid >> 0) & 63];
725 *p++ = tbl[(pid >> 6) & 63];
726 *p++ = tbl[(pid >> 12) & 63];
729 /* Here we try to minimize useless stat'ing when this function is
730 invoked many times successively with the same PREFIX. We achieve
731 this by using a very pseudo-random number generator to generate
732 file names unique to this process, with a very long cycle. */
738 p[0] = tbl[(temp_name_rand >> 0) & 63];
739 p[1] = tbl[(temp_name_rand >> 6) & 63];
740 p[2] = tbl[(temp_name_rand >> 12) & 63];
742 /* Poor man's congruential RN generator. Replace with ++count
744 temp_name_rand += 25229;
745 temp_name_rand %= 225307;
749 if (xemacs_stat ((const char *) data, &ignored) < 0)
751 /* We want to return only if errno is ENOENT. */
755 /* The error here is dubious, but there is little else we
756 can do. The alternatives are to return nil, which is
757 as bad as (and in many cases worse than) throwing the
758 error, or to ignore the error, which will likely result
760 report_file_error ("Cannot create temporary name for prefix",
762 return Qnil; /* not reached */
768 DEFUN ("expand-file-name", Fexpand_file_name, 1, 2, 0, /*
769 Convert filename NAME to absolute, and canonicalize it.
770 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative
771 (does not start with slash); if DEFAULT-DIRECTORY is nil or missing,
772 the current buffer's value of `default-directory' is used.
773 File name components that are `.' are removed, and
774 so are file name components followed by `..', along with the `..' itself;
775 note that these simplifications are done without checking the resulting
776 file names in the file system.
777 An initial `~/' expands to your home directory.
778 An initial `~USER/' expands to USER's home directory.
779 See also the function `substitute-in-file-name'.
781 (name, default_directory))
783 /* This function can GC. GC-checked 2000-11-18 */
786 Bufbyte *newdir, *p, *o;
789 #ifdef WIN32_FILENAMES
791 int collapse_newdir = 1;
795 #endif /* WIN32_FILENAMES */
797 Lisp_Object handler = Qnil;
801 struct gcpro gcpro1, gcpro2, gcpro3;
803 /* both of these get set below */
804 GCPRO3 (name, default_directory, handler);
808 /* If the file name has special constructs in it,
809 call the corresponding file handler. */
810 handler = Ffind_file_name_handler (name, Qexpand_file_name);
812 RETURN_UNGCPRO (call3_check_string (handler, Qexpand_file_name,
813 name, default_directory));
815 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
816 if (NILP (default_directory))
817 default_directory = current_buffer->directory;
818 if (! STRINGP (default_directory))
819 default_directory = build_string ("/");
821 if (!NILP (default_directory))
823 handler = Ffind_file_name_handler (default_directory, Qexpand_file_name);
825 RETURN_UNGCPRO (call3 (handler, Qexpand_file_name,
826 name, default_directory));
829 o = XSTRING_DATA (default_directory);
831 /* Make sure DEFAULT_DIRECTORY is properly expanded.
832 It would be better to do this down below where we actually use
833 default_directory. Unfortunately, calling Fexpand_file_name recursively
834 could invoke GC, and the strings might be relocated. This would
835 be annoying because we have pointers into strings lying around
836 that would need adjusting, and people would add new pointers to
837 the code and forget to adjust them, resulting in intermittent bugs.
838 Putting this call here avoids all that crud.
840 The EQ test avoids infinite recursion. */
841 if (! NILP (default_directory) && !EQ (default_directory, name)
842 /* Save time in some common cases - as long as default_directory
843 is not relative, it can be canonicalized with name below (if it
844 is needed at all) without requiring it to be expanded now. */
845 #ifdef WIN32_FILENAMES
846 /* Detect Windows file names with drive specifiers. */
847 && ! (IS_DRIVE (o[0]) && (IS_DEVICE_SEP (o[1]) && IS_DIRECTORY_SEP (o[2])))
848 /* Detect Windows file names in UNC format. */
849 && ! (IS_DIRECTORY_SEP (o[0]) && IS_DIRECTORY_SEP (o[1]))
850 #endif /* not WIN32_FILENAMES */
852 /* Detect Unix absolute file names (/... alone is not absolute on
854 && ! (IS_DIRECTORY_SEP (o[0]))
855 #endif /* not WIN32_NATIVE */
858 default_directory = Fexpand_file_name (default_directory, Qnil);
860 #ifdef FILE_SYSTEM_CASE
861 name = FILE_SYSTEM_CASE (name);
864 /* #### dmoore - this is ugly, clean this up. Looks like nm pointing
865 into name should be safe during all of this, though. */
866 nm = XSTRING_DATA (name);
868 #ifdef WIN32_FILENAMES
869 /* We will force directory separators to be either all \ or /, so make
870 a local copy to modify, even if there ends up being no change. */
871 nm = (Bufbyte *) strcpy ((char *) alloca (strlen ((char *) nm) + 1),
874 /* Find and remove drive specifier if present; this makes nm absolute
875 even if the rest of the name appears to be relative. */
877 Bufbyte *colon = (Bufbyte *) strrchr ((char *)nm, ':');
881 /* Only recognize colon as part of drive specifier if there is a
882 single alphabetic character preceding the colon (and if the
883 character before the drive letter, if present, is a directory
884 separator); this is to support the remote system syntax used by
885 ange-ftp, and the "po:username" syntax for POP mailboxes. */
889 else if (IS_DRIVE (colon[-1])
890 && (colon == nm + 1 || IS_DIRECTORY_SEP (colon[-2])))
897 while (--colon >= nm)
904 /* If we see "c://somedir", we want to strip the first slash after the
905 colon when stripping the drive letter. Otherwise, this expands to
907 if (drive && IS_DIRECTORY_SEP (nm[0]) && IS_DIRECTORY_SEP (nm[1]))
909 #endif /* WIN32_FILENAMES */
911 /* If nm is absolute, look for /./ or /../ sequences; if none are
912 found, we can probably return right away. We will avoid allocating
913 a new string if name is already fully expanded. */
915 IS_DIRECTORY_SEP (nm[0])
917 && (drive || IS_DIRECTORY_SEP (nm[1]))
921 /* If it turns out that the filename we want to return is just a
922 suffix of FILENAME, we don't need to go through and edit
923 things; we just need to construct a new string using data
924 starting at the middle of FILENAME. If we set lose to a
925 non-zero value, that means we've discovered that we can't do
932 /* Since we know the name is absolute, we can assume that each
933 element starts with a "/". */
935 /* "." and ".." are hairy. */
936 if (IS_DIRECTORY_SEP (p[0])
938 && (IS_DIRECTORY_SEP (p[2])
940 || (p[2] == '.' && (IS_DIRECTORY_SEP (p[3])
947 #ifdef WIN32_FILENAMES
948 if (drive || IS_DIRECTORY_SEP (nm[1]))
950 /* Make sure directories are all separated with / or \ as
951 desired, but avoid allocation of a new string when not
953 CORRECT_DIR_SEPS (nm);
954 if (IS_DIRECTORY_SEP (nm[1]))
956 if (strcmp ((char *) nm, (char *) XSTRING_DATA (name)) != 0)
957 name = build_string ((Bufbyte *) nm);
959 /* drive must be set, so this is okay */
960 else if (strcmp ((char *) nm - 2,
961 (char *) XSTRING_DATA (name)) != 0)
963 name = make_string (nm - 2, p - nm + 2);
964 XSTRING_DATA (name)[0] = DRIVE_LETTER (drive);
965 XSTRING_DATA (name)[1] = ':';
967 RETURN_UNGCPRO (name);
969 #endif /* not WIN32_FILENAMES */
971 if (nm == XSTRING_DATA (name))
972 RETURN_UNGCPRO (name);
973 RETURN_UNGCPRO (build_string ((char *) nm));
974 #endif /* not WIN32_NATIVE */
978 /* At this point, nm might or might not be an absolute file name. We
979 need to expand ~ or ~user if present, otherwise prefix nm with
980 default_directory if nm is not absolute, and finally collapse /./
981 and /foo/../ sequences.
983 We set newdir to be the appropriate prefix if one is needed:
984 - the relevant user directory if nm starts with ~ or ~user
985 - the specified drive's working dir (DOS/NT only) if nm does not
987 - the value of default_directory.
989 Note that these prefixes are not guaranteed to be absolute (except
990 for the working dir of a drive). Therefore, to ensure we always
991 return an absolute name, if the final prefix is not absolute we
992 append it to the current working directory. */
996 if (nm[0] == '~') /* prefix ~ */
998 if (IS_DIRECTORY_SEP (nm[1])
999 || nm[1] == 0) /* ~ by itself */
1001 Extbyte *newdir_external = get_home_directory ();
1003 if (newdir_external == NULL)
1004 newdir = (Bufbyte *) "";
1006 TO_INTERNAL_FORMAT (C_STRING, newdir_external,
1007 C_STRING_ALLOCA, (* ((char **) &newdir)),
1011 #ifdef WIN32_FILENAMES
1012 collapse_newdir = 0;
1015 else /* ~user/filename */
1017 for (p = nm; *p && (!IS_DIRECTORY_SEP (*p)); p++)
1019 o = (Bufbyte *) alloca (p - nm + 1);
1020 memcpy (o, (char *) nm, p - nm);
1023 /* #### While NT is single-user (for the moment) you still
1024 can have multiple user profiles users defined, each with
1025 its HOME. So maybe possibly we should think about handling
1027 #ifndef WIN32_NATIVE
1029 if ((user = user_login_name (NULL)) != NULL)
1031 /* Does the user login name match the ~name? */
1032 if (strcmp (user, (char *) o + 1) == 0)
1034 newdir = (Bufbyte *) get_home_directory();
1041 /* Jamie reports that getpwnam() can get wedged by SIGIO/SIGALARM
1042 occurring in it. (It can call select()). */
1043 slow_down_interrupts ();
1044 pw = (struct passwd *) getpwnam ((char *) o + 1);
1045 speed_up_interrupts ();
1048 newdir = (Bufbyte *) pw -> pw_dir;
1054 #endif /* not WIN32_NATIVE */
1056 /* If we don't find a user of that name, leave the name
1057 unchanged; don't move nm forward to p. */
1061 #ifdef WIN32_FILENAMES
1062 /* On DOS and Windows, nm is absolute if a drive name was specified;
1063 use the drive's current directory as the prefix if needed. */
1064 if (!newdir && drive)
1067 /* Get default directory if needed to make nm absolute. */
1068 if (!IS_DIRECTORY_SEP (nm[0]))
1070 newdir = (Bufbyte *) alloca (MAXPATHLEN + 1);
1071 if (!_getdcwd (toupper (drive) - 'A' + 1, newdir, MAXPATHLEN))
1074 #endif /* WIN32_NATIVE */
1077 /* Either nm starts with /, or drive isn't mounted. */
1078 newdir = (Bufbyte *) alloca (4);
1079 newdir[0] = DRIVE_LETTER (drive);
1085 #endif /* WIN32_FILENAMES */
1087 /* Finally, if no prefix has been specified and nm is not absolute,
1088 then it must be expanded relative to default_directory. */
1091 #ifndef WIN32_NATIVE
1092 /* /... alone is not absolute on DOS and Windows. */
1093 && !IS_DIRECTORY_SEP (nm[0])
1095 #ifdef WIN32_FILENAMES
1096 && !(IS_DIRECTORY_SEP (nm[0]) && IS_DIRECTORY_SEP (nm[1]))
1100 newdir = XSTRING_DATA (default_directory);
1103 #ifdef WIN32_FILENAMES
1106 /* First ensure newdir is an absolute name. */
1108 /* Detect Windows file names with drive specifiers. */
1109 ! (IS_DRIVE (newdir[0])
1110 && IS_DEVICE_SEP (newdir[1]) && IS_DIRECTORY_SEP (newdir[2]))
1111 /* Detect Windows file names in UNC format. */
1112 && ! (IS_DIRECTORY_SEP (newdir[0]) && IS_DIRECTORY_SEP (newdir[1]))
1113 /* Detect drive spec by itself */
1114 && ! (IS_DEVICE_SEP (newdir[1]) && newdir[2] == 0)
1115 /* Detect unix format. */
1116 #ifndef WIN32_NATIVE
1117 && ! (IS_DIRECTORY_SEP (newdir[0]))
1121 /* Effectively, let newdir be (expand-file-name newdir cwd).
1122 Because of the admonition against calling expand-file-name
1123 when we have pointers into lisp strings, we accomplish this
1124 indirectly by prepending newdir to nm if necessary, and using
1125 cwd (or the wd of newdir's drive) as the new newdir. */
1127 if (IS_DRIVE (newdir[0]) && newdir[1] == ':')
1132 if (!IS_DIRECTORY_SEP (nm[0]))
1134 Bufbyte *tmp = (Bufbyte *) alloca (strlen ((char *) newdir) +
1135 strlen ((char *) nm) + 2);
1136 file_name_as_directory ((char *) tmp, (char *) newdir);
1137 strcat ((char *) tmp, (char *) nm);
1140 newdir = (Bufbyte *) alloca (MAXPATHLEN + 1);
1144 if (!_getdcwd (toupper (drive) - 'A' + 1, newdir, MAXPATHLEN))
1146 newdir = (Bufbyte *) "/";
1149 getcwd ((char *) newdir, MAXPATHLEN);
1152 /* Strip off drive name from prefix, if present. */
1153 if (IS_DRIVE (newdir[0]) && newdir[1] == ':')
1159 /* Keep only a prefix from newdir if nm starts with slash
1160 (/ /server/share for UNC, nothing otherwise). */
1161 if (IS_DIRECTORY_SEP (nm[0])
1162 #ifndef WIN32_NATIVE
1163 && IS_DIRECTORY_SEP (nm[1])
1167 if (IS_DIRECTORY_SEP (newdir[0]) && IS_DIRECTORY_SEP (newdir[1]))
1171 strcpy ((char *) alloca (strlen ((char *) newdir) + 1),
1174 while (*p && !IS_DIRECTORY_SEP (*p)) p++;
1176 while (*p && !IS_DIRECTORY_SEP (*p)) p++;
1180 newdir = (Bufbyte *) "";
1183 #endif /* WIN32_FILENAMES */
1187 /* Get rid of any slash at the end of newdir, unless newdir is
1188 just // (an incomplete UNC name). */
1189 length = strlen ((char *) newdir);
1190 if (length > 1 && IS_DIRECTORY_SEP (newdir[length - 1])
1191 #ifdef WIN32_FILENAMES
1192 && !(length == 2 && IS_DIRECTORY_SEP (newdir[0]))
1196 Bufbyte *temp = (Bufbyte *) alloca (length);
1197 memcpy (temp, newdir, length - 1);
1198 temp[length - 1] = 0;
1206 /* Now concatenate the directory and name to new space in the stack frame */
1207 tlen += strlen ((char *) nm) + 1;
1208 #ifdef WIN32_FILENAMES
1209 /* Add reserved space for drive name. (The Microsoft x86 compiler
1210 produces incorrect code if the following two lines are combined.) */
1211 target = (Bufbyte *) alloca (tlen + 2);
1213 #else /* not WIN32_FILENAMES */
1214 target = (Bufbyte *) alloca (tlen);
1215 #endif /* not WIN32_FILENAMES */
1220 if (nm[0] == 0 || IS_DIRECTORY_SEP (nm[0]))
1221 strcpy ((char *) target, (char *) newdir);
1223 file_name_as_directory ((char *) target, (char *) newdir);
1226 strcat ((char *) target, (char *) nm);
1228 /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */
1230 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1237 if (!IS_DIRECTORY_SEP (*p))
1241 else if (IS_DIRECTORY_SEP (p[0])
1243 && (IS_DIRECTORY_SEP (p[2])
1246 /* If "/." is the entire filename, keep the "/". Otherwise,
1247 just delete the whole "/.". */
1248 if (o == target && p[2] == '\0')
1252 else if (IS_DIRECTORY_SEP (p[0]) && p[1] == '.' && p[2] == '.'
1253 /* `/../' is the "superroot" on certain file systems. */
1255 && (IS_DIRECTORY_SEP (p[3]) || p[3] == 0))
1257 while (o != target && (--o) && !IS_DIRECTORY_SEP (*o))
1259 /* Keep initial / only if this is the whole name. */
1260 if (o == target && IS_ANY_SEP (*o) && p[3] == 0)
1264 #ifdef WIN32_FILENAMES
1265 /* if drive is set, we're not dealing with an UNC, so
1266 multiple dir-seps are redundant (and reportedly cause trouble
1268 else if (drive && IS_DIRECTORY_SEP (p[0]) && IS_DIRECTORY_SEP (p[1]))
1277 #ifdef WIN32_FILENAMES
1278 /* At last, set drive name, except for network file name. */
1282 target[0] = DRIVE_LETTER (drive);
1288 assert (IS_DIRECTORY_SEP (target[0]) && IS_DIRECTORY_SEP (target[1]));
1291 CORRECT_DIR_SEPS (target);
1292 #endif /* WIN32_FILENAMES */
1294 RETURN_UNGCPRO (make_string (target, o - target));
1297 DEFUN ("file-truename", Ffile_truename, 1, 2, 0, /*
1298 Return the canonical name of FILENAME.
1299 Second arg DEFAULT is directory to start with if FILENAME is relative
1300 (does not start with slash); if DEFAULT is nil or missing,
1301 the current buffer's value of `default-directory' is used.
1302 No component of the resulting pathname will be a symbolic link, as
1303 in the realpath() function.
1305 (filename, default_))
1307 /* This function can GC. GC checked 2000-07-28 ben. */
1308 Lisp_Object expanded_name;
1309 struct gcpro gcpro1;
1311 CHECK_STRING (filename);
1313 expanded_name = Fexpand_file_name (filename, default_);
1315 if (!STRINGP (expanded_name))
1318 GCPRO1 (expanded_name);
1321 Lisp_Object handler =
1322 Ffind_file_name_handler (expanded_name, Qfile_truename);
1324 if (!NILP (handler))
1326 (call2_check_string (handler, Qfile_truename, expanded_name));
1330 char resolved_path[MAXPATHLEN];
1335 TO_EXTERNAL_FORMAT (LISP_STRING, expanded_name,
1336 ALLOCA, (path, elen),
1339 #if defined(WIN32_FILENAMES) && defined(CYGWIN)
1340 /* When using win32 filenames in cygwin we want file-truename to
1341 detect that c:/windows == /windows for example. */
1342 if ((IS_DIRECTORY_SEP (path[0])
1343 && (elen == 1 || !IS_DIRECTORY_SEP (path[1])))
1344 || (isalpha (path[0])
1345 && (elen == 1 || !IS_DEVICE_SEP (path[1])))) {
1347 cygwin_posix_to_win32_path_list_buf_size (path);
1348 p = (Bufbyte *) alloca (ltwff2);
1349 cygwin_posix_to_win32_path_list (path, p);
1355 if (elen > MAXPATHLEN)
1358 /* Try doing it all at once. */
1359 /* !! Does realpath() Mule-encapsulate?
1360 Answer: Nope! So we do it above */
1361 if (!xrealpath ((char *) path, resolved_path))
1363 /* Didn't resolve it -- have to do it one component at a time. */
1364 /* "realpath" is a typically useless, stupid un*x piece of crap.
1365 It claims to return a useful value in the "error" case, but since
1366 there is no indication provided of how far along the pathname
1367 the function went before erring, there is no way to use the
1368 partial result returned. What a piece of junk.
1370 The above comment refers to historical versions of
1371 realpath(). The Unix98 specs state:
1373 "On successful completion, realpath() returns a
1374 pointer to the resolved name. Otherwise, realpath()
1375 returns a null pointer and sets errno to indicate the
1376 error, and the contents of the buffer pointed to by
1377 resolved_name are undefined."
1379 Since we depend on undocumented semantics of various system realpath()s,
1380 we just use our own version in realpath.c. */
1385 #ifdef WIN32_FILENAMES
1386 if (IS_DRIVE (p[0]) && IS_DEVICE_SEP (p[1])
1387 && IS_DIRECTORY_SEP (p[2]))
1388 /* don't test c: on windows */
1390 else if (IS_DIRECTORY_SEP (p[0]) && IS_DIRECTORY_SEP (p[1]))
1391 /* start after // */
1394 for (pos = p + 1; pos < path + elen; pos++)
1395 if (IS_DIRECTORY_SEP (*pos))
1403 if (xrealpath ((char *) path, resolved_path))
1411 else if (errno == ENOENT || errno == EACCES)
1413 /* Failed on this component. Just tack on the rest of
1414 the string and we are done. */
1415 int rlen = strlen (resolved_path);
1417 /* "On failure, it returns NULL, sets errno to indicate
1418 the error, and places in resolved_path the absolute pathname
1419 of the path component which could not be resolved." */
1423 int plen = elen - (p - path);
1425 if (rlen > 1 && IS_DIRECTORY_SEP (resolved_path[rlen - 1]))
1428 if (plen + rlen + 1 > countof (resolved_path))
1431 resolved_path[rlen] = DIRECTORY_SEP;
1432 memcpy (resolved_path + rlen + 1, p + 1, plen + 1 - 1);
1442 Lisp_Object resolved_name;
1443 int rlen = strlen (resolved_path);
1444 if (elen > 0 && IS_DIRECTORY_SEP (XSTRING_BYTE (expanded_name, elen - 1))
1445 && !(rlen > 0 && IS_DIRECTORY_SEP (resolved_path[rlen - 1])))
1447 if (rlen + 1 > countof (resolved_path))
1449 resolved_path[rlen++] = DIRECTORY_SEP;
1450 resolved_path[rlen] = '\0';
1452 TO_INTERNAL_FORMAT (DATA, (resolved_path, rlen),
1453 LISP_STRING, resolved_name,
1455 RETURN_UNGCPRO (resolved_name);
1459 errno = ENAMETOOLONG;
1462 report_file_error ("Finding truename", list1 (expanded_name));
1464 RETURN_UNGCPRO (Qnil);
1468 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name, 1, 1, 0, /*
1469 Substitute environment variables referred to in FILENAME.
1470 `$FOO' where FOO is an environment variable name means to substitute
1471 the value of that variable. The variable name should be terminated
1472 with a character, not a letter, digit or underscore; otherwise, enclose
1473 the entire variable name in braces.
1474 If `/~' appears, all of FILENAME through that `/' is discarded.
1478 /* This function can GC. GC checked 2000-07-28 ben. */
1481 Bufbyte *s, *p, *o, *x, *endp;
1482 Bufbyte *target = 0;
1484 int substituted = 0;
1486 Lisp_Object handler;
1488 CHECK_STRING (filename);
1490 /* If the file name has special constructs in it,
1491 call the corresponding file handler. */
1492 handler = Ffind_file_name_handler (filename, Qsubstitute_in_file_name);
1493 if (!NILP (handler))
1494 return call2_check_string_or_nil (handler, Qsubstitute_in_file_name,
1497 nm = XSTRING_DATA (filename);
1498 endp = nm + XSTRING_LENGTH (filename);
1500 /* If /~ or // appears, discard everything through first slash. */
1502 for (p = nm; p != endp; p++)
1505 #if defined (WIN32_FILENAMES)
1506 /* // at start of file name is meaningful in WindowsNT systems */
1507 || (IS_DIRECTORY_SEP (p[0]) && p - 1 != nm)
1508 #else /* not (WIN32_FILENAMES) */
1509 || IS_DIRECTORY_SEP (p[0])
1510 #endif /* not (WIN32_FILENAMES) */
1513 && (IS_DIRECTORY_SEP (p[-1])))
1518 #ifdef WIN32_FILENAMES
1519 /* see comment in expand-file-name about drive specifiers */
1520 else if (IS_DRIVE (p[0]) && p[1] == ':'
1521 && p > nm && IS_DIRECTORY_SEP (p[-1]))
1526 #endif /* WIN32_FILENAMES */
1529 /* See if any variables are substituted into the string
1530 and find the total length of their values in `total' */
1532 for (p = nm; p != endp;)
1542 /* "$$" means a single "$" */
1551 while (p != endp && *p != '}') p++;
1552 if (*p != '}') goto missingclose;
1558 while (p != endp && (isalnum (*p) || *p == '_')) p++;
1562 /* Copy out the variable name */
1563 target = (Bufbyte *) alloca (s - o + 1);
1564 strncpy ((char *) target, (char *) o, s - o);
1567 strupr (target); /* $home == $HOME etc. */
1568 #endif /* WIN32_NATIVE */
1570 /* Get variable value */
1571 o = (Bufbyte *) egetenv ((char *) target);
1572 if (!o) goto badvar;
1573 total += strlen ((char *) o);
1580 /* If substitution required, recopy the filename and do it */
1581 /* Make space in stack frame for the new copy */
1582 xnm = (Bufbyte *) alloca (XSTRING_LENGTH (filename) + total + 1);
1585 /* Copy the rest of the name through, replacing $ constructs with values */
1602 while (p != endp && *p != '}') p++;
1603 if (*p != '}') goto missingclose;
1609 while (p != endp && (isalnum (*p) || *p == '_')) p++;
1613 /* Copy out the variable name */
1614 target = (Bufbyte *) alloca (s - o + 1);
1615 strncpy ((char *) target, (char *) o, s - o);
1618 strupr (target); /* $home == $HOME etc. */
1619 #endif /* WIN32_NATIVE */
1621 /* Get variable value */
1622 o = (Bufbyte *) egetenv ((char *) target);
1626 strcpy ((char *) x, (char *) o);
1627 x += strlen ((char *) o);
1632 /* If /~ or // appears, discard everything through first slash. */
1634 for (p = xnm; p != x; p++)
1636 #if defined (WIN32_FILENAMES)
1637 || (IS_DIRECTORY_SEP (p[0]) && p - 1 != xnm)
1638 #else /* not WIN32_FILENAMES */
1639 || IS_DIRECTORY_SEP (p[0])
1640 #endif /* not WIN32_FILENAMES */
1642 /* don't do p[-1] if that would go off the beginning --jwz */
1643 && p != nm && p > xnm && IS_DIRECTORY_SEP (p[-1]))
1645 #ifdef WIN32_FILENAMES
1646 else if (IS_DRIVE (p[0]) && p[1] == ':'
1647 && p > nm && IS_DIRECTORY_SEP (p[-1]))
1651 return make_string (xnm, x - xnm);
1654 syntax_error ("Bad format environment-variable substitution", filename);
1656 syntax_error ("Missing \"}\" in environment-variable substitution",
1659 syntax_error_2 ("Substituting nonexistent environment variable",
1660 filename, build_string ((char *) target));
1663 return Qnil; /* suppress compiler warning */
1666 /* A slightly faster and more convenient way to get
1667 (directory-file-name (expand-file-name FOO)). */
1670 expand_and_dir_to_file (Lisp_Object filename, Lisp_Object defdir)
1672 /* This function can call Lisp. GC checked 2000-07-28 ben */
1673 Lisp_Object abspath;
1674 struct gcpro gcpro1;
1676 abspath = Fexpand_file_name (filename, defdir);
1678 /* Remove final slash, if any (unless path is root).
1679 stat behaves differently depending! */
1680 if (XSTRING_LENGTH (abspath) > 1
1681 && IS_DIRECTORY_SEP (XSTRING_BYTE (abspath, XSTRING_LENGTH (abspath) - 1))
1682 && !IS_DEVICE_SEP (XSTRING_BYTE (abspath, XSTRING_LENGTH (abspath) - 2)))
1683 /* We cannot take shortcuts; they might be wrong for magic file names. */
1684 abspath = Fdirectory_file_name (abspath);
1689 /* Signal an error if the file ABSNAME already exists.
1690 If INTERACTIVE is nonzero, ask the user whether to proceed,
1691 and bypass the error if the user says to go ahead.
1692 QUERYSTRING is a name for the action that is being considered
1694 *STATPTR is used to store the stat information if the file exists.
1695 If the file does not exist, STATPTR->st_mode is set to 0. */
1698 barf_or_query_if_file_exists (Lisp_Object absname, const char *querystring,
1699 int interactive, struct stat *statptr)
1701 /* This function can call Lisp. GC checked 2000-07-28 ben */
1702 struct stat statbuf;
1704 /* stat is a good way to tell whether the file exists,
1705 regardless of what access permissions it has. */
1706 if (xemacs_stat ((char *) XSTRING_DATA (absname), &statbuf) >= 0)
1713 struct gcpro gcpro1;
1715 prompt = emacs_doprnt_string_c
1716 ((const Bufbyte *) GETTEXT ("File %s already exists; %s anyway? "),
1717 Qnil, -1, XSTRING_DATA (absname),
1718 GETTEXT (querystring));
1721 tem = call1 (Qyes_or_no_p, prompt);
1728 Fsignal (Qfile_already_exists,
1729 list2 (build_translated_string ("File already exists"),
1737 statptr->st_mode = 0;
1742 DEFUN ("copy-file", Fcopy_file, 2, 4,
1743 "fCopy file: \nFCopy %s to file: \np\nP", /*
1744 Copy FILENAME to NEWNAME. Both args must be strings.
1745 Signals a `file-already-exists' error if file NEWNAME already exists,
1746 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.
1747 A number as third arg means request confirmation if NEWNAME already exists.
1748 This is what happens in interactive use with M-x.
1749 Fourth arg KEEP-TIME non-nil means give the new file the same
1750 last-modified time as the old one. (This works on only some systems.)
1751 A prefix arg makes KEEP-TIME non-nil.
1753 (filename, newname, ok_if_already_exists, keep_time))
1755 /* This function can call Lisp. GC checked 2000-07-28 ben */
1757 char buf[16 * 1024];
1758 struct stat st, out_st;
1759 Lisp_Object handler;
1760 int speccount = specpdl_depth ();
1761 struct gcpro gcpro1, gcpro2;
1762 /* Lisp_Object args[6]; */
1763 int input_file_statable_p;
1765 GCPRO2 (filename, newname);
1766 CHECK_STRING (filename);
1767 CHECK_STRING (newname);
1768 filename = Fexpand_file_name (filename, Qnil);
1769 newname = Fexpand_file_name (newname, Qnil);
1771 /* If the input file name has special constructs in it,
1772 call the corresponding file handler. */
1773 handler = Ffind_file_name_handler (filename, Qcopy_file);
1774 /* Likewise for output file name. */
1776 handler = Ffind_file_name_handler (newname, Qcopy_file);
1777 if (!NILP (handler))
1780 return call5 (handler, Qcopy_file, filename, newname,
1781 ok_if_already_exists, keep_time);
1784 /* When second argument is a directory, copy the file into it.
1785 (copy-file "foo" "bar/") == (copy-file "foo" "bar/foo")
1787 if (!NILP (Ffile_directory_p (newname)))
1789 Lisp_Object args[3];
1790 struct gcpro ngcpro1;
1794 args[1] = Qnil; args[2] = Qnil;
1797 if (!IS_DIRECTORY_SEP (XSTRING_BYTE (newname,
1798 XSTRING_LENGTH (newname) - 1)))
1800 args[i++] = Fchar_to_string (Vdirectory_sep_char);
1801 args[i++] = Ffile_name_nondirectory (filename);
1802 newname = Fconcat (i, args);
1806 if (NILP (ok_if_already_exists)
1807 || INTP (ok_if_already_exists))
1808 barf_or_query_if_file_exists (newname, "copy to it",
1809 INTP (ok_if_already_exists), &out_st);
1810 else if (xemacs_stat ((const char *) XSTRING_DATA (newname), &out_st) < 0)
1813 ifd = interruptible_open ((char *) XSTRING_DATA (filename), O_RDONLY | OPEN_BINARY, 0);
1815 report_file_error ("Opening input file", list1 (filename));
1817 record_unwind_protect (close_file_unwind, make_int (ifd));
1819 /* We can only copy regular files and symbolic links. Other files are not
1821 input_file_statable_p = (fstat (ifd, &st) >= 0);
1823 #ifndef WIN32_NATIVE
1824 if (out_st.st_mode != 0
1825 && st.st_dev == out_st.st_dev && st.st_ino == out_st.st_ino)
1828 report_file_error ("Input and output files are the same",
1829 list2 (filename, newname));
1833 #if defined (S_ISREG) && defined (S_ISLNK)
1834 if (input_file_statable_p)
1836 if (!(S_ISREG (st.st_mode))
1837 /* XEmacs: have to allow S_ISCHR in order to copy /dev/null */
1839 && !(S_ISCHR (st.st_mode))
1841 && !(S_ISLNK (st.st_mode)))
1843 #if defined (EISDIR)
1844 /* Get a better looking error message. */
1847 report_file_error ("Non-regular file", list1 (filename));
1850 #endif /* S_ISREG && S_ISLNK */
1852 ofd = open( (char *) XSTRING_DATA (newname),
1853 O_WRONLY | O_CREAT | O_TRUNC | OPEN_BINARY, CREAT_MODE);
1855 report_file_error ("Opening output file", list1 (newname));
1858 Lisp_Object ofd_locative = noseeum_cons (make_int (ofd), Qnil);
1860 record_unwind_protect (close_file_unwind, ofd_locative);
1862 while ((n = read_allowing_quit (ifd, buf, sizeof (buf))) > 0)
1864 if (write_allowing_quit (ofd, buf, n) != n)
1865 report_file_error ("I/O error", list1 (newname));
1868 /* Closing the output clobbers the file times on some systems. */
1869 if (close (ofd) < 0)
1870 report_file_error ("I/O error", list1 (newname));
1872 if (input_file_statable_p)
1874 if (!NILP (keep_time))
1876 EMACS_TIME atime, mtime;
1877 EMACS_SET_SECS_USECS (atime, st.st_atime, 0);
1878 EMACS_SET_SECS_USECS (mtime, st.st_mtime, 0);
1879 if (set_file_times (newname, atime, mtime))
1880 report_file_error ("I/O error", list1 (newname));
1882 chmod ((const char *) XSTRING_DATA (newname),
1883 st.st_mode & 07777);
1886 /* We'll close it by hand */
1887 XCAR (ofd_locative) = Qnil;
1890 unbind_to (speccount, Qnil);
1897 DEFUN ("make-directory-internal", Fmake_directory_internal, 1, 1, 0, /*
1898 Create a directory. One argument, a file name string.
1902 /* This function can GC. GC checked 1997.04.06. */
1903 char dir [MAXPATHLEN];
1904 Lisp_Object handler;
1905 struct gcpro gcpro1;
1907 CHECK_STRING (dirname_);
1908 dirname_ = Fexpand_file_name (dirname_, Qnil);
1911 handler = Ffind_file_name_handler (dirname_, Qmake_directory_internal);
1913 if (!NILP (handler))
1914 return (call2 (handler, Qmake_directory_internal, dirname_));
1916 if (XSTRING_LENGTH (dirname_) > (Bytecount) (sizeof (dir) - 1))
1918 return Fsignal (Qfile_error,
1919 list3 (build_translated_string ("Creating directory"),
1920 build_translated_string ("pathname too long"),
1923 strncpy (dir, (char *) XSTRING_DATA (dirname_),
1924 XSTRING_LENGTH (dirname_) + 1);
1926 if (dir [XSTRING_LENGTH (dirname_) - 1] == '/')
1927 dir [XSTRING_LENGTH (dirname_) - 1] = 0;
1929 if (mkdir (dir, 0777) != 0)
1930 report_file_error ("Creating directory", list1 (dirname_));
1935 DEFUN ("delete-directory", Fdelete_directory, 1, 1, "FDelete directory: ", /*
1936 Delete a directory. One argument, a file name or directory name string.
1940 /* This function can GC. GC checked 1997.04.06. */
1941 Lisp_Object handler;
1942 struct gcpro gcpro1;
1944 CHECK_STRING (dirname_);
1947 dirname_ = Fexpand_file_name (dirname_, Qnil);
1948 dirname_ = Fdirectory_file_name (dirname_);
1950 handler = Ffind_file_name_handler (dirname_, Qdelete_directory);
1952 if (!NILP (handler))
1953 return (call2 (handler, Qdelete_directory, dirname_));
1955 if (rmdir ((char *) XSTRING_DATA (dirname_)) != 0)
1956 report_file_error ("Removing directory", list1 (dirname_));
1961 DEFUN ("delete-file", Fdelete_file, 1, 1, "fDelete file: ", /*
1962 Delete the file named FILENAME (a string).
1963 If FILENAME has multiple names, it continues to exist with the other names.
1967 /* This function can GC. GC checked 1997.04.06. */
1968 Lisp_Object handler;
1969 struct gcpro gcpro1;
1971 CHECK_STRING (filename);
1972 filename = Fexpand_file_name (filename, Qnil);
1975 handler = Ffind_file_name_handler (filename, Qdelete_file);
1977 if (!NILP (handler))
1978 return call2 (handler, Qdelete_file, filename);
1980 if (0 > unlink ((char *) XSTRING_DATA (filename)))
1981 report_file_error ("Removing old name", list1 (filename));
1986 internal_delete_file_1 (Lisp_Object ignore, Lisp_Object ignore2)
1991 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */
1994 internal_delete_file (Lisp_Object filename)
1996 /* This function can GC. GC checked 1997.04.06. */
1997 return NILP (condition_case_1 (Qt, Fdelete_file, filename,
1998 internal_delete_file_1, Qnil));
2001 DEFUN ("rename-file", Frename_file, 2, 3,
2002 "fRename file: \nFRename %s to file: \np", /*
2003 Rename FILENAME as NEWNAME. Both args must be strings.
2004 If file has names other than FILENAME, it continues to have those names.
2005 Signals a `file-already-exists' error if a file NEWNAME already exists
2006 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2007 A number as third arg means request confirmation if NEWNAME already exists.
2008 This is what happens in interactive use with M-x.
2010 (filename, newname, ok_if_already_exists))
2012 /* This function can GC. GC checked 1997.04.06. */
2013 Lisp_Object handler;
2014 struct gcpro gcpro1, gcpro2;
2016 GCPRO2 (filename, newname);
2017 CHECK_STRING (filename);
2018 CHECK_STRING (newname);
2019 filename = Fexpand_file_name (filename, Qnil);
2020 newname = Fexpand_file_name (newname, Qnil);
2022 /* If the file name has special constructs in it,
2023 call the corresponding file handler. */
2024 handler = Ffind_file_name_handler (filename, Qrename_file);
2026 handler = Ffind_file_name_handler (newname, Qrename_file);
2027 if (!NILP (handler))
2030 return call4 (handler, Qrename_file,
2031 filename, newname, ok_if_already_exists);
2034 /* When second argument is a directory, rename the file into it.
2035 (rename-file "foo" "bar/") == (rename-file "foo" "bar/foo")
2037 if (!NILP (Ffile_directory_p (newname)))
2039 Lisp_Object args[3];
2040 struct gcpro ngcpro1;
2044 args[1] = Qnil; args[2] = Qnil;
2047 if (XSTRING_BYTE (newname, XSTRING_LENGTH (newname) - 1) != '/')
2048 args[i++] = build_string ("/");
2049 args[i++] = Ffile_name_nondirectory (filename);
2050 newname = Fconcat (i, args);
2054 if (NILP (ok_if_already_exists)
2055 || INTP (ok_if_already_exists))
2056 barf_or_query_if_file_exists (newname, "rename to it",
2057 INTP (ok_if_already_exists), 0);
2059 /* Syncing with FSF 19.34.6 note: FSF does not have conditional code for
2060 WIN32_NATIVE here; I've removed it. --marcpa */
2062 /* We have configure check for rename() and emulate using
2063 link()/unlink() if necessary. */
2064 if (0 > rename ((char *) XSTRING_DATA (filename),
2065 (char *) XSTRING_DATA (newname)))
2069 Fcopy_file (filename, newname,
2070 /* We have already prompted if it was an integer,
2071 so don't have copy-file prompt again. */
2072 (NILP (ok_if_already_exists) ? Qnil : Qt),
2074 Fdelete_file (filename);
2078 report_file_error ("Renaming", list2 (filename, newname));
2085 DEFUN ("add-name-to-file", Fadd_name_to_file, 2, 3,
2086 "fAdd name to file: \nFName to add to %s: \np", /*
2087 Give FILENAME additional name NEWNAME. Both args must be strings.
2088 Signals a `file-already-exists' error if a file NEWNAME already exists
2089 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2090 A number as third arg means request confirmation if NEWNAME already exists.
2091 This is what happens in interactive use with M-x.
2093 (filename, newname, ok_if_already_exists))
2095 /* This function can GC. GC checked 1997.04.06. */
2096 Lisp_Object handler;
2097 struct gcpro gcpro1, gcpro2;
2099 GCPRO2 (filename, newname);
2100 CHECK_STRING (filename);
2101 CHECK_STRING (newname);
2102 filename = Fexpand_file_name (filename, Qnil);
2103 newname = Fexpand_file_name (newname, Qnil);
2105 /* If the file name has special constructs in it,
2106 call the corresponding file handler. */
2107 handler = Ffind_file_name_handler (filename, Qadd_name_to_file);
2108 if (!NILP (handler))
2109 RETURN_UNGCPRO (call4 (handler, Qadd_name_to_file, filename,
2110 newname, ok_if_already_exists));
2112 /* If the new name has special constructs in it,
2113 call the corresponding file handler. */
2114 handler = Ffind_file_name_handler (newname, Qadd_name_to_file);
2115 if (!NILP (handler))
2116 RETURN_UNGCPRO (call4 (handler, Qadd_name_to_file, filename,
2117 newname, ok_if_already_exists));
2119 if (NILP (ok_if_already_exists)
2120 || INTP (ok_if_already_exists))
2121 barf_or_query_if_file_exists (newname, "make it a new name",
2122 INTP (ok_if_already_exists), 0);
2123 /* Syncing with FSF 19.34.6 note: FSF does not report a file error
2124 on NT here. --marcpa */
2125 /* But FSF #defines link as sys_link which is supplied in nt.c. We can't do
2126 that because sysfile.h defines sys_link depending on ENCAPSULATE_LINK.
2127 Reverted to previous behavior pending a working fix. (jhar) */
2128 #if defined(WIN32_NATIVE)
2129 /* Windows does not support this operation. */
2130 report_file_error ("Adding new name", Flist (2, &filename));
2131 #else /* not defined(WIN32_NATIVE) */
2133 unlink ((char *) XSTRING_DATA (newname));
2134 if (0 > link ((char *) XSTRING_DATA (filename),
2135 (char *) XSTRING_DATA (newname)))
2137 report_file_error ("Adding new name",
2138 list2 (filename, newname));
2140 #endif /* defined(WIN32_NATIVE) */
2146 DEFUN ("make-symbolic-link", Fmake_symbolic_link, 2, 3,
2147 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np", /*
2148 Make a symbolic link to FILENAME, named LINKNAME. Both args strings.
2149 Signals a `file-already-exists' error if a file LINKNAME already exists
2150 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2151 A number as third arg means request confirmation if LINKNAME already exists.
2152 This happens for interactive use with M-x.
2154 (filename, linkname, ok_if_already_exists))
2156 /* This function can GC. GC checked 1997.06.04. */
2157 /* XEmacs change: run handlers even if local machine doesn't have symlinks */
2158 Lisp_Object handler;
2159 struct gcpro gcpro1, gcpro2;
2161 GCPRO2 (filename, linkname);
2162 CHECK_STRING (filename);
2163 CHECK_STRING (linkname);
2164 /* If the link target has a ~, we must expand it to get
2165 a truly valid file name. Otherwise, do not expand;
2166 we want to permit links to relative file names. */
2167 if (XSTRING_BYTE (filename, 0) == '~')
2168 filename = Fexpand_file_name (filename, Qnil);
2169 linkname = Fexpand_file_name (linkname, Qnil);
2171 /* If the file name has special constructs in it,
2172 call the corresponding file handler. */
2173 handler = Ffind_file_name_handler (filename, Qmake_symbolic_link);
2174 if (!NILP (handler))
2175 RETURN_UNGCPRO (call4 (handler, Qmake_symbolic_link, filename, linkname,
2176 ok_if_already_exists));
2178 /* If the new link name has special constructs in it,
2179 call the corresponding file handler. */
2180 handler = Ffind_file_name_handler (linkname, Qmake_symbolic_link);
2181 if (!NILP (handler))
2182 RETURN_UNGCPRO (call4 (handler, Qmake_symbolic_link, filename,
2183 linkname, ok_if_already_exists));
2186 if (NILP (ok_if_already_exists)
2187 || INTP (ok_if_already_exists))
2188 barf_or_query_if_file_exists (linkname, "make it a link",
2189 INTP (ok_if_already_exists), 0);
2191 unlink ((char *) XSTRING_DATA (linkname));
2192 if (0 > symlink ((char *) XSTRING_DATA (filename),
2193 (char *) XSTRING_DATA (linkname)))
2195 report_file_error ("Making symbolic link",
2196 list2 (filename, linkname));
2198 #endif /* S_IFLNK */
2206 DEFUN ("sysnetunam", Fsysnetunam, 2, 2, 0, /*
2207 Open a network connection to PATH using LOGIN as the login string.
2212 const char *path_ext;
2213 const char *login_ext;
2215 CHECK_STRING (path);
2216 CHECK_STRING (login);
2218 /* netunam, being a strange-o system call only used once, is not
2221 LISP_STRING_TO_EXTERNAL (path, path_ext, Qfile_name);
2222 LISP_STRING_TO_EXTERNAL (login, login_ext, Qnative);
2224 netresult = netunam (path_ext, login_ext);
2226 return netresult == -1 ? Qnil : Qt;
2228 #endif /* HPUX_NET */
2230 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p, 1, 1, 0, /*
2231 Return t if file FILENAME specifies an absolute path name.
2232 On Unix, this is a name starting with a `/' or a `~'.
2236 /* This function does not GC */
2239 CHECK_STRING (filename);
2240 ptr = XSTRING_DATA (filename);
2241 return (IS_DIRECTORY_SEP (*ptr) || *ptr == '~'
2242 #ifdef WIN32_FILENAMES
2243 || (IS_DRIVE (*ptr) && ptr[1] == ':' && IS_DIRECTORY_SEP (ptr[2]))
2248 /* Return nonzero if file FILENAME exists and can be executed. */
2251 check_executable (char *filename)
2255 if (xemacs_stat (filename, &st) < 0)
2257 return ((st.st_mode & S_IEXEC) != 0);
2258 #else /* not WIN32_NATIVE */
2260 return eaccess (filename, X_OK) >= 0;
2262 /* Access isn't quite right because it uses the real uid
2263 and we really want to test with the effective uid.
2264 But Unix doesn't give us a right way to do it. */
2265 return access (filename, X_OK) >= 0;
2266 #endif /* HAVE_EACCESS */
2267 #endif /* not WIN32_NATIVE */
2270 /* Return nonzero if file FILENAME exists and can be written. */
2273 check_writable (const char *filename)
2276 return (eaccess (filename, W_OK) >= 0);
2278 /* Access isn't quite right because it uses the real uid
2279 and we really want to test with the effective uid.
2280 But Unix doesn't give us a right way to do it.
2281 Opening with O_WRONLY could work for an ordinary file,
2282 but would lose for directories. */
2283 return (access (filename, W_OK) >= 0);
2287 DEFUN ("file-exists-p", Ffile_exists_p, 1, 1, 0, /*
2288 Return t if file FILENAME exists. (This does not mean you can read it.)
2289 See also `file-readable-p' and `file-attributes'.
2293 /* This function can call lisp; GC checked 2000-07-11 ben */
2294 Lisp_Object abspath;
2295 Lisp_Object handler;
2296 struct stat statbuf;
2297 struct gcpro gcpro1;
2299 CHECK_STRING (filename);
2300 abspath = Fexpand_file_name (filename, Qnil);
2302 /* If the file name has special constructs in it,
2303 call the corresponding file handler. */
2305 handler = Ffind_file_name_handler (abspath, Qfile_exists_p);
2307 if (!NILP (handler))
2308 return call2 (handler, Qfile_exists_p, abspath);
2310 return xemacs_stat ((char *) XSTRING_DATA (abspath), &statbuf) >= 0 ? Qt : Qnil;
2313 DEFUN ("file-executable-p", Ffile_executable_p, 1, 1, 0, /*
2314 Return t if FILENAME can be executed by you.
2315 For a directory, this means you can access files in that directory.
2320 /* This function can GC. GC checked 07-11-2000 ben. */
2321 Lisp_Object abspath;
2322 Lisp_Object handler;
2323 struct gcpro gcpro1;
2325 CHECK_STRING (filename);
2326 abspath = Fexpand_file_name (filename, Qnil);
2328 /* If the file name has special constructs in it,
2329 call the corresponding file handler. */
2331 handler = Ffind_file_name_handler (abspath, Qfile_executable_p);
2333 if (!NILP (handler))
2334 return call2 (handler, Qfile_executable_p, abspath);
2336 return check_executable ((char *) XSTRING_DATA (abspath)) ? Qt : Qnil;
2339 DEFUN ("file-readable-p", Ffile_readable_p, 1, 1, 0, /*
2340 Return t if file FILENAME exists and you can read it.
2341 See also `file-exists-p' and `file-attributes'.
2345 /* This function can GC */
2346 Lisp_Object abspath = Qnil;
2347 Lisp_Object handler;
2348 struct gcpro gcpro1;
2351 CHECK_STRING (filename);
2352 abspath = Fexpand_file_name (filename, Qnil);
2354 /* If the file name has special constructs in it,
2355 call the corresponding file handler. */
2356 handler = Ffind_file_name_handler (abspath, Qfile_readable_p);
2357 if (!NILP (handler))
2358 RETURN_UNGCPRO (call2 (handler, Qfile_readable_p, abspath));
2360 #if defined(WIN32_FILENAMES)
2361 /* Under MS-DOS and Windows, open does not work for directories. */
2363 if (access (XSTRING_DATA (abspath), 0) == 0)
2367 #else /* not WIN32_FILENAMES */
2369 int desc = interruptible_open ((char *) XSTRING_DATA (abspath), O_RDONLY | OPEN_BINARY, 0);
2376 #endif /* not WIN32_FILENAMES */
2379 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2381 DEFUN ("file-writable-p", Ffile_writable_p, 1, 1, 0, /*
2382 Return t if file FILENAME can be written or created by you.
2386 /* This function can GC. GC checked 1997.04.10. */
2387 Lisp_Object abspath, dir;
2388 Lisp_Object handler;
2389 struct stat statbuf;
2390 struct gcpro gcpro1;
2392 CHECK_STRING (filename);
2393 abspath = Fexpand_file_name (filename, Qnil);
2395 /* If the file name has special constructs in it,
2396 call the corresponding file handler. */
2398 handler = Ffind_file_name_handler (abspath, Qfile_writable_p);
2400 if (!NILP (handler))
2401 return call2 (handler, Qfile_writable_p, abspath);
2403 if (xemacs_stat ((char *) XSTRING_DATA (abspath), &statbuf) >= 0)
2404 return (check_writable ((char *) XSTRING_DATA (abspath))
2409 dir = Ffile_name_directory (abspath);
2411 return (check_writable (!NILP (dir) ? (char *) XSTRING_DATA (dir)
2416 DEFUN ("file-symlink-p", Ffile_symlink_p, 1, 1, 0, /*
2417 Return non-nil if file FILENAME is the name of a symbolic link.
2418 The value is the name of the file to which it is linked.
2419 Otherwise returns nil.
2423 /* This function can GC. GC checked 1997.04.10. */
2424 /* XEmacs change: run handlers even if local machine doesn't have symlinks */
2431 Lisp_Object handler;
2432 struct gcpro gcpro1;
2434 CHECK_STRING (filename);
2435 filename = Fexpand_file_name (filename, Qnil);
2437 /* If the file name has special constructs in it,
2438 call the corresponding file handler. */
2440 handler = Ffind_file_name_handler (filename, Qfile_symlink_p);
2442 if (!NILP (handler))
2443 return call2 (handler, Qfile_symlink_p, filename);
2449 buf = xnew_array_and_zero (char, bufsize);
2450 valsize = readlink ((char *) XSTRING_DATA (filename),
2452 if (valsize < bufsize) break;
2453 /* Buffer was not long enough */
2462 val = make_string ((Bufbyte *) buf, valsize);
2465 #else /* not S_IFLNK */
2467 #endif /* not S_IFLNK */
2470 DEFUN ("file-directory-p", Ffile_directory_p, 1, 1, 0, /*
2471 Return t if file FILENAME is the name of a directory as a file.
2472 A directory name spec may be given instead; then the value is t
2473 if the directory so specified exists and really is a directory.
2477 /* This function can GC. GC checked 1997.04.10. */
2478 Lisp_Object abspath;
2480 Lisp_Object handler;
2481 struct gcpro gcpro1;
2483 GCPRO1 (current_buffer->directory);
2484 abspath = expand_and_dir_to_file (filename,
2485 current_buffer->directory);
2488 /* If the file name has special constructs in it,
2489 call the corresponding file handler. */
2491 handler = Ffind_file_name_handler (abspath, Qfile_directory_p);
2493 if (!NILP (handler))
2494 return call2 (handler, Qfile_directory_p, abspath);
2496 if (xemacs_stat ((char *) XSTRING_DATA (abspath), &st) < 0)
2498 return (st.st_mode & S_IFMT) == S_IFDIR ? Qt : Qnil;
2501 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p, 1, 1, 0, /*
2502 Return t if file FILENAME is the name of a directory as a file,
2503 and files in that directory can be opened by you. In order to use a
2504 directory as a buffer's current directory, this predicate must return true.
2505 A directory name spec may be given instead; then the value is t
2506 if the directory so specified exists and really is a readable and
2507 searchable directory.
2511 /* This function can GC. GC checked 1997.04.10. */
2512 Lisp_Object handler;
2514 /* If the file name has special constructs in it,
2515 call the corresponding file handler. */
2516 handler = Ffind_file_name_handler (filename, Qfile_accessible_directory_p);
2517 if (!NILP (handler))
2518 return call2 (handler, Qfile_accessible_directory_p,
2521 #if !defined(WIN32_NATIVE)
2522 if (NILP (Ffile_directory_p (filename)))
2525 return Ffile_executable_p (filename);
2529 struct gcpro gcpro1;
2530 /* It's an unlikely combination, but yes we really do need to gcpro:
2531 Suppose that file-accessible-directory-p has no handler, but
2532 file-directory-p does have a handler; this handler causes a GC which
2533 relocates the string in `filename'; and finally file-directory-p
2534 returns non-nil. Then we would end up passing a garbaged string
2535 to file-executable-p. */
2537 tem = (NILP (Ffile_directory_p (filename))
2538 || NILP (Ffile_executable_p (filename)));
2540 return tem ? Qnil : Qt;
2542 #endif /* !defined(WIN32_NATIVE) */
2545 DEFUN ("file-regular-p", Ffile_regular_p, 1, 1, 0, /*
2546 Return t if file FILENAME is the name of a regular file.
2547 This is the sort of file that holds an ordinary stream of data bytes.
2551 /* This function can GC. GC checked 1997.04.10. */
2552 Lisp_Object abspath;
2554 Lisp_Object handler;
2555 struct gcpro gcpro1;
2557 GCPRO1 (current_buffer->directory);
2558 abspath = expand_and_dir_to_file (filename, current_buffer->directory);
2561 /* If the file name has special constructs in it,
2562 call the corresponding file handler. */
2564 handler = Ffind_file_name_handler (abspath, Qfile_regular_p);
2566 if (!NILP (handler))
2567 return call2 (handler, Qfile_regular_p, abspath);
2569 if (xemacs_stat ((char *) XSTRING_DATA (abspath), &st) < 0)
2571 return (st.st_mode & S_IFMT) == S_IFREG ? Qt : Qnil;
2574 DEFUN ("file-modes", Ffile_modes, 1, 1, 0, /*
2575 Return mode bits of file named FILENAME, as an integer.
2579 /* This function can GC. GC checked 1997.04.10. */
2580 Lisp_Object abspath;
2582 Lisp_Object handler;
2583 struct gcpro gcpro1;
2585 GCPRO1 (current_buffer->directory);
2586 abspath = expand_and_dir_to_file (filename,
2587 current_buffer->directory);
2590 /* If the file name has special constructs in it,
2591 call the corresponding file handler. */
2593 handler = Ffind_file_name_handler (abspath, Qfile_modes);
2595 if (!NILP (handler))
2596 return call2 (handler, Qfile_modes, abspath);
2598 if (xemacs_stat ((char *) XSTRING_DATA (abspath), &st) < 0)
2600 /* Syncing with FSF 19.34.6 note: not in FSF, #if 0'ed out here. */
2603 if (check_executable (XSTRING_DATA (abspath)))
2604 st.st_mode |= S_IEXEC;
2605 #endif /* WIN32_NATIVE */
2608 return make_int (st.st_mode & 07777);
2611 DEFUN ("set-file-modes", Fset_file_modes, 2, 2, 0, /*
2612 Set mode bits of file named FILENAME to MODE (an integer).
2613 Only the 12 low bits of MODE are used.
2617 /* This function can GC. GC checked 1997.04.10. */
2618 Lisp_Object abspath;
2619 Lisp_Object handler;
2620 struct gcpro gcpro1;
2622 GCPRO1 (current_buffer->directory);
2623 abspath = Fexpand_file_name (filename, current_buffer->directory);
2628 /* If the file name has special constructs in it,
2629 call the corresponding file handler. */
2631 handler = Ffind_file_name_handler (abspath, Qset_file_modes);
2633 if (!NILP (handler))
2634 return call3 (handler, Qset_file_modes, abspath, mode);
2636 if (chmod ((char *) XSTRING_DATA (abspath), XINT (mode)) < 0)
2637 report_file_error ("Doing chmod", list1 (abspath));
2642 DEFUN ("set-default-file-modes", Fset_default_file_modes, 1, 1, 0, /*
2643 Set the file permission bits for newly created files.
2644 The argument MODE should be an integer; if a bit in MODE is 1,
2645 subsequently created files will not have the permission corresponding
2646 to that bit enabled. Only the low 9 bits are used.
2647 This setting is inherited by subprocesses.
2653 umask ((~ XINT (mode)) & 0777);
2658 DEFUN ("default-file-modes", Fdefault_file_modes, 0, 0, 0, /*
2659 Return the default file protection for created files.
2660 The umask value determines which permissions are enabled in newly
2661 created files. If a permission's bit in the umask is 1, subsequently
2662 created files will not have that permission enabled.
2671 return make_int ((~ mode) & 0777);
2674 DEFUN ("unix-sync", Funix_sync, 0, 0, "", /*
2675 Tell Unix to finish all pending disk updates.
2679 #ifndef WIN32_NATIVE
2686 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p, 2, 2, 0, /*
2687 Return t if file FILE1 is newer than file FILE2.
2688 If FILE1 does not exist, the answer is nil;
2689 otherwise, if FILE2 does not exist, the answer is t.
2693 /* This function can GC. GC checked 1997.04.10. */
2694 Lisp_Object abspath1, abspath2;
2697 Lisp_Object handler;
2698 struct gcpro gcpro1, gcpro2, gcpro3;
2700 CHECK_STRING (file1);
2701 CHECK_STRING (file2);
2706 GCPRO3 (abspath1, abspath2, current_buffer->directory);
2707 abspath1 = expand_and_dir_to_file (file1, current_buffer->directory);
2708 abspath2 = expand_and_dir_to_file (file2, current_buffer->directory);
2710 /* If the file name has special constructs in it,
2711 call the corresponding file handler. */
2712 handler = Ffind_file_name_handler (abspath1, Qfile_newer_than_file_p);
2714 handler = Ffind_file_name_handler (abspath2, Qfile_newer_than_file_p);
2716 if (!NILP (handler))
2717 return call3 (handler, Qfile_newer_than_file_p, abspath1,
2720 if (xemacs_stat ((char *) XSTRING_DATA (abspath1), &st) < 0)
2723 mtime1 = st.st_mtime;
2725 if (xemacs_stat ((char *) XSTRING_DATA (abspath2), &st) < 0)
2728 return (mtime1 > st.st_mtime) ? Qt : Qnil;
2732 /* Stack sizes > 2**16 is a good way to elicit compiler bugs */
2733 /* #define READ_BUF_SIZE (2 << 16) */
2734 #define READ_BUF_SIZE (1 << 15)
2736 DEFUN ("insert-file-contents-internal", Finsert_file_contents_internal,
2738 Insert contents of file FILENAME after point; no coding-system frobbing.
2739 This function is identical to `insert-file-contents' except for the
2740 handling of the CODESYS and USED-CODESYS arguments under
2741 XEmacs/Mule. (When Mule support is not present, both functions are
2742 identical and ignore the CODESYS and USED-CODESYS arguments.)
2744 If support for Mule exists in this Emacs, the file is decoded according
2745 to CODESYS; if omitted, no conversion happens. If USED-CODESYS is non-nil,
2746 it should be a symbol, and the actual coding system that was used for the
2747 decoding is stored into it. It will in general be different from CODESYS
2748 if CODESYS specifies automatic encoding detection or end-of-line detection.
2750 Currently START and END refer to byte positions (as opposed to character
2751 positions), even in Mule. (Fixing this is very difficult.)
2753 (filename, visit, start, end, replace, codesys, used_codesys))
2755 /* This function can call lisp */
2759 Charcount inserted = 0;
2761 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
2762 Lisp_Object handler = Qnil, val;
2764 Bufbyte read_buf[READ_BUF_SIZE];
2766 struct buffer *buf = current_buffer;
2768 int not_regular = 0;
2770 if (buf->base_buffer && ! NILP (visit))
2771 error ("Cannot do file visiting in an indirect buffer");
2773 /* No need to call Fbarf_if_buffer_read_only() here.
2774 That's called in begin_multiple_change() or wherever. */
2778 /* #### dmoore - should probably check in various places to see if
2779 curbuf was killed and if so signal an error? */
2781 XSETBUFFER (curbuf, buf);
2783 GCPRO5 (filename, val, visit, handler, curbuf);
2785 mc_count = (NILP (replace)) ?
2786 begin_multiple_change (buf, BUF_PT (buf), BUF_PT (buf)) :
2787 begin_multiple_change (buf, BUF_BEG (buf), BUF_Z (buf));
2789 speccount = specpdl_depth (); /* begin_multiple_change also adds
2790 an unwind_protect */
2792 filename = Fexpand_file_name (filename, Qnil);
2794 /* If the file name has special constructs in it,
2795 call the corresponding file handler. */
2796 handler = Ffind_file_name_handler (filename, Qinsert_file_contents);
2797 if (!NILP (handler))
2799 val = call6 (handler, Qinsert_file_contents, filename,
2800 visit, start, end, replace);
2805 if (!NILP (used_codesys))
2806 CHECK_SYMBOL (used_codesys);
2809 if ( (!NILP (start) || !NILP (end)) && !NILP (visit) )
2810 error ("Attempt to visit less than an entire file");
2814 if (xemacs_stat ((char *) XSTRING_DATA (filename), &st) < 0)
2816 if (fd >= 0) close (fd);
2819 report_file_error ("Opening input file", list1 (filename));
2825 /* Signal an error if we are accessing a non-regular file, with
2826 REPLACE, START or END being non-nil. */
2827 if (!S_ISREG (st.st_mode))
2834 if (!NILP (replace) || !NILP (start) || !NILP (end))
2836 end_multiple_change (buf, mc_count);
2839 (Fsignal (Qfile_error,
2840 list2 (build_translated_string("not a regular file"),
2844 #endif /* S_IFREG */
2856 if ((fd = interruptible_open ((char *) XSTRING_DATA (filename),
2857 O_RDONLY | OPEN_BINARY, 0)) < 0)
2861 /* Replacement should preserve point as it preserves markers. */
2862 if (!NILP (replace))
2863 record_unwind_protect (restore_point_unwind, Fpoint_marker (Qnil, Qnil));
2865 record_unwind_protect (close_file_unwind, make_int (fd));
2867 /* Supposedly happens on VMS. */
2869 error ("File size is negative");
2875 end = make_int (st.st_size);
2876 if (XINT (end) != st.st_size)
2877 error ("Maximum buffer size exceeded");
2881 /* If requested, replace the accessible part of the buffer
2882 with the file contents. Avoid replacing text at the
2883 beginning or end of the buffer that matches the file contents;
2884 that preserves markers pointing to the unchanged parts. */
2885 #if !defined (FILE_CODING)
2886 /* The replace-mode code currently only works when the assumption
2887 'one byte == one char' holds true. This fails Mule because
2888 files may contain multibyte characters. It holds under Windows NT
2889 provided we convert CRLF into LF. */
2890 # define FSFMACS_SPEEDY_INSERT
2891 #endif /* !defined (FILE_CODING) */
2893 #ifndef FSFMACS_SPEEDY_INSERT
2894 if (!NILP (replace))
2896 buffer_delete_range (buf, BUF_BEG (buf), BUF_Z (buf),
2897 !NILP (visit) ? INSDEL_NO_LOCKING : 0);
2899 #else /* FSFMACS_SPEEDY_INSERT */
2900 if (!NILP (replace))
2902 char buffer[1 << 14];
2903 Bufpos same_at_start = BUF_BEGV (buf);
2904 Bufpos same_at_end = BUF_ZV (buf);
2907 /* Count how many chars at the start of the file
2908 match the text at the beginning of the buffer. */
2913 nread = read_allowing_quit (fd, buffer, sizeof buffer);
2915 error ("IO error reading %s: %s",
2916 XSTRING_DATA (filename), strerror (errno));
2917 else if (nread == 0)
2920 while (bufpos < nread && same_at_start < BUF_ZV (buf)
2921 && BUF_FETCH_CHAR (buf, same_at_start) == buffer[bufpos])
2922 same_at_start++, bufpos++;
2923 /* If we found a discrepancy, stop the scan.
2924 Otherwise loop around and scan the next bufferful. */
2925 if (bufpos != nread)
2928 /* If the file matches the buffer completely,
2929 there's no need to replace anything. */
2930 if (same_at_start - BUF_BEGV (buf) == st.st_size)
2933 unbind_to (speccount, Qnil);
2934 /* Truncate the buffer to the size of the file. */
2935 buffer_delete_range (buf, same_at_start, same_at_end,
2936 !NILP (visit) ? INSDEL_NO_LOCKING : 0);
2939 /* Count how many chars at the end of the file
2940 match the text at the end of the buffer. */
2943 int total_read, nread;
2944 Bufpos bufpos, curpos, trial;
2946 /* At what file position are we now scanning? */
2947 curpos = st.st_size - (BUF_ZV (buf) - same_at_end);
2948 /* If the entire file matches the buffer tail, stop the scan. */
2951 /* How much can we scan in the next step? */
2952 trial = min (curpos, (Bufpos) sizeof (buffer));
2953 if (lseek (fd, curpos - trial, 0) < 0)
2954 report_file_error ("Setting file position", list1 (filename));
2957 while (total_read < trial)
2959 nread = read_allowing_quit (fd, buffer + total_read,
2960 trial - total_read);
2962 report_file_error ("IO error reading file", list1 (filename));
2963 total_read += nread;
2965 /* Scan this bufferful from the end, comparing with
2966 the Emacs buffer. */
2967 bufpos = total_read;
2968 /* Compare with same_at_start to avoid counting some buffer text
2969 as matching both at the file's beginning and at the end. */
2970 while (bufpos > 0 && same_at_end > same_at_start
2971 && BUF_FETCH_CHAR (buf, same_at_end - 1) ==
2973 same_at_end--, bufpos--;
2974 /* If we found a discrepancy, stop the scan.
2975 Otherwise loop around and scan the preceding bufferful. */
2978 /* If display current starts at beginning of line,
2979 keep it that way. */
2980 if (XBUFFER (XWINDOW (Fselected_window (Qnil))->buffer) == buf)
2981 XWINDOW (Fselected_window (Qnil))->start_at_line_beg =
2982 !NILP (Fbolp (make_buffer (buf)));
2985 /* Don't try to reuse the same piece of text twice. */
2986 overlap = same_at_start - BUF_BEGV (buf) -
2987 (same_at_end + st.st_size - BUF_ZV (buf));
2989 same_at_end += overlap;
2991 /* Arrange to read only the nonmatching middle part of the file. */
2992 start = make_int (same_at_start - BUF_BEGV (buf));
2993 end = make_int (st.st_size - (BUF_ZV (buf) - same_at_end));
2995 buffer_delete_range (buf, same_at_start, same_at_end,
2996 !NILP (visit) ? INSDEL_NO_LOCKING : 0);
2997 /* Insert from the file at the proper position. */
2998 BUF_SET_PT (buf, same_at_start);
3000 #endif /* FSFMACS_SPEEDY_INSERT */
3004 total = XINT (end) - XINT (start);
3006 /* Make sure point-max won't overflow after this insertion. */
3007 if (total != XINT (make_int (total)))
3008 error ("Maximum buffer size exceeded");
3011 /* For a special file, all we can do is guess. The value of -1
3012 will make the stream functions read as much as possible. */
3015 if (XINT (start) != 0
3016 #ifdef FSFMACS_SPEEDY_INSERT
3017 /* why was this here? asked jwz. The reason is that the replace-mode
3018 connivings above will normally put the file pointer other than
3019 where it should be. */
3021 #endif /* !FSFMACS_SPEEDY_INSERT */
3024 if (lseek (fd, XINT (start), 0) < 0)
3025 report_file_error ("Setting file position", list1 (filename));
3029 Bufpos cur_point = BUF_PT (buf);
3030 struct gcpro ngcpro1;
3031 Lisp_Object stream = make_filedesc_input_stream (fd, 0, total,
3035 Lstream_set_buffering (XLSTREAM (stream), LSTREAM_BLOCKN_BUFFERED, 65536);
3037 stream = make_decoding_input_stream
3038 (XLSTREAM (stream), Fget_coding_system (codesys));
3039 Lstream_set_character_mode (XLSTREAM (stream));
3040 Lstream_set_buffering (XLSTREAM (stream), LSTREAM_BLOCKN_BUFFERED, 65536);
3041 #endif /* FILE_CODING */
3043 record_unwind_protect (delete_stream_unwind, stream);
3045 /* No need to limit the amount of stuff we attempt to read. (It would
3046 be incorrect, anyway, when Mule is enabled.) Instead, the limiting
3047 occurs inside of the filedesc stream. */
3050 Lstream_data_count this_len;
3051 Charcount cc_inserted;
3054 this_len = Lstream_read (XLSTREAM (stream), read_buf,
3064 cc_inserted = buffer_insert_raw_string_1 (buf, cur_point, read_buf,
3067 ? INSDEL_NO_LOCKING : 0);
3068 inserted += cc_inserted;
3069 cur_point += cc_inserted;
3072 if (!NILP (used_codesys))
3075 XCODING_SYSTEM_NAME (decoding_stream_coding_system (XLSTREAM (stream))));
3077 #endif /* FILE_CODING */
3081 /* Close the file/stream */
3082 unbind_to (speccount, Qnil);
3086 error ("IO error reading %s: %s",
3087 XSTRING_DATA (filename), strerror (saverrno));
3093 end_multiple_change (buf, mc_count);
3097 if (!EQ (buf->undo_list, Qt))
3098 buf->undo_list = Qnil;
3101 buf->modtime = st.st_mtime;
3102 buf->filename = filename;
3103 /* XEmacs addition: */
3104 /* This function used to be in C, ostensibly so that
3105 it could be called here. But that's just silly.
3106 There's no reason C code can't call out to Lisp
3107 code, and it's a lot cleaner this way. */
3108 /* Note: compute-buffer-file-truename is called for
3109 side-effect! Its return value is intentionally
3111 if (!NILP (Ffboundp (Qcompute_buffer_file_truename)))
3112 call1 (Qcompute_buffer_file_truename, make_buffer (buf));
3114 BUF_SAVE_MODIFF (buf) = BUF_MODIFF (buf);
3115 buf->auto_save_modified = BUF_MODIFF (buf);
3116 buf->saved_size = make_int (BUF_SIZE (buf));
3117 #ifdef CLASH_DETECTION
3120 if (!NILP (buf->file_truename))
3121 unlock_file (buf->file_truename);
3122 unlock_file (filename);
3124 #endif /* CLASH_DETECTION */
3126 RETURN_UNGCPRO (Fsignal (Qfile_error,
3127 list2 (build_string ("not a regular file"),
3130 /* If visiting nonexistent file, return nil. */
3131 if (buf->modtime == -1)
3132 report_file_error ("Opening input file",
3136 /* Decode file format */
3139 Lisp_Object insval = call3 (Qformat_decode,
3140 Qnil, make_int (inserted), visit);
3142 inserted = XINT (insval);
3148 struct gcpro ngcpro1;
3151 EXTERNAL_LIST_LOOP (p, Vafter_insert_file_functions)
3153 Lisp_Object insval =
3154 call1 (XCAR (p), make_int (inserted));
3157 CHECK_NATNUM (insval);
3158 inserted = XINT (insval);
3170 return (list2 (filename, make_int (inserted)));
3174 static int a_write (Lisp_Object outstream, Lisp_Object instream, int pos,
3175 Lisp_Object *annot);
3176 static Lisp_Object build_annotations (Lisp_Object start, Lisp_Object end);
3178 /* If build_annotations switched buffers, switch back to BUF.
3179 Kill the temporary buffer that was selected in the meantime. */
3182 build_annotations_unwind (Lisp_Object buf)
3186 if (XBUFFER (buf) == current_buffer)
3188 tembuf = Fcurrent_buffer ();
3190 Fkill_buffer (tembuf);
3194 DEFUN ("write-region-internal", Fwrite_region_internal, 3, 7,
3195 "r\nFWrite region to file: ", /*
3196 Write current region into specified file; no coding-system frobbing.
3197 This function is identical to `write-region' except for the handling
3198 of the CODESYS argument under XEmacs/Mule. (When Mule support is not
3199 present, both functions are identical and ignore the CODESYS argument.)
3200 If support for Mule exists in this Emacs, the file is encoded according
3201 to the value of CODESYS. If this is nil, no code conversion occurs.
3203 (start, end, filename, append, visit, lockname, codesys))
3205 /* This function can call lisp. GC checked 2000-07-28 ben */
3210 Lisp_Object fn = Qnil;
3211 int speccount = specpdl_depth ();
3212 int visiting_other = STRINGP (visit);
3213 int visiting = (EQ (visit, Qt) || visiting_other);
3214 int quietly = (!visiting && !NILP (visit));
3215 Lisp_Object visit_file = Qnil;
3216 Lisp_Object annotations = Qnil;
3217 struct buffer *given_buffer;
3218 Bufpos start1, end1;
3219 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
3220 struct gcpro ngcpro1, ngcpro2;
3223 XSETBUFFER (curbuf, current_buffer);
3225 /* start, end, visit, and append are never modified in this fun
3226 so we don't protect them. */
3227 GCPRO5 (visit_file, filename, codesys, lockname, annotations);
3228 NGCPRO2 (curbuf, fn);
3230 /* [[ dmoore - if Fexpand_file_name or handlers kill the buffer,
3231 we should signal an error rather than blissfully continuing
3232 along. ARGH, this function is going to lose lose lose. We need
3233 to protect the current_buffer from being destroyed, but the
3234 multiple return points make this a pain in the butt. ]] we do
3235 protect curbuf now. --ben */
3238 codesys = Fget_coding_system (codesys);
3239 #endif /* FILE_CODING */
3241 if (current_buffer->base_buffer && ! NILP (visit))
3242 invalid_operation ("Cannot do file visiting in an indirect buffer",
3245 if (!NILP (start) && !STRINGP (start))
3246 get_buffer_range_char (current_buffer, start, end, &start1, &end1, 0);
3249 Lisp_Object handler;
3252 visit_file = Fexpand_file_name (visit, Qnil);
3254 visit_file = filename;
3255 filename = Fexpand_file_name (filename, Qnil);
3257 if (NILP (lockname))
3258 lockname = visit_file;
3260 /* We used to UNGCPRO here. BAD! visit_file is used below after
3261 more Lisp calling. */
3262 /* If the file name has special constructs in it,
3263 call the corresponding file handler. */
3264 handler = Ffind_file_name_handler (filename, Qwrite_region);
3265 /* If FILENAME has no handler, see if VISIT has one. */
3266 if (NILP (handler) && STRINGP (visit))
3267 handler = Ffind_file_name_handler (visit, Qwrite_region);
3269 if (!NILP (handler))
3271 Lisp_Object val = call8 (handler, Qwrite_region, start, end,
3272 filename, append, visit, lockname, codesys);
3275 BUF_SAVE_MODIFF (current_buffer) = BUF_MODIFF (current_buffer);
3276 current_buffer->saved_size = make_int (BUF_SIZE (current_buffer));
3277 current_buffer->filename = visit_file;
3278 MARK_MODELINE_CHANGED;
3286 #ifdef CLASH_DETECTION
3288 lock_file (lockname);
3289 #endif /* CLASH_DETECTION */
3291 /* Special kludge to simplify auto-saving. */
3294 start1 = BUF_BEG (current_buffer);
3295 end1 = BUF_Z (current_buffer);
3298 record_unwind_protect (build_annotations_unwind, Fcurrent_buffer ());
3300 given_buffer = current_buffer;
3301 annotations = build_annotations (start, end);
3302 if (current_buffer != given_buffer)
3304 start1 = BUF_BEGV (current_buffer);
3305 end1 = BUF_ZV (current_buffer);
3312 desc = open ((char *) XSTRING_DATA (fn), O_WRONLY | OPEN_BINARY, 0);
3316 desc = open ((char *) XSTRING_DATA (fn),
3317 O_WRONLY | O_TRUNC | O_CREAT | OPEN_BINARY,
3318 auto_saving ? auto_save_mode_bits : CREAT_MODE);
3323 #ifdef CLASH_DETECTION
3325 if (!auto_saving) unlock_file (lockname);
3327 #endif /* CLASH_DETECTION */
3328 report_file_error ("Opening output file", list1 (filename));
3332 Lisp_Object desc_locative = Fcons (make_int (desc), Qnil);
3333 Lisp_Object instream = Qnil, outstream = Qnil;
3334 struct gcpro nngcpro1, nngcpro2;
3335 /* need to gcpro; QUIT could happen out of call to write() */
3336 NNGCPRO2 (instream, outstream);
3338 record_unwind_protect (close_file_unwind, desc_locative);
3342 if (lseek (desc, 0, 2) < 0)
3344 #ifdef CLASH_DETECTION
3345 if (!auto_saving) unlock_file (lockname);
3346 #endif /* CLASH_DETECTION */
3347 report_file_error ("Lseek error",
3354 /* Note: I tried increasing the buffering size, along with
3355 various other tricks, but nothing seemed to make much of
3356 a difference in the time it took to save a large file.
3357 (Actually that's not true. With a local disk, changing
3358 the buffer size doesn't seem to make much difference.
3359 With an NFS-mounted disk, it could make a lot of difference
3360 because you're affecting the number of network requests
3361 that need to be made, and there could be a large latency
3362 for each request. So I've increased the buffer size
3364 outstream = make_filedesc_output_stream (desc, 0, -1, 0);
3365 Lstream_set_buffering (XLSTREAM (outstream),
3366 LSTREAM_BLOCKN_BUFFERED, 65536);
3369 make_encoding_output_stream (XLSTREAM (outstream), codesys);
3370 Lstream_set_buffering (XLSTREAM (outstream),
3371 LSTREAM_BLOCKN_BUFFERED, 65536);
3372 #endif /* FILE_CODING */
3373 if (STRINGP (start))
3375 instream = make_lisp_string_input_stream (start, 0, -1);
3379 instream = make_lisp_buffer_input_stream (current_buffer, start1, end1,
3381 LSTR_IGNORE_ACCESSIBLE);
3382 failure = (0 > (a_write (outstream, instream, start1,
3385 /* Note that this doesn't close the desc since we created the
3386 stream without the LSTR_CLOSING flag, but it does
3387 flush out any buffered data. */
3388 if (Lstream_close (XLSTREAM (outstream)) < 0)
3393 Lstream_close (XLSTREAM (instream));
3396 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
3397 Disk full in NFS may be reported here. */
3398 /* mib says that closing the file will try to write as fast as NFS can do
3399 it, and that means the fsync here is not crucial for autosave files. */
3400 if (!auto_saving && fsync (desc) < 0
3401 /* If fsync fails with EINTR, don't treat that as serious. */
3407 #endif /* HAVE_FSYNC */
3409 /* Spurious "file has changed on disk" warnings used to be seen on
3410 systems where close() can change the modtime. This is known to
3411 happen on various NFS file systems, on Windows, and on Linux.
3412 Rather than handling this on a per-system basis, we
3413 unconditionally do the xemacs_stat() after the close(). */
3415 /* NFS can report a write failure now. */
3416 if (close (desc) < 0)
3422 /* Discard the close unwind-protect. Execute the one for
3423 build_annotations (switches back to the original current buffer
3425 XCAR (desc_locative) = Qnil;
3426 unbind_to (speccount, Qnil);
3431 xemacs_stat ((char *) XSTRING_DATA (fn), &st);
3433 #ifdef CLASH_DETECTION
3435 unlock_file (lockname);
3436 #endif /* CLASH_DETECTION */
3438 /* Do this before reporting IO error
3439 to avoid a "file has changed on disk" warning on
3440 next attempt to save. */
3442 current_buffer->modtime = st.st_mtime;
3447 report_file_error ("Writing file", list1 (fn));
3452 BUF_SAVE_MODIFF (current_buffer) = BUF_MODIFF (current_buffer);
3453 current_buffer->saved_size = make_int (BUF_SIZE (current_buffer));
3454 current_buffer->filename = visit_file;
3455 MARK_MODELINE_CHANGED;
3467 message ("Wrote %s", XSTRING_DATA (visit_file));
3470 Lisp_Object fsp = Qnil;
3471 struct gcpro nngcpro1;
3474 fsp = Ffile_symlink_p (fn);
3476 message ("Wrote %s", XSTRING_DATA (fn));
3478 message ("Wrote %s (symlink to %s)",
3479 XSTRING_DATA (fn), XSTRING_DATA (fsp));
3488 /* #### This is such a load of shit!!!! There is no way we should define
3489 something so stupid as a subr, just sort the fucking list more
3491 DEFUN ("car-less-than-car", Fcar_less_than_car, 2, 2, 0, /*
3492 Return t if (car A) is numerically less than (car B).
3496 Lisp_Object objs[2];
3499 return Flss (2, objs);
3502 /* Heh heh heh, let's define this too, just to aggravate the person who
3503 wrote the above comment. */
3504 DEFUN ("cdr-less-than-cdr", Fcdr_less_than_cdr, 2, 2, 0, /*
3505 Return t if (cdr A) is numerically less than (cdr B).
3509 Lisp_Object objs[2];
3512 return Flss (2, objs);
3515 /* Build the complete list of annotations appropriate for writing out
3516 the text between START and END, by calling all the functions in
3517 write-region-annotate-functions and merging the lists they return.
3518 If one of these functions switches to a different buffer, we assume
3519 that buffer contains altered text. Therefore, the caller must
3520 make sure to restore the current buffer in all cases,
3521 as save-excursion would do. */
3524 build_annotations (Lisp_Object start, Lisp_Object end)
3526 /* This function can GC */
3527 Lisp_Object annotations;
3529 struct gcpro gcpro1, gcpro2;
3530 Lisp_Object original_buffer;
3532 XSETBUFFER (original_buffer, current_buffer);
3535 p = Vwrite_region_annotate_functions;
3536 GCPRO2 (annotations, p);
3539 struct buffer *given_buffer = current_buffer;
3540 Vwrite_region_annotations_so_far = annotations;
3541 res = call2 (Fcar (p), start, end);
3542 /* If the function makes a different buffer current,
3543 assume that means this buffer contains altered text to be output.
3544 Reset START and END from the buffer bounds
3545 and discard all previous annotations because they should have
3546 been dealt with by this function. */
3547 if (current_buffer != given_buffer)
3549 start = make_int (BUF_BEGV (current_buffer));
3550 end = make_int (BUF_ZV (current_buffer));
3553 Flength (res); /* Check basic validity of return value */
3554 annotations = merge (annotations, res, Qcar_less_than_car);
3558 /* Now do the same for annotation functions implied by the file-format */
3559 if (auto_saving && (!EQ (Vauto_save_file_format, Qt)))
3560 p = Vauto_save_file_format;
3562 p = current_buffer->file_format;
3565 struct buffer *given_buffer = current_buffer;
3566 Vwrite_region_annotations_so_far = annotations;
3567 res = call4 (Qformat_annotate_function, Fcar (p), start, end,
3569 if (current_buffer != given_buffer)
3571 start = make_int (BUF_BEGV (current_buffer));
3572 end = make_int (BUF_ZV (current_buffer));
3576 annotations = merge (annotations, res, Qcar_less_than_car);
3583 /* Write to stream OUTSTREAM the characters from INSTREAM (it is read until
3584 EOF is encountered), assuming they start at position POS in the buffer
3585 of string that STREAM refers to. Intersperse with them the annotations
3586 from *ANNOT that fall into the range of positions we are reading from,
3587 each at its appropriate position.
3589 Modify *ANNOT by discarding elements as we output them.
3590 The return value is negative in case of system call failure. */
3592 /* 4K should probably be fine. We just need to reduce the number of
3593 function calls to reasonable level. The Lstream stuff itself will
3594 batch to 64K to reduce the number of system calls. */
3596 #define A_WRITE_BATCH_SIZE 4096
3599 a_write (Lisp_Object outstream, Lisp_Object instream, int pos,
3604 unsigned char largebuf[A_WRITE_BATCH_SIZE];
3605 Lstream *instr = XLSTREAM (instream);
3606 Lstream *outstr = XLSTREAM (outstream);
3608 while (LISTP (*annot))
3610 tem = Fcar_safe (Fcar (*annot));
3612 nextpos = XINT (tem);
3616 /* If there are annotations left and we have Mule, then we
3617 have to do the I/O one emchar at a time so we can
3618 determine when to insert the annotation. */
3622 while (pos != nextpos && (ch = Lstream_get_emchar (instr)) != EOF)
3624 if (Lstream_put_emchar (outstr, ch) < 0)
3632 while (pos != nextpos)
3634 /* Otherwise there is no point to that. Just go in batches. */
3635 int chunk = min (nextpos - pos, A_WRITE_BATCH_SIZE);
3637 chunk = Lstream_read (instr, largebuf, chunk);
3640 if (chunk == 0) /* EOF */
3642 if (Lstream_write (outstr, largebuf, chunk) < chunk)
3649 tem = Fcdr (Fcar (*annot));
3652 if (Lstream_write (outstr, XSTRING_DATA (tem),
3653 XSTRING_LENGTH (tem)) < 0)
3656 *annot = Fcdr (*annot);
3667 #include <des_crypt.h>
3669 #define CRYPT_BLOCK_SIZE 8 /* bytes */
3670 #define CRYPT_KEY_SIZE 8 /* bytes */
3672 DEFUN ("encrypt-string", Fencrypt_string, 2, 2, 0, /*
3673 Encrypt STRING using KEY.
3677 char *encrypted_string, *raw_key;
3678 int rounded_size, extra, key_size;
3680 /* !!#### May produce bogus data under Mule. */
3681 CHECK_STRING (string);
3684 extra = XSTRING_LENGTH (string) % CRYPT_BLOCK_SIZE;
3685 rounded_size = XSTRING_LENGTH (string) + extra;
3686 encrypted_string = alloca (rounded_size + 1);
3687 memcpy (encrypted_string, XSTRING_DATA (string), XSTRING_LENGTH (string));
3688 memset (encrypted_string + rounded_size - extra, 0, extra + 1);
3690 key_size = min (CRYPT_KEY_SIZE, XSTRING_LENGTH (key))
3692 raw_key = alloca (CRYPT_KEY_SIZE + 1);
3693 memcpy (raw_key, XSTRING_DATA (key), key_size);
3694 memset (raw_key + key_size, 0, (CRYPT_KEY_SIZE + 1) - key_size);
3696 ecb_crypt (raw_key, encrypted_string, rounded_size,
3697 DES_ENCRYPT | DES_SW);
3698 return make_string (encrypted_string, rounded_size);
3701 DEFUN ("decrypt-string", Fdecrypt_string, 2, 2, 0, /*
3702 Decrypt STRING using KEY.
3706 char *decrypted_string, *raw_key;
3707 int string_size, key_size;
3709 CHECK_STRING (string);
3712 string_size = XSTRING_LENGTH (string) + 1;
3713 decrypted_string = alloca (string_size);
3714 memcpy (decrypted_string, XSTRING_DATA (string), string_size);
3715 decrypted_string[string_size - 1] = '\0';
3717 key_size = min (CRYPT_KEY_SIZE, XSTRING_LENGTH (key))
3719 raw_key = alloca (CRYPT_KEY_SIZE + 1);
3720 memcpy (raw_key, XSTRING_DATA (key), key_size);
3721 memset (raw_key + key_size, 0, (CRYPT_KEY_SIZE + 1) - key_size);
3724 ecb_crypt (raw_key, decrypted_string, string_size, D | DES_SW);
3725 return make_string (decrypted_string, string_size - 1);
3730 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime, 1, 1, 0, /*
3731 Return t if last mod time of BUFFER's visited file matches what BUFFER records.
3732 This means that the file has not been changed since it was visited or saved.
3736 /* This function can call lisp; GC checked 2000-07-11 ben */
3739 Lisp_Object handler;
3741 CHECK_BUFFER (buffer);
3742 b = XBUFFER (buffer);
3744 if (!STRINGP (b->filename)) return Qt;
3745 if (b->modtime == 0) return Qt;
3747 /* If the file name has special constructs in it,
3748 call the corresponding file handler. */
3749 handler = Ffind_file_name_handler (b->filename,
3750 Qverify_visited_file_modtime);
3751 if (!NILP (handler))
3752 return call2 (handler, Qverify_visited_file_modtime, buffer);
3754 if (xemacs_stat ((char *) XSTRING_DATA (b->filename), &st) < 0)
3756 /* If the file doesn't exist now and didn't exist before,
3757 we say that it isn't modified, provided the error is a tame one. */
3758 if (errno == ENOENT || errno == EACCES || errno == ENOTDIR)
3763 if (st.st_mtime == b->modtime
3764 /* If both are positive, accept them if they are off by one second. */
3765 || (st.st_mtime > 0 && b->modtime > 0
3766 && (st.st_mtime == b->modtime + 1
3767 || st.st_mtime == b->modtime - 1)))
3772 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime, 0, 0, 0, /*
3773 Clear out records of last mod time of visited file.
3774 Next attempt to save will certainly not complain of a discrepancy.
3778 current_buffer->modtime = 0;
3782 DEFUN ("visited-file-modtime", Fvisited_file_modtime, 0, 0, 0, /*
3783 Return the current buffer's recorded visited file modification time.
3784 The value is a list of the form (HIGH . LOW), like the time values
3785 that `file-attributes' returns.
3789 return time_to_lisp ((time_t) current_buffer->modtime);
3792 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime, 0, 1, 0, /*
3793 Update buffer's recorded modification time from the visited file's time.
3794 Useful if the buffer was not read from the file normally
3795 or if the file itself has been changed for some known benign reason.
3796 An argument specifies the modification time value to use
3797 \(instead of that of the visited file), in the form of a list
3798 \(HIGH . LOW) or (HIGH LOW).
3802 /* This function can call lisp */
3803 if (!NILP (time_list))
3806 lisp_to_time (time_list, &the_time);
3807 current_buffer->modtime = (int) the_time;
3811 Lisp_Object filename = Qnil;
3813 Lisp_Object handler;
3814 struct gcpro gcpro1, gcpro2, gcpro3;
3816 GCPRO3 (filename, time_list, current_buffer->filename);
3817 filename = Fexpand_file_name (current_buffer->filename, Qnil);
3819 /* If the file name has special constructs in it,
3820 call the corresponding file handler. */
3821 handler = Ffind_file_name_handler (filename, Qset_visited_file_modtime);
3823 if (!NILP (handler))
3824 /* The handler can find the file name the same way we did. */
3825 return call2 (handler, Qset_visited_file_modtime, Qnil);
3826 else if (xemacs_stat ((char *) XSTRING_DATA (filename), &st) >= 0)
3827 current_buffer->modtime = st.st_mtime;
3834 auto_save_error (Lisp_Object condition_object, Lisp_Object ignored)
3836 /* This function can call lisp */
3839 /* Don't try printing an error message after everything is gone! */
3840 if (preparing_for_armageddon)
3842 clear_echo_area (selected_frame (), Qauto_saving, 1);
3843 Fding (Qt, Qauto_save_error, Qnil);
3844 message ("Auto-saving...error for %s", XSTRING_DATA (current_buffer->name));
3845 Fsleep_for (make_int (1));
3846 message ("Auto-saving...error!for %s", XSTRING_DATA (current_buffer->name));
3847 Fsleep_for (make_int (1));
3848 message ("Auto-saving...error for %s", XSTRING_DATA (current_buffer->name));
3849 Fsleep_for (make_int (1));
3854 auto_save_1 (Lisp_Object ignored)
3856 /* This function can call lisp */
3857 /* #### I think caller is protecting current_buffer? */
3859 Lisp_Object fn = current_buffer->filename;
3860 Lisp_Object a = current_buffer->auto_save_file_name;
3865 /* Get visited file's mode to become the auto save file's mode. */
3867 xemacs_stat ((char *) XSTRING_DATA (fn), &st) >= 0)
3868 /* But make sure we can overwrite it later! */
3869 auto_save_mode_bits = st.st_mode | 0600;
3871 /* default mode for auto-save files of buffers with no file is
3872 readable by owner only. This may annoy some small number of
3873 people, but the alternative removes all privacy from email. */
3874 auto_save_mode_bits = 0600;
3877 /* !!#### need to deal with this 'escape-quoted everywhere */
3878 Fwrite_region_internal (Qnil, Qnil, a, Qnil, Qlambda, Qnil,
3880 current_buffer->buffer_file_coding_system
3888 auto_save_expand_name_error (Lisp_Object condition_object, Lisp_Object ignored)
3890 /* #### this function should spew an error message about not being
3891 able to open the .saves file. */
3896 auto_save_expand_name (Lisp_Object name)
3898 struct gcpro gcpro1;
3900 /* note that caller did NOT gc protect name, so we do it. */
3901 /* #### dmoore - this might not be necessary, if condition_case_1
3902 protects it. but I don't think it does. */
3904 RETURN_UNGCPRO (Fexpand_file_name (name, Qnil));
3909 do_auto_save_unwind (Lisp_Object fd)
3916 do_auto_save_unwind_2 (Lisp_Object old_auto_saving)
3918 auto_saving = XINT (old_auto_saving);
3922 /* Fdo_auto_save() checks whether a GC is in progress when it is called,
3923 and if so, tries to avoid touching lisp objects.
3925 The only time that Fdo_auto_save() is called while GC is in progress
3926 is if we're going down, as a result of an abort() or a kill signal.
3927 It's fairly important that we generate autosave files in that case!
3930 DEFUN ("do-auto-save", Fdo_auto_save, 0, 2, "", /*
3931 Auto-save all buffers that need it.
3932 This is all buffers that have auto-saving enabled
3933 and are changed since last auto-saved.
3934 Auto-saving writes the buffer into a file
3935 so that your editing is not lost if the system crashes.
3936 This file is not the file you visited; that changes only when you save.
3937 Normally we run the normal hook `auto-save-hook' before saving.
3939 Non-nil first argument means do not print any message if successful.
3940 Non-nil second argument means save only current buffer.
3942 (no_message, current_only))
3944 /* This function can call lisp */
3946 Lisp_Object tail, buf;
3948 int do_handled_files;
3949 Lisp_Object oquit = Qnil;
3950 Lisp_Object listfile = Qnil;
3953 int speccount = specpdl_depth ();
3954 struct gcpro gcpro1, gcpro2, gcpro3;
3956 XSETBUFFER (old, current_buffer);
3957 GCPRO3 (oquit, listfile, old);
3958 check_quit (); /* make Vquit_flag accurate */
3959 /* Ordinarily don't quit within this function,
3960 but don't make it impossible to quit (in case we get hung in I/O). */
3964 /* No further GCPRO needed, because (when it matters) all Lisp_Object
3965 variables point to non-strings reached from Vbuffer_alist. */
3967 if (minibuf_level != 0 || preparing_for_armageddon)
3970 run_hook (Qauto_save_hook);
3972 if (STRINGP (Vauto_save_list_file_name))
3973 listfile = condition_case_1 (Qt,
3974 auto_save_expand_name,
3975 Vauto_save_list_file_name,
3976 auto_save_expand_name_error, Qnil);
3978 /* Make sure auto_saving is reset. */
3979 record_unwind_protect (do_auto_save_unwind_2, make_int (auto_saving));
3983 /* First, save all files which don't have handlers. If Emacs is
3984 crashing, the handlers may tweak what is causing Emacs to crash
3985 in the first place, and it would be a shame if Emacs failed to
3986 autosave perfectly ordinary files because it couldn't handle some
3988 for (do_handled_files = 0; do_handled_files < 2; do_handled_files++)
3990 for (tail = Vbuffer_alist;
3994 buf = XCDR (XCAR (tail));
3997 if (!NILP (current_only)
3998 && b != current_buffer)
4001 /* Don't auto-save indirect buffers.
4002 The base buffer takes care of it. */
4006 /* Check for auto save enabled
4007 and file changed since last auto save
4008 and file changed since last real save. */
4009 if (STRINGP (b->auto_save_file_name)
4010 && BUF_SAVE_MODIFF (b) < BUF_MODIFF (b)
4011 && b->auto_save_modified < BUF_MODIFF (b)
4012 /* -1 means we've turned off autosaving for a while--see below. */
4013 && XINT (b->saved_size) >= 0
4014 && (do_handled_files
4015 || NILP (Ffind_file_name_handler (b->auto_save_file_name,
4018 EMACS_TIME before_time, after_time;
4020 EMACS_GET_TIME (before_time);
4021 /* If we had a failure, don't try again for 20 minutes. */
4022 if (!preparing_for_armageddon
4023 && b->auto_save_failure_time >= 0
4024 && (EMACS_SECS (before_time) - b->auto_save_failure_time <
4028 if (!preparing_for_armageddon &&
4029 (XINT (b->saved_size) * 10
4030 > (BUF_Z (b) - BUF_BEG (b)) * 13)
4031 /* A short file is likely to change a large fraction;
4032 spare the user annoying messages. */
4033 && XINT (b->saved_size) > 5000
4034 /* These messages are frequent and annoying for `*mail*'. */
4035 && !NILP (b->filename)
4036 && NILP (no_message)
4037 && disable_auto_save_when_buffer_shrinks)
4039 /* It has shrunk too much; turn off auto-saving here.
4040 Unless we're about to crash, in which case auto-save it
4044 ("Buffer %s has shrunk a lot; auto save turned off there",
4045 XSTRING_DATA (b->name));
4046 /* Turn off auto-saving until there's a real save,
4047 and prevent any more warnings. */
4048 b->saved_size = make_int (-1);
4049 if (!gc_in_progress)
4050 Fsleep_for (make_int (1));
4053 set_buffer_internal (b);
4054 if (!auto_saved && NILP (no_message))
4056 static const unsigned char *msg
4057 = (const unsigned char *) "Auto-saving...";
4058 echo_area_message (selected_frame (), msg, Qnil,
4059 0, strlen ((const char *) msg),
4063 /* Open the auto-save list file, if necessary.
4064 We only do this now so that the file only exists
4065 if we actually auto-saved any files. */
4066 if (!auto_saved && !inhibit_auto_save_session
4067 && !NILP (Vauto_save_list_file_prefix)
4068 && STRINGP (listfile) && listdesc < 0)
4070 listdesc = open ((char *) XSTRING_DATA (listfile),
4071 O_WRONLY | O_TRUNC | O_CREAT | OPEN_BINARY,
4074 /* Arrange to close that file whether or not we get
4077 record_unwind_protect (do_auto_save_unwind,
4078 make_int (listdesc));
4081 /* Record all the buffers that we are auto-saving in
4082 the special file that lists them. For each of
4083 these buffers, record visited name (if any) and
4087 const Extbyte *auto_save_file_name_ext;
4088 Extcount auto_save_file_name_ext_len;
4090 TO_EXTERNAL_FORMAT (LISP_STRING, b->auto_save_file_name,
4091 ALLOCA, (auto_save_file_name_ext,
4092 auto_save_file_name_ext_len),
4094 if (!NILP (b->filename))
4096 const Extbyte *filename_ext;
4097 Extcount filename_ext_len;
4099 TO_EXTERNAL_FORMAT (LISP_STRING, b->filename,
4100 ALLOCA, (filename_ext,
4103 write (listdesc, filename_ext, filename_ext_len);
4105 write (listdesc, "\n", 1);
4106 write (listdesc, auto_save_file_name_ext,
4107 auto_save_file_name_ext_len);
4108 write (listdesc, "\n", 1);
4111 /* dmoore - In a bad scenario we've set b=XBUFFER(buf)
4112 based on values in Vbuffer_alist. auto_save_1 may
4113 cause lisp handlers to run. Those handlers may kill
4114 the buffer and then GC. Since the buffer is killed,
4115 it's no longer in Vbuffer_alist so it might get reaped
4116 by the GC. We also need to protect tail. */
4117 /* #### There is probably a lot of other code which has
4118 pointers into buffers which may get blown away by
4121 struct gcpro ngcpro1, ngcpro2;
4122 NGCPRO2 (buf, tail);
4123 condition_case_1 (Qt,
4125 auto_save_error, Qnil);
4128 /* Handler killed our saved current-buffer! Pick any. */
4129 if (!BUFFER_LIVE_P (XBUFFER (old)))
4130 XSETBUFFER (old, current_buffer);
4132 set_buffer_internal (XBUFFER (old));
4135 /* Handler killed their own buffer! */
4136 if (!BUFFER_LIVE_P(b))
4139 b->auto_save_modified = BUF_MODIFF (b);
4140 b->saved_size = make_int (BUF_SIZE (b));
4141 EMACS_GET_TIME (after_time);
4142 /* If auto-save took more than 60 seconds,
4143 assume it was an NFS failure that got a timeout. */
4144 if (EMACS_SECS (after_time) - EMACS_SECS (before_time) > 60)
4145 b->auto_save_failure_time = EMACS_SECS (after_time);
4150 /* Prevent another auto save till enough input events come in. */
4152 record_auto_save ();
4154 /* If we didn't save anything into the listfile, remove the old
4155 one because nothing needed to be auto-saved. Do this afterwards
4156 rather than before in case we get a crash attempting to autosave
4157 (in that case we'd still want the old one around). */
4158 if (listdesc < 0 && !auto_saved && STRINGP (listfile))
4159 unlink ((char *) XSTRING_DATA (listfile));
4161 /* Show "...done" only if the echo area would otherwise be empty. */
4162 if (auto_saved && NILP (no_message)
4163 && NILP (clear_echo_area (selected_frame (), Qauto_saving, 0)))
4165 static const unsigned char *msg
4166 = (const unsigned char *)"Auto-saving...done";
4167 echo_area_message (selected_frame (), msg, Qnil, 0,
4168 strlen ((const char *) msg), Qauto_saving);
4173 RETURN_UNGCPRO (unbind_to (speccount, Qnil));
4176 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved, 0, 0, 0, /*
4177 Mark current buffer as auto-saved with its current text.
4178 No auto-save file will be written until the buffer changes again.
4182 current_buffer->auto_save_modified = BUF_MODIFF (current_buffer);
4183 current_buffer->saved_size = make_int (BUF_SIZE (current_buffer));
4184 current_buffer->auto_save_failure_time = -1;
4188 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure, 0, 0, 0, /*
4189 Clear any record of a recent auto-save failure in the current buffer.
4193 current_buffer->auto_save_failure_time = -1;
4197 DEFUN ("recent-auto-save-p", Frecent_auto_save_p, 0, 0, 0, /*
4198 Return t if buffer has been auto-saved since last read in or saved.
4202 return (BUF_SAVE_MODIFF (current_buffer) <
4203 current_buffer->auto_save_modified) ? Qt : Qnil;
4207 /************************************************************************/
4208 /* initialization */
4209 /************************************************************************/
4212 syms_of_fileio (void)
4214 defsymbol (&Qexpand_file_name, "expand-file-name");
4215 defsymbol (&Qfile_truename, "file-truename");
4216 defsymbol (&Qsubstitute_in_file_name, "substitute-in-file-name");
4217 defsymbol (&Qdirectory_file_name, "directory-file-name");
4218 defsymbol (&Qfile_name_directory, "file-name-directory");
4219 defsymbol (&Qfile_name_nondirectory, "file-name-nondirectory");
4220 defsymbol (&Qunhandled_file_name_directory, "unhandled-file-name-directory");
4221 defsymbol (&Qfile_name_as_directory, "file-name-as-directory");
4222 defsymbol (&Qcopy_file, "copy-file");
4223 defsymbol (&Qmake_directory_internal, "make-directory-internal");
4224 defsymbol (&Qdelete_directory, "delete-directory");
4225 defsymbol (&Qdelete_file, "delete-file");
4226 defsymbol (&Qrename_file, "rename-file");
4227 defsymbol (&Qadd_name_to_file, "add-name-to-file");
4228 defsymbol (&Qmake_symbolic_link, "make-symbolic-link");
4229 defsymbol (&Qfile_exists_p, "file-exists-p");
4230 defsymbol (&Qfile_executable_p, "file-executable-p");
4231 defsymbol (&Qfile_readable_p, "file-readable-p");
4232 defsymbol (&Qfile_symlink_p, "file-symlink-p");
4233 defsymbol (&Qfile_writable_p, "file-writable-p");
4234 defsymbol (&Qfile_directory_p, "file-directory-p");
4235 defsymbol (&Qfile_regular_p, "file-regular-p");
4236 defsymbol (&Qfile_accessible_directory_p, "file-accessible-directory-p");
4237 defsymbol (&Qfile_modes, "file-modes");
4238 defsymbol (&Qset_file_modes, "set-file-modes");
4239 defsymbol (&Qfile_newer_than_file_p, "file-newer-than-file-p");
4240 defsymbol (&Qinsert_file_contents, "insert-file-contents");
4241 defsymbol (&Qwrite_region, "write-region");
4242 defsymbol (&Qverify_visited_file_modtime, "verify-visited-file-modtime");
4243 defsymbol (&Qset_visited_file_modtime, "set-visited-file-modtime");
4244 defsymbol (&Qcar_less_than_car, "car-less-than-car"); /* Vomitous! */
4246 defsymbol (&Qauto_save_hook, "auto-save-hook");
4247 defsymbol (&Qauto_save_error, "auto-save-error");
4248 defsymbol (&Qauto_saving, "auto-saving");
4250 defsymbol (&Qformat_decode, "format-decode");
4251 defsymbol (&Qformat_annotate_function, "format-annotate-function");
4253 defsymbol (&Qcompute_buffer_file_truename, "compute-buffer-file-truename");
4254 DEFERROR_STANDARD (Qfile_error, Qio_error);
4255 DEFERROR_STANDARD (Qfile_already_exists, Qfile_error);
4257 DEFSUBR (Ffind_file_name_handler);
4259 DEFSUBR (Ffile_name_directory);
4260 DEFSUBR (Ffile_name_nondirectory);
4261 DEFSUBR (Funhandled_file_name_directory);
4262 DEFSUBR (Ffile_name_as_directory);
4263 DEFSUBR (Fdirectory_file_name);
4264 DEFSUBR (Fmake_temp_name);
4265 DEFSUBR (Fexpand_file_name);
4266 DEFSUBR (Ffile_truename);
4267 DEFSUBR (Fsubstitute_in_file_name);
4268 DEFSUBR (Fcopy_file);
4269 DEFSUBR (Fmake_directory_internal);
4270 DEFSUBR (Fdelete_directory);
4271 DEFSUBR (Fdelete_file);
4272 DEFSUBR (Frename_file);
4273 DEFSUBR (Fadd_name_to_file);
4274 DEFSUBR (Fmake_symbolic_link);
4276 DEFSUBR (Fsysnetunam);
4277 #endif /* HPUX_NET */
4278 DEFSUBR (Ffile_name_absolute_p);
4279 DEFSUBR (Ffile_exists_p);
4280 DEFSUBR (Ffile_executable_p);
4281 DEFSUBR (Ffile_readable_p);
4282 DEFSUBR (Ffile_writable_p);
4283 DEFSUBR (Ffile_symlink_p);
4284 DEFSUBR (Ffile_directory_p);
4285 DEFSUBR (Ffile_accessible_directory_p);
4286 DEFSUBR (Ffile_regular_p);
4287 DEFSUBR (Ffile_modes);
4288 DEFSUBR (Fset_file_modes);
4289 DEFSUBR (Fset_default_file_modes);
4290 DEFSUBR (Fdefault_file_modes);
4291 DEFSUBR (Funix_sync);
4292 DEFSUBR (Ffile_newer_than_file_p);
4293 DEFSUBR (Finsert_file_contents_internal);
4294 DEFSUBR (Fwrite_region_internal);
4295 DEFSUBR (Fcar_less_than_car); /* Vomitous! */
4296 DEFSUBR (Fcdr_less_than_cdr); /* Yeah oh yeah bucko .... */
4298 DEFSUBR (Fencrypt_string);
4299 DEFSUBR (Fdecrypt_string);
4301 DEFSUBR (Fverify_visited_file_modtime);
4302 DEFSUBR (Fclear_visited_file_modtime);
4303 DEFSUBR (Fvisited_file_modtime);
4304 DEFSUBR (Fset_visited_file_modtime);
4306 DEFSUBR (Fdo_auto_save);
4307 DEFSUBR (Fset_buffer_auto_saved);
4308 DEFSUBR (Fclear_buffer_auto_save_failure);
4309 DEFSUBR (Frecent_auto_save_p);
4313 vars_of_fileio (void)
4315 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format /*
4316 *Format in which to write auto-save files.
4317 Should be a list of symbols naming formats that are defined in `format-alist'.
4318 If it is t, which is the default, auto-save files are written in the
4319 same format as a regular save would use.
4321 Vauto_save_file_format = Qt;
4323 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist /*
4324 *Alist of elements (REGEXP . HANDLER) for file names handled specially.
4325 If a file name matches REGEXP, then all I/O on that file is done by calling
4328 The first argument given to HANDLER is the name of the I/O primitive
4329 to be handled; the remaining arguments are the arguments that were
4330 passed to that primitive. For example, if you do
4331 (file-exists-p FILENAME)
4332 and FILENAME is handled by HANDLER, then HANDLER is called like this:
4333 (funcall HANDLER 'file-exists-p FILENAME)
4334 The function `find-file-name-handler' checks this list for a handler
4337 Vfile_name_handler_alist = Qnil;
4339 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions /*
4340 A list of functions to be called at the end of `insert-file-contents'.
4341 Each is passed one argument, the number of bytes inserted. It should return
4342 the new byte count, and leave point the same. If `insert-file-contents' is
4343 intercepted by a handler from `file-name-handler-alist', that handler is
4344 responsible for calling the after-insert-file-functions if appropriate.
4346 Vafter_insert_file_functions = Qnil;
4348 DEFVAR_LISP ("write-region-annotate-functions",
4349 &Vwrite_region_annotate_functions /*
4350 A list of functions to be called at the start of `write-region'.
4351 Each is passed two arguments, START and END, as for `write-region'.
4352 It should return a list of pairs (POSITION . STRING) of strings to be
4353 effectively inserted at the specified positions of the file being written
4354 \(1 means to insert before the first byte written). The POSITIONs must be
4355 sorted into increasing order. If there are several functions in the list,
4356 the several lists are merged destructively.
4358 Vwrite_region_annotate_functions = Qnil;
4360 DEFVAR_LISP ("write-region-annotations-so-far",
4361 &Vwrite_region_annotations_so_far /*
4362 When an annotation function is called, this holds the previous annotations.
4363 These are the annotations made by other annotation functions
4364 that were already called. See also `write-region-annotate-functions'.
4366 Vwrite_region_annotations_so_far = Qnil;
4368 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers /*
4369 A list of file name handlers that temporarily should not be used.
4370 This applies only to the operation `inhibit-file-name-operation'.
4372 Vinhibit_file_name_handlers = Qnil;
4374 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation /*
4375 The operation for which `inhibit-file-name-handlers' is applicable.
4377 Vinhibit_file_name_operation = Qnil;
4379 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name /*
4380 File name in which we write a list of all auto save file names.
4382 Vauto_save_list_file_name = Qnil;
4384 DEFVAR_LISP ("auto-save-list-file-prefix", &Vauto_save_list_file_prefix /*
4385 Prefix for generating auto-save-list-file-name.
4386 Emacs's pid and the system name will be appended to
4387 this prefix to create a unique file name.
4389 Vauto_save_list_file_prefix = build_string ("~/.saves-");
4391 DEFVAR_BOOL ("inhibit-auto-save-session", &inhibit_auto_save_session /*
4392 When non-nil, inhibit auto save list file creation.
4394 inhibit_auto_save_session = 0;
4396 DEFVAR_BOOL ("disable-auto-save-when-buffer-shrinks",
4397 &disable_auto_save_when_buffer_shrinks /*
4398 If non-nil, auto-saving is disabled when a buffer shrinks too much.
4399 This is to prevent you from losing your edits if you accidentally
4400 delete a large chunk of the buffer and don't notice it until too late.
4401 Saving the buffer normally turns auto-save back on.
4403 disable_auto_save_when_buffer_shrinks = 1;
4405 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char /*
4406 Directory separator character for built-in functions that return file names.
4407 The value should be either ?/ or ?\\ (any other value is treated as ?\\).
4408 This variable affects the built-in functions only on Windows,
4409 on other platforms, it is initialized so that Lisp code can find out
4410 what the normal separator is.
4413 Vdirectory_sep_char = make_char ('\\');
4415 Vdirectory_sep_char = make_char ('/');
4418 reinit_vars_of_fileio ();
4422 reinit_vars_of_fileio (void)
4424 /* We want temp_name_rand to be initialized to a value likely to be
4425 unique to the process, not to the executable. The danger is that
4426 two different XEmacs processes using the same binary on different
4427 machines creating temp files in the same directory will be
4428 unlucky enough to have the same pid. If we randomize using
4429 process startup time, then in practice they will be unlikely to
4430 collide. We use the microseconds field so that scripts that start
4431 simultaneous XEmacs processes on multiple machines will have less
4432 chance of collision. */
4436 EMACS_GET_TIME (thyme);
4437 temp_name_rand = (unsigned int) (EMACS_SECS (thyme) ^ EMACS_USECS (thyme));