update.
[chise/xemacs-chise.git] / src / fileio.c
1 /* File IO for XEmacs.
2    Copyright (C) 1985-1988, 1992-1995 Free Software Foundation, Inc.
3    Copyright (C) 1996 Ben Wing.
4
5 This file is part of XEmacs.
6
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
10 later version.
11
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
15 for more details.
16
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.  */
21
22 /* Synched up with: Mule 2.0, FSF 19.30. */
23 /* More syncing: FSF Emacs 19.34.6 by Marc Paquette <marcpa@cam.org> */
24
25 #include <config.h>
26 #include "lisp.h"
27
28 #include "buffer.h"
29 #include "events.h"
30 #include "frame.h"
31 #include "insdel.h"
32 #include "lstream.h"
33 #include "redisplay.h"
34 #include "sysdep.h"
35 #include "window.h"             /* minibuf_level */
36 #ifdef FILE_CODING
37 #include "file-coding.h"
38 #endif
39
40 #ifdef HAVE_LIBGEN_H            /* Must come before sysfile.h */
41 #include <libgen.h>
42 #endif
43 #include "sysfile.h"
44 #include "sysproc.h"
45 #include "syspwd.h"
46 #include "systime.h"
47 #include "sysdir.h"
48
49 #ifdef HPUX
50 #include <netio.h>
51 #ifdef HPUX_PRE_8_0
52 #include <errnet.h>
53 #endif /* HPUX_PRE_8_0 */
54 #endif /* HPUX */
55
56 #if defined(WIN32_NATIVE) || defined(CYGWIN)
57 #define WIN32_FILENAMES
58 #ifdef WIN32_NATIVE
59 #include "nt.h"
60 #include <aclapi.h>
61 #endif /* WIN32_NATIVE */
62 #ifdef CYGWIN
63 #include <w32api/aclapi.h>
64 #endif
65
66
67 #define IS_DRIVE(x) isalpha (x)
68 /* Need to lower-case the drive letter, or else expanded
69    filenames will sometimes compare inequal, because
70    `expand-file-name' doesn't always down-case the drive letter.  */
71 #define DRIVE_LETTER(x) tolower (x)
72 #ifndef CORRECT_DIR_SEPS
73 #define CORRECT_DIR_SEPS(s) \
74   normalize_filename(s, DIRECTORY_SEP)
75 /* Default implementation that coerces a file to use path_sep. */
76 static void
77 normalize_filename (Bufbyte *fp, Bufbyte path_sep)
78 {
79   /* Always lower-case drive letters a-z, even if the filesystem
80      preserves case in filenames.
81      This is so filenames can be compared by string comparison
82      functions that are case-sensitive.  Even case-preserving filesystems
83      do not distinguish case in drive letters.  */
84   if (fp[1] == ':' && *fp >= 'A' && *fp <= 'Z')
85     {
86       *fp += 'a' - 'A';
87       fp += 2;
88     }
89
90   while (*fp)
91     {
92       if (*fp == '/' || *fp == '\\')
93         *fp = path_sep;
94       fp++;
95     }
96 }
97 #endif /* CORRECT_DIR_SEPS */
98 #endif /* WIN32_NATIVE || CYGWIN */
99
100 int lisp_to_time (Lisp_Object, time_t *);
101 Lisp_Object time_to_lisp (time_t);
102
103 /* Nonzero during writing of auto-save files */
104 static int auto_saving;
105
106 /* Set by auto_save_1 to mode of original file so Fwrite_region_internal
107    will create a new file with the same mode as the original */
108 static int auto_save_mode_bits;
109
110 /* Alist of elements (REGEXP . HANDLER) for file names
111    whose I/O is done with a special handler.  */
112 Lisp_Object Vfile_name_handler_alist;
113
114 /* Format for auto-save files */
115 Lisp_Object Vauto_save_file_format;
116
117 /* Lisp functions for translating file formats */
118 Lisp_Object Qformat_decode, Qformat_annotate_function;
119
120 /* Functions to be called to process text properties in inserted file.  */
121 Lisp_Object Vafter_insert_file_functions;
122
123 /* Functions to be called to create text property annotations for file.  */
124 Lisp_Object Vwrite_region_annotate_functions;
125
126 /* During build_annotations, each time an annotation function is called,
127    this holds the annotations made by the previous functions.  */
128 Lisp_Object Vwrite_region_annotations_so_far;
129
130 /* File name in which we write a list of all our auto save files.  */
131 Lisp_Object Vauto_save_list_file_name;
132
133 /* Prefix used to construct Vauto_save_list_file_name. */
134 Lisp_Object Vauto_save_list_file_prefix;
135
136 /* When non-nil, it prevents auto-save list file creation. */
137 int inhibit_auto_save_session;
138
139 int disable_auto_save_when_buffer_shrinks;
140
141 Lisp_Object Vdirectory_sep_char;
142
143 /* These variables describe handlers that have "already" had a chance
144    to handle the current operation.
145
146    Vinhibit_file_name_handlers is a list of file name handlers.
147    Vinhibit_file_name_operation is the operation being handled.
148    If we try to handle that operation, we ignore those handlers.  */
149
150 static Lisp_Object Vinhibit_file_name_handlers;
151 static Lisp_Object Vinhibit_file_name_operation;
152
153 Lisp_Object Qfile_error, Qfile_already_exists;
154
155 Lisp_Object Qauto_save_hook;
156 Lisp_Object Qauto_save_error;
157 Lisp_Object Qauto_saving;
158
159 Lisp_Object Qcar_less_than_car;
160
161 Lisp_Object Qcompute_buffer_file_truename;
162
163 EXFUN (Frunning_temacs_p, 0);
164
165 /* signal a file error when errno contains a meaningful value. */
166
167 DOESNT_RETURN
168 report_file_error (const char *string, Lisp_Object data)
169 {
170   /* #### dmoore - This uses current_buffer, better make sure no one
171      has GC'd the current buffer.  File handlers are giving me a headache
172      maybe I'll just always protect current_buffer around all of those
173      calls. */
174
175   signal_error (Qfile_error,
176                 Fcons (build_translated_string (string),
177                        Fcons (lisp_strerror (errno), data)));
178 }
179
180 void
181 maybe_report_file_error (const char *string, Lisp_Object data,
182                          Lisp_Object class, Error_behavior errb)
183 {
184   /* Optimization: */
185   if (ERRB_EQ (errb, ERROR_ME_NOT))
186     return;
187
188   maybe_signal_error (Qfile_error,
189                       Fcons (build_translated_string (string),
190                              Fcons (lisp_strerror (errno), data)),
191                       class, errb);
192 }
193
194 /* signal a file error when errno does not contain a meaningful value. */
195
196 DOESNT_RETURN
197 signal_file_error (const char *string, Lisp_Object data)
198 {
199   signal_error (Qfile_error,
200                 list2 (build_translated_string (string), data));
201 }
202
203 void
204 maybe_signal_file_error (const char *string, Lisp_Object data,
205                          Lisp_Object class, Error_behavior errb)
206 {
207   /* Optimization: */
208   if (ERRB_EQ (errb, ERROR_ME_NOT))
209     return;
210   maybe_signal_error (Qfile_error,
211                       list2 (build_translated_string (string), data),
212                       class, errb);
213 }
214
215 DOESNT_RETURN
216 signal_double_file_error (const char *string1, const char *string2,
217                           Lisp_Object data)
218 {
219   signal_error (Qfile_error,
220                 list3 (build_translated_string (string1),
221                        build_translated_string (string2),
222                        data));
223 }
224
225 void
226 maybe_signal_double_file_error (const char *string1, const char *string2,
227                                 Lisp_Object data, Lisp_Object class,
228                                 Error_behavior errb)
229 {
230   /* Optimization: */
231   if (ERRB_EQ (errb, ERROR_ME_NOT))
232     return;
233   maybe_signal_error (Qfile_error,
234                       list3 (build_translated_string (string1),
235                              build_translated_string (string2),
236                              data),
237                       class, errb);
238 }
239
240 DOESNT_RETURN
241 signal_double_file_error_2 (const char *string1, const char *string2,
242                             Lisp_Object data1, Lisp_Object data2)
243 {
244   signal_error (Qfile_error,
245                 list4 (build_translated_string (string1),
246                        build_translated_string (string2),
247                        data1, data2));
248 }
249
250 void
251 maybe_signal_double_file_error_2 (const char *string1, const char *string2,
252                                   Lisp_Object data1, Lisp_Object data2,
253                                   Lisp_Object class, Error_behavior errb)
254 {
255   /* Optimization: */
256   if (ERRB_EQ (errb, ERROR_ME_NOT))
257     return;
258   maybe_signal_error (Qfile_error,
259                       list4 (build_translated_string (string1),
260                              build_translated_string (string2),
261                              data1, data2),
262                       class, errb);
263 }
264
265 \f
266 /* Just like strerror(3), except return a lisp string instead of char *.
267    The string needs to be converted since it may be localized.
268    Perhaps this should use strerror-coding-system instead? */
269 Lisp_Object
270 lisp_strerror (int errnum)
271 {
272   return build_ext_string (strerror (errnum), Qnative);
273 }
274
275 static Lisp_Object
276 close_file_unwind (Lisp_Object fd)
277 {
278   if (CONSP (fd))
279     {
280       if (INTP (XCAR (fd)))
281         close (XINT (XCAR (fd)));
282
283       free_cons (XCONS (fd));
284     }
285   else
286     close (XINT (fd));
287
288   return Qnil;
289 }
290
291 static Lisp_Object
292 delete_stream_unwind (Lisp_Object stream)
293 {
294   Lstream_delete (XLSTREAM (stream));
295   return Qnil;
296 }
297
298 /* Restore point, having saved it as a marker.  */
299
300 static Lisp_Object
301 restore_point_unwind (Lisp_Object point_marker)
302 {
303   BUF_SET_PT (current_buffer, marker_position (point_marker));
304   return Fset_marker (point_marker, Qnil, Qnil);
305 }
306
307 /* Versions of read() and write() that allow quitting out of the actual
308    I/O.  We don't use immediate_quit (i.e. direct longjmp() out of the
309    signal handler) because that's way too losing.
310
311    (#### Actually, longjmp()ing out of the signal handler may not be
312    as losing as I thought.  See sys_do_signal() in sysdep.c.) */
313
314 ssize_t
315 read_allowing_quit (int fildes, void *buf, size_t size)
316 {
317   QUIT;
318   return sys_read_1 (fildes, buf, size, 1);
319 }
320
321 ssize_t
322 write_allowing_quit (int fildes, const void *buf, size_t size)
323 {
324   QUIT;
325   return sys_write_1 (fildes, buf, size, 1);
326 }
327
328 \f
329 Lisp_Object Qexpand_file_name;
330 Lisp_Object Qfile_truename;
331 Lisp_Object Qsubstitute_in_file_name;
332 Lisp_Object Qdirectory_file_name;
333 Lisp_Object Qfile_name_directory;
334 Lisp_Object Qfile_name_nondirectory;
335 Lisp_Object Qunhandled_file_name_directory;
336 Lisp_Object Qfile_name_as_directory;
337 Lisp_Object Qcopy_file;
338 Lisp_Object Qmake_directory_internal;
339 Lisp_Object Qdelete_directory;
340 Lisp_Object Qdelete_file;
341 Lisp_Object Qrename_file;
342 Lisp_Object Qadd_name_to_file;
343 Lisp_Object Qmake_symbolic_link;
344 Lisp_Object Qfile_exists_p;
345 Lisp_Object Qfile_executable_p;
346 Lisp_Object Qfile_readable_p;
347 Lisp_Object Qfile_symlink_p;
348 Lisp_Object Qfile_writable_p;
349 Lisp_Object Qfile_directory_p;
350 Lisp_Object Qfile_regular_p;
351 Lisp_Object Qfile_accessible_directory_p;
352 Lisp_Object Qfile_modes;
353 Lisp_Object Qset_file_modes;
354 Lisp_Object Qfile_newer_than_file_p;
355 Lisp_Object Qinsert_file_contents;
356 Lisp_Object Qwrite_region;
357 Lisp_Object Qverify_visited_file_modtime;
358 Lisp_Object Qset_visited_file_modtime;
359
360 /* If FILENAME is handled specially on account of its syntax,
361    return its handler function.  Otherwise, return nil.  */
362
363 DEFUN ("find-file-name-handler", Ffind_file_name_handler, 1, 2, 0, /*
364 Return FILENAME's handler function for OPERATION, if it has one.
365 Otherwise, return nil.
366 A file name is handled if one of the regular expressions in
367 `file-name-handler-alist' matches it.
368
369 If OPERATION equals `inhibit-file-name-operation', then we ignore
370 any handlers that are members of `inhibit-file-name-handlers',
371 but we still do run any other handlers.  This lets handlers
372 use the standard functions without calling themselves recursively.
373
374 Otherwise, OPERATION is the name of a funcall'able function.
375 */
376        (filename, operation))
377 {
378   /* This function does not GC */
379   /* This function can be called during GC */
380   /* This function must not munge the match data.  */
381   Lisp_Object chain, inhibited_handlers;
382
383   CHECK_STRING (filename);
384
385   if (EQ (operation, Vinhibit_file_name_operation))
386     inhibited_handlers = Vinhibit_file_name_handlers;
387   else
388     inhibited_handlers = Qnil;
389
390   EXTERNAL_LIST_LOOP (chain, Vfile_name_handler_alist)
391     {
392       Lisp_Object elt = XCAR (chain);
393       if (CONSP (elt))
394         {
395           Lisp_Object string = XCAR (elt);
396           if (STRINGP (string)
397               && (fast_lisp_string_match (string, filename) >= 0))
398             {
399               Lisp_Object handler = XCDR (elt);
400               if (NILP (Fmemq (handler, inhibited_handlers)))
401                 return handler;
402             }
403         }
404       QUIT;
405     }
406   return Qnil;
407 }
408
409 static Lisp_Object
410 call2_check_string (Lisp_Object fn, Lisp_Object arg0, Lisp_Object arg1)
411 {
412   /* This function can call lisp */
413   Lisp_Object result = call2 (fn, arg0, arg1);
414   CHECK_STRING (result);
415   return result;
416 }
417
418 static Lisp_Object
419 call2_check_string_or_nil (Lisp_Object fn, Lisp_Object arg0, Lisp_Object arg1)
420 {
421   /* This function can call lisp */
422   Lisp_Object result = call2 (fn, arg0, arg1);
423   if (!NILP (result))
424     CHECK_STRING (result);
425   return result;
426 }
427
428 static Lisp_Object
429 call3_check_string (Lisp_Object fn, Lisp_Object arg0,
430                     Lisp_Object arg1, Lisp_Object arg2)
431 {
432   /* This function can call lisp */
433   Lisp_Object result = call3 (fn, arg0, arg1, arg2);
434   CHECK_STRING (result);
435   return result;
436 }
437
438 \f
439 DEFUN ("file-name-directory", Ffile_name_directory, 1, 1, 0, /*
440 Return the directory component in file name FILENAME.
441 Return nil if FILENAME does not include a directory.
442 Otherwise return a directory spec.
443 Given a Unix syntax file name, returns a string ending in slash.
444 */
445        (filename))
446 {
447   /* This function can GC.  GC checked 2000-07-28 ben */
448   Bufbyte *beg;
449   Bufbyte *p;
450   Lisp_Object handler;
451
452   CHECK_STRING (filename);
453
454   /* If the file name has special constructs in it,
455      call the corresponding file handler.  */
456   handler = Ffind_file_name_handler (filename, Qfile_name_directory);
457   if (!NILP (handler))
458     return call2_check_string_or_nil (handler, Qfile_name_directory, filename);
459
460 #ifdef FILE_SYSTEM_CASE
461   filename = FILE_SYSTEM_CASE (filename);
462 #endif
463   beg = XSTRING_DATA (filename);
464   p = beg + XSTRING_LENGTH (filename);
465
466   while (p != beg && !IS_ANY_SEP (p[-1])
467 #ifdef WIN32_FILENAMES
468          /* only recognize drive specifier at beginning */
469          && !(p[-1] == ':' && p == beg + 2)
470 #endif
471     ) p--;
472
473   if (p == beg)
474     return Qnil;
475 #ifdef WIN32_NATIVE
476   /* Expansion of "c:" to drive and default directory.  */
477   /* (NT does the right thing.)  */
478   if (p == beg + 2 && beg[1] == ':')
479     {
480       /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir.  */
481       Bufbyte *res = (Bufbyte*) alloca (MAXPATHLEN + 1);
482       if (_getdcwd (toupper (*beg) - 'A' + 1, (char *)res, MAXPATHLEN))
483         {
484           char *c=((char *) res) + strlen ((char *) res);
485           if (!IS_DIRECTORY_SEP (*c))
486             {
487               *c++ = DIRECTORY_SEP;
488               *c = '\0';
489             }
490           beg = res;
491           p = beg + strlen ((char *) beg);
492         }
493     }
494 #endif /* WIN32_NATIVE */
495   return make_string (beg, p - beg);
496 }
497
498 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory, 1, 1, 0, /*
499 Return file name FILENAME sans its directory.
500 For example, in a Unix-syntax file name,
501 this is everything after the last slash,
502 or the entire name if it contains no slash.
503 */
504        (filename))
505 {
506   /* This function can GC.  GC checked 2000-07-28 ben */
507   Bufbyte *beg, *p, *end;
508   Lisp_Object handler;
509
510   CHECK_STRING (filename);
511
512   /* If the file name has special constructs in it,
513      call the corresponding file handler.  */
514   handler = Ffind_file_name_handler (filename, Qfile_name_nondirectory);
515   if (!NILP (handler))
516     return call2_check_string (handler, Qfile_name_nondirectory, filename);
517
518   beg = XSTRING_DATA (filename);
519   end = p = beg + XSTRING_LENGTH (filename);
520
521   while (p != beg && !IS_ANY_SEP (p[-1])
522 #ifdef WIN32_FILENAMES
523          /* only recognize drive specifier at beginning */
524          && !(p[-1] == ':' && p == beg + 2)
525 #endif
526     ) p--;
527
528   return make_string (p, end - p);
529 }
530
531 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory, 1, 1, 0, /*
532 Return a directly usable directory name somehow associated with FILENAME.
533 A `directly usable' directory name is one that may be used without the
534 intervention of any file handler.
535 If FILENAME is a directly usable file itself, return
536 \(file-name-directory FILENAME).
537 The `call-process' and `start-process' functions use this function to
538 get a current directory to run processes in.
539 */
540        (filename))
541 {
542   /* This function can GC.  GC checked 2000-07-28 ben */
543   Lisp_Object handler;
544
545   /* If the file name has special constructs in it,
546      call the corresponding file handler.  */
547   handler = Ffind_file_name_handler (filename, Qunhandled_file_name_directory);
548   if (!NILP (handler))
549     return call2 (handler, Qunhandled_file_name_directory,
550                   filename);
551
552   return Ffile_name_directory (filename);
553 }
554
555 \f
556 static char *
557 file_name_as_directory (char *out, char *in)
558 {
559   /* This function cannot GC */
560   int size = strlen (in);
561
562   if (size == 0)
563     {
564       out[0] = '.';
565       out[1] = DIRECTORY_SEP;
566       out[2] = '\0';
567     }
568   else
569     {
570       strcpy (out, in);
571       /* Append a slash if necessary */
572       if (!IS_ANY_SEP (out[size-1]))
573         {
574           out[size] = DIRECTORY_SEP;
575           out[size + 1] = '\0';
576         }
577     }
578   return out;
579 }
580
581 DEFUN ("file-name-as-directory", Ffile_name_as_directory, 1, 1, 0, /*
582 Return a string representing file FILENAME interpreted as a directory.
583 This operation exists because a directory is also a file, but its name as
584 a directory is different from its name as a file.
585 The result can be used as the value of `default-directory'
586 or passed as second argument to `expand-file-name'.
587 For a Unix-syntax file name, just appends a slash,
588 except for (file-name-as-directory \"\") => \"./\".
589 */
590        (filename))
591 {
592   /* This function can GC.  GC checked 2000-07-28 ben */
593   char *buf;
594   Lisp_Object handler;
595
596   CHECK_STRING (filename);
597
598   /* If the file name has special constructs in it,
599      call the corresponding file handler.  */
600   handler = Ffind_file_name_handler (filename, Qfile_name_as_directory);
601   if (!NILP (handler))
602     return call2_check_string (handler, Qfile_name_as_directory, filename);
603
604   buf = (char *) alloca (XSTRING_LENGTH (filename) + 10);
605   return build_string (file_name_as_directory
606                        (buf, (char *) XSTRING_DATA (filename)));
607 }
608 \f
609 /*
610  * Convert from directory name to filename.
611  * On UNIX, it's simple: just make sure there isn't a terminating /
612  *
613  * Value is nonzero if the string output is different from the input.
614  */
615
616 static int
617 directory_file_name (const char *src, char *dst)
618 {
619   /* This function cannot GC */
620   long slen = strlen (src);
621   /* Process as Unix format: just remove any final slash.
622      But leave "/" unchanged; do not change it to "".  */
623   strcpy (dst, src);
624   if (slen > 1
625       && IS_DIRECTORY_SEP (dst[slen - 1])
626 #ifdef WIN32_FILENAMES
627       && !IS_ANY_SEP (dst[slen - 2])
628 #endif /* WIN32_FILENAMES */
629       )
630     dst[slen - 1] = 0;
631   return 1;
632 }
633
634 DEFUN ("directory-file-name", Fdirectory_file_name, 1, 1, 0, /*
635 Return the file name of the directory named DIRECTORY.
636 This is the name of the file that holds the data for the directory.
637 This operation exists because a directory is also a file, but its name as
638 a directory is different from its name as a file.
639 In Unix-syntax, this function just removes the final slash.
640 */
641        (directory))
642 {
643   /* This function can GC.  GC checked 2000-07-28 ben */
644   char *buf;
645   Lisp_Object handler;
646
647   CHECK_STRING (directory);
648
649 #if 0 /* #### WTF? */
650   if (NILP (directory))
651     return Qnil;
652 #endif
653
654   /* If the file name has special constructs in it,
655      call the corresponding file handler.  */
656   handler = Ffind_file_name_handler (directory, Qdirectory_file_name);
657   if (!NILP (handler))
658     return call2_check_string (handler, Qdirectory_file_name, directory);
659   buf = (char *) alloca (XSTRING_LENGTH (directory) + 20);
660   directory_file_name ((char *) XSTRING_DATA (directory), buf);
661   return build_string (buf);
662 }
663 \f
664 /* Fmake_temp_name used to be a simple wrapper around mktemp(), but it
665    proved too broken for our purposes (it supported only 26 or 62
666    unique names under some implementations).  For example, this
667    arbitrary limit broke generation of Gnus Incoming* files.
668
669    This implementation is better than what one usually finds in libc.
670    --hniksic */
671
672 static unsigned int temp_name_rand;
673
674 DEFUN ("make-temp-name", Fmake_temp_name, 1, 1, 0, /*
675 Generate a temporary file name starting with PREFIX.
676 The Emacs process number forms part of the result, so there is no
677 danger of generating a name being used by another process.
678
679 In addition, this function makes an attempt to choose a name that
680 does not specify an existing file.  To make this work, PREFIX should
681 be an absolute file name.
682 */
683        (prefix))
684 {
685   static const char tbl[64] =
686   {
687     'A','B','C','D','E','F','G','H',
688     'I','J','K','L','M','N','O','P',
689     'Q','R','S','T','U','V','W','X',
690     'Y','Z','a','b','c','d','e','f',
691     'g','h','i','j','k','l','m','n',
692     'o','p','q','r','s','t','u','v',
693     'w','x','y','z','0','1','2','3',
694     '4','5','6','7','8','9','-','_'
695   };
696
697   Lisp_Object val;
698   Bytecount len;
699   Bufbyte *p, *data;
700
701   CHECK_STRING (prefix);
702
703   /* I was tempted to apply Fexpand_file_name on PREFIX here, but it's
704      a bad idea because:
705
706      1) It might change the prefix, so the resulting string might not
707      begin with PREFIX.  This violates the principle of least
708      surprise.
709
710      2) It breaks under many unforeseeable circumstances, such as with
711      the code that uses (make-temp-name "") instead of
712      (make-temp-name "./").
713
714      3) It might yield unexpected (to stat(2)) results in the presence
715      of EFS and file name handlers.  */
716
717   len = XSTRING_LENGTH (prefix);
718   val = make_uninit_string (len + 6);
719   data = XSTRING_DATA (val);
720   memcpy (data, XSTRING_DATA (prefix), len);
721   p = data + len;
722
723   /* VAL is created by adding 6 characters to PREFIX.  The first three
724      are the PID of this process, in base 64, and the second three are
725      a pseudo-random number seeded from process startup time.  This
726      ensures 262144 unique file names per PID per PREFIX per machine.  */
727
728   {
729     unsigned int pid = (unsigned int) getpid ();
730     *p++ = tbl[(pid >>  0) & 63];
731     *p++ = tbl[(pid >>  6) & 63];
732     *p++ = tbl[(pid >> 12) & 63];
733   }
734
735   /* Here we try to minimize useless stat'ing when this function is
736      invoked many times successively with the same PREFIX.  We achieve
737      this by using a very pseudo-random number generator to generate
738      file names unique to this process, with a very long cycle. */
739
740   while (1)
741     {
742       struct stat ignored;
743
744       p[0] = tbl[(temp_name_rand >>  0) & 63];
745       p[1] = tbl[(temp_name_rand >>  6) & 63];
746       p[2] = tbl[(temp_name_rand >> 12) & 63];
747
748       /* Poor man's congruential RN generator.  Replace with ++count
749          for debugging.  */
750       temp_name_rand += 25229;
751       temp_name_rand %= 225307;
752
753       QUIT;
754
755       if (xemacs_stat ((const char *) data, &ignored) < 0)
756         {
757           /* We want to return only if errno is ENOENT.  */
758           if (errno == ENOENT)
759             return val;
760
761           /* The error here is dubious, but there is little else we
762              can do.  The alternatives are to return nil, which is
763              as bad as (and in many cases worse than) throwing the
764              error, or to ignore the error, which will likely result
765              in inflooping.  */
766           report_file_error ("Cannot create temporary name for prefix",
767                              list1 (prefix));
768           return Qnil; /* not reached */
769         }
770     }
771 }
772
773 \f
774 DEFUN ("expand-file-name", Fexpand_file_name, 1, 2, 0, /*
775 Convert filename NAME to absolute, and canonicalize it.
776 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative
777  (does not start with slash); if DEFAULT-DIRECTORY is nil or missing,
778 the current buffer's value of `default-directory' is used.
779 File name components that are `.' are removed, and
780 so are file name components followed by `..', along with the `..' itself;
781 note that these simplifications are done without checking the resulting
782 file names in the file system.
783 An initial `~/' expands to your home directory.
784 An initial `~USER/' expands to USER's home directory.
785 See also the function `substitute-in-file-name'.
786 */
787        (name, default_directory))
788 {
789   /* This function can GC.  GC-checked 2000-11-18 */
790   Bufbyte *nm;
791
792   Bufbyte *newdir, *p, *o;
793   int tlen;
794   Bufbyte *target;
795 #ifdef WIN32_FILENAMES
796   int drive = 0;
797   int collapse_newdir = 1;
798 #endif
799 #ifndef WIN32_NATIVE
800   struct passwd *pw;
801 #endif /* WIN32_FILENAMES */
802   int length;
803   Lisp_Object handler = Qnil;
804 #ifdef CYGWIN
805   char *user;
806 #endif
807   struct gcpro gcpro1, gcpro2, gcpro3;
808
809   /* both of these get set below */
810   GCPRO3 (name, default_directory, handler);
811
812   CHECK_STRING (name);
813
814   /* If the file name has special constructs in it,
815      call the corresponding file handler.  */
816   handler = Ffind_file_name_handler (name, Qexpand_file_name);
817   if (!NILP (handler))
818     RETURN_UNGCPRO (call3_check_string (handler, Qexpand_file_name,
819                                         name, default_directory));
820
821   /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted.  */
822   if (NILP (default_directory))
823     default_directory = current_buffer->directory;
824   if (! STRINGP (default_directory))
825     default_directory = build_string ("/");
826
827   if (!NILP (default_directory))
828     {
829       handler = Ffind_file_name_handler (default_directory, Qexpand_file_name);
830       if (!NILP (handler))
831         RETURN_UNGCPRO (call3 (handler, Qexpand_file_name,
832                                name, default_directory));
833     }
834
835   o = XSTRING_DATA (default_directory);
836
837   /* Make sure DEFAULT_DIRECTORY is properly expanded.
838      It would be better to do this down below where we actually use
839      default_directory.  Unfortunately, calling Fexpand_file_name recursively
840      could invoke GC, and the strings might be relocated.  This would
841      be annoying because we have pointers into strings lying around
842      that would need adjusting, and people would add new pointers to
843      the code and forget to adjust them, resulting in intermittent bugs.
844      Putting this call here avoids all that crud.
845
846      The EQ test avoids infinite recursion.  */
847   if (! NILP (default_directory) && !EQ (default_directory, name)
848       /* Save time in some common cases - as long as default_directory
849          is not relative, it can be canonicalized with name below (if it
850          is needed at all) without requiring it to be expanded now.  */
851 #ifdef WIN32_FILENAMES
852       /* Detect Windows file names with drive specifiers.  */
853       && ! (IS_DRIVE (o[0]) && (IS_DEVICE_SEP (o[1]) && IS_DIRECTORY_SEP (o[2])))
854       /* Detect Windows file names in UNC format.  */
855       && ! (IS_DIRECTORY_SEP (o[0]) && IS_DIRECTORY_SEP (o[1]))
856 #endif /* not WIN32_FILENAMES */
857 #ifndef WIN32_NATIVE
858       /* Detect Unix absolute file names (/... alone is not absolute on
859          Windows).  */
860       && ! (IS_DIRECTORY_SEP (o[0]))
861 #endif /* not WIN32_NATIVE */
862       )
863
864     default_directory = Fexpand_file_name (default_directory, Qnil);
865
866 #ifdef FILE_SYSTEM_CASE
867   name = FILE_SYSTEM_CASE (name);
868 #endif
869
870  /* #### dmoore - this is ugly, clean this up.  Looks like nm pointing
871     into name should be safe during all of this, though. */
872   nm = XSTRING_DATA (name);
873
874 #ifdef WIN32_FILENAMES
875   /* We will force directory separators to be either all \ or /, so make
876      a local copy to modify, even if there ends up being no change. */
877   nm = (Bufbyte *) strcpy ((char *) alloca (strlen ((char *) nm) + 1),
878                            (char *) nm);
879
880   /* Find and remove drive specifier if present; this makes nm absolute
881      even if the rest of the name appears to be relative. */
882   {
883     Bufbyte *colon = (Bufbyte *) strrchr ((char *)nm, ':');
884
885     if (colon)
886       {
887       /* Only recognize colon as part of drive specifier if there is a
888          single alphabetic character preceding the colon (and if the
889          character before the drive letter, if present, is a directory
890          separator); this is to support the remote system syntax used by
891          ange-ftp, and the "po:username" syntax for POP mailboxes. */
892     look_again:
893       if (nm == colon)
894         nm++;
895       else if (IS_DRIVE (colon[-1])
896                && (colon == nm + 1 || IS_DIRECTORY_SEP (colon[-2])))
897         {
898           drive = colon[-1];
899           nm = colon + 1;
900         }
901       else
902         {
903           while (--colon >= nm)
904             if (colon[0] == ':')
905               goto look_again;
906         }
907       }
908   }
909
910   /* If we see "c://somedir", we want to strip the first slash after the
911      colon when stripping the drive letter.  Otherwise, this expands to
912      "//somedir".  */
913   if (drive && IS_DIRECTORY_SEP (nm[0]) && IS_DIRECTORY_SEP (nm[1]))
914     nm++;
915 #endif /* WIN32_FILENAMES */
916
917   /* If nm is absolute, look for /./ or /../ sequences; if none are
918      found, we can probably return right away.  We will avoid allocating
919      a new string if name is already fully expanded.  */
920   if (
921       IS_DIRECTORY_SEP (nm[0])
922 #ifdef WIN32_NATIVE
923       && (drive || IS_DIRECTORY_SEP (nm[1]))
924 #endif
925       )
926     {
927       /* If it turns out that the filename we want to return is just a
928          suffix of FILENAME, we don't need to go through and edit
929          things; we just need to construct a new string using data
930          starting at the middle of FILENAME.  If we set lose to a
931          non-zero value, that means we've discovered that we can't do
932          that cool trick.  */
933       int lose = 0;
934
935       p = nm;
936       while (*p)
937         {
938           /* Since we know the name is absolute, we can assume that each
939              element starts with a "/".  */
940
941           /* "." and ".." are hairy.  */
942           if (IS_DIRECTORY_SEP (p[0])
943               && p[1] == '.'
944               && (IS_DIRECTORY_SEP (p[2])
945                   || p[2] == 0
946                   || (p[2] == '.' && (IS_DIRECTORY_SEP (p[3])
947                                       || p[3] == 0))))
948             lose = 1;
949           p++;
950         }
951       if (!lose)
952         {
953 #ifdef WIN32_FILENAMES
954           if (drive || IS_DIRECTORY_SEP (nm[1]))
955             {
956               /* Make sure directories are all separated with / or \ as
957                  desired, but avoid allocation of a new string when not
958                  required. */
959               CORRECT_DIR_SEPS (nm);
960               if (IS_DIRECTORY_SEP (nm[1]))
961                 {
962                   if (strcmp ((char *) nm, (char *) XSTRING_DATA (name)) != 0)
963                     name = build_string ((Bufbyte *) nm);
964                 }
965               /* drive must be set, so this is okay */
966               else if (strcmp ((char *) nm - 2,
967                                (char *) XSTRING_DATA (name)) != 0)
968                 {
969                   name = make_string (nm - 2, p - nm + 2);
970                   XSTRING_DATA (name)[0] = DRIVE_LETTER (drive);
971                   XSTRING_DATA (name)[1] = ':';
972                 }
973               RETURN_UNGCPRO (name);
974             }
975 #endif /* not WIN32_FILENAMES */
976 #ifndef WIN32_NATIVE
977           if (nm == XSTRING_DATA (name))
978             RETURN_UNGCPRO (name);
979           RETURN_UNGCPRO (build_string ((char *) nm));
980 #endif /* not WIN32_NATIVE */
981         }
982     }
983
984   /* At this point, nm might or might not be an absolute file name.  We
985      need to expand ~ or ~user if present, otherwise prefix nm with
986      default_directory if nm is not absolute, and finally collapse /./
987      and /foo/../ sequences.
988
989      We set newdir to be the appropriate prefix if one is needed:
990        - the relevant user directory if nm starts with ~ or ~user
991        - the specified drive's working dir (DOS/NT only) if nm does not
992          start with /
993        - the value of default_directory.
994
995      Note that these prefixes are not guaranteed to be absolute (except
996      for the working dir of a drive).  Therefore, to ensure we always
997      return an absolute name, if the final prefix is not absolute we
998      append it to the current working directory.  */
999
1000   newdir = 0;
1001
1002   if (nm[0] == '~')             /* prefix ~ */
1003     {
1004       if (IS_DIRECTORY_SEP (nm[1])
1005           || nm[1] == 0)        /* ~ by itself */
1006         {
1007           Extbyte *newdir_external = get_home_directory ();
1008
1009           if (newdir_external == NULL)
1010             newdir = (Bufbyte *) "";
1011           else
1012             TO_INTERNAL_FORMAT (C_STRING, newdir_external,
1013                                 C_STRING_ALLOCA, (* ((char **) &newdir)),
1014                                 Qfile_name);
1015
1016           nm++;
1017 #ifdef WIN32_FILENAMES
1018           collapse_newdir = 0;
1019 #endif
1020         }
1021       else                      /* ~user/filename */
1022         {
1023           for (p = nm; *p && (!IS_DIRECTORY_SEP (*p)); p++)
1024             DO_NOTHING;
1025           o = (Bufbyte *) alloca (p - nm + 1);
1026           memcpy (o, (char *) nm, p - nm);
1027           o [p - nm] = 0;
1028
1029           /* #### While NT is single-user (for the moment) you still
1030              can have multiple user profiles users defined, each with
1031              its HOME.  So maybe possibly we should think about handling
1032              ~user. --ben */
1033 #ifndef WIN32_NATIVE
1034 #ifdef CYGWIN
1035           if ((user = user_login_name (NULL)) != NULL)
1036             {
1037               /* Does the user login name match the ~name? */
1038               if (strcmp (user, (char *) o + 1) == 0)
1039                 {
1040                   newdir = (Bufbyte *) get_home_directory();
1041                   nm = p;
1042                 }
1043             }
1044           if (! newdir)
1045             {
1046 #endif /* CYGWIN */
1047           /* Jamie reports that getpwnam() can get wedged by SIGIO/SIGALARM
1048              occurring in it. (It can call select()). */
1049           slow_down_interrupts ();
1050           pw = (struct passwd *) getpwnam ((char *) o + 1);
1051           speed_up_interrupts ();
1052           if (pw)
1053             {
1054               newdir = (Bufbyte *) pw -> pw_dir;
1055               nm = p;
1056             }
1057 #ifdef CYGWIN
1058             }
1059 #endif
1060 #endif /* not WIN32_NATIVE */
1061
1062           /* If we don't find a user of that name, leave the name
1063              unchanged; don't move nm forward to p.  */
1064         }
1065     }
1066
1067 #ifdef WIN32_FILENAMES
1068   /* On DOS and Windows, nm is absolute if a drive name was specified;
1069      use the drive's current directory as the prefix if needed.  */
1070   if (!newdir && drive)
1071     {
1072 #ifdef WIN32_NATIVE
1073       /* Get default directory if needed to make nm absolute. */
1074       if (!IS_DIRECTORY_SEP (nm[0]))
1075         {
1076           newdir = (Bufbyte *) alloca (MAXPATHLEN + 1);
1077           if (!_getdcwd (toupper (drive) - 'A' + 1, newdir, MAXPATHLEN))
1078             newdir = NULL;
1079         }
1080 #endif /* WIN32_NATIVE */
1081       if (!newdir)
1082         {
1083           /* Either nm starts with /, or drive isn't mounted. */
1084           newdir = (Bufbyte *) alloca (4);
1085           newdir[0] = DRIVE_LETTER (drive);
1086           newdir[1] = ':';
1087           newdir[2] = '/';
1088           newdir[3] = 0;
1089         }
1090     }
1091 #endif /* WIN32_FILENAMES */
1092
1093   /* Finally, if no prefix has been specified and nm is not absolute,
1094      then it must be expanded relative to default_directory. */
1095
1096   if (1
1097 #ifndef WIN32_NATIVE
1098       /* /... alone is not absolute on DOS and Windows. */
1099       && !IS_DIRECTORY_SEP (nm[0])
1100 #endif
1101 #ifdef WIN32_FILENAMES
1102       && !(IS_DIRECTORY_SEP (nm[0]) && IS_DIRECTORY_SEP (nm[1]))
1103 #endif
1104       && !newdir)
1105     {
1106       newdir = XSTRING_DATA (default_directory);
1107     }
1108
1109 #ifdef WIN32_FILENAMES
1110   if (newdir)
1111     {
1112       /* First ensure newdir is an absolute name. */
1113       if (
1114           /* Detect Windows file names with drive specifiers.  */
1115           ! (IS_DRIVE (newdir[0])
1116              && IS_DEVICE_SEP (newdir[1]) && IS_DIRECTORY_SEP (newdir[2]))
1117           /* Detect Windows file names in UNC format.  */
1118           && ! (IS_DIRECTORY_SEP (newdir[0]) && IS_DIRECTORY_SEP (newdir[1]))
1119           /* Detect drive spec by itself */
1120           && ! (IS_DEVICE_SEP (newdir[1]) && newdir[2] == 0)
1121           /* Detect unix format.  */
1122 #ifndef WIN32_NATIVE
1123           && ! (IS_DIRECTORY_SEP (newdir[0]))
1124 #endif
1125           )
1126         {
1127           /* Effectively, let newdir be (expand-file-name newdir cwd).
1128              Because of the admonition against calling expand-file-name
1129              when we have pointers into lisp strings, we accomplish this
1130              indirectly by prepending newdir to nm if necessary, and using
1131              cwd (or the wd of newdir's drive) as the new newdir. */
1132
1133           if (IS_DRIVE (newdir[0]) && newdir[1] == ':')
1134             {
1135               drive = newdir[0];
1136               newdir += 2;
1137             }
1138           if (!IS_DIRECTORY_SEP (nm[0]))
1139             {
1140               Bufbyte *tmp = (Bufbyte *) alloca (strlen ((char *) newdir) +
1141                                                  strlen ((char *) nm) + 2);
1142               file_name_as_directory ((char *) tmp, (char *) newdir);
1143               strcat ((char *) tmp, (char *) nm);
1144               nm = tmp;
1145             }
1146           newdir = (Bufbyte *) alloca (MAXPATHLEN + 1);
1147           if (drive)
1148             {
1149 #ifdef WIN32_NATIVE
1150               if (!_getdcwd (toupper (drive) - 'A' + 1, newdir, MAXPATHLEN))
1151 #endif
1152                 newdir = (Bufbyte *) "/";
1153             }
1154           else
1155             getcwd ((char *) newdir, MAXPATHLEN);
1156         }
1157
1158       /* Strip off drive name from prefix, if present. */
1159       if (IS_DRIVE (newdir[0]) && newdir[1] == ':')
1160         {
1161           drive = newdir[0];
1162           newdir += 2;
1163         }
1164
1165       /* Keep only a prefix from newdir if nm starts with slash
1166          (/ /server/share for UNC, nothing otherwise).  */
1167       if (IS_DIRECTORY_SEP (nm[0]) 
1168 #ifndef WIN32_NATIVE
1169           && IS_DIRECTORY_SEP (nm[1])
1170 #endif
1171           && collapse_newdir)
1172         {
1173           if (IS_DIRECTORY_SEP (newdir[0]) && IS_DIRECTORY_SEP (newdir[1]))
1174             {
1175               newdir =
1176                 (Bufbyte *)
1177                   strcpy ((char *) alloca (strlen ((char *) newdir) + 1),
1178                           (char *) newdir);
1179               p = newdir + 2;
1180               while (*p && !IS_DIRECTORY_SEP (*p)) p++;
1181               p++;
1182               while (*p && !IS_DIRECTORY_SEP (*p)) p++;
1183               *p = 0;
1184             }
1185           else
1186             newdir = (Bufbyte *) "";
1187         }
1188     }
1189 #endif /* WIN32_FILENAMES */
1190
1191   if (newdir)
1192     {
1193       /* Get rid of any slash at the end of newdir, unless newdir is
1194          just // (an incomplete UNC name).  */
1195       length = strlen ((char *) newdir);
1196       if (length > 1 && IS_DIRECTORY_SEP (newdir[length - 1])
1197 #ifdef WIN32_FILENAMES
1198           && !(length == 2 && IS_DIRECTORY_SEP (newdir[0]))
1199 #endif
1200           )
1201         {
1202           Bufbyte *temp = (Bufbyte *) alloca (length);
1203           memcpy (temp, newdir, length - 1);
1204           temp[length - 1] = 0;
1205           newdir = temp;
1206         }
1207       tlen = length + 1;
1208     }
1209   else
1210     tlen = 0;
1211
1212   /* Now concatenate the directory and name to new space in the stack frame */
1213   tlen += strlen ((char *) nm) + 1;
1214 #ifdef WIN32_FILENAMES
1215   /* Add reserved space for drive name.  (The Microsoft x86 compiler
1216      produces incorrect code if the following two lines are combined.)  */
1217   target = (Bufbyte *) alloca (tlen + 2);
1218   target += 2;
1219 #else  /* not WIN32_FILENAMES */
1220   target = (Bufbyte *) alloca (tlen);
1221 #endif /* not WIN32_FILENAMES */
1222   *target = 0;
1223
1224   if (newdir)
1225     {
1226       if (nm[0] == 0 || IS_DIRECTORY_SEP (nm[0]))
1227         strcpy ((char *) target, (char *) newdir);
1228       else
1229         file_name_as_directory ((char *) target, (char *) newdir);
1230     }
1231
1232   strcat ((char *) target, (char *) nm);
1233
1234   /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */
1235
1236   /* Now canonicalize by removing /. and /foo/.. if they appear.  */
1237
1238   p = target;
1239   o = target;
1240
1241   while (*p)
1242     {
1243       if (!IS_DIRECTORY_SEP (*p))
1244         {
1245           *o++ = *p++;
1246         }
1247       else if (IS_DIRECTORY_SEP (p[0])
1248                && p[1] == '.'
1249                && (IS_DIRECTORY_SEP (p[2])
1250                    || p[2] == 0))
1251         {
1252           /* If "/." is the entire filename, keep the "/".  Otherwise,
1253              just delete the whole "/.".  */
1254           if (o == target && p[2] == '\0')
1255             *o++ = *p;
1256           p += 2;
1257         }
1258       else if (IS_DIRECTORY_SEP (p[0]) && p[1] == '.' && p[2] == '.'
1259                /* `/../' is the "superroot" on certain file systems.  */
1260                && o != target
1261                && (IS_DIRECTORY_SEP (p[3]) || p[3] == 0))
1262         {
1263           while (o != target && (--o) && !IS_DIRECTORY_SEP (*o))
1264             ;
1265           /* Keep initial / only if this is the whole name.  */
1266           if (o == target && IS_ANY_SEP (*o) && p[3] == 0)
1267             ++o;
1268           p += 3;
1269         }
1270 #ifdef WIN32_FILENAMES
1271       /* if drive is set, we're not dealing with an UNC, so
1272          multiple dir-seps are redundant (and reportedly cause trouble
1273          under win95) */
1274       else if (drive && IS_DIRECTORY_SEP (p[0]) && IS_DIRECTORY_SEP (p[1]))
1275           ++p;
1276 #endif
1277       else
1278         {
1279           *o++ = *p++;
1280         }
1281     }
1282
1283 #ifdef WIN32_FILENAMES
1284   /* At last, set drive name, except for network file name.  */
1285   if (drive)
1286     {
1287       target -= 2;
1288       target[0] = DRIVE_LETTER (drive);
1289       target[1] = ':';
1290     }
1291 #ifdef WIN32_NATIVE
1292   else
1293     {
1294       assert (IS_DIRECTORY_SEP (target[0]) && IS_DIRECTORY_SEP (target[1]));
1295     }
1296 #endif
1297   CORRECT_DIR_SEPS (target);
1298 #endif /* WIN32_FILENAMES */
1299
1300   RETURN_UNGCPRO (make_string (target, o - target));
1301 }
1302
1303 DEFUN ("file-truename", Ffile_truename, 1, 2, 0, /*
1304 Return the canonical name of FILENAME.
1305 Second arg DEFAULT is directory to start with if FILENAME is relative
1306  (does not start with slash); if DEFAULT is nil or missing,
1307  the current buffer's value of `default-directory' is used.
1308 No component of the resulting pathname will be a symbolic link, as
1309  in the realpath() function.
1310 */
1311        (filename, default_))
1312 {
1313   /* This function can GC.  GC checked 2000-07-28 ben. */
1314   Lisp_Object expanded_name;
1315   struct gcpro gcpro1;
1316
1317   CHECK_STRING (filename);
1318
1319   expanded_name = Fexpand_file_name (filename, default_);
1320
1321   if (!STRINGP (expanded_name))
1322     return Qnil;
1323
1324   GCPRO1 (expanded_name);
1325
1326   {
1327     Lisp_Object handler =
1328       Ffind_file_name_handler (expanded_name, Qfile_truename);
1329
1330     if (!NILP (handler))
1331       RETURN_UNGCPRO
1332         (call2_check_string (handler, Qfile_truename, expanded_name));
1333   }
1334
1335   {
1336     char resolved_path[MAXPATHLEN];
1337     Extbyte *path;
1338     Extbyte *p;
1339     Extcount elen;
1340
1341     TO_EXTERNAL_FORMAT (LISP_STRING, expanded_name,
1342                         ALLOCA, (path, elen),
1343                         Qfile_name);
1344
1345 #if defined(WIN32_FILENAMES) && defined(CYGWIN)
1346     /* When using win32 filenames in cygwin we want file-truename to
1347        detect that c:/windows == /windows for example. */
1348     if ((IS_DIRECTORY_SEP (path[0]) 
1349          && (elen == 1 || !IS_DIRECTORY_SEP (path[1])))
1350         || (isalpha (path[0])
1351             && (elen == 1 || !IS_DEVICE_SEP (path[1])))) {
1352       int ltwff2 =
1353         cygwin_posix_to_win32_path_list_buf_size (path);
1354       p = (Bufbyte *) alloca (ltwff2);
1355       cygwin_posix_to_win32_path_list (path, p);
1356       path = p;
1357     }
1358 #endif
1359     p = path;
1360
1361     if (elen > MAXPATHLEN)
1362       goto toolong;
1363
1364     /* Try doing it all at once. */
1365     /* !! Does realpath() Mule-encapsulate?
1366        Answer: Nope! So we do it above */
1367     if (!xrealpath ((char *) path, resolved_path))
1368       {
1369         /* Didn't resolve it -- have to do it one component at a time. */
1370         /* "realpath" is a typically useless, stupid un*x piece of crap.
1371            It claims to return a useful value in the "error" case, but since
1372            there is no indication provided of how far along the pathname
1373            the function went before erring, there is no way to use the
1374            partial result returned.  What a piece of junk.
1375
1376            The above comment refers to historical versions of
1377            realpath().  The Unix98 specs state:
1378
1379            "On successful completion, realpath() returns a
1380            pointer to the resolved name. Otherwise, realpath()
1381            returns a null pointer and sets errno to indicate the
1382            error, and the contents of the buffer pointed to by
1383            resolved_name are undefined."
1384
1385            Since we depend on undocumented semantics of various system realpath()s,
1386            we just use our own version in realpath.c. */
1387         for (;;)
1388           {
1389             Extbyte *pos;
1390
1391 #ifdef WIN32_FILENAMES
1392             if (IS_DRIVE (p[0]) && IS_DEVICE_SEP (p[1]) 
1393                 && IS_DIRECTORY_SEP (p[2]))
1394               /* don't test c: on windows */
1395               p = p+2;
1396             else if (IS_DIRECTORY_SEP (p[0]) && IS_DIRECTORY_SEP (p[1]))
1397               /* start after // */
1398               p = p+1;
1399 #endif
1400             for (pos = p + 1; pos < path + elen; pos++)
1401               if (IS_DIRECTORY_SEP (*pos))
1402                 {
1403                   *(p = pos) = 0;
1404                   break;
1405                 }
1406             if (p != pos)
1407               p = 0;
1408
1409             if (xrealpath ((char *) path, resolved_path))
1410               {
1411                 if (p)
1412                   *p = DIRECTORY_SEP;
1413                 else
1414                   break;
1415
1416               }
1417             else if (errno == ENOENT || errno == EACCES)
1418               {
1419                 /* Failed on this component.  Just tack on the rest of
1420                    the string and we are done. */
1421                 int rlen = strlen (resolved_path);
1422
1423                 /* "On failure, it returns NULL, sets errno to indicate
1424                    the error, and places in resolved_path the absolute pathname
1425                    of the path component which could not be resolved." */
1426
1427                 if (p)
1428                   {
1429                     int plen = elen - (p - path);
1430
1431                     if (rlen > 1 && IS_DIRECTORY_SEP (resolved_path[rlen - 1]))
1432                       rlen = rlen - 1;
1433
1434                     if (plen + rlen + 1 > countof (resolved_path))
1435                       goto toolong;
1436
1437                     resolved_path[rlen] = DIRECTORY_SEP;
1438                     memcpy (resolved_path + rlen + 1, p + 1, plen + 1 - 1);
1439                   }
1440                 break;
1441               }
1442             else
1443               goto lose;
1444           }
1445       }
1446
1447     {
1448       Lisp_Object resolved_name;
1449       int rlen = strlen (resolved_path);
1450       if (elen > 0 && IS_DIRECTORY_SEP (XSTRING_BYTE (expanded_name, elen - 1))
1451           && !(rlen > 0 && IS_DIRECTORY_SEP (resolved_path[rlen - 1])))
1452         {
1453           if (rlen + 1 > countof (resolved_path))
1454             goto toolong;
1455           resolved_path[rlen++] = DIRECTORY_SEP;
1456           resolved_path[rlen] = '\0';
1457         }
1458       TO_INTERNAL_FORMAT (DATA, (resolved_path, rlen),
1459                           LISP_STRING, resolved_name,
1460                           Qfile_name);
1461       RETURN_UNGCPRO (resolved_name);
1462     }
1463
1464   toolong:
1465     errno = ENAMETOOLONG;
1466     goto lose;
1467   lose:
1468     report_file_error ("Finding truename", list1 (expanded_name));
1469   }
1470   RETURN_UNGCPRO (Qnil);
1471 }
1472
1473 \f
1474 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name, 1, 1, 0, /*
1475 Substitute environment variables referred to in FILENAME.
1476 `$FOO' where FOO is an environment variable name means to substitute
1477 the value of that variable.  The variable name should be terminated
1478 with a character, not a letter, digit or underscore; otherwise, enclose
1479 the entire variable name in braces.
1480 If `/~' appears, all of FILENAME through that `/' is discarded.
1481 */
1482        (filename))
1483 {
1484   /* This function can GC.  GC checked 2000-07-28 ben. */
1485   Bufbyte *nm;
1486
1487   Bufbyte *s, *p, *o, *x, *endp;
1488   Bufbyte *target = 0;
1489   int total = 0;
1490   int substituted = 0;
1491   Bufbyte *xnm;
1492   Lisp_Object handler;
1493
1494   CHECK_STRING (filename);
1495
1496   /* If the file name has special constructs in it,
1497      call the corresponding file handler.  */
1498   handler = Ffind_file_name_handler (filename, Qsubstitute_in_file_name);
1499   if (!NILP (handler))
1500     return call2_check_string_or_nil (handler, Qsubstitute_in_file_name,
1501                                       filename);
1502
1503   nm = XSTRING_DATA (filename);
1504   endp = nm + XSTRING_LENGTH (filename);
1505
1506   /* If /~ or // appears, discard everything through first slash. */
1507
1508   for (p = nm; p != endp; p++)
1509     {
1510       if ((p[0] == '~'
1511 #if defined (WIN32_FILENAMES)
1512            /* // at start of file name is meaningful in WindowsNT systems */
1513            || (IS_DIRECTORY_SEP (p[0]) && p - 1 != nm)
1514 #else /* not (WIN32_FILENAMES) */
1515            || IS_DIRECTORY_SEP (p[0])
1516 #endif /* not (WIN32_FILENAMES) */
1517            )
1518           && p != nm
1519           && (IS_DIRECTORY_SEP (p[-1])))
1520         {
1521           nm = p;
1522           substituted = 1;
1523         }
1524 #ifdef WIN32_FILENAMES
1525       /* see comment in expand-file-name about drive specifiers */
1526       else if (IS_DRIVE (p[0]) && p[1] == ':'
1527                && p > nm && IS_DIRECTORY_SEP (p[-1]))
1528         {
1529           nm = p;
1530           substituted = 1;
1531         }
1532 #endif /* WIN32_FILENAMES */
1533     }
1534
1535   /* See if any variables are substituted into the string
1536      and find the total length of their values in `total' */
1537
1538   for (p = nm; p != endp;)
1539     if (*p != '$')
1540       p++;
1541     else
1542       {
1543         p++;
1544         if (p == endp)
1545           goto badsubst;
1546         else if (*p == '$')
1547           {
1548             /* "$$" means a single "$" */
1549             p++;
1550             total -= 1;
1551             substituted = 1;
1552             continue;
1553           }
1554         else if (*p == '{')
1555           {
1556             o = ++p;
1557             while (p != endp && *p != '}') p++;
1558             if (*p != '}') goto missingclose;
1559             s = p;
1560           }
1561         else
1562           {
1563             o = p;
1564             while (p != endp && (isalnum (*p) || *p == '_')) p++;
1565             s = p;
1566           }
1567
1568         /* Copy out the variable name */
1569         target = (Bufbyte *) alloca (s - o + 1);
1570         strncpy ((char *) target, (char *) o, s - o);
1571         target[s - o] = 0;
1572 #ifdef WIN32_NATIVE
1573         strupr (target); /* $home == $HOME etc.  */
1574 #endif /* WIN32_NATIVE */
1575
1576         /* Get variable value */
1577         o = (Bufbyte *) egetenv ((char *) target);
1578         if (!o) goto badvar;
1579         total += strlen ((char *) o);
1580         substituted = 1;
1581       }
1582
1583   if (!substituted)
1584     return filename;
1585
1586   /* If substitution required, recopy the filename and do it */
1587   /* Make space in stack frame for the new copy */
1588   xnm = (Bufbyte *) alloca (XSTRING_LENGTH (filename) + total + 1);
1589   x = xnm;
1590
1591   /* Copy the rest of the name through, replacing $ constructs with values */
1592   for (p = nm; *p;)
1593     if (*p != '$')
1594       *x++ = *p++;
1595     else
1596       {
1597         p++;
1598         if (p == endp)
1599           goto badsubst;
1600         else if (*p == '$')
1601           {
1602             *x++ = *p++;
1603             continue;
1604           }
1605         else if (*p == '{')
1606           {
1607             o = ++p;
1608             while (p != endp && *p != '}') p++;
1609             if (*p != '}') goto missingclose;
1610             s = p++;
1611           }
1612         else
1613           {
1614             o = p;
1615             while (p != endp && (isalnum (*p) || *p == '_')) p++;
1616             s = p;
1617           }
1618
1619         /* Copy out the variable name */
1620         target = (Bufbyte *) alloca (s - o + 1);
1621         strncpy ((char *) target, (char *) o, s - o);
1622         target[s - o] = 0;
1623 #ifdef WIN32_NATIVE
1624         strupr (target); /* $home == $HOME etc.  */
1625 #endif /* WIN32_NATIVE */
1626
1627         /* Get variable value */
1628         o = (Bufbyte *) egetenv ((char *) target);
1629         if (!o)
1630           goto badvar;
1631
1632         strcpy ((char *) x, (char *) o);
1633         x += strlen ((char *) o);
1634       }
1635
1636   *x = 0;
1637
1638   /* If /~ or // appears, discard everything through first slash. */
1639
1640   for (p = xnm; p != x; p++)
1641     if ((p[0] == '~'
1642 #if defined (WIN32_FILENAMES)
1643          || (IS_DIRECTORY_SEP (p[0]) && p - 1 != xnm)
1644 #else /* not WIN32_FILENAMES */
1645          || IS_DIRECTORY_SEP (p[0])
1646 #endif /* not WIN32_FILENAMES */
1647          )
1648         /* don't do p[-1] if that would go off the beginning --jwz */
1649         && p != nm && p > xnm && IS_DIRECTORY_SEP (p[-1]))
1650       xnm = p;
1651 #ifdef WIN32_FILENAMES
1652     else if (IS_DRIVE (p[0]) && p[1] == ':'
1653              && p > nm && IS_DIRECTORY_SEP (p[-1]))
1654         xnm = p;
1655 #endif
1656
1657   return make_string (xnm, x - xnm);
1658
1659  badsubst:
1660   syntax_error ("Bad format environment-variable substitution", filename);
1661  missingclose:
1662   syntax_error ("Missing \"}\" in environment-variable substitution",
1663                 filename);
1664  badvar:
1665   syntax_error_2 ("Substituting nonexistent environment variable",
1666                   filename, build_string ((char *) target));
1667
1668   /* NOTREACHED */
1669   return Qnil;  /* suppress compiler warning */
1670 }
1671 \f
1672 /* A slightly faster and more convenient way to get
1673    (directory-file-name (expand-file-name FOO)).  */
1674
1675 Lisp_Object
1676 expand_and_dir_to_file (Lisp_Object filename, Lisp_Object defdir)
1677 {
1678   /* This function can call Lisp.  GC checked 2000-07-28 ben */
1679   Lisp_Object abspath;
1680   struct gcpro gcpro1;
1681
1682   abspath = Fexpand_file_name (filename, defdir);
1683   GCPRO1 (abspath);
1684   /* Remove final slash, if any (unless path is root).
1685      stat behaves differently depending!  */
1686   if (XSTRING_LENGTH (abspath) > 1
1687       && IS_DIRECTORY_SEP (XSTRING_BYTE (abspath, XSTRING_LENGTH (abspath) - 1))
1688       && !IS_DEVICE_SEP (XSTRING_BYTE (abspath, XSTRING_LENGTH (abspath) - 2)))
1689     /* We cannot take shortcuts; they might be wrong for magic file names.  */
1690     abspath = Fdirectory_file_name (abspath);
1691   UNGCPRO;
1692   return abspath;
1693 }
1694 \f
1695 /* Signal an error if the file ABSNAME already exists.
1696    If INTERACTIVE is nonzero, ask the user whether to proceed,
1697    and bypass the error if the user says to go ahead.
1698    QUERYSTRING is a name for the action that is being considered
1699    to alter the file.
1700    *STATPTR is used to store the stat information if the file exists.
1701    If the file does not exist, STATPTR->st_mode is set to 0.  */
1702
1703 static void
1704 barf_or_query_if_file_exists (Lisp_Object absname, const char *querystring,
1705                               int interactive, struct stat *statptr)
1706 {
1707   /* This function can call Lisp.  GC checked 2000-07-28 ben */
1708   struct stat statbuf;
1709
1710   /* stat is a good way to tell whether the file exists,
1711      regardless of what access permissions it has.  */
1712   if (xemacs_stat ((char *) XSTRING_DATA (absname), &statbuf) >= 0)
1713     {
1714       Lisp_Object tem;
1715
1716       if (interactive)
1717         {
1718           Lisp_Object prompt;
1719           struct gcpro gcpro1;
1720
1721           prompt = emacs_doprnt_string_c
1722             ((const Bufbyte *) GETTEXT ("File %s already exists; %s anyway? "),
1723              Qnil, -1, XSTRING_DATA (absname),
1724              GETTEXT (querystring));
1725
1726           GCPRO1 (prompt);
1727           tem = call1 (Qyes_or_no_p, prompt);
1728           UNGCPRO;
1729         }
1730       else
1731         tem = Qnil;
1732
1733       if (NILP (tem))
1734         Fsignal (Qfile_already_exists,
1735                  list2 (build_translated_string ("File already exists"),
1736                         absname));
1737       if (statptr)
1738         *statptr = statbuf;
1739     }
1740   else
1741     {
1742       if (statptr)
1743         statptr->st_mode = 0;
1744     }
1745   return;
1746 }
1747
1748 DEFUN ("copy-file", Fcopy_file, 2, 4,
1749        "fCopy file: \nFCopy %s to file: \np\nP", /*
1750 Copy FILENAME to NEWNAME.  Both args must be strings.
1751 Signals a `file-already-exists' error if file NEWNAME already exists,
1752 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.
1753 A number as third arg means request confirmation if NEWNAME already exists.
1754 This is what happens in interactive use with M-x.
1755 Fourth arg KEEP-TIME non-nil means give the new file the same
1756 last-modified time as the old one.  (This works on only some systems.)
1757 A prefix arg makes KEEP-TIME non-nil.
1758 */
1759        (filename, newname, ok_if_already_exists, keep_time))
1760 {
1761   /* This function can call Lisp.  GC checked 2000-07-28 ben */
1762   int ifd, ofd, n;
1763   char buf[16 * 1024];
1764   struct stat st, out_st;
1765   Lisp_Object handler;
1766   int speccount = specpdl_depth ();
1767   struct gcpro gcpro1, gcpro2;
1768   /* Lisp_Object args[6]; */
1769   int input_file_statable_p;
1770
1771   GCPRO2 (filename, newname);
1772   CHECK_STRING (filename);
1773   CHECK_STRING (newname);
1774   filename = Fexpand_file_name (filename, Qnil);
1775   newname = Fexpand_file_name (newname, Qnil);
1776
1777   /* If the input file name has special constructs in it,
1778      call the corresponding file handler.  */
1779   handler = Ffind_file_name_handler (filename, Qcopy_file);
1780   /* Likewise for output file name.  */
1781   if (NILP (handler))
1782     handler = Ffind_file_name_handler (newname, Qcopy_file);
1783   if (!NILP (handler))
1784   {
1785     UNGCPRO;
1786     return call5 (handler, Qcopy_file, filename, newname,
1787                   ok_if_already_exists, keep_time);
1788   }
1789
1790   /* When second argument is a directory, copy the file into it.
1791      (copy-file "foo" "bar/") == (copy-file "foo" "bar/foo")
1792    */
1793   if (!NILP (Ffile_directory_p (newname)))
1794     {
1795       Lisp_Object args[3];
1796       struct gcpro ngcpro1;
1797       int i = 1;
1798
1799       args[0] = newname;
1800       args[1] = Qnil; args[2] = Qnil;
1801       NGCPRO1 (*args);
1802       ngcpro1.nvars = 3;
1803       if (!IS_DIRECTORY_SEP (XSTRING_BYTE (newname,
1804                                            XSTRING_LENGTH (newname) - 1)))
1805
1806         args[i++] = Fchar_to_string (Vdirectory_sep_char);
1807       args[i++] = Ffile_name_nondirectory (filename);
1808       newname = Fconcat (i, args);
1809       NUNGCPRO;
1810     }
1811
1812   if (NILP (ok_if_already_exists)
1813       || INTP (ok_if_already_exists))
1814     barf_or_query_if_file_exists (newname, "copy to it",
1815                                   INTP (ok_if_already_exists), &out_st);
1816   else if (xemacs_stat ((const char *) XSTRING_DATA (newname), &out_st) < 0)
1817     out_st.st_mode = 0;
1818
1819   ifd = interruptible_open ((char *) XSTRING_DATA (filename), O_RDONLY | OPEN_BINARY, 0);
1820   if (ifd < 0)
1821     report_file_error ("Opening input file", list1 (filename));
1822
1823   record_unwind_protect (close_file_unwind, make_int (ifd));
1824
1825   /* We can only copy regular files and symbolic links.  Other files are not
1826      copyable by us. */
1827   input_file_statable_p = (fstat (ifd, &st) >= 0);
1828
1829 #ifndef WIN32_NATIVE
1830   if (out_st.st_mode != 0
1831       && st.st_dev == out_st.st_dev && st.st_ino == out_st.st_ino)
1832     {
1833       errno = 0;
1834       report_file_error ("Input and output files are the same",
1835                          list2 (filename, newname));
1836     }
1837 #endif
1838
1839 #if defined (S_ISREG) && defined (S_ISLNK)
1840   if (input_file_statable_p)
1841     {
1842       if (!(S_ISREG (st.st_mode))
1843           /* XEmacs: have to allow S_ISCHR in order to copy /dev/null */
1844 #ifdef S_ISCHR
1845           && !(S_ISCHR (st.st_mode))
1846 #endif
1847           && !(S_ISLNK (st.st_mode)))
1848         {
1849 #if defined (EISDIR)
1850           /* Get a better looking error message. */
1851           errno = EISDIR;
1852 #endif /* EISDIR */
1853         report_file_error ("Non-regular file", list1 (filename));
1854         }
1855     }
1856 #endif /* S_ISREG && S_ISLNK */
1857
1858   ofd = open( (char *) XSTRING_DATA (newname),
1859               O_WRONLY | O_CREAT | O_TRUNC | OPEN_BINARY, CREAT_MODE);
1860   if (ofd < 0)
1861     report_file_error ("Opening output file", list1 (newname));
1862
1863   {
1864     Lisp_Object ofd_locative = noseeum_cons (make_int (ofd), Qnil);
1865
1866     record_unwind_protect (close_file_unwind, ofd_locative);
1867
1868     while ((n = read_allowing_quit (ifd, buf, sizeof (buf))) > 0)
1869     {
1870       if (write_allowing_quit (ofd, buf, n) != n)
1871         report_file_error ("I/O error", list1 (newname));
1872     }
1873
1874     /* Closing the output clobbers the file times on some systems.  */
1875     if (close (ofd) < 0)
1876       report_file_error ("I/O error", list1 (newname));
1877
1878     if (input_file_statable_p)
1879       {
1880         if (!NILP (keep_time))
1881           {
1882             EMACS_TIME atime, mtime;
1883             EMACS_SET_SECS_USECS (atime, st.st_atime, 0);
1884             EMACS_SET_SECS_USECS (mtime, st.st_mtime, 0);
1885             if (set_file_times (newname, atime, mtime))
1886               report_file_error ("I/O error", list1 (newname));
1887           }
1888         chmod ((const char *) XSTRING_DATA (newname),
1889                st.st_mode & 07777);
1890       }
1891
1892     /* We'll close it by hand */
1893     XCAR (ofd_locative) = Qnil;
1894
1895     /* Close ifd */
1896     unbind_to (speccount, Qnil);
1897   }
1898
1899   UNGCPRO;
1900   return Qnil;
1901 }
1902 \f
1903 DEFUN ("make-directory-internal", Fmake_directory_internal, 1, 1, 0, /*
1904 Create a directory.  One argument, a file name string.
1905 */
1906        (dirname_))
1907 {
1908   /* This function can GC.  GC checked 1997.04.06. */
1909   char dir [MAXPATHLEN];
1910   Lisp_Object handler;
1911   struct gcpro gcpro1;
1912
1913   CHECK_STRING (dirname_);
1914   dirname_ = Fexpand_file_name (dirname_, Qnil);
1915
1916   GCPRO1 (dirname_);
1917   handler = Ffind_file_name_handler (dirname_, Qmake_directory_internal);
1918   UNGCPRO;
1919   if (!NILP (handler))
1920     return (call2 (handler, Qmake_directory_internal, dirname_));
1921
1922   if (XSTRING_LENGTH (dirname_) > (Bytecount) (sizeof (dir) - 1))
1923     {
1924       return Fsignal (Qfile_error,
1925                       list3 (build_translated_string ("Creating directory"),
1926                              build_translated_string ("pathname too long"),
1927                              dirname_));
1928     }
1929   strncpy (dir, (char *) XSTRING_DATA (dirname_),
1930            XSTRING_LENGTH (dirname_) + 1);
1931
1932   if (dir [XSTRING_LENGTH (dirname_) - 1] == '/')
1933     dir [XSTRING_LENGTH (dirname_) - 1] = 0;
1934
1935   if (mkdir (dir, 0777) != 0)
1936     report_file_error ("Creating directory", list1 (dirname_));
1937
1938   return Qnil;
1939 }
1940
1941 DEFUN ("delete-directory", Fdelete_directory, 1, 1, "FDelete directory: ", /*
1942 Delete a directory.  One argument, a file name or directory name string.
1943 */
1944        (dirname_))
1945 {
1946   /* This function can GC.  GC checked 1997.04.06. */
1947   Lisp_Object handler;
1948   struct gcpro gcpro1;
1949
1950   CHECK_STRING (dirname_);
1951
1952   GCPRO1 (dirname_);
1953   dirname_ = Fexpand_file_name (dirname_, Qnil);
1954   dirname_ = Fdirectory_file_name (dirname_);
1955
1956   handler = Ffind_file_name_handler (dirname_, Qdelete_directory);
1957   UNGCPRO;
1958   if (!NILP (handler))
1959     return (call2 (handler, Qdelete_directory, dirname_));
1960
1961   if (rmdir ((char *) XSTRING_DATA (dirname_)) != 0)
1962     report_file_error ("Removing directory", list1 (dirname_));
1963
1964   return Qnil;
1965 }
1966
1967 DEFUN ("delete-file", Fdelete_file, 1, 1, "fDelete file: ", /*
1968 Delete the file named FILENAME (a string).
1969 If FILENAME has multiple names, it continues to exist with the other names.
1970 */
1971        (filename))
1972 {
1973   /* This function can GC.  GC checked 1997.04.06. */
1974   Lisp_Object handler;
1975   struct gcpro gcpro1;
1976
1977   CHECK_STRING (filename);
1978   filename = Fexpand_file_name (filename, Qnil);
1979
1980   GCPRO1 (filename);
1981   handler = Ffind_file_name_handler (filename, Qdelete_file);
1982   UNGCPRO;
1983   if (!NILP (handler))
1984     return call2 (handler, Qdelete_file, filename);
1985
1986   if (0 > unlink ((char *) XSTRING_DATA (filename)))
1987     report_file_error ("Removing old name", list1 (filename));
1988   return Qnil;
1989 }
1990
1991 static Lisp_Object
1992 internal_delete_file_1 (Lisp_Object ignore, Lisp_Object ignore2)
1993 {
1994   return Qt;
1995 }
1996
1997 /* Delete file FILENAME, returning 1 if successful and 0 if failed.  */
1998
1999 int
2000 internal_delete_file (Lisp_Object filename)
2001 {
2002   /* This function can GC.  GC checked 1997.04.06. */
2003   return NILP (condition_case_1 (Qt, Fdelete_file, filename,
2004                                  internal_delete_file_1, Qnil));
2005 }
2006 \f
2007 DEFUN ("rename-file", Frename_file, 2, 3,
2008        "fRename file: \nFRename %s to file: \np", /*
2009 Rename FILENAME as NEWNAME.  Both args must be strings.
2010 If file has names other than FILENAME, it continues to have those names.
2011 Signals a `file-already-exists' error if a file NEWNAME already exists
2012 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2013 A number as third arg means request confirmation if NEWNAME already exists.
2014 This is what happens in interactive use with M-x.
2015 */
2016        (filename, newname, ok_if_already_exists))
2017 {
2018   /* This function can GC.  GC checked 1997.04.06. */
2019   Lisp_Object handler;
2020   struct gcpro gcpro1, gcpro2;
2021
2022   GCPRO2 (filename, newname);
2023   CHECK_STRING (filename);
2024   CHECK_STRING (newname);
2025   filename = Fexpand_file_name (filename, Qnil);
2026   newname = Fexpand_file_name (newname, Qnil);
2027
2028   /* If the file name has special constructs in it,
2029      call the corresponding file handler.  */
2030   handler = Ffind_file_name_handler (filename, Qrename_file);
2031   if (NILP (handler))
2032     handler = Ffind_file_name_handler (newname, Qrename_file);
2033   if (!NILP (handler))
2034   {
2035     UNGCPRO;
2036     return call4 (handler, Qrename_file,
2037                   filename, newname, ok_if_already_exists);
2038   }
2039
2040   /* When second argument is a directory, rename the file into it.
2041      (rename-file "foo" "bar/") == (rename-file "foo" "bar/foo")
2042    */
2043   if (!NILP (Ffile_directory_p (newname)))
2044     {
2045       Lisp_Object args[3];
2046       struct gcpro ngcpro1;
2047       int i = 1;
2048
2049       args[0] = newname;
2050       args[1] = Qnil; args[2] = Qnil;
2051       NGCPRO1 (*args);
2052       ngcpro1.nvars = 3;
2053       if (XSTRING_BYTE (newname, XSTRING_LENGTH (newname) - 1) != '/')
2054         args[i++] = build_string ("/");
2055       args[i++] = Ffile_name_nondirectory (filename);
2056       newname = Fconcat (i, args);
2057       NUNGCPRO;
2058     }
2059
2060   if (NILP (ok_if_already_exists)
2061       || INTP (ok_if_already_exists))
2062     barf_or_query_if_file_exists (newname, "rename to it",
2063                                   INTP (ok_if_already_exists), 0);
2064
2065 /* Syncing with FSF 19.34.6 note: FSF does not have conditional code for
2066    WIN32_NATIVE here; I've removed it.  --marcpa */
2067
2068   /* We have configure check for rename() and emulate using
2069      link()/unlink() if necessary. */
2070   if (0 > rename ((char *) XSTRING_DATA (filename),
2071                   (char *) XSTRING_DATA (newname)))
2072     {
2073       if (errno == EXDEV)
2074         {
2075           Fcopy_file (filename, newname,
2076                       /* We have already prompted if it was an integer,
2077                          so don't have copy-file prompt again.  */
2078                       (NILP (ok_if_already_exists) ? Qnil : Qt),
2079                       Qt);
2080           Fdelete_file (filename);
2081         }
2082       else
2083         {
2084           report_file_error ("Renaming", list2 (filename, newname));
2085         }
2086     }
2087   UNGCPRO;
2088   return Qnil;
2089 }
2090
2091 DEFUN ("add-name-to-file", Fadd_name_to_file, 2, 3,
2092        "fAdd name to file: \nFName to add to %s: \np", /*
2093 Give FILENAME additional name NEWNAME.  Both args must be strings.
2094 Signals a `file-already-exists' error if a file NEWNAME already exists
2095 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2096 A number as third arg means request confirmation if NEWNAME already exists.
2097 This is what happens in interactive use with M-x.
2098 */
2099        (filename, newname, ok_if_already_exists))
2100 {
2101   /* This function can GC.  GC checked 1997.04.06. */
2102   Lisp_Object handler;
2103   struct gcpro gcpro1, gcpro2;
2104
2105   GCPRO2 (filename, newname);
2106   CHECK_STRING (filename);
2107   CHECK_STRING (newname);
2108   filename = Fexpand_file_name (filename, Qnil);
2109   newname = Fexpand_file_name (newname, Qnil);
2110
2111   /* If the file name has special constructs in it,
2112      call the corresponding file handler.  */
2113   handler = Ffind_file_name_handler (filename, Qadd_name_to_file);
2114   if (!NILP (handler))
2115     RETURN_UNGCPRO (call4 (handler, Qadd_name_to_file, filename,
2116                            newname, ok_if_already_exists));
2117
2118   /* If the new name has special constructs in it,
2119      call the corresponding file handler.  */
2120   handler = Ffind_file_name_handler (newname, Qadd_name_to_file);
2121   if (!NILP (handler))
2122     RETURN_UNGCPRO (call4 (handler, Qadd_name_to_file, filename,
2123                            newname, ok_if_already_exists));
2124
2125   if (NILP (ok_if_already_exists)
2126       || INTP (ok_if_already_exists))
2127     barf_or_query_if_file_exists (newname, "make it a new name",
2128                                   INTP (ok_if_already_exists), 0);
2129 /* Syncing with FSF 19.34.6 note: FSF does not report a file error
2130    on NT here. --marcpa */
2131 /* But FSF #defines link as sys_link which is supplied in nt.c. We can't do
2132    that because sysfile.h defines sys_link depending on ENCAPSULATE_LINK.
2133    Reverted to previous behavior pending a working fix. (jhar) */
2134 #if defined(WIN32_NATIVE)
2135   /* Windows does not support this operation.  */
2136   report_file_error ("Adding new name", Flist (2, &filename));
2137 #else /* not defined(WIN32_NATIVE) */
2138
2139   unlink ((char *) XSTRING_DATA (newname));
2140   if (0 > link ((char *) XSTRING_DATA (filename),
2141                 (char *) XSTRING_DATA (newname)))
2142     {
2143       report_file_error ("Adding new name",
2144                          list2 (filename, newname));
2145     }
2146 #endif /* defined(WIN32_NATIVE) */
2147
2148   UNGCPRO;
2149   return Qnil;
2150 }
2151
2152 DEFUN ("make-symbolic-link", Fmake_symbolic_link, 2, 3,
2153        "FMake symbolic link to file: \nFMake symbolic link to file %s: \np", /*
2154 Make a symbolic link to FILENAME, named LINKNAME.  Both args strings.
2155 Signals a `file-already-exists' error if a file LINKNAME already exists
2156 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2157 A number as third arg means request confirmation if LINKNAME already exists.
2158 This happens for interactive use with M-x.
2159 */
2160        (filename, linkname, ok_if_already_exists))
2161 {
2162   /* This function can GC.  GC checked 1997.06.04. */
2163   /* XEmacs change: run handlers even if local machine doesn't have symlinks */
2164   Lisp_Object handler;
2165   struct gcpro gcpro1, gcpro2;
2166
2167   GCPRO2 (filename, linkname);
2168   CHECK_STRING (filename);
2169   CHECK_STRING (linkname);
2170   /* If the link target has a ~, we must expand it to get
2171      a truly valid file name.  Otherwise, do not expand;
2172      we want to permit links to relative file names.  */
2173   if (XSTRING_BYTE (filename, 0) == '~')
2174     filename = Fexpand_file_name (filename, Qnil);
2175   linkname = Fexpand_file_name (linkname, Qnil);
2176
2177   /* If the file name has special constructs in it,
2178      call the corresponding file handler.  */
2179   handler = Ffind_file_name_handler (filename, Qmake_symbolic_link);
2180   if (!NILP (handler))
2181     RETURN_UNGCPRO (call4 (handler, Qmake_symbolic_link, filename, linkname,
2182                            ok_if_already_exists));
2183
2184   /* If the new link name has special constructs in it,
2185      call the corresponding file handler.  */
2186   handler = Ffind_file_name_handler (linkname, Qmake_symbolic_link);
2187   if (!NILP (handler))
2188     RETURN_UNGCPRO (call4 (handler, Qmake_symbolic_link, filename,
2189                            linkname, ok_if_already_exists));
2190
2191 #ifdef S_IFLNK
2192   if (NILP (ok_if_already_exists)
2193       || INTP (ok_if_already_exists))
2194     barf_or_query_if_file_exists (linkname, "make it a link",
2195                                   INTP (ok_if_already_exists), 0);
2196
2197   unlink ((char *) XSTRING_DATA (linkname));
2198   if (0 > symlink ((char *) XSTRING_DATA (filename),
2199                    (char *) XSTRING_DATA (linkname)))
2200     {
2201       report_file_error ("Making symbolic link",
2202                          list2 (filename, linkname));
2203     }
2204 #endif /* S_IFLNK */
2205
2206   UNGCPRO;
2207   return Qnil;
2208 }
2209
2210 #ifdef HPUX_NET
2211
2212 DEFUN ("sysnetunam", Fsysnetunam, 2, 2, 0, /*
2213 Open a network connection to PATH using LOGIN as the login string.
2214 */
2215        (path, login))
2216 {
2217   int netresult;
2218   const char *path_ext;
2219   const char *login_ext;
2220
2221   CHECK_STRING (path);
2222   CHECK_STRING (login);
2223
2224   /* netunam, being a strange-o system call only used once, is not
2225      encapsulated. */
2226
2227   LISP_STRING_TO_EXTERNAL (path, path_ext, Qfile_name);
2228   LISP_STRING_TO_EXTERNAL (login, login_ext, Qnative);
2229
2230   netresult = netunam (path_ext, login_ext);
2231
2232   return netresult == -1 ? Qnil : Qt;
2233 }
2234 #endif /* HPUX_NET */
2235 \f
2236 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p, 1, 1, 0, /*
2237 Return t if file FILENAME specifies an absolute path name.
2238 On Unix, this is a name starting with a `/' or a `~'.
2239 */
2240        (filename))
2241 {
2242   /* This function does not GC */
2243   Bufbyte *ptr;
2244
2245   CHECK_STRING (filename);
2246   ptr = XSTRING_DATA (filename);
2247   return (IS_DIRECTORY_SEP (*ptr) || *ptr == '~'
2248 #ifdef WIN32_FILENAMES
2249           || (IS_DRIVE (*ptr) && ptr[1] == ':' && IS_DIRECTORY_SEP (ptr[2]))
2250 #endif
2251           ) ? Qt : Qnil;
2252 }
2253 \f
2254 /* Return nonzero if file FILENAME exists and can be executed.  */
2255
2256 static int
2257 check_executable (char *filename)
2258 {
2259 #ifdef WIN32_NATIVE
2260   struct stat st;
2261   if (xemacs_stat (filename, &st) < 0)
2262     return 0;
2263   return ((st.st_mode & S_IEXEC) != 0);
2264 #else /* not WIN32_NATIVE */
2265 #ifdef HAVE_EACCESS
2266   return eaccess (filename, X_OK) >= 0;
2267 #else
2268   /* Access isn't quite right because it uses the real uid
2269      and we really want to test with the effective uid.
2270      But Unix doesn't give us a right way to do it.  */
2271   return access (filename, X_OK) >= 0;
2272 #endif /* HAVE_EACCESS */
2273 #endif /* not WIN32_NATIVE */
2274 }
2275
2276
2277
2278 /* Return nonzero if file FILENAME exists and can be written.  */
2279
2280 static int
2281 check_writable (const char *filename)
2282 {
2283 #if defined(WIN32_NATIVE) || defined(CYGWIN)
2284 #ifdef CYGWIN
2285   char filename_buffer[PATH_MAX];
2286 #endif
2287   // Since this has to work for a directory, we can't just call 'CreateFile'
2288   PSECURITY_DESCRIPTOR pDesc; /* Must be freed with LocalFree */
2289   /* these need not be freed, they point into pDesc */
2290   PSID psidOwner;
2291   PSID psidGroup;
2292   PACL pDacl;
2293   PACL pSacl;
2294   /* end of insides of descriptor */
2295   DWORD error;
2296   DWORD attributes;
2297   HANDLE tokenHandle;
2298   GENERIC_MAPPING genericMapping;
2299   DWORD accessMask;
2300   PRIVILEGE_SET PrivilegeSet;
2301   DWORD dwPrivSetSize = sizeof( PRIVILEGE_SET );
2302   BOOL fAccessGranted = FALSE;
2303   DWORD dwAccessAllowed;
2304
2305 #ifdef CYGWIN
2306   cygwin_conv_to_full_win32_path(filename, filename_buffer);
2307   filename = filename_buffer;
2308 #endif
2309
2310   // First check for a normal file with the old-style readonly bit
2311   attributes = GetFileAttributes(filename);
2312   if (FILE_ATTRIBUTE_READONLY == (attributes & (FILE_ATTRIBUTE_DIRECTORY|FILE_ATTRIBUTE_READONLY)))
2313     return 0;
2314
2315   /* Win32 prototype lacks const. */
2316   error = GetNamedSecurityInfo((LPTSTR)filename, SE_FILE_OBJECT, 
2317                                DACL_SECURITY_INFORMATION|GROUP_SECURITY_INFORMATION|OWNER_SECURITY_INFORMATION,
2318                                &psidOwner, &psidGroup, &pDacl, &pSacl, &pDesc);
2319   if (error != ERROR_SUCCESS) { // FAT?
2320     attributes = GetFileAttributes(filename);
2321     return (attributes & FILE_ATTRIBUTE_DIRECTORY) || (0 == (attributes & FILE_ATTRIBUTE_READONLY));
2322   }
2323
2324   genericMapping.GenericRead = FILE_GENERIC_READ;
2325   genericMapping.GenericWrite = FILE_GENERIC_WRITE;
2326   genericMapping.GenericExecute = FILE_GENERIC_EXECUTE;
2327   genericMapping.GenericAll = FILE_ALL_ACCESS;
2328
2329   if (!ImpersonateSelf(SecurityDelegation)) {
2330     return 0;
2331   }
2332   if (!OpenThreadToken(GetCurrentThread(), TOKEN_ALL_ACCESS, TRUE, &tokenHandle)) {
2333       return 0;
2334   }
2335
2336   accessMask = GENERIC_WRITE;
2337   MapGenericMask(&accessMask, &genericMapping);
2338
2339   if (!AccessCheck(pDesc, tokenHandle, accessMask, &genericMapping,
2340                    &PrivilegeSet,       // receives privileges used in check
2341                    &dwPrivSetSize,      // size of PrivilegeSet buffer
2342                    &dwAccessAllowed,    // receives mask of allowed access rights
2343                    &fAccessGranted)) 
2344   {
2345     DWORD oops = GetLastError();
2346     CloseHandle(tokenHandle);
2347     RevertToSelf();
2348     LocalFree(pDesc);
2349     return 0;
2350   }
2351   CloseHandle(tokenHandle);
2352   RevertToSelf();
2353   LocalFree(pDesc);
2354   return fAccessGranted == TRUE;
2355 #else
2356 #ifdef HAVE_EACCESS
2357   return (eaccess (filename, W_OK) >= 0);
2358 #else
2359   /* Access isn't quite right because it uses the real uid
2360      and we really want to test with the effective uid.
2361      But Unix doesn't give us a right way to do it.
2362      Opening with O_WRONLY could work for an ordinary file,
2363      but would lose for directories.  */
2364   return (access (filename, W_OK) >= 0);
2365 #endif
2366 #endif
2367 }
2368
2369 DEFUN ("file-exists-p", Ffile_exists_p, 1, 1, 0, /*
2370 Return t if file FILENAME exists.  (This does not mean you can read it.)
2371 See also `file-readable-p' and `file-attributes'.
2372 */
2373        (filename))
2374 {
2375   /* This function can call lisp; GC checked 2000-07-11 ben */
2376   Lisp_Object abspath;
2377   Lisp_Object handler;
2378   struct stat statbuf;
2379   struct gcpro gcpro1;
2380
2381   CHECK_STRING (filename);
2382   abspath = Fexpand_file_name (filename, Qnil);
2383
2384   /* If the file name has special constructs in it,
2385      call the corresponding file handler.  */
2386   GCPRO1 (abspath);
2387   handler = Ffind_file_name_handler (abspath, Qfile_exists_p);
2388   UNGCPRO;
2389   if (!NILP (handler))
2390     return call2 (handler, Qfile_exists_p, abspath);
2391
2392   return xemacs_stat ((char *) XSTRING_DATA (abspath), &statbuf) >= 0 ? Qt : Qnil;
2393 }
2394
2395 DEFUN ("file-executable-p", Ffile_executable_p, 1, 1, 0, /*
2396 Return t if FILENAME can be executed by you.
2397 For a directory, this means you can access files in that directory.
2398 */
2399        (filename))
2400
2401 {
2402   /* This function can GC.  GC checked 07-11-2000 ben. */
2403   Lisp_Object abspath;
2404   Lisp_Object handler;
2405   struct gcpro gcpro1;
2406
2407   CHECK_STRING (filename);
2408   abspath = Fexpand_file_name (filename, Qnil);
2409
2410   /* If the file name has special constructs in it,
2411      call the corresponding file handler.  */
2412   GCPRO1 (abspath);
2413   handler = Ffind_file_name_handler (abspath, Qfile_executable_p);
2414   UNGCPRO;
2415   if (!NILP (handler))
2416     return call2 (handler, Qfile_executable_p, abspath);
2417
2418   return check_executable ((char *) XSTRING_DATA (abspath)) ? Qt : Qnil;
2419 }
2420
2421 DEFUN ("file-readable-p", Ffile_readable_p, 1, 1, 0, /*
2422 Return t if file FILENAME exists and you can read it.
2423 See also `file-exists-p' and `file-attributes'.
2424 */
2425        (filename))
2426 {
2427   /* This function can GC */
2428   Lisp_Object abspath = Qnil;
2429   Lisp_Object handler;
2430   struct gcpro gcpro1;
2431   GCPRO1 (abspath);
2432
2433   CHECK_STRING (filename);
2434   abspath = Fexpand_file_name (filename, Qnil);
2435
2436   /* If the file name has special constructs in it,
2437      call the corresponding file handler.  */
2438   handler = Ffind_file_name_handler (abspath, Qfile_readable_p);
2439   if (!NILP (handler))
2440     RETURN_UNGCPRO (call2 (handler, Qfile_readable_p, abspath));
2441
2442 #if defined(WIN32_FILENAMES)
2443   /* Under MS-DOS and Windows, open does not work for directories.  */
2444   UNGCPRO;
2445   if (access (XSTRING_DATA (abspath), 0) == 0)
2446     return Qt;
2447   else
2448     return Qnil;
2449 #else /* not WIN32_FILENAMES */
2450   {
2451     int desc = interruptible_open ((char *) XSTRING_DATA (abspath), O_RDONLY | OPEN_BINARY, 0);
2452     UNGCPRO;
2453     if (desc < 0)
2454       return Qnil;
2455     close (desc);
2456     return Qt;
2457   }
2458 #endif /* not WIN32_FILENAMES */
2459 }
2460
2461 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2462    on the RT/PC.  */
2463 DEFUN ("file-writable-p", Ffile_writable_p, 1, 1, 0, /*
2464 Return t if file FILENAME can be written or created by you.
2465 */
2466        (filename))
2467 {
2468   /* This function can GC.  GC checked 1997.04.10. */
2469   Lisp_Object abspath, dir;
2470   Lisp_Object handler;
2471   struct stat statbuf;
2472   struct gcpro gcpro1;
2473
2474   CHECK_STRING (filename);
2475   abspath = Fexpand_file_name (filename, Qnil);
2476
2477   /* If the file name has special constructs in it,
2478      call the corresponding file handler.  */
2479   GCPRO1 (abspath);
2480   handler = Ffind_file_name_handler (abspath, Qfile_writable_p);
2481   UNGCPRO;
2482   if (!NILP (handler))
2483     return call2 (handler, Qfile_writable_p, abspath);
2484
2485   if (xemacs_stat ((char *) XSTRING_DATA (abspath), &statbuf) >= 0)
2486     return (check_writable ((char *) XSTRING_DATA (abspath))
2487             ? Qt : Qnil);
2488
2489
2490   GCPRO1 (abspath);
2491   dir = Ffile_name_directory (abspath);
2492   UNGCPRO;
2493   return (check_writable (!NILP (dir) ? (char *) XSTRING_DATA (dir)
2494                           : "")
2495           ? Qt : Qnil);
2496 }
2497
2498 DEFUN ("file-symlink-p", Ffile_symlink_p, 1, 1, 0, /*
2499 Return non-nil if file FILENAME is the name of a symbolic link.
2500 The value is the name of the file to which it is linked.
2501 Otherwise returns nil.
2502 */
2503        (filename))
2504 {
2505   /* This function can GC.  GC checked 1997.04.10. */
2506   /* XEmacs change: run handlers even if local machine doesn't have symlinks */
2507 #ifdef S_IFLNK
2508   char *buf;
2509   int bufsize;
2510   int valsize;
2511   Lisp_Object val;
2512 #endif
2513   Lisp_Object handler;
2514   struct gcpro gcpro1;
2515
2516   CHECK_STRING (filename);
2517   filename = Fexpand_file_name (filename, Qnil);
2518
2519   /* If the file name has special constructs in it,
2520      call the corresponding file handler.  */
2521   GCPRO1 (filename);
2522   handler = Ffind_file_name_handler (filename, Qfile_symlink_p);
2523   UNGCPRO;
2524   if (!NILP (handler))
2525     return call2 (handler, Qfile_symlink_p, filename);
2526
2527 #ifdef S_IFLNK
2528   bufsize = 100;
2529   while (1)
2530     {
2531       buf = xnew_array_and_zero (char, bufsize);
2532       valsize = readlink ((char *) XSTRING_DATA (filename),
2533                           buf, bufsize);
2534       if (valsize < bufsize) break;
2535       /* Buffer was not long enough */
2536       xfree (buf);
2537       bufsize *= 2;
2538     }
2539   if (valsize == -1)
2540     {
2541       xfree (buf);
2542       return Qnil;
2543     }
2544   val = make_string ((Bufbyte *) buf, valsize);
2545   xfree (buf);
2546   return val;
2547 #else /* not S_IFLNK */
2548   return Qnil;
2549 #endif /* not S_IFLNK */
2550 }
2551
2552 DEFUN ("file-directory-p", Ffile_directory_p, 1, 1, 0, /*
2553 Return t if file FILENAME is the name of a directory as a file.
2554 A directory name spec may be given instead; then the value is t
2555 if the directory so specified exists and really is a directory.
2556 */
2557        (filename))
2558 {
2559   /* This function can GC.  GC checked 1997.04.10. */
2560   Lisp_Object abspath;
2561   struct stat st;
2562   Lisp_Object handler;
2563   struct gcpro gcpro1;
2564
2565   GCPRO1 (current_buffer->directory);
2566   abspath = expand_and_dir_to_file (filename,
2567                                     current_buffer->directory);
2568   UNGCPRO;
2569
2570   /* If the file name has special constructs in it,
2571      call the corresponding file handler.  */
2572   GCPRO1 (abspath);
2573   handler = Ffind_file_name_handler (abspath, Qfile_directory_p);
2574   UNGCPRO;
2575   if (!NILP (handler))
2576     return call2 (handler, Qfile_directory_p, abspath);
2577
2578   if (xemacs_stat ((char *) XSTRING_DATA (abspath), &st) < 0)
2579     return Qnil;
2580   return (st.st_mode & S_IFMT) == S_IFDIR ? Qt : Qnil;
2581 }
2582
2583 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p, 1, 1, 0, /*
2584 Return t if file FILENAME is the name of a directory as a file,
2585 and files in that directory can be opened by you.  In order to use a
2586 directory as a buffer's current directory, this predicate must return true.
2587 A directory name spec may be given instead; then the value is t
2588 if the directory so specified exists and really is a readable and
2589 searchable directory.
2590 */
2591        (filename))
2592 {
2593   /* This function can GC.  GC checked 1997.04.10. */
2594   Lisp_Object handler;
2595
2596   /* If the file name has special constructs in it,
2597      call the corresponding file handler.  */
2598   handler = Ffind_file_name_handler (filename, Qfile_accessible_directory_p);
2599   if (!NILP (handler))
2600     return call2 (handler, Qfile_accessible_directory_p,
2601                   filename);
2602
2603 #if !defined(WIN32_NATIVE)
2604   if (NILP (Ffile_directory_p (filename)))
2605       return (Qnil);
2606   else
2607     return Ffile_executable_p (filename);
2608 #else
2609   {
2610     int tem;
2611     struct gcpro gcpro1;
2612     /* It's an unlikely combination, but yes we really do need to gcpro:
2613        Suppose that file-accessible-directory-p has no handler, but
2614        file-directory-p does have a handler; this handler causes a GC which
2615        relocates the string in `filename'; and finally file-directory-p
2616        returns non-nil.  Then we would end up passing a garbaged string
2617        to file-executable-p.  */
2618     GCPRO1 (filename);
2619     tem = (NILP (Ffile_directory_p (filename))
2620            || NILP (Ffile_executable_p (filename)));
2621     UNGCPRO;
2622     return tem ? Qnil : Qt;
2623   }
2624 #endif /* !defined(WIN32_NATIVE) */
2625 }
2626
2627 DEFUN ("file-regular-p", Ffile_regular_p, 1, 1, 0, /*
2628 Return t if file FILENAME is the name of a regular file.
2629 This is the sort of file that holds an ordinary stream of data bytes.
2630 */
2631        (filename))
2632 {
2633   /* This function can GC.  GC checked 1997.04.10. */
2634   Lisp_Object abspath;
2635   struct stat st;
2636   Lisp_Object handler;
2637   struct gcpro gcpro1;
2638
2639   GCPRO1 (current_buffer->directory);
2640   abspath = expand_and_dir_to_file (filename, current_buffer->directory);
2641   UNGCPRO;
2642
2643   /* If the file name has special constructs in it,
2644      call the corresponding file handler.  */
2645   GCPRO1 (abspath);
2646   handler = Ffind_file_name_handler (abspath, Qfile_regular_p);
2647   UNGCPRO;
2648   if (!NILP (handler))
2649     return call2 (handler, Qfile_regular_p, abspath);
2650
2651   if (xemacs_stat ((char *) XSTRING_DATA (abspath), &st) < 0)
2652     return Qnil;
2653   return (st.st_mode & S_IFMT) == S_IFREG ? Qt : Qnil;
2654 }
2655 \f
2656 DEFUN ("file-modes", Ffile_modes, 1, 1, 0, /*
2657 Return mode bits of file named FILENAME, as an integer.
2658 */
2659        (filename))
2660 {
2661   /* This function can GC.  GC checked 1997.04.10. */
2662   Lisp_Object abspath;
2663   struct stat st;
2664   Lisp_Object handler;
2665   struct gcpro gcpro1;
2666
2667   GCPRO1 (current_buffer->directory);
2668   abspath = expand_and_dir_to_file (filename,
2669                                     current_buffer->directory);
2670   UNGCPRO;
2671
2672   /* If the file name has special constructs in it,
2673      call the corresponding file handler.  */
2674   GCPRO1 (abspath);
2675   handler = Ffind_file_name_handler (abspath, Qfile_modes);
2676   UNGCPRO;
2677   if (!NILP (handler))
2678     return call2 (handler, Qfile_modes, abspath);
2679
2680   if (xemacs_stat ((char *) XSTRING_DATA (abspath), &st) < 0)
2681     return Qnil;
2682   /* Syncing with FSF 19.34.6 note: not in FSF, #if 0'ed out here. */
2683 #if 0
2684 #ifdef WIN32_NATIVE
2685   if (check_executable (XSTRING_DATA (abspath)))
2686     st.st_mode |= S_IEXEC;
2687 #endif /* WIN32_NATIVE */
2688 #endif /* 0 */
2689
2690   return make_int (st.st_mode & 07777);
2691 }
2692
2693 DEFUN ("set-file-modes", Fset_file_modes, 2, 2, 0, /*
2694 Set mode bits of file named FILENAME to MODE (an integer).
2695 Only the 12 low bits of MODE are used.
2696 */
2697        (filename, mode))
2698 {
2699   /* This function can GC.  GC checked 1997.04.10. */
2700   Lisp_Object abspath;
2701   Lisp_Object handler;
2702   struct gcpro gcpro1;
2703
2704   GCPRO1 (current_buffer->directory);
2705   abspath = Fexpand_file_name (filename, current_buffer->directory);
2706   UNGCPRO;
2707
2708   CHECK_INT (mode);
2709
2710   /* If the file name has special constructs in it,
2711      call the corresponding file handler.  */
2712   GCPRO1 (abspath);
2713   handler = Ffind_file_name_handler (abspath, Qset_file_modes);
2714   UNGCPRO;
2715   if (!NILP (handler))
2716     return call3 (handler, Qset_file_modes, abspath, mode);
2717
2718   if (chmod ((char *) XSTRING_DATA (abspath), XINT (mode)) < 0)
2719     report_file_error ("Doing chmod", list1 (abspath));
2720
2721   return Qnil;
2722 }
2723
2724 DEFUN ("set-default-file-modes", Fset_default_file_modes, 1, 1, 0, /*
2725 Set the file permission bits for newly created files.
2726 The argument MODE should be an integer; if a bit in MODE is 1,
2727 subsequently created files will not have the permission corresponding
2728 to that bit enabled.  Only the low 9 bits are used.
2729 This setting is inherited by subprocesses.
2730 */
2731        (mode))
2732 {
2733   CHECK_INT (mode);
2734
2735   umask ((~ XINT (mode)) & 0777);
2736
2737   return Qnil;
2738 }
2739
2740 DEFUN ("default-file-modes", Fdefault_file_modes, 0, 0, 0, /*
2741 Return the default file protection for created files.
2742 The umask value determines which permissions are enabled in newly
2743 created files.  If a permission's bit in the umask is 1, subsequently
2744 created files will not have that permission enabled.
2745 */
2746        ())
2747 {
2748   int mode;
2749
2750   mode = umask (0);
2751   umask (mode);
2752
2753   return make_int ((~ mode) & 0777);
2754 }
2755 \f
2756 DEFUN ("unix-sync", Funix_sync, 0, 0, "", /*
2757 Tell Unix to finish all pending disk updates.
2758 */
2759        ())
2760 {
2761 #ifndef WIN32_NATIVE
2762   sync ();
2763 #endif
2764   return Qnil;
2765 }
2766
2767 \f
2768 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p, 2, 2, 0, /*
2769 Return t if file FILE1 is newer than file FILE2.
2770 If FILE1 does not exist, the answer is nil;
2771 otherwise, if FILE2 does not exist, the answer is t.
2772 */
2773        (file1, file2))
2774 {
2775   /* This function can GC.  GC checked 1997.04.10. */
2776   Lisp_Object abspath1, abspath2;
2777   struct stat st;
2778   int mtime1;
2779   Lisp_Object handler;
2780   struct gcpro gcpro1, gcpro2, gcpro3;
2781
2782   CHECK_STRING (file1);
2783   CHECK_STRING (file2);
2784
2785   abspath1 = Qnil;
2786   abspath2 = Qnil;
2787
2788   GCPRO3 (abspath1, abspath2, current_buffer->directory);
2789   abspath1 = expand_and_dir_to_file (file1, current_buffer->directory);
2790   abspath2 = expand_and_dir_to_file (file2, current_buffer->directory);
2791
2792   /* If the file name has special constructs in it,
2793      call the corresponding file handler.  */
2794   handler = Ffind_file_name_handler (abspath1, Qfile_newer_than_file_p);
2795   if (NILP (handler))
2796     handler = Ffind_file_name_handler (abspath2, Qfile_newer_than_file_p);
2797   UNGCPRO;
2798   if (!NILP (handler))
2799     return call3 (handler, Qfile_newer_than_file_p, abspath1,
2800                   abspath2);
2801
2802   if (xemacs_stat ((char *) XSTRING_DATA (abspath1), &st) < 0)
2803     return Qnil;
2804
2805   mtime1 = st.st_mtime;
2806
2807   if (xemacs_stat ((char *) XSTRING_DATA (abspath2), &st) < 0)
2808     return Qt;
2809
2810   return (mtime1 > st.st_mtime) ? Qt : Qnil;
2811 }
2812
2813 \f
2814 /* Stack sizes > 2**16 is a good way to elicit compiler bugs */
2815 /* #define READ_BUF_SIZE (2 << 16) */
2816 #define READ_BUF_SIZE (1 << 15)
2817
2818 DEFUN ("insert-file-contents-internal", Finsert_file_contents_internal,
2819        1, 7, 0, /*
2820 Insert contents of file FILENAME after point; no coding-system frobbing.
2821 This function is identical to `insert-file-contents' except for the
2822 handling of the CODESYS and USED-CODESYS arguments under
2823 XEmacs/Mule. (When Mule support is not present, both functions are
2824 identical and ignore the CODESYS and USED-CODESYS arguments.)
2825
2826 If support for Mule exists in this Emacs, the file is decoded according
2827 to CODESYS; if omitted, no conversion happens.  If USED-CODESYS is non-nil,
2828 it should be a symbol, and the actual coding system that was used for the
2829 decoding is stored into it.  It will in general be different from CODESYS
2830 if CODESYS specifies automatic encoding detection or end-of-line detection.
2831
2832 Currently START and END refer to byte positions (as opposed to character
2833 positions), even in Mule. (Fixing this is very difficult.)
2834 */
2835        (filename, visit, start, end, replace, codesys, used_codesys))
2836 {
2837   /* This function can call lisp */
2838   struct stat st;
2839   int fd;
2840   int saverrno = 0;
2841   Charcount inserted = 0;
2842   int speccount;
2843   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
2844   Lisp_Object handler = Qnil, val;
2845   int total;
2846   Bufbyte read_buf[READ_BUF_SIZE];
2847   int mc_count;
2848   struct buffer *buf = current_buffer;
2849   Lisp_Object curbuf;
2850   int not_regular = 0;
2851
2852   if (buf->base_buffer && ! NILP (visit))
2853     error ("Cannot do file visiting in an indirect buffer");
2854
2855   /* No need to call Fbarf_if_buffer_read_only() here.
2856      That's called in begin_multiple_change() or wherever. */
2857
2858   val = Qnil;
2859
2860   /* #### dmoore - should probably check in various places to see if
2861      curbuf was killed and if so signal an error? */
2862
2863   XSETBUFFER (curbuf, buf);
2864
2865   GCPRO5 (filename, val, visit, handler, curbuf);
2866
2867   mc_count = (NILP (replace)) ?
2868     begin_multiple_change (buf, BUF_PT  (buf), BUF_PT (buf)) :
2869     begin_multiple_change (buf, BUF_BEG (buf), BUF_Z  (buf));
2870
2871   speccount = specpdl_depth (); /* begin_multiple_change also adds
2872                                    an unwind_protect */
2873
2874   filename = Fexpand_file_name (filename, Qnil);
2875
2876   /* If the file name has special constructs in it,
2877      call the corresponding file handler.  */
2878   handler = Ffind_file_name_handler (filename, Qinsert_file_contents);
2879   if (!NILP (handler))
2880     {
2881       val = call6 (handler, Qinsert_file_contents, filename,
2882                    visit, start, end, replace);
2883       goto handled;
2884     }
2885
2886 #ifdef FILE_CODING
2887   if (!NILP (used_codesys))
2888     CHECK_SYMBOL (used_codesys);
2889 #endif
2890
2891   if ( (!NILP (start) || !NILP (end)) && !NILP (visit) )
2892     error ("Attempt to visit less than an entire file");
2893
2894   fd = -1;
2895
2896   if (xemacs_stat ((char *) XSTRING_DATA (filename), &st) < 0)
2897     {
2898       if (fd >= 0) close (fd);
2899     badopen:
2900       if (NILP (visit))
2901         report_file_error ("Opening input file", list1 (filename));
2902       st.st_mtime = -1;
2903       goto notfound;
2904     }
2905
2906 #ifdef S_IFREG
2907   /* Signal an error if we are accessing a non-regular file, with
2908      REPLACE, START or END being non-nil.  */
2909   if (!S_ISREG (st.st_mode))
2910     {
2911       not_regular = 1;
2912
2913       if (!NILP (visit))
2914         goto notfound;
2915
2916       if (!NILP (replace) || !NILP (start) || !NILP (end))
2917         {
2918           end_multiple_change (buf, mc_count);
2919
2920           RETURN_UNGCPRO
2921             (Fsignal (Qfile_error,
2922                       list2 (build_translated_string("not a regular file"),
2923                              filename)));
2924         }
2925     }
2926 #endif /* S_IFREG */
2927
2928   if (!NILP (start))
2929     CHECK_INT (start);
2930   else
2931     start = Qzero;
2932
2933   if (!NILP (end))
2934     CHECK_INT (end);
2935
2936   if (fd < 0)
2937     {
2938       if ((fd = interruptible_open ((char *) XSTRING_DATA (filename),
2939                                     O_RDONLY | OPEN_BINARY, 0)) < 0)
2940         goto badopen;
2941     }
2942
2943   /* Replacement should preserve point as it preserves markers.  */
2944   if (!NILP (replace))
2945     record_unwind_protect (restore_point_unwind, Fpoint_marker (Qnil, Qnil));
2946
2947   record_unwind_protect (close_file_unwind, make_int (fd));
2948
2949   /* Supposedly happens on VMS.  */
2950   if (st.st_size < 0)
2951     error ("File size is negative");
2952
2953   if (NILP (end))
2954     {
2955       if (!not_regular)
2956         {
2957           end = make_int (st.st_size);
2958           if (XINT (end) != st.st_size)
2959             error ("Maximum buffer size exceeded");
2960         }
2961     }
2962
2963   /* If requested, replace the accessible part of the buffer
2964      with the file contents.  Avoid replacing text at the
2965      beginning or end of the buffer that matches the file contents;
2966      that preserves markers pointing to the unchanged parts.  */
2967 #if !defined (FILE_CODING)
2968   /* The replace-mode code currently only works when the assumption
2969      'one byte == one char' holds true.  This fails Mule because
2970      files may contain multibyte characters.  It holds under Windows NT
2971      provided we convert CRLF into LF. */
2972 # define FSFMACS_SPEEDY_INSERT
2973 #endif /* !defined (FILE_CODING) */
2974
2975 #ifndef FSFMACS_SPEEDY_INSERT
2976   if (!NILP (replace))
2977     {
2978       buffer_delete_range (buf, BUF_BEG (buf), BUF_Z (buf),
2979                            !NILP (visit) ? INSDEL_NO_LOCKING : 0);
2980     }
2981 #else /* FSFMACS_SPEEDY_INSERT */
2982   if (!NILP (replace))
2983     {
2984       char buffer[1 << 14];
2985       Bufpos same_at_start = BUF_BEGV (buf);
2986       Bufpos same_at_end = BUF_ZV (buf);
2987       int overlap;
2988
2989       /* Count how many chars at the start of the file
2990          match the text at the beginning of the buffer.  */
2991       while (1)
2992         {
2993           int nread;
2994           Bufpos bufpos;
2995           nread = read_allowing_quit (fd, buffer, sizeof buffer);
2996           if (nread < 0)
2997             error ("IO error reading %s: %s",
2998                    XSTRING_DATA (filename), strerror (errno));
2999           else if (nread == 0)
3000             break;
3001           bufpos = 0;
3002           while (bufpos < nread && same_at_start < BUF_ZV (buf)
3003                  && BUF_FETCH_CHAR (buf, same_at_start) == buffer[bufpos])
3004             same_at_start++, bufpos++;
3005           /* If we found a discrepancy, stop the scan.
3006              Otherwise loop around and scan the next bufferful.  */
3007           if (bufpos != nread)
3008             break;
3009         }
3010       /* If the file matches the buffer completely,
3011          there's no need to replace anything.  */
3012       if (same_at_start - BUF_BEGV (buf) == st.st_size)
3013         {
3014           close (fd);
3015           unbind_to (speccount, Qnil);
3016           /* Truncate the buffer to the size of the file.  */
3017           buffer_delete_range (buf, same_at_start, same_at_end,
3018                                !NILP (visit) ? INSDEL_NO_LOCKING : 0);
3019           goto handled;
3020         }
3021       /* Count how many chars at the end of the file
3022          match the text at the end of the buffer.  */
3023       while (1)
3024         {
3025           int total_read, nread;
3026           Bufpos bufpos, curpos, trial;
3027
3028           /* At what file position are we now scanning?  */
3029           curpos = st.st_size - (BUF_ZV (buf) - same_at_end);
3030           /* If the entire file matches the buffer tail, stop the scan.  */
3031           if (curpos == 0)
3032             break;
3033           /* How much can we scan in the next step?  */
3034           trial = min (curpos, (Bufpos) sizeof (buffer));
3035           if (lseek (fd, curpos - trial, 0) < 0)
3036             report_file_error ("Setting file position", list1 (filename));
3037
3038           total_read = 0;
3039           while (total_read < trial)
3040             {
3041               nread = read_allowing_quit (fd, buffer + total_read,
3042                                           trial - total_read);
3043               if (nread <= 0)
3044                 report_file_error ("IO error reading file", list1 (filename));
3045               total_read += nread;
3046             }
3047           /* Scan this bufferful from the end, comparing with
3048              the Emacs buffer.  */
3049           bufpos = total_read;
3050           /* Compare with same_at_start to avoid counting some buffer text
3051              as matching both at the file's beginning and at the end.  */
3052           while (bufpos > 0 && same_at_end > same_at_start
3053                  && BUF_FETCH_CHAR (buf, same_at_end - 1) ==
3054                  buffer[bufpos - 1])
3055             same_at_end--, bufpos--;
3056           /* If we found a discrepancy, stop the scan.
3057              Otherwise loop around and scan the preceding bufferful.  */
3058           if (bufpos != 0)
3059             break;
3060           /* If display current starts at beginning of line,
3061              keep it that way.  */
3062           if (XBUFFER (XWINDOW (Fselected_window (Qnil))->buffer) == buf)
3063             XWINDOW (Fselected_window (Qnil))->start_at_line_beg =
3064               !NILP (Fbolp (make_buffer (buf)));
3065         }
3066
3067       /* Don't try to reuse the same piece of text twice.  */
3068       overlap = same_at_start - BUF_BEGV (buf) -
3069         (same_at_end + st.st_size - BUF_ZV (buf));
3070       if (overlap > 0)
3071         same_at_end += overlap;
3072
3073       /* Arrange to read only the nonmatching middle part of the file.  */
3074       start = make_int (same_at_start - BUF_BEGV (buf));
3075       end = make_int (st.st_size - (BUF_ZV (buf) - same_at_end));
3076
3077       buffer_delete_range (buf, same_at_start, same_at_end,
3078                            !NILP (visit) ? INSDEL_NO_LOCKING : 0);
3079       /* Insert from the file at the proper position.  */
3080       BUF_SET_PT (buf, same_at_start);
3081     }
3082 #endif /* FSFMACS_SPEEDY_INSERT */
3083
3084   if (!not_regular)
3085     {
3086       total = XINT (end) - XINT (start);
3087
3088       /* Make sure point-max won't overflow after this insertion.  */
3089       if (total != XINT (make_int (total)))
3090         error ("Maximum buffer size exceeded");
3091     }
3092   else
3093     /* For a special file, all we can do is guess.  The value of -1
3094        will make the stream functions read as much as possible.  */
3095     total = -1;
3096
3097   if (XINT (start) != 0
3098 #ifdef FSFMACS_SPEEDY_INSERT
3099       /* why was this here? asked jwz.  The reason is that the replace-mode
3100          connivings above will normally put the file pointer other than
3101          where it should be. */
3102       || !NILP (replace)
3103 #endif /* !FSFMACS_SPEEDY_INSERT */
3104       )
3105     {
3106       if (lseek (fd, XINT (start), 0) < 0)
3107         report_file_error ("Setting file position", list1 (filename));
3108     }
3109
3110   {
3111     Bufpos cur_point = BUF_PT (buf);
3112     struct gcpro ngcpro1;
3113     Lisp_Object stream = make_filedesc_input_stream (fd, 0, total,
3114                                                      LSTR_ALLOW_QUIT);
3115
3116     NGCPRO1 (stream);
3117     Lstream_set_buffering (XLSTREAM (stream), LSTREAM_BLOCKN_BUFFERED, 65536);
3118 #ifdef FILE_CODING
3119     stream = make_decoding_input_stream
3120       (XLSTREAM (stream), Fget_coding_system (codesys));
3121     Lstream_set_character_mode (XLSTREAM (stream));
3122     Lstream_set_buffering (XLSTREAM (stream), LSTREAM_BLOCKN_BUFFERED, 65536);
3123 #endif /* FILE_CODING */
3124
3125     record_unwind_protect (delete_stream_unwind, stream);
3126
3127     /* No need to limit the amount of stuff we attempt to read. (It would
3128        be incorrect, anyway, when Mule is enabled.) Instead, the limiting
3129        occurs inside of the filedesc stream. */
3130     while (1)
3131       {
3132         Lstream_data_count this_len;
3133         Charcount cc_inserted;
3134
3135         QUIT;
3136         this_len = Lstream_read (XLSTREAM (stream), read_buf,
3137                                  sizeof (read_buf));
3138
3139         if (this_len <= 0)
3140           {
3141             if (this_len < 0)
3142               saverrno = errno;
3143             break;
3144           }
3145
3146         cc_inserted = buffer_insert_raw_string_1 (buf, cur_point, read_buf,
3147                                                   this_len,
3148                                                   !NILP (visit)
3149                                                   ? INSDEL_NO_LOCKING : 0);
3150         inserted  += cc_inserted;
3151         cur_point += cc_inserted;
3152       }
3153 #ifdef FILE_CODING
3154     if (!NILP (used_codesys))
3155       {
3156         Fset (used_codesys,
3157               XCODING_SYSTEM_NAME (decoding_stream_coding_system (XLSTREAM (stream))));
3158       }
3159 #endif /* FILE_CODING */
3160     NUNGCPRO;
3161   }
3162
3163   /* Close the file/stream */
3164   unbind_to (speccount, Qnil);
3165
3166   if (saverrno != 0)
3167     {
3168       error ("IO error reading %s: %s",
3169              XSTRING_DATA (filename), strerror (saverrno));
3170     }
3171
3172  notfound:
3173  handled:
3174
3175   end_multiple_change (buf, mc_count);
3176
3177   if (!NILP (visit))
3178     {
3179       if (!EQ (buf->undo_list, Qt))
3180         buf->undo_list = Qnil;
3181       if (NILP (handler))
3182         {
3183           buf->modtime = st.st_mtime;
3184           buf->filename = filename;
3185           /* XEmacs addition: */
3186           /* This function used to be in C, ostensibly so that
3187              it could be called here.  But that's just silly.
3188              There's no reason C code can't call out to Lisp
3189              code, and it's a lot cleaner this way. */
3190           /*  Note: compute-buffer-file-truename is called for
3191               side-effect!  Its return value is intentionally
3192               ignored. */
3193           if (!NILP (Ffboundp (Qcompute_buffer_file_truename)))
3194             call1 (Qcompute_buffer_file_truename, make_buffer (buf));
3195         }
3196       BUF_SAVE_MODIFF (buf) = BUF_MODIFF (buf);
3197       buf->auto_save_modified = BUF_MODIFF (buf);
3198       buf->saved_size = make_int (BUF_SIZE (buf));
3199 #ifdef CLASH_DETECTION
3200       if (NILP (handler))
3201         {
3202           if (!NILP (buf->file_truename))
3203             unlock_file (buf->file_truename);
3204           unlock_file (filename);
3205         }
3206 #endif /* CLASH_DETECTION */
3207       if (not_regular)
3208         RETURN_UNGCPRO (Fsignal (Qfile_error,
3209                                  list2 (build_string ("not a regular file"),
3210                                  filename)));
3211
3212       /* If visiting nonexistent file, return nil.  */
3213       if (buf->modtime == -1)
3214         report_file_error ("Opening input file",
3215                            list1 (filename));
3216     }
3217
3218   /* Decode file format */
3219   if (inserted > 0)
3220     {
3221       Lisp_Object insval = call3 (Qformat_decode,
3222                                   Qnil, make_int (inserted), visit);
3223       CHECK_INT (insval);
3224       inserted = XINT (insval);
3225     }
3226
3227   if (inserted > 0)
3228     {
3229       Lisp_Object p;
3230       struct gcpro ngcpro1;
3231
3232       NGCPRO1 (p);
3233       EXTERNAL_LIST_LOOP (p, Vafter_insert_file_functions)
3234         {
3235           Lisp_Object insval =
3236             call1 (XCAR (p), make_int (inserted));
3237           if (!NILP (insval))
3238             {
3239               CHECK_NATNUM (insval);
3240               inserted = XINT (insval);
3241             }
3242           QUIT;
3243         }
3244       NUNGCPRO;
3245     }
3246
3247   UNGCPRO;
3248
3249   if (!NILP (val))
3250     return (val);
3251   else
3252     return (list2 (filename, make_int (inserted)));
3253 }
3254
3255 \f
3256 static int a_write (Lisp_Object outstream, Lisp_Object instream, int pos,
3257                     Lisp_Object *annot);
3258 static Lisp_Object build_annotations (Lisp_Object start, Lisp_Object end);
3259
3260 /* If build_annotations switched buffers, switch back to BUF.
3261    Kill the temporary buffer that was selected in the meantime.  */
3262
3263 static Lisp_Object
3264 build_annotations_unwind (Lisp_Object buf)
3265 {
3266   Lisp_Object tembuf;
3267
3268   if (XBUFFER (buf) == current_buffer)
3269     return Qnil;
3270   tembuf = Fcurrent_buffer ();
3271   Fset_buffer (buf);
3272   Fkill_buffer (tembuf);
3273   return Qnil;
3274 }
3275
3276 DEFUN ("write-region-internal", Fwrite_region_internal, 3, 7,
3277        "r\nFWrite region to file: ", /*
3278 Write current region into specified file; no coding-system frobbing.
3279 This function is identical to `write-region' except for the handling
3280 of the CODESYS argument under XEmacs/Mule. (When Mule support is not
3281 present, both functions are identical and ignore the CODESYS argument.)
3282 If support for Mule exists in this Emacs, the file is encoded according
3283 to the value of CODESYS.  If this is nil, no code conversion occurs.
3284
3285 As a special kludge to support auto-saving, when START is nil START and
3286 END are set to the beginning and end, respectively, of the buffer,
3287 regardless of any restrictions.  Don't use this feature.  It is documented
3288 here because write-region handler writers need to be aware of it.
3289 */
3290        (start, end, filename, append, visit, lockname, codesys))
3291 {
3292   /* This function can call lisp.  GC checked 2000-07-28 ben */
3293   int desc;
3294   int failure;
3295   int save_errno = 0;
3296   struct stat st;
3297   Lisp_Object fn = Qnil;
3298   int speccount = specpdl_depth ();
3299   int visiting_other = STRINGP (visit);
3300   int visiting = (EQ (visit, Qt) || visiting_other);
3301   int quietly = (!visiting && !NILP (visit));
3302   Lisp_Object visit_file = Qnil;
3303   Lisp_Object annotations = Qnil;
3304   struct buffer *given_buffer;
3305   Bufpos start1, end1;
3306   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
3307   struct gcpro ngcpro1, ngcpro2;
3308   Lisp_Object curbuf;
3309
3310   XSETBUFFER (curbuf, current_buffer);
3311
3312   /* start, end, visit, and append are never modified in this fun
3313      so we don't protect them. */
3314   GCPRO5 (visit_file, filename, codesys, lockname, annotations);
3315   NGCPRO2 (curbuf, fn);
3316
3317   /* [[ dmoore - if Fexpand_file_name or handlers kill the buffer,
3318      we should signal an error rather than blissfully continuing
3319      along.  ARGH, this function is going to lose lose lose.  We need
3320      to protect the current_buffer from being destroyed, but the
3321      multiple return points make this a pain in the butt. ]] we do
3322      protect curbuf now. --ben */
3323
3324 #ifdef FILE_CODING
3325   codesys = Fget_coding_system (codesys);
3326 #endif /* FILE_CODING */
3327
3328   if (current_buffer->base_buffer && ! NILP (visit))
3329     invalid_operation ("Cannot do file visiting in an indirect buffer",
3330                        curbuf);
3331
3332   if (!NILP (start) && !STRINGP (start))
3333     get_buffer_range_char (current_buffer, start, end, &start1, &end1, 0);
3334
3335   {
3336     Lisp_Object handler;
3337
3338     if (visiting_other)
3339       visit_file = Fexpand_file_name (visit, Qnil);
3340     else
3341       visit_file = filename;
3342     filename = Fexpand_file_name (filename, Qnil);
3343
3344     if (NILP (lockname))
3345       lockname = visit_file;
3346
3347     /* We used to UNGCPRO here.  BAD!  visit_file is used below after
3348        more Lisp calling. */
3349     /* If the file name has special constructs in it,
3350        call the corresponding file handler.  */
3351     handler = Ffind_file_name_handler (filename, Qwrite_region);
3352     /* If FILENAME has no handler, see if VISIT has one.  */
3353     if (NILP (handler) && STRINGP (visit))
3354       handler = Ffind_file_name_handler (visit, Qwrite_region);
3355
3356     if (!NILP (handler))
3357       {
3358         Lisp_Object val = call8 (handler, Qwrite_region, start, end,
3359                                  filename, append, visit, lockname, codesys);
3360         if (visiting)
3361           {
3362             BUF_SAVE_MODIFF (current_buffer) = BUF_MODIFF (current_buffer);
3363             current_buffer->saved_size = make_int (BUF_SIZE (current_buffer));
3364             current_buffer->filename = visit_file;
3365             MARK_MODELINE_CHANGED;
3366           }
3367         NUNGCPRO;
3368         UNGCPRO;
3369         return val;
3370       }
3371   }
3372
3373 #ifdef CLASH_DETECTION
3374   if (!auto_saving)
3375     lock_file (lockname);
3376 #endif /* CLASH_DETECTION */
3377
3378   /* Special kludge to simplify auto-saving.  */
3379   if (NILP (start))
3380     {
3381       start1 = BUF_BEG (current_buffer);
3382       end1 = BUF_Z (current_buffer);
3383     }
3384
3385   record_unwind_protect (build_annotations_unwind, Fcurrent_buffer ());
3386
3387   given_buffer = current_buffer;
3388   annotations = build_annotations (start, end);
3389   if (current_buffer != given_buffer)
3390     {
3391       start1 = BUF_BEGV (current_buffer);
3392       end1 = BUF_ZV (current_buffer);
3393     }
3394
3395   fn = filename;
3396   desc = -1;
3397   if (!NILP (append))
3398     {
3399       desc = open ((char *) XSTRING_DATA (fn), O_WRONLY | OPEN_BINARY, 0);
3400     }
3401   if (desc < 0)
3402     {
3403       desc = open ((char *) XSTRING_DATA (fn),
3404                    O_WRONLY | O_TRUNC | O_CREAT | OPEN_BINARY,
3405                    auto_saving ? auto_save_mode_bits : CREAT_MODE);
3406     }
3407
3408   if (desc < 0)
3409     {
3410 #ifdef CLASH_DETECTION
3411       save_errno = errno;
3412       if (!auto_saving) unlock_file (lockname);
3413       errno = save_errno;
3414 #endif /* CLASH_DETECTION */
3415       report_file_error ("Opening output file", list1 (filename));
3416     }
3417
3418   {
3419     Lisp_Object desc_locative = Fcons (make_int (desc), Qnil);
3420     Lisp_Object instream = Qnil, outstream = Qnil;
3421     struct gcpro nngcpro1, nngcpro2;
3422     /* need to gcpro; QUIT could happen out of call to write() */
3423     NNGCPRO2 (instream, outstream);
3424
3425     record_unwind_protect (close_file_unwind, desc_locative);
3426
3427     if (!NILP (append))
3428       {
3429         if (lseek (desc, 0, 2) < 0)
3430           {
3431 #ifdef CLASH_DETECTION
3432             if (!auto_saving) unlock_file (lockname);
3433 #endif /* CLASH_DETECTION */
3434             report_file_error ("Lseek error",
3435                                list1 (filename));
3436           }
3437       }
3438
3439     failure = 0;
3440
3441     /* Note: I tried increasing the buffering size, along with
3442        various other tricks, but nothing seemed to make much of
3443        a difference in the time it took to save a large file.
3444        (Actually that's not true.  With a local disk, changing
3445        the buffer size doesn't seem to make much difference.
3446        With an NFS-mounted disk, it could make a lot of difference
3447        because you're affecting the number of network requests
3448        that need to be made, and there could be a large latency
3449        for each request.  So I've increased the buffer size
3450        to 64K.) */
3451     outstream = make_filedesc_output_stream (desc, 0, -1, 0);
3452     Lstream_set_buffering (XLSTREAM (outstream),
3453                            LSTREAM_BLOCKN_BUFFERED, 65536);
3454 #ifdef FILE_CODING
3455     outstream =
3456       make_encoding_output_stream (XLSTREAM (outstream), codesys);
3457     Lstream_set_buffering (XLSTREAM (outstream),
3458                            LSTREAM_BLOCKN_BUFFERED, 65536);
3459 #endif /* FILE_CODING */
3460     if (STRINGP (start))
3461       {
3462         instream = make_lisp_string_input_stream (start, 0, -1);
3463         start1 = 0;
3464       }
3465     else
3466       instream = make_lisp_buffer_input_stream (current_buffer, start1, end1,
3467                                                 LSTR_SELECTIVE |
3468                                                 LSTR_IGNORE_ACCESSIBLE);
3469     failure = (0 > (a_write (outstream, instream, start1,
3470                              &annotations)));
3471     save_errno = errno;
3472     /* Note that this doesn't close the desc since we created the
3473        stream without the LSTR_CLOSING flag, but it does
3474        flush out any buffered data. */
3475     if (Lstream_close (XLSTREAM (outstream)) < 0)
3476       {
3477         failure = 1;
3478         save_errno = errno;
3479       }
3480     Lstream_close (XLSTREAM (instream));
3481
3482 #ifdef HAVE_FSYNC
3483     /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
3484        Disk full in NFS may be reported here.  */
3485     /* mib says that closing the file will try to write as fast as NFS can do
3486        it, and that means the fsync here is not crucial for autosave files.  */
3487     if (!auto_saving && fsync (desc) < 0
3488         /* If fsync fails with EINTR, don't treat that as serious.  */
3489         && errno != EINTR)
3490       {
3491         failure = 1;
3492         save_errno = errno;
3493       }
3494 #endif /* HAVE_FSYNC */
3495
3496     /* Spurious "file has changed on disk" warnings used to be seen on
3497        systems where close() can change the modtime.  This is known to
3498        happen on various NFS file systems, on Windows, and on Linux.
3499        Rather than handling this on a per-system basis, we
3500        unconditionally do the xemacs_stat() after the close(). */
3501
3502     /* NFS can report a write failure now.  */
3503     if (close (desc) < 0)
3504       {
3505         failure = 1;
3506         save_errno = errno;
3507       }
3508
3509     /* Discard the close unwind-protect.  Execute the one for
3510        build_annotations (switches back to the original current buffer
3511        as necessary). */
3512     XCAR (desc_locative) = Qnil;
3513     unbind_to (speccount, Qnil);
3514
3515     NNUNGCPRO;
3516   }
3517
3518   xemacs_stat ((char *) XSTRING_DATA (fn), &st);
3519
3520 #ifdef CLASH_DETECTION
3521   if (!auto_saving)
3522     unlock_file (lockname);
3523 #endif /* CLASH_DETECTION */
3524
3525   /* Do this before reporting IO error
3526      to avoid a "file has changed on disk" warning on
3527      next attempt to save.  */
3528   if (visiting)
3529     current_buffer->modtime = st.st_mtime;
3530
3531   if (failure)
3532     {
3533       errno = save_errno;
3534       report_file_error ("Writing file", list1 (fn));
3535     }
3536
3537   if (visiting)
3538     {
3539       BUF_SAVE_MODIFF (current_buffer) = BUF_MODIFF (current_buffer);
3540       current_buffer->saved_size = make_int (BUF_SIZE (current_buffer));
3541       current_buffer->filename = visit_file;
3542       MARK_MODELINE_CHANGED;
3543     }
3544   else if (quietly)
3545     {
3546       NUNGCPRO;
3547       UNGCPRO;
3548       return Qnil;
3549     }
3550
3551   if (!auto_saving)
3552     {
3553       if (visiting_other)
3554         message ("Wrote %s", XSTRING_DATA (visit_file));
3555       else
3556         {
3557           Lisp_Object fsp = Qnil;
3558           struct gcpro nngcpro1;
3559
3560           NNGCPRO1 (fsp);
3561           fsp = Ffile_symlink_p (fn);
3562           if (NILP (fsp))
3563             message ("Wrote %s", XSTRING_DATA (fn));
3564           else
3565             message ("Wrote %s (symlink to %s)",
3566                      XSTRING_DATA (fn), XSTRING_DATA (fsp));
3567           NNUNGCPRO;
3568         }
3569     }
3570   NUNGCPRO;
3571   UNGCPRO;
3572   return Qnil;
3573 }
3574
3575 /* #### This is such a load of shit!!!!  There is no way we should define
3576    something so stupid as a subr, just sort the fucking list more
3577    intelligently. */
3578 DEFUN ("car-less-than-car", Fcar_less_than_car, 2, 2, 0, /*
3579 Return t if (car A) is numerically less than (car B).
3580 */
3581        (a, b))
3582 {
3583   Lisp_Object objs[2];
3584   objs[0] = Fcar (a);
3585   objs[1] = Fcar (b);
3586   return Flss (2, objs);
3587 }
3588
3589 /* Heh heh heh, let's define this too, just to aggravate the person who
3590    wrote the above comment. */
3591 DEFUN ("cdr-less-than-cdr", Fcdr_less_than_cdr, 2, 2, 0, /*
3592 Return t if (cdr A) is numerically less than (cdr B).
3593 */
3594        (a, b))
3595 {
3596   Lisp_Object objs[2];
3597   objs[0] = Fcdr (a);
3598   objs[1] = Fcdr (b);
3599   return Flss (2, objs);
3600 }
3601
3602 /* Build the complete list of annotations appropriate for writing out
3603    the text between START and END, by calling all the functions in
3604    write-region-annotate-functions and merging the lists they return.
3605    If one of these functions switches to a different buffer, we assume
3606    that buffer contains altered text.  Therefore, the caller must
3607    make sure to restore the current buffer in all cases,
3608    as save-excursion would do.  */
3609
3610 static Lisp_Object
3611 build_annotations (Lisp_Object start, Lisp_Object end)
3612 {
3613   /* This function can GC */
3614   Lisp_Object annotations;
3615   Lisp_Object p, res;
3616   struct gcpro gcpro1, gcpro2;
3617   Lisp_Object original_buffer;
3618
3619   XSETBUFFER (original_buffer, current_buffer);
3620
3621   annotations = Qnil;
3622   p = Vwrite_region_annotate_functions;
3623   GCPRO2 (annotations, p);
3624   while (!NILP (p))
3625     {
3626       struct buffer *given_buffer = current_buffer;
3627       Vwrite_region_annotations_so_far = annotations;
3628       res = call2 (Fcar (p), start, end);
3629       /* If the function makes a different buffer current,
3630          assume that means this buffer contains altered text to be output.
3631          Reset START and END from the buffer bounds
3632          and discard all previous annotations because they should have
3633          been dealt with by this function.  */
3634       if (current_buffer != given_buffer)
3635         {
3636           start = make_int (BUF_BEGV (current_buffer));
3637           end = make_int (BUF_ZV (current_buffer));
3638           annotations = Qnil;
3639         }
3640       Flength (res);     /* Check basic validity of return value */
3641       annotations = merge (annotations, res, Qcar_less_than_car);
3642       p = Fcdr (p);
3643     }
3644
3645   /* Now do the same for annotation functions implied by the file-format */
3646   if (auto_saving && (!EQ (Vauto_save_file_format, Qt)))
3647     p = Vauto_save_file_format;
3648   else
3649     p = current_buffer->file_format;
3650   while (!NILP (p))
3651     {
3652       struct buffer *given_buffer = current_buffer;
3653       Vwrite_region_annotations_so_far = annotations;
3654       res = call4 (Qformat_annotate_function, Fcar (p), start, end,
3655                    original_buffer);
3656       if (current_buffer != given_buffer)
3657         {
3658           start = make_int (BUF_BEGV (current_buffer));
3659           end = make_int (BUF_ZV (current_buffer));
3660           annotations = Qnil;
3661         }
3662       Flength (res);
3663       annotations = merge (annotations, res, Qcar_less_than_car);
3664       p = Fcdr (p);
3665     }
3666   UNGCPRO;
3667   return annotations;
3668 }
3669
3670 /* Write to stream OUTSTREAM the characters from INSTREAM (it is read until
3671    EOF is encountered), assuming they start at position POS in the buffer
3672    of string that STREAM refers to.  Intersperse with them the annotations
3673    from *ANNOT that fall into the range of positions we are reading from,
3674    each at its appropriate position.
3675
3676    Modify *ANNOT by discarding elements as we output them.
3677    The return value is negative in case of system call failure.  */
3678
3679 /* 4K should probably be fine.  We just need to reduce the number of
3680    function calls to reasonable level.  The Lstream stuff itself will
3681    batch to 64K to reduce the number of system calls. */
3682
3683 #define A_WRITE_BATCH_SIZE 4096
3684
3685 static int
3686 a_write (Lisp_Object outstream, Lisp_Object instream, int pos,
3687          Lisp_Object *annot)
3688 {
3689   Lisp_Object tem;
3690   int nextpos;
3691   unsigned char largebuf[A_WRITE_BATCH_SIZE];
3692   Lstream *instr = XLSTREAM (instream);
3693   Lstream *outstr = XLSTREAM (outstream);
3694
3695   while (LISTP (*annot))
3696     {
3697       tem = Fcar_safe (Fcar (*annot));
3698       if (INTP (tem))
3699         nextpos = XINT (tem);
3700       else
3701         nextpos = INT_MAX;
3702 #ifdef MULE
3703       /* If there are annotations left and we have Mule, then we
3704          have to do the I/O one emchar at a time so we can
3705          determine when to insert the annotation. */
3706       if (!NILP (*annot))
3707         {
3708           Emchar ch;
3709           while (pos != nextpos && (ch = Lstream_get_emchar (instr)) != EOF)
3710             {
3711               if (Lstream_put_emchar (outstr, ch) < 0)
3712                 return -1;
3713               pos++;
3714             }
3715         }
3716       else
3717 #endif /* MULE */
3718         {
3719           while (pos != nextpos)
3720             {
3721               /* Otherwise there is no point to that.  Just go in batches. */
3722               int chunk = min (nextpos - pos, A_WRITE_BATCH_SIZE);
3723
3724               chunk = Lstream_read (instr, largebuf, chunk);
3725               if (chunk < 0)
3726                 return -1;
3727               if (chunk == 0) /* EOF */
3728                 break;
3729               if (Lstream_write (outstr, largebuf, chunk) < chunk)
3730                 return -1;
3731               pos += chunk;
3732             }
3733         }
3734       if (pos == nextpos)
3735         {
3736           tem = Fcdr (Fcar (*annot));
3737           if (STRINGP (tem))
3738             {
3739               if (Lstream_write (outstr, XSTRING_DATA (tem),
3740                                  XSTRING_LENGTH (tem)) < 0)
3741                 return -1;
3742             }
3743           *annot = Fcdr (*annot);
3744         }
3745       else
3746         return 0;
3747     }
3748   return -1;
3749 }
3750
3751
3752 \f
3753 #if 0
3754 #include <des_crypt.h>
3755
3756 #define CRYPT_BLOCK_SIZE 8      /* bytes */
3757 #define CRYPT_KEY_SIZE 8        /* bytes */
3758
3759 DEFUN ("encrypt-string", Fencrypt_string, 2, 2, 0, /*
3760 Encrypt STRING using KEY.
3761 */
3762        (string, key))
3763 {
3764   char *encrypted_string, *raw_key;
3765   int rounded_size, extra, key_size;
3766
3767   /* !!#### May produce bogus data under Mule. */
3768   CHECK_STRING (string);
3769   CHECK_STRING (key);
3770
3771   extra = XSTRING_LENGTH (string) % CRYPT_BLOCK_SIZE;
3772   rounded_size = XSTRING_LENGTH (string) + extra;
3773   encrypted_string = alloca (rounded_size + 1);
3774   memcpy (encrypted_string, XSTRING_DATA (string), XSTRING_LENGTH (string));
3775   memset (encrypted_string + rounded_size - extra, 0, extra + 1);
3776
3777   key_size = min (CRYPT_KEY_SIZE, XSTRING_LENGTH (key))
3778
3779   raw_key = alloca (CRYPT_KEY_SIZE + 1);
3780   memcpy (raw_key, XSTRING_DATA (key), key_size);
3781   memset (raw_key + key_size, 0, (CRYPT_KEY_SIZE + 1) - key_size);
3782
3783   ecb_crypt (raw_key, encrypted_string, rounded_size,
3784              DES_ENCRYPT | DES_SW);
3785   return make_string (encrypted_string, rounded_size);
3786 }
3787
3788 DEFUN ("decrypt-string", Fdecrypt_string, 2, 2, 0, /*
3789 Decrypt STRING using KEY.
3790 */
3791        (string, key))
3792 {
3793   char *decrypted_string, *raw_key;
3794   int string_size, key_size;
3795
3796   CHECK_STRING (string);
3797   CHECK_STRING (key);
3798
3799   string_size = XSTRING_LENGTH (string) + 1;
3800   decrypted_string = alloca (string_size);
3801   memcpy (decrypted_string, XSTRING_DATA (string), string_size);
3802   decrypted_string[string_size - 1] = '\0';
3803
3804   key_size = min (CRYPT_KEY_SIZE, XSTRING_LENGTH (key))
3805
3806   raw_key = alloca (CRYPT_KEY_SIZE + 1);
3807   memcpy (raw_key, XSTRING_DATA (key), key_size);
3808   memset (raw_key + key_size, 0, (CRYPT_KEY_SIZE + 1) - key_size);
3809
3810
3811   ecb_crypt (raw_key, decrypted_string, string_size, D | DES_SW);
3812   return make_string (decrypted_string, string_size - 1);
3813 }
3814 #endif /* 0 */
3815
3816 \f
3817 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime, 1, 1, 0, /*
3818 Return t if last mod time of BUFFER's visited file matches what BUFFER records.
3819 This means that the file has not been changed since it was visited or saved.
3820 */
3821        (buffer))
3822 {
3823   /* This function can call lisp; GC checked 2000-07-11 ben */
3824   struct buffer *b;
3825   struct stat st;
3826   Lisp_Object handler;
3827
3828   CHECK_BUFFER (buffer);
3829   b = XBUFFER (buffer);
3830
3831   if (!STRINGP (b->filename)) return Qt;
3832   if (b->modtime == 0) return Qt;
3833
3834   /* If the file name has special constructs in it,
3835      call the corresponding file handler.  */
3836   handler = Ffind_file_name_handler (b->filename,
3837                                      Qverify_visited_file_modtime);
3838   if (!NILP (handler))
3839     return call2 (handler, Qverify_visited_file_modtime, buffer);
3840
3841   if (xemacs_stat ((char *) XSTRING_DATA (b->filename), &st) < 0)
3842     {
3843       /* If the file doesn't exist now and didn't exist before,
3844          we say that it isn't modified, provided the error is a tame one.  */
3845       if (errno == ENOENT || errno == EACCES || errno == ENOTDIR)
3846         st.st_mtime = -1;
3847       else
3848         st.st_mtime = 0;
3849     }
3850   if (st.st_mtime == b->modtime
3851       /* If both are positive, accept them if they are off by one second.  */
3852       || (st.st_mtime > 0 && b->modtime > 0
3853           && (st.st_mtime == b->modtime + 1
3854               || st.st_mtime == b->modtime - 1)))
3855     return Qt;
3856   return Qnil;
3857 }
3858
3859 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime, 0, 0, 0, /*
3860 Clear out records of last mod time of visited file.
3861 Next attempt to save will certainly not complain of a discrepancy.
3862 */
3863        ())
3864 {
3865   current_buffer->modtime = 0;
3866   return Qnil;
3867 }
3868
3869 DEFUN ("visited-file-modtime", Fvisited_file_modtime, 0, 0, 0, /*
3870 Return the current buffer's recorded visited file modification time.
3871 The value is a list of the form (HIGH . LOW), like the time values
3872 that `file-attributes' returns.
3873 */
3874        ())
3875 {
3876   return time_to_lisp ((time_t) current_buffer->modtime);
3877 }
3878
3879 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime, 0, 1, 0, /*
3880 Update buffer's recorded modification time from the visited file's time.
3881 Useful if the buffer was not read from the file normally
3882 or if the file itself has been changed for some known benign reason.
3883 An argument specifies the modification time value to use
3884 \(instead of that of the visited file), in the form of a list
3885 \(HIGH . LOW) or (HIGH LOW).
3886 */
3887        (time_list))
3888 {
3889   /* This function can call lisp */
3890   if (!NILP (time_list))
3891     {
3892       time_t the_time;
3893       lisp_to_time (time_list, &the_time);
3894       current_buffer->modtime = (int) the_time;
3895     }
3896   else
3897     {
3898       Lisp_Object filename = Qnil;
3899       struct stat st;
3900       Lisp_Object handler;
3901       struct gcpro gcpro1, gcpro2, gcpro3;
3902
3903       GCPRO3 (filename, time_list, current_buffer->filename);
3904       filename = Fexpand_file_name (current_buffer->filename, Qnil);
3905
3906       /* If the file name has special constructs in it,
3907          call the corresponding file handler.  */
3908       handler = Ffind_file_name_handler (filename, Qset_visited_file_modtime);
3909       UNGCPRO;
3910       if (!NILP (handler))
3911         /* The handler can find the file name the same way we did.  */
3912         return call2 (handler, Qset_visited_file_modtime, Qnil);
3913       else if (xemacs_stat ((char *) XSTRING_DATA (filename), &st) >= 0)
3914         current_buffer->modtime = st.st_mtime;
3915     }
3916
3917   return Qnil;
3918 }
3919 \f
3920 static Lisp_Object
3921 auto_save_error (Lisp_Object condition_object, Lisp_Object ignored)
3922 {
3923   /* This function can call lisp */
3924   if (gc_in_progress)
3925     return Qnil;
3926   /* Don't try printing an error message after everything is gone! */
3927   if (preparing_for_armageddon)
3928     return Qnil;
3929   clear_echo_area (selected_frame (), Qauto_saving, 1);
3930   Fding (Qt, Qauto_save_error, Qnil);
3931   message ("Auto-saving...error for %s", XSTRING_DATA (current_buffer->name));
3932   Fsleep_for (make_int (1));
3933   message ("Auto-saving...error!for %s", XSTRING_DATA (current_buffer->name));
3934   Fsleep_for (make_int (1));
3935   message ("Auto-saving...error for %s", XSTRING_DATA (current_buffer->name));
3936   Fsleep_for (make_int (1));
3937   return Qnil;
3938 }
3939
3940 static Lisp_Object
3941 auto_save_1 (Lisp_Object ignored)
3942 {
3943   /* This function can call lisp */
3944   /* #### I think caller is protecting current_buffer? */
3945   struct stat st;
3946   Lisp_Object fn = current_buffer->filename;
3947   Lisp_Object a  = current_buffer->auto_save_file_name;
3948
3949   if (!STRINGP (a))
3950     return (Qnil);
3951
3952   /* Get visited file's mode to become the auto save file's mode.  */
3953   if (STRINGP (fn) &&
3954       xemacs_stat ((char *) XSTRING_DATA (fn), &st) >= 0)
3955     /* But make sure we can overwrite it later!  */
3956     auto_save_mode_bits = st.st_mode | 0600;
3957   else
3958     /* default mode for auto-save files of buffers with no file is
3959        readable by owner only.  This may annoy some small number of
3960        people, but the alternative removes all privacy from email. */
3961     auto_save_mode_bits = 0600;
3962
3963   return
3964     /* !!#### need to deal with this 'escape-quoted everywhere */
3965     Fwrite_region_internal (Qnil, Qnil, a, Qnil, Qlambda, Qnil,
3966 #ifdef FILE_CODING
3967                             current_buffer->buffer_file_coding_system
3968 #else
3969                             Qnil
3970 #endif
3971                             );
3972 }
3973
3974 static Lisp_Object
3975 auto_save_expand_name_error (Lisp_Object condition_object, Lisp_Object ignored)
3976 {
3977   /* #### this function should spew an error message about not being
3978      able to open the .saves file. */
3979   return Qnil;
3980 }
3981
3982 static Lisp_Object
3983 auto_save_expand_name (Lisp_Object name)
3984 {
3985   struct gcpro gcpro1;
3986
3987   /* note that caller did NOT gc protect name, so we do it. */
3988   /* #### dmoore - this might not be necessary, if condition_case_1
3989      protects it.  but I don't think it does. */
3990   GCPRO1 (name);
3991   RETURN_UNGCPRO (Fexpand_file_name (name, Qnil));
3992 }
3993
3994
3995 static Lisp_Object
3996 do_auto_save_unwind (Lisp_Object fd)
3997 {
3998   close (XINT (fd));
3999   return (fd);
4000 }
4001
4002 static Lisp_Object
4003 do_auto_save_unwind_2 (Lisp_Object old_auto_saving)
4004 {
4005   auto_saving = XINT (old_auto_saving);
4006   return Qnil;
4007 }
4008
4009 /* Fdo_auto_save() checks whether a GC is in progress when it is called,
4010    and if so, tries to avoid touching lisp objects.
4011
4012    The only time that Fdo_auto_save() is called while GC is in progress
4013    is if we're going down, as a result of an ABORT() or a kill signal.
4014    It's fairly important that we generate autosave files in that case!
4015  */
4016
4017 DEFUN ("do-auto-save", Fdo_auto_save, 0, 2, "", /*
4018 Auto-save all buffers that need it.
4019 This is all buffers that have auto-saving enabled
4020 and are changed since last auto-saved.
4021 Auto-saving writes the buffer into a file
4022 so that your editing is not lost if the system crashes.
4023 This file is not the file you visited; that changes only when you save.
4024 Normally we run the normal hook `auto-save-hook' before saving.
4025
4026 Non-nil first argument means do not print any message if successful.
4027 Non-nil second argument means save only current buffer.
4028 */
4029        (no_message, current_only))
4030 {
4031   /* This function can call lisp */
4032   struct buffer *b;
4033   Lisp_Object tail, buf;
4034   int auto_saved = 0;
4035   int do_handled_files;
4036   Lisp_Object oquit = Qnil;
4037   Lisp_Object listfile = Qnil;
4038   Lisp_Object old;
4039   int listdesc = -1;
4040   int speccount = specpdl_depth ();
4041   struct gcpro gcpro1, gcpro2, gcpro3;
4042
4043   XSETBUFFER (old, current_buffer);
4044   GCPRO3 (oquit, listfile, old);
4045   check_quit (); /* make Vquit_flag accurate */
4046   /* Ordinarily don't quit within this function,
4047      but don't make it impossible to quit (in case we get hung in I/O).  */
4048   oquit = Vquit_flag;
4049   Vquit_flag = Qnil;
4050
4051   /* No further GCPRO needed, because (when it matters) all Lisp_Object
4052      variables point to non-strings reached from Vbuffer_alist.  */
4053
4054   if (minibuf_level != 0 || preparing_for_armageddon)
4055     no_message = Qt;
4056
4057   run_hook (Qauto_save_hook);
4058
4059   if (STRINGP (Vauto_save_list_file_name))
4060     listfile = condition_case_1 (Qt,
4061                                  auto_save_expand_name,
4062                                  Vauto_save_list_file_name,
4063                                  auto_save_expand_name_error, Qnil);
4064
4065   /* Make sure auto_saving is reset. */
4066   record_unwind_protect (do_auto_save_unwind_2, make_int (auto_saving));
4067
4068   auto_saving = 1;
4069
4070   /* First, save all files which don't have handlers.  If Emacs is
4071      crashing, the handlers may tweak what is causing Emacs to crash
4072      in the first place, and it would be a shame if Emacs failed to
4073      autosave perfectly ordinary files because it couldn't handle some
4074      ange-ftp'd file.  */
4075   for (do_handled_files = 0; do_handled_files < 2; do_handled_files++)
4076     {
4077       for (tail = Vbuffer_alist;
4078            CONSP (tail);
4079            tail = XCDR (tail))
4080         {
4081           buf = XCDR (XCAR (tail));
4082           b = XBUFFER (buf);
4083
4084           if (!NILP (current_only)
4085               && b != current_buffer)
4086             continue;
4087
4088           /* Don't auto-save indirect buffers.
4089              The base buffer takes care of it.  */
4090           if (b->base_buffer)
4091             continue;
4092
4093           /* Check for auto save enabled
4094              and file changed since last auto save
4095              and file changed since last real save.  */
4096           if (STRINGP (b->auto_save_file_name)
4097               && BUF_SAVE_MODIFF (b) < BUF_MODIFF (b)
4098               && b->auto_save_modified < BUF_MODIFF (b)
4099               /* -1 means we've turned off autosaving for a while--see below.  */
4100               && XINT (b->saved_size) >= 0
4101               && (do_handled_files
4102                   || NILP (Ffind_file_name_handler (b->auto_save_file_name,
4103                                                     Qwrite_region))))
4104             {
4105               EMACS_TIME before_time, after_time;
4106
4107               EMACS_GET_TIME (before_time);
4108               /* If we had a failure, don't try again for 20 minutes.  */
4109               if (!preparing_for_armageddon
4110                   && b->auto_save_failure_time >= 0
4111                   && (EMACS_SECS (before_time) - b->auto_save_failure_time <
4112                       1200))
4113                 continue;
4114
4115               if (!preparing_for_armageddon &&
4116                   (XINT (b->saved_size) * 10
4117                    > (BUF_Z (b) - BUF_BEG (b)) * 13)
4118                   /* A short file is likely to change a large fraction;
4119                      spare the user annoying messages.  */
4120                   && XINT (b->saved_size) > 5000
4121                   /* These messages are frequent and annoying for `*mail*'.  */
4122                   && !NILP (b->filename)
4123                   && NILP (no_message)
4124                   && disable_auto_save_when_buffer_shrinks)
4125                 {
4126                   /* It has shrunk too much; turn off auto-saving here.
4127                      Unless we're about to crash, in which case auto-save it
4128                      anyway.
4129                      */
4130                   message
4131                     ("Buffer %s has shrunk a lot; auto save turned off there",
4132                      XSTRING_DATA (b->name));
4133                   /* Turn off auto-saving until there's a real save,
4134                      and prevent any more warnings.  */
4135                   b->saved_size = make_int (-1);
4136                   if (!gc_in_progress)
4137                     Fsleep_for (make_int (1));
4138                   continue;
4139                 }
4140               set_buffer_internal (b);
4141               if (!auto_saved && NILP (no_message))
4142                 {
4143                   static const unsigned char *msg
4144                     = (const unsigned char *) "Auto-saving...";
4145                   echo_area_message (selected_frame (), msg, Qnil,
4146                                      0, strlen ((const char *) msg),
4147                                      Qauto_saving);
4148                 }
4149
4150               /* Open the auto-save list file, if necessary.
4151                  We only do this now so that the file only exists
4152                  if we actually auto-saved any files. */
4153               if (!auto_saved && !inhibit_auto_save_session
4154                   && !NILP (Vauto_save_list_file_prefix)
4155                   && STRINGP (listfile) && listdesc < 0)
4156                 {
4157                   listdesc = open ((char *) XSTRING_DATA (listfile),
4158                                    O_WRONLY | O_TRUNC | O_CREAT | OPEN_BINARY,
4159                                    CREAT_MODE);
4160
4161                   /* Arrange to close that file whether or not we get
4162                      an error. */
4163                   if (listdesc >= 0)
4164                     record_unwind_protect (do_auto_save_unwind,
4165                                            make_int (listdesc));
4166                 }
4167
4168               /* Record all the buffers that we are auto-saving in
4169                  the special file that lists them.  For each of
4170                  these buffers, record visited name (if any) and
4171                  auto save name.  */
4172               if (listdesc >= 0)
4173                 {
4174                   const Extbyte *auto_save_file_name_ext;
4175                   Extcount auto_save_file_name_ext_len;
4176
4177                   TO_EXTERNAL_FORMAT (LISP_STRING, b->auto_save_file_name,
4178                                       ALLOCA, (auto_save_file_name_ext,
4179                                                auto_save_file_name_ext_len),
4180                                       Qfile_name);
4181                   if (!NILP (b->filename))
4182                     {
4183                       const Extbyte *filename_ext;
4184                       Extcount filename_ext_len;
4185
4186                       TO_EXTERNAL_FORMAT (LISP_STRING, b->filename,
4187                                           ALLOCA, (filename_ext,
4188                                                    filename_ext_len),
4189                                           Qfile_name);
4190                       write (listdesc, filename_ext, filename_ext_len);
4191                     }
4192                   write (listdesc, "\n", 1);
4193                   write (listdesc, auto_save_file_name_ext,
4194                          auto_save_file_name_ext_len);
4195                   write (listdesc, "\n", 1);
4196                 }
4197
4198               /* dmoore - In a bad scenario we've set b=XBUFFER(buf)
4199                  based on values in Vbuffer_alist.  auto_save_1 may
4200                  cause lisp handlers to run.  Those handlers may kill
4201                  the buffer and then GC.  Since the buffer is killed,
4202                  it's no longer in Vbuffer_alist so it might get reaped
4203                  by the GC.  We also need to protect tail. */
4204               /* #### There is probably a lot of other code which has
4205                  pointers into buffers which may get blown away by
4206                  handlers. */
4207               {
4208                 struct gcpro ngcpro1, ngcpro2;
4209                 NGCPRO2 (buf, tail);
4210                 condition_case_1 (Qt,
4211                                   auto_save_1, Qnil,
4212                                   auto_save_error, Qnil);
4213                 NUNGCPRO;
4214               }
4215               /* Handler killed our saved current-buffer!  Pick any. */
4216               if (!BUFFER_LIVE_P (XBUFFER (old)))
4217                 XSETBUFFER (old, current_buffer);
4218
4219               set_buffer_internal (XBUFFER (old));
4220               auto_saved++;
4221
4222               /* Handler killed their own buffer! */
4223               if (!BUFFER_LIVE_P(b))
4224                 continue;
4225
4226               b->auto_save_modified = BUF_MODIFF (b);
4227               b->saved_size = make_int (BUF_SIZE (b));
4228               EMACS_GET_TIME (after_time);
4229               /* If auto-save took more than 60 seconds,
4230                  assume it was an NFS failure that got a timeout.  */
4231               if (EMACS_SECS (after_time) - EMACS_SECS (before_time) > 60)
4232                 b->auto_save_failure_time = EMACS_SECS (after_time);
4233             }
4234         }
4235     }
4236
4237   /* Prevent another auto save till enough input events come in.  */
4238   if (auto_saved)
4239     record_auto_save ();
4240
4241   /* If we didn't save anything into the listfile, remove the old
4242      one because nothing needed to be auto-saved.  Do this afterwards
4243      rather than before in case we get a crash attempting to autosave
4244      (in that case we'd still want the old one around). */
4245   if (listdesc < 0 && !auto_saved && STRINGP (listfile))
4246     unlink ((char *) XSTRING_DATA (listfile));
4247
4248   /* Show "...done" only if the echo area would otherwise be empty. */
4249   if (auto_saved && NILP (no_message)
4250       && NILP (clear_echo_area (selected_frame (), Qauto_saving, 0)))
4251     {
4252       static const unsigned char *msg
4253         = (const unsigned char *)"Auto-saving...done";
4254       echo_area_message (selected_frame (), msg, Qnil, 0,
4255                          strlen ((const char *) msg), Qauto_saving);
4256     }
4257
4258   Vquit_flag = oquit;
4259
4260   RETURN_UNGCPRO (unbind_to (speccount, Qnil));
4261 }
4262
4263 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved, 0, 0, 0, /*
4264 Mark current buffer as auto-saved with its current text.
4265 No auto-save file will be written until the buffer changes again.
4266 */
4267        ())
4268 {
4269   current_buffer->auto_save_modified = BUF_MODIFF (current_buffer);
4270   current_buffer->saved_size = make_int (BUF_SIZE (current_buffer));
4271   current_buffer->auto_save_failure_time = -1;
4272   return Qnil;
4273 }
4274
4275 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure, 0, 0, 0, /*
4276 Clear any record of a recent auto-save failure in the current buffer.
4277 */
4278        ())
4279 {
4280   current_buffer->auto_save_failure_time = -1;
4281   return Qnil;
4282 }
4283
4284 DEFUN ("recent-auto-save-p", Frecent_auto_save_p, 0, 0, 0, /*
4285 Return t if buffer has been auto-saved since last read in or saved.
4286 */
4287        ())
4288 {
4289   return (BUF_SAVE_MODIFF (current_buffer) <
4290           current_buffer->auto_save_modified) ? Qt : Qnil;
4291 }
4292
4293 \f
4294 /************************************************************************/
4295 /*                            initialization                            */
4296 /************************************************************************/
4297
4298 void
4299 syms_of_fileio (void)
4300 {
4301   defsymbol (&Qexpand_file_name, "expand-file-name");
4302   defsymbol (&Qfile_truename, "file-truename");
4303   defsymbol (&Qsubstitute_in_file_name, "substitute-in-file-name");
4304   defsymbol (&Qdirectory_file_name, "directory-file-name");
4305   defsymbol (&Qfile_name_directory, "file-name-directory");
4306   defsymbol (&Qfile_name_nondirectory, "file-name-nondirectory");
4307   defsymbol (&Qunhandled_file_name_directory, "unhandled-file-name-directory");
4308   defsymbol (&Qfile_name_as_directory, "file-name-as-directory");
4309   defsymbol (&Qcopy_file, "copy-file");
4310   defsymbol (&Qmake_directory_internal, "make-directory-internal");
4311   defsymbol (&Qdelete_directory, "delete-directory");
4312   defsymbol (&Qdelete_file, "delete-file");
4313   defsymbol (&Qrename_file, "rename-file");
4314   defsymbol (&Qadd_name_to_file, "add-name-to-file");
4315   defsymbol (&Qmake_symbolic_link, "make-symbolic-link");
4316   defsymbol (&Qfile_exists_p, "file-exists-p");
4317   defsymbol (&Qfile_executable_p, "file-executable-p");
4318   defsymbol (&Qfile_readable_p, "file-readable-p");
4319   defsymbol (&Qfile_symlink_p, "file-symlink-p");
4320   defsymbol (&Qfile_writable_p, "file-writable-p");
4321   defsymbol (&Qfile_directory_p, "file-directory-p");
4322   defsymbol (&Qfile_regular_p, "file-regular-p");
4323   defsymbol (&Qfile_accessible_directory_p, "file-accessible-directory-p");
4324   defsymbol (&Qfile_modes, "file-modes");
4325   defsymbol (&Qset_file_modes, "set-file-modes");
4326   defsymbol (&Qfile_newer_than_file_p, "file-newer-than-file-p");
4327   defsymbol (&Qinsert_file_contents, "insert-file-contents");
4328   defsymbol (&Qwrite_region, "write-region");
4329   defsymbol (&Qverify_visited_file_modtime, "verify-visited-file-modtime");
4330   defsymbol (&Qset_visited_file_modtime, "set-visited-file-modtime");
4331   defsymbol (&Qcar_less_than_car, "car-less-than-car"); /* Vomitous! */
4332
4333   defsymbol (&Qauto_save_hook, "auto-save-hook");
4334   defsymbol (&Qauto_save_error, "auto-save-error");
4335   defsymbol (&Qauto_saving, "auto-saving");
4336
4337   defsymbol (&Qformat_decode, "format-decode");
4338   defsymbol (&Qformat_annotate_function, "format-annotate-function");
4339
4340   defsymbol (&Qcompute_buffer_file_truename, "compute-buffer-file-truename");
4341   DEFERROR_STANDARD (Qfile_error, Qio_error);
4342   DEFERROR_STANDARD (Qfile_already_exists, Qfile_error);
4343
4344   DEFSUBR (Ffind_file_name_handler);
4345
4346   DEFSUBR (Ffile_name_directory);
4347   DEFSUBR (Ffile_name_nondirectory);
4348   DEFSUBR (Funhandled_file_name_directory);
4349   DEFSUBR (Ffile_name_as_directory);
4350   DEFSUBR (Fdirectory_file_name);
4351   DEFSUBR (Fmake_temp_name);
4352   DEFSUBR (Fexpand_file_name);
4353   DEFSUBR (Ffile_truename);
4354   DEFSUBR (Fsubstitute_in_file_name);
4355   DEFSUBR (Fcopy_file);
4356   DEFSUBR (Fmake_directory_internal);
4357   DEFSUBR (Fdelete_directory);
4358   DEFSUBR (Fdelete_file);
4359   DEFSUBR (Frename_file);
4360   DEFSUBR (Fadd_name_to_file);
4361   DEFSUBR (Fmake_symbolic_link);
4362 #ifdef HPUX_NET
4363   DEFSUBR (Fsysnetunam);
4364 #endif /* HPUX_NET */
4365   DEFSUBR (Ffile_name_absolute_p);
4366   DEFSUBR (Ffile_exists_p);
4367   DEFSUBR (Ffile_executable_p);
4368   DEFSUBR (Ffile_readable_p);
4369   DEFSUBR (Ffile_writable_p);
4370   DEFSUBR (Ffile_symlink_p);
4371   DEFSUBR (Ffile_directory_p);
4372   DEFSUBR (Ffile_accessible_directory_p);
4373   DEFSUBR (Ffile_regular_p);
4374   DEFSUBR (Ffile_modes);
4375   DEFSUBR (Fset_file_modes);
4376   DEFSUBR (Fset_default_file_modes);
4377   DEFSUBR (Fdefault_file_modes);
4378   DEFSUBR (Funix_sync);
4379   DEFSUBR (Ffile_newer_than_file_p);
4380   DEFSUBR (Finsert_file_contents_internal);
4381   DEFSUBR (Fwrite_region_internal);
4382   DEFSUBR (Fcar_less_than_car); /* Vomitous! */
4383   DEFSUBR (Fcdr_less_than_cdr); /* Yeah oh yeah bucko .... */
4384 #if 0
4385   DEFSUBR (Fencrypt_string);
4386   DEFSUBR (Fdecrypt_string);
4387 #endif
4388   DEFSUBR (Fverify_visited_file_modtime);
4389   DEFSUBR (Fclear_visited_file_modtime);
4390   DEFSUBR (Fvisited_file_modtime);
4391   DEFSUBR (Fset_visited_file_modtime);
4392
4393   DEFSUBR (Fdo_auto_save);
4394   DEFSUBR (Fset_buffer_auto_saved);
4395   DEFSUBR (Fclear_buffer_auto_save_failure);
4396   DEFSUBR (Frecent_auto_save_p);
4397 }
4398
4399 void
4400 vars_of_fileio (void)
4401 {
4402   DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format /*
4403 *Format in which to write auto-save files.
4404 Should be a list of symbols naming formats that are defined in `format-alist'.
4405 If it is t, which is the default, auto-save files are written in the
4406 same format as a regular save would use.
4407 */ );
4408   Vauto_save_file_format = Qt;
4409
4410   DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist /*
4411 *Alist of elements (REGEXP . HANDLER) for file names handled specially.
4412 If a file name matches REGEXP, then all I/O on that file is done by calling
4413 HANDLER.
4414
4415 The first argument given to HANDLER is the name of the I/O primitive
4416 to be handled; the remaining arguments are the arguments that were
4417 passed to that primitive.  For example, if you do
4418     (file-exists-p FILENAME)
4419 and FILENAME is handled by HANDLER, then HANDLER is called like this:
4420     (funcall HANDLER 'file-exists-p FILENAME)
4421 The function `find-file-name-handler' checks this list for a handler
4422 for its argument.
4423 */ );
4424   Vfile_name_handler_alist = Qnil;
4425
4426   DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions /*
4427 A list of functions to be called at the end of `insert-file-contents'.
4428 Each is passed one argument, the number of bytes inserted.  It should return
4429 the new byte count, and leave point the same.  If `insert-file-contents' is
4430 intercepted by a handler from `file-name-handler-alist', that handler is
4431 responsible for calling the after-insert-file-functions if appropriate.
4432 */ );
4433   Vafter_insert_file_functions = Qnil;
4434
4435   DEFVAR_LISP ("write-region-annotate-functions",
4436                &Vwrite_region_annotate_functions /*
4437 A list of functions to be called at the start of `write-region'.
4438 Each is passed two arguments, START and END, as for `write-region'.
4439 It should return a list of pairs (POSITION . STRING) of strings to be
4440 effectively inserted at the specified positions of the file being written
4441 \(1 means to insert before the first byte written).  The POSITIONs must be
4442 sorted into increasing order.  If there are several functions in the list,
4443 the several lists are merged destructively.
4444 */ );
4445   Vwrite_region_annotate_functions = Qnil;
4446
4447   DEFVAR_LISP ("write-region-annotations-so-far",
4448                &Vwrite_region_annotations_so_far /*
4449 When an annotation function is called, this holds the previous annotations.
4450 These are the annotations made by other annotation functions
4451 that were already called.  See also `write-region-annotate-functions'.
4452 */ );
4453   Vwrite_region_annotations_so_far = Qnil;
4454
4455   DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers /*
4456 A list of file name handlers that temporarily should not be used.
4457 This applies only to the operation `inhibit-file-name-operation'.
4458 */ );
4459   Vinhibit_file_name_handlers = Qnil;
4460
4461   DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation /*
4462 The operation for which `inhibit-file-name-handlers' is applicable.
4463 */ );
4464   Vinhibit_file_name_operation = Qnil;
4465
4466   DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name /*
4467 File name in which we write a list of all auto save file names.
4468 */ );
4469   Vauto_save_list_file_name = Qnil;
4470
4471   DEFVAR_LISP ("auto-save-list-file-prefix", &Vauto_save_list_file_prefix /*
4472 Prefix for generating auto-save-list-file-name.
4473 Emacs's pid and the system name will be appended to
4474 this prefix to create a unique file name.
4475 */ );
4476   Vauto_save_list_file_prefix = build_string ("~/.saves-");
4477
4478   DEFVAR_BOOL ("inhibit-auto-save-session", &inhibit_auto_save_session /*
4479 When non-nil, inhibit auto save list file creation.
4480 */ );
4481   inhibit_auto_save_session = 0;
4482
4483   DEFVAR_BOOL ("disable-auto-save-when-buffer-shrinks",
4484                &disable_auto_save_when_buffer_shrinks /*
4485 If non-nil, auto-saving is disabled when a buffer shrinks too much.
4486 This is to prevent you from losing your edits if you accidentally
4487 delete a large chunk of the buffer and don't notice it until too late.
4488 Saving the buffer normally turns auto-save back on.
4489 */ );
4490   disable_auto_save_when_buffer_shrinks = 1;
4491
4492   DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char /*
4493 Directory separator character for built-in functions that return file names.
4494 The value should be either ?/ or ?\\ (any other value is treated as ?\\).
4495 This variable affects the built-in functions only on Windows,
4496 on other platforms, it is initialized so that Lisp code can find out
4497 what the normal separator is.
4498 */ );
4499 #ifdef WIN32_NATIVE
4500   Vdirectory_sep_char = make_char ('\\');
4501 #else
4502   Vdirectory_sep_char = make_char ('/');
4503 #endif
4504
4505   reinit_vars_of_fileio ();
4506 }
4507
4508 void
4509 reinit_vars_of_fileio (void)
4510 {
4511   /* We want temp_name_rand to be initialized to a value likely to be
4512      unique to the process, not to the executable.  The danger is that
4513      two different XEmacs processes using the same binary on different
4514      machines creating temp files in the same directory will be
4515      unlucky enough to have the same pid.  If we randomize using
4516      process startup time, then in practice they will be unlikely to
4517      collide. We use the microseconds field so that scripts that start
4518      simultaneous XEmacs processes on multiple machines will have less
4519      chance of collision.  */
4520   {
4521     EMACS_TIME thyme;
4522
4523     EMACS_GET_TIME (thyme);
4524     temp_name_rand = (unsigned int) (EMACS_SECS (thyme) ^ EMACS_USECS (thyme));
4525   }
4526 }