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 (elen > MAXPATHLEN)
1342 /* Try doing it all at once. */
1343 /* !! Does realpath() Mule-encapsulate?
1344 Answer: Nope! So we do it above */
1345 if (!xrealpath ((char *) path, resolved_path))
1347 /* Didn't resolve it -- have to do it one component at a time. */
1348 /* "realpath" is a typically useless, stupid un*x piece of crap.
1349 It claims to return a useful value in the "error" case, but since
1350 there is no indication provided of how far along the pathname
1351 the function went before erring, there is no way to use the
1352 partial result returned. What a piece of junk.
1354 The above comment refers to historical versions of
1355 realpath(). The Unix98 specs state:
1357 "On successful completion, realpath() returns a
1358 pointer to the resolved name. Otherwise, realpath()
1359 returns a null pointer and sets errno to indicate the
1360 error, and the contents of the buffer pointed to by
1361 resolved_name are undefined."
1363 Since we depend on undocumented semantics of various system realpath()s,
1364 we just use our own version in realpath.c. */
1369 #ifdef WIN32_FILENAMES
1370 if (IS_DRIVE (p[0]) && IS_DEVICE_SEP (p[1])
1371 && IS_DIRECTORY_SEP (p[2]))
1372 /* don't test c: on windows */
1374 else if (IS_DIRECTORY_SEP (p[0]) && IS_DIRECTORY_SEP (p[1]))
1375 /* start after // */
1378 for (pos = p + 1; pos < path + elen; pos++)
1379 if (IS_DIRECTORY_SEP (*pos))
1387 if (xrealpath ((char *) path, resolved_path))
1395 else if (errno == ENOENT || errno == EACCES)
1397 /* Failed on this component. Just tack on the rest of
1398 the string and we are done. */
1399 int rlen = strlen (resolved_path);
1401 /* "On failure, it returns NULL, sets errno to indicate
1402 the error, and places in resolved_path the absolute pathname
1403 of the path component which could not be resolved." */
1407 int plen = elen - (p - path);
1409 if (rlen > 1 && IS_DIRECTORY_SEP (resolved_path[rlen - 1]))
1412 if (plen + rlen + 1 > countof (resolved_path))
1415 resolved_path[rlen] = DIRECTORY_SEP;
1416 memcpy (resolved_path + rlen + 1, p + 1, plen + 1 - 1);
1426 Lisp_Object resolved_name;
1427 int rlen = strlen (resolved_path);
1428 if (elen > 0 && IS_DIRECTORY_SEP (XSTRING_BYTE (expanded_name, elen - 1))
1429 && !(rlen > 0 && IS_DIRECTORY_SEP (resolved_path[rlen - 1])))
1431 if (rlen + 1 > countof (resolved_path))
1433 resolved_path[rlen++] = DIRECTORY_SEP;
1434 resolved_path[rlen] = '\0';
1436 TO_INTERNAL_FORMAT (DATA, (resolved_path, rlen),
1437 LISP_STRING, resolved_name,
1439 RETURN_UNGCPRO (resolved_name);
1443 errno = ENAMETOOLONG;
1446 report_file_error ("Finding truename", list1 (expanded_name));
1448 RETURN_UNGCPRO (Qnil);
1452 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name, 1, 1, 0, /*
1453 Substitute environment variables referred to in FILENAME.
1454 `$FOO' where FOO is an environment variable name means to substitute
1455 the value of that variable. The variable name should be terminated
1456 with a character, not a letter, digit or underscore; otherwise, enclose
1457 the entire variable name in braces.
1458 If `/~' appears, all of FILENAME through that `/' is discarded.
1462 /* This function can GC. GC checked 2000-07-28 ben. */
1465 Bufbyte *s, *p, *o, *x, *endp;
1466 Bufbyte *target = 0;
1468 int substituted = 0;
1470 Lisp_Object handler;
1472 CHECK_STRING (filename);
1474 /* If the file name has special constructs in it,
1475 call the corresponding file handler. */
1476 handler = Ffind_file_name_handler (filename, Qsubstitute_in_file_name);
1477 if (!NILP (handler))
1478 return call2_check_string_or_nil (handler, Qsubstitute_in_file_name,
1481 nm = XSTRING_DATA (filename);
1482 endp = nm + XSTRING_LENGTH (filename);
1484 /* If /~ or // appears, discard everything through first slash. */
1486 for (p = nm; p != endp; p++)
1489 #if defined (WIN32_FILENAMES)
1490 /* // at start of file name is meaningful in WindowsNT systems */
1491 || (IS_DIRECTORY_SEP (p[0]) && p - 1 != nm)
1492 #else /* not (WIN32_FILENAMES) */
1493 || IS_DIRECTORY_SEP (p[0])
1494 #endif /* not (WIN32_FILENAMES) */
1497 && (IS_DIRECTORY_SEP (p[-1])))
1502 #ifdef WIN32_FILENAMES
1503 /* see comment in expand-file-name about drive specifiers */
1504 else if (IS_DRIVE (p[0]) && p[1] == ':'
1505 && p > nm && IS_DIRECTORY_SEP (p[-1]))
1510 #endif /* WIN32_FILENAMES */
1513 /* See if any variables are substituted into the string
1514 and find the total length of their values in `total' */
1516 for (p = nm; p != endp;)
1526 /* "$$" means a single "$" */
1535 while (p != endp && *p != '}') p++;
1536 if (*p != '}') goto missingclose;
1542 while (p != endp && (isalnum (*p) || *p == '_')) p++;
1546 /* Copy out the variable name */
1547 target = (Bufbyte *) alloca (s - o + 1);
1548 strncpy ((char *) target, (char *) o, s - o);
1551 strupr (target); /* $home == $HOME etc. */
1552 #endif /* WIN32_NATIVE */
1554 /* Get variable value */
1555 o = (Bufbyte *) egetenv ((char *) target);
1556 if (!o) goto badvar;
1557 total += strlen ((char *) o);
1564 /* If substitution required, recopy the filename and do it */
1565 /* Make space in stack frame for the new copy */
1566 xnm = (Bufbyte *) alloca (XSTRING_LENGTH (filename) + total + 1);
1569 /* Copy the rest of the name through, replacing $ constructs with values */
1586 while (p != endp && *p != '}') p++;
1587 if (*p != '}') goto missingclose;
1593 while (p != endp && (isalnum (*p) || *p == '_')) p++;
1597 /* Copy out the variable name */
1598 target = (Bufbyte *) alloca (s - o + 1);
1599 strncpy ((char *) target, (char *) o, s - o);
1602 strupr (target); /* $home == $HOME etc. */
1603 #endif /* WIN32_NATIVE */
1605 /* Get variable value */
1606 o = (Bufbyte *) egetenv ((char *) target);
1610 strcpy ((char *) x, (char *) o);
1611 x += strlen ((char *) o);
1616 /* If /~ or // appears, discard everything through first slash. */
1618 for (p = xnm; p != x; p++)
1620 #if defined (WIN32_FILENAMES)
1621 || (IS_DIRECTORY_SEP (p[0]) && p - 1 != xnm)
1622 #else /* not WIN32_FILENAMES */
1623 || IS_DIRECTORY_SEP (p[0])
1624 #endif /* not WIN32_FILENAMES */
1626 /* don't do p[-1] if that would go off the beginning --jwz */
1627 && p != nm && p > xnm && IS_DIRECTORY_SEP (p[-1]))
1629 #ifdef WIN32_FILENAMES
1630 else if (IS_DRIVE (p[0]) && p[1] == ':'
1631 && p > nm && IS_DIRECTORY_SEP (p[-1]))
1635 return make_string (xnm, x - xnm);
1638 syntax_error ("Bad format environment-variable substitution", filename);
1640 syntax_error ("Missing \"}\" in environment-variable substitution",
1643 syntax_error_2 ("Substituting nonexistent environment variable",
1644 filename, build_string ((char *) target));
1647 return Qnil; /* suppress compiler warning */
1650 /* A slightly faster and more convenient way to get
1651 (directory-file-name (expand-file-name FOO)). */
1654 expand_and_dir_to_file (Lisp_Object filename, Lisp_Object defdir)
1656 /* This function can call Lisp. GC checked 2000-07-28 ben */
1657 Lisp_Object abspath;
1658 struct gcpro gcpro1;
1660 abspath = Fexpand_file_name (filename, defdir);
1662 /* Remove final slash, if any (unless path is root).
1663 stat behaves differently depending! */
1664 if (XSTRING_LENGTH (abspath) > 1
1665 && IS_DIRECTORY_SEP (XSTRING_BYTE (abspath, XSTRING_LENGTH (abspath) - 1))
1666 && !IS_DEVICE_SEP (XSTRING_BYTE (abspath, XSTRING_LENGTH (abspath) - 2)))
1667 /* We cannot take shortcuts; they might be wrong for magic file names. */
1668 abspath = Fdirectory_file_name (abspath);
1673 /* Signal an error if the file ABSNAME already exists.
1674 If INTERACTIVE is nonzero, ask the user whether to proceed,
1675 and bypass the error if the user says to go ahead.
1676 QUERYSTRING is a name for the action that is being considered
1678 *STATPTR is used to store the stat information if the file exists.
1679 If the file does not exist, STATPTR->st_mode is set to 0. */
1682 barf_or_query_if_file_exists (Lisp_Object absname, const char *querystring,
1683 int interactive, struct stat *statptr)
1685 /* This function can call Lisp. GC checked 2000-07-28 ben */
1686 struct stat statbuf;
1688 /* stat is a good way to tell whether the file exists,
1689 regardless of what access permissions it has. */
1690 if (xemacs_stat ((char *) XSTRING_DATA (absname), &statbuf) >= 0)
1697 struct gcpro gcpro1;
1699 prompt = emacs_doprnt_string_c
1700 ((const Bufbyte *) GETTEXT ("File %s already exists; %s anyway? "),
1701 Qnil, -1, XSTRING_DATA (absname),
1702 GETTEXT (querystring));
1705 tem = call1 (Qyes_or_no_p, prompt);
1712 Fsignal (Qfile_already_exists,
1713 list2 (build_translated_string ("File already exists"),
1721 statptr->st_mode = 0;
1726 DEFUN ("copy-file", Fcopy_file, 2, 4,
1727 "fCopy file: \nFCopy %s to file: \np\nP", /*
1728 Copy FILENAME to NEWNAME. Both args must be strings.
1729 Signals a `file-already-exists' error if file NEWNAME already exists,
1730 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.
1731 A number as third arg means request confirmation if NEWNAME already exists.
1732 This is what happens in interactive use with M-x.
1733 Fourth arg KEEP-TIME non-nil means give the new file the same
1734 last-modified time as the old one. (This works on only some systems.)
1735 A prefix arg makes KEEP-TIME non-nil.
1737 (filename, newname, ok_if_already_exists, keep_time))
1739 /* This function can call Lisp. GC checked 2000-07-28 ben */
1741 char buf[16 * 1024];
1742 struct stat st, out_st;
1743 Lisp_Object handler;
1744 int speccount = specpdl_depth ();
1745 struct gcpro gcpro1, gcpro2;
1746 /* Lisp_Object args[6]; */
1747 int input_file_statable_p;
1749 GCPRO2 (filename, newname);
1750 CHECK_STRING (filename);
1751 CHECK_STRING (newname);
1752 filename = Fexpand_file_name (filename, Qnil);
1753 newname = Fexpand_file_name (newname, Qnil);
1755 /* If the input file name has special constructs in it,
1756 call the corresponding file handler. */
1757 handler = Ffind_file_name_handler (filename, Qcopy_file);
1758 /* Likewise for output file name. */
1760 handler = Ffind_file_name_handler (newname, Qcopy_file);
1761 if (!NILP (handler))
1764 return call5 (handler, Qcopy_file, filename, newname,
1765 ok_if_already_exists, keep_time);
1768 /* When second argument is a directory, copy the file into it.
1769 (copy-file "foo" "bar/") == (copy-file "foo" "bar/foo")
1771 if (!NILP (Ffile_directory_p (newname)))
1773 Lisp_Object args[3];
1774 struct gcpro ngcpro1;
1778 args[1] = Qnil; args[2] = Qnil;
1781 if (!IS_DIRECTORY_SEP (XSTRING_BYTE (newname,
1782 XSTRING_LENGTH (newname) - 1)))
1784 args[i++] = Fchar_to_string (Vdirectory_sep_char);
1785 args[i++] = Ffile_name_nondirectory (filename);
1786 newname = Fconcat (i, args);
1790 if (NILP (ok_if_already_exists)
1791 || INTP (ok_if_already_exists))
1792 barf_or_query_if_file_exists (newname, "copy to it",
1793 INTP (ok_if_already_exists), &out_st);
1794 else if (xemacs_stat ((const char *) XSTRING_DATA (newname), &out_st) < 0)
1797 ifd = interruptible_open ((char *) XSTRING_DATA (filename), O_RDONLY | OPEN_BINARY, 0);
1799 report_file_error ("Opening input file", list1 (filename));
1801 record_unwind_protect (close_file_unwind, make_int (ifd));
1803 /* We can only copy regular files and symbolic links. Other files are not
1805 input_file_statable_p = (fstat (ifd, &st) >= 0);
1807 #ifndef WIN32_NATIVE
1808 if (out_st.st_mode != 0
1809 && st.st_dev == out_st.st_dev && st.st_ino == out_st.st_ino)
1812 report_file_error ("Input and output files are the same",
1813 list2 (filename, newname));
1817 #if defined (S_ISREG) && defined (S_ISLNK)
1818 if (input_file_statable_p)
1820 if (!(S_ISREG (st.st_mode))
1821 /* XEmacs: have to allow S_ISCHR in order to copy /dev/null */
1823 && !(S_ISCHR (st.st_mode))
1825 && !(S_ISLNK (st.st_mode)))
1827 #if defined (EISDIR)
1828 /* Get a better looking error message. */
1831 report_file_error ("Non-regular file", list1 (filename));
1834 #endif /* S_ISREG && S_ISLNK */
1836 ofd = open( (char *) XSTRING_DATA (newname),
1837 O_WRONLY | O_CREAT | O_TRUNC | OPEN_BINARY, CREAT_MODE);
1839 report_file_error ("Opening output file", list1 (newname));
1842 Lisp_Object ofd_locative = noseeum_cons (make_int (ofd), Qnil);
1844 record_unwind_protect (close_file_unwind, ofd_locative);
1846 while ((n = read_allowing_quit (ifd, buf, sizeof (buf))) > 0)
1848 if (write_allowing_quit (ofd, buf, n) != n)
1849 report_file_error ("I/O error", list1 (newname));
1852 /* Closing the output clobbers the file times on some systems. */
1853 if (close (ofd) < 0)
1854 report_file_error ("I/O error", list1 (newname));
1856 if (input_file_statable_p)
1858 if (!NILP (keep_time))
1860 EMACS_TIME atime, mtime;
1861 EMACS_SET_SECS_USECS (atime, st.st_atime, 0);
1862 EMACS_SET_SECS_USECS (mtime, st.st_mtime, 0);
1863 if (set_file_times (newname, atime, mtime))
1864 report_file_error ("I/O error", list1 (newname));
1866 chmod ((const char *) XSTRING_DATA (newname),
1867 st.st_mode & 07777);
1870 /* We'll close it by hand */
1871 XCAR (ofd_locative) = Qnil;
1874 unbind_to (speccount, Qnil);
1881 DEFUN ("make-directory-internal", Fmake_directory_internal, 1, 1, 0, /*
1882 Create a directory. One argument, a file name string.
1886 /* This function can GC. GC checked 1997.04.06. */
1887 char dir [MAXPATHLEN];
1888 Lisp_Object handler;
1889 struct gcpro gcpro1;
1891 CHECK_STRING (dirname_);
1892 dirname_ = Fexpand_file_name (dirname_, Qnil);
1895 handler = Ffind_file_name_handler (dirname_, Qmake_directory_internal);
1897 if (!NILP (handler))
1898 return (call2 (handler, Qmake_directory_internal, dirname_));
1900 if (XSTRING_LENGTH (dirname_) > (Bytecount) (sizeof (dir) - 1))
1902 return Fsignal (Qfile_error,
1903 list3 (build_translated_string ("Creating directory"),
1904 build_translated_string ("pathname too long"),
1907 strncpy (dir, (char *) XSTRING_DATA (dirname_),
1908 XSTRING_LENGTH (dirname_) + 1);
1910 if (dir [XSTRING_LENGTH (dirname_) - 1] == '/')
1911 dir [XSTRING_LENGTH (dirname_) - 1] = 0;
1913 if (mkdir (dir, 0777) != 0)
1914 report_file_error ("Creating directory", list1 (dirname_));
1919 DEFUN ("delete-directory", Fdelete_directory, 1, 1, "FDelete directory: ", /*
1920 Delete a directory. One argument, a file name or directory name string.
1924 /* This function can GC. GC checked 1997.04.06. */
1925 Lisp_Object handler;
1926 struct gcpro gcpro1;
1928 CHECK_STRING (dirname_);
1931 dirname_ = Fexpand_file_name (dirname_, Qnil);
1932 dirname_ = Fdirectory_file_name (dirname_);
1934 handler = Ffind_file_name_handler (dirname_, Qdelete_directory);
1936 if (!NILP (handler))
1937 return (call2 (handler, Qdelete_directory, dirname_));
1939 if (rmdir ((char *) XSTRING_DATA (dirname_)) != 0)
1940 report_file_error ("Removing directory", list1 (dirname_));
1945 DEFUN ("delete-file", Fdelete_file, 1, 1, "fDelete file: ", /*
1946 Delete the file named FILENAME (a string).
1947 If FILENAME has multiple names, it continues to exist with the other names.
1951 /* This function can GC. GC checked 1997.04.06. */
1952 Lisp_Object handler;
1953 struct gcpro gcpro1;
1955 CHECK_STRING (filename);
1956 filename = Fexpand_file_name (filename, Qnil);
1959 handler = Ffind_file_name_handler (filename, Qdelete_file);
1961 if (!NILP (handler))
1962 return call2 (handler, Qdelete_file, filename);
1964 if (0 > unlink ((char *) XSTRING_DATA (filename)))
1965 report_file_error ("Removing old name", list1 (filename));
1970 internal_delete_file_1 (Lisp_Object ignore, Lisp_Object ignore2)
1975 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */
1978 internal_delete_file (Lisp_Object filename)
1980 /* This function can GC. GC checked 1997.04.06. */
1981 return NILP (condition_case_1 (Qt, Fdelete_file, filename,
1982 internal_delete_file_1, Qnil));
1985 DEFUN ("rename-file", Frename_file, 2, 3,
1986 "fRename file: \nFRename %s to file: \np", /*
1987 Rename FILENAME as NEWNAME. Both args must be strings.
1988 If file has names other than FILENAME, it continues to have those names.
1989 Signals a `file-already-exists' error if a file NEWNAME already exists
1990 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
1991 A number as third arg means request confirmation if NEWNAME already exists.
1992 This is what happens in interactive use with M-x.
1994 (filename, newname, ok_if_already_exists))
1996 /* This function can GC. GC checked 1997.04.06. */
1997 Lisp_Object handler;
1998 struct gcpro gcpro1, gcpro2;
2000 GCPRO2 (filename, newname);
2001 CHECK_STRING (filename);
2002 CHECK_STRING (newname);
2003 filename = Fexpand_file_name (filename, Qnil);
2004 newname = Fexpand_file_name (newname, Qnil);
2006 /* If the file name has special constructs in it,
2007 call the corresponding file handler. */
2008 handler = Ffind_file_name_handler (filename, Qrename_file);
2010 handler = Ffind_file_name_handler (newname, Qrename_file);
2011 if (!NILP (handler))
2014 return call4 (handler, Qrename_file,
2015 filename, newname, ok_if_already_exists);
2018 /* When second argument is a directory, rename the file into it.
2019 (rename-file "foo" "bar/") == (rename-file "foo" "bar/foo")
2021 if (!NILP (Ffile_directory_p (newname)))
2023 Lisp_Object args[3];
2024 struct gcpro ngcpro1;
2028 args[1] = Qnil; args[2] = Qnil;
2031 if (XSTRING_BYTE (newname, XSTRING_LENGTH (newname) - 1) != '/')
2032 args[i++] = build_string ("/");
2033 args[i++] = Ffile_name_nondirectory (filename);
2034 newname = Fconcat (i, args);
2038 if (NILP (ok_if_already_exists)
2039 || INTP (ok_if_already_exists))
2040 barf_or_query_if_file_exists (newname, "rename to it",
2041 INTP (ok_if_already_exists), 0);
2043 /* Syncing with FSF 19.34.6 note: FSF does not have conditional code for
2044 WIN32_NATIVE here; I've removed it. --marcpa */
2046 /* We have configure check for rename() and emulate using
2047 link()/unlink() if necessary. */
2048 if (0 > rename ((char *) XSTRING_DATA (filename),
2049 (char *) XSTRING_DATA (newname)))
2053 Fcopy_file (filename, newname,
2054 /* We have already prompted if it was an integer,
2055 so don't have copy-file prompt again. */
2056 (NILP (ok_if_already_exists) ? Qnil : Qt),
2058 Fdelete_file (filename);
2062 report_file_error ("Renaming", list2 (filename, newname));
2069 DEFUN ("add-name-to-file", Fadd_name_to_file, 2, 3,
2070 "fAdd name to file: \nFName to add to %s: \np", /*
2071 Give FILENAME additional name NEWNAME. Both args must be strings.
2072 Signals a `file-already-exists' error if a file NEWNAME already exists
2073 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2074 A number as third arg means request confirmation if NEWNAME already exists.
2075 This is what happens in interactive use with M-x.
2077 (filename, newname, ok_if_already_exists))
2079 /* This function can GC. GC checked 1997.04.06. */
2080 Lisp_Object handler;
2081 struct gcpro gcpro1, gcpro2;
2083 GCPRO2 (filename, newname);
2084 CHECK_STRING (filename);
2085 CHECK_STRING (newname);
2086 filename = Fexpand_file_name (filename, Qnil);
2087 newname = Fexpand_file_name (newname, Qnil);
2089 /* If the file name has special constructs in it,
2090 call the corresponding file handler. */
2091 handler = Ffind_file_name_handler (filename, Qadd_name_to_file);
2092 if (!NILP (handler))
2093 RETURN_UNGCPRO (call4 (handler, Qadd_name_to_file, filename,
2094 newname, ok_if_already_exists));
2096 /* If the new name has special constructs in it,
2097 call the corresponding file handler. */
2098 handler = Ffind_file_name_handler (newname, Qadd_name_to_file);
2099 if (!NILP (handler))
2100 RETURN_UNGCPRO (call4 (handler, Qadd_name_to_file, filename,
2101 newname, ok_if_already_exists));
2103 if (NILP (ok_if_already_exists)
2104 || INTP (ok_if_already_exists))
2105 barf_or_query_if_file_exists (newname, "make it a new name",
2106 INTP (ok_if_already_exists), 0);
2107 /* Syncing with FSF 19.34.6 note: FSF does not report a file error
2108 on NT here. --marcpa */
2109 /* But FSF #defines link as sys_link which is supplied in nt.c. We can't do
2110 that because sysfile.h defines sys_link depending on ENCAPSULATE_LINK.
2111 Reverted to previous behavior pending a working fix. (jhar) */
2112 #if defined(WIN32_NATIVE)
2113 /* Windows does not support this operation. */
2114 report_file_error ("Adding new name", Flist (2, &filename));
2115 #else /* not defined(WIN32_NATIVE) */
2117 unlink ((char *) XSTRING_DATA (newname));
2118 if (0 > link ((char *) XSTRING_DATA (filename),
2119 (char *) XSTRING_DATA (newname)))
2121 report_file_error ("Adding new name",
2122 list2 (filename, newname));
2124 #endif /* defined(WIN32_NATIVE) */
2130 DEFUN ("make-symbolic-link", Fmake_symbolic_link, 2, 3,
2131 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np", /*
2132 Make a symbolic link to FILENAME, named LINKNAME. Both args strings.
2133 Signals a `file-already-exists' error if a file LINKNAME already exists
2134 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2135 A number as third arg means request confirmation if LINKNAME already exists.
2136 This happens for interactive use with M-x.
2138 (filename, linkname, ok_if_already_exists))
2140 /* This function can GC. GC checked 1997.06.04. */
2141 /* XEmacs change: run handlers even if local machine doesn't have symlinks */
2142 Lisp_Object handler;
2143 struct gcpro gcpro1, gcpro2;
2145 GCPRO2 (filename, linkname);
2146 CHECK_STRING (filename);
2147 CHECK_STRING (linkname);
2148 /* If the link target has a ~, we must expand it to get
2149 a truly valid file name. Otherwise, do not expand;
2150 we want to permit links to relative file names. */
2151 if (XSTRING_BYTE (filename, 0) == '~')
2152 filename = Fexpand_file_name (filename, Qnil);
2153 linkname = Fexpand_file_name (linkname, Qnil);
2155 /* If the file name has special constructs in it,
2156 call the corresponding file handler. */
2157 handler = Ffind_file_name_handler (filename, Qmake_symbolic_link);
2158 if (!NILP (handler))
2159 RETURN_UNGCPRO (call4 (handler, Qmake_symbolic_link, filename, linkname,
2160 ok_if_already_exists));
2162 /* If the new link name has special constructs in it,
2163 call the corresponding file handler. */
2164 handler = Ffind_file_name_handler (linkname, Qmake_symbolic_link);
2165 if (!NILP (handler))
2166 RETURN_UNGCPRO (call4 (handler, Qmake_symbolic_link, filename,
2167 linkname, ok_if_already_exists));
2170 if (NILP (ok_if_already_exists)
2171 || INTP (ok_if_already_exists))
2172 barf_or_query_if_file_exists (linkname, "make it a link",
2173 INTP (ok_if_already_exists), 0);
2175 unlink ((char *) XSTRING_DATA (linkname));
2176 if (0 > symlink ((char *) XSTRING_DATA (filename),
2177 (char *) XSTRING_DATA (linkname)))
2179 report_file_error ("Making symbolic link",
2180 list2 (filename, linkname));
2182 #endif /* S_IFLNK */
2190 DEFUN ("sysnetunam", Fsysnetunam, 2, 2, 0, /*
2191 Open a network connection to PATH using LOGIN as the login string.
2196 const char *path_ext;
2197 const char *login_ext;
2199 CHECK_STRING (path);
2200 CHECK_STRING (login);
2202 /* netunam, being a strange-o system call only used once, is not
2205 LISP_STRING_TO_EXTERNAL (path, path_ext, Qfile_name);
2206 LISP_STRING_TO_EXTERNAL (login, login_ext, Qnative);
2208 netresult = netunam (path_ext, login_ext);
2210 return netresult == -1 ? Qnil : Qt;
2212 #endif /* HPUX_NET */
2214 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p, 1, 1, 0, /*
2215 Return t if file FILENAME specifies an absolute path name.
2216 On Unix, this is a name starting with a `/' or a `~'.
2220 /* This function does not GC */
2223 CHECK_STRING (filename);
2224 ptr = XSTRING_DATA (filename);
2225 return (IS_DIRECTORY_SEP (*ptr) || *ptr == '~'
2226 #ifdef WIN32_FILENAMES
2227 || (IS_DRIVE (*ptr) && ptr[1] == ':' && IS_DIRECTORY_SEP (ptr[2]))
2232 /* Return nonzero if file FILENAME exists and can be executed. */
2235 check_executable (char *filename)
2239 if (xemacs_stat (filename, &st) < 0)
2241 return ((st.st_mode & S_IEXEC) != 0);
2242 #else /* not WIN32_NATIVE */
2244 return eaccess (filename, X_OK) >= 0;
2246 /* Access isn't quite right because it uses the real uid
2247 and we really want to test with the effective uid.
2248 But Unix doesn't give us a right way to do it. */
2249 return access (filename, X_OK) >= 0;
2250 #endif /* HAVE_EACCESS */
2251 #endif /* not WIN32_NATIVE */
2254 /* Return nonzero if file FILENAME exists and can be written. */
2257 check_writable (const char *filename)
2260 return (eaccess (filename, W_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 Opening with O_WRONLY could work for an ordinary file,
2266 but would lose for directories. */
2267 return (access (filename, W_OK) >= 0);
2271 DEFUN ("file-exists-p", Ffile_exists_p, 1, 1, 0, /*
2272 Return t if file FILENAME exists. (This does not mean you can read it.)
2273 See also `file-readable-p' and `file-attributes'.
2277 /* This function can call lisp; GC checked 2000-07-11 ben */
2278 Lisp_Object abspath;
2279 Lisp_Object handler;
2280 struct stat statbuf;
2281 struct gcpro gcpro1;
2283 CHECK_STRING (filename);
2284 abspath = Fexpand_file_name (filename, Qnil);
2286 /* If the file name has special constructs in it,
2287 call the corresponding file handler. */
2289 handler = Ffind_file_name_handler (abspath, Qfile_exists_p);
2291 if (!NILP (handler))
2292 return call2 (handler, Qfile_exists_p, abspath);
2294 return xemacs_stat ((char *) XSTRING_DATA (abspath), &statbuf) >= 0 ? Qt : Qnil;
2297 DEFUN ("file-executable-p", Ffile_executable_p, 1, 1, 0, /*
2298 Return t if FILENAME can be executed by you.
2299 For a directory, this means you can access files in that directory.
2304 /* This function can GC. GC checked 07-11-2000 ben. */
2305 Lisp_Object abspath;
2306 Lisp_Object handler;
2307 struct gcpro gcpro1;
2309 CHECK_STRING (filename);
2310 abspath = Fexpand_file_name (filename, Qnil);
2312 /* If the file name has special constructs in it,
2313 call the corresponding file handler. */
2315 handler = Ffind_file_name_handler (abspath, Qfile_executable_p);
2317 if (!NILP (handler))
2318 return call2 (handler, Qfile_executable_p, abspath);
2320 return check_executable ((char *) XSTRING_DATA (abspath)) ? Qt : Qnil;
2323 DEFUN ("file-readable-p", Ffile_readable_p, 1, 1, 0, /*
2324 Return t if file FILENAME exists and you can read it.
2325 See also `file-exists-p' and `file-attributes'.
2329 /* This function can GC */
2330 Lisp_Object abspath = Qnil;
2331 Lisp_Object handler;
2332 struct gcpro gcpro1;
2335 CHECK_STRING (filename);
2336 abspath = Fexpand_file_name (filename, Qnil);
2338 /* If the file name has special constructs in it,
2339 call the corresponding file handler. */
2340 handler = Ffind_file_name_handler (abspath, Qfile_readable_p);
2341 if (!NILP (handler))
2342 RETURN_UNGCPRO (call2 (handler, Qfile_readable_p, abspath));
2344 #if defined(WIN32_FILENAMES)
2345 /* Under MS-DOS and Windows, open does not work for directories. */
2347 if (access (XSTRING_DATA (abspath), 0) == 0)
2351 #else /* not WIN32_FILENAMES */
2353 int desc = interruptible_open ((char *) XSTRING_DATA (abspath), O_RDONLY | OPEN_BINARY, 0);
2360 #endif /* not WIN32_FILENAMES */
2363 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2365 DEFUN ("file-writable-p", Ffile_writable_p, 1, 1, 0, /*
2366 Return t if file FILENAME can be written or created by you.
2370 /* This function can GC. GC checked 1997.04.10. */
2371 Lisp_Object abspath, dir;
2372 Lisp_Object handler;
2373 struct stat statbuf;
2374 struct gcpro gcpro1;
2376 CHECK_STRING (filename);
2377 abspath = Fexpand_file_name (filename, Qnil);
2379 /* If the file name has special constructs in it,
2380 call the corresponding file handler. */
2382 handler = Ffind_file_name_handler (abspath, Qfile_writable_p);
2384 if (!NILP (handler))
2385 return call2 (handler, Qfile_writable_p, abspath);
2387 if (xemacs_stat ((char *) XSTRING_DATA (abspath), &statbuf) >= 0)
2388 return (check_writable ((char *) XSTRING_DATA (abspath))
2393 dir = Ffile_name_directory (abspath);
2395 return (check_writable (!NILP (dir) ? (char *) XSTRING_DATA (dir)
2400 DEFUN ("file-symlink-p", Ffile_symlink_p, 1, 1, 0, /*
2401 Return non-nil if file FILENAME is the name of a symbolic link.
2402 The value is the name of the file to which it is linked.
2403 Otherwise returns nil.
2407 /* This function can GC. GC checked 1997.04.10. */
2408 /* XEmacs change: run handlers even if local machine doesn't have symlinks */
2415 Lisp_Object handler;
2416 struct gcpro gcpro1;
2418 CHECK_STRING (filename);
2419 filename = Fexpand_file_name (filename, Qnil);
2421 /* If the file name has special constructs in it,
2422 call the corresponding file handler. */
2424 handler = Ffind_file_name_handler (filename, Qfile_symlink_p);
2426 if (!NILP (handler))
2427 return call2 (handler, Qfile_symlink_p, filename);
2433 buf = xnew_array_and_zero (char, bufsize);
2434 valsize = readlink ((char *) XSTRING_DATA (filename),
2436 if (valsize < bufsize) break;
2437 /* Buffer was not long enough */
2446 val = make_string ((Bufbyte *) buf, valsize);
2449 #else /* not S_IFLNK */
2451 #endif /* not S_IFLNK */
2454 DEFUN ("file-directory-p", Ffile_directory_p, 1, 1, 0, /*
2455 Return t if file FILENAME is the name of a directory as a file.
2456 A directory name spec may be given instead; then the value is t
2457 if the directory so specified exists and really is a directory.
2461 /* This function can GC. GC checked 1997.04.10. */
2462 Lisp_Object abspath;
2464 Lisp_Object handler;
2465 struct gcpro gcpro1;
2467 GCPRO1 (current_buffer->directory);
2468 abspath = expand_and_dir_to_file (filename,
2469 current_buffer->directory);
2472 /* If the file name has special constructs in it,
2473 call the corresponding file handler. */
2475 handler = Ffind_file_name_handler (abspath, Qfile_directory_p);
2477 if (!NILP (handler))
2478 return call2 (handler, Qfile_directory_p, abspath);
2480 if (xemacs_stat ((char *) XSTRING_DATA (abspath), &st) < 0)
2482 return (st.st_mode & S_IFMT) == S_IFDIR ? Qt : Qnil;
2485 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p, 1, 1, 0, /*
2486 Return t if file FILENAME is the name of a directory as a file,
2487 and files in that directory can be opened by you. In order to use a
2488 directory as a buffer's current directory, this predicate must return true.
2489 A directory name spec may be given instead; then the value is t
2490 if the directory so specified exists and really is a readable and
2491 searchable directory.
2495 /* This function can GC. GC checked 1997.04.10. */
2496 Lisp_Object handler;
2498 /* If the file name has special constructs in it,
2499 call the corresponding file handler. */
2500 handler = Ffind_file_name_handler (filename, Qfile_accessible_directory_p);
2501 if (!NILP (handler))
2502 return call2 (handler, Qfile_accessible_directory_p,
2505 #if !defined(WIN32_NATIVE)
2506 if (NILP (Ffile_directory_p (filename)))
2509 return Ffile_executable_p (filename);
2513 struct gcpro gcpro1;
2514 /* It's an unlikely combination, but yes we really do need to gcpro:
2515 Suppose that file-accessible-directory-p has no handler, but
2516 file-directory-p does have a handler; this handler causes a GC which
2517 relocates the string in `filename'; and finally file-directory-p
2518 returns non-nil. Then we would end up passing a garbaged string
2519 to file-executable-p. */
2521 tem = (NILP (Ffile_directory_p (filename))
2522 || NILP (Ffile_executable_p (filename)));
2524 return tem ? Qnil : Qt;
2526 #endif /* !defined(WIN32_NATIVE) */
2529 DEFUN ("file-regular-p", Ffile_regular_p, 1, 1, 0, /*
2530 Return t if file FILENAME is the name of a regular file.
2531 This is the sort of file that holds an ordinary stream of data bytes.
2535 /* This function can GC. GC checked 1997.04.10. */
2536 Lisp_Object abspath;
2538 Lisp_Object handler;
2539 struct gcpro gcpro1;
2541 GCPRO1 (current_buffer->directory);
2542 abspath = expand_and_dir_to_file (filename, current_buffer->directory);
2545 /* If the file name has special constructs in it,
2546 call the corresponding file handler. */
2548 handler = Ffind_file_name_handler (abspath, Qfile_regular_p);
2550 if (!NILP (handler))
2551 return call2 (handler, Qfile_regular_p, abspath);
2553 if (xemacs_stat ((char *) XSTRING_DATA (abspath), &st) < 0)
2555 return (st.st_mode & S_IFMT) == S_IFREG ? Qt : Qnil;
2558 DEFUN ("file-modes", Ffile_modes, 1, 1, 0, /*
2559 Return mode bits of file named FILENAME, as an integer.
2563 /* This function can GC. GC checked 1997.04.10. */
2564 Lisp_Object abspath;
2566 Lisp_Object handler;
2567 struct gcpro gcpro1;
2569 GCPRO1 (current_buffer->directory);
2570 abspath = expand_and_dir_to_file (filename,
2571 current_buffer->directory);
2574 /* If the file name has special constructs in it,
2575 call the corresponding file handler. */
2577 handler = Ffind_file_name_handler (abspath, Qfile_modes);
2579 if (!NILP (handler))
2580 return call2 (handler, Qfile_modes, abspath);
2582 if (xemacs_stat ((char *) XSTRING_DATA (abspath), &st) < 0)
2584 /* Syncing with FSF 19.34.6 note: not in FSF, #if 0'ed out here. */
2587 if (check_executable (XSTRING_DATA (abspath)))
2588 st.st_mode |= S_IEXEC;
2589 #endif /* WIN32_NATIVE */
2592 return make_int (st.st_mode & 07777);
2595 DEFUN ("set-file-modes", Fset_file_modes, 2, 2, 0, /*
2596 Set mode bits of file named FILENAME to MODE (an integer).
2597 Only the 12 low bits of MODE are used.
2601 /* This function can GC. GC checked 1997.04.10. */
2602 Lisp_Object abspath;
2603 Lisp_Object handler;
2604 struct gcpro gcpro1;
2606 GCPRO1 (current_buffer->directory);
2607 abspath = Fexpand_file_name (filename, current_buffer->directory);
2612 /* If the file name has special constructs in it,
2613 call the corresponding file handler. */
2615 handler = Ffind_file_name_handler (abspath, Qset_file_modes);
2617 if (!NILP (handler))
2618 return call3 (handler, Qset_file_modes, abspath, mode);
2620 if (chmod ((char *) XSTRING_DATA (abspath), XINT (mode)) < 0)
2621 report_file_error ("Doing chmod", list1 (abspath));
2626 DEFUN ("set-default-file-modes", Fset_default_file_modes, 1, 1, 0, /*
2627 Set the file permission bits for newly created files.
2628 The argument MODE should be an integer; if a bit in MODE is 1,
2629 subsequently created files will not have the permission corresponding
2630 to that bit enabled. Only the low 9 bits are used.
2631 This setting is inherited by subprocesses.
2637 umask ((~ XINT (mode)) & 0777);
2642 DEFUN ("default-file-modes", Fdefault_file_modes, 0, 0, 0, /*
2643 Return the default file protection for created files.
2644 The umask value determines which permissions are enabled in newly
2645 created files. If a permission's bit in the umask is 1, subsequently
2646 created files will not have that permission enabled.
2655 return make_int ((~ mode) & 0777);
2658 DEFUN ("unix-sync", Funix_sync, 0, 0, "", /*
2659 Tell Unix to finish all pending disk updates.
2663 #ifndef WIN32_NATIVE
2670 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p, 2, 2, 0, /*
2671 Return t if file FILE1 is newer than file FILE2.
2672 If FILE1 does not exist, the answer is nil;
2673 otherwise, if FILE2 does not exist, the answer is t.
2677 /* This function can GC. GC checked 1997.04.10. */
2678 Lisp_Object abspath1, abspath2;
2681 Lisp_Object handler;
2682 struct gcpro gcpro1, gcpro2, gcpro3;
2684 CHECK_STRING (file1);
2685 CHECK_STRING (file2);
2690 GCPRO3 (abspath1, abspath2, current_buffer->directory);
2691 abspath1 = expand_and_dir_to_file (file1, current_buffer->directory);
2692 abspath2 = expand_and_dir_to_file (file2, current_buffer->directory);
2694 /* If the file name has special constructs in it,
2695 call the corresponding file handler. */
2696 handler = Ffind_file_name_handler (abspath1, Qfile_newer_than_file_p);
2698 handler = Ffind_file_name_handler (abspath2, Qfile_newer_than_file_p);
2700 if (!NILP (handler))
2701 return call3 (handler, Qfile_newer_than_file_p, abspath1,
2704 if (xemacs_stat ((char *) XSTRING_DATA (abspath1), &st) < 0)
2707 mtime1 = st.st_mtime;
2709 if (xemacs_stat ((char *) XSTRING_DATA (abspath2), &st) < 0)
2712 return (mtime1 > st.st_mtime) ? Qt : Qnil;
2716 /* Stack sizes > 2**16 is a good way to elicit compiler bugs */
2717 /* #define READ_BUF_SIZE (2 << 16) */
2718 #define READ_BUF_SIZE (1 << 15)
2720 DEFUN ("insert-file-contents-internal", Finsert_file_contents_internal,
2722 Insert contents of file FILENAME after point; no coding-system frobbing.
2723 This function is identical to `insert-file-contents' except for the
2724 handling of the CODESYS and USED-CODESYS arguments under
2725 XEmacs/Mule. (When Mule support is not present, both functions are
2726 identical and ignore the CODESYS and USED-CODESYS arguments.)
2728 If support for Mule exists in this Emacs, the file is decoded according
2729 to CODESYS; if omitted, no conversion happens. If USED-CODESYS is non-nil,
2730 it should be a symbol, and the actual coding system that was used for the
2731 decoding is stored into it. It will in general be different from CODESYS
2732 if CODESYS specifies automatic encoding detection or end-of-line detection.
2734 Currently START and END refer to byte positions (as opposed to character
2735 positions), even in Mule. (Fixing this is very difficult.)
2737 (filename, visit, start, end, replace, codesys, used_codesys))
2739 /* This function can call lisp */
2743 Charcount inserted = 0;
2745 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
2746 Lisp_Object handler = Qnil, val;
2748 Bufbyte read_buf[READ_BUF_SIZE];
2750 struct buffer *buf = current_buffer;
2752 int not_regular = 0;
2754 if (buf->base_buffer && ! NILP (visit))
2755 error ("Cannot do file visiting in an indirect buffer");
2757 /* No need to call Fbarf_if_buffer_read_only() here.
2758 That's called in begin_multiple_change() or wherever. */
2762 /* #### dmoore - should probably check in various places to see if
2763 curbuf was killed and if so signal an error? */
2765 XSETBUFFER (curbuf, buf);
2767 GCPRO5 (filename, val, visit, handler, curbuf);
2769 mc_count = (NILP (replace)) ?
2770 begin_multiple_change (buf, BUF_PT (buf), BUF_PT (buf)) :
2771 begin_multiple_change (buf, BUF_BEG (buf), BUF_Z (buf));
2773 speccount = specpdl_depth (); /* begin_multiple_change also adds
2774 an unwind_protect */
2776 filename = Fexpand_file_name (filename, Qnil);
2778 /* If the file name has special constructs in it,
2779 call the corresponding file handler. */
2780 handler = Ffind_file_name_handler (filename, Qinsert_file_contents);
2781 if (!NILP (handler))
2783 val = call6 (handler, Qinsert_file_contents, filename,
2784 visit, start, end, replace);
2789 if (!NILP (used_codesys))
2790 CHECK_SYMBOL (used_codesys);
2793 if ( (!NILP (start) || !NILP (end)) && !NILP (visit) )
2794 error ("Attempt to visit less than an entire file");
2798 if (xemacs_stat ((char *) XSTRING_DATA (filename), &st) < 0)
2800 if (fd >= 0) close (fd);
2803 report_file_error ("Opening input file", list1 (filename));
2809 /* Signal an error if we are accessing a non-regular file, with
2810 REPLACE, START or END being non-nil. */
2811 if (!S_ISREG (st.st_mode))
2818 if (!NILP (replace) || !NILP (start) || !NILP (end))
2820 end_multiple_change (buf, mc_count);
2823 (Fsignal (Qfile_error,
2824 list2 (build_translated_string("not a regular file"),
2828 #endif /* S_IFREG */
2840 if ((fd = interruptible_open ((char *) XSTRING_DATA (filename),
2841 O_RDONLY | OPEN_BINARY, 0)) < 0)
2845 /* Replacement should preserve point as it preserves markers. */
2846 if (!NILP (replace))
2847 record_unwind_protect (restore_point_unwind, Fpoint_marker (Qnil, Qnil));
2849 record_unwind_protect (close_file_unwind, make_int (fd));
2851 /* Supposedly happens on VMS. */
2853 error ("File size is negative");
2859 end = make_int (st.st_size);
2860 if (XINT (end) != st.st_size)
2861 error ("Maximum buffer size exceeded");
2865 /* If requested, replace the accessible part of the buffer
2866 with the file contents. Avoid replacing text at the
2867 beginning or end of the buffer that matches the file contents;
2868 that preserves markers pointing to the unchanged parts. */
2869 #if !defined (FILE_CODING)
2870 /* The replace-mode code currently only works when the assumption
2871 'one byte == one char' holds true. This fails Mule because
2872 files may contain multibyte characters. It holds under Windows NT
2873 provided we convert CRLF into LF. */
2874 # define FSFMACS_SPEEDY_INSERT
2875 #endif /* !defined (FILE_CODING) */
2877 #ifndef FSFMACS_SPEEDY_INSERT
2878 if (!NILP (replace))
2880 buffer_delete_range (buf, BUF_BEG (buf), BUF_Z (buf),
2881 !NILP (visit) ? INSDEL_NO_LOCKING : 0);
2883 #else /* FSFMACS_SPEEDY_INSERT */
2884 if (!NILP (replace))
2886 char buffer[1 << 14];
2887 Bufpos same_at_start = BUF_BEGV (buf);
2888 Bufpos same_at_end = BUF_ZV (buf);
2891 /* Count how many chars at the start of the file
2892 match the text at the beginning of the buffer. */
2897 nread = read_allowing_quit (fd, buffer, sizeof buffer);
2899 error ("IO error reading %s: %s",
2900 XSTRING_DATA (filename), strerror (errno));
2901 else if (nread == 0)
2904 while (bufpos < nread && same_at_start < BUF_ZV (buf)
2905 && BUF_FETCH_CHAR (buf, same_at_start) == buffer[bufpos])
2906 same_at_start++, bufpos++;
2907 /* If we found a discrepancy, stop the scan.
2908 Otherwise loop around and scan the next bufferful. */
2909 if (bufpos != nread)
2912 /* If the file matches the buffer completely,
2913 there's no need to replace anything. */
2914 if (same_at_start - BUF_BEGV (buf) == st.st_size)
2917 unbind_to (speccount, Qnil);
2918 /* Truncate the buffer to the size of the file. */
2919 buffer_delete_range (buf, same_at_start, same_at_end,
2920 !NILP (visit) ? INSDEL_NO_LOCKING : 0);
2923 /* Count how many chars at the end of the file
2924 match the text at the end of the buffer. */
2927 int total_read, nread;
2928 Bufpos bufpos, curpos, trial;
2930 /* At what file position are we now scanning? */
2931 curpos = st.st_size - (BUF_ZV (buf) - same_at_end);
2932 /* If the entire file matches the buffer tail, stop the scan. */
2935 /* How much can we scan in the next step? */
2936 trial = min (curpos, (Bufpos) sizeof (buffer));
2937 if (lseek (fd, curpos - trial, 0) < 0)
2938 report_file_error ("Setting file position", list1 (filename));
2941 while (total_read < trial)
2943 nread = read_allowing_quit (fd, buffer + total_read,
2944 trial - total_read);
2946 report_file_error ("IO error reading file", list1 (filename));
2947 total_read += nread;
2949 /* Scan this bufferful from the end, comparing with
2950 the Emacs buffer. */
2951 bufpos = total_read;
2952 /* Compare with same_at_start to avoid counting some buffer text
2953 as matching both at the file's beginning and at the end. */
2954 while (bufpos > 0 && same_at_end > same_at_start
2955 && BUF_FETCH_CHAR (buf, same_at_end - 1) ==
2957 same_at_end--, bufpos--;
2958 /* If we found a discrepancy, stop the scan.
2959 Otherwise loop around and scan the preceding bufferful. */
2962 /* If display current starts at beginning of line,
2963 keep it that way. */
2964 if (XBUFFER (XWINDOW (Fselected_window (Qnil))->buffer) == buf)
2965 XWINDOW (Fselected_window (Qnil))->start_at_line_beg =
2966 !NILP (Fbolp (make_buffer (buf)));
2969 /* Don't try to reuse the same piece of text twice. */
2970 overlap = same_at_start - BUF_BEGV (buf) -
2971 (same_at_end + st.st_size - BUF_ZV (buf));
2973 same_at_end += overlap;
2975 /* Arrange to read only the nonmatching middle part of the file. */
2976 start = make_int (same_at_start - BUF_BEGV (buf));
2977 end = make_int (st.st_size - (BUF_ZV (buf) - same_at_end));
2979 buffer_delete_range (buf, same_at_start, same_at_end,
2980 !NILP (visit) ? INSDEL_NO_LOCKING : 0);
2981 /* Insert from the file at the proper position. */
2982 BUF_SET_PT (buf, same_at_start);
2984 #endif /* FSFMACS_SPEEDY_INSERT */
2988 total = XINT (end) - XINT (start);
2990 /* Make sure point-max won't overflow after this insertion. */
2991 if (total != XINT (make_int (total)))
2992 error ("Maximum buffer size exceeded");
2995 /* For a special file, all we can do is guess. The value of -1
2996 will make the stream functions read as much as possible. */
2999 if (XINT (start) != 0
3000 #ifdef FSFMACS_SPEEDY_INSERT
3001 /* why was this here? asked jwz. The reason is that the replace-mode
3002 connivings above will normally put the file pointer other than
3003 where it should be. */
3005 #endif /* !FSFMACS_SPEEDY_INSERT */
3008 if (lseek (fd, XINT (start), 0) < 0)
3009 report_file_error ("Setting file position", list1 (filename));
3013 Bufpos cur_point = BUF_PT (buf);
3014 struct gcpro ngcpro1;
3015 Lisp_Object stream = make_filedesc_input_stream (fd, 0, total,
3019 Lstream_set_buffering (XLSTREAM (stream), LSTREAM_BLOCKN_BUFFERED, 65536);
3021 stream = make_decoding_input_stream
3022 (XLSTREAM (stream), Fget_coding_system (codesys));
3023 Lstream_set_character_mode (XLSTREAM (stream));
3024 Lstream_set_buffering (XLSTREAM (stream), LSTREAM_BLOCKN_BUFFERED, 65536);
3025 #endif /* FILE_CODING */
3027 record_unwind_protect (delete_stream_unwind, stream);
3029 /* No need to limit the amount of stuff we attempt to read. (It would
3030 be incorrect, anyway, when Mule is enabled.) Instead, the limiting
3031 occurs inside of the filedesc stream. */
3034 Lstream_data_count this_len;
3035 Charcount cc_inserted;
3038 this_len = Lstream_read (XLSTREAM (stream), read_buf,
3048 cc_inserted = buffer_insert_raw_string_1 (buf, cur_point, read_buf,
3051 ? INSDEL_NO_LOCKING : 0);
3052 inserted += cc_inserted;
3053 cur_point += cc_inserted;
3056 if (!NILP (used_codesys))
3059 XCODING_SYSTEM_NAME (decoding_stream_coding_system (XLSTREAM (stream))));
3061 #endif /* FILE_CODING */
3065 /* Close the file/stream */
3066 unbind_to (speccount, Qnil);
3070 error ("IO error reading %s: %s",
3071 XSTRING_DATA (filename), strerror (saverrno));
3077 end_multiple_change (buf, mc_count);
3081 if (!EQ (buf->undo_list, Qt))
3082 buf->undo_list = Qnil;
3085 buf->modtime = st.st_mtime;
3086 buf->filename = filename;
3087 /* XEmacs addition: */
3088 /* This function used to be in C, ostensibly so that
3089 it could be called here. But that's just silly.
3090 There's no reason C code can't call out to Lisp
3091 code, and it's a lot cleaner this way. */
3092 /* Note: compute-buffer-file-truename is called for
3093 side-effect! Its return value is intentionally
3095 if (!NILP (Ffboundp (Qcompute_buffer_file_truename)))
3096 call1 (Qcompute_buffer_file_truename, make_buffer (buf));
3098 BUF_SAVE_MODIFF (buf) = BUF_MODIFF (buf);
3099 buf->auto_save_modified = BUF_MODIFF (buf);
3100 buf->saved_size = make_int (BUF_SIZE (buf));
3101 #ifdef CLASH_DETECTION
3104 if (!NILP (buf->file_truename))
3105 unlock_file (buf->file_truename);
3106 unlock_file (filename);
3108 #endif /* CLASH_DETECTION */
3110 RETURN_UNGCPRO (Fsignal (Qfile_error,
3111 list2 (build_string ("not a regular file"),
3114 /* If visiting nonexistent file, return nil. */
3115 if (buf->modtime == -1)
3116 report_file_error ("Opening input file",
3120 /* Decode file format */
3123 Lisp_Object insval = call3 (Qformat_decode,
3124 Qnil, make_int (inserted), visit);
3126 inserted = XINT (insval);
3132 struct gcpro ngcpro1;
3135 EXTERNAL_LIST_LOOP (p, Vafter_insert_file_functions)
3137 Lisp_Object insval =
3138 call1 (XCAR (p), make_int (inserted));
3141 CHECK_NATNUM (insval);
3142 inserted = XINT (insval);
3154 return (list2 (filename, make_int (inserted)));
3158 static int a_write (Lisp_Object outstream, Lisp_Object instream, int pos,
3159 Lisp_Object *annot);
3160 static Lisp_Object build_annotations (Lisp_Object start, Lisp_Object end);
3162 /* If build_annotations switched buffers, switch back to BUF.
3163 Kill the temporary buffer that was selected in the meantime. */
3166 build_annotations_unwind (Lisp_Object buf)
3170 if (XBUFFER (buf) == current_buffer)
3172 tembuf = Fcurrent_buffer ();
3174 Fkill_buffer (tembuf);
3178 DEFUN ("write-region-internal", Fwrite_region_internal, 3, 7,
3179 "r\nFWrite region to file: ", /*
3180 Write current region into specified file; no coding-system frobbing.
3181 This function is identical to `write-region' except for the handling
3182 of the CODESYS argument under XEmacs/Mule. (When Mule support is not
3183 present, both functions are identical and ignore the CODESYS argument.)
3184 If support for Mule exists in this Emacs, the file is encoded according
3185 to the value of CODESYS. If this is nil, no code conversion occurs.
3187 (start, end, filename, append, visit, lockname, codesys))
3189 /* This function can call lisp. GC checked 2000-07-28 ben */
3194 Lisp_Object fn = Qnil;
3195 int speccount = specpdl_depth ();
3196 int visiting_other = STRINGP (visit);
3197 int visiting = (EQ (visit, Qt) || visiting_other);
3198 int quietly = (!visiting && !NILP (visit));
3199 Lisp_Object visit_file = Qnil;
3200 Lisp_Object annotations = Qnil;
3201 struct buffer *given_buffer;
3202 Bufpos start1, end1;
3203 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
3204 struct gcpro ngcpro1, ngcpro2;
3207 XSETBUFFER (curbuf, current_buffer);
3209 /* start, end, visit, and append are never modified in this fun
3210 so we don't protect them. */
3211 GCPRO5 (visit_file, filename, codesys, lockname, annotations);
3212 NGCPRO2 (curbuf, fn);
3214 /* [[ dmoore - if Fexpand_file_name or handlers kill the buffer,
3215 we should signal an error rather than blissfully continuing
3216 along. ARGH, this function is going to lose lose lose. We need
3217 to protect the current_buffer from being destroyed, but the
3218 multiple return points make this a pain in the butt. ]] we do
3219 protect curbuf now. --ben */
3222 codesys = Fget_coding_system (codesys);
3223 #endif /* FILE_CODING */
3225 if (current_buffer->base_buffer && ! NILP (visit))
3226 invalid_operation ("Cannot do file visiting in an indirect buffer",
3229 if (!NILP (start) && !STRINGP (start))
3230 get_buffer_range_char (current_buffer, start, end, &start1, &end1, 0);
3233 Lisp_Object handler;
3236 visit_file = Fexpand_file_name (visit, Qnil);
3238 visit_file = filename;
3239 filename = Fexpand_file_name (filename, Qnil);
3241 if (NILP (lockname))
3242 lockname = visit_file;
3244 /* We used to UNGCPRO here. BAD! visit_file is used below after
3245 more Lisp calling. */
3246 /* If the file name has special constructs in it,
3247 call the corresponding file handler. */
3248 handler = Ffind_file_name_handler (filename, Qwrite_region);
3249 /* If FILENAME has no handler, see if VISIT has one. */
3250 if (NILP (handler) && STRINGP (visit))
3251 handler = Ffind_file_name_handler (visit, Qwrite_region);
3253 if (!NILP (handler))
3255 Lisp_Object val = call8 (handler, Qwrite_region, start, end,
3256 filename, append, visit, lockname, codesys);
3259 BUF_SAVE_MODIFF (current_buffer) = BUF_MODIFF (current_buffer);
3260 current_buffer->saved_size = make_int (BUF_SIZE (current_buffer));
3261 current_buffer->filename = visit_file;
3262 MARK_MODELINE_CHANGED;
3270 #ifdef CLASH_DETECTION
3272 lock_file (lockname);
3273 #endif /* CLASH_DETECTION */
3275 /* Special kludge to simplify auto-saving. */
3278 start1 = BUF_BEG (current_buffer);
3279 end1 = BUF_Z (current_buffer);
3282 record_unwind_protect (build_annotations_unwind, Fcurrent_buffer ());
3284 given_buffer = current_buffer;
3285 annotations = build_annotations (start, end);
3286 if (current_buffer != given_buffer)
3288 start1 = BUF_BEGV (current_buffer);
3289 end1 = BUF_ZV (current_buffer);
3296 desc = open ((char *) XSTRING_DATA (fn), O_WRONLY | OPEN_BINARY, 0);
3300 desc = open ((char *) XSTRING_DATA (fn),
3301 O_WRONLY | O_TRUNC | O_CREAT | OPEN_BINARY,
3302 auto_saving ? auto_save_mode_bits : CREAT_MODE);
3307 #ifdef CLASH_DETECTION
3309 if (!auto_saving) unlock_file (lockname);
3311 #endif /* CLASH_DETECTION */
3312 report_file_error ("Opening output file", list1 (filename));
3316 Lisp_Object desc_locative = Fcons (make_int (desc), Qnil);
3317 Lisp_Object instream = Qnil, outstream = Qnil;
3318 struct gcpro nngcpro1, nngcpro2;
3319 /* need to gcpro; QUIT could happen out of call to write() */
3320 NNGCPRO2 (instream, outstream);
3322 record_unwind_protect (close_file_unwind, desc_locative);
3326 if (lseek (desc, 0, 2) < 0)
3328 #ifdef CLASH_DETECTION
3329 if (!auto_saving) unlock_file (lockname);
3330 #endif /* CLASH_DETECTION */
3331 report_file_error ("Lseek error",
3338 /* Note: I tried increasing the buffering size, along with
3339 various other tricks, but nothing seemed to make much of
3340 a difference in the time it took to save a large file.
3341 (Actually that's not true. With a local disk, changing
3342 the buffer size doesn't seem to make much difference.
3343 With an NFS-mounted disk, it could make a lot of difference
3344 because you're affecting the number of network requests
3345 that need to be made, and there could be a large latency
3346 for each request. So I've increased the buffer size
3348 outstream = make_filedesc_output_stream (desc, 0, -1, 0);
3349 Lstream_set_buffering (XLSTREAM (outstream),
3350 LSTREAM_BLOCKN_BUFFERED, 65536);
3353 make_encoding_output_stream (XLSTREAM (outstream), codesys);
3354 Lstream_set_buffering (XLSTREAM (outstream),
3355 LSTREAM_BLOCKN_BUFFERED, 65536);
3356 #endif /* FILE_CODING */
3357 if (STRINGP (start))
3359 instream = make_lisp_string_input_stream (start, 0, -1);
3363 instream = make_lisp_buffer_input_stream (current_buffer, start1, end1,
3365 LSTR_IGNORE_ACCESSIBLE);
3366 failure = (0 > (a_write (outstream, instream, start1,
3369 /* Note that this doesn't close the desc since we created the
3370 stream without the LSTR_CLOSING flag, but it does
3371 flush out any buffered data. */
3372 if (Lstream_close (XLSTREAM (outstream)) < 0)
3377 Lstream_close (XLSTREAM (instream));
3380 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
3381 Disk full in NFS may be reported here. */
3382 /* mib says that closing the file will try to write as fast as NFS can do
3383 it, and that means the fsync here is not crucial for autosave files. */
3384 if (!auto_saving && fsync (desc) < 0
3385 /* If fsync fails with EINTR, don't treat that as serious. */
3391 #endif /* HAVE_FSYNC */
3393 /* Spurious "file has changed on disk" warnings used to be seen on
3394 systems where close() can change the modtime. This is known to
3395 happen on various NFS file systems, on Windows, and on Linux.
3396 Rather than handling this on a per-system basis, we
3397 unconditionally do the xemacs_stat() after the close(). */
3399 /* NFS can report a write failure now. */
3400 if (close (desc) < 0)
3406 /* Discard the close unwind-protect. Execute the one for
3407 build_annotations (switches back to the original current buffer
3409 XCAR (desc_locative) = Qnil;
3410 unbind_to (speccount, Qnil);
3415 xemacs_stat ((char *) XSTRING_DATA (fn), &st);
3417 #ifdef CLASH_DETECTION
3419 unlock_file (lockname);
3420 #endif /* CLASH_DETECTION */
3422 /* Do this before reporting IO error
3423 to avoid a "file has changed on disk" warning on
3424 next attempt to save. */
3426 current_buffer->modtime = st.st_mtime;
3431 report_file_error ("Writing file", list1 (fn));
3436 BUF_SAVE_MODIFF (current_buffer) = BUF_MODIFF (current_buffer);
3437 current_buffer->saved_size = make_int (BUF_SIZE (current_buffer));
3438 current_buffer->filename = visit_file;
3439 MARK_MODELINE_CHANGED;
3451 message ("Wrote %s", XSTRING_DATA (visit_file));
3454 Lisp_Object fsp = Qnil;
3455 struct gcpro nngcpro1;
3458 fsp = Ffile_symlink_p (fn);
3460 message ("Wrote %s", XSTRING_DATA (fn));
3462 message ("Wrote %s (symlink to %s)",
3463 XSTRING_DATA (fn), XSTRING_DATA (fsp));
3472 /* #### This is such a load of shit!!!! There is no way we should define
3473 something so stupid as a subr, just sort the fucking list more
3475 DEFUN ("car-less-than-car", Fcar_less_than_car, 2, 2, 0, /*
3476 Return t if (car A) is numerically less than (car B).
3480 Lisp_Object objs[2];
3483 return Flss (2, objs);
3486 /* Heh heh heh, let's define this too, just to aggravate the person who
3487 wrote the above comment. */
3488 DEFUN ("cdr-less-than-cdr", Fcdr_less_than_cdr, 2, 2, 0, /*
3489 Return t if (cdr A) is numerically less than (cdr B).
3493 Lisp_Object objs[2];
3496 return Flss (2, objs);
3499 /* Build the complete list of annotations appropriate for writing out
3500 the text between START and END, by calling all the functions in
3501 write-region-annotate-functions and merging the lists they return.
3502 If one of these functions switches to a different buffer, we assume
3503 that buffer contains altered text. Therefore, the caller must
3504 make sure to restore the current buffer in all cases,
3505 as save-excursion would do. */
3508 build_annotations (Lisp_Object start, Lisp_Object end)
3510 /* This function can GC */
3511 Lisp_Object annotations;
3513 struct gcpro gcpro1, gcpro2;
3514 Lisp_Object original_buffer;
3516 XSETBUFFER (original_buffer, current_buffer);
3519 p = Vwrite_region_annotate_functions;
3520 GCPRO2 (annotations, p);
3523 struct buffer *given_buffer = current_buffer;
3524 Vwrite_region_annotations_so_far = annotations;
3525 res = call2 (Fcar (p), start, end);
3526 /* If the function makes a different buffer current,
3527 assume that means this buffer contains altered text to be output.
3528 Reset START and END from the buffer bounds
3529 and discard all previous annotations because they should have
3530 been dealt with by this function. */
3531 if (current_buffer != given_buffer)
3533 start = make_int (BUF_BEGV (current_buffer));
3534 end = make_int (BUF_ZV (current_buffer));
3537 Flength (res); /* Check basic validity of return value */
3538 annotations = merge (annotations, res, Qcar_less_than_car);
3542 /* Now do the same for annotation functions implied by the file-format */
3543 if (auto_saving && (!EQ (Vauto_save_file_format, Qt)))
3544 p = Vauto_save_file_format;
3546 p = current_buffer->file_format;
3549 struct buffer *given_buffer = current_buffer;
3550 Vwrite_region_annotations_so_far = annotations;
3551 res = call4 (Qformat_annotate_function, Fcar (p), start, end,
3553 if (current_buffer != given_buffer)
3555 start = make_int (BUF_BEGV (current_buffer));
3556 end = make_int (BUF_ZV (current_buffer));
3560 annotations = merge (annotations, res, Qcar_less_than_car);
3567 /* Write to stream OUTSTREAM the characters from INSTREAM (it is read until
3568 EOF is encountered), assuming they start at position POS in the buffer
3569 of string that STREAM refers to. Intersperse with them the annotations
3570 from *ANNOT that fall into the range of positions we are reading from,
3571 each at its appropriate position.
3573 Modify *ANNOT by discarding elements as we output them.
3574 The return value is negative in case of system call failure. */
3576 /* 4K should probably be fine. We just need to reduce the number of
3577 function calls to reasonable level. The Lstream stuff itself will
3578 batch to 64K to reduce the number of system calls. */
3580 #define A_WRITE_BATCH_SIZE 4096
3583 a_write (Lisp_Object outstream, Lisp_Object instream, int pos,
3588 unsigned char largebuf[A_WRITE_BATCH_SIZE];
3589 Lstream *instr = XLSTREAM (instream);
3590 Lstream *outstr = XLSTREAM (outstream);
3592 while (LISTP (*annot))
3594 tem = Fcar_safe (Fcar (*annot));
3596 nextpos = XINT (tem);
3600 /* If there are annotations left and we have Mule, then we
3601 have to do the I/O one emchar at a time so we can
3602 determine when to insert the annotation. */
3606 while (pos != nextpos && (ch = Lstream_get_emchar (instr)) != EOF)
3608 if (Lstream_put_emchar (outstr, ch) < 0)
3616 while (pos != nextpos)
3618 /* Otherwise there is no point to that. Just go in batches. */
3619 int chunk = min (nextpos - pos, A_WRITE_BATCH_SIZE);
3621 chunk = Lstream_read (instr, largebuf, chunk);
3624 if (chunk == 0) /* EOF */
3626 if (Lstream_write (outstr, largebuf, chunk) < chunk)
3633 tem = Fcdr (Fcar (*annot));
3636 if (Lstream_write (outstr, XSTRING_DATA (tem),
3637 XSTRING_LENGTH (tem)) < 0)
3640 *annot = Fcdr (*annot);
3651 #include <des_crypt.h>
3653 #define CRYPT_BLOCK_SIZE 8 /* bytes */
3654 #define CRYPT_KEY_SIZE 8 /* bytes */
3656 DEFUN ("encrypt-string", Fencrypt_string, 2, 2, 0, /*
3657 Encrypt STRING using KEY.
3661 char *encrypted_string, *raw_key;
3662 int rounded_size, extra, key_size;
3664 /* !!#### May produce bogus data under Mule. */
3665 CHECK_STRING (string);
3668 extra = XSTRING_LENGTH (string) % CRYPT_BLOCK_SIZE;
3669 rounded_size = XSTRING_LENGTH (string) + extra;
3670 encrypted_string = alloca (rounded_size + 1);
3671 memcpy (encrypted_string, XSTRING_DATA (string), XSTRING_LENGTH (string));
3672 memset (encrypted_string + rounded_size - extra, 0, extra + 1);
3674 key_size = min (CRYPT_KEY_SIZE, XSTRING_LENGTH (key))
3676 raw_key = alloca (CRYPT_KEY_SIZE + 1);
3677 memcpy (raw_key, XSTRING_DATA (key), key_size);
3678 memset (raw_key + key_size, 0, (CRYPT_KEY_SIZE + 1) - key_size);
3680 ecb_crypt (raw_key, encrypted_string, rounded_size,
3681 DES_ENCRYPT | DES_SW);
3682 return make_string (encrypted_string, rounded_size);
3685 DEFUN ("decrypt-string", Fdecrypt_string, 2, 2, 0, /*
3686 Decrypt STRING using KEY.
3690 char *decrypted_string, *raw_key;
3691 int string_size, key_size;
3693 CHECK_STRING (string);
3696 string_size = XSTRING_LENGTH (string) + 1;
3697 decrypted_string = alloca (string_size);
3698 memcpy (decrypted_string, XSTRING_DATA (string), string_size);
3699 decrypted_string[string_size - 1] = '\0';
3701 key_size = min (CRYPT_KEY_SIZE, XSTRING_LENGTH (key))
3703 raw_key = alloca (CRYPT_KEY_SIZE + 1);
3704 memcpy (raw_key, XSTRING_DATA (key), key_size);
3705 memset (raw_key + key_size, 0, (CRYPT_KEY_SIZE + 1) - key_size);
3708 ecb_crypt (raw_key, decrypted_string, string_size, D | DES_SW);
3709 return make_string (decrypted_string, string_size - 1);
3714 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime, 1, 1, 0, /*
3715 Return t if last mod time of BUFFER's visited file matches what BUFFER records.
3716 This means that the file has not been changed since it was visited or saved.
3720 /* This function can call lisp; GC checked 2000-07-11 ben */
3723 Lisp_Object handler;
3725 CHECK_BUFFER (buffer);
3726 b = XBUFFER (buffer);
3728 if (!STRINGP (b->filename)) return Qt;
3729 if (b->modtime == 0) return Qt;
3731 /* If the file name has special constructs in it,
3732 call the corresponding file handler. */
3733 handler = Ffind_file_name_handler (b->filename,
3734 Qverify_visited_file_modtime);
3735 if (!NILP (handler))
3736 return call2 (handler, Qverify_visited_file_modtime, buffer);
3738 if (xemacs_stat ((char *) XSTRING_DATA (b->filename), &st) < 0)
3740 /* If the file doesn't exist now and didn't exist before,
3741 we say that it isn't modified, provided the error is a tame one. */
3742 if (errno == ENOENT || errno == EACCES || errno == ENOTDIR)
3747 if (st.st_mtime == b->modtime
3748 /* If both are positive, accept them if they are off by one second. */
3749 || (st.st_mtime > 0 && b->modtime > 0
3750 && (st.st_mtime == b->modtime + 1
3751 || st.st_mtime == b->modtime - 1)))
3756 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime, 0, 0, 0, /*
3757 Clear out records of last mod time of visited file.
3758 Next attempt to save will certainly not complain of a discrepancy.
3762 current_buffer->modtime = 0;
3766 DEFUN ("visited-file-modtime", Fvisited_file_modtime, 0, 0, 0, /*
3767 Return the current buffer's recorded visited file modification time.
3768 The value is a list of the form (HIGH . LOW), like the time values
3769 that `file-attributes' returns.
3773 return time_to_lisp ((time_t) current_buffer->modtime);
3776 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime, 0, 1, 0, /*
3777 Update buffer's recorded modification time from the visited file's time.
3778 Useful if the buffer was not read from the file normally
3779 or if the file itself has been changed for some known benign reason.
3780 An argument specifies the modification time value to use
3781 \(instead of that of the visited file), in the form of a list
3782 \(HIGH . LOW) or (HIGH LOW).
3786 /* This function can call lisp */
3787 if (!NILP (time_list))
3790 lisp_to_time (time_list, &the_time);
3791 current_buffer->modtime = (int) the_time;
3795 Lisp_Object filename = Qnil;
3797 Lisp_Object handler;
3798 struct gcpro gcpro1, gcpro2, gcpro3;
3800 GCPRO3 (filename, time_list, current_buffer->filename);
3801 filename = Fexpand_file_name (current_buffer->filename, Qnil);
3803 /* If the file name has special constructs in it,
3804 call the corresponding file handler. */
3805 handler = Ffind_file_name_handler (filename, Qset_visited_file_modtime);
3807 if (!NILP (handler))
3808 /* The handler can find the file name the same way we did. */
3809 return call2 (handler, Qset_visited_file_modtime, Qnil);
3810 else if (xemacs_stat ((char *) XSTRING_DATA (filename), &st) >= 0)
3811 current_buffer->modtime = st.st_mtime;
3818 auto_save_error (Lisp_Object condition_object, Lisp_Object ignored)
3820 /* This function can call lisp */
3823 /* Don't try printing an error message after everything is gone! */
3824 if (preparing_for_armageddon)
3826 clear_echo_area (selected_frame (), Qauto_saving, 1);
3827 Fding (Qt, Qauto_save_error, Qnil);
3828 message ("Auto-saving...error for %s", XSTRING_DATA (current_buffer->name));
3829 Fsleep_for (make_int (1));
3830 message ("Auto-saving...error!for %s", XSTRING_DATA (current_buffer->name));
3831 Fsleep_for (make_int (1));
3832 message ("Auto-saving...error for %s", XSTRING_DATA (current_buffer->name));
3833 Fsleep_for (make_int (1));
3838 auto_save_1 (Lisp_Object ignored)
3840 /* This function can call lisp */
3841 /* #### I think caller is protecting current_buffer? */
3843 Lisp_Object fn = current_buffer->filename;
3844 Lisp_Object a = current_buffer->auto_save_file_name;
3849 /* Get visited file's mode to become the auto save file's mode. */
3851 xemacs_stat ((char *) XSTRING_DATA (fn), &st) >= 0)
3852 /* But make sure we can overwrite it later! */
3853 auto_save_mode_bits = st.st_mode | 0600;
3855 /* default mode for auto-save files of buffers with no file is
3856 readable by owner only. This may annoy some small number of
3857 people, but the alternative removes all privacy from email. */
3858 auto_save_mode_bits = 0600;
3861 /* !!#### need to deal with this 'escape-quoted everywhere */
3862 Fwrite_region_internal (Qnil, Qnil, a, Qnil, Qlambda, Qnil,
3864 current_buffer->buffer_file_coding_system
3872 auto_save_expand_name_error (Lisp_Object condition_object, Lisp_Object ignored)
3874 /* #### this function should spew an error message about not being
3875 able to open the .saves file. */
3880 auto_save_expand_name (Lisp_Object name)
3882 struct gcpro gcpro1;
3884 /* note that caller did NOT gc protect name, so we do it. */
3885 /* #### dmoore - this might not be necessary, if condition_case_1
3886 protects it. but I don't think it does. */
3888 RETURN_UNGCPRO (Fexpand_file_name (name, Qnil));
3893 do_auto_save_unwind (Lisp_Object fd)
3900 do_auto_save_unwind_2 (Lisp_Object old_auto_saving)
3902 auto_saving = XINT (old_auto_saving);
3906 /* Fdo_auto_save() checks whether a GC is in progress when it is called,
3907 and if so, tries to avoid touching lisp objects.
3909 The only time that Fdo_auto_save() is called while GC is in progress
3910 is if we're going down, as a result of an abort() or a kill signal.
3911 It's fairly important that we generate autosave files in that case!
3914 DEFUN ("do-auto-save", Fdo_auto_save, 0, 2, "", /*
3915 Auto-save all buffers that need it.
3916 This is all buffers that have auto-saving enabled
3917 and are changed since last auto-saved.
3918 Auto-saving writes the buffer into a file
3919 so that your editing is not lost if the system crashes.
3920 This file is not the file you visited; that changes only when you save.
3921 Normally we run the normal hook `auto-save-hook' before saving.
3923 Non-nil first argument means do not print any message if successful.
3924 Non-nil second argument means save only current buffer.
3926 (no_message, current_only))
3928 /* This function can call lisp */
3930 Lisp_Object tail, buf;
3932 int do_handled_files;
3933 Lisp_Object oquit = Qnil;
3934 Lisp_Object listfile = Qnil;
3937 int speccount = specpdl_depth ();
3938 struct gcpro gcpro1, gcpro2, gcpro3;
3940 XSETBUFFER (old, current_buffer);
3941 GCPRO3 (oquit, listfile, old);
3942 check_quit (); /* make Vquit_flag accurate */
3943 /* Ordinarily don't quit within this function,
3944 but don't make it impossible to quit (in case we get hung in I/O). */
3948 /* No further GCPRO needed, because (when it matters) all Lisp_Object
3949 variables point to non-strings reached from Vbuffer_alist. */
3951 if (minibuf_level != 0 || preparing_for_armageddon)
3954 run_hook (Qauto_save_hook);
3956 if (STRINGP (Vauto_save_list_file_name))
3957 listfile = condition_case_1 (Qt,
3958 auto_save_expand_name,
3959 Vauto_save_list_file_name,
3960 auto_save_expand_name_error, Qnil);
3962 /* Make sure auto_saving is reset. */
3963 record_unwind_protect (do_auto_save_unwind_2, make_int (auto_saving));
3967 /* First, save all files which don't have handlers. If Emacs is
3968 crashing, the handlers may tweak what is causing Emacs to crash
3969 in the first place, and it would be a shame if Emacs failed to
3970 autosave perfectly ordinary files because it couldn't handle some
3972 for (do_handled_files = 0; do_handled_files < 2; do_handled_files++)
3974 for (tail = Vbuffer_alist;
3978 buf = XCDR (XCAR (tail));
3981 if (!NILP (current_only)
3982 && b != current_buffer)
3985 /* Don't auto-save indirect buffers.
3986 The base buffer takes care of it. */
3990 /* Check for auto save enabled
3991 and file changed since last auto save
3992 and file changed since last real save. */
3993 if (STRINGP (b->auto_save_file_name)
3994 && BUF_SAVE_MODIFF (b) < BUF_MODIFF (b)
3995 && b->auto_save_modified < BUF_MODIFF (b)
3996 /* -1 means we've turned off autosaving for a while--see below. */
3997 && XINT (b->saved_size) >= 0
3998 && (do_handled_files
3999 || NILP (Ffind_file_name_handler (b->auto_save_file_name,
4002 EMACS_TIME before_time, after_time;
4004 EMACS_GET_TIME (before_time);
4005 /* If we had a failure, don't try again for 20 minutes. */
4006 if (!preparing_for_armageddon
4007 && b->auto_save_failure_time >= 0
4008 && (EMACS_SECS (before_time) - b->auto_save_failure_time <
4012 if (!preparing_for_armageddon &&
4013 (XINT (b->saved_size) * 10
4014 > (BUF_Z (b) - BUF_BEG (b)) * 13)
4015 /* A short file is likely to change a large fraction;
4016 spare the user annoying messages. */
4017 && XINT (b->saved_size) > 5000
4018 /* These messages are frequent and annoying for `*mail*'. */
4019 && !NILP (b->filename)
4020 && NILP (no_message)
4021 && disable_auto_save_when_buffer_shrinks)
4023 /* It has shrunk too much; turn off auto-saving here.
4024 Unless we're about to crash, in which case auto-save it
4028 ("Buffer %s has shrunk a lot; auto save turned off there",
4029 XSTRING_DATA (b->name));
4030 /* Turn off auto-saving until there's a real save,
4031 and prevent any more warnings. */
4032 b->saved_size = make_int (-1);
4033 if (!gc_in_progress)
4034 Fsleep_for (make_int (1));
4037 set_buffer_internal (b);
4038 if (!auto_saved && NILP (no_message))
4040 static const unsigned char *msg
4041 = (const unsigned char *) "Auto-saving...";
4042 echo_area_message (selected_frame (), msg, Qnil,
4043 0, strlen ((const char *) msg),
4047 /* Open the auto-save list file, if necessary.
4048 We only do this now so that the file only exists
4049 if we actually auto-saved any files. */
4050 if (!auto_saved && !inhibit_auto_save_session
4051 && !NILP (Vauto_save_list_file_prefix)
4052 && STRINGP (listfile) && listdesc < 0)
4054 listdesc = open ((char *) XSTRING_DATA (listfile),
4055 O_WRONLY | O_TRUNC | O_CREAT | OPEN_BINARY,
4058 /* Arrange to close that file whether or not we get
4061 record_unwind_protect (do_auto_save_unwind,
4062 make_int (listdesc));
4065 /* Record all the buffers that we are auto-saving in
4066 the special file that lists them. For each of
4067 these buffers, record visited name (if any) and
4071 const Extbyte *auto_save_file_name_ext;
4072 Extcount auto_save_file_name_ext_len;
4074 TO_EXTERNAL_FORMAT (LISP_STRING, b->auto_save_file_name,
4075 ALLOCA, (auto_save_file_name_ext,
4076 auto_save_file_name_ext_len),
4078 if (!NILP (b->filename))
4080 const Extbyte *filename_ext;
4081 Extcount filename_ext_len;
4083 TO_EXTERNAL_FORMAT (LISP_STRING, b->filename,
4084 ALLOCA, (filename_ext,
4087 write (listdesc, filename_ext, filename_ext_len);
4089 write (listdesc, "\n", 1);
4090 write (listdesc, auto_save_file_name_ext,
4091 auto_save_file_name_ext_len);
4092 write (listdesc, "\n", 1);
4095 /* dmoore - In a bad scenario we've set b=XBUFFER(buf)
4096 based on values in Vbuffer_alist. auto_save_1 may
4097 cause lisp handlers to run. Those handlers may kill
4098 the buffer and then GC. Since the buffer is killed,
4099 it's no longer in Vbuffer_alist so it might get reaped
4100 by the GC. We also need to protect tail. */
4101 /* #### There is probably a lot of other code which has
4102 pointers into buffers which may get blown away by
4105 struct gcpro ngcpro1, ngcpro2;
4106 NGCPRO2 (buf, tail);
4107 condition_case_1 (Qt,
4109 auto_save_error, Qnil);
4112 /* Handler killed our saved current-buffer! Pick any. */
4113 if (!BUFFER_LIVE_P (XBUFFER (old)))
4114 XSETBUFFER (old, current_buffer);
4116 set_buffer_internal (XBUFFER (old));
4119 /* Handler killed their own buffer! */
4120 if (!BUFFER_LIVE_P(b))
4123 b->auto_save_modified = BUF_MODIFF (b);
4124 b->saved_size = make_int (BUF_SIZE (b));
4125 EMACS_GET_TIME (after_time);
4126 /* If auto-save took more than 60 seconds,
4127 assume it was an NFS failure that got a timeout. */
4128 if (EMACS_SECS (after_time) - EMACS_SECS (before_time) > 60)
4129 b->auto_save_failure_time = EMACS_SECS (after_time);
4134 /* Prevent another auto save till enough input events come in. */
4136 record_auto_save ();
4138 /* If we didn't save anything into the listfile, remove the old
4139 one because nothing needed to be auto-saved. Do this afterwards
4140 rather than before in case we get a crash attempting to autosave
4141 (in that case we'd still want the old one around). */
4142 if (listdesc < 0 && !auto_saved && STRINGP (listfile))
4143 unlink ((char *) XSTRING_DATA (listfile));
4145 /* Show "...done" only if the echo area would otherwise be empty. */
4146 if (auto_saved && NILP (no_message)
4147 && NILP (clear_echo_area (selected_frame (), Qauto_saving, 0)))
4149 static const unsigned char *msg
4150 = (const unsigned char *)"Auto-saving...done";
4151 echo_area_message (selected_frame (), msg, Qnil, 0,
4152 strlen ((const char *) msg), Qauto_saving);
4157 RETURN_UNGCPRO (unbind_to (speccount, Qnil));
4160 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved, 0, 0, 0, /*
4161 Mark current buffer as auto-saved with its current text.
4162 No auto-save file will be written until the buffer changes again.
4166 current_buffer->auto_save_modified = BUF_MODIFF (current_buffer);
4167 current_buffer->saved_size = make_int (BUF_SIZE (current_buffer));
4168 current_buffer->auto_save_failure_time = -1;
4172 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure, 0, 0, 0, /*
4173 Clear any record of a recent auto-save failure in the current buffer.
4177 current_buffer->auto_save_failure_time = -1;
4181 DEFUN ("recent-auto-save-p", Frecent_auto_save_p, 0, 0, 0, /*
4182 Return t if buffer has been auto-saved since last read in or saved.
4186 return (BUF_SAVE_MODIFF (current_buffer) <
4187 current_buffer->auto_save_modified) ? Qt : Qnil;
4191 /************************************************************************/
4192 /* initialization */
4193 /************************************************************************/
4196 syms_of_fileio (void)
4198 defsymbol (&Qexpand_file_name, "expand-file-name");
4199 defsymbol (&Qfile_truename, "file-truename");
4200 defsymbol (&Qsubstitute_in_file_name, "substitute-in-file-name");
4201 defsymbol (&Qdirectory_file_name, "directory-file-name");
4202 defsymbol (&Qfile_name_directory, "file-name-directory");
4203 defsymbol (&Qfile_name_nondirectory, "file-name-nondirectory");
4204 defsymbol (&Qunhandled_file_name_directory, "unhandled-file-name-directory");
4205 defsymbol (&Qfile_name_as_directory, "file-name-as-directory");
4206 defsymbol (&Qcopy_file, "copy-file");
4207 defsymbol (&Qmake_directory_internal, "make-directory-internal");
4208 defsymbol (&Qdelete_directory, "delete-directory");
4209 defsymbol (&Qdelete_file, "delete-file");
4210 defsymbol (&Qrename_file, "rename-file");
4211 defsymbol (&Qadd_name_to_file, "add-name-to-file");
4212 defsymbol (&Qmake_symbolic_link, "make-symbolic-link");
4213 defsymbol (&Qfile_exists_p, "file-exists-p");
4214 defsymbol (&Qfile_executable_p, "file-executable-p");
4215 defsymbol (&Qfile_readable_p, "file-readable-p");
4216 defsymbol (&Qfile_symlink_p, "file-symlink-p");
4217 defsymbol (&Qfile_writable_p, "file-writable-p");
4218 defsymbol (&Qfile_directory_p, "file-directory-p");
4219 defsymbol (&Qfile_regular_p, "file-regular-p");
4220 defsymbol (&Qfile_accessible_directory_p, "file-accessible-directory-p");
4221 defsymbol (&Qfile_modes, "file-modes");
4222 defsymbol (&Qset_file_modes, "set-file-modes");
4223 defsymbol (&Qfile_newer_than_file_p, "file-newer-than-file-p");
4224 defsymbol (&Qinsert_file_contents, "insert-file-contents");
4225 defsymbol (&Qwrite_region, "write-region");
4226 defsymbol (&Qverify_visited_file_modtime, "verify-visited-file-modtime");
4227 defsymbol (&Qset_visited_file_modtime, "set-visited-file-modtime");
4228 defsymbol (&Qcar_less_than_car, "car-less-than-car"); /* Vomitous! */
4230 defsymbol (&Qauto_save_hook, "auto-save-hook");
4231 defsymbol (&Qauto_save_error, "auto-save-error");
4232 defsymbol (&Qauto_saving, "auto-saving");
4234 defsymbol (&Qformat_decode, "format-decode");
4235 defsymbol (&Qformat_annotate_function, "format-annotate-function");
4237 defsymbol (&Qcompute_buffer_file_truename, "compute-buffer-file-truename");
4238 DEFERROR_STANDARD (Qfile_error, Qio_error);
4239 DEFERROR_STANDARD (Qfile_already_exists, Qfile_error);
4241 DEFSUBR (Ffind_file_name_handler);
4243 DEFSUBR (Ffile_name_directory);
4244 DEFSUBR (Ffile_name_nondirectory);
4245 DEFSUBR (Funhandled_file_name_directory);
4246 DEFSUBR (Ffile_name_as_directory);
4247 DEFSUBR (Fdirectory_file_name);
4248 DEFSUBR (Fmake_temp_name);
4249 DEFSUBR (Fexpand_file_name);
4250 DEFSUBR (Ffile_truename);
4251 DEFSUBR (Fsubstitute_in_file_name);
4252 DEFSUBR (Fcopy_file);
4253 DEFSUBR (Fmake_directory_internal);
4254 DEFSUBR (Fdelete_directory);
4255 DEFSUBR (Fdelete_file);
4256 DEFSUBR (Frename_file);
4257 DEFSUBR (Fadd_name_to_file);
4258 DEFSUBR (Fmake_symbolic_link);
4260 DEFSUBR (Fsysnetunam);
4261 #endif /* HPUX_NET */
4262 DEFSUBR (Ffile_name_absolute_p);
4263 DEFSUBR (Ffile_exists_p);
4264 DEFSUBR (Ffile_executable_p);
4265 DEFSUBR (Ffile_readable_p);
4266 DEFSUBR (Ffile_writable_p);
4267 DEFSUBR (Ffile_symlink_p);
4268 DEFSUBR (Ffile_directory_p);
4269 DEFSUBR (Ffile_accessible_directory_p);
4270 DEFSUBR (Ffile_regular_p);
4271 DEFSUBR (Ffile_modes);
4272 DEFSUBR (Fset_file_modes);
4273 DEFSUBR (Fset_default_file_modes);
4274 DEFSUBR (Fdefault_file_modes);
4275 DEFSUBR (Funix_sync);
4276 DEFSUBR (Ffile_newer_than_file_p);
4277 DEFSUBR (Finsert_file_contents_internal);
4278 DEFSUBR (Fwrite_region_internal);
4279 DEFSUBR (Fcar_less_than_car); /* Vomitous! */
4280 DEFSUBR (Fcdr_less_than_cdr); /* Yeah oh yeah bucko .... */
4282 DEFSUBR (Fencrypt_string);
4283 DEFSUBR (Fdecrypt_string);
4285 DEFSUBR (Fverify_visited_file_modtime);
4286 DEFSUBR (Fclear_visited_file_modtime);
4287 DEFSUBR (Fvisited_file_modtime);
4288 DEFSUBR (Fset_visited_file_modtime);
4290 DEFSUBR (Fdo_auto_save);
4291 DEFSUBR (Fset_buffer_auto_saved);
4292 DEFSUBR (Fclear_buffer_auto_save_failure);
4293 DEFSUBR (Frecent_auto_save_p);
4297 vars_of_fileio (void)
4299 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format /*
4300 *Format in which to write auto-save files.
4301 Should be a list of symbols naming formats that are defined in `format-alist'.
4302 If it is t, which is the default, auto-save files are written in the
4303 same format as a regular save would use.
4305 Vauto_save_file_format = Qt;
4307 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist /*
4308 *Alist of elements (REGEXP . HANDLER) for file names handled specially.
4309 If a file name matches REGEXP, then all I/O on that file is done by calling
4312 The first argument given to HANDLER is the name of the I/O primitive
4313 to be handled; the remaining arguments are the arguments that were
4314 passed to that primitive. For example, if you do
4315 (file-exists-p FILENAME)
4316 and FILENAME is handled by HANDLER, then HANDLER is called like this:
4317 (funcall HANDLER 'file-exists-p FILENAME)
4318 The function `find-file-name-handler' checks this list for a handler
4321 Vfile_name_handler_alist = Qnil;
4323 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions /*
4324 A list of functions to be called at the end of `insert-file-contents'.
4325 Each is passed one argument, the number of bytes inserted. It should return
4326 the new byte count, and leave point the same. If `insert-file-contents' is
4327 intercepted by a handler from `file-name-handler-alist', that handler is
4328 responsible for calling the after-insert-file-functions if appropriate.
4330 Vafter_insert_file_functions = Qnil;
4332 DEFVAR_LISP ("write-region-annotate-functions",
4333 &Vwrite_region_annotate_functions /*
4334 A list of functions to be called at the start of `write-region'.
4335 Each is passed two arguments, START and END, as for `write-region'.
4336 It should return a list of pairs (POSITION . STRING) of strings to be
4337 effectively inserted at the specified positions of the file being written
4338 \(1 means to insert before the first byte written). The POSITIONs must be
4339 sorted into increasing order. If there are several functions in the list,
4340 the several lists are merged destructively.
4342 Vwrite_region_annotate_functions = Qnil;
4344 DEFVAR_LISP ("write-region-annotations-so-far",
4345 &Vwrite_region_annotations_so_far /*
4346 When an annotation function is called, this holds the previous annotations.
4347 These are the annotations made by other annotation functions
4348 that were already called. See also `write-region-annotate-functions'.
4350 Vwrite_region_annotations_so_far = Qnil;
4352 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers /*
4353 A list of file name handlers that temporarily should not be used.
4354 This applies only to the operation `inhibit-file-name-operation'.
4356 Vinhibit_file_name_handlers = Qnil;
4358 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation /*
4359 The operation for which `inhibit-file-name-handlers' is applicable.
4361 Vinhibit_file_name_operation = Qnil;
4363 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name /*
4364 File name in which we write a list of all auto save file names.
4366 Vauto_save_list_file_name = Qnil;
4368 DEFVAR_LISP ("auto-save-list-file-prefix", &Vauto_save_list_file_prefix /*
4369 Prefix for generating auto-save-list-file-name.
4370 Emacs's pid and the system name will be appended to
4371 this prefix to create a unique file name.
4373 Vauto_save_list_file_prefix = build_string ("~/.saves-");
4375 DEFVAR_BOOL ("inhibit-auto-save-session", &inhibit_auto_save_session /*
4376 When non-nil, inhibit auto save list file creation.
4378 inhibit_auto_save_session = 0;
4380 DEFVAR_BOOL ("disable-auto-save-when-buffer-shrinks",
4381 &disable_auto_save_when_buffer_shrinks /*
4382 If non-nil, auto-saving is disabled when a buffer shrinks too much.
4383 This is to prevent you from losing your edits if you accidentally
4384 delete a large chunk of the buffer and don't notice it until too late.
4385 Saving the buffer normally turns auto-save back on.
4387 disable_auto_save_when_buffer_shrinks = 1;
4389 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char /*
4390 Directory separator character for built-in functions that return file names.
4391 The value should be either ?/ or ?\\ (any other value is treated as ?\\).
4392 This variable affects the built-in functions only on Windows,
4393 on other platforms, it is initialized so that Lisp code can find out
4394 what the normal separator is.
4397 Vdirectory_sep_char = make_char ('\\');
4399 Vdirectory_sep_char = make_char ('/');
4402 reinit_vars_of_fileio ();
4406 reinit_vars_of_fileio (void)
4408 /* We want temp_name_rand to be initialized to a value likely to be
4409 unique to the process, not to the executable. The danger is that
4410 two different XEmacs processes using the same binary on different
4411 machines creating temp files in the same directory will be
4412 unlucky enough to have the same pid. If we randomize using
4413 process startup time, then in practice they will be unlikely to
4414 collide. We use the microseconds field so that scripts that start
4415 simultaneous XEmacs processes on multiple machines will have less
4416 chance of collision. */
4420 EMACS_GET_TIME (thyme);
4421 temp_name_rand = (unsigned int) (EMACS_SECS (thyme) ^ EMACS_USECS (thyme));