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