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