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;
3521 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3522 error ("Cannot do file visiting in an indirect buffer");
3524 if (!NILP (current_buffer
->read_only
))
3525 Fbarf_if_buffer_read_only ();
3529 orig_filename
= Qnil
;
3531 GCPRO4 (filename
, val
, p
, orig_filename
);
3533 CHECK_STRING (filename
, 0);
3534 filename
= Fexpand_file_name (filename
, Qnil
);
3536 /* If the file name has special constructs in it,
3537 call the corresponding file handler. */
3538 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
3539 if (!NILP (handler
))
3541 val
= call6 (handler
, Qinsert_file_contents
, filename
,
3542 visit
, beg
, end
, replace
);
3543 if (CONSP (val
) && CONSP (XCDR (val
)))
3544 inserted
= XINT (XCAR (XCDR (val
)));
3548 orig_filename
= filename
;
3549 filename
= ENCODE_FILE (filename
);
3555 Lisp_Object tem
= Vw32_get_true_file_attributes
;
3557 /* Tell stat to use expensive method to get accurate info. */
3558 Vw32_get_true_file_attributes
= Qt
;
3559 total
= stat (XSTRING (filename
)->data
, &st
);
3560 Vw32_get_true_file_attributes
= tem
;
3565 if (stat (XSTRING (filename
)->data
, &st
) < 0)
3567 if ((fd
= emacs_open (XSTRING (filename
)->data
, O_RDONLY
, 0)) < 0
3568 || fstat (fd
, &st
) < 0)
3569 #endif /* not APOLLO */
3570 #endif /* WINDOWSNT */
3572 if (fd
>= 0) emacs_close (fd
);
3575 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3578 if (!NILP (Vcoding_system_for_read
))
3579 Fset (Qbuffer_file_coding_system
, Vcoding_system_for_read
);
3584 /* This code will need to be changed in order to work on named
3585 pipes, and it's probably just not worth it. So we should at
3586 least signal an error. */
3587 if (!S_ISREG (st
.st_mode
))
3594 if (! NILP (replace
) || ! NILP (beg
) || ! NILP (end
))
3595 Fsignal (Qfile_error
,
3596 Fcons (build_string ("not a regular file"),
3597 Fcons (orig_filename
, Qnil
)));
3602 if ((fd
= emacs_open (XSTRING (filename
)->data
, O_RDONLY
, 0)) < 0)
3605 /* Replacement should preserve point as it preserves markers. */
3606 if (!NILP (replace
))
3607 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
3609 record_unwind_protect (close_file_unwind
, make_number (fd
));
3611 /* Supposedly happens on VMS. */
3612 if (! not_regular
&& st
.st_size
< 0)
3613 error ("File size is negative");
3615 /* Prevent redisplay optimizations. */
3616 current_buffer
->clip_changed
= 1;
3620 if (!NILP (beg
) || !NILP (end
))
3621 error ("Attempt to visit less than an entire file");
3622 if (BEG
< Z
&& NILP (replace
))
3623 error ("Cannot do file visiting in a non-empty buffer");
3627 CHECK_NUMBER (beg
, 0);
3629 XSETFASTINT (beg
, 0);
3632 CHECK_NUMBER (end
, 0);
3637 XSETINT (end
, st
.st_size
);
3639 /* Arithmetic overflow can occur if an Emacs integer cannot
3640 represent the file size, or if the calculations below
3641 overflow. The calculations below double the file size
3642 twice, so check that it can be multiplied by 4 safely. */
3643 if (XINT (end
) != st
.st_size
3644 || ((int) st
.st_size
* 4) / 4 != st
.st_size
)
3645 error ("Maximum buffer size exceeded");
3647 /* The file size returned from stat may be zero, but data
3648 may be readable nonetheless, for example when this is a
3649 file in the /proc filesystem. */
3650 if (st
.st_size
== 0)
3651 XSETINT (end
, READ_BUF_SIZE
);
3657 /* Decide the coding system to use for reading the file now
3658 because we can't use an optimized method for handling
3659 `coding:' tag if the current buffer is not empty. */
3663 if (!NILP (Vcoding_system_for_read
))
3664 val
= Vcoding_system_for_read
;
3665 else if (! NILP (replace
))
3666 /* In REPLACE mode, we can use the same coding system
3667 that was used to visit the file. */
3668 val
= current_buffer
->buffer_file_coding_system
;
3671 /* Don't try looking inside a file for a coding system
3672 specification if it is not seekable. */
3673 if (! not_regular
&& ! NILP (Vset_auto_coding_function
))
3675 /* Find a coding system specified in the heading two
3676 lines or in the tailing several lines of the file.
3677 We assume that the 1K-byte and 3K-byte for heading
3678 and tailing respectively are sufficient for this
3682 if (st
.st_size
<= (1024 * 4))
3683 nread
= emacs_read (fd
, read_buf
, 1024 * 4);
3686 nread
= emacs_read (fd
, read_buf
, 1024);
3689 if (lseek (fd
, st
.st_size
- (1024 * 3), 0) < 0)
3690 report_file_error ("Setting file position",
3691 Fcons (orig_filename
, Qnil
));
3692 nread
+= emacs_read (fd
, read_buf
+ nread
, 1024 * 3);
3697 error ("IO error reading %s: %s",
3698 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3701 struct buffer
*prev
= current_buffer
;
3704 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
3706 /* The call to temp_output_buffer_setup binds
3708 count1
= specpdl_ptr
- specpdl
;
3709 temp_output_buffer_setup (" *code-converting-work*");
3711 set_buffer_internal (XBUFFER (Vstandard_output
));
3712 current_buffer
->enable_multibyte_characters
= Qnil
;
3713 insert_1_both (read_buf
, nread
, nread
, 0, 0, 0);
3714 TEMP_SET_PT_BOTH (BEG
, BEG_BYTE
);
3715 val
= call2 (Vset_auto_coding_function
,
3716 filename
, make_number (nread
));
3717 set_buffer_internal (prev
);
3719 /* Remove the binding for standard-output. */
3720 unbind_to (count1
, Qnil
);
3722 /* Discard the unwind protect for recovering the
3726 /* Rewind the file for the actual read done later. */
3727 if (lseek (fd
, 0, 0) < 0)
3728 report_file_error ("Setting file position",
3729 Fcons (orig_filename
, Qnil
));
3735 /* If we have not yet decided a coding system, check
3736 file-coding-system-alist. */
3737 Lisp_Object args
[6], coding_systems
;
3739 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
;
3740 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = replace
;
3741 coding_systems
= Ffind_operation_coding_system (6, args
);
3742 if (CONSP (coding_systems
))
3743 val
= XCAR (coding_systems
);
3747 setup_coding_system (Fcheck_coding_system (val
), &coding
);
3748 /* Ensure we set Vlast_coding_system_used. */
3749 set_coding_system
= 1;
3751 if (NILP (current_buffer
->enable_multibyte_characters
)
3753 /* We must suppress all character code conversion except for
3754 end-of-line conversion. */
3755 setup_raw_text_coding_system (&coding
);
3757 coding
.src_multibyte
= 0;
3758 coding
.dst_multibyte
3759 = !NILP (current_buffer
->enable_multibyte_characters
);
3760 coding_system_decided
= 1;
3763 /* If requested, replace the accessible part of the buffer
3764 with the file contents. Avoid replacing text at the
3765 beginning or end of the buffer that matches the file contents;
3766 that preserves markers pointing to the unchanged parts.
3768 Here we implement this feature in an optimized way
3769 for the case where code conversion is NOT needed.
3770 The following if-statement handles the case of conversion
3771 in a less optimal way.
3773 If the code conversion is "automatic" then we try using this
3774 method and hope for the best.
3775 But if we discover the need for conversion, we give up on this method
3776 and let the following if-statement handle the replace job. */
3779 && !(coding
.common_flags
& CODING_REQUIRE_DECODING_MASK
))
3781 /* same_at_start and same_at_end count bytes,
3782 because file access counts bytes
3783 and BEG and END count bytes. */
3784 int same_at_start
= BEGV_BYTE
;
3785 int same_at_end
= ZV_BYTE
;
3787 /* There is still a possibility we will find the need to do code
3788 conversion. If that happens, we set this variable to 1 to
3789 give up on handling REPLACE in the optimized way. */
3790 int giveup_match_end
= 0;
3792 if (XINT (beg
) != 0)
3794 if (lseek (fd
, XINT (beg
), 0) < 0)
3795 report_file_error ("Setting file position",
3796 Fcons (orig_filename
, Qnil
));
3801 /* Count how many chars at the start of the file
3802 match the text at the beginning of the buffer. */
3807 nread
= emacs_read (fd
, buffer
, sizeof buffer
);
3809 error ("IO error reading %s: %s",
3810 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3811 else if (nread
== 0)
3814 if (coding
.type
== coding_type_undecided
)
3815 detect_coding (&coding
, buffer
, nread
);
3816 if (coding
.common_flags
& CODING_REQUIRE_DECODING_MASK
)
3817 /* We found that the file should be decoded somehow.
3818 Let's give up here. */
3820 giveup_match_end
= 1;
3824 if (coding
.eol_type
== CODING_EOL_UNDECIDED
)
3825 detect_eol (&coding
, buffer
, nread
);
3826 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3827 && coding
.eol_type
!= CODING_EOL_LF
)
3828 /* We found that the format of eol should be decoded.
3829 Let's give up here. */
3831 giveup_match_end
= 1;
3836 while (bufpos
< nread
&& same_at_start
< ZV_BYTE
3837 && FETCH_BYTE (same_at_start
) == buffer
[bufpos
])
3838 same_at_start
++, bufpos
++;
3839 /* If we found a discrepancy, stop the scan.
3840 Otherwise loop around and scan the next bufferful. */
3841 if (bufpos
!= nread
)
3845 /* If the file matches the buffer completely,
3846 there's no need to replace anything. */
3847 if (same_at_start
- BEGV_BYTE
== XINT (end
))
3851 /* Truncate the buffer to the size of the file. */
3852 del_range_1 (same_at_start
, same_at_end
, 0, 0);
3857 /* Count how many chars at the end of the file
3858 match the text at the end of the buffer. But, if we have
3859 already found that decoding is necessary, don't waste time. */
3860 while (!giveup_match_end
)
3862 int total_read
, nread
, bufpos
, curpos
, trial
;
3864 /* At what file position are we now scanning? */
3865 curpos
= XINT (end
) - (ZV_BYTE
- same_at_end
);
3866 /* If the entire file matches the buffer tail, stop the scan. */
3869 /* How much can we scan in the next step? */
3870 trial
= min (curpos
, sizeof buffer
);
3871 if (lseek (fd
, curpos
- trial
, 0) < 0)
3872 report_file_error ("Setting file position",
3873 Fcons (orig_filename
, Qnil
));
3875 total_read
= nread
= 0;
3876 while (total_read
< trial
)
3878 nread
= emacs_read (fd
, buffer
+ total_read
, trial
- total_read
);
3880 error ("IO error reading %s: %s",
3881 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3882 else if (nread
== 0)
3884 total_read
+= nread
;
3887 /* Scan this bufferful from the end, comparing with
3888 the Emacs buffer. */
3889 bufpos
= total_read
;
3891 /* Compare with same_at_start to avoid counting some buffer text
3892 as matching both at the file's beginning and at the end. */
3893 while (bufpos
> 0 && same_at_end
> same_at_start
3894 && FETCH_BYTE (same_at_end
- 1) == buffer
[bufpos
- 1])
3895 same_at_end
--, bufpos
--;
3897 /* If we found a discrepancy, stop the scan.
3898 Otherwise loop around and scan the preceding bufferful. */
3901 /* If this discrepancy is because of code conversion,
3902 we cannot use this method; giveup and try the other. */
3903 if (same_at_end
> same_at_start
3904 && FETCH_BYTE (same_at_end
- 1) >= 0200
3905 && ! NILP (current_buffer
->enable_multibyte_characters
)
3906 && (CODING_MAY_REQUIRE_DECODING (&coding
)))
3907 giveup_match_end
= 1;
3916 if (! giveup_match_end
)
3920 /* We win! We can handle REPLACE the optimized way. */
3922 /* Extend the start of non-matching text area to multibyte
3923 character boundary. */
3924 if (! NILP (current_buffer
->enable_multibyte_characters
))
3925 while (same_at_start
> BEGV_BYTE
3926 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start
)))
3929 /* Extend the end of non-matching text area to multibyte
3930 character boundary. */
3931 if (! NILP (current_buffer
->enable_multibyte_characters
))
3932 while (same_at_end
< ZV_BYTE
3933 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
3936 /* Don't try to reuse the same piece of text twice. */
3937 overlap
= (same_at_start
- BEGV_BYTE
3938 - (same_at_end
+ st
.st_size
- ZV
));
3940 same_at_end
+= overlap
;
3942 /* Arrange to read only the nonmatching middle part of the file. */
3943 XSETFASTINT (beg
, XINT (beg
) + (same_at_start
- BEGV_BYTE
));
3944 XSETFASTINT (end
, XINT (end
) - (ZV_BYTE
- same_at_end
));
3946 del_range_byte (same_at_start
, same_at_end
, 0);
3947 /* Insert from the file at the proper position. */
3948 temp
= BYTE_TO_CHAR (same_at_start
);
3949 SET_PT_BOTH (temp
, same_at_start
);
3951 /* If display currently starts at beginning of line,
3952 keep it that way. */
3953 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3954 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3956 replace_handled
= 1;
3960 /* If requested, replace the accessible part of the buffer
3961 with the file contents. Avoid replacing text at the
3962 beginning or end of the buffer that matches the file contents;
3963 that preserves markers pointing to the unchanged parts.
3965 Here we implement this feature for the case where code conversion
3966 is needed, in a simple way that needs a lot of memory.
3967 The preceding if-statement handles the case of no conversion
3968 in a more optimized way. */
3969 if (!NILP (replace
) && ! replace_handled
&& BEGV
< ZV
)
3971 int same_at_start
= BEGV_BYTE
;
3972 int same_at_end
= ZV_BYTE
;
3975 /* Make sure that the gap is large enough. */
3976 int bufsize
= 2 * st
.st_size
;
3977 unsigned char *conversion_buffer
= (unsigned char *) xmalloc (bufsize
);
3980 /* First read the whole file, performing code conversion into
3981 CONVERSION_BUFFER. */
3983 if (lseek (fd
, XINT (beg
), 0) < 0)
3985 xfree (conversion_buffer
);
3986 report_file_error ("Setting file position",
3987 Fcons (orig_filename
, Qnil
));
3990 total
= st
.st_size
; /* Total bytes in the file. */
3991 how_much
= 0; /* Bytes read from file so far. */
3992 inserted
= 0; /* Bytes put into CONVERSION_BUFFER so far. */
3993 unprocessed
= 0; /* Bytes not processed in previous loop. */
3995 while (how_much
< total
)
3997 /* try is reserved in some compilers (Microsoft C) */
3998 int trytry
= min (total
- how_much
, READ_BUF_SIZE
- unprocessed
);
3999 unsigned char *destination
= read_buf
+ unprocessed
;
4002 /* Allow quitting out of the actual I/O. */
4005 this = emacs_read (fd
, destination
, trytry
);
4008 if (this < 0 || this + unprocessed
== 0)
4016 if (CODING_MAY_REQUIRE_DECODING (&coding
))
4018 int require
, result
;
4020 this += unprocessed
;
4022 /* If we are using more space than estimated,
4023 make CONVERSION_BUFFER bigger. */
4024 require
= decoding_buffer_size (&coding
, this);
4025 if (inserted
+ require
+ 2 * (total
- how_much
) > bufsize
)
4027 bufsize
= inserted
+ require
+ 2 * (total
- how_much
);
4028 conversion_buffer
= (unsigned char *) xrealloc (conversion_buffer
, bufsize
);
4031 /* Convert this batch with results in CONVERSION_BUFFER. */
4032 if (how_much
>= total
) /* This is the last block. */
4033 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4034 if (coding
.composing
!= COMPOSITION_DISABLED
)
4035 coding_allocate_composition_data (&coding
, BEGV
);
4036 result
= decode_coding (&coding
, read_buf
,
4037 conversion_buffer
+ inserted
,
4038 this, bufsize
- inserted
);
4040 /* Save for next iteration whatever we didn't convert. */
4041 unprocessed
= this - coding
.consumed
;
4042 bcopy (read_buf
+ coding
.consumed
, read_buf
, unprocessed
);
4043 if (!NILP (current_buffer
->enable_multibyte_characters
))
4044 this = coding
.produced
;
4046 this = str_as_unibyte (conversion_buffer
+ inserted
,
4053 /* At this point, INSERTED is how many characters (i.e. bytes)
4054 are present in CONVERSION_BUFFER.
4055 HOW_MUCH should equal TOTAL,
4056 or should be <= 0 if we couldn't read the file. */
4060 xfree (conversion_buffer
);
4063 error ("IO error reading %s: %s",
4064 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
4065 else if (how_much
== -2)
4066 error ("maximum buffer size exceeded");
4069 /* Compare the beginning of the converted file
4070 with the buffer text. */
4073 while (bufpos
< inserted
&& same_at_start
< same_at_end
4074 && FETCH_BYTE (same_at_start
) == conversion_buffer
[bufpos
])
4075 same_at_start
++, bufpos
++;
4077 /* If the file matches the buffer completely,
4078 there's no need to replace anything. */
4080 if (bufpos
== inserted
)
4082 xfree (conversion_buffer
);
4085 /* Truncate the buffer to the size of the file. */
4086 del_range_byte (same_at_start
, same_at_end
, 0);
4091 /* Extend the start of non-matching text area to multibyte
4092 character boundary. */
4093 if (! NILP (current_buffer
->enable_multibyte_characters
))
4094 while (same_at_start
> BEGV_BYTE
4095 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start
)))
4098 /* Scan this bufferful from the end, comparing with
4099 the Emacs buffer. */
4102 /* Compare with same_at_start to avoid counting some buffer text
4103 as matching both at the file's beginning and at the end. */
4104 while (bufpos
> 0 && same_at_end
> same_at_start
4105 && FETCH_BYTE (same_at_end
- 1) == conversion_buffer
[bufpos
- 1])
4106 same_at_end
--, bufpos
--;
4108 /* Extend the end of non-matching text area to multibyte
4109 character boundary. */
4110 if (! NILP (current_buffer
->enable_multibyte_characters
))
4111 while (same_at_end
< ZV_BYTE
4112 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
4115 /* Don't try to reuse the same piece of text twice. */
4116 overlap
= same_at_start
- BEGV_BYTE
- (same_at_end
+ inserted
- ZV_BYTE
);
4118 same_at_end
+= overlap
;
4120 /* If display currently starts at beginning of line,
4121 keep it that way. */
4122 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
4123 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
4125 /* Replace the chars that we need to replace,
4126 and update INSERTED to equal the number of bytes
4127 we are taking from the file. */
4128 inserted
-= (Z_BYTE
- same_at_end
) + (same_at_start
- BEG_BYTE
);
4130 if (same_at_end
!= same_at_start
)
4132 del_range_byte (same_at_start
, same_at_end
, 0);
4134 same_at_start
= GPT_BYTE
;
4138 temp
= BYTE_TO_CHAR (same_at_start
);
4140 /* Insert from the file at the proper position. */
4141 SET_PT_BOTH (temp
, same_at_start
);
4142 insert_1 (conversion_buffer
+ same_at_start
- BEG_BYTE
, inserted
,
4144 if (coding
.cmp_data
&& coding
.cmp_data
->used
)
4145 coding_restore_composition (&coding
, Fcurrent_buffer ());
4146 coding_free_composition_data (&coding
);
4148 /* Set `inserted' to the number of inserted characters. */
4149 inserted
= PT
- temp
;
4151 xfree (conversion_buffer
);
4160 register Lisp_Object temp
;
4162 total
= XINT (end
) - XINT (beg
);
4164 /* Make sure point-max won't overflow after this insertion. */
4165 XSETINT (temp
, total
);
4166 if (total
!= XINT (temp
))
4167 error ("Maximum buffer size exceeded");
4170 /* For a special file, all we can do is guess. */
4171 total
= READ_BUF_SIZE
;
4173 if (NILP (visit
) && total
> 0)
4174 prepare_to_modify_buffer (PT
, PT
, NULL
);
4177 if (GAP_SIZE
< total
)
4178 make_gap (total
- GAP_SIZE
);
4180 if (XINT (beg
) != 0 || !NILP (replace
))
4182 if (lseek (fd
, XINT (beg
), 0) < 0)
4183 report_file_error ("Setting file position",
4184 Fcons (orig_filename
, Qnil
));
4187 /* In the following loop, HOW_MUCH contains the total bytes read so
4188 far for a regular file, and not changed for a special file. But,
4189 before exiting the loop, it is set to a negative value if I/O
4193 /* Total bytes inserted. */
4196 /* Here, we don't do code conversion in the loop. It is done by
4197 code_convert_region after all data are read into the buffer. */
4199 int gap_size
= GAP_SIZE
;
4201 while (how_much
< total
)
4203 /* try is reserved in some compilers (Microsoft C) */
4204 int trytry
= min (total
- how_much
, READ_BUF_SIZE
);
4211 /* Maybe make more room. */
4212 if (gap_size
< trytry
)
4214 make_gap (total
- gap_size
);
4215 gap_size
= GAP_SIZE
;
4218 /* Read from the file, capturing `quit'. When an
4219 error occurs, end the loop, and arrange for a quit
4220 to be signaled after decoding the text we read. */
4221 non_regular_fd
= fd
;
4222 non_regular_inserted
= inserted
;
4223 non_regular_nbytes
= trytry
;
4224 val
= internal_condition_case_1 (read_non_regular
, Qnil
, Qerror
,
4225 read_non_regular_quit
);
4236 /* Allow quitting out of the actual I/O. We don't make text
4237 part of the buffer until all the reading is done, so a C-g
4238 here doesn't do any harm. */
4241 this = emacs_read (fd
, BEG_ADDR
+ PT_BYTE
- 1 + inserted
, trytry
);
4253 /* For a regular file, where TOTAL is the real size,
4254 count HOW_MUCH to compare with it.
4255 For a special file, where TOTAL is just a buffer size,
4256 so don't bother counting in HOW_MUCH.
4257 (INSERTED is where we count the number of characters inserted.) */
4264 /* Make the text read part of the buffer. */
4265 GAP_SIZE
-= inserted
;
4267 GPT_BYTE
+= inserted
;
4269 ZV_BYTE
+= inserted
;
4274 /* Put an anchor to ensure multi-byte form ends at gap. */
4279 /* Discard the unwind protect for closing the file. */
4283 error ("IO error reading %s: %s",
4284 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
4288 if (! coding_system_decided
)
4290 /* The coding system is not yet decided. Decide it by an
4291 optimized method for handling `coding:' tag.
4293 Note that we can get here only if the buffer was empty
4294 before the insertion. */
4298 if (!NILP (Vcoding_system_for_read
))
4299 val
= Vcoding_system_for_read
;
4302 /* Since we are sure that the current buffer was empty
4303 before the insertion, we can toggle
4304 enable-multibyte-characters directly here without taking
4305 care of marker adjustment and byte combining problem. By
4306 this way, we can run Lisp program safely before decoding
4307 the inserted text. */
4308 Lisp_Object unwind_data
;
4309 int count
= specpdl_ptr
- specpdl
;
4311 unwind_data
= Fcons (current_buffer
->enable_multibyte_characters
,
4312 Fcons (current_buffer
->undo_list
,
4313 Fcurrent_buffer ()));
4314 current_buffer
->enable_multibyte_characters
= Qnil
;
4315 current_buffer
->undo_list
= Qt
;
4316 record_unwind_protect (decide_coding_unwind
, unwind_data
);
4318 if (inserted
> 0 && ! NILP (Vset_auto_coding_function
))
4320 val
= call2 (Vset_auto_coding_function
,
4321 filename
, make_number (inserted
));
4326 /* If the coding system is not yet decided, check
4327 file-coding-system-alist. */
4328 Lisp_Object args
[6], coding_systems
;
4330 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
;
4331 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = Qnil
;
4332 coding_systems
= Ffind_operation_coding_system (6, args
);
4333 if (CONSP (coding_systems
))
4334 val
= XCAR (coding_systems
);
4337 unbind_to (count
, Qnil
);
4338 inserted
= Z_BYTE
- BEG_BYTE
;
4341 /* The following kludgy code is to avoid some compiler bug.
4343 setup_coding_system (val, &coding);
4346 struct coding_system temp_coding
;
4347 setup_coding_system (val
, &temp_coding
);
4348 bcopy (&temp_coding
, &coding
, sizeof coding
);
4350 /* Ensure we set Vlast_coding_system_used. */
4351 set_coding_system
= 1;
4353 if (NILP (current_buffer
->enable_multibyte_characters
)
4355 /* We must suppress all character code conversion except for
4356 end-of-line conversion. */
4357 setup_raw_text_coding_system (&coding
);
4358 coding
.src_multibyte
= 0;
4359 coding
.dst_multibyte
4360 = !NILP (current_buffer
->enable_multibyte_characters
);
4364 /* Can't do this if part of the buffer might be preserved. */
4366 && (coding
.type
== coding_type_no_conversion
4367 || coding
.type
== coding_type_raw_text
))
4369 /* Visiting a file with these coding system makes the buffer
4371 current_buffer
->enable_multibyte_characters
= Qnil
;
4372 coding
.dst_multibyte
= 0;
4375 if (inserted
> 0 || coding
.type
== coding_type_ccl
)
4377 if (CODING_MAY_REQUIRE_DECODING (&coding
))
4379 code_convert_region (PT
, PT_BYTE
, PT
+ inserted
, PT_BYTE
+ inserted
,
4381 inserted
= coding
.produced_char
;
4384 adjust_after_insert (PT
, PT_BYTE
, PT
+ inserted
, PT_BYTE
+ inserted
,
4389 /* Use the conversion type to determine buffer-file-type
4390 (find-buffer-file-type is now used to help determine the
4392 if ((coding
.eol_type
== CODING_EOL_UNDECIDED
4393 || coding
.eol_type
== CODING_EOL_LF
)
4394 && ! CODING_REQUIRE_DECODING (&coding
))
4395 current_buffer
->buffer_file_type
= Qt
;
4397 current_buffer
->buffer_file_type
= Qnil
;
4404 if (!EQ (current_buffer
->undo_list
, Qt
))
4405 current_buffer
->undo_list
= Qnil
;
4407 stat (XSTRING (filename
)->data
, &st
);
4412 current_buffer
->modtime
= st
.st_mtime
;
4413 current_buffer
->filename
= orig_filename
;
4416 SAVE_MODIFF
= MODIFF
;
4417 current_buffer
->auto_save_modified
= MODIFF
;
4418 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4419 #ifdef CLASH_DETECTION
4422 if (!NILP (current_buffer
->file_truename
))
4423 unlock_file (current_buffer
->file_truename
);
4424 unlock_file (filename
);
4426 #endif /* CLASH_DETECTION */
4428 Fsignal (Qfile_error
,
4429 Fcons (build_string ("not a regular file"),
4430 Fcons (orig_filename
, Qnil
)));
4433 /* Decode file format */
4436 int empty_undo_list_p
= 0;
4438 /* If we're anyway going to discard undo information, don't
4439 record it in the first place. The buffer's undo list at this
4440 point is either nil or t when visiting a file. */
4443 empty_undo_list_p
= NILP (current_buffer
->undo_list
);
4444 current_buffer
->undo_list
= Qt
;
4447 insval
= call3 (Qformat_decode
,
4448 Qnil
, make_number (inserted
), visit
);
4449 CHECK_NUMBER (insval
, 0);
4450 inserted
= XFASTINT (insval
);
4453 current_buffer
->undo_list
= empty_undo_list_p
? Qnil
: Qt
;
4456 if (set_coding_system
)
4457 Vlast_coding_system_used
= coding
.symbol
;
4459 /* Call after-change hooks for the inserted text, aside from the case
4460 of normal visiting (not with REPLACE), which is done in a new buffer
4461 "before" the buffer is changed. */
4462 if (inserted
> 0 && total
> 0
4463 && (NILP (visit
) || !NILP (replace
)))
4465 signal_after_change (PT
, 0, inserted
);
4466 update_compositions (PT
, PT
, CHECK_BORDER
);
4469 p
= Vafter_insert_file_functions
;
4472 insval
= call1 (Fcar (p
), make_number (inserted
));
4475 CHECK_NUMBER (insval
, 0);
4476 inserted
= XFASTINT (insval
);
4483 && current_buffer
->modtime
== -1)
4485 /* If visiting nonexistent file, return nil. */
4486 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
4490 Fsignal (Qquit
, Qnil
);
4492 /* ??? Retval needs to be dealt with in all cases consistently. */
4494 val
= Fcons (orig_filename
,
4495 Fcons (make_number (inserted
),
4498 RETURN_UNGCPRO (unbind_to (count
, val
));
4501 static Lisp_Object build_annotations
P_ ((Lisp_Object
, Lisp_Object
,
4504 /* If build_annotations switched buffers, switch back to BUF.
4505 Kill the temporary buffer that was selected in the meantime.
4507 Since this kill only the last temporary buffer, some buffers remain
4508 not killed if build_annotations switched buffers more than once.
4512 build_annotations_unwind (buf
)
4517 if (XBUFFER (buf
) == current_buffer
)
4519 tembuf
= Fcurrent_buffer ();
4521 Fkill_buffer (tembuf
);
4525 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 7,
4526 "r\nFWrite region to file: \ni\ni\ni\np",
4527 doc
: /* Write current region into specified file.
4528 When called from a program, takes three arguments:
4529 START, END and FILENAME. START and END are buffer positions.
4530 Optional fourth argument APPEND if non-nil means
4531 append to existing file contents (if any). If it is an integer,
4532 seek to that offset in the file before writing.
4533 Optional fifth argument VISIT if t means
4534 set the last-save-file-modtime of buffer to this file's modtime
4535 and mark buffer not modified.
4536 If VISIT is a string, it is a second file name;
4537 the output goes to FILENAME, but the buffer is marked as visiting VISIT.
4538 VISIT is also the file name to lock and unlock for clash detection.
4539 If VISIT is neither t nor nil nor a string,
4540 that means do not print the \"Wrote file\" message.
4541 The optional sixth arg LOCKNAME, if non-nil, specifies the name to
4542 use for locking and unlocking, overriding FILENAME and VISIT.
4543 The optional seventh arg MUSTBENEW, if non-nil, insists on a check
4544 for an existing file with the same name. If MUSTBENEW is `excl',
4545 that means to get an error if the file already exists; never overwrite.
4546 If MUSTBENEW is neither nil nor `excl', that means ask for
4547 confirmation before overwriting, but do go ahead and overwrite the file
4548 if the user confirms.
4549 Kludgy feature: if START is a string, then that string is written
4550 to the file, instead of any buffer contents, and END is ignored.
4552 This does code conversion according to the value of
4553 `coding-system-for-write', `buffer-file-coding-system', or
4554 `file-coding-system-alist', and sets the variable
4555 `last-coding-system-used' to the coding system actually used. */)
4556 (start
, end
, filename
, append
, visit
, lockname
, mustbenew
)
4557 Lisp_Object start
, end
, filename
, append
, visit
, lockname
, mustbenew
;
4565 int count
= specpdl_ptr
- specpdl
;
4568 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
4570 Lisp_Object handler
;
4571 Lisp_Object visit_file
;
4572 Lisp_Object annotations
;
4573 Lisp_Object encoded_filename
;
4574 int visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
4575 int quietly
= !NILP (visit
);
4576 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
4577 struct buffer
*given_buffer
;
4579 int buffer_file_type
= O_BINARY
;
4581 struct coding_system coding
;
4583 if (current_buffer
->base_buffer
&& visiting
)
4584 error ("Cannot do file visiting in an indirect buffer");
4586 if (!NILP (start
) && !STRINGP (start
))
4587 validate_region (&start
, &end
);
4589 GCPRO4 (start
, filename
, visit
, lockname
);
4591 /* Decide the coding-system to encode the data with. */
4597 else if (!NILP (Vcoding_system_for_write
))
4598 val
= Vcoding_system_for_write
;
4601 /* If the variable `buffer-file-coding-system' is set locally,
4602 it means that the file was read with some kind of code
4603 conversion or the variable is explicitly set by users. We
4604 had better write it out with the same coding system even if
4605 `enable-multibyte-characters' is nil.
4607 If it is not set locally, we anyway have to convert EOL
4608 format if the default value of `buffer-file-coding-system'
4609 tells that it is not Unix-like (LF only) format. */
4610 int using_default_coding
= 0;
4611 int force_raw_text
= 0;
4613 val
= current_buffer
->buffer_file_coding_system
;
4615 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4618 if (NILP (current_buffer
->enable_multibyte_characters
))
4624 /* Check file-coding-system-alist. */
4625 Lisp_Object args
[7], coding_systems
;
4627 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4628 args
[3] = filename
; args
[4] = append
; args
[5] = visit
;
4630 coding_systems
= Ffind_operation_coding_system (7, args
);
4631 if (CONSP (coding_systems
) && !NILP (XCDR (coding_systems
)))
4632 val
= XCDR (coding_systems
);
4636 && !NILP (current_buffer
->buffer_file_coding_system
))
4638 /* If we still have not decided a coding system, use the
4639 default value of buffer-file-coding-system. */
4640 val
= current_buffer
->buffer_file_coding_system
;
4641 using_default_coding
= 1;
4645 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4646 /* Confirm that VAL can surely encode the current region. */
4647 val
= call3 (Vselect_safe_coding_system_function
, start
, end
, val
);
4649 setup_coding_system (Fcheck_coding_system (val
), &coding
);
4650 if (coding
.eol_type
== CODING_EOL_UNDECIDED
4651 && !using_default_coding
)
4653 if (! EQ (default_buffer_file_coding
.symbol
,
4654 buffer_defaults
.buffer_file_coding_system
))
4655 setup_coding_system (buffer_defaults
.buffer_file_coding_system
,
4656 &default_buffer_file_coding
);
4657 if (default_buffer_file_coding
.eol_type
!= CODING_EOL_UNDECIDED
)
4659 Lisp_Object subsidiaries
;
4661 coding
.eol_type
= default_buffer_file_coding
.eol_type
;
4662 subsidiaries
= Fget (coding
.symbol
, Qeol_type
);
4663 if (VECTORP (subsidiaries
)
4664 && XVECTOR (subsidiaries
)->size
== 3)
4666 = XVECTOR (subsidiaries
)->contents
[coding
.eol_type
];
4671 setup_raw_text_coding_system (&coding
);
4672 goto done_setup_coding
;
4675 setup_coding_system (Fcheck_coding_system (val
), &coding
);
4678 if (!STRINGP (start
) && !NILP (current_buffer
->selective_display
))
4679 coding
.mode
|= CODING_MODE_SELECTIVE_DISPLAY
;
4682 Vlast_coding_system_used
= coding
.symbol
;
4684 filename
= Fexpand_file_name (filename
, Qnil
);
4686 if (! NILP (mustbenew
) && !EQ (mustbenew
, Qexcl
))
4687 barf_or_query_if_file_exists (filename
, "overwrite", 1, 0, 1);
4689 if (STRINGP (visit
))
4690 visit_file
= Fexpand_file_name (visit
, Qnil
);
4692 visit_file
= filename
;
4697 if (NILP (lockname
))
4698 lockname
= visit_file
;
4700 GCPRO5 (start
, filename
, annotations
, visit_file
, lockname
);
4702 /* If the file name has special constructs in it,
4703 call the corresponding file handler. */
4704 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
4705 /* If FILENAME has no handler, see if VISIT has one. */
4706 if (NILP (handler
) && STRINGP (visit
))
4707 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
4709 if (!NILP (handler
))
4712 val
= call6 (handler
, Qwrite_region
, start
, end
,
4713 filename
, append
, visit
);
4717 SAVE_MODIFF
= MODIFF
;
4718 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4719 current_buffer
->filename
= visit_file
;
4725 /* Special kludge to simplify auto-saving. */
4728 XSETFASTINT (start
, BEG
);
4729 XSETFASTINT (end
, Z
);
4732 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
4733 count1
= specpdl_ptr
- specpdl
;
4735 given_buffer
= current_buffer
;
4736 annotations
= build_annotations (start
, end
, coding
.pre_write_conversion
);
4737 if (current_buffer
!= given_buffer
)
4739 XSETFASTINT (start
, BEGV
);
4740 XSETFASTINT (end
, ZV
);
4743 #ifdef CLASH_DETECTION
4746 #if 0 /* This causes trouble for GNUS. */
4747 /* If we've locked this file for some other buffer,
4748 query before proceeding. */
4749 if (!visiting
&& EQ (Ffile_locked_p (lockname
), Qt
))
4750 call2 (intern ("ask-user-about-lock"), filename
, Vuser_login_name
);
4753 lock_file (lockname
);
4755 #endif /* CLASH_DETECTION */
4757 encoded_filename
= ENCODE_FILE (filename
);
4759 fn
= XSTRING (encoded_filename
)->data
;
4763 desc
= emacs_open (fn
, O_WRONLY
| buffer_file_type
, 0);
4764 #else /* not DOS_NT */
4765 desc
= emacs_open (fn
, O_WRONLY
, 0);
4766 #endif /* not DOS_NT */
4768 if (desc
< 0 && (NILP (append
) || errno
== ENOENT
))
4770 if (auto_saving
) /* Overwrite any previous version of autosave file */
4772 vms_truncate (fn
); /* if fn exists, truncate to zero length */
4773 desc
= emacs_open (fn
, O_RDWR
, 0);
4775 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
4776 ? XSTRING (current_buffer
->filename
)->data
: 0,
4779 else /* Write to temporary name and rename if no errors */
4781 Lisp_Object temp_name
;
4782 temp_name
= Ffile_name_directory (filename
);
4784 if (!NILP (temp_name
))
4786 temp_name
= Fmake_temp_name (concat2 (temp_name
,
4787 build_string ("$$SAVE$$")));
4788 fname
= XSTRING (filename
)->data
;
4789 fn
= XSTRING (temp_name
)->data
;
4790 desc
= creat_copy_attrs (fname
, fn
);
4793 /* If we can't open the temporary file, try creating a new
4794 version of the original file. VMS "creat" creates a
4795 new version rather than truncating an existing file. */
4798 desc
= creat (fn
, 0666);
4799 #if 0 /* This can clobber an existing file and fail to replace it,
4800 if the user runs out of space. */
4803 /* We can't make a new version;
4804 try to truncate and rewrite existing version if any. */
4806 desc
= emacs_open (fn
, O_RDWR
, 0);
4812 desc
= creat (fn
, 0666);
4816 desc
= emacs_open (fn
,
4817 O_WRONLY
| O_CREAT
| buffer_file_type
4818 | (EQ (mustbenew
, Qexcl
) ? O_EXCL
: O_TRUNC
),
4819 S_IREAD
| S_IWRITE
);
4820 #else /* not DOS_NT */
4821 desc
= emacs_open (fn
, O_WRONLY
| O_TRUNC
| O_CREAT
4822 | (EQ (mustbenew
, Qexcl
) ? O_EXCL
: 0),
4823 auto_saving
? auto_save_mode_bits
: 0666);
4824 #endif /* not DOS_NT */
4825 #endif /* not VMS */
4829 #ifdef CLASH_DETECTION
4831 if (!auto_saving
) unlock_file (lockname
);
4833 #endif /* CLASH_DETECTION */
4835 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
4838 record_unwind_protect (close_file_unwind
, make_number (desc
));
4840 if (!NILP (append
) && !NILP (Ffile_regular_p (filename
)))
4844 if (NUMBERP (append
))
4845 ret
= lseek (desc
, XINT (append
), 1);
4847 ret
= lseek (desc
, 0, 2);
4850 #ifdef CLASH_DETECTION
4851 if (!auto_saving
) unlock_file (lockname
);
4852 #endif /* CLASH_DETECTION */
4854 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
4862 * Kludge Warning: The VMS C RTL likes to insert carriage returns
4863 * if we do writes that don't end with a carriage return. Furthermore
4864 * it cannot handle writes of more then 16K. The modified
4865 * version of "sys_write" in SYSDEP.C (see comment there) copes with
4866 * this EXCEPT for the last record (iff it doesn't end with a carriage
4867 * return). This implies that if your buffer doesn't end with a carriage
4868 * return, you get one free... tough. However it also means that if
4869 * we make two calls to sys_write (a la the following code) you can
4870 * get one at the gap as well. The easiest way to fix this (honest)
4871 * is to move the gap to the next newline (or the end of the buffer).
4876 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4877 move_gap (find_next_newline (GPT
, 1));
4879 /* Whether VMS or not, we must move the gap to the next of newline
4880 when we must put designation sequences at beginning of line. */
4881 if (INTEGERP (start
)
4882 && coding
.type
== coding_type_iso2022
4883 && coding
.flags
& CODING_FLAG_ISO_DESIGNATE_AT_BOL
4884 && GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4886 int opoint
= PT
, opoint_byte
= PT_BYTE
;
4887 scan_newline (PT
, PT_BYTE
, ZV
, ZV_BYTE
, 1, 0);
4888 move_gap_both (PT
, PT_BYTE
);
4889 SET_PT_BOTH (opoint
, opoint_byte
);
4896 if (STRINGP (start
))
4898 failure
= 0 > a_write (desc
, start
, 0, XSTRING (start
)->size
,
4899 &annotations
, &coding
);
4902 else if (XINT (start
) != XINT (end
))
4904 tem
= CHAR_TO_BYTE (XINT (start
));
4906 if (XINT (start
) < GPT
)
4908 failure
= 0 > a_write (desc
, Qnil
, XINT (start
),
4909 min (GPT
, XINT (end
)) - XINT (start
),
4910 &annotations
, &coding
);
4914 if (XINT (end
) > GPT
&& !failure
)
4916 tem
= max (XINT (start
), GPT
);
4917 failure
= 0 > a_write (desc
, Qnil
, tem
, XINT (end
) - tem
,
4918 &annotations
, &coding
);
4924 /* If file was empty, still need to write the annotations */
4925 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4926 failure
= 0 > a_write (desc
, Qnil
, XINT (end
), 0, &annotations
, &coding
);
4930 if (CODING_REQUIRE_FLUSHING (&coding
)
4931 && !(coding
.mode
& CODING_MODE_LAST_BLOCK
)
4934 /* We have to flush out a data. */
4935 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4936 failure
= 0 > e_write (desc
, Qnil
, 0, 0, &coding
);
4943 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
4944 Disk full in NFS may be reported here. */
4945 /* mib says that closing the file will try to write as fast as NFS can do
4946 it, and that means the fsync here is not crucial for autosave files. */
4947 if (!auto_saving
&& fsync (desc
) < 0)
4949 /* If fsync fails with EINTR, don't treat that as serious. */
4951 failure
= 1, save_errno
= errno
;
4955 /* Spurious "file has changed on disk" warnings have been
4956 observed on Suns as well.
4957 It seems that `close' can change the modtime, under nfs.
4959 (This has supposedly been fixed in Sunos 4,
4960 but who knows about all the other machines with NFS?) */
4963 /* On VMS and APOLLO, must do the stat after the close
4964 since closing changes the modtime. */
4967 /* Recall that #if defined does not work on VMS. */
4974 /* NFS can report a write failure now. */
4975 if (emacs_close (desc
) < 0)
4976 failure
= 1, save_errno
= errno
;
4979 /* If we wrote to a temporary name and had no errors, rename to real name. */
4983 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
4991 /* Discard the unwind protect for close_file_unwind. */
4992 specpdl_ptr
= specpdl
+ count1
;
4993 /* Restore the original current buffer. */
4994 visit_file
= unbind_to (count
, visit_file
);
4996 #ifdef CLASH_DETECTION
4998 unlock_file (lockname
);
4999 #endif /* CLASH_DETECTION */
5001 /* Do this before reporting IO error
5002 to avoid a "file has changed on disk" warning on
5003 next attempt to save. */
5005 current_buffer
->modtime
= st
.st_mtime
;
5008 error ("IO error writing %s: %s", XSTRING (filename
)->data
,
5009 emacs_strerror (save_errno
));
5013 SAVE_MODIFF
= MODIFF
;
5014 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
5015 current_buffer
->filename
= visit_file
;
5016 update_mode_lines
++;
5022 message_with_string ("Wrote %s", visit_file
, 1);
5027 Lisp_Object
merge ();
5029 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
5030 doc
: /* Return t if (car A) is numerically less than (car B). */)
5034 return Flss (Fcar (a
), Fcar (b
));
5037 /* Build the complete list of annotations appropriate for writing out
5038 the text between START and END, by calling all the functions in
5039 write-region-annotate-functions and merging the lists they return.
5040 If one of these functions switches to a different buffer, we assume
5041 that buffer contains altered text. Therefore, the caller must
5042 make sure to restore the current buffer in all cases,
5043 as save-excursion would do. */
5046 build_annotations (start
, end
, pre_write_conversion
)
5047 Lisp_Object start
, end
, pre_write_conversion
;
5049 Lisp_Object annotations
;
5051 struct gcpro gcpro1
, gcpro2
;
5052 Lisp_Object original_buffer
;
5055 XSETBUFFER (original_buffer
, current_buffer
);
5058 p
= Vwrite_region_annotate_functions
;
5059 GCPRO2 (annotations
, p
);
5062 struct buffer
*given_buffer
= current_buffer
;
5063 Vwrite_region_annotations_so_far
= annotations
;
5064 res
= call2 (Fcar (p
), start
, end
);
5065 /* If the function makes a different buffer current,
5066 assume that means this buffer contains altered text to be output.
5067 Reset START and END from the buffer bounds
5068 and discard all previous annotations because they should have
5069 been dealt with by this function. */
5070 if (current_buffer
!= given_buffer
)
5072 XSETFASTINT (start
, BEGV
);
5073 XSETFASTINT (end
, ZV
);
5076 Flength (res
); /* Check basic validity of return value */
5077 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
5081 /* Now do the same for annotation functions implied by the file-format */
5082 if (auto_saving
&& (!EQ (Vauto_save_file_format
, Qt
)))
5083 p
= Vauto_save_file_format
;
5085 p
= current_buffer
->file_format
;
5086 for (i
= 0; !NILP (p
); p
= Fcdr (p
), ++i
)
5088 struct buffer
*given_buffer
= current_buffer
;
5090 Vwrite_region_annotations_so_far
= annotations
;
5092 /* Value is either a list of annotations or nil if the function
5093 has written annotations to a temporary buffer, which is now
5095 res
= call5 (Qformat_annotate_function
, Fcar (p
), start
, end
,
5096 original_buffer
, make_number (i
));
5097 if (current_buffer
!= given_buffer
)
5099 XSETFASTINT (start
, BEGV
);
5100 XSETFASTINT (end
, ZV
);
5105 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
5108 /* At last, do the same for the function PRE_WRITE_CONVERSION
5109 implied by the current coding-system. */
5110 if (!NILP (pre_write_conversion
))
5112 struct buffer
*given_buffer
= current_buffer
;
5113 Vwrite_region_annotations_so_far
= annotations
;
5114 res
= call2 (pre_write_conversion
, start
, end
);
5116 annotations
= (current_buffer
!= given_buffer
5118 : merge (annotations
, res
, Qcar_less_than_car
));
5125 /* Write to descriptor DESC the NCHARS chars starting at POS of STRING.
5126 If STRING is nil, POS is the character position in the current buffer.
5127 Intersperse with them the annotations from *ANNOT
5128 which fall within the range of POS to POS + NCHARS,
5129 each at its appropriate position.
5131 We modify *ANNOT by discarding elements as we use them up.
5133 The return value is negative in case of system call failure. */
5136 a_write (desc
, string
, pos
, nchars
, annot
, coding
)
5139 register int nchars
;
5142 struct coding_system
*coding
;
5146 int lastpos
= pos
+ nchars
;
5148 while (NILP (*annot
) || CONSP (*annot
))
5150 tem
= Fcar_safe (Fcar (*annot
));
5153 nextpos
= XFASTINT (tem
);
5155 /* If there are no more annotations in this range,
5156 output the rest of the range all at once. */
5157 if (! (nextpos
>= pos
&& nextpos
<= lastpos
))
5158 return e_write (desc
, string
, pos
, lastpos
, coding
);
5160 /* Output buffer text up to the next annotation's position. */
5163 if (0 > e_write (desc
, string
, pos
, nextpos
, coding
))
5167 /* Output the annotation. */
5168 tem
= Fcdr (Fcar (*annot
));
5171 if (0 > e_write (desc
, tem
, 0, XSTRING (tem
)->size
, coding
))
5174 *annot
= Fcdr (*annot
);
5179 #ifndef WRITE_BUF_SIZE
5180 #define WRITE_BUF_SIZE (16 * 1024)
5183 /* Write text in the range START and END into descriptor DESC,
5184 encoding them with coding system CODING. If STRING is nil, START
5185 and END are character positions of the current buffer, else they
5186 are indexes to the string STRING. */
5189 e_write (desc
, string
, start
, end
, coding
)
5193 struct coding_system
*coding
;
5195 register char *addr
;
5196 register int nbytes
;
5197 char buf
[WRITE_BUF_SIZE
];
5201 coding
->composing
= COMPOSITION_DISABLED
;
5202 if (coding
->composing
!= COMPOSITION_DISABLED
)
5203 coding_save_composition (coding
, start
, end
, string
);
5205 if (STRINGP (string
))
5207 addr
= XSTRING (string
)->data
;
5208 nbytes
= STRING_BYTES (XSTRING (string
));
5209 coding
->src_multibyte
= STRING_MULTIBYTE (string
);
5211 else if (start
< end
)
5213 /* It is assured that the gap is not in the range START and END-1. */
5214 addr
= CHAR_POS_ADDR (start
);
5215 nbytes
= CHAR_TO_BYTE (end
) - CHAR_TO_BYTE (start
);
5216 coding
->src_multibyte
5217 = !NILP (current_buffer
->enable_multibyte_characters
);
5223 coding
->src_multibyte
= 1;
5226 /* We used to have a code for handling selective display here. But,
5227 now it is handled within encode_coding. */
5232 result
= encode_coding (coding
, addr
, buf
, nbytes
, WRITE_BUF_SIZE
);
5233 if (coding
->produced
> 0)
5235 coding
->produced
-= emacs_write (desc
, buf
, coding
->produced
);
5236 if (coding
->produced
)
5242 nbytes
-= coding
->consumed
;
5243 addr
+= coding
->consumed
;
5244 if (result
== CODING_FINISH_INSUFFICIENT_SRC
5247 /* The source text ends by an incomplete multibyte form.
5248 There's no way other than write it out as is. */
5249 nbytes
-= emacs_write (desc
, addr
, nbytes
);
5258 start
+= coding
->consumed_char
;
5259 if (coding
->cmp_data
)
5260 coding_adjust_composition_offset (coding
, start
);
5263 if (coding
->cmp_data
)
5264 coding_free_composition_data (coding
);
5269 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
5270 Sverify_visited_file_modtime
, 1, 1, 0,
5271 doc
: /* Return t if last mod time of BUF's visited file matches what BUF records.
5272 This means that the file has not been changed since it was visited or saved. */)
5278 Lisp_Object handler
;
5279 Lisp_Object filename
;
5281 CHECK_BUFFER (buf
, 0);
5284 if (!STRINGP (b
->filename
)) return Qt
;
5285 if (b
->modtime
== 0) return Qt
;
5287 /* If the file name has special constructs in it,
5288 call the corresponding file handler. */
5289 handler
= Ffind_file_name_handler (b
->filename
,
5290 Qverify_visited_file_modtime
);
5291 if (!NILP (handler
))
5292 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
5294 filename
= ENCODE_FILE (b
->filename
);
5296 if (stat (XSTRING (filename
)->data
, &st
) < 0)
5298 /* If the file doesn't exist now and didn't exist before,
5299 we say that it isn't modified, provided the error is a tame one. */
5300 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
5305 if (st
.st_mtime
== b
->modtime
5306 /* If both are positive, accept them if they are off by one second. */
5307 || (st
.st_mtime
> 0 && b
->modtime
> 0
5308 && (st
.st_mtime
== b
->modtime
+ 1
5309 || st
.st_mtime
== b
->modtime
- 1)))
5314 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
5315 Sclear_visited_file_modtime
, 0, 0, 0,
5316 doc
: /* Clear out records of last mod time of visited file.
5317 Next attempt to save will certainly not complain of a discrepancy. */)
5320 current_buffer
->modtime
= 0;
5324 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
5325 Svisited_file_modtime
, 0, 0, 0,
5326 doc
: /* Return the current buffer's recorded visited file modification time.
5327 The value is a list of the form (HIGH . LOW), like the time values
5328 that `file-attributes' returns. */)
5331 return long_to_cons ((unsigned long) current_buffer
->modtime
);
5334 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
5335 Sset_visited_file_modtime
, 0, 1, 0,
5336 doc
: /* Update buffer's recorded modification time from the visited file's time.
5337 Useful if the buffer was not read from the file normally
5338 or if the file itself has been changed for some known benign reason.
5339 An argument specifies the modification time value to use
5340 \(instead of that of the visited file), in the form of a list
5341 \(HIGH . LOW) or (HIGH LOW). */)
5343 Lisp_Object time_list
;
5345 if (!NILP (time_list
))
5346 current_buffer
->modtime
= cons_to_long (time_list
);
5349 register Lisp_Object filename
;
5351 Lisp_Object handler
;
5353 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
5355 /* If the file name has special constructs in it,
5356 call the corresponding file handler. */
5357 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
5358 if (!NILP (handler
))
5359 /* The handler can find the file name the same way we did. */
5360 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
5362 filename
= ENCODE_FILE (filename
);
5364 if (stat (XSTRING (filename
)->data
, &st
) >= 0)
5365 current_buffer
->modtime
= st
.st_mtime
;
5372 auto_save_error (error
)
5375 Lisp_Object args
[3], msg
;
5377 struct gcpro gcpro1
;
5381 args
[0] = build_string ("Auto-saving %s: %s");
5382 args
[1] = current_buffer
->name
;
5383 args
[2] = Ferror_message_string (error
);
5384 msg
= Fformat (3, args
);
5386 nbytes
= STRING_BYTES (XSTRING (msg
));
5388 for (i
= 0; i
< 3; ++i
)
5391 message2 (XSTRING (msg
)->data
, nbytes
, STRING_MULTIBYTE (msg
));
5393 message2_nolog (XSTRING (msg
)->data
, nbytes
, STRING_MULTIBYTE (msg
));
5394 Fsleep_for (make_number (1), Qnil
);
5406 /* Get visited file's mode to become the auto save file's mode. */
5407 if (! NILP (current_buffer
->filename
)
5408 && stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
5409 /* But make sure we can overwrite it later! */
5410 auto_save_mode_bits
= st
.st_mode
| 0600;
5412 auto_save_mode_bits
= 0666;
5415 Fwrite_region (Qnil
, Qnil
,
5416 current_buffer
->auto_save_file_name
,
5417 Qnil
, Qlambda
, Qnil
, Qnil
);
5421 do_auto_save_unwind (stream
) /* used as unwind-protect function */
5426 fclose ((FILE *) (XFASTINT (XCAR (stream
)) << 16
5427 | XFASTINT (XCDR (stream
))));
5433 do_auto_save_unwind_1 (value
) /* used as unwind-protect function */
5436 minibuffer_auto_raise
= XINT (value
);
5440 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
5441 doc
: /* Auto-save all buffers that need it.
5442 This is all buffers that have auto-saving enabled
5443 and are changed since last auto-saved.
5444 Auto-saving writes the buffer into a file
5445 so that your editing is not lost if the system crashes.
5446 This file is not the file you visited; that changes only when you save.
5447 Normally we run the normal hook `auto-save-hook' before saving.
5449 A non-nil NO-MESSAGE argument means do not print any message if successful.
5450 A non-nil CURRENT-ONLY argument means save only current buffer. */)
5451 (no_message
, current_only
)
5452 Lisp_Object no_message
, current_only
;
5454 struct buffer
*old
= current_buffer
, *b
;
5455 Lisp_Object tail
, buf
;
5457 int do_handled_files
;
5460 Lisp_Object lispstream
;
5461 int count
= specpdl_ptr
- specpdl
;
5462 int orig_minibuffer_auto_raise
= minibuffer_auto_raise
;
5463 int message_p
= push_message ();
5465 /* Ordinarily don't quit within this function,
5466 but don't make it impossible to quit (in case we get hung in I/O). */
5470 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
5471 point to non-strings reached from Vbuffer_alist. */
5476 if (!NILP (Vrun_hooks
))
5477 call1 (Vrun_hooks
, intern ("auto-save-hook"));
5479 if (STRINGP (Vauto_save_list_file_name
))
5481 Lisp_Object listfile
;
5483 listfile
= Fexpand_file_name (Vauto_save_list_file_name
, Qnil
);
5485 /* Don't try to create the directory when shutting down Emacs,
5486 because creating the directory might signal an error, and
5487 that would leave Emacs in a strange state. */
5488 if (!NILP (Vrun_hooks
))
5491 dir
= Ffile_name_directory (listfile
);
5492 if (NILP (Ffile_directory_p (dir
)))
5493 call2 (Qmake_directory
, dir
, Qt
);
5496 stream
= fopen (XSTRING (listfile
)->data
, "w");
5499 /* Arrange to close that file whether or not we get an error.
5500 Also reset auto_saving to 0. */
5501 lispstream
= Fcons (Qnil
, Qnil
);
5502 XSETCARFASTINT (lispstream
, (EMACS_UINT
)stream
>> 16);
5503 XSETCDRFASTINT (lispstream
, (EMACS_UINT
)stream
& 0xffff);
5514 record_unwind_protect (do_auto_save_unwind
, lispstream
);
5515 record_unwind_protect (do_auto_save_unwind_1
,
5516 make_number (minibuffer_auto_raise
));
5517 minibuffer_auto_raise
= 0;
5520 /* First, save all files which don't have handlers. If Emacs is
5521 crashing, the handlers may tweak what is causing Emacs to crash
5522 in the first place, and it would be a shame if Emacs failed to
5523 autosave perfectly ordinary files because it couldn't handle some
5525 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
5526 for (tail
= Vbuffer_alist
; GC_CONSP (tail
); tail
= XCDR (tail
))
5528 buf
= XCDR (XCAR (tail
));
5531 /* Record all the buffers that have auto save mode
5532 in the special file that lists them. For each of these buffers,
5533 Record visited name (if any) and auto save name. */
5534 if (STRINGP (b
->auto_save_file_name
)
5535 && stream
!= NULL
&& do_handled_files
== 0)
5537 if (!NILP (b
->filename
))
5539 fwrite (XSTRING (b
->filename
)->data
, 1,
5540 STRING_BYTES (XSTRING (b
->filename
)), stream
);
5542 putc ('\n', stream
);
5543 fwrite (XSTRING (b
->auto_save_file_name
)->data
, 1,
5544 STRING_BYTES (XSTRING (b
->auto_save_file_name
)), stream
);
5545 putc ('\n', stream
);
5548 if (!NILP (current_only
)
5549 && b
!= current_buffer
)
5552 /* Don't auto-save indirect buffers.
5553 The base buffer takes care of it. */
5557 /* Check for auto save enabled
5558 and file changed since last auto save
5559 and file changed since last real save. */
5560 if (STRINGP (b
->auto_save_file_name
)
5561 && BUF_SAVE_MODIFF (b
) < BUF_MODIFF (b
)
5562 && b
->auto_save_modified
< BUF_MODIFF (b
)
5563 /* -1 means we've turned off autosaving for a while--see below. */
5564 && XINT (b
->save_length
) >= 0
5565 && (do_handled_files
5566 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
5569 EMACS_TIME before_time
, after_time
;
5571 EMACS_GET_TIME (before_time
);
5573 /* If we had a failure, don't try again for 20 minutes. */
5574 if (b
->auto_save_failure_time
>= 0
5575 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
5578 if ((XFASTINT (b
->save_length
) * 10
5579 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
5580 /* A short file is likely to change a large fraction;
5581 spare the user annoying messages. */
5582 && XFASTINT (b
->save_length
) > 5000
5583 /* These messages are frequent and annoying for `*mail*'. */
5584 && !EQ (b
->filename
, Qnil
)
5585 && NILP (no_message
))
5587 /* It has shrunk too much; turn off auto-saving here. */
5588 minibuffer_auto_raise
= orig_minibuffer_auto_raise
;
5589 message_with_string ("Buffer %s has shrunk a lot; auto save turned off there",
5591 minibuffer_auto_raise
= 0;
5592 /* Turn off auto-saving until there's a real save,
5593 and prevent any more warnings. */
5594 XSETINT (b
->save_length
, -1);
5595 Fsleep_for (make_number (1), Qnil
);
5598 set_buffer_internal (b
);
5599 if (!auto_saved
&& NILP (no_message
))
5600 message1 ("Auto-saving...");
5601 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
5603 b
->auto_save_modified
= BUF_MODIFF (b
);
5604 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
5605 set_buffer_internal (old
);
5607 EMACS_GET_TIME (after_time
);
5609 /* If auto-save took more than 60 seconds,
5610 assume it was an NFS failure that got a timeout. */
5611 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
5612 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
5616 /* Prevent another auto save till enough input events come in. */
5617 record_auto_save ();
5619 if (auto_saved
&& NILP (no_message
))
5623 sit_for (1, 0, 0, 0, 0);
5627 message1 ("Auto-saving...done");
5632 unbind_to (count
, Qnil
);
5636 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
5637 Sset_buffer_auto_saved
, 0, 0, 0,
5638 doc
: /* Mark current buffer as auto-saved with its current text.
5639 No auto-save file will be written until the buffer changes again. */)
5642 current_buffer
->auto_save_modified
= MODIFF
;
5643 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
5644 current_buffer
->auto_save_failure_time
= -1;
5648 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
5649 Sclear_buffer_auto_save_failure
, 0, 0, 0,
5650 doc
: /* Clear any record of a recent auto-save failure in the current buffer. */)
5653 current_buffer
->auto_save_failure_time
= -1;
5657 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
5659 doc
: /* Return t if buffer has been auto-saved since last read in or saved. */)
5662 return (SAVE_MODIFF
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
5665 /* Reading and completing file names */
5666 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
5668 /* In the string VAL, change each $ to $$ and return the result. */
5671 double_dollars (val
)
5674 register unsigned char *old
, *new;
5678 osize
= STRING_BYTES (XSTRING (val
));
5680 /* Count the number of $ characters. */
5681 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
5682 if (*old
++ == '$') count
++;
5685 old
= XSTRING (val
)->data
;
5686 val
= make_uninit_multibyte_string (XSTRING (val
)->size
+ count
,
5688 new = XSTRING (val
)->data
;
5689 for (n
= osize
; n
> 0; n
--)
5702 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
5704 doc
: /* Internal subroutine for read-file-name. Do not call this. */)
5705 (string
, dir
, action
)
5706 Lisp_Object string
, dir
, action
;
5707 /* action is nil for complete, t for return list of completions,
5708 lambda for verify final value */
5710 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
5712 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
5714 CHECK_STRING (string
, 0);
5721 /* No need to protect ACTION--we only compare it with t and nil. */
5722 GCPRO5 (string
, realdir
, name
, specdir
, orig_string
);
5724 if (XSTRING (string
)->size
== 0)
5726 if (EQ (action
, Qlambda
))
5734 orig_string
= string
;
5735 string
= Fsubstitute_in_file_name (string
);
5736 changed
= NILP (Fstring_equal (string
, orig_string
));
5737 name
= Ffile_name_nondirectory (string
);
5738 val
= Ffile_name_directory (string
);
5740 realdir
= Fexpand_file_name (val
, realdir
);
5745 specdir
= Ffile_name_directory (string
);
5746 val
= Ffile_name_completion (name
, realdir
);
5751 return double_dollars (string
);
5755 if (!NILP (specdir
))
5756 val
= concat2 (specdir
, val
);
5758 return double_dollars (val
);
5761 #endif /* not VMS */
5765 if (EQ (action
, Qt
))
5766 return Ffile_name_all_completions (name
, realdir
);
5767 /* Only other case actually used is ACTION = lambda */
5769 /* Supposedly this helps commands such as `cd' that read directory names,
5770 but can someone explain how it helps them? -- RMS */
5771 if (XSTRING (name
)->size
== 0)
5774 return Ffile_exists_p (string
);
5777 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
5778 doc
: /* Read file name, prompting with PROMPT and completing in directory DIR.
5779 Value is not expanded---you must call `expand-file-name' yourself.
5780 Default name to DEFAULT-FILENAME if user enters a null string.
5781 (If DEFAULT-FILENAME is omitted, the visited file name is used,
5782 except that if INITIAL is specified, that combined with DIR is used.)
5783 Fourth arg MUSTMATCH non-nil means require existing file's name.
5784 Non-nil and non-t means also require confirmation after completion.
5785 Fifth arg INITIAL specifies text to start with.
5786 DIR defaults to current buffer's directory default.
5788 If this command was invoked with the mouse, use a file dialog box if
5789 `use-dialog-box' is non-nil, and the window system or X toolkit in use
5790 provides a file dialog box. */)
5791 (prompt
, dir
, default_filename
, mustmatch
, initial
)
5792 Lisp_Object prompt
, dir
, default_filename
, mustmatch
, initial
;
5794 Lisp_Object val
, insdef
, tem
;
5795 struct gcpro gcpro1
, gcpro2
;
5796 register char *homedir
;
5797 int replace_in_history
= 0;
5798 int add_to_history
= 0;
5802 dir
= current_buffer
->directory
;
5803 if (NILP (default_filename
))
5805 if (! NILP (initial
))
5806 default_filename
= Fexpand_file_name (initial
, dir
);
5808 default_filename
= current_buffer
->filename
;
5811 /* If dir starts with user's homedir, change that to ~. */
5812 homedir
= (char *) egetenv ("HOME");
5814 /* homedir can be NULL in temacs, since Vprocess_environment is not
5815 yet set up. We shouldn't crash in that case. */
5818 homedir
= strcpy (alloca (strlen (homedir
) + 1), homedir
);
5819 CORRECT_DIR_SEPS (homedir
);
5824 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5825 && IS_DIRECTORY_SEP (XSTRING (dir
)->data
[strlen (homedir
)]))
5827 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5828 STRING_BYTES (XSTRING (dir
)) - strlen (homedir
) + 1);
5829 XSTRING (dir
)->data
[0] = '~';
5831 /* Likewise for default_filename. */
5833 && STRINGP (default_filename
)
5834 && !strncmp (homedir
, XSTRING (default_filename
)->data
, strlen (homedir
))
5835 && IS_DIRECTORY_SEP (XSTRING (default_filename
)->data
[strlen (homedir
)]))
5838 = make_string (XSTRING (default_filename
)->data
+ strlen (homedir
) - 1,
5839 STRING_BYTES (XSTRING (default_filename
)) - strlen (homedir
) + 1);
5840 XSTRING (default_filename
)->data
[0] = '~';
5842 if (!NILP (default_filename
))
5844 CHECK_STRING (default_filename
, 3);
5845 default_filename
= double_dollars (default_filename
);
5848 if (insert_default_directory
&& STRINGP (dir
))
5851 if (!NILP (initial
))
5853 Lisp_Object args
[2], pos
;
5857 insdef
= Fconcat (2, args
);
5858 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
5859 insdef
= Fcons (double_dollars (insdef
), pos
);
5862 insdef
= double_dollars (insdef
);
5864 else if (STRINGP (initial
))
5865 insdef
= Fcons (double_dollars (initial
), make_number (0));
5869 count
= specpdl_ptr
- specpdl
;
5871 specbind (intern ("completion-ignore-case"), Qt
);
5874 specbind (intern ("minibuffer-completing-file-name"), Qt
);
5876 GCPRO2 (insdef
, default_filename
);
5878 #if defined (USE_MOTIF) || defined (HAVE_NTGUI)
5879 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
5883 /* If DIR contains a file name, split it. */
5885 file
= Ffile_name_nondirectory (dir
);
5886 if (XSTRING (file
)->size
&& NILP (default_filename
))
5888 default_filename
= file
;
5889 dir
= Ffile_name_directory (dir
);
5891 if (!NILP(default_filename
))
5892 default_filename
= Fexpand_file_name (default_filename
, dir
);
5893 val
= Fx_file_dialog (prompt
, dir
, default_filename
, mustmatch
);
5898 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5899 dir
, mustmatch
, insdef
,
5900 Qfile_name_history
, default_filename
, Qnil
);
5902 tem
= Fsymbol_value (Qfile_name_history
);
5903 if (CONSP (tem
) && EQ (XCAR (tem
), val
))
5904 replace_in_history
= 1;
5906 /* If Fcompleting_read returned the inserted default string itself
5907 (rather than a new string with the same contents),
5908 it has to mean that the user typed RET with the minibuffer empty.
5909 In that case, we really want to return ""
5910 so that commands such as set-visited-file-name can distinguish. */
5911 if (EQ (val
, default_filename
))
5913 /* In this case, Fcompleting_read has not added an element
5914 to the history. Maybe we should. */
5915 if (! replace_in_history
)
5918 val
= build_string ("");
5921 unbind_to (count
, Qnil
);
5924 error ("No file name specified");
5926 tem
= Fstring_equal (val
, CONSP (insdef
) ? XCAR (insdef
) : insdef
);
5928 if (!NILP (tem
) && !NILP (default_filename
))
5929 val
= default_filename
;
5930 else if (XSTRING (val
)->size
== 0 && NILP (insdef
))
5932 if (!NILP (default_filename
))
5933 val
= default_filename
;
5935 error ("No default file name");
5937 val
= Fsubstitute_in_file_name (val
);
5939 if (replace_in_history
)
5940 /* Replace what Fcompleting_read added to the history
5941 with what we will actually return. */
5942 XSETCAR (Fsymbol_value (Qfile_name_history
), double_dollars (val
));
5943 else if (add_to_history
)
5945 /* Add the value to the history--but not if it matches
5946 the last value already there. */
5947 Lisp_Object val1
= double_dollars (val
);
5948 tem
= Fsymbol_value (Qfile_name_history
);
5949 if (! CONSP (tem
) || NILP (Fequal (XCAR (tem
), val1
)))
5950 Fset (Qfile_name_history
,
5961 /* Must be set before any path manipulation is performed. */
5962 XSETFASTINT (Vdirectory_sep_char
, '/');
5969 Qexpand_file_name
= intern ("expand-file-name");
5970 Qsubstitute_in_file_name
= intern ("substitute-in-file-name");
5971 Qdirectory_file_name
= intern ("directory-file-name");
5972 Qfile_name_directory
= intern ("file-name-directory");
5973 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
5974 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
5975 Qfile_name_as_directory
= intern ("file-name-as-directory");
5976 Qcopy_file
= intern ("copy-file");
5977 Qmake_directory_internal
= intern ("make-directory-internal");
5978 Qmake_directory
= intern ("make-directory");
5979 Qdelete_directory
= intern ("delete-directory");
5980 Qdelete_file
= intern ("delete-file");
5981 Qrename_file
= intern ("rename-file");
5982 Qadd_name_to_file
= intern ("add-name-to-file");
5983 Qmake_symbolic_link
= intern ("make-symbolic-link");
5984 Qfile_exists_p
= intern ("file-exists-p");
5985 Qfile_executable_p
= intern ("file-executable-p");
5986 Qfile_readable_p
= intern ("file-readable-p");
5987 Qfile_writable_p
= intern ("file-writable-p");
5988 Qfile_symlink_p
= intern ("file-symlink-p");
5989 Qaccess_file
= intern ("access-file");
5990 Qfile_directory_p
= intern ("file-directory-p");
5991 Qfile_regular_p
= intern ("file-regular-p");
5992 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
5993 Qfile_modes
= intern ("file-modes");
5994 Qset_file_modes
= intern ("set-file-modes");
5995 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
5996 Qinsert_file_contents
= intern ("insert-file-contents");
5997 Qwrite_region
= intern ("write-region");
5998 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
5999 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
6001 staticpro (&Qexpand_file_name
);
6002 staticpro (&Qsubstitute_in_file_name
);
6003 staticpro (&Qdirectory_file_name
);
6004 staticpro (&Qfile_name_directory
);
6005 staticpro (&Qfile_name_nondirectory
);
6006 staticpro (&Qunhandled_file_name_directory
);
6007 staticpro (&Qfile_name_as_directory
);
6008 staticpro (&Qcopy_file
);
6009 staticpro (&Qmake_directory_internal
);
6010 staticpro (&Qmake_directory
);
6011 staticpro (&Qdelete_directory
);
6012 staticpro (&Qdelete_file
);
6013 staticpro (&Qrename_file
);
6014 staticpro (&Qadd_name_to_file
);
6015 staticpro (&Qmake_symbolic_link
);
6016 staticpro (&Qfile_exists_p
);
6017 staticpro (&Qfile_executable_p
);
6018 staticpro (&Qfile_readable_p
);
6019 staticpro (&Qfile_writable_p
);
6020 staticpro (&Qaccess_file
);
6021 staticpro (&Qfile_symlink_p
);
6022 staticpro (&Qfile_directory_p
);
6023 staticpro (&Qfile_regular_p
);
6024 staticpro (&Qfile_accessible_directory_p
);
6025 staticpro (&Qfile_modes
);
6026 staticpro (&Qset_file_modes
);
6027 staticpro (&Qfile_newer_than_file_p
);
6028 staticpro (&Qinsert_file_contents
);
6029 staticpro (&Qwrite_region
);
6030 staticpro (&Qverify_visited_file_modtime
);
6031 staticpro (&Qset_visited_file_modtime
);
6033 Qfile_name_history
= intern ("file-name-history");
6034 Fset (Qfile_name_history
, Qnil
);
6035 staticpro (&Qfile_name_history
);
6037 Qfile_error
= intern ("file-error");
6038 staticpro (&Qfile_error
);
6039 Qfile_already_exists
= intern ("file-already-exists");
6040 staticpro (&Qfile_already_exists
);
6041 Qfile_date_error
= intern ("file-date-error");
6042 staticpro (&Qfile_date_error
);
6043 Qexcl
= intern ("excl");
6047 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
6048 staticpro (&Qfind_buffer_file_type
);
6051 DEFVAR_LISP ("file-name-coding-system", &Vfile_name_coding_system
,
6052 doc
: /* *Coding system for encoding file names.
6053 If it is nil, default-file-name-coding-system (which see) is used. */);
6054 Vfile_name_coding_system
= Qnil
;
6056 DEFVAR_LISP ("default-file-name-coding-system",
6057 &Vdefault_file_name_coding_system
,
6058 doc
: /* Default coding system for encoding file names.
6059 This variable is used only when file-name-coding-system is nil.
6061 This variable is set/changed by the command set-language-environment.
6062 User should not set this variable manually,
6063 instead use file-name-coding-system to get a constant encoding
6064 of file names regardless of the current language environment. */);
6065 Vdefault_file_name_coding_system
= Qnil
;
6067 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format
,
6068 doc
: /* *Format in which to write auto-save files.
6069 Should be a list of symbols naming formats that are defined in `format-alist'.
6070 If it is t, which is the default, auto-save files are written in the
6071 same format as a regular save would use. */);
6072 Vauto_save_file_format
= Qt
;
6074 Qformat_decode
= intern ("format-decode");
6075 staticpro (&Qformat_decode
);
6076 Qformat_annotate_function
= intern ("format-annotate-function");
6077 staticpro (&Qformat_annotate_function
);
6079 Qcar_less_than_car
= intern ("car-less-than-car");
6080 staticpro (&Qcar_less_than_car
);
6082 Fput (Qfile_error
, Qerror_conditions
,
6083 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
6084 Fput (Qfile_error
, Qerror_message
,
6085 build_string ("File error"));
6087 Fput (Qfile_already_exists
, Qerror_conditions
,
6088 Fcons (Qfile_already_exists
,
6089 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
6090 Fput (Qfile_already_exists
, Qerror_message
,
6091 build_string ("File already exists"));
6093 Fput (Qfile_date_error
, Qerror_conditions
,
6094 Fcons (Qfile_date_error
,
6095 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
6096 Fput (Qfile_date_error
, Qerror_message
,
6097 build_string ("Cannot set file date"));
6099 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
6100 doc
: /* *Non-nil means when reading a filename start with default dir in minibuffer. */);
6101 insert_default_directory
= 1;
6103 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
6104 doc
: /* *Non-nil means write new files with record format `stmlf'.
6105 nil means use format `var'. This variable is meaningful only on VMS. */);
6106 vms_stmlf_recfm
= 0;
6108 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char
,
6109 doc
: /* Directory separator character for built-in functions that return file names.
6110 The value should be either ?/ or ?\\ (any other value is treated as ?\\).
6111 This variable affects the built-in functions only on Windows,
6112 on other platforms, it is initialized so that Lisp code can find out
6113 what the normal separator is.
6115 WARNING: This variable is deprecated and will be removed in the near
6116 future. DO NOT USE IT. */);
6118 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
6119 doc
: /* *Alist of elements (REGEXP . HANDLER) for file names handled specially.
6120 If a file name matches REGEXP, then all I/O on that file is done by calling
6123 The first argument given to HANDLER is the name of the I/O primitive
6124 to be handled; the remaining arguments are the arguments that were
6125 passed to that primitive. For example, if you do
6126 (file-exists-p FILENAME)
6127 and FILENAME is handled by HANDLER, then HANDLER is called like this:
6128 (funcall HANDLER 'file-exists-p FILENAME)
6129 The function `find-file-name-handler' checks this list for a handler
6130 for its argument. */);
6131 Vfile_name_handler_alist
= Qnil
;
6133 DEFVAR_LISP ("set-auto-coding-function",
6134 &Vset_auto_coding_function
,
6135 doc
: /* If non-nil, a function to call to decide a coding system of file.
6136 Two arguments are passed to this function: the file name
6137 and the length of a file contents following the point.
6138 This function should return a coding system to decode the file contents.
6139 It should check the file name against `auto-coding-alist'.
6140 If no coding system is decided, it should check a coding system
6141 specified in the heading lines with the format:
6142 -*- ... coding: CODING-SYSTEM; ... -*-
6143 or local variable spec of the tailing lines with `coding:' tag. */);
6144 Vset_auto_coding_function
= Qnil
;
6146 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
6147 doc
: /* A list of functions to be called at the end of `insert-file-contents'.
6148 Each is passed one argument, the number of bytes inserted. It should return
6149 the new byte count, and leave point the same. If `insert-file-contents' is
6150 intercepted by a handler from `file-name-handler-alist', that handler is
6151 responsible for calling the after-insert-file-functions if appropriate. */);
6152 Vafter_insert_file_functions
= Qnil
;
6154 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
6155 doc
: /* A list of functions to be called at the start of `write-region'.
6156 Each is passed two arguments, START and END as for `write-region'.
6157 These are usually two numbers but not always; see the documentation
6158 for `write-region'. The function should return a list of pairs
6159 of the form (POSITION . STRING), consisting of strings to be effectively
6160 inserted at the specified positions of the file being written (1 means to
6161 insert before the first byte written). The POSITIONs must be sorted into
6162 increasing order. If there are several functions in the list, the several
6163 lists are merged destructively. */);
6164 Vwrite_region_annotate_functions
= Qnil
;
6166 DEFVAR_LISP ("write-region-annotations-so-far",
6167 &Vwrite_region_annotations_so_far
,
6168 doc
: /* When an annotation function is called, this holds the previous annotations.
6169 These are the annotations made by other annotation functions
6170 that were already called. See also `write-region-annotate-functions'. */);
6171 Vwrite_region_annotations_so_far
= Qnil
;
6173 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
6174 doc
: /* A list of file name handlers that temporarily should not be used.
6175 This applies only to the operation `inhibit-file-name-operation'. */);
6176 Vinhibit_file_name_handlers
= Qnil
;
6178 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
6179 doc
: /* The operation for which `inhibit-file-name-handlers' is applicable. */);
6180 Vinhibit_file_name_operation
= Qnil
;
6182 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
6183 doc
: /* File name in which we write a list of all auto save file names.
6184 This variable is initialized automatically from `auto-save-list-file-prefix'
6185 shortly after Emacs reads your `.emacs' file, if you have not yet given it
6186 a non-nil value. */);
6187 Vauto_save_list_file_name
= Qnil
;
6189 defsubr (&Sfind_file_name_handler
);
6190 defsubr (&Sfile_name_directory
);
6191 defsubr (&Sfile_name_nondirectory
);
6192 defsubr (&Sunhandled_file_name_directory
);
6193 defsubr (&Sfile_name_as_directory
);
6194 defsubr (&Sdirectory_file_name
);
6195 defsubr (&Smake_temp_name
);
6196 defsubr (&Sexpand_file_name
);
6197 defsubr (&Ssubstitute_in_file_name
);
6198 defsubr (&Scopy_file
);
6199 defsubr (&Smake_directory_internal
);
6200 defsubr (&Sdelete_directory
);
6201 defsubr (&Sdelete_file
);
6202 defsubr (&Srename_file
);
6203 defsubr (&Sadd_name_to_file
);
6205 defsubr (&Smake_symbolic_link
);
6206 #endif /* S_IFLNK */
6208 defsubr (&Sdefine_logical_name
);
6211 defsubr (&Ssysnetunam
);
6212 #endif /* HPUX_NET */
6213 defsubr (&Sfile_name_absolute_p
);
6214 defsubr (&Sfile_exists_p
);
6215 defsubr (&Sfile_executable_p
);
6216 defsubr (&Sfile_readable_p
);
6217 defsubr (&Sfile_writable_p
);
6218 defsubr (&Saccess_file
);
6219 defsubr (&Sfile_symlink_p
);
6220 defsubr (&Sfile_directory_p
);
6221 defsubr (&Sfile_accessible_directory_p
);
6222 defsubr (&Sfile_regular_p
);
6223 defsubr (&Sfile_modes
);
6224 defsubr (&Sset_file_modes
);
6225 defsubr (&Sset_default_file_modes
);
6226 defsubr (&Sdefault_file_modes
);
6227 defsubr (&Sfile_newer_than_file_p
);
6228 defsubr (&Sinsert_file_contents
);
6229 defsubr (&Swrite_region
);
6230 defsubr (&Scar_less_than_car
);
6231 defsubr (&Sverify_visited_file_modtime
);
6232 defsubr (&Sclear_visited_file_modtime
);
6233 defsubr (&Svisited_file_modtime
);
6234 defsubr (&Sset_visited_file_modtime
);
6235 defsubr (&Sdo_auto_save
);
6236 defsubr (&Sset_buffer_auto_saved
);
6237 defsubr (&Sclear_buffer_auto_save_failure
);
6238 defsubr (&Srecent_auto_save_p
);
6240 defsubr (&Sread_file_name_internal
);
6241 defsubr (&Sread_file_name
);
6244 defsubr (&Sunix_sync
);