1 /* File IO for GNU Emacs.
2 Copyright (C) 1985,86,87,88,93,94,95,96,97,98,99,2000, 2001
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 #define _GNU_SOURCE /* for euidaccess */
26 #if defined (USG5) || defined (BSD_SYSTEM) || defined (LINUX)
31 #include <sys/types.h>
38 #if !defined (S_ISLNK) && defined (S_IFLNK)
39 # define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
42 #if !defined (S_ISFIFO) && defined (S_IFIFO)
43 # define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO)
46 #if !defined (S_ISREG) && defined (S_IFREG)
47 # define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
88 #include "intervals.h"
99 #endif /* not WINDOWSNT */
103 #include <sys/param.h>
111 #define CORRECT_DIR_SEPS(s) \
112 do { if ('/' == DIRECTORY_SEP) dostounix_filename (s); \
113 else unixtodos_filename (s); \
115 /* On Windows, drive letters must be alphabetic - on DOS, the Netware
116 redirector allows the six letters between 'Z' and 'a' as well. */
118 #define IS_DRIVE(x) ((x) >= 'A' && (x) <= 'z')
121 #define IS_DRIVE(x) isalpha (x)
123 /* Need to lower-case the drive letter, or else expanded
124 filenames will sometimes compare inequal, because
125 `expand-file-name' doesn't always down-case the drive letter. */
126 #define DRIVE_LETTER(x) (tolower (x))
147 #include "commands.h"
148 extern int use_dialog_box
;
162 /* Nonzero during writing of auto-save files */
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. */
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
;
217 extern Lisp_Object Vw32_get_true_file_attributes
;
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
;
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
*));
246 report_file_error (string
, data
)
250 Lisp_Object errstring
;
253 synchronize_system_messages_locale ();
254 errstring
= code_convert_string_norecord (build_string (strerror (errorno
)),
255 Vlocale_coding_system
, 0);
261 Fsignal (Qfile_already_exists
, Fcons (errstring
, data
));
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
)));
275 close_file_unwind (fd
)
278 emacs_close (XFASTINT (fd
));
282 /* Restore point, having saved it as a marker. */
285 restore_point_unwind (location
)
286 Lisp_Object location
;
288 Fgoto_char (location
);
289 Fset_marker (location
, Qnil
, 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 Qmake_directory
;
303 Lisp_Object Qdelete_directory
;
304 Lisp_Object Qdelete_file
;
305 Lisp_Object Qrename_file
;
306 Lisp_Object Qadd_name_to_file
;
307 Lisp_Object Qmake_symbolic_link
;
308 Lisp_Object Qfile_exists_p
;
309 Lisp_Object Qfile_executable_p
;
310 Lisp_Object Qfile_readable_p
;
311 Lisp_Object Qfile_writable_p
;
312 Lisp_Object Qfile_symlink_p
;
313 Lisp_Object Qaccess_file
;
314 Lisp_Object Qfile_directory_p
;
315 Lisp_Object Qfile_regular_p
;
316 Lisp_Object Qfile_accessible_directory_p
;
317 Lisp_Object Qfile_modes
;
318 Lisp_Object Qset_file_modes
;
319 Lisp_Object Qfile_newer_than_file_p
;
320 Lisp_Object Qinsert_file_contents
;
321 Lisp_Object Qwrite_region
;
322 Lisp_Object Qverify_visited_file_modtime
;
323 Lisp_Object Qset_visited_file_modtime
;
325 DEFUN ("find-file-name-handler", Ffind_file_name_handler
, Sfind_file_name_handler
, 2, 2, 0,
326 doc
: /* Return FILENAME's handler function for OPERATION, if it has one.
327 Otherwise, return nil.
328 A file name is handled if one of the regular expressions in
329 `file-name-handler-alist' matches it.
331 If OPERATION equals `inhibit-file-name-operation', then we ignore
332 any handlers that are members of `inhibit-file-name-handlers',
333 but we still do run any other handlers. This lets handlers
334 use the standard functions without calling themselves recursively. */)
335 (filename
, operation
)
336 Lisp_Object filename
, operation
;
338 /* This function must not munge the match data. */
339 Lisp_Object chain
, inhibited_handlers
;
341 CHECK_STRING (filename
, 0);
343 if (EQ (operation
, Vinhibit_file_name_operation
))
344 inhibited_handlers
= Vinhibit_file_name_handlers
;
346 inhibited_handlers
= Qnil
;
348 for (chain
= Vfile_name_handler_alist
; CONSP (chain
);
349 chain
= XCDR (chain
))
357 if (STRINGP (string
) && fast_string_match (string
, filename
) >= 0)
359 Lisp_Object handler
, tem
;
361 handler
= XCDR (elt
);
362 tem
= Fmemq (handler
, inhibited_handlers
);
373 DEFUN ("file-name-directory", Ffile_name_directory
, Sfile_name_directory
,
375 doc
: /* Return the directory component in file name FILENAME.
376 Return nil if FILENAME does not include a directory.
377 Otherwise return a directory spec.
378 Given a Unix syntax file name, returns a string ending in slash;
379 on VMS, perhaps instead a string ending in `:', `]' or `>'. */)
381 Lisp_Object filename
;
383 register unsigned char *beg
;
384 register unsigned char *p
;
387 CHECK_STRING (filename
, 0);
389 /* If the file name has special constructs in it,
390 call the corresponding file handler. */
391 handler
= Ffind_file_name_handler (filename
, Qfile_name_directory
);
393 return call2 (handler
, Qfile_name_directory
, filename
);
395 #ifdef FILE_SYSTEM_CASE
396 filename
= FILE_SYSTEM_CASE (filename
);
398 beg
= XSTRING (filename
)->data
;
400 beg
= strcpy (alloca (strlen (beg
) + 1), beg
);
402 p
= beg
+ STRING_BYTES (XSTRING (filename
));
404 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
406 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
409 /* only recognise drive specifier at the beginning */
411 /* handle the "/:d:foo" and "/:foo" cases correctly */
412 && ((p
== beg
+ 2 && !IS_DIRECTORY_SEP (*beg
))
413 || (p
== beg
+ 4 && IS_DIRECTORY_SEP (*beg
))))
420 /* Expansion of "c:" to drive and default directory. */
423 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
424 unsigned char *res
= alloca (MAXPATHLEN
+ 1);
425 unsigned char *r
= res
;
427 if (p
== beg
+ 4 && IS_DIRECTORY_SEP (*beg
) && beg
[1] == ':')
429 strncpy (res
, beg
, 2);
434 if (getdefdir (toupper (*beg
) - 'A' + 1, r
))
436 if (!IS_DIRECTORY_SEP (res
[strlen (res
) - 1]))
439 p
= beg
+ strlen (beg
);
442 CORRECT_DIR_SEPS (beg
);
445 if (STRING_MULTIBYTE (filename
))
446 return make_string (beg
, p
- beg
);
447 return make_unibyte_string (beg
, p
- beg
);
450 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory
,
451 Sfile_name_nondirectory
, 1, 1, 0,
452 doc
: /* Return file name FILENAME sans its directory.
453 For example, in a Unix-syntax file name,
454 this is everything after the last slash,
455 or the entire name if it contains no slash. */)
457 Lisp_Object filename
;
459 register unsigned char *beg
, *p
, *end
;
462 CHECK_STRING (filename
, 0);
464 /* If the file name has special constructs in it,
465 call the corresponding file handler. */
466 handler
= Ffind_file_name_handler (filename
, Qfile_name_nondirectory
);
468 return call2 (handler
, Qfile_name_nondirectory
, filename
);
470 beg
= XSTRING (filename
)->data
;
471 end
= p
= beg
+ STRING_BYTES (XSTRING (filename
));
473 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
475 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
478 /* only recognise drive specifier at beginning */
480 /* handle the "/:d:foo" case correctly */
481 && (p
== beg
+ 2 || (p
== beg
+ 4 && IS_DIRECTORY_SEP (*beg
))))
486 if (STRING_MULTIBYTE (filename
))
487 return make_string (p
, end
- p
);
488 return make_unibyte_string (p
, end
- p
);
491 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory
,
492 Sunhandled_file_name_directory
, 1, 1, 0,
493 doc
: /* Return a directly usable directory name somehow associated with FILENAME.
494 A `directly usable' directory name is one that may be used without the
495 intervention of any file handler.
496 If FILENAME is a directly usable file itself, return
497 \(file-name-directory FILENAME).
498 The `call-process' and `start-process' functions use this function to
499 get a current directory to run processes in. */)
501 Lisp_Object filename
;
505 /* If the file name has special constructs in it,
506 call the corresponding file handler. */
507 handler
= Ffind_file_name_handler (filename
, Qunhandled_file_name_directory
);
509 return call2 (handler
, Qunhandled_file_name_directory
, filename
);
511 return Ffile_name_directory (filename
);
516 file_name_as_directory (out
, in
)
519 int size
= strlen (in
) - 1;
532 /* Is it already a directory string? */
533 if (in
[size
] == ':' || in
[size
] == ']' || in
[size
] == '>')
535 /* Is it a VMS directory file name? If so, hack VMS syntax. */
536 else if (! index (in
, '/')
537 && ((size
> 3 && ! strcmp (&in
[size
- 3], ".DIR"))
538 || (size
> 3 && ! strcmp (&in
[size
- 3], ".dir"))
539 || (size
> 5 && (! strncmp (&in
[size
- 5], ".DIR", 4)
540 || ! strncmp (&in
[size
- 5], ".dir", 4))
541 && (in
[size
- 1] == '.' || in
[size
- 1] == ';')
542 && in
[size
] == '1')))
544 register char *p
, *dot
;
548 dir:x.dir --> dir:[x]
549 dir:[x]y.dir --> dir:[x.y] */
551 while (p
!= in
&& *p
!= ':' && *p
!= '>' && *p
!= ']') p
--;
554 strncpy (out
, in
, p
- in
);
573 dot
= index (p
, '.');
576 /* blindly remove any extension */
577 size
= strlen (out
) + (dot
- p
);
578 strncat (out
, p
, dot
- p
);
589 /* For Unix syntax, Append a slash if necessary */
590 if (!IS_DIRECTORY_SEP (out
[size
]))
592 out
[size
+ 1] = DIRECTORY_SEP
;
593 out
[size
+ 2] = '\0';
596 CORRECT_DIR_SEPS (out
);
602 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
603 Sfile_name_as_directory
, 1, 1, 0,
604 doc
: /* Return a string representing file FILENAME interpreted as a directory.
605 This operation exists because a directory is also a file, but its name as
606 a directory is different from its name as a file.
607 The result can be used as the value of `default-directory'
608 or passed as second argument to `expand-file-name'.
609 For a Unix-syntax file name, just appends a slash.
610 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc. */)
617 CHECK_STRING (file
, 0);
621 /* If the file name has special constructs in it,
622 call the corresponding file handler. */
623 handler
= Ffind_file_name_handler (file
, Qfile_name_as_directory
);
625 return call2 (handler
, Qfile_name_as_directory
, file
);
627 buf
= (char *) alloca (STRING_BYTES (XSTRING (file
)) + 10);
628 return build_string (file_name_as_directory (buf
, XSTRING (file
)->data
));
632 * Convert from directory name to filename.
634 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
635 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
636 * On UNIX, it's simple: just make sure there isn't a terminating /
638 * Value is nonzero if the string output is different from the input.
642 directory_file_name (src
, dst
)
650 struct FAB fab
= cc$rms_fab
;
651 struct NAM nam
= cc$rms_nam
;
652 char esa
[NAM$C_MAXRSS
];
657 if (! index (src
, '/')
658 && (src
[slen
- 1] == ']'
659 || src
[slen
- 1] == ':'
660 || src
[slen
- 1] == '>'))
662 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
664 fab
.fab$b_fns
= slen
;
665 fab
.fab$l_nam
= &nam
;
666 fab
.fab$l_fop
= FAB$M_NAM
;
669 nam
.nam$b_ess
= sizeof esa
;
670 nam
.nam$b_nop
|= NAM$M_SYNCHK
;
672 /* We call SYS$PARSE to handle such things as [--] for us. */
673 if (SYS$
PARSE (&fab
, 0, 0) == RMS$_NORMAL
)
675 slen
= nam
.nam$b_esl
;
676 if (esa
[slen
- 1] == ';' && esa
[slen
- 2] == '.')
681 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
683 /* what about when we have logical_name:???? */
684 if (src
[slen
- 1] == ':')
685 { /* Xlate logical name and see what we get */
686 ptr
= strcpy (dst
, src
); /* upper case for getenv */
689 if ('a' <= *ptr
&& *ptr
<= 'z')
693 dst
[slen
- 1] = 0; /* remove colon */
694 if (!(src
= egetenv (dst
)))
696 /* should we jump to the beginning of this procedure?
697 Good points: allows us to use logical names that xlate
699 Bad points: can be a problem if we just translated to a device
701 For now, I'll punt and always expect VMS names, and hope for
704 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
705 { /* no recursion here! */
711 { /* not a directory spec */
716 bracket
= src
[slen
- 1];
718 /* If bracket is ']' or '>', bracket - 2 is the corresponding
720 ptr
= index (src
, bracket
- 2);
722 { /* no opening bracket */
726 if (!(rptr
= rindex (src
, '.')))
729 strncpy (dst
, src
, slen
);
733 dst
[slen
++] = bracket
;
738 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
739 then translate the device and recurse. */
740 if (dst
[slen
- 1] == ':'
741 && dst
[slen
- 2] != ':' /* skip decnet nodes */
742 && strcmp (src
+ slen
, "[000000]") == 0)
744 dst
[slen
- 1] = '\0';
745 if ((ptr
= egetenv (dst
))
746 && (rlen
= strlen (ptr
) - 1) > 0
747 && (ptr
[rlen
] == ']' || ptr
[rlen
] == '>')
748 && ptr
[rlen
- 1] == '.')
750 char * buf
= (char *) alloca (strlen (ptr
) + 1);
754 return directory_file_name (buf
, dst
);
759 strcat (dst
, "[000000]");
763 rlen
= strlen (rptr
) - 1;
764 strncat (dst
, rptr
, rlen
);
765 dst
[slen
+ rlen
] = '\0';
766 strcat (dst
, ".DIR.1");
770 /* Process as Unix format: just remove any final slash.
771 But leave "/" unchanged; do not change it to "". */
774 /* Handle // as root for apollo's. */
775 if ((slen
> 2 && dst
[slen
- 1] == '/')
776 || (slen
> 1 && dst
[0] != '/' && dst
[slen
- 1] == '/'))
780 && IS_DIRECTORY_SEP (dst
[slen
- 1])
782 && !IS_ANY_SEP (dst
[slen
- 2])
788 CORRECT_DIR_SEPS (dst
);
793 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
795 doc
: /* Returns the file name of the directory named DIRECTORY.
796 This is the name of the file that holds the data for the directory DIRECTORY.
797 This operation exists because a directory is also a file, but its name as
798 a directory is different from its name as a file.
799 In Unix-syntax, this function just removes the final slash.
800 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",
801 it returns a file name such as \"[X]Y.DIR.1\". */)
803 Lisp_Object directory
;
808 CHECK_STRING (directory
, 0);
810 if (NILP (directory
))
813 /* If the file name has special constructs in it,
814 call the corresponding file handler. */
815 handler
= Ffind_file_name_handler (directory
, Qdirectory_file_name
);
817 return call2 (handler
, Qdirectory_file_name
, directory
);
820 /* 20 extra chars is insufficient for VMS, since we might perform a
821 logical name translation. an equivalence string can be up to 255
822 chars long, so grab that much extra space... - sss */
823 buf
= (char *) alloca (STRING_BYTES (XSTRING (directory
)) + 20 + 255);
825 buf
= (char *) alloca (STRING_BYTES (XSTRING (directory
)) + 20);
827 directory_file_name (XSTRING (directory
)->data
, buf
);
828 return build_string (buf
);
831 static char make_temp_name_tbl
[64] =
833 'A','B','C','D','E','F','G','H',
834 'I','J','K','L','M','N','O','P',
835 'Q','R','S','T','U','V','W','X',
836 'Y','Z','a','b','c','d','e','f',
837 'g','h','i','j','k','l','m','n',
838 'o','p','q','r','s','t','u','v',
839 'w','x','y','z','0','1','2','3',
840 '4','5','6','7','8','9','-','_'
843 static unsigned make_temp_name_count
, make_temp_name_count_initialized_p
;
845 /* Value is a temporary file name starting with PREFIX, a string.
847 The Emacs process number forms part of the result, so there is
848 no danger of generating a name being used by another process.
849 In addition, this function makes an attempt to choose a name
850 which has no existing file. To make this work, PREFIX should be
851 an absolute file name.
853 BASE64_P non-zero means add the pid as 3 characters in base64
854 encoding. In this case, 6 characters will be added to PREFIX to
855 form the file name. Otherwise, if Emacs is running on a system
856 with long file names, add the pid as a decimal number.
858 This function signals an error if no unique file name could be
862 make_temp_name (prefix
, base64_p
)
869 unsigned char *p
, *data
;
873 CHECK_STRING (prefix
, 0);
875 /* VAL is created by adding 6 characters to PREFIX. The first
876 three are the PID of this process, in base 64, and the second
877 three are incremented if the file already exists. This ensures
878 262144 unique file names per PID per PREFIX. */
880 pid
= (int) getpid ();
884 pidbuf
[0] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
885 pidbuf
[1] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
886 pidbuf
[2] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
891 #ifdef HAVE_LONG_FILE_NAMES
892 sprintf (pidbuf
, "%d", pid
);
893 pidlen
= strlen (pidbuf
);
895 pidbuf
[0] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
896 pidbuf
[1] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
897 pidbuf
[2] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
902 len
= XSTRING (prefix
)->size
;
903 val
= make_uninit_string (len
+ 3 + pidlen
);
904 data
= XSTRING (val
)->data
;
905 bcopy(XSTRING (prefix
)->data
, data
, len
);
908 bcopy (pidbuf
, p
, pidlen
);
911 /* Here we try to minimize useless stat'ing when this function is
912 invoked many times successively with the same PREFIX. We achieve
913 this by initializing count to a random value, and incrementing it
916 We don't want make-temp-name to be called while dumping,
917 because then make_temp_name_count_initialized_p would get set
918 and then make_temp_name_count would not be set when Emacs starts. */
920 if (!make_temp_name_count_initialized_p
)
922 make_temp_name_count
= (unsigned) time (NULL
);
923 make_temp_name_count_initialized_p
= 1;
929 unsigned num
= make_temp_name_count
;
931 p
[0] = make_temp_name_tbl
[num
& 63], num
>>= 6;
932 p
[1] = make_temp_name_tbl
[num
& 63], num
>>= 6;
933 p
[2] = make_temp_name_tbl
[num
& 63], num
>>= 6;
935 /* Poor man's congruential RN generator. Replace with
936 ++make_temp_name_count for debugging. */
937 make_temp_name_count
+= 25229;
938 make_temp_name_count
%= 225307;
940 if (stat (data
, &ignored
) < 0)
942 /* We want to return only if errno is ENOENT. */
946 /* The error here is dubious, but there is little else we
947 can do. The alternatives are to return nil, which is
948 as bad as (and in many cases worse than) throwing the
949 error, or to ignore the error, which will likely result
950 in looping through 225307 stat's, which is not only
951 dog-slow, but also useless since it will fallback to
952 the errow below, anyway. */
953 report_file_error ("Cannot create temporary name for prefix",
954 Fcons (prefix
, Qnil
));
959 error ("Cannot create temporary name for prefix `%s'",
960 XSTRING (prefix
)->data
);
965 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
966 doc
: /* Generate temporary file name (string) starting with PREFIX (a string).
967 The Emacs process number forms part of the result,
968 so there is no danger of generating a name being used by another process.
970 In addition, this function makes an attempt to choose a name
971 which has no existing file. To make this work,
972 PREFIX should be an absolute file name.
974 There is a race condition between calling `make-temp-name' and creating the
975 file which opens all kinds of security holes. For that reason, you should
976 probably use `make-temp-file' instead. */)
980 return make_temp_name (prefix
, 0);
985 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
986 doc
: /* Convert filename NAME to absolute, and canonicalize it.
987 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative
988 (does not start with slash); if DEFAULT-DIRECTORY is nil or missing,
989 the current buffer's value of default-directory is used.
990 File name components that are `.' are removed, and
991 so are file name components followed by `..', along with the `..' itself;
992 note that these simplifications are done without checking the resulting
993 file names in the file system.
994 An initial `~/' expands to your home directory.
995 An initial `~USER/' expands to USER's home directory.
996 See also the function `substitute-in-file-name'. */)
997 (name
, default_directory
)
998 Lisp_Object name
, default_directory
;
1002 register unsigned char *newdir
, *p
, *o
;
1004 unsigned char *target
;
1007 unsigned char * colon
= 0;
1008 unsigned char * close
= 0;
1009 unsigned char * slash
= 0;
1010 unsigned char * brack
= 0;
1011 int lbrack
= 0, rbrack
= 0;
1016 int collapse_newdir
= 1;
1020 Lisp_Object handler
;
1022 CHECK_STRING (name
, 0);
1024 /* If the file name has special constructs in it,
1025 call the corresponding file handler. */
1026 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
1027 if (!NILP (handler
))
1028 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
1030 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
1031 if (NILP (default_directory
))
1032 default_directory
= current_buffer
->directory
;
1033 if (! STRINGP (default_directory
))
1034 default_directory
= build_string ("/");
1036 if (!NILP (default_directory
))
1038 handler
= Ffind_file_name_handler (default_directory
, Qexpand_file_name
);
1039 if (!NILP (handler
))
1040 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
1043 o
= XSTRING (default_directory
)->data
;
1045 /* Make sure DEFAULT_DIRECTORY is properly expanded.
1046 It would be better to do this down below where we actually use
1047 default_directory. Unfortunately, calling Fexpand_file_name recursively
1048 could invoke GC, and the strings might be relocated. This would
1049 be annoying because we have pointers into strings lying around
1050 that would need adjusting, and people would add new pointers to
1051 the code and forget to adjust them, resulting in intermittent bugs.
1052 Putting this call here avoids all that crud.
1054 The EQ test avoids infinite recursion. */
1055 if (! NILP (default_directory
) && !EQ (default_directory
, name
)
1056 /* Save time in some common cases - as long as default_directory
1057 is not relative, it can be canonicalized with name below (if it
1058 is needed at all) without requiring it to be expanded now. */
1060 /* Detect MSDOS file names with drive specifiers. */
1061 && ! (IS_DRIVE (o
[0]) && IS_DEVICE_SEP (o
[1]) && IS_DIRECTORY_SEP (o
[2]))
1063 /* Detect Windows file names in UNC format. */
1064 && ! (IS_DIRECTORY_SEP (o
[0]) && IS_DIRECTORY_SEP (o
[1]))
1066 #else /* not DOS_NT */
1067 /* Detect Unix absolute file names (/... alone is not absolute on
1069 && ! (IS_DIRECTORY_SEP (o
[0]))
1070 #endif /* not DOS_NT */
1073 struct gcpro gcpro1
;
1076 default_directory
= Fexpand_file_name (default_directory
, Qnil
);
1081 /* Filenames on VMS are always upper case. */
1082 name
= Fupcase (name
);
1084 #ifdef FILE_SYSTEM_CASE
1085 name
= FILE_SYSTEM_CASE (name
);
1088 nm
= XSTRING (name
)->data
;
1091 /* We will force directory separators to be either all \ or /, so make
1092 a local copy to modify, even if there ends up being no change. */
1093 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
1095 /* Note if special escape prefix is present, but remove for now. */
1096 if (nm
[0] == '/' && nm
[1] == ':')
1102 /* Find and remove drive specifier if present; this makes nm absolute
1103 even if the rest of the name appears to be relative. Only look for
1104 drive specifier at the beginning. */
1105 if (IS_DRIVE (nm
[0]) && IS_DEVICE_SEP (nm
[1]))
1112 /* If we see "c://somedir", we want to strip the first slash after the
1113 colon when stripping the drive letter. Otherwise, this expands to
1115 if (drive
&& IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1117 #endif /* WINDOWSNT */
1121 /* Discard any previous drive specifier if nm is now in UNC format. */
1122 if (IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1128 /* If nm is absolute, look for `/./' or `/../' or `//''sequences; if
1129 none are found, we can probably return right away. We will avoid
1130 allocating a new string if name is already fully expanded. */
1132 IS_DIRECTORY_SEP (nm
[0])
1134 && drive
&& !is_escaped
1137 && (drive
|| IS_DIRECTORY_SEP (nm
[1])) && !is_escaped
1144 /* If it turns out that the filename we want to return is just a
1145 suffix of FILENAME, we don't need to go through and edit
1146 things; we just need to construct a new string using data
1147 starting at the middle of FILENAME. If we set lose to a
1148 non-zero value, that means we've discovered that we can't do
1155 /* Since we know the name is absolute, we can assume that each
1156 element starts with a "/". */
1158 /* "." and ".." are hairy. */
1159 if (IS_DIRECTORY_SEP (p
[0])
1161 && (IS_DIRECTORY_SEP (p
[2])
1163 || (p
[2] == '.' && (IS_DIRECTORY_SEP (p
[3])
1166 /* We want to replace multiple `/' in a row with a single
1169 && IS_DIRECTORY_SEP (p
[0])
1170 && IS_DIRECTORY_SEP (p
[1]))
1177 /* if dev:[dir]/, move nm to / */
1178 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1179 nm
= (brack
? brack
+ 1 : colon
+ 1);
1180 lbrack
= rbrack
= 0;
1188 /* VMS pre V4.4,convert '-'s in filenames. */
1189 if (lbrack
== rbrack
)
1191 if (dots
< 2) /* this is to allow negative version numbers */
1196 if (lbrack
> rbrack
&&
1197 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1198 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1204 /* count open brackets, reset close bracket pointer */
1205 if (p
[0] == '[' || p
[0] == '<')
1206 lbrack
++, brack
= 0;
1207 /* count close brackets, set close bracket pointer */
1208 if (p
[0] == ']' || p
[0] == '>')
1209 rbrack
++, brack
= p
;
1210 /* detect ][ or >< */
1211 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1213 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1214 nm
= p
+ 1, lose
= 1;
1215 if (p
[0] == ':' && (colon
|| slash
))
1216 /* if dev1:[dir]dev2:, move nm to dev2: */
1222 /* if /name/dev:, move nm to dev: */
1225 /* if node::dev:, move colon following dev */
1226 else if (colon
&& colon
[-1] == ':')
1228 /* if dev1:dev2:, move nm to dev2: */
1229 else if (colon
&& colon
[-1] != ':')
1234 if (p
[0] == ':' && !colon
)
1240 if (lbrack
== rbrack
)
1243 else if (p
[0] == '.')
1251 if (index (nm
, '/'))
1252 return build_string (sys_translate_unix (nm
));
1255 /* Make sure directories are all separated with / or \ as
1256 desired, but avoid allocation of a new string when not
1258 CORRECT_DIR_SEPS (nm
);
1260 if (IS_DIRECTORY_SEP (nm
[1]))
1262 if (strcmp (nm
, XSTRING (name
)->data
) != 0)
1263 name
= build_string (nm
);
1267 /* drive must be set, so this is okay */
1268 if (strcmp (nm
- 2, XSTRING (name
)->data
) != 0)
1270 name
= make_string (nm
- 2, p
- nm
+ 2);
1271 XSTRING (name
)->data
[0] = DRIVE_LETTER (drive
);
1272 XSTRING (name
)->data
[1] = ':';
1275 #else /* not DOS_NT */
1276 if (nm
== XSTRING (name
)->data
)
1278 return build_string (nm
);
1279 #endif /* not DOS_NT */
1283 /* At this point, nm might or might not be an absolute file name. We
1284 need to expand ~ or ~user if present, otherwise prefix nm with
1285 default_directory if nm is not absolute, and finally collapse /./
1286 and /foo/../ sequences.
1288 We set newdir to be the appropriate prefix if one is needed:
1289 - the relevant user directory if nm starts with ~ or ~user
1290 - the specified drive's working dir (DOS/NT only) if nm does not
1292 - the value of default_directory.
1294 Note that these prefixes are not guaranteed to be absolute (except
1295 for the working dir of a drive). Therefore, to ensure we always
1296 return an absolute name, if the final prefix is not absolute we
1297 append it to the current working directory. */
1301 if (nm
[0] == '~') /* prefix ~ */
1303 if (IS_DIRECTORY_SEP (nm
[1])
1307 || nm
[1] == 0) /* ~ by itself */
1309 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1310 newdir
= (unsigned char *) "";
1313 collapse_newdir
= 0;
1316 nm
++; /* Don't leave the slash in nm. */
1319 else /* ~user/filename */
1321 for (p
= nm
; *p
&& (!IS_DIRECTORY_SEP (*p
)
1326 o
= (unsigned char *) alloca (p
- nm
+ 1);
1327 bcopy ((char *) nm
, o
, p
- nm
);
1330 pw
= (struct passwd
*) getpwnam (o
+ 1);
1333 newdir
= (unsigned char *) pw
-> pw_dir
;
1335 nm
= p
+ 1; /* skip the terminator */
1339 collapse_newdir
= 0;
1344 /* If we don't find a user of that name, leave the name
1345 unchanged; don't move nm forward to p. */
1350 /* On DOS and Windows, nm is absolute if a drive name was specified;
1351 use the drive's current directory as the prefix if needed. */
1352 if (!newdir
&& drive
)
1354 /* Get default directory if needed to make nm absolute. */
1355 if (!IS_DIRECTORY_SEP (nm
[0]))
1357 newdir
= alloca (MAXPATHLEN
+ 1);
1358 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1363 /* Either nm starts with /, or drive isn't mounted. */
1364 newdir
= alloca (4);
1365 newdir
[0] = DRIVE_LETTER (drive
);
1373 /* Finally, if no prefix has been specified and nm is not absolute,
1374 then it must be expanded relative to default_directory. */
1378 /* /... alone is not absolute on DOS and Windows. */
1379 && !IS_DIRECTORY_SEP (nm
[0])
1382 && !(IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1389 newdir
= XSTRING (default_directory
)->data
;
1391 /* Note if special escape prefix is present, but remove for now. */
1392 if (newdir
[0] == '/' && newdir
[1] == ':')
1403 /* First ensure newdir is an absolute name. */
1405 /* Detect MSDOS file names with drive specifiers. */
1406 ! (IS_DRIVE (newdir
[0])
1407 && IS_DEVICE_SEP (newdir
[1]) && IS_DIRECTORY_SEP (newdir
[2]))
1409 /* Detect Windows file names in UNC format. */
1410 && ! (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1414 /* Effectively, let newdir be (expand-file-name newdir cwd).
1415 Because of the admonition against calling expand-file-name
1416 when we have pointers into lisp strings, we accomplish this
1417 indirectly by prepending newdir to nm if necessary, and using
1418 cwd (or the wd of newdir's drive) as the new newdir. */
1420 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1425 if (!IS_DIRECTORY_SEP (nm
[0]))
1427 char * tmp
= alloca (strlen (newdir
) + strlen (nm
) + 2);
1428 file_name_as_directory (tmp
, newdir
);
1432 newdir
= alloca (MAXPATHLEN
+ 1);
1435 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1442 /* Strip off drive name from prefix, if present. */
1443 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1449 /* Keep only a prefix from newdir if nm starts with slash
1450 (//server/share for UNC, nothing otherwise). */
1451 if (IS_DIRECTORY_SEP (nm
[0]) && collapse_newdir
)
1454 if (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1456 newdir
= strcpy (alloca (strlen (newdir
) + 1), newdir
);
1458 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1460 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1472 /* Get rid of any slash at the end of newdir, unless newdir is
1473 just / or // (an incomplete UNC name). */
1474 length
= strlen (newdir
);
1475 if (length
> 1 && IS_DIRECTORY_SEP (newdir
[length
- 1])
1477 && !(length
== 2 && IS_DIRECTORY_SEP (newdir
[0]))
1481 unsigned char *temp
= (unsigned char *) alloca (length
);
1482 bcopy (newdir
, temp
, length
- 1);
1483 temp
[length
- 1] = 0;
1491 /* Now concatenate the directory and name to new space in the stack frame */
1492 tlen
+= strlen (nm
) + 1;
1494 /* Reserve space for drive specifier and escape prefix, since either
1495 or both may need to be inserted. (The Microsoft x86 compiler
1496 produces incorrect code if the following two lines are combined.) */
1497 target
= (unsigned char *) alloca (tlen
+ 4);
1499 #else /* not DOS_NT */
1500 target
= (unsigned char *) alloca (tlen
);
1501 #endif /* not DOS_NT */
1507 if (nm
[0] == 0 || IS_DIRECTORY_SEP (nm
[0]))
1510 /* If newdir is effectively "C:/", then the drive letter will have
1511 been stripped and newdir will be "/". Concatenating with an
1512 absolute directory in nm produces "//", which will then be
1513 incorrectly treated as a network share. Ignore newdir in
1514 this case (keeping the drive letter). */
1515 if (!(drive
&& nm
[0] && IS_DIRECTORY_SEP (newdir
[0])
1516 && newdir
[1] == '\0'))
1518 strcpy (target
, newdir
);
1522 file_name_as_directory (target
, newdir
);
1525 strcat (target
, nm
);
1527 if (index (target
, '/'))
1528 strcpy (target
, sys_translate_unix (target
));
1531 /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */
1533 /* Now canonicalize by removing `//', `/.' and `/foo/..' if they
1542 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1548 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1549 /* brackets are offset from each other by 2 */
1552 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1553 /* convert [foo][bar] to [bar] */
1554 while (o
[-1] != '[' && o
[-1] != '<')
1556 else if (*p
== '-' && *o
!= '.')
1559 else if (p
[0] == '-' && o
[-1] == '.' &&
1560 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1561 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1565 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1566 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1568 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1570 /* else [foo.-] ==> [-] */
1576 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1577 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1583 if (!IS_DIRECTORY_SEP (*p
))
1587 else if (IS_DIRECTORY_SEP (p
[0])
1589 && (IS_DIRECTORY_SEP (p
[2])
1592 /* If "/." is the entire filename, keep the "/". Otherwise,
1593 just delete the whole "/.". */
1594 if (o
== target
&& p
[2] == '\0')
1598 else if (IS_DIRECTORY_SEP (p
[0]) && p
[1] == '.' && p
[2] == '.'
1599 /* `/../' is the "superroot" on certain file systems. */
1601 && (IS_DIRECTORY_SEP (p
[3]) || p
[3] == 0))
1603 while (o
!= target
&& (--o
) && !IS_DIRECTORY_SEP (*o
))
1605 /* Keep initial / only if this is the whole name. */
1606 if (o
== target
&& IS_ANY_SEP (*o
) && p
[3] == 0)
1611 && IS_DIRECTORY_SEP (p
[0]) && IS_DIRECTORY_SEP (p
[1]))
1613 /* Collapse multiple `/' in a row. */
1615 while (IS_DIRECTORY_SEP (*p
))
1622 #endif /* not VMS */
1626 /* At last, set drive name. */
1628 /* Except for network file name. */
1629 if (!(IS_DIRECTORY_SEP (target
[0]) && IS_DIRECTORY_SEP (target
[1])))
1630 #endif /* WINDOWSNT */
1632 if (!drive
) abort ();
1634 target
[0] = DRIVE_LETTER (drive
);
1637 /* Reinsert the escape prefix if required. */
1644 CORRECT_DIR_SEPS (target
);
1647 return make_string (target
, o
- target
);
1651 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'. */
1652 DEAFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
1653 "Convert FILENAME to absolute, and canonicalize it.\n\
1654 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1655 (does not start with slash); if DEFAULT is nil or missing,\n\
1656 the current buffer's value of default-directory is used.\n\
1657 Filenames containing `.' or `..' as components are simplified;\n\
1658 initial `~/' expands to your home directory.\n\
1659 See also the function `substitute-in-file-name'.")
1661 Lisp_Object name
, defalt
;
1665 register unsigned char *newdir
, *p
, *o
;
1667 unsigned char *target
;
1671 unsigned char * colon
= 0;
1672 unsigned char * close
= 0;
1673 unsigned char * slash
= 0;
1674 unsigned char * brack
= 0;
1675 int lbrack
= 0, rbrack
= 0;
1679 CHECK_STRING (name
, 0);
1682 /* Filenames on VMS are always upper case. */
1683 name
= Fupcase (name
);
1686 nm
= XSTRING (name
)->data
;
1688 /* If nm is absolute, flush ...// and detect /./ and /../.
1689 If no /./ or /../ we can return right away. */
1701 if (p
[0] == '/' && p
[1] == '/'
1703 /* // at start of filename is meaningful on Apollo system. */
1708 if (p
[0] == '/' && p
[1] == '~')
1709 nm
= p
+ 1, lose
= 1;
1710 if (p
[0] == '/' && p
[1] == '.'
1711 && (p
[2] == '/' || p
[2] == 0
1712 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1718 /* if dev:[dir]/, move nm to / */
1719 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1720 nm
= (brack
? brack
+ 1 : colon
+ 1);
1721 lbrack
= rbrack
= 0;
1729 /* VMS pre V4.4,convert '-'s in filenames. */
1730 if (lbrack
== rbrack
)
1732 if (dots
< 2) /* this is to allow negative version numbers */
1737 if (lbrack
> rbrack
&&
1738 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1739 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1745 /* count open brackets, reset close bracket pointer */
1746 if (p
[0] == '[' || p
[0] == '<')
1747 lbrack
++, brack
= 0;
1748 /* count close brackets, set close bracket pointer */
1749 if (p
[0] == ']' || p
[0] == '>')
1750 rbrack
++, brack
= p
;
1751 /* detect ][ or >< */
1752 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1754 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1755 nm
= p
+ 1, lose
= 1;
1756 if (p
[0] == ':' && (colon
|| slash
))
1757 /* if dev1:[dir]dev2:, move nm to dev2: */
1763 /* If /name/dev:, move nm to dev: */
1766 /* If node::dev:, move colon following dev */
1767 else if (colon
&& colon
[-1] == ':')
1769 /* If dev1:dev2:, move nm to dev2: */
1770 else if (colon
&& colon
[-1] != ':')
1775 if (p
[0] == ':' && !colon
)
1781 if (lbrack
== rbrack
)
1784 else if (p
[0] == '.')
1792 if (index (nm
, '/'))
1793 return build_string (sys_translate_unix (nm
));
1795 if (nm
== XSTRING (name
)->data
)
1797 return build_string (nm
);
1801 /* Now determine directory to start with and put it in NEWDIR */
1805 if (nm
[0] == '~') /* prefix ~ */
1810 || nm
[1] == 0)/* ~/filename */
1812 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1813 newdir
= (unsigned char *) "";
1816 nm
++; /* Don't leave the slash in nm. */
1819 else /* ~user/filename */
1821 /* Get past ~ to user */
1822 unsigned char *user
= nm
+ 1;
1823 /* Find end of name. */
1824 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1825 int len
= ptr
? ptr
- user
: strlen (user
);
1827 unsigned char *ptr1
= index (user
, ':');
1828 if (ptr1
!= 0 && ptr1
- user
< len
)
1831 /* Copy the user name into temp storage. */
1832 o
= (unsigned char *) alloca (len
+ 1);
1833 bcopy ((char *) user
, o
, len
);
1836 /* Look up the user name. */
1837 pw
= (struct passwd
*) getpwnam (o
+ 1);
1839 error ("\"%s\" isn't a registered user", o
+ 1);
1841 newdir
= (unsigned char *) pw
->pw_dir
;
1843 /* Discard the user name from NM. */
1850 #endif /* not VMS */
1854 defalt
= current_buffer
->directory
;
1855 CHECK_STRING (defalt
, 1);
1856 newdir
= XSTRING (defalt
)->data
;
1859 /* Now concatenate the directory and name to new space in the stack frame */
1861 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1862 target
= (unsigned char *) alloca (tlen
);
1868 if (nm
[0] == 0 || nm
[0] == '/')
1869 strcpy (target
, newdir
);
1872 file_name_as_directory (target
, newdir
);
1875 strcat (target
, nm
);
1877 if (index (target
, '/'))
1878 strcpy (target
, sys_translate_unix (target
));
1881 /* Now canonicalize by removing /. and /foo/.. if they appear */
1889 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1895 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1896 /* brackets are offset from each other by 2 */
1899 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1900 /* convert [foo][bar] to [bar] */
1901 while (o
[-1] != '[' && o
[-1] != '<')
1903 else if (*p
== '-' && *o
!= '.')
1906 else if (p
[0] == '-' && o
[-1] == '.' &&
1907 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1908 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1912 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1913 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1915 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1917 /* else [foo.-] ==> [-] */
1923 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1924 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1934 else if (!strncmp (p
, "//", 2)
1936 /* // at start of filename is meaningful in Apollo system. */
1944 else if (p
[0] == '/' && p
[1] == '.' &&
1945 (p
[2] == '/' || p
[2] == 0))
1947 else if (!strncmp (p
, "/..", 3)
1948 /* `/../' is the "superroot" on certain file systems. */
1950 && (p
[3] == '/' || p
[3] == 0))
1952 while (o
!= target
&& *--o
!= '/')
1955 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1959 if (o
== target
&& *o
== '/')
1967 #endif /* not VMS */
1970 return make_string (target
, o
- target
);
1974 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1975 Ssubstitute_in_file_name
, 1, 1, 0,
1976 doc
: /* Substitute environment variables referred to in FILENAME.
1977 `$FOO' where FOO is an environment variable name means to substitute
1978 the value of that variable. The variable name should be terminated
1979 with a character not a letter, digit or underscore; otherwise, enclose
1980 the entire variable name in braces.
1981 If `/~' appears, all of FILENAME through that `/' is discarded.
1983 On VMS, `$' substitution is not done; this function does little and only
1984 duplicates what `expand-file-name' does. */)
1986 Lisp_Object filename
;
1990 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1991 unsigned char *target
= NULL
;
1993 int substituted
= 0;
1995 Lisp_Object handler
;
1997 CHECK_STRING (filename
, 0);
1999 /* If the file name has special constructs in it,
2000 call the corresponding file handler. */
2001 handler
= Ffind_file_name_handler (filename
, Qsubstitute_in_file_name
);
2002 if (!NILP (handler
))
2003 return call2 (handler
, Qsubstitute_in_file_name
, filename
);
2005 nm
= XSTRING (filename
)->data
;
2007 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
2008 CORRECT_DIR_SEPS (nm
);
2009 substituted
= (strcmp (nm
, XSTRING (filename
)->data
) != 0);
2011 endp
= nm
+ STRING_BYTES (XSTRING (filename
));
2013 /* If /~ or // appears, discard everything through first slash. */
2015 for (p
= nm
; p
!= endp
; p
++)
2018 #if defined (APOLLO) || defined (WINDOWSNT)
2019 /* // at start of file name is meaningful in Apollo and
2020 WindowsNT systems. */
2021 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != nm
)
2022 #else /* not (APOLLO || WINDOWSNT) */
2023 || IS_DIRECTORY_SEP (p
[0])
2024 #endif /* not (APOLLO || WINDOWSNT) */
2029 || p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>'
2031 || IS_DIRECTORY_SEP (p
[-1])))
2037 /* see comment in expand-file-name about drive specifiers */
2038 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
2039 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
2048 return build_string (nm
);
2051 /* See if any variables are substituted into the string
2052 and find the total length of their values in `total' */
2054 for (p
= nm
; p
!= endp
;)
2064 /* "$$" means a single "$" */
2073 while (p
!= endp
&& *p
!= '}') p
++;
2074 if (*p
!= '}') goto missingclose
;
2080 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
2084 /* Copy out the variable name */
2085 target
= (unsigned char *) alloca (s
- o
+ 1);
2086 strncpy (target
, o
, s
- o
);
2089 strupr (target
); /* $home == $HOME etc. */
2092 /* Get variable value */
2093 o
= (unsigned char *) egetenv (target
);
2094 if (!o
) goto badvar
;
2095 total
+= strlen (o
);
2102 /* If substitution required, recopy the string and do it */
2103 /* Make space in stack frame for the new copy */
2104 xnm
= (unsigned char *) alloca (STRING_BYTES (XSTRING (filename
)) + total
+ 1);
2107 /* Copy the rest of the name through, replacing $ constructs with values */
2124 while (p
!= endp
&& *p
!= '}') p
++;
2125 if (*p
!= '}') goto missingclose
;
2131 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
2135 /* Copy out the variable name */
2136 target
= (unsigned char *) alloca (s
- o
+ 1);
2137 strncpy (target
, o
, s
- o
);
2140 strupr (target
); /* $home == $HOME etc. */
2143 /* Get variable value */
2144 o
= (unsigned char *) egetenv (target
);
2148 if (STRING_MULTIBYTE (filename
))
2150 /* If the original string is multibyte,
2151 convert what we substitute into multibyte. */
2154 int c
= unibyte_char_to_multibyte (*o
++);
2155 x
+= CHAR_STRING (c
, x
);
2167 /* If /~ or // appears, discard everything through first slash. */
2169 for (p
= xnm
; p
!= x
; p
++)
2171 #if defined (APOLLO) || defined (WINDOWSNT)
2172 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != xnm
)
2173 #else /* not (APOLLO || WINDOWSNT) */
2174 || IS_DIRECTORY_SEP (p
[0])
2175 #endif /* not (APOLLO || WINDOWSNT) */
2177 && p
!= xnm
&& IS_DIRECTORY_SEP (p
[-1]))
2180 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
2181 && p
> xnm
&& IS_DIRECTORY_SEP (p
[-1]))
2185 if (STRING_MULTIBYTE (filename
))
2186 return make_string (xnm
, x
- xnm
);
2187 return make_unibyte_string (xnm
, x
- xnm
);
2190 error ("Bad format environment-variable substitution");
2192 error ("Missing \"}\" in environment-variable substitution");
2194 error ("Substituting nonexistent environment variable \"%s\"", target
);
2197 #endif /* not VMS */
2201 /* A slightly faster and more convenient way to get
2202 (directory-file-name (expand-file-name FOO)). */
2205 expand_and_dir_to_file (filename
, defdir
)
2206 Lisp_Object filename
, defdir
;
2208 register Lisp_Object absname
;
2210 absname
= Fexpand_file_name (filename
, defdir
);
2213 register int c
= XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
)) - 1];
2214 if (c
== ':' || c
== ']' || c
== '>')
2215 absname
= Fdirectory_file_name (absname
);
2218 /* Remove final slash, if any (unless this is the root dir).
2219 stat behaves differently depending! */
2220 if (XSTRING (absname
)->size
> 1
2221 && IS_DIRECTORY_SEP (XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
)) - 1])
2222 && !IS_DEVICE_SEP (XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
))-2]))
2223 /* We cannot take shortcuts; they might be wrong for magic file names. */
2224 absname
= Fdirectory_file_name (absname
);
2229 /* Signal an error if the file ABSNAME already exists.
2230 If INTERACTIVE is nonzero, ask the user whether to proceed,
2231 and bypass the error if the user says to go ahead.
2232 QUERYSTRING is a name for the action that is being considered
2235 *STATPTR is used to store the stat information if the file exists.
2236 If the file does not exist, STATPTR->st_mode is set to 0.
2237 If STATPTR is null, we don't store into it.
2239 If QUICK is nonzero, we ask for y or n, not yes or no. */
2242 barf_or_query_if_file_exists (absname
, querystring
, interactive
, statptr
, quick
)
2243 Lisp_Object absname
;
2244 unsigned char *querystring
;
2246 struct stat
*statptr
;
2249 register Lisp_Object tem
, encoded_filename
;
2250 struct stat statbuf
;
2251 struct gcpro gcpro1
;
2253 encoded_filename
= ENCODE_FILE (absname
);
2255 /* stat is a good way to tell whether the file exists,
2256 regardless of what access permissions it has. */
2257 if (stat (XSTRING (encoded_filename
)->data
, &statbuf
) >= 0)
2260 Fsignal (Qfile_already_exists
,
2261 Fcons (build_string ("File already exists"),
2262 Fcons (absname
, Qnil
)));
2264 tem
= format1 ("File %s already exists; %s anyway? ",
2265 XSTRING (absname
)->data
, querystring
);
2267 tem
= Fy_or_n_p (tem
);
2269 tem
= do_yes_or_no_p (tem
);
2272 Fsignal (Qfile_already_exists
,
2273 Fcons (build_string ("File already exists"),
2274 Fcons (absname
, Qnil
)));
2281 statptr
->st_mode
= 0;
2286 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
2287 "fCopy file: \nFCopy %s to file: \np\nP",
2288 doc
: /* Copy FILE to NEWNAME. Both args must be strings.
2289 If NEWNAME names a directory, copy FILE there.
2290 Signals a `file-already-exists' error if file NEWNAME already exists,
2291 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.
2292 A number as third arg means request confirmation if NEWNAME already exists.
2293 This is what happens in interactive use with M-x.
2294 Fourth arg KEEP-TIME non-nil means give the new file the same
2295 last-modified time as the old one. (This works on only some systems.)
2296 A prefix arg makes KEEP-TIME non-nil. */)
2297 (file
, newname
, ok_if_already_exists
, keep_time
)
2298 Lisp_Object file
, newname
, ok_if_already_exists
, keep_time
;
2301 char buf
[16 * 1024];
2302 struct stat st
, out_st
;
2303 Lisp_Object handler
;
2304 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2305 int count
= specpdl_ptr
- specpdl
;
2306 int input_file_statable_p
;
2307 Lisp_Object encoded_file
, encoded_newname
;
2309 encoded_file
= encoded_newname
= Qnil
;
2310 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2311 CHECK_STRING (file
, 0);
2312 CHECK_STRING (newname
, 1);
2314 if (!NILP (Ffile_directory_p (newname
)))
2315 newname
= Fexpand_file_name (file
, newname
);
2317 newname
= Fexpand_file_name (newname
, Qnil
);
2319 file
= Fexpand_file_name (file
, Qnil
);
2321 /* If the input file name has special constructs in it,
2322 call the corresponding file handler. */
2323 handler
= Ffind_file_name_handler (file
, Qcopy_file
);
2324 /* Likewise for output file name. */
2326 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
2327 if (!NILP (handler
))
2328 RETURN_UNGCPRO (call5 (handler
, Qcopy_file
, file
, newname
,
2329 ok_if_already_exists
, keep_time
));
2331 encoded_file
= ENCODE_FILE (file
);
2332 encoded_newname
= ENCODE_FILE (newname
);
2334 if (NILP (ok_if_already_exists
)
2335 || INTEGERP (ok_if_already_exists
))
2336 barf_or_query_if_file_exists (encoded_newname
, "copy to it",
2337 INTEGERP (ok_if_already_exists
), &out_st
, 0);
2338 else if (stat (XSTRING (encoded_newname
)->data
, &out_st
) < 0)
2342 if (!CopyFile (XSTRING (encoded_file
)->data
,
2343 XSTRING (encoded_newname
)->data
,
2345 report_file_error ("Copying file", Fcons (file
, Fcons (newname
, Qnil
)));
2346 else if (NILP (keep_time
))
2349 EMACS_GET_TIME (now
);
2350 if (set_file_times (XSTRING (encoded_newname
)->data
,
2352 Fsignal (Qfile_date_error
,
2353 Fcons (build_string ("Cannot set file date"),
2354 Fcons (newname
, Qnil
)));
2356 #else /* not WINDOWSNT */
2357 ifd
= emacs_open (XSTRING (encoded_file
)->data
, O_RDONLY
, 0);
2359 report_file_error ("Opening input file", Fcons (file
, Qnil
));
2361 record_unwind_protect (close_file_unwind
, make_number (ifd
));
2363 /* We can only copy regular files and symbolic links. Other files are not
2365 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
2367 #if !defined (DOS_NT) || __DJGPP__ > 1
2368 if (out_st
.st_mode
!= 0
2369 && st
.st_dev
== out_st
.st_dev
&& st
.st_ino
== out_st
.st_ino
)
2372 report_file_error ("Input and output files are the same",
2373 Fcons (file
, Fcons (newname
, Qnil
)));
2377 #if defined (S_ISREG) && defined (S_ISLNK)
2378 if (input_file_statable_p
)
2380 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
2382 #if defined (EISDIR)
2383 /* Get a better looking error message. */
2386 report_file_error ("Non-regular file", Fcons (file
, Qnil
));
2389 #endif /* S_ISREG && S_ISLNK */
2392 /* Create the copy file with the same record format as the input file */
2393 ofd
= sys_creat (XSTRING (encoded_newname
)->data
, 0666, ifd
);
2396 /* System's default file type was set to binary by _fmode in emacs.c. */
2397 ofd
= creat (XSTRING (encoded_newname
)->data
, S_IREAD
| S_IWRITE
);
2398 #else /* not MSDOS */
2399 ofd
= creat (XSTRING (encoded_newname
)->data
, 0666);
2400 #endif /* not MSDOS */
2403 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
2405 record_unwind_protect (close_file_unwind
, make_number (ofd
));
2409 while ((n
= emacs_read (ifd
, buf
, sizeof buf
)) > 0)
2410 if (emacs_write (ofd
, buf
, n
) != n
)
2411 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2414 /* Closing the output clobbers the file times on some systems. */
2415 if (emacs_close (ofd
) < 0)
2416 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2418 if (input_file_statable_p
)
2420 if (!NILP (keep_time
))
2422 EMACS_TIME atime
, mtime
;
2423 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
2424 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
2425 if (set_file_times (XSTRING (encoded_newname
)->data
,
2427 Fsignal (Qfile_date_error
,
2428 Fcons (build_string ("Cannot set file date"),
2429 Fcons (newname
, Qnil
)));
2432 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2434 #if defined (__DJGPP__) && __DJGPP__ > 1
2435 /* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
2436 and if it can't, it tells so. Otherwise, under MSDOS we usually
2437 get only the READ bit, which will make the copied file read-only,
2438 so it's better not to chmod at all. */
2439 if ((_djstat_flags
& _STFAIL_WRITEBIT
) == 0)
2440 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2441 #endif /* DJGPP version 2 or newer */
2446 #endif /* WINDOWSNT */
2448 /* Discard the unwind protects. */
2449 specpdl_ptr
= specpdl
+ count
;
2455 DEFUN ("make-directory-internal", Fmake_directory_internal
,
2456 Smake_directory_internal
, 1, 1, 0,
2457 doc
: /* Create a new directory named DIRECTORY. */)
2459 Lisp_Object directory
;
2462 Lisp_Object handler
;
2463 Lisp_Object encoded_dir
;
2465 CHECK_STRING (directory
, 0);
2466 directory
= Fexpand_file_name (directory
, Qnil
);
2468 handler
= Ffind_file_name_handler (directory
, Qmake_directory_internal
);
2469 if (!NILP (handler
))
2470 return call2 (handler
, Qmake_directory_internal
, directory
);
2472 encoded_dir
= ENCODE_FILE (directory
);
2474 dir
= XSTRING (encoded_dir
)->data
;
2477 if (mkdir (dir
) != 0)
2479 if (mkdir (dir
, 0777) != 0)
2481 report_file_error ("Creating directory", Flist (1, &directory
));
2486 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
2487 doc
: /* Delete the directory named DIRECTORY. */)
2489 Lisp_Object directory
;
2492 Lisp_Object handler
;
2493 Lisp_Object encoded_dir
;
2495 CHECK_STRING (directory
, 0);
2496 directory
= Fdirectory_file_name (Fexpand_file_name (directory
, Qnil
));
2498 handler
= Ffind_file_name_handler (directory
, Qdelete_directory
);
2499 if (!NILP (handler
))
2500 return call2 (handler
, Qdelete_directory
, directory
);
2502 encoded_dir
= ENCODE_FILE (directory
);
2504 dir
= XSTRING (encoded_dir
)->data
;
2506 if (rmdir (dir
) != 0)
2507 report_file_error ("Removing directory", Flist (1, &directory
));
2512 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
2513 doc
: /* Delete file named FILENAME.
2514 If file has multiple names, it continues to exist with the other names. */)
2516 Lisp_Object filename
;
2518 Lisp_Object handler
;
2519 Lisp_Object encoded_file
;
2521 CHECK_STRING (filename
, 0);
2522 filename
= Fexpand_file_name (filename
, Qnil
);
2524 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
2525 if (!NILP (handler
))
2526 return call2 (handler
, Qdelete_file
, filename
);
2528 encoded_file
= ENCODE_FILE (filename
);
2530 if (0 > unlink (XSTRING (encoded_file
)->data
))
2531 report_file_error ("Removing old name", Flist (1, &filename
));
2536 internal_delete_file_1 (ignore
)
2542 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */
2545 internal_delete_file (filename
)
2546 Lisp_Object filename
;
2548 return NILP (internal_condition_case_1 (Fdelete_file
, filename
,
2549 Qt
, internal_delete_file_1
));
2552 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
2553 "fRename file: \nFRename %s to file: \np",
2554 doc
: /* Rename FILE as NEWNAME. Both args strings.
2555 If file has names other than FILE, it continues to have those names.
2556 Signals a `file-already-exists' error if a file NEWNAME already exists
2557 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2558 A number as third arg means request confirmation if NEWNAME already exists.
2559 This is what happens in interactive use with M-x. */)
2560 (file
, newname
, ok_if_already_exists
)
2561 Lisp_Object file
, newname
, ok_if_already_exists
;
2564 Lisp_Object args
[2];
2566 Lisp_Object handler
;
2567 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2568 Lisp_Object encoded_file
, encoded_newname
;
2570 encoded_file
= encoded_newname
= Qnil
;
2571 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2572 CHECK_STRING (file
, 0);
2573 CHECK_STRING (newname
, 1);
2574 file
= Fexpand_file_name (file
, Qnil
);
2575 newname
= Fexpand_file_name (newname
, Qnil
);
2577 /* If the file name has special constructs in it,
2578 call the corresponding file handler. */
2579 handler
= Ffind_file_name_handler (file
, Qrename_file
);
2581 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
2582 if (!NILP (handler
))
2583 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
2584 file
, newname
, ok_if_already_exists
));
2586 encoded_file
= ENCODE_FILE (file
);
2587 encoded_newname
= ENCODE_FILE (newname
);
2590 /* If the file names are identical but for the case, don't ask for
2591 confirmation: they simply want to change the letter-case of the
2593 if (NILP (Fstring_equal (Fdowncase (file
), Fdowncase (newname
))))
2595 if (NILP (ok_if_already_exists
)
2596 || INTEGERP (ok_if_already_exists
))
2597 barf_or_query_if_file_exists (encoded_newname
, "rename to it",
2598 INTEGERP (ok_if_already_exists
), 0, 0);
2600 if (0 > rename (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2602 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
)
2603 || 0 > unlink (XSTRING (encoded_file
)->data
))
2608 Fcopy_file (file
, newname
,
2609 /* We have already prompted if it was an integer,
2610 so don't have copy-file prompt again. */
2611 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
2612 Fdelete_file (file
);
2619 report_file_error ("Renaming", Flist (2, args
));
2622 report_file_error ("Renaming", Flist (2, &file
));
2629 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
2630 "fAdd name to file: \nFName to add to %s: \np",
2631 doc
: /* Give FILE additional name NEWNAME. Both args strings.
2632 Signals a `file-already-exists' error if a file NEWNAME already exists
2633 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2634 A number as third arg means request confirmation if NEWNAME already exists.
2635 This is what happens in interactive use with M-x. */)
2636 (file
, newname
, ok_if_already_exists
)
2637 Lisp_Object file
, newname
, ok_if_already_exists
;
2640 Lisp_Object args
[2];
2642 Lisp_Object handler
;
2643 Lisp_Object encoded_file
, encoded_newname
;
2644 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2646 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2647 encoded_file
= encoded_newname
= Qnil
;
2648 CHECK_STRING (file
, 0);
2649 CHECK_STRING (newname
, 1);
2650 file
= Fexpand_file_name (file
, Qnil
);
2651 newname
= Fexpand_file_name (newname
, Qnil
);
2653 /* If the file name has special constructs in it,
2654 call the corresponding file handler. */
2655 handler
= Ffind_file_name_handler (file
, Qadd_name_to_file
);
2656 if (!NILP (handler
))
2657 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2658 newname
, ok_if_already_exists
));
2660 /* If the new name has special constructs in it,
2661 call the corresponding file handler. */
2662 handler
= Ffind_file_name_handler (newname
, Qadd_name_to_file
);
2663 if (!NILP (handler
))
2664 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2665 newname
, ok_if_already_exists
));
2667 encoded_file
= ENCODE_FILE (file
);
2668 encoded_newname
= ENCODE_FILE (newname
);
2670 if (NILP (ok_if_already_exists
)
2671 || INTEGERP (ok_if_already_exists
))
2672 barf_or_query_if_file_exists (encoded_newname
, "make it a new name",
2673 INTEGERP (ok_if_already_exists
), 0, 0);
2675 unlink (XSTRING (newname
)->data
);
2676 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2681 report_file_error ("Adding new name", Flist (2, args
));
2683 report_file_error ("Adding new name", Flist (2, &file
));
2692 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2693 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2694 doc
: /* Make a symbolic link to FILENAME, named LINKNAME. Both args strings.
2695 Signals a `file-already-exists' error if a file LINKNAME already exists
2696 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.
2697 A number as third arg means request confirmation if LINKNAME already exists.
2698 This happens for interactive use with M-x. */)
2699 (filename
, linkname
, ok_if_already_exists
)
2700 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2703 Lisp_Object args
[2];
2705 Lisp_Object handler
;
2706 Lisp_Object encoded_filename
, encoded_linkname
;
2707 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2709 GCPRO4 (filename
, linkname
, encoded_filename
, encoded_linkname
);
2710 encoded_filename
= encoded_linkname
= Qnil
;
2711 CHECK_STRING (filename
, 0);
2712 CHECK_STRING (linkname
, 1);
2713 /* If the link target has a ~, we must expand it to get
2714 a truly valid file name. Otherwise, do not expand;
2715 we want to permit links to relative file names. */
2716 if (XSTRING (filename
)->data
[0] == '~')
2717 filename
= Fexpand_file_name (filename
, Qnil
);
2718 linkname
= Fexpand_file_name (linkname
, Qnil
);
2720 /* If the file name has special constructs in it,
2721 call the corresponding file handler. */
2722 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2723 if (!NILP (handler
))
2724 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2725 linkname
, ok_if_already_exists
));
2727 /* If the new link name has special constructs in it,
2728 call the corresponding file handler. */
2729 handler
= Ffind_file_name_handler (linkname
, Qmake_symbolic_link
);
2730 if (!NILP (handler
))
2731 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2732 linkname
, ok_if_already_exists
));
2734 encoded_filename
= ENCODE_FILE (filename
);
2735 encoded_linkname
= ENCODE_FILE (linkname
);
2737 if (NILP (ok_if_already_exists
)
2738 || INTEGERP (ok_if_already_exists
))
2739 barf_or_query_if_file_exists (encoded_linkname
, "make it a link",
2740 INTEGERP (ok_if_already_exists
), 0, 0);
2741 if (0 > symlink (XSTRING (encoded_filename
)->data
,
2742 XSTRING (encoded_linkname
)->data
))
2744 /* If we didn't complain already, silently delete existing file. */
2745 if (errno
== EEXIST
)
2747 unlink (XSTRING (encoded_linkname
)->data
);
2748 if (0 <= symlink (XSTRING (encoded_filename
)->data
,
2749 XSTRING (encoded_linkname
)->data
))
2759 report_file_error ("Making symbolic link", Flist (2, args
));
2761 report_file_error ("Making symbolic link", Flist (2, &filename
));
2767 #endif /* S_IFLNK */
2771 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2772 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2773 doc
: /* Define the job-wide logical name NAME to have the value STRING.
2774 If STRING is nil or a null string, the logical name NAME is deleted. */)
2779 CHECK_STRING (name
, 0);
2781 delete_logical_name (XSTRING (name
)->data
);
2784 CHECK_STRING (string
, 1);
2786 if (XSTRING (string
)->size
== 0)
2787 delete_logical_name (XSTRING (name
)->data
);
2789 define_logical_name (XSTRING (name
)->data
, XSTRING (string
)->data
);
2798 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2799 doc
: /* Open a network connection to PATH using LOGIN as the login string. */)
2801 Lisp_Object path
, login
;
2805 CHECK_STRING (path
, 0);
2806 CHECK_STRING (login
, 0);
2808 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2810 if (netresult
== -1)
2815 #endif /* HPUX_NET */
2817 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2819 doc
: /* Return t if file FILENAME specifies an absolute file name.
2820 On Unix, this is a name starting with a `/' or a `~'. */)
2822 Lisp_Object filename
;
2826 CHECK_STRING (filename
, 0);
2827 ptr
= XSTRING (filename
)->data
;
2828 if (IS_DIRECTORY_SEP (*ptr
) || *ptr
== '~'
2830 /* ??? This criterion is probably wrong for '<'. */
2831 || index (ptr
, ':') || index (ptr
, '<')
2832 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2836 || (IS_DRIVE (*ptr
) && ptr
[1] == ':' && IS_DIRECTORY_SEP (ptr
[2]))
2844 /* Return nonzero if file FILENAME exists and can be executed. */
2847 check_executable (filename
)
2851 int len
= strlen (filename
);
2854 if (stat (filename
, &st
) < 0)
2856 #if defined (WINDOWSNT) || (defined (MSDOS) && __DJGPP__ > 1)
2857 return ((st
.st_mode
& S_IEXEC
) != 0);
2859 return (S_ISREG (st
.st_mode
)
2861 && (stricmp ((suffix
= filename
+ len
-4), ".com") == 0
2862 || stricmp (suffix
, ".exe") == 0
2863 || stricmp (suffix
, ".bat") == 0)
2864 || (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2865 #endif /* not WINDOWSNT */
2866 #else /* not DOS_NT */
2867 #ifdef HAVE_EUIDACCESS
2868 return (euidaccess (filename
, 1) >= 0);
2870 /* Access isn't quite right because it uses the real uid
2871 and we really want to test with the effective uid.
2872 But Unix doesn't give us a right way to do it. */
2873 return (access (filename
, 1) >= 0);
2875 #endif /* not DOS_NT */
2878 /* Return nonzero if file FILENAME exists and can be written. */
2881 check_writable (filename
)
2886 if (stat (filename
, &st
) < 0)
2888 return (st
.st_mode
& S_IWRITE
|| (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2889 #else /* not MSDOS */
2890 #ifdef HAVE_EUIDACCESS
2891 return (euidaccess (filename
, 2) >= 0);
2893 /* Access isn't quite right because it uses the real uid
2894 and we really want to test with the effective uid.
2895 But Unix doesn't give us a right way to do it.
2896 Opening with O_WRONLY could work for an ordinary file,
2897 but would lose for directories. */
2898 return (access (filename
, 2) >= 0);
2900 #endif /* not MSDOS */
2903 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2904 doc
: /* Return t if file FILENAME exists. (This does not mean you can read it.)
2905 See also `file-readable-p' and `file-attributes'. */)
2907 Lisp_Object filename
;
2909 Lisp_Object absname
;
2910 Lisp_Object handler
;
2911 struct stat statbuf
;
2913 CHECK_STRING (filename
, 0);
2914 absname
= Fexpand_file_name (filename
, Qnil
);
2916 /* If the file name has special constructs in it,
2917 call the corresponding file handler. */
2918 handler
= Ffind_file_name_handler (absname
, Qfile_exists_p
);
2919 if (!NILP (handler
))
2920 return call2 (handler
, Qfile_exists_p
, absname
);
2922 absname
= ENCODE_FILE (absname
);
2924 return (stat (XSTRING (absname
)->data
, &statbuf
) >= 0) ? Qt
: Qnil
;
2927 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2928 doc
: /* Return t if FILENAME can be executed by you.
2929 For a directory, this means you can access files in that directory. */)
2931 Lisp_Object filename
;
2933 Lisp_Object absname
;
2934 Lisp_Object handler
;
2936 CHECK_STRING (filename
, 0);
2937 absname
= Fexpand_file_name (filename
, Qnil
);
2939 /* If the file name has special constructs in it,
2940 call the corresponding file handler. */
2941 handler
= Ffind_file_name_handler (absname
, Qfile_executable_p
);
2942 if (!NILP (handler
))
2943 return call2 (handler
, Qfile_executable_p
, absname
);
2945 absname
= ENCODE_FILE (absname
);
2947 return (check_executable (XSTRING (absname
)->data
) ? Qt
: Qnil
);
2950 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2951 doc
: /* Return t if file FILENAME exists and you can read it.
2952 See also `file-exists-p' and `file-attributes'. */)
2954 Lisp_Object filename
;
2956 Lisp_Object absname
;
2957 Lisp_Object handler
;
2960 struct stat statbuf
;
2962 CHECK_STRING (filename
, 0);
2963 absname
= Fexpand_file_name (filename
, Qnil
);
2965 /* If the file name has special constructs in it,
2966 call the corresponding file handler. */
2967 handler
= Ffind_file_name_handler (absname
, Qfile_readable_p
);
2968 if (!NILP (handler
))
2969 return call2 (handler
, Qfile_readable_p
, absname
);
2971 absname
= ENCODE_FILE (absname
);
2973 #if defined(DOS_NT) || defined(macintosh)
2974 /* Under MS-DOS, Windows, and Macintosh, open does not work for
2976 if (access (XSTRING (absname
)->data
, 0) == 0)
2979 #else /* not DOS_NT and not macintosh */
2981 #if defined (S_ISFIFO) && defined (O_NONBLOCK)
2982 /* Opening a fifo without O_NONBLOCK can wait.
2983 We don't want to wait. But we don't want to mess wth O_NONBLOCK
2984 except in the case of a fifo, on a system which handles it. */
2985 desc
= stat (XSTRING (absname
)->data
, &statbuf
);
2988 if (S_ISFIFO (statbuf
.st_mode
))
2989 flags
|= O_NONBLOCK
;
2991 desc
= emacs_open (XSTRING (absname
)->data
, flags
, 0);
2996 #endif /* not DOS_NT and not macintosh */
2999 /* Having this before file-symlink-p mysteriously caused it to be forgotten
3001 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
3002 doc
: /* Return t if file FILENAME can be written or created by you. */)
3004 Lisp_Object filename
;
3006 Lisp_Object absname
, dir
, encoded
;
3007 Lisp_Object handler
;
3008 struct stat statbuf
;
3010 CHECK_STRING (filename
, 0);
3011 absname
= Fexpand_file_name (filename
, Qnil
);
3013 /* If the file name has special constructs in it,
3014 call the corresponding file handler. */
3015 handler
= Ffind_file_name_handler (absname
, Qfile_writable_p
);
3016 if (!NILP (handler
))
3017 return call2 (handler
, Qfile_writable_p
, absname
);
3019 encoded
= ENCODE_FILE (absname
);
3020 if (stat (XSTRING (encoded
)->data
, &statbuf
) >= 0)
3021 return (check_writable (XSTRING (encoded
)->data
)
3024 dir
= Ffile_name_directory (absname
);
3027 dir
= Fdirectory_file_name (dir
);
3031 dir
= Fdirectory_file_name (dir
);
3034 dir
= ENCODE_FILE (dir
);
3036 /* The read-only attribute of the parent directory doesn't affect
3037 whether a file or directory can be created within it. Some day we
3038 should check ACLs though, which do affect this. */
3039 if (stat (XSTRING (dir
)->data
, &statbuf
) < 0)
3041 return (statbuf
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
3043 return (check_writable (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "")
3048 DEFUN ("access-file", Faccess_file
, Saccess_file
, 2, 2, 0,
3049 doc
: /* Access file FILENAME, and get an error if that does not work.
3050 The second argument STRING is used in the error message.
3051 If there is no error, we return nil. */)
3053 Lisp_Object filename
, string
;
3055 Lisp_Object handler
, encoded_filename
;
3058 CHECK_STRING (filename
, 0);
3059 CHECK_STRING (string
, 1);
3061 /* If the file name has special constructs in it,
3062 call the corresponding file handler. */
3063 handler
= Ffind_file_name_handler (filename
, Qaccess_file
);
3064 if (!NILP (handler
))
3065 return call3 (handler
, Qaccess_file
, filename
, string
);
3067 encoded_filename
= ENCODE_FILE (filename
);
3069 fd
= emacs_open (XSTRING (encoded_filename
)->data
, O_RDONLY
, 0);
3071 report_file_error (XSTRING (string
)->data
, Fcons (filename
, Qnil
));
3077 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
3078 doc
: /* Return non-nil if file FILENAME is the name of a symbolic link.
3079 The value is the name of the file to which it is linked.
3080 Otherwise returns nil. */)
3082 Lisp_Object filename
;
3089 Lisp_Object handler
;
3091 CHECK_STRING (filename
, 0);
3092 filename
= Fexpand_file_name (filename
, Qnil
);
3094 /* If the file name has special constructs in it,
3095 call the corresponding file handler. */
3096 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
3097 if (!NILP (handler
))
3098 return call2 (handler
, Qfile_symlink_p
, filename
);
3100 filename
= ENCODE_FILE (filename
);
3107 buf
= (char *) xrealloc (buf
, bufsize
);
3108 bzero (buf
, bufsize
);
3111 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
3115 /* HP-UX reports ERANGE if buffer is too small. */
3116 if (errno
== ERANGE
)
3126 while (valsize
>= bufsize
);
3128 val
= make_string (buf
, valsize
);
3129 if (buf
[0] == '/' && index (buf
, ':'))
3130 val
= concat2 (build_string ("/:"), val
);
3132 val
= DECODE_FILE (val
);
3134 #else /* not S_IFLNK */
3136 #endif /* not S_IFLNK */
3139 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
3140 doc
: /* Return t if FILENAME names an existing directory.
3141 Symbolic links to directories count as directories.
3142 See `file-symlink-p' to distinguish symlinks. */)
3144 Lisp_Object filename
;
3146 register Lisp_Object absname
;
3148 Lisp_Object handler
;
3150 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
3152 /* If the file name has special constructs in it,
3153 call the corresponding file handler. */
3154 handler
= Ffind_file_name_handler (absname
, Qfile_directory_p
);
3155 if (!NILP (handler
))
3156 return call2 (handler
, Qfile_directory_p
, absname
);
3158 absname
= ENCODE_FILE (absname
);
3160 if (stat (XSTRING (absname
)->data
, &st
) < 0)
3162 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
3165 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
3166 doc
: /* Return t if file FILENAME is the name of a directory as a file,
3167 and files in that directory can be opened by you. In order to use a
3168 directory as a buffer's current directory, this predicate must return true.
3169 A directory name spec may be given instead; then the value is t
3170 if the directory so specified exists and really is a readable and
3171 searchable directory. */)
3173 Lisp_Object filename
;
3175 Lisp_Object handler
;
3177 struct gcpro gcpro1
;
3179 /* If the file name has special constructs in it,
3180 call the corresponding file handler. */
3181 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
3182 if (!NILP (handler
))
3183 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
3185 /* It's an unlikely combination, but yes we really do need to gcpro:
3186 Suppose that file-accessible-directory-p has no handler, but
3187 file-directory-p does have a handler; this handler causes a GC which
3188 relocates the string in `filename'; and finally file-directory-p
3189 returns non-nil. Then we would end up passing a garbaged string
3190 to file-executable-p. */
3192 tem
= (NILP (Ffile_directory_p (filename
))
3193 || NILP (Ffile_executable_p (filename
)));
3195 return tem
? Qnil
: Qt
;
3198 DEFUN ("file-regular-p", Ffile_regular_p
, Sfile_regular_p
, 1, 1, 0,
3199 doc
: /* Return t if file FILENAME is the name of a regular file.
3200 This is the sort of file that holds an ordinary stream of data bytes. */)
3202 Lisp_Object filename
;
3204 register Lisp_Object absname
;
3206 Lisp_Object handler
;
3208 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
3210 /* If the file name has special constructs in it,
3211 call the corresponding file handler. */
3212 handler
= Ffind_file_name_handler (absname
, Qfile_regular_p
);
3213 if (!NILP (handler
))
3214 return call2 (handler
, Qfile_regular_p
, absname
);
3216 absname
= ENCODE_FILE (absname
);
3221 Lisp_Object tem
= Vw32_get_true_file_attributes
;
3223 /* Tell stat to use expensive method to get accurate info. */
3224 Vw32_get_true_file_attributes
= Qt
;
3225 result
= stat (XSTRING (absname
)->data
, &st
);
3226 Vw32_get_true_file_attributes
= tem
;
3230 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
3233 if (stat (XSTRING (absname
)->data
, &st
) < 0)
3235 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
3239 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
3240 doc
: /* Return mode bits of file named FILENAME, as an integer. */)
3242 Lisp_Object filename
;
3244 Lisp_Object absname
;
3246 Lisp_Object handler
;
3248 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
3250 /* If the file name has special constructs in it,
3251 call the corresponding file handler. */
3252 handler
= Ffind_file_name_handler (absname
, Qfile_modes
);
3253 if (!NILP (handler
))
3254 return call2 (handler
, Qfile_modes
, absname
);
3256 absname
= ENCODE_FILE (absname
);
3258 if (stat (XSTRING (absname
)->data
, &st
) < 0)
3260 #if defined (MSDOS) && __DJGPP__ < 2
3261 if (check_executable (XSTRING (absname
)->data
))
3262 st
.st_mode
|= S_IEXEC
;
3263 #endif /* MSDOS && __DJGPP__ < 2 */
3265 return make_number (st
.st_mode
& 07777);
3268 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
3269 doc
: /* Set mode bits of file named FILENAME to MODE (an integer).
3270 Only the 12 low bits of MODE are used. */)
3272 Lisp_Object filename
, mode
;
3274 Lisp_Object absname
, encoded_absname
;
3275 Lisp_Object handler
;
3277 absname
= Fexpand_file_name (filename
, current_buffer
->directory
);
3278 CHECK_NUMBER (mode
, 1);
3280 /* If the file name has special constructs in it,
3281 call the corresponding file handler. */
3282 handler
= Ffind_file_name_handler (absname
, Qset_file_modes
);
3283 if (!NILP (handler
))
3284 return call3 (handler
, Qset_file_modes
, absname
, mode
);
3286 encoded_absname
= ENCODE_FILE (absname
);
3288 if (chmod (XSTRING (encoded_absname
)->data
, XINT (mode
)) < 0)
3289 report_file_error ("Doing chmod", Fcons (absname
, Qnil
));
3294 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
3295 doc
: /* Set the file permission bits for newly created files.
3296 The argument MODE should be an integer; only the low 9 bits are used.
3297 This setting is inherited by subprocesses. */)
3301 CHECK_NUMBER (mode
, 0);
3303 umask ((~ XINT (mode
)) & 0777);
3308 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
3309 doc
: /* Return the default file protection for created files.
3310 The value is an integer. */)
3316 realmask
= umask (0);
3319 XSETINT (value
, (~ realmask
) & 0777);
3329 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
3330 doc
: /* Tell Unix to finish all pending disk updates. */)
3339 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
3340 doc
: /* Return t if file FILE1 is newer than file FILE2.
3341 If FILE1 does not exist, the answer is nil;
3342 otherwise, if FILE2 does not exist, the answer is t. */)
3344 Lisp_Object file1
, file2
;
3346 Lisp_Object absname1
, absname2
;
3349 Lisp_Object handler
;
3350 struct gcpro gcpro1
, gcpro2
;
3352 CHECK_STRING (file1
, 0);
3353 CHECK_STRING (file2
, 0);
3356 GCPRO2 (absname1
, file2
);
3357 absname1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
3358 absname2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
3361 /* If the file name has special constructs in it,
3362 call the corresponding file handler. */
3363 handler
= Ffind_file_name_handler (absname1
, Qfile_newer_than_file_p
);
3365 handler
= Ffind_file_name_handler (absname2
, Qfile_newer_than_file_p
);
3366 if (!NILP (handler
))
3367 return call3 (handler
, Qfile_newer_than_file_p
, absname1
, absname2
);
3369 GCPRO2 (absname1
, absname2
);
3370 absname1
= ENCODE_FILE (absname1
);
3371 absname2
= ENCODE_FILE (absname2
);
3374 if (stat (XSTRING (absname1
)->data
, &st
) < 0)
3377 mtime1
= st
.st_mtime
;
3379 if (stat (XSTRING (absname2
)->data
, &st
) < 0)
3382 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
3386 Lisp_Object Qfind_buffer_file_type
;
3389 #ifndef READ_BUF_SIZE
3390 #define READ_BUF_SIZE (64 << 10)
3393 extern void adjust_markers_for_delete
P_ ((int, int, int, int));
3395 /* This function is called after Lisp functions to decide a coding
3396 system are called, or when they cause an error. Before they are
3397 called, the current buffer is set unibyte and it contains only a
3398 newly inserted text (thus the buffer was empty before the
3401 The functions may set markers, overlays, text properties, or even
3402 alter the buffer contents, change the current buffer.
3404 Here, we reset all those changes by:
3405 o set back the current buffer.
3406 o move all markers and overlays to BEG.
3407 o remove all text properties.
3408 o set back the buffer multibyteness. */
3411 decide_coding_unwind (unwind_data
)
3412 Lisp_Object unwind_data
;
3414 Lisp_Object multibyte
, undo_list
, buffer
;
3416 multibyte
= XCAR (unwind_data
);
3417 unwind_data
= XCDR (unwind_data
);
3418 undo_list
= XCAR (unwind_data
);
3419 buffer
= XCDR (unwind_data
);
3421 if (current_buffer
!= XBUFFER (buffer
))
3422 set_buffer_internal (XBUFFER (buffer
));
3423 adjust_markers_for_delete (BEG
, BEG_BYTE
, Z
, Z_BYTE
);
3424 adjust_overlays_for_delete (BEG
, Z
- BEG
);
3425 BUF_INTERVALS (current_buffer
) = 0;
3426 TEMP_SET_PT_BOTH (BEG
, BEG_BYTE
);
3428 /* Now we are safe to change the buffer's multibyteness directly. */
3429 current_buffer
->enable_multibyte_characters
= multibyte
;
3430 current_buffer
->undo_list
= undo_list
;
3436 /* Used to pass values from insert-file-contents to read_non_regular. */
3438 static int non_regular_fd
;
3439 static int non_regular_inserted
;
3440 static int non_regular_nbytes
;
3443 /* Read from a non-regular file.
3444 Read non_regular_trytry bytes max from non_regular_fd.
3445 Non_regular_inserted specifies where to put the read bytes.
3446 Value is the number of bytes read. */
3455 nbytes
= emacs_read (non_regular_fd
,
3456 BEG_ADDR
+ PT_BYTE
- 1 + non_regular_inserted
,
3457 non_regular_nbytes
);
3458 Fsignal (Qquit
, Qnil
);
3460 return make_number (nbytes
);
3464 /* Condition-case handler used when reading from non-regular files
3465 in insert-file-contents. */
3468 read_non_regular_quit ()
3474 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
3476 doc
: /* Insert contents of file FILENAME after point.
3477 Returns list of absolute file name and number of bytes inserted.
3478 If second argument VISIT is non-nil, the buffer's visited filename
3479 and last save file modtime are set, and it is marked unmodified.
3480 If visiting and the file does not exist, visiting is completed
3481 before the error is signaled.
3482 The optional third and fourth arguments BEG and END
3483 specify what portion of the file to insert.
3484 These arguments count bytes in the file, not characters in the buffer.
3485 If VISIT is non-nil, BEG and END must be nil.
3487 If optional fifth argument REPLACE is non-nil,
3488 it means replace the current buffer contents (in the accessible portion)
3489 with the file contents. This is better than simply deleting and inserting
3490 the whole thing because (1) it preserves some marker positions
3491 and (2) it puts less data in the undo list.
3492 When REPLACE is non-nil, the value is the number of characters actually read,
3493 which is often less than the number of characters to be read.
3495 This does code conversion according to the value of
3496 `coding-system-for-read' or `file-coding-system-alist',
3497 and sets the variable `last-coding-system-used' to the coding system
3499 (filename
, visit
, beg
, end
, replace
)
3500 Lisp_Object filename
, visit
, beg
, end
, replace
;
3505 register int how_much
;
3506 register int unprocessed
;
3507 int count
= BINDING_STACK_SIZE ();
3508 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3509 Lisp_Object handler
, val
, insval
, orig_filename
;
3512 int not_regular
= 0;
3513 unsigned char read_buf
[READ_BUF_SIZE
];
3514 struct coding_system coding
;
3515 unsigned char buffer
[1 << 14];
3516 int replace_handled
= 0;
3517 int set_coding_system
= 0;
3518 int coding_system_decided
= 0;
3522 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3523 error ("Cannot do file visiting in an indirect buffer");
3525 if (!NILP (current_buffer
->read_only
))
3526 Fbarf_if_buffer_read_only ();
3530 orig_filename
= Qnil
;
3532 GCPRO4 (filename
, val
, p
, orig_filename
);
3534 CHECK_STRING (filename
, 0);
3535 filename
= Fexpand_file_name (filename
, Qnil
);
3537 /* If the file name has special constructs in it,
3538 call the corresponding file handler. */
3539 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
3540 if (!NILP (handler
))
3542 val
= call6 (handler
, Qinsert_file_contents
, filename
,
3543 visit
, beg
, end
, replace
);
3544 if (CONSP (val
) && CONSP (XCDR (val
)))
3545 inserted
= XINT (XCAR (XCDR (val
)));
3549 orig_filename
= filename
;
3550 filename
= ENCODE_FILE (filename
);
3556 Lisp_Object tem
= Vw32_get_true_file_attributes
;
3558 /* Tell stat to use expensive method to get accurate info. */
3559 Vw32_get_true_file_attributes
= Qt
;
3560 total
= stat (XSTRING (filename
)->data
, &st
);
3561 Vw32_get_true_file_attributes
= tem
;
3566 if (stat (XSTRING (filename
)->data
, &st
) < 0)
3568 if ((fd
= emacs_open (XSTRING (filename
)->data
, O_RDONLY
, 0)) < 0
3569 || fstat (fd
, &st
) < 0)
3570 #endif /* not APOLLO */
3571 #endif /* WINDOWSNT */
3573 if (fd
>= 0) emacs_close (fd
);
3576 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3579 if (!NILP (Vcoding_system_for_read
))
3580 Fset (Qbuffer_file_coding_system
, Vcoding_system_for_read
);
3585 /* This code will need to be changed in order to work on named
3586 pipes, and it's probably just not worth it. So we should at
3587 least signal an error. */
3588 if (!S_ISREG (st
.st_mode
))
3595 if (! NILP (replace
) || ! NILP (beg
) || ! NILP (end
))
3596 Fsignal (Qfile_error
,
3597 Fcons (build_string ("not a regular file"),
3598 Fcons (orig_filename
, Qnil
)));
3603 if ((fd
= emacs_open (XSTRING (filename
)->data
, O_RDONLY
, 0)) < 0)
3606 /* Replacement should preserve point as it preserves markers. */
3607 if (!NILP (replace
))
3608 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
3610 record_unwind_protect (close_file_unwind
, make_number (fd
));
3612 /* Supposedly happens on VMS. */
3613 if (! not_regular
&& st
.st_size
< 0)
3614 error ("File size is negative");
3616 /* Prevent redisplay optimizations. */
3617 current_buffer
->clip_changed
= 1;
3621 if (!NILP (beg
) || !NILP (end
))
3622 error ("Attempt to visit less than an entire file");
3623 if (BEG
< Z
&& NILP (replace
))
3624 error ("Cannot do file visiting in a non-empty buffer");
3628 CHECK_NUMBER (beg
, 0);
3630 XSETFASTINT (beg
, 0);
3633 CHECK_NUMBER (end
, 0);
3638 XSETINT (end
, st
.st_size
);
3640 /* Arithmetic overflow can occur if an Emacs integer cannot
3641 represent the file size, or if the calculations below
3642 overflow. The calculations below double the file size
3643 twice, so check that it can be multiplied by 4 safely. */
3644 if (XINT (end
) != st
.st_size
3645 || ((int) st
.st_size
* 4) / 4 != st
.st_size
)
3646 error ("Maximum buffer size exceeded");
3648 /* The file size returned from stat may be zero, but data
3649 may be readable nonetheless, for example when this is a
3650 file in the /proc filesystem. */
3651 if (st
.st_size
== 0)
3652 XSETINT (end
, READ_BUF_SIZE
);
3658 /* Decide the coding system to use for reading the file now
3659 because we can't use an optimized method for handling
3660 `coding:' tag if the current buffer is not empty. */
3664 if (!NILP (Vcoding_system_for_read
))
3665 val
= Vcoding_system_for_read
;
3666 else if (! NILP (replace
))
3667 /* In REPLACE mode, we can use the same coding system
3668 that was used to visit the file. */
3669 val
= current_buffer
->buffer_file_coding_system
;
3672 /* Don't try looking inside a file for a coding system
3673 specification if it is not seekable. */
3674 if (! not_regular
&& ! NILP (Vset_auto_coding_function
))
3676 /* Find a coding system specified in the heading two
3677 lines or in the tailing several lines of the file.
3678 We assume that the 1K-byte and 3K-byte for heading
3679 and tailing respectively are sufficient for this
3683 if (st
.st_size
<= (1024 * 4))
3684 nread
= emacs_read (fd
, read_buf
, 1024 * 4);
3687 nread
= emacs_read (fd
, read_buf
, 1024);
3690 if (lseek (fd
, st
.st_size
- (1024 * 3), 0) < 0)
3691 report_file_error ("Setting file position",
3692 Fcons (orig_filename
, Qnil
));
3693 nread
+= emacs_read (fd
, read_buf
+ nread
, 1024 * 3);
3698 error ("IO error reading %s: %s",
3699 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3702 struct buffer
*prev
= current_buffer
;
3705 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
3707 /* The call to temp_output_buffer_setup binds
3709 count1
= specpdl_ptr
- specpdl
;
3710 temp_output_buffer_setup (" *code-converting-work*");
3712 set_buffer_internal (XBUFFER (Vstandard_output
));
3713 current_buffer
->enable_multibyte_characters
= Qnil
;
3714 insert_1_both (read_buf
, nread
, nread
, 0, 0, 0);
3715 TEMP_SET_PT_BOTH (BEG
, BEG_BYTE
);
3716 val
= call2 (Vset_auto_coding_function
,
3717 filename
, make_number (nread
));
3718 set_buffer_internal (prev
);
3720 /* Remove the binding for standard-output. */
3721 unbind_to (count1
, Qnil
);
3723 /* Discard the unwind protect for recovering the
3727 /* Rewind the file for the actual read done later. */
3728 if (lseek (fd
, 0, 0) < 0)
3729 report_file_error ("Setting file position",
3730 Fcons (orig_filename
, Qnil
));
3736 /* If we have not yet decided a coding system, check
3737 file-coding-system-alist. */
3738 Lisp_Object args
[6], coding_systems
;
3740 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
;
3741 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = replace
;
3742 coding_systems
= Ffind_operation_coding_system (6, args
);
3743 if (CONSP (coding_systems
))
3744 val
= XCAR (coding_systems
);
3748 setup_coding_system (Fcheck_coding_system (val
), &coding
);
3749 /* Ensure we set Vlast_coding_system_used. */
3750 set_coding_system
= 1;
3752 if (NILP (current_buffer
->enable_multibyte_characters
)
3754 /* We must suppress all character code conversion except for
3755 end-of-line conversion. */
3756 setup_raw_text_coding_system (&coding
);
3758 coding
.src_multibyte
= 0;
3759 coding
.dst_multibyte
3760 = !NILP (current_buffer
->enable_multibyte_characters
);
3761 coding_system_decided
= 1;
3764 /* If requested, replace the accessible part of the buffer
3765 with the file contents. Avoid replacing text at the
3766 beginning or end of the buffer that matches the file contents;
3767 that preserves markers pointing to the unchanged parts.
3769 Here we implement this feature in an optimized way
3770 for the case where code conversion is NOT needed.
3771 The following if-statement handles the case of conversion
3772 in a less optimal way.
3774 If the code conversion is "automatic" then we try using this
3775 method and hope for the best.
3776 But if we discover the need for conversion, we give up on this method
3777 and let the following if-statement handle the replace job. */
3780 && !(coding
.common_flags
& CODING_REQUIRE_DECODING_MASK
))
3782 /* same_at_start and same_at_end count bytes,
3783 because file access counts bytes
3784 and BEG and END count bytes. */
3785 int same_at_start
= BEGV_BYTE
;
3786 int same_at_end
= ZV_BYTE
;
3788 /* There is still a possibility we will find the need to do code
3789 conversion. If that happens, we set this variable to 1 to
3790 give up on handling REPLACE in the optimized way. */
3791 int giveup_match_end
= 0;
3793 if (XINT (beg
) != 0)
3795 if (lseek (fd
, XINT (beg
), 0) < 0)
3796 report_file_error ("Setting file position",
3797 Fcons (orig_filename
, Qnil
));
3802 /* Count how many chars at the start of the file
3803 match the text at the beginning of the buffer. */
3808 nread
= emacs_read (fd
, buffer
, sizeof buffer
);
3810 error ("IO error reading %s: %s",
3811 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3812 else if (nread
== 0)
3815 if (coding
.type
== coding_type_undecided
)
3816 detect_coding (&coding
, buffer
, nread
);
3817 if (coding
.common_flags
& CODING_REQUIRE_DECODING_MASK
)
3818 /* We found that the file should be decoded somehow.
3819 Let's give up here. */
3821 giveup_match_end
= 1;
3825 if (coding
.eol_type
== CODING_EOL_UNDECIDED
)
3826 detect_eol (&coding
, buffer
, nread
);
3827 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3828 && coding
.eol_type
!= CODING_EOL_LF
)
3829 /* We found that the format of eol should be decoded.
3830 Let's give up here. */
3832 giveup_match_end
= 1;
3837 while (bufpos
< nread
&& same_at_start
< ZV_BYTE
3838 && FETCH_BYTE (same_at_start
) == buffer
[bufpos
])
3839 same_at_start
++, bufpos
++;
3840 /* If we found a discrepancy, stop the scan.
3841 Otherwise loop around and scan the next bufferful. */
3842 if (bufpos
!= nread
)
3846 /* If the file matches the buffer completely,
3847 there's no need to replace anything. */
3848 if (same_at_start
- BEGV_BYTE
== XINT (end
))
3852 /* Truncate the buffer to the size of the file. */
3853 del_range_1 (same_at_start
, same_at_end
, 0, 0);
3858 /* Count how many chars at the end of the file
3859 match the text at the end of the buffer. But, if we have
3860 already found that decoding is necessary, don't waste time. */
3861 while (!giveup_match_end
)
3863 int total_read
, nread
, bufpos
, curpos
, trial
;
3865 /* At what file position are we now scanning? */
3866 curpos
= XINT (end
) - (ZV_BYTE
- same_at_end
);
3867 /* If the entire file matches the buffer tail, stop the scan. */
3870 /* How much can we scan in the next step? */
3871 trial
= min (curpos
, sizeof buffer
);
3872 if (lseek (fd
, curpos
- trial
, 0) < 0)
3873 report_file_error ("Setting file position",
3874 Fcons (orig_filename
, Qnil
));
3876 total_read
= nread
= 0;
3877 while (total_read
< trial
)
3879 nread
= emacs_read (fd
, buffer
+ total_read
, trial
- total_read
);
3881 error ("IO error reading %s: %s",
3882 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3883 else if (nread
== 0)
3885 total_read
+= nread
;
3888 /* Scan this bufferful from the end, comparing with
3889 the Emacs buffer. */
3890 bufpos
= total_read
;
3892 /* Compare with same_at_start to avoid counting some buffer text
3893 as matching both at the file's beginning and at the end. */
3894 while (bufpos
> 0 && same_at_end
> same_at_start
3895 && FETCH_BYTE (same_at_end
- 1) == buffer
[bufpos
- 1])
3896 same_at_end
--, bufpos
--;
3898 /* If we found a discrepancy, stop the scan.
3899 Otherwise loop around and scan the preceding bufferful. */
3902 /* If this discrepancy is because of code conversion,
3903 we cannot use this method; giveup and try the other. */
3904 if (same_at_end
> same_at_start
3905 && FETCH_BYTE (same_at_end
- 1) >= 0200
3906 && ! NILP (current_buffer
->enable_multibyte_characters
)
3907 && (CODING_MAY_REQUIRE_DECODING (&coding
)))
3908 giveup_match_end
= 1;
3917 if (! giveup_match_end
)
3921 /* We win! We can handle REPLACE the optimized way. */
3923 /* Extend the start of non-matching text area to multibyte
3924 character boundary. */
3925 if (! NILP (current_buffer
->enable_multibyte_characters
))
3926 while (same_at_start
> BEGV_BYTE
3927 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start
)))
3930 /* Extend the end of non-matching text area to multibyte
3931 character boundary. */
3932 if (! NILP (current_buffer
->enable_multibyte_characters
))
3933 while (same_at_end
< ZV_BYTE
3934 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
3937 /* Don't try to reuse the same piece of text twice. */
3938 overlap
= (same_at_start
- BEGV_BYTE
3939 - (same_at_end
+ st
.st_size
- ZV
));
3941 same_at_end
+= overlap
;
3943 /* Arrange to read only the nonmatching middle part of the file. */
3944 XSETFASTINT (beg
, XINT (beg
) + (same_at_start
- BEGV_BYTE
));
3945 XSETFASTINT (end
, XINT (end
) - (ZV_BYTE
- same_at_end
));
3947 del_range_byte (same_at_start
, same_at_end
, 0);
3948 /* Insert from the file at the proper position. */
3949 temp
= BYTE_TO_CHAR (same_at_start
);
3950 SET_PT_BOTH (temp
, same_at_start
);
3952 /* If display currently starts at beginning of line,
3953 keep it that way. */
3954 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3955 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3957 replace_handled
= 1;
3961 /* If requested, replace the accessible part of the buffer
3962 with the file contents. Avoid replacing text at the
3963 beginning or end of the buffer that matches the file contents;
3964 that preserves markers pointing to the unchanged parts.
3966 Here we implement this feature for the case where code conversion
3967 is needed, in a simple way that needs a lot of memory.
3968 The preceding if-statement handles the case of no conversion
3969 in a more optimized way. */
3970 if (!NILP (replace
) && ! replace_handled
&& BEGV
< ZV
)
3972 int same_at_start
= BEGV_BYTE
;
3973 int same_at_end
= ZV_BYTE
;
3976 /* Make sure that the gap is large enough. */
3977 int bufsize
= 2 * st
.st_size
;
3978 unsigned char *conversion_buffer
= (unsigned char *) xmalloc (bufsize
);
3981 /* First read the whole file, performing code conversion into
3982 CONVERSION_BUFFER. */
3984 if (lseek (fd
, XINT (beg
), 0) < 0)
3986 xfree (conversion_buffer
);
3987 report_file_error ("Setting file position",
3988 Fcons (orig_filename
, Qnil
));
3991 total
= st
.st_size
; /* Total bytes in the file. */
3992 how_much
= 0; /* Bytes read from file so far. */
3993 inserted
= 0; /* Bytes put into CONVERSION_BUFFER so far. */
3994 unprocessed
= 0; /* Bytes not processed in previous loop. */
3996 while (how_much
< total
)
3998 /* try is reserved in some compilers (Microsoft C) */
3999 int trytry
= min (total
- how_much
, READ_BUF_SIZE
- unprocessed
);
4000 unsigned char *destination
= read_buf
+ unprocessed
;
4003 /* Allow quitting out of the actual I/O. */
4006 this = emacs_read (fd
, destination
, trytry
);
4009 if (this < 0 || this + unprocessed
== 0)
4017 if (CODING_MAY_REQUIRE_DECODING (&coding
))
4019 int require
, result
;
4021 this += unprocessed
;
4023 /* If we are using more space than estimated,
4024 make CONVERSION_BUFFER bigger. */
4025 require
= decoding_buffer_size (&coding
, this);
4026 if (inserted
+ require
+ 2 * (total
- how_much
) > bufsize
)
4028 bufsize
= inserted
+ require
+ 2 * (total
- how_much
);
4029 conversion_buffer
= (unsigned char *) xrealloc (conversion_buffer
, bufsize
);
4032 /* Convert this batch with results in CONVERSION_BUFFER. */
4033 if (how_much
>= total
) /* This is the last block. */
4034 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4035 if (coding
.composing
!= COMPOSITION_DISABLED
)
4036 coding_allocate_composition_data (&coding
, BEGV
);
4037 result
= decode_coding (&coding
, read_buf
,
4038 conversion_buffer
+ inserted
,
4039 this, bufsize
- inserted
);
4041 /* Save for next iteration whatever we didn't convert. */
4042 unprocessed
= this - coding
.consumed
;
4043 bcopy (read_buf
+ coding
.consumed
, read_buf
, unprocessed
);
4044 if (!NILP (current_buffer
->enable_multibyte_characters
))
4045 this = coding
.produced
;
4047 this = str_as_unibyte (conversion_buffer
+ inserted
,
4054 /* At this point, INSERTED is how many characters (i.e. bytes)
4055 are present in CONVERSION_BUFFER.
4056 HOW_MUCH should equal TOTAL,
4057 or should be <= 0 if we couldn't read the file. */
4061 xfree (conversion_buffer
);
4064 error ("IO error reading %s: %s",
4065 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
4066 else if (how_much
== -2)
4067 error ("maximum buffer size exceeded");
4070 /* Compare the beginning of the converted file
4071 with the buffer text. */
4074 while (bufpos
< inserted
&& same_at_start
< same_at_end
4075 && FETCH_BYTE (same_at_start
) == conversion_buffer
[bufpos
])
4076 same_at_start
++, bufpos
++;
4078 /* If the file matches the buffer completely,
4079 there's no need to replace anything. */
4081 if (bufpos
== inserted
)
4083 xfree (conversion_buffer
);
4086 /* Truncate the buffer to the size of the file. */
4087 del_range_byte (same_at_start
, same_at_end
, 0);
4092 /* Extend the start of non-matching text area to multibyte
4093 character boundary. */
4094 if (! NILP (current_buffer
->enable_multibyte_characters
))
4095 while (same_at_start
> BEGV_BYTE
4096 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start
)))
4099 /* Scan this bufferful from the end, comparing with
4100 the Emacs buffer. */
4103 /* Compare with same_at_start to avoid counting some buffer text
4104 as matching both at the file's beginning and at the end. */
4105 while (bufpos
> 0 && same_at_end
> same_at_start
4106 && FETCH_BYTE (same_at_end
- 1) == conversion_buffer
[bufpos
- 1])
4107 same_at_end
--, bufpos
--;
4109 /* Extend the end of non-matching text area to multibyte
4110 character boundary. */
4111 if (! NILP (current_buffer
->enable_multibyte_characters
))
4112 while (same_at_end
< ZV_BYTE
4113 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
4116 /* Don't try to reuse the same piece of text twice. */
4117 overlap
= same_at_start
- BEGV_BYTE
- (same_at_end
+ inserted
- ZV_BYTE
);
4119 same_at_end
+= overlap
;
4121 /* If display currently starts at beginning of line,
4122 keep it that way. */
4123 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
4124 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
4126 /* Replace the chars that we need to replace,
4127 and update INSERTED to equal the number of bytes
4128 we are taking from the file. */
4129 inserted
-= (Z_BYTE
- same_at_end
) + (same_at_start
- BEG_BYTE
);
4131 if (same_at_end
!= same_at_start
)
4133 del_range_byte (same_at_start
, same_at_end
, 0);
4135 same_at_start
= GPT_BYTE
;
4139 temp
= BYTE_TO_CHAR (same_at_start
);
4141 /* Insert from the file at the proper position. */
4142 SET_PT_BOTH (temp
, same_at_start
);
4143 insert_1 (conversion_buffer
+ same_at_start
- BEG_BYTE
, inserted
,
4145 if (coding
.cmp_data
&& coding
.cmp_data
->used
)
4146 coding_restore_composition (&coding
, Fcurrent_buffer ());
4147 coding_free_composition_data (&coding
);
4149 /* Set `inserted' to the number of inserted characters. */
4150 inserted
= PT
- temp
;
4152 xfree (conversion_buffer
);
4161 register Lisp_Object temp
;
4163 total
= XINT (end
) - XINT (beg
);
4165 /* Make sure point-max won't overflow after this insertion. */
4166 XSETINT (temp
, total
);
4167 if (total
!= XINT (temp
))
4168 error ("Maximum buffer size exceeded");
4171 /* For a special file, all we can do is guess. */
4172 total
= READ_BUF_SIZE
;
4174 if (NILP (visit
) && total
> 0)
4175 prepare_to_modify_buffer (PT
, PT
, NULL
);
4178 if (GAP_SIZE
< total
)
4179 make_gap (total
- GAP_SIZE
);
4181 if (XINT (beg
) != 0 || !NILP (replace
))
4183 if (lseek (fd
, XINT (beg
), 0) < 0)
4184 report_file_error ("Setting file position",
4185 Fcons (orig_filename
, Qnil
));
4188 /* In the following loop, HOW_MUCH contains the total bytes read so
4189 far for a regular file, and not changed for a special file. But,
4190 before exiting the loop, it is set to a negative value if I/O
4194 /* Total bytes inserted. */
4197 /* Here, we don't do code conversion in the loop. It is done by
4198 code_convert_region after all data are read into the buffer. */
4200 int gap_size
= GAP_SIZE
;
4202 while (how_much
< total
)
4204 /* try is reserved in some compilers (Microsoft C) */
4205 int trytry
= min (total
- how_much
, READ_BUF_SIZE
);
4212 /* Maybe make more room. */
4213 if (gap_size
< trytry
)
4215 make_gap (total
- gap_size
);
4216 gap_size
= GAP_SIZE
;
4219 /* Read from the file, capturing `quit'. When an
4220 error occurs, end the loop, and arrange for a quit
4221 to be signaled after decoding the text we read. */
4222 non_regular_fd
= fd
;
4223 non_regular_inserted
= inserted
;
4224 non_regular_nbytes
= trytry
;
4225 val
= internal_condition_case_1 (read_non_regular
, Qnil
, Qerror
,
4226 read_non_regular_quit
);
4237 /* Allow quitting out of the actual I/O. We don't make text
4238 part of the buffer until all the reading is done, so a C-g
4239 here doesn't do any harm. */
4242 this = emacs_read (fd
, BEG_ADDR
+ PT_BYTE
- 1 + inserted
, trytry
);
4254 /* For a regular file, where TOTAL is the real size,
4255 count HOW_MUCH to compare with it.
4256 For a special file, where TOTAL is just a buffer size,
4257 so don't bother counting in HOW_MUCH.
4258 (INSERTED is where we count the number of characters inserted.) */
4265 /* Make the text read part of the buffer. */
4266 GAP_SIZE
-= inserted
;
4268 GPT_BYTE
+= inserted
;
4270 ZV_BYTE
+= inserted
;
4275 /* Put an anchor to ensure multi-byte form ends at gap. */
4280 /* Discard the unwind protect for closing the file. */
4284 error ("IO error reading %s: %s",
4285 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
4289 if (! coding_system_decided
)
4291 /* The coding system is not yet decided. Decide it by an
4292 optimized method for handling `coding:' tag.
4294 Note that we can get here only if the buffer was empty
4295 before the insertion. */
4299 if (!NILP (Vcoding_system_for_read
))
4300 val
= Vcoding_system_for_read
;
4303 /* Since we are sure that the current buffer was empty
4304 before the insertion, we can toggle
4305 enable-multibyte-characters directly here without taking
4306 care of marker adjustment and byte combining problem. By
4307 this way, we can run Lisp program safely before decoding
4308 the inserted text. */
4309 Lisp_Object unwind_data
;
4310 int count
= specpdl_ptr
- specpdl
;
4312 unwind_data
= Fcons (current_buffer
->enable_multibyte_characters
,
4313 Fcons (current_buffer
->undo_list
,
4314 Fcurrent_buffer ()));
4315 current_buffer
->enable_multibyte_characters
= Qnil
;
4316 current_buffer
->undo_list
= Qt
;
4317 record_unwind_protect (decide_coding_unwind
, unwind_data
);
4319 if (inserted
> 0 && ! NILP (Vset_auto_coding_function
))
4321 val
= call2 (Vset_auto_coding_function
,
4322 filename
, make_number (inserted
));
4327 /* If the coding system is not yet decided, check
4328 file-coding-system-alist. */
4329 Lisp_Object args
[6], coding_systems
;
4331 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
;
4332 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = Qnil
;
4333 coding_systems
= Ffind_operation_coding_system (6, args
);
4334 if (CONSP (coding_systems
))
4335 val
= XCAR (coding_systems
);
4338 unbind_to (count
, Qnil
);
4339 inserted
= Z_BYTE
- BEG_BYTE
;
4342 /* The following kludgy code is to avoid some compiler bug.
4344 setup_coding_system (val, &coding);
4347 struct coding_system temp_coding
;
4348 setup_coding_system (val
, &temp_coding
);
4349 bcopy (&temp_coding
, &coding
, sizeof coding
);
4351 /* Ensure we set Vlast_coding_system_used. */
4352 set_coding_system
= 1;
4354 if (NILP (current_buffer
->enable_multibyte_characters
)
4356 /* We must suppress all character code conversion except for
4357 end-of-line conversion. */
4358 setup_raw_text_coding_system (&coding
);
4359 coding
.src_multibyte
= 0;
4360 coding
.dst_multibyte
4361 = !NILP (current_buffer
->enable_multibyte_characters
);
4365 /* Can't do this if part of the buffer might be preserved. */
4367 && (coding
.type
== coding_type_no_conversion
4368 || coding
.type
== coding_type_raw_text
))
4370 /* Visiting a file with these coding system makes the buffer
4372 current_buffer
->enable_multibyte_characters
= Qnil
;
4373 coding
.dst_multibyte
= 0;
4376 if (inserted
> 0 || coding
.type
== coding_type_ccl
)
4378 if (CODING_MAY_REQUIRE_DECODING (&coding
))
4380 code_convert_region (PT
, PT_BYTE
, PT
+ inserted
, PT_BYTE
+ inserted
,
4382 inserted
= coding
.produced_char
;
4385 adjust_after_insert (PT
, PT_BYTE
, PT
+ inserted
, PT_BYTE
+ inserted
,
4390 /* Use the conversion type to determine buffer-file-type
4391 (find-buffer-file-type is now used to help determine the
4393 if ((coding
.eol_type
== CODING_EOL_UNDECIDED
4394 || coding
.eol_type
== CODING_EOL_LF
)
4395 && ! CODING_REQUIRE_DECODING (&coding
))
4396 current_buffer
->buffer_file_type
= Qt
;
4398 current_buffer
->buffer_file_type
= Qnil
;
4405 if (!EQ (current_buffer
->undo_list
, Qt
))
4406 current_buffer
->undo_list
= Qnil
;
4408 stat (XSTRING (filename
)->data
, &st
);
4413 current_buffer
->modtime
= st
.st_mtime
;
4414 current_buffer
->filename
= orig_filename
;
4417 SAVE_MODIFF
= MODIFF
;
4418 current_buffer
->auto_save_modified
= MODIFF
;
4419 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4420 #ifdef CLASH_DETECTION
4423 if (!NILP (current_buffer
->file_truename
))
4424 unlock_file (current_buffer
->file_truename
);
4425 unlock_file (filename
);
4427 #endif /* CLASH_DETECTION */
4429 Fsignal (Qfile_error
,
4430 Fcons (build_string ("not a regular file"),
4431 Fcons (orig_filename
, Qnil
)));
4434 /* Decode file format */
4437 int empty_undo_list_p
= 0;
4439 /* If we're anyway going to discard undo information, don't
4440 record it in the first place. The buffer's undo list at this
4441 point is either nil or t when visiting a file. */
4444 empty_undo_list_p
= NILP (current_buffer
->undo_list
);
4445 current_buffer
->undo_list
= Qt
;
4448 insval
= call3 (Qformat_decode
,
4449 Qnil
, make_number (inserted
), visit
);
4450 CHECK_NUMBER (insval
, 0);
4451 inserted
= XFASTINT (insval
);
4454 current_buffer
->undo_list
= empty_undo_list_p
? Qnil
: Qt
;
4457 if (set_coding_system
)
4458 Vlast_coding_system_used
= coding
.symbol
;
4460 /* Call after-change hooks for the inserted text, aside from the case
4461 of normal visiting (not with REPLACE), which is done in a new buffer
4462 "before" the buffer is changed. */
4463 if (inserted
> 0 && total
> 0
4464 && (NILP (visit
) || !NILP (replace
)))
4466 signal_after_change (PT
, 0, inserted
);
4467 update_compositions (PT
, PT
, CHECK_BORDER
);
4470 p
= Vafter_insert_file_functions
;
4473 insval
= call1 (Fcar (p
), make_number (inserted
));
4476 CHECK_NUMBER (insval
, 0);
4477 inserted
= XFASTINT (insval
);
4484 && current_buffer
->modtime
== -1)
4486 /* If visiting nonexistent file, return nil. */
4487 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
4491 Fsignal (Qquit
, Qnil
);
4493 /* ??? Retval needs to be dealt with in all cases consistently. */
4495 val
= Fcons (orig_filename
,
4496 Fcons (make_number (inserted
),
4499 RETURN_UNGCPRO (unbind_to (count
, val
));
4502 static Lisp_Object build_annotations
P_ ((Lisp_Object
, Lisp_Object
,
4505 /* If build_annotations switched buffers, switch back to BUF.
4506 Kill the temporary buffer that was selected in the meantime.
4508 Since this kill only the last temporary buffer, some buffers remain
4509 not killed if build_annotations switched buffers more than once.
4513 build_annotations_unwind (buf
)
4518 if (XBUFFER (buf
) == current_buffer
)
4520 tembuf
= Fcurrent_buffer ();
4522 Fkill_buffer (tembuf
);
4526 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 7,
4527 "r\nFWrite region to file: \ni\ni\ni\np",
4528 doc
: /* Write current region into specified file.
4529 When called from a program, takes three arguments:
4530 START, END and FILENAME. START and END are buffer positions.
4531 Optional fourth argument APPEND if non-nil means
4532 append to existing file contents (if any). If it is an integer,
4533 seek to that offset in the file before writing.
4534 Optional fifth argument VISIT if t means
4535 set the last-save-file-modtime of buffer to this file's modtime
4536 and mark buffer not modified.
4537 If VISIT is a string, it is a second file name;
4538 the output goes to FILENAME, but the buffer is marked as visiting VISIT.
4539 VISIT is also the file name to lock and unlock for clash detection.
4540 If VISIT is neither t nor nil nor a string,
4541 that means do not print the \"Wrote file\" message.
4542 The optional sixth arg LOCKNAME, if non-nil, specifies the name to
4543 use for locking and unlocking, overriding FILENAME and VISIT.
4544 The optional seventh arg MUSTBENEW, if non-nil, insists on a check
4545 for an existing file with the same name. If MUSTBENEW is `excl',
4546 that means to get an error if the file already exists; never overwrite.
4547 If MUSTBENEW is neither nil nor `excl', that means ask for
4548 confirmation before overwriting, but do go ahead and overwrite the file
4549 if the user confirms.
4550 Kludgy feature: if START is a string, then that string is written
4551 to the file, instead of any buffer contents, and END is ignored.
4553 This does code conversion according to the value of
4554 `coding-system-for-write', `buffer-file-coding-system', or
4555 `file-coding-system-alist', and sets the variable
4556 `last-coding-system-used' to the coding system actually used. */)
4557 (start
, end
, filename
, append
, visit
, lockname
, mustbenew
)
4558 Lisp_Object start
, end
, filename
, append
, visit
, lockname
, mustbenew
;
4566 int count
= specpdl_ptr
- specpdl
;
4569 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
4571 Lisp_Object handler
;
4572 Lisp_Object visit_file
;
4573 Lisp_Object annotations
;
4574 Lisp_Object encoded_filename
;
4575 int visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
4576 int quietly
= !NILP (visit
);
4577 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
4578 struct buffer
*given_buffer
;
4580 int buffer_file_type
= O_BINARY
;
4582 struct coding_system coding
;
4584 if (current_buffer
->base_buffer
&& visiting
)
4585 error ("Cannot do file visiting in an indirect buffer");
4587 if (!NILP (start
) && !STRINGP (start
))
4588 validate_region (&start
, &end
);
4590 GCPRO4 (start
, filename
, visit
, lockname
);
4592 /* Decide the coding-system to encode the data with. */
4598 else if (!NILP (Vcoding_system_for_write
))
4599 val
= Vcoding_system_for_write
;
4602 /* If the variable `buffer-file-coding-system' is set locally,
4603 it means that the file was read with some kind of code
4604 conversion or the variable is explicitly set by users. We
4605 had better write it out with the same coding system even if
4606 `enable-multibyte-characters' is nil.
4608 If it is not set locally, we anyway have to convert EOL
4609 format if the default value of `buffer-file-coding-system'
4610 tells that it is not Unix-like (LF only) format. */
4611 int using_default_coding
= 0;
4612 int force_raw_text
= 0;
4614 val
= current_buffer
->buffer_file_coding_system
;
4616 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4619 if (NILP (current_buffer
->enable_multibyte_characters
))
4625 /* Check file-coding-system-alist. */
4626 Lisp_Object args
[7], coding_systems
;
4628 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4629 args
[3] = filename
; args
[4] = append
; args
[5] = visit
;
4631 coding_systems
= Ffind_operation_coding_system (7, args
);
4632 if (CONSP (coding_systems
) && !NILP (XCDR (coding_systems
)))
4633 val
= XCDR (coding_systems
);
4637 && !NILP (current_buffer
->buffer_file_coding_system
))
4639 /* If we still have not decided a coding system, use the
4640 default value of buffer-file-coding-system. */
4641 val
= current_buffer
->buffer_file_coding_system
;
4642 using_default_coding
= 1;
4646 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4647 /* Confirm that VAL can surely encode the current region. */
4648 val
= call3 (Vselect_safe_coding_system_function
, start
, end
, val
);
4650 setup_coding_system (Fcheck_coding_system (val
), &coding
);
4651 if (coding
.eol_type
== CODING_EOL_UNDECIDED
4652 && !using_default_coding
)
4654 if (! EQ (default_buffer_file_coding
.symbol
,
4655 buffer_defaults
.buffer_file_coding_system
))
4656 setup_coding_system (buffer_defaults
.buffer_file_coding_system
,
4657 &default_buffer_file_coding
);
4658 if (default_buffer_file_coding
.eol_type
!= CODING_EOL_UNDECIDED
)
4660 Lisp_Object subsidiaries
;
4662 coding
.eol_type
= default_buffer_file_coding
.eol_type
;
4663 subsidiaries
= Fget (coding
.symbol
, Qeol_type
);
4664 if (VECTORP (subsidiaries
)
4665 && XVECTOR (subsidiaries
)->size
== 3)
4667 = XVECTOR (subsidiaries
)->contents
[coding
.eol_type
];
4672 setup_raw_text_coding_system (&coding
);
4673 goto done_setup_coding
;
4676 setup_coding_system (Fcheck_coding_system (val
), &coding
);
4679 if (!STRINGP (start
) && !NILP (current_buffer
->selective_display
))
4680 coding
.mode
|= CODING_MODE_SELECTIVE_DISPLAY
;
4683 Vlast_coding_system_used
= coding
.symbol
;
4685 filename
= Fexpand_file_name (filename
, Qnil
);
4687 if (! NILP (mustbenew
) && !EQ (mustbenew
, Qexcl
))
4688 barf_or_query_if_file_exists (filename
, "overwrite", 1, 0, 1);
4690 if (STRINGP (visit
))
4691 visit_file
= Fexpand_file_name (visit
, Qnil
);
4693 visit_file
= filename
;
4698 if (NILP (lockname
))
4699 lockname
= visit_file
;
4701 GCPRO5 (start
, filename
, annotations
, visit_file
, lockname
);
4703 /* If the file name has special constructs in it,
4704 call the corresponding file handler. */
4705 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
4706 /* If FILENAME has no handler, see if VISIT has one. */
4707 if (NILP (handler
) && STRINGP (visit
))
4708 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
4710 if (!NILP (handler
))
4713 val
= call6 (handler
, Qwrite_region
, start
, end
,
4714 filename
, append
, visit
);
4718 SAVE_MODIFF
= MODIFF
;
4719 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4720 current_buffer
->filename
= visit_file
;
4726 /* Special kludge to simplify auto-saving. */
4729 XSETFASTINT (start
, BEG
);
4730 XSETFASTINT (end
, Z
);
4733 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
4734 count1
= specpdl_ptr
- specpdl
;
4736 given_buffer
= current_buffer
;
4737 annotations
= build_annotations (start
, end
, coding
.pre_write_conversion
);
4738 if (current_buffer
!= given_buffer
)
4740 XSETFASTINT (start
, BEGV
);
4741 XSETFASTINT (end
, ZV
);
4744 #ifdef CLASH_DETECTION
4747 #if 0 /* This causes trouble for GNUS. */
4748 /* If we've locked this file for some other buffer,
4749 query before proceeding. */
4750 if (!visiting
&& EQ (Ffile_locked_p (lockname
), Qt
))
4751 call2 (intern ("ask-user-about-lock"), filename
, Vuser_login_name
);
4754 lock_file (lockname
);
4756 #endif /* CLASH_DETECTION */
4758 encoded_filename
= ENCODE_FILE (filename
);
4760 fn
= XSTRING (encoded_filename
)->data
;
4764 desc
= emacs_open (fn
, O_WRONLY
| buffer_file_type
, 0);
4765 #else /* not DOS_NT */
4766 desc
= emacs_open (fn
, O_WRONLY
, 0);
4767 #endif /* not DOS_NT */
4769 if (desc
< 0 && (NILP (append
) || errno
== ENOENT
))
4771 if (auto_saving
) /* Overwrite any previous version of autosave file */
4773 vms_truncate (fn
); /* if fn exists, truncate to zero length */
4774 desc
= emacs_open (fn
, O_RDWR
, 0);
4776 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
4777 ? XSTRING (current_buffer
->filename
)->data
: 0,
4780 else /* Write to temporary name and rename if no errors */
4782 Lisp_Object temp_name
;
4783 temp_name
= Ffile_name_directory (filename
);
4785 if (!NILP (temp_name
))
4787 temp_name
= Fmake_temp_name (concat2 (temp_name
,
4788 build_string ("$$SAVE$$")));
4789 fname
= XSTRING (filename
)->data
;
4790 fn
= XSTRING (temp_name
)->data
;
4791 desc
= creat_copy_attrs (fname
, fn
);
4794 /* If we can't open the temporary file, try creating a new
4795 version of the original file. VMS "creat" creates a
4796 new version rather than truncating an existing file. */
4799 desc
= creat (fn
, 0666);
4800 #if 0 /* This can clobber an existing file and fail to replace it,
4801 if the user runs out of space. */
4804 /* We can't make a new version;
4805 try to truncate and rewrite existing version if any. */
4807 desc
= emacs_open (fn
, O_RDWR
, 0);
4813 desc
= creat (fn
, 0666);
4817 desc
= emacs_open (fn
,
4818 O_WRONLY
| O_CREAT
| buffer_file_type
4819 | (EQ (mustbenew
, Qexcl
) ? O_EXCL
: O_TRUNC
),
4820 S_IREAD
| S_IWRITE
);
4821 #else /* not DOS_NT */
4822 desc
= emacs_open (fn
, O_WRONLY
| O_TRUNC
| O_CREAT
4823 | (EQ (mustbenew
, Qexcl
) ? O_EXCL
: 0),
4824 auto_saving
? auto_save_mode_bits
: 0666);
4825 #endif /* not DOS_NT */
4826 #endif /* not VMS */
4830 #ifdef CLASH_DETECTION
4832 if (!auto_saving
) unlock_file (lockname
);
4834 #endif /* CLASH_DETECTION */
4836 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
4839 record_unwind_protect (close_file_unwind
, make_number (desc
));
4841 if (!NILP (append
) && !NILP (Ffile_regular_p (filename
)))
4845 if (NUMBERP (append
))
4846 ret
= lseek (desc
, XINT (append
), 1);
4848 ret
= lseek (desc
, 0, 2);
4851 #ifdef CLASH_DETECTION
4852 if (!auto_saving
) unlock_file (lockname
);
4853 #endif /* CLASH_DETECTION */
4855 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
4863 * Kludge Warning: The VMS C RTL likes to insert carriage returns
4864 * if we do writes that don't end with a carriage return. Furthermore
4865 * it cannot handle writes of more then 16K. The modified
4866 * version of "sys_write" in SYSDEP.C (see comment there) copes with
4867 * this EXCEPT for the last record (iff it doesn't end with a carriage
4868 * return). This implies that if your buffer doesn't end with a carriage
4869 * return, you get one free... tough. However it also means that if
4870 * we make two calls to sys_write (a la the following code) you can
4871 * get one at the gap as well. The easiest way to fix this (honest)
4872 * is to move the gap to the next newline (or the end of the buffer).
4877 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4878 move_gap (find_next_newline (GPT
, 1));
4880 /* Whether VMS or not, we must move the gap to the next of newline
4881 when we must put designation sequences at beginning of line. */
4882 if (INTEGERP (start
)
4883 && coding
.type
== coding_type_iso2022
4884 && coding
.flags
& CODING_FLAG_ISO_DESIGNATE_AT_BOL
4885 && GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4887 int opoint
= PT
, opoint_byte
= PT_BYTE
;
4888 scan_newline (PT
, PT_BYTE
, ZV
, ZV_BYTE
, 1, 0);
4889 move_gap_both (PT
, PT_BYTE
);
4890 SET_PT_BOTH (opoint
, opoint_byte
);
4897 if (STRINGP (start
))
4899 failure
= 0 > a_write (desc
, start
, 0, XSTRING (start
)->size
,
4900 &annotations
, &coding
);
4903 else if (XINT (start
) != XINT (end
))
4905 tem
= CHAR_TO_BYTE (XINT (start
));
4907 if (XINT (start
) < GPT
)
4909 failure
= 0 > a_write (desc
, Qnil
, XINT (start
),
4910 min (GPT
, XINT (end
)) - XINT (start
),
4911 &annotations
, &coding
);
4915 if (XINT (end
) > GPT
&& !failure
)
4917 tem
= max (XINT (start
), GPT
);
4918 failure
= 0 > a_write (desc
, Qnil
, tem
, XINT (end
) - tem
,
4919 &annotations
, &coding
);
4925 /* If file was empty, still need to write the annotations */
4926 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4927 failure
= 0 > a_write (desc
, Qnil
, XINT (end
), 0, &annotations
, &coding
);
4931 if (CODING_REQUIRE_FLUSHING (&coding
)
4932 && !(coding
.mode
& CODING_MODE_LAST_BLOCK
)
4935 /* We have to flush out a data. */
4936 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4937 failure
= 0 > e_write (desc
, Qnil
, 0, 0, &coding
);
4944 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
4945 Disk full in NFS may be reported here. */
4946 /* mib says that closing the file will try to write as fast as NFS can do
4947 it, and that means the fsync here is not crucial for autosave files. */
4948 if (!auto_saving
&& fsync (desc
) < 0)
4950 /* If fsync fails with EINTR, don't treat that as serious. */
4952 failure
= 1, save_errno
= errno
;
4956 /* Spurious "file has changed on disk" warnings have been
4957 observed on Suns as well.
4958 It seems that `close' can change the modtime, under nfs.
4960 (This has supposedly been fixed in Sunos 4,
4961 but who knows about all the other machines with NFS?) */
4964 /* On VMS and APOLLO, must do the stat after the close
4965 since closing changes the modtime. */
4968 /* Recall that #if defined does not work on VMS. */
4975 /* NFS can report a write failure now. */
4976 if (emacs_close (desc
) < 0)
4977 failure
= 1, save_errno
= errno
;
4980 /* If we wrote to a temporary name and had no errors, rename to real name. */
4984 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
4992 /* Discard the unwind protect for close_file_unwind. */
4993 specpdl_ptr
= specpdl
+ count1
;
4994 /* Restore the original current buffer. */
4995 visit_file
= unbind_to (count
, visit_file
);
4997 #ifdef CLASH_DETECTION
4999 unlock_file (lockname
);
5000 #endif /* CLASH_DETECTION */
5002 /* Do this before reporting IO error
5003 to avoid a "file has changed on disk" warning on
5004 next attempt to save. */
5006 current_buffer
->modtime
= st
.st_mtime
;
5009 error ("IO error writing %s: %s", XSTRING (filename
)->data
,
5010 emacs_strerror (save_errno
));
5014 SAVE_MODIFF
= MODIFF
;
5015 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
5016 current_buffer
->filename
= visit_file
;
5017 update_mode_lines
++;
5023 message_with_string ("Wrote %s", visit_file
, 1);
5028 Lisp_Object
merge ();
5030 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
5031 doc
: /* Return t if (car A) is numerically less than (car B). */)
5035 return Flss (Fcar (a
), Fcar (b
));
5038 /* Build the complete list of annotations appropriate for writing out
5039 the text between START and END, by calling all the functions in
5040 write-region-annotate-functions and merging the lists they return.
5041 If one of these functions switches to a different buffer, we assume
5042 that buffer contains altered text. Therefore, the caller must
5043 make sure to restore the current buffer in all cases,
5044 as save-excursion would do. */
5047 build_annotations (start
, end
, pre_write_conversion
)
5048 Lisp_Object start
, end
, pre_write_conversion
;
5050 Lisp_Object annotations
;
5052 struct gcpro gcpro1
, gcpro2
;
5053 Lisp_Object original_buffer
;
5056 XSETBUFFER (original_buffer
, current_buffer
);
5059 p
= Vwrite_region_annotate_functions
;
5060 GCPRO2 (annotations
, p
);
5063 struct buffer
*given_buffer
= current_buffer
;
5064 Vwrite_region_annotations_so_far
= annotations
;
5065 res
= call2 (Fcar (p
), start
, end
);
5066 /* If the function makes a different buffer current,
5067 assume that means this buffer contains altered text to be output.
5068 Reset START and END from the buffer bounds
5069 and discard all previous annotations because they should have
5070 been dealt with by this function. */
5071 if (current_buffer
!= given_buffer
)
5073 XSETFASTINT (start
, BEGV
);
5074 XSETFASTINT (end
, ZV
);
5077 Flength (res
); /* Check basic validity of return value */
5078 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
5082 /* Now do the same for annotation functions implied by the file-format */
5083 if (auto_saving
&& (!EQ (Vauto_save_file_format
, Qt
)))
5084 p
= Vauto_save_file_format
;
5086 p
= current_buffer
->file_format
;
5087 for (i
= 0; !NILP (p
); p
= Fcdr (p
), ++i
)
5089 struct buffer
*given_buffer
= current_buffer
;
5091 Vwrite_region_annotations_so_far
= annotations
;
5093 /* Value is either a list of annotations or nil if the function
5094 has written annotations to a temporary buffer, which is now
5096 res
= call5 (Qformat_annotate_function
, Fcar (p
), start
, end
,
5097 original_buffer
, make_number (i
));
5098 if (current_buffer
!= given_buffer
)
5100 XSETFASTINT (start
, BEGV
);
5101 XSETFASTINT (end
, ZV
);
5106 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
5109 /* At last, do the same for the function PRE_WRITE_CONVERSION
5110 implied by the current coding-system. */
5111 if (!NILP (pre_write_conversion
))
5113 struct buffer
*given_buffer
= current_buffer
;
5114 Vwrite_region_annotations_so_far
= annotations
;
5115 res
= call2 (pre_write_conversion
, start
, end
);
5117 annotations
= (current_buffer
!= given_buffer
5119 : merge (annotations
, res
, Qcar_less_than_car
));
5126 /* Write to descriptor DESC the NCHARS chars starting at POS of STRING.
5127 If STRING is nil, POS is the character position in the current buffer.
5128 Intersperse with them the annotations from *ANNOT
5129 which fall within the range of POS to POS + NCHARS,
5130 each at its appropriate position.
5132 We modify *ANNOT by discarding elements as we use them up.
5134 The return value is negative in case of system call failure. */
5137 a_write (desc
, string
, pos
, nchars
, annot
, coding
)
5140 register int nchars
;
5143 struct coding_system
*coding
;
5147 int lastpos
= pos
+ nchars
;
5149 while (NILP (*annot
) || CONSP (*annot
))
5151 tem
= Fcar_safe (Fcar (*annot
));
5154 nextpos
= XFASTINT (tem
);
5156 /* If there are no more annotations in this range,
5157 output the rest of the range all at once. */
5158 if (! (nextpos
>= pos
&& nextpos
<= lastpos
))
5159 return e_write (desc
, string
, pos
, lastpos
, coding
);
5161 /* Output buffer text up to the next annotation's position. */
5164 if (0 > e_write (desc
, string
, pos
, nextpos
, coding
))
5168 /* Output the annotation. */
5169 tem
= Fcdr (Fcar (*annot
));
5172 if (0 > e_write (desc
, tem
, 0, XSTRING (tem
)->size
, coding
))
5175 *annot
= Fcdr (*annot
);
5180 #ifndef WRITE_BUF_SIZE
5181 #define WRITE_BUF_SIZE (16 * 1024)
5184 /* Write text in the range START and END into descriptor DESC,
5185 encoding them with coding system CODING. If STRING is nil, START
5186 and END are character positions of the current buffer, else they
5187 are indexes to the string STRING. */
5190 e_write (desc
, string
, start
, end
, coding
)
5194 struct coding_system
*coding
;
5196 register char *addr
;
5197 register int nbytes
;
5198 char buf
[WRITE_BUF_SIZE
];
5202 coding
->composing
= COMPOSITION_DISABLED
;
5203 if (coding
->composing
!= COMPOSITION_DISABLED
)
5204 coding_save_composition (coding
, start
, end
, string
);
5206 if (STRINGP (string
))
5208 addr
= XSTRING (string
)->data
;
5209 nbytes
= STRING_BYTES (XSTRING (string
));
5210 coding
->src_multibyte
= STRING_MULTIBYTE (string
);
5212 else if (start
< end
)
5214 /* It is assured that the gap is not in the range START and END-1. */
5215 addr
= CHAR_POS_ADDR (start
);
5216 nbytes
= CHAR_TO_BYTE (end
) - CHAR_TO_BYTE (start
);
5217 coding
->src_multibyte
5218 = !NILP (current_buffer
->enable_multibyte_characters
);
5224 coding
->src_multibyte
= 1;
5227 /* We used to have a code for handling selective display here. But,
5228 now it is handled within encode_coding. */
5233 result
= encode_coding (coding
, addr
, buf
, nbytes
, WRITE_BUF_SIZE
);
5234 if (coding
->produced
> 0)
5236 coding
->produced
-= emacs_write (desc
, buf
, coding
->produced
);
5237 if (coding
->produced
)
5243 nbytes
-= coding
->consumed
;
5244 addr
+= coding
->consumed
;
5245 if (result
== CODING_FINISH_INSUFFICIENT_SRC
5248 /* The source text ends by an incomplete multibyte form.
5249 There's no way other than write it out as is. */
5250 nbytes
-= emacs_write (desc
, addr
, nbytes
);
5259 start
+= coding
->consumed_char
;
5260 if (coding
->cmp_data
)
5261 coding_adjust_composition_offset (coding
, start
);
5264 if (coding
->cmp_data
)
5265 coding_free_composition_data (coding
);
5270 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
5271 Sverify_visited_file_modtime
, 1, 1, 0,
5272 doc
: /* Return t if last mod time of BUF's visited file matches what BUF records.
5273 This means that the file has not been changed since it was visited or saved. */)
5279 Lisp_Object handler
;
5280 Lisp_Object filename
;
5282 CHECK_BUFFER (buf
, 0);
5285 if (!STRINGP (b
->filename
)) return Qt
;
5286 if (b
->modtime
== 0) return Qt
;
5288 /* If the file name has special constructs in it,
5289 call the corresponding file handler. */
5290 handler
= Ffind_file_name_handler (b
->filename
,
5291 Qverify_visited_file_modtime
);
5292 if (!NILP (handler
))
5293 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
5295 filename
= ENCODE_FILE (b
->filename
);
5297 if (stat (XSTRING (filename
)->data
, &st
) < 0)
5299 /* If the file doesn't exist now and didn't exist before,
5300 we say that it isn't modified, provided the error is a tame one. */
5301 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
5306 if (st
.st_mtime
== b
->modtime
5307 /* If both are positive, accept them if they are off by one second. */
5308 || (st
.st_mtime
> 0 && b
->modtime
> 0
5309 && (st
.st_mtime
== b
->modtime
+ 1
5310 || st
.st_mtime
== b
->modtime
- 1)))
5315 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
5316 Sclear_visited_file_modtime
, 0, 0, 0,
5317 doc
: /* Clear out records of last mod time of visited file.
5318 Next attempt to save will certainly not complain of a discrepancy. */)
5321 current_buffer
->modtime
= 0;
5325 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
5326 Svisited_file_modtime
, 0, 0, 0,
5327 doc
: /* Return the current buffer's recorded visited file modification time.
5328 The value is a list of the form (HIGH . LOW), like the time values
5329 that `file-attributes' returns. */)
5332 return long_to_cons ((unsigned long) current_buffer
->modtime
);
5335 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
5336 Sset_visited_file_modtime
, 0, 1, 0,
5337 doc
: /* Update buffer's recorded modification time from the visited file's time.
5338 Useful if the buffer was not read from the file normally
5339 or if the file itself has been changed for some known benign reason.
5340 An argument specifies the modification time value to use
5341 \(instead of that of the visited file), in the form of a list
5342 \(HIGH . LOW) or (HIGH LOW). */)
5344 Lisp_Object time_list
;
5346 if (!NILP (time_list
))
5347 current_buffer
->modtime
= cons_to_long (time_list
);
5350 register Lisp_Object filename
;
5352 Lisp_Object handler
;
5354 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
5356 /* If the file name has special constructs in it,
5357 call the corresponding file handler. */
5358 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
5359 if (!NILP (handler
))
5360 /* The handler can find the file name the same way we did. */
5361 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
5363 filename
= ENCODE_FILE (filename
);
5365 if (stat (XSTRING (filename
)->data
, &st
) >= 0)
5366 current_buffer
->modtime
= st
.st_mtime
;
5373 auto_save_error (error
)
5376 Lisp_Object args
[3], msg
;
5378 struct gcpro gcpro1
;
5382 args
[0] = build_string ("Auto-saving %s: %s");
5383 args
[1] = current_buffer
->name
;
5384 args
[2] = Ferror_message_string (error
);
5385 msg
= Fformat (3, args
);
5387 nbytes
= STRING_BYTES (XSTRING (msg
));
5389 for (i
= 0; i
< 3; ++i
)
5392 message2 (XSTRING (msg
)->data
, nbytes
, STRING_MULTIBYTE (msg
));
5394 message2_nolog (XSTRING (msg
)->data
, nbytes
, STRING_MULTIBYTE (msg
));
5395 Fsleep_for (make_number (1), Qnil
);
5407 /* Get visited file's mode to become the auto save file's mode. */
5408 if (! NILP (current_buffer
->filename
)
5409 && stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
5410 /* But make sure we can overwrite it later! */
5411 auto_save_mode_bits
= st
.st_mode
| 0600;
5413 auto_save_mode_bits
= 0666;
5416 Fwrite_region (Qnil
, Qnil
,
5417 current_buffer
->auto_save_file_name
,
5418 Qnil
, Qlambda
, Qnil
, Qnil
);
5422 do_auto_save_unwind (stream
) /* used as unwind-protect function */
5427 fclose ((FILE *) (XFASTINT (XCAR (stream
)) << 16
5428 | XFASTINT (XCDR (stream
))));
5434 do_auto_save_unwind_1 (value
) /* used as unwind-protect function */
5437 minibuffer_auto_raise
= XINT (value
);
5441 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
5442 doc
: /* Auto-save all buffers that need it.
5443 This is all buffers that have auto-saving enabled
5444 and are changed since last auto-saved.
5445 Auto-saving writes the buffer into a file
5446 so that your editing is not lost if the system crashes.
5447 This file is not the file you visited; that changes only when you save.
5448 Normally we run the normal hook `auto-save-hook' before saving.
5450 A non-nil NO-MESSAGE argument means do not print any message if successful.
5451 A non-nil CURRENT-ONLY argument means save only current buffer. */)
5452 (no_message
, current_only
)
5453 Lisp_Object no_message
, current_only
;
5455 struct buffer
*old
= current_buffer
, *b
;
5456 Lisp_Object tail
, buf
;
5458 int do_handled_files
;
5461 Lisp_Object lispstream
;
5462 int count
= specpdl_ptr
- specpdl
;
5463 int orig_minibuffer_auto_raise
= minibuffer_auto_raise
;
5464 int message_p
= push_message ();
5466 /* Ordinarily don't quit within this function,
5467 but don't make it impossible to quit (in case we get hung in I/O). */
5471 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
5472 point to non-strings reached from Vbuffer_alist. */
5477 if (!NILP (Vrun_hooks
))
5478 call1 (Vrun_hooks
, intern ("auto-save-hook"));
5480 if (STRINGP (Vauto_save_list_file_name
))
5482 Lisp_Object listfile
;
5484 listfile
= Fexpand_file_name (Vauto_save_list_file_name
, Qnil
);
5486 /* Don't try to create the directory when shutting down Emacs,
5487 because creating the directory might signal an error, and
5488 that would leave Emacs in a strange state. */
5489 if (!NILP (Vrun_hooks
))
5492 dir
= Ffile_name_directory (listfile
);
5493 if (NILP (Ffile_directory_p (dir
)))
5494 call2 (Qmake_directory
, dir
, Qt
);
5497 stream
= fopen (XSTRING (listfile
)->data
, "w");
5500 /* Arrange to close that file whether or not we get an error.
5501 Also reset auto_saving to 0. */
5502 lispstream
= Fcons (Qnil
, Qnil
);
5503 XSETCARFASTINT (lispstream
, (EMACS_UINT
)stream
>> 16);
5504 XSETCDRFASTINT (lispstream
, (EMACS_UINT
)stream
& 0xffff);
5515 record_unwind_protect (do_auto_save_unwind
, lispstream
);
5516 record_unwind_protect (do_auto_save_unwind_1
,
5517 make_number (minibuffer_auto_raise
));
5518 minibuffer_auto_raise
= 0;
5521 /* First, save all files which don't have handlers. If Emacs is
5522 crashing, the handlers may tweak what is causing Emacs to crash
5523 in the first place, and it would be a shame if Emacs failed to
5524 autosave perfectly ordinary files because it couldn't handle some
5526 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
5527 for (tail
= Vbuffer_alist
; GC_CONSP (tail
); tail
= XCDR (tail
))
5529 buf
= XCDR (XCAR (tail
));
5532 /* Record all the buffers that have auto save mode
5533 in the special file that lists them. For each of these buffers,
5534 Record visited name (if any) and auto save name. */
5535 if (STRINGP (b
->auto_save_file_name
)
5536 && stream
!= NULL
&& do_handled_files
== 0)
5538 if (!NILP (b
->filename
))
5540 fwrite (XSTRING (b
->filename
)->data
, 1,
5541 STRING_BYTES (XSTRING (b
->filename
)), stream
);
5543 putc ('\n', stream
);
5544 fwrite (XSTRING (b
->auto_save_file_name
)->data
, 1,
5545 STRING_BYTES (XSTRING (b
->auto_save_file_name
)), stream
);
5546 putc ('\n', stream
);
5549 if (!NILP (current_only
)
5550 && b
!= current_buffer
)
5553 /* Don't auto-save indirect buffers.
5554 The base buffer takes care of it. */
5558 /* Check for auto save enabled
5559 and file changed since last auto save
5560 and file changed since last real save. */
5561 if (STRINGP (b
->auto_save_file_name
)
5562 && BUF_SAVE_MODIFF (b
) < BUF_MODIFF (b
)
5563 && b
->auto_save_modified
< BUF_MODIFF (b
)
5564 /* -1 means we've turned off autosaving for a while--see below. */
5565 && XINT (b
->save_length
) >= 0
5566 && (do_handled_files
5567 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
5570 EMACS_TIME before_time
, after_time
;
5572 EMACS_GET_TIME (before_time
);
5574 /* If we had a failure, don't try again for 20 minutes. */
5575 if (b
->auto_save_failure_time
>= 0
5576 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
5579 if ((XFASTINT (b
->save_length
) * 10
5580 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
5581 /* A short file is likely to change a large fraction;
5582 spare the user annoying messages. */
5583 && XFASTINT (b
->save_length
) > 5000
5584 /* These messages are frequent and annoying for `*mail*'. */
5585 && !EQ (b
->filename
, Qnil
)
5586 && NILP (no_message
))
5588 /* It has shrunk too much; turn off auto-saving here. */
5589 minibuffer_auto_raise
= orig_minibuffer_auto_raise
;
5590 message_with_string ("Buffer %s has shrunk a lot; auto save turned off there",
5592 minibuffer_auto_raise
= 0;
5593 /* Turn off auto-saving until there's a real save,
5594 and prevent any more warnings. */
5595 XSETINT (b
->save_length
, -1);
5596 Fsleep_for (make_number (1), Qnil
);
5599 set_buffer_internal (b
);
5600 if (!auto_saved
&& NILP (no_message
))
5601 message1 ("Auto-saving...");
5602 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
5604 b
->auto_save_modified
= BUF_MODIFF (b
);
5605 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
5606 set_buffer_internal (old
);
5608 EMACS_GET_TIME (after_time
);
5610 /* If auto-save took more than 60 seconds,
5611 assume it was an NFS failure that got a timeout. */
5612 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
5613 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
5617 /* Prevent another auto save till enough input events come in. */
5618 record_auto_save ();
5620 if (auto_saved
&& NILP (no_message
))
5624 sit_for (1, 0, 0, 0, 0);
5628 message1 ("Auto-saving...done");
5633 unbind_to (count
, Qnil
);
5637 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
5638 Sset_buffer_auto_saved
, 0, 0, 0,
5639 doc
: /* Mark current buffer as auto-saved with its current text.
5640 No auto-save file will be written until the buffer changes again. */)
5643 current_buffer
->auto_save_modified
= MODIFF
;
5644 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
5645 current_buffer
->auto_save_failure_time
= -1;
5649 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
5650 Sclear_buffer_auto_save_failure
, 0, 0, 0,
5651 doc
: /* Clear any record of a recent auto-save failure in the current buffer. */)
5654 current_buffer
->auto_save_failure_time
= -1;
5658 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
5660 doc
: /* Return t if buffer has been auto-saved since last read in or saved. */)
5663 return (SAVE_MODIFF
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
5666 /* Reading and completing file names */
5667 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
5669 /* In the string VAL, change each $ to $$ and return the result. */
5672 double_dollars (val
)
5675 register unsigned char *old
, *new;
5679 osize
= STRING_BYTES (XSTRING (val
));
5681 /* Count the number of $ characters. */
5682 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
5683 if (*old
++ == '$') count
++;
5686 old
= XSTRING (val
)->data
;
5687 val
= make_uninit_multibyte_string (XSTRING (val
)->size
+ count
,
5689 new = XSTRING (val
)->data
;
5690 for (n
= osize
; n
> 0; n
--)
5703 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
5705 doc
: /* Internal subroutine for read-file-name. Do not call this. */)
5706 (string
, dir
, action
)
5707 Lisp_Object string
, dir
, action
;
5708 /* action is nil for complete, t for return list of completions,
5709 lambda for verify final value */
5711 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
5713 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
5715 CHECK_STRING (string
, 0);
5722 /* No need to protect ACTION--we only compare it with t and nil. */
5723 GCPRO5 (string
, realdir
, name
, specdir
, orig_string
);
5725 if (XSTRING (string
)->size
== 0)
5727 if (EQ (action
, Qlambda
))
5735 orig_string
= string
;
5736 string
= Fsubstitute_in_file_name (string
);
5737 changed
= NILP (Fstring_equal (string
, orig_string
));
5738 name
= Ffile_name_nondirectory (string
);
5739 val
= Ffile_name_directory (string
);
5741 realdir
= Fexpand_file_name (val
, realdir
);
5746 specdir
= Ffile_name_directory (string
);
5747 val
= Ffile_name_completion (name
, realdir
);
5752 return double_dollars (string
);
5756 if (!NILP (specdir
))
5757 val
= concat2 (specdir
, val
);
5759 return double_dollars (val
);
5762 #endif /* not VMS */
5766 if (EQ (action
, Qt
))
5767 return Ffile_name_all_completions (name
, realdir
);
5768 /* Only other case actually used is ACTION = lambda */
5770 /* Supposedly this helps commands such as `cd' that read directory names,
5771 but can someone explain how it helps them? -- RMS */
5772 if (XSTRING (name
)->size
== 0)
5775 return Ffile_exists_p (string
);
5778 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
5779 doc
: /* Read file name, prompting with PROMPT and completing in directory DIR.
5780 Value is not expanded---you must call `expand-file-name' yourself.
5781 Default name to DEFAULT-FILENAME if user enters a null string.
5782 (If DEFAULT-FILENAME is omitted, the visited file name is used,
5783 except that if INITIAL is specified, that combined with DIR is used.)
5784 Fourth arg MUSTMATCH non-nil means require existing file's name.
5785 Non-nil and non-t means also require confirmation after completion.
5786 Fifth arg INITIAL specifies text to start with.
5787 DIR defaults to current buffer's directory default.
5789 If this command was invoked with the mouse, use a file dialog box if
5790 `use-dialog-box' is non-nil, and the window system or X toolkit in use
5791 provides a file dialog box. */)
5792 (prompt
, dir
, default_filename
, mustmatch
, initial
)
5793 Lisp_Object prompt
, dir
, default_filename
, mustmatch
, initial
;
5795 Lisp_Object val
, insdef
, tem
;
5796 struct gcpro gcpro1
, gcpro2
;
5797 register char *homedir
;
5798 int replace_in_history
= 0;
5799 int add_to_history
= 0;
5803 dir
= current_buffer
->directory
;
5804 if (NILP (default_filename
))
5806 if (! NILP (initial
))
5807 default_filename
= Fexpand_file_name (initial
, dir
);
5809 default_filename
= current_buffer
->filename
;
5812 /* If dir starts with user's homedir, change that to ~. */
5813 homedir
= (char *) egetenv ("HOME");
5815 /* homedir can be NULL in temacs, since Vprocess_environment is not
5816 yet set up. We shouldn't crash in that case. */
5819 homedir
= strcpy (alloca (strlen (homedir
) + 1), homedir
);
5820 CORRECT_DIR_SEPS (homedir
);
5825 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5826 && IS_DIRECTORY_SEP (XSTRING (dir
)->data
[strlen (homedir
)]))
5828 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5829 STRING_BYTES (XSTRING (dir
)) - strlen (homedir
) + 1);
5830 XSTRING (dir
)->data
[0] = '~';
5832 /* Likewise for default_filename. */
5834 && STRINGP (default_filename
)
5835 && !strncmp (homedir
, XSTRING (default_filename
)->data
, strlen (homedir
))
5836 && IS_DIRECTORY_SEP (XSTRING (default_filename
)->data
[strlen (homedir
)]))
5839 = make_string (XSTRING (default_filename
)->data
+ strlen (homedir
) - 1,
5840 STRING_BYTES (XSTRING (default_filename
)) - strlen (homedir
) + 1);
5841 XSTRING (default_filename
)->data
[0] = '~';
5843 if (!NILP (default_filename
))
5845 CHECK_STRING (default_filename
, 3);
5846 default_filename
= double_dollars (default_filename
);
5849 if (insert_default_directory
&& STRINGP (dir
))
5852 if (!NILP (initial
))
5854 Lisp_Object args
[2], pos
;
5858 insdef
= Fconcat (2, args
);
5859 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
5860 insdef
= Fcons (double_dollars (insdef
), pos
);
5863 insdef
= double_dollars (insdef
);
5865 else if (STRINGP (initial
))
5866 insdef
= Fcons (double_dollars (initial
), make_number (0));
5870 count
= specpdl_ptr
- specpdl
;
5872 specbind (intern ("completion-ignore-case"), Qt
);
5875 specbind (intern ("minibuffer-completing-file-name"), Qt
);
5877 GCPRO2 (insdef
, default_filename
);
5879 #if defined (USE_MOTIF) || defined (HAVE_NTGUI)
5880 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
5884 /* If DIR contains a file name, split it. */
5886 file
= Ffile_name_nondirectory (dir
);
5887 if (XSTRING (file
)->size
&& NILP (default_filename
))
5889 default_filename
= file
;
5890 dir
= Ffile_name_directory (dir
);
5892 if (!NILP(default_filename
))
5893 default_filename
= Fexpand_file_name (default_filename
, dir
);
5894 val
= Fx_file_dialog (prompt
, dir
, default_filename
, mustmatch
);
5899 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5900 dir
, mustmatch
, insdef
,
5901 Qfile_name_history
, default_filename
, Qnil
);
5903 tem
= Fsymbol_value (Qfile_name_history
);
5904 if (CONSP (tem
) && EQ (XCAR (tem
), val
))
5905 replace_in_history
= 1;
5907 /* If Fcompleting_read returned the inserted default string itself
5908 (rather than a new string with the same contents),
5909 it has to mean that the user typed RET with the minibuffer empty.
5910 In that case, we really want to return ""
5911 so that commands such as set-visited-file-name can distinguish. */
5912 if (EQ (val
, default_filename
))
5914 /* In this case, Fcompleting_read has not added an element
5915 to the history. Maybe we should. */
5916 if (! replace_in_history
)
5919 val
= build_string ("");
5922 unbind_to (count
, Qnil
);
5925 error ("No file name specified");
5927 tem
= Fstring_equal (val
, CONSP (insdef
) ? XCAR (insdef
) : insdef
);
5929 if (!NILP (tem
) && !NILP (default_filename
))
5930 val
= default_filename
;
5931 else if (XSTRING (val
)->size
== 0 && NILP (insdef
))
5933 if (!NILP (default_filename
))
5934 val
= default_filename
;
5936 error ("No default file name");
5938 val
= Fsubstitute_in_file_name (val
);
5940 if (replace_in_history
)
5941 /* Replace what Fcompleting_read added to the history
5942 with what we will actually return. */
5943 XSETCAR (Fsymbol_value (Qfile_name_history
), double_dollars (val
));
5944 else if (add_to_history
)
5946 /* Add the value to the history--but not if it matches
5947 the last value already there. */
5948 Lisp_Object val1
= double_dollars (val
);
5949 tem
= Fsymbol_value (Qfile_name_history
);
5950 if (! CONSP (tem
) || NILP (Fequal (XCAR (tem
), val1
)))
5951 Fset (Qfile_name_history
,
5962 /* Must be set before any path manipulation is performed. */
5963 XSETFASTINT (Vdirectory_sep_char
, '/');
5970 Qexpand_file_name
= intern ("expand-file-name");
5971 Qsubstitute_in_file_name
= intern ("substitute-in-file-name");
5972 Qdirectory_file_name
= intern ("directory-file-name");
5973 Qfile_name_directory
= intern ("file-name-directory");
5974 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
5975 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
5976 Qfile_name_as_directory
= intern ("file-name-as-directory");
5977 Qcopy_file
= intern ("copy-file");
5978 Qmake_directory_internal
= intern ("make-directory-internal");
5979 Qmake_directory
= intern ("make-directory");
5980 Qdelete_directory
= intern ("delete-directory");
5981 Qdelete_file
= intern ("delete-file");
5982 Qrename_file
= intern ("rename-file");
5983 Qadd_name_to_file
= intern ("add-name-to-file");
5984 Qmake_symbolic_link
= intern ("make-symbolic-link");
5985 Qfile_exists_p
= intern ("file-exists-p");
5986 Qfile_executable_p
= intern ("file-executable-p");
5987 Qfile_readable_p
= intern ("file-readable-p");
5988 Qfile_writable_p
= intern ("file-writable-p");
5989 Qfile_symlink_p
= intern ("file-symlink-p");
5990 Qaccess_file
= intern ("access-file");
5991 Qfile_directory_p
= intern ("file-directory-p");
5992 Qfile_regular_p
= intern ("file-regular-p");
5993 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
5994 Qfile_modes
= intern ("file-modes");
5995 Qset_file_modes
= intern ("set-file-modes");
5996 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
5997 Qinsert_file_contents
= intern ("insert-file-contents");
5998 Qwrite_region
= intern ("write-region");
5999 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
6000 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
6002 staticpro (&Qexpand_file_name
);
6003 staticpro (&Qsubstitute_in_file_name
);
6004 staticpro (&Qdirectory_file_name
);
6005 staticpro (&Qfile_name_directory
);
6006 staticpro (&Qfile_name_nondirectory
);
6007 staticpro (&Qunhandled_file_name_directory
);
6008 staticpro (&Qfile_name_as_directory
);
6009 staticpro (&Qcopy_file
);
6010 staticpro (&Qmake_directory_internal
);
6011 staticpro (&Qmake_directory
);
6012 staticpro (&Qdelete_directory
);
6013 staticpro (&Qdelete_file
);
6014 staticpro (&Qrename_file
);
6015 staticpro (&Qadd_name_to_file
);
6016 staticpro (&Qmake_symbolic_link
);
6017 staticpro (&Qfile_exists_p
);
6018 staticpro (&Qfile_executable_p
);
6019 staticpro (&Qfile_readable_p
);
6020 staticpro (&Qfile_writable_p
);
6021 staticpro (&Qaccess_file
);
6022 staticpro (&Qfile_symlink_p
);
6023 staticpro (&Qfile_directory_p
);
6024 staticpro (&Qfile_regular_p
);
6025 staticpro (&Qfile_accessible_directory_p
);
6026 staticpro (&Qfile_modes
);
6027 staticpro (&Qset_file_modes
);
6028 staticpro (&Qfile_newer_than_file_p
);
6029 staticpro (&Qinsert_file_contents
);
6030 staticpro (&Qwrite_region
);
6031 staticpro (&Qverify_visited_file_modtime
);
6032 staticpro (&Qset_visited_file_modtime
);
6034 Qfile_name_history
= intern ("file-name-history");
6035 Fset (Qfile_name_history
, Qnil
);
6036 staticpro (&Qfile_name_history
);
6038 Qfile_error
= intern ("file-error");
6039 staticpro (&Qfile_error
);
6040 Qfile_already_exists
= intern ("file-already-exists");
6041 staticpro (&Qfile_already_exists
);
6042 Qfile_date_error
= intern ("file-date-error");
6043 staticpro (&Qfile_date_error
);
6044 Qexcl
= intern ("excl");
6048 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
6049 staticpro (&Qfind_buffer_file_type
);
6052 DEFVAR_LISP ("file-name-coding-system", &Vfile_name_coding_system
,
6053 doc
: /* *Coding system for encoding file names.
6054 If it is nil, default-file-name-coding-system (which see) is used. */);
6055 Vfile_name_coding_system
= Qnil
;
6057 DEFVAR_LISP ("default-file-name-coding-system",
6058 &Vdefault_file_name_coding_system
,
6059 doc
: /* Default coding system for encoding file names.
6060 This variable is used only when file-name-coding-system is nil.
6062 This variable is set/changed by the command set-language-environment.
6063 User should not set this variable manually,
6064 instead use file-name-coding-system to get a constant encoding
6065 of file names regardless of the current language environment. */);
6066 Vdefault_file_name_coding_system
= Qnil
;
6068 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format
,
6069 doc
: /* *Format in which to write auto-save files.
6070 Should be a list of symbols naming formats that are defined in `format-alist'.
6071 If it is t, which is the default, auto-save files are written in the
6072 same format as a regular save would use. */);
6073 Vauto_save_file_format
= Qt
;
6075 Qformat_decode
= intern ("format-decode");
6076 staticpro (&Qformat_decode
);
6077 Qformat_annotate_function
= intern ("format-annotate-function");
6078 staticpro (&Qformat_annotate_function
);
6080 Qcar_less_than_car
= intern ("car-less-than-car");
6081 staticpro (&Qcar_less_than_car
);
6083 Fput (Qfile_error
, Qerror_conditions
,
6084 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
6085 Fput (Qfile_error
, Qerror_message
,
6086 build_string ("File error"));
6088 Fput (Qfile_already_exists
, Qerror_conditions
,
6089 Fcons (Qfile_already_exists
,
6090 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
6091 Fput (Qfile_already_exists
, Qerror_message
,
6092 build_string ("File already exists"));
6094 Fput (Qfile_date_error
, Qerror_conditions
,
6095 Fcons (Qfile_date_error
,
6096 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
6097 Fput (Qfile_date_error
, Qerror_message
,
6098 build_string ("Cannot set file date"));
6100 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
6101 doc
: /* *Non-nil means when reading a filename start with default dir in minibuffer. */);
6102 insert_default_directory
= 1;
6104 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
6105 doc
: /* *Non-nil means write new files with record format `stmlf'.
6106 nil means use format `var'. This variable is meaningful only on VMS. */);
6107 vms_stmlf_recfm
= 0;
6109 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char
,
6110 doc
: /* Directory separator character for built-in functions that return file names.
6111 The value should be either ?/ or ?\\ (any other value is treated as ?\\).
6112 This variable affects the built-in functions only on Windows,
6113 on other platforms, it is initialized so that Lisp code can find out
6114 what the normal separator is.
6116 WARNING: This variable is deprecated and will be removed in the near
6117 future. DO NOT USE IT. */);
6119 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
6120 doc
: /* *Alist of elements (REGEXP . HANDLER) for file names handled specially.
6121 If a file name matches REGEXP, then all I/O on that file is done by calling
6124 The first argument given to HANDLER is the name of the I/O primitive
6125 to be handled; the remaining arguments are the arguments that were
6126 passed to that primitive. For example, if you do
6127 (file-exists-p FILENAME)
6128 and FILENAME is handled by HANDLER, then HANDLER is called like this:
6129 (funcall HANDLER 'file-exists-p FILENAME)
6130 The function `find-file-name-handler' checks this list for a handler
6131 for its argument. */);
6132 Vfile_name_handler_alist
= Qnil
;
6134 DEFVAR_LISP ("set-auto-coding-function",
6135 &Vset_auto_coding_function
,
6136 doc
: /* If non-nil, a function to call to decide a coding system of file.
6137 Two arguments are passed to this function: the file name
6138 and the length of a file contents following the point.
6139 This function should return a coding system to decode the file contents.
6140 It should check the file name against `auto-coding-alist'.
6141 If no coding system is decided, it should check a coding system
6142 specified in the heading lines with the format:
6143 -*- ... coding: CODING-SYSTEM; ... -*-
6144 or local variable spec of the tailing lines with `coding:' tag. */);
6145 Vset_auto_coding_function
= Qnil
;
6147 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
6148 doc
: /* A list of functions to be called at the end of `insert-file-contents'.
6149 Each is passed one argument, the number of bytes inserted. It should return
6150 the new byte count, and leave point the same. If `insert-file-contents' is
6151 intercepted by a handler from `file-name-handler-alist', that handler is
6152 responsible for calling the after-insert-file-functions if appropriate. */);
6153 Vafter_insert_file_functions
= Qnil
;
6155 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
6156 doc
: /* A list of functions to be called at the start of `write-region'.
6157 Each is passed two arguments, START and END as for `write-region'.
6158 These are usually two numbers but not always; see the documentation
6159 for `write-region'. The function should return a list of pairs
6160 of the form (POSITION . STRING), consisting of strings to be effectively
6161 inserted at the specified positions of the file being written (1 means to
6162 insert before the first byte written). The POSITIONs must be sorted into
6163 increasing order. If there are several functions in the list, the several
6164 lists are merged destructively. */);
6165 Vwrite_region_annotate_functions
= Qnil
;
6167 DEFVAR_LISP ("write-region-annotations-so-far",
6168 &Vwrite_region_annotations_so_far
,
6169 doc
: /* When an annotation function is called, this holds the previous annotations.
6170 These are the annotations made by other annotation functions
6171 that were already called. See also `write-region-annotate-functions'. */);
6172 Vwrite_region_annotations_so_far
= Qnil
;
6174 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
6175 doc
: /* A list of file name handlers that temporarily should not be used.
6176 This applies only to the operation `inhibit-file-name-operation'. */);
6177 Vinhibit_file_name_handlers
= Qnil
;
6179 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
6180 doc
: /* The operation for which `inhibit-file-name-handlers' is applicable. */);
6181 Vinhibit_file_name_operation
= Qnil
;
6183 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
6184 doc
: /* File name in which we write a list of all auto save file names.
6185 This variable is initialized automatically from `auto-save-list-file-prefix'
6186 shortly after Emacs reads your `.emacs' file, if you have not yet given it
6187 a non-nil value. */);
6188 Vauto_save_list_file_name
= Qnil
;
6190 defsubr (&Sfind_file_name_handler
);
6191 defsubr (&Sfile_name_directory
);
6192 defsubr (&Sfile_name_nondirectory
);
6193 defsubr (&Sunhandled_file_name_directory
);
6194 defsubr (&Sfile_name_as_directory
);
6195 defsubr (&Sdirectory_file_name
);
6196 defsubr (&Smake_temp_name
);
6197 defsubr (&Sexpand_file_name
);
6198 defsubr (&Ssubstitute_in_file_name
);
6199 defsubr (&Scopy_file
);
6200 defsubr (&Smake_directory_internal
);
6201 defsubr (&Sdelete_directory
);
6202 defsubr (&Sdelete_file
);
6203 defsubr (&Srename_file
);
6204 defsubr (&Sadd_name_to_file
);
6206 defsubr (&Smake_symbolic_link
);
6207 #endif /* S_IFLNK */
6209 defsubr (&Sdefine_logical_name
);
6212 defsubr (&Ssysnetunam
);
6213 #endif /* HPUX_NET */
6214 defsubr (&Sfile_name_absolute_p
);
6215 defsubr (&Sfile_exists_p
);
6216 defsubr (&Sfile_executable_p
);
6217 defsubr (&Sfile_readable_p
);
6218 defsubr (&Sfile_writable_p
);
6219 defsubr (&Saccess_file
);
6220 defsubr (&Sfile_symlink_p
);
6221 defsubr (&Sfile_directory_p
);
6222 defsubr (&Sfile_accessible_directory_p
);
6223 defsubr (&Sfile_regular_p
);
6224 defsubr (&Sfile_modes
);
6225 defsubr (&Sset_file_modes
);
6226 defsubr (&Sset_default_file_modes
);
6227 defsubr (&Sdefault_file_modes
);
6228 defsubr (&Sfile_newer_than_file_p
);
6229 defsubr (&Sinsert_file_contents
);
6230 defsubr (&Swrite_region
);
6231 defsubr (&Scar_less_than_car
);
6232 defsubr (&Sverify_visited_file_modtime
);
6233 defsubr (&Sclear_visited_file_modtime
);
6234 defsubr (&Svisited_file_modtime
);
6235 defsubr (&Sset_visited_file_modtime
);
6236 defsubr (&Sdo_auto_save
);
6237 defsubr (&Sset_buffer_auto_saved
);
6238 defsubr (&Sclear_buffer_auto_save_failure
);
6239 defsubr (&Srecent_auto_save_p
);
6241 defsubr (&Sread_file_name_internal
);
6242 defsubr (&Sread_file_name
);
6245 defsubr (&Sunix_sync
);