comparison src/fileio.c @ 428:3ecd8885ac67 r21-2-22

Import from CVS: tag r21-2-22
author cvs
date Mon, 13 Aug 2007 11:28:15 +0200
parents
children 3a7e78e1142d
comparison
equal deleted inserted replaced
427:0a0253eac470 428:3ecd8885ac67
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 Vdirectory_sep_char;
113
114 /* These variables describe handlers that have "already" had a chance
115 to handle the current operation.
116
117 Vinhibit_file_name_handlers is a list of file name handlers.
118 Vinhibit_file_name_operation is the operation being handled.
119 If we try to handle that operation, we ignore those handlers. */
120
121 static Lisp_Object Vinhibit_file_name_handlers;
122 static Lisp_Object Vinhibit_file_name_operation;
123
124 Lisp_Object Qfile_error, Qfile_already_exists;
125
126 Lisp_Object Qauto_save_hook;
127 Lisp_Object Qauto_save_error;
128 Lisp_Object Qauto_saving;
129
130 Lisp_Object Qcar_less_than_car;
131
132 Lisp_Object Qcompute_buffer_file_truename;
133
134 EXFUN (Frunning_temacs_p, 0);
135
136 /* signal a file error when errno contains a meaningful value. */
137
138 DOESNT_RETURN
139 report_file_error (CONST char *string, Lisp_Object data)
140 {
141 /* #### dmoore - This uses current_buffer, better make sure no one
142 has GC'd the current buffer. File handlers are giving me a headache
143 maybe I'll just always protect current_buffer around all of those
144 calls. */
145
146 signal_error (Qfile_error,
147 Fcons (build_translated_string (string),
148 Fcons (lisp_strerror (errno), data)));
149 }
150
151 void
152 maybe_report_file_error (CONST char *string, Lisp_Object data,
153 Lisp_Object class, Error_behavior errb)
154 {
155 /* Optimization: */
156 if (ERRB_EQ (errb, ERROR_ME_NOT))
157 return;
158
159 maybe_signal_error (Qfile_error,
160 Fcons (build_translated_string (string),
161 Fcons (lisp_strerror (errno), data)),
162 class, errb);
163 }
164
165 /* signal a file error when errno does not contain a meaningful value. */
166
167 DOESNT_RETURN
168 signal_file_error (CONST char *string, Lisp_Object data)
169 {
170 signal_error (Qfile_error,
171 list2 (build_translated_string (string), data));
172 }
173
174 void
175 maybe_signal_file_error (CONST char *string, Lisp_Object data,
176 Lisp_Object class, Error_behavior errb)
177 {
178 /* Optimization: */
179 if (ERRB_EQ (errb, ERROR_ME_NOT))
180 return;
181 maybe_signal_error (Qfile_error,
182 list2 (build_translated_string (string), data),
183 class, errb);
184 }
185
186 DOESNT_RETURN
187 signal_double_file_error (CONST char *string1, CONST char *string2,
188 Lisp_Object data)
189 {
190 signal_error (Qfile_error,
191 list3 (build_translated_string (string1),
192 build_translated_string (string2),
193 data));
194 }
195
196 void
197 maybe_signal_double_file_error (CONST char *string1, CONST char *string2,
198 Lisp_Object data, Lisp_Object class,
199 Error_behavior errb)
200 {
201 /* Optimization: */
202 if (ERRB_EQ (errb, ERROR_ME_NOT))
203 return;
204 maybe_signal_error (Qfile_error,
205 list3 (build_translated_string (string1),
206 build_translated_string (string2),
207 data),
208 class, errb);
209 }
210
211 DOESNT_RETURN
212 signal_double_file_error_2 (CONST char *string1, CONST char *string2,
213 Lisp_Object data1, Lisp_Object data2)
214 {
215 signal_error (Qfile_error,
216 list4 (build_translated_string (string1),
217 build_translated_string (string2),
218 data1, data2));
219 }
220
221 void
222 maybe_signal_double_file_error_2 (CONST char *string1, CONST char *string2,
223 Lisp_Object data1, Lisp_Object data2,
224 Lisp_Object class, Error_behavior errb)
225 {
226 /* Optimization: */
227 if (ERRB_EQ (errb, ERROR_ME_NOT))
228 return;
229 maybe_signal_error (Qfile_error,
230 list4 (build_translated_string (string1),
231 build_translated_string (string2),
232 data1, data2),
233 class, errb);
234 }
235
236
237 /* Just like strerror(3), except return a lisp string instead of char *.
238 The string needs to be converted since it may be localized.
239 Perhaps this should use strerror-coding-system instead? */
240 Lisp_Object
241 lisp_strerror (int errnum)
242 {
243 return build_ext_string (strerror (errnum), FORMAT_NATIVE);
244 }
245
246 static Lisp_Object
247 close_file_unwind (Lisp_Object fd)
248 {
249 if (CONSP (fd))
250 {
251 if (INTP (XCAR (fd)))
252 close (XINT (XCAR (fd)));
253
254 free_cons (XCONS (fd));
255 }
256 else
257 close (XINT (fd));
258
259 return Qnil;
260 }
261
262 static Lisp_Object
263 delete_stream_unwind (Lisp_Object stream)
264 {
265 Lstream_delete (XLSTREAM (stream));
266 return Qnil;
267 }
268
269 /* Restore point, having saved it as a marker. */
270
271 static Lisp_Object
272 restore_point_unwind (Lisp_Object point_marker)
273 {
274 BUF_SET_PT (current_buffer, marker_position (point_marker));
275 return Fset_marker (point_marker, Qnil, Qnil);
276 }
277
278 /* Versions of read() and write() that allow quitting out of the actual
279 I/O. We don't use immediate_quit (i.e. direct longjmp() out of the
280 signal handler) because that's way too losing.
281
282 (#### Actually, longjmp()ing out of the signal handler may not be
283 as losing as I thought. See sys_do_signal() in sysdep.c.) */
284
285 ssize_t
286 read_allowing_quit (int fildes, void *buf, size_t size)
287 {
288 QUIT;
289 return sys_read_1 (fildes, buf, size, 1);
290 }
291
292 ssize_t
293 write_allowing_quit (int fildes, CONST void *buf, size_t size)
294 {
295 QUIT;
296 return sys_write_1 (fildes, buf, size, 1);
297 }
298
299
300 Lisp_Object Qexpand_file_name;
301 Lisp_Object Qfile_truename;
302 Lisp_Object Qsubstitute_in_file_name;
303 Lisp_Object Qdirectory_file_name;
304 Lisp_Object Qfile_name_directory;
305 Lisp_Object Qfile_name_nondirectory;
306 Lisp_Object Qunhandled_file_name_directory;
307 Lisp_Object Qfile_name_as_directory;
308 Lisp_Object Qcopy_file;
309 Lisp_Object Qmake_directory_internal;
310 Lisp_Object Qdelete_directory;
311 Lisp_Object Qdelete_file;
312 Lisp_Object Qrename_file;
313 Lisp_Object Qadd_name_to_file;
314 Lisp_Object Qmake_symbolic_link;
315 Lisp_Object Qfile_exists_p;
316 Lisp_Object Qfile_executable_p;
317 Lisp_Object Qfile_readable_p;
318 Lisp_Object Qfile_symlink_p;
319 Lisp_Object Qfile_writable_p;
320 Lisp_Object Qfile_directory_p;
321 Lisp_Object Qfile_regular_p;
322 Lisp_Object Qfile_accessible_directory_p;
323 Lisp_Object Qfile_modes;
324 Lisp_Object Qset_file_modes;
325 Lisp_Object Qfile_newer_than_file_p;
326 Lisp_Object Qinsert_file_contents;
327 Lisp_Object Qwrite_region;
328 Lisp_Object Qverify_visited_file_modtime;
329 Lisp_Object Qset_visited_file_modtime;
330
331 /* If FILENAME is handled specially on account of its syntax,
332 return its handler function. Otherwise, return nil. */
333
334 DEFUN ("find-file-name-handler", Ffind_file_name_handler, 1, 2, 0, /*
335 Return FILENAME's handler function for OPERATION, if it has one.
336 Otherwise, return nil.
337 A file name is handled if one of the regular expressions in
338 `file-name-handler-alist' matches it.
339
340 If OPERATION equals `inhibit-file-name-operation', then we ignore
341 any handlers that are members of `inhibit-file-name-handlers',
342 but we still do run any other handlers. This lets handlers
343 use the standard functions without calling themselves recursively.
344 */
345 (filename, operation))
346 {
347 /* This function does not GC */
348 /* This function can be called during GC */
349 /* This function must not munge the match data. */
350 Lisp_Object chain, inhibited_handlers;
351
352 CHECK_STRING (filename);
353
354 if (EQ (operation, Vinhibit_file_name_operation))
355 inhibited_handlers = Vinhibit_file_name_handlers;
356 else
357 inhibited_handlers = Qnil;
358
359 EXTERNAL_LIST_LOOP (chain, Vfile_name_handler_alist)
360 {
361 Lisp_Object elt = XCAR (chain);
362 if (CONSP (elt))
363 {
364 Lisp_Object string = XCAR (elt);
365 if (STRINGP (string)
366 && (fast_lisp_string_match (string, filename) >= 0))
367 {
368 Lisp_Object handler = XCDR (elt);
369 if (NILP (Fmemq (handler, inhibited_handlers)))
370 return handler;
371 }
372 }
373 QUIT;
374 }
375 return Qnil;
376 }
377
378 static Lisp_Object
379 call2_check_string (Lisp_Object fn, Lisp_Object arg0, Lisp_Object arg1)
380 {
381 /* This function can call lisp */
382 Lisp_Object result = call2 (fn, arg0, arg1);
383 CHECK_STRING (result);
384 return result;
385 }
386
387 static Lisp_Object
388 call2_check_string_or_nil (Lisp_Object fn, Lisp_Object arg0, Lisp_Object arg1)
389 {
390 /* This function can call lisp */
391 Lisp_Object result = call2 (fn, arg0, arg1);
392 if (!NILP (result))
393 CHECK_STRING (result);
394 return result;
395 }
396
397 static Lisp_Object
398 call3_check_string (Lisp_Object fn, Lisp_Object arg0,
399 Lisp_Object arg1, Lisp_Object arg2)
400 {
401 /* This function can call lisp */
402 Lisp_Object result = call3 (fn, arg0, arg1, arg2);
403 CHECK_STRING (result);
404 return result;
405 }
406
407
408 DEFUN ("file-name-directory", Ffile_name_directory, 1, 1, 0, /*
409 Return the directory component in file name NAME.
410 Return nil if NAME does not include a directory.
411 Otherwise return a directory spec.
412 Given a Unix syntax file name, returns a string ending in slash.
413 */
414 (file))
415 {
416 /* This function can GC. GC checked 1997.04.06. */
417 Bufbyte *beg;
418 Bufbyte *p;
419 Lisp_Object handler;
420
421 CHECK_STRING (file);
422
423 /* If the file name has special constructs in it,
424 call the corresponding file handler. */
425 handler = Ffind_file_name_handler (file, Qfile_name_directory);
426 if (!NILP (handler))
427 return call2_check_string_or_nil (handler, Qfile_name_directory, file);
428
429 #ifdef FILE_SYSTEM_CASE
430 file = FILE_SYSTEM_CASE (file);
431 #endif
432 beg = XSTRING_DATA (file);
433 p = beg + XSTRING_LENGTH (file);
434
435 while (p != beg && !IS_ANY_SEP (p[-1])
436 #ifdef WINDOWSNT
437 /* only recognize drive specifier at beginning */
438 && !(p[-1] == ':' && p == beg + 2)
439 #endif
440 ) p--;
441
442 if (p == beg)
443 return Qnil;
444 #ifdef WINDOWSNT
445 /* Expansion of "c:" to drive and default directory. */
446 /* (NT does the right thing.) */
447 if (p == beg + 2 && beg[1] == ':')
448 {
449 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
450 Bufbyte *res = alloca (MAXPATHLEN + 1);
451 if (getdefdir (toupper (*beg) - 'A' + 1, res))
452 {
453 char *c=((char *) res) + strlen ((char *) res);
454 if (!IS_DIRECTORY_SEP (*c))
455 {
456 *c++ = DIRECTORY_SEP;
457 *c = '\0';
458 }
459 beg = res;
460 p = beg + strlen ((char *) beg);
461 }
462 }
463 #endif /* WINDOWSNT */
464 return make_string (beg, p - beg);
465 }
466
467 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory, 1, 1, 0, /*
468 Return file name NAME sans its directory.
469 For example, in a Unix-syntax file name,
470 this is everything after the last slash,
471 or the entire name if it contains no slash.
472 */
473 (file))
474 {
475 /* This function can GC. GC checked 1997.04.06. */
476 Bufbyte *beg, *p, *end;
477 Lisp_Object handler;
478
479 CHECK_STRING (file);
480
481 /* If the file name has special constructs in it,
482 call the corresponding file handler. */
483 handler = Ffind_file_name_handler (file, Qfile_name_nondirectory);
484 if (!NILP (handler))
485 return call2_check_string (handler, Qfile_name_nondirectory, file);
486
487 beg = XSTRING_DATA (file);
488 end = p = beg + XSTRING_LENGTH (file);
489
490 while (p != beg && !IS_ANY_SEP (p[-1])
491 #ifdef WINDOWSNT
492 /* only recognize drive specifier at beginning */
493 && !(p[-1] == ':' && p == beg + 2)
494 #endif
495 ) p--;
496
497 return make_string (p, end - p);
498 }
499
500 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory, 1, 1, 0, /*
501 Return a directly usable directory name somehow associated with FILENAME.
502 A `directly usable' directory name is one that may be used without the
503 intervention of any file handler.
504 If FILENAME is a directly usable file itself, return
505 \(file-name-directory FILENAME).
506 The `call-process' and `start-process' functions use this function to
507 get a current directory to run processes in.
508 */
509 (filename))
510 {
511 /* This function can GC. GC checked 1997.04.06. */
512 Lisp_Object handler;
513
514 /* If the file name has special constructs in it,
515 call the corresponding file handler. */
516 handler = Ffind_file_name_handler (filename, Qunhandled_file_name_directory);
517 if (!NILP (handler))
518 return call2 (handler, Qunhandled_file_name_directory,
519 filename);
520
521 return Ffile_name_directory (filename);
522 }
523
524
525 static char *
526 file_name_as_directory (char *out, char *in)
527 {
528 int size = strlen (in);
529
530 if (size == 0)
531 {
532 out[0] = '.';
533 out[1] = DIRECTORY_SEP;
534 out[2] = '\0';
535 }
536 else
537 {
538 strcpy (out, in);
539 /* Append a slash if necessary */
540 if (!IS_ANY_SEP (out[size-1]))
541 {
542 out[size] = DIRECTORY_SEP;
543 out[size + 1] = '\0';
544 }
545 }
546 return out;
547 }
548
549 DEFUN ("file-name-as-directory", Ffile_name_as_directory, 1, 1, 0, /*
550 Return a string representing file FILENAME interpreted as a directory.
551 This operation exists because a directory is also a file, but its name as
552 a directory is different from its name as a file.
553 The result can be used as the value of `default-directory'
554 or passed as second argument to `expand-file-name'.
555 For a Unix-syntax file name, just appends a slash,
556 except for (file-name-as-directory \"\") => \"./\".
557 */
558 (file))
559 {
560 /* This function can GC. GC checked 1997.04.06. */
561 char *buf;
562 Lisp_Object handler;
563
564 CHECK_STRING (file);
565
566 /* If the file name has special constructs in it,
567 call the corresponding file handler. */
568 handler = Ffind_file_name_handler (file, Qfile_name_as_directory);
569 if (!NILP (handler))
570 return call2_check_string (handler, Qfile_name_as_directory, file);
571
572 buf = (char *) alloca (XSTRING_LENGTH (file) + 10);
573 return build_string (file_name_as_directory
574 (buf, (char *) XSTRING_DATA (file)));
575 }
576
577 /*
578 * Convert from directory name to filename.
579 * On UNIX, it's simple: just make sure there isn't a terminating /
580 *
581 * Value is nonzero if the string output is different from the input.
582 */
583
584 static int
585 directory_file_name (CONST char *src, char *dst)
586 {
587 long slen;
588
589 slen = strlen (src);
590 /* Process as Unix format: just remove any final slash.
591 But leave "/" unchanged; do not change it to "". */
592 strcpy (dst, src);
593 #ifdef APOLLO
594 /* Handle // as root for apollo's. */
595 if ((slen > 2 && dst[slen - 1] == '/')
596 || (slen > 1 && dst[0] != '/' && dst[slen - 1] == '/'))
597 dst[slen - 1] = 0;
598 #else
599 if (slen > 1
600 && IS_DIRECTORY_SEP (dst[slen - 1])
601 #ifdef WINDOWSNT
602 && !IS_ANY_SEP (dst[slen - 2])
603 #endif /* WINDOWSNT */
604 )
605 dst[slen - 1] = 0;
606 #endif /* APOLLO */
607 return 1;
608 }
609
610 DEFUN ("directory-file-name", Fdirectory_file_name, 1, 1, 0, /*
611 Return the file name of the directory named DIR.
612 This is the name of the file that holds the data for the directory DIR.
613 This operation exists because a directory is also a file, but its name as
614 a directory is different from its name as a file.
615 In Unix-syntax, this function just removes the final slash.
616 */
617 (directory))
618 {
619 /* This function can GC. GC checked 1997.04.06. */
620 char *buf;
621 Lisp_Object handler;
622
623 CHECK_STRING (directory);
624
625 #if 0 /* #### WTF? */
626 if (NILP (directory))
627 return Qnil;
628 #endif
629
630 /* If the file name has special constructs in it,
631 call the corresponding file handler. */
632 handler = Ffind_file_name_handler (directory, Qdirectory_file_name);
633 if (!NILP (handler))
634 return call2_check_string (handler, Qdirectory_file_name, directory);
635 buf = (char *) alloca (XSTRING_LENGTH (directory) + 20);
636 directory_file_name ((char *) XSTRING_DATA (directory), buf);
637 return build_string (buf);
638 }
639
640 /* Fmake_temp_name used to be a simple wrapper around mktemp(), but it
641 proved too broken for our purposes (it supported only 26 or 62
642 unique names under some implementations). For example, this
643 arbitrary limit broke generation of Gnus Incoming* files.
644
645 This implementation is better than what one usually finds in libc.
646 --hniksic */
647
648 DEFUN ("make-temp-name", Fmake_temp_name, 1, 1, 0, /*
649 Generate temporary file name starting with PREFIX.
650 The Emacs process number forms part of the result, so there is no
651 danger of generating a name being used by another process.
652
653 In addition, this function makes an attempt to choose a name that
654 does not specify an existing file. To make this work, PREFIX should
655 be an absolute file name.
656 */
657 (prefix))
658 {
659 static char tbl[64] = {
660 'A','B','C','D','E','F','G','H',
661 'I','J','K','L','M','N','O','P',
662 'Q','R','S','T','U','V','W','X',
663 'Y','Z','a','b','c','d','e','f',
664 'g','h','i','j','k','l','m','n',
665 'o','p','q','r','s','t','u','v',
666 'w','x','y','z','0','1','2','3',
667 '4','5','6','7','8','9','-','_' };
668 static unsigned count, count_initialized_p;
669
670 Lisp_Object val;
671 Bytecount len;
672 Bufbyte *p, *data;
673 unsigned pid;
674
675 CHECK_STRING (prefix);
676
677 /* I was tempted to apply Fexpand_file_name on PREFIX here, but it's
678 a bad idea because:
679
680 1) It might change the prefix, so the resulting string might not
681 begin with PREFIX. This violates the principle of least
682 surprise.
683
684 2) It breaks under many unforeseeable circumstances, such as with
685 the code that uses (make-temp-name "") instead of
686 (make-temp-name "./").
687
688 3) It might yield unexpected (to stat(2)) results in the presence
689 of EFS and file name handlers. */
690
691 len = XSTRING_LENGTH (prefix);
692 val = make_uninit_string (len + 6);
693 data = XSTRING_DATA (val);
694 memcpy (data, XSTRING_DATA (prefix), len);
695 p = data + len;
696
697 /* VAL is created by adding 6 characters to PREFIX. The first three
698 are the PID of this process, in base 64, and the second three are
699 incremented if the file already exists. This ensures 262144
700 unique file names per PID per PREFIX. */
701
702 pid = (unsigned)getpid ();
703 *p++ = tbl[pid & 63], pid >>= 6;
704 *p++ = tbl[pid & 63], pid >>= 6;
705 *p++ = tbl[pid & 63], pid >>= 6;
706
707 /* Here we try to minimize useless stat'ing when this function is
708 invoked many times successively with the same PREFIX. We achieve
709 this by initializing count to a random value, and incrementing it
710 afterwards. */
711 if (!count_initialized_p)
712 {
713 count = (unsigned)time (NULL);
714 /* Dumping temacs with a non-zero count_initialized_p wouldn't
715 make much sense. */
716 if (NILP (Frunning_temacs_p ()))
717 count_initialized_p = 1;
718 }
719
720 while (1)
721 {
722 struct stat ignored;
723 unsigned num = count;
724
725 p[0] = tbl[num & 63], num >>= 6;
726 p[1] = tbl[num & 63], num >>= 6;
727 p[2] = tbl[num & 63], num >>= 6;
728
729 /* Poor man's congruential RN generator. Replace with ++count
730 for debugging. */
731 count += 25229;
732 count %= 225307;
733
734 QUIT;
735
736 if (stat ((CONST char *) data, &ignored) < 0)
737 {
738 /* We want to return only if errno is ENOENT. */
739 if (errno == ENOENT)
740 return val;
741
742 /* The error here is dubious, but there is little else we
743 can do. The alternatives are to return nil, which is
744 as bad as (and in many cases worse than) throwing the
745 error, or to ignore the error, which will likely result
746 in inflooping. */
747 report_file_error ("Cannot create temporary name for prefix",
748 list1 (prefix));
749 return Qnil; /* not reached */
750 }
751 }
752 }
753
754
755 DEFUN ("expand-file-name", Fexpand_file_name, 1, 2, 0, /*
756 Convert filename NAME to absolute, and canonicalize it.
757 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative
758 (does not start with slash); if DEFAULT-DIRECTORY is nil or missing,
759 the current buffer's value of default-directory is used.
760 File name components that are `.' are removed, and
761 so are file name components followed by `..', along with the `..' itself;
762 note that these simplifications are done without checking the resulting
763 file names in the file system.
764 An initial `~/' expands to your home directory.
765 An initial `~USER/' expands to USER's home directory.
766 See also the function `substitute-in-file-name'.
767 */
768 (name, default_directory))
769 {
770 /* This function can GC */
771 Bufbyte *nm;
772
773 Bufbyte *newdir, *p, *o;
774 int tlen;
775 Bufbyte *target;
776 #ifdef WINDOWSNT
777 int drive = 0;
778 int collapse_newdir = 1;
779 #else
780 struct passwd *pw;
781 #endif /* WINDOWSNT */
782 int length;
783 Lisp_Object handler;
784 #ifdef __CYGWIN32__
785 char *user;
786 #endif
787
788 CHECK_STRING (name);
789
790 /* If the file name has special constructs in it,
791 call the corresponding file handler. */
792 handler = Ffind_file_name_handler (name, Qexpand_file_name);
793 if (!NILP (handler))
794 return call3_check_string (handler, Qexpand_file_name, name,
795 default_directory);
796
797 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
798 if (NILP (default_directory))
799 default_directory = current_buffer->directory;
800 if (! STRINGP (default_directory))
801 default_directory = build_string ("/");
802
803 if (!NILP (default_directory))
804 {
805 handler = Ffind_file_name_handler (default_directory, Qexpand_file_name);
806 if (!NILP (handler))
807 return call3 (handler, Qexpand_file_name, name, default_directory);
808 }
809
810 o = XSTRING_DATA (default_directory);
811
812 /* Make sure DEFAULT_DIRECTORY is properly expanded.
813 It would be better to do this down below where we actually use
814 default_directory. Unfortunately, calling Fexpand_file_name recursively
815 could invoke GC, and the strings might be relocated. This would
816 be annoying because we have pointers into strings lying around
817 that would need adjusting, and people would add new pointers to
818 the code and forget to adjust them, resulting in intermittent bugs.
819 Putting this call here avoids all that crud.
820
821 The EQ test avoids infinite recursion. */
822 if (! NILP (default_directory) && !EQ (default_directory, name)
823 /* Save time in some common cases - as long as default_directory
824 is not relative, it can be canonicalized with name below (if it
825 is needed at all) without requiring it to be expanded now. */
826 #ifdef WINDOWSNT
827 /* Detect MSDOS file names with drive specifiers. */
828 && ! (IS_DRIVE (o[0]) && (IS_DEVICE_SEP (o[1]) && IS_DIRECTORY_SEP (o[2])))
829 /* Detect Windows file names in UNC format. */
830 && ! (IS_DIRECTORY_SEP (o[0]) && IS_DIRECTORY_SEP (o[1]))
831
832 #else /* not WINDOWSNT */
833
834 /* Detect Unix absolute file names (/... alone is not absolute on
835 DOS or Windows). */
836 && ! (IS_DIRECTORY_SEP (o[0]))
837 #endif /* not WINDOWSNT */
838 )
839 {
840 struct gcpro gcpro1;
841
842 GCPRO1 (name);
843 default_directory = Fexpand_file_name (default_directory, Qnil);
844 UNGCPRO;
845 }
846
847 #ifdef FILE_SYSTEM_CASE
848 name = FILE_SYSTEM_CASE (name);
849 #endif
850
851 /* #### dmoore - this is ugly, clean this up. Looks like nm pointing
852 into name should be safe during all of this, though. */
853 nm = XSTRING_DATA (name);
854
855 #ifdef WINDOWSNT
856 /* We will force directory separators to be either all \ or /, so make
857 a local copy to modify, even if there ends up being no change. */
858 nm = strcpy (alloca (strlen (nm) + 1), nm);
859
860 /* Find and remove drive specifier if present; this makes nm absolute
861 even if the rest of the name appears to be relative. */
862 {
863 Bufbyte *colon = strrchr (nm, ':');
864
865 if (colon)
866 /* Only recognize colon as part of drive specifier if there is a
867 single alphabetic character preceding the colon (and if the
868 character before the drive letter, if present, is a directory
869 separator); this is to support the remote system syntax used by
870 ange-ftp, and the "po:username" syntax for POP mailboxes. */
871 look_again:
872 if (nm == colon)
873 nm++;
874 else if (IS_DRIVE (colon[-1])
875 && (colon == nm + 1 || IS_DIRECTORY_SEP (colon[-2])))
876 {
877 drive = colon[-1];
878 nm = colon + 1;
879 }
880 else
881 {
882 while (--colon >= nm)
883 if (colon[0] == ':')
884 goto look_again;
885 }
886 }
887
888 /* If we see "c://somedir", we want to strip the first slash after the
889 colon when stripping the drive letter. Otherwise, this expands to
890 "//somedir". */
891 if (drive && IS_DIRECTORY_SEP (nm[0]) && IS_DIRECTORY_SEP (nm[1]))
892 nm++;
893 #endif /* WINDOWSNT */
894
895 /* If nm is absolute, look for /./ or /../ sequences; if none are
896 found, we can probably return right away. We will avoid allocating
897 a new string if name is already fully expanded. */
898 if (
899 IS_DIRECTORY_SEP (nm[0])
900 #ifdef WINDOWSNT
901 && (drive || IS_DIRECTORY_SEP (nm[1]))
902 #endif
903 )
904 {
905 /* If it turns out that the filename we want to return is just a
906 suffix of FILENAME, we don't need to go through and edit
907 things; we just need to construct a new string using data
908 starting at the middle of FILENAME. If we set lose to a
909 non-zero value, that means we've discovered that we can't do
910 that cool trick. */
911 int lose = 0;
912
913 p = nm;
914 while (*p)
915 {
916 /* Since we know the name is absolute, we can assume that each
917 element starts with a "/". */
918
919 /* "." and ".." are hairy. */
920 if (IS_DIRECTORY_SEP (p[0])
921 && p[1] == '.'
922 && (IS_DIRECTORY_SEP (p[2])
923 || p[2] == 0
924 || (p[2] == '.' && (IS_DIRECTORY_SEP (p[3])
925 || p[3] == 0))))
926 lose = 1;
927 p++;
928 }
929 if (!lose)
930 {
931 #ifdef WINDOWSNT
932 /* Make sure directories are all separated with / or \ as
933 desired, but avoid allocation of a new string when not
934 required. */
935 CORRECT_DIR_SEPS (nm);
936 if (IS_DIRECTORY_SEP (nm[1]))
937 {
938 if (strcmp (nm, XSTRING_DATA (name)) != 0)
939 name = build_string (nm);
940 }
941 /* drive must be set, so this is okay */
942 else if (strcmp (nm - 2, XSTRING_DATA (name)) != 0)
943 {
944 name = make_string (nm - 2, p - nm + 2);
945 XSTRING_DATA (name)[0] = DRIVE_LETTER (drive);
946 XSTRING_DATA (name)[1] = ':';
947 }
948 return name;
949 #else /* not WINDOWSNT */
950 if (nm == XSTRING_DATA (name))
951 return name;
952 return build_string ((char *) nm);
953 #endif /* not WINDOWSNT */
954 }
955 }
956
957 /* At this point, nm might or might not be an absolute file name. We
958 need to expand ~ or ~user if present, otherwise prefix nm with
959 default_directory if nm is not absolute, and finally collapse /./
960 and /foo/../ sequences.
961
962 We set newdir to be the appropriate prefix if one is needed:
963 - the relevant user directory if nm starts with ~ or ~user
964 - the specified drive's working dir (DOS/NT only) if nm does not
965 start with /
966 - the value of default_directory.
967
968 Note that these prefixes are not guaranteed to be absolute (except
969 for the working dir of a drive). Therefore, to ensure we always
970 return an absolute name, if the final prefix is not absolute we
971 append it to the current working directory. */
972
973 newdir = 0;
974
975 if (nm[0] == '~') /* prefix ~ */
976 {
977 if (IS_DIRECTORY_SEP (nm[1])
978 || nm[1] == 0) /* ~ by itself */
979 {
980 char * newdir_external = get_home_directory ();
981
982 if (newdir_external == NULL)
983 newdir = (Bufbyte *) "";
984 else
985 GET_C_CHARPTR_INT_FILENAME_DATA_ALLOCA (newdir_external, newdir);
986
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 DO_NOTHING;
996 o = (Bufbyte *) alloca (p - nm + 1);
997 memcpy (o, (char *) nm, p - nm);
998 o [p - nm] = 0;
999
1000 /* #### marcpa's syncing note: FSF uses getpwnam even on NT,
1001 which does not work. The following works only if ~USER
1002 names the user who runs this instance of XEmacs. While
1003 NT is single-user (for the moment) you still can have
1004 multiple user profiles users defined, each with its HOME.
1005 Therefore, the following should be reworked to handle
1006 this case. */
1007 #ifdef WINDOWSNT
1008 /* Now if the file given is "~foo/file" and HOME="c:/", then
1009 we want the file to be named "c:/file" ("~foo" becomes
1010 "c:/"). The variable o has "~foo", so we can use the
1011 length of that string to offset nm. August Hill, 31 Aug
1012 1998. */
1013 newdir = (Bufbyte *) get_home_directory();
1014 dostounix_filename (newdir);
1015 nm += strlen(o) + 1;
1016 #else /* not WINDOWSNT */
1017 #ifdef __CYGWIN32__
1018 if ((user = user_login_name (NULL)) != NULL)
1019 {
1020 /* Does the user login name match the ~name? */
1021 if (strcmp (user, (char *) o + 1) == 0)
1022 {
1023 newdir = (Bufbyte *) get_home_directory();
1024 nm = p;
1025 }
1026 }
1027 if (! newdir)
1028 {
1029 #endif /* __CYGWIN32__ */
1030 /* Jamie reports that getpwnam() can get wedged by SIGIO/SIGALARM
1031 occurring in it. (It can call select()). */
1032 slow_down_interrupts ();
1033 pw = (struct passwd *) getpwnam ((char *) o + 1);
1034 speed_up_interrupts ();
1035 if (pw)
1036 {
1037 newdir = (Bufbyte *) pw -> pw_dir;
1038 nm = p;
1039 }
1040 #ifdef __CYGWIN32__
1041 }
1042 #endif
1043 #endif /* not WINDOWSNT */
1044
1045 /* If we don't find a user of that name, leave the name
1046 unchanged; don't move nm forward to p. */
1047 }
1048 }
1049
1050 #ifdef WINDOWSNT
1051 /* On DOS and Windows, nm is absolute if a drive name was specified;
1052 use the drive's current directory as the prefix if needed. */
1053 if (!newdir && drive)
1054 {
1055 /* Get default directory if needed to make nm absolute. */
1056 if (!IS_DIRECTORY_SEP (nm[0]))
1057 {
1058 newdir = alloca (MAXPATHLEN + 1);
1059 if (!getdefdir (toupper (drive) - 'A' + 1, newdir))
1060 newdir = NULL;
1061 }
1062 if (!newdir)
1063 {
1064 /* Either nm starts with /, or drive isn't mounted. */
1065 newdir = alloca (4);
1066 newdir[0] = DRIVE_LETTER (drive);
1067 newdir[1] = ':';
1068 newdir[2] = '/';
1069 newdir[3] = 0;
1070 }
1071 }
1072 #endif /* WINDOWSNT */
1073
1074 /* Finally, if no prefix has been specified and nm is not absolute,
1075 then it must be expanded relative to default_directory. */
1076
1077 if (1
1078 #ifndef WINDOWSNT
1079 /* /... alone is not absolute on DOS and Windows. */
1080 && !IS_DIRECTORY_SEP (nm[0])
1081 #else
1082 && !(IS_DIRECTORY_SEP (nm[0]) && IS_DIRECTORY_SEP (nm[1]))
1083 #endif
1084 && !newdir)
1085 {
1086 newdir = XSTRING_DATA (default_directory);
1087 }
1088
1089 #ifdef WINDOWSNT
1090 if (newdir)
1091 {
1092 /* First ensure newdir is an absolute name. */
1093 if (
1094 /* Detect MSDOS file names with drive specifiers. */
1095 ! (IS_DRIVE (newdir[0])
1096 && IS_DEVICE_SEP (newdir[1]) && IS_DIRECTORY_SEP (newdir[2]))
1097 /* Detect Windows file names in UNC format. */
1098 && ! (IS_DIRECTORY_SEP (newdir[0]) && IS_DIRECTORY_SEP (newdir[1]))
1099 /* Detect drive spec by itself */
1100 && ! (IS_DEVICE_SEP (newdir[1]) && newdir[2] == 0)
1101 )
1102 {
1103 /* Effectively, let newdir be (expand-file-name newdir cwd).
1104 Because of the admonition against calling expand-file-name
1105 when we have pointers into lisp strings, we accomplish this
1106 indirectly by prepending newdir to nm if necessary, and using
1107 cwd (or the wd of newdir's drive) as the new newdir. */
1108
1109 if (IS_DRIVE (newdir[0]) && newdir[1] == ':')
1110 {
1111 drive = newdir[0];
1112 newdir += 2;
1113 }
1114 if (!IS_DIRECTORY_SEP (nm[0]))
1115 {
1116 char * tmp = alloca (strlen (newdir) + strlen (nm) + 2);
1117 file_name_as_directory (tmp, newdir);
1118 strcat (tmp, nm);
1119 nm = tmp;
1120 }
1121 newdir = alloca (MAXPATHLEN + 1);
1122 if (drive)
1123 {
1124 if (!getdefdir (toupper (drive) - 'A' + 1, newdir))
1125 newdir = "/";
1126 }
1127 else
1128 getwd (newdir);
1129 }
1130
1131 /* Strip off drive name from prefix, if present. */
1132 if (IS_DRIVE (newdir[0]) && newdir[1] == ':')
1133 {
1134 drive = newdir[0];
1135 newdir += 2;
1136 }
1137
1138 /* Keep only a prefix from newdir if nm starts with slash
1139 (/ /server/share for UNC, nothing otherwise). */
1140 if (IS_DIRECTORY_SEP (nm[0]) && collapse_newdir)
1141 {
1142 if (IS_DIRECTORY_SEP (newdir[0]) && IS_DIRECTORY_SEP (newdir[1]))
1143 {
1144 newdir = strcpy (alloca (strlen (newdir) + 1), newdir);
1145 p = newdir + 2;
1146 while (*p && !IS_DIRECTORY_SEP (*p)) p++;
1147 p++;
1148 while (*p && !IS_DIRECTORY_SEP (*p)) p++;
1149 *p = 0;
1150 }
1151 else
1152 newdir = "";
1153 }
1154 }
1155 #endif /* WINDOWSNT */
1156
1157 if (newdir)
1158 {
1159 /* Get rid of any slash at the end of newdir, unless newdir is
1160 just // (an incomplete UNC name). */
1161 length = strlen ((char *) newdir);
1162 if (length > 1 && IS_DIRECTORY_SEP (newdir[length - 1])
1163 #ifdef WINDOWSNT
1164 && !(length == 2 && IS_DIRECTORY_SEP (newdir[0]))
1165 #endif
1166 )
1167 {
1168 Bufbyte *temp = (Bufbyte *) alloca (length);
1169 memcpy (temp, newdir, length - 1);
1170 temp[length - 1] = 0;
1171 newdir = temp;
1172 }
1173 tlen = length + 1;
1174 }
1175 else
1176 tlen = 0;
1177
1178 /* Now concatenate the directory and name to new space in the stack frame */
1179 tlen += strlen ((char *) nm) + 1;
1180 #ifdef WINDOWSNT
1181 /* Add reserved space for drive name. (The Microsoft x86 compiler
1182 produces incorrect code if the following two lines are combined.) */
1183 target = (Bufbyte *) alloca (tlen + 2);
1184 target += 2;
1185 #else /* not WINDOWSNT */
1186 target = (Bufbyte *) alloca (tlen);
1187 #endif /* not WINDOWSNT */
1188 *target = 0;
1189
1190 if (newdir)
1191 {
1192 if (nm[0] == 0 || IS_DIRECTORY_SEP (nm[0]))
1193 strcpy ((char *) target, (char *) newdir);
1194 else
1195 file_name_as_directory ((char *) target, (char *) newdir);
1196 }
1197
1198 strcat ((char *) target, (char *) nm);
1199
1200 /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */
1201
1202 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1203
1204 p = target;
1205 o = target;
1206
1207 while (*p)
1208 {
1209 if (!IS_DIRECTORY_SEP (*p))
1210 {
1211 *o++ = *p++;
1212 }
1213 else if (IS_DIRECTORY_SEP (p[0])
1214 && p[1] == '.'
1215 && (IS_DIRECTORY_SEP (p[2])
1216 || p[2] == 0))
1217 {
1218 /* If "/." is the entire filename, keep the "/". Otherwise,
1219 just delete the whole "/.". */
1220 if (o == target && p[2] == '\0')
1221 *o++ = *p;
1222 p += 2;
1223 }
1224 else if (IS_DIRECTORY_SEP (p[0]) && p[1] == '.' && p[2] == '.'
1225 /* `/../' is the "superroot" on certain file systems. */
1226 && o != target
1227 && (IS_DIRECTORY_SEP (p[3]) || p[3] == 0))
1228 {
1229 while (o != target && (--o) && !IS_DIRECTORY_SEP (*o))
1230 ;
1231 /* Keep initial / only if this is the whole name. */
1232 if (o == target && IS_ANY_SEP (*o) && p[3] == 0)
1233 ++o;
1234 p += 3;
1235 }
1236 #ifdef WINDOWSNT
1237 /* if drive is set, we're not dealing with an UNC, so
1238 multiple dir-seps are redundant (and reportedly cause trouble
1239 under win95) */
1240 else if (drive && IS_DIRECTORY_SEP (p[0]) && IS_DIRECTORY_SEP (p[1]))
1241 ++p;
1242 #endif
1243 else
1244 {
1245 *o++ = *p++;
1246 }
1247 }
1248
1249 #ifdef WINDOWSNT
1250 /* At last, set drive name, except for network file name. */
1251 if (drive)
1252 {
1253 target -= 2;
1254 target[0] = DRIVE_LETTER (drive);
1255 target[1] = ':';
1256 }
1257 else
1258 {
1259 assert (IS_DIRECTORY_SEP (target[0]) && IS_DIRECTORY_SEP (target[1]));
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 Extbyte *path;
1303 Extbyte *p;
1304 Extcount elen = XSTRING_LENGTH (expanded_name);
1305
1306 GET_STRING_FILENAME_DATA_ALLOCA (expanded_name,path,elen);
1307 p = path;
1308 if (elen > MAXPATHLEN)
1309 goto toolong;
1310
1311 /* Try doing it all at once. */
1312 /* !! Does realpath() Mule-encapsulate?
1313 Answer: Nope! So we do it above */
1314 if (!xrealpath ((char *) 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 = (Extbyte *) 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 ((char *) 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
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
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
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
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
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 behavior 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
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
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
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_DATA (abspath)))
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
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
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
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 ssize_t 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
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 /* The spurious warnings appear on Linux too. Rather than handling
3350 this on a per-system basis, unconditionally do the stat after the close - cgw */
3351
3352 #if 0 /* !defined (WINDOWSNT) */ /* !defined (VMS) && !defined (APOLLO) */
3353 fstat (desc, &st);
3354 #endif
3355
3356 /* NFS can report a write failure now. */
3357 if (close (desc) < 0)
3358 {
3359 failure = 1;
3360 save_errno = errno;
3361 }
3362
3363 /* Discard the close unwind-protect. Execute the one for
3364 build_annotations (switches back to the original current buffer
3365 as necessary). */
3366 XCAR (desc_locative) = Qnil;
3367 unbind_to (speccount, Qnil);
3368 }
3369
3370 /* # if defined (WINDOWSNT) */ /* defined (VMS) || defined (APOLLO) */
3371 stat ((char *) XSTRING_DATA (fn), &st);
3372 /* #endif */
3373
3374 #ifdef CLASH_DETECTION
3375 if (!auto_saving)
3376 unlock_file (lockname);
3377 #endif /* CLASH_DETECTION */
3378
3379 /* Do this before reporting IO error
3380 to avoid a "file has changed on disk" warning on
3381 next attempt to save. */
3382 if (visiting)
3383 current_buffer->modtime = st.st_mtime;
3384
3385 if (failure)
3386 error ("IO error writing %s: %s",
3387 XSTRING_DATA (fn),
3388 strerror (save_errno));
3389
3390 if (visiting)
3391 {
3392 BUF_SAVE_MODIFF (current_buffer) = BUF_MODIFF (current_buffer);
3393 current_buffer->saved_size = make_int (BUF_SIZE (current_buffer));
3394 current_buffer->filename = visit_file;
3395 MARK_MODELINE_CHANGED;
3396 }
3397 else if (quietly)
3398 {
3399 return Qnil;
3400 }
3401
3402 if (!auto_saving)
3403 {
3404 if (visiting_other)
3405 message ("Wrote %s", XSTRING_DATA (visit_file));
3406 else
3407 {
3408 struct gcpro gcpro1;
3409 Lisp_Object fsp;
3410 GCPRO1 (fn);
3411
3412 fsp = Ffile_symlink_p (fn);
3413 if (NILP (fsp))
3414 message ("Wrote %s", XSTRING_DATA (fn));
3415 else
3416 message ("Wrote %s (symlink to %s)",
3417 XSTRING_DATA (fn), XSTRING_DATA (fsp));
3418 UNGCPRO;
3419 }
3420 }
3421 return Qnil;
3422 }
3423
3424 /* #### This is such a load of shit!!!! There is no way we should define
3425 something so stupid as a subr, just sort the fucking list more
3426 intelligently. */
3427 DEFUN ("car-less-than-car", Fcar_less_than_car, 2, 2, 0, /*
3428 Return t if (car A) is numerically less than (car B).
3429 */
3430 (a, b))
3431 {
3432 Lisp_Object objs[2];
3433 objs[0] = Fcar (a);
3434 objs[1] = Fcar (b);
3435 return Flss (2, objs);
3436 }
3437
3438 /* Heh heh heh, let's define this too, just to aggravate the person who
3439 wrote the above comment. */
3440 DEFUN ("cdr-less-than-cdr", Fcdr_less_than_cdr, 2, 2, 0, /*
3441 Return t if (cdr A) is numerically less than (cdr B).
3442 */
3443 (a, b))
3444 {
3445 Lisp_Object objs[2];
3446 objs[0] = Fcdr (a);
3447 objs[1] = Fcdr (b);
3448 return Flss (2, objs);
3449 }
3450
3451 /* Build the complete list of annotations appropriate for writing out
3452 the text between START and END, by calling all the functions in
3453 write-region-annotate-functions and merging the lists they return.
3454 If one of these functions switches to a different buffer, we assume
3455 that buffer contains altered text. Therefore, the caller must
3456 make sure to restore the current buffer in all cases,
3457 as save-excursion would do. */
3458
3459 static Lisp_Object
3460 build_annotations (Lisp_Object start, Lisp_Object end)
3461 {
3462 /* This function can GC */
3463 Lisp_Object annotations;
3464 Lisp_Object p, res;
3465 struct gcpro gcpro1, gcpro2;
3466 Lisp_Object original_buffer;
3467
3468 XSETBUFFER (original_buffer, current_buffer);
3469
3470 annotations = Qnil;
3471 p = Vwrite_region_annotate_functions;
3472 GCPRO2 (annotations, p);
3473 while (!NILP (p))
3474 {
3475 struct buffer *given_buffer = current_buffer;
3476 Vwrite_region_annotations_so_far = annotations;
3477 res = call2 (Fcar (p), start, end);
3478 /* If the function makes a different buffer current,
3479 assume that means this buffer contains altered text to be output.
3480 Reset START and END from the buffer bounds
3481 and discard all previous annotations because they should have
3482 been dealt with by this function. */
3483 if (current_buffer != given_buffer)
3484 {
3485 start = make_int (BUF_BEGV (current_buffer));
3486 end = make_int (BUF_ZV (current_buffer));
3487 annotations = Qnil;
3488 }
3489 Flength (res); /* Check basic validity of return value */
3490 annotations = merge (annotations, res, Qcar_less_than_car);
3491 p = Fcdr (p);
3492 }
3493
3494 /* Now do the same for annotation functions implied by the file-format */
3495 if (auto_saving && (!EQ (Vauto_save_file_format, Qt)))
3496 p = Vauto_save_file_format;
3497 else
3498 p = current_buffer->file_format;
3499 while (!NILP (p))
3500 {
3501 struct buffer *given_buffer = current_buffer;
3502 Vwrite_region_annotations_so_far = annotations;
3503 res = call4 (Qformat_annotate_function, Fcar (p), start, end,
3504 original_buffer);
3505 if (current_buffer != given_buffer)
3506 {
3507 start = make_int (BUF_BEGV (current_buffer));
3508 end = make_int (BUF_ZV (current_buffer));
3509 annotations = Qnil;
3510 }
3511 Flength (res);
3512 annotations = merge (annotations, res, Qcar_less_than_car);
3513 p = Fcdr (p);
3514 }
3515 UNGCPRO;
3516 return annotations;
3517 }
3518
3519 /* Write to stream OUTSTREAM the characters from INSTREAM (it is read until
3520 EOF is encountered), assuming they start at position POS in the buffer
3521 of string that STREAM refers to. Intersperse with them the annotations
3522 from *ANNOT that fall into the range of positions we are reading from,
3523 each at its appropriate position.
3524
3525 Modify *ANNOT by discarding elements as we output them.
3526 The return value is negative in case of system call failure. */
3527
3528 /* 4K should probably be fine. We just need to reduce the number of
3529 function calls to reasonable level. The Lstream stuff itself will
3530 batch to 64K to reduce the number of system calls. */
3531
3532 #define A_WRITE_BATCH_SIZE 4096
3533
3534 static int
3535 a_write (Lisp_Object outstream, Lisp_Object instream, int pos,
3536 Lisp_Object *annot)
3537 {
3538 Lisp_Object tem;
3539 int nextpos;
3540 unsigned char largebuf[A_WRITE_BATCH_SIZE];
3541 Lstream *instr = XLSTREAM (instream);
3542 Lstream *outstr = XLSTREAM (outstream);
3543
3544 while (LISTP (*annot))
3545 {
3546 tem = Fcar_safe (Fcar (*annot));
3547 if (INTP (tem))
3548 nextpos = XINT (tem);
3549 else
3550 nextpos = INT_MAX;
3551 #ifdef MULE
3552 /* If there are annotations left and we have Mule, then we
3553 have to do the I/O one emchar at a time so we can
3554 determine when to insert the annotation. */
3555 if (!NILP (*annot))
3556 {
3557 Emchar ch;
3558 while (pos != nextpos && (ch = Lstream_get_emchar (instr)) != EOF)
3559 {
3560 if (Lstream_put_emchar (outstr, ch) < 0)
3561 return -1;
3562 pos++;
3563 }
3564 }
3565 else
3566 #endif /* MULE */
3567 {
3568 while (pos != nextpos)
3569 {
3570 /* Otherwise there is no point to that. Just go in batches. */
3571 int chunk = min (nextpos - pos, A_WRITE_BATCH_SIZE);
3572
3573 chunk = Lstream_read (instr, largebuf, chunk);
3574 if (chunk < 0)
3575 return -1;
3576 if (chunk == 0) /* EOF */
3577 break;
3578 if (Lstream_write (outstr, largebuf, chunk) < chunk)
3579 return -1;
3580 pos += chunk;
3581 }
3582 }
3583 if (pos == nextpos)
3584 {
3585 tem = Fcdr (Fcar (*annot));
3586 if (STRINGP (tem))
3587 {
3588 if (Lstream_write (outstr, XSTRING_DATA (tem),
3589 XSTRING_LENGTH (tem)) < 0)
3590 return -1;
3591 }
3592 *annot = Fcdr (*annot);
3593 }
3594 else
3595 return 0;
3596 }
3597 return -1;
3598 }
3599
3600
3601
3602 #if 0
3603 #include <des_crypt.h>
3604
3605 #define CRYPT_BLOCK_SIZE 8 /* bytes */
3606 #define CRYPT_KEY_SIZE 8 /* bytes */
3607
3608 DEFUN ("encrypt-string", Fencrypt_string, 2, 2, 0, /*
3609 Encrypt STRING using KEY.
3610 */
3611 (string, key))
3612 {
3613 char *encrypted_string, *raw_key;
3614 int rounded_size, extra, key_size;
3615
3616 /* !!#### May produce bogus data under Mule. */
3617 CHECK_STRING (string);
3618 CHECK_STRING (key);
3619
3620 extra = XSTRING_LENGTH (string) % CRYPT_BLOCK_SIZE;
3621 rounded_size = XSTRING_LENGTH (string) + extra;
3622 encrypted_string = alloca (rounded_size + 1);
3623 memcpy (encrypted_string, XSTRING_DATA (string), XSTRING_LENGTH (string));
3624 memset (encrypted_string + rounded_size - extra, 0, extra + 1);
3625
3626 key_size = min (CRYPT_KEY_SIZE, XSTRING_LENGTH (key))
3627
3628 raw_key = alloca (CRYPT_KEY_SIZE + 1);
3629 memcpy (raw_key, XSTRING_DATA (key), key_size);
3630 memset (raw_key + key_size, 0, (CRYPT_KEY_SIZE + 1) - key_size);
3631
3632 ecb_crypt (raw_key, encrypted_string, rounded_size,
3633 DES_ENCRYPT | DES_SW);
3634 return make_string (encrypted_string, rounded_size);
3635 }
3636
3637 DEFUN ("decrypt-string", Fdecrypt_string, 2, 2, 0, /*
3638 Decrypt STRING using KEY.
3639 */
3640 (string, key))
3641 {
3642 char *decrypted_string, *raw_key;
3643 int string_size, key_size;
3644
3645 CHECK_STRING (string);
3646 CHECK_STRING (key);
3647
3648 string_size = XSTRING_LENGTH (string) + 1;
3649 decrypted_string = alloca (string_size);
3650 memcpy (decrypted_string, XSTRING_DATA (string), string_size);
3651 decrypted_string[string_size - 1] = '\0';
3652
3653 key_size = min (CRYPT_KEY_SIZE, XSTRING_LENGTH (key))
3654
3655 raw_key = alloca (CRYPT_KEY_SIZE + 1);
3656 memcpy (raw_key, XSTRING_DATA (key), key_size);
3657 memset (raw_key + key_size, 0, (CRYPT_KEY_SIZE + 1) - key_size);
3658
3659
3660 ecb_crypt (raw_key, decrypted_string, string_size, D | DES_SW);
3661 return make_string (decrypted_string, string_size - 1);
3662 }
3663 #endif /* 0 */
3664
3665
3666 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime, 1, 1, 0, /*
3667 Return t if last mod time of BUF's visited file matches what BUF records.
3668 This means that the file has not been changed since it was visited or saved.
3669 */
3670 (buf))
3671 {
3672 /* This function can call lisp */
3673 struct buffer *b;
3674 struct stat st;
3675 Lisp_Object handler;
3676
3677 CHECK_BUFFER (buf);
3678 b = XBUFFER (buf);
3679
3680 if (!STRINGP (b->filename)) return Qt;
3681 if (b->modtime == 0) return Qt;
3682
3683 /* If the file name has special constructs in it,
3684 call the corresponding file handler. */
3685 handler = Ffind_file_name_handler (b->filename,
3686 Qverify_visited_file_modtime);
3687 if (!NILP (handler))
3688 return call2 (handler, Qverify_visited_file_modtime, buf);
3689
3690 if (stat ((char *) XSTRING_DATA (b->filename), &st) < 0)
3691 {
3692 /* If the file doesn't exist now and didn't exist before,
3693 we say that it isn't modified, provided the error is a tame one. */
3694 if (errno == ENOENT || errno == EACCES || errno == ENOTDIR)
3695 st.st_mtime = -1;
3696 else
3697 st.st_mtime = 0;
3698 }
3699 if (st.st_mtime == b->modtime
3700 /* If both are positive, accept them if they are off by one second. */
3701 || (st.st_mtime > 0 && b->modtime > 0
3702 && (st.st_mtime == b->modtime + 1
3703 || st.st_mtime == b->modtime - 1)))
3704 return Qt;
3705 return Qnil;
3706 }
3707
3708 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime, 0, 0, 0, /*
3709 Clear out records of last mod time of visited file.
3710 Next attempt to save will certainly not complain of a discrepancy.
3711 */
3712 ())
3713 {
3714 current_buffer->modtime = 0;
3715 return Qnil;
3716 }
3717
3718 DEFUN ("visited-file-modtime", Fvisited_file_modtime, 0, 0, 0, /*
3719 Return the current buffer's recorded visited file modification time.
3720 The value is a list of the form (HIGH . LOW), like the time values
3721 that `file-attributes' returns.
3722 */
3723 ())
3724 {
3725 return time_to_lisp ((time_t) current_buffer->modtime);
3726 }
3727
3728 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime, 0, 1, 0, /*
3729 Update buffer's recorded modification time from the visited file's time.
3730 Useful if the buffer was not read from the file normally
3731 or if the file itself has been changed for some known benign reason.
3732 An argument specifies the modification time value to use
3733 \(instead of that of the visited file), in the form of a list
3734 \(HIGH . LOW) or (HIGH LOW).
3735 */
3736 (time_list))
3737 {
3738 /* This function can call lisp */
3739 if (!NILP (time_list))
3740 {
3741 time_t the_time;
3742 lisp_to_time (time_list, &the_time);
3743 current_buffer->modtime = (int) the_time;
3744 }
3745 else
3746 {
3747 Lisp_Object filename;
3748 struct stat st;
3749 Lisp_Object handler;
3750 struct gcpro gcpro1, gcpro2, gcpro3;
3751
3752 GCPRO3 (filename, time_list, current_buffer->filename);
3753 filename = Fexpand_file_name (current_buffer->filename, Qnil);
3754
3755 /* If the file name has special constructs in it,
3756 call the corresponding file handler. */
3757 handler = Ffind_file_name_handler (filename, Qset_visited_file_modtime);
3758 UNGCPRO;
3759 if (!NILP (handler))
3760 /* The handler can find the file name the same way we did. */
3761 return call2 (handler, Qset_visited_file_modtime, Qnil);
3762 else if (stat ((char *) XSTRING_DATA (filename), &st) >= 0)
3763 current_buffer->modtime = st.st_mtime;
3764 }
3765
3766 return Qnil;
3767 }
3768
3769 static Lisp_Object
3770 auto_save_error (Lisp_Object condition_object, Lisp_Object ignored)
3771 {
3772 /* This function can call lisp */
3773 if (gc_in_progress)
3774 return Qnil;
3775 /* Don't try printing an error message after everything is gone! */
3776 if (preparing_for_armageddon)
3777 return Qnil;
3778 clear_echo_area (selected_frame (), Qauto_saving, 1);
3779 Fding (Qt, Qauto_save_error, Qnil);
3780 message ("Auto-saving...error for %s", XSTRING_DATA (current_buffer->name));
3781 Fsleep_for (make_int (1));
3782 message ("Auto-saving...error!for %s", XSTRING_DATA (current_buffer->name));
3783 Fsleep_for (make_int (1));
3784 message ("Auto-saving...error for %s", XSTRING_DATA (current_buffer->name));
3785 Fsleep_for (make_int (1));
3786 return Qnil;
3787 }
3788
3789 static Lisp_Object
3790 auto_save_1 (Lisp_Object ignored)
3791 {
3792 /* This function can call lisp */
3793 /* #### I think caller is protecting current_buffer? */
3794 struct stat st;
3795 Lisp_Object fn = current_buffer->filename;
3796 Lisp_Object a = current_buffer->auto_save_file_name;
3797
3798 if (!STRINGP (a))
3799 return (Qnil);
3800
3801 /* Get visited file's mode to become the auto save file's mode. */
3802 if (STRINGP (fn) &&
3803 stat ((char *) XSTRING_DATA (fn), &st) >= 0)
3804 /* But make sure we can overwrite it later! */
3805 auto_save_mode_bits = st.st_mode | 0600;
3806 else
3807 /* default mode for auto-save files of buffers with no file is
3808 readable by owner only. This may annoy some small number of
3809 people, but the alternative removes all privacy from email. */
3810 auto_save_mode_bits = 0600;
3811
3812 return
3813 /* !!#### need to deal with this 'escape-quoted everywhere */
3814 Fwrite_region_internal (Qnil, Qnil, a, Qnil, Qlambda, Qnil,
3815 #ifdef MULE
3816 Qescape_quoted
3817 #else
3818 Qnil
3819 #endif
3820 );
3821 }
3822
3823 static Lisp_Object
3824 auto_save_expand_name_error (Lisp_Object condition_object, Lisp_Object ignored)
3825 {
3826 /* #### this function should spew an error message about not being
3827 able to open the .saves file. */
3828 return Qnil;
3829 }
3830
3831 static Lisp_Object
3832 auto_save_expand_name (Lisp_Object name)
3833 {
3834 struct gcpro gcpro1;
3835
3836 /* note that caller did NOT gc protect name, so we do it. */
3837 /* #### dmoore - this might not be necessary, if condition_case_1
3838 protects it. but I don't think it does. */
3839 GCPRO1 (name);
3840 RETURN_UNGCPRO (Fexpand_file_name (name, Qnil));
3841 }
3842
3843
3844 static Lisp_Object
3845 do_auto_save_unwind (Lisp_Object fd)
3846 {
3847 close (XINT (fd));
3848 return (fd);
3849 }
3850
3851 static Lisp_Object
3852 do_auto_save_unwind_2 (Lisp_Object old_auto_saving)
3853 {
3854 auto_saving = XINT (old_auto_saving);
3855 return Qnil;
3856 }
3857
3858 /* Fdo_auto_save() checks whether a GC is in progress when it is called,
3859 and if so, tries to avoid touching lisp objects.
3860
3861 The only time that Fdo_auto_save() is called while GC is in progress
3862 is if we're going down, as a result of an abort() or a kill signal.
3863 It's fairly important that we generate autosave files in that case!
3864 */
3865
3866 DEFUN ("do-auto-save", Fdo_auto_save, 0, 2, "", /*
3867 Auto-save all buffers that need it.
3868 This is all buffers that have auto-saving enabled
3869 and are changed since last auto-saved.
3870 Auto-saving writes the buffer into a file
3871 so that your editing is not lost if the system crashes.
3872 This file is not the file you visited; that changes only when you save.
3873 Normally we run the normal hook `auto-save-hook' before saving.
3874
3875 Non-nil first argument means do not print any message if successful.
3876 Non-nil second argument means save only current buffer.
3877 */
3878 (no_message, current_only))
3879 {
3880 /* This function can call lisp */
3881 struct buffer *b;
3882 Lisp_Object tail, buf;
3883 int auto_saved = 0;
3884 int do_handled_files;
3885 Lisp_Object oquit = Qnil;
3886 Lisp_Object listfile = Qnil;
3887 Lisp_Object old;
3888 int listdesc = -1;
3889 int speccount = specpdl_depth ();
3890 struct gcpro gcpro1, gcpro2, gcpro3;
3891
3892 XSETBUFFER (old, current_buffer);
3893 GCPRO3 (oquit, listfile, old);
3894 check_quit (); /* make Vquit_flag accurate */
3895 /* Ordinarily don't quit within this function,
3896 but don't make it impossible to quit (in case we get hung in I/O). */
3897 oquit = Vquit_flag;
3898 Vquit_flag = Qnil;
3899
3900 /* No further GCPRO needed, because (when it matters) all Lisp_Object
3901 variables point to non-strings reached from Vbuffer_alist. */
3902
3903 if (minibuf_level != 0 || preparing_for_armageddon)
3904 no_message = Qt;
3905
3906 run_hook (Qauto_save_hook);
3907
3908 if (STRINGP (Vauto_save_list_file_name))
3909 listfile = condition_case_1 (Qt,
3910 auto_save_expand_name,
3911 Vauto_save_list_file_name,
3912 auto_save_expand_name_error, Qnil);
3913
3914 /* Make sure auto_saving is reset. */
3915 record_unwind_protect (do_auto_save_unwind_2, make_int (auto_saving));
3916
3917 auto_saving = 1;
3918
3919 /* First, save all files which don't have handlers. If Emacs is
3920 crashing, the handlers may tweak what is causing Emacs to crash
3921 in the first place, and it would be a shame if Emacs failed to
3922 autosave perfectly ordinary files because it couldn't handle some
3923 ange-ftp'd file. */
3924 for (do_handled_files = 0; do_handled_files < 2; do_handled_files++)
3925 {
3926 for (tail = Vbuffer_alist;
3927 CONSP (tail);
3928 tail = XCDR (tail))
3929 {
3930 buf = XCDR (XCAR (tail));
3931 b = XBUFFER (buf);
3932
3933 if (!NILP (current_only)
3934 && b != current_buffer)
3935 continue;
3936
3937 /* Don't auto-save indirect buffers.
3938 The base buffer takes care of it. */
3939 if (b->base_buffer)
3940 continue;
3941
3942 /* Check for auto save enabled
3943 and file changed since last auto save
3944 and file changed since last real save. */
3945 if (STRINGP (b->auto_save_file_name)
3946 && BUF_SAVE_MODIFF (b) < BUF_MODIFF (b)
3947 && b->auto_save_modified < BUF_MODIFF (b)
3948 /* -1 means we've turned off autosaving for a while--see below. */
3949 && XINT (b->saved_size) >= 0
3950 && (do_handled_files
3951 || NILP (Ffind_file_name_handler (b->auto_save_file_name,
3952 Qwrite_region))))
3953 {
3954 EMACS_TIME before_time, after_time;
3955
3956 EMACS_GET_TIME (before_time);
3957 /* If we had a failure, don't try again for 20 minutes. */
3958 if (!preparing_for_armageddon
3959 && b->auto_save_failure_time >= 0
3960 && (EMACS_SECS (before_time) - b->auto_save_failure_time <
3961 1200))
3962 continue;
3963
3964 if (!preparing_for_armageddon &&
3965 (XINT (b->saved_size) * 10
3966 > (BUF_Z (b) - BUF_BEG (b)) * 13)
3967 /* A short file is likely to change a large fraction;
3968 spare the user annoying messages. */
3969 && XINT (b->saved_size) > 5000
3970 /* These messages are frequent and annoying for `*mail*'. */
3971 && !NILP (b->filename)
3972 && NILP (no_message)
3973 && disable_auto_save_when_buffer_shrinks)
3974 {
3975 /* It has shrunk too much; turn off auto-saving here.
3976 Unless we're about to crash, in which case auto-save it
3977 anyway.
3978 */
3979 message
3980 ("Buffer %s has shrunk a lot; auto save turned off there",
3981 XSTRING_DATA (b->name));
3982 /* Turn off auto-saving until there's a real save,
3983 and prevent any more warnings. */
3984 b->saved_size = make_int (-1);
3985 if (!gc_in_progress)
3986 Fsleep_for (make_int (1));
3987 continue;
3988 }
3989 set_buffer_internal (b);
3990 if (!auto_saved && NILP (no_message))
3991 {
3992 static CONST unsigned char *msg
3993 = (CONST unsigned char *) "Auto-saving...";
3994 echo_area_message (selected_frame (), msg, Qnil,
3995 0, strlen ((CONST char *) msg),
3996 Qauto_saving);
3997 }
3998
3999 /* Open the auto-save list file, if necessary.
4000 We only do this now so that the file only exists
4001 if we actually auto-saved any files. */
4002 if (!auto_saved && STRINGP (listfile) && listdesc < 0)
4003 {
4004 listdesc = open ((char *) XSTRING_DATA (listfile),
4005 O_WRONLY | O_TRUNC | O_CREAT | OPEN_BINARY,
4006 CREAT_MODE);
4007
4008 /* Arrange to close that file whether or not we get
4009 an error. */
4010 if (listdesc >= 0)
4011 record_unwind_protect (do_auto_save_unwind,
4012 make_int (listdesc));
4013 }
4014
4015 /* Record all the buffers that we are auto-saving in
4016 the special file that lists them. For each of
4017 these buffers, record visited name (if any) and
4018 auto save name. */
4019 if (listdesc >= 0)
4020 {
4021 CONST Extbyte *auto_save_file_name_ext;
4022 Extcount auto_save_file_name_ext_len;
4023
4024 GET_STRING_FILENAME_DATA_ALLOCA
4025 (b->auto_save_file_name,
4026 auto_save_file_name_ext,
4027 auto_save_file_name_ext_len);
4028 if (!NILP (b->filename))
4029 {
4030 CONST Extbyte *filename_ext;
4031 Extcount filename_ext_len;
4032
4033 GET_STRING_FILENAME_DATA_ALLOCA (b->filename,
4034 filename_ext,
4035 filename_ext_len);
4036 write (listdesc, filename_ext, filename_ext_len);
4037 }
4038 write (listdesc, "\n", 1);
4039 write (listdesc, auto_save_file_name_ext,
4040 auto_save_file_name_ext_len);
4041 write (listdesc, "\n", 1);
4042 }
4043
4044 /* dmoore - In a bad scenario we've set b=XBUFFER(buf)
4045 based on values in Vbuffer_alist. auto_save_1 may
4046 cause lisp handlers to run. Those handlers may kill
4047 the buffer and then GC. Since the buffer is killed,
4048 it's no longer in Vbuffer_alist so it might get reaped
4049 by the GC. We also need to protect tail. */
4050 /* #### There is probably a lot of other code which has
4051 pointers into buffers which may get blown away by
4052 handlers. */
4053 {
4054 struct gcpro ngcpro1, ngcpro2;
4055 NGCPRO2 (buf, tail);
4056 condition_case_1 (Qt,
4057 auto_save_1, Qnil,
4058 auto_save_error, Qnil);
4059 NUNGCPRO;
4060 }
4061 /* Handler killed our saved current-buffer! Pick any. */
4062 if (!BUFFER_LIVE_P (XBUFFER (old)))
4063 XSETBUFFER (old, current_buffer);
4064
4065 set_buffer_internal (XBUFFER (old));
4066 auto_saved++;
4067
4068 /* Handler killed their own buffer! */
4069 if (!BUFFER_LIVE_P(b))
4070 continue;
4071
4072 b->auto_save_modified = BUF_MODIFF (b);
4073 b->saved_size = make_int (BUF_SIZE (b));
4074 EMACS_GET_TIME (after_time);
4075 /* If auto-save took more than 60 seconds,
4076 assume it was an NFS failure that got a timeout. */
4077 if (EMACS_SECS (after_time) - EMACS_SECS (before_time) > 60)
4078 b->auto_save_failure_time = EMACS_SECS (after_time);
4079 }
4080 }
4081 }
4082
4083 /* Prevent another auto save till enough input events come in. */
4084 if (auto_saved)
4085 record_auto_save ();
4086
4087 /* If we didn't save anything into the listfile, remove the old
4088 one because nothing needed to be auto-saved. Do this afterwards
4089 rather than before in case we get a crash attempting to autosave
4090 (in that case we'd still want the old one around). */
4091 if (listdesc < 0 && !auto_saved && STRINGP (listfile))
4092 unlink ((char *) XSTRING_DATA (listfile));
4093
4094 /* Show "...done" only if the echo area would otherwise be empty. */
4095 if (auto_saved && NILP (no_message)
4096 && NILP (clear_echo_area (selected_frame (), Qauto_saving, 0)))
4097 {
4098 static CONST unsigned char *msg
4099 = (CONST unsigned char *)"Auto-saving...done";
4100 echo_area_message (selected_frame (), msg, Qnil, 0,
4101 strlen ((CONST char *) msg), Qauto_saving);
4102 }
4103
4104 Vquit_flag = oquit;
4105
4106 RETURN_UNGCPRO (unbind_to (speccount, Qnil));
4107 }
4108
4109 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved, 0, 0, 0, /*
4110 Mark current buffer as auto-saved with its current text.
4111 No auto-save file will be written until the buffer changes again.
4112 */
4113 ())
4114 {
4115 current_buffer->auto_save_modified = BUF_MODIFF (current_buffer);
4116 current_buffer->saved_size = make_int (BUF_SIZE (current_buffer));
4117 current_buffer->auto_save_failure_time = -1;
4118 return Qnil;
4119 }
4120
4121 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure, 0, 0, 0, /*
4122 Clear any record of a recent auto-save failure in the current buffer.
4123 */
4124 ())
4125 {
4126 current_buffer->auto_save_failure_time = -1;
4127 return Qnil;
4128 }
4129
4130 DEFUN ("recent-auto-save-p", Frecent_auto_save_p, 0, 0, 0, /*
4131 Return t if buffer has been auto-saved since last read in or saved.
4132 */
4133 ())
4134 {
4135 return (BUF_SAVE_MODIFF (current_buffer) <
4136 current_buffer->auto_save_modified) ? Qt : Qnil;
4137 }
4138
4139
4140 /************************************************************************/
4141 /* initialization */
4142 /************************************************************************/
4143
4144 void
4145 syms_of_fileio (void)
4146 {
4147 defsymbol (&Qexpand_file_name, "expand-file-name");
4148 defsymbol (&Qfile_truename, "file-truename");
4149 defsymbol (&Qsubstitute_in_file_name, "substitute-in-file-name");
4150 defsymbol (&Qdirectory_file_name, "directory-file-name");
4151 defsymbol (&Qfile_name_directory, "file-name-directory");
4152 defsymbol (&Qfile_name_nondirectory, "file-name-nondirectory");
4153 defsymbol (&Qunhandled_file_name_directory, "unhandled-file-name-directory");
4154 defsymbol (&Qfile_name_as_directory, "file-name-as-directory");
4155 defsymbol (&Qcopy_file, "copy-file");
4156 defsymbol (&Qmake_directory_internal, "make-directory-internal");
4157 defsymbol (&Qdelete_directory, "delete-directory");
4158 defsymbol (&Qdelete_file, "delete-file");
4159 defsymbol (&Qrename_file, "rename-file");
4160 defsymbol (&Qadd_name_to_file, "add-name-to-file");
4161 defsymbol (&Qmake_symbolic_link, "make-symbolic-link");
4162 defsymbol (&Qfile_exists_p, "file-exists-p");
4163 defsymbol (&Qfile_executable_p, "file-executable-p");
4164 defsymbol (&Qfile_readable_p, "file-readable-p");
4165 defsymbol (&Qfile_symlink_p, "file-symlink-p");
4166 defsymbol (&Qfile_writable_p, "file-writable-p");
4167 defsymbol (&Qfile_directory_p, "file-directory-p");
4168 defsymbol (&Qfile_regular_p, "file-regular-p");
4169 defsymbol (&Qfile_accessible_directory_p, "file-accessible-directory-p");
4170 defsymbol (&Qfile_modes, "file-modes");
4171 defsymbol (&Qset_file_modes, "set-file-modes");
4172 defsymbol (&Qfile_newer_than_file_p, "file-newer-than-file-p");
4173 defsymbol (&Qinsert_file_contents, "insert-file-contents");
4174 defsymbol (&Qwrite_region, "write-region");
4175 defsymbol (&Qverify_visited_file_modtime, "verify-visited-file-modtime");
4176 defsymbol (&Qset_visited_file_modtime, "set-visited-file-modtime");
4177 defsymbol (&Qcar_less_than_car, "car-less-than-car"); /* Vomitous! */
4178
4179 defsymbol (&Qauto_save_hook, "auto-save-hook");
4180 defsymbol (&Qauto_save_error, "auto-save-error");
4181 defsymbol (&Qauto_saving, "auto-saving");
4182
4183 defsymbol (&Qformat_decode, "format-decode");
4184 defsymbol (&Qformat_annotate_function, "format-annotate-function");
4185
4186 defsymbol (&Qcompute_buffer_file_truename, "compute-buffer-file-truename");
4187 deferror (&Qfile_error, "file-error", "File error", Qio_error);
4188 deferror (&Qfile_already_exists, "file-already-exists",
4189 "File already exists", Qfile_error);
4190
4191 DEFSUBR (Ffind_file_name_handler);
4192
4193 DEFSUBR (Ffile_name_directory);
4194 DEFSUBR (Ffile_name_nondirectory);
4195 DEFSUBR (Funhandled_file_name_directory);
4196 DEFSUBR (Ffile_name_as_directory);
4197 DEFSUBR (Fdirectory_file_name);
4198 DEFSUBR (Fmake_temp_name);
4199 DEFSUBR (Fexpand_file_name);
4200 DEFSUBR (Ffile_truename);
4201 DEFSUBR (Fsubstitute_in_file_name);
4202 DEFSUBR (Fcopy_file);
4203 DEFSUBR (Fmake_directory_internal);
4204 DEFSUBR (Fdelete_directory);
4205 DEFSUBR (Fdelete_file);
4206 DEFSUBR (Frename_file);
4207 DEFSUBR (Fadd_name_to_file);
4208 #ifdef S_IFLNK
4209 DEFSUBR (Fmake_symbolic_link);
4210 #endif /* S_IFLNK */
4211 #ifdef HPUX_NET
4212 DEFSUBR (Fsysnetunam);
4213 #endif /* HPUX_NET */
4214 DEFSUBR (Ffile_name_absolute_p);
4215 DEFSUBR (Ffile_exists_p);
4216 DEFSUBR (Ffile_executable_p);
4217 DEFSUBR (Ffile_readable_p);
4218 DEFSUBR (Ffile_writable_p);
4219 DEFSUBR (Ffile_symlink_p);
4220 DEFSUBR (Ffile_directory_p);
4221 DEFSUBR (Ffile_accessible_directory_p);
4222 DEFSUBR (Ffile_regular_p);
4223 DEFSUBR (Ffile_modes);
4224 DEFSUBR (Fset_file_modes);
4225 DEFSUBR (Fset_default_file_modes);
4226 DEFSUBR (Fdefault_file_modes);
4227 DEFSUBR (Funix_sync);
4228 DEFSUBR (Ffile_newer_than_file_p);
4229 DEFSUBR (Finsert_file_contents_internal);
4230 DEFSUBR (Fwrite_region_internal);
4231 DEFSUBR (Fcar_less_than_car); /* Vomitous! */
4232 DEFSUBR (Fcdr_less_than_cdr); /* Yeah oh yeah bucko .... */
4233 #if 0
4234 DEFSUBR (Fencrypt_string);
4235 DEFSUBR (Fdecrypt_string);
4236 #endif
4237 DEFSUBR (Fverify_visited_file_modtime);
4238 DEFSUBR (Fclear_visited_file_modtime);
4239 DEFSUBR (Fvisited_file_modtime);
4240 DEFSUBR (Fset_visited_file_modtime);
4241
4242 DEFSUBR (Fdo_auto_save);
4243 DEFSUBR (Fset_buffer_auto_saved);
4244 DEFSUBR (Fclear_buffer_auto_save_failure);
4245 DEFSUBR (Frecent_auto_save_p);
4246 }
4247
4248 void
4249 vars_of_fileio (void)
4250 {
4251 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format /*
4252 *Format in which to write auto-save files.
4253 Should be a list of symbols naming formats that are defined in `format-alist'.
4254 If it is t, which is the default, auto-save files are written in the
4255 same format as a regular save would use.
4256 */ );
4257 Vauto_save_file_format = Qt;
4258
4259 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist /*
4260 *Alist of elements (REGEXP . HANDLER) for file names handled specially.
4261 If a file name matches REGEXP, then all I/O on that file is done by calling
4262 HANDLER.
4263
4264 The first argument given to HANDLER is the name of the I/O primitive
4265 to be handled; the remaining arguments are the arguments that were
4266 passed to that primitive. For example, if you do
4267 (file-exists-p FILENAME)
4268 and FILENAME is handled by HANDLER, then HANDLER is called like this:
4269 (funcall HANDLER 'file-exists-p FILENAME)
4270 The function `find-file-name-handler' checks this list for a handler
4271 for its argument.
4272 */ );
4273 Vfile_name_handler_alist = Qnil;
4274
4275 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions /*
4276 A list of functions to be called at the end of `insert-file-contents'.
4277 Each is passed one argument, the number of bytes inserted. It should return
4278 the new byte count, and leave point the same. If `insert-file-contents' is
4279 intercepted by a handler from `file-name-handler-alist', that handler is
4280 responsible for calling the after-insert-file-functions if appropriate.
4281 */ );
4282 Vafter_insert_file_functions = Qnil;
4283
4284 DEFVAR_LISP ("write-region-annotate-functions",
4285 &Vwrite_region_annotate_functions /*
4286 A list of functions to be called at the start of `write-region'.
4287 Each is passed two arguments, START and END, as for `write-region'.
4288 It should return a list of pairs (POSITION . STRING) of strings to be
4289 effectively inserted at the specified positions of the file being written
4290 \(1 means to insert before the first byte written). The POSITIONs must be
4291 sorted into increasing order. If there are several functions in the list,
4292 the several lists are merged destructively.
4293 */ );
4294 Vwrite_region_annotate_functions = Qnil;
4295
4296 DEFVAR_LISP ("write-region-annotations-so-far",
4297 &Vwrite_region_annotations_so_far /*
4298 When an annotation function is called, this holds the previous annotations.
4299 These are the annotations made by other annotation functions
4300 that were already called. See also `write-region-annotate-functions'.
4301 */ );
4302 Vwrite_region_annotations_so_far = Qnil;
4303
4304 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers /*
4305 A list of file name handlers that temporarily should not be used.
4306 This applies only to the operation `inhibit-file-name-operation'.
4307 */ );
4308 Vinhibit_file_name_handlers = Qnil;
4309
4310 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation /*
4311 The operation for which `inhibit-file-name-handlers' is applicable.
4312 */ );
4313 Vinhibit_file_name_operation = Qnil;
4314
4315 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name /*
4316 File name in which we write a list of all auto save file names.
4317 */ );
4318 Vauto_save_list_file_name = Qnil;
4319
4320 DEFVAR_BOOL ("disable-auto-save-when-buffer-shrinks",
4321 &disable_auto_save_when_buffer_shrinks /*
4322 If non-nil, auto-saving is disabled when a buffer shrinks too much.
4323 This is to prevent you from losing your edits if you accidentally
4324 delete a large chunk of the buffer and don't notice it until too late.
4325 Saving the buffer normally turns auto-save back on.
4326 */ );
4327 disable_auto_save_when_buffer_shrinks = 1;
4328
4329 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char /*
4330 Directory separator character for built-in functions that return file names.
4331 The value should be either ?/ or ?\\ (any other value is treated as ?\\).
4332 This variable affects the built-in functions only on Windows,
4333 on other platforms, it is initialized so that Lisp code can find out
4334 what the normal separator is.
4335 */ );
4336 Vdirectory_sep_char = make_char ('/');
4337 }