(combine-run-hooks): New function.
[emacs.git] / src / fileio.c
blob726d3fca803a3104db4fea2472f9e6ea9f38b898
1 /* File IO for GNU Emacs.
2 Copyright (C) 1985,86,87,88,93,94,95,96,97,98,1999 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
9 any later version.
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
21 #define _GNU_SOURCE /* for euidaccess */
23 #include <config.h>
25 #if defined (USG5) || defined (BSD_SYSTEM) || defined (LINUX)
26 #include <fcntl.h>
27 #endif
29 #include <stdio.h>
30 #include <sys/types.h>
31 #include <sys/stat.h>
33 #ifdef HAVE_UNISTD_H
34 #include <unistd.h>
35 #endif
37 #if !defined (S_ISLNK) && defined (S_IFLNK)
38 # define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
39 #endif
41 #if !defined (S_ISFIFO) && defined (S_IFIFO)
42 # define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO)
43 #endif
45 #if !defined (S_ISREG) && defined (S_IFREG)
46 # define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
47 #endif
49 #ifdef VMS
50 #include "vms-pwd.h"
51 #else
52 #include <pwd.h>
53 #endif
55 #include <ctype.h>
57 #ifdef VMS
58 #include "vmsdir.h"
59 #include <perror.h>
60 #include <stddef.h>
61 #include <string.h>
62 #endif
64 #include <errno.h>
66 #ifndef vax11c
67 extern int errno;
68 #endif
70 #ifdef APOLLO
71 #include <sys/time.h>
72 #endif
74 #ifndef USG
75 #ifndef VMS
76 #ifndef BSD4_1
77 #ifndef WINDOWSNT
78 #define HAVE_FSYNC
79 #endif
80 #endif
81 #endif
82 #endif
84 #include "lisp.h"
85 #include "intervals.h"
86 #include "buffer.h"
87 #include "charset.h"
88 #include "coding.h"
89 #include "window.h"
91 #ifdef WINDOWSNT
92 #define NOMINMAX 1
93 #include <windows.h>
94 #include <stdlib.h>
95 #include <fcntl.h>
96 #endif /* not WINDOWSNT */
98 #ifdef MSDOS
99 #include "msdos.h"
100 #include <sys/param.h>
101 #if __DJGPP__ >= 2
102 #include <fcntl.h>
103 #include <string.h>
104 #endif
105 #endif
107 #ifdef DOS_NT
108 #define CORRECT_DIR_SEPS(s) \
109 do { if ('/' == DIRECTORY_SEP) dostounix_filename (s); \
110 else unixtodos_filename (s); \
111 } while (0)
112 /* On Windows, drive letters must be alphabetic - on DOS, the Netware
113 redirector allows the six letters between 'Z' and 'a' as well. */
114 #ifdef MSDOS
115 #define IS_DRIVE(x) ((x) >= 'A' && (x) <= 'z')
116 #endif
117 #ifdef WINDOWSNT
118 #define IS_DRIVE(x) isalpha (x)
119 #endif
120 /* Need to lower-case the drive letter, or else expanded
121 filenames will sometimes compare inequal, because
122 `expand-file-name' doesn't always down-case the drive letter. */
123 #define DRIVE_LETTER(x) (tolower (x))
124 #endif
126 #ifdef VMS
127 #include <file.h>
128 #include <rmsdef.h>
129 #include <fab.h>
130 #include <nam.h>
131 #endif
133 #include "systime.h"
135 #ifdef HPUX
136 #include <netio.h>
137 #ifndef HPUX8
138 #ifndef HPUX9
139 #include <errnet.h>
140 #endif
141 #endif
142 #endif
144 #include "commands.h"
145 extern int use_dialog_box;
147 #ifndef O_WRONLY
148 #define O_WRONLY 1
149 #endif
151 #ifndef O_RDONLY
152 #define O_RDONLY 0
153 #endif
155 #ifndef S_ISLNK
156 # define lstat stat
157 #endif
159 #define min(a, b) ((a) < (b) ? (a) : (b))
160 #define max(a, b) ((a) > (b) ? (a) : (b))
162 /* Nonzero during writing of auto-save files */
163 int auto_saving;
165 /* Set by auto_save_1 to mode of original file so Fwrite_region will create
166 a new file with the same mode as the original */
167 int auto_save_mode_bits;
169 /* Coding system for file names, or nil if none. */
170 Lisp_Object Vfile_name_coding_system;
172 /* Coding system for file names used only when
173 Vfile_name_coding_system is nil. */
174 Lisp_Object Vdefault_file_name_coding_system;
176 /* Alist of elements (REGEXP . HANDLER) for file names
177 whose I/O is done with a special handler. */
178 Lisp_Object Vfile_name_handler_alist;
180 /* Format for auto-save files */
181 Lisp_Object Vauto_save_file_format;
183 /* Lisp functions for translating file formats */
184 Lisp_Object Qformat_decode, Qformat_annotate_function;
186 /* Function to be called to decide a coding system of a reading file. */
187 Lisp_Object Vset_auto_coding_function;
189 /* Functions to be called to process text properties in inserted file. */
190 Lisp_Object Vafter_insert_file_functions;
192 /* Functions to be called to create text property annotations for file. */
193 Lisp_Object Vwrite_region_annotate_functions;
195 /* During build_annotations, each time an annotation function is called,
196 this holds the annotations made by the previous functions. */
197 Lisp_Object Vwrite_region_annotations_so_far;
199 /* File name in which we write a list of all our auto save files. */
200 Lisp_Object Vauto_save_list_file_name;
202 /* Nonzero means, when reading a filename in the minibuffer,
203 start out by inserting the default directory into the minibuffer. */
204 int insert_default_directory;
206 /* On VMS, nonzero means write new files with record format stmlf.
207 Zero means use var format. */
208 int vms_stmlf_recfm;
210 /* On NT, specifies the directory separator character, used (eg.) when
211 expanding file names. This can be bound to / or \. */
212 Lisp_Object Vdirectory_sep_char;
214 extern Lisp_Object Vuser_login_name;
216 #ifdef WINDOWSNT
217 extern Lisp_Object Vw32_get_true_file_attributes;
218 #endif
220 extern int minibuf_level;
222 extern int minibuffer_auto_raise;
224 /* These variables describe handlers that have "already" had a chance
225 to handle the current operation.
227 Vinhibit_file_name_handlers is a list of file name handlers.
228 Vinhibit_file_name_operation is the operation being handled.
229 If we try to handle that operation, we ignore those handlers. */
231 static Lisp_Object Vinhibit_file_name_handlers;
232 static Lisp_Object Vinhibit_file_name_operation;
234 Lisp_Object Qfile_error, Qfile_already_exists, Qfile_date_error;
235 Lisp_Object Qexcl;
236 Lisp_Object Qfile_name_history;
238 Lisp_Object Qcar_less_than_car;
240 static int a_write P_ ((int, Lisp_Object, int, int,
241 Lisp_Object *, struct coding_system *));
242 static int e_write P_ ((int, Lisp_Object, int, int, struct coding_system *));
245 void
246 report_file_error (string, data)
247 char *string;
248 Lisp_Object data;
250 Lisp_Object errstring;
251 int errorno = errno;
253 synchronize_system_messages_locale ();
254 errstring = code_convert_string_norecord (build_string (strerror (errorno)),
255 Vlocale_coding_system, 0);
257 while (1)
258 switch (errorno)
260 case EEXIST:
261 Fsignal (Qfile_already_exists, Fcons (errstring, data));
262 break;
263 default:
264 /* System error messages are capitalized. Downcase the initial
265 unless it is followed by a slash. */
266 if (XSTRING (errstring)->data[1] != '/')
267 XSTRING (errstring)->data[0] = DOWNCASE (XSTRING (errstring)->data[0]);
269 Fsignal (Qfile_error,
270 Fcons (build_string (string), Fcons (errstring, data)));
274 Lisp_Object
275 close_file_unwind (fd)
276 Lisp_Object fd;
278 emacs_close (XFASTINT (fd));
279 return Qnil;
282 /* Restore point, having saved it as a marker. */
284 static Lisp_Object
285 restore_point_unwind (location)
286 Lisp_Object location;
288 Fgoto_char (location);
289 Fset_marker (location, Qnil, Qnil);
290 return Qnil;
293 Lisp_Object Qexpand_file_name;
294 Lisp_Object Qsubstitute_in_file_name;
295 Lisp_Object Qdirectory_file_name;
296 Lisp_Object Qfile_name_directory;
297 Lisp_Object Qfile_name_nondirectory;
298 Lisp_Object Qunhandled_file_name_directory;
299 Lisp_Object Qfile_name_as_directory;
300 Lisp_Object Qcopy_file;
301 Lisp_Object Qmake_directory_internal;
302 Lisp_Object Qdelete_directory;
303 Lisp_Object Qdelete_file;
304 Lisp_Object Qrename_file;
305 Lisp_Object Qadd_name_to_file;
306 Lisp_Object Qmake_symbolic_link;
307 Lisp_Object Qfile_exists_p;
308 Lisp_Object Qfile_executable_p;
309 Lisp_Object Qfile_readable_p;
310 Lisp_Object Qfile_writable_p;
311 Lisp_Object Qfile_symlink_p;
312 Lisp_Object Qaccess_file;
313 Lisp_Object Qfile_directory_p;
314 Lisp_Object Qfile_regular_p;
315 Lisp_Object Qfile_accessible_directory_p;
316 Lisp_Object Qfile_modes;
317 Lisp_Object Qset_file_modes;
318 Lisp_Object Qfile_newer_than_file_p;
319 Lisp_Object Qinsert_file_contents;
320 Lisp_Object Qwrite_region;
321 Lisp_Object Qverify_visited_file_modtime;
322 Lisp_Object Qset_visited_file_modtime;
324 DEFUN ("find-file-name-handler", Ffind_file_name_handler, Sfind_file_name_handler, 2, 2, 0,
325 "Return FILENAME's handler function for OPERATION, if it has one.\n\
326 Otherwise, return nil.\n\
327 A file name is handled if one of the regular expressions in\n\
328 `file-name-handler-alist' matches it.\n\n\
329 If OPERATION equals `inhibit-file-name-operation', then we ignore\n\
330 any handlers that are members of `inhibit-file-name-handlers',\n\
331 but we still do run any other handlers. This lets handlers\n\
332 use the standard functions without calling themselves recursively.")
333 (filename, operation)
334 Lisp_Object filename, operation;
336 /* This function must not munge the match data. */
337 Lisp_Object chain, inhibited_handlers;
339 CHECK_STRING (filename, 0);
341 if (EQ (operation, Vinhibit_file_name_operation))
342 inhibited_handlers = Vinhibit_file_name_handlers;
343 else
344 inhibited_handlers = Qnil;
346 for (chain = Vfile_name_handler_alist; CONSP (chain);
347 chain = XCDR (chain))
349 Lisp_Object elt;
350 elt = XCAR (chain);
351 if (CONSP (elt))
353 Lisp_Object string;
354 string = XCAR (elt);
355 if (STRINGP (string) && fast_string_match (string, filename) >= 0)
357 Lisp_Object handler, tem;
359 handler = XCDR (elt);
360 tem = Fmemq (handler, inhibited_handlers);
361 if (NILP (tem))
362 return handler;
366 QUIT;
368 return Qnil;
371 DEFUN ("file-name-directory", Ffile_name_directory, Sfile_name_directory,
372 1, 1, 0,
373 "Return the directory component in file name FILENAME.\n\
374 Return nil if FILENAME does not include a directory.\n\
375 Otherwise return a directory spec.\n\
376 Given a Unix syntax file name, returns a string ending in slash;\n\
377 on VMS, perhaps instead a string ending in `:', `]' or `>'.")
378 (filename)
379 Lisp_Object filename;
381 register unsigned char *beg;
382 register unsigned char *p;
383 Lisp_Object handler;
385 CHECK_STRING (filename, 0);
387 /* If the file name has special constructs in it,
388 call the corresponding file handler. */
389 handler = Ffind_file_name_handler (filename, Qfile_name_directory);
390 if (!NILP (handler))
391 return call2 (handler, Qfile_name_directory, filename);
393 #ifdef FILE_SYSTEM_CASE
394 filename = FILE_SYSTEM_CASE (filename);
395 #endif
396 beg = XSTRING (filename)->data;
397 #ifdef DOS_NT
398 beg = strcpy (alloca (strlen (beg) + 1), beg);
399 #endif
400 p = beg + STRING_BYTES (XSTRING (filename));
402 while (p != beg && !IS_DIRECTORY_SEP (p[-1])
403 #ifdef VMS
404 && p[-1] != ':' && p[-1] != ']' && p[-1] != '>'
405 #endif /* VMS */
406 #ifdef DOS_NT
407 /* only recognise drive specifier at the beginning */
408 && !(p[-1] == ':'
409 /* handle the "/:d:foo" and "/:foo" cases correctly */
410 && ((p == beg + 2 && !IS_DIRECTORY_SEP (*beg))
411 || (p == beg + 4 && IS_DIRECTORY_SEP (*beg))))
412 #endif
413 ) p--;
415 if (p == beg)
416 return Qnil;
417 #ifdef DOS_NT
418 /* Expansion of "c:" to drive and default directory. */
419 if (p[-1] == ':')
421 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
422 unsigned char *res = alloca (MAXPATHLEN + 1);
423 unsigned char *r = res;
425 if (p == beg + 4 && IS_DIRECTORY_SEP (*beg) && beg[1] == ':')
427 strncpy (res, beg, 2);
428 beg += 2;
429 r += 2;
432 if (getdefdir (toupper (*beg) - 'A' + 1, r))
434 if (!IS_DIRECTORY_SEP (res[strlen (res) - 1]))
435 strcat (res, "/");
436 beg = res;
437 p = beg + strlen (beg);
440 CORRECT_DIR_SEPS (beg);
441 #endif /* DOS_NT */
443 if (STRING_MULTIBYTE (filename))
444 return make_string (beg, p - beg);
445 return make_unibyte_string (beg, p - beg);
448 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory,
449 Sfile_name_nondirectory, 1, 1, 0,
450 "Return file name FILENAME sans its directory.\n\
451 For example, in a Unix-syntax file name,\n\
452 this is everything after the last slash,\n\
453 or the entire name if it contains no slash.")
454 (filename)
455 Lisp_Object filename;
457 register unsigned char *beg, *p, *end;
458 Lisp_Object handler;
460 CHECK_STRING (filename, 0);
462 /* If the file name has special constructs in it,
463 call the corresponding file handler. */
464 handler = Ffind_file_name_handler (filename, Qfile_name_nondirectory);
465 if (!NILP (handler))
466 return call2 (handler, Qfile_name_nondirectory, filename);
468 beg = XSTRING (filename)->data;
469 end = p = beg + STRING_BYTES (XSTRING (filename));
471 while (p != beg && !IS_DIRECTORY_SEP (p[-1])
472 #ifdef VMS
473 && p[-1] != ':' && p[-1] != ']' && p[-1] != '>'
474 #endif /* VMS */
475 #ifdef DOS_NT
476 /* only recognise drive specifier at beginning */
477 && !(p[-1] == ':'
478 /* handle the "/:d:foo" case correctly */
479 && (p == beg + 2 || (p == beg + 4 && IS_DIRECTORY_SEP (*beg))))
480 #endif
482 p--;
484 if (STRING_MULTIBYTE (filename))
485 return make_string (p, end - p);
486 return make_unibyte_string (p, end - p);
489 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory,
490 Sunhandled_file_name_directory, 1, 1, 0,
491 "Return a directly usable directory name somehow associated with FILENAME.\n\
492 A `directly usable' directory name is one that may be used without the\n\
493 intervention of any file handler.\n\
494 If FILENAME is a directly usable file itself, return\n\
495 \(file-name-directory FILENAME).\n\
496 The `call-process' and `start-process' functions use this function to\n\
497 get a current directory to run processes in.")
498 (filename)
499 Lisp_Object filename;
501 Lisp_Object handler;
503 /* If the file name has special constructs in it,
504 call the corresponding file handler. */
505 handler = Ffind_file_name_handler (filename, Qunhandled_file_name_directory);
506 if (!NILP (handler))
507 return call2 (handler, Qunhandled_file_name_directory, filename);
509 return Ffile_name_directory (filename);
513 char *
514 file_name_as_directory (out, in)
515 char *out, *in;
517 int size = strlen (in) - 1;
519 strcpy (out, in);
521 if (size < 0)
523 out[0] = '.';
524 out[1] = '/';
525 out[2] = 0;
526 return out;
529 #ifdef VMS
530 /* Is it already a directory string? */
531 if (in[size] == ':' || in[size] == ']' || in[size] == '>')
532 return out;
533 /* Is it a VMS directory file name? If so, hack VMS syntax. */
534 else if (! index (in, '/')
535 && ((size > 3 && ! strcmp (&in[size - 3], ".DIR"))
536 || (size > 3 && ! strcmp (&in[size - 3], ".dir"))
537 || (size > 5 && (! strncmp (&in[size - 5], ".DIR", 4)
538 || ! strncmp (&in[size - 5], ".dir", 4))
539 && (in[size - 1] == '.' || in[size - 1] == ';')
540 && in[size] == '1')))
542 register char *p, *dot;
543 char brack;
545 /* x.dir -> [.x]
546 dir:x.dir --> dir:[x]
547 dir:[x]y.dir --> dir:[x.y] */
548 p = in + size;
549 while (p != in && *p != ':' && *p != '>' && *p != ']') p--;
550 if (p != in)
552 strncpy (out, in, p - in);
553 out[p - in] = '\0';
554 if (*p == ':')
556 brack = ']';
557 strcat (out, ":[");
559 else
561 brack = *p;
562 strcat (out, ".");
564 p++;
566 else
568 brack = ']';
569 strcpy (out, "[.");
571 dot = index (p, '.');
572 if (dot)
574 /* blindly remove any extension */
575 size = strlen (out) + (dot - p);
576 strncat (out, p, dot - p);
578 else
580 strcat (out, p);
581 size = strlen (out);
583 out[size++] = brack;
584 out[size] = '\0';
586 #else /* not VMS */
587 /* For Unix syntax, Append a slash if necessary */
588 if (!IS_DIRECTORY_SEP (out[size]))
590 out[size + 1] = DIRECTORY_SEP;
591 out[size + 2] = '\0';
593 #ifdef DOS_NT
594 CORRECT_DIR_SEPS (out);
595 #endif
596 #endif /* not VMS */
597 return out;
600 DEFUN ("file-name-as-directory", Ffile_name_as_directory,
601 Sfile_name_as_directory, 1, 1, 0,
602 "Return a string representing file FILENAME interpreted as a directory.\n\
603 This operation exists because a directory is also a file, but its name as\n\
604 a directory is different from its name as a file.\n\
605 The result can be used as the value of `default-directory'\n\
606 or passed as second argument to `expand-file-name'.\n\
607 For a Unix-syntax file name, just appends a slash.\n\
608 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
609 (file)
610 Lisp_Object file;
612 char *buf;
613 Lisp_Object handler;
615 CHECK_STRING (file, 0);
616 if (NILP (file))
617 return Qnil;
619 /* If the file name has special constructs in it,
620 call the corresponding file handler. */
621 handler = Ffind_file_name_handler (file, Qfile_name_as_directory);
622 if (!NILP (handler))
623 return call2 (handler, Qfile_name_as_directory, file);
625 buf = (char *) alloca (STRING_BYTES (XSTRING (file)) + 10);
626 return build_string (file_name_as_directory (buf, XSTRING (file)->data));
630 * Convert from directory name to filename.
631 * On VMS:
632 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
633 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
634 * On UNIX, it's simple: just make sure there isn't a terminating /
636 * Value is nonzero if the string output is different from the input.
640 directory_file_name (src, dst)
641 char *src, *dst;
643 long slen;
644 #ifdef VMS
645 long rlen;
646 char * ptr, * rptr;
647 char bracket;
648 struct FAB fab = cc$rms_fab;
649 struct NAM nam = cc$rms_nam;
650 char esa[NAM$C_MAXRSS];
651 #endif /* VMS */
653 slen = strlen (src);
654 #ifdef VMS
655 if (! index (src, '/')
656 && (src[slen - 1] == ']'
657 || src[slen - 1] == ':'
658 || src[slen - 1] == '>'))
660 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
661 fab.fab$l_fna = src;
662 fab.fab$b_fns = slen;
663 fab.fab$l_nam = &nam;
664 fab.fab$l_fop = FAB$M_NAM;
666 nam.nam$l_esa = esa;
667 nam.nam$b_ess = sizeof esa;
668 nam.nam$b_nop |= NAM$M_SYNCHK;
670 /* We call SYS$PARSE to handle such things as [--] for us. */
671 if (SYS$PARSE (&fab, 0, 0) == RMS$_NORMAL)
673 slen = nam.nam$b_esl;
674 if (esa[slen - 1] == ';' && esa[slen - 2] == '.')
675 slen -= 2;
676 esa[slen] = '\0';
677 src = esa;
679 if (src[slen - 1] != ']' && src[slen - 1] != '>')
681 /* what about when we have logical_name:???? */
682 if (src[slen - 1] == ':')
683 { /* Xlate logical name and see what we get */
684 ptr = strcpy (dst, src); /* upper case for getenv */
685 while (*ptr)
687 if ('a' <= *ptr && *ptr <= 'z')
688 *ptr -= 040;
689 ptr++;
691 dst[slen - 1] = 0; /* remove colon */
692 if (!(src = egetenv (dst)))
693 return 0;
694 /* should we jump to the beginning of this procedure?
695 Good points: allows us to use logical names that xlate
696 to Unix names,
697 Bad points: can be a problem if we just translated to a device
698 name...
699 For now, I'll punt and always expect VMS names, and hope for
700 the best! */
701 slen = strlen (src);
702 if (src[slen - 1] != ']' && src[slen - 1] != '>')
703 { /* no recursion here! */
704 strcpy (dst, src);
705 return 0;
708 else
709 { /* not a directory spec */
710 strcpy (dst, src);
711 return 0;
714 bracket = src[slen - 1];
716 /* If bracket is ']' or '>', bracket - 2 is the corresponding
717 opening bracket. */
718 ptr = index (src, bracket - 2);
719 if (ptr == 0)
720 { /* no opening bracket */
721 strcpy (dst, src);
722 return 0;
724 if (!(rptr = rindex (src, '.')))
725 rptr = ptr;
726 slen = rptr - src;
727 strncpy (dst, src, slen);
728 dst[slen] = '\0';
729 if (*rptr == '.')
731 dst[slen++] = bracket;
732 dst[slen] = '\0';
734 else
736 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
737 then translate the device and recurse. */
738 if (dst[slen - 1] == ':'
739 && dst[slen - 2] != ':' /* skip decnet nodes */
740 && strcmp (src + slen, "[000000]") == 0)
742 dst[slen - 1] = '\0';
743 if ((ptr = egetenv (dst))
744 && (rlen = strlen (ptr) - 1) > 0
745 && (ptr[rlen] == ']' || ptr[rlen] == '>')
746 && ptr[rlen - 1] == '.')
748 char * buf = (char *) alloca (strlen (ptr) + 1);
749 strcpy (buf, ptr);
750 buf[rlen - 1] = ']';
751 buf[rlen] = '\0';
752 return directory_file_name (buf, dst);
754 else
755 dst[slen - 1] = ':';
757 strcat (dst, "[000000]");
758 slen += 8;
760 rptr++;
761 rlen = strlen (rptr) - 1;
762 strncat (dst, rptr, rlen);
763 dst[slen + rlen] = '\0';
764 strcat (dst, ".DIR.1");
765 return 1;
767 #endif /* VMS */
768 /* Process as Unix format: just remove any final slash.
769 But leave "/" unchanged; do not change it to "". */
770 strcpy (dst, src);
771 #ifdef APOLLO
772 /* Handle // as root for apollo's. */
773 if ((slen > 2 && dst[slen - 1] == '/')
774 || (slen > 1 && dst[0] != '/' && dst[slen - 1] == '/'))
775 dst[slen - 1] = 0;
776 #else
777 if (slen > 1
778 && IS_DIRECTORY_SEP (dst[slen - 1])
779 #ifdef DOS_NT
780 && !IS_ANY_SEP (dst[slen - 2])
781 #endif
783 dst[slen - 1] = 0;
784 #endif
785 #ifdef DOS_NT
786 CORRECT_DIR_SEPS (dst);
787 #endif
788 return 1;
791 DEFUN ("directory-file-name", Fdirectory_file_name, Sdirectory_file_name,
792 1, 1, 0,
793 "Returns the file name of the directory named DIRECTORY.\n\
794 This is the name of the file that holds the data for the directory DIRECTORY.\n\
795 This operation exists because a directory is also a file, but its name as\n\
796 a directory is different from its name as a file.\n\
797 In Unix-syntax, this function just removes the final slash.\n\
798 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
799 it returns a file name such as \"[X]Y.DIR.1\".")
800 (directory)
801 Lisp_Object directory;
803 char *buf;
804 Lisp_Object handler;
806 CHECK_STRING (directory, 0);
808 if (NILP (directory))
809 return Qnil;
811 /* If the file name has special constructs in it,
812 call the corresponding file handler. */
813 handler = Ffind_file_name_handler (directory, Qdirectory_file_name);
814 if (!NILP (handler))
815 return call2 (handler, Qdirectory_file_name, directory);
817 #ifdef VMS
818 /* 20 extra chars is insufficient for VMS, since we might perform a
819 logical name translation. an equivalence string can be up to 255
820 chars long, so grab that much extra space... - sss */
821 buf = (char *) alloca (STRING_BYTES (XSTRING (directory)) + 20 + 255);
822 #else
823 buf = (char *) alloca (STRING_BYTES (XSTRING (directory)) + 20);
824 #endif
825 directory_file_name (XSTRING (directory)->data, buf);
826 return build_string (buf);
829 static char make_temp_name_tbl[64] =
831 'A','B','C','D','E','F','G','H',
832 'I','J','K','L','M','N','O','P',
833 'Q','R','S','T','U','V','W','X',
834 'Y','Z','a','b','c','d','e','f',
835 'g','h','i','j','k','l','m','n',
836 'o','p','q','r','s','t','u','v',
837 'w','x','y','z','0','1','2','3',
838 '4','5','6','7','8','9','-','_'
840 static unsigned make_temp_name_count, make_temp_name_count_initialized_p;
842 DEFUN ("make-temp-name", Fmake_temp_name, Smake_temp_name, 1, 1, 0,
843 "Generate temporary file name (string) starting with PREFIX (a string).\n\
844 The Emacs process number forms part of the result,\n\
845 so there is no danger of generating a name being used by another process.\n\
847 In addition, this function makes an attempt to choose a name\n\
848 which has no existing file. To make this work,\n\
849 PREFIX should be an absolute file name.\n\
851 There is a race condition between calling `make-temp-name' and creating the\n\
852 file which opens all kinds of security holes. For that reason, you should\n\
853 probably use `make-temp-file' instead.")
854 (prefix)
855 Lisp_Object prefix;
857 Lisp_Object val;
858 int len;
859 int pid;
860 unsigned char *p, *data;
861 char pidbuf[20];
862 int pidlen;
864 CHECK_STRING (prefix, 0);
866 /* VAL is created by adding 6 characters to PREFIX. The first
867 three are the PID of this process, in base 64, and the second
868 three are incremented if the file already exists. This ensures
869 262144 unique file names per PID per PREFIX. */
871 pid = (int) getpid ();
873 #ifdef HAVE_LONG_FILE_NAMES
874 sprintf (pidbuf, "%d", pid);
875 pidlen = strlen (pidbuf);
876 #else
877 pidbuf[0] = make_temp_name_tbl[pid & 63], pid >>= 6;
878 pidbuf[1] = make_temp_name_tbl[pid & 63], pid >>= 6;
879 pidbuf[2] = make_temp_name_tbl[pid & 63], pid >>= 6;
880 pidlen = 3;
881 #endif
883 len = XSTRING (prefix)->size;
884 val = make_uninit_string (len + 3 + pidlen);
885 data = XSTRING (val)->data;
886 bcopy(XSTRING (prefix)->data, data, len);
887 p = data + len;
889 bcopy (pidbuf, p, pidlen);
890 p += pidlen;
892 /* Here we try to minimize useless stat'ing when this function is
893 invoked many times successively with the same PREFIX. We achieve
894 this by initializing count to a random value, and incrementing it
895 afterwards.
897 We don't want make-temp-name to be called while dumping,
898 because then make_temp_name_count_initialized_p would get set
899 and then make_temp_name_count would not be set when Emacs starts. */
901 if (!make_temp_name_count_initialized_p)
903 make_temp_name_count = (unsigned) time (NULL);
904 make_temp_name_count_initialized_p = 1;
907 while (1)
909 struct stat ignored;
910 unsigned num = make_temp_name_count;
912 p[0] = make_temp_name_tbl[num & 63], num >>= 6;
913 p[1] = make_temp_name_tbl[num & 63], num >>= 6;
914 p[2] = make_temp_name_tbl[num & 63], num >>= 6;
916 /* Poor man's congruential RN generator. Replace with
917 ++make_temp_name_count for debugging. */
918 make_temp_name_count += 25229;
919 make_temp_name_count %= 225307;
921 if (stat (data, &ignored) < 0)
923 /* We want to return only if errno is ENOENT. */
924 if (errno == ENOENT)
925 return val;
926 else
927 /* The error here is dubious, but there is little else we
928 can do. The alternatives are to return nil, which is
929 as bad as (and in many cases worse than) throwing the
930 error, or to ignore the error, which will likely result
931 in looping through 225307 stat's, which is not only
932 dog-slow, but also useless since it will fallback to
933 the errow below, anyway. */
934 report_file_error ("Cannot create temporary name for prefix `%s'",
935 Fcons (prefix, Qnil));
936 /* not reached */
940 error ("Cannot create temporary name for prefix `%s'",
941 XSTRING (prefix)->data);
942 return Qnil;
946 DEFUN ("expand-file-name", Fexpand_file_name, Sexpand_file_name, 1, 2, 0,
947 "Convert filename NAME to absolute, and canonicalize it.\n\
948 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative\n\
949 (does not start with slash); if DEFAULT-DIRECTORY is nil or missing,\n\
950 the current buffer's value of default-directory is used.\n\
951 File name components that are `.' are removed, and \n\
952 so are file name components followed by `..', along with the `..' itself;\n\
953 note that these simplifications are done without checking the resulting\n\
954 file names in the file system.\n\
955 An initial `~/' expands to your home directory.\n\
956 An initial `~USER/' expands to USER's home directory.\n\
957 See also the function `substitute-in-file-name'.")
958 (name, default_directory)
959 Lisp_Object name, default_directory;
961 unsigned char *nm;
963 register unsigned char *newdir, *p, *o;
964 int tlen;
965 unsigned char *target;
966 struct passwd *pw;
967 #ifdef VMS
968 unsigned char * colon = 0;
969 unsigned char * close = 0;
970 unsigned char * slash = 0;
971 unsigned char * brack = 0;
972 int lbrack = 0, rbrack = 0;
973 int dots = 0;
974 #endif /* VMS */
975 #ifdef DOS_NT
976 int drive = 0;
977 int collapse_newdir = 1;
978 int is_escaped = 0;
979 #endif /* DOS_NT */
980 int length;
981 Lisp_Object handler;
983 CHECK_STRING (name, 0);
985 /* If the file name has special constructs in it,
986 call the corresponding file handler. */
987 handler = Ffind_file_name_handler (name, Qexpand_file_name);
988 if (!NILP (handler))
989 return call3 (handler, Qexpand_file_name, name, default_directory);
991 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
992 if (NILP (default_directory))
993 default_directory = current_buffer->directory;
994 if (! STRINGP (default_directory))
995 default_directory = build_string ("/");
997 if (!NILP (default_directory))
999 handler = Ffind_file_name_handler (default_directory, Qexpand_file_name);
1000 if (!NILP (handler))
1001 return call3 (handler, Qexpand_file_name, name, default_directory);
1004 o = XSTRING (default_directory)->data;
1006 /* Make sure DEFAULT_DIRECTORY is properly expanded.
1007 It would be better to do this down below where we actually use
1008 default_directory. Unfortunately, calling Fexpand_file_name recursively
1009 could invoke GC, and the strings might be relocated. This would
1010 be annoying because we have pointers into strings lying around
1011 that would need adjusting, and people would add new pointers to
1012 the code and forget to adjust them, resulting in intermittent bugs.
1013 Putting this call here avoids all that crud.
1015 The EQ test avoids infinite recursion. */
1016 if (! NILP (default_directory) && !EQ (default_directory, name)
1017 /* Save time in some common cases - as long as default_directory
1018 is not relative, it can be canonicalized with name below (if it
1019 is needed at all) without requiring it to be expanded now. */
1020 #ifdef DOS_NT
1021 /* Detect MSDOS file names with drive specifiers. */
1022 && ! (IS_DRIVE (o[0]) && IS_DEVICE_SEP (o[1]) && IS_DIRECTORY_SEP (o[2]))
1023 #ifdef WINDOWSNT
1024 /* Detect Windows file names in UNC format. */
1025 && ! (IS_DIRECTORY_SEP (o[0]) && IS_DIRECTORY_SEP (o[1]))
1026 #endif
1027 #else /* not DOS_NT */
1028 /* Detect Unix absolute file names (/... alone is not absolute on
1029 DOS or Windows). */
1030 && ! (IS_DIRECTORY_SEP (o[0]))
1031 #endif /* not DOS_NT */
1034 struct gcpro gcpro1;
1036 GCPRO1 (name);
1037 default_directory = Fexpand_file_name (default_directory, Qnil);
1038 UNGCPRO;
1041 #ifdef VMS
1042 /* Filenames on VMS are always upper case. */
1043 name = Fupcase (name);
1044 #endif
1045 #ifdef FILE_SYSTEM_CASE
1046 name = FILE_SYSTEM_CASE (name);
1047 #endif
1049 nm = XSTRING (name)->data;
1051 #ifdef DOS_NT
1052 /* We will force directory separators to be either all \ or /, so make
1053 a local copy to modify, even if there ends up being no change. */
1054 nm = strcpy (alloca (strlen (nm) + 1), nm);
1056 /* Note if special escape prefix is present, but remove for now. */
1057 if (nm[0] == '/' && nm[1] == ':')
1059 is_escaped = 1;
1060 nm += 2;
1063 /* Find and remove drive specifier if present; this makes nm absolute
1064 even if the rest of the name appears to be relative. Only look for
1065 drive specifier at the beginning. */
1066 if (IS_DRIVE (nm[0]) && IS_DEVICE_SEP (nm[1]))
1068 drive = nm[0];
1069 nm += 2;
1072 #ifdef WINDOWSNT
1073 /* If we see "c://somedir", we want to strip the first slash after the
1074 colon when stripping the drive letter. Otherwise, this expands to
1075 "//somedir". */
1076 if (drive && IS_DIRECTORY_SEP (nm[0]) && IS_DIRECTORY_SEP (nm[1]))
1077 nm++;
1078 #endif /* WINDOWSNT */
1079 #endif /* DOS_NT */
1081 #ifdef WINDOWSNT
1082 /* Discard any previous drive specifier if nm is now in UNC format. */
1083 if (IS_DIRECTORY_SEP (nm[0]) && IS_DIRECTORY_SEP (nm[1]))
1085 drive = 0;
1087 #endif
1089 /* If nm is absolute, look for /./ or /../ sequences; if none are
1090 found, we can probably return right away. We will avoid allocating
1091 a new string if name is already fully expanded. */
1092 if (
1093 IS_DIRECTORY_SEP (nm[0])
1094 #ifdef MSDOS
1095 && drive && !is_escaped
1096 #endif
1097 #ifdef WINDOWSNT
1098 && (drive || IS_DIRECTORY_SEP (nm[1])) && !is_escaped
1099 #endif
1100 #ifdef VMS
1101 || index (nm, ':')
1102 #endif /* VMS */
1105 /* If it turns out that the filename we want to return is just a
1106 suffix of FILENAME, we don't need to go through and edit
1107 things; we just need to construct a new string using data
1108 starting at the middle of FILENAME. If we set lose to a
1109 non-zero value, that means we've discovered that we can't do
1110 that cool trick. */
1111 int lose = 0;
1113 p = nm;
1114 while (*p)
1116 /* Since we know the name is absolute, we can assume that each
1117 element starts with a "/". */
1119 /* "." and ".." are hairy. */
1120 if (IS_DIRECTORY_SEP (p[0])
1121 && p[1] == '.'
1122 && (IS_DIRECTORY_SEP (p[2])
1123 || p[2] == 0
1124 || (p[2] == '.' && (IS_DIRECTORY_SEP (p[3])
1125 || p[3] == 0))))
1126 lose = 1;
1127 #ifdef VMS
1128 if (p[0] == '\\')
1129 lose = 1;
1130 if (p[0] == '/') {
1131 /* if dev:[dir]/, move nm to / */
1132 if (!slash && p > nm && (brack || colon)) {
1133 nm = (brack ? brack + 1 : colon + 1);
1134 lbrack = rbrack = 0;
1135 brack = 0;
1136 colon = 0;
1138 slash = p;
1140 if (p[0] == '-')
1141 #ifndef VMS4_4
1142 /* VMS pre V4.4,convert '-'s in filenames. */
1143 if (lbrack == rbrack)
1145 if (dots < 2) /* this is to allow negative version numbers */
1146 p[0] = '_';
1148 else
1149 #endif /* VMS4_4 */
1150 if (lbrack > rbrack &&
1151 ((p[-1] == '.' || p[-1] == '[' || p[-1] == '<') &&
1152 (p[1] == '.' || p[1] == ']' || p[1] == '>')))
1153 lose = 1;
1154 #ifndef VMS4_4
1155 else
1156 p[0] = '_';
1157 #endif /* VMS4_4 */
1158 /* count open brackets, reset close bracket pointer */
1159 if (p[0] == '[' || p[0] == '<')
1160 lbrack++, brack = 0;
1161 /* count close brackets, set close bracket pointer */
1162 if (p[0] == ']' || p[0] == '>')
1163 rbrack++, brack = p;
1164 /* detect ][ or >< */
1165 if ((p[0] == ']' || p[0] == '>') && (p[1] == '[' || p[1] == '<'))
1166 lose = 1;
1167 if ((p[0] == ':' || p[0] == ']' || p[0] == '>') && p[1] == '~')
1168 nm = p + 1, lose = 1;
1169 if (p[0] == ':' && (colon || slash))
1170 /* if dev1:[dir]dev2:, move nm to dev2: */
1171 if (brack)
1173 nm = brack + 1;
1174 brack = 0;
1176 /* if /name/dev:, move nm to dev: */
1177 else if (slash)
1178 nm = slash + 1;
1179 /* if node::dev:, move colon following dev */
1180 else if (colon && colon[-1] == ':')
1181 colon = p;
1182 /* if dev1:dev2:, move nm to dev2: */
1183 else if (colon && colon[-1] != ':')
1185 nm = colon + 1;
1186 colon = 0;
1188 if (p[0] == ':' && !colon)
1190 if (p[1] == ':')
1191 p++;
1192 colon = p;
1194 if (lbrack == rbrack)
1195 if (p[0] == ';')
1196 dots = 2;
1197 else if (p[0] == '.')
1198 dots++;
1199 #endif /* VMS */
1200 p++;
1202 if (!lose)
1204 #ifdef VMS
1205 if (index (nm, '/'))
1206 return build_string (sys_translate_unix (nm));
1207 #endif /* VMS */
1208 #ifdef DOS_NT
1209 /* Make sure directories are all separated with / or \ as
1210 desired, but avoid allocation of a new string when not
1211 required. */
1212 CORRECT_DIR_SEPS (nm);
1213 #ifdef WINDOWSNT
1214 if (IS_DIRECTORY_SEP (nm[1]))
1216 if (strcmp (nm, XSTRING (name)->data) != 0)
1217 name = build_string (nm);
1219 else
1220 #endif
1221 /* drive must be set, so this is okay */
1222 if (strcmp (nm - 2, XSTRING (name)->data) != 0)
1224 name = make_string (nm - 2, p - nm + 2);
1225 XSTRING (name)->data[0] = DRIVE_LETTER (drive);
1226 XSTRING (name)->data[1] = ':';
1228 return name;
1229 #else /* not DOS_NT */
1230 if (nm == XSTRING (name)->data)
1231 return name;
1232 return build_string (nm);
1233 #endif /* not DOS_NT */
1237 /* At this point, nm might or might not be an absolute file name. We
1238 need to expand ~ or ~user if present, otherwise prefix nm with
1239 default_directory if nm is not absolute, and finally collapse /./
1240 and /foo/../ sequences.
1242 We set newdir to be the appropriate prefix if one is needed:
1243 - the relevant user directory if nm starts with ~ or ~user
1244 - the specified drive's working dir (DOS/NT only) if nm does not
1245 start with /
1246 - the value of default_directory.
1248 Note that these prefixes are not guaranteed to be absolute (except
1249 for the working dir of a drive). Therefore, to ensure we always
1250 return an absolute name, if the final prefix is not absolute we
1251 append it to the current working directory. */
1253 newdir = 0;
1255 if (nm[0] == '~') /* prefix ~ */
1257 if (IS_DIRECTORY_SEP (nm[1])
1258 #ifdef VMS
1259 || nm[1] == ':'
1260 #endif /* VMS */
1261 || nm[1] == 0) /* ~ by itself */
1263 if (!(newdir = (unsigned char *) egetenv ("HOME")))
1264 newdir = (unsigned char *) "";
1265 nm++;
1266 #ifdef DOS_NT
1267 collapse_newdir = 0;
1268 #endif
1269 #ifdef VMS
1270 nm++; /* Don't leave the slash in nm. */
1271 #endif /* VMS */
1273 else /* ~user/filename */
1275 for (p = nm; *p && (!IS_DIRECTORY_SEP (*p)
1276 #ifdef VMS
1277 && *p != ':'
1278 #endif /* VMS */
1279 ); p++);
1280 o = (unsigned char *) alloca (p - nm + 1);
1281 bcopy ((char *) nm, o, p - nm);
1282 o [p - nm] = 0;
1284 pw = (struct passwd *) getpwnam (o + 1);
1285 if (pw)
1287 newdir = (unsigned char *) pw -> pw_dir;
1288 #ifdef VMS
1289 nm = p + 1; /* skip the terminator */
1290 #else
1291 nm = p;
1292 #ifdef DOS_NT
1293 collapse_newdir = 0;
1294 #endif
1295 #endif /* VMS */
1298 /* If we don't find a user of that name, leave the name
1299 unchanged; don't move nm forward to p. */
1303 #ifdef DOS_NT
1304 /* On DOS and Windows, nm is absolute if a drive name was specified;
1305 use the drive's current directory as the prefix if needed. */
1306 if (!newdir && drive)
1308 /* Get default directory if needed to make nm absolute. */
1309 if (!IS_DIRECTORY_SEP (nm[0]))
1311 newdir = alloca (MAXPATHLEN + 1);
1312 if (!getdefdir (toupper (drive) - 'A' + 1, newdir))
1313 newdir = NULL;
1315 if (!newdir)
1317 /* Either nm starts with /, or drive isn't mounted. */
1318 newdir = alloca (4);
1319 newdir[0] = DRIVE_LETTER (drive);
1320 newdir[1] = ':';
1321 newdir[2] = '/';
1322 newdir[3] = 0;
1325 #endif /* DOS_NT */
1327 /* Finally, if no prefix has been specified and nm is not absolute,
1328 then it must be expanded relative to default_directory. */
1330 if (1
1331 #ifndef DOS_NT
1332 /* /... alone is not absolute on DOS and Windows. */
1333 && !IS_DIRECTORY_SEP (nm[0])
1334 #endif
1335 #ifdef WINDOWSNT
1336 && !(IS_DIRECTORY_SEP (nm[0]) && IS_DIRECTORY_SEP (nm[1]))
1337 #endif
1338 #ifdef VMS
1339 && !index (nm, ':')
1340 #endif
1341 && !newdir)
1343 newdir = XSTRING (default_directory)->data;
1344 #ifdef DOS_NT
1345 /* Note if special escape prefix is present, but remove for now. */
1346 if (newdir[0] == '/' && newdir[1] == ':')
1348 is_escaped = 1;
1349 newdir += 2;
1351 #endif
1354 #ifdef DOS_NT
1355 if (newdir)
1357 /* First ensure newdir is an absolute name. */
1358 if (
1359 /* Detect MSDOS file names with drive specifiers. */
1360 ! (IS_DRIVE (newdir[0])
1361 && IS_DEVICE_SEP (newdir[1]) && IS_DIRECTORY_SEP (newdir[2]))
1362 #ifdef WINDOWSNT
1363 /* Detect Windows file names in UNC format. */
1364 && ! (IS_DIRECTORY_SEP (newdir[0]) && IS_DIRECTORY_SEP (newdir[1]))
1365 #endif
1368 /* Effectively, let newdir be (expand-file-name newdir cwd).
1369 Because of the admonition against calling expand-file-name
1370 when we have pointers into lisp strings, we accomplish this
1371 indirectly by prepending newdir to nm if necessary, and using
1372 cwd (or the wd of newdir's drive) as the new newdir. */
1374 if (IS_DRIVE (newdir[0]) && newdir[1] == ':')
1376 drive = newdir[0];
1377 newdir += 2;
1379 if (!IS_DIRECTORY_SEP (nm[0]))
1381 char * tmp = alloca (strlen (newdir) + strlen (nm) + 2);
1382 file_name_as_directory (tmp, newdir);
1383 strcat (tmp, nm);
1384 nm = tmp;
1386 newdir = alloca (MAXPATHLEN + 1);
1387 if (drive)
1389 if (!getdefdir (toupper (drive) - 'A' + 1, newdir))
1390 newdir = "/";
1392 else
1393 getwd (newdir);
1396 /* Strip off drive name from prefix, if present. */
1397 if (IS_DRIVE (newdir[0]) && newdir[1] == ':')
1399 drive = newdir[0];
1400 newdir += 2;
1403 /* Keep only a prefix from newdir if nm starts with slash
1404 (//server/share for UNC, nothing otherwise). */
1405 if (IS_DIRECTORY_SEP (nm[0]) && collapse_newdir)
1407 #ifdef WINDOWSNT
1408 if (IS_DIRECTORY_SEP (newdir[0]) && IS_DIRECTORY_SEP (newdir[1]))
1410 newdir = strcpy (alloca (strlen (newdir) + 1), newdir);
1411 p = newdir + 2;
1412 while (*p && !IS_DIRECTORY_SEP (*p)) p++;
1413 p++;
1414 while (*p && !IS_DIRECTORY_SEP (*p)) p++;
1415 *p = 0;
1417 else
1418 #endif
1419 newdir = "";
1422 #endif /* DOS_NT */
1424 if (newdir)
1426 /* Get rid of any slash at the end of newdir, unless newdir is
1427 just / or // (an incomplete UNC name). */
1428 length = strlen (newdir);
1429 if (length > 1 && IS_DIRECTORY_SEP (newdir[length - 1])
1430 #ifdef WINDOWSNT
1431 && !(length == 2 && IS_DIRECTORY_SEP (newdir[0]))
1432 #endif
1435 unsigned char *temp = (unsigned char *) alloca (length);
1436 bcopy (newdir, temp, length - 1);
1437 temp[length - 1] = 0;
1438 newdir = temp;
1440 tlen = length + 1;
1442 else
1443 tlen = 0;
1445 /* Now concatenate the directory and name to new space in the stack frame */
1446 tlen += strlen (nm) + 1;
1447 #ifdef DOS_NT
1448 /* Reserve space for drive specifier and escape prefix, since either
1449 or both may need to be inserted. (The Microsoft x86 compiler
1450 produces incorrect code if the following two lines are combined.) */
1451 target = (unsigned char *) alloca (tlen + 4);
1452 target += 4;
1453 #else /* not DOS_NT */
1454 target = (unsigned char *) alloca (tlen);
1455 #endif /* not DOS_NT */
1456 *target = 0;
1458 if (newdir)
1460 #ifndef VMS
1461 if (nm[0] == 0 || IS_DIRECTORY_SEP (nm[0]))
1463 #ifdef DOS_NT
1464 /* If newdir is effectively "C:/", then the drive letter will have
1465 been stripped and newdir will be "/". Concatenating with an
1466 absolute directory in nm produces "//", which will then be
1467 incorrectly treated as a network share. Ignore newdir in
1468 this case (keeping the drive letter). */
1469 if (!(drive && nm[0] && IS_DIRECTORY_SEP (newdir[0])
1470 && newdir[1] == '\0'))
1471 #endif
1472 strcpy (target, newdir);
1474 else
1475 #endif
1476 file_name_as_directory (target, newdir);
1479 strcat (target, nm);
1480 #ifdef VMS
1481 if (index (target, '/'))
1482 strcpy (target, sys_translate_unix (target));
1483 #endif /* VMS */
1485 /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */
1487 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1489 p = target;
1490 o = target;
1492 while (*p)
1494 #ifdef VMS
1495 if (*p != ']' && *p != '>' && *p != '-')
1497 if (*p == '\\')
1498 p++;
1499 *o++ = *p++;
1501 else if ((p[0] == ']' || p[0] == '>') && p[0] == p[1] + 2)
1502 /* brackets are offset from each other by 2 */
1504 p += 2;
1505 if (*p != '.' && *p != '-' && o[-1] != '.')
1506 /* convert [foo][bar] to [bar] */
1507 while (o[-1] != '[' && o[-1] != '<')
1508 o--;
1509 else if (*p == '-' && *o != '.')
1510 *--p = '.';
1512 else if (p[0] == '-' && o[-1] == '.' &&
1513 (p[1] == '.' || p[1] == ']' || p[1] == '>'))
1514 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1517 o--;
1518 while (o[-1] != '.' && o[-1] != '[' && o[-1] != '<');
1519 if (p[1] == '.') /* foo.-.bar ==> bar. */
1520 p += 2;
1521 else if (o[-1] == '.') /* '.foo.-]' ==> ']' */
1522 p++, o--;
1523 /* else [foo.-] ==> [-] */
1525 else
1527 #ifndef VMS4_4
1528 if (*p == '-' &&
1529 o[-1] != '[' && o[-1] != '<' && o[-1] != '.' &&
1530 p[1] != ']' && p[1] != '>' && p[1] != '.')
1531 *p = '_';
1532 #endif /* VMS4_4 */
1533 *o++ = *p++;
1535 #else /* not VMS */
1536 if (!IS_DIRECTORY_SEP (*p))
1538 *o++ = *p++;
1540 else if (IS_DIRECTORY_SEP (p[0])
1541 && p[1] == '.'
1542 && (IS_DIRECTORY_SEP (p[2])
1543 || p[2] == 0))
1545 /* If "/." is the entire filename, keep the "/". Otherwise,
1546 just delete the whole "/.". */
1547 if (o == target && p[2] == '\0')
1548 *o++ = *p;
1549 p += 2;
1551 else if (IS_DIRECTORY_SEP (p[0]) && p[1] == '.' && p[2] == '.'
1552 /* `/../' is the "superroot" on certain file systems. */
1553 && o != target
1554 && (IS_DIRECTORY_SEP (p[3]) || p[3] == 0))
1556 while (o != target && (--o) && !IS_DIRECTORY_SEP (*o))
1558 /* Keep initial / only if this is the whole name. */
1559 if (o == target && IS_ANY_SEP (*o) && p[3] == 0)
1560 ++o;
1561 p += 3;
1563 else
1565 *o++ = *p++;
1567 #endif /* not VMS */
1570 #ifdef DOS_NT
1571 /* At last, set drive name. */
1572 #ifdef WINDOWSNT
1573 /* Except for network file name. */
1574 if (!(IS_DIRECTORY_SEP (target[0]) && IS_DIRECTORY_SEP (target[1])))
1575 #endif /* WINDOWSNT */
1577 if (!drive) abort ();
1578 target -= 2;
1579 target[0] = DRIVE_LETTER (drive);
1580 target[1] = ':';
1582 /* Reinsert the escape prefix if required. */
1583 if (is_escaped)
1585 target -= 2;
1586 target[0] = '/';
1587 target[1] = ':';
1589 CORRECT_DIR_SEPS (target);
1590 #endif /* DOS_NT */
1592 return make_string (target, o - target);
1595 #if 0
1596 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'. */
1597 DEAFUN ("expand-file-name", Fexpand_file_name, Sexpand_file_name, 1, 2, 0,
1598 "Convert FILENAME to absolute, and canonicalize it.\n\
1599 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1600 (does not start with slash); if DEFAULT is nil or missing,\n\
1601 the current buffer's value of default-directory is used.\n\
1602 Filenames containing `.' or `..' as components are simplified;\n\
1603 initial `~/' expands to your home directory.\n\
1604 See also the function `substitute-in-file-name'.")
1605 (name, defalt)
1606 Lisp_Object name, defalt;
1608 unsigned char *nm;
1610 register unsigned char *newdir, *p, *o;
1611 int tlen;
1612 unsigned char *target;
1613 struct passwd *pw;
1614 int lose;
1615 #ifdef VMS
1616 unsigned char * colon = 0;
1617 unsigned char * close = 0;
1618 unsigned char * slash = 0;
1619 unsigned char * brack = 0;
1620 int lbrack = 0, rbrack = 0;
1621 int dots = 0;
1622 #endif /* VMS */
1624 CHECK_STRING (name, 0);
1626 #ifdef VMS
1627 /* Filenames on VMS are always upper case. */
1628 name = Fupcase (name);
1629 #endif
1631 nm = XSTRING (name)->data;
1633 /* If nm is absolute, flush ...// and detect /./ and /../.
1634 If no /./ or /../ we can return right away. */
1635 if (
1636 nm[0] == '/'
1637 #ifdef VMS
1638 || index (nm, ':')
1639 #endif /* VMS */
1642 p = nm;
1643 lose = 0;
1644 while (*p)
1646 if (p[0] == '/' && p[1] == '/'
1647 #ifdef APOLLO
1648 /* // at start of filename is meaningful on Apollo system. */
1649 && nm != p
1650 #endif /* APOLLO */
1652 nm = p + 1;
1653 if (p[0] == '/' && p[1] == '~')
1654 nm = p + 1, lose = 1;
1655 if (p[0] == '/' && p[1] == '.'
1656 && (p[2] == '/' || p[2] == 0
1657 || (p[2] == '.' && (p[3] == '/' || p[3] == 0))))
1658 lose = 1;
1659 #ifdef VMS
1660 if (p[0] == '\\')
1661 lose = 1;
1662 if (p[0] == '/') {
1663 /* if dev:[dir]/, move nm to / */
1664 if (!slash && p > nm && (brack || colon)) {
1665 nm = (brack ? brack + 1 : colon + 1);
1666 lbrack = rbrack = 0;
1667 brack = 0;
1668 colon = 0;
1670 slash = p;
1672 if (p[0] == '-')
1673 #ifndef VMS4_4
1674 /* VMS pre V4.4,convert '-'s in filenames. */
1675 if (lbrack == rbrack)
1677 if (dots < 2) /* this is to allow negative version numbers */
1678 p[0] = '_';
1680 else
1681 #endif /* VMS4_4 */
1682 if (lbrack > rbrack &&
1683 ((p[-1] == '.' || p[-1] == '[' || p[-1] == '<') &&
1684 (p[1] == '.' || p[1] == ']' || p[1] == '>')))
1685 lose = 1;
1686 #ifndef VMS4_4
1687 else
1688 p[0] = '_';
1689 #endif /* VMS4_4 */
1690 /* count open brackets, reset close bracket pointer */
1691 if (p[0] == '[' || p[0] == '<')
1692 lbrack++, brack = 0;
1693 /* count close brackets, set close bracket pointer */
1694 if (p[0] == ']' || p[0] == '>')
1695 rbrack++, brack = p;
1696 /* detect ][ or >< */
1697 if ((p[0] == ']' || p[0] == '>') && (p[1] == '[' || p[1] == '<'))
1698 lose = 1;
1699 if ((p[0] == ':' || p[0] == ']' || p[0] == '>') && p[1] == '~')
1700 nm = p + 1, lose = 1;
1701 if (p[0] == ':' && (colon || slash))
1702 /* if dev1:[dir]dev2:, move nm to dev2: */
1703 if (brack)
1705 nm = brack + 1;
1706 brack = 0;
1708 /* If /name/dev:, move nm to dev: */
1709 else if (slash)
1710 nm = slash + 1;
1711 /* If node::dev:, move colon following dev */
1712 else if (colon && colon[-1] == ':')
1713 colon = p;
1714 /* If dev1:dev2:, move nm to dev2: */
1715 else if (colon && colon[-1] != ':')
1717 nm = colon + 1;
1718 colon = 0;
1720 if (p[0] == ':' && !colon)
1722 if (p[1] == ':')
1723 p++;
1724 colon = p;
1726 if (lbrack == rbrack)
1727 if (p[0] == ';')
1728 dots = 2;
1729 else if (p[0] == '.')
1730 dots++;
1731 #endif /* VMS */
1732 p++;
1734 if (!lose)
1736 #ifdef VMS
1737 if (index (nm, '/'))
1738 return build_string (sys_translate_unix (nm));
1739 #endif /* VMS */
1740 if (nm == XSTRING (name)->data)
1741 return name;
1742 return build_string (nm);
1746 /* Now determine directory to start with and put it in NEWDIR */
1748 newdir = 0;
1750 if (nm[0] == '~') /* prefix ~ */
1751 if (nm[1] == '/'
1752 #ifdef VMS
1753 || nm[1] == ':'
1754 #endif /* VMS */
1755 || nm[1] == 0)/* ~/filename */
1757 if (!(newdir = (unsigned char *) egetenv ("HOME")))
1758 newdir = (unsigned char *) "";
1759 nm++;
1760 #ifdef VMS
1761 nm++; /* Don't leave the slash in nm. */
1762 #endif /* VMS */
1764 else /* ~user/filename */
1766 /* Get past ~ to user */
1767 unsigned char *user = nm + 1;
1768 /* Find end of name. */
1769 unsigned char *ptr = (unsigned char *) index (user, '/');
1770 int len = ptr ? ptr - user : strlen (user);
1771 #ifdef VMS
1772 unsigned char *ptr1 = index (user, ':');
1773 if (ptr1 != 0 && ptr1 - user < len)
1774 len = ptr1 - user;
1775 #endif /* VMS */
1776 /* Copy the user name into temp storage. */
1777 o = (unsigned char *) alloca (len + 1);
1778 bcopy ((char *) user, o, len);
1779 o[len] = 0;
1781 /* Look up the user name. */
1782 pw = (struct passwd *) getpwnam (o + 1);
1783 if (!pw)
1784 error ("\"%s\" isn't a registered user", o + 1);
1786 newdir = (unsigned char *) pw->pw_dir;
1788 /* Discard the user name from NM. */
1789 nm += len;
1792 if (nm[0] != '/'
1793 #ifdef VMS
1794 && !index (nm, ':')
1795 #endif /* not VMS */
1796 && !newdir)
1798 if (NILP (defalt))
1799 defalt = current_buffer->directory;
1800 CHECK_STRING (defalt, 1);
1801 newdir = XSTRING (defalt)->data;
1804 /* Now concatenate the directory and name to new space in the stack frame */
1806 tlen = (newdir ? strlen (newdir) + 1 : 0) + strlen (nm) + 1;
1807 target = (unsigned char *) alloca (tlen);
1808 *target = 0;
1810 if (newdir)
1812 #ifndef VMS
1813 if (nm[0] == 0 || nm[0] == '/')
1814 strcpy (target, newdir);
1815 else
1816 #endif
1817 file_name_as_directory (target, newdir);
1820 strcat (target, nm);
1821 #ifdef VMS
1822 if (index (target, '/'))
1823 strcpy (target, sys_translate_unix (target));
1824 #endif /* VMS */
1826 /* Now canonicalize by removing /. and /foo/.. if they appear */
1828 p = target;
1829 o = target;
1831 while (*p)
1833 #ifdef VMS
1834 if (*p != ']' && *p != '>' && *p != '-')
1836 if (*p == '\\')
1837 p++;
1838 *o++ = *p++;
1840 else if ((p[0] == ']' || p[0] == '>') && p[0] == p[1] + 2)
1841 /* brackets are offset from each other by 2 */
1843 p += 2;
1844 if (*p != '.' && *p != '-' && o[-1] != '.')
1845 /* convert [foo][bar] to [bar] */
1846 while (o[-1] != '[' && o[-1] != '<')
1847 o--;
1848 else if (*p == '-' && *o != '.')
1849 *--p = '.';
1851 else if (p[0] == '-' && o[-1] == '.' &&
1852 (p[1] == '.' || p[1] == ']' || p[1] == '>'))
1853 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1856 o--;
1857 while (o[-1] != '.' && o[-1] != '[' && o[-1] != '<');
1858 if (p[1] == '.') /* foo.-.bar ==> bar. */
1859 p += 2;
1860 else if (o[-1] == '.') /* '.foo.-]' ==> ']' */
1861 p++, o--;
1862 /* else [foo.-] ==> [-] */
1864 else
1866 #ifndef VMS4_4
1867 if (*p == '-' &&
1868 o[-1] != '[' && o[-1] != '<' && o[-1] != '.' &&
1869 p[1] != ']' && p[1] != '>' && p[1] != '.')
1870 *p = '_';
1871 #endif /* VMS4_4 */
1872 *o++ = *p++;
1874 #else /* not VMS */
1875 if (*p != '/')
1877 *o++ = *p++;
1879 else if (!strncmp (p, "//", 2)
1880 #ifdef APOLLO
1881 /* // at start of filename is meaningful in Apollo system. */
1882 && o != target
1883 #endif /* APOLLO */
1886 o = target;
1887 p++;
1889 else if (p[0] == '/' && p[1] == '.' &&
1890 (p[2] == '/' || p[2] == 0))
1891 p += 2;
1892 else if (!strncmp (p, "/..", 3)
1893 /* `/../' is the "superroot" on certain file systems. */
1894 && o != target
1895 && (p[3] == '/' || p[3] == 0))
1897 while (o != target && *--o != '/')
1899 #ifdef APOLLO
1900 if (o == target + 1 && o[-1] == '/' && o[0] == '/')
1901 ++o;
1902 else
1903 #endif /* APOLLO */
1904 if (o == target && *o == '/')
1905 ++o;
1906 p += 3;
1908 else
1910 *o++ = *p++;
1912 #endif /* not VMS */
1915 return make_string (target, o - target);
1917 #endif
1919 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name,
1920 Ssubstitute_in_file_name, 1, 1, 0,
1921 "Substitute environment variables referred to in FILENAME.\n\
1922 `$FOO' where FOO is an environment variable name means to substitute\n\
1923 the value of that variable. The variable name should be terminated\n\
1924 with a character not a letter, digit or underscore; otherwise, enclose\n\
1925 the entire variable name in braces.\n\
1926 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1927 On VMS, `$' substitution is not done; this function does little and only\n\
1928 duplicates what `expand-file-name' does.")
1929 (filename)
1930 Lisp_Object filename;
1932 unsigned char *nm;
1934 register unsigned char *s, *p, *o, *x, *endp;
1935 unsigned char *target;
1936 int total = 0;
1937 int substituted = 0;
1938 unsigned char *xnm;
1939 Lisp_Object handler;
1941 CHECK_STRING (filename, 0);
1943 /* If the file name has special constructs in it,
1944 call the corresponding file handler. */
1945 handler = Ffind_file_name_handler (filename, Qsubstitute_in_file_name);
1946 if (!NILP (handler))
1947 return call2 (handler, Qsubstitute_in_file_name, filename);
1949 nm = XSTRING (filename)->data;
1950 #ifdef DOS_NT
1951 nm = strcpy (alloca (strlen (nm) + 1), nm);
1952 CORRECT_DIR_SEPS (nm);
1953 substituted = (strcmp (nm, XSTRING (filename)->data) != 0);
1954 #endif
1955 endp = nm + STRING_BYTES (XSTRING (filename));
1957 /* If /~ or // appears, discard everything through first slash. */
1959 for (p = nm; p != endp; p++)
1961 if ((p[0] == '~'
1962 #if defined (APOLLO) || defined (WINDOWSNT)
1963 /* // at start of file name is meaningful in Apollo and
1964 WindowsNT systems. */
1965 || (IS_DIRECTORY_SEP (p[0]) && p - 1 != nm)
1966 #else /* not (APOLLO || WINDOWSNT) */
1967 || IS_DIRECTORY_SEP (p[0])
1968 #endif /* not (APOLLO || WINDOWSNT) */
1970 && p != nm
1971 && (0
1972 #ifdef VMS
1973 || p[-1] == ':' || p[-1] == ']' || p[-1] == '>'
1974 #endif /* VMS */
1975 || IS_DIRECTORY_SEP (p[-1])))
1977 nm = p;
1978 substituted = 1;
1980 #ifdef DOS_NT
1981 /* see comment in expand-file-name about drive specifiers */
1982 else if (IS_DRIVE (p[0]) && p[1] == ':'
1983 && p > nm && IS_DIRECTORY_SEP (p[-1]))
1985 nm = p;
1986 substituted = 1;
1988 #endif /* DOS_NT */
1991 #ifdef VMS
1992 return build_string (nm);
1993 #else
1995 /* See if any variables are substituted into the string
1996 and find the total length of their values in `total' */
1998 for (p = nm; p != endp;)
1999 if (*p != '$')
2000 p++;
2001 else
2003 p++;
2004 if (p == endp)
2005 goto badsubst;
2006 else if (*p == '$')
2008 /* "$$" means a single "$" */
2009 p++;
2010 total -= 1;
2011 substituted = 1;
2012 continue;
2014 else if (*p == '{')
2016 o = ++p;
2017 while (p != endp && *p != '}') p++;
2018 if (*p != '}') goto missingclose;
2019 s = p;
2021 else
2023 o = p;
2024 while (p != endp && (isalnum (*p) || *p == '_')) p++;
2025 s = p;
2028 /* Copy out the variable name */
2029 target = (unsigned char *) alloca (s - o + 1);
2030 strncpy (target, o, s - o);
2031 target[s - o] = 0;
2032 #ifdef DOS_NT
2033 strupr (target); /* $home == $HOME etc. */
2034 #endif /* DOS_NT */
2036 /* Get variable value */
2037 o = (unsigned char *) egetenv (target);
2038 if (!o) goto badvar;
2039 total += strlen (o);
2040 substituted = 1;
2043 if (!substituted)
2044 return filename;
2046 /* If substitution required, recopy the string and do it */
2047 /* Make space in stack frame for the new copy */
2048 xnm = (unsigned char *) alloca (STRING_BYTES (XSTRING (filename)) + total + 1);
2049 x = xnm;
2051 /* Copy the rest of the name through, replacing $ constructs with values */
2052 for (p = nm; *p;)
2053 if (*p != '$')
2054 *x++ = *p++;
2055 else
2057 p++;
2058 if (p == endp)
2059 goto badsubst;
2060 else if (*p == '$')
2062 *x++ = *p++;
2063 continue;
2065 else if (*p == '{')
2067 o = ++p;
2068 while (p != endp && *p != '}') p++;
2069 if (*p != '}') goto missingclose;
2070 s = p++;
2072 else
2074 o = p;
2075 while (p != endp && (isalnum (*p) || *p == '_')) p++;
2076 s = p;
2079 /* Copy out the variable name */
2080 target = (unsigned char *) alloca (s - o + 1);
2081 strncpy (target, o, s - o);
2082 target[s - o] = 0;
2083 #ifdef DOS_NT
2084 strupr (target); /* $home == $HOME etc. */
2085 #endif /* DOS_NT */
2087 /* Get variable value */
2088 o = (unsigned char *) egetenv (target);
2089 if (!o)
2090 goto badvar;
2092 if (STRING_MULTIBYTE (filename))
2094 /* If the original string is multibyte,
2095 convert what we substitute into multibyte. */
2096 while (*o)
2098 int c = unibyte_char_to_multibyte (*o++);
2099 x += CHAR_STRING (c, x);
2102 else
2104 strcpy (x, o);
2105 x += strlen (o);
2109 *x = 0;
2111 /* If /~ or // appears, discard everything through first slash. */
2113 for (p = xnm; p != x; p++)
2114 if ((p[0] == '~'
2115 #if defined (APOLLO) || defined (WINDOWSNT)
2116 || (IS_DIRECTORY_SEP (p[0]) && p - 1 != xnm)
2117 #else /* not (APOLLO || WINDOWSNT) */
2118 || IS_DIRECTORY_SEP (p[0])
2119 #endif /* not (APOLLO || WINDOWSNT) */
2121 && p != xnm && IS_DIRECTORY_SEP (p[-1]))
2122 xnm = p;
2123 #ifdef DOS_NT
2124 else if (IS_DRIVE (p[0]) && p[1] == ':'
2125 && p > xnm && IS_DIRECTORY_SEP (p[-1]))
2126 xnm = p;
2127 #endif
2129 if (STRING_MULTIBYTE (filename))
2130 return make_string (xnm, x - xnm);
2131 return make_unibyte_string (xnm, x - xnm);
2133 badsubst:
2134 error ("Bad format environment-variable substitution");
2135 missingclose:
2136 error ("Missing \"}\" in environment-variable substitution");
2137 badvar:
2138 error ("Substituting nonexistent environment variable \"%s\"", target);
2140 /* NOTREACHED */
2141 #endif /* not VMS */
2144 /* A slightly faster and more convenient way to get
2145 (directory-file-name (expand-file-name FOO)). */
2147 Lisp_Object
2148 expand_and_dir_to_file (filename, defdir)
2149 Lisp_Object filename, defdir;
2151 register Lisp_Object absname;
2153 absname = Fexpand_file_name (filename, defdir);
2154 #ifdef VMS
2156 register int c = XSTRING (absname)->data[STRING_BYTES (XSTRING (absname)) - 1];
2157 if (c == ':' || c == ']' || c == '>')
2158 absname = Fdirectory_file_name (absname);
2160 #else
2161 /* Remove final slash, if any (unless this is the root dir).
2162 stat behaves differently depending! */
2163 if (XSTRING (absname)->size > 1
2164 && IS_DIRECTORY_SEP (XSTRING (absname)->data[STRING_BYTES (XSTRING (absname)) - 1])
2165 && !IS_DEVICE_SEP (XSTRING (absname)->data[STRING_BYTES (XSTRING (absname))-2]))
2166 /* We cannot take shortcuts; they might be wrong for magic file names. */
2167 absname = Fdirectory_file_name (absname);
2168 #endif
2169 return absname;
2172 /* Signal an error if the file ABSNAME already exists.
2173 If INTERACTIVE is nonzero, ask the user whether to proceed,
2174 and bypass the error if the user says to go ahead.
2175 QUERYSTRING is a name for the action that is being considered
2176 to alter the file.
2178 *STATPTR is used to store the stat information if the file exists.
2179 If the file does not exist, STATPTR->st_mode is set to 0.
2180 If STATPTR is null, we don't store into it.
2182 If QUICK is nonzero, we ask for y or n, not yes or no. */
2184 void
2185 barf_or_query_if_file_exists (absname, querystring, interactive, statptr, quick)
2186 Lisp_Object absname;
2187 unsigned char *querystring;
2188 int interactive;
2189 struct stat *statptr;
2190 int quick;
2192 register Lisp_Object tem, encoded_filename;
2193 struct stat statbuf;
2194 struct gcpro gcpro1;
2196 encoded_filename = ENCODE_FILE (absname);
2198 /* stat is a good way to tell whether the file exists,
2199 regardless of what access permissions it has. */
2200 if (stat (XSTRING (encoded_filename)->data, &statbuf) >= 0)
2202 if (! interactive)
2203 Fsignal (Qfile_already_exists,
2204 Fcons (build_string ("File already exists"),
2205 Fcons (absname, Qnil)));
2206 GCPRO1 (absname);
2207 tem = format1 ("File %s already exists; %s anyway? ",
2208 XSTRING (absname)->data, querystring);
2209 if (quick)
2210 tem = Fy_or_n_p (tem);
2211 else
2212 tem = do_yes_or_no_p (tem);
2213 UNGCPRO;
2214 if (NILP (tem))
2215 Fsignal (Qfile_already_exists,
2216 Fcons (build_string ("File already exists"),
2217 Fcons (absname, Qnil)));
2218 if (statptr)
2219 *statptr = statbuf;
2221 else
2223 if (statptr)
2224 statptr->st_mode = 0;
2226 return;
2229 DEFUN ("copy-file", Fcopy_file, Scopy_file, 2, 4,
2230 "fCopy file: \nFCopy %s to file: \np\nP",
2231 "Copy FILE to NEWNAME. Both args must be strings.\n\
2232 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
2233 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
2234 A number as third arg means request confirmation if NEWNAME already exists.\n\
2235 This is what happens in interactive use with M-x.\n\
2236 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
2237 last-modified time as the old one. (This works on only some systems.)\n\
2238 A prefix arg makes KEEP-TIME non-nil.")
2239 (file, newname, ok_if_already_exists, keep_date)
2240 Lisp_Object file, newname, ok_if_already_exists, keep_date;
2242 int ifd, ofd, n;
2243 char buf[16 * 1024];
2244 struct stat st, out_st;
2245 Lisp_Object handler;
2246 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
2247 int count = specpdl_ptr - specpdl;
2248 int input_file_statable_p;
2249 Lisp_Object encoded_file, encoded_newname;
2251 encoded_file = encoded_newname = Qnil;
2252 GCPRO4 (file, newname, encoded_file, encoded_newname);
2253 CHECK_STRING (file, 0);
2254 CHECK_STRING (newname, 1);
2256 file = Fexpand_file_name (file, Qnil);
2257 newname = Fexpand_file_name (newname, Qnil);
2259 /* If the input file name has special constructs in it,
2260 call the corresponding file handler. */
2261 handler = Ffind_file_name_handler (file, Qcopy_file);
2262 /* Likewise for output file name. */
2263 if (NILP (handler))
2264 handler = Ffind_file_name_handler (newname, Qcopy_file);
2265 if (!NILP (handler))
2266 RETURN_UNGCPRO (call5 (handler, Qcopy_file, file, newname,
2267 ok_if_already_exists, keep_date));
2269 encoded_file = ENCODE_FILE (file);
2270 encoded_newname = ENCODE_FILE (newname);
2272 if (NILP (ok_if_already_exists)
2273 || INTEGERP (ok_if_already_exists))
2274 barf_or_query_if_file_exists (encoded_newname, "copy to it",
2275 INTEGERP (ok_if_already_exists), &out_st, 0);
2276 else if (stat (XSTRING (encoded_newname)->data, &out_st) < 0)
2277 out_st.st_mode = 0;
2279 ifd = emacs_open (XSTRING (encoded_file)->data, O_RDONLY, 0);
2280 if (ifd < 0)
2281 report_file_error ("Opening input file", Fcons (file, Qnil));
2283 record_unwind_protect (close_file_unwind, make_number (ifd));
2285 /* We can only copy regular files and symbolic links. Other files are not
2286 copyable by us. */
2287 input_file_statable_p = (fstat (ifd, &st) >= 0);
2289 #if !defined (DOS_NT) || __DJGPP__ > 1
2290 if (out_st.st_mode != 0
2291 && st.st_dev == out_st.st_dev && st.st_ino == out_st.st_ino)
2293 errno = 0;
2294 report_file_error ("Input and output files are the same",
2295 Fcons (file, Fcons (newname, Qnil)));
2297 #endif
2299 #if defined (S_ISREG) && defined (S_ISLNK)
2300 if (input_file_statable_p)
2302 if (!(S_ISREG (st.st_mode)) && !(S_ISLNK (st.st_mode)))
2304 #if defined (EISDIR)
2305 /* Get a better looking error message. */
2306 errno = EISDIR;
2307 #endif /* EISDIR */
2308 report_file_error ("Non-regular file", Fcons (file, Qnil));
2311 #endif /* S_ISREG && S_ISLNK */
2313 #ifdef VMS
2314 /* Create the copy file with the same record format as the input file */
2315 ofd = sys_creat (XSTRING (encoded_newname)->data, 0666, ifd);
2316 #else
2317 #ifdef MSDOS
2318 /* System's default file type was set to binary by _fmode in emacs.c. */
2319 ofd = creat (XSTRING (encoded_newname)->data, S_IREAD | S_IWRITE);
2320 #else /* not MSDOS */
2321 ofd = creat (XSTRING (encoded_newname)->data, 0666);
2322 #endif /* not MSDOS */
2323 #endif /* VMS */
2324 if (ofd < 0)
2325 report_file_error ("Opening output file", Fcons (newname, Qnil));
2327 record_unwind_protect (close_file_unwind, make_number (ofd));
2329 immediate_quit = 1;
2330 QUIT;
2331 while ((n = emacs_read (ifd, buf, sizeof buf)) > 0)
2332 if (emacs_write (ofd, buf, n) != n)
2333 report_file_error ("I/O error", Fcons (newname, Qnil));
2334 immediate_quit = 0;
2336 /* Closing the output clobbers the file times on some systems. */
2337 if (emacs_close (ofd) < 0)
2338 report_file_error ("I/O error", Fcons (newname, Qnil));
2340 if (input_file_statable_p)
2342 if (!NILP (keep_date))
2344 EMACS_TIME atime, mtime;
2345 EMACS_SET_SECS_USECS (atime, st.st_atime, 0);
2346 EMACS_SET_SECS_USECS (mtime, st.st_mtime, 0);
2347 if (set_file_times (XSTRING (encoded_newname)->data,
2348 atime, mtime))
2349 Fsignal (Qfile_date_error,
2350 Fcons (build_string ("Cannot set file date"),
2351 Fcons (newname, Qnil)));
2353 #ifndef MSDOS
2354 chmod (XSTRING (encoded_newname)->data, st.st_mode & 07777);
2355 #else /* MSDOS */
2356 #if defined (__DJGPP__) && __DJGPP__ > 1
2357 /* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
2358 and if it can't, it tells so. Otherwise, under MSDOS we usually
2359 get only the READ bit, which will make the copied file read-only,
2360 so it's better not to chmod at all. */
2361 if ((_djstat_flags & _STFAIL_WRITEBIT) == 0)
2362 chmod (XSTRING (encoded_newname)->data, st.st_mode & 07777);
2363 #endif /* DJGPP version 2 or newer */
2364 #endif /* MSDOS */
2367 emacs_close (ifd);
2369 /* Discard the unwind protects. */
2370 specpdl_ptr = specpdl + count;
2372 UNGCPRO;
2373 return Qnil;
2376 DEFUN ("make-directory-internal", Fmake_directory_internal,
2377 Smake_directory_internal, 1, 1, 0,
2378 "Create a new directory named DIRECTORY.")
2379 (directory)
2380 Lisp_Object directory;
2382 unsigned char *dir;
2383 Lisp_Object handler;
2384 Lisp_Object encoded_dir;
2386 CHECK_STRING (directory, 0);
2387 directory = Fexpand_file_name (directory, Qnil);
2389 handler = Ffind_file_name_handler (directory, Qmake_directory_internal);
2390 if (!NILP (handler))
2391 return call2 (handler, Qmake_directory_internal, directory);
2393 encoded_dir = ENCODE_FILE (directory);
2395 dir = XSTRING (encoded_dir)->data;
2397 #ifdef WINDOWSNT
2398 if (mkdir (dir) != 0)
2399 #else
2400 if (mkdir (dir, 0777) != 0)
2401 #endif
2402 report_file_error ("Creating directory", Flist (1, &directory));
2404 return Qnil;
2407 DEFUN ("delete-directory", Fdelete_directory, Sdelete_directory, 1, 1, "FDelete directory: ",
2408 "Delete the directory named DIRECTORY.")
2409 (directory)
2410 Lisp_Object directory;
2412 unsigned char *dir;
2413 Lisp_Object handler;
2414 Lisp_Object encoded_dir;
2416 CHECK_STRING (directory, 0);
2417 directory = Fdirectory_file_name (Fexpand_file_name (directory, Qnil));
2419 handler = Ffind_file_name_handler (directory, Qdelete_directory);
2420 if (!NILP (handler))
2421 return call2 (handler, Qdelete_directory, directory);
2423 encoded_dir = ENCODE_FILE (directory);
2425 dir = XSTRING (encoded_dir)->data;
2427 if (rmdir (dir) != 0)
2428 report_file_error ("Removing directory", Flist (1, &directory));
2430 return Qnil;
2433 DEFUN ("delete-file", Fdelete_file, Sdelete_file, 1, 1, "fDelete file: ",
2434 "Delete file named FILENAME.\n\
2435 If file has multiple names, it continues to exist with the other names.")
2436 (filename)
2437 Lisp_Object filename;
2439 Lisp_Object handler;
2440 Lisp_Object encoded_file;
2442 CHECK_STRING (filename, 0);
2443 filename = Fexpand_file_name (filename, Qnil);
2445 handler = Ffind_file_name_handler (filename, Qdelete_file);
2446 if (!NILP (handler))
2447 return call2 (handler, Qdelete_file, filename);
2449 encoded_file = ENCODE_FILE (filename);
2451 if (0 > unlink (XSTRING (encoded_file)->data))
2452 report_file_error ("Removing old name", Flist (1, &filename));
2453 return Qnil;
2456 static Lisp_Object
2457 internal_delete_file_1 (ignore)
2458 Lisp_Object ignore;
2460 return Qt;
2463 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */
2466 internal_delete_file (filename)
2467 Lisp_Object filename;
2469 return NILP (internal_condition_case_1 (Fdelete_file, filename,
2470 Qt, internal_delete_file_1));
2473 DEFUN ("rename-file", Frename_file, Srename_file, 2, 3,
2474 "fRename file: \nFRename %s to file: \np",
2475 "Rename FILE as NEWNAME. Both args strings.\n\
2476 If file has names other than FILE, it continues to have those names.\n\
2477 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2478 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2479 A number as third arg means request confirmation if NEWNAME already exists.\n\
2480 This is what happens in interactive use with M-x.")
2481 (file, newname, ok_if_already_exists)
2482 Lisp_Object file, newname, ok_if_already_exists;
2484 #ifdef NO_ARG_ARRAY
2485 Lisp_Object args[2];
2486 #endif
2487 Lisp_Object handler;
2488 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
2489 Lisp_Object encoded_file, encoded_newname;
2491 encoded_file = encoded_newname = Qnil;
2492 GCPRO4 (file, newname, encoded_file, encoded_newname);
2493 CHECK_STRING (file, 0);
2494 CHECK_STRING (newname, 1);
2495 file = Fexpand_file_name (file, Qnil);
2496 newname = Fexpand_file_name (newname, Qnil);
2498 /* If the file name has special constructs in it,
2499 call the corresponding file handler. */
2500 handler = Ffind_file_name_handler (file, Qrename_file);
2501 if (NILP (handler))
2502 handler = Ffind_file_name_handler (newname, Qrename_file);
2503 if (!NILP (handler))
2504 RETURN_UNGCPRO (call4 (handler, Qrename_file,
2505 file, newname, ok_if_already_exists));
2507 encoded_file = ENCODE_FILE (file);
2508 encoded_newname = ENCODE_FILE (newname);
2510 if (NILP (ok_if_already_exists)
2511 || INTEGERP (ok_if_already_exists))
2512 barf_or_query_if_file_exists (encoded_newname, "rename to it",
2513 INTEGERP (ok_if_already_exists), 0, 0);
2514 #ifndef BSD4_1
2515 if (0 > rename (XSTRING (encoded_file)->data, XSTRING (encoded_newname)->data))
2516 #else
2517 if (0 > link (XSTRING (encoded_file)->data, XSTRING (encoded_newname)->data)
2518 || 0 > unlink (XSTRING (encoded_file)->data))
2519 #endif
2521 if (errno == EXDEV)
2523 Fcopy_file (file, newname,
2524 /* We have already prompted if it was an integer,
2525 so don't have copy-file prompt again. */
2526 NILP (ok_if_already_exists) ? Qnil : Qt, Qt);
2527 Fdelete_file (file);
2529 else
2530 #ifdef NO_ARG_ARRAY
2532 args[0] = file;
2533 args[1] = newname;
2534 report_file_error ("Renaming", Flist (2, args));
2536 #else
2537 report_file_error ("Renaming", Flist (2, &file));
2538 #endif
2540 UNGCPRO;
2541 return Qnil;
2544 DEFUN ("add-name-to-file", Fadd_name_to_file, Sadd_name_to_file, 2, 3,
2545 "fAdd name to file: \nFName to add to %s: \np",
2546 "Give FILE additional name NEWNAME. Both args strings.\n\
2547 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2548 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2549 A number as third arg means request confirmation if NEWNAME already exists.\n\
2550 This is what happens in interactive use with M-x.")
2551 (file, newname, ok_if_already_exists)
2552 Lisp_Object file, newname, ok_if_already_exists;
2554 #ifdef NO_ARG_ARRAY
2555 Lisp_Object args[2];
2556 #endif
2557 Lisp_Object handler;
2558 Lisp_Object encoded_file, encoded_newname;
2559 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
2561 GCPRO4 (file, newname, encoded_file, encoded_newname);
2562 encoded_file = encoded_newname = Qnil;
2563 CHECK_STRING (file, 0);
2564 CHECK_STRING (newname, 1);
2565 file = Fexpand_file_name (file, Qnil);
2566 newname = Fexpand_file_name (newname, Qnil);
2568 /* If the file name has special constructs in it,
2569 call the corresponding file handler. */
2570 handler = Ffind_file_name_handler (file, Qadd_name_to_file);
2571 if (!NILP (handler))
2572 RETURN_UNGCPRO (call4 (handler, Qadd_name_to_file, file,
2573 newname, ok_if_already_exists));
2575 /* If the new name has special constructs in it,
2576 call the corresponding file handler. */
2577 handler = Ffind_file_name_handler (newname, Qadd_name_to_file);
2578 if (!NILP (handler))
2579 RETURN_UNGCPRO (call4 (handler, Qadd_name_to_file, file,
2580 newname, ok_if_already_exists));
2582 encoded_file = ENCODE_FILE (file);
2583 encoded_newname = ENCODE_FILE (newname);
2585 if (NILP (ok_if_already_exists)
2586 || INTEGERP (ok_if_already_exists))
2587 barf_or_query_if_file_exists (encoded_newname, "make it a new name",
2588 INTEGERP (ok_if_already_exists), 0, 0);
2590 unlink (XSTRING (newname)->data);
2591 if (0 > link (XSTRING (encoded_file)->data, XSTRING (encoded_newname)->data))
2593 #ifdef NO_ARG_ARRAY
2594 args[0] = file;
2595 args[1] = newname;
2596 report_file_error ("Adding new name", Flist (2, args));
2597 #else
2598 report_file_error ("Adding new name", Flist (2, &file));
2599 #endif
2602 UNGCPRO;
2603 return Qnil;
2606 #ifdef S_IFLNK
2607 DEFUN ("make-symbolic-link", Fmake_symbolic_link, Smake_symbolic_link, 2, 3,
2608 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2609 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
2610 Signals a `file-already-exists' error if a file LINKNAME already exists\n\
2611 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2612 A number as third arg means request confirmation if LINKNAME already exists.\n\
2613 This happens for interactive use with M-x.")
2614 (filename, linkname, ok_if_already_exists)
2615 Lisp_Object filename, linkname, ok_if_already_exists;
2617 #ifdef NO_ARG_ARRAY
2618 Lisp_Object args[2];
2619 #endif
2620 Lisp_Object handler;
2621 Lisp_Object encoded_filename, encoded_linkname;
2622 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
2624 GCPRO4 (filename, linkname, encoded_filename, encoded_linkname);
2625 encoded_filename = encoded_linkname = Qnil;
2626 CHECK_STRING (filename, 0);
2627 CHECK_STRING (linkname, 1);
2628 /* If the link target has a ~, we must expand it to get
2629 a truly valid file name. Otherwise, do not expand;
2630 we want to permit links to relative file names. */
2631 if (XSTRING (filename)->data[0] == '~')
2632 filename = Fexpand_file_name (filename, Qnil);
2633 linkname = Fexpand_file_name (linkname, Qnil);
2635 /* If the file name has special constructs in it,
2636 call the corresponding file handler. */
2637 handler = Ffind_file_name_handler (filename, Qmake_symbolic_link);
2638 if (!NILP (handler))
2639 RETURN_UNGCPRO (call4 (handler, Qmake_symbolic_link, filename,
2640 linkname, ok_if_already_exists));
2642 /* If the new link name has special constructs in it,
2643 call the corresponding file handler. */
2644 handler = Ffind_file_name_handler (linkname, Qmake_symbolic_link);
2645 if (!NILP (handler))
2646 RETURN_UNGCPRO (call4 (handler, Qmake_symbolic_link, filename,
2647 linkname, ok_if_already_exists));
2649 encoded_filename = ENCODE_FILE (filename);
2650 encoded_linkname = ENCODE_FILE (linkname);
2652 if (NILP (ok_if_already_exists)
2653 || INTEGERP (ok_if_already_exists))
2654 barf_or_query_if_file_exists (encoded_linkname, "make it a link",
2655 INTEGERP (ok_if_already_exists), 0, 0);
2656 if (0 > symlink (XSTRING (encoded_filename)->data,
2657 XSTRING (encoded_linkname)->data))
2659 /* If we didn't complain already, silently delete existing file. */
2660 if (errno == EEXIST)
2662 unlink (XSTRING (encoded_linkname)->data);
2663 if (0 <= symlink (XSTRING (encoded_filename)->data,
2664 XSTRING (encoded_linkname)->data))
2666 UNGCPRO;
2667 return Qnil;
2671 #ifdef NO_ARG_ARRAY
2672 args[0] = filename;
2673 args[1] = linkname;
2674 report_file_error ("Making symbolic link", Flist (2, args));
2675 #else
2676 report_file_error ("Making symbolic link", Flist (2, &filename));
2677 #endif
2679 UNGCPRO;
2680 return Qnil;
2682 #endif /* S_IFLNK */
2684 #ifdef VMS
2686 DEFUN ("define-logical-name", Fdefine_logical_name, Sdefine_logical_name,
2687 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2688 "Define the job-wide logical name NAME to have the value STRING.\n\
2689 If STRING is nil or a null string, the logical name NAME is deleted.")
2690 (name, string)
2691 Lisp_Object name;
2692 Lisp_Object string;
2694 CHECK_STRING (name, 0);
2695 if (NILP (string))
2696 delete_logical_name (XSTRING (name)->data);
2697 else
2699 CHECK_STRING (string, 1);
2701 if (XSTRING (string)->size == 0)
2702 delete_logical_name (XSTRING (name)->data);
2703 else
2704 define_logical_name (XSTRING (name)->data, XSTRING (string)->data);
2707 return string;
2709 #endif /* VMS */
2711 #ifdef HPUX_NET
2713 DEFUN ("sysnetunam", Fsysnetunam, Ssysnetunam, 2, 2, 0,
2714 "Open a network connection to PATH using LOGIN as the login string.")
2715 (path, login)
2716 Lisp_Object path, login;
2718 int netresult;
2720 CHECK_STRING (path, 0);
2721 CHECK_STRING (login, 0);
2723 netresult = netunam (XSTRING (path)->data, XSTRING (login)->data);
2725 if (netresult == -1)
2726 return Qnil;
2727 else
2728 return Qt;
2730 #endif /* HPUX_NET */
2732 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p, Sfile_name_absolute_p,
2733 1, 1, 0,
2734 "Return t if file FILENAME specifies an absolute file name.\n\
2735 On Unix, this is a name starting with a `/' or a `~'.")
2736 (filename)
2737 Lisp_Object filename;
2739 unsigned char *ptr;
2741 CHECK_STRING (filename, 0);
2742 ptr = XSTRING (filename)->data;
2743 if (IS_DIRECTORY_SEP (*ptr) || *ptr == '~'
2744 #ifdef VMS
2745 /* ??? This criterion is probably wrong for '<'. */
2746 || index (ptr, ':') || index (ptr, '<')
2747 || (*ptr == '[' && (ptr[1] != '-' || (ptr[2] != '.' && ptr[2] != ']'))
2748 && ptr[1] != '.')
2749 #endif /* VMS */
2750 #ifdef DOS_NT
2751 || (IS_DRIVE (*ptr) && ptr[1] == ':' && IS_DIRECTORY_SEP (ptr[2]))
2752 #endif
2754 return Qt;
2755 else
2756 return Qnil;
2759 /* Return nonzero if file FILENAME exists and can be executed. */
2761 static int
2762 check_executable (filename)
2763 char *filename;
2765 #ifdef DOS_NT
2766 int len = strlen (filename);
2767 char *suffix;
2768 struct stat st;
2769 if (stat (filename, &st) < 0)
2770 return 0;
2771 #if defined (WINDOWSNT) || (defined (MSDOS) && __DJGPP__ > 1)
2772 return ((st.st_mode & S_IEXEC) != 0);
2773 #else
2774 return (S_ISREG (st.st_mode)
2775 && len >= 5
2776 && (stricmp ((suffix = filename + len-4), ".com") == 0
2777 || stricmp (suffix, ".exe") == 0
2778 || stricmp (suffix, ".bat") == 0)
2779 || (st.st_mode & S_IFMT) == S_IFDIR);
2780 #endif /* not WINDOWSNT */
2781 #else /* not DOS_NT */
2782 #ifdef HAVE_EUIDACCESS
2783 return (euidaccess (filename, 1) >= 0);
2784 #else
2785 /* Access isn't quite right because it uses the real uid
2786 and we really want to test with the effective uid.
2787 But Unix doesn't give us a right way to do it. */
2788 return (access (filename, 1) >= 0);
2789 #endif
2790 #endif /* not DOS_NT */
2793 /* Return nonzero if file FILENAME exists and can be written. */
2795 static int
2796 check_writable (filename)
2797 char *filename;
2799 #ifdef MSDOS
2800 struct stat st;
2801 if (stat (filename, &st) < 0)
2802 return 0;
2803 return (st.st_mode & S_IWRITE || (st.st_mode & S_IFMT) == S_IFDIR);
2804 #else /* not MSDOS */
2805 #ifdef HAVE_EUIDACCESS
2806 return (euidaccess (filename, 2) >= 0);
2807 #else
2808 /* Access isn't quite right because it uses the real uid
2809 and we really want to test with the effective uid.
2810 But Unix doesn't give us a right way to do it.
2811 Opening with O_WRONLY could work for an ordinary file,
2812 but would lose for directories. */
2813 return (access (filename, 2) >= 0);
2814 #endif
2815 #endif /* not MSDOS */
2818 DEFUN ("file-exists-p", Ffile_exists_p, Sfile_exists_p, 1, 1, 0,
2819 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
2820 See also `file-readable-p' and `file-attributes'.")
2821 (filename)
2822 Lisp_Object filename;
2824 Lisp_Object absname;
2825 Lisp_Object handler;
2826 struct stat statbuf;
2828 CHECK_STRING (filename, 0);
2829 absname = Fexpand_file_name (filename, Qnil);
2831 /* If the file name has special constructs in it,
2832 call the corresponding file handler. */
2833 handler = Ffind_file_name_handler (absname, Qfile_exists_p);
2834 if (!NILP (handler))
2835 return call2 (handler, Qfile_exists_p, absname);
2837 absname = ENCODE_FILE (absname);
2839 return (stat (XSTRING (absname)->data, &statbuf) >= 0) ? Qt : Qnil;
2842 DEFUN ("file-executable-p", Ffile_executable_p, Sfile_executable_p, 1, 1, 0,
2843 "Return t if FILENAME can be executed by you.\n\
2844 For a directory, this means you can access files in that directory.")
2845 (filename)
2846 Lisp_Object filename;
2849 Lisp_Object absname;
2850 Lisp_Object handler;
2852 CHECK_STRING (filename, 0);
2853 absname = Fexpand_file_name (filename, Qnil);
2855 /* If the file name has special constructs in it,
2856 call the corresponding file handler. */
2857 handler = Ffind_file_name_handler (absname, Qfile_executable_p);
2858 if (!NILP (handler))
2859 return call2 (handler, Qfile_executable_p, absname);
2861 absname = ENCODE_FILE (absname);
2863 return (check_executable (XSTRING (absname)->data) ? Qt : Qnil);
2866 DEFUN ("file-readable-p", Ffile_readable_p, Sfile_readable_p, 1, 1, 0,
2867 "Return t if file FILENAME exists and you can read it.\n\
2868 See also `file-exists-p' and `file-attributes'.")
2869 (filename)
2870 Lisp_Object filename;
2872 Lisp_Object absname;
2873 Lisp_Object handler;
2874 int desc;
2875 int flags;
2876 struct stat statbuf;
2878 CHECK_STRING (filename, 0);
2879 absname = Fexpand_file_name (filename, Qnil);
2881 /* If the file name has special constructs in it,
2882 call the corresponding file handler. */
2883 handler = Ffind_file_name_handler (absname, Qfile_readable_p);
2884 if (!NILP (handler))
2885 return call2 (handler, Qfile_readable_p, absname);
2887 absname = ENCODE_FILE (absname);
2889 #ifdef DOS_NT
2890 /* Under MS-DOS and Windows, open does not work for directories. */
2891 if (access (XSTRING (absname)->data, 0) == 0)
2892 return Qt;
2893 return Qnil;
2894 #else /* not DOS_NT */
2895 flags = O_RDONLY;
2896 #if defined (S_ISFIFO) && defined (O_NONBLOCK)
2897 /* Opening a fifo without O_NONBLOCK can wait.
2898 We don't want to wait. But we don't want to mess wth O_NONBLOCK
2899 except in the case of a fifo, on a system which handles it. */
2900 desc = stat (XSTRING (absname)->data, &statbuf);
2901 if (desc < 0)
2902 return Qnil;
2903 if (S_ISFIFO (statbuf.st_mode))
2904 flags |= O_NONBLOCK;
2905 #endif
2906 desc = emacs_open (XSTRING (absname)->data, flags, 0);
2907 if (desc < 0)
2908 return Qnil;
2909 emacs_close (desc);
2910 return Qt;
2911 #endif /* not DOS_NT */
2914 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2915 on the RT/PC. */
2916 DEFUN ("file-writable-p", Ffile_writable_p, Sfile_writable_p, 1, 1, 0,
2917 "Return t if file FILENAME can be written or created by you.")
2918 (filename)
2919 Lisp_Object filename;
2921 Lisp_Object absname, dir, encoded;
2922 Lisp_Object handler;
2923 struct stat statbuf;
2925 CHECK_STRING (filename, 0);
2926 absname = Fexpand_file_name (filename, Qnil);
2928 /* If the file name has special constructs in it,
2929 call the corresponding file handler. */
2930 handler = Ffind_file_name_handler (absname, Qfile_writable_p);
2931 if (!NILP (handler))
2932 return call2 (handler, Qfile_writable_p, absname);
2934 encoded = ENCODE_FILE (absname);
2935 if (stat (XSTRING (encoded)->data, &statbuf) >= 0)
2936 return (check_writable (XSTRING (encoded)->data)
2937 ? Qt : Qnil);
2939 dir = Ffile_name_directory (absname);
2940 #ifdef VMS
2941 if (!NILP (dir))
2942 dir = Fdirectory_file_name (dir);
2943 #endif /* VMS */
2944 #ifdef MSDOS
2945 if (!NILP (dir))
2946 dir = Fdirectory_file_name (dir);
2947 #endif /* MSDOS */
2949 dir = ENCODE_FILE (dir);
2950 return (check_writable (!NILP (dir) ? (char *) XSTRING (dir)->data : "")
2951 ? Qt : Qnil);
2954 DEFUN ("access-file", Faccess_file, Saccess_file, 2, 2, 0,
2955 "Access file FILENAME, and get an error if that does not work.\n\
2956 The second argument STRING is used in the error message.\n\
2957 If there is no error, we return nil.")
2958 (filename, string)
2959 Lisp_Object filename, string;
2961 Lisp_Object handler, encoded_filename;
2962 int fd;
2964 CHECK_STRING (filename, 0);
2965 CHECK_STRING (string, 1);
2967 /* If the file name has special constructs in it,
2968 call the corresponding file handler. */
2969 handler = Ffind_file_name_handler (filename, Qaccess_file);
2970 if (!NILP (handler))
2971 return call3 (handler, Qaccess_file, filename, string);
2973 encoded_filename = ENCODE_FILE (filename);
2975 fd = emacs_open (XSTRING (encoded_filename)->data, O_RDONLY, 0);
2976 if (fd < 0)
2977 report_file_error (XSTRING (string)->data, Fcons (filename, Qnil));
2978 emacs_close (fd);
2980 return Qnil;
2983 DEFUN ("file-symlink-p", Ffile_symlink_p, Sfile_symlink_p, 1, 1, 0,
2984 "Return non-nil if file FILENAME is the name of a symbolic link.\n\
2985 The value is the name of the file to which it is linked.\n\
2986 Otherwise returns nil.")
2987 (filename)
2988 Lisp_Object filename;
2990 #ifdef S_IFLNK
2991 char *buf;
2992 int bufsize;
2993 int valsize;
2994 Lisp_Object val;
2995 Lisp_Object handler;
2997 CHECK_STRING (filename, 0);
2998 filename = Fexpand_file_name (filename, Qnil);
3000 /* If the file name has special constructs in it,
3001 call the corresponding file handler. */
3002 handler = Ffind_file_name_handler (filename, Qfile_symlink_p);
3003 if (!NILP (handler))
3004 return call2 (handler, Qfile_symlink_p, filename);
3006 filename = ENCODE_FILE (filename);
3008 bufsize = 100;
3009 while (1)
3011 buf = (char *) xmalloc (bufsize);
3012 bzero (buf, bufsize);
3013 valsize = readlink (XSTRING (filename)->data, buf, bufsize);
3014 if (valsize < bufsize) break;
3015 /* Buffer was not long enough */
3016 xfree (buf);
3017 bufsize *= 2;
3019 if (valsize == -1)
3021 xfree (buf);
3022 return Qnil;
3024 val = make_string (buf, valsize);
3025 if (buf[0] == '/' && index (buf, ':'))
3026 val = concat2 (build_string ("/:"), val);
3027 xfree (buf);
3028 val = DECODE_FILE (val);
3029 return val;
3030 #else /* not S_IFLNK */
3031 return Qnil;
3032 #endif /* not S_IFLNK */
3035 DEFUN ("file-directory-p", Ffile_directory_p, Sfile_directory_p, 1, 1, 0,
3036 "Return t if FILENAME names an existing directory.\n\
3037 Symbolic links to directories count as directories.\n\
3038 See `file-symlink-p' to distinguish symlinks.")
3039 (filename)
3040 Lisp_Object filename;
3042 register Lisp_Object absname;
3043 struct stat st;
3044 Lisp_Object handler;
3046 absname = expand_and_dir_to_file (filename, current_buffer->directory);
3048 /* If the file name has special constructs in it,
3049 call the corresponding file handler. */
3050 handler = Ffind_file_name_handler (absname, Qfile_directory_p);
3051 if (!NILP (handler))
3052 return call2 (handler, Qfile_directory_p, absname);
3054 absname = ENCODE_FILE (absname);
3056 if (stat (XSTRING (absname)->data, &st) < 0)
3057 return Qnil;
3058 return (st.st_mode & S_IFMT) == S_IFDIR ? Qt : Qnil;
3061 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p, Sfile_accessible_directory_p, 1, 1, 0,
3062 "Return t if file FILENAME is the name of a directory as a file,\n\
3063 and files in that directory can be opened by you. In order to use a\n\
3064 directory as a buffer's current directory, this predicate must return true.\n\
3065 A directory name spec may be given instead; then the value is t\n\
3066 if the directory so specified exists and really is a readable and\n\
3067 searchable directory.")
3068 (filename)
3069 Lisp_Object filename;
3071 Lisp_Object handler;
3072 int tem;
3073 struct gcpro gcpro1;
3075 /* If the file name has special constructs in it,
3076 call the corresponding file handler. */
3077 handler = Ffind_file_name_handler (filename, Qfile_accessible_directory_p);
3078 if (!NILP (handler))
3079 return call2 (handler, Qfile_accessible_directory_p, filename);
3081 /* It's an unlikely combination, but yes we really do need to gcpro:
3082 Suppose that file-accessible-directory-p has no handler, but
3083 file-directory-p does have a handler; this handler causes a GC which
3084 relocates the string in `filename'; and finally file-directory-p
3085 returns non-nil. Then we would end up passing a garbaged string
3086 to file-executable-p. */
3087 GCPRO1 (filename);
3088 tem = (NILP (Ffile_directory_p (filename))
3089 || NILP (Ffile_executable_p (filename)));
3090 UNGCPRO;
3091 return tem ? Qnil : Qt;
3094 DEFUN ("file-regular-p", Ffile_regular_p, Sfile_regular_p, 1, 1, 0,
3095 "Return t if file FILENAME is the name of a regular file.\n\
3096 This is the sort of file that holds an ordinary stream of data bytes.")
3097 (filename)
3098 Lisp_Object filename;
3100 register Lisp_Object absname;
3101 struct stat st;
3102 Lisp_Object handler;
3104 absname = expand_and_dir_to_file (filename, current_buffer->directory);
3106 /* If the file name has special constructs in it,
3107 call the corresponding file handler. */
3108 handler = Ffind_file_name_handler (absname, Qfile_regular_p);
3109 if (!NILP (handler))
3110 return call2 (handler, Qfile_regular_p, absname);
3112 absname = ENCODE_FILE (absname);
3114 #ifdef WINDOWSNT
3116 int result;
3117 Lisp_Object tem = Vw32_get_true_file_attributes;
3119 /* Tell stat to use expensive method to get accurate info. */
3120 Vw32_get_true_file_attributes = Qt;
3121 result = stat (XSTRING (absname)->data, &st);
3122 Vw32_get_true_file_attributes = tem;
3124 if (result < 0)
3125 return Qnil;
3126 return (st.st_mode & S_IFMT) == S_IFREG ? Qt : Qnil;
3128 #else
3129 if (stat (XSTRING (absname)->data, &st) < 0)
3130 return Qnil;
3131 return (st.st_mode & S_IFMT) == S_IFREG ? Qt : Qnil;
3132 #endif
3135 DEFUN ("file-modes", Ffile_modes, Sfile_modes, 1, 1, 0,
3136 "Return mode bits of file named FILENAME, as an integer.")
3137 (filename)
3138 Lisp_Object filename;
3140 Lisp_Object absname;
3141 struct stat st;
3142 Lisp_Object handler;
3144 absname = expand_and_dir_to_file (filename, current_buffer->directory);
3146 /* If the file name has special constructs in it,
3147 call the corresponding file handler. */
3148 handler = Ffind_file_name_handler (absname, Qfile_modes);
3149 if (!NILP (handler))
3150 return call2 (handler, Qfile_modes, absname);
3152 absname = ENCODE_FILE (absname);
3154 if (stat (XSTRING (absname)->data, &st) < 0)
3155 return Qnil;
3156 #if defined (MSDOS) && __DJGPP__ < 2
3157 if (check_executable (XSTRING (absname)->data))
3158 st.st_mode |= S_IEXEC;
3159 #endif /* MSDOS && __DJGPP__ < 2 */
3161 return make_number (st.st_mode & 07777);
3164 DEFUN ("set-file-modes", Fset_file_modes, Sset_file_modes, 2, 2, 0,
3165 "Set mode bits of file named FILENAME to MODE (an integer).\n\
3166 Only the 12 low bits of MODE are used.")
3167 (filename, mode)
3168 Lisp_Object filename, mode;
3170 Lisp_Object absname, encoded_absname;
3171 Lisp_Object handler;
3173 absname = Fexpand_file_name (filename, current_buffer->directory);
3174 CHECK_NUMBER (mode, 1);
3176 /* If the file name has special constructs in it,
3177 call the corresponding file handler. */
3178 handler = Ffind_file_name_handler (absname, Qset_file_modes);
3179 if (!NILP (handler))
3180 return call3 (handler, Qset_file_modes, absname, mode);
3182 encoded_absname = ENCODE_FILE (absname);
3184 if (chmod (XSTRING (encoded_absname)->data, XINT (mode)) < 0)
3185 report_file_error ("Doing chmod", Fcons (absname, Qnil));
3187 return Qnil;
3190 DEFUN ("set-default-file-modes", Fset_default_file_modes, Sset_default_file_modes, 1, 1, 0,
3191 "Set the file permission bits for newly created files.\n\
3192 The argument MODE should be an integer; only the low 9 bits are used.\n\
3193 This setting is inherited by subprocesses.")
3194 (mode)
3195 Lisp_Object mode;
3197 CHECK_NUMBER (mode, 0);
3199 umask ((~ XINT (mode)) & 0777);
3201 return Qnil;
3204 DEFUN ("default-file-modes", Fdefault_file_modes, Sdefault_file_modes, 0, 0, 0,
3205 "Return the default file protection for created files.\n\
3206 The value is an integer.")
3209 int realmask;
3210 Lisp_Object value;
3212 realmask = umask (0);
3213 umask (realmask);
3215 XSETINT (value, (~ realmask) & 0777);
3216 return value;
3220 #ifdef __NetBSD__
3221 #define unix 42
3222 #endif
3224 #ifdef unix
3225 DEFUN ("unix-sync", Funix_sync, Sunix_sync, 0, 0, "",
3226 "Tell Unix to finish all pending disk updates.")
3229 sync ();
3230 return Qnil;
3233 #endif /* unix */
3235 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p, Sfile_newer_than_file_p, 2, 2, 0,
3236 "Return t if file FILE1 is newer than file FILE2.\n\
3237 If FILE1 does not exist, the answer is nil;\n\
3238 otherwise, if FILE2 does not exist, the answer is t.")
3239 (file1, file2)
3240 Lisp_Object file1, file2;
3242 Lisp_Object absname1, absname2;
3243 struct stat st;
3244 int mtime1;
3245 Lisp_Object handler;
3246 struct gcpro gcpro1, gcpro2;
3248 CHECK_STRING (file1, 0);
3249 CHECK_STRING (file2, 0);
3251 absname1 = Qnil;
3252 GCPRO2 (absname1, file2);
3253 absname1 = expand_and_dir_to_file (file1, current_buffer->directory);
3254 absname2 = expand_and_dir_to_file (file2, current_buffer->directory);
3255 UNGCPRO;
3257 /* If the file name has special constructs in it,
3258 call the corresponding file handler. */
3259 handler = Ffind_file_name_handler (absname1, Qfile_newer_than_file_p);
3260 if (NILP (handler))
3261 handler = Ffind_file_name_handler (absname2, Qfile_newer_than_file_p);
3262 if (!NILP (handler))
3263 return call3 (handler, Qfile_newer_than_file_p, absname1, absname2);
3265 GCPRO2 (absname1, absname2);
3266 absname1 = ENCODE_FILE (absname1);
3267 absname2 = ENCODE_FILE (absname2);
3268 UNGCPRO;
3270 if (stat (XSTRING (absname1)->data, &st) < 0)
3271 return Qnil;
3273 mtime1 = st.st_mtime;
3275 if (stat (XSTRING (absname2)->data, &st) < 0)
3276 return Qt;
3278 return (mtime1 > st.st_mtime) ? Qt : Qnil;
3281 #ifdef DOS_NT
3282 Lisp_Object Qfind_buffer_file_type;
3283 #endif /* DOS_NT */
3285 #ifndef READ_BUF_SIZE
3286 #define READ_BUF_SIZE (64 << 10)
3287 #endif
3289 extern void adjust_markers_for_delete P_ ((int, int, int, int));
3291 /* This function is called after Lisp functions to decide a coding
3292 system are called, or when they cause an error. Before they are
3293 called, the current buffer is set unibyte and it contains only a
3294 newly inserted text (thus the buffer was empty before the
3295 insertion).
3297 The functions may set markers, overlays, text properties, or even
3298 alter the buffer contents, change the current buffer.
3300 Here, we reset all those changes by:
3301 o set back the current buffer.
3302 o move all markers and overlays to BEG.
3303 o remove all text properties.
3304 o set back the buffer multibyteness. */
3306 static Lisp_Object
3307 decide_coding_unwind (unwind_data)
3308 Lisp_Object unwind_data;
3310 Lisp_Object multibyte, undo_list, buffer;
3312 multibyte = XCAR (unwind_data);
3313 unwind_data = XCDR (unwind_data);
3314 undo_list = XCAR (unwind_data);
3315 buffer = XCDR (unwind_data);
3317 if (current_buffer != XBUFFER (buffer))
3318 set_buffer_internal (XBUFFER (buffer));
3319 adjust_markers_for_delete (BEG, BEG_BYTE, Z, Z_BYTE);
3320 adjust_overlays_for_delete (BEG, Z - BEG);
3321 BUF_INTERVALS (current_buffer) = 0;
3322 TEMP_SET_PT_BOTH (BEG, BEG_BYTE);
3324 /* Now we are safe to change the buffer's multibyteness directly. */
3325 current_buffer->enable_multibyte_characters = multibyte;
3326 current_buffer->undo_list = undo_list;
3328 return Qnil;
3331 DEFUN ("insert-file-contents", Finsert_file_contents, Sinsert_file_contents,
3332 1, 5, 0,
3333 "Insert contents of file FILENAME after point.\n\
3334 Returns list of absolute file name and number of bytes inserted.\n\
3335 If second argument VISIT is non-nil, the buffer's visited filename\n\
3336 and last save file modtime are set, and it is marked unmodified.\n\
3337 If visiting and the file does not exist, visiting is completed\n\
3338 before the error is signaled.\n\
3339 The optional third and fourth arguments BEG and END\n\
3340 specify what portion of the file to insert.\n\
3341 These arguments count bytes in the file, not characters in the buffer.\n\
3342 If VISIT is non-nil, BEG and END must be nil.\n\
3344 If optional fifth argument REPLACE is non-nil,\n\
3345 it means replace the current buffer contents (in the accessible portion)\n\
3346 with the file contents. This is better than simply deleting and inserting\n\
3347 the whole thing because (1) it preserves some marker positions\n\
3348 and (2) it puts less data in the undo list.\n\
3349 When REPLACE is non-nil, the value is the number of characters actually read,\n\
3350 which is often less than the number of characters to be read.\n\
3352 This does code conversion according to the value of\n\
3353 `coding-system-for-read' or `file-coding-system-alist',\n\
3354 and sets the variable `last-coding-system-used' to the coding system\n\
3355 actually used.")
3356 (filename, visit, beg, end, replace)
3357 Lisp_Object filename, visit, beg, end, replace;
3359 struct stat st;
3360 register int fd;
3361 int inserted = 0;
3362 register int how_much;
3363 register int unprocessed;
3364 int count = specpdl_ptr - specpdl;
3365 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
3366 Lisp_Object handler, val, insval, orig_filename;
3367 Lisp_Object p;
3368 int total;
3369 int not_regular = 0;
3370 unsigned char read_buf[READ_BUF_SIZE];
3371 struct coding_system coding;
3372 unsigned char buffer[1 << 14];
3373 int replace_handled = 0;
3374 int set_coding_system = 0;
3375 int coding_system_decided = 0;
3377 if (current_buffer->base_buffer && ! NILP (visit))
3378 error ("Cannot do file visiting in an indirect buffer");
3380 if (!NILP (current_buffer->read_only))
3381 Fbarf_if_buffer_read_only ();
3383 val = Qnil;
3384 p = Qnil;
3385 orig_filename = Qnil;
3387 GCPRO4 (filename, val, p, orig_filename);
3389 CHECK_STRING (filename, 0);
3390 filename = Fexpand_file_name (filename, Qnil);
3392 /* If the file name has special constructs in it,
3393 call the corresponding file handler. */
3394 handler = Ffind_file_name_handler (filename, Qinsert_file_contents);
3395 if (!NILP (handler))
3397 val = call6 (handler, Qinsert_file_contents, filename,
3398 visit, beg, end, replace);
3399 if (CONSP (val) && CONSP (XCDR (val)))
3400 inserted = XINT (XCAR (XCDR (val)));
3401 goto handled;
3404 orig_filename = filename;
3405 filename = ENCODE_FILE (filename);
3407 fd = -1;
3409 #ifdef WINDOWSNT
3411 Lisp_Object tem = Vw32_get_true_file_attributes;
3413 /* Tell stat to use expensive method to get accurate info. */
3414 Vw32_get_true_file_attributes = Qt;
3415 total = stat (XSTRING (filename)->data, &st);
3416 Vw32_get_true_file_attributes = tem;
3418 if (total < 0)
3419 #else
3420 #ifndef APOLLO
3421 if (stat (XSTRING (filename)->data, &st) < 0)
3422 #else
3423 if ((fd = emacs_open (XSTRING (filename)->data, O_RDONLY, 0)) < 0
3424 || fstat (fd, &st) < 0)
3425 #endif /* not APOLLO */
3426 #endif /* WINDOWSNT */
3428 if (fd >= 0) emacs_close (fd);
3429 badopen:
3430 if (NILP (visit))
3431 report_file_error ("Opening input file", Fcons (orig_filename, Qnil));
3432 st.st_mtime = -1;
3433 how_much = 0;
3434 if (!NILP (Vcoding_system_for_read))
3435 Fset (Qbuffer_file_coding_system, Vcoding_system_for_read);
3436 goto notfound;
3439 #ifdef S_IFREG
3440 /* This code will need to be changed in order to work on named
3441 pipes, and it's probably just not worth it. So we should at
3442 least signal an error. */
3443 if (!S_ISREG (st.st_mode))
3445 not_regular = 1;
3447 if (! NILP (visit))
3448 goto notfound;
3450 if (! NILP (replace) || ! NILP (beg) || ! NILP (end))
3451 Fsignal (Qfile_error,
3452 Fcons (build_string ("not a regular file"),
3453 Fcons (orig_filename, Qnil)));
3455 #endif
3457 if (fd < 0)
3458 if ((fd = emacs_open (XSTRING (filename)->data, O_RDONLY, 0)) < 0)
3459 goto badopen;
3461 /* Replacement should preserve point as it preserves markers. */
3462 if (!NILP (replace))
3463 record_unwind_protect (restore_point_unwind, Fpoint_marker ());
3465 record_unwind_protect (close_file_unwind, make_number (fd));
3467 /* Supposedly happens on VMS. */
3468 if (! not_regular && st.st_size < 0)
3469 error ("File size is negative");
3471 /* Prevent redisplay optimizations. */
3472 current_buffer->clip_changed = 1;
3474 if (!NILP (visit))
3476 if (!NILP (beg) || !NILP (end))
3477 error ("Attempt to visit less than an entire file");
3478 if (BEG < Z && NILP (replace))
3479 error ("Cannot do file visiting in a non-empty buffer");
3482 if (!NILP (beg))
3483 CHECK_NUMBER (beg, 0);
3484 else
3485 XSETFASTINT (beg, 0);
3487 if (!NILP (end))
3488 CHECK_NUMBER (end, 0);
3489 else
3491 if (! not_regular)
3493 XSETINT (end, st.st_size);
3495 /* Arithmetic overflow can occur if an Emacs integer cannot
3496 represent the file size, or if the calculations below
3497 overflow. The calculations below double the file size
3498 twice, so check that it can be multiplied by 4 safely. */
3499 if (XINT (end) != st.st_size
3500 || ((int) st.st_size * 4) / 4 != st.st_size)
3501 error ("Maximum buffer size exceeded");
3505 if (BEG < Z)
3507 /* Decide the coding system to use for reading the file now
3508 because we can't use an optimized method for handling
3509 `coding:' tag if the current buffer is not empty. */
3510 Lisp_Object val;
3511 val = Qnil;
3513 if (!NILP (Vcoding_system_for_read))
3514 val = Vcoding_system_for_read;
3515 else if (! NILP (replace))
3516 /* In REPLACE mode, we can use the same coding system
3517 that was used to visit the file. */
3518 val = current_buffer->buffer_file_coding_system;
3519 else
3521 /* Don't try looking inside a file for a coding system
3522 specification if it is not seekable. */
3523 if (! not_regular && ! NILP (Vset_auto_coding_function))
3525 /* Find a coding system specified in the heading two
3526 lines or in the tailing several lines of the file.
3527 We assume that the 1K-byte and 3K-byte for heading
3528 and tailing respectively are sufficient for this
3529 purpose. */
3530 int nread;
3532 if (st.st_size <= (1024 * 4))
3533 nread = emacs_read (fd, read_buf, 1024 * 4);
3534 else
3536 nread = emacs_read (fd, read_buf, 1024);
3537 if (nread >= 0)
3539 if (lseek (fd, st.st_size - (1024 * 3), 0) < 0)
3540 report_file_error ("Setting file position",
3541 Fcons (orig_filename, Qnil));
3542 nread += emacs_read (fd, read_buf + nread, 1024 * 3);
3546 if (nread < 0)
3547 error ("IO error reading %s: %s",
3548 XSTRING (orig_filename)->data, emacs_strerror (errno));
3549 else if (nread > 0)
3551 struct buffer *prev = current_buffer;
3552 int count1;
3554 record_unwind_protect (Fset_buffer, Fcurrent_buffer ());
3556 /* The call to temp_output_buffer_setup binds
3557 standard-output. */
3558 count1 = specpdl_ptr - specpdl;
3559 temp_output_buffer_setup (" *code-converting-work*");
3561 set_buffer_internal (XBUFFER (Vstandard_output));
3562 current_buffer->enable_multibyte_characters = Qnil;
3563 insert_1_both (read_buf, nread, nread, 0, 0, 0);
3564 TEMP_SET_PT_BOTH (BEG, BEG_BYTE);
3565 val = call2 (Vset_auto_coding_function,
3566 filename, make_number (nread));
3567 set_buffer_internal (prev);
3569 /* Remove the binding for standard-output. */
3570 unbind_to (count1, Qnil);
3572 /* Discard the unwind protect for recovering the
3573 current buffer. */
3574 specpdl_ptr--;
3576 /* Rewind the file for the actual read done later. */
3577 if (lseek (fd, 0, 0) < 0)
3578 report_file_error ("Setting file position",
3579 Fcons (orig_filename, Qnil));
3583 if (NILP (val))
3585 /* If we have not yet decided a coding system, check
3586 file-coding-system-alist. */
3587 Lisp_Object args[6], coding_systems;
3589 args[0] = Qinsert_file_contents, args[1] = orig_filename;
3590 args[2] = visit, args[3] = beg, args[4] = end, args[5] = replace;
3591 coding_systems = Ffind_operation_coding_system (6, args);
3592 if (CONSP (coding_systems))
3593 val = XCAR (coding_systems);
3597 setup_coding_system (Fcheck_coding_system (val), &coding);
3599 if (NILP (current_buffer->enable_multibyte_characters)
3600 && ! NILP (val))
3601 /* We must suppress all character code conversion except for
3602 end-of-line conversion. */
3603 setup_raw_text_coding_system (&coding);
3605 coding_system_decided = 1;
3608 /* Ensure we always set Vlast_coding_system_used. */
3609 set_coding_system = 1;
3611 /* If requested, replace the accessible part of the buffer
3612 with the file contents. Avoid replacing text at the
3613 beginning or end of the buffer that matches the file contents;
3614 that preserves markers pointing to the unchanged parts.
3616 Here we implement this feature in an optimized way
3617 for the case where code conversion is NOT needed.
3618 The following if-statement handles the case of conversion
3619 in a less optimal way.
3621 If the code conversion is "automatic" then we try using this
3622 method and hope for the best.
3623 But if we discover the need for conversion, we give up on this method
3624 and let the following if-statement handle the replace job. */
3625 if (!NILP (replace)
3626 && BEGV < ZV
3627 && ! CODING_REQUIRE_DECODING (&coding)
3628 && (coding.eol_type == CODING_EOL_UNDECIDED
3629 || coding.eol_type == CODING_EOL_LF))
3631 /* same_at_start and same_at_end count bytes,
3632 because file access counts bytes
3633 and BEG and END count bytes. */
3634 int same_at_start = BEGV_BYTE;
3635 int same_at_end = ZV_BYTE;
3636 int overlap;
3637 /* There is still a possibility we will find the need to do code
3638 conversion. If that happens, we set this variable to 1 to
3639 give up on handling REPLACE in the optimized way. */
3640 int giveup_match_end = 0;
3642 if (XINT (beg) != 0)
3644 if (lseek (fd, XINT (beg), 0) < 0)
3645 report_file_error ("Setting file position",
3646 Fcons (orig_filename, Qnil));
3649 immediate_quit = 1;
3650 QUIT;
3651 /* Count how many chars at the start of the file
3652 match the text at the beginning of the buffer. */
3653 while (1)
3655 int nread, bufpos;
3657 nread = emacs_read (fd, buffer, sizeof buffer);
3658 if (nread < 0)
3659 error ("IO error reading %s: %s",
3660 XSTRING (orig_filename)->data, emacs_strerror (errno));
3661 else if (nread == 0)
3662 break;
3664 if (coding.type == coding_type_undecided)
3665 detect_coding (&coding, buffer, nread);
3666 if (CODING_REQUIRE_DECODING (&coding))
3667 /* We found that the file should be decoded somehow.
3668 Let's give up here. */
3670 giveup_match_end = 1;
3671 break;
3674 if (coding.eol_type == CODING_EOL_UNDECIDED)
3675 detect_eol (&coding, buffer, nread);
3676 if (coding.eol_type != CODING_EOL_UNDECIDED
3677 && coding.eol_type != CODING_EOL_LF)
3678 /* We found that the format of eol should be decoded.
3679 Let's give up here. */
3681 giveup_match_end = 1;
3682 break;
3685 bufpos = 0;
3686 while (bufpos < nread && same_at_start < ZV_BYTE
3687 && FETCH_BYTE (same_at_start) == buffer[bufpos])
3688 same_at_start++, bufpos++;
3689 /* If we found a discrepancy, stop the scan.
3690 Otherwise loop around and scan the next bufferful. */
3691 if (bufpos != nread)
3692 break;
3694 immediate_quit = 0;
3695 /* If the file matches the buffer completely,
3696 there's no need to replace anything. */
3697 if (same_at_start - BEGV_BYTE == XINT (end))
3699 emacs_close (fd);
3700 specpdl_ptr--;
3701 /* Truncate the buffer to the size of the file. */
3702 del_range_1 (same_at_start, same_at_end, 0, 0);
3703 goto handled;
3705 immediate_quit = 1;
3706 QUIT;
3707 /* Count how many chars at the end of the file
3708 match the text at the end of the buffer. But, if we have
3709 already found that decoding is necessary, don't waste time. */
3710 while (!giveup_match_end)
3712 int total_read, nread, bufpos, curpos, trial;
3714 /* At what file position are we now scanning? */
3715 curpos = XINT (end) - (ZV_BYTE - same_at_end);
3716 /* If the entire file matches the buffer tail, stop the scan. */
3717 if (curpos == 0)
3718 break;
3719 /* How much can we scan in the next step? */
3720 trial = min (curpos, sizeof buffer);
3721 if (lseek (fd, curpos - trial, 0) < 0)
3722 report_file_error ("Setting file position",
3723 Fcons (orig_filename, Qnil));
3725 total_read = 0;
3726 while (total_read < trial)
3728 nread = emacs_read (fd, buffer + total_read, trial - total_read);
3729 if (nread <= 0)
3730 error ("IO error reading %s: %s",
3731 XSTRING (orig_filename)->data, emacs_strerror (errno));
3732 total_read += nread;
3734 /* Scan this bufferful from the end, comparing with
3735 the Emacs buffer. */
3736 bufpos = total_read;
3737 /* Compare with same_at_start to avoid counting some buffer text
3738 as matching both at the file's beginning and at the end. */
3739 while (bufpos > 0 && same_at_end > same_at_start
3740 && FETCH_BYTE (same_at_end - 1) == buffer[bufpos - 1])
3741 same_at_end--, bufpos--;
3743 /* If we found a discrepancy, stop the scan.
3744 Otherwise loop around and scan the preceding bufferful. */
3745 if (bufpos != 0)
3747 /* If this discrepancy is because of code conversion,
3748 we cannot use this method; giveup and try the other. */
3749 if (same_at_end > same_at_start
3750 && FETCH_BYTE (same_at_end - 1) >= 0200
3751 && ! NILP (current_buffer->enable_multibyte_characters)
3752 && (CODING_MAY_REQUIRE_DECODING (&coding)))
3753 giveup_match_end = 1;
3754 break;
3757 immediate_quit = 0;
3759 if (! giveup_match_end)
3761 int temp;
3763 /* We win! We can handle REPLACE the optimized way. */
3765 /* Extend the start of non-matching text area to multibyte
3766 character boundary. */
3767 if (! NILP (current_buffer->enable_multibyte_characters))
3768 while (same_at_start > BEGV_BYTE
3769 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start)))
3770 same_at_start--;
3772 /* Extend the end of non-matching text area to multibyte
3773 character boundary. */
3774 if (! NILP (current_buffer->enable_multibyte_characters))
3775 while (same_at_end < ZV_BYTE
3776 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end)))
3777 same_at_end++;
3779 /* Don't try to reuse the same piece of text twice. */
3780 overlap = (same_at_start - BEGV_BYTE
3781 - (same_at_end + st.st_size - ZV));
3782 if (overlap > 0)
3783 same_at_end += overlap;
3785 /* Arrange to read only the nonmatching middle part of the file. */
3786 XSETFASTINT (beg, XINT (beg) + (same_at_start - BEGV_BYTE));
3787 XSETFASTINT (end, XINT (end) - (ZV_BYTE - same_at_end));
3789 del_range_byte (same_at_start, same_at_end, 0);
3790 /* Insert from the file at the proper position. */
3791 temp = BYTE_TO_CHAR (same_at_start);
3792 SET_PT_BOTH (temp, same_at_start);
3794 /* If display currently starts at beginning of line,
3795 keep it that way. */
3796 if (XBUFFER (XWINDOW (selected_window)->buffer) == current_buffer)
3797 XWINDOW (selected_window)->start_at_line_beg = Fbolp ();
3799 replace_handled = 1;
3803 /* If requested, replace the accessible part of the buffer
3804 with the file contents. Avoid replacing text at the
3805 beginning or end of the buffer that matches the file contents;
3806 that preserves markers pointing to the unchanged parts.
3808 Here we implement this feature for the case where code conversion
3809 is needed, in a simple way that needs a lot of memory.
3810 The preceding if-statement handles the case of no conversion
3811 in a more optimized way. */
3812 if (!NILP (replace) && ! replace_handled && BEGV < ZV)
3814 int same_at_start = BEGV_BYTE;
3815 int same_at_end = ZV_BYTE;
3816 int overlap;
3817 int bufpos;
3818 /* Make sure that the gap is large enough. */
3819 int bufsize = 2 * st.st_size;
3820 unsigned char *conversion_buffer = (unsigned char *) xmalloc (bufsize);
3821 int temp;
3823 /* First read the whole file, performing code conversion into
3824 CONVERSION_BUFFER. */
3826 if (lseek (fd, XINT (beg), 0) < 0)
3828 xfree (conversion_buffer);
3829 report_file_error ("Setting file position",
3830 Fcons (orig_filename, Qnil));
3833 total = st.st_size; /* Total bytes in the file. */
3834 how_much = 0; /* Bytes read from file so far. */
3835 inserted = 0; /* Bytes put into CONVERSION_BUFFER so far. */
3836 unprocessed = 0; /* Bytes not processed in previous loop. */
3838 while (how_much < total)
3840 /* try is reserved in some compilers (Microsoft C) */
3841 int trytry = min (total - how_much, READ_BUF_SIZE - unprocessed);
3842 unsigned char *destination = read_buf + unprocessed;
3843 int this;
3845 /* Allow quitting out of the actual I/O. */
3846 immediate_quit = 1;
3847 QUIT;
3848 this = emacs_read (fd, destination, trytry);
3849 immediate_quit = 0;
3851 if (this < 0 || this + unprocessed == 0)
3853 how_much = this;
3854 break;
3857 how_much += this;
3859 if (CODING_MAY_REQUIRE_DECODING (&coding))
3861 int require, result;
3863 this += unprocessed;
3865 /* If we are using more space than estimated,
3866 make CONVERSION_BUFFER bigger. */
3867 require = decoding_buffer_size (&coding, this);
3868 if (inserted + require + 2 * (total - how_much) > bufsize)
3870 bufsize = inserted + require + 2 * (total - how_much);
3871 conversion_buffer = (unsigned char *) xrealloc (conversion_buffer, bufsize);
3874 /* Convert this batch with results in CONVERSION_BUFFER. */
3875 if (how_much >= total) /* This is the last block. */
3876 coding.mode |= CODING_MODE_LAST_BLOCK;
3877 result = decode_coding (&coding, read_buf,
3878 conversion_buffer + inserted,
3879 this, bufsize - inserted);
3881 /* Save for next iteration whatever we didn't convert. */
3882 unprocessed = this - coding.consumed;
3883 bcopy (read_buf + coding.consumed, read_buf, unprocessed);
3884 this = coding.produced;
3887 inserted += this;
3890 /* At this point, INSERTED is how many characters (i.e. bytes)
3891 are present in CONVERSION_BUFFER.
3892 HOW_MUCH should equal TOTAL,
3893 or should be <= 0 if we couldn't read the file. */
3895 if (how_much < 0)
3897 xfree (conversion_buffer);
3899 if (how_much == -1)
3900 error ("IO error reading %s: %s",
3901 XSTRING (orig_filename)->data, emacs_strerror (errno));
3902 else if (how_much == -2)
3903 error ("maximum buffer size exceeded");
3906 /* Compare the beginning of the converted file
3907 with the buffer text. */
3909 bufpos = 0;
3910 while (bufpos < inserted && same_at_start < same_at_end
3911 && FETCH_BYTE (same_at_start) == conversion_buffer[bufpos])
3912 same_at_start++, bufpos++;
3914 /* If the file matches the buffer completely,
3915 there's no need to replace anything. */
3917 if (bufpos == inserted)
3919 xfree (conversion_buffer);
3920 emacs_close (fd);
3921 specpdl_ptr--;
3922 /* Truncate the buffer to the size of the file. */
3923 del_range_byte (same_at_start, same_at_end, 0);
3924 inserted = 0;
3925 goto handled;
3928 /* Extend the start of non-matching text area to multibyte
3929 character boundary. */
3930 if (! NILP (current_buffer->enable_multibyte_characters))
3931 while (same_at_start > BEGV_BYTE
3932 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start)))
3933 same_at_start--;
3935 /* Scan this bufferful from the end, comparing with
3936 the Emacs buffer. */
3937 bufpos = inserted;
3939 /* Compare with same_at_start to avoid counting some buffer text
3940 as matching both at the file's beginning and at the end. */
3941 while (bufpos > 0 && same_at_end > same_at_start
3942 && FETCH_BYTE (same_at_end - 1) == conversion_buffer[bufpos - 1])
3943 same_at_end--, bufpos--;
3945 /* Extend the end of non-matching text area to multibyte
3946 character boundary. */
3947 if (! NILP (current_buffer->enable_multibyte_characters))
3948 while (same_at_end < ZV_BYTE
3949 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end)))
3950 same_at_end++;
3952 /* Don't try to reuse the same piece of text twice. */
3953 overlap = same_at_start - BEGV_BYTE - (same_at_end + inserted - ZV_BYTE);
3954 if (overlap > 0)
3955 same_at_end += overlap;
3957 /* If display currently starts at beginning of line,
3958 keep it that way. */
3959 if (XBUFFER (XWINDOW (selected_window)->buffer) == current_buffer)
3960 XWINDOW (selected_window)->start_at_line_beg = Fbolp ();
3962 /* Replace the chars that we need to replace,
3963 and update INSERTED to equal the number of bytes
3964 we are taking from the file. */
3965 inserted -= (Z_BYTE - same_at_end) + (same_at_start - BEG_BYTE);
3967 if (same_at_end != same_at_start)
3969 del_range_byte (same_at_start, same_at_end, 0);
3970 temp = GPT;
3971 same_at_start = GPT_BYTE;
3973 else
3975 temp = BYTE_TO_CHAR (same_at_start);
3977 /* Insert from the file at the proper position. */
3978 SET_PT_BOTH (temp, same_at_start);
3979 insert_1 (conversion_buffer + same_at_start - BEG_BYTE, inserted,
3980 0, 0, 0);
3981 /* Set `inserted' to the number of inserted characters. */
3982 inserted = PT - temp;
3984 free (conversion_buffer);
3985 emacs_close (fd);
3986 specpdl_ptr--;
3988 goto handled;
3991 if (! not_regular)
3993 register Lisp_Object temp;
3995 total = XINT (end) - XINT (beg);
3997 /* Make sure point-max won't overflow after this insertion. */
3998 XSETINT (temp, total);
3999 if (total != XINT (temp))
4000 error ("Maximum buffer size exceeded");
4002 else
4003 /* For a special file, all we can do is guess. */
4004 total = READ_BUF_SIZE;
4006 if (NILP (visit) && total > 0)
4007 prepare_to_modify_buffer (PT, PT, NULL);
4009 move_gap (PT);
4010 if (GAP_SIZE < total)
4011 make_gap (total - GAP_SIZE);
4013 if (XINT (beg) != 0 || !NILP (replace))
4015 if (lseek (fd, XINT (beg), 0) < 0)
4016 report_file_error ("Setting file position",
4017 Fcons (orig_filename, Qnil));
4020 /* In the following loop, HOW_MUCH contains the total bytes read so
4021 far for a regular file, and not changed for a special file. But,
4022 before exiting the loop, it is set to a negative value if I/O
4023 error occurs. */
4024 how_much = 0;
4025 /* Total bytes inserted. */
4026 inserted = 0;
4027 /* Here, we don't do code conversion in the loop. It is done by
4028 code_convert_region after all data are read into the buffer. */
4029 while (how_much < total)
4031 /* try is reserved in some compilers (Microsoft C) */
4032 int trytry = min (total - how_much, READ_BUF_SIZE);
4033 int this;
4035 /* For a special file, GAP_SIZE should be checked every time. */
4036 if (not_regular && GAP_SIZE < trytry)
4037 make_gap (total - GAP_SIZE);
4039 /* Allow quitting out of the actual I/O. */
4040 immediate_quit = 1;
4041 QUIT;
4042 this = emacs_read (fd, BYTE_POS_ADDR (PT_BYTE + inserted - 1) + 1,
4043 trytry);
4044 immediate_quit = 0;
4046 if (this <= 0)
4048 how_much = this;
4049 break;
4052 GAP_SIZE -= this;
4053 GPT_BYTE += this;
4054 ZV_BYTE += this;
4055 Z_BYTE += this;
4056 GPT += this;
4057 ZV += this;
4058 Z += this;
4060 /* For a regular file, where TOTAL is the real size,
4061 count HOW_MUCH to compare with it.
4062 For a special file, where TOTAL is just a buffer size,
4063 so don't bother counting in HOW_MUCH.
4064 (INSERTED is where we count the number of characters inserted.) */
4065 if (! not_regular)
4066 how_much += this;
4067 inserted += this;
4070 if (GAP_SIZE > 0)
4071 /* Put an anchor to ensure multi-byte form ends at gap. */
4072 *GPT_ADDR = 0;
4074 emacs_close (fd);
4076 /* Discard the unwind protect for closing the file. */
4077 specpdl_ptr--;
4079 if (how_much < 0)
4080 error ("IO error reading %s: %s",
4081 XSTRING (orig_filename)->data, emacs_strerror (errno));
4083 if (! coding_system_decided)
4085 /* The coding system is not yet decided. Decide it by an
4086 optimized method for handling `coding:' tag.
4088 Note that we can get here only if the buffer was empty
4089 before the insertion. */
4090 Lisp_Object val;
4091 val = Qnil;
4093 if (!NILP (Vcoding_system_for_read))
4094 val = Vcoding_system_for_read;
4095 else
4097 /* Since we are sure that the current buffer was empty
4098 before the insertion, we can toggle
4099 enable-multibyte-characters directly here without taking
4100 care of marker adjustment and byte combining problem. By
4101 this way, we can run Lisp program safely before decoding
4102 the inserted text. */
4103 Lisp_Object unwind_data;
4104 int count = specpdl_ptr - specpdl;
4106 unwind_data = Fcons (current_buffer->enable_multibyte_characters,
4107 Fcons (current_buffer->undo_list,
4108 Fcurrent_buffer ()));
4109 current_buffer->enable_multibyte_characters = Qnil;
4110 current_buffer->undo_list = Qt;
4111 record_unwind_protect (decide_coding_unwind, unwind_data);
4113 if (inserted > 0 && ! NILP (Vset_auto_coding_function))
4115 val = call2 (Vset_auto_coding_function,
4116 filename, make_number (inserted));
4119 if (NILP (val))
4121 /* If the coding system is not yet decided, check
4122 file-coding-system-alist. */
4123 Lisp_Object args[6], coding_systems;
4125 args[0] = Qinsert_file_contents, args[1] = orig_filename;
4126 args[2] = visit, args[3] = beg, args[4] = end, args[5] = Qnil;
4127 coding_systems = Ffind_operation_coding_system (6, args);
4128 if (CONSP (coding_systems))
4129 val = XCAR (coding_systems);
4132 unbind_to (count, Qnil);
4133 inserted = Z_BYTE - BEG_BYTE;
4136 /* The following kludgy code is to avoid some compiler bug.
4137 We can't simply do
4138 setup_coding_system (val, &coding);
4139 on some system. */
4141 struct coding_system temp_coding;
4142 setup_coding_system (val, &temp_coding);
4143 bcopy (&temp_coding, &coding, sizeof coding);
4146 if (NILP (current_buffer->enable_multibyte_characters)
4147 && ! NILP (val))
4148 /* We must suppress all character code conversion except for
4149 end-of-line conversion. */
4150 setup_raw_text_coding_system (&coding);
4153 if (inserted > 0 || coding.type == coding_type_ccl)
4155 if (CODING_MAY_REQUIRE_DECODING (&coding))
4157 /* Here, we don't have to consider byte combining (see the
4158 comment below) because code_convert_region takes care of
4159 it. */
4160 code_convert_region (PT, PT_BYTE, PT + inserted, PT_BYTE + inserted,
4161 &coding, 0, 0);
4162 inserted = (NILP (current_buffer->enable_multibyte_characters)
4163 ? coding.produced : coding.produced_char);
4165 else if (!NILP (current_buffer->enable_multibyte_characters))
4167 int inserted_byte = inserted;
4169 /* There's a possibility that we must combine bytes at the
4170 head (resp. the tail) of the just inserted text with the
4171 bytes before (resp. after) the gap to form a single
4172 character. */
4173 inserted = multibyte_chars_in_text (GPT_ADDR - inserted, inserted);
4174 adjust_after_insert (PT, PT_BYTE,
4175 PT + inserted_byte, PT_BYTE + inserted_byte,
4176 inserted);
4178 else
4179 adjust_after_insert (PT, PT_BYTE, PT + inserted, PT_BYTE + inserted,
4180 inserted);
4183 #ifdef DOS_NT
4184 /* Use the conversion type to determine buffer-file-type
4185 (find-buffer-file-type is now used to help determine the
4186 conversion). */
4187 if ((coding.eol_type == CODING_EOL_UNDECIDED
4188 || coding.eol_type == CODING_EOL_LF)
4189 && ! CODING_REQUIRE_DECODING (&coding))
4190 current_buffer->buffer_file_type = Qt;
4191 else
4192 current_buffer->buffer_file_type = Qnil;
4193 #endif
4195 notfound:
4196 handled:
4198 if (!NILP (visit))
4200 if (!EQ (current_buffer->undo_list, Qt))
4201 current_buffer->undo_list = Qnil;
4202 #ifdef APOLLO
4203 stat (XSTRING (filename)->data, &st);
4204 #endif
4206 if (NILP (handler))
4208 current_buffer->modtime = st.st_mtime;
4209 current_buffer->filename = orig_filename;
4212 SAVE_MODIFF = MODIFF;
4213 current_buffer->auto_save_modified = MODIFF;
4214 XSETFASTINT (current_buffer->save_length, Z - BEG);
4215 #ifdef CLASH_DETECTION
4216 if (NILP (handler))
4218 if (!NILP (current_buffer->file_truename))
4219 unlock_file (current_buffer->file_truename);
4220 unlock_file (filename);
4222 #endif /* CLASH_DETECTION */
4223 if (not_regular)
4224 Fsignal (Qfile_error,
4225 Fcons (build_string ("not a regular file"),
4226 Fcons (orig_filename, Qnil)));
4228 /* If visiting nonexistent file, return nil. */
4229 if (current_buffer->modtime == -1)
4230 report_file_error ("Opening input file", Fcons (orig_filename, Qnil));
4233 /* Decode file format */
4234 if (inserted > 0)
4236 insval = call3 (Qformat_decode,
4237 Qnil, make_number (inserted), visit);
4238 CHECK_NUMBER (insval, 0);
4239 inserted = XFASTINT (insval);
4242 if (set_coding_system)
4243 Vlast_coding_system_used = coding.symbol;
4245 /* Call after-change hooks for the inserted text, aside from the case
4246 of normal visiting (not with REPLACE), which is done in a new buffer
4247 "before" the buffer is changed. */
4248 if (inserted > 0 && total > 0
4249 && (NILP (visit) || !NILP (replace)))
4251 signal_after_change (PT, 0, inserted);
4252 update_compositions (PT, PT, CHECK_BORDER);
4255 if (inserted > 0)
4257 p = Vafter_insert_file_functions;
4258 while (!NILP (p))
4260 insval = call1 (Fcar (p), make_number (inserted));
4261 if (!NILP (insval))
4263 CHECK_NUMBER (insval, 0);
4264 inserted = XFASTINT (insval);
4266 QUIT;
4267 p = Fcdr (p);
4271 /* ??? Retval needs to be dealt with in all cases consistently. */
4272 if (NILP (val))
4273 val = Fcons (orig_filename,
4274 Fcons (make_number (inserted),
4275 Qnil));
4277 RETURN_UNGCPRO (unbind_to (count, val));
4280 static Lisp_Object build_annotations P_ ((Lisp_Object, Lisp_Object,
4281 Lisp_Object));
4283 /* If build_annotations switched buffers, switch back to BUF.
4284 Kill the temporary buffer that was selected in the meantime.
4286 Since this kill only the last temporary buffer, some buffers remain
4287 not killed if build_annotations switched buffers more than once.
4288 -- K.Handa */
4290 static Lisp_Object
4291 build_annotations_unwind (buf)
4292 Lisp_Object buf;
4294 Lisp_Object tembuf;
4296 if (XBUFFER (buf) == current_buffer)
4297 return Qnil;
4298 tembuf = Fcurrent_buffer ();
4299 Fset_buffer (buf);
4300 Fkill_buffer (tembuf);
4301 return Qnil;
4304 DEFUN ("write-region", Fwrite_region, Swrite_region, 3, 7,
4305 "r\nFWrite region to file: \ni\ni\ni\np",
4306 "Write current region into specified file.\n\
4307 When called from a program, takes three arguments:\n\
4308 START, END and FILENAME. START and END are buffer positions.\n\
4309 Optional fourth argument APPEND if non-nil means\n\
4310 append to existing file contents (if any).\n\
4311 Optional fifth argument VISIT if t means\n\
4312 set the last-save-file-modtime of buffer to this file's modtime\n\
4313 and mark buffer not modified.\n\
4314 If VISIT is a string, it is a second file name;\n\
4315 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
4316 VISIT is also the file name to lock and unlock for clash detection.\n\
4317 If VISIT is neither t nor nil nor a string,\n\
4318 that means do not print the \"Wrote file\" message.\n\
4319 The optional sixth arg LOCKNAME, if non-nil, specifies the name to\n\
4320 use for locking and unlocking, overriding FILENAME and VISIT.\n\
4321 The optional seventh arg MUSTBENEW, if non-nil, insists on a check\n\
4322 for an existing file with the same name. If MUSTBENEW is `excl',\n\
4323 that means to get an error if the file already exists; never overwrite.\n\
4324 If MUSTBENEW is neither nil nor `excl', that means ask for\n\
4325 confirmation before overwriting, but do go ahead and overwrite the file\n\
4326 if the user confirms.\n\
4327 Kludgy feature: if START is a string, then that string is written\n\
4328 to the file, instead of any buffer contents, and END is ignored.\n\
4330 This does code conversion according to the value of\n\
4331 `coding-system-for-write', `buffer-file-coding-system', or\n\
4332 `file-coding-system-alist', and sets the variable\n\
4333 `last-coding-system-used' to the coding system actually used.")
4335 (start, end, filename, append, visit, lockname, mustbenew)
4336 Lisp_Object start, end, filename, append, visit, lockname, mustbenew;
4338 register int desc;
4339 int failure;
4340 int save_errno;
4341 unsigned char *fn;
4342 struct stat st;
4343 int tem;
4344 int count = specpdl_ptr - specpdl;
4345 int count1;
4346 #ifdef VMS
4347 unsigned char *fname = 0; /* If non-0, original filename (must rename) */
4348 #endif /* VMS */
4349 Lisp_Object handler;
4350 Lisp_Object visit_file;
4351 Lisp_Object annotations;
4352 Lisp_Object encoded_filename;
4353 int visiting, quietly;
4354 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
4355 struct buffer *given_buffer;
4356 #ifdef DOS_NT
4357 int buffer_file_type = O_BINARY;
4358 #endif /* DOS_NT */
4359 struct coding_system coding;
4361 if (current_buffer->base_buffer && ! NILP (visit))
4362 error ("Cannot do file visiting in an indirect buffer");
4364 if (!NILP (start) && !STRINGP (start))
4365 validate_region (&start, &end);
4367 GCPRO4 (start, filename, visit, lockname);
4369 /* Decide the coding-system to encode the data with. */
4371 Lisp_Object val;
4373 if (auto_saving)
4374 val = Qnil;
4375 else if (!NILP (Vcoding_system_for_write))
4376 val = Vcoding_system_for_write;
4377 else
4379 /* If the variable `buffer-file-coding-system' is set locally,
4380 it means that the file was read with some kind of code
4381 conversion or the varialbe is explicitely set by users. We
4382 had better write it out with the same coding system even if
4383 `enable-multibyte-characters' is nil.
4385 If it is not set locally, we anyway have to convert EOL
4386 format if the default value of `buffer-file-coding-system'
4387 tells that it is not Unix-like (LF only) format. */
4388 int using_default_coding = 0;
4389 int force_raw_text = 0;
4391 val = current_buffer->buffer_file_coding_system;
4392 if (NILP (val)
4393 || NILP (Flocal_variable_p (Qbuffer_file_coding_system, Qnil)))
4395 val = Qnil;
4396 if (NILP (current_buffer->enable_multibyte_characters))
4397 force_raw_text = 1;
4400 if (NILP (val))
4402 /* Check file-coding-system-alist. */
4403 Lisp_Object args[7], coding_systems;
4405 args[0] = Qwrite_region; args[1] = start; args[2] = end;
4406 args[3] = filename; args[4] = append; args[5] = visit;
4407 args[6] = lockname;
4408 coding_systems = Ffind_operation_coding_system (7, args);
4409 if (CONSP (coding_systems) && !NILP (XCDR (coding_systems)))
4410 val = XCDR (coding_systems);
4413 if (NILP (val)
4414 && !NILP (current_buffer->buffer_file_coding_system))
4416 /* If we still have not decided a coding system, use the
4417 default value of buffer-file-coding-system. */
4418 val = current_buffer->buffer_file_coding_system;
4419 using_default_coding = 1;
4422 if (!force_raw_text
4423 && !NILP (Ffboundp (Vselect_safe_coding_system_function)))
4424 /* Confirm that VAL can surely encode the current region. */
4425 val = call3 (Vselect_safe_coding_system_function, start, end, val);
4427 setup_coding_system (Fcheck_coding_system (val), &coding);
4428 if (coding.eol_type == CODING_EOL_UNDECIDED
4429 && !using_default_coding)
4431 if (! EQ (default_buffer_file_coding.symbol,
4432 buffer_defaults.buffer_file_coding_system))
4433 setup_coding_system (buffer_defaults.buffer_file_coding_system,
4434 &default_buffer_file_coding);
4435 if (default_buffer_file_coding.eol_type != CODING_EOL_UNDECIDED)
4437 Lisp_Object subsidiaries;
4439 coding.eol_type = default_buffer_file_coding.eol_type;
4440 subsidiaries = Fget (coding.symbol, Qeol_type);
4441 if (VECTORP (subsidiaries)
4442 && XVECTOR (subsidiaries)->size == 3)
4443 coding.symbol
4444 = XVECTOR (subsidiaries)->contents[coding.eol_type];
4448 if (force_raw_text)
4449 setup_raw_text_coding_system (&coding);
4450 goto done_setup_coding;
4453 setup_coding_system (Fcheck_coding_system (val), &coding);
4455 done_setup_coding:
4456 if (!STRINGP (start) && !NILP (current_buffer->selective_display))
4457 coding.mode |= CODING_MODE_SELECTIVE_DISPLAY;
4460 Vlast_coding_system_used = coding.symbol;
4462 filename = Fexpand_file_name (filename, Qnil);
4464 if (! NILP (mustbenew) && mustbenew != Qexcl)
4465 barf_or_query_if_file_exists (filename, "overwrite", 1, 0, 1);
4467 if (STRINGP (visit))
4468 visit_file = Fexpand_file_name (visit, Qnil);
4469 else
4470 visit_file = filename;
4471 UNGCPRO;
4473 visiting = (EQ (visit, Qt) || STRINGP (visit));
4474 quietly = !NILP (visit);
4476 annotations = Qnil;
4478 if (NILP (lockname))
4479 lockname = visit_file;
4481 GCPRO5 (start, filename, annotations, visit_file, lockname);
4483 /* If the file name has special constructs in it,
4484 call the corresponding file handler. */
4485 handler = Ffind_file_name_handler (filename, Qwrite_region);
4486 /* If FILENAME has no handler, see if VISIT has one. */
4487 if (NILP (handler) && STRINGP (visit))
4488 handler = Ffind_file_name_handler (visit, Qwrite_region);
4490 if (!NILP (handler))
4492 Lisp_Object val;
4493 val = call6 (handler, Qwrite_region, start, end,
4494 filename, append, visit);
4496 if (visiting)
4498 SAVE_MODIFF = MODIFF;
4499 XSETFASTINT (current_buffer->save_length, Z - BEG);
4500 current_buffer->filename = visit_file;
4502 UNGCPRO;
4503 return val;
4506 /* Special kludge to simplify auto-saving. */
4507 if (NILP (start))
4509 XSETFASTINT (start, BEG);
4510 XSETFASTINT (end, Z);
4513 record_unwind_protect (build_annotations_unwind, Fcurrent_buffer ());
4514 count1 = specpdl_ptr - specpdl;
4516 given_buffer = current_buffer;
4517 annotations = build_annotations (start, end, coding.pre_write_conversion);
4518 if (current_buffer != given_buffer)
4520 XSETFASTINT (start, BEGV);
4521 XSETFASTINT (end, ZV);
4524 #ifdef CLASH_DETECTION
4525 if (!auto_saving)
4527 #if 0 /* This causes trouble for GNUS. */
4528 /* If we've locked this file for some other buffer,
4529 query before proceeding. */
4530 if (!visiting && EQ (Ffile_locked_p (lockname), Qt))
4531 call2 (intern ("ask-user-about-lock"), filename, Vuser_login_name);
4532 #endif
4534 lock_file (lockname);
4536 #endif /* CLASH_DETECTION */
4538 encoded_filename = ENCODE_FILE (filename);
4540 fn = XSTRING (encoded_filename)->data;
4541 desc = -1;
4542 if (!NILP (append))
4543 #ifdef DOS_NT
4544 desc = emacs_open (fn, O_WRONLY | buffer_file_type, 0);
4545 #else /* not DOS_NT */
4546 desc = emacs_open (fn, O_WRONLY, 0);
4547 #endif /* not DOS_NT */
4549 if (desc < 0 && (NILP (append) || errno == ENOENT))
4550 #ifdef VMS
4551 if (auto_saving) /* Overwrite any previous version of autosave file */
4553 vms_truncate (fn); /* if fn exists, truncate to zero length */
4554 desc = emacs_open (fn, O_RDWR, 0);
4555 if (desc < 0)
4556 desc = creat_copy_attrs (STRINGP (current_buffer->filename)
4557 ? XSTRING (current_buffer->filename)->data : 0,
4558 fn);
4560 else /* Write to temporary name and rename if no errors */
4562 Lisp_Object temp_name;
4563 temp_name = Ffile_name_directory (filename);
4565 if (!NILP (temp_name))
4567 temp_name = Fmake_temp_name (concat2 (temp_name,
4568 build_string ("$$SAVE$$")));
4569 fname = XSTRING (filename)->data;
4570 fn = XSTRING (temp_name)->data;
4571 desc = creat_copy_attrs (fname, fn);
4572 if (desc < 0)
4574 /* If we can't open the temporary file, try creating a new
4575 version of the original file. VMS "creat" creates a
4576 new version rather than truncating an existing file. */
4577 fn = fname;
4578 fname = 0;
4579 desc = creat (fn, 0666);
4580 #if 0 /* This can clobber an existing file and fail to replace it,
4581 if the user runs out of space. */
4582 if (desc < 0)
4584 /* We can't make a new version;
4585 try to truncate and rewrite existing version if any. */
4586 vms_truncate (fn);
4587 desc = emacs_open (fn, O_RDWR, 0);
4589 #endif
4592 else
4593 desc = creat (fn, 0666);
4595 #else /* not VMS */
4596 #ifdef DOS_NT
4597 desc = emacs_open (fn,
4598 O_WRONLY | O_TRUNC | O_CREAT | buffer_file_type
4599 | (mustbenew == Qexcl ? O_EXCL : 0),
4600 S_IREAD | S_IWRITE);
4601 #else /* not DOS_NT */
4602 desc = emacs_open (fn, O_WRONLY | O_TRUNC | O_CREAT
4603 | (mustbenew == Qexcl ? O_EXCL : 0),
4604 auto_saving ? auto_save_mode_bits : 0666);
4605 #endif /* not DOS_NT */
4606 #endif /* not VMS */
4608 UNGCPRO;
4610 if (desc < 0)
4612 #ifdef CLASH_DETECTION
4613 save_errno = errno;
4614 if (!auto_saving) unlock_file (lockname);
4615 errno = save_errno;
4616 #endif /* CLASH_DETECTION */
4617 report_file_error ("Opening output file", Fcons (filename, Qnil));
4620 record_unwind_protect (close_file_unwind, make_number (desc));
4622 if (!NILP (append) && !NILP (Ffile_regular_p (filename)))
4623 if (lseek (desc, 0, 2) < 0)
4625 #ifdef CLASH_DETECTION
4626 if (!auto_saving) unlock_file (lockname);
4627 #endif /* CLASH_DETECTION */
4628 report_file_error ("Lseek error", Fcons (filename, Qnil));
4631 #ifdef VMS
4633 * Kludge Warning: The VMS C RTL likes to insert carriage returns
4634 * if we do writes that don't end with a carriage return. Furthermore
4635 * it cannot handle writes of more then 16K. The modified
4636 * version of "sys_write" in SYSDEP.C (see comment there) copes with
4637 * this EXCEPT for the last record (iff it doesn't end with a carriage
4638 * return). This implies that if your buffer doesn't end with a carriage
4639 * return, you get one free... tough. However it also means that if
4640 * we make two calls to sys_write (a la the following code) you can
4641 * get one at the gap as well. The easiest way to fix this (honest)
4642 * is to move the gap to the next newline (or the end of the buffer).
4643 * Thus this change.
4645 * Yech!
4647 if (GPT > BEG && GPT_ADDR[-1] != '\n')
4648 move_gap (find_next_newline (GPT, 1));
4649 #else
4650 /* Whether VMS or not, we must move the gap to the next of newline
4651 when we must put designation sequences at beginning of line. */
4652 if (INTEGERP (start)
4653 && coding.type == coding_type_iso2022
4654 && coding.flags & CODING_FLAG_ISO_DESIGNATE_AT_BOL
4655 && GPT > BEG && GPT_ADDR[-1] != '\n')
4657 int opoint = PT, opoint_byte = PT_BYTE;
4658 scan_newline (PT, PT_BYTE, ZV, ZV_BYTE, 1, 0);
4659 move_gap_both (PT, PT_BYTE);
4660 SET_PT_BOTH (opoint, opoint_byte);
4662 #endif
4664 failure = 0;
4665 immediate_quit = 1;
4667 if (STRINGP (start))
4669 failure = 0 > a_write (desc, start, 0, XSTRING (start)->size,
4670 &annotations, &coding);
4671 save_errno = errno;
4673 else if (XINT (start) != XINT (end))
4675 tem = CHAR_TO_BYTE (XINT (start));
4677 if (XINT (start) < GPT)
4679 failure = 0 > a_write (desc, Qnil, XINT (start),
4680 min (GPT, XINT (end)) - XINT (start),
4681 &annotations, &coding);
4682 save_errno = errno;
4685 if (XINT (end) > GPT && !failure)
4687 tem = max (XINT (start), GPT);
4688 failure = 0 > a_write (desc, Qnil, tem , XINT (end) - tem,
4689 &annotations, &coding);
4690 save_errno = errno;
4693 else
4695 /* If file was empty, still need to write the annotations */
4696 coding.mode |= CODING_MODE_LAST_BLOCK;
4697 failure = 0 > a_write (desc, Qnil, XINT (end), 0, &annotations, &coding);
4698 save_errno = errno;
4701 if (CODING_REQUIRE_FLUSHING (&coding)
4702 && !(coding.mode & CODING_MODE_LAST_BLOCK)
4703 && ! failure)
4705 /* We have to flush out a data. */
4706 coding.mode |= CODING_MODE_LAST_BLOCK;
4707 failure = 0 > e_write (desc, Qnil, 0, 0, &coding);
4708 save_errno = errno;
4711 immediate_quit = 0;
4713 #ifdef HAVE_FSYNC
4714 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
4715 Disk full in NFS may be reported here. */
4716 /* mib says that closing the file will try to write as fast as NFS can do
4717 it, and that means the fsync here is not crucial for autosave files. */
4718 if (!auto_saving && fsync (desc) < 0)
4720 /* If fsync fails with EINTR, don't treat that as serious. */
4721 if (errno != EINTR)
4722 failure = 1, save_errno = errno;
4724 #endif
4726 /* Spurious "file has changed on disk" warnings have been
4727 observed on Suns as well.
4728 It seems that `close' can change the modtime, under nfs.
4730 (This has supposedly been fixed in Sunos 4,
4731 but who knows about all the other machines with NFS?) */
4732 #if 0
4734 /* On VMS and APOLLO, must do the stat after the close
4735 since closing changes the modtime. */
4736 #ifndef VMS
4737 #ifndef APOLLO
4738 /* Recall that #if defined does not work on VMS. */
4739 #define FOO
4740 fstat (desc, &st);
4741 #endif
4742 #endif
4743 #endif
4745 /* NFS can report a write failure now. */
4746 if (emacs_close (desc) < 0)
4747 failure = 1, save_errno = errno;
4749 #ifdef VMS
4750 /* If we wrote to a temporary name and had no errors, rename to real name. */
4751 if (fname)
4753 if (!failure)
4754 failure = (rename (fn, fname) != 0), save_errno = errno;
4755 fn = fname;
4757 #endif /* VMS */
4759 #ifndef FOO
4760 stat (fn, &st);
4761 #endif
4762 /* Discard the unwind protect for close_file_unwind. */
4763 specpdl_ptr = specpdl + count1;
4764 /* Restore the original current buffer. */
4765 visit_file = unbind_to (count, visit_file);
4767 #ifdef CLASH_DETECTION
4768 if (!auto_saving)
4769 unlock_file (lockname);
4770 #endif /* CLASH_DETECTION */
4772 /* Do this before reporting IO error
4773 to avoid a "file has changed on disk" warning on
4774 next attempt to save. */
4775 if (visiting)
4776 current_buffer->modtime = st.st_mtime;
4778 if (failure)
4779 error ("IO error writing %s: %s", XSTRING (filename)->data,
4780 emacs_strerror (save_errno));
4782 if (visiting)
4784 SAVE_MODIFF = MODIFF;
4785 XSETFASTINT (current_buffer->save_length, Z - BEG);
4786 current_buffer->filename = visit_file;
4787 update_mode_lines++;
4789 else if (quietly)
4790 return Qnil;
4792 if (!auto_saving)
4793 message_with_string ("Wrote %s", visit_file, 1);
4795 return Qnil;
4798 Lisp_Object merge ();
4800 DEFUN ("car-less-than-car", Fcar_less_than_car, Scar_less_than_car, 2, 2, 0,
4801 "Return t if (car A) is numerically less than (car B).")
4802 (a, b)
4803 Lisp_Object a, b;
4805 return Flss (Fcar (a), Fcar (b));
4808 /* Build the complete list of annotations appropriate for writing out
4809 the text between START and END, by calling all the functions in
4810 write-region-annotate-functions and merging the lists they return.
4811 If one of these functions switches to a different buffer, we assume
4812 that buffer contains altered text. Therefore, the caller must
4813 make sure to restore the current buffer in all cases,
4814 as save-excursion would do. */
4816 static Lisp_Object
4817 build_annotations (start, end, pre_write_conversion)
4818 Lisp_Object start, end, pre_write_conversion;
4820 Lisp_Object annotations;
4821 Lisp_Object p, res;
4822 struct gcpro gcpro1, gcpro2;
4823 Lisp_Object original_buffer;
4825 XSETBUFFER (original_buffer, current_buffer);
4827 annotations = Qnil;
4828 p = Vwrite_region_annotate_functions;
4829 GCPRO2 (annotations, p);
4830 while (!NILP (p))
4832 struct buffer *given_buffer = current_buffer;
4833 Vwrite_region_annotations_so_far = annotations;
4834 res = call2 (Fcar (p), start, end);
4835 /* If the function makes a different buffer current,
4836 assume that means this buffer contains altered text to be output.
4837 Reset START and END from the buffer bounds
4838 and discard all previous annotations because they should have
4839 been dealt with by this function. */
4840 if (current_buffer != given_buffer)
4842 XSETFASTINT (start, BEGV);
4843 XSETFASTINT (end, ZV);
4844 annotations = Qnil;
4846 Flength (res); /* Check basic validity of return value */
4847 annotations = merge (annotations, res, Qcar_less_than_car);
4848 p = Fcdr (p);
4851 /* Now do the same for annotation functions implied by the file-format */
4852 if (auto_saving && (!EQ (Vauto_save_file_format, Qt)))
4853 p = Vauto_save_file_format;
4854 else
4855 p = current_buffer->file_format;
4856 while (!NILP (p))
4858 struct buffer *given_buffer = current_buffer;
4859 Vwrite_region_annotations_so_far = annotations;
4860 res = call4 (Qformat_annotate_function, Fcar (p), start, end,
4861 original_buffer);
4862 if (current_buffer != given_buffer)
4864 XSETFASTINT (start, BEGV);
4865 XSETFASTINT (end, ZV);
4866 annotations = Qnil;
4868 Flength (res);
4869 annotations = merge (annotations, res, Qcar_less_than_car);
4870 p = Fcdr (p);
4873 /* At last, do the same for the function PRE_WRITE_CONVERSION
4874 implied by the current coding-system. */
4875 if (!NILP (pre_write_conversion))
4877 struct buffer *given_buffer = current_buffer;
4878 Vwrite_region_annotations_so_far = annotations;
4879 res = call2 (pre_write_conversion, start, end);
4880 Flength (res);
4881 annotations = (current_buffer != given_buffer
4882 ? res
4883 : merge (annotations, res, Qcar_less_than_car));
4886 UNGCPRO;
4887 return annotations;
4890 /* Write to descriptor DESC the NCHARS chars starting at POS of STRING.
4891 If STRING is nil, POS is the character position in the current buffer.
4892 Intersperse with them the annotations from *ANNOT
4893 which fall within the range of POS to POS + NCHARS,
4894 each at its appropriate position.
4896 We modify *ANNOT by discarding elements as we use them up.
4898 The return value is negative in case of system call failure. */
4900 static int
4901 a_write (desc, string, pos, nchars, annot, coding)
4902 int desc;
4903 Lisp_Object string;
4904 register int nchars;
4905 int pos;
4906 Lisp_Object *annot;
4907 struct coding_system *coding;
4909 Lisp_Object tem;
4910 int nextpos;
4911 int lastpos = pos + nchars;
4913 while (NILP (*annot) || CONSP (*annot))
4915 tem = Fcar_safe (Fcar (*annot));
4916 nextpos = pos - 1;
4917 if (INTEGERP (tem))
4918 nextpos = XFASTINT (tem);
4920 /* If there are no more annotations in this range,
4921 output the rest of the range all at once. */
4922 if (! (nextpos >= pos && nextpos <= lastpos))
4923 return e_write (desc, string, pos, lastpos, coding);
4925 /* Output buffer text up to the next annotation's position. */
4926 if (nextpos > pos)
4928 if (0 > e_write (desc, string, pos, nextpos, coding));
4929 return -1;
4930 pos = nextpos;
4932 /* Output the annotation. */
4933 tem = Fcdr (Fcar (*annot));
4934 if (STRINGP (tem))
4936 if (0 > e_write (desc, tem, 0, XSTRING (tem)->size, coding));
4937 return -1;
4939 *annot = Fcdr (*annot);
4941 return 0;
4944 #ifndef WRITE_BUF_SIZE
4945 #define WRITE_BUF_SIZE (16 * 1024)
4946 #endif
4948 /* Write text in the range START and END into descriptor DESC,
4949 encoding them with coding system CODING. If STRING is nil, START
4950 and END are character positions of the current buffer, else they
4951 are indexes to the string STRING. */
4953 static int
4954 e_write (desc, string, start, end, coding)
4955 int desc;
4956 Lisp_Object string;
4957 int start, end;
4958 struct coding_system *coding;
4960 register char *addr;
4961 register int nbytes;
4962 char buf[WRITE_BUF_SIZE];
4963 int return_val = 0;
4965 if (start >= end)
4966 coding->composing = COMPOSITION_DISABLED;
4967 if (coding->composing != COMPOSITION_DISABLED)
4968 coding_save_composition (coding, start, end, string);
4970 if (STRINGP (string))
4972 addr = XSTRING (string)->data;
4973 nbytes = STRING_BYTES (XSTRING (string));
4975 else if (start < end)
4977 /* It is assured that the gap is not in the range START and END-1. */
4978 addr = CHAR_POS_ADDR (start);
4979 nbytes = CHAR_TO_BYTE (end) - CHAR_TO_BYTE (start);
4981 else
4983 addr = "";
4984 nbytes = 0;
4987 /* We used to have a code for handling selective display here. But,
4988 now it is handled within encode_coding. */
4989 while (1)
4991 int result;
4993 result = encode_coding (coding, addr, buf, nbytes, WRITE_BUF_SIZE);
4994 if (coding->produced > 0)
4996 coding->produced -= emacs_write (desc, buf, coding->produced);
4997 if (coding->produced)
4999 return_val = -1;
5000 break;
5003 nbytes -= coding->consumed;
5004 addr += coding->consumed;
5005 if (result == CODING_FINISH_INSUFFICIENT_SRC
5006 && nbytes > 0)
5008 /* The source text ends by an incomplete multibyte form.
5009 There's no way other than write it out as is. */
5010 nbytes -= emacs_write (desc, addr, nbytes);
5011 if (nbytes)
5013 return_val = -1;
5014 break;
5017 if (nbytes <= 0)
5018 break;
5019 start += coding->consumed_char;
5020 if (coding->cmp_data)
5021 coding_adjust_composition_offset (coding, start);
5023 return 0;
5026 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime,
5027 Sverify_visited_file_modtime, 1, 1, 0,
5028 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
5029 This means that the file has not been changed since it was visited or saved.")
5030 (buf)
5031 Lisp_Object buf;
5033 struct buffer *b;
5034 struct stat st;
5035 Lisp_Object handler;
5036 Lisp_Object filename;
5038 CHECK_BUFFER (buf, 0);
5039 b = XBUFFER (buf);
5041 if (!STRINGP (b->filename)) return Qt;
5042 if (b->modtime == 0) return Qt;
5044 /* If the file name has special constructs in it,
5045 call the corresponding file handler. */
5046 handler = Ffind_file_name_handler (b->filename,
5047 Qverify_visited_file_modtime);
5048 if (!NILP (handler))
5049 return call2 (handler, Qverify_visited_file_modtime, buf);
5051 filename = ENCODE_FILE (b->filename);
5053 if (stat (XSTRING (filename)->data, &st) < 0)
5055 /* If the file doesn't exist now and didn't exist before,
5056 we say that it isn't modified, provided the error is a tame one. */
5057 if (errno == ENOENT || errno == EACCES || errno == ENOTDIR)
5058 st.st_mtime = -1;
5059 else
5060 st.st_mtime = 0;
5062 if (st.st_mtime == b->modtime
5063 /* If both are positive, accept them if they are off by one second. */
5064 || (st.st_mtime > 0 && b->modtime > 0
5065 && (st.st_mtime == b->modtime + 1
5066 || st.st_mtime == b->modtime - 1)))
5067 return Qt;
5068 return Qnil;
5071 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime,
5072 Sclear_visited_file_modtime, 0, 0, 0,
5073 "Clear out records of last mod time of visited file.\n\
5074 Next attempt to save will certainly not complain of a discrepancy.")
5077 current_buffer->modtime = 0;
5078 return Qnil;
5081 DEFUN ("visited-file-modtime", Fvisited_file_modtime,
5082 Svisited_file_modtime, 0, 0, 0,
5083 "Return the current buffer's recorded visited file modification time.\n\
5084 The value is a list of the form (HIGH . LOW), like the time values\n\
5085 that `file-attributes' returns.")
5088 return long_to_cons ((unsigned long) current_buffer->modtime);
5091 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime,
5092 Sset_visited_file_modtime, 0, 1, 0,
5093 "Update buffer's recorded modification time from the visited file's time.\n\
5094 Useful if the buffer was not read from the file normally\n\
5095 or if the file itself has been changed for some known benign reason.\n\
5096 An argument specifies the modification time value to use\n\
5097 \(instead of that of the visited file), in the form of a list\n\
5098 \(HIGH . LOW) or (HIGH LOW).")
5099 (time_list)
5100 Lisp_Object time_list;
5102 if (!NILP (time_list))
5103 current_buffer->modtime = cons_to_long (time_list);
5104 else
5106 register Lisp_Object filename;
5107 struct stat st;
5108 Lisp_Object handler;
5110 filename = Fexpand_file_name (current_buffer->filename, Qnil);
5112 /* If the file name has special constructs in it,
5113 call the corresponding file handler. */
5114 handler = Ffind_file_name_handler (filename, Qset_visited_file_modtime);
5115 if (!NILP (handler))
5116 /* The handler can find the file name the same way we did. */
5117 return call2 (handler, Qset_visited_file_modtime, Qnil);
5119 filename = ENCODE_FILE (filename);
5121 if (stat (XSTRING (filename)->data, &st) >= 0)
5122 current_buffer->modtime = st.st_mtime;
5125 return Qnil;
5128 Lisp_Object
5129 auto_save_error ()
5131 ring_bell ();
5132 message_with_string ("Autosaving...error for %s", current_buffer->name, 1);
5133 Fsleep_for (make_number (1), Qnil);
5134 message_with_string ("Autosaving...error for %s", current_buffer->name, 0);
5135 Fsleep_for (make_number (1), Qnil);
5136 message_with_string ("Autosaving...error for %s", current_buffer->name, 0);
5137 Fsleep_for (make_number (1), Qnil);
5138 return Qnil;
5141 Lisp_Object
5142 auto_save_1 ()
5144 struct stat st;
5146 /* Get visited file's mode to become the auto save file's mode. */
5147 if (stat (XSTRING (current_buffer->filename)->data, &st) >= 0)
5148 /* But make sure we can overwrite it later! */
5149 auto_save_mode_bits = st.st_mode | 0600;
5150 else
5151 auto_save_mode_bits = 0666;
5153 return
5154 Fwrite_region (Qnil, Qnil,
5155 current_buffer->auto_save_file_name,
5156 Qnil, Qlambda, Qnil, Qnil);
5159 static Lisp_Object
5160 do_auto_save_unwind (stream) /* used as unwind-protect function */
5161 Lisp_Object stream;
5163 auto_saving = 0;
5164 if (!NILP (stream))
5165 fclose ((FILE *) (XFASTINT (XCAR (stream)) << 16
5166 | XFASTINT (XCDR (stream))));
5167 return Qnil;
5170 static Lisp_Object
5171 do_auto_save_unwind_1 (value) /* used as unwind-protect function */
5172 Lisp_Object value;
5174 minibuffer_auto_raise = XINT (value);
5175 return Qnil;
5178 DEFUN ("do-auto-save", Fdo_auto_save, Sdo_auto_save, 0, 2, "",
5179 "Auto-save all buffers that need it.\n\
5180 This is all buffers that have auto-saving enabled\n\
5181 and are changed since last auto-saved.\n\
5182 Auto-saving writes the buffer into a file\n\
5183 so that your editing is not lost if the system crashes.\n\
5184 This file is not the file you visited; that changes only when you save.\n\
5185 Normally we run the normal hook `auto-save-hook' before saving.\n\n\
5186 A non-nil NO-MESSAGE argument means do not print any message if successful.\n\
5187 A non-nil CURRENT-ONLY argument means save only current buffer.")
5188 (no_message, current_only)
5189 Lisp_Object no_message, current_only;
5191 struct buffer *old = current_buffer, *b;
5192 Lisp_Object tail, buf;
5193 int auto_saved = 0;
5194 int do_handled_files;
5195 Lisp_Object oquit;
5196 FILE *stream;
5197 Lisp_Object lispstream;
5198 int count = specpdl_ptr - specpdl;
5199 int orig_minibuffer_auto_raise = minibuffer_auto_raise;
5200 int message_p = push_message ();
5202 /* Ordinarily don't quit within this function,
5203 but don't make it impossible to quit (in case we get hung in I/O). */
5204 oquit = Vquit_flag;
5205 Vquit_flag = Qnil;
5207 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
5208 point to non-strings reached from Vbuffer_alist. */
5210 if (minibuf_level)
5211 no_message = Qt;
5213 if (!NILP (Vrun_hooks))
5214 call1 (Vrun_hooks, intern ("auto-save-hook"));
5216 if (STRINGP (Vauto_save_list_file_name))
5218 Lisp_Object listfile;
5219 listfile = Fexpand_file_name (Vauto_save_list_file_name, Qnil);
5220 stream = fopen (XSTRING (listfile)->data, "w");
5221 if (stream != NULL)
5223 /* Arrange to close that file whether or not we get an error.
5224 Also reset auto_saving to 0. */
5225 lispstream = Fcons (Qnil, Qnil);
5226 XSETFASTINT (XCAR (lispstream), (EMACS_UINT)stream >> 16);
5227 XSETFASTINT (XCDR (lispstream), (EMACS_UINT)stream & 0xffff);
5229 else
5230 lispstream = Qnil;
5232 else
5234 stream = NULL;
5235 lispstream = Qnil;
5238 record_unwind_protect (do_auto_save_unwind, lispstream);
5239 record_unwind_protect (do_auto_save_unwind_1,
5240 make_number (minibuffer_auto_raise));
5241 minibuffer_auto_raise = 0;
5242 auto_saving = 1;
5244 /* First, save all files which don't have handlers. If Emacs is
5245 crashing, the handlers may tweak what is causing Emacs to crash
5246 in the first place, and it would be a shame if Emacs failed to
5247 autosave perfectly ordinary files because it couldn't handle some
5248 ange-ftp'd file. */
5249 for (do_handled_files = 0; do_handled_files < 2; do_handled_files++)
5250 for (tail = Vbuffer_alist; GC_CONSP (tail); tail = XCDR (tail))
5252 buf = XCDR (XCAR (tail));
5253 b = XBUFFER (buf);
5255 /* Record all the buffers that have auto save mode
5256 in the special file that lists them. For each of these buffers,
5257 Record visited name (if any) and auto save name. */
5258 if (STRINGP (b->auto_save_file_name)
5259 && stream != NULL && do_handled_files == 0)
5261 if (!NILP (b->filename))
5263 fwrite (XSTRING (b->filename)->data, 1,
5264 STRING_BYTES (XSTRING (b->filename)), stream);
5266 putc ('\n', stream);
5267 fwrite (XSTRING (b->auto_save_file_name)->data, 1,
5268 STRING_BYTES (XSTRING (b->auto_save_file_name)), stream);
5269 putc ('\n', stream);
5272 if (!NILP (current_only)
5273 && b != current_buffer)
5274 continue;
5276 /* Don't auto-save indirect buffers.
5277 The base buffer takes care of it. */
5278 if (b->base_buffer)
5279 continue;
5281 /* Check for auto save enabled
5282 and file changed since last auto save
5283 and file changed since last real save. */
5284 if (STRINGP (b->auto_save_file_name)
5285 && BUF_SAVE_MODIFF (b) < BUF_MODIFF (b)
5286 && b->auto_save_modified < BUF_MODIFF (b)
5287 /* -1 means we've turned off autosaving for a while--see below. */
5288 && XINT (b->save_length) >= 0
5289 && (do_handled_files
5290 || NILP (Ffind_file_name_handler (b->auto_save_file_name,
5291 Qwrite_region))))
5293 EMACS_TIME before_time, after_time;
5295 EMACS_GET_TIME (before_time);
5297 /* If we had a failure, don't try again for 20 minutes. */
5298 if (b->auto_save_failure_time >= 0
5299 && EMACS_SECS (before_time) - b->auto_save_failure_time < 1200)
5300 continue;
5302 if ((XFASTINT (b->save_length) * 10
5303 > (BUF_Z (b) - BUF_BEG (b)) * 13)
5304 /* A short file is likely to change a large fraction;
5305 spare the user annoying messages. */
5306 && XFASTINT (b->save_length) > 5000
5307 /* These messages are frequent and annoying for `*mail*'. */
5308 && !EQ (b->filename, Qnil)
5309 && NILP (no_message))
5311 /* It has shrunk too much; turn off auto-saving here. */
5312 minibuffer_auto_raise = orig_minibuffer_auto_raise;
5313 message_with_string ("Buffer %s has shrunk a lot; auto save turned off there",
5314 b->name, 1);
5315 minibuffer_auto_raise = 0;
5316 /* Turn off auto-saving until there's a real save,
5317 and prevent any more warnings. */
5318 XSETINT (b->save_length, -1);
5319 Fsleep_for (make_number (1), Qnil);
5320 continue;
5322 set_buffer_internal (b);
5323 if (!auto_saved && NILP (no_message))
5324 message1 ("Auto-saving...");
5325 internal_condition_case (auto_save_1, Qt, auto_save_error);
5326 auto_saved++;
5327 b->auto_save_modified = BUF_MODIFF (b);
5328 XSETFASTINT (current_buffer->save_length, Z - BEG);
5329 set_buffer_internal (old);
5331 EMACS_GET_TIME (after_time);
5333 /* If auto-save took more than 60 seconds,
5334 assume it was an NFS failure that got a timeout. */
5335 if (EMACS_SECS (after_time) - EMACS_SECS (before_time) > 60)
5336 b->auto_save_failure_time = EMACS_SECS (after_time);
5340 /* Prevent another auto save till enough input events come in. */
5341 record_auto_save ();
5343 if (auto_saved && NILP (no_message))
5345 if (message_p)
5347 sit_for (1, 0, 0, 0, 0);
5348 restore_message ();
5350 else
5351 message1 ("Auto-saving...done");
5354 Vquit_flag = oquit;
5356 pop_message ();
5357 unbind_to (count, Qnil);
5358 return Qnil;
5361 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved,
5362 Sset_buffer_auto_saved, 0, 0, 0,
5363 "Mark current buffer as auto-saved with its current text.\n\
5364 No auto-save file will be written until the buffer changes again.")
5367 current_buffer->auto_save_modified = MODIFF;
5368 XSETFASTINT (current_buffer->save_length, Z - BEG);
5369 current_buffer->auto_save_failure_time = -1;
5370 return Qnil;
5373 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure,
5374 Sclear_buffer_auto_save_failure, 0, 0, 0,
5375 "Clear any record of a recent auto-save failure in the current buffer.")
5378 current_buffer->auto_save_failure_time = -1;
5379 return Qnil;
5382 DEFUN ("recent-auto-save-p", Frecent_auto_save_p, Srecent_auto_save_p,
5383 0, 0, 0,
5384 "Return t if buffer has been auto-saved since last read in or saved.")
5387 return (SAVE_MODIFF < current_buffer->auto_save_modified) ? Qt : Qnil;
5390 /* Reading and completing file names */
5391 extern Lisp_Object Ffile_name_completion (), Ffile_name_all_completions ();
5393 /* In the string VAL, change each $ to $$ and return the result. */
5395 static Lisp_Object
5396 double_dollars (val)
5397 Lisp_Object val;
5399 register unsigned char *old, *new;
5400 register int n;
5401 int osize, count;
5403 osize = STRING_BYTES (XSTRING (val));
5405 /* Count the number of $ characters. */
5406 for (n = osize, count = 0, old = XSTRING (val)->data; n > 0; n--)
5407 if (*old++ == '$') count++;
5408 if (count > 0)
5410 old = XSTRING (val)->data;
5411 val = make_uninit_multibyte_string (XSTRING (val)->size + count,
5412 osize + count);
5413 new = XSTRING (val)->data;
5414 for (n = osize; n > 0; n--)
5415 if (*old != '$')
5416 *new++ = *old++;
5417 else
5419 *new++ = '$';
5420 *new++ = '$';
5421 old++;
5424 return val;
5427 DEFUN ("read-file-name-internal", Fread_file_name_internal, Sread_file_name_internal,
5428 3, 3, 0,
5429 "Internal subroutine for read-file-name. Do not call this.")
5430 (string, dir, action)
5431 Lisp_Object string, dir, action;
5432 /* action is nil for complete, t for return list of completions,
5433 lambda for verify final value */
5435 Lisp_Object name, specdir, realdir, val, orig_string;
5436 int changed;
5437 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
5439 CHECK_STRING (string, 0);
5441 realdir = dir;
5442 name = string;
5443 orig_string = Qnil;
5444 specdir = Qnil;
5445 changed = 0;
5446 /* No need to protect ACTION--we only compare it with t and nil. */
5447 GCPRO5 (string, realdir, name, specdir, orig_string);
5449 if (XSTRING (string)->size == 0)
5451 if (EQ (action, Qlambda))
5453 UNGCPRO;
5454 return Qnil;
5457 else
5459 orig_string = string;
5460 string = Fsubstitute_in_file_name (string);
5461 changed = NILP (Fstring_equal (string, orig_string));
5462 name = Ffile_name_nondirectory (string);
5463 val = Ffile_name_directory (string);
5464 if (! NILP (val))
5465 realdir = Fexpand_file_name (val, realdir);
5468 if (NILP (action))
5470 specdir = Ffile_name_directory (string);
5471 val = Ffile_name_completion (name, realdir);
5472 UNGCPRO;
5473 if (!STRINGP (val))
5475 if (changed)
5476 return double_dollars (string);
5477 return val;
5480 if (!NILP (specdir))
5481 val = concat2 (specdir, val);
5482 #ifndef VMS
5483 return double_dollars (val);
5484 #else /* not VMS */
5485 return val;
5486 #endif /* not VMS */
5488 UNGCPRO;
5490 if (EQ (action, Qt))
5491 return Ffile_name_all_completions (name, realdir);
5492 /* Only other case actually used is ACTION = lambda */
5493 #ifdef VMS
5494 /* Supposedly this helps commands such as `cd' that read directory names,
5495 but can someone explain how it helps them? -- RMS */
5496 if (XSTRING (name)->size == 0)
5497 return Qt;
5498 #endif /* VMS */
5499 return Ffile_exists_p (string);
5502 DEFUN ("read-file-name", Fread_file_name, Sread_file_name, 1, 5, 0,
5503 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
5504 Value is not expanded---you must call `expand-file-name' yourself.\n\
5505 Default name to DEFAULT-FILENAME if user enters a null string.\n\
5506 (If DEFAULT-FILENAME is omitted, the visited file name is used,\n\
5507 except that if INITIAL is specified, that combined with DIR is used.)\n\
5508 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
5509 Non-nil and non-t means also require confirmation after completion.\n\
5510 Fifth arg INITIAL specifies text to start with.\n\
5511 DIR defaults to current buffer's directory default.")
5512 (prompt, dir, default_filename, mustmatch, initial)
5513 Lisp_Object prompt, dir, default_filename, mustmatch, initial;
5515 Lisp_Object val, insdef, tem;
5516 struct gcpro gcpro1, gcpro2;
5517 register char *homedir;
5518 int replace_in_history = 0;
5519 int add_to_history = 0;
5520 int count;
5522 if (NILP (dir))
5523 dir = current_buffer->directory;
5524 if (NILP (default_filename))
5526 if (! NILP (initial))
5527 default_filename = Fexpand_file_name (initial, dir);
5528 else
5529 default_filename = current_buffer->filename;
5532 /* If dir starts with user's homedir, change that to ~. */
5533 homedir = (char *) egetenv ("HOME");
5534 #ifdef DOS_NT
5535 homedir = strcpy (alloca (strlen (homedir) + 1), homedir);
5536 CORRECT_DIR_SEPS (homedir);
5537 #endif
5538 if (homedir != 0
5539 && STRINGP (dir)
5540 && !strncmp (homedir, XSTRING (dir)->data, strlen (homedir))
5541 && IS_DIRECTORY_SEP (XSTRING (dir)->data[strlen (homedir)]))
5543 dir = make_string (XSTRING (dir)->data + strlen (homedir) - 1,
5544 STRING_BYTES (XSTRING (dir)) - strlen (homedir) + 1);
5545 XSTRING (dir)->data[0] = '~';
5547 /* Likewise for default_filename. */
5548 if (homedir != 0
5549 && STRINGP (default_filename)
5550 && !strncmp (homedir, XSTRING (default_filename)->data, strlen (homedir))
5551 && IS_DIRECTORY_SEP (XSTRING (default_filename)->data[strlen (homedir)]))
5553 default_filename
5554 = make_string (XSTRING (default_filename)->data + strlen (homedir) - 1,
5555 STRING_BYTES (XSTRING (default_filename)) - strlen (homedir) + 1);
5556 XSTRING (default_filename)->data[0] = '~';
5558 if (!NILP (default_filename))
5560 CHECK_STRING (default_filename, 3);
5561 default_filename = double_dollars (default_filename);
5564 if (insert_default_directory && STRINGP (dir))
5566 insdef = dir;
5567 if (!NILP (initial))
5569 Lisp_Object args[2], pos;
5571 args[0] = insdef;
5572 args[1] = initial;
5573 insdef = Fconcat (2, args);
5574 pos = make_number (XSTRING (double_dollars (dir))->size);
5575 insdef = Fcons (double_dollars (insdef), pos);
5577 else
5578 insdef = double_dollars (insdef);
5580 else if (STRINGP (initial))
5581 insdef = Fcons (double_dollars (initial), make_number (0));
5582 else
5583 insdef = Qnil;
5585 count = specpdl_ptr - specpdl;
5586 #ifdef VMS
5587 specbind (intern ("completion-ignore-case"), Qt);
5588 #endif
5590 specbind (intern ("minibuffer-completing-file-name"), Qt);
5592 GCPRO2 (insdef, default_filename);
5594 #ifdef USE_MOTIF
5595 if ((NILP (last_nonmenu_event) || CONSP (last_nonmenu_event))
5596 && use_dialog_box
5597 && have_menus_p ())
5599 /* If DIR contains a file name, split it. */
5600 Lisp_Object file;
5601 file = Ffile_name_nondirectory (dir);
5602 if (XSTRING (file)->size && NILP (default_filename))
5604 default_filename = file;
5605 dir = Ffile_name_directory (dir);
5607 default_filename = Fexpand_file_name (default_filename, dir);
5608 val = Fx_file_dialog (prompt, dir, default_filename, mustmatch);
5609 add_to_history = 1;
5611 else
5612 #endif
5613 val = Fcompleting_read (prompt, intern ("read-file-name-internal"),
5614 dir, mustmatch, insdef,
5615 Qfile_name_history, default_filename, Qnil);
5617 tem = Fsymbol_value (Qfile_name_history);
5618 if (CONSP (tem) && EQ (XCAR (tem), val))
5619 replace_in_history = 1;
5621 /* If Fcompleting_read returned the inserted default string itself
5622 (rather than a new string with the same contents),
5623 it has to mean that the user typed RET with the minibuffer empty.
5624 In that case, we really want to return ""
5625 so that commands such as set-visited-file-name can distinguish. */
5626 if (EQ (val, default_filename))
5628 /* In this case, Fcompleting_read has not added an element
5629 to the history. Maybe we should. */
5630 if (! replace_in_history)
5631 add_to_history = 1;
5633 val = build_string ("");
5636 unbind_to (count, Qnil);
5637 UNGCPRO;
5638 if (NILP (val))
5639 error ("No file name specified");
5641 tem = Fstring_equal (val, CONSP (insdef) ? XCAR (insdef) : insdef);
5643 if (!NILP (tem) && !NILP (default_filename))
5644 val = default_filename;
5645 else if (XSTRING (val)->size == 0 && NILP (insdef))
5647 if (!NILP (default_filename))
5648 val = default_filename;
5649 else
5650 error ("No default file name");
5652 val = Fsubstitute_in_file_name (val);
5654 if (replace_in_history)
5655 /* Replace what Fcompleting_read added to the history
5656 with what we will actually return. */
5657 XCAR (Fsymbol_value (Qfile_name_history)) = double_dollars (val);
5658 else if (add_to_history)
5660 /* Add the value to the history--but not if it matches
5661 the last value already there. */
5662 Lisp_Object val1 = double_dollars (val);
5663 tem = Fsymbol_value (Qfile_name_history);
5664 if (! CONSP (tem) || NILP (Fequal (XCAR (tem), val1)))
5665 Fset (Qfile_name_history,
5666 Fcons (val1, tem));
5669 return val;
5673 void
5674 init_fileio_once ()
5676 /* Must be set before any path manipulation is performed. */
5677 XSETFASTINT (Vdirectory_sep_char, '/');
5681 void
5682 syms_of_fileio ()
5684 Qexpand_file_name = intern ("expand-file-name");
5685 Qsubstitute_in_file_name = intern ("substitute-in-file-name");
5686 Qdirectory_file_name = intern ("directory-file-name");
5687 Qfile_name_directory = intern ("file-name-directory");
5688 Qfile_name_nondirectory = intern ("file-name-nondirectory");
5689 Qunhandled_file_name_directory = intern ("unhandled-file-name-directory");
5690 Qfile_name_as_directory = intern ("file-name-as-directory");
5691 Qcopy_file = intern ("copy-file");
5692 Qmake_directory_internal = intern ("make-directory-internal");
5693 Qdelete_directory = intern ("delete-directory");
5694 Qdelete_file = intern ("delete-file");
5695 Qrename_file = intern ("rename-file");
5696 Qadd_name_to_file = intern ("add-name-to-file");
5697 Qmake_symbolic_link = intern ("make-symbolic-link");
5698 Qfile_exists_p = intern ("file-exists-p");
5699 Qfile_executable_p = intern ("file-executable-p");
5700 Qfile_readable_p = intern ("file-readable-p");
5701 Qfile_writable_p = intern ("file-writable-p");
5702 Qfile_symlink_p = intern ("file-symlink-p");
5703 Qaccess_file = intern ("access-file");
5704 Qfile_directory_p = intern ("file-directory-p");
5705 Qfile_regular_p = intern ("file-regular-p");
5706 Qfile_accessible_directory_p = intern ("file-accessible-directory-p");
5707 Qfile_modes = intern ("file-modes");
5708 Qset_file_modes = intern ("set-file-modes");
5709 Qfile_newer_than_file_p = intern ("file-newer-than-file-p");
5710 Qinsert_file_contents = intern ("insert-file-contents");
5711 Qwrite_region = intern ("write-region");
5712 Qverify_visited_file_modtime = intern ("verify-visited-file-modtime");
5713 Qset_visited_file_modtime = intern ("set-visited-file-modtime");
5715 staticpro (&Qexpand_file_name);
5716 staticpro (&Qsubstitute_in_file_name);
5717 staticpro (&Qdirectory_file_name);
5718 staticpro (&Qfile_name_directory);
5719 staticpro (&Qfile_name_nondirectory);
5720 staticpro (&Qunhandled_file_name_directory);
5721 staticpro (&Qfile_name_as_directory);
5722 staticpro (&Qcopy_file);
5723 staticpro (&Qmake_directory_internal);
5724 staticpro (&Qdelete_directory);
5725 staticpro (&Qdelete_file);
5726 staticpro (&Qrename_file);
5727 staticpro (&Qadd_name_to_file);
5728 staticpro (&Qmake_symbolic_link);
5729 staticpro (&Qfile_exists_p);
5730 staticpro (&Qfile_executable_p);
5731 staticpro (&Qfile_readable_p);
5732 staticpro (&Qfile_writable_p);
5733 staticpro (&Qaccess_file);
5734 staticpro (&Qfile_symlink_p);
5735 staticpro (&Qfile_directory_p);
5736 staticpro (&Qfile_regular_p);
5737 staticpro (&Qfile_accessible_directory_p);
5738 staticpro (&Qfile_modes);
5739 staticpro (&Qset_file_modes);
5740 staticpro (&Qfile_newer_than_file_p);
5741 staticpro (&Qinsert_file_contents);
5742 staticpro (&Qwrite_region);
5743 staticpro (&Qverify_visited_file_modtime);
5744 staticpro (&Qset_visited_file_modtime);
5746 Qfile_name_history = intern ("file-name-history");
5747 Fset (Qfile_name_history, Qnil);
5748 staticpro (&Qfile_name_history);
5750 Qfile_error = intern ("file-error");
5751 staticpro (&Qfile_error);
5752 Qfile_already_exists = intern ("file-already-exists");
5753 staticpro (&Qfile_already_exists);
5754 Qfile_date_error = intern ("file-date-error");
5755 staticpro (&Qfile_date_error);
5756 Qexcl = intern ("excl");
5757 staticpro (&Qexcl);
5759 #ifdef DOS_NT
5760 Qfind_buffer_file_type = intern ("find-buffer-file-type");
5761 staticpro (&Qfind_buffer_file_type);
5762 #endif /* DOS_NT */
5764 DEFVAR_LISP ("file-name-coding-system", &Vfile_name_coding_system,
5765 "*Coding system for encoding file names.\n\
5766 If it is nil, default-file-name-coding-system (which see) is used.");
5767 Vfile_name_coding_system = Qnil;
5769 DEFVAR_LISP ("default-file-name-coding-system",
5770 &Vdefault_file_name_coding_system,
5771 "Default coding system for encoding file names.\n\
5772 This variable is used only when file-name-coding-system is nil.\n\
5774 This variable is set/changed by the command set-language-environment.\n\
5775 User should not set this variable manually,\n\
5776 instead use file-name-coding-system to get a constant encoding\n\
5777 of file names regardless of the current language environment.");
5778 Vdefault_file_name_coding_system = Qnil;
5780 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format,
5781 "*Format in which to write auto-save files.\n\
5782 Should be a list of symbols naming formats that are defined in `format-alist'.\n\
5783 If it is t, which is the default, auto-save files are written in the\n\
5784 same format as a regular save would use.");
5785 Vauto_save_file_format = Qt;
5787 Qformat_decode = intern ("format-decode");
5788 staticpro (&Qformat_decode);
5789 Qformat_annotate_function = intern ("format-annotate-function");
5790 staticpro (&Qformat_annotate_function);
5792 Qcar_less_than_car = intern ("car-less-than-car");
5793 staticpro (&Qcar_less_than_car);
5795 Fput (Qfile_error, Qerror_conditions,
5796 Fcons (Qfile_error, Fcons (Qerror, Qnil)));
5797 Fput (Qfile_error, Qerror_message,
5798 build_string ("File error"));
5800 Fput (Qfile_already_exists, Qerror_conditions,
5801 Fcons (Qfile_already_exists,
5802 Fcons (Qfile_error, Fcons (Qerror, Qnil))));
5803 Fput (Qfile_already_exists, Qerror_message,
5804 build_string ("File already exists"));
5806 Fput (Qfile_date_error, Qerror_conditions,
5807 Fcons (Qfile_date_error,
5808 Fcons (Qfile_error, Fcons (Qerror, Qnil))));
5809 Fput (Qfile_date_error, Qerror_message,
5810 build_string ("Cannot set file date"));
5812 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory,
5813 "*Non-nil means when reading a filename start with default dir in minibuffer.");
5814 insert_default_directory = 1;
5816 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm,
5817 "*Non-nil means write new files with record format `stmlf'.\n\
5818 nil means use format `var'. This variable is meaningful only on VMS.");
5819 vms_stmlf_recfm = 0;
5821 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char,
5822 "Directory separator character for built-in functions that return file names.\n\
5823 The value should be either ?/ or ?\\ (any other value is treated as ?\\).\n\
5824 This variable affects the built-in functions only on Windows,\n\
5825 on other platforms, it is initialized so that Lisp code can find out\n\
5826 what the normal separator is.");
5828 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist,
5829 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
5830 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
5831 HANDLER.\n\
5833 The first argument given to HANDLER is the name of the I/O primitive\n\
5834 to be handled; the remaining arguments are the arguments that were\n\
5835 passed to that primitive. For example, if you do\n\
5836 (file-exists-p FILENAME)\n\
5837 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
5838 (funcall HANDLER 'file-exists-p FILENAME)\n\
5839 The function `find-file-name-handler' checks this list for a handler\n\
5840 for its argument.");
5841 Vfile_name_handler_alist = Qnil;
5843 DEFVAR_LISP ("set-auto-coding-function",
5844 &Vset_auto_coding_function,
5845 "If non-nil, a function to call to decide a coding system of file.\n\
5846 Two arguments are passed to this function: the file name\n\
5847 and the length of a file contents following the point.\n\
5848 This function should return a coding system to decode the file contents.\n\
5849 It should check the file name against `auto-coding-alist'.\n\
5850 If no coding system is decided, it should check a coding system\n\
5851 specified in the heading lines with the format:\n\
5852 -*- ... coding: CODING-SYSTEM; ... -*-\n\
5853 or local variable spec of the tailing lines with `coding:' tag.");
5854 Vset_auto_coding_function = Qnil;
5856 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions,
5857 "A list of functions to be called at the end of `insert-file-contents'.\n\
5858 Each is passed one argument, the number of bytes inserted. It should return\n\
5859 the new byte count, and leave point the same. If `insert-file-contents' is\n\
5860 intercepted by a handler from `file-name-handler-alist', that handler is\n\
5861 responsible for calling the after-insert-file-functions if appropriate.");
5862 Vafter_insert_file_functions = Qnil;
5864 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions,
5865 "A list of functions to be called at the start of `write-region'.\n\
5866 Each is passed two arguments, START and END as for `write-region'.\n\
5867 These are usually two numbers but not always; see the documentation\n\
5868 for `write-region'. The function should return a list of pairs\n\
5869 of the form (POSITION . STRING), consisting of strings to be effectively\n\
5870 inserted at the specified positions of the file being written (1 means to\n\
5871 insert before the first byte written). The POSITIONs must be sorted into\n\
5872 increasing order. If there are several functions in the list, the several\n\
5873 lists are merged destructively.");
5874 Vwrite_region_annotate_functions = Qnil;
5876 DEFVAR_LISP ("write-region-annotations-so-far",
5877 &Vwrite_region_annotations_so_far,
5878 "When an annotation function is called, this holds the previous annotations.\n\
5879 These are the annotations made by other annotation functions\n\
5880 that were already called. See also `write-region-annotate-functions'.");
5881 Vwrite_region_annotations_so_far = Qnil;
5883 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers,
5884 "A list of file name handlers that temporarily should not be used.\n\
5885 This applies only to the operation `inhibit-file-name-operation'.");
5886 Vinhibit_file_name_handlers = Qnil;
5888 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation,
5889 "The operation for which `inhibit-file-name-handlers' is applicable.");
5890 Vinhibit_file_name_operation = Qnil;
5892 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name,
5893 "File name in which we write a list of all auto save file names.\n\
5894 This variable is initialized automatically from `auto-save-list-file-prefix'\n\
5895 shortly after Emacs reads your `.emacs' file, if you have not yet given it\n\
5896 a non-nil value.");
5897 Vauto_save_list_file_name = Qnil;
5899 defsubr (&Sfind_file_name_handler);
5900 defsubr (&Sfile_name_directory);
5901 defsubr (&Sfile_name_nondirectory);
5902 defsubr (&Sunhandled_file_name_directory);
5903 defsubr (&Sfile_name_as_directory);
5904 defsubr (&Sdirectory_file_name);
5905 defsubr (&Smake_temp_name);
5906 defsubr (&Sexpand_file_name);
5907 defsubr (&Ssubstitute_in_file_name);
5908 defsubr (&Scopy_file);
5909 defsubr (&Smake_directory_internal);
5910 defsubr (&Sdelete_directory);
5911 defsubr (&Sdelete_file);
5912 defsubr (&Srename_file);
5913 defsubr (&Sadd_name_to_file);
5914 #ifdef S_IFLNK
5915 defsubr (&Smake_symbolic_link);
5916 #endif /* S_IFLNK */
5917 #ifdef VMS
5918 defsubr (&Sdefine_logical_name);
5919 #endif /* VMS */
5920 #ifdef HPUX_NET
5921 defsubr (&Ssysnetunam);
5922 #endif /* HPUX_NET */
5923 defsubr (&Sfile_name_absolute_p);
5924 defsubr (&Sfile_exists_p);
5925 defsubr (&Sfile_executable_p);
5926 defsubr (&Sfile_readable_p);
5927 defsubr (&Sfile_writable_p);
5928 defsubr (&Saccess_file);
5929 defsubr (&Sfile_symlink_p);
5930 defsubr (&Sfile_directory_p);
5931 defsubr (&Sfile_accessible_directory_p);
5932 defsubr (&Sfile_regular_p);
5933 defsubr (&Sfile_modes);
5934 defsubr (&Sset_file_modes);
5935 defsubr (&Sset_default_file_modes);
5936 defsubr (&Sdefault_file_modes);
5937 defsubr (&Sfile_newer_than_file_p);
5938 defsubr (&Sinsert_file_contents);
5939 defsubr (&Swrite_region);
5940 defsubr (&Scar_less_than_car);
5941 defsubr (&Sverify_visited_file_modtime);
5942 defsubr (&Sclear_visited_file_modtime);
5943 defsubr (&Svisited_file_modtime);
5944 defsubr (&Sset_visited_file_modtime);
5945 defsubr (&Sdo_auto_save);
5946 defsubr (&Sset_buffer_auto_saved);
5947 defsubr (&Sclear_buffer_auto_save_failure);
5948 defsubr (&Srecent_auto_save_p);
5950 defsubr (&Sread_file_name_internal);
5951 defsubr (&Sread_file_name);
5953 #ifdef unix
5954 defsubr (&Sunix_sync);
5955 #endif