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