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