(syms_of_fileio): Clarify docstring of `write-region-inhibit-fsync'.
[bpt/emacs.git] / src / fileio.c
1 /* File IO for GNU Emacs.
2 Copyright (C) 1985, 1986, 1987, 1988, 1993, 1994, 1995, 1996,
3 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4 2005 Free Software Foundation, Inc.
5
6 This file is part of GNU Emacs.
7
8 GNU Emacs is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
11 any later version.
12
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs; see the file COPYING. If not, write to
20 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
21 Boston, MA 02110-1301, USA. */
22
23 #include <config.h>
24
25 #ifdef HAVE_FCNTL_H
26 #include <fcntl.h>
27 #endif
28
29 #include <stdio.h>
30 #include <sys/types.h>
31 #include <sys/stat.h>
32
33 #ifdef HAVE_UNISTD_H
34 #include <unistd.h>
35 #endif
36
37 #if !defined (S_ISLNK) && defined (S_IFLNK)
38 # define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
39 #endif
40
41 #if !defined (S_ISFIFO) && defined (S_IFIFO)
42 # define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO)
43 #endif
44
45 #if !defined (S_ISREG) && defined (S_IFREG)
46 # define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
47 #endif
48
49 #ifdef HAVE_PWD_H
50 #include <pwd.h>
51 #endif
52
53 #include <ctype.h>
54
55 #ifdef VMS
56 #include "vmsdir.h"
57 #include <perror.h>
58 #include <stddef.h>
59 #include <string.h>
60 #endif
61
62 #include <errno.h>
63
64 #ifndef vax11c
65 #ifndef USE_CRT_DLL
66 extern int errno;
67 #endif
68 #endif
69
70 #ifdef APOLLO
71 #include <sys/time.h>
72 #endif
73
74 #include "lisp.h"
75 #include "intervals.h"
76 #include "buffer.h"
77 #include "charset.h"
78 #include "coding.h"
79 #include "window.h"
80
81 #ifdef WINDOWSNT
82 #define NOMINMAX 1
83 #include <windows.h>
84 #include <stdlib.h>
85 #include <fcntl.h>
86 #endif /* not WINDOWSNT */
87
88 #ifdef MSDOS
89 #include "msdos.h"
90 #include <sys/param.h>
91 #if __DJGPP__ >= 2
92 #include <fcntl.h>
93 #include <string.h>
94 #endif
95 #endif
96
97 #ifdef DOS_NT
98 #define CORRECT_DIR_SEPS(s) \
99 do { if ('/' == DIRECTORY_SEP) dostounix_filename (s); \
100 else unixtodos_filename (s); \
101 } while (0)
102 /* On Windows, drive letters must be alphabetic - on DOS, the Netware
103 redirector allows the six letters between 'Z' and 'a' as well. */
104 #ifdef MSDOS
105 #define IS_DRIVE(x) ((x) >= 'A' && (x) <= 'z')
106 #endif
107 #ifdef WINDOWSNT
108 #define IS_DRIVE(x) isalpha (x)
109 #endif
110 /* Need to lower-case the drive letter, or else expanded
111 filenames will sometimes compare inequal, because
112 `expand-file-name' doesn't always down-case the drive letter. */
113 #define DRIVE_LETTER(x) (tolower (x))
114 #endif
115
116 #ifdef VMS
117 #include <file.h>
118 #include <rmsdef.h>
119 #include <fab.h>
120 #include <nam.h>
121 #endif
122
123 #include "systime.h"
124
125 #ifdef HPUX
126 #include <netio.h>
127 #ifndef HPUX8
128 #ifndef HPUX9
129 #include <errnet.h>
130 #endif
131 #endif
132 #endif
133
134 #include "commands.h"
135 extern int use_dialog_box;
136 extern int use_file_dialog;
137
138 #ifndef O_WRONLY
139 #define O_WRONLY 1
140 #endif
141
142 #ifndef O_RDONLY
143 #define O_RDONLY 0
144 #endif
145
146 #ifndef S_ISLNK
147 # define lstat stat
148 #endif
149
150 #ifndef FILE_SYSTEM_CASE
151 #define FILE_SYSTEM_CASE(filename) (filename)
152 #endif
153
154 /* Nonzero during writing of auto-save files */
155 int auto_saving;
156
157 /* Set by auto_save_1 to mode of original file so Fwrite_region will create
158 a new file with the same mode as the original */
159 int auto_save_mode_bits;
160
161 /* The symbol bound to coding-system-for-read when
162 insert-file-contents is called for recovering a file. This is not
163 an actual coding system name, but just an indicator to tell
164 insert-file-contents to use `emacs-mule' with a special flag for
165 auto saving and recovering a file. */
166 Lisp_Object Qauto_save_coding;
167
168 /* Coding system for file names, or nil if none. */
169 Lisp_Object Vfile_name_coding_system;
170
171 /* Coding system for file names used only when
172 Vfile_name_coding_system is nil. */
173 Lisp_Object Vdefault_file_name_coding_system;
174
175 /* Alist of elements (REGEXP . HANDLER) for file names
176 whose I/O is done with a special handler. */
177 Lisp_Object Vfile_name_handler_alist;
178
179 /* Property name of a file name handler,
180 which gives a list of operations it handles.. */
181 Lisp_Object Qoperations;
182
183 /* Lisp functions for translating file formats */
184 Lisp_Object Qformat_decode, Qformat_annotate_function;
185
186 /* Function to be called to decide a coding system of a reading file. */
187 Lisp_Object Vset_auto_coding_function;
188
189 /* Functions to be called to process text properties in inserted file. */
190 Lisp_Object Vafter_insert_file_functions;
191
192 /* Lisp function for setting buffer-file-coding-system and the
193 multibyteness of the current buffer after inserting a file. */
194 Lisp_Object Qafter_insert_file_set_coding;
195
196 /* Functions to be called to create text property annotations for file. */
197 Lisp_Object Vwrite_region_annotate_functions;
198 Lisp_Object Qwrite_region_annotate_functions;
199
200 /* During build_annotations, each time an annotation function is called,
201 this holds the annotations made by the previous functions. */
202 Lisp_Object Vwrite_region_annotations_so_far;
203
204 /* File name in which we write a list of all our auto save files. */
205 Lisp_Object Vauto_save_list_file_name;
206
207 /* Function to call to read a file name. */
208 Lisp_Object Vread_file_name_function;
209
210 /* Current predicate used by read_file_name_internal. */
211 Lisp_Object Vread_file_name_predicate;
212
213 /* Nonzero means completion ignores case when reading file name. */
214 int read_file_name_completion_ignore_case;
215
216 /* Nonzero means, when reading a filename in the minibuffer,
217 start out by inserting the default directory into the minibuffer. */
218 int insert_default_directory;
219
220 /* On VMS, nonzero means write new files with record format stmlf.
221 Zero means use var format. */
222 int vms_stmlf_recfm;
223
224 /* On NT, specifies the directory separator character, used (eg.) when
225 expanding file names. This can be bound to / or \. */
226 Lisp_Object Vdirectory_sep_char;
227
228 #ifdef HAVE_FSYNC
229 /* Nonzero means skip the call to fsync in Fwrite-region. */
230 int write_region_inhibit_fsync;
231 #endif
232
233 extern Lisp_Object Vuser_login_name;
234
235 #ifdef WINDOWSNT
236 extern Lisp_Object Vw32_get_true_file_attributes;
237 #endif
238
239 extern int minibuf_level;
240
241 extern int minibuffer_auto_raise;
242
243 extern int history_delete_duplicates;
244
245 /* These variables describe handlers that have "already" had a chance
246 to handle the current operation.
247
248 Vinhibit_file_name_handlers is a list of file name handlers.
249 Vinhibit_file_name_operation is the operation being handled.
250 If we try to handle that operation, we ignore those handlers. */
251
252 static Lisp_Object Vinhibit_file_name_handlers;
253 static Lisp_Object Vinhibit_file_name_operation;
254
255 Lisp_Object Qfile_error, Qfile_already_exists, Qfile_date_error;
256 Lisp_Object Qexcl;
257 Lisp_Object Qfile_name_history;
258
259 Lisp_Object Qcar_less_than_car;
260
261 static int a_write P_ ((int, Lisp_Object, int, int,
262 Lisp_Object *, struct coding_system *));
263 static int e_write P_ ((int, Lisp_Object, int, int, struct coding_system *));
264
265 \f
266 void
267 report_file_error (string, data)
268 const char *string;
269 Lisp_Object data;
270 {
271 Lisp_Object errstring;
272 int errorno = errno;
273
274 synchronize_system_messages_locale ();
275 errstring = code_convert_string_norecord (build_string (strerror (errorno)),
276 Vlocale_coding_system, 0);
277
278 while (1)
279 switch (errorno)
280 {
281 case EEXIST:
282 Fsignal (Qfile_already_exists, Fcons (errstring, data));
283 break;
284 default:
285 /* System error messages are capitalized. Downcase the initial
286 unless it is followed by a slash. */
287 if (SREF (errstring, 1) != '/')
288 SSET (errstring, 0, DOWNCASE (SREF (errstring, 0)));
289
290 Fsignal (Qfile_error,
291 Fcons (build_string (string), Fcons (errstring, data)));
292 }
293 }
294
295 Lisp_Object
296 close_file_unwind (fd)
297 Lisp_Object fd;
298 {
299 emacs_close (XFASTINT (fd));
300 return Qnil;
301 }
302
303 /* Restore point, having saved it as a marker. */
304
305 static Lisp_Object
306 restore_point_unwind (location)
307 Lisp_Object location;
308 {
309 Fgoto_char (location);
310 Fset_marker (location, Qnil, Qnil);
311 return Qnil;
312 }
313 \f
314 Lisp_Object Qexpand_file_name;
315 Lisp_Object Qsubstitute_in_file_name;
316 Lisp_Object Qdirectory_file_name;
317 Lisp_Object Qfile_name_directory;
318 Lisp_Object Qfile_name_nondirectory;
319 Lisp_Object Qunhandled_file_name_directory;
320 Lisp_Object Qfile_name_as_directory;
321 Lisp_Object Qcopy_file;
322 Lisp_Object Qmake_directory_internal;
323 Lisp_Object Qmake_directory;
324 Lisp_Object Qdelete_directory;
325 Lisp_Object Qdelete_file;
326 Lisp_Object Qrename_file;
327 Lisp_Object Qadd_name_to_file;
328 Lisp_Object Qmake_symbolic_link;
329 Lisp_Object Qfile_exists_p;
330 Lisp_Object Qfile_executable_p;
331 Lisp_Object Qfile_readable_p;
332 Lisp_Object Qfile_writable_p;
333 Lisp_Object Qfile_symlink_p;
334 Lisp_Object Qaccess_file;
335 Lisp_Object Qfile_directory_p;
336 Lisp_Object Qfile_regular_p;
337 Lisp_Object Qfile_accessible_directory_p;
338 Lisp_Object Qfile_modes;
339 Lisp_Object Qset_file_modes;
340 Lisp_Object Qset_file_times;
341 Lisp_Object Qfile_newer_than_file_p;
342 Lisp_Object Qinsert_file_contents;
343 Lisp_Object Qwrite_region;
344 Lisp_Object Qverify_visited_file_modtime;
345 Lisp_Object Qset_visited_file_modtime;
346
347 DEFUN ("find-file-name-handler", Ffind_file_name_handler, Sfind_file_name_handler, 2, 2, 0,
348 doc: /* Return FILENAME's handler function for OPERATION, if it has one.
349 Otherwise, return nil.
350 A file name is handled if one of the regular expressions in
351 `file-name-handler-alist' matches it.
352
353 If OPERATION equals `inhibit-file-name-operation', then we ignore
354 any handlers that are members of `inhibit-file-name-handlers',
355 but we still do run any other handlers. This lets handlers
356 use the standard functions without calling themselves recursively. */)
357 (filename, operation)
358 Lisp_Object filename, operation;
359 {
360 /* This function must not munge the match data. */
361 Lisp_Object chain, inhibited_handlers, result;
362 int pos = -1;
363
364 result = Qnil;
365 CHECK_STRING (filename);
366
367 if (EQ (operation, Vinhibit_file_name_operation))
368 inhibited_handlers = Vinhibit_file_name_handlers;
369 else
370 inhibited_handlers = Qnil;
371
372 for (chain = Vfile_name_handler_alist; CONSP (chain);
373 chain = XCDR (chain))
374 {
375 Lisp_Object elt;
376 elt = XCAR (chain);
377 if (CONSP (elt))
378 {
379 Lisp_Object string = XCAR (elt);
380 int match_pos;
381 Lisp_Object handler = XCDR (elt);
382 Lisp_Object operations = Qnil;
383
384 if (SYMBOLP (handler))
385 operations = Fget (handler, Qoperations);
386
387 if (STRINGP (string)
388 && (match_pos = fast_string_match (string, filename)) > pos
389 && (NILP (operations) || ! NILP (Fmemq (operation, operations))))
390 {
391 Lisp_Object tem;
392
393 handler = XCDR (elt);
394 tem = Fmemq (handler, inhibited_handlers);
395 if (NILP (tem))
396 {
397 result = handler;
398 pos = match_pos;
399 }
400 }
401 }
402
403 QUIT;
404 }
405 return result;
406 }
407 \f
408 DEFUN ("file-name-directory", Ffile_name_directory, Sfile_name_directory,
409 1, 1, 0,
410 doc: /* Return the directory component in file name FILENAME.
411 Return nil if FILENAME does not include a directory.
412 Otherwise return a directory spec.
413 Given a Unix syntax file name, returns a string ending in slash;
414 on VMS, perhaps instead a string ending in `:', `]' or `>'. */)
415 (filename)
416 Lisp_Object filename;
417 {
418 #ifndef DOS_NT
419 register const unsigned char *beg;
420 #else
421 register unsigned char *beg;
422 #endif
423 register const unsigned char *p;
424 Lisp_Object handler;
425
426 CHECK_STRING (filename);
427
428 /* If the file name has special constructs in it,
429 call the corresponding file handler. */
430 handler = Ffind_file_name_handler (filename, Qfile_name_directory);
431 if (!NILP (handler))
432 return call2 (handler, Qfile_name_directory, filename);
433
434 filename = FILE_SYSTEM_CASE (filename);
435 beg = SDATA (filename);
436 #ifdef DOS_NT
437 beg = strcpy (alloca (strlen (beg) + 1), beg);
438 #endif
439 p = beg + SBYTES (filename);
440
441 while (p != beg && !IS_DIRECTORY_SEP (p[-1])
442 #ifdef VMS
443 && p[-1] != ':' && p[-1] != ']' && p[-1] != '>'
444 #endif /* VMS */
445 #ifdef DOS_NT
446 /* only recognise drive specifier at the beginning */
447 && !(p[-1] == ':'
448 /* handle the "/:d:foo" and "/:foo" cases correctly */
449 && ((p == beg + 2 && !IS_DIRECTORY_SEP (*beg))
450 || (p == beg + 4 && IS_DIRECTORY_SEP (*beg))))
451 #endif
452 ) p--;
453
454 if (p == beg)
455 return Qnil;
456 #ifdef DOS_NT
457 /* Expansion of "c:" to drive and default directory. */
458 if (p[-1] == ':')
459 {
460 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
461 unsigned char *res = alloca (MAXPATHLEN + 1);
462 unsigned char *r = res;
463
464 if (p == beg + 4 && IS_DIRECTORY_SEP (*beg) && beg[1] == ':')
465 {
466 strncpy (res, beg, 2);
467 beg += 2;
468 r += 2;
469 }
470
471 if (getdefdir (toupper (*beg) - 'A' + 1, r))
472 {
473 if (!IS_DIRECTORY_SEP (res[strlen (res) - 1]))
474 strcat (res, "/");
475 beg = res;
476 p = beg + strlen (beg);
477 }
478 }
479 CORRECT_DIR_SEPS (beg);
480 #endif /* DOS_NT */
481
482 return make_specified_string (beg, -1, p - beg, STRING_MULTIBYTE (filename));
483 }
484
485 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory,
486 Sfile_name_nondirectory, 1, 1, 0,
487 doc: /* Return file name FILENAME sans its directory.
488 For example, in a Unix-syntax file name,
489 this is everything after the last slash,
490 or the entire name if it contains no slash. */)
491 (filename)
492 Lisp_Object filename;
493 {
494 register const unsigned char *beg, *p, *end;
495 Lisp_Object handler;
496
497 CHECK_STRING (filename);
498
499 /* If the file name has special constructs in it,
500 call the corresponding file handler. */
501 handler = Ffind_file_name_handler (filename, Qfile_name_nondirectory);
502 if (!NILP (handler))
503 return call2 (handler, Qfile_name_nondirectory, filename);
504
505 beg = SDATA (filename);
506 end = p = beg + SBYTES (filename);
507
508 while (p != beg && !IS_DIRECTORY_SEP (p[-1])
509 #ifdef VMS
510 && p[-1] != ':' && p[-1] != ']' && p[-1] != '>'
511 #endif /* VMS */
512 #ifdef DOS_NT
513 /* only recognise drive specifier at beginning */
514 && !(p[-1] == ':'
515 /* handle the "/:d:foo" case correctly */
516 && (p == beg + 2 || (p == beg + 4 && IS_DIRECTORY_SEP (*beg))))
517 #endif
518 )
519 p--;
520
521 return make_specified_string (p, -1, end - p, STRING_MULTIBYTE (filename));
522 }
523
524 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory,
525 Sunhandled_file_name_directory, 1, 1, 0,
526 doc: /* Return a directly usable directory name somehow associated with FILENAME.
527 A `directly usable' directory name is one that may be used without the
528 intervention of any file handler.
529 If FILENAME is a directly usable file itself, return
530 \(file-name-directory FILENAME).
531 The `call-process' and `start-process' functions use this function to
532 get a current directory to run processes in. */)
533 (filename)
534 Lisp_Object filename;
535 {
536 Lisp_Object handler;
537
538 /* If the file name has special constructs in it,
539 call the corresponding file handler. */
540 handler = Ffind_file_name_handler (filename, Qunhandled_file_name_directory);
541 if (!NILP (handler))
542 return call2 (handler, Qunhandled_file_name_directory, filename);
543
544 return Ffile_name_directory (filename);
545 }
546
547 \f
548 char *
549 file_name_as_directory (out, in)
550 char *out, *in;
551 {
552 int size = strlen (in) - 1;
553
554 strcpy (out, in);
555
556 if (size < 0)
557 {
558 out[0] = '.';
559 out[1] = '/';
560 out[2] = 0;
561 return out;
562 }
563
564 #ifdef VMS
565 /* Is it already a directory string? */
566 if (in[size] == ':' || in[size] == ']' || in[size] == '>')
567 return out;
568 /* Is it a VMS directory file name? If so, hack VMS syntax. */
569 else if (! index (in, '/')
570 && ((size > 3 && ! strcmp (&in[size - 3], ".DIR"))
571 || (size > 3 && ! strcmp (&in[size - 3], ".dir"))
572 || (size > 5 && (! strncmp (&in[size - 5], ".DIR", 4)
573 || ! strncmp (&in[size - 5], ".dir", 4))
574 && (in[size - 1] == '.' || in[size - 1] == ';')
575 && in[size] == '1')))
576 {
577 register char *p, *dot;
578 char brack;
579
580 /* x.dir -> [.x]
581 dir:x.dir --> dir:[x]
582 dir:[x]y.dir --> dir:[x.y] */
583 p = in + size;
584 while (p != in && *p != ':' && *p != '>' && *p != ']') p--;
585 if (p != in)
586 {
587 strncpy (out, in, p - in);
588 out[p - in] = '\0';
589 if (*p == ':')
590 {
591 brack = ']';
592 strcat (out, ":[");
593 }
594 else
595 {
596 brack = *p;
597 strcat (out, ".");
598 }
599 p++;
600 }
601 else
602 {
603 brack = ']';
604 strcpy (out, "[.");
605 }
606 dot = index (p, '.');
607 if (dot)
608 {
609 /* blindly remove any extension */
610 size = strlen (out) + (dot - p);
611 strncat (out, p, dot - p);
612 }
613 else
614 {
615 strcat (out, p);
616 size = strlen (out);
617 }
618 out[size++] = brack;
619 out[size] = '\0';
620 }
621 #else /* not VMS */
622 /* For Unix syntax, Append a slash if necessary */
623 if (!IS_DIRECTORY_SEP (out[size]))
624 {
625 /* Cannot use DIRECTORY_SEP, which could have any value */
626 out[size + 1] = '/';
627 out[size + 2] = '\0';
628 }
629 #ifdef DOS_NT
630 CORRECT_DIR_SEPS (out);
631 #endif
632 #endif /* not VMS */
633 return out;
634 }
635
636 DEFUN ("file-name-as-directory", Ffile_name_as_directory,
637 Sfile_name_as_directory, 1, 1, 0,
638 doc: /* Return a string representing the file name FILE interpreted as a directory.
639 This operation exists because a directory is also a file, but its name as
640 a directory is different from its name as a file.
641 The result can be used as the value of `default-directory'
642 or passed as second argument to `expand-file-name'.
643 For a Unix-syntax file name, just appends a slash.
644 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc. */)
645 (file)
646 Lisp_Object file;
647 {
648 char *buf;
649 Lisp_Object handler;
650
651 CHECK_STRING (file);
652 if (NILP (file))
653 return Qnil;
654
655 /* If the file name has special constructs in it,
656 call the corresponding file handler. */
657 handler = Ffind_file_name_handler (file, Qfile_name_as_directory);
658 if (!NILP (handler))
659 return call2 (handler, Qfile_name_as_directory, file);
660
661 buf = (char *) alloca (SBYTES (file) + 10);
662 file_name_as_directory (buf, SDATA (file));
663 return make_specified_string (buf, -1, strlen (buf),
664 STRING_MULTIBYTE (file));
665 }
666 \f
667 /*
668 * Convert from directory name to filename.
669 * On VMS:
670 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
671 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
672 * On UNIX, it's simple: just make sure there isn't a terminating /
673
674 * Value is nonzero if the string output is different from the input.
675 */
676
677 int
678 directory_file_name (src, dst)
679 char *src, *dst;
680 {
681 long slen;
682 #ifdef VMS
683 long rlen;
684 char * ptr, * rptr;
685 char bracket;
686 struct FAB fab = cc$rms_fab;
687 struct NAM nam = cc$rms_nam;
688 char esa[NAM$C_MAXRSS];
689 #endif /* VMS */
690
691 slen = strlen (src);
692 #ifdef VMS
693 if (! index (src, '/')
694 && (src[slen - 1] == ']'
695 || src[slen - 1] == ':'
696 || src[slen - 1] == '>'))
697 {
698 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
699 fab.fab$l_fna = src;
700 fab.fab$b_fns = slen;
701 fab.fab$l_nam = &nam;
702 fab.fab$l_fop = FAB$M_NAM;
703
704 nam.nam$l_esa = esa;
705 nam.nam$b_ess = sizeof esa;
706 nam.nam$b_nop |= NAM$M_SYNCHK;
707
708 /* We call SYS$PARSE to handle such things as [--] for us. */
709 if (SYS$PARSE (&fab, 0, 0) == RMS$_NORMAL)
710 {
711 slen = nam.nam$b_esl;
712 if (esa[slen - 1] == ';' && esa[slen - 2] == '.')
713 slen -= 2;
714 esa[slen] = '\0';
715 src = esa;
716 }
717 if (src[slen - 1] != ']' && src[slen - 1] != '>')
718 {
719 /* what about when we have logical_name:???? */
720 if (src[slen - 1] == ':')
721 { /* Xlate logical name and see what we get */
722 ptr = strcpy (dst, src); /* upper case for getenv */
723 while (*ptr)
724 {
725 if ('a' <= *ptr && *ptr <= 'z')
726 *ptr -= 040;
727 ptr++;
728 }
729 dst[slen - 1] = 0; /* remove colon */
730 if (!(src = egetenv (dst)))
731 return 0;
732 /* should we jump to the beginning of this procedure?
733 Good points: allows us to use logical names that xlate
734 to Unix names,
735 Bad points: can be a problem if we just translated to a device
736 name...
737 For now, I'll punt and always expect VMS names, and hope for
738 the best! */
739 slen = strlen (src);
740 if (src[slen - 1] != ']' && src[slen - 1] != '>')
741 { /* no recursion here! */
742 strcpy (dst, src);
743 return 0;
744 }
745 }
746 else
747 { /* not a directory spec */
748 strcpy (dst, src);
749 return 0;
750 }
751 }
752 bracket = src[slen - 1];
753
754 /* If bracket is ']' or '>', bracket - 2 is the corresponding
755 opening bracket. */
756 ptr = index (src, bracket - 2);
757 if (ptr == 0)
758 { /* no opening bracket */
759 strcpy (dst, src);
760 return 0;
761 }
762 if (!(rptr = rindex (src, '.')))
763 rptr = ptr;
764 slen = rptr - src;
765 strncpy (dst, src, slen);
766 dst[slen] = '\0';
767 if (*rptr == '.')
768 {
769 dst[slen++] = bracket;
770 dst[slen] = '\0';
771 }
772 else
773 {
774 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
775 then translate the device and recurse. */
776 if (dst[slen - 1] == ':'
777 && dst[slen - 2] != ':' /* skip decnet nodes */
778 && strcmp (src + slen, "[000000]") == 0)
779 {
780 dst[slen - 1] = '\0';
781 if ((ptr = egetenv (dst))
782 && (rlen = strlen (ptr) - 1) > 0
783 && (ptr[rlen] == ']' || ptr[rlen] == '>')
784 && ptr[rlen - 1] == '.')
785 {
786 char * buf = (char *) alloca (strlen (ptr) + 1);
787 strcpy (buf, ptr);
788 buf[rlen - 1] = ']';
789 buf[rlen] = '\0';
790 return directory_file_name (buf, dst);
791 }
792 else
793 dst[slen - 1] = ':';
794 }
795 strcat (dst, "[000000]");
796 slen += 8;
797 }
798 rptr++;
799 rlen = strlen (rptr) - 1;
800 strncat (dst, rptr, rlen);
801 dst[slen + rlen] = '\0';
802 strcat (dst, ".DIR.1");
803 return 1;
804 }
805 #endif /* VMS */
806 /* Process as Unix format: just remove any final slash.
807 But leave "/" unchanged; do not change it to "". */
808 strcpy (dst, src);
809 #ifdef APOLLO
810 /* Handle // as root for apollo's. */
811 if ((slen > 2 && dst[slen - 1] == '/')
812 || (slen > 1 && dst[0] != '/' && dst[slen - 1] == '/'))
813 dst[slen - 1] = 0;
814 #else
815 if (slen > 1
816 && IS_DIRECTORY_SEP (dst[slen - 1])
817 #ifdef DOS_NT
818 && !IS_ANY_SEP (dst[slen - 2])
819 #endif
820 )
821 dst[slen - 1] = 0;
822 #endif
823 #ifdef DOS_NT
824 CORRECT_DIR_SEPS (dst);
825 #endif
826 return 1;
827 }
828
829 DEFUN ("directory-file-name", Fdirectory_file_name, Sdirectory_file_name,
830 1, 1, 0,
831 doc: /* Returns the file name of the directory named DIRECTORY.
832 This is the name of the file that holds the data for the directory DIRECTORY.
833 This operation exists because a directory is also a file, but its name as
834 a directory is different from its name as a file.
835 In Unix-syntax, this function just removes the final slash.
836 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",
837 it returns a file name such as \"[X]Y.DIR.1\". */)
838 (directory)
839 Lisp_Object directory;
840 {
841 char *buf;
842 Lisp_Object handler;
843
844 CHECK_STRING (directory);
845
846 if (NILP (directory))
847 return Qnil;
848
849 /* If the file name has special constructs in it,
850 call the corresponding file handler. */
851 handler = Ffind_file_name_handler (directory, Qdirectory_file_name);
852 if (!NILP (handler))
853 return call2 (handler, Qdirectory_file_name, directory);
854
855 #ifdef VMS
856 /* 20 extra chars is insufficient for VMS, since we might perform a
857 logical name translation. an equivalence string can be up to 255
858 chars long, so grab that much extra space... - sss */
859 buf = (char *) alloca (SBYTES (directory) + 20 + 255);
860 #else
861 buf = (char *) alloca (SBYTES (directory) + 20);
862 #endif
863 directory_file_name (SDATA (directory), buf);
864 return make_specified_string (buf, -1, strlen (buf),
865 STRING_MULTIBYTE (directory));
866 }
867
868 static char make_temp_name_tbl[64] =
869 {
870 'A','B','C','D','E','F','G','H',
871 'I','J','K','L','M','N','O','P',
872 'Q','R','S','T','U','V','W','X',
873 'Y','Z','a','b','c','d','e','f',
874 'g','h','i','j','k','l','m','n',
875 'o','p','q','r','s','t','u','v',
876 'w','x','y','z','0','1','2','3',
877 '4','5','6','7','8','9','-','_'
878 };
879
880 static unsigned make_temp_name_count, make_temp_name_count_initialized_p;
881
882 /* Value is a temporary file name starting with PREFIX, a string.
883
884 The Emacs process number forms part of the result, so there is
885 no danger of generating a name being used by another process.
886 In addition, this function makes an attempt to choose a name
887 which has no existing file. To make this work, PREFIX should be
888 an absolute file name.
889
890 BASE64_P non-zero means add the pid as 3 characters in base64
891 encoding. In this case, 6 characters will be added to PREFIX to
892 form the file name. Otherwise, if Emacs is running on a system
893 with long file names, add the pid as a decimal number.
894
895 This function signals an error if no unique file name could be
896 generated. */
897
898 Lisp_Object
899 make_temp_name (prefix, base64_p)
900 Lisp_Object prefix;
901 int base64_p;
902 {
903 Lisp_Object val;
904 int len, clen;
905 int pid;
906 unsigned char *p, *data;
907 char pidbuf[20];
908 int pidlen;
909
910 CHECK_STRING (prefix);
911
912 /* VAL is created by adding 6 characters to PREFIX. The first
913 three are the PID of this process, in base 64, and the second
914 three are incremented if the file already exists. This ensures
915 262144 unique file names per PID per PREFIX. */
916
917 pid = (int) getpid ();
918
919 if (base64_p)
920 {
921 pidbuf[0] = make_temp_name_tbl[pid & 63], pid >>= 6;
922 pidbuf[1] = make_temp_name_tbl[pid & 63], pid >>= 6;
923 pidbuf[2] = make_temp_name_tbl[pid & 63], pid >>= 6;
924 pidlen = 3;
925 }
926 else
927 {
928 #ifdef HAVE_LONG_FILE_NAMES
929 sprintf (pidbuf, "%d", pid);
930 pidlen = strlen (pidbuf);
931 #else
932 pidbuf[0] = make_temp_name_tbl[pid & 63], pid >>= 6;
933 pidbuf[1] = make_temp_name_tbl[pid & 63], pid >>= 6;
934 pidbuf[2] = make_temp_name_tbl[pid & 63], pid >>= 6;
935 pidlen = 3;
936 #endif
937 }
938
939 len = SBYTES (prefix); clen = SCHARS (prefix);
940 val = make_uninit_multibyte_string (clen + 3 + pidlen, len + 3 + pidlen);
941 if (!STRING_MULTIBYTE (prefix))
942 STRING_SET_UNIBYTE (val);
943 data = SDATA (val);
944 bcopy(SDATA (prefix), data, len);
945 p = data + len;
946
947 bcopy (pidbuf, p, pidlen);
948 p += pidlen;
949
950 /* Here we try to minimize useless stat'ing when this function is
951 invoked many times successively with the same PREFIX. We achieve
952 this by initializing count to a random value, and incrementing it
953 afterwards.
954
955 We don't want make-temp-name to be called while dumping,
956 because then make_temp_name_count_initialized_p would get set
957 and then make_temp_name_count would not be set when Emacs starts. */
958
959 if (!make_temp_name_count_initialized_p)
960 {
961 make_temp_name_count = (unsigned) time (NULL);
962 make_temp_name_count_initialized_p = 1;
963 }
964
965 while (1)
966 {
967 struct stat ignored;
968 unsigned num = make_temp_name_count;
969
970 p[0] = make_temp_name_tbl[num & 63], num >>= 6;
971 p[1] = make_temp_name_tbl[num & 63], num >>= 6;
972 p[2] = make_temp_name_tbl[num & 63], num >>= 6;
973
974 /* Poor man's congruential RN generator. Replace with
975 ++make_temp_name_count for debugging. */
976 make_temp_name_count += 25229;
977 make_temp_name_count %= 225307;
978
979 if (stat (data, &ignored) < 0)
980 {
981 /* We want to return only if errno is ENOENT. */
982 if (errno == ENOENT)
983 return val;
984 else
985 /* The error here is dubious, but there is little else we
986 can do. The alternatives are to return nil, which is
987 as bad as (and in many cases worse than) throwing the
988 error, or to ignore the error, which will likely result
989 in looping through 225307 stat's, which is not only
990 dog-slow, but also useless since it will fallback to
991 the errow below, anyway. */
992 report_file_error ("Cannot create temporary name for prefix",
993 Fcons (prefix, Qnil));
994 /* not reached */
995 }
996 }
997
998 error ("Cannot create temporary name for prefix `%s'",
999 SDATA (prefix));
1000 return Qnil;
1001 }
1002
1003
1004 DEFUN ("make-temp-name", Fmake_temp_name, Smake_temp_name, 1, 1, 0,
1005 doc: /* Generate temporary file name (string) starting with PREFIX (a string).
1006 The Emacs process number forms part of the result,
1007 so there is no danger of generating a name being used by another process.
1008
1009 In addition, this function makes an attempt to choose a name
1010 which has no existing file. To make this work,
1011 PREFIX should be an absolute file name.
1012
1013 There is a race condition between calling `make-temp-name' and creating the
1014 file which opens all kinds of security holes. For that reason, you should
1015 probably use `make-temp-file' instead, except in three circumstances:
1016
1017 * If you are creating the file in the user's home directory.
1018 * If you are creating a directory rather than an ordinary file.
1019 * If you are taking special precautions as `make-temp-file' does. */)
1020 (prefix)
1021 Lisp_Object prefix;
1022 {
1023 return make_temp_name (prefix, 0);
1024 }
1025
1026
1027 \f
1028 DEFUN ("expand-file-name", Fexpand_file_name, Sexpand_file_name, 1, 2, 0,
1029 doc: /* Convert filename NAME to absolute, and canonicalize it.
1030 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative
1031 \(does not start with slash); if DEFAULT-DIRECTORY is nil or missing,
1032 the current buffer's value of `default-directory' is used.
1033 File name components that are `.' are removed, and
1034 so are file name components followed by `..', along with the `..' itself;
1035 note that these simplifications are done without checking the resulting
1036 file names in the file system.
1037 An initial `~/' expands to your home directory.
1038 An initial `~USER/' expands to USER's home directory.
1039 See also the function `substitute-in-file-name'. */)
1040 (name, default_directory)
1041 Lisp_Object name, default_directory;
1042 {
1043 unsigned char *nm;
1044
1045 register unsigned char *newdir, *p, *o;
1046 int tlen;
1047 unsigned char *target;
1048 struct passwd *pw;
1049 #ifdef VMS
1050 unsigned char * colon = 0;
1051 unsigned char * close = 0;
1052 unsigned char * slash = 0;
1053 unsigned char * brack = 0;
1054 int lbrack = 0, rbrack = 0;
1055 int dots = 0;
1056 #endif /* VMS */
1057 #ifdef DOS_NT
1058 int drive = 0;
1059 int collapse_newdir = 1;
1060 int is_escaped = 0;
1061 #endif /* DOS_NT */
1062 int length;
1063 Lisp_Object handler, result;
1064 int multibyte;
1065
1066 CHECK_STRING (name);
1067
1068 /* If the file name has special constructs in it,
1069 call the corresponding file handler. */
1070 handler = Ffind_file_name_handler (name, Qexpand_file_name);
1071 if (!NILP (handler))
1072 return call3 (handler, Qexpand_file_name, name, default_directory);
1073
1074 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
1075 if (NILP (default_directory))
1076 default_directory = current_buffer->directory;
1077 if (! STRINGP (default_directory))
1078 {
1079 #ifdef DOS_NT
1080 /* "/" is not considered a root directory on DOS_NT, so using "/"
1081 here causes an infinite recursion in, e.g., the following:
1082
1083 (let (default-directory)
1084 (expand-file-name "a"))
1085
1086 To avoid this, we set default_directory to the root of the
1087 current drive. */
1088 extern char *emacs_root_dir (void);
1089
1090 default_directory = build_string (emacs_root_dir ());
1091 #else
1092 default_directory = build_string ("/");
1093 #endif
1094 }
1095
1096 if (!NILP (default_directory))
1097 {
1098 handler = Ffind_file_name_handler (default_directory, Qexpand_file_name);
1099 if (!NILP (handler))
1100 return call3 (handler, Qexpand_file_name, name, default_directory);
1101 }
1102
1103 o = SDATA (default_directory);
1104
1105 /* Make sure DEFAULT_DIRECTORY is properly expanded.
1106 It would be better to do this down below where we actually use
1107 default_directory. Unfortunately, calling Fexpand_file_name recursively
1108 could invoke GC, and the strings might be relocated. This would
1109 be annoying because we have pointers into strings lying around
1110 that would need adjusting, and people would add new pointers to
1111 the code and forget to adjust them, resulting in intermittent bugs.
1112 Putting this call here avoids all that crud.
1113
1114 The EQ test avoids infinite recursion. */
1115 if (! NILP (default_directory) && !EQ (default_directory, name)
1116 /* Save time in some common cases - as long as default_directory
1117 is not relative, it can be canonicalized with name below (if it
1118 is needed at all) without requiring it to be expanded now. */
1119 #ifdef DOS_NT
1120 /* Detect MSDOS file names with drive specifiers. */
1121 && ! (IS_DRIVE (o[0]) && IS_DEVICE_SEP (o[1]) && IS_DIRECTORY_SEP (o[2]))
1122 #ifdef WINDOWSNT
1123 /* Detect Windows file names in UNC format. */
1124 && ! (IS_DIRECTORY_SEP (o[0]) && IS_DIRECTORY_SEP (o[1]))
1125 #endif
1126 #else /* not DOS_NT */
1127 /* Detect Unix absolute file names (/... alone is not absolute on
1128 DOS or Windows). */
1129 && ! (IS_DIRECTORY_SEP (o[0]))
1130 #endif /* not DOS_NT */
1131 )
1132 {
1133 struct gcpro gcpro1;
1134
1135 GCPRO1 (name);
1136 default_directory = Fexpand_file_name (default_directory, Qnil);
1137 UNGCPRO;
1138 }
1139
1140 name = FILE_SYSTEM_CASE (name);
1141 nm = SDATA (name);
1142 multibyte = STRING_MULTIBYTE (name);
1143
1144 #ifdef DOS_NT
1145 /* We will force directory separators to be either all \ or /, so make
1146 a local copy to modify, even if there ends up being no change. */
1147 nm = strcpy (alloca (strlen (nm) + 1), nm);
1148
1149 /* Note if special escape prefix is present, but remove for now. */
1150 if (nm[0] == '/' && nm[1] == ':')
1151 {
1152 is_escaped = 1;
1153 nm += 2;
1154 }
1155
1156 /* Find and remove drive specifier if present; this makes nm absolute
1157 even if the rest of the name appears to be relative. Only look for
1158 drive specifier at the beginning. */
1159 if (IS_DRIVE (nm[0]) && IS_DEVICE_SEP (nm[1]))
1160 {
1161 drive = nm[0];
1162 nm += 2;
1163 }
1164
1165 #ifdef WINDOWSNT
1166 /* If we see "c://somedir", we want to strip the first slash after the
1167 colon when stripping the drive letter. Otherwise, this expands to
1168 "//somedir". */
1169 if (drive && IS_DIRECTORY_SEP (nm[0]) && IS_DIRECTORY_SEP (nm[1]))
1170 nm++;
1171 #endif /* WINDOWSNT */
1172 #endif /* DOS_NT */
1173
1174 #ifdef WINDOWSNT
1175 /* Discard any previous drive specifier if nm is now in UNC format. */
1176 if (IS_DIRECTORY_SEP (nm[0]) && IS_DIRECTORY_SEP (nm[1]))
1177 {
1178 drive = 0;
1179 }
1180 #endif
1181
1182 /* If nm is absolute, look for `/./' or `/../' or `//''sequences; if
1183 none are found, we can probably return right away. We will avoid
1184 allocating a new string if name is already fully expanded. */
1185 if (
1186 IS_DIRECTORY_SEP (nm[0])
1187 #ifdef MSDOS
1188 && drive && !is_escaped
1189 #endif
1190 #ifdef WINDOWSNT
1191 && (drive || IS_DIRECTORY_SEP (nm[1])) && !is_escaped
1192 #endif
1193 #ifdef VMS
1194 || index (nm, ':')
1195 #endif /* VMS */
1196 )
1197 {
1198 /* If it turns out that the filename we want to return is just a
1199 suffix of FILENAME, we don't need to go through and edit
1200 things; we just need to construct a new string using data
1201 starting at the middle of FILENAME. If we set lose to a
1202 non-zero value, that means we've discovered that we can't do
1203 that cool trick. */
1204 int lose = 0;
1205
1206 p = nm;
1207 while (*p)
1208 {
1209 /* Since we know the name is absolute, we can assume that each
1210 element starts with a "/". */
1211
1212 /* "." and ".." are hairy. */
1213 if (IS_DIRECTORY_SEP (p[0])
1214 && p[1] == '.'
1215 && (IS_DIRECTORY_SEP (p[2])
1216 || p[2] == 0
1217 || (p[2] == '.' && (IS_DIRECTORY_SEP (p[3])
1218 || p[3] == 0))))
1219 lose = 1;
1220 /* We want to replace multiple `/' in a row with a single
1221 slash. */
1222 else if (p > nm
1223 && IS_DIRECTORY_SEP (p[0])
1224 && IS_DIRECTORY_SEP (p[1]))
1225 lose = 1;
1226
1227 #ifdef VMS
1228 if (p[0] == '\\')
1229 lose = 1;
1230 if (p[0] == '/') {
1231 /* if dev:[dir]/, move nm to / */
1232 if (!slash && p > nm && (brack || colon)) {
1233 nm = (brack ? brack + 1 : colon + 1);
1234 lbrack = rbrack = 0;
1235 brack = 0;
1236 colon = 0;
1237 }
1238 slash = p;
1239 }
1240 if (p[0] == '-')
1241 #ifdef NO_HYPHENS_IN_FILENAMES
1242 if (lbrack == rbrack)
1243 {
1244 /* Avoid clobbering negative version numbers. */
1245 if (dots < 2)
1246 p[0] = '_';
1247 }
1248 else
1249 #endif /* NO_HYPHENS_IN_FILENAMES */
1250 if (lbrack > rbrack &&
1251 ((p[-1] == '.' || p[-1] == '[' || p[-1] == '<') &&
1252 (p[1] == '.' || p[1] == ']' || p[1] == '>')))
1253 lose = 1;
1254 #ifdef NO_HYPHENS_IN_FILENAMES
1255 else
1256 p[0] = '_';
1257 #endif /* NO_HYPHENS_IN_FILENAMES */
1258 /* count open brackets, reset close bracket pointer */
1259 if (p[0] == '[' || p[0] == '<')
1260 lbrack++, brack = 0;
1261 /* count close brackets, set close bracket pointer */
1262 if (p[0] == ']' || p[0] == '>')
1263 rbrack++, brack = p;
1264 /* detect ][ or >< */
1265 if ((p[0] == ']' || p[0] == '>') && (p[1] == '[' || p[1] == '<'))
1266 lose = 1;
1267 if ((p[0] == ':' || p[0] == ']' || p[0] == '>') && p[1] == '~')
1268 nm = p + 1, lose = 1;
1269 if (p[0] == ':' && (colon || slash))
1270 /* if dev1:[dir]dev2:, move nm to dev2: */
1271 if (brack)
1272 {
1273 nm = brack + 1;
1274 brack = 0;
1275 }
1276 /* if /name/dev:, move nm to dev: */
1277 else if (slash)
1278 nm = slash + 1;
1279 /* if node::dev:, move colon following dev */
1280 else if (colon && colon[-1] == ':')
1281 colon = p;
1282 /* if dev1:dev2:, move nm to dev2: */
1283 else if (colon && colon[-1] != ':')
1284 {
1285 nm = colon + 1;
1286 colon = 0;
1287 }
1288 if (p[0] == ':' && !colon)
1289 {
1290 if (p[1] == ':')
1291 p++;
1292 colon = p;
1293 }
1294 if (lbrack == rbrack)
1295 if (p[0] == ';')
1296 dots = 2;
1297 else if (p[0] == '.')
1298 dots++;
1299 #endif /* VMS */
1300 p++;
1301 }
1302 if (!lose)
1303 {
1304 #ifdef VMS
1305 if (index (nm, '/'))
1306 {
1307 nm = sys_translate_unix (nm);
1308 return make_specified_string (nm, -1, strlen (nm), multibyte);
1309 }
1310 #endif /* VMS */
1311 #ifdef DOS_NT
1312 /* Make sure directories are all separated with / or \ as
1313 desired, but avoid allocation of a new string when not
1314 required. */
1315 CORRECT_DIR_SEPS (nm);
1316 #ifdef WINDOWSNT
1317 if (IS_DIRECTORY_SEP (nm[1]))
1318 {
1319 if (strcmp (nm, SDATA (name)) != 0)
1320 name = make_specified_string (nm, -1, strlen (nm), multibyte);
1321 }
1322 else
1323 #endif
1324 /* drive must be set, so this is okay */
1325 if (strcmp (nm - 2, SDATA (name)) != 0)
1326 {
1327 char temp[] = " :";
1328
1329 name = make_specified_string (nm, -1, p - nm, multibyte);
1330 temp[0] = DRIVE_LETTER (drive);
1331 name = concat2 (build_string (temp), name);
1332 }
1333 return name;
1334 #else /* not DOS_NT */
1335 if (nm == SDATA (name))
1336 return name;
1337 return make_specified_string (nm, -1, strlen (nm), multibyte);
1338 #endif /* not DOS_NT */
1339 }
1340 }
1341
1342 /* At this point, nm might or might not be an absolute file name. We
1343 need to expand ~ or ~user if present, otherwise prefix nm with
1344 default_directory if nm is not absolute, and finally collapse /./
1345 and /foo/../ sequences.
1346
1347 We set newdir to be the appropriate prefix if one is needed:
1348 - the relevant user directory if nm starts with ~ or ~user
1349 - the specified drive's working dir (DOS/NT only) if nm does not
1350 start with /
1351 - the value of default_directory.
1352
1353 Note that these prefixes are not guaranteed to be absolute (except
1354 for the working dir of a drive). Therefore, to ensure we always
1355 return an absolute name, if the final prefix is not absolute we
1356 append it to the current working directory. */
1357
1358 newdir = 0;
1359
1360 if (nm[0] == '~') /* prefix ~ */
1361 {
1362 if (IS_DIRECTORY_SEP (nm[1])
1363 #ifdef VMS
1364 || nm[1] == ':'
1365 #endif /* VMS */
1366 || nm[1] == 0) /* ~ by itself */
1367 {
1368 if (!(newdir = (unsigned char *) egetenv ("HOME")))
1369 newdir = (unsigned char *) "";
1370 nm++;
1371 #ifdef DOS_NT
1372 collapse_newdir = 0;
1373 #endif
1374 #ifdef VMS
1375 nm++; /* Don't leave the slash in nm. */
1376 #endif /* VMS */
1377 }
1378 else /* ~user/filename */
1379 {
1380 for (p = nm; *p && (!IS_DIRECTORY_SEP (*p)
1381 #ifdef VMS
1382 && *p != ':'
1383 #endif /* VMS */
1384 ); p++);
1385 o = (unsigned char *) alloca (p - nm + 1);
1386 bcopy ((char *) nm, o, p - nm);
1387 o [p - nm] = 0;
1388
1389 pw = (struct passwd *) getpwnam (o + 1);
1390 if (pw)
1391 {
1392 newdir = (unsigned char *) pw -> pw_dir;
1393 #ifdef VMS
1394 nm = p + 1; /* skip the terminator */
1395 #else
1396 nm = p;
1397 #ifdef DOS_NT
1398 collapse_newdir = 0;
1399 #endif
1400 #endif /* VMS */
1401 }
1402
1403 /* If we don't find a user of that name, leave the name
1404 unchanged; don't move nm forward to p. */
1405 }
1406 }
1407
1408 #ifdef DOS_NT
1409 /* On DOS and Windows, nm is absolute if a drive name was specified;
1410 use the drive's current directory as the prefix if needed. */
1411 if (!newdir && drive)
1412 {
1413 /* Get default directory if needed to make nm absolute. */
1414 if (!IS_DIRECTORY_SEP (nm[0]))
1415 {
1416 newdir = alloca (MAXPATHLEN + 1);
1417 if (!getdefdir (toupper (drive) - 'A' + 1, newdir))
1418 newdir = NULL;
1419 }
1420 if (!newdir)
1421 {
1422 /* Either nm starts with /, or drive isn't mounted. */
1423 newdir = alloca (4);
1424 newdir[0] = DRIVE_LETTER (drive);
1425 newdir[1] = ':';
1426 newdir[2] = '/';
1427 newdir[3] = 0;
1428 }
1429 }
1430 #endif /* DOS_NT */
1431
1432 /* Finally, if no prefix has been specified and nm is not absolute,
1433 then it must be expanded relative to default_directory. */
1434
1435 if (1
1436 #ifndef DOS_NT
1437 /* /... alone is not absolute on DOS and Windows. */
1438 && !IS_DIRECTORY_SEP (nm[0])
1439 #endif
1440 #ifdef WINDOWSNT
1441 && !(IS_DIRECTORY_SEP (nm[0]) && IS_DIRECTORY_SEP (nm[1]))
1442 #endif
1443 #ifdef VMS
1444 && !index (nm, ':')
1445 #endif
1446 && !newdir)
1447 {
1448 newdir = SDATA (default_directory);
1449 multibyte |= STRING_MULTIBYTE (default_directory);
1450 #ifdef DOS_NT
1451 /* Note if special escape prefix is present, but remove for now. */
1452 if (newdir[0] == '/' && newdir[1] == ':')
1453 {
1454 is_escaped = 1;
1455 newdir += 2;
1456 }
1457 #endif
1458 }
1459
1460 #ifdef DOS_NT
1461 if (newdir)
1462 {
1463 /* First ensure newdir is an absolute name. */
1464 if (
1465 /* Detect MSDOS file names with drive specifiers. */
1466 ! (IS_DRIVE (newdir[0])
1467 && IS_DEVICE_SEP (newdir[1]) && IS_DIRECTORY_SEP (newdir[2]))
1468 #ifdef WINDOWSNT
1469 /* Detect Windows file names in UNC format. */
1470 && ! (IS_DIRECTORY_SEP (newdir[0]) && IS_DIRECTORY_SEP (newdir[1]))
1471 #endif
1472 )
1473 {
1474 /* Effectively, let newdir be (expand-file-name newdir cwd).
1475 Because of the admonition against calling expand-file-name
1476 when we have pointers into lisp strings, we accomplish this
1477 indirectly by prepending newdir to nm if necessary, and using
1478 cwd (or the wd of newdir's drive) as the new newdir. */
1479
1480 if (IS_DRIVE (newdir[0]) && IS_DEVICE_SEP (newdir[1]))
1481 {
1482 drive = newdir[0];
1483 newdir += 2;
1484 }
1485 if (!IS_DIRECTORY_SEP (nm[0]))
1486 {
1487 char * tmp = alloca (strlen (newdir) + strlen (nm) + 2);
1488 file_name_as_directory (tmp, newdir);
1489 strcat (tmp, nm);
1490 nm = tmp;
1491 }
1492 newdir = alloca (MAXPATHLEN + 1);
1493 if (drive)
1494 {
1495 if (!getdefdir (toupper (drive) - 'A' + 1, newdir))
1496 newdir = "/";
1497 }
1498 else
1499 getwd (newdir);
1500 }
1501
1502 /* Strip off drive name from prefix, if present. */
1503 if (IS_DRIVE (newdir[0]) && IS_DEVICE_SEP (newdir[1]))
1504 {
1505 drive = newdir[0];
1506 newdir += 2;
1507 }
1508
1509 /* Keep only a prefix from newdir if nm starts with slash
1510 (//server/share for UNC, nothing otherwise). */
1511 if (IS_DIRECTORY_SEP (nm[0]) && collapse_newdir)
1512 {
1513 #ifdef WINDOWSNT
1514 if (IS_DIRECTORY_SEP (newdir[0]) && IS_DIRECTORY_SEP (newdir[1]))
1515 {
1516 newdir = strcpy (alloca (strlen (newdir) + 1), newdir);
1517 p = newdir + 2;
1518 while (*p && !IS_DIRECTORY_SEP (*p)) p++;
1519 p++;
1520 while (*p && !IS_DIRECTORY_SEP (*p)) p++;
1521 *p = 0;
1522 }
1523 else
1524 #endif
1525 newdir = "";
1526 }
1527 }
1528 #endif /* DOS_NT */
1529
1530 if (newdir)
1531 {
1532 /* Get rid of any slash at the end of newdir, unless newdir is
1533 just / or // (an incomplete UNC name). */
1534 length = strlen (newdir);
1535 if (length > 1 && IS_DIRECTORY_SEP (newdir[length - 1])
1536 #ifdef WINDOWSNT
1537 && !(length == 2 && IS_DIRECTORY_SEP (newdir[0]))
1538 #endif
1539 )
1540 {
1541 unsigned char *temp = (unsigned char *) alloca (length);
1542 bcopy (newdir, temp, length - 1);
1543 temp[length - 1] = 0;
1544 newdir = temp;
1545 }
1546 tlen = length + 1;
1547 }
1548 else
1549 tlen = 0;
1550
1551 /* Now concatenate the directory and name to new space in the stack frame */
1552 tlen += strlen (nm) + 1;
1553 #ifdef DOS_NT
1554 /* Reserve space for drive specifier and escape prefix, since either
1555 or both may need to be inserted. (The Microsoft x86 compiler
1556 produces incorrect code if the following two lines are combined.) */
1557 target = (unsigned char *) alloca (tlen + 4);
1558 target += 4;
1559 #else /* not DOS_NT */
1560 target = (unsigned char *) alloca (tlen);
1561 #endif /* not DOS_NT */
1562 *target = 0;
1563
1564 if (newdir)
1565 {
1566 #ifndef VMS
1567 if (nm[0] == 0 || IS_DIRECTORY_SEP (nm[0]))
1568 {
1569 #ifdef DOS_NT
1570 /* If newdir is effectively "C:/", then the drive letter will have
1571 been stripped and newdir will be "/". Concatenating with an
1572 absolute directory in nm produces "//", which will then be
1573 incorrectly treated as a network share. Ignore newdir in
1574 this case (keeping the drive letter). */
1575 if (!(drive && nm[0] && IS_DIRECTORY_SEP (newdir[0])
1576 && newdir[1] == '\0'))
1577 #endif
1578 strcpy (target, newdir);
1579 }
1580 else
1581 #endif
1582 file_name_as_directory (target, newdir);
1583 }
1584
1585 strcat (target, nm);
1586 #ifdef VMS
1587 if (index (target, '/'))
1588 strcpy (target, sys_translate_unix (target));
1589 #endif /* VMS */
1590
1591 /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */
1592
1593 /* Now canonicalize by removing `//', `/.' and `/foo/..' if they
1594 appear. */
1595
1596 p = target;
1597 o = target;
1598
1599 while (*p)
1600 {
1601 #ifdef VMS
1602 if (*p != ']' && *p != '>' && *p != '-')
1603 {
1604 if (*p == '\\')
1605 p++;
1606 *o++ = *p++;
1607 }
1608 else if ((p[0] == ']' || p[0] == '>') && p[0] == p[1] + 2)
1609 /* brackets are offset from each other by 2 */
1610 {
1611 p += 2;
1612 if (*p != '.' && *p != '-' && o[-1] != '.')
1613 /* convert [foo][bar] to [bar] */
1614 while (o[-1] != '[' && o[-1] != '<')
1615 o--;
1616 else if (*p == '-' && *o != '.')
1617 *--p = '.';
1618 }
1619 else if (p[0] == '-' && o[-1] == '.' &&
1620 (p[1] == '.' || p[1] == ']' || p[1] == '>'))
1621 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1622 {
1623 do
1624 o--;
1625 while (o[-1] != '.' && o[-1] != '[' && o[-1] != '<');
1626 if (p[1] == '.') /* foo.-.bar ==> bar. */
1627 p += 2;
1628 else if (o[-1] == '.') /* '.foo.-]' ==> ']' */
1629 p++, o--;
1630 /* else [foo.-] ==> [-] */
1631 }
1632 else
1633 {
1634 #ifdef NO_HYPHENS_IN_FILENAMES
1635 if (*p == '-' &&
1636 o[-1] != '[' && o[-1] != '<' && o[-1] != '.' &&
1637 p[1] != ']' && p[1] != '>' && p[1] != '.')
1638 *p = '_';
1639 #endif /* NO_HYPHENS_IN_FILENAMES */
1640 *o++ = *p++;
1641 }
1642 #else /* not VMS */
1643 if (!IS_DIRECTORY_SEP (*p))
1644 {
1645 *o++ = *p++;
1646 }
1647 else if (IS_DIRECTORY_SEP (p[0])
1648 && p[1] == '.'
1649 && (IS_DIRECTORY_SEP (p[2])
1650 || p[2] == 0))
1651 {
1652 /* If "/." is the entire filename, keep the "/". Otherwise,
1653 just delete the whole "/.". */
1654 if (o == target && p[2] == '\0')
1655 *o++ = *p;
1656 p += 2;
1657 }
1658 else if (IS_DIRECTORY_SEP (p[0]) && p[1] == '.' && p[2] == '.'
1659 /* `/../' is the "superroot" on certain file systems.
1660 Turned off on DOS_NT systems because they have no
1661 "superroot" and because this causes us to produce
1662 file names like "d:/../foo" which fail file-related
1663 functions of the underlying OS. (To reproduce, try a
1664 long series of "../../" in default_directory, longer
1665 than the number of levels from the root.) */
1666 #ifndef DOS_NT
1667 && o != target
1668 #endif
1669 && (IS_DIRECTORY_SEP (p[3]) || p[3] == 0))
1670 {
1671 while (o != target && (--o) && !IS_DIRECTORY_SEP (*o))
1672 ;
1673 /* Keep initial / only if this is the whole name. */
1674 if (o == target && IS_ANY_SEP (*o) && p[3] == 0)
1675 ++o;
1676 p += 3;
1677 }
1678 else if (p > target
1679 && IS_DIRECTORY_SEP (p[0]) && IS_DIRECTORY_SEP (p[1]))
1680 {
1681 /* Collapse multiple `/' in a row. */
1682 *o++ = *p++;
1683 while (IS_DIRECTORY_SEP (*p))
1684 ++p;
1685 }
1686 else
1687 {
1688 *o++ = *p++;
1689 }
1690 #endif /* not VMS */
1691 }
1692
1693 #ifdef DOS_NT
1694 /* At last, set drive name. */
1695 #ifdef WINDOWSNT
1696 /* Except for network file name. */
1697 if (!(IS_DIRECTORY_SEP (target[0]) && IS_DIRECTORY_SEP (target[1])))
1698 #endif /* WINDOWSNT */
1699 {
1700 if (!drive) abort ();
1701 target -= 2;
1702 target[0] = DRIVE_LETTER (drive);
1703 target[1] = ':';
1704 }
1705 /* Reinsert the escape prefix if required. */
1706 if (is_escaped)
1707 {
1708 target -= 2;
1709 target[0] = '/';
1710 target[1] = ':';
1711 }
1712 CORRECT_DIR_SEPS (target);
1713 #endif /* DOS_NT */
1714
1715 result = make_specified_string (target, -1, o - target, multibyte);
1716
1717 /* Again look to see if the file name has special constructs in it
1718 and perhaps call the corresponding file handler. This is needed
1719 for filenames such as "/foo/../user@host:/bar/../baz". Expanding
1720 the ".." component gives us "/user@host:/bar/../baz" which needs
1721 to be expanded again. */
1722 handler = Ffind_file_name_handler (result, Qexpand_file_name);
1723 if (!NILP (handler))
1724 return call3 (handler, Qexpand_file_name, result, default_directory);
1725
1726 return result;
1727 }
1728
1729 #if 0
1730 /* PLEASE DO NOT DELETE THIS COMMENTED-OUT VERSION!
1731 This is the old version of expand-file-name, before it was thoroughly
1732 rewritten for Emacs 10.31. We leave this version here commented-out,
1733 because the code is very complex and likely to have subtle bugs. If
1734 bugs _are_ found, it might be of interest to look at the old code and
1735 see what did it do in the relevant situation.
1736
1737 Don't remove this code: it's true that it will be accessible via CVS,
1738 but a few years from deletion, people will forget it is there. */
1739
1740 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'. */
1741 DEAFUN ("expand-file-name", Fexpand_file_name, Sexpand_file_name, 1, 2, 0,
1742 "Convert FILENAME to absolute, and canonicalize it.\n\
1743 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1744 \(does not start with slash); if DEFAULT is nil or missing,\n\
1745 the current buffer's value of default-directory is used.\n\
1746 Filenames containing `.' or `..' as components are simplified;\n\
1747 initial `~/' expands to your home directory.\n\
1748 See also the function `substitute-in-file-name'.")
1749 (name, defalt)
1750 Lisp_Object name, defalt;
1751 {
1752 unsigned char *nm;
1753
1754 register unsigned char *newdir, *p, *o;
1755 int tlen;
1756 unsigned char *target;
1757 struct passwd *pw;
1758 int lose;
1759 #ifdef VMS
1760 unsigned char * colon = 0;
1761 unsigned char * close = 0;
1762 unsigned char * slash = 0;
1763 unsigned char * brack = 0;
1764 int lbrack = 0, rbrack = 0;
1765 int dots = 0;
1766 #endif /* VMS */
1767
1768 CHECK_STRING (name);
1769
1770 #ifdef VMS
1771 /* Filenames on VMS are always upper case. */
1772 name = Fupcase (name);
1773 #endif
1774
1775 nm = SDATA (name);
1776
1777 /* If nm is absolute, flush ...// and detect /./ and /../.
1778 If no /./ or /../ we can return right away. */
1779 if (
1780 nm[0] == '/'
1781 #ifdef VMS
1782 || index (nm, ':')
1783 #endif /* VMS */
1784 )
1785 {
1786 p = nm;
1787 lose = 0;
1788 while (*p)
1789 {
1790 if (p[0] == '/' && p[1] == '/'
1791 #ifdef APOLLO
1792 /* // at start of filename is meaningful on Apollo system. */
1793 && nm != p
1794 #endif /* APOLLO */
1795 )
1796 nm = p + 1;
1797 if (p[0] == '/' && p[1] == '~')
1798 nm = p + 1, lose = 1;
1799 if (p[0] == '/' && p[1] == '.'
1800 && (p[2] == '/' || p[2] == 0
1801 || (p[2] == '.' && (p[3] == '/' || p[3] == 0))))
1802 lose = 1;
1803 #ifdef VMS
1804 if (p[0] == '\\')
1805 lose = 1;
1806 if (p[0] == '/') {
1807 /* if dev:[dir]/, move nm to / */
1808 if (!slash && p > nm && (brack || colon)) {
1809 nm = (brack ? brack + 1 : colon + 1);
1810 lbrack = rbrack = 0;
1811 brack = 0;
1812 colon = 0;
1813 }
1814 slash = p;
1815 }
1816 if (p[0] == '-')
1817 #ifndef VMS4_4
1818 /* VMS pre V4.4,convert '-'s in filenames. */
1819 if (lbrack == rbrack)
1820 {
1821 if (dots < 2) /* this is to allow negative version numbers */
1822 p[0] = '_';
1823 }
1824 else
1825 #endif /* VMS4_4 */
1826 if (lbrack > rbrack &&
1827 ((p[-1] == '.' || p[-1] == '[' || p[-1] == '<') &&
1828 (p[1] == '.' || p[1] == ']' || p[1] == '>')))
1829 lose = 1;
1830 #ifndef VMS4_4
1831 else
1832 p[0] = '_';
1833 #endif /* VMS4_4 */
1834 /* count open brackets, reset close bracket pointer */
1835 if (p[0] == '[' || p[0] == '<')
1836 lbrack++, brack = 0;
1837 /* count close brackets, set close bracket pointer */
1838 if (p[0] == ']' || p[0] == '>')
1839 rbrack++, brack = p;
1840 /* detect ][ or >< */
1841 if ((p[0] == ']' || p[0] == '>') && (p[1] == '[' || p[1] == '<'))
1842 lose = 1;
1843 if ((p[0] == ':' || p[0] == ']' || p[0] == '>') && p[1] == '~')
1844 nm = p + 1, lose = 1;
1845 if (p[0] == ':' && (colon || slash))
1846 /* if dev1:[dir]dev2:, move nm to dev2: */
1847 if (brack)
1848 {
1849 nm = brack + 1;
1850 brack = 0;
1851 }
1852 /* If /name/dev:, move nm to dev: */
1853 else if (slash)
1854 nm = slash + 1;
1855 /* If node::dev:, move colon following dev */
1856 else if (colon && colon[-1] == ':')
1857 colon = p;
1858 /* If dev1:dev2:, move nm to dev2: */
1859 else if (colon && colon[-1] != ':')
1860 {
1861 nm = colon + 1;
1862 colon = 0;
1863 }
1864 if (p[0] == ':' && !colon)
1865 {
1866 if (p[1] == ':')
1867 p++;
1868 colon = p;
1869 }
1870 if (lbrack == rbrack)
1871 if (p[0] == ';')
1872 dots = 2;
1873 else if (p[0] == '.')
1874 dots++;
1875 #endif /* VMS */
1876 p++;
1877 }
1878 if (!lose)
1879 {
1880 #ifdef VMS
1881 if (index (nm, '/'))
1882 return build_string (sys_translate_unix (nm));
1883 #endif /* VMS */
1884 if (nm == SDATA (name))
1885 return name;
1886 return build_string (nm);
1887 }
1888 }
1889
1890 /* Now determine directory to start with and put it in NEWDIR */
1891
1892 newdir = 0;
1893
1894 if (nm[0] == '~') /* prefix ~ */
1895 if (nm[1] == '/'
1896 #ifdef VMS
1897 || nm[1] == ':'
1898 #endif /* VMS */
1899 || nm[1] == 0)/* ~/filename */
1900 {
1901 if (!(newdir = (unsigned char *) egetenv ("HOME")))
1902 newdir = (unsigned char *) "";
1903 nm++;
1904 #ifdef VMS
1905 nm++; /* Don't leave the slash in nm. */
1906 #endif /* VMS */
1907 }
1908 else /* ~user/filename */
1909 {
1910 /* Get past ~ to user */
1911 unsigned char *user = nm + 1;
1912 /* Find end of name. */
1913 unsigned char *ptr = (unsigned char *) index (user, '/');
1914 int len = ptr ? ptr - user : strlen (user);
1915 #ifdef VMS
1916 unsigned char *ptr1 = index (user, ':');
1917 if (ptr1 != 0 && ptr1 - user < len)
1918 len = ptr1 - user;
1919 #endif /* VMS */
1920 /* Copy the user name into temp storage. */
1921 o = (unsigned char *) alloca (len + 1);
1922 bcopy ((char *) user, o, len);
1923 o[len] = 0;
1924
1925 /* Look up the user name. */
1926 pw = (struct passwd *) getpwnam (o + 1);
1927 if (!pw)
1928 error ("\"%s\" isn't a registered user", o + 1);
1929
1930 newdir = (unsigned char *) pw->pw_dir;
1931
1932 /* Discard the user name from NM. */
1933 nm += len;
1934 }
1935
1936 if (nm[0] != '/'
1937 #ifdef VMS
1938 && !index (nm, ':')
1939 #endif /* not VMS */
1940 && !newdir)
1941 {
1942 if (NILP (defalt))
1943 defalt = current_buffer->directory;
1944 CHECK_STRING (defalt);
1945 newdir = SDATA (defalt);
1946 }
1947
1948 /* Now concatenate the directory and name to new space in the stack frame */
1949
1950 tlen = (newdir ? strlen (newdir) + 1 : 0) + strlen (nm) + 1;
1951 target = (unsigned char *) alloca (tlen);
1952 *target = 0;
1953
1954 if (newdir)
1955 {
1956 #ifndef VMS
1957 if (nm[0] == 0 || nm[0] == '/')
1958 strcpy (target, newdir);
1959 else
1960 #endif
1961 file_name_as_directory (target, newdir);
1962 }
1963
1964 strcat (target, nm);
1965 #ifdef VMS
1966 if (index (target, '/'))
1967 strcpy (target, sys_translate_unix (target));
1968 #endif /* VMS */
1969
1970 /* Now canonicalize by removing /. and /foo/.. if they appear */
1971
1972 p = target;
1973 o = target;
1974
1975 while (*p)
1976 {
1977 #ifdef VMS
1978 if (*p != ']' && *p != '>' && *p != '-')
1979 {
1980 if (*p == '\\')
1981 p++;
1982 *o++ = *p++;
1983 }
1984 else if ((p[0] == ']' || p[0] == '>') && p[0] == p[1] + 2)
1985 /* brackets are offset from each other by 2 */
1986 {
1987 p += 2;
1988 if (*p != '.' && *p != '-' && o[-1] != '.')
1989 /* convert [foo][bar] to [bar] */
1990 while (o[-1] != '[' && o[-1] != '<')
1991 o--;
1992 else if (*p == '-' && *o != '.')
1993 *--p = '.';
1994 }
1995 else if (p[0] == '-' && o[-1] == '.' &&
1996 (p[1] == '.' || p[1] == ']' || p[1] == '>'))
1997 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1998 {
1999 do
2000 o--;
2001 while (o[-1] != '.' && o[-1] != '[' && o[-1] != '<');
2002 if (p[1] == '.') /* foo.-.bar ==> bar. */
2003 p += 2;
2004 else if (o[-1] == '.') /* '.foo.-]' ==> ']' */
2005 p++, o--;
2006 /* else [foo.-] ==> [-] */
2007 }
2008 else
2009 {
2010 #ifndef VMS4_4
2011 if (*p == '-' &&
2012 o[-1] != '[' && o[-1] != '<' && o[-1] != '.' &&
2013 p[1] != ']' && p[1] != '>' && p[1] != '.')
2014 *p = '_';
2015 #endif /* VMS4_4 */
2016 *o++ = *p++;
2017 }
2018 #else /* not VMS */
2019 if (*p != '/')
2020 {
2021 *o++ = *p++;
2022 }
2023 else if (!strncmp (p, "//", 2)
2024 #ifdef APOLLO
2025 /* // at start of filename is meaningful in Apollo system. */
2026 && o != target
2027 #endif /* APOLLO */
2028 )
2029 {
2030 o = target;
2031 p++;
2032 }
2033 else if (p[0] == '/' && p[1] == '.' &&
2034 (p[2] == '/' || p[2] == 0))
2035 p += 2;
2036 else if (!strncmp (p, "/..", 3)
2037 /* `/../' is the "superroot" on certain file systems. */
2038 && o != target
2039 && (p[3] == '/' || p[3] == 0))
2040 {
2041 while (o != target && *--o != '/')
2042 ;
2043 #ifdef APOLLO
2044 if (o == target + 1 && o[-1] == '/' && o[0] == '/')
2045 ++o;
2046 else
2047 #endif /* APOLLO */
2048 if (o == target && *o == '/')
2049 ++o;
2050 p += 3;
2051 }
2052 else
2053 {
2054 *o++ = *p++;
2055 }
2056 #endif /* not VMS */
2057 }
2058
2059 return make_string (target, o - target);
2060 }
2061 #endif
2062 \f
2063 /* If /~ or // appears, discard everything through first slash. */
2064 static int
2065 file_name_absolute_p (filename)
2066 const unsigned char *filename;
2067 {
2068 return
2069 (IS_DIRECTORY_SEP (*filename) || *filename == '~'
2070 #ifdef VMS
2071 /* ??? This criterion is probably wrong for '<'. */
2072 || index (filename, ':') || index (filename, '<')
2073 || (*filename == '[' && (filename[1] != '-'
2074 || (filename[2] != '.' && filename[2] != ']'))
2075 && filename[1] != '.')
2076 #endif /* VMS */
2077 #ifdef DOS_NT
2078 || (IS_DRIVE (*filename) && IS_DEVICE_SEP (filename[1])
2079 && IS_DIRECTORY_SEP (filename[2]))
2080 #endif
2081 );
2082 }
2083
2084 static unsigned char *
2085 search_embedded_absfilename (nm, endp)
2086 unsigned char *nm, *endp;
2087 {
2088 unsigned char *p, *s;
2089
2090 for (p = nm + 1; p < endp; p++)
2091 {
2092 if ((0
2093 #ifdef VMS
2094 || p[-1] == ':' || p[-1] == ']' || p[-1] == '>'
2095 #endif /* VMS */
2096 || IS_DIRECTORY_SEP (p[-1]))
2097 && file_name_absolute_p (p)
2098 #if defined (APOLLO) || defined (WINDOWSNT) || defined(CYGWIN)
2099 /* // at start of file name is meaningful in Apollo,
2100 WindowsNT and Cygwin systems. */
2101 && !(IS_DIRECTORY_SEP (p[0]) && p - 1 == nm)
2102 #endif /* not (APOLLO || WINDOWSNT || CYGWIN) */
2103 )
2104 {
2105 for (s = p; *s && (!IS_DIRECTORY_SEP (*s)
2106 #ifdef VMS
2107 && *s != ':'
2108 #endif /* VMS */
2109 ); s++);
2110 if (p[0] == '~' && s > p + 1) /* we've got "/~something/" */
2111 {
2112 unsigned char *o = alloca (s - p + 1);
2113 struct passwd *pw;
2114 bcopy (p, o, s - p);
2115 o [s - p] = 0;
2116
2117 /* If we have ~user and `user' exists, discard
2118 everything up to ~. But if `user' does not exist, leave
2119 ~user alone, it might be a literal file name. */
2120 if ((pw = getpwnam (o + 1)))
2121 return p;
2122 else
2123 xfree (pw);
2124 }
2125 else
2126 return p;
2127 }
2128 }
2129 return NULL;
2130 }
2131
2132 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name,
2133 Ssubstitute_in_file_name, 1, 1, 0,
2134 doc: /* Substitute environment variables referred to in FILENAME.
2135 `$FOO' where FOO is an environment variable name means to substitute
2136 the value of that variable. The variable name should be terminated
2137 with a character not a letter, digit or underscore; otherwise, enclose
2138 the entire variable name in braces.
2139 If `/~' appears, all of FILENAME through that `/' is discarded.
2140
2141 On VMS, `$' substitution is not done; this function does little and only
2142 duplicates what `expand-file-name' does. */)
2143 (filename)
2144 Lisp_Object filename;
2145 {
2146 unsigned char *nm;
2147
2148 register unsigned char *s, *p, *o, *x, *endp;
2149 unsigned char *target = NULL;
2150 int total = 0;
2151 int substituted = 0;
2152 unsigned char *xnm;
2153 Lisp_Object handler;
2154
2155 CHECK_STRING (filename);
2156
2157 /* If the file name has special constructs in it,
2158 call the corresponding file handler. */
2159 handler = Ffind_file_name_handler (filename, Qsubstitute_in_file_name);
2160 if (!NILP (handler))
2161 return call2 (handler, Qsubstitute_in_file_name, filename);
2162
2163 nm = SDATA (filename);
2164 #ifdef DOS_NT
2165 nm = strcpy (alloca (strlen (nm) + 1), nm);
2166 CORRECT_DIR_SEPS (nm);
2167 substituted = (strcmp (nm, SDATA (filename)) != 0);
2168 #endif
2169 endp = nm + SBYTES (filename);
2170
2171 /* If /~ or // appears, discard everything through first slash. */
2172 p = search_embedded_absfilename (nm, endp);
2173 if (p)
2174 /* Start over with the new string, so we check the file-name-handler
2175 again. Important with filenames like "/home/foo//:/hello///there"
2176 which whould substitute to "/:/hello///there" rather than "/there". */
2177 return Fsubstitute_in_file_name
2178 (make_specified_string (p, -1, endp - p,
2179 STRING_MULTIBYTE (filename)));
2180
2181 #ifdef VMS
2182 return filename;
2183 #else
2184
2185 /* See if any variables are substituted into the string
2186 and find the total length of their values in `total' */
2187
2188 for (p = nm; p != endp;)
2189 if (*p != '$')
2190 p++;
2191 else
2192 {
2193 p++;
2194 if (p == endp)
2195 goto badsubst;
2196 else if (*p == '$')
2197 {
2198 /* "$$" means a single "$" */
2199 p++;
2200 total -= 1;
2201 substituted = 1;
2202 continue;
2203 }
2204 else if (*p == '{')
2205 {
2206 o = ++p;
2207 while (p != endp && *p != '}') p++;
2208 if (*p != '}') goto missingclose;
2209 s = p;
2210 }
2211 else
2212 {
2213 o = p;
2214 while (p != endp && (isalnum (*p) || *p == '_')) p++;
2215 s = p;
2216 }
2217
2218 /* Copy out the variable name */
2219 target = (unsigned char *) alloca (s - o + 1);
2220 strncpy (target, o, s - o);
2221 target[s - o] = 0;
2222 #ifdef DOS_NT
2223 strupr (target); /* $home == $HOME etc. */
2224 #endif /* DOS_NT */
2225
2226 /* Get variable value */
2227 o = (unsigned char *) egetenv (target);
2228 if (o)
2229 {
2230 total += strlen (o);
2231 substituted = 1;
2232 }
2233 else if (*p == '}')
2234 goto badvar;
2235 }
2236
2237 if (!substituted)
2238 return filename;
2239
2240 /* If substitution required, recopy the string and do it */
2241 /* Make space in stack frame for the new copy */
2242 xnm = (unsigned char *) alloca (SBYTES (filename) + total + 1);
2243 x = xnm;
2244
2245 /* Copy the rest of the name through, replacing $ constructs with values */
2246 for (p = nm; *p;)
2247 if (*p != '$')
2248 *x++ = *p++;
2249 else
2250 {
2251 p++;
2252 if (p == endp)
2253 goto badsubst;
2254 else if (*p == '$')
2255 {
2256 *x++ = *p++;
2257 continue;
2258 }
2259 else if (*p == '{')
2260 {
2261 o = ++p;
2262 while (p != endp && *p != '}') p++;
2263 if (*p != '}') goto missingclose;
2264 s = p++;
2265 }
2266 else
2267 {
2268 o = p;
2269 while (p != endp && (isalnum (*p) || *p == '_')) p++;
2270 s = p;
2271 }
2272
2273 /* Copy out the variable name */
2274 target = (unsigned char *) alloca (s - o + 1);
2275 strncpy (target, o, s - o);
2276 target[s - o] = 0;
2277 #ifdef DOS_NT
2278 strupr (target); /* $home == $HOME etc. */
2279 #endif /* DOS_NT */
2280
2281 /* Get variable value */
2282 o = (unsigned char *) egetenv (target);
2283 if (!o)
2284 {
2285 *x++ = '$';
2286 strcpy (x, target); x+= strlen (target);
2287 }
2288 else if (STRING_MULTIBYTE (filename))
2289 {
2290 /* If the original string is multibyte,
2291 convert what we substitute into multibyte. */
2292 while (*o)
2293 {
2294 int c = unibyte_char_to_multibyte (*o++);
2295 x += CHAR_STRING (c, x);
2296 }
2297 }
2298 else
2299 {
2300 strcpy (x, o);
2301 x += strlen (o);
2302 }
2303 }
2304
2305 *x = 0;
2306
2307 /* If /~ or // appears, discard everything through first slash. */
2308 while ((p = search_embedded_absfilename (xnm, x)))
2309 /* This time we do not start over because we've already expanded envvars
2310 and replaced $$ with $. Maybe we should start over as well, but we'd
2311 need to quote some $ to $$ first. */
2312 xnm = p;
2313
2314 return make_specified_string (xnm, -1, x - xnm, STRING_MULTIBYTE (filename));
2315
2316 badsubst:
2317 error ("Bad format environment-variable substitution");
2318 missingclose:
2319 error ("Missing \"}\" in environment-variable substitution");
2320 badvar:
2321 error ("Substituting nonexistent environment variable \"%s\"", target);
2322
2323 /* NOTREACHED */
2324 #endif /* not VMS */
2325 return Qnil;
2326 }
2327 \f
2328 /* A slightly faster and more convenient way to get
2329 (directory-file-name (expand-file-name FOO)). */
2330
2331 Lisp_Object
2332 expand_and_dir_to_file (filename, defdir)
2333 Lisp_Object filename, defdir;
2334 {
2335 register Lisp_Object absname;
2336
2337 absname = Fexpand_file_name (filename, defdir);
2338 #ifdef VMS
2339 {
2340 register int c = SREF (absname, SBYTES (absname) - 1);
2341 if (c == ':' || c == ']' || c == '>')
2342 absname = Fdirectory_file_name (absname);
2343 }
2344 #else
2345 /* Remove final slash, if any (unless this is the root dir).
2346 stat behaves differently depending! */
2347 if (SCHARS (absname) > 1
2348 && IS_DIRECTORY_SEP (SREF (absname, SBYTES (absname) - 1))
2349 && !IS_DEVICE_SEP (SREF (absname, SBYTES (absname)-2)))
2350 /* We cannot take shortcuts; they might be wrong for magic file names. */
2351 absname = Fdirectory_file_name (absname);
2352 #endif
2353 return absname;
2354 }
2355 \f
2356 /* Signal an error if the file ABSNAME already exists.
2357 If INTERACTIVE is nonzero, ask the user whether to proceed,
2358 and bypass the error if the user says to go ahead.
2359 QUERYSTRING is a name for the action that is being considered
2360 to alter the file.
2361
2362 *STATPTR is used to store the stat information if the file exists.
2363 If the file does not exist, STATPTR->st_mode is set to 0.
2364 If STATPTR is null, we don't store into it.
2365
2366 If QUICK is nonzero, we ask for y or n, not yes or no. */
2367
2368 void
2369 barf_or_query_if_file_exists (absname, querystring, interactive, statptr, quick)
2370 Lisp_Object absname;
2371 unsigned char *querystring;
2372 int interactive;
2373 struct stat *statptr;
2374 int quick;
2375 {
2376 register Lisp_Object tem, encoded_filename;
2377 struct stat statbuf;
2378 struct gcpro gcpro1;
2379
2380 encoded_filename = ENCODE_FILE (absname);
2381
2382 /* stat is a good way to tell whether the file exists,
2383 regardless of what access permissions it has. */
2384 if (lstat (SDATA (encoded_filename), &statbuf) >= 0)
2385 {
2386 if (! interactive)
2387 Fsignal (Qfile_already_exists,
2388 Fcons (build_string ("File already exists"),
2389 Fcons (absname, Qnil)));
2390 GCPRO1 (absname);
2391 tem = format2 ("File %s already exists; %s anyway? ",
2392 absname, build_string (querystring));
2393 if (quick)
2394 tem = Fy_or_n_p (tem);
2395 else
2396 tem = do_yes_or_no_p (tem);
2397 UNGCPRO;
2398 if (NILP (tem))
2399 Fsignal (Qfile_already_exists,
2400 Fcons (build_string ("File already exists"),
2401 Fcons (absname, Qnil)));
2402 if (statptr)
2403 *statptr = statbuf;
2404 }
2405 else
2406 {
2407 if (statptr)
2408 statptr->st_mode = 0;
2409 }
2410 return;
2411 }
2412
2413 DEFUN ("copy-file", Fcopy_file, Scopy_file, 2, 6,
2414 "fCopy file: \nGCopy %s to file: \np\nP",
2415 doc: /* Copy FILE to NEWNAME. Both args must be strings.
2416 If NEWNAME names a directory, copy FILE there.
2417 Signals a `file-already-exists' error if file NEWNAME already exists,
2418 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.
2419 A number as third arg means request confirmation if NEWNAME already exists.
2420 This is what happens in interactive use with M-x.
2421 Always sets the file modes of the output file to match the input file.
2422
2423 Fourth arg KEEP-TIME non-nil means give the output file the same
2424 last-modified time as the old one. (This works on only some systems.)
2425
2426 A prefix arg makes KEEP-TIME non-nil.
2427
2428 The optional fifth arg MUSTBENEW, if non-nil, insists on a check
2429 for an existing file with the same name. If MUSTBENEW is `excl',
2430 that means to get an error if the file already exists; never overwrite.
2431 If MUSTBENEW is neither nil nor `excl', that means ask for
2432 confirmation before overwriting, but do go ahead and overwrite the file
2433 if the user confirms.
2434
2435 If PRESERVE-UID-GID is non-nil, we try to transfer the
2436 uid and gid of FILE to NEWNAME. */)
2437 (file, newname, ok_if_already_exists, keep_time, mustbenew, preserve_uid_gid)
2438 Lisp_Object file, newname, ok_if_already_exists, keep_time, mustbenew;
2439 Lisp_Object preserve_uid_gid;
2440 {
2441 int ifd, ofd, n;
2442 char buf[16 * 1024];
2443 struct stat st, out_st;
2444 Lisp_Object handler;
2445 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
2446 int count = SPECPDL_INDEX ();
2447 int input_file_statable_p;
2448 Lisp_Object encoded_file, encoded_newname;
2449
2450 encoded_file = encoded_newname = Qnil;
2451 GCPRO4 (file, newname, encoded_file, encoded_newname);
2452 CHECK_STRING (file);
2453 CHECK_STRING (newname);
2454
2455 if (!NILP (mustbenew) && !EQ (mustbenew, Qexcl))
2456 barf_or_query_if_file_exists (newname, "overwrite", 1, 0, 1);
2457
2458 if (!NILP (Ffile_directory_p (newname)))
2459 newname = Fexpand_file_name (Ffile_name_nondirectory (file), newname);
2460 else
2461 newname = Fexpand_file_name (newname, Qnil);
2462
2463 file = Fexpand_file_name (file, Qnil);
2464
2465 /* If the input file name has special constructs in it,
2466 call the corresponding file handler. */
2467 handler = Ffind_file_name_handler (file, Qcopy_file);
2468 /* Likewise for output file name. */
2469 if (NILP (handler))
2470 handler = Ffind_file_name_handler (newname, Qcopy_file);
2471 if (!NILP (handler))
2472 RETURN_UNGCPRO (call5 (handler, Qcopy_file, file, newname,
2473 ok_if_already_exists, keep_time));
2474
2475 encoded_file = ENCODE_FILE (file);
2476 encoded_newname = ENCODE_FILE (newname);
2477
2478 if (NILP (ok_if_already_exists)
2479 || INTEGERP (ok_if_already_exists))
2480 barf_or_query_if_file_exists (encoded_newname, "copy to it",
2481 INTEGERP (ok_if_already_exists), &out_st, 0);
2482 else if (stat (SDATA (encoded_newname), &out_st) < 0)
2483 out_st.st_mode = 0;
2484
2485 #ifdef WINDOWSNT
2486 if (!CopyFile (SDATA (encoded_file),
2487 SDATA (encoded_newname),
2488 FALSE))
2489 report_file_error ("Copying file", Fcons (file, Fcons (newname, Qnil)));
2490 /* CopyFile retains the timestamp by default. */
2491 else if (NILP (keep_time))
2492 {
2493 EMACS_TIME now;
2494 DWORD attributes;
2495 char * filename;
2496
2497 EMACS_GET_TIME (now);
2498 filename = SDATA (encoded_newname);
2499
2500 /* Ensure file is writable while its modified time is set. */
2501 attributes = GetFileAttributes (filename);
2502 SetFileAttributes (filename, attributes & ~FILE_ATTRIBUTE_READONLY);
2503 if (set_file_times (filename, now, now))
2504 {
2505 /* Restore original attributes. */
2506 SetFileAttributes (filename, attributes);
2507 Fsignal (Qfile_date_error,
2508 Fcons (build_string ("Cannot set file date"),
2509 Fcons (newname, Qnil)));
2510 }
2511 /* Restore original attributes. */
2512 SetFileAttributes (filename, attributes);
2513 }
2514 #else /* not WINDOWSNT */
2515 immediate_quit = 1;
2516 ifd = emacs_open (SDATA (encoded_file), O_RDONLY, 0);
2517 immediate_quit = 0;
2518
2519 if (ifd < 0)
2520 report_file_error ("Opening input file", Fcons (file, Qnil));
2521
2522 record_unwind_protect (close_file_unwind, make_number (ifd));
2523
2524 /* We can only copy regular files and symbolic links. Other files are not
2525 copyable by us. */
2526 input_file_statable_p = (fstat (ifd, &st) >= 0);
2527
2528 #if !defined (MSDOS) || __DJGPP__ > 1
2529 if (out_st.st_mode != 0
2530 && st.st_dev == out_st.st_dev && st.st_ino == out_st.st_ino)
2531 {
2532 errno = 0;
2533 report_file_error ("Input and output files are the same",
2534 Fcons (file, Fcons (newname, Qnil)));
2535 }
2536 #endif
2537
2538 #if defined (S_ISREG) && defined (S_ISLNK)
2539 if (input_file_statable_p)
2540 {
2541 if (!(S_ISREG (st.st_mode)) && !(S_ISLNK (st.st_mode)))
2542 {
2543 #if defined (EISDIR)
2544 /* Get a better looking error message. */
2545 errno = EISDIR;
2546 #endif /* EISDIR */
2547 report_file_error ("Non-regular file", Fcons (file, Qnil));
2548 }
2549 }
2550 #endif /* S_ISREG && S_ISLNK */
2551
2552 #ifdef VMS
2553 /* Create the copy file with the same record format as the input file */
2554 ofd = sys_creat (SDATA (encoded_newname), 0666, ifd);
2555 #else
2556 #ifdef MSDOS
2557 /* System's default file type was set to binary by _fmode in emacs.c. */
2558 ofd = emacs_open (SDATA (encoded_newname),
2559 O_WRONLY | O_TRUNC | O_CREAT
2560 | (EQ (mustbenew, Qexcl) ? O_EXCL : 0),
2561 S_IREAD | S_IWRITE);
2562 #else /* not MSDOS */
2563 ofd = emacs_open (SDATA (encoded_newname),
2564 O_WRONLY | O_TRUNC | O_CREAT
2565 | (EQ (mustbenew, Qexcl) ? O_EXCL : 0),
2566 0666);
2567 #endif /* not MSDOS */
2568 #endif /* VMS */
2569 if (ofd < 0)
2570 report_file_error ("Opening output file", Fcons (newname, Qnil));
2571
2572 record_unwind_protect (close_file_unwind, make_number (ofd));
2573
2574 immediate_quit = 1;
2575 QUIT;
2576 while ((n = emacs_read (ifd, buf, sizeof buf)) > 0)
2577 if (emacs_write (ofd, buf, n) != n)
2578 report_file_error ("I/O error", Fcons (newname, Qnil));
2579 immediate_quit = 0;
2580
2581 #ifndef MSDOS
2582 /* Preserve the original file modes, and if requested, also its
2583 owner and group. */
2584 if (input_file_statable_p)
2585 {
2586 if (! NILP (preserve_uid_gid))
2587 fchown (ofd, st.st_uid, st.st_gid);
2588 fchmod (ofd, st.st_mode & 07777);
2589 }
2590 #endif /* not MSDOS */
2591
2592 /* Closing the output clobbers the file times on some systems. */
2593 if (emacs_close (ofd) < 0)
2594 report_file_error ("I/O error", Fcons (newname, Qnil));
2595
2596 if (input_file_statable_p)
2597 {
2598 if (!NILP (keep_time))
2599 {
2600 EMACS_TIME atime, mtime;
2601 EMACS_SET_SECS_USECS (atime, st.st_atime, 0);
2602 EMACS_SET_SECS_USECS (mtime, st.st_mtime, 0);
2603 if (set_file_times (SDATA (encoded_newname),
2604 atime, mtime))
2605 Fsignal (Qfile_date_error,
2606 Fcons (build_string ("Cannot set file date"),
2607 Fcons (newname, Qnil)));
2608 }
2609 }
2610
2611 emacs_close (ifd);
2612
2613 #if defined (__DJGPP__) && __DJGPP__ > 1
2614 if (input_file_statable_p)
2615 {
2616 /* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
2617 and if it can't, it tells so. Otherwise, under MSDOS we usually
2618 get only the READ bit, which will make the copied file read-only,
2619 so it's better not to chmod at all. */
2620 if ((_djstat_flags & _STFAIL_WRITEBIT) == 0)
2621 chmod (SDATA (encoded_newname), st.st_mode & 07777);
2622 }
2623 #endif /* DJGPP version 2 or newer */
2624 #endif /* not WINDOWSNT */
2625
2626 /* Discard the unwind protects. */
2627 specpdl_ptr = specpdl + count;
2628
2629 UNGCPRO;
2630 return Qnil;
2631 }
2632 \f
2633 DEFUN ("make-directory-internal", Fmake_directory_internal,
2634 Smake_directory_internal, 1, 1, 0,
2635 doc: /* Create a new directory named DIRECTORY. */)
2636 (directory)
2637 Lisp_Object directory;
2638 {
2639 const unsigned char *dir;
2640 Lisp_Object handler;
2641 Lisp_Object encoded_dir;
2642
2643 CHECK_STRING (directory);
2644 directory = Fexpand_file_name (directory, Qnil);
2645
2646 handler = Ffind_file_name_handler (directory, Qmake_directory_internal);
2647 if (!NILP (handler))
2648 return call2 (handler, Qmake_directory_internal, directory);
2649
2650 encoded_dir = ENCODE_FILE (directory);
2651
2652 dir = SDATA (encoded_dir);
2653
2654 #ifdef WINDOWSNT
2655 if (mkdir (dir) != 0)
2656 #else
2657 if (mkdir (dir, 0777) != 0)
2658 #endif
2659 report_file_error ("Creating directory", Flist (1, &directory));
2660
2661 return Qnil;
2662 }
2663
2664 DEFUN ("delete-directory", Fdelete_directory, Sdelete_directory, 1, 1, "FDelete directory: ",
2665 doc: /* Delete the directory named DIRECTORY. Does not follow symlinks. */)
2666 (directory)
2667 Lisp_Object directory;
2668 {
2669 const unsigned char *dir;
2670 Lisp_Object handler;
2671 Lisp_Object encoded_dir;
2672
2673 CHECK_STRING (directory);
2674 directory = Fdirectory_file_name (Fexpand_file_name (directory, Qnil));
2675
2676 handler = Ffind_file_name_handler (directory, Qdelete_directory);
2677 if (!NILP (handler))
2678 return call2 (handler, Qdelete_directory, directory);
2679
2680 encoded_dir = ENCODE_FILE (directory);
2681
2682 dir = SDATA (encoded_dir);
2683
2684 if (rmdir (dir) != 0)
2685 report_file_error ("Removing directory", Flist (1, &directory));
2686
2687 return Qnil;
2688 }
2689
2690 DEFUN ("delete-file", Fdelete_file, Sdelete_file, 1, 1, "fDelete file: ",
2691 doc: /* Delete file named FILENAME. If it is a symlink, remove the symlink.
2692 If file has multiple names, it continues to exist with the other names. */)
2693 (filename)
2694 Lisp_Object filename;
2695 {
2696 Lisp_Object handler;
2697 Lisp_Object encoded_file;
2698 struct gcpro gcpro1;
2699
2700 GCPRO1 (filename);
2701 if (!NILP (Ffile_directory_p (filename))
2702 && NILP (Ffile_symlink_p (filename)))
2703 Fsignal (Qfile_error,
2704 Fcons (build_string ("Removing old name: is a directory"),
2705 Fcons (filename, Qnil)));
2706 UNGCPRO;
2707 filename = Fexpand_file_name (filename, Qnil);
2708
2709 handler = Ffind_file_name_handler (filename, Qdelete_file);
2710 if (!NILP (handler))
2711 return call2 (handler, Qdelete_file, filename);
2712
2713 encoded_file = ENCODE_FILE (filename);
2714
2715 if (0 > unlink (SDATA (encoded_file)))
2716 report_file_error ("Removing old name", Flist (1, &filename));
2717 return Qnil;
2718 }
2719
2720 static Lisp_Object
2721 internal_delete_file_1 (ignore)
2722 Lisp_Object ignore;
2723 {
2724 return Qt;
2725 }
2726
2727 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */
2728
2729 int
2730 internal_delete_file (filename)
2731 Lisp_Object filename;
2732 {
2733 return NILP (internal_condition_case_1 (Fdelete_file, filename,
2734 Qt, internal_delete_file_1));
2735 }
2736 \f
2737 DEFUN ("rename-file", Frename_file, Srename_file, 2, 3,
2738 "fRename file: \nGRename %s to file: \np",
2739 doc: /* Rename FILE as NEWNAME. Both args must be strings.
2740 If file has names other than FILE, it continues to have those names.
2741 Signals a `file-already-exists' error if a file NEWNAME already exists
2742 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2743 A number as third arg means request confirmation if NEWNAME already exists.
2744 This is what happens in interactive use with M-x. */)
2745 (file, newname, ok_if_already_exists)
2746 Lisp_Object file, newname, ok_if_already_exists;
2747 {
2748 #ifdef NO_ARG_ARRAY
2749 Lisp_Object args[2];
2750 #endif
2751 Lisp_Object handler;
2752 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
2753 Lisp_Object encoded_file, encoded_newname, symlink_target;
2754
2755 symlink_target = encoded_file = encoded_newname = Qnil;
2756 GCPRO5 (file, newname, encoded_file, encoded_newname, symlink_target);
2757 CHECK_STRING (file);
2758 CHECK_STRING (newname);
2759 file = Fexpand_file_name (file, Qnil);
2760
2761 if (!NILP (Ffile_directory_p (newname)))
2762 newname = Fexpand_file_name (Ffile_name_nondirectory (file), newname);
2763 else
2764 newname = Fexpand_file_name (newname, Qnil);
2765
2766 /* If the file name has special constructs in it,
2767 call the corresponding file handler. */
2768 handler = Ffind_file_name_handler (file, Qrename_file);
2769 if (NILP (handler))
2770 handler = Ffind_file_name_handler (newname, Qrename_file);
2771 if (!NILP (handler))
2772 RETURN_UNGCPRO (call4 (handler, Qrename_file,
2773 file, newname, ok_if_already_exists));
2774
2775 encoded_file = ENCODE_FILE (file);
2776 encoded_newname = ENCODE_FILE (newname);
2777
2778 #ifdef DOS_NT
2779 /* If the file names are identical but for the case, don't ask for
2780 confirmation: they simply want to change the letter-case of the
2781 file name. */
2782 if (NILP (Fstring_equal (Fdowncase (file), Fdowncase (newname))))
2783 #endif
2784 if (NILP (ok_if_already_exists)
2785 || INTEGERP (ok_if_already_exists))
2786 barf_or_query_if_file_exists (encoded_newname, "rename to it",
2787 INTEGERP (ok_if_already_exists), 0, 0);
2788 #ifndef BSD4_1
2789 if (0 > rename (SDATA (encoded_file), SDATA (encoded_newname)))
2790 #else
2791 if (0 > link (SDATA (encoded_file), SDATA (encoded_newname))
2792 || 0 > unlink (SDATA (encoded_file)))
2793 #endif
2794 {
2795 if (errno == EXDEV)
2796 {
2797 #ifdef S_IFLNK
2798 symlink_target = Ffile_symlink_p (file);
2799 if (! NILP (symlink_target))
2800 Fmake_symbolic_link (symlink_target, newname,
2801 NILP (ok_if_already_exists) ? Qnil : Qt);
2802 else
2803 #endif
2804 Fcopy_file (file, newname,
2805 /* We have already prompted if it was an integer,
2806 so don't have copy-file prompt again. */
2807 NILP (ok_if_already_exists) ? Qnil : Qt,
2808 Qt, Qnil, Qt);
2809
2810 Fdelete_file (file);
2811 }
2812 else
2813 #ifdef NO_ARG_ARRAY
2814 {
2815 args[0] = file;
2816 args[1] = newname;
2817 report_file_error ("Renaming", Flist (2, args));
2818 }
2819 #else
2820 report_file_error ("Renaming", Flist (2, &file));
2821 #endif
2822 }
2823 UNGCPRO;
2824 return Qnil;
2825 }
2826
2827 DEFUN ("add-name-to-file", Fadd_name_to_file, Sadd_name_to_file, 2, 3,
2828 "fAdd name to file: \nGName to add to %s: \np",
2829 doc: /* Give FILE additional name NEWNAME. Both args must be strings.
2830 Signals a `file-already-exists' error if a file NEWNAME already exists
2831 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2832 A number as third arg means request confirmation if NEWNAME already exists.
2833 This is what happens in interactive use with M-x. */)
2834 (file, newname, ok_if_already_exists)
2835 Lisp_Object file, newname, ok_if_already_exists;
2836 {
2837 #ifdef NO_ARG_ARRAY
2838 Lisp_Object args[2];
2839 #endif
2840 Lisp_Object handler;
2841 Lisp_Object encoded_file, encoded_newname;
2842 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
2843
2844 GCPRO4 (file, newname, encoded_file, encoded_newname);
2845 encoded_file = encoded_newname = Qnil;
2846 CHECK_STRING (file);
2847 CHECK_STRING (newname);
2848 file = Fexpand_file_name (file, Qnil);
2849
2850 if (!NILP (Ffile_directory_p (newname)))
2851 newname = Fexpand_file_name (Ffile_name_nondirectory (file), newname);
2852 else
2853 newname = Fexpand_file_name (newname, Qnil);
2854
2855 /* If the file name has special constructs in it,
2856 call the corresponding file handler. */
2857 handler = Ffind_file_name_handler (file, Qadd_name_to_file);
2858 if (!NILP (handler))
2859 RETURN_UNGCPRO (call4 (handler, Qadd_name_to_file, file,
2860 newname, ok_if_already_exists));
2861
2862 /* If the new name has special constructs in it,
2863 call the corresponding file handler. */
2864 handler = Ffind_file_name_handler (newname, Qadd_name_to_file);
2865 if (!NILP (handler))
2866 RETURN_UNGCPRO (call4 (handler, Qadd_name_to_file, file,
2867 newname, ok_if_already_exists));
2868
2869 encoded_file = ENCODE_FILE (file);
2870 encoded_newname = ENCODE_FILE (newname);
2871
2872 if (NILP (ok_if_already_exists)
2873 || INTEGERP (ok_if_already_exists))
2874 barf_or_query_if_file_exists (encoded_newname, "make it a new name",
2875 INTEGERP (ok_if_already_exists), 0, 0);
2876
2877 unlink (SDATA (newname));
2878 if (0 > link (SDATA (encoded_file), SDATA (encoded_newname)))
2879 {
2880 #ifdef NO_ARG_ARRAY
2881 args[0] = file;
2882 args[1] = newname;
2883 report_file_error ("Adding new name", Flist (2, args));
2884 #else
2885 report_file_error ("Adding new name", Flist (2, &file));
2886 #endif
2887 }
2888
2889 UNGCPRO;
2890 return Qnil;
2891 }
2892
2893 #ifdef S_IFLNK
2894 DEFUN ("make-symbolic-link", Fmake_symbolic_link, Smake_symbolic_link, 2, 3,
2895 "FMake symbolic link to file: \nGMake symbolic link to file %s: \np",
2896 doc: /* Make a symbolic link to FILENAME, named LINKNAME.
2897 Both args must be strings.
2898 Signals a `file-already-exists' error if a file LINKNAME already exists
2899 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2900 A number as third arg means request confirmation if LINKNAME already exists.
2901 This happens for interactive use with M-x. */)
2902 (filename, linkname, ok_if_already_exists)
2903 Lisp_Object filename, linkname, ok_if_already_exists;
2904 {
2905 #ifdef NO_ARG_ARRAY
2906 Lisp_Object args[2];
2907 #endif
2908 Lisp_Object handler;
2909 Lisp_Object encoded_filename, encoded_linkname;
2910 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
2911
2912 GCPRO4 (filename, linkname, encoded_filename, encoded_linkname);
2913 encoded_filename = encoded_linkname = Qnil;
2914 CHECK_STRING (filename);
2915 CHECK_STRING (linkname);
2916 /* If the link target has a ~, we must expand it to get
2917 a truly valid file name. Otherwise, do not expand;
2918 we want to permit links to relative file names. */
2919 if (SREF (filename, 0) == '~')
2920 filename = Fexpand_file_name (filename, Qnil);
2921
2922 if (!NILP (Ffile_directory_p (linkname)))
2923 linkname = Fexpand_file_name (Ffile_name_nondirectory (filename), linkname);
2924 else
2925 linkname = Fexpand_file_name (linkname, Qnil);
2926
2927 /* If the file name has special constructs in it,
2928 call the corresponding file handler. */
2929 handler = Ffind_file_name_handler (filename, Qmake_symbolic_link);
2930 if (!NILP (handler))
2931 RETURN_UNGCPRO (call4 (handler, Qmake_symbolic_link, filename,
2932 linkname, ok_if_already_exists));
2933
2934 /* If the new link name has special constructs in it,
2935 call the corresponding file handler. */
2936 handler = Ffind_file_name_handler (linkname, Qmake_symbolic_link);
2937 if (!NILP (handler))
2938 RETURN_UNGCPRO (call4 (handler, Qmake_symbolic_link, filename,
2939 linkname, ok_if_already_exists));
2940
2941 encoded_filename = ENCODE_FILE (filename);
2942 encoded_linkname = ENCODE_FILE (linkname);
2943
2944 if (NILP (ok_if_already_exists)
2945 || INTEGERP (ok_if_already_exists))
2946 barf_or_query_if_file_exists (encoded_linkname, "make it a link",
2947 INTEGERP (ok_if_already_exists), 0, 0);
2948 if (0 > symlink (SDATA (encoded_filename),
2949 SDATA (encoded_linkname)))
2950 {
2951 /* If we didn't complain already, silently delete existing file. */
2952 if (errno == EEXIST)
2953 {
2954 unlink (SDATA (encoded_linkname));
2955 if (0 <= symlink (SDATA (encoded_filename),
2956 SDATA (encoded_linkname)))
2957 {
2958 UNGCPRO;
2959 return Qnil;
2960 }
2961 }
2962
2963 #ifdef NO_ARG_ARRAY
2964 args[0] = filename;
2965 args[1] = linkname;
2966 report_file_error ("Making symbolic link", Flist (2, args));
2967 #else
2968 report_file_error ("Making symbolic link", Flist (2, &filename));
2969 #endif
2970 }
2971 UNGCPRO;
2972 return Qnil;
2973 }
2974 #endif /* S_IFLNK */
2975
2976 #ifdef VMS
2977
2978 DEFUN ("define-logical-name", Fdefine_logical_name, Sdefine_logical_name,
2979 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2980 doc: /* Define the job-wide logical name NAME to have the value STRING.
2981 If STRING is nil or a null string, the logical name NAME is deleted. */)
2982 (name, string)
2983 Lisp_Object name;
2984 Lisp_Object string;
2985 {
2986 CHECK_STRING (name);
2987 if (NILP (string))
2988 delete_logical_name (SDATA (name));
2989 else
2990 {
2991 CHECK_STRING (string);
2992
2993 if (SCHARS (string) == 0)
2994 delete_logical_name (SDATA (name));
2995 else
2996 define_logical_name (SDATA (name), SDATA (string));
2997 }
2998
2999 return string;
3000 }
3001 #endif /* VMS */
3002
3003 #ifdef HPUX_NET
3004
3005 DEFUN ("sysnetunam", Fsysnetunam, Ssysnetunam, 2, 2, 0,
3006 doc: /* Open a network connection to PATH using LOGIN as the login string. */)
3007 (path, login)
3008 Lisp_Object path, login;
3009 {
3010 int netresult;
3011
3012 CHECK_STRING (path);
3013 CHECK_STRING (login);
3014
3015 netresult = netunam (SDATA (path), SDATA (login));
3016
3017 if (netresult == -1)
3018 return Qnil;
3019 else
3020 return Qt;
3021 }
3022 #endif /* HPUX_NET */
3023 \f
3024 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p, Sfile_name_absolute_p,
3025 1, 1, 0,
3026 doc: /* Return t if file FILENAME specifies an absolute file name.
3027 On Unix, this is a name starting with a `/' or a `~'. */)
3028 (filename)
3029 Lisp_Object filename;
3030 {
3031 CHECK_STRING (filename);
3032 return file_name_absolute_p (SDATA (filename)) ? Qt : Qnil;
3033 }
3034 \f
3035 /* Return nonzero if file FILENAME exists and can be executed. */
3036
3037 static int
3038 check_executable (filename)
3039 char *filename;
3040 {
3041 #ifdef DOS_NT
3042 int len = strlen (filename);
3043 char *suffix;
3044 struct stat st;
3045 if (stat (filename, &st) < 0)
3046 return 0;
3047 #if defined (WINDOWSNT) || (defined (MSDOS) && __DJGPP__ > 1)
3048 return ((st.st_mode & S_IEXEC) != 0);
3049 #else
3050 return (S_ISREG (st.st_mode)
3051 && len >= 5
3052 && (stricmp ((suffix = filename + len-4), ".com") == 0
3053 || stricmp (suffix, ".exe") == 0
3054 || stricmp (suffix, ".bat") == 0)
3055 || (st.st_mode & S_IFMT) == S_IFDIR);
3056 #endif /* not WINDOWSNT */
3057 #else /* not DOS_NT */
3058 #ifdef HAVE_EUIDACCESS
3059 return (euidaccess (filename, 1) >= 0);
3060 #else
3061 /* Access isn't quite right because it uses the real uid
3062 and we really want to test with the effective uid.
3063 But Unix doesn't give us a right way to do it. */
3064 return (access (filename, 1) >= 0);
3065 #endif
3066 #endif /* not DOS_NT */
3067 }
3068
3069 /* Return nonzero if file FILENAME exists and can be written. */
3070
3071 static int
3072 check_writable (filename)
3073 char *filename;
3074 {
3075 #ifdef MSDOS
3076 struct stat st;
3077 if (stat (filename, &st) < 0)
3078 return 0;
3079 return (st.st_mode & S_IWRITE || (st.st_mode & S_IFMT) == S_IFDIR);
3080 #else /* not MSDOS */
3081 #ifdef HAVE_EUIDACCESS
3082 return (euidaccess (filename, 2) >= 0);
3083 #else
3084 /* Access isn't quite right because it uses the real uid
3085 and we really want to test with the effective uid.
3086 But Unix doesn't give us a right way to do it.
3087 Opening with O_WRONLY could work for an ordinary file,
3088 but would lose for directories. */
3089 return (access (filename, 2) >= 0);
3090 #endif
3091 #endif /* not MSDOS */
3092 }
3093
3094 DEFUN ("file-exists-p", Ffile_exists_p, Sfile_exists_p, 1, 1, 0,
3095 doc: /* Return t if file FILENAME exists (whether or not you can read it.)
3096 See also `file-readable-p' and `file-attributes'.
3097 This returns nil for a symlink to a nonexistent file.
3098 Use `file-symlink-p' to test for such links. */)
3099 (filename)
3100 Lisp_Object filename;
3101 {
3102 Lisp_Object absname;
3103 Lisp_Object handler;
3104 struct stat statbuf;
3105
3106 CHECK_STRING (filename);
3107 absname = Fexpand_file_name (filename, Qnil);
3108
3109 /* If the file name has special constructs in it,
3110 call the corresponding file handler. */
3111 handler = Ffind_file_name_handler (absname, Qfile_exists_p);
3112 if (!NILP (handler))
3113 return call2 (handler, Qfile_exists_p, absname);
3114
3115 absname = ENCODE_FILE (absname);
3116
3117 return (stat (SDATA (absname), &statbuf) >= 0) ? Qt : Qnil;
3118 }
3119
3120 DEFUN ("file-executable-p", Ffile_executable_p, Sfile_executable_p, 1, 1, 0,
3121 doc: /* Return t if FILENAME can be executed by you.
3122 For a directory, this means you can access files in that directory. */)
3123 (filename)
3124 Lisp_Object filename;
3125 {
3126 Lisp_Object absname;
3127 Lisp_Object handler;
3128
3129 CHECK_STRING (filename);
3130 absname = Fexpand_file_name (filename, Qnil);
3131
3132 /* If the file name has special constructs in it,
3133 call the corresponding file handler. */
3134 handler = Ffind_file_name_handler (absname, Qfile_executable_p);
3135 if (!NILP (handler))
3136 return call2 (handler, Qfile_executable_p, absname);
3137
3138 absname = ENCODE_FILE (absname);
3139
3140 return (check_executable (SDATA (absname)) ? Qt : Qnil);
3141 }
3142
3143 DEFUN ("file-readable-p", Ffile_readable_p, Sfile_readable_p, 1, 1, 0,
3144 doc: /* Return t if file FILENAME exists and you can read it.
3145 See also `file-exists-p' and `file-attributes'. */)
3146 (filename)
3147 Lisp_Object filename;
3148 {
3149 Lisp_Object absname;
3150 Lisp_Object handler;
3151 int desc;
3152 int flags;
3153 struct stat statbuf;
3154
3155 CHECK_STRING (filename);
3156 absname = Fexpand_file_name (filename, Qnil);
3157
3158 /* If the file name has special constructs in it,
3159 call the corresponding file handler. */
3160 handler = Ffind_file_name_handler (absname, Qfile_readable_p);
3161 if (!NILP (handler))
3162 return call2 (handler, Qfile_readable_p, absname);
3163
3164 absname = ENCODE_FILE (absname);
3165
3166 #if defined(DOS_NT) || defined(macintosh)
3167 /* Under MS-DOS, Windows, and Macintosh, open does not work for
3168 directories. */
3169 if (access (SDATA (absname), 0) == 0)
3170 return Qt;
3171 return Qnil;
3172 #else /* not DOS_NT and not macintosh */
3173 flags = O_RDONLY;
3174 #if defined (S_ISFIFO) && defined (O_NONBLOCK)
3175 /* Opening a fifo without O_NONBLOCK can wait.
3176 We don't want to wait. But we don't want to mess wth O_NONBLOCK
3177 except in the case of a fifo, on a system which handles it. */
3178 desc = stat (SDATA (absname), &statbuf);
3179 if (desc < 0)
3180 return Qnil;
3181 if (S_ISFIFO (statbuf.st_mode))
3182 flags |= O_NONBLOCK;
3183 #endif
3184 desc = emacs_open (SDATA (absname), flags, 0);
3185 if (desc < 0)
3186 return Qnil;
3187 emacs_close (desc);
3188 return Qt;
3189 #endif /* not DOS_NT and not macintosh */
3190 }
3191
3192 /* Having this before file-symlink-p mysteriously caused it to be forgotten
3193 on the RT/PC. */
3194 DEFUN ("file-writable-p", Ffile_writable_p, Sfile_writable_p, 1, 1, 0,
3195 doc: /* Return t if file FILENAME can be written or created by you. */)
3196 (filename)
3197 Lisp_Object filename;
3198 {
3199 Lisp_Object absname, dir, encoded;
3200 Lisp_Object handler;
3201 struct stat statbuf;
3202
3203 CHECK_STRING (filename);
3204 absname = Fexpand_file_name (filename, Qnil);
3205
3206 /* If the file name has special constructs in it,
3207 call the corresponding file handler. */
3208 handler = Ffind_file_name_handler (absname, Qfile_writable_p);
3209 if (!NILP (handler))
3210 return call2 (handler, Qfile_writable_p, absname);
3211
3212 encoded = ENCODE_FILE (absname);
3213 if (stat (SDATA (encoded), &statbuf) >= 0)
3214 return (check_writable (SDATA (encoded))
3215 ? Qt : Qnil);
3216
3217 dir = Ffile_name_directory (absname);
3218 #ifdef VMS
3219 if (!NILP (dir))
3220 dir = Fdirectory_file_name (dir);
3221 #endif /* VMS */
3222 #ifdef MSDOS
3223 if (!NILP (dir))
3224 dir = Fdirectory_file_name (dir);
3225 #endif /* MSDOS */
3226
3227 dir = ENCODE_FILE (dir);
3228 #ifdef WINDOWSNT
3229 /* The read-only attribute of the parent directory doesn't affect
3230 whether a file or directory can be created within it. Some day we
3231 should check ACLs though, which do affect this. */
3232 if (stat (SDATA (dir), &statbuf) < 0)
3233 return Qnil;
3234 return (statbuf.st_mode & S_IFMT) == S_IFDIR ? Qt : Qnil;
3235 #else
3236 return (check_writable (!NILP (dir) ? (char *) SDATA (dir) : "")
3237 ? Qt : Qnil);
3238 #endif
3239 }
3240 \f
3241 DEFUN ("access-file", Faccess_file, Saccess_file, 2, 2, 0,
3242 doc: /* Access file FILENAME, and get an error if that does not work.
3243 The second argument STRING is used in the error message.
3244 If there is no error, returns nil. */)
3245 (filename, string)
3246 Lisp_Object filename, string;
3247 {
3248 Lisp_Object handler, encoded_filename, absname;
3249 int fd;
3250
3251 CHECK_STRING (filename);
3252 absname = Fexpand_file_name (filename, Qnil);
3253
3254 CHECK_STRING (string);
3255
3256 /* If the file name has special constructs in it,
3257 call the corresponding file handler. */
3258 handler = Ffind_file_name_handler (absname, Qaccess_file);
3259 if (!NILP (handler))
3260 return call3 (handler, Qaccess_file, absname, string);
3261
3262 encoded_filename = ENCODE_FILE (absname);
3263
3264 fd = emacs_open (SDATA (encoded_filename), O_RDONLY, 0);
3265 if (fd < 0)
3266 report_file_error (SDATA (string), Fcons (filename, Qnil));
3267 emacs_close (fd);
3268
3269 return Qnil;
3270 }
3271 \f
3272 DEFUN ("file-symlink-p", Ffile_symlink_p, Sfile_symlink_p, 1, 1, 0,
3273 doc: /* Return non-nil if file FILENAME is the name of a symbolic link.
3274 The value is the link target, as a string.
3275 Otherwise it returns nil.
3276
3277 This function returns t when given the name of a symlink that
3278 points to a nonexistent file. */)
3279 (filename)
3280 Lisp_Object filename;
3281 {
3282 Lisp_Object handler;
3283
3284 CHECK_STRING (filename);
3285 filename = Fexpand_file_name (filename, Qnil);
3286
3287 /* If the file name has special constructs in it,
3288 call the corresponding file handler. */
3289 handler = Ffind_file_name_handler (filename, Qfile_symlink_p);
3290 if (!NILP (handler))
3291 return call2 (handler, Qfile_symlink_p, filename);
3292
3293 #ifdef S_IFLNK
3294 {
3295 char *buf;
3296 int bufsize;
3297 int valsize;
3298 Lisp_Object val;
3299
3300 filename = ENCODE_FILE (filename);
3301
3302 bufsize = 50;
3303 buf = NULL;
3304 do
3305 {
3306 bufsize *= 2;
3307 buf = (char *) xrealloc (buf, bufsize);
3308 bzero (buf, bufsize);
3309
3310 errno = 0;
3311 valsize = readlink (SDATA (filename), buf, bufsize);
3312 if (valsize == -1)
3313 {
3314 #ifdef ERANGE
3315 /* HP-UX reports ERANGE if buffer is too small. */
3316 if (errno == ERANGE)
3317 valsize = bufsize;
3318 else
3319 #endif
3320 {
3321 xfree (buf);
3322 return Qnil;
3323 }
3324 }
3325 }
3326 while (valsize >= bufsize);
3327
3328 val = make_string (buf, valsize);
3329 if (buf[0] == '/' && index (buf, ':'))
3330 val = concat2 (build_string ("/:"), val);
3331 xfree (buf);
3332 val = DECODE_FILE (val);
3333 return val;
3334 }
3335 #else /* not S_IFLNK */
3336 return Qnil;
3337 #endif /* not S_IFLNK */
3338 }
3339
3340 DEFUN ("file-directory-p", Ffile_directory_p, Sfile_directory_p, 1, 1, 0,
3341 doc: /* Return t if FILENAME names an existing directory.
3342 Symbolic links to directories count as directories.
3343 See `file-symlink-p' to distinguish symlinks. */)
3344 (filename)
3345 Lisp_Object filename;
3346 {
3347 register Lisp_Object absname;
3348 struct stat st;
3349 Lisp_Object handler;
3350
3351 absname = expand_and_dir_to_file (filename, current_buffer->directory);
3352
3353 /* If the file name has special constructs in it,
3354 call the corresponding file handler. */
3355 handler = Ffind_file_name_handler (absname, Qfile_directory_p);
3356 if (!NILP (handler))
3357 return call2 (handler, Qfile_directory_p, absname);
3358
3359 absname = ENCODE_FILE (absname);
3360
3361 if (stat (SDATA (absname), &st) < 0)
3362 return Qnil;
3363 return (st.st_mode & S_IFMT) == S_IFDIR ? Qt : Qnil;
3364 }
3365
3366 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p, Sfile_accessible_directory_p, 1, 1, 0,
3367 doc: /* Return t if file FILENAME names a directory you can open.
3368 For the value to be t, FILENAME must specify the name of a directory as a file,
3369 and the directory must allow you to open files in it. In order to use a
3370 directory as a buffer's current directory, this predicate must return true.
3371 A directory name spec may be given instead; then the value is t
3372 if the directory so specified exists and really is a readable and
3373 searchable directory. */)
3374 (filename)
3375 Lisp_Object filename;
3376 {
3377 Lisp_Object handler;
3378 int tem;
3379 struct gcpro gcpro1;
3380
3381 /* If the file name has special constructs in it,
3382 call the corresponding file handler. */
3383 handler = Ffind_file_name_handler (filename, Qfile_accessible_directory_p);
3384 if (!NILP (handler))
3385 return call2 (handler, Qfile_accessible_directory_p, filename);
3386
3387 GCPRO1 (filename);
3388 tem = (NILP (Ffile_directory_p (filename))
3389 || NILP (Ffile_executable_p (filename)));
3390 UNGCPRO;
3391 return tem ? Qnil : Qt;
3392 }
3393
3394 DEFUN ("file-regular-p", Ffile_regular_p, Sfile_regular_p, 1, 1, 0,
3395 doc: /* Return t if file FILENAME is the name of a regular file.
3396 This is the sort of file that holds an ordinary stream of data bytes. */)
3397 (filename)
3398 Lisp_Object filename;
3399 {
3400 register Lisp_Object absname;
3401 struct stat st;
3402 Lisp_Object handler;
3403
3404 absname = expand_and_dir_to_file (filename, current_buffer->directory);
3405
3406 /* If the file name has special constructs in it,
3407 call the corresponding file handler. */
3408 handler = Ffind_file_name_handler (absname, Qfile_regular_p);
3409 if (!NILP (handler))
3410 return call2 (handler, Qfile_regular_p, absname);
3411
3412 absname = ENCODE_FILE (absname);
3413
3414 #ifdef WINDOWSNT
3415 {
3416 int result;
3417 Lisp_Object tem = Vw32_get_true_file_attributes;
3418
3419 /* Tell stat to use expensive method to get accurate info. */
3420 Vw32_get_true_file_attributes = Qt;
3421 result = stat (SDATA (absname), &st);
3422 Vw32_get_true_file_attributes = tem;
3423
3424 if (result < 0)
3425 return Qnil;
3426 return (st.st_mode & S_IFMT) == S_IFREG ? Qt : Qnil;
3427 }
3428 #else
3429 if (stat (SDATA (absname), &st) < 0)
3430 return Qnil;
3431 return (st.st_mode & S_IFMT) == S_IFREG ? Qt : Qnil;
3432 #endif
3433 }
3434 \f
3435 DEFUN ("file-modes", Ffile_modes, Sfile_modes, 1, 1, 0,
3436 doc: /* Return mode bits of file named FILENAME, as an integer.
3437 Return nil, if file does not exist or is not accessible. */)
3438 (filename)
3439 Lisp_Object filename;
3440 {
3441 Lisp_Object absname;
3442 struct stat st;
3443 Lisp_Object handler;
3444
3445 absname = expand_and_dir_to_file (filename, current_buffer->directory);
3446
3447 /* If the file name has special constructs in it,
3448 call the corresponding file handler. */
3449 handler = Ffind_file_name_handler (absname, Qfile_modes);
3450 if (!NILP (handler))
3451 return call2 (handler, Qfile_modes, absname);
3452
3453 absname = ENCODE_FILE (absname);
3454
3455 if (stat (SDATA (absname), &st) < 0)
3456 return Qnil;
3457 #if defined (MSDOS) && __DJGPP__ < 2
3458 if (check_executable (SDATA (absname)))
3459 st.st_mode |= S_IEXEC;
3460 #endif /* MSDOS && __DJGPP__ < 2 */
3461
3462 return make_number (st.st_mode & 07777);
3463 }
3464
3465 DEFUN ("set-file-modes", Fset_file_modes, Sset_file_modes, 2, 2, 0,
3466 doc: /* Set mode bits of file named FILENAME to MODE (an integer).
3467 Only the 12 low bits of MODE are used. */)
3468 (filename, mode)
3469 Lisp_Object filename, mode;
3470 {
3471 Lisp_Object absname, encoded_absname;
3472 Lisp_Object handler;
3473
3474 absname = Fexpand_file_name (filename, current_buffer->directory);
3475 CHECK_NUMBER (mode);
3476
3477 /* If the file name has special constructs in it,
3478 call the corresponding file handler. */
3479 handler = Ffind_file_name_handler (absname, Qset_file_modes);
3480 if (!NILP (handler))
3481 return call3 (handler, Qset_file_modes, absname, mode);
3482
3483 encoded_absname = ENCODE_FILE (absname);
3484
3485 if (chmod (SDATA (encoded_absname), XINT (mode)) < 0)
3486 report_file_error ("Doing chmod", Fcons (absname, Qnil));
3487
3488 return Qnil;
3489 }
3490
3491 DEFUN ("set-default-file-modes", Fset_default_file_modes, Sset_default_file_modes, 1, 1, 0,
3492 doc: /* Set the file permission bits for newly created files.
3493 The argument MODE should be an integer; only the low 9 bits are used.
3494 This setting is inherited by subprocesses. */)
3495 (mode)
3496 Lisp_Object mode;
3497 {
3498 CHECK_NUMBER (mode);
3499
3500 umask ((~ XINT (mode)) & 0777);
3501
3502 return Qnil;
3503 }
3504
3505 DEFUN ("default-file-modes", Fdefault_file_modes, Sdefault_file_modes, 0, 0, 0,
3506 doc: /* Return the default file protection for created files.
3507 The value is an integer. */)
3508 ()
3509 {
3510 int realmask;
3511 Lisp_Object value;
3512
3513 realmask = umask (0);
3514 umask (realmask);
3515
3516 XSETINT (value, (~ realmask) & 0777);
3517 return value;
3518 }
3519 \f
3520 extern int lisp_time_argument P_ ((Lisp_Object, time_t *, int *));
3521
3522 DEFUN ("set-file-times", Fset_file_times, Sset_file_times, 1, 2, 0,
3523 doc: /* Set times of file FILENAME to TIME.
3524 Set both access and modification times.
3525 Return t on success, else nil.
3526 Use the current time if TIME is nil. TIME is in the format of
3527 `current-time'. */)
3528 (filename, time)
3529 Lisp_Object filename, time;
3530 {
3531 Lisp_Object absname, encoded_absname;
3532 Lisp_Object handler;
3533 time_t sec;
3534 int usec;
3535
3536 if (! lisp_time_argument (time, &sec, &usec))
3537 error ("Invalid time specification");
3538
3539 absname = Fexpand_file_name (filename, current_buffer->directory);
3540
3541 /* If the file name has special constructs in it,
3542 call the corresponding file handler. */
3543 handler = Ffind_file_name_handler (absname, Qset_file_times);
3544 if (!NILP (handler))
3545 return call3 (handler, Qset_file_times, absname, time);
3546
3547 encoded_absname = ENCODE_FILE (absname);
3548
3549 {
3550 EMACS_TIME t;
3551
3552 EMACS_SET_SECS (t, sec);
3553 EMACS_SET_USECS (t, usec);
3554
3555 if (set_file_times (SDATA (encoded_absname), t, t))
3556 {
3557 #ifdef DOS_NT
3558 struct stat st;
3559
3560 /* Setting times on a directory always fails. */
3561 if (stat (SDATA (encoded_absname), &st) == 0
3562 && (st.st_mode & S_IFMT) == S_IFDIR)
3563 return Qnil;
3564 #endif
3565 report_file_error ("Setting file times", Fcons (absname, Qnil));
3566 return Qnil;
3567 }
3568 }
3569
3570 return Qt;
3571 }
3572 \f
3573 #ifdef __NetBSD__
3574 #define unix 42
3575 #endif
3576
3577 #ifdef unix
3578 DEFUN ("unix-sync", Funix_sync, Sunix_sync, 0, 0, "",
3579 doc: /* Tell Unix to finish all pending disk updates. */)
3580 ()
3581 {
3582 sync ();
3583 return Qnil;
3584 }
3585
3586 #endif /* unix */
3587
3588 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p, Sfile_newer_than_file_p, 2, 2, 0,
3589 doc: /* Return t if file FILE1 is newer than file FILE2.
3590 If FILE1 does not exist, the answer is nil;
3591 otherwise, if FILE2 does not exist, the answer is t. */)
3592 (file1, file2)
3593 Lisp_Object file1, file2;
3594 {
3595 Lisp_Object absname1, absname2;
3596 struct stat st;
3597 int mtime1;
3598 Lisp_Object handler;
3599 struct gcpro gcpro1, gcpro2;
3600
3601 CHECK_STRING (file1);
3602 CHECK_STRING (file2);
3603
3604 absname1 = Qnil;
3605 GCPRO2 (absname1, file2);
3606 absname1 = expand_and_dir_to_file (file1, current_buffer->directory);
3607 absname2 = expand_and_dir_to_file (file2, current_buffer->directory);
3608 UNGCPRO;
3609
3610 /* If the file name has special constructs in it,
3611 call the corresponding file handler. */
3612 handler = Ffind_file_name_handler (absname1, Qfile_newer_than_file_p);
3613 if (NILP (handler))
3614 handler = Ffind_file_name_handler (absname2, Qfile_newer_than_file_p);
3615 if (!NILP (handler))
3616 return call3 (handler, Qfile_newer_than_file_p, absname1, absname2);
3617
3618 GCPRO2 (absname1, absname2);
3619 absname1 = ENCODE_FILE (absname1);
3620 absname2 = ENCODE_FILE (absname2);
3621 UNGCPRO;
3622
3623 if (stat (SDATA (absname1), &st) < 0)
3624 return Qnil;
3625
3626 mtime1 = st.st_mtime;
3627
3628 if (stat (SDATA (absname2), &st) < 0)
3629 return Qt;
3630
3631 return (mtime1 > st.st_mtime) ? Qt : Qnil;
3632 }
3633 \f
3634 #ifdef DOS_NT
3635 Lisp_Object Qfind_buffer_file_type;
3636 #endif /* DOS_NT */
3637
3638 #ifndef READ_BUF_SIZE
3639 #define READ_BUF_SIZE (64 << 10)
3640 #endif
3641
3642 extern void adjust_markers_for_delete P_ ((int, int, int, int));
3643
3644 /* This function is called after Lisp functions to decide a coding
3645 system are called, or when they cause an error. Before they are
3646 called, the current buffer is set unibyte and it contains only a
3647 newly inserted text (thus the buffer was empty before the
3648 insertion).
3649
3650 The functions may set markers, overlays, text properties, or even
3651 alter the buffer contents, change the current buffer.
3652
3653 Here, we reset all those changes by:
3654 o set back the current buffer.
3655 o move all markers and overlays to BEG.
3656 o remove all text properties.
3657 o set back the buffer multibyteness. */
3658
3659 static Lisp_Object
3660 decide_coding_unwind (unwind_data)
3661 Lisp_Object unwind_data;
3662 {
3663 Lisp_Object multibyte, undo_list, buffer;
3664
3665 multibyte = XCAR (unwind_data);
3666 unwind_data = XCDR (unwind_data);
3667 undo_list = XCAR (unwind_data);
3668 buffer = XCDR (unwind_data);
3669
3670 if (current_buffer != XBUFFER (buffer))
3671 set_buffer_internal (XBUFFER (buffer));
3672 adjust_markers_for_delete (BEG, BEG_BYTE, Z, Z_BYTE);
3673 adjust_overlays_for_delete (BEG, Z - BEG);
3674 BUF_INTERVALS (current_buffer) = 0;
3675 TEMP_SET_PT_BOTH (BEG, BEG_BYTE);
3676
3677 /* Now we are safe to change the buffer's multibyteness directly. */
3678 current_buffer->enable_multibyte_characters = multibyte;
3679 current_buffer->undo_list = undo_list;
3680
3681 return Qnil;
3682 }
3683
3684
3685 /* Used to pass values from insert-file-contents to read_non_regular. */
3686
3687 static int non_regular_fd;
3688 static int non_regular_inserted;
3689 static int non_regular_nbytes;
3690
3691
3692 /* Read from a non-regular file.
3693 Read non_regular_trytry bytes max from non_regular_fd.
3694 Non_regular_inserted specifies where to put the read bytes.
3695 Value is the number of bytes read. */
3696
3697 static Lisp_Object
3698 read_non_regular ()
3699 {
3700 int nbytes;
3701
3702 immediate_quit = 1;
3703 QUIT;
3704 nbytes = emacs_read (non_regular_fd,
3705 BEG_ADDR + PT_BYTE - BEG_BYTE + non_regular_inserted,
3706 non_regular_nbytes);
3707 immediate_quit = 0;
3708 return make_number (nbytes);
3709 }
3710
3711
3712 /* Condition-case handler used when reading from non-regular files
3713 in insert-file-contents. */
3714
3715 static Lisp_Object
3716 read_non_regular_quit ()
3717 {
3718 return Qnil;
3719 }
3720
3721
3722 DEFUN ("insert-file-contents", Finsert_file_contents, Sinsert_file_contents,
3723 1, 5, 0,
3724 doc: /* Insert contents of file FILENAME after point.
3725 Returns list of absolute file name and number of characters inserted.
3726 If second argument VISIT is non-nil, the buffer's visited filename
3727 and last save file modtime are set, and it is marked unmodified.
3728 If visiting and the file does not exist, visiting is completed
3729 before the error is signaled.
3730 The optional third and fourth arguments BEG and END
3731 specify what portion of the file to insert.
3732 These arguments count bytes in the file, not characters in the buffer.
3733 If VISIT is non-nil, BEG and END must be nil.
3734
3735 If optional fifth argument REPLACE is non-nil,
3736 it means replace the current buffer contents (in the accessible portion)
3737 with the file contents. This is better than simply deleting and inserting
3738 the whole thing because (1) it preserves some marker positions
3739 and (2) it puts less data in the undo list.
3740 When REPLACE is non-nil, the value is the number of characters actually read,
3741 which is often less than the number of characters to be read.
3742
3743 This does code conversion according to the value of
3744 `coding-system-for-read' or `file-coding-system-alist',
3745 and sets the variable `last-coding-system-used' to the coding system
3746 actually used. */)
3747 (filename, visit, beg, end, replace)
3748 Lisp_Object filename, visit, beg, end, replace;
3749 {
3750 struct stat st;
3751 register int fd;
3752 int inserted = 0;
3753 register int how_much;
3754 register int unprocessed;
3755 int count = SPECPDL_INDEX ();
3756 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
3757 Lisp_Object handler, val, insval, orig_filename;
3758 Lisp_Object p;
3759 int total = 0;
3760 int not_regular = 0;
3761 unsigned char read_buf[READ_BUF_SIZE];
3762 struct coding_system coding;
3763 unsigned char buffer[1 << 14];
3764 int replace_handled = 0;
3765 int set_coding_system = 0;
3766 int coding_system_decided = 0;
3767 int read_quit = 0;
3768 Lisp_Object old_Vdeactivate_mark = Vdeactivate_mark;
3769 int we_locked_file = 0;
3770
3771 if (current_buffer->base_buffer && ! NILP (visit))
3772 error ("Cannot do file visiting in an indirect buffer");
3773
3774 if (!NILP (current_buffer->read_only))
3775 Fbarf_if_buffer_read_only ();
3776
3777 val = Qnil;
3778 p = Qnil;
3779 orig_filename = Qnil;
3780
3781 GCPRO4 (filename, val, p, orig_filename);
3782
3783 CHECK_STRING (filename);
3784 filename = Fexpand_file_name (filename, Qnil);
3785
3786 /* If the file name has special constructs in it,
3787 call the corresponding file handler. */
3788 handler = Ffind_file_name_handler (filename, Qinsert_file_contents);
3789 if (!NILP (handler))
3790 {
3791 val = call6 (handler, Qinsert_file_contents, filename,
3792 visit, beg, end, replace);
3793 if (CONSP (val) && CONSP (XCDR (val)))
3794 inserted = XINT (XCAR (XCDR (val)));
3795 goto handled;
3796 }
3797
3798 orig_filename = filename;
3799 filename = ENCODE_FILE (filename);
3800
3801 fd = -1;
3802
3803 #ifdef WINDOWSNT
3804 {
3805 Lisp_Object tem = Vw32_get_true_file_attributes;
3806
3807 /* Tell stat to use expensive method to get accurate info. */
3808 Vw32_get_true_file_attributes = Qt;
3809 total = stat (SDATA (filename), &st);
3810 Vw32_get_true_file_attributes = tem;
3811 }
3812 if (total < 0)
3813 #else
3814 #ifndef APOLLO
3815 if (stat (SDATA (filename), &st) < 0)
3816 #else
3817 if ((fd = emacs_open (SDATA (filename), O_RDONLY, 0)) < 0
3818 || fstat (fd, &st) < 0)
3819 #endif /* not APOLLO */
3820 #endif /* WINDOWSNT */
3821 {
3822 if (fd >= 0) emacs_close (fd);
3823 badopen:
3824 if (NILP (visit))
3825 report_file_error ("Opening input file", Fcons (orig_filename, Qnil));
3826 st.st_mtime = -1;
3827 how_much = 0;
3828 if (!NILP (Vcoding_system_for_read))
3829 Fset (Qbuffer_file_coding_system, Vcoding_system_for_read);
3830 goto notfound;
3831 }
3832
3833 #ifdef S_IFREG
3834 /* This code will need to be changed in order to work on named
3835 pipes, and it's probably just not worth it. So we should at
3836 least signal an error. */
3837 if (!S_ISREG (st.st_mode))
3838 {
3839 not_regular = 1;
3840
3841 if (! NILP (visit))
3842 goto notfound;
3843
3844 if (! NILP (replace) || ! NILP (beg) || ! NILP (end))
3845 Fsignal (Qfile_error,
3846 Fcons (build_string ("not a regular file"),
3847 Fcons (orig_filename, Qnil)));
3848 }
3849 #endif
3850
3851 if (fd < 0)
3852 if ((fd = emacs_open (SDATA (filename), O_RDONLY, 0)) < 0)
3853 goto badopen;
3854
3855 /* Replacement should preserve point as it preserves markers. */
3856 if (!NILP (replace))
3857 record_unwind_protect (restore_point_unwind, Fpoint_marker ());
3858
3859 record_unwind_protect (close_file_unwind, make_number (fd));
3860
3861 /* Supposedly happens on VMS. */
3862 /* Can happen on any platform that uses long as type of off_t, but allows
3863 file sizes to exceed 2Gb. VMS is no longer officially supported, so
3864 give a message suitable for the latter case. */
3865 if (! not_regular && st.st_size < 0)
3866 error ("Maximum buffer size exceeded");
3867
3868 /* Prevent redisplay optimizations. */
3869 current_buffer->clip_changed = 1;
3870
3871 if (!NILP (visit))
3872 {
3873 if (!NILP (beg) || !NILP (end))
3874 error ("Attempt to visit less than an entire file");
3875 if (BEG < Z && NILP (replace))
3876 error ("Cannot do file visiting in a non-empty buffer");
3877 }
3878
3879 if (!NILP (beg))
3880 CHECK_NUMBER (beg);
3881 else
3882 XSETFASTINT (beg, 0);
3883
3884 if (!NILP (end))
3885 CHECK_NUMBER (end);
3886 else
3887 {
3888 if (! not_regular)
3889 {
3890 XSETINT (end, st.st_size);
3891
3892 /* Arithmetic overflow can occur if an Emacs integer cannot
3893 represent the file size, or if the calculations below
3894 overflow. The calculations below double the file size
3895 twice, so check that it can be multiplied by 4 safely. */
3896 if (XINT (end) != st.st_size
3897 || ((int) st.st_size * 4) / 4 != st.st_size)
3898 error ("Maximum buffer size exceeded");
3899
3900 /* The file size returned from stat may be zero, but data
3901 may be readable nonetheless, for example when this is a
3902 file in the /proc filesystem. */
3903 if (st.st_size == 0)
3904 XSETINT (end, READ_BUF_SIZE);
3905 }
3906 }
3907
3908 if (EQ (Vcoding_system_for_read, Qauto_save_coding))
3909 {
3910 /* We use emacs-mule for auto saving... */
3911 setup_coding_system (Qemacs_mule, &coding);
3912 /* ... but with the special flag to indicate to read in a
3913 multibyte sequence for eight-bit-control char as is. */
3914 coding.flags = 1;
3915 coding.src_multibyte = 0;
3916 coding.dst_multibyte
3917 = !NILP (current_buffer->enable_multibyte_characters);
3918 coding.eol_type = CODING_EOL_LF;
3919 coding_system_decided = 1;
3920 }
3921 else if (BEG < Z)
3922 {
3923 /* Decide the coding system to use for reading the file now
3924 because we can't use an optimized method for handling
3925 `coding:' tag if the current buffer is not empty. */
3926 Lisp_Object val;
3927 val = Qnil;
3928
3929 if (!NILP (Vcoding_system_for_read))
3930 val = Vcoding_system_for_read;
3931 else
3932 {
3933 /* Don't try looking inside a file for a coding system
3934 specification if it is not seekable. */
3935 if (! not_regular && ! NILP (Vset_auto_coding_function))
3936 {
3937 /* Find a coding system specified in the heading two
3938 lines or in the tailing several lines of the file.
3939 We assume that the 1K-byte and 3K-byte for heading
3940 and tailing respectively are sufficient for this
3941 purpose. */
3942 int nread;
3943
3944 if (st.st_size <= (1024 * 4))
3945 nread = emacs_read (fd, read_buf, 1024 * 4);
3946 else
3947 {
3948 nread = emacs_read (fd, read_buf, 1024);
3949 if (nread >= 0)
3950 {
3951 if (lseek (fd, st.st_size - (1024 * 3), 0) < 0)
3952 report_file_error ("Setting file position",
3953 Fcons (orig_filename, Qnil));
3954 nread += emacs_read (fd, read_buf + nread, 1024 * 3);
3955 }
3956 }
3957
3958 if (nread < 0)
3959 error ("IO error reading %s: %s",
3960 SDATA (orig_filename), emacs_strerror (errno));
3961 else if (nread > 0)
3962 {
3963 struct buffer *prev = current_buffer;
3964 Lisp_Object buffer;
3965 struct buffer *buf;
3966
3967 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
3968
3969 buffer = Fget_buffer_create (build_string (" *code-converting-work*"));
3970 buf = XBUFFER (buffer);
3971
3972 delete_all_overlays (buf);
3973 buf->directory = current_buffer->directory;
3974 buf->read_only = Qnil;
3975 buf->filename = Qnil;
3976 buf->undo_list = Qt;
3977 eassert (buf->overlays_before == NULL);
3978 eassert (buf->overlays_after == NULL);
3979
3980 set_buffer_internal (buf);
3981 Ferase_buffer ();
3982 buf->enable_multibyte_characters = Qnil;
3983
3984 insert_1_both (read_buf, nread, nread, 0, 0, 0);
3985 TEMP_SET_PT_BOTH (BEG, BEG_BYTE);
3986 val = call2 (Vset_auto_coding_function,
3987 filename, make_number (nread));
3988 set_buffer_internal (prev);
3989
3990 /* Discard the unwind protect for recovering the
3991 current buffer. */
3992 specpdl_ptr--;
3993
3994 /* Rewind the file for the actual read done later. */
3995 if (lseek (fd, 0, 0) < 0)
3996 report_file_error ("Setting file position",
3997 Fcons (orig_filename, Qnil));
3998 }
3999 }
4000
4001 if (NILP (val))
4002 {
4003 /* If we have not yet decided a coding system, check
4004 file-coding-system-alist. */
4005 Lisp_Object args[6], coding_systems;
4006
4007 args[0] = Qinsert_file_contents, args[1] = orig_filename;
4008 args[2] = visit, args[3] = beg, args[4] = end, args[5] = replace;
4009 coding_systems = Ffind_operation_coding_system (6, args);
4010 if (CONSP (coding_systems))
4011 val = XCAR (coding_systems);
4012 }
4013 }
4014
4015 setup_coding_system (Fcheck_coding_system (val), &coding);
4016 /* Ensure we set Vlast_coding_system_used. */
4017 set_coding_system = 1;
4018
4019 if (NILP (current_buffer->enable_multibyte_characters)
4020 && ! NILP (val))
4021 /* We must suppress all character code conversion except for
4022 end-of-line conversion. */
4023 setup_raw_text_coding_system (&coding);
4024
4025 coding.src_multibyte = 0;
4026 coding.dst_multibyte
4027 = !NILP (current_buffer->enable_multibyte_characters);
4028 coding_system_decided = 1;
4029 }
4030
4031 /* If requested, replace the accessible part of the buffer
4032 with the file contents. Avoid replacing text at the
4033 beginning or end of the buffer that matches the file contents;
4034 that preserves markers pointing to the unchanged parts.
4035
4036 Here we implement this feature in an optimized way
4037 for the case where code conversion is NOT needed.
4038 The following if-statement handles the case of conversion
4039 in a less optimal way.
4040
4041 If the code conversion is "automatic" then we try using this
4042 method and hope for the best.
4043 But if we discover the need for conversion, we give up on this method
4044 and let the following if-statement handle the replace job. */
4045 if (!NILP (replace)
4046 && BEGV < ZV
4047 && !(coding.common_flags & CODING_REQUIRE_DECODING_MASK))
4048 {
4049 /* same_at_start and same_at_end count bytes,
4050 because file access counts bytes
4051 and BEG and END count bytes. */
4052 int same_at_start = BEGV_BYTE;
4053 int same_at_end = ZV_BYTE;
4054 int overlap;
4055 /* There is still a possibility we will find the need to do code
4056 conversion. If that happens, we set this variable to 1 to
4057 give up on handling REPLACE in the optimized way. */
4058 int giveup_match_end = 0;
4059
4060 if (XINT (beg) != 0)
4061 {
4062 if (lseek (fd, XINT (beg), 0) < 0)
4063 report_file_error ("Setting file position",
4064 Fcons (orig_filename, Qnil));
4065 }
4066
4067 immediate_quit = 1;
4068 QUIT;
4069 /* Count how many chars at the start of the file
4070 match the text at the beginning of the buffer. */
4071 while (1)
4072 {
4073 int nread, bufpos;
4074
4075 nread = emacs_read (fd, buffer, sizeof buffer);
4076 if (nread < 0)
4077 error ("IO error reading %s: %s",
4078 SDATA (orig_filename), emacs_strerror (errno));
4079 else if (nread == 0)
4080 break;
4081
4082 if (coding.type == coding_type_undecided)
4083 detect_coding (&coding, buffer, nread);
4084 if (coding.common_flags & CODING_REQUIRE_DECODING_MASK)
4085 /* We found that the file should be decoded somehow.
4086 Let's give up here. */
4087 {
4088 giveup_match_end = 1;
4089 break;
4090 }
4091
4092 if (coding.eol_type == CODING_EOL_UNDECIDED)
4093 detect_eol (&coding, buffer, nread);
4094 if (coding.eol_type != CODING_EOL_UNDECIDED
4095 && coding.eol_type != CODING_EOL_LF)
4096 /* We found that the format of eol should be decoded.
4097 Let's give up here. */
4098 {
4099 giveup_match_end = 1;
4100 break;
4101 }
4102
4103 bufpos = 0;
4104 while (bufpos < nread && same_at_start < ZV_BYTE
4105 && FETCH_BYTE (same_at_start) == buffer[bufpos])
4106 same_at_start++, bufpos++;
4107 /* If we found a discrepancy, stop the scan.
4108 Otherwise loop around and scan the next bufferful. */
4109 if (bufpos != nread)
4110 break;
4111 }
4112 immediate_quit = 0;
4113 /* If the file matches the buffer completely,
4114 there's no need to replace anything. */
4115 if (same_at_start - BEGV_BYTE == XINT (end))
4116 {
4117 emacs_close (fd);
4118 specpdl_ptr--;
4119 /* Truncate the buffer to the size of the file. */
4120 del_range_1 (same_at_start, same_at_end, 0, 0);
4121 goto handled;
4122 }
4123 immediate_quit = 1;
4124 QUIT;
4125 /* Count how many chars at the end of the file
4126 match the text at the end of the buffer. But, if we have
4127 already found that decoding is necessary, don't waste time. */
4128 while (!giveup_match_end)
4129 {
4130 int total_read, nread, bufpos, curpos, trial;
4131
4132 /* At what file position are we now scanning? */
4133 curpos = XINT (end) - (ZV_BYTE - same_at_end);
4134 /* If the entire file matches the buffer tail, stop the scan. */
4135 if (curpos == 0)
4136 break;
4137 /* How much can we scan in the next step? */
4138 trial = min (curpos, sizeof buffer);
4139 if (lseek (fd, curpos - trial, 0) < 0)
4140 report_file_error ("Setting file position",
4141 Fcons (orig_filename, Qnil));
4142
4143 total_read = nread = 0;
4144 while (total_read < trial)
4145 {
4146 nread = emacs_read (fd, buffer + total_read, trial - total_read);
4147 if (nread < 0)
4148 error ("IO error reading %s: %s",
4149 SDATA (orig_filename), emacs_strerror (errno));
4150 else if (nread == 0)
4151 break;
4152 total_read += nread;
4153 }
4154
4155 /* Scan this bufferful from the end, comparing with
4156 the Emacs buffer. */
4157 bufpos = total_read;
4158
4159 /* Compare with same_at_start to avoid counting some buffer text
4160 as matching both at the file's beginning and at the end. */
4161 while (bufpos > 0 && same_at_end > same_at_start
4162 && FETCH_BYTE (same_at_end - 1) == buffer[bufpos - 1])
4163 same_at_end--, bufpos--;
4164
4165 /* If we found a discrepancy, stop the scan.
4166 Otherwise loop around and scan the preceding bufferful. */
4167 if (bufpos != 0)
4168 {
4169 /* If this discrepancy is because of code conversion,
4170 we cannot use this method; giveup and try the other. */
4171 if (same_at_end > same_at_start
4172 && FETCH_BYTE (same_at_end - 1) >= 0200
4173 && ! NILP (current_buffer->enable_multibyte_characters)
4174 && (CODING_MAY_REQUIRE_DECODING (&coding)))
4175 giveup_match_end = 1;
4176 break;
4177 }
4178
4179 if (nread == 0)
4180 break;
4181 }
4182 immediate_quit = 0;
4183
4184 if (! giveup_match_end)
4185 {
4186 int temp;
4187
4188 /* We win! We can handle REPLACE the optimized way. */
4189
4190 /* Extend the start of non-matching text area to multibyte
4191 character boundary. */
4192 if (! NILP (current_buffer->enable_multibyte_characters))
4193 while (same_at_start > BEGV_BYTE
4194 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start)))
4195 same_at_start--;
4196
4197 /* Extend the end of non-matching text area to multibyte
4198 character boundary. */
4199 if (! NILP (current_buffer->enable_multibyte_characters))
4200 while (same_at_end < ZV_BYTE
4201 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end)))
4202 same_at_end++;
4203
4204 /* Don't try to reuse the same piece of text twice. */
4205 overlap = (same_at_start - BEGV_BYTE
4206 - (same_at_end + st.st_size - ZV));
4207 if (overlap > 0)
4208 same_at_end += overlap;
4209
4210 /* Arrange to read only the nonmatching middle part of the file. */
4211 XSETFASTINT (beg, XINT (beg) + (same_at_start - BEGV_BYTE));
4212 XSETFASTINT (end, XINT (end) - (ZV_BYTE - same_at_end));
4213
4214 del_range_byte (same_at_start, same_at_end, 0);
4215 /* Insert from the file at the proper position. */
4216 temp = BYTE_TO_CHAR (same_at_start);
4217 SET_PT_BOTH (temp, same_at_start);
4218
4219 /* If display currently starts at beginning of line,
4220 keep it that way. */
4221 if (XBUFFER (XWINDOW (selected_window)->buffer) == current_buffer)
4222 XWINDOW (selected_window)->start_at_line_beg = Fbolp ();
4223
4224 replace_handled = 1;
4225 }
4226 }
4227
4228 /* If requested, replace the accessible part of the buffer
4229 with the file contents. Avoid replacing text at the
4230 beginning or end of the buffer that matches the file contents;
4231 that preserves markers pointing to the unchanged parts.
4232
4233 Here we implement this feature for the case where code conversion
4234 is needed, in a simple way that needs a lot of memory.
4235 The preceding if-statement handles the case of no conversion
4236 in a more optimized way. */
4237 if (!NILP (replace) && ! replace_handled && BEGV < ZV)
4238 {
4239 int same_at_start = BEGV_BYTE;
4240 int same_at_end = ZV_BYTE;
4241 int overlap;
4242 int bufpos;
4243 /* Make sure that the gap is large enough. */
4244 int bufsize = 2 * st.st_size;
4245 unsigned char *conversion_buffer = (unsigned char *) xmalloc (bufsize);
4246 int temp;
4247
4248 /* First read the whole file, performing code conversion into
4249 CONVERSION_BUFFER. */
4250
4251 if (lseek (fd, XINT (beg), 0) < 0)
4252 {
4253 xfree (conversion_buffer);
4254 report_file_error ("Setting file position",
4255 Fcons (orig_filename, Qnil));
4256 }
4257
4258 total = st.st_size; /* Total bytes in the file. */
4259 how_much = 0; /* Bytes read from file so far. */
4260 inserted = 0; /* Bytes put into CONVERSION_BUFFER so far. */
4261 unprocessed = 0; /* Bytes not processed in previous loop. */
4262
4263 while (how_much < total)
4264 {
4265 /* try is reserved in some compilers (Microsoft C) */
4266 int trytry = min (total - how_much, READ_BUF_SIZE - unprocessed);
4267 unsigned char *destination = read_buf + unprocessed;
4268 int this;
4269
4270 /* Allow quitting out of the actual I/O. */
4271 immediate_quit = 1;
4272 QUIT;
4273 this = emacs_read (fd, destination, trytry);
4274 immediate_quit = 0;
4275
4276 if (this < 0 || this + unprocessed == 0)
4277 {
4278 how_much = this;
4279 break;
4280 }
4281
4282 how_much += this;
4283
4284 if (CODING_MAY_REQUIRE_DECODING (&coding))
4285 {
4286 int require, result;
4287
4288 this += unprocessed;
4289
4290 /* If we are using more space than estimated,
4291 make CONVERSION_BUFFER bigger. */
4292 require = decoding_buffer_size (&coding, this);
4293 if (inserted + require + 2 * (total - how_much) > bufsize)
4294 {
4295 bufsize = inserted + require + 2 * (total - how_much);
4296 conversion_buffer = (unsigned char *) xrealloc (conversion_buffer, bufsize);
4297 }
4298
4299 /* Convert this batch with results in CONVERSION_BUFFER. */
4300 if (how_much >= total) /* This is the last block. */
4301 coding.mode |= CODING_MODE_LAST_BLOCK;
4302 if (coding.composing != COMPOSITION_DISABLED)
4303 coding_allocate_composition_data (&coding, BEGV);
4304 result = decode_coding (&coding, read_buf,
4305 conversion_buffer + inserted,
4306 this, bufsize - inserted);
4307
4308 /* Save for next iteration whatever we didn't convert. */
4309 unprocessed = this - coding.consumed;
4310 bcopy (read_buf + coding.consumed, read_buf, unprocessed);
4311 if (!NILP (current_buffer->enable_multibyte_characters))
4312 this = coding.produced;
4313 else
4314 this = str_as_unibyte (conversion_buffer + inserted,
4315 coding.produced);
4316 }
4317
4318 inserted += this;
4319 }
4320
4321 /* At this point, INSERTED is how many characters (i.e. bytes)
4322 are present in CONVERSION_BUFFER.
4323 HOW_MUCH should equal TOTAL,
4324 or should be <= 0 if we couldn't read the file. */
4325
4326 if (how_much < 0)
4327 {
4328 xfree (conversion_buffer);
4329 coding_free_composition_data (&coding);
4330 if (how_much == -1)
4331 error ("IO error reading %s: %s",
4332 SDATA (orig_filename), emacs_strerror (errno));
4333 else if (how_much == -2)
4334 error ("maximum buffer size exceeded");
4335 }
4336
4337 /* Compare the beginning of the converted file
4338 with the buffer text. */
4339
4340 bufpos = 0;
4341 while (bufpos < inserted && same_at_start < same_at_end
4342 && FETCH_BYTE (same_at_start) == conversion_buffer[bufpos])
4343 same_at_start++, bufpos++;
4344
4345 /* If the file matches the buffer completely,
4346 there's no need to replace anything. */
4347
4348 if (bufpos == inserted)
4349 {
4350 xfree (conversion_buffer);
4351 coding_free_composition_data (&coding);
4352 emacs_close (fd);
4353 specpdl_ptr--;
4354 /* Truncate the buffer to the size of the file. */
4355 del_range_byte (same_at_start, same_at_end, 0);
4356 inserted = 0;
4357 goto handled;
4358 }
4359
4360 /* Extend the start of non-matching text area to multibyte
4361 character boundary. */
4362 if (! NILP (current_buffer->enable_multibyte_characters))
4363 while (same_at_start > BEGV_BYTE
4364 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start)))
4365 same_at_start--;
4366
4367 /* Scan this bufferful from the end, comparing with
4368 the Emacs buffer. */
4369 bufpos = inserted;
4370
4371 /* Compare with same_at_start to avoid counting some buffer text
4372 as matching both at the file's beginning and at the end. */
4373 while (bufpos > 0 && same_at_end > same_at_start
4374 && FETCH_BYTE (same_at_end - 1) == conversion_buffer[bufpos - 1])
4375 same_at_end--, bufpos--;
4376
4377 /* Extend the end of non-matching text area to multibyte
4378 character boundary. */
4379 if (! NILP (current_buffer->enable_multibyte_characters))
4380 while (same_at_end < ZV_BYTE
4381 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end)))
4382 same_at_end++;
4383
4384 /* Don't try to reuse the same piece of text twice. */
4385 overlap = same_at_start - BEGV_BYTE - (same_at_end + inserted - ZV_BYTE);
4386 if (overlap > 0)
4387 same_at_end += overlap;
4388
4389 /* If display currently starts at beginning of line,
4390 keep it that way. */
4391 if (XBUFFER (XWINDOW (selected_window)->buffer) == current_buffer)
4392 XWINDOW (selected_window)->start_at_line_beg = Fbolp ();
4393
4394 /* Replace the chars that we need to replace,
4395 and update INSERTED to equal the number of bytes
4396 we are taking from the file. */
4397 inserted -= (ZV_BYTE - same_at_end) + (same_at_start - BEGV_BYTE);
4398
4399 if (same_at_end != same_at_start)
4400 {
4401 del_range_byte (same_at_start, same_at_end, 0);
4402 temp = GPT;
4403 same_at_start = GPT_BYTE;
4404 }
4405 else
4406 {
4407 temp = BYTE_TO_CHAR (same_at_start);
4408 }
4409 /* Insert from the file at the proper position. */
4410 SET_PT_BOTH (temp, same_at_start);
4411 insert_1 (conversion_buffer + same_at_start - BEGV_BYTE, inserted,
4412 0, 0, 0);
4413 if (coding.cmp_data && coding.cmp_data->used)
4414 coding_restore_composition (&coding, Fcurrent_buffer ());
4415 coding_free_composition_data (&coding);
4416
4417 /* Set `inserted' to the number of inserted characters. */
4418 inserted = PT - temp;
4419
4420 xfree (conversion_buffer);
4421 emacs_close (fd);
4422 specpdl_ptr--;
4423
4424 goto handled;
4425 }
4426
4427 if (! not_regular)
4428 {
4429 register Lisp_Object temp;
4430
4431 total = XINT (end) - XINT (beg);
4432
4433 /* Make sure point-max won't overflow after this insertion. */
4434 XSETINT (temp, total);
4435 if (total != XINT (temp))
4436 error ("Maximum buffer size exceeded");
4437 }
4438 else
4439 /* For a special file, all we can do is guess. */
4440 total = READ_BUF_SIZE;
4441
4442 if (NILP (visit) && inserted > 0)
4443 {
4444 #ifdef CLASH_DETECTION
4445 if (!NILP (current_buffer->file_truename)
4446 /* Make binding buffer-file-name to nil effective. */
4447 && !NILP (current_buffer->filename)
4448 && SAVE_MODIFF >= MODIFF)
4449 we_locked_file = 1;
4450 #endif /* CLASH_DETECTION */
4451 prepare_to_modify_buffer (GPT, GPT, NULL);
4452 }
4453
4454 move_gap (PT);
4455 if (GAP_SIZE < total)
4456 make_gap (total - GAP_SIZE);
4457
4458 if (XINT (beg) != 0 || !NILP (replace))
4459 {
4460 if (lseek (fd, XINT (beg), 0) < 0)
4461 report_file_error ("Setting file position",
4462 Fcons (orig_filename, Qnil));
4463 }
4464
4465 /* In the following loop, HOW_MUCH contains the total bytes read so
4466 far for a regular file, and not changed for a special file. But,
4467 before exiting the loop, it is set to a negative value if I/O
4468 error occurs. */
4469 how_much = 0;
4470
4471 /* Total bytes inserted. */
4472 inserted = 0;
4473
4474 /* Here, we don't do code conversion in the loop. It is done by
4475 code_convert_region after all data are read into the buffer. */
4476 {
4477 int gap_size = GAP_SIZE;
4478
4479 while (how_much < total)
4480 {
4481 /* try is reserved in some compilers (Microsoft C) */
4482 int trytry = min (total - how_much, READ_BUF_SIZE);
4483 int this;
4484
4485 if (not_regular)
4486 {
4487 Lisp_Object val;
4488
4489 /* Maybe make more room. */
4490 if (gap_size < trytry)
4491 {
4492 make_gap (total - gap_size);
4493 gap_size = GAP_SIZE;
4494 }
4495
4496 /* Read from the file, capturing `quit'. When an
4497 error occurs, end the loop, and arrange for a quit
4498 to be signaled after decoding the text we read. */
4499 non_regular_fd = fd;
4500 non_regular_inserted = inserted;
4501 non_regular_nbytes = trytry;
4502 val = internal_condition_case_1 (read_non_regular, Qnil, Qerror,
4503 read_non_regular_quit);
4504 if (NILP (val))
4505 {
4506 read_quit = 1;
4507 break;
4508 }
4509
4510 this = XINT (val);
4511 }
4512 else
4513 {
4514 /* Allow quitting out of the actual I/O. We don't make text
4515 part of the buffer until all the reading is done, so a C-g
4516 here doesn't do any harm. */
4517 immediate_quit = 1;
4518 QUIT;
4519 this = emacs_read (fd, BEG_ADDR + PT_BYTE - BEG_BYTE + inserted, trytry);
4520 immediate_quit = 0;
4521 }
4522
4523 if (this <= 0)
4524 {
4525 how_much = this;
4526 break;
4527 }
4528
4529 gap_size -= this;
4530
4531 /* For a regular file, where TOTAL is the real size,
4532 count HOW_MUCH to compare with it.
4533 For a special file, where TOTAL is just a buffer size,
4534 so don't bother counting in HOW_MUCH.
4535 (INSERTED is where we count the number of characters inserted.) */
4536 if (! not_regular)
4537 how_much += this;
4538 inserted += this;
4539 }
4540 }
4541
4542 /* Now we have read all the file data into the gap.
4543 If it was empty, undo marking the buffer modified. */
4544
4545 if (inserted == 0)
4546 {
4547 #ifdef CLASH_DETECTION
4548 if (we_locked_file)
4549 unlock_file (current_buffer->file_truename);
4550 #endif
4551 Vdeactivate_mark = old_Vdeactivate_mark;
4552 }
4553
4554 /* Make the text read part of the buffer. */
4555 GAP_SIZE -= inserted;
4556 GPT += inserted;
4557 GPT_BYTE += inserted;
4558 ZV += inserted;
4559 ZV_BYTE += inserted;
4560 Z += inserted;
4561 Z_BYTE += inserted;
4562
4563 if (GAP_SIZE > 0)
4564 /* Put an anchor to ensure multi-byte form ends at gap. */
4565 *GPT_ADDR = 0;
4566
4567 emacs_close (fd);
4568
4569 /* Discard the unwind protect for closing the file. */
4570 specpdl_ptr--;
4571
4572 if (how_much < 0)
4573 error ("IO error reading %s: %s",
4574 SDATA (orig_filename), emacs_strerror (errno));
4575
4576 notfound:
4577
4578 if (! coding_system_decided)
4579 {
4580 /* The coding system is not yet decided. Decide it by an
4581 optimized method for handling `coding:' tag.
4582
4583 Note that we can get here only if the buffer was empty
4584 before the insertion. */
4585 Lisp_Object val;
4586 val = Qnil;
4587
4588 if (!NILP (Vcoding_system_for_read))
4589 val = Vcoding_system_for_read;
4590 else
4591 {
4592 /* Since we are sure that the current buffer was empty
4593 before the insertion, we can toggle
4594 enable-multibyte-characters directly here without taking
4595 care of marker adjustment and byte combining problem. By
4596 this way, we can run Lisp program safely before decoding
4597 the inserted text. */
4598 Lisp_Object unwind_data;
4599 int count = SPECPDL_INDEX ();
4600
4601 unwind_data = Fcons (current_buffer->enable_multibyte_characters,
4602 Fcons (current_buffer->undo_list,
4603 Fcurrent_buffer ()));
4604 current_buffer->enable_multibyte_characters = Qnil;
4605 current_buffer->undo_list = Qt;
4606 record_unwind_protect (decide_coding_unwind, unwind_data);
4607
4608 if (inserted > 0 && ! NILP (Vset_auto_coding_function))
4609 {
4610 val = call2 (Vset_auto_coding_function,
4611 filename, make_number (inserted));
4612 }
4613
4614 if (NILP (val))
4615 {
4616 /* If the coding system is not yet decided, check
4617 file-coding-system-alist. */
4618 Lisp_Object args[6], coding_systems;
4619
4620 args[0] = Qinsert_file_contents, args[1] = orig_filename;
4621 args[2] = visit, args[3] = beg, args[4] = end, args[5] = Qnil;
4622 coding_systems = Ffind_operation_coding_system (6, args);
4623 if (CONSP (coding_systems))
4624 val = XCAR (coding_systems);
4625 }
4626 unbind_to (count, Qnil);
4627 inserted = Z_BYTE - BEG_BYTE;
4628 }
4629
4630 /* The following kludgy code is to avoid some compiler bug.
4631 We can't simply do
4632 setup_coding_system (val, &coding);
4633 on some system. */
4634 {
4635 struct coding_system temp_coding;
4636 setup_coding_system (Fcheck_coding_system (val), &temp_coding);
4637 bcopy (&temp_coding, &coding, sizeof coding);
4638 }
4639 /* Ensure we set Vlast_coding_system_used. */
4640 set_coding_system = 1;
4641
4642 if (NILP (current_buffer->enable_multibyte_characters)
4643 && ! NILP (val))
4644 /* We must suppress all character code conversion except for
4645 end-of-line conversion. */
4646 setup_raw_text_coding_system (&coding);
4647 coding.src_multibyte = 0;
4648 coding.dst_multibyte
4649 = !NILP (current_buffer->enable_multibyte_characters);
4650 }
4651
4652 if (!NILP (visit)
4653 /* Can't do this if part of the buffer might be preserved. */
4654 && NILP (replace)
4655 && (coding.type == coding_type_no_conversion
4656 || coding.type == coding_type_raw_text))
4657 {
4658 /* Visiting a file with these coding system makes the buffer
4659 unibyte. */
4660 current_buffer->enable_multibyte_characters = Qnil;
4661 coding.dst_multibyte = 0;
4662 }
4663
4664 if (inserted > 0 || coding.type == coding_type_ccl)
4665 {
4666 if (CODING_MAY_REQUIRE_DECODING (&coding))
4667 {
4668 code_convert_region (PT, PT_BYTE, PT + inserted, PT_BYTE + inserted,
4669 &coding, 0, 0);
4670 inserted = coding.produced_char;
4671 }
4672 else
4673 adjust_after_insert (PT, PT_BYTE, PT + inserted, PT_BYTE + inserted,
4674 inserted);
4675 }
4676
4677 /* Now INSERTED is measured in characters. */
4678
4679 #ifdef DOS_NT
4680 /* Use the conversion type to determine buffer-file-type
4681 (find-buffer-file-type is now used to help determine the
4682 conversion). */
4683 if ((coding.eol_type == CODING_EOL_UNDECIDED
4684 || coding.eol_type == CODING_EOL_LF)
4685 && ! CODING_REQUIRE_DECODING (&coding))
4686 current_buffer->buffer_file_type = Qt;
4687 else
4688 current_buffer->buffer_file_type = Qnil;
4689 #endif
4690
4691 handled:
4692
4693 if (!NILP (visit))
4694 {
4695 if (!EQ (current_buffer->undo_list, Qt))
4696 current_buffer->undo_list = Qnil;
4697 #ifdef APOLLO
4698 stat (SDATA (filename), &st);
4699 #endif
4700
4701 if (NILP (handler))
4702 {
4703 current_buffer->modtime = st.st_mtime;
4704 current_buffer->filename = orig_filename;
4705 }
4706
4707 SAVE_MODIFF = MODIFF;
4708 current_buffer->auto_save_modified = MODIFF;
4709 XSETFASTINT (current_buffer->save_length, Z - BEG);
4710 #ifdef CLASH_DETECTION
4711 if (NILP (handler))
4712 {
4713 if (!NILP (current_buffer->file_truename))
4714 unlock_file (current_buffer->file_truename);
4715 unlock_file (filename);
4716 }
4717 #endif /* CLASH_DETECTION */
4718 if (not_regular)
4719 Fsignal (Qfile_error,
4720 Fcons (build_string ("not a regular file"),
4721 Fcons (orig_filename, Qnil)));
4722 }
4723
4724 if (set_coding_system)
4725 Vlast_coding_system_used = coding.symbol;
4726
4727 if (! NILP (Ffboundp (Qafter_insert_file_set_coding)))
4728 {
4729 insval = call2 (Qafter_insert_file_set_coding, make_number (inserted),
4730 visit);
4731 if (! NILP (insval))
4732 {
4733 CHECK_NUMBER (insval);
4734 inserted = XFASTINT (insval);
4735 }
4736 }
4737
4738 /* Decode file format */
4739 if (inserted > 0)
4740 {
4741 int empty_undo_list_p = 0;
4742
4743 /* If we're anyway going to discard undo information, don't
4744 record it in the first place. The buffer's undo list at this
4745 point is either nil or t when visiting a file. */
4746 if (!NILP (visit))
4747 {
4748 empty_undo_list_p = NILP (current_buffer->undo_list);
4749 current_buffer->undo_list = Qt;
4750 }
4751
4752 insval = call3 (Qformat_decode,
4753 Qnil, make_number (inserted), visit);
4754 CHECK_NUMBER (insval);
4755 inserted = XFASTINT (insval);
4756
4757 if (!NILP (visit))
4758 current_buffer->undo_list = empty_undo_list_p ? Qnil : Qt;
4759 }
4760
4761 /* Call after-change hooks for the inserted text, aside from the case
4762 of normal visiting (not with REPLACE), which is done in a new buffer
4763 "before" the buffer is changed. */
4764 if (inserted > 0 && total > 0
4765 && (NILP (visit) || !NILP (replace)))
4766 {
4767 signal_after_change (PT, 0, inserted);
4768 update_compositions (PT, PT, CHECK_BORDER);
4769 }
4770
4771 p = Vafter_insert_file_functions;
4772 while (CONSP (p))
4773 {
4774 insval = call1 (XCAR (p), make_number (inserted));
4775 if (!NILP (insval))
4776 {
4777 CHECK_NUMBER (insval);
4778 inserted = XFASTINT (insval);
4779 }
4780 QUIT;
4781 p = XCDR (p);
4782 }
4783
4784 if (!NILP (visit)
4785 && current_buffer->modtime == -1)
4786 {
4787 /* If visiting nonexistent file, return nil. */
4788 report_file_error ("Opening input file", Fcons (orig_filename, Qnil));
4789 }
4790
4791 if (read_quit)
4792 Fsignal (Qquit, Qnil);
4793
4794 /* ??? Retval needs to be dealt with in all cases consistently. */
4795 if (NILP (val))
4796 val = Fcons (orig_filename,
4797 Fcons (make_number (inserted),
4798 Qnil));
4799
4800 RETURN_UNGCPRO (unbind_to (count, val));
4801 }
4802 \f
4803 static Lisp_Object build_annotations P_ ((Lisp_Object, Lisp_Object));
4804 static Lisp_Object build_annotations_2 P_ ((Lisp_Object, Lisp_Object,
4805 Lisp_Object, Lisp_Object));
4806
4807 /* If build_annotations switched buffers, switch back to BUF.
4808 Kill the temporary buffer that was selected in the meantime.
4809
4810 Since this kill only the last temporary buffer, some buffers remain
4811 not killed if build_annotations switched buffers more than once.
4812 -- K.Handa */
4813
4814 static Lisp_Object
4815 build_annotations_unwind (buf)
4816 Lisp_Object buf;
4817 {
4818 Lisp_Object tembuf;
4819
4820 if (XBUFFER (buf) == current_buffer)
4821 return Qnil;
4822 tembuf = Fcurrent_buffer ();
4823 Fset_buffer (buf);
4824 Fkill_buffer (tembuf);
4825 return Qnil;
4826 }
4827
4828 /* Decide the coding-system to encode the data with. */
4829
4830 void
4831 choose_write_coding_system (start, end, filename,
4832 append, visit, lockname, coding)
4833 Lisp_Object start, end, filename, append, visit, lockname;
4834 struct coding_system *coding;
4835 {
4836 Lisp_Object val;
4837
4838 if (auto_saving
4839 && NILP (Fstring_equal (current_buffer->filename,
4840 current_buffer->auto_save_file_name)))
4841 {
4842 /* We use emacs-mule for auto saving... */
4843 setup_coding_system (Qemacs_mule, coding);
4844 /* ... but with the special flag to indicate not to strip off
4845 leading code of eight-bit-control chars. */
4846 coding->flags = 1;
4847 goto done_setup_coding;
4848 }
4849 else if (!NILP (Vcoding_system_for_write))
4850 {
4851 val = Vcoding_system_for_write;
4852 if (coding_system_require_warning
4853 && !NILP (Ffboundp (Vselect_safe_coding_system_function)))
4854 /* Confirm that VAL can surely encode the current region. */
4855 val = call5 (Vselect_safe_coding_system_function,
4856 start, end, Fcons (Qt, Fcons (val, Qnil)),
4857 Qnil, filename);
4858 }
4859 else
4860 {
4861 /* If the variable `buffer-file-coding-system' is set locally,
4862 it means that the file was read with some kind of code
4863 conversion or the variable is explicitly set by users. We
4864 had better write it out with the same coding system even if
4865 `enable-multibyte-characters' is nil.
4866
4867 If it is not set locally, we anyway have to convert EOL
4868 format if the default value of `buffer-file-coding-system'
4869 tells that it is not Unix-like (LF only) format. */
4870 int using_default_coding = 0;
4871 int force_raw_text = 0;
4872
4873 val = current_buffer->buffer_file_coding_system;
4874 if (NILP (val)
4875 || NILP (Flocal_variable_p (Qbuffer_file_coding_system, Qnil)))
4876 {
4877 val = Qnil;
4878 if (NILP (current_buffer->enable_multibyte_characters))
4879 force_raw_text = 1;
4880 }
4881
4882 if (NILP (val))
4883 {
4884 /* Check file-coding-system-alist. */
4885 Lisp_Object args[7], coding_systems;
4886
4887 args[0] = Qwrite_region; args[1] = start; args[2] = end;
4888 args[3] = filename; args[4] = append; args[5] = visit;
4889 args[6] = lockname;
4890 coding_systems = Ffind_operation_coding_system (7, args);
4891 if (CONSP (coding_systems) && !NILP (XCDR (coding_systems)))
4892 val = XCDR (coding_systems);
4893 }
4894
4895 if (NILP (val)
4896 && !NILP (current_buffer->buffer_file_coding_system))
4897 {
4898 /* If we still have not decided a coding system, use the
4899 default value of buffer-file-coding-system. */
4900 val = current_buffer->buffer_file_coding_system;
4901 using_default_coding = 1;
4902 }
4903
4904 if (!force_raw_text
4905 && !NILP (Ffboundp (Vselect_safe_coding_system_function)))
4906 /* Confirm that VAL can surely encode the current region. */
4907 val = call5 (Vselect_safe_coding_system_function,
4908 start, end, val, Qnil, filename);
4909
4910 setup_coding_system (Fcheck_coding_system (val), coding);
4911 if (coding->eol_type == CODING_EOL_UNDECIDED
4912 && !using_default_coding)
4913 {
4914 if (! EQ (default_buffer_file_coding.symbol,
4915 buffer_defaults.buffer_file_coding_system))
4916 setup_coding_system (buffer_defaults.buffer_file_coding_system,
4917 &default_buffer_file_coding);
4918 if (default_buffer_file_coding.eol_type != CODING_EOL_UNDECIDED)
4919 {
4920 Lisp_Object subsidiaries;
4921
4922 coding->eol_type = default_buffer_file_coding.eol_type;
4923 subsidiaries = Fget (coding->symbol, Qeol_type);
4924 if (VECTORP (subsidiaries)
4925 && XVECTOR (subsidiaries)->size == 3)
4926 coding->symbol
4927 = XVECTOR (subsidiaries)->contents[coding->eol_type];
4928 }
4929 }
4930
4931 if (force_raw_text)
4932 setup_raw_text_coding_system (coding);
4933 goto done_setup_coding;
4934 }
4935
4936 setup_coding_system (Fcheck_coding_system (val), coding);
4937
4938 done_setup_coding:
4939 if (!STRINGP (start) && !NILP (current_buffer->selective_display))
4940 coding->mode |= CODING_MODE_SELECTIVE_DISPLAY;
4941 }
4942
4943 DEFUN ("write-region", Fwrite_region, Swrite_region, 3, 7,
4944 "r\nFWrite region to file: \ni\ni\ni\np",
4945 doc: /* Write current region into specified file.
4946 When called from a program, requires three arguments:
4947 START, END and FILENAME. START and END are normally buffer positions
4948 specifying the part of the buffer to write.
4949 If START is nil, that means to use the entire buffer contents.
4950 If START is a string, then output that string to the file
4951 instead of any buffer contents; END is ignored.
4952
4953 Optional fourth argument APPEND if non-nil means
4954 append to existing file contents (if any). If it is an integer,
4955 seek to that offset in the file before writing.
4956 Optional fifth argument VISIT, if t or a string, means
4957 set the last-save-file-modtime of buffer to this file's modtime
4958 and mark buffer not modified.
4959 If VISIT is a string, it is a second file name;
4960 the output goes to FILENAME, but the buffer is marked as visiting VISIT.
4961 VISIT is also the file name to lock and unlock for clash detection.
4962 If VISIT is neither t nor nil nor a string,
4963 that means do not display the \"Wrote file\" message.
4964 The optional sixth arg LOCKNAME, if non-nil, specifies the name to
4965 use for locking and unlocking, overriding FILENAME and VISIT.
4966 The optional seventh arg MUSTBENEW, if non-nil, insists on a check
4967 for an existing file with the same name. If MUSTBENEW is `excl',
4968 that means to get an error if the file already exists; never overwrite.
4969 If MUSTBENEW is neither nil nor `excl', that means ask for
4970 confirmation before overwriting, but do go ahead and overwrite the file
4971 if the user confirms.
4972
4973 This does code conversion according to the value of
4974 `coding-system-for-write', `buffer-file-coding-system', or
4975 `file-coding-system-alist', and sets the variable
4976 `last-coding-system-used' to the coding system actually used. */)
4977 (start, end, filename, append, visit, lockname, mustbenew)
4978 Lisp_Object start, end, filename, append, visit, lockname, mustbenew;
4979 {
4980 register int desc;
4981 int failure;
4982 int save_errno = 0;
4983 const unsigned char *fn;
4984 struct stat st;
4985 int tem;
4986 int count = SPECPDL_INDEX ();
4987 int count1;
4988 #ifdef VMS
4989 unsigned char *fname = 0; /* If non-0, original filename (must rename) */
4990 #endif /* VMS */
4991 Lisp_Object handler;
4992 Lisp_Object visit_file;
4993 Lisp_Object annotations;
4994 Lisp_Object encoded_filename;
4995 int visiting = (EQ (visit, Qt) || STRINGP (visit));
4996 int quietly = !NILP (visit);
4997 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
4998 struct buffer *given_buffer;
4999 #ifdef DOS_NT
5000 int buffer_file_type = O_BINARY;
5001 #endif /* DOS_NT */
5002 struct coding_system coding;
5003
5004 if (current_buffer->base_buffer && visiting)
5005 error ("Cannot do file visiting in an indirect buffer");
5006
5007 if (!NILP (start) && !STRINGP (start))
5008 validate_region (&start, &end);
5009
5010 GCPRO5 (start, filename, visit, visit_file, lockname);
5011
5012 filename = Fexpand_file_name (filename, Qnil);
5013
5014 if (!NILP (mustbenew) && !EQ (mustbenew, Qexcl))
5015 barf_or_query_if_file_exists (filename, "overwrite", 1, 0, 1);
5016
5017 if (STRINGP (visit))
5018 visit_file = Fexpand_file_name (visit, Qnil);
5019 else
5020 visit_file = filename;
5021
5022 if (NILP (lockname))
5023 lockname = visit_file;
5024
5025 annotations = Qnil;
5026
5027 /* If the file name has special constructs in it,
5028 call the corresponding file handler. */
5029 handler = Ffind_file_name_handler (filename, Qwrite_region);
5030 /* If FILENAME has no handler, see if VISIT has one. */
5031 if (NILP (handler) && STRINGP (visit))
5032 handler = Ffind_file_name_handler (visit, Qwrite_region);
5033
5034 if (!NILP (handler))
5035 {
5036 Lisp_Object val;
5037 val = call6 (handler, Qwrite_region, start, end,
5038 filename, append, visit);
5039
5040 if (visiting)
5041 {
5042 SAVE_MODIFF = MODIFF;
5043 XSETFASTINT (current_buffer->save_length, Z - BEG);
5044 current_buffer->filename = visit_file;
5045 }
5046 UNGCPRO;
5047 return val;
5048 }
5049
5050 record_unwind_protect (save_restriction_restore, save_restriction_save ());
5051
5052 /* Special kludge to simplify auto-saving. */
5053 if (NILP (start))
5054 {
5055 XSETFASTINT (start, BEG);
5056 XSETFASTINT (end, Z);
5057 Fwiden ();
5058 }
5059
5060 record_unwind_protect (build_annotations_unwind, Fcurrent_buffer ());
5061 count1 = SPECPDL_INDEX ();
5062
5063 given_buffer = current_buffer;
5064
5065 if (!STRINGP (start))
5066 {
5067 annotations = build_annotations (start, end);
5068
5069 if (current_buffer != given_buffer)
5070 {
5071 XSETFASTINT (start, BEGV);
5072 XSETFASTINT (end, ZV);
5073 }
5074 }
5075
5076 UNGCPRO;
5077
5078 GCPRO5 (start, filename, annotations, visit_file, lockname);
5079
5080 /* Decide the coding-system to encode the data with.
5081 We used to make this choice before calling build_annotations, but that
5082 leads to problems when a write-annotate-function takes care of
5083 unsavable chars (as was the case with X-Symbol). */
5084 choose_write_coding_system (start, end, filename,
5085 append, visit, lockname, &coding);
5086 Vlast_coding_system_used = coding.symbol;
5087
5088 given_buffer = current_buffer;
5089 if (! STRINGP (start))
5090 {
5091 annotations = build_annotations_2 (start, end,
5092 coding.pre_write_conversion, annotations);
5093 if (current_buffer != given_buffer)
5094 {
5095 XSETFASTINT (start, BEGV);
5096 XSETFASTINT (end, ZV);
5097 }
5098 }
5099
5100 #ifdef CLASH_DETECTION
5101 if (!auto_saving)
5102 {
5103 #if 0 /* This causes trouble for GNUS. */
5104 /* If we've locked this file for some other buffer,
5105 query before proceeding. */
5106 if (!visiting && EQ (Ffile_locked_p (lockname), Qt))
5107 call2 (intern ("ask-user-about-lock"), filename, Vuser_login_name);
5108 #endif
5109
5110 lock_file (lockname);
5111 }
5112 #endif /* CLASH_DETECTION */
5113
5114 encoded_filename = ENCODE_FILE (filename);
5115
5116 fn = SDATA (encoded_filename);
5117 desc = -1;
5118 if (!NILP (append))
5119 #ifdef DOS_NT
5120 desc = emacs_open (fn, O_WRONLY | buffer_file_type, 0);
5121 #else /* not DOS_NT */
5122 desc = emacs_open (fn, O_WRONLY, 0);
5123 #endif /* not DOS_NT */
5124
5125 if (desc < 0 && (NILP (append) || errno == ENOENT))
5126 #ifdef VMS
5127 if (auto_saving) /* Overwrite any previous version of autosave file */
5128 {
5129 vms_truncate (fn); /* if fn exists, truncate to zero length */
5130 desc = emacs_open (fn, O_RDWR, 0);
5131 if (desc < 0)
5132 desc = creat_copy_attrs (STRINGP (current_buffer->filename)
5133 ? SDATA (current_buffer->filename) : 0,
5134 fn);
5135 }
5136 else /* Write to temporary name and rename if no errors */
5137 {
5138 Lisp_Object temp_name;
5139 temp_name = Ffile_name_directory (filename);
5140
5141 if (!NILP (temp_name))
5142 {
5143 temp_name = Fmake_temp_name (concat2 (temp_name,
5144 build_string ("$$SAVE$$")));
5145 fname = SDATA (filename);
5146 fn = SDATA (temp_name);
5147 desc = creat_copy_attrs (fname, fn);
5148 if (desc < 0)
5149 {
5150 /* If we can't open the temporary file, try creating a new
5151 version of the original file. VMS "creat" creates a
5152 new version rather than truncating an existing file. */
5153 fn = fname;
5154 fname = 0;
5155 desc = creat (fn, 0666);
5156 #if 0 /* This can clobber an existing file and fail to replace it,
5157 if the user runs out of space. */
5158 if (desc < 0)
5159 {
5160 /* We can't make a new version;
5161 try to truncate and rewrite existing version if any. */
5162 vms_truncate (fn);
5163 desc = emacs_open (fn, O_RDWR, 0);
5164 }
5165 #endif
5166 }
5167 }
5168 else
5169 desc = creat (fn, 0666);
5170 }
5171 #else /* not VMS */
5172 #ifdef DOS_NT
5173 desc = emacs_open (fn,
5174 O_WRONLY | O_CREAT | buffer_file_type
5175 | (EQ (mustbenew, Qexcl) ? O_EXCL : O_TRUNC),
5176 S_IREAD | S_IWRITE);
5177 #else /* not DOS_NT */
5178 desc = emacs_open (fn, O_WRONLY | O_TRUNC | O_CREAT
5179 | (EQ (mustbenew, Qexcl) ? O_EXCL : 0),
5180 auto_saving ? auto_save_mode_bits : 0666);
5181 #endif /* not DOS_NT */
5182 #endif /* not VMS */
5183
5184 if (desc < 0)
5185 {
5186 #ifdef CLASH_DETECTION
5187 save_errno = errno;
5188 if (!auto_saving) unlock_file (lockname);
5189 errno = save_errno;
5190 #endif /* CLASH_DETECTION */
5191 UNGCPRO;
5192 report_file_error ("Opening output file", Fcons (filename, Qnil));
5193 }
5194
5195 record_unwind_protect (close_file_unwind, make_number (desc));
5196
5197 if (!NILP (append) && !NILP (Ffile_regular_p (filename)))
5198 {
5199 long ret;
5200
5201 if (NUMBERP (append))
5202 ret = lseek (desc, XINT (append), 1);
5203 else
5204 ret = lseek (desc, 0, 2);
5205 if (ret < 0)
5206 {
5207 #ifdef CLASH_DETECTION
5208 if (!auto_saving) unlock_file (lockname);
5209 #endif /* CLASH_DETECTION */
5210 UNGCPRO;
5211 report_file_error ("Lseek error", Fcons (filename, Qnil));
5212 }
5213 }
5214
5215 UNGCPRO;
5216
5217 #ifdef VMS
5218 /*
5219 * Kludge Warning: The VMS C RTL likes to insert carriage returns
5220 * if we do writes that don't end with a carriage return. Furthermore
5221 * it cannot handle writes of more then 16K. The modified
5222 * version of "sys_write" in SYSDEP.C (see comment there) copes with
5223 * this EXCEPT for the last record (iff it doesn't end with a carriage
5224 * return). This implies that if your buffer doesn't end with a carriage
5225 * return, you get one free... tough. However it also means that if
5226 * we make two calls to sys_write (a la the following code) you can
5227 * get one at the gap as well. The easiest way to fix this (honest)
5228 * is to move the gap to the next newline (or the end of the buffer).
5229 * Thus this change.
5230 *
5231 * Yech!
5232 */
5233 if (GPT > BEG && GPT_ADDR[-1] != '\n')
5234 move_gap (find_next_newline (GPT, 1));
5235 #else
5236 /* Whether VMS or not, we must move the gap to the next of newline
5237 when we must put designation sequences at beginning of line. */
5238 if (INTEGERP (start)
5239 && coding.type == coding_type_iso2022
5240 && coding.flags & CODING_FLAG_ISO_DESIGNATE_AT_BOL
5241 && GPT > BEG && GPT_ADDR[-1] != '\n')
5242 {
5243 int opoint = PT, opoint_byte = PT_BYTE;
5244 scan_newline (PT, PT_BYTE, ZV, ZV_BYTE, 1, 0);
5245 move_gap_both (PT, PT_BYTE);
5246 SET_PT_BOTH (opoint, opoint_byte);
5247 }
5248 #endif
5249
5250 failure = 0;
5251 immediate_quit = 1;
5252
5253 if (STRINGP (start))
5254 {
5255 failure = 0 > a_write (desc, start, 0, SCHARS (start),
5256 &annotations, &coding);
5257 save_errno = errno;
5258 }
5259 else if (XINT (start) != XINT (end))
5260 {
5261 tem = CHAR_TO_BYTE (XINT (start));
5262
5263 if (XINT (start) < GPT)
5264 {
5265 failure = 0 > a_write (desc, Qnil, XINT (start),
5266 min (GPT, XINT (end)) - XINT (start),
5267 &annotations, &coding);
5268 save_errno = errno;
5269 }
5270
5271 if (XINT (end) > GPT && !failure)
5272 {
5273 tem = max (XINT (start), GPT);
5274 failure = 0 > a_write (desc, Qnil, tem , XINT (end) - tem,
5275 &annotations, &coding);
5276 save_errno = errno;
5277 }
5278 }
5279 else
5280 {
5281 /* If file was empty, still need to write the annotations */
5282 coding.mode |= CODING_MODE_LAST_BLOCK;
5283 failure = 0 > a_write (desc, Qnil, XINT (end), 0, &annotations, &coding);
5284 save_errno = errno;
5285 }
5286
5287 if (CODING_REQUIRE_FLUSHING (&coding)
5288 && !(coding.mode & CODING_MODE_LAST_BLOCK)
5289 && ! failure)
5290 {
5291 /* We have to flush out a data. */
5292 coding.mode |= CODING_MODE_LAST_BLOCK;
5293 failure = 0 > e_write (desc, Qnil, 0, 0, &coding);
5294 save_errno = errno;
5295 }
5296
5297 immediate_quit = 0;
5298
5299 #ifdef HAVE_FSYNC
5300 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
5301 Disk full in NFS may be reported here. */
5302 /* mib says that closing the file will try to write as fast as NFS can do
5303 it, and that means the fsync here is not crucial for autosave files. */
5304 if (!auto_saving && !write_region_inhibit_fsync && fsync (desc) < 0)
5305 {
5306 /* If fsync fails with EINTR, don't treat that as serious. */
5307 if (errno != EINTR)
5308 failure = 1, save_errno = errno;
5309 }
5310 #endif
5311
5312 /* Spurious "file has changed on disk" warnings have been
5313 observed on Suns as well.
5314 It seems that `close' can change the modtime, under nfs.
5315
5316 (This has supposedly been fixed in Sunos 4,
5317 but who knows about all the other machines with NFS?) */
5318 #if 0
5319
5320 /* On VMS and APOLLO, must do the stat after the close
5321 since closing changes the modtime. */
5322 #ifndef VMS
5323 #ifndef APOLLO
5324 /* Recall that #if defined does not work on VMS. */
5325 #define FOO
5326 fstat (desc, &st);
5327 #endif
5328 #endif
5329 #endif
5330
5331 /* NFS can report a write failure now. */
5332 if (emacs_close (desc) < 0)
5333 failure = 1, save_errno = errno;
5334
5335 #ifdef VMS
5336 /* If we wrote to a temporary name and had no errors, rename to real name. */
5337 if (fname)
5338 {
5339 if (!failure)
5340 failure = (rename (fn, fname) != 0), save_errno = errno;
5341 fn = fname;
5342 }
5343 #endif /* VMS */
5344
5345 #ifndef FOO
5346 stat (fn, &st);
5347 #endif
5348 /* Discard the unwind protect for close_file_unwind. */
5349 specpdl_ptr = specpdl + count1;
5350 /* Restore the original current buffer. */
5351 visit_file = unbind_to (count, visit_file);
5352
5353 #ifdef CLASH_DETECTION
5354 if (!auto_saving)
5355 unlock_file (lockname);
5356 #endif /* CLASH_DETECTION */
5357
5358 /* Do this before reporting IO error
5359 to avoid a "file has changed on disk" warning on
5360 next attempt to save. */
5361 if (visiting)
5362 current_buffer->modtime = st.st_mtime;
5363
5364 if (failure)
5365 error ("IO error writing %s: %s", SDATA (filename),
5366 emacs_strerror (save_errno));
5367
5368 if (visiting)
5369 {
5370 SAVE_MODIFF = MODIFF;
5371 XSETFASTINT (current_buffer->save_length, Z - BEG);
5372 current_buffer->filename = visit_file;
5373 update_mode_lines++;
5374 }
5375 else if (quietly)
5376 {
5377 if (auto_saving
5378 && ! NILP (Fstring_equal (current_buffer->filename,
5379 current_buffer->auto_save_file_name)))
5380 SAVE_MODIFF = MODIFF;
5381
5382 return Qnil;
5383 }
5384
5385 if (!auto_saving)
5386 message_with_string ((INTEGERP (append)
5387 ? "Updated %s"
5388 : ! NILP (append)
5389 ? "Added to %s"
5390 : "Wrote %s"),
5391 visit_file, 1);
5392
5393 return Qnil;
5394 }
5395 \f
5396 Lisp_Object merge ();
5397
5398 DEFUN ("car-less-than-car", Fcar_less_than_car, Scar_less_than_car, 2, 2, 0,
5399 doc: /* Return t if (car A) is numerically less than (car B). */)
5400 (a, b)
5401 Lisp_Object a, b;
5402 {
5403 return Flss (Fcar (a), Fcar (b));
5404 }
5405
5406 /* Build the complete list of annotations appropriate for writing out
5407 the text between START and END, by calling all the functions in
5408 write-region-annotate-functions and merging the lists they return.
5409 If one of these functions switches to a different buffer, we assume
5410 that buffer contains altered text. Therefore, the caller must
5411 make sure to restore the current buffer in all cases,
5412 as save-excursion would do. */
5413
5414 static Lisp_Object
5415 build_annotations (start, end)
5416 Lisp_Object start, end;
5417 {
5418 Lisp_Object annotations;
5419 Lisp_Object p, res;
5420 struct gcpro gcpro1, gcpro2;
5421 Lisp_Object original_buffer;
5422 int i, used_global = 0;
5423
5424 XSETBUFFER (original_buffer, current_buffer);
5425
5426 annotations = Qnil;
5427 p = Vwrite_region_annotate_functions;
5428 GCPRO2 (annotations, p);
5429 while (CONSP (p))
5430 {
5431 struct buffer *given_buffer = current_buffer;
5432 if (EQ (Qt, XCAR (p)) && !used_global)
5433 { /* Use the global value of the hook. */
5434 Lisp_Object arg[2];
5435 used_global = 1;
5436 arg[0] = Fdefault_value (Qwrite_region_annotate_functions);
5437 arg[1] = XCDR (p);
5438 p = Fappend (2, arg);
5439 continue;
5440 }
5441 Vwrite_region_annotations_so_far = annotations;
5442 res = call2 (XCAR (p), start, end);
5443 /* If the function makes a different buffer current,
5444 assume that means this buffer contains altered text to be output.
5445 Reset START and END from the buffer bounds
5446 and discard all previous annotations because they should have
5447 been dealt with by this function. */
5448 if (current_buffer != given_buffer)
5449 {
5450 XSETFASTINT (start, BEGV);
5451 XSETFASTINT (end, ZV);
5452 annotations = Qnil;
5453 }
5454 Flength (res); /* Check basic validity of return value */
5455 annotations = merge (annotations, res, Qcar_less_than_car);
5456 p = XCDR (p);
5457 }
5458
5459 /* Now do the same for annotation functions implied by the file-format */
5460 if (auto_saving && (!EQ (current_buffer->auto_save_file_format, Qt)))
5461 p = current_buffer->auto_save_file_format;
5462 else
5463 p = current_buffer->file_format;
5464 for (i = 0; CONSP (p); p = XCDR (p), ++i)
5465 {
5466 struct buffer *given_buffer = current_buffer;
5467
5468 Vwrite_region_annotations_so_far = annotations;
5469
5470 /* Value is either a list of annotations or nil if the function
5471 has written annotations to a temporary buffer, which is now
5472 current. */
5473 res = call5 (Qformat_annotate_function, XCAR (p), start, end,
5474 original_buffer, make_number (i));
5475 if (current_buffer != given_buffer)
5476 {
5477 XSETFASTINT (start, BEGV);
5478 XSETFASTINT (end, ZV);
5479 annotations = Qnil;
5480 }
5481
5482 if (CONSP (res))
5483 annotations = merge (annotations, res, Qcar_less_than_car);
5484 }
5485
5486 UNGCPRO;
5487 return annotations;
5488 }
5489
5490 static Lisp_Object
5491 build_annotations_2 (start, end, pre_write_conversion, annotations)
5492 Lisp_Object start, end, pre_write_conversion, annotations;
5493 {
5494 struct gcpro gcpro1;
5495 Lisp_Object res;
5496
5497 GCPRO1 (annotations);
5498 /* At last, do the same for the function PRE_WRITE_CONVERSION
5499 implied by the current coding-system. */
5500 if (!NILP (pre_write_conversion))
5501 {
5502 struct buffer *given_buffer = current_buffer;
5503 Vwrite_region_annotations_so_far = annotations;
5504 res = call2 (pre_write_conversion, start, end);
5505 Flength (res);
5506 annotations = (current_buffer != given_buffer
5507 ? res
5508 : merge (annotations, res, Qcar_less_than_car));
5509 }
5510
5511 UNGCPRO;
5512 return annotations;
5513 }
5514 \f
5515 /* Write to descriptor DESC the NCHARS chars starting at POS of STRING.
5516 If STRING is nil, POS is the character position in the current buffer.
5517 Intersperse with them the annotations from *ANNOT
5518 which fall within the range of POS to POS + NCHARS,
5519 each at its appropriate position.
5520
5521 We modify *ANNOT by discarding elements as we use them up.
5522
5523 The return value is negative in case of system call failure. */
5524
5525 static int
5526 a_write (desc, string, pos, nchars, annot, coding)
5527 int desc;
5528 Lisp_Object string;
5529 register int nchars;
5530 int pos;
5531 Lisp_Object *annot;
5532 struct coding_system *coding;
5533 {
5534 Lisp_Object tem;
5535 int nextpos;
5536 int lastpos = pos + nchars;
5537
5538 while (NILP (*annot) || CONSP (*annot))
5539 {
5540 tem = Fcar_safe (Fcar (*annot));
5541 nextpos = pos - 1;
5542 if (INTEGERP (tem))
5543 nextpos = XFASTINT (tem);
5544
5545 /* If there are no more annotations in this range,
5546 output the rest of the range all at once. */
5547 if (! (nextpos >= pos && nextpos <= lastpos))
5548 return e_write (desc, string, pos, lastpos, coding);
5549
5550 /* Output buffer text up to the next annotation's position. */
5551 if (nextpos > pos)
5552 {
5553 if (0 > e_write (desc, string, pos, nextpos, coding))
5554 return -1;
5555 pos = nextpos;
5556 }
5557 /* Output the annotation. */
5558 tem = Fcdr (Fcar (*annot));
5559 if (STRINGP (tem))
5560 {
5561 if (0 > e_write (desc, tem, 0, SCHARS (tem), coding))
5562 return -1;
5563 }
5564 *annot = Fcdr (*annot);
5565 }
5566 return 0;
5567 }
5568
5569 #ifndef WRITE_BUF_SIZE
5570 #define WRITE_BUF_SIZE (16 * 1024)
5571 #endif
5572
5573 /* Write text in the range START and END into descriptor DESC,
5574 encoding them with coding system CODING. If STRING is nil, START
5575 and END are character positions of the current buffer, else they
5576 are indexes to the string STRING. */
5577
5578 static int
5579 e_write (desc, string, start, end, coding)
5580 int desc;
5581 Lisp_Object string;
5582 int start, end;
5583 struct coding_system *coding;
5584 {
5585 register char *addr;
5586 register int nbytes;
5587 char buf[WRITE_BUF_SIZE];
5588 int return_val = 0;
5589
5590 if (start >= end)
5591 coding->composing = COMPOSITION_DISABLED;
5592 if (coding->composing != COMPOSITION_DISABLED)
5593 coding_save_composition (coding, start, end, string);
5594
5595 if (STRINGP (string))
5596 {
5597 addr = SDATA (string);
5598 nbytes = SBYTES (string);
5599 coding->src_multibyte = STRING_MULTIBYTE (string);
5600 }
5601 else if (start < end)
5602 {
5603 /* It is assured that the gap is not in the range START and END-1. */
5604 addr = CHAR_POS_ADDR (start);
5605 nbytes = CHAR_TO_BYTE (end) - CHAR_TO_BYTE (start);
5606 coding->src_multibyte
5607 = !NILP (current_buffer->enable_multibyte_characters);
5608 }
5609 else
5610 {
5611 addr = "";
5612 nbytes = 0;
5613 coding->src_multibyte = 1;
5614 }
5615
5616 /* We used to have a code for handling selective display here. But,
5617 now it is handled within encode_coding. */
5618 while (1)
5619 {
5620 int result;
5621
5622 result = encode_coding (coding, addr, buf, nbytes, WRITE_BUF_SIZE);
5623 if (coding->produced > 0)
5624 {
5625 coding->produced -= emacs_write (desc, buf, coding->produced);
5626 if (coding->produced)
5627 {
5628 return_val = -1;
5629 break;
5630 }
5631 }
5632 nbytes -= coding->consumed;
5633 addr += coding->consumed;
5634 if (result == CODING_FINISH_INSUFFICIENT_SRC
5635 && nbytes > 0)
5636 {
5637 /* The source text ends by an incomplete multibyte form.
5638 There's no way other than write it out as is. */
5639 nbytes -= emacs_write (desc, addr, nbytes);
5640 if (nbytes)
5641 {
5642 return_val = -1;
5643 break;
5644 }
5645 }
5646 if (nbytes <= 0)
5647 break;
5648 start += coding->consumed_char;
5649 if (coding->cmp_data)
5650 coding_adjust_composition_offset (coding, start);
5651 }
5652
5653 if (coding->cmp_data)
5654 coding_free_composition_data (coding);
5655
5656 return return_val;
5657 }
5658 \f
5659 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime,
5660 Sverify_visited_file_modtime, 1, 1, 0,
5661 doc: /* Return t if last mod time of BUF's visited file matches what BUF records.
5662 This means that the file has not been changed since it was visited or saved.
5663 See Info node `(elisp)Modification Time' for more details. */)
5664 (buf)
5665 Lisp_Object buf;
5666 {
5667 struct buffer *b;
5668 struct stat st;
5669 Lisp_Object handler;
5670 Lisp_Object filename;
5671
5672 CHECK_BUFFER (buf);
5673 b = XBUFFER (buf);
5674
5675 if (!STRINGP (b->filename)) return Qt;
5676 if (b->modtime == 0) return Qt;
5677
5678 /* If the file name has special constructs in it,
5679 call the corresponding file handler. */
5680 handler = Ffind_file_name_handler (b->filename,
5681 Qverify_visited_file_modtime);
5682 if (!NILP (handler))
5683 return call2 (handler, Qverify_visited_file_modtime, buf);
5684
5685 filename = ENCODE_FILE (b->filename);
5686
5687 if (stat (SDATA (filename), &st) < 0)
5688 {
5689 /* If the file doesn't exist now and didn't exist before,
5690 we say that it isn't modified, provided the error is a tame one. */
5691 if (errno == ENOENT || errno == EACCES || errno == ENOTDIR)
5692 st.st_mtime = -1;
5693 else
5694 st.st_mtime = 0;
5695 }
5696 if (st.st_mtime == b->modtime
5697 /* If both are positive, accept them if they are off by one second. */
5698 || (st.st_mtime > 0 && b->modtime > 0
5699 && (st.st_mtime == b->modtime + 1
5700 || st.st_mtime == b->modtime - 1)))
5701 return Qt;
5702 return Qnil;
5703 }
5704
5705 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime,
5706 Sclear_visited_file_modtime, 0, 0, 0,
5707 doc: /* Clear out records of last mod time of visited file.
5708 Next attempt to save will certainly not complain of a discrepancy. */)
5709 ()
5710 {
5711 current_buffer->modtime = 0;
5712 return Qnil;
5713 }
5714
5715 DEFUN ("visited-file-modtime", Fvisited_file_modtime,
5716 Svisited_file_modtime, 0, 0, 0,
5717 doc: /* Return the current buffer's recorded visited file modification time.
5718 The value is a list of the form (HIGH LOW), like the time values
5719 that `file-attributes' returns. If the current buffer has no recorded
5720 file modification time, this function returns 0.
5721 See Info node `(elisp)Modification Time' for more details. */)
5722 ()
5723 {
5724 Lisp_Object tcons;
5725 tcons = long_to_cons ((unsigned long) current_buffer->modtime);
5726 if (CONSP (tcons))
5727 return list2 (XCAR (tcons), XCDR (tcons));
5728 return tcons;
5729 }
5730
5731 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime,
5732 Sset_visited_file_modtime, 0, 1, 0,
5733 doc: /* Update buffer's recorded modification time from the visited file's time.
5734 Useful if the buffer was not read from the file normally
5735 or if the file itself has been changed for some known benign reason.
5736 An argument specifies the modification time value to use
5737 \(instead of that of the visited file), in the form of a list
5738 \(HIGH . LOW) or (HIGH LOW). */)
5739 (time_list)
5740 Lisp_Object time_list;
5741 {
5742 if (!NILP (time_list))
5743 current_buffer->modtime = cons_to_long (time_list);
5744 else
5745 {
5746 register Lisp_Object filename;
5747 struct stat st;
5748 Lisp_Object handler;
5749
5750 filename = Fexpand_file_name (current_buffer->filename, Qnil);
5751
5752 /* If the file name has special constructs in it,
5753 call the corresponding file handler. */
5754 handler = Ffind_file_name_handler (filename, Qset_visited_file_modtime);
5755 if (!NILP (handler))
5756 /* The handler can find the file name the same way we did. */
5757 return call2 (handler, Qset_visited_file_modtime, Qnil);
5758
5759 filename = ENCODE_FILE (filename);
5760
5761 if (stat (SDATA (filename), &st) >= 0)
5762 current_buffer->modtime = st.st_mtime;
5763 }
5764
5765 return Qnil;
5766 }
5767 \f
5768 Lisp_Object
5769 auto_save_error (error)
5770 Lisp_Object error;
5771 {
5772 Lisp_Object args[3], msg;
5773 int i, nbytes;
5774 struct gcpro gcpro1;
5775 char *msgbuf;
5776 USE_SAFE_ALLOCA;
5777
5778 ring_bell ();
5779
5780 args[0] = build_string ("Auto-saving %s: %s");
5781 args[1] = current_buffer->name;
5782 args[2] = Ferror_message_string (error);
5783 msg = Fformat (3, args);
5784 GCPRO1 (msg);
5785 nbytes = SBYTES (msg);
5786 SAFE_ALLOCA (msgbuf, char *, nbytes);
5787 bcopy (SDATA (msg), msgbuf, nbytes);
5788
5789 for (i = 0; i < 3; ++i)
5790 {
5791 if (i == 0)
5792 message2 (msgbuf, nbytes, STRING_MULTIBYTE (msg));
5793 else
5794 message2_nolog (msgbuf, nbytes, STRING_MULTIBYTE (msg));
5795 Fsleep_for (make_number (1), Qnil);
5796 }
5797
5798 UNGCPRO;
5799 return Qnil;
5800 }
5801
5802 Lisp_Object
5803 auto_save_1 ()
5804 {
5805 struct stat st;
5806 Lisp_Object modes;
5807
5808 auto_save_mode_bits = 0666;
5809
5810 /* Get visited file's mode to become the auto save file's mode. */
5811 if (! NILP (current_buffer->filename))
5812 {
5813 if (stat (SDATA (current_buffer->filename), &st) >= 0)
5814 /* But make sure we can overwrite it later! */
5815 auto_save_mode_bits = st.st_mode | 0600;
5816 else if ((modes = Ffile_modes (current_buffer->filename),
5817 INTEGERP (modes)))
5818 /* Remote files don't cooperate with stat. */
5819 auto_save_mode_bits = XINT (modes) | 0600;
5820 }
5821
5822 return
5823 Fwrite_region (Qnil, Qnil,
5824 current_buffer->auto_save_file_name,
5825 Qnil, Qlambda, Qnil, Qnil);
5826 }
5827
5828 static Lisp_Object
5829 do_auto_save_unwind (arg) /* used as unwind-protect function */
5830 Lisp_Object arg;
5831 {
5832 FILE *stream = (FILE *) XSAVE_VALUE (arg)->pointer;
5833 auto_saving = 0;
5834 if (stream != NULL)
5835 fclose (stream);
5836 return Qnil;
5837 }
5838
5839 static Lisp_Object
5840 do_auto_save_unwind_1 (value) /* used as unwind-protect function */
5841 Lisp_Object value;
5842 {
5843 minibuffer_auto_raise = XINT (value);
5844 return Qnil;
5845 }
5846
5847 static Lisp_Object
5848 do_auto_save_make_dir (dir)
5849 Lisp_Object dir;
5850 {
5851 return call2 (Qmake_directory, dir, Qt);
5852 }
5853
5854 static Lisp_Object
5855 do_auto_save_eh (ignore)
5856 Lisp_Object ignore;
5857 {
5858 return Qnil;
5859 }
5860
5861 DEFUN ("do-auto-save", Fdo_auto_save, Sdo_auto_save, 0, 2, "",
5862 doc: /* Auto-save all buffers that need it.
5863 This is all buffers that have auto-saving enabled
5864 and are changed since last auto-saved.
5865 Auto-saving writes the buffer into a file
5866 so that your editing is not lost if the system crashes.
5867 This file is not the file you visited; that changes only when you save.
5868 Normally we run the normal hook `auto-save-hook' before saving.
5869
5870 A non-nil NO-MESSAGE argument means do not print any message if successful.
5871 A non-nil CURRENT-ONLY argument means save only current buffer. */)
5872 (no_message, current_only)
5873 Lisp_Object no_message, current_only;
5874 {
5875 struct buffer *old = current_buffer, *b;
5876 Lisp_Object tail, buf;
5877 int auto_saved = 0;
5878 int do_handled_files;
5879 Lisp_Object oquit;
5880 FILE *stream = NULL;
5881 int count = SPECPDL_INDEX ();
5882 int orig_minibuffer_auto_raise = minibuffer_auto_raise;
5883 int old_message_p = 0;
5884 struct gcpro gcpro1, gcpro2;
5885
5886 if (max_specpdl_size < specpdl_size + 40)
5887 max_specpdl_size = specpdl_size + 40;
5888
5889 if (minibuf_level)
5890 no_message = Qt;
5891
5892 if (NILP (no_message))
5893 {
5894 old_message_p = push_message ();
5895 record_unwind_protect (pop_message_unwind, Qnil);
5896 }
5897
5898 /* Ordinarily don't quit within this function,
5899 but don't make it impossible to quit (in case we get hung in I/O). */
5900 oquit = Vquit_flag;
5901 Vquit_flag = Qnil;
5902
5903 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
5904 point to non-strings reached from Vbuffer_alist. */
5905
5906 if (!NILP (Vrun_hooks))
5907 call1 (Vrun_hooks, intern ("auto-save-hook"));
5908
5909 if (STRINGP (Vauto_save_list_file_name))
5910 {
5911 Lisp_Object listfile;
5912
5913 listfile = Fexpand_file_name (Vauto_save_list_file_name, Qnil);
5914
5915 /* Don't try to create the directory when shutting down Emacs,
5916 because creating the directory might signal an error, and
5917 that would leave Emacs in a strange state. */
5918 if (!NILP (Vrun_hooks))
5919 {
5920 Lisp_Object dir;
5921 dir = Qnil;
5922 GCPRO2 (dir, listfile);
5923 dir = Ffile_name_directory (listfile);
5924 if (NILP (Ffile_directory_p (dir)))
5925 internal_condition_case_1 (do_auto_save_make_dir,
5926 dir, Fcons (Fcons (Qfile_error, Qnil), Qnil),
5927 do_auto_save_eh);
5928 UNGCPRO;
5929 }
5930
5931 stream = fopen (SDATA (listfile), "w");
5932 }
5933
5934 record_unwind_protect (do_auto_save_unwind,
5935 make_save_value (stream, 0));
5936 record_unwind_protect (do_auto_save_unwind_1,
5937 make_number (minibuffer_auto_raise));
5938 minibuffer_auto_raise = 0;
5939 auto_saving = 1;
5940
5941 /* On first pass, save all files that don't have handlers.
5942 On second pass, save all files that do have handlers.
5943
5944 If Emacs is crashing, the handlers may tweak what is causing
5945 Emacs to crash in the first place, and it would be a shame if
5946 Emacs failed to autosave perfectly ordinary files because it
5947 couldn't handle some ange-ftp'd file. */
5948
5949 for (do_handled_files = 0; do_handled_files < 2; do_handled_files++)
5950 for (tail = Vbuffer_alist; GC_CONSP (tail); tail = XCDR (tail))
5951 {
5952 buf = XCDR (XCAR (tail));
5953 b = XBUFFER (buf);
5954
5955 /* Record all the buffers that have auto save mode
5956 in the special file that lists them. For each of these buffers,
5957 Record visited name (if any) and auto save name. */
5958 if (STRINGP (b->auto_save_file_name)
5959 && stream != NULL && do_handled_files == 0)
5960 {
5961 if (!NILP (b->filename))
5962 {
5963 fwrite (SDATA (b->filename), 1,
5964 SBYTES (b->filename), stream);
5965 }
5966 putc ('\n', stream);
5967 fwrite (SDATA (b->auto_save_file_name), 1,
5968 SBYTES (b->auto_save_file_name), stream);
5969 putc ('\n', stream);
5970 }
5971
5972 if (!NILP (current_only)
5973 && b != current_buffer)
5974 continue;
5975
5976 /* Don't auto-save indirect buffers.
5977 The base buffer takes care of it. */
5978 if (b->base_buffer)
5979 continue;
5980
5981 /* Check for auto save enabled
5982 and file changed since last auto save
5983 and file changed since last real save. */
5984 if (STRINGP (b->auto_save_file_name)
5985 && BUF_SAVE_MODIFF (b) < BUF_MODIFF (b)
5986 && b->auto_save_modified < BUF_MODIFF (b)
5987 /* -1 means we've turned off autosaving for a while--see below. */
5988 && XINT (b->save_length) >= 0
5989 && (do_handled_files
5990 || NILP (Ffind_file_name_handler (b->auto_save_file_name,
5991 Qwrite_region))))
5992 {
5993 EMACS_TIME before_time, after_time;
5994
5995 EMACS_GET_TIME (before_time);
5996
5997 /* If we had a failure, don't try again for 20 minutes. */
5998 if (b->auto_save_failure_time >= 0
5999 && EMACS_SECS (before_time) - b->auto_save_failure_time < 1200)
6000 continue;
6001
6002 if ((XFASTINT (b->save_length) * 10
6003 > (BUF_Z (b) - BUF_BEG (b)) * 13)
6004 /* A short file is likely to change a large fraction;
6005 spare the user annoying messages. */
6006 && XFASTINT (b->save_length) > 5000
6007 /* These messages are frequent and annoying for `*mail*'. */
6008 && !EQ (b->filename, Qnil)
6009 && NILP (no_message))
6010 {
6011 /* It has shrunk too much; turn off auto-saving here. */
6012 minibuffer_auto_raise = orig_minibuffer_auto_raise;
6013 message_with_string ("Buffer %s has shrunk a lot; auto save disabled in that buffer until next real save",
6014 b->name, 1);
6015 minibuffer_auto_raise = 0;
6016 /* Turn off auto-saving until there's a real save,
6017 and prevent any more warnings. */
6018 XSETINT (b->save_length, -1);
6019 Fsleep_for (make_number (1), Qnil);
6020 continue;
6021 }
6022 set_buffer_internal (b);
6023 if (!auto_saved && NILP (no_message))
6024 message1 ("Auto-saving...");
6025 internal_condition_case (auto_save_1, Qt, auto_save_error);
6026 auto_saved++;
6027 b->auto_save_modified = BUF_MODIFF (b);
6028 XSETFASTINT (current_buffer->save_length, Z - BEG);
6029 set_buffer_internal (old);
6030
6031 EMACS_GET_TIME (after_time);
6032
6033 /* If auto-save took more than 60 seconds,
6034 assume it was an NFS failure that got a timeout. */
6035 if (EMACS_SECS (after_time) - EMACS_SECS (before_time) > 60)
6036 b->auto_save_failure_time = EMACS_SECS (after_time);
6037 }
6038 }
6039
6040 /* Prevent another auto save till enough input events come in. */
6041 record_auto_save ();
6042
6043 if (auto_saved && NILP (no_message))
6044 {
6045 if (old_message_p)
6046 {
6047 /* If we are going to restore an old message,
6048 give time to read ours. */
6049 sit_for (1, 0, 0, 0, 0);
6050 restore_message ();
6051 }
6052 else
6053 /* If we displayed a message and then restored a state
6054 with no message, leave a "done" message on the screen. */
6055 message1 ("Auto-saving...done");
6056 }
6057
6058 Vquit_flag = oquit;
6059
6060 /* This restores the message-stack status. */
6061 unbind_to (count, Qnil);
6062 return Qnil;
6063 }
6064
6065 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved,
6066 Sset_buffer_auto_saved, 0, 0, 0,
6067 doc: /* Mark current buffer as auto-saved with its current text.
6068 No auto-save file will be written until the buffer changes again. */)
6069 ()
6070 {
6071 current_buffer->auto_save_modified = MODIFF;
6072 XSETFASTINT (current_buffer->save_length, Z - BEG);
6073 current_buffer->auto_save_failure_time = -1;
6074 return Qnil;
6075 }
6076
6077 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure,
6078 Sclear_buffer_auto_save_failure, 0, 0, 0,
6079 doc: /* Clear any record of a recent auto-save failure in the current buffer. */)
6080 ()
6081 {
6082 current_buffer->auto_save_failure_time = -1;
6083 return Qnil;
6084 }
6085
6086 DEFUN ("recent-auto-save-p", Frecent_auto_save_p, Srecent_auto_save_p,
6087 0, 0, 0,
6088 doc: /* Return t if current buffer has been auto-saved recently.
6089 More precisely, if it has been auto-saved since last read from or saved
6090 in the visited file. If the buffer has no visited file,
6091 then any auto-save counts as "recent". */)
6092 ()
6093 {
6094 return (SAVE_MODIFF < current_buffer->auto_save_modified) ? Qt : Qnil;
6095 }
6096 \f
6097 /* Reading and completing file names */
6098 extern Lisp_Object Ffile_name_completion (), Ffile_name_all_completions ();
6099
6100 /* In the string VAL, change each $ to $$ and return the result. */
6101
6102 static Lisp_Object
6103 double_dollars (val)
6104 Lisp_Object val;
6105 {
6106 register const unsigned char *old;
6107 register unsigned char *new;
6108 register int n;
6109 int osize, count;
6110
6111 osize = SBYTES (val);
6112
6113 /* Count the number of $ characters. */
6114 for (n = osize, count = 0, old = SDATA (val); n > 0; n--)
6115 if (*old++ == '$') count++;
6116 if (count > 0)
6117 {
6118 old = SDATA (val);
6119 val = make_uninit_multibyte_string (SCHARS (val) + count,
6120 osize + count);
6121 new = SDATA (val);
6122 for (n = osize; n > 0; n--)
6123 if (*old != '$')
6124 *new++ = *old++;
6125 else
6126 {
6127 *new++ = '$';
6128 *new++ = '$';
6129 old++;
6130 }
6131 }
6132 return val;
6133 }
6134
6135 static Lisp_Object
6136 read_file_name_cleanup (arg)
6137 Lisp_Object arg;
6138 {
6139 return (current_buffer->directory = arg);
6140 }
6141
6142 DEFUN ("read-file-name-internal", Fread_file_name_internal, Sread_file_name_internal,
6143 3, 3, 0,
6144 doc: /* Internal subroutine for read-file-name. Do not call this. */)
6145 (string, dir, action)
6146 Lisp_Object string, dir, action;
6147 /* action is nil for complete, t for return list of completions,
6148 lambda for verify final value */
6149 {
6150 Lisp_Object name, specdir, realdir, val, orig_string;
6151 int changed;
6152 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
6153
6154 CHECK_STRING (string);
6155
6156 realdir = dir;
6157 name = string;
6158 orig_string = Qnil;
6159 specdir = Qnil;
6160 changed = 0;
6161 /* No need to protect ACTION--we only compare it with t and nil. */
6162 GCPRO5 (string, realdir, name, specdir, orig_string);
6163
6164 if (SCHARS (string) == 0)
6165 {
6166 if (EQ (action, Qlambda))
6167 {
6168 UNGCPRO;
6169 return Qnil;
6170 }
6171 }
6172 else
6173 {
6174 orig_string = string;
6175 string = Fsubstitute_in_file_name (string);
6176 changed = NILP (Fstring_equal (string, orig_string));
6177 name = Ffile_name_nondirectory (string);
6178 val = Ffile_name_directory (string);
6179 if (! NILP (val))
6180 realdir = Fexpand_file_name (val, realdir);
6181 }
6182
6183 if (NILP (action))
6184 {
6185 specdir = Ffile_name_directory (string);
6186 val = Ffile_name_completion (name, realdir);
6187 UNGCPRO;
6188 if (!STRINGP (val))
6189 {
6190 if (changed)
6191 return double_dollars (string);
6192 return val;
6193 }
6194
6195 if (!NILP (specdir))
6196 val = concat2 (specdir, val);
6197 #ifndef VMS
6198 return double_dollars (val);
6199 #else /* not VMS */
6200 return val;
6201 #endif /* not VMS */
6202 }
6203 UNGCPRO;
6204
6205 if (EQ (action, Qt))
6206 {
6207 Lisp_Object all = Ffile_name_all_completions (name, realdir);
6208 Lisp_Object comp;
6209 int count;
6210
6211 if (NILP (Vread_file_name_predicate)
6212 || EQ (Vread_file_name_predicate, Qfile_exists_p))
6213 return all;
6214
6215 #ifndef VMS
6216 if (EQ (Vread_file_name_predicate, Qfile_directory_p))
6217 {
6218 /* Brute-force speed up for directory checking:
6219 Discard strings which don't end in a slash. */
6220 for (comp = Qnil; CONSP (all); all = XCDR (all))
6221 {
6222 Lisp_Object tem = XCAR (all);
6223 int len;
6224 if (STRINGP (tem) &&
6225 (len = SCHARS (tem), len > 0) &&
6226 IS_DIRECTORY_SEP (SREF (tem, len-1)))
6227 comp = Fcons (tem, comp);
6228 }
6229 }
6230 else
6231 #endif
6232 {
6233 /* Must do it the hard (and slow) way. */
6234 GCPRO3 (all, comp, specdir);
6235 count = SPECPDL_INDEX ();
6236 record_unwind_protect (read_file_name_cleanup, current_buffer->directory);
6237 current_buffer->directory = realdir;
6238 for (comp = Qnil; CONSP (all); all = XCDR (all))
6239 if (!NILP (call1 (Vread_file_name_predicate, XCAR (all))))
6240 comp = Fcons (XCAR (all), comp);
6241 unbind_to (count, Qnil);
6242 UNGCPRO;
6243 }
6244 return Fnreverse (comp);
6245 }
6246
6247 /* Only other case actually used is ACTION = lambda */
6248 #ifdef VMS
6249 /* Supposedly this helps commands such as `cd' that read directory names,
6250 but can someone explain how it helps them? -- RMS */
6251 if (SCHARS (name) == 0)
6252 return Qt;
6253 #endif /* VMS */
6254 string = Fexpand_file_name (string, dir);
6255 if (!NILP (Vread_file_name_predicate))
6256 return call1 (Vread_file_name_predicate, string);
6257 return Ffile_exists_p (string);
6258 }
6259
6260 DEFUN ("next-read-file-uses-dialog-p", Fnext_read_file_uses_dialog_p,
6261 Snext_read_file_uses_dialog_p, 0, 0, 0,
6262 doc: /* Return t if a call to `read-file-name' will use a dialog.
6263 The return value is only relevant for a call to `read-file-name' that happens
6264 before any other event (mouse or keypress) is handeled. */)
6265 ()
6266 {
6267 #if defined (USE_MOTIF) || defined (HAVE_NTGUI) || defined (USE_GTK) || defined (HAVE_CARBON)
6268 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
6269 && use_dialog_box
6270 && use_file_dialog
6271 && have_menus_p ())
6272 return Qt;
6273 #endif
6274 return Qnil;
6275 }
6276
6277 DEFUN ("read-file-name", Fread_file_name, Sread_file_name, 1, 6, 0,
6278 doc: /* Read file name, prompting with PROMPT and completing in directory DIR.
6279 Value is not expanded---you must call `expand-file-name' yourself.
6280 Default name to DEFAULT-FILENAME if user exits the minibuffer with
6281 the same non-empty string that was inserted by this function.
6282 (If DEFAULT-FILENAME is omitted, the visited file name is used,
6283 except that if INITIAL is specified, that combined with DIR is used.)
6284 If the user exits with an empty minibuffer, this function returns
6285 an empty string. (This can only happen if the user erased the
6286 pre-inserted contents or if `insert-default-directory' is nil.)
6287 Fourth arg MUSTMATCH non-nil means require existing file's name.
6288 Non-nil and non-t means also require confirmation after completion.
6289 Fifth arg INITIAL specifies text to start with.
6290 If optional sixth arg PREDICATE is non-nil, possible completions and
6291 the resulting file name must satisfy (funcall PREDICATE NAME).
6292 DIR should be an absolute directory name. It defaults to the value of
6293 `default-directory'.
6294
6295 If this command was invoked with the mouse, use a file dialog box if
6296 `use-dialog-box' is non-nil, and the window system or X toolkit in use
6297 provides a file dialog box.
6298
6299 See also `read-file-name-completion-ignore-case'
6300 and `read-file-name-function'. */)
6301 (prompt, dir, default_filename, mustmatch, initial, predicate)
6302 Lisp_Object prompt, dir, default_filename, mustmatch, initial, predicate;
6303 {
6304 Lisp_Object val, insdef, tem;
6305 struct gcpro gcpro1, gcpro2;
6306 register char *homedir;
6307 Lisp_Object decoded_homedir;
6308 int replace_in_history = 0;
6309 int add_to_history = 0;
6310 int count;
6311
6312 if (NILP (dir))
6313 dir = current_buffer->directory;
6314 if (NILP (Ffile_name_absolute_p (dir)))
6315 dir = Fexpand_file_name (dir, Qnil);
6316 if (NILP (default_filename))
6317 default_filename
6318 = (!NILP (initial)
6319 ? Fexpand_file_name (initial, dir)
6320 : current_buffer->filename);
6321
6322 /* If dir starts with user's homedir, change that to ~. */
6323 homedir = (char *) egetenv ("HOME");
6324 #ifdef DOS_NT
6325 /* homedir can be NULL in temacs, since Vprocess_environment is not
6326 yet set up. We shouldn't crash in that case. */
6327 if (homedir != 0)
6328 {
6329 homedir = strcpy (alloca (strlen (homedir) + 1), homedir);
6330 CORRECT_DIR_SEPS (homedir);
6331 }
6332 #endif
6333 if (homedir != 0)
6334 decoded_homedir
6335 = DECODE_FILE (make_unibyte_string (homedir, strlen (homedir)));
6336 if (homedir != 0
6337 && STRINGP (dir)
6338 && !strncmp (SDATA (decoded_homedir), SDATA (dir),
6339 SBYTES (decoded_homedir))
6340 && IS_DIRECTORY_SEP (SREF (dir, SBYTES (decoded_homedir))))
6341 {
6342 dir = Fsubstring (dir, make_number (SCHARS (decoded_homedir)), Qnil);
6343 dir = concat2 (build_string ("~"), dir);
6344 }
6345 /* Likewise for default_filename. */
6346 if (homedir != 0
6347 && STRINGP (default_filename)
6348 && !strncmp (SDATA (decoded_homedir), SDATA (default_filename),
6349 SBYTES (decoded_homedir))
6350 && IS_DIRECTORY_SEP (SREF (default_filename, SBYTES (decoded_homedir))))
6351 {
6352 default_filename
6353 = Fsubstring (default_filename,
6354 make_number (SCHARS (decoded_homedir)), Qnil);
6355 default_filename = concat2 (build_string ("~"), default_filename);
6356 }
6357 if (!NILP (default_filename))
6358 {
6359 CHECK_STRING (default_filename);
6360 default_filename = double_dollars (default_filename);
6361 }
6362
6363 if (insert_default_directory && STRINGP (dir))
6364 {
6365 insdef = dir;
6366 if (!NILP (initial))
6367 {
6368 Lisp_Object args[2], pos;
6369
6370 args[0] = insdef;
6371 args[1] = initial;
6372 insdef = Fconcat (2, args);
6373 pos = make_number (SCHARS (double_dollars (dir)));
6374 insdef = Fcons (double_dollars (insdef), pos);
6375 }
6376 else
6377 insdef = double_dollars (insdef);
6378 }
6379 else if (STRINGP (initial))
6380 insdef = Fcons (double_dollars (initial), make_number (0));
6381 else
6382 insdef = Qnil;
6383
6384 if (!NILP (Vread_file_name_function))
6385 {
6386 Lisp_Object args[7];
6387
6388 GCPRO2 (insdef, default_filename);
6389 args[0] = Vread_file_name_function;
6390 args[1] = prompt;
6391 args[2] = dir;
6392 args[3] = default_filename;
6393 args[4] = mustmatch;
6394 args[5] = initial;
6395 args[6] = predicate;
6396 RETURN_UNGCPRO (Ffuncall (7, args));
6397 }
6398
6399 count = SPECPDL_INDEX ();
6400 specbind (intern ("completion-ignore-case"),
6401 read_file_name_completion_ignore_case ? Qt : Qnil);
6402 specbind (intern ("minibuffer-completing-file-name"), Qt);
6403 specbind (intern ("read-file-name-predicate"),
6404 (NILP (predicate) ? Qfile_exists_p : predicate));
6405
6406 GCPRO2 (insdef, default_filename);
6407
6408 #if defined (USE_MOTIF) || defined (HAVE_NTGUI) || defined (USE_GTK) || defined (HAVE_CARBON)
6409 if (! NILP (Fnext_read_file_uses_dialog_p ()))
6410 {
6411 /* If DIR contains a file name, split it. */
6412 Lisp_Object file;
6413 file = Ffile_name_nondirectory (dir);
6414 if (SCHARS (file) && NILP (default_filename))
6415 {
6416 default_filename = file;
6417 dir = Ffile_name_directory (dir);
6418 }
6419 if (!NILP(default_filename))
6420 default_filename = Fexpand_file_name (default_filename, dir);
6421 val = Fx_file_dialog (prompt, dir, default_filename, mustmatch,
6422 EQ (predicate, Qfile_directory_p) ? Qt : Qnil);
6423 add_to_history = 1;
6424 }
6425 else
6426 #endif
6427 val = Fcompleting_read (prompt, intern ("read-file-name-internal"),
6428 dir, mustmatch, insdef,
6429 Qfile_name_history, default_filename, Qnil);
6430
6431 tem = Fsymbol_value (Qfile_name_history);
6432 if (CONSP (tem) && EQ (XCAR (tem), val))
6433 replace_in_history = 1;
6434
6435 /* If Fcompleting_read returned the inserted default string itself
6436 (rather than a new string with the same contents),
6437 it has to mean that the user typed RET with the minibuffer empty.
6438 In that case, we really want to return ""
6439 so that commands such as set-visited-file-name can distinguish. */
6440 if (EQ (val, default_filename))
6441 {
6442 /* In this case, Fcompleting_read has not added an element
6443 to the history. Maybe we should. */
6444 if (! replace_in_history)
6445 add_to_history = 1;
6446
6447 val = empty_string;
6448 }
6449
6450 unbind_to (count, Qnil);
6451 UNGCPRO;
6452 if (NILP (val))
6453 error ("No file name specified");
6454
6455 tem = Fstring_equal (val, CONSP (insdef) ? XCAR (insdef) : insdef);
6456
6457 if (!NILP (tem) && !NILP (default_filename))
6458 val = default_filename;
6459 val = Fsubstitute_in_file_name (val);
6460
6461 if (replace_in_history)
6462 /* Replace what Fcompleting_read added to the history
6463 with what we will actually return. */
6464 {
6465 Lisp_Object val1 = double_dollars (val);
6466 tem = Fsymbol_value (Qfile_name_history);
6467 if (history_delete_duplicates)
6468 XSETCDR (tem, Fdelete (val1, XCDR(tem)));
6469 XSETCAR (tem, val1);
6470 }
6471 else if (add_to_history)
6472 {
6473 /* Add the value to the history--but not if it matches
6474 the last value already there. */
6475 Lisp_Object val1 = double_dollars (val);
6476 tem = Fsymbol_value (Qfile_name_history);
6477 if (! CONSP (tem) || NILP (Fequal (XCAR (tem), val1)))
6478 {
6479 if (history_delete_duplicates) tem = Fdelete (val1, tem);
6480 Fset (Qfile_name_history, Fcons (val1, tem));
6481 }
6482 }
6483
6484 return val;
6485 }
6486
6487 \f
6488 void
6489 init_fileio_once ()
6490 {
6491 /* Must be set before any path manipulation is performed. */
6492 XSETFASTINT (Vdirectory_sep_char, '/');
6493 }
6494
6495 \f
6496 void
6497 syms_of_fileio ()
6498 {
6499 Qoperations = intern ("operations");
6500 Qexpand_file_name = intern ("expand-file-name");
6501 Qsubstitute_in_file_name = intern ("substitute-in-file-name");
6502 Qdirectory_file_name = intern ("directory-file-name");
6503 Qfile_name_directory = intern ("file-name-directory");
6504 Qfile_name_nondirectory = intern ("file-name-nondirectory");
6505 Qunhandled_file_name_directory = intern ("unhandled-file-name-directory");
6506 Qfile_name_as_directory = intern ("file-name-as-directory");
6507 Qcopy_file = intern ("copy-file");
6508 Qmake_directory_internal = intern ("make-directory-internal");
6509 Qmake_directory = intern ("make-directory");
6510 Qdelete_directory = intern ("delete-directory");
6511 Qdelete_file = intern ("delete-file");
6512 Qrename_file = intern ("rename-file");
6513 Qadd_name_to_file = intern ("add-name-to-file");
6514 Qmake_symbolic_link = intern ("make-symbolic-link");
6515 Qfile_exists_p = intern ("file-exists-p");
6516 Qfile_executable_p = intern ("file-executable-p");
6517 Qfile_readable_p = intern ("file-readable-p");
6518 Qfile_writable_p = intern ("file-writable-p");
6519 Qfile_symlink_p = intern ("file-symlink-p");
6520 Qaccess_file = intern ("access-file");
6521 Qfile_directory_p = intern ("file-directory-p");
6522 Qfile_regular_p = intern ("file-regular-p");
6523 Qfile_accessible_directory_p = intern ("file-accessible-directory-p");
6524 Qfile_modes = intern ("file-modes");
6525 Qset_file_modes = intern ("set-file-modes");
6526 Qset_file_times = intern ("set-file-times");
6527 Qfile_newer_than_file_p = intern ("file-newer-than-file-p");
6528 Qinsert_file_contents = intern ("insert-file-contents");
6529 Qwrite_region = intern ("write-region");
6530 Qverify_visited_file_modtime = intern ("verify-visited-file-modtime");
6531 Qset_visited_file_modtime = intern ("set-visited-file-modtime");
6532 Qauto_save_coding = intern ("auto-save-coding");
6533
6534 staticpro (&Qoperations);
6535 staticpro (&Qexpand_file_name);
6536 staticpro (&Qsubstitute_in_file_name);
6537 staticpro (&Qdirectory_file_name);
6538 staticpro (&Qfile_name_directory);
6539 staticpro (&Qfile_name_nondirectory);
6540 staticpro (&Qunhandled_file_name_directory);
6541 staticpro (&Qfile_name_as_directory);
6542 staticpro (&Qcopy_file);
6543 staticpro (&Qmake_directory_internal);
6544 staticpro (&Qmake_directory);
6545 staticpro (&Qdelete_directory);
6546 staticpro (&Qdelete_file);
6547 staticpro (&Qrename_file);
6548 staticpro (&Qadd_name_to_file);
6549 staticpro (&Qmake_symbolic_link);
6550 staticpro (&Qfile_exists_p);
6551 staticpro (&Qfile_executable_p);
6552 staticpro (&Qfile_readable_p);
6553 staticpro (&Qfile_writable_p);
6554 staticpro (&Qaccess_file);
6555 staticpro (&Qfile_symlink_p);
6556 staticpro (&Qfile_directory_p);
6557 staticpro (&Qfile_regular_p);
6558 staticpro (&Qfile_accessible_directory_p);
6559 staticpro (&Qfile_modes);
6560 staticpro (&Qset_file_modes);
6561 staticpro (&Qset_file_times);
6562 staticpro (&Qfile_newer_than_file_p);
6563 staticpro (&Qinsert_file_contents);
6564 staticpro (&Qwrite_region);
6565 staticpro (&Qverify_visited_file_modtime);
6566 staticpro (&Qset_visited_file_modtime);
6567 staticpro (&Qauto_save_coding);
6568
6569 Qfile_name_history = intern ("file-name-history");
6570 Fset (Qfile_name_history, Qnil);
6571 staticpro (&Qfile_name_history);
6572
6573 Qfile_error = intern ("file-error");
6574 staticpro (&Qfile_error);
6575 Qfile_already_exists = intern ("file-already-exists");
6576 staticpro (&Qfile_already_exists);
6577 Qfile_date_error = intern ("file-date-error");
6578 staticpro (&Qfile_date_error);
6579 Qexcl = intern ("excl");
6580 staticpro (&Qexcl);
6581
6582 #ifdef DOS_NT
6583 Qfind_buffer_file_type = intern ("find-buffer-file-type");
6584 staticpro (&Qfind_buffer_file_type);
6585 #endif /* DOS_NT */
6586
6587 DEFVAR_LISP ("file-name-coding-system", &Vfile_name_coding_system,
6588 doc: /* *Coding system for encoding file names.
6589 If it is nil, `default-file-name-coding-system' (which see) is used. */);
6590 Vfile_name_coding_system = Qnil;
6591
6592 DEFVAR_LISP ("default-file-name-coding-system",
6593 &Vdefault_file_name_coding_system,
6594 doc: /* Default coding system for encoding file names.
6595 This variable is used only when `file-name-coding-system' is nil.
6596
6597 This variable is set/changed by the command `set-language-environment'.
6598 User should not set this variable manually,
6599 instead use `file-name-coding-system' to get a constant encoding
6600 of file names regardless of the current language environment. */);
6601 Vdefault_file_name_coding_system = Qnil;
6602
6603 Qformat_decode = intern ("format-decode");
6604 staticpro (&Qformat_decode);
6605 Qformat_annotate_function = intern ("format-annotate-function");
6606 staticpro (&Qformat_annotate_function);
6607 Qafter_insert_file_set_coding = intern ("after-insert-file-set-coding");
6608 staticpro (&Qafter_insert_file_set_coding);
6609
6610 Qcar_less_than_car = intern ("car-less-than-car");
6611 staticpro (&Qcar_less_than_car);
6612
6613 Fput (Qfile_error, Qerror_conditions,
6614 Fcons (Qfile_error, Fcons (Qerror, Qnil)));
6615 Fput (Qfile_error, Qerror_message,
6616 build_string ("File error"));
6617
6618 Fput (Qfile_already_exists, Qerror_conditions,
6619 Fcons (Qfile_already_exists,
6620 Fcons (Qfile_error, Fcons (Qerror, Qnil))));
6621 Fput (Qfile_already_exists, Qerror_message,
6622 build_string ("File already exists"));
6623
6624 Fput (Qfile_date_error, Qerror_conditions,
6625 Fcons (Qfile_date_error,
6626 Fcons (Qfile_error, Fcons (Qerror, Qnil))));
6627 Fput (Qfile_date_error, Qerror_message,
6628 build_string ("Cannot set file date"));
6629
6630 DEFVAR_LISP ("read-file-name-function", &Vread_file_name_function,
6631 doc: /* If this is non-nil, `read-file-name' does its work by calling this function. */);
6632 Vread_file_name_function = Qnil;
6633
6634 DEFVAR_LISP ("read-file-name-predicate", &Vread_file_name_predicate,
6635 doc: /* Current predicate used by `read-file-name-internal'. */);
6636 Vread_file_name_predicate = Qnil;
6637
6638 DEFVAR_BOOL ("read-file-name-completion-ignore-case", &read_file_name_completion_ignore_case,
6639 doc: /* *Non-nil means when reading a file name completion ignores case. */);
6640 #if defined VMS || defined DOS_NT || defined MAC_OS
6641 read_file_name_completion_ignore_case = 1;
6642 #else
6643 read_file_name_completion_ignore_case = 0;
6644 #endif
6645
6646 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory,
6647 doc: /* *Non-nil means when reading a filename start with default dir in minibuffer.
6648 If the initial minibuffer contents are non-empty, you can usually
6649 request a default filename by typing RETURN without editing. For some
6650 commands, exiting with an empty minibuffer has a special meaning,
6651 such as making the current buffer visit no file in the case of
6652 `set-visited-file-name'.
6653 If this variable is non-nil, the minibuffer contents are always
6654 initially non-empty and typing RETURN without editing will fetch the
6655 default name, if one is provided. Note however that this default name
6656 is not necessarily the name originally inserted in the minibuffer, if
6657 that is just the default directory.
6658 If this variable is nil, the minibuffer often starts out empty. In
6659 that case you may have to explicitly fetch the next history element to
6660 request the default name. */);
6661 insert_default_directory = 1;
6662
6663 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm,
6664 doc: /* *Non-nil means write new files with record format `stmlf'.
6665 nil means use format `var'. This variable is meaningful only on VMS. */);
6666 vms_stmlf_recfm = 0;
6667
6668 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char,
6669 doc: /* Directory separator character for built-in functions that return file names.
6670 The value is always ?/. Don't use this variable, just use `/'. */);
6671
6672 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist,
6673 doc: /* *Alist of elements (REGEXP . HANDLER) for file names handled specially.
6674 If a file name matches REGEXP, then all I/O on that file is done by calling
6675 HANDLER.
6676
6677 The first argument given to HANDLER is the name of the I/O primitive
6678 to be handled; the remaining arguments are the arguments that were
6679 passed to that primitive. For example, if you do
6680 (file-exists-p FILENAME)
6681 and FILENAME is handled by HANDLER, then HANDLER is called like this:
6682 (funcall HANDLER 'file-exists-p FILENAME)
6683 The function `find-file-name-handler' checks this list for a handler
6684 for its argument. */);
6685 Vfile_name_handler_alist = Qnil;
6686
6687 DEFVAR_LISP ("set-auto-coding-function",
6688 &Vset_auto_coding_function,
6689 doc: /* If non-nil, a function to call to decide a coding system of file.
6690 Two arguments are passed to this function: the file name
6691 and the length of a file contents following the point.
6692 This function should return a coding system to decode the file contents.
6693 It should check the file name against `auto-coding-alist'.
6694 If no coding system is decided, it should check a coding system
6695 specified in the heading lines with the format:
6696 -*- ... coding: CODING-SYSTEM; ... -*-
6697 or local variable spec of the tailing lines with `coding:' tag. */);
6698 Vset_auto_coding_function = Qnil;
6699
6700 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions,
6701 doc: /* A list of functions to be called at the end of `insert-file-contents'.
6702 Each is passed one argument, the number of characters inserted.
6703 It should return the new character count, and leave point the same.
6704 If `insert-file-contents' is intercepted by a handler from
6705 `file-name-handler-alist', that handler is responsible for calling the
6706 functions in `after-insert-file-functions' if appropriate. */);
6707 Vafter_insert_file_functions = Qnil;
6708
6709 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions,
6710 doc: /* A list of functions to be called at the start of `write-region'.
6711 Each is passed two arguments, START and END as for `write-region'.
6712 These are usually two numbers but not always; see the documentation
6713 for `write-region'. The function should return a list of pairs
6714 of the form (POSITION . STRING), consisting of strings to be effectively
6715 inserted at the specified positions of the file being written (1 means to
6716 insert before the first byte written). The POSITIONs must be sorted into
6717 increasing order. If there are several functions in the list, the several
6718 lists are merged destructively. Alternatively, the function can return
6719 with a different buffer current; in that case it should pay attention
6720 to the annotations returned by previous functions and listed in
6721 `write-region-annotations-so-far'.*/);
6722 Vwrite_region_annotate_functions = Qnil;
6723 staticpro (&Qwrite_region_annotate_functions);
6724 Qwrite_region_annotate_functions
6725 = intern ("write-region-annotate-functions");
6726
6727 DEFVAR_LISP ("write-region-annotations-so-far",
6728 &Vwrite_region_annotations_so_far,
6729 doc: /* When an annotation function is called, this holds the previous annotations.
6730 These are the annotations made by other annotation functions
6731 that were already called. See also `write-region-annotate-functions'. */);
6732 Vwrite_region_annotations_so_far = Qnil;
6733
6734 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers,
6735 doc: /* A list of file name handlers that temporarily should not be used.
6736 This applies only to the operation `inhibit-file-name-operation'. */);
6737 Vinhibit_file_name_handlers = Qnil;
6738
6739 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation,
6740 doc: /* The operation for which `inhibit-file-name-handlers' is applicable. */);
6741 Vinhibit_file_name_operation = Qnil;
6742
6743 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name,
6744 doc: /* File name in which we write a list of all auto save file names.
6745 This variable is initialized automatically from `auto-save-list-file-prefix'
6746 shortly after Emacs reads your `.emacs' file, if you have not yet given it
6747 a non-nil value. */);
6748 Vauto_save_list_file_name = Qnil;
6749
6750 #ifdef HAVE_FSYNC
6751 DEFVAR_BOOL ("write-region-inhibit-fsync", &write_region_inhibit_fsync,
6752 doc: /* *Non-nil means don't call fsync in `write-region'.
6753 This variable affects calls to `write-region' as well as save commands.
6754 A non-nil value may result in data loss! */);
6755 write_region_inhibit_fsync = 0;
6756 #endif
6757
6758 defsubr (&Sfind_file_name_handler);
6759 defsubr (&Sfile_name_directory);
6760 defsubr (&Sfile_name_nondirectory);
6761 defsubr (&Sunhandled_file_name_directory);
6762 defsubr (&Sfile_name_as_directory);
6763 defsubr (&Sdirectory_file_name);
6764 defsubr (&Smake_temp_name);
6765 defsubr (&Sexpand_file_name);
6766 defsubr (&Ssubstitute_in_file_name);
6767 defsubr (&Scopy_file);
6768 defsubr (&Smake_directory_internal);
6769 defsubr (&Sdelete_directory);
6770 defsubr (&Sdelete_file);
6771 defsubr (&Srename_file);
6772 defsubr (&Sadd_name_to_file);
6773 #ifdef S_IFLNK
6774 defsubr (&Smake_symbolic_link);
6775 #endif /* S_IFLNK */
6776 #ifdef VMS
6777 defsubr (&Sdefine_logical_name);
6778 #endif /* VMS */
6779 #ifdef HPUX_NET
6780 defsubr (&Ssysnetunam);
6781 #endif /* HPUX_NET */
6782 defsubr (&Sfile_name_absolute_p);
6783 defsubr (&Sfile_exists_p);
6784 defsubr (&Sfile_executable_p);
6785 defsubr (&Sfile_readable_p);
6786 defsubr (&Sfile_writable_p);
6787 defsubr (&Saccess_file);
6788 defsubr (&Sfile_symlink_p);
6789 defsubr (&Sfile_directory_p);
6790 defsubr (&Sfile_accessible_directory_p);
6791 defsubr (&Sfile_regular_p);
6792 defsubr (&Sfile_modes);
6793 defsubr (&Sset_file_modes);
6794 defsubr (&Sset_file_times);
6795 defsubr (&Sset_default_file_modes);
6796 defsubr (&Sdefault_file_modes);
6797 defsubr (&Sfile_newer_than_file_p);
6798 defsubr (&Sinsert_file_contents);
6799 defsubr (&Swrite_region);
6800 defsubr (&Scar_less_than_car);
6801 defsubr (&Sverify_visited_file_modtime);
6802 defsubr (&Sclear_visited_file_modtime);
6803 defsubr (&Svisited_file_modtime);
6804 defsubr (&Sset_visited_file_modtime);
6805 defsubr (&Sdo_auto_save);
6806 defsubr (&Sset_buffer_auto_saved);
6807 defsubr (&Sclear_buffer_auto_save_failure);
6808 defsubr (&Srecent_auto_save_p);
6809
6810 defsubr (&Sread_file_name_internal);
6811 defsubr (&Sread_file_name);
6812 defsubr (&Snext_read_file_uses_dialog_p);
6813
6814 #ifdef unix
6815 defsubr (&Sunix_sync);
6816 #endif
6817 }
6818
6819 /* arch-tag: 64ba3fd7-f844-4fb2-ba4b-427eb928786c
6820 (do not change this comment) */