1 /* File IO for GNU Emacs.
2 Copyright (C) 1985,86,87,88,93,94,95,96,97,98,99,2000
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)
86 #include "intervals.h"
97 #endif /* not WINDOWSNT */
101 #include <sys/param.h>
109 #define CORRECT_DIR_SEPS(s) \
110 do { if ('/' == DIRECTORY_SEP) dostounix_filename (s); \
111 else unixtodos_filename (s); \
113 /* On Windows, drive letters must be alphabetic - on DOS, the Netware
114 redirector allows the six letters between 'Z' and 'a' as well. */
116 #define IS_DRIVE(x) ((x) >= 'A' && (x) <= 'z')
119 #define IS_DRIVE(x) isalpha (x)
121 /* Need to lower-case the drive letter, or else expanded
122 filenames will sometimes compare inequal, because
123 `expand-file-name' doesn't always down-case the drive letter. */
124 #define DRIVE_LETTER(x) (tolower (x))
145 #include "commands.h"
146 extern int use_dialog_box
;
160 #define min(a, b) ((a) < (b) ? (a) : (b))
161 #define max(a, b) ((a) > (b) ? (a) : (b))
163 /* Nonzero during writing of auto-save files */
166 /* Set by auto_save_1 to mode of original file so Fwrite_region will create
167 a new file with the same mode as the original */
168 int auto_save_mode_bits
;
170 /* Coding system for file names, or nil if none. */
171 Lisp_Object Vfile_name_coding_system
;
173 /* Coding system for file names used only when
174 Vfile_name_coding_system is nil. */
175 Lisp_Object Vdefault_file_name_coding_system
;
177 /* Alist of elements (REGEXP . HANDLER) for file names
178 whose I/O is done with a special handler. */
179 Lisp_Object Vfile_name_handler_alist
;
181 /* Format for auto-save files */
182 Lisp_Object Vauto_save_file_format
;
184 /* Lisp functions for translating file formats */
185 Lisp_Object Qformat_decode
, Qformat_annotate_function
;
187 /* Function to be called to decide a coding system of a reading file. */
188 Lisp_Object Vset_auto_coding_function
;
190 /* Functions to be called to process text properties in inserted file. */
191 Lisp_Object Vafter_insert_file_functions
;
193 /* Functions to be called to create text property annotations for file. */
194 Lisp_Object Vwrite_region_annotate_functions
;
196 /* During build_annotations, each time an annotation function is called,
197 this holds the annotations made by the previous functions. */
198 Lisp_Object Vwrite_region_annotations_so_far
;
200 /* File name in which we write a list of all our auto save files. */
201 Lisp_Object Vauto_save_list_file_name
;
203 /* Nonzero means, when reading a filename in the minibuffer,
204 start out by inserting the default directory into the minibuffer. */
205 int insert_default_directory
;
207 /* On VMS, nonzero means write new files with record format stmlf.
208 Zero means use var format. */
211 /* On NT, specifies the directory separator character, used (eg.) when
212 expanding file names. This can be bound to / or \. */
213 Lisp_Object Vdirectory_sep_char
;
215 extern Lisp_Object Vuser_login_name
;
218 extern Lisp_Object Vw32_get_true_file_attributes
;
221 extern int minibuf_level
;
223 extern int minibuffer_auto_raise
;
225 /* These variables describe handlers that have "already" had a chance
226 to handle the current operation.
228 Vinhibit_file_name_handlers is a list of file name handlers.
229 Vinhibit_file_name_operation is the operation being handled.
230 If we try to handle that operation, we ignore those handlers. */
232 static Lisp_Object Vinhibit_file_name_handlers
;
233 static Lisp_Object Vinhibit_file_name_operation
;
235 Lisp_Object Qfile_error
, Qfile_already_exists
, Qfile_date_error
;
237 Lisp_Object Qfile_name_history
;
239 Lisp_Object Qcar_less_than_car
;
241 static int a_write
P_ ((int, Lisp_Object
, int, int,
242 Lisp_Object
*, struct coding_system
*));
243 static int e_write
P_ ((int, Lisp_Object
, int, int, struct coding_system
*));
247 report_file_error (string
, data
)
251 Lisp_Object errstring
;
254 synchronize_system_messages_locale ();
255 errstring
= code_convert_string_norecord (build_string (strerror (errorno
)),
256 Vlocale_coding_system
, 0);
262 Fsignal (Qfile_already_exists
, Fcons (errstring
, data
));
265 /* System error messages are capitalized. Downcase the initial
266 unless it is followed by a slash. */
267 if (XSTRING (errstring
)->data
[1] != '/')
268 XSTRING (errstring
)->data
[0] = DOWNCASE (XSTRING (errstring
)->data
[0]);
270 Fsignal (Qfile_error
,
271 Fcons (build_string (string
), Fcons (errstring
, data
)));
276 close_file_unwind (fd
)
279 emacs_close (XFASTINT (fd
));
283 /* Restore point, having saved it as a marker. */
286 restore_point_unwind (location
)
287 Lisp_Object location
;
289 Fgoto_char (location
);
290 Fset_marker (location
, Qnil
, Qnil
);
294 Lisp_Object Qexpand_file_name
;
295 Lisp_Object Qsubstitute_in_file_name
;
296 Lisp_Object Qdirectory_file_name
;
297 Lisp_Object Qfile_name_directory
;
298 Lisp_Object Qfile_name_nondirectory
;
299 Lisp_Object Qunhandled_file_name_directory
;
300 Lisp_Object Qfile_name_as_directory
;
301 Lisp_Object Qcopy_file
;
302 Lisp_Object Qmake_directory_internal
;
303 Lisp_Object Qmake_directory
;
304 Lisp_Object Qdelete_directory
;
305 Lisp_Object Qdelete_file
;
306 Lisp_Object Qrename_file
;
307 Lisp_Object Qadd_name_to_file
;
308 Lisp_Object Qmake_symbolic_link
;
309 Lisp_Object Qfile_exists_p
;
310 Lisp_Object Qfile_executable_p
;
311 Lisp_Object Qfile_readable_p
;
312 Lisp_Object Qfile_writable_p
;
313 Lisp_Object Qfile_symlink_p
;
314 Lisp_Object Qaccess_file
;
315 Lisp_Object Qfile_directory_p
;
316 Lisp_Object Qfile_regular_p
;
317 Lisp_Object Qfile_accessible_directory_p
;
318 Lisp_Object Qfile_modes
;
319 Lisp_Object Qset_file_modes
;
320 Lisp_Object Qfile_newer_than_file_p
;
321 Lisp_Object Qinsert_file_contents
;
322 Lisp_Object Qwrite_region
;
323 Lisp_Object Qverify_visited_file_modtime
;
324 Lisp_Object Qset_visited_file_modtime
;
326 DEFUN ("find-file-name-handler", Ffind_file_name_handler
, Sfind_file_name_handler
, 2, 2, 0,
327 "Return FILENAME's handler function for OPERATION, if it has one.\n\
328 Otherwise, return nil.\n\
329 A file name is handled if one of the regular expressions in\n\
330 `file-name-handler-alist' matches it.\n\n\
331 If OPERATION equals `inhibit-file-name-operation', then we ignore\n\
332 any handlers that are members of `inhibit-file-name-handlers',\n\
333 but we still do run any other handlers. This lets handlers\n\
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 "Return the directory component in file name FILENAME.\n\
376 Return nil if FILENAME does not include a directory.\n\
377 Otherwise return a directory spec.\n\
378 Given a Unix syntax file name, returns a string ending in slash;\n\
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 "Return file name FILENAME sans its directory.\n\
453 For example, in a Unix-syntax file name,\n\
454 this is everything after the last slash,\n\
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 "Return a directly usable directory name somehow associated with FILENAME.\n\
494 A `directly usable' directory name is one that may be used without the\n\
495 intervention of any file handler.\n\
496 If FILENAME is a directly usable file itself, return\n\
497 \(file-name-directory FILENAME).\n\
498 The `call-process' and `start-process' functions use this function to\n\
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 "Return a string representing file FILENAME interpreted as a directory.\n\
605 This operation exists because a directory is also a file, but its name as\n\
606 a directory is different from its name as a file.\n\
607 The result can be used as the value of `default-directory'\n\
608 or passed as second argument to `expand-file-name'.\n\
609 For a Unix-syntax file name, just appends a slash.\n\
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 "Returns the file name of the directory named DIRECTORY.\n\
796 This is the name of the file that holds the data for the directory DIRECTORY.\n\
797 This operation exists because a directory is also a file, but its name as\n\
798 a directory is different from its name as a file.\n\
799 In Unix-syntax, this function just removes the final slash.\n\
800 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
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 `%s'",
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 "Generate temporary file name (string) starting with PREFIX (a string).\n\
967 The Emacs process number forms part of the result,\n\
968 so there is no danger of generating a name being used by another process.\n\
970 In addition, this function makes an attempt to choose a name\n\
971 which has no existing file. To make this work,\n\
972 PREFIX should be an absolute file name.\n\
974 There is a race condition between calling `make-temp-name' and creating the\n\
975 file which opens all kinds of security holes. For that reason, you should\n\
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 "Convert filename NAME to absolute, and canonicalize it.\n\
987 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative\n\
988 (does not start with slash); if DEFAULT-DIRECTORY is nil or missing,\n\
989 the current buffer's value of default-directory is used.\n\
990 File name components that are `.' are removed, and \n\
991 so are file name components followed by `..', along with the `..' itself;\n\
992 note that these simplifications are done without checking the resulting\n\
993 file names in the file system.\n\
994 An initial `~/' expands to your home directory.\n\
995 An initial `~USER/' expands to USER's home directory.\n\
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 /../ sequences; if none are
1129 found, we can probably return right away. We will avoid allocating
1130 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])
1170 /* if dev:[dir]/, move nm to / */
1171 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1172 nm
= (brack
? brack
+ 1 : colon
+ 1);
1173 lbrack
= rbrack
= 0;
1181 /* VMS pre V4.4,convert '-'s in filenames. */
1182 if (lbrack
== rbrack
)
1184 if (dots
< 2) /* this is to allow negative version numbers */
1189 if (lbrack
> rbrack
&&
1190 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1191 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1197 /* count open brackets, reset close bracket pointer */
1198 if (p
[0] == '[' || p
[0] == '<')
1199 lbrack
++, brack
= 0;
1200 /* count close brackets, set close bracket pointer */
1201 if (p
[0] == ']' || p
[0] == '>')
1202 rbrack
++, brack
= p
;
1203 /* detect ][ or >< */
1204 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1206 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1207 nm
= p
+ 1, lose
= 1;
1208 if (p
[0] == ':' && (colon
|| slash
))
1209 /* if dev1:[dir]dev2:, move nm to dev2: */
1215 /* if /name/dev:, move nm to dev: */
1218 /* if node::dev:, move colon following dev */
1219 else if (colon
&& colon
[-1] == ':')
1221 /* if dev1:dev2:, move nm to dev2: */
1222 else if (colon
&& colon
[-1] != ':')
1227 if (p
[0] == ':' && !colon
)
1233 if (lbrack
== rbrack
)
1236 else if (p
[0] == '.')
1244 if (index (nm
, '/'))
1245 return build_string (sys_translate_unix (nm
));
1248 /* Make sure directories are all separated with / or \ as
1249 desired, but avoid allocation of a new string when not
1251 CORRECT_DIR_SEPS (nm
);
1253 if (IS_DIRECTORY_SEP (nm
[1]))
1255 if (strcmp (nm
, XSTRING (name
)->data
) != 0)
1256 name
= build_string (nm
);
1260 /* drive must be set, so this is okay */
1261 if (strcmp (nm
- 2, XSTRING (name
)->data
) != 0)
1263 name
= make_string (nm
- 2, p
- nm
+ 2);
1264 XSTRING (name
)->data
[0] = DRIVE_LETTER (drive
);
1265 XSTRING (name
)->data
[1] = ':';
1268 #else /* not DOS_NT */
1269 if (nm
== XSTRING (name
)->data
)
1271 return build_string (nm
);
1272 #endif /* not DOS_NT */
1276 /* At this point, nm might or might not be an absolute file name. We
1277 need to expand ~ or ~user if present, otherwise prefix nm with
1278 default_directory if nm is not absolute, and finally collapse /./
1279 and /foo/../ sequences.
1281 We set newdir to be the appropriate prefix if one is needed:
1282 - the relevant user directory if nm starts with ~ or ~user
1283 - the specified drive's working dir (DOS/NT only) if nm does not
1285 - the value of default_directory.
1287 Note that these prefixes are not guaranteed to be absolute (except
1288 for the working dir of a drive). Therefore, to ensure we always
1289 return an absolute name, if the final prefix is not absolute we
1290 append it to the current working directory. */
1294 if (nm
[0] == '~') /* prefix ~ */
1296 if (IS_DIRECTORY_SEP (nm
[1])
1300 || nm
[1] == 0) /* ~ by itself */
1302 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1303 newdir
= (unsigned char *) "";
1306 collapse_newdir
= 0;
1309 nm
++; /* Don't leave the slash in nm. */
1312 else /* ~user/filename */
1314 for (p
= nm
; *p
&& (!IS_DIRECTORY_SEP (*p
)
1319 o
= (unsigned char *) alloca (p
- nm
+ 1);
1320 bcopy ((char *) nm
, o
, p
- nm
);
1323 pw
= (struct passwd
*) getpwnam (o
+ 1);
1326 newdir
= (unsigned char *) pw
-> pw_dir
;
1328 nm
= p
+ 1; /* skip the terminator */
1332 collapse_newdir
= 0;
1337 /* If we don't find a user of that name, leave the name
1338 unchanged; don't move nm forward to p. */
1343 /* On DOS and Windows, nm is absolute if a drive name was specified;
1344 use the drive's current directory as the prefix if needed. */
1345 if (!newdir
&& drive
)
1347 /* Get default directory if needed to make nm absolute. */
1348 if (!IS_DIRECTORY_SEP (nm
[0]))
1350 newdir
= alloca (MAXPATHLEN
+ 1);
1351 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1356 /* Either nm starts with /, or drive isn't mounted. */
1357 newdir
= alloca (4);
1358 newdir
[0] = DRIVE_LETTER (drive
);
1366 /* Finally, if no prefix has been specified and nm is not absolute,
1367 then it must be expanded relative to default_directory. */
1371 /* /... alone is not absolute on DOS and Windows. */
1372 && !IS_DIRECTORY_SEP (nm
[0])
1375 && !(IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1382 newdir
= XSTRING (default_directory
)->data
;
1384 /* Note if special escape prefix is present, but remove for now. */
1385 if (newdir
[0] == '/' && newdir
[1] == ':')
1396 /* First ensure newdir is an absolute name. */
1398 /* Detect MSDOS file names with drive specifiers. */
1399 ! (IS_DRIVE (newdir
[0])
1400 && IS_DEVICE_SEP (newdir
[1]) && IS_DIRECTORY_SEP (newdir
[2]))
1402 /* Detect Windows file names in UNC format. */
1403 && ! (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1407 /* Effectively, let newdir be (expand-file-name newdir cwd).
1408 Because of the admonition against calling expand-file-name
1409 when we have pointers into lisp strings, we accomplish this
1410 indirectly by prepending newdir to nm if necessary, and using
1411 cwd (or the wd of newdir's drive) as the new newdir. */
1413 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1418 if (!IS_DIRECTORY_SEP (nm
[0]))
1420 char * tmp
= alloca (strlen (newdir
) + strlen (nm
) + 2);
1421 file_name_as_directory (tmp
, newdir
);
1425 newdir
= alloca (MAXPATHLEN
+ 1);
1428 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1435 /* Strip off drive name from prefix, if present. */
1436 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1442 /* Keep only a prefix from newdir if nm starts with slash
1443 (//server/share for UNC, nothing otherwise). */
1444 if (IS_DIRECTORY_SEP (nm
[0]) && collapse_newdir
)
1447 if (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1449 newdir
= strcpy (alloca (strlen (newdir
) + 1), newdir
);
1451 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1453 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1465 /* Get rid of any slash at the end of newdir, unless newdir is
1466 just / or // (an incomplete UNC name). */
1467 length
= strlen (newdir
);
1468 if (length
> 1 && IS_DIRECTORY_SEP (newdir
[length
- 1])
1470 && !(length
== 2 && IS_DIRECTORY_SEP (newdir
[0]))
1474 unsigned char *temp
= (unsigned char *) alloca (length
);
1475 bcopy (newdir
, temp
, length
- 1);
1476 temp
[length
- 1] = 0;
1484 /* Now concatenate the directory and name to new space in the stack frame */
1485 tlen
+= strlen (nm
) + 1;
1487 /* Reserve space for drive specifier and escape prefix, since either
1488 or both may need to be inserted. (The Microsoft x86 compiler
1489 produces incorrect code if the following two lines are combined.) */
1490 target
= (unsigned char *) alloca (tlen
+ 4);
1492 #else /* not DOS_NT */
1493 target
= (unsigned char *) alloca (tlen
);
1494 #endif /* not DOS_NT */
1500 if (nm
[0] == 0 || IS_DIRECTORY_SEP (nm
[0]))
1503 /* If newdir is effectively "C:/", then the drive letter will have
1504 been stripped and newdir will be "/". Concatenating with an
1505 absolute directory in nm produces "//", which will then be
1506 incorrectly treated as a network share. Ignore newdir in
1507 this case (keeping the drive letter). */
1508 if (!(drive
&& nm
[0] && IS_DIRECTORY_SEP (newdir
[0])
1509 && newdir
[1] == '\0'))
1511 strcpy (target
, newdir
);
1515 file_name_as_directory (target
, newdir
);
1518 strcat (target
, nm
);
1520 if (index (target
, '/'))
1521 strcpy (target
, sys_translate_unix (target
));
1524 /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */
1526 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1534 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1540 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1541 /* brackets are offset from each other by 2 */
1544 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1545 /* convert [foo][bar] to [bar] */
1546 while (o
[-1] != '[' && o
[-1] != '<')
1548 else if (*p
== '-' && *o
!= '.')
1551 else if (p
[0] == '-' && o
[-1] == '.' &&
1552 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1553 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1557 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1558 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1560 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1562 /* else [foo.-] ==> [-] */
1568 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1569 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1575 if (!IS_DIRECTORY_SEP (*p
))
1579 else if (IS_DIRECTORY_SEP (p
[0])
1581 && (IS_DIRECTORY_SEP (p
[2])
1584 /* If "/." is the entire filename, keep the "/". Otherwise,
1585 just delete the whole "/.". */
1586 if (o
== target
&& p
[2] == '\0')
1590 else if (IS_DIRECTORY_SEP (p
[0]) && p
[1] == '.' && p
[2] == '.'
1591 /* `/../' is the "superroot" on certain file systems. */
1593 && (IS_DIRECTORY_SEP (p
[3]) || p
[3] == 0))
1595 while (o
!= target
&& (--o
) && !IS_DIRECTORY_SEP (*o
))
1597 /* Keep initial / only if this is the whole name. */
1598 if (o
== target
&& IS_ANY_SEP (*o
) && p
[3] == 0)
1606 #endif /* not VMS */
1610 /* At last, set drive name. */
1612 /* Except for network file name. */
1613 if (!(IS_DIRECTORY_SEP (target
[0]) && IS_DIRECTORY_SEP (target
[1])))
1614 #endif /* WINDOWSNT */
1616 if (!drive
) abort ();
1618 target
[0] = DRIVE_LETTER (drive
);
1621 /* Reinsert the escape prefix if required. */
1628 CORRECT_DIR_SEPS (target
);
1631 return make_string (target
, o
- target
);
1635 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'. */
1636 DEAFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
1637 "Convert FILENAME to absolute, and canonicalize it.\n\
1638 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1639 (does not start with slash); if DEFAULT is nil or missing,\n\
1640 the current buffer's value of default-directory is used.\n\
1641 Filenames containing `.' or `..' as components are simplified;\n\
1642 initial `~/' expands to your home directory.\n\
1643 See also the function `substitute-in-file-name'.")
1645 Lisp_Object name
, defalt
;
1649 register unsigned char *newdir
, *p
, *o
;
1651 unsigned char *target
;
1655 unsigned char * colon
= 0;
1656 unsigned char * close
= 0;
1657 unsigned char * slash
= 0;
1658 unsigned char * brack
= 0;
1659 int lbrack
= 0, rbrack
= 0;
1663 CHECK_STRING (name
, 0);
1666 /* Filenames on VMS are always upper case. */
1667 name
= Fupcase (name
);
1670 nm
= XSTRING (name
)->data
;
1672 /* If nm is absolute, flush ...// and detect /./ and /../.
1673 If no /./ or /../ we can return right away. */
1685 if (p
[0] == '/' && p
[1] == '/'
1687 /* // at start of filename is meaningful on Apollo system. */
1692 if (p
[0] == '/' && p
[1] == '~')
1693 nm
= p
+ 1, lose
= 1;
1694 if (p
[0] == '/' && p
[1] == '.'
1695 && (p
[2] == '/' || p
[2] == 0
1696 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1702 /* if dev:[dir]/, move nm to / */
1703 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1704 nm
= (brack
? brack
+ 1 : colon
+ 1);
1705 lbrack
= rbrack
= 0;
1713 /* VMS pre V4.4,convert '-'s in filenames. */
1714 if (lbrack
== rbrack
)
1716 if (dots
< 2) /* this is to allow negative version numbers */
1721 if (lbrack
> rbrack
&&
1722 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1723 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1729 /* count open brackets, reset close bracket pointer */
1730 if (p
[0] == '[' || p
[0] == '<')
1731 lbrack
++, brack
= 0;
1732 /* count close brackets, set close bracket pointer */
1733 if (p
[0] == ']' || p
[0] == '>')
1734 rbrack
++, brack
= p
;
1735 /* detect ][ or >< */
1736 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1738 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1739 nm
= p
+ 1, lose
= 1;
1740 if (p
[0] == ':' && (colon
|| slash
))
1741 /* if dev1:[dir]dev2:, move nm to dev2: */
1747 /* If /name/dev:, move nm to dev: */
1750 /* If node::dev:, move colon following dev */
1751 else if (colon
&& colon
[-1] == ':')
1753 /* If dev1:dev2:, move nm to dev2: */
1754 else if (colon
&& colon
[-1] != ':')
1759 if (p
[0] == ':' && !colon
)
1765 if (lbrack
== rbrack
)
1768 else if (p
[0] == '.')
1776 if (index (nm
, '/'))
1777 return build_string (sys_translate_unix (nm
));
1779 if (nm
== XSTRING (name
)->data
)
1781 return build_string (nm
);
1785 /* Now determine directory to start with and put it in NEWDIR */
1789 if (nm
[0] == '~') /* prefix ~ */
1794 || nm
[1] == 0)/* ~/filename */
1796 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1797 newdir
= (unsigned char *) "";
1800 nm
++; /* Don't leave the slash in nm. */
1803 else /* ~user/filename */
1805 /* Get past ~ to user */
1806 unsigned char *user
= nm
+ 1;
1807 /* Find end of name. */
1808 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1809 int len
= ptr
? ptr
- user
: strlen (user
);
1811 unsigned char *ptr1
= index (user
, ':');
1812 if (ptr1
!= 0 && ptr1
- user
< len
)
1815 /* Copy the user name into temp storage. */
1816 o
= (unsigned char *) alloca (len
+ 1);
1817 bcopy ((char *) user
, o
, len
);
1820 /* Look up the user name. */
1821 pw
= (struct passwd
*) getpwnam (o
+ 1);
1823 error ("\"%s\" isn't a registered user", o
+ 1);
1825 newdir
= (unsigned char *) pw
->pw_dir
;
1827 /* Discard the user name from NM. */
1834 #endif /* not VMS */
1838 defalt
= current_buffer
->directory
;
1839 CHECK_STRING (defalt
, 1);
1840 newdir
= XSTRING (defalt
)->data
;
1843 /* Now concatenate the directory and name to new space in the stack frame */
1845 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1846 target
= (unsigned char *) alloca (tlen
);
1852 if (nm
[0] == 0 || nm
[0] == '/')
1853 strcpy (target
, newdir
);
1856 file_name_as_directory (target
, newdir
);
1859 strcat (target
, nm
);
1861 if (index (target
, '/'))
1862 strcpy (target
, sys_translate_unix (target
));
1865 /* Now canonicalize by removing /. and /foo/.. if they appear */
1873 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1879 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1880 /* brackets are offset from each other by 2 */
1883 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1884 /* convert [foo][bar] to [bar] */
1885 while (o
[-1] != '[' && o
[-1] != '<')
1887 else if (*p
== '-' && *o
!= '.')
1890 else if (p
[0] == '-' && o
[-1] == '.' &&
1891 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1892 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1896 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1897 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1899 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1901 /* else [foo.-] ==> [-] */
1907 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1908 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1918 else if (!strncmp (p
, "//", 2)
1920 /* // at start of filename is meaningful in Apollo system. */
1928 else if (p
[0] == '/' && p
[1] == '.' &&
1929 (p
[2] == '/' || p
[2] == 0))
1931 else if (!strncmp (p
, "/..", 3)
1932 /* `/../' is the "superroot" on certain file systems. */
1934 && (p
[3] == '/' || p
[3] == 0))
1936 while (o
!= target
&& *--o
!= '/')
1939 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1943 if (o
== target
&& *o
== '/')
1951 #endif /* not VMS */
1954 return make_string (target
, o
- target
);
1958 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1959 Ssubstitute_in_file_name
, 1, 1, 0,
1960 "Substitute environment variables referred to in FILENAME.\n\
1961 `$FOO' where FOO is an environment variable name means to substitute\n\
1962 the value of that variable. The variable name should be terminated\n\
1963 with a character not a letter, digit or underscore; otherwise, enclose\n\
1964 the entire variable name in braces.\n\
1965 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1966 On VMS, `$' substitution is not done; this function does little and only\n\
1967 duplicates what `expand-file-name' does.")
1969 Lisp_Object filename
;
1973 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1974 unsigned char *target
;
1976 int substituted
= 0;
1978 Lisp_Object handler
;
1980 CHECK_STRING (filename
, 0);
1982 /* If the file name has special constructs in it,
1983 call the corresponding file handler. */
1984 handler
= Ffind_file_name_handler (filename
, Qsubstitute_in_file_name
);
1985 if (!NILP (handler
))
1986 return call2 (handler
, Qsubstitute_in_file_name
, filename
);
1988 nm
= XSTRING (filename
)->data
;
1990 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
1991 CORRECT_DIR_SEPS (nm
);
1992 substituted
= (strcmp (nm
, XSTRING (filename
)->data
) != 0);
1994 endp
= nm
+ STRING_BYTES (XSTRING (filename
));
1996 /* If /~ or // appears, discard everything through first slash. */
1998 for (p
= nm
; p
!= endp
; p
++)
2001 #if defined (APOLLO) || defined (WINDOWSNT)
2002 /* // at start of file name is meaningful in Apollo and
2003 WindowsNT systems. */
2004 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != nm
)
2005 #else /* not (APOLLO || WINDOWSNT) */
2006 || IS_DIRECTORY_SEP (p
[0])
2007 #endif /* not (APOLLO || WINDOWSNT) */
2012 || p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>'
2014 || IS_DIRECTORY_SEP (p
[-1])))
2020 /* see comment in expand-file-name about drive specifiers */
2021 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
2022 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
2031 return build_string (nm
);
2034 /* See if any variables are substituted into the string
2035 and find the total length of their values in `total' */
2037 for (p
= nm
; p
!= endp
;)
2047 /* "$$" means a single "$" */
2056 while (p
!= endp
&& *p
!= '}') p
++;
2057 if (*p
!= '}') goto missingclose
;
2063 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
2067 /* Copy out the variable name */
2068 target
= (unsigned char *) alloca (s
- o
+ 1);
2069 strncpy (target
, o
, s
- o
);
2072 strupr (target
); /* $home == $HOME etc. */
2075 /* Get variable value */
2076 o
= (unsigned char *) egetenv (target
);
2077 if (!o
) goto badvar
;
2078 total
+= strlen (o
);
2085 /* If substitution required, recopy the string and do it */
2086 /* Make space in stack frame for the new copy */
2087 xnm
= (unsigned char *) alloca (STRING_BYTES (XSTRING (filename
)) + total
+ 1);
2090 /* Copy the rest of the name through, replacing $ constructs with values */
2107 while (p
!= endp
&& *p
!= '}') p
++;
2108 if (*p
!= '}') goto missingclose
;
2114 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
2118 /* Copy out the variable name */
2119 target
= (unsigned char *) alloca (s
- o
+ 1);
2120 strncpy (target
, o
, s
- o
);
2123 strupr (target
); /* $home == $HOME etc. */
2126 /* Get variable value */
2127 o
= (unsigned char *) egetenv (target
);
2131 if (STRING_MULTIBYTE (filename
))
2133 /* If the original string is multibyte,
2134 convert what we substitute into multibyte. */
2137 int c
= unibyte_char_to_multibyte (*o
++);
2138 x
+= CHAR_STRING (c
, x
);
2150 /* If /~ or // appears, discard everything through first slash. */
2152 for (p
= xnm
; p
!= x
; p
++)
2154 #if defined (APOLLO) || defined (WINDOWSNT)
2155 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != xnm
)
2156 #else /* not (APOLLO || WINDOWSNT) */
2157 || IS_DIRECTORY_SEP (p
[0])
2158 #endif /* not (APOLLO || WINDOWSNT) */
2160 && p
!= xnm
&& IS_DIRECTORY_SEP (p
[-1]))
2163 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
2164 && p
> xnm
&& IS_DIRECTORY_SEP (p
[-1]))
2168 if (STRING_MULTIBYTE (filename
))
2169 return make_string (xnm
, x
- xnm
);
2170 return make_unibyte_string (xnm
, x
- xnm
);
2173 error ("Bad format environment-variable substitution");
2175 error ("Missing \"}\" in environment-variable substitution");
2177 error ("Substituting nonexistent environment variable \"%s\"", target
);
2180 #endif /* not VMS */
2183 /* A slightly faster and more convenient way to get
2184 (directory-file-name (expand-file-name FOO)). */
2187 expand_and_dir_to_file (filename
, defdir
)
2188 Lisp_Object filename
, defdir
;
2190 register Lisp_Object absname
;
2192 absname
= Fexpand_file_name (filename
, defdir
);
2195 register int c
= XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
)) - 1];
2196 if (c
== ':' || c
== ']' || c
== '>')
2197 absname
= Fdirectory_file_name (absname
);
2200 /* Remove final slash, if any (unless this is the root dir).
2201 stat behaves differently depending! */
2202 if (XSTRING (absname
)->size
> 1
2203 && IS_DIRECTORY_SEP (XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
)) - 1])
2204 && !IS_DEVICE_SEP (XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
))-2]))
2205 /* We cannot take shortcuts; they might be wrong for magic file names. */
2206 absname
= Fdirectory_file_name (absname
);
2211 /* Signal an error if the file ABSNAME already exists.
2212 If INTERACTIVE is nonzero, ask the user whether to proceed,
2213 and bypass the error if the user says to go ahead.
2214 QUERYSTRING is a name for the action that is being considered
2217 *STATPTR is used to store the stat information if the file exists.
2218 If the file does not exist, STATPTR->st_mode is set to 0.
2219 If STATPTR is null, we don't store into it.
2221 If QUICK is nonzero, we ask for y or n, not yes or no. */
2224 barf_or_query_if_file_exists (absname
, querystring
, interactive
, statptr
, quick
)
2225 Lisp_Object absname
;
2226 unsigned char *querystring
;
2228 struct stat
*statptr
;
2231 register Lisp_Object tem
, encoded_filename
;
2232 struct stat statbuf
;
2233 struct gcpro gcpro1
;
2235 encoded_filename
= ENCODE_FILE (absname
);
2237 /* stat is a good way to tell whether the file exists,
2238 regardless of what access permissions it has. */
2239 if (stat (XSTRING (encoded_filename
)->data
, &statbuf
) >= 0)
2242 Fsignal (Qfile_already_exists
,
2243 Fcons (build_string ("File already exists"),
2244 Fcons (absname
, Qnil
)));
2246 tem
= format1 ("File %s already exists; %s anyway? ",
2247 XSTRING (absname
)->data
, querystring
);
2249 tem
= Fy_or_n_p (tem
);
2251 tem
= do_yes_or_no_p (tem
);
2254 Fsignal (Qfile_already_exists
,
2255 Fcons (build_string ("File already exists"),
2256 Fcons (absname
, Qnil
)));
2263 statptr
->st_mode
= 0;
2268 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
2269 "fCopy file: \nFCopy %s to file: \np\nP",
2270 "Copy FILE to NEWNAME. Both args must be strings.\n\
2271 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
2272 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
2273 A number as third arg means request confirmation if NEWNAME already exists.\n\
2274 This is what happens in interactive use with M-x.\n\
2275 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
2276 last-modified time as the old one. (This works on only some systems.)\n\
2277 A prefix arg makes KEEP-TIME non-nil.")
2278 (file
, newname
, ok_if_already_exists
, keep_date
)
2279 Lisp_Object file
, newname
, ok_if_already_exists
, keep_date
;
2282 char buf
[16 * 1024];
2283 struct stat st
, out_st
;
2284 Lisp_Object handler
;
2285 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2286 int count
= specpdl_ptr
- specpdl
;
2287 int input_file_statable_p
;
2288 Lisp_Object encoded_file
, encoded_newname
;
2290 encoded_file
= encoded_newname
= Qnil
;
2291 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2292 CHECK_STRING (file
, 0);
2293 CHECK_STRING (newname
, 1);
2295 file
= Fexpand_file_name (file
, Qnil
);
2296 newname
= Fexpand_file_name (newname
, Qnil
);
2298 /* If the input file name has special constructs in it,
2299 call the corresponding file handler. */
2300 handler
= Ffind_file_name_handler (file
, Qcopy_file
);
2301 /* Likewise for output file name. */
2303 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
2304 if (!NILP (handler
))
2305 RETURN_UNGCPRO (call5 (handler
, Qcopy_file
, file
, newname
,
2306 ok_if_already_exists
, keep_date
));
2308 encoded_file
= ENCODE_FILE (file
);
2309 encoded_newname
= ENCODE_FILE (newname
);
2311 if (NILP (ok_if_already_exists
)
2312 || INTEGERP (ok_if_already_exists
))
2313 barf_or_query_if_file_exists (encoded_newname
, "copy to it",
2314 INTEGERP (ok_if_already_exists
), &out_st
, 0);
2315 else if (stat (XSTRING (encoded_newname
)->data
, &out_st
) < 0)
2318 ifd
= emacs_open (XSTRING (encoded_file
)->data
, O_RDONLY
, 0);
2320 report_file_error ("Opening input file", Fcons (file
, Qnil
));
2322 record_unwind_protect (close_file_unwind
, make_number (ifd
));
2324 /* We can only copy regular files and symbolic links. Other files are not
2326 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
2328 #if !defined (DOS_NT) || __DJGPP__ > 1
2329 if (out_st
.st_mode
!= 0
2330 && st
.st_dev
== out_st
.st_dev
&& st
.st_ino
== out_st
.st_ino
)
2333 report_file_error ("Input and output files are the same",
2334 Fcons (file
, Fcons (newname
, Qnil
)));
2338 #if defined (S_ISREG) && defined (S_ISLNK)
2339 if (input_file_statable_p
)
2341 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
2343 #if defined (EISDIR)
2344 /* Get a better looking error message. */
2347 report_file_error ("Non-regular file", Fcons (file
, Qnil
));
2350 #endif /* S_ISREG && S_ISLNK */
2353 /* Create the copy file with the same record format as the input file */
2354 ofd
= sys_creat (XSTRING (encoded_newname
)->data
, 0666, ifd
);
2357 /* System's default file type was set to binary by _fmode in emacs.c. */
2358 ofd
= creat (XSTRING (encoded_newname
)->data
, S_IREAD
| S_IWRITE
);
2359 #else /* not MSDOS */
2360 ofd
= creat (XSTRING (encoded_newname
)->data
, 0666);
2361 #endif /* not MSDOS */
2364 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
2366 record_unwind_protect (close_file_unwind
, make_number (ofd
));
2370 while ((n
= emacs_read (ifd
, buf
, sizeof buf
)) > 0)
2371 if (emacs_write (ofd
, buf
, n
) != n
)
2372 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2375 /* Closing the output clobbers the file times on some systems. */
2376 if (emacs_close (ofd
) < 0)
2377 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2379 if (input_file_statable_p
)
2381 if (!NILP (keep_date
))
2383 EMACS_TIME atime
, mtime
;
2384 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
2385 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
2386 if (set_file_times (XSTRING (encoded_newname
)->data
,
2388 Fsignal (Qfile_date_error
,
2389 Fcons (build_string ("Cannot set file date"),
2390 Fcons (newname
, Qnil
)));
2393 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2395 #if defined (__DJGPP__) && __DJGPP__ > 1
2396 /* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
2397 and if it can't, it tells so. Otherwise, under MSDOS we usually
2398 get only the READ bit, which will make the copied file read-only,
2399 so it's better not to chmod at all. */
2400 if ((_djstat_flags
& _STFAIL_WRITEBIT
) == 0)
2401 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2402 #endif /* DJGPP version 2 or newer */
2408 /* Discard the unwind protects. */
2409 specpdl_ptr
= specpdl
+ count
;
2415 DEFUN ("make-directory-internal", Fmake_directory_internal
,
2416 Smake_directory_internal
, 1, 1, 0,
2417 "Create a new directory named DIRECTORY.")
2419 Lisp_Object directory
;
2422 Lisp_Object handler
;
2423 Lisp_Object encoded_dir
;
2425 CHECK_STRING (directory
, 0);
2426 directory
= Fexpand_file_name (directory
, Qnil
);
2428 handler
= Ffind_file_name_handler (directory
, Qmake_directory_internal
);
2429 if (!NILP (handler
))
2430 return call2 (handler
, Qmake_directory_internal
, directory
);
2432 encoded_dir
= ENCODE_FILE (directory
);
2434 dir
= XSTRING (encoded_dir
)->data
;
2437 if (mkdir (dir
) != 0)
2439 if (mkdir (dir
, 0777) != 0)
2441 report_file_error ("Creating directory", Flist (1, &directory
));
2446 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
2447 "Delete the directory named DIRECTORY.")
2449 Lisp_Object directory
;
2452 Lisp_Object handler
;
2453 Lisp_Object encoded_dir
;
2455 CHECK_STRING (directory
, 0);
2456 directory
= Fdirectory_file_name (Fexpand_file_name (directory
, Qnil
));
2458 handler
= Ffind_file_name_handler (directory
, Qdelete_directory
);
2459 if (!NILP (handler
))
2460 return call2 (handler
, Qdelete_directory
, directory
);
2462 encoded_dir
= ENCODE_FILE (directory
);
2464 dir
= XSTRING (encoded_dir
)->data
;
2466 if (rmdir (dir
) != 0)
2467 report_file_error ("Removing directory", Flist (1, &directory
));
2472 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
2473 "Delete file named FILENAME.\n\
2474 If file has multiple names, it continues to exist with the other names.")
2476 Lisp_Object filename
;
2478 Lisp_Object handler
;
2479 Lisp_Object encoded_file
;
2481 CHECK_STRING (filename
, 0);
2482 filename
= Fexpand_file_name (filename
, Qnil
);
2484 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
2485 if (!NILP (handler
))
2486 return call2 (handler
, Qdelete_file
, filename
);
2488 encoded_file
= ENCODE_FILE (filename
);
2490 if (0 > unlink (XSTRING (encoded_file
)->data
))
2491 report_file_error ("Removing old name", Flist (1, &filename
));
2496 internal_delete_file_1 (ignore
)
2502 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */
2505 internal_delete_file (filename
)
2506 Lisp_Object filename
;
2508 return NILP (internal_condition_case_1 (Fdelete_file
, filename
,
2509 Qt
, internal_delete_file_1
));
2512 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
2513 "fRename file: \nFRename %s to file: \np",
2514 "Rename FILE as NEWNAME. Both args strings.\n\
2515 If file has names other than FILE, it continues to have those names.\n\
2516 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2517 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2518 A number as third arg means request confirmation if NEWNAME already exists.\n\
2519 This is what happens in interactive use with M-x.")
2520 (file
, newname
, ok_if_already_exists
)
2521 Lisp_Object file
, newname
, ok_if_already_exists
;
2524 Lisp_Object args
[2];
2526 Lisp_Object handler
;
2527 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2528 Lisp_Object encoded_file
, encoded_newname
;
2530 encoded_file
= encoded_newname
= Qnil
;
2531 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2532 CHECK_STRING (file
, 0);
2533 CHECK_STRING (newname
, 1);
2534 file
= Fexpand_file_name (file
, Qnil
);
2535 newname
= Fexpand_file_name (newname
, Qnil
);
2537 /* If the file name has special constructs in it,
2538 call the corresponding file handler. */
2539 handler
= Ffind_file_name_handler (file
, Qrename_file
);
2541 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
2542 if (!NILP (handler
))
2543 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
2544 file
, newname
, ok_if_already_exists
));
2546 encoded_file
= ENCODE_FILE (file
);
2547 encoded_newname
= ENCODE_FILE (newname
);
2549 if (NILP (ok_if_already_exists
)
2550 || INTEGERP (ok_if_already_exists
))
2551 barf_or_query_if_file_exists (encoded_newname
, "rename to it",
2552 INTEGERP (ok_if_already_exists
), 0, 0);
2554 if (0 > rename (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2556 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
)
2557 || 0 > unlink (XSTRING (encoded_file
)->data
))
2562 Fcopy_file (file
, newname
,
2563 /* We have already prompted if it was an integer,
2564 so don't have copy-file prompt again. */
2565 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
2566 Fdelete_file (file
);
2573 report_file_error ("Renaming", Flist (2, args
));
2576 report_file_error ("Renaming", Flist (2, &file
));
2583 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
2584 "fAdd name to file: \nFName to add to %s: \np",
2585 "Give FILE additional name NEWNAME. Both args strings.\n\
2586 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2587 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2588 A number as third arg means request confirmation if NEWNAME already exists.\n\
2589 This is what happens in interactive use with M-x.")
2590 (file
, newname
, ok_if_already_exists
)
2591 Lisp_Object file
, newname
, ok_if_already_exists
;
2594 Lisp_Object args
[2];
2596 Lisp_Object handler
;
2597 Lisp_Object encoded_file
, encoded_newname
;
2598 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2600 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2601 encoded_file
= encoded_newname
= Qnil
;
2602 CHECK_STRING (file
, 0);
2603 CHECK_STRING (newname
, 1);
2604 file
= Fexpand_file_name (file
, Qnil
);
2605 newname
= Fexpand_file_name (newname
, Qnil
);
2607 /* If the file name has special constructs in it,
2608 call the corresponding file handler. */
2609 handler
= Ffind_file_name_handler (file
, Qadd_name_to_file
);
2610 if (!NILP (handler
))
2611 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2612 newname
, ok_if_already_exists
));
2614 /* If the new name has special constructs in it,
2615 call the corresponding file handler. */
2616 handler
= Ffind_file_name_handler (newname
, Qadd_name_to_file
);
2617 if (!NILP (handler
))
2618 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2619 newname
, ok_if_already_exists
));
2621 encoded_file
= ENCODE_FILE (file
);
2622 encoded_newname
= ENCODE_FILE (newname
);
2624 if (NILP (ok_if_already_exists
)
2625 || INTEGERP (ok_if_already_exists
))
2626 barf_or_query_if_file_exists (encoded_newname
, "make it a new name",
2627 INTEGERP (ok_if_already_exists
), 0, 0);
2629 unlink (XSTRING (newname
)->data
);
2630 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2635 report_file_error ("Adding new name", Flist (2, args
));
2637 report_file_error ("Adding new name", Flist (2, &file
));
2646 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2647 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2648 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
2649 Signals a `file-already-exists' error if a file LINKNAME already exists\n\
2650 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2651 A number as third arg means request confirmation if LINKNAME already exists.\n\
2652 This happens for interactive use with M-x.")
2653 (filename
, linkname
, ok_if_already_exists
)
2654 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2657 Lisp_Object args
[2];
2659 Lisp_Object handler
;
2660 Lisp_Object encoded_filename
, encoded_linkname
;
2661 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2663 GCPRO4 (filename
, linkname
, encoded_filename
, encoded_linkname
);
2664 encoded_filename
= encoded_linkname
= Qnil
;
2665 CHECK_STRING (filename
, 0);
2666 CHECK_STRING (linkname
, 1);
2667 /* If the link target has a ~, we must expand it to get
2668 a truly valid file name. Otherwise, do not expand;
2669 we want to permit links to relative file names. */
2670 if (XSTRING (filename
)->data
[0] == '~')
2671 filename
= Fexpand_file_name (filename
, Qnil
);
2672 linkname
= Fexpand_file_name (linkname
, Qnil
);
2674 /* If the file name has special constructs in it,
2675 call the corresponding file handler. */
2676 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2677 if (!NILP (handler
))
2678 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2679 linkname
, ok_if_already_exists
));
2681 /* If the new link name has special constructs in it,
2682 call the corresponding file handler. */
2683 handler
= Ffind_file_name_handler (linkname
, Qmake_symbolic_link
);
2684 if (!NILP (handler
))
2685 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2686 linkname
, ok_if_already_exists
));
2688 encoded_filename
= ENCODE_FILE (filename
);
2689 encoded_linkname
= ENCODE_FILE (linkname
);
2691 if (NILP (ok_if_already_exists
)
2692 || INTEGERP (ok_if_already_exists
))
2693 barf_or_query_if_file_exists (encoded_linkname
, "make it a link",
2694 INTEGERP (ok_if_already_exists
), 0, 0);
2695 if (0 > symlink (XSTRING (encoded_filename
)->data
,
2696 XSTRING (encoded_linkname
)->data
))
2698 /* If we didn't complain already, silently delete existing file. */
2699 if (errno
== EEXIST
)
2701 unlink (XSTRING (encoded_linkname
)->data
);
2702 if (0 <= symlink (XSTRING (encoded_filename
)->data
,
2703 XSTRING (encoded_linkname
)->data
))
2713 report_file_error ("Making symbolic link", Flist (2, args
));
2715 report_file_error ("Making symbolic link", Flist (2, &filename
));
2721 #endif /* S_IFLNK */
2725 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2726 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2727 "Define the job-wide logical name NAME to have the value STRING.\n\
2728 If STRING is nil or a null string, the logical name NAME is deleted.")
2733 CHECK_STRING (name
, 0);
2735 delete_logical_name (XSTRING (name
)->data
);
2738 CHECK_STRING (string
, 1);
2740 if (XSTRING (string
)->size
== 0)
2741 delete_logical_name (XSTRING (name
)->data
);
2743 define_logical_name (XSTRING (name
)->data
, XSTRING (string
)->data
);
2752 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2753 "Open a network connection to PATH using LOGIN as the login string.")
2755 Lisp_Object path
, login
;
2759 CHECK_STRING (path
, 0);
2760 CHECK_STRING (login
, 0);
2762 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2764 if (netresult
== -1)
2769 #endif /* HPUX_NET */
2771 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2773 "Return t if file FILENAME specifies an absolute file name.\n\
2774 On Unix, this is a name starting with a `/' or a `~'.")
2776 Lisp_Object filename
;
2780 CHECK_STRING (filename
, 0);
2781 ptr
= XSTRING (filename
)->data
;
2782 if (IS_DIRECTORY_SEP (*ptr
) || *ptr
== '~'
2784 /* ??? This criterion is probably wrong for '<'. */
2785 || index (ptr
, ':') || index (ptr
, '<')
2786 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2790 || (IS_DRIVE (*ptr
) && ptr
[1] == ':' && IS_DIRECTORY_SEP (ptr
[2]))
2798 /* Return nonzero if file FILENAME exists and can be executed. */
2801 check_executable (filename
)
2805 int len
= strlen (filename
);
2808 if (stat (filename
, &st
) < 0)
2810 #if defined (WINDOWSNT) || (defined (MSDOS) && __DJGPP__ > 1)
2811 return ((st
.st_mode
& S_IEXEC
) != 0);
2813 return (S_ISREG (st
.st_mode
)
2815 && (stricmp ((suffix
= filename
+ len
-4), ".com") == 0
2816 || stricmp (suffix
, ".exe") == 0
2817 || stricmp (suffix
, ".bat") == 0)
2818 || (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2819 #endif /* not WINDOWSNT */
2820 #else /* not DOS_NT */
2821 #ifdef HAVE_EUIDACCESS
2822 return (euidaccess (filename
, 1) >= 0);
2824 /* Access isn't quite right because it uses the real uid
2825 and we really want to test with the effective uid.
2826 But Unix doesn't give us a right way to do it. */
2827 return (access (filename
, 1) >= 0);
2829 #endif /* not DOS_NT */
2832 /* Return nonzero if file FILENAME exists and can be written. */
2835 check_writable (filename
)
2840 if (stat (filename
, &st
) < 0)
2842 return (st
.st_mode
& S_IWRITE
|| (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2843 #else /* not MSDOS */
2844 #ifdef HAVE_EUIDACCESS
2845 return (euidaccess (filename
, 2) >= 0);
2847 /* Access isn't quite right because it uses the real uid
2848 and we really want to test with the effective uid.
2849 But Unix doesn't give us a right way to do it.
2850 Opening with O_WRONLY could work for an ordinary file,
2851 but would lose for directories. */
2852 return (access (filename
, 2) >= 0);
2854 #endif /* not MSDOS */
2857 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2858 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
2859 See also `file-readable-p' and `file-attributes'.")
2861 Lisp_Object filename
;
2863 Lisp_Object absname
;
2864 Lisp_Object handler
;
2865 struct stat statbuf
;
2867 CHECK_STRING (filename
, 0);
2868 absname
= Fexpand_file_name (filename
, Qnil
);
2870 /* If the file name has special constructs in it,
2871 call the corresponding file handler. */
2872 handler
= Ffind_file_name_handler (absname
, Qfile_exists_p
);
2873 if (!NILP (handler
))
2874 return call2 (handler
, Qfile_exists_p
, absname
);
2876 absname
= ENCODE_FILE (absname
);
2878 return (stat (XSTRING (absname
)->data
, &statbuf
) >= 0) ? Qt
: Qnil
;
2881 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2882 "Return t if FILENAME can be executed by you.\n\
2883 For a directory, this means you can access files in that directory.")
2885 Lisp_Object filename
;
2888 Lisp_Object absname
;
2889 Lisp_Object handler
;
2891 CHECK_STRING (filename
, 0);
2892 absname
= Fexpand_file_name (filename
, Qnil
);
2894 /* If the file name has special constructs in it,
2895 call the corresponding file handler. */
2896 handler
= Ffind_file_name_handler (absname
, Qfile_executable_p
);
2897 if (!NILP (handler
))
2898 return call2 (handler
, Qfile_executable_p
, absname
);
2900 absname
= ENCODE_FILE (absname
);
2902 return (check_executable (XSTRING (absname
)->data
) ? Qt
: Qnil
);
2905 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2906 "Return t if file FILENAME exists and you can read it.\n\
2907 See also `file-exists-p' and `file-attributes'.")
2909 Lisp_Object filename
;
2911 Lisp_Object absname
;
2912 Lisp_Object handler
;
2915 struct stat statbuf
;
2917 CHECK_STRING (filename
, 0);
2918 absname
= Fexpand_file_name (filename
, Qnil
);
2920 /* If the file name has special constructs in it,
2921 call the corresponding file handler. */
2922 handler
= Ffind_file_name_handler (absname
, Qfile_readable_p
);
2923 if (!NILP (handler
))
2924 return call2 (handler
, Qfile_readable_p
, absname
);
2926 absname
= ENCODE_FILE (absname
);
2929 /* Under MS-DOS and Windows, open does not work for directories. */
2930 if (access (XSTRING (absname
)->data
, 0) == 0)
2933 #else /* not DOS_NT */
2935 #if defined (S_ISFIFO) && defined (O_NONBLOCK)
2936 /* Opening a fifo without O_NONBLOCK can wait.
2937 We don't want to wait. But we don't want to mess wth O_NONBLOCK
2938 except in the case of a fifo, on a system which handles it. */
2939 desc
= stat (XSTRING (absname
)->data
, &statbuf
);
2942 if (S_ISFIFO (statbuf
.st_mode
))
2943 flags
|= O_NONBLOCK
;
2945 desc
= emacs_open (XSTRING (absname
)->data
, flags
, 0);
2950 #endif /* not DOS_NT */
2953 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2955 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
2956 "Return t if file FILENAME can be written or created by you.")
2958 Lisp_Object filename
;
2960 Lisp_Object absname
, dir
, encoded
;
2961 Lisp_Object handler
;
2962 struct stat statbuf
;
2964 CHECK_STRING (filename
, 0);
2965 absname
= Fexpand_file_name (filename
, Qnil
);
2967 /* If the file name has special constructs in it,
2968 call the corresponding file handler. */
2969 handler
= Ffind_file_name_handler (absname
, Qfile_writable_p
);
2970 if (!NILP (handler
))
2971 return call2 (handler
, Qfile_writable_p
, absname
);
2973 encoded
= ENCODE_FILE (absname
);
2974 if (stat (XSTRING (encoded
)->data
, &statbuf
) >= 0)
2975 return (check_writable (XSTRING (encoded
)->data
)
2978 dir
= Ffile_name_directory (absname
);
2981 dir
= Fdirectory_file_name (dir
);
2985 dir
= Fdirectory_file_name (dir
);
2988 dir
= ENCODE_FILE (dir
);
2990 /* The read-only attribute of the parent directory doesn't affect
2991 whether a file or directory can be created within it. Some day we
2992 should check ACLs though, which do affect this. */
2993 if (stat (XSTRING (dir
)->data
, &statbuf
) < 0)
2995 return (statbuf
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
2997 return (check_writable (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "")
3002 DEFUN ("access-file", Faccess_file
, Saccess_file
, 2, 2, 0,
3003 "Access file FILENAME, and get an error if that does not work.\n\
3004 The second argument STRING is used in the error message.\n\
3005 If there is no error, we return nil.")
3007 Lisp_Object filename
, string
;
3009 Lisp_Object handler
, encoded_filename
;
3012 CHECK_STRING (filename
, 0);
3013 CHECK_STRING (string
, 1);
3015 /* If the file name has special constructs in it,
3016 call the corresponding file handler. */
3017 handler
= Ffind_file_name_handler (filename
, Qaccess_file
);
3018 if (!NILP (handler
))
3019 return call3 (handler
, Qaccess_file
, filename
, string
);
3021 encoded_filename
= ENCODE_FILE (filename
);
3023 fd
= emacs_open (XSTRING (encoded_filename
)->data
, O_RDONLY
, 0);
3025 report_file_error (XSTRING (string
)->data
, Fcons (filename
, Qnil
));
3031 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
3032 "Return non-nil if file FILENAME is the name of a symbolic link.\n\
3033 The value is the name of the file to which it is linked.\n\
3034 Otherwise returns nil.")
3036 Lisp_Object filename
;
3043 Lisp_Object handler
;
3045 CHECK_STRING (filename
, 0);
3046 filename
= Fexpand_file_name (filename
, Qnil
);
3048 /* If the file name has special constructs in it,
3049 call the corresponding file handler. */
3050 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
3051 if (!NILP (handler
))
3052 return call2 (handler
, Qfile_symlink_p
, filename
);
3054 filename
= ENCODE_FILE (filename
);
3059 buf
= (char *) xmalloc (bufsize
);
3060 bzero (buf
, bufsize
);
3061 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
3062 if (valsize
< bufsize
) break;
3063 /* Buffer was not long enough */
3072 val
= make_string (buf
, valsize
);
3073 if (buf
[0] == '/' && index (buf
, ':'))
3074 val
= concat2 (build_string ("/:"), val
);
3076 val
= DECODE_FILE (val
);
3078 #else /* not S_IFLNK */
3080 #endif /* not S_IFLNK */
3083 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
3084 "Return t if FILENAME names an existing directory.\n\
3085 Symbolic links to directories count as directories.\n\
3086 See `file-symlink-p' to distinguish symlinks.")
3088 Lisp_Object filename
;
3090 register Lisp_Object absname
;
3092 Lisp_Object handler
;
3094 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
3096 /* If the file name has special constructs in it,
3097 call the corresponding file handler. */
3098 handler
= Ffind_file_name_handler (absname
, Qfile_directory_p
);
3099 if (!NILP (handler
))
3100 return call2 (handler
, Qfile_directory_p
, absname
);
3102 absname
= ENCODE_FILE (absname
);
3104 if (stat (XSTRING (absname
)->data
, &st
) < 0)
3106 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
3109 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
3110 "Return t if file FILENAME is the name of a directory as a file,\n\
3111 and files in that directory can be opened by you. In order to use a\n\
3112 directory as a buffer's current directory, this predicate must return true.\n\
3113 A directory name spec may be given instead; then the value is t\n\
3114 if the directory so specified exists and really is a readable and\n\
3115 searchable directory.")
3117 Lisp_Object filename
;
3119 Lisp_Object handler
;
3121 struct gcpro gcpro1
;
3123 /* If the file name has special constructs in it,
3124 call the corresponding file handler. */
3125 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
3126 if (!NILP (handler
))
3127 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
3129 /* It's an unlikely combination, but yes we really do need to gcpro:
3130 Suppose that file-accessible-directory-p has no handler, but
3131 file-directory-p does have a handler; this handler causes a GC which
3132 relocates the string in `filename'; and finally file-directory-p
3133 returns non-nil. Then we would end up passing a garbaged string
3134 to file-executable-p. */
3136 tem
= (NILP (Ffile_directory_p (filename
))
3137 || NILP (Ffile_executable_p (filename
)));
3139 return tem
? Qnil
: Qt
;
3142 DEFUN ("file-regular-p", Ffile_regular_p
, Sfile_regular_p
, 1, 1, 0,
3143 "Return t if file FILENAME is the name of a regular file.\n\
3144 This is the sort of file that holds an ordinary stream of data bytes.")
3146 Lisp_Object filename
;
3148 register Lisp_Object absname
;
3150 Lisp_Object handler
;
3152 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
3154 /* If the file name has special constructs in it,
3155 call the corresponding file handler. */
3156 handler
= Ffind_file_name_handler (absname
, Qfile_regular_p
);
3157 if (!NILP (handler
))
3158 return call2 (handler
, Qfile_regular_p
, absname
);
3160 absname
= ENCODE_FILE (absname
);
3165 Lisp_Object tem
= Vw32_get_true_file_attributes
;
3167 /* Tell stat to use expensive method to get accurate info. */
3168 Vw32_get_true_file_attributes
= Qt
;
3169 result
= stat (XSTRING (absname
)->data
, &st
);
3170 Vw32_get_true_file_attributes
= tem
;
3174 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
3177 if (stat (XSTRING (absname
)->data
, &st
) < 0)
3179 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
3183 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
3184 "Return mode bits of file named FILENAME, as an integer.")
3186 Lisp_Object filename
;
3188 Lisp_Object absname
;
3190 Lisp_Object handler
;
3192 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
3194 /* If the file name has special constructs in it,
3195 call the corresponding file handler. */
3196 handler
= Ffind_file_name_handler (absname
, Qfile_modes
);
3197 if (!NILP (handler
))
3198 return call2 (handler
, Qfile_modes
, absname
);
3200 absname
= ENCODE_FILE (absname
);
3202 if (stat (XSTRING (absname
)->data
, &st
) < 0)
3204 #if defined (MSDOS) && __DJGPP__ < 2
3205 if (check_executable (XSTRING (absname
)->data
))
3206 st
.st_mode
|= S_IEXEC
;
3207 #endif /* MSDOS && __DJGPP__ < 2 */
3209 return make_number (st
.st_mode
& 07777);
3212 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
3213 "Set mode bits of file named FILENAME to MODE (an integer).\n\
3214 Only the 12 low bits of MODE are used.")
3216 Lisp_Object filename
, mode
;
3218 Lisp_Object absname
, encoded_absname
;
3219 Lisp_Object handler
;
3221 absname
= Fexpand_file_name (filename
, current_buffer
->directory
);
3222 CHECK_NUMBER (mode
, 1);
3224 /* If the file name has special constructs in it,
3225 call the corresponding file handler. */
3226 handler
= Ffind_file_name_handler (absname
, Qset_file_modes
);
3227 if (!NILP (handler
))
3228 return call3 (handler
, Qset_file_modes
, absname
, mode
);
3230 encoded_absname
= ENCODE_FILE (absname
);
3232 if (chmod (XSTRING (encoded_absname
)->data
, XINT (mode
)) < 0)
3233 report_file_error ("Doing chmod", Fcons (absname
, Qnil
));
3238 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
3239 "Set the file permission bits for newly created files.\n\
3240 The argument MODE should be an integer; only the low 9 bits are used.\n\
3241 This setting is inherited by subprocesses.")
3245 CHECK_NUMBER (mode
, 0);
3247 umask ((~ XINT (mode
)) & 0777);
3252 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
3253 "Return the default file protection for created files.\n\
3254 The value is an integer.")
3260 realmask
= umask (0);
3263 XSETINT (value
, (~ realmask
) & 0777);
3273 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
3274 "Tell Unix to finish all pending disk updates.")
3283 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
3284 "Return t if file FILE1 is newer than file FILE2.\n\
3285 If FILE1 does not exist, the answer is nil;\n\
3286 otherwise, if FILE2 does not exist, the answer is t.")
3288 Lisp_Object file1
, file2
;
3290 Lisp_Object absname1
, absname2
;
3293 Lisp_Object handler
;
3294 struct gcpro gcpro1
, gcpro2
;
3296 CHECK_STRING (file1
, 0);
3297 CHECK_STRING (file2
, 0);
3300 GCPRO2 (absname1
, file2
);
3301 absname1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
3302 absname2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
3305 /* If the file name has special constructs in it,
3306 call the corresponding file handler. */
3307 handler
= Ffind_file_name_handler (absname1
, Qfile_newer_than_file_p
);
3309 handler
= Ffind_file_name_handler (absname2
, Qfile_newer_than_file_p
);
3310 if (!NILP (handler
))
3311 return call3 (handler
, Qfile_newer_than_file_p
, absname1
, absname2
);
3313 GCPRO2 (absname1
, absname2
);
3314 absname1
= ENCODE_FILE (absname1
);
3315 absname2
= ENCODE_FILE (absname2
);
3318 if (stat (XSTRING (absname1
)->data
, &st
) < 0)
3321 mtime1
= st
.st_mtime
;
3323 if (stat (XSTRING (absname2
)->data
, &st
) < 0)
3326 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
3330 Lisp_Object Qfind_buffer_file_type
;
3333 #ifndef READ_BUF_SIZE
3334 #define READ_BUF_SIZE (64 << 10)
3337 extern void adjust_markers_for_delete
P_ ((int, int, int, int));
3339 /* This function is called after Lisp functions to decide a coding
3340 system are called, or when they cause an error. Before they are
3341 called, the current buffer is set unibyte and it contains only a
3342 newly inserted text (thus the buffer was empty before the
3345 The functions may set markers, overlays, text properties, or even
3346 alter the buffer contents, change the current buffer.
3348 Here, we reset all those changes by:
3349 o set back the current buffer.
3350 o move all markers and overlays to BEG.
3351 o remove all text properties.
3352 o set back the buffer multibyteness. */
3355 decide_coding_unwind (unwind_data
)
3356 Lisp_Object unwind_data
;
3358 Lisp_Object multibyte
, undo_list
, buffer
;
3360 multibyte
= XCAR (unwind_data
);
3361 unwind_data
= XCDR (unwind_data
);
3362 undo_list
= XCAR (unwind_data
);
3363 buffer
= XCDR (unwind_data
);
3365 if (current_buffer
!= XBUFFER (buffer
))
3366 set_buffer_internal (XBUFFER (buffer
));
3367 adjust_markers_for_delete (BEG
, BEG_BYTE
, Z
, Z_BYTE
);
3368 adjust_overlays_for_delete (BEG
, Z
- BEG
);
3369 BUF_INTERVALS (current_buffer
) = 0;
3370 TEMP_SET_PT_BOTH (BEG
, BEG_BYTE
);
3372 /* Now we are safe to change the buffer's multibyteness directly. */
3373 current_buffer
->enable_multibyte_characters
= multibyte
;
3374 current_buffer
->undo_list
= undo_list
;
3379 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
3381 "Insert contents of file FILENAME after point.\n\
3382 Returns list of absolute file name and number of bytes inserted.\n\
3383 If second argument VISIT is non-nil, the buffer's visited filename\n\
3384 and last save file modtime are set, and it is marked unmodified.\n\
3385 If visiting and the file does not exist, visiting is completed\n\
3386 before the error is signaled.\n\
3387 The optional third and fourth arguments BEG and END\n\
3388 specify what portion of the file to insert.\n\
3389 These arguments count bytes in the file, not characters in the buffer.\n\
3390 If VISIT is non-nil, BEG and END must be nil.\n\
3392 If optional fifth argument REPLACE is non-nil,\n\
3393 it means replace the current buffer contents (in the accessible portion)\n\
3394 with the file contents. This is better than simply deleting and inserting\n\
3395 the whole thing because (1) it preserves some marker positions\n\
3396 and (2) it puts less data in the undo list.\n\
3397 When REPLACE is non-nil, the value is the number of characters actually read,\n\
3398 which is often less than the number of characters to be read.\n\
3400 This does code conversion according to the value of\n\
3401 `coding-system-for-read' or `file-coding-system-alist',\n\
3402 and sets the variable `last-coding-system-used' to the coding system\n\
3404 (filename
, visit
, beg
, end
, replace
)
3405 Lisp_Object filename
, visit
, beg
, end
, replace
;
3410 register int how_much
;
3411 register int unprocessed
;
3412 int count
= specpdl_ptr
- specpdl
;
3413 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3414 Lisp_Object handler
, val
, insval
, orig_filename
;
3417 int not_regular
= 0;
3418 unsigned char read_buf
[READ_BUF_SIZE
];
3419 struct coding_system coding
;
3420 unsigned char buffer
[1 << 14];
3421 int replace_handled
= 0;
3422 int set_coding_system
= 0;
3423 int coding_system_decided
= 0;
3425 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3426 error ("Cannot do file visiting in an indirect buffer");
3428 if (!NILP (current_buffer
->read_only
))
3429 Fbarf_if_buffer_read_only ();
3433 orig_filename
= Qnil
;
3435 GCPRO4 (filename
, val
, p
, orig_filename
);
3437 CHECK_STRING (filename
, 0);
3438 filename
= Fexpand_file_name (filename
, Qnil
);
3440 /* If the file name has special constructs in it,
3441 call the corresponding file handler. */
3442 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
3443 if (!NILP (handler
))
3445 val
= call6 (handler
, Qinsert_file_contents
, filename
,
3446 visit
, beg
, end
, replace
);
3447 if (CONSP (val
) && CONSP (XCDR (val
)))
3448 inserted
= XINT (XCAR (XCDR (val
)));
3452 orig_filename
= filename
;
3453 filename
= ENCODE_FILE (filename
);
3459 Lisp_Object tem
= Vw32_get_true_file_attributes
;
3461 /* Tell stat to use expensive method to get accurate info. */
3462 Vw32_get_true_file_attributes
= Qt
;
3463 total
= stat (XSTRING (filename
)->data
, &st
);
3464 Vw32_get_true_file_attributes
= tem
;
3469 if (stat (XSTRING (filename
)->data
, &st
) < 0)
3471 if ((fd
= emacs_open (XSTRING (filename
)->data
, O_RDONLY
, 0)) < 0
3472 || fstat (fd
, &st
) < 0)
3473 #endif /* not APOLLO */
3474 #endif /* WINDOWSNT */
3476 if (fd
>= 0) emacs_close (fd
);
3479 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3482 if (!NILP (Vcoding_system_for_read
))
3483 Fset (Qbuffer_file_coding_system
, Vcoding_system_for_read
);
3488 /* This code will need to be changed in order to work on named
3489 pipes, and it's probably just not worth it. So we should at
3490 least signal an error. */
3491 if (!S_ISREG (st
.st_mode
))
3498 if (! NILP (replace
) || ! NILP (beg
) || ! NILP (end
))
3499 Fsignal (Qfile_error
,
3500 Fcons (build_string ("not a regular file"),
3501 Fcons (orig_filename
, Qnil
)));
3506 if ((fd
= emacs_open (XSTRING (filename
)->data
, O_RDONLY
, 0)) < 0)
3509 /* Replacement should preserve point as it preserves markers. */
3510 if (!NILP (replace
))
3511 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
3513 record_unwind_protect (close_file_unwind
, make_number (fd
));
3515 /* Supposedly happens on VMS. */
3516 if (! not_regular
&& st
.st_size
< 0)
3517 error ("File size is negative");
3519 /* Prevent redisplay optimizations. */
3520 current_buffer
->clip_changed
= 1;
3524 if (!NILP (beg
) || !NILP (end
))
3525 error ("Attempt to visit less than an entire file");
3526 if (BEG
< Z
&& NILP (replace
))
3527 error ("Cannot do file visiting in a non-empty buffer");
3531 CHECK_NUMBER (beg
, 0);
3533 XSETFASTINT (beg
, 0);
3536 CHECK_NUMBER (end
, 0);
3541 XSETINT (end
, st
.st_size
);
3543 /* Arithmetic overflow can occur if an Emacs integer cannot
3544 represent the file size, or if the calculations below
3545 overflow. The calculations below double the file size
3546 twice, so check that it can be multiplied by 4 safely. */
3547 if (XINT (end
) != st
.st_size
3548 || ((int) st
.st_size
* 4) / 4 != st
.st_size
)
3549 error ("Maximum buffer size exceeded");
3555 /* Decide the coding system to use for reading the file now
3556 because we can't use an optimized method for handling
3557 `coding:' tag if the current buffer is not empty. */
3561 if (!NILP (Vcoding_system_for_read
))
3562 val
= Vcoding_system_for_read
;
3563 else if (! NILP (replace
))
3564 /* In REPLACE mode, we can use the same coding system
3565 that was used to visit the file. */
3566 val
= current_buffer
->buffer_file_coding_system
;
3569 /* Don't try looking inside a file for a coding system
3570 specification if it is not seekable. */
3571 if (! not_regular
&& ! NILP (Vset_auto_coding_function
))
3573 /* Find a coding system specified in the heading two
3574 lines or in the tailing several lines of the file.
3575 We assume that the 1K-byte and 3K-byte for heading
3576 and tailing respectively are sufficient for this
3580 if (st
.st_size
<= (1024 * 4))
3581 nread
= emacs_read (fd
, read_buf
, 1024 * 4);
3584 nread
= emacs_read (fd
, read_buf
, 1024);
3587 if (lseek (fd
, st
.st_size
- (1024 * 3), 0) < 0)
3588 report_file_error ("Setting file position",
3589 Fcons (orig_filename
, Qnil
));
3590 nread
+= emacs_read (fd
, read_buf
+ nread
, 1024 * 3);
3595 error ("IO error reading %s: %s",
3596 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3599 struct buffer
*prev
= current_buffer
;
3602 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
3604 /* The call to temp_output_buffer_setup binds
3606 count1
= specpdl_ptr
- specpdl
;
3607 temp_output_buffer_setup (" *code-converting-work*");
3609 set_buffer_internal (XBUFFER (Vstandard_output
));
3610 current_buffer
->enable_multibyte_characters
= Qnil
;
3611 insert_1_both (read_buf
, nread
, nread
, 0, 0, 0);
3612 TEMP_SET_PT_BOTH (BEG
, BEG_BYTE
);
3613 val
= call2 (Vset_auto_coding_function
,
3614 filename
, make_number (nread
));
3615 set_buffer_internal (prev
);
3617 /* Remove the binding for standard-output. */
3618 unbind_to (count1
, Qnil
);
3620 /* Discard the unwind protect for recovering the
3624 /* Rewind the file for the actual read done later. */
3625 if (lseek (fd
, 0, 0) < 0)
3626 report_file_error ("Setting file position",
3627 Fcons (orig_filename
, Qnil
));
3633 /* If we have not yet decided a coding system, check
3634 file-coding-system-alist. */
3635 Lisp_Object args
[6], coding_systems
;
3637 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
;
3638 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = replace
;
3639 coding_systems
= Ffind_operation_coding_system (6, args
);
3640 if (CONSP (coding_systems
))
3641 val
= XCAR (coding_systems
);
3645 setup_coding_system (Fcheck_coding_system (val
), &coding
);
3646 /* Ensure we set Vlast_coding_system_used. */
3647 set_coding_system
= 1;
3649 if (NILP (current_buffer
->enable_multibyte_characters
)
3651 /* We must suppress all character code conversion except for
3652 end-of-line conversion. */
3653 setup_raw_text_coding_system (&coding
);
3655 coding
.src_multibyte
= 0;
3656 coding
.dst_multibyte
3657 = !NILP (current_buffer
->enable_multibyte_characters
);
3658 coding_system_decided
= 1;
3661 /* If requested, replace the accessible part of the buffer
3662 with the file contents. Avoid replacing text at the
3663 beginning or end of the buffer that matches the file contents;
3664 that preserves markers pointing to the unchanged parts.
3666 Here we implement this feature in an optimized way
3667 for the case where code conversion is NOT needed.
3668 The following if-statement handles the case of conversion
3669 in a less optimal way.
3671 If the code conversion is "automatic" then we try using this
3672 method and hope for the best.
3673 But if we discover the need for conversion, we give up on this method
3674 and let the following if-statement handle the replace job. */
3677 && !(coding
.common_flags
& CODING_REQUIRE_DECODING_MASK
))
3679 /* same_at_start and same_at_end count bytes,
3680 because file access counts bytes
3681 and BEG and END count bytes. */
3682 int same_at_start
= BEGV_BYTE
;
3683 int same_at_end
= ZV_BYTE
;
3685 /* There is still a possibility we will find the need to do code
3686 conversion. If that happens, we set this variable to 1 to
3687 give up on handling REPLACE in the optimized way. */
3688 int giveup_match_end
= 0;
3690 if (XINT (beg
) != 0)
3692 if (lseek (fd
, XINT (beg
), 0) < 0)
3693 report_file_error ("Setting file position",
3694 Fcons (orig_filename
, Qnil
));
3699 /* Count how many chars at the start of the file
3700 match the text at the beginning of the buffer. */
3705 nread
= emacs_read (fd
, buffer
, sizeof buffer
);
3707 error ("IO error reading %s: %s",
3708 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3709 else if (nread
== 0)
3712 if (coding
.type
== coding_type_undecided
)
3713 detect_coding (&coding
, buffer
, nread
);
3714 if (coding
.common_flags
& CODING_REQUIRE_DECODING_MASK
)
3715 /* We found that the file should be decoded somehow.
3716 Let's give up here. */
3718 giveup_match_end
= 1;
3722 if (coding
.eol_type
== CODING_EOL_UNDECIDED
)
3723 detect_eol (&coding
, buffer
, nread
);
3724 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3725 && coding
.eol_type
!= CODING_EOL_LF
)
3726 /* We found that the format of eol should be decoded.
3727 Let's give up here. */
3729 giveup_match_end
= 1;
3734 while (bufpos
< nread
&& same_at_start
< ZV_BYTE
3735 && FETCH_BYTE (same_at_start
) == buffer
[bufpos
])
3736 same_at_start
++, bufpos
++;
3737 /* If we found a discrepancy, stop the scan.
3738 Otherwise loop around and scan the next bufferful. */
3739 if (bufpos
!= nread
)
3743 /* If the file matches the buffer completely,
3744 there's no need to replace anything. */
3745 if (same_at_start
- BEGV_BYTE
== XINT (end
))
3749 /* Truncate the buffer to the size of the file. */
3750 del_range_1 (same_at_start
, same_at_end
, 0, 0);
3755 /* Count how many chars at the end of the file
3756 match the text at the end of the buffer. But, if we have
3757 already found that decoding is necessary, don't waste time. */
3758 while (!giveup_match_end
)
3760 int total_read
, nread
, bufpos
, curpos
, trial
;
3762 /* At what file position are we now scanning? */
3763 curpos
= XINT (end
) - (ZV_BYTE
- same_at_end
);
3764 /* If the entire file matches the buffer tail, stop the scan. */
3767 /* How much can we scan in the next step? */
3768 trial
= min (curpos
, sizeof buffer
);
3769 if (lseek (fd
, curpos
- trial
, 0) < 0)
3770 report_file_error ("Setting file position",
3771 Fcons (orig_filename
, Qnil
));
3774 while (total_read
< trial
)
3776 nread
= emacs_read (fd
, buffer
+ total_read
, trial
- total_read
);
3778 error ("IO error reading %s: %s",
3779 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3780 total_read
+= nread
;
3782 /* Scan this bufferful from the end, comparing with
3783 the Emacs buffer. */
3784 bufpos
= total_read
;
3785 /* Compare with same_at_start to avoid counting some buffer text
3786 as matching both at the file's beginning and at the end. */
3787 while (bufpos
> 0 && same_at_end
> same_at_start
3788 && FETCH_BYTE (same_at_end
- 1) == buffer
[bufpos
- 1])
3789 same_at_end
--, bufpos
--;
3791 /* If we found a discrepancy, stop the scan.
3792 Otherwise loop around and scan the preceding bufferful. */
3795 /* If this discrepancy is because of code conversion,
3796 we cannot use this method; giveup and try the other. */
3797 if (same_at_end
> same_at_start
3798 && FETCH_BYTE (same_at_end
- 1) >= 0200
3799 && ! NILP (current_buffer
->enable_multibyte_characters
)
3800 && (CODING_MAY_REQUIRE_DECODING (&coding
)))
3801 giveup_match_end
= 1;
3807 if (! giveup_match_end
)
3811 /* We win! We can handle REPLACE the optimized way. */
3813 /* Extend the start of non-matching text area to multibyte
3814 character boundary. */
3815 if (! NILP (current_buffer
->enable_multibyte_characters
))
3816 while (same_at_start
> BEGV_BYTE
3817 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start
)))
3820 /* Extend the end of non-matching text area to multibyte
3821 character boundary. */
3822 if (! NILP (current_buffer
->enable_multibyte_characters
))
3823 while (same_at_end
< ZV_BYTE
3824 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
3827 /* Don't try to reuse the same piece of text twice. */
3828 overlap
= (same_at_start
- BEGV_BYTE
3829 - (same_at_end
+ st
.st_size
- ZV
));
3831 same_at_end
+= overlap
;
3833 /* Arrange to read only the nonmatching middle part of the file. */
3834 XSETFASTINT (beg
, XINT (beg
) + (same_at_start
- BEGV_BYTE
));
3835 XSETFASTINT (end
, XINT (end
) - (ZV_BYTE
- same_at_end
));
3837 del_range_byte (same_at_start
, same_at_end
, 0);
3838 /* Insert from the file at the proper position. */
3839 temp
= BYTE_TO_CHAR (same_at_start
);
3840 SET_PT_BOTH (temp
, same_at_start
);
3842 /* If display currently starts at beginning of line,
3843 keep it that way. */
3844 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3845 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3847 replace_handled
= 1;
3851 /* If requested, replace the accessible part of the buffer
3852 with the file contents. Avoid replacing text at the
3853 beginning or end of the buffer that matches the file contents;
3854 that preserves markers pointing to the unchanged parts.
3856 Here we implement this feature for the case where code conversion
3857 is needed, in a simple way that needs a lot of memory.
3858 The preceding if-statement handles the case of no conversion
3859 in a more optimized way. */
3860 if (!NILP (replace
) && ! replace_handled
&& BEGV
< ZV
)
3862 int same_at_start
= BEGV_BYTE
;
3863 int same_at_end
= ZV_BYTE
;
3866 /* Make sure that the gap is large enough. */
3867 int bufsize
= 2 * st
.st_size
;
3868 unsigned char *conversion_buffer
= (unsigned char *) xmalloc (bufsize
);
3871 /* First read the whole file, performing code conversion into
3872 CONVERSION_BUFFER. */
3874 if (lseek (fd
, XINT (beg
), 0) < 0)
3876 xfree (conversion_buffer
);
3877 report_file_error ("Setting file position",
3878 Fcons (orig_filename
, Qnil
));
3881 total
= st
.st_size
; /* Total bytes in the file. */
3882 how_much
= 0; /* Bytes read from file so far. */
3883 inserted
= 0; /* Bytes put into CONVERSION_BUFFER so far. */
3884 unprocessed
= 0; /* Bytes not processed in previous loop. */
3886 while (how_much
< total
)
3888 /* try is reserved in some compilers (Microsoft C) */
3889 int trytry
= min (total
- how_much
, READ_BUF_SIZE
- unprocessed
);
3890 unsigned char *destination
= read_buf
+ unprocessed
;
3893 /* Allow quitting out of the actual I/O. */
3896 this = emacs_read (fd
, destination
, trytry
);
3899 if (this < 0 || this + unprocessed
== 0)
3907 if (CODING_MAY_REQUIRE_DECODING (&coding
))
3909 int require
, result
;
3911 this += unprocessed
;
3913 /* If we are using more space than estimated,
3914 make CONVERSION_BUFFER bigger. */
3915 require
= decoding_buffer_size (&coding
, this);
3916 if (inserted
+ require
+ 2 * (total
- how_much
) > bufsize
)
3918 bufsize
= inserted
+ require
+ 2 * (total
- how_much
);
3919 conversion_buffer
= (unsigned char *) xrealloc (conversion_buffer
, bufsize
);
3922 /* Convert this batch with results in CONVERSION_BUFFER. */
3923 if (how_much
>= total
) /* This is the last block. */
3924 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
3925 result
= decode_coding (&coding
, read_buf
,
3926 conversion_buffer
+ inserted
,
3927 this, bufsize
- inserted
);
3929 /* Save for next iteration whatever we didn't convert. */
3930 unprocessed
= this - coding
.consumed
;
3931 bcopy (read_buf
+ coding
.consumed
, read_buf
, unprocessed
);
3932 if (!NILP (current_buffer
->enable_multibyte_characters
))
3933 this = coding
.produced
;
3935 this = str_as_unibyte (conversion_buffer
+ inserted
,
3942 /* At this point, INSERTED is how many characters (i.e. bytes)
3943 are present in CONVERSION_BUFFER.
3944 HOW_MUCH should equal TOTAL,
3945 or should be <= 0 if we couldn't read the file. */
3949 xfree (conversion_buffer
);
3952 error ("IO error reading %s: %s",
3953 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3954 else if (how_much
== -2)
3955 error ("maximum buffer size exceeded");
3958 /* Compare the beginning of the converted file
3959 with the buffer text. */
3962 while (bufpos
< inserted
&& same_at_start
< same_at_end
3963 && FETCH_BYTE (same_at_start
) == conversion_buffer
[bufpos
])
3964 same_at_start
++, bufpos
++;
3966 /* If the file matches the buffer completely,
3967 there's no need to replace anything. */
3969 if (bufpos
== inserted
)
3971 xfree (conversion_buffer
);
3974 /* Truncate the buffer to the size of the file. */
3975 del_range_byte (same_at_start
, same_at_end
, 0);
3980 /* Extend the start of non-matching text area to multibyte
3981 character boundary. */
3982 if (! NILP (current_buffer
->enable_multibyte_characters
))
3983 while (same_at_start
> BEGV_BYTE
3984 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start
)))
3987 /* Scan this bufferful from the end, comparing with
3988 the Emacs buffer. */
3991 /* Compare with same_at_start to avoid counting some buffer text
3992 as matching both at the file's beginning and at the end. */
3993 while (bufpos
> 0 && same_at_end
> same_at_start
3994 && FETCH_BYTE (same_at_end
- 1) == conversion_buffer
[bufpos
- 1])
3995 same_at_end
--, bufpos
--;
3997 /* Extend the end of non-matching text area to multibyte
3998 character boundary. */
3999 if (! NILP (current_buffer
->enable_multibyte_characters
))
4000 while (same_at_end
< ZV_BYTE
4001 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
4004 /* Don't try to reuse the same piece of text twice. */
4005 overlap
= same_at_start
- BEGV_BYTE
- (same_at_end
+ inserted
- ZV_BYTE
);
4007 same_at_end
+= overlap
;
4009 /* If display currently starts at beginning of line,
4010 keep it that way. */
4011 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
4012 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
4014 /* Replace the chars that we need to replace,
4015 and update INSERTED to equal the number of bytes
4016 we are taking from the file. */
4017 inserted
-= (Z_BYTE
- same_at_end
) + (same_at_start
- BEG_BYTE
);
4019 if (same_at_end
!= same_at_start
)
4021 del_range_byte (same_at_start
, same_at_end
, 0);
4023 same_at_start
= GPT_BYTE
;
4027 temp
= BYTE_TO_CHAR (same_at_start
);
4029 /* Insert from the file at the proper position. */
4030 SET_PT_BOTH (temp
, same_at_start
);
4031 insert_1 (conversion_buffer
+ same_at_start
- BEG_BYTE
, inserted
,
4033 /* Set `inserted' to the number of inserted characters. */
4034 inserted
= PT
- temp
;
4036 free (conversion_buffer
);
4045 register Lisp_Object temp
;
4047 total
= XINT (end
) - XINT (beg
);
4049 /* Make sure point-max won't overflow after this insertion. */
4050 XSETINT (temp
, total
);
4051 if (total
!= XINT (temp
))
4052 error ("Maximum buffer size exceeded");
4055 /* For a special file, all we can do is guess. */
4056 total
= READ_BUF_SIZE
;
4058 if (NILP (visit
) && total
> 0)
4059 prepare_to_modify_buffer (PT
, PT
, NULL
);
4062 if (GAP_SIZE
< total
)
4063 make_gap (total
- GAP_SIZE
);
4065 if (XINT (beg
) != 0 || !NILP (replace
))
4067 if (lseek (fd
, XINT (beg
), 0) < 0)
4068 report_file_error ("Setting file position",
4069 Fcons (orig_filename
, Qnil
));
4072 /* In the following loop, HOW_MUCH contains the total bytes read so
4073 far for a regular file, and not changed for a special file. But,
4074 before exiting the loop, it is set to a negative value if I/O
4077 /* Total bytes inserted. */
4079 /* Here, we don't do code conversion in the loop. It is done by
4080 code_convert_region after all data are read into the buffer. */
4081 while (how_much
< total
)
4083 /* try is reserved in some compilers (Microsoft C) */
4084 int trytry
= min (total
- how_much
, READ_BUF_SIZE
);
4087 /* For a special file, GAP_SIZE should be checked every time. */
4088 if (not_regular
&& GAP_SIZE
< trytry
)
4089 make_gap (total
- GAP_SIZE
);
4091 /* Allow quitting out of the actual I/O. */
4094 this = emacs_read (fd
, BYTE_POS_ADDR (PT_BYTE
+ inserted
- 1) + 1,
4112 /* For a regular file, where TOTAL is the real size,
4113 count HOW_MUCH to compare with it.
4114 For a special file, where TOTAL is just a buffer size,
4115 so don't bother counting in HOW_MUCH.
4116 (INSERTED is where we count the number of characters inserted.) */
4123 /* Put an anchor to ensure multi-byte form ends at gap. */
4128 /* Discard the unwind protect for closing the file. */
4132 error ("IO error reading %s: %s",
4133 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
4137 if (! coding_system_decided
)
4139 /* The coding system is not yet decided. Decide it by an
4140 optimized method for handling `coding:' tag.
4142 Note that we can get here only if the buffer was empty
4143 before the insertion. */
4147 if (!NILP (Vcoding_system_for_read
))
4148 val
= Vcoding_system_for_read
;
4151 /* Since we are sure that the current buffer was empty
4152 before the insertion, we can toggle
4153 enable-multibyte-characters directly here without taking
4154 care of marker adjustment and byte combining problem. By
4155 this way, we can run Lisp program safely before decoding
4156 the inserted text. */
4157 Lisp_Object unwind_data
;
4158 int count
= specpdl_ptr
- specpdl
;
4160 unwind_data
= Fcons (current_buffer
->enable_multibyte_characters
,
4161 Fcons (current_buffer
->undo_list
,
4162 Fcurrent_buffer ()));
4163 current_buffer
->enable_multibyte_characters
= Qnil
;
4164 current_buffer
->undo_list
= Qt
;
4165 record_unwind_protect (decide_coding_unwind
, unwind_data
);
4167 if (inserted
> 0 && ! NILP (Vset_auto_coding_function
))
4169 val
= call2 (Vset_auto_coding_function
,
4170 filename
, make_number (inserted
));
4175 /* If the coding system is not yet decided, check
4176 file-coding-system-alist. */
4177 Lisp_Object args
[6], coding_systems
;
4179 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
;
4180 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = Qnil
;
4181 coding_systems
= Ffind_operation_coding_system (6, args
);
4182 if (CONSP (coding_systems
))
4183 val
= XCAR (coding_systems
);
4186 unbind_to (count
, Qnil
);
4187 inserted
= Z_BYTE
- BEG_BYTE
;
4190 /* The following kludgy code is to avoid some compiler bug.
4192 setup_coding_system (val, &coding);
4195 struct coding_system temp_coding
;
4196 setup_coding_system (val
, &temp_coding
);
4197 bcopy (&temp_coding
, &coding
, sizeof coding
);
4199 /* Ensure we set Vlast_coding_system_used. */
4200 set_coding_system
= 1;
4202 if (NILP (current_buffer
->enable_multibyte_characters
)
4204 /* We must suppress all character code conversion except for
4205 end-of-line conversion. */
4206 setup_raw_text_coding_system (&coding
);
4210 && (coding
.type
== coding_type_no_conversion
4211 || coding
.type
== coding_type_raw_text
))
4213 /* Visiting a file with these coding system always make the buffer
4215 current_buffer
->enable_multibyte_characters
= Qnil
;
4216 coding
.dst_multibyte
= 0;
4219 if (inserted
> 0 || coding
.type
== coding_type_ccl
)
4221 if (CODING_MAY_REQUIRE_DECODING (&coding
))
4223 code_convert_region (PT
, PT_BYTE
, PT
+ inserted
, PT_BYTE
+ inserted
,
4225 inserted
= coding
.produced_char
;
4228 adjust_after_insert (PT
, PT_BYTE
, PT
+ inserted
, PT_BYTE
+ inserted
,
4233 /* Use the conversion type to determine buffer-file-type
4234 (find-buffer-file-type is now used to help determine the
4236 if ((coding
.eol_type
== CODING_EOL_UNDECIDED
4237 || coding
.eol_type
== CODING_EOL_LF
)
4238 && ! CODING_REQUIRE_DECODING (&coding
))
4239 current_buffer
->buffer_file_type
= Qt
;
4241 current_buffer
->buffer_file_type
= Qnil
;
4248 if (!EQ (current_buffer
->undo_list
, Qt
))
4249 current_buffer
->undo_list
= Qnil
;
4251 stat (XSTRING (filename
)->data
, &st
);
4256 current_buffer
->modtime
= st
.st_mtime
;
4257 current_buffer
->filename
= orig_filename
;
4260 SAVE_MODIFF
= MODIFF
;
4261 current_buffer
->auto_save_modified
= MODIFF
;
4262 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4263 #ifdef CLASH_DETECTION
4266 if (!NILP (current_buffer
->file_truename
))
4267 unlock_file (current_buffer
->file_truename
);
4268 unlock_file (filename
);
4270 #endif /* CLASH_DETECTION */
4272 Fsignal (Qfile_error
,
4273 Fcons (build_string ("not a regular file"),
4274 Fcons (orig_filename
, Qnil
)));
4277 /* Decode file format */
4280 insval
= call3 (Qformat_decode
,
4281 Qnil
, make_number (inserted
), visit
);
4282 CHECK_NUMBER (insval
, 0);
4283 inserted
= XFASTINT (insval
);
4286 if (set_coding_system
)
4287 Vlast_coding_system_used
= coding
.symbol
;
4289 /* Call after-change hooks for the inserted text, aside from the case
4290 of normal visiting (not with REPLACE), which is done in a new buffer
4291 "before" the buffer is changed. */
4292 if (inserted
> 0 && total
> 0
4293 && (NILP (visit
) || !NILP (replace
)))
4295 signal_after_change (PT
, 0, inserted
);
4296 update_compositions (PT
, PT
, CHECK_BORDER
);
4299 p
= Vafter_insert_file_functions
;
4302 insval
= call1 (Fcar (p
), make_number (inserted
));
4305 CHECK_NUMBER (insval
, 0);
4306 inserted
= XFASTINT (insval
);
4313 && current_buffer
->modtime
== -1)
4315 /* If visiting nonexistent file, return nil. */
4316 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
4319 /* ??? Retval needs to be dealt with in all cases consistently. */
4321 val
= Fcons (orig_filename
,
4322 Fcons (make_number (inserted
),
4325 RETURN_UNGCPRO (unbind_to (count
, val
));
4328 static Lisp_Object build_annotations
P_ ((Lisp_Object
, Lisp_Object
,
4331 /* If build_annotations switched buffers, switch back to BUF.
4332 Kill the temporary buffer that was selected in the meantime.
4334 Since this kill only the last temporary buffer, some buffers remain
4335 not killed if build_annotations switched buffers more than once.
4339 build_annotations_unwind (buf
)
4344 if (XBUFFER (buf
) == current_buffer
)
4346 tembuf
= Fcurrent_buffer ();
4348 Fkill_buffer (tembuf
);
4352 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 7,
4353 "r\nFWrite region to file: \ni\ni\ni\np",
4354 "Write current region into specified file.\n\
4355 When called from a program, takes three arguments:\n\
4356 START, END and FILENAME. START and END are buffer positions.\n\
4357 Optional fourth argument APPEND if non-nil means\n\
4358 append to existing file contents (if any). If it is an integer,\n\
4359 seek to that offset in the file before writing.\n\
4360 Optional fifth argument VISIT if t means\n\
4361 set the last-save-file-modtime of buffer to this file's modtime\n\
4362 and mark buffer not modified.\n\
4363 If VISIT is a string, it is a second file name;\n\
4364 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
4365 VISIT is also the file name to lock and unlock for clash detection.\n\
4366 If VISIT is neither t nor nil nor a string,\n\
4367 that means do not print the \"Wrote file\" message.\n\
4368 The optional sixth arg LOCKNAME, if non-nil, specifies the name to\n\
4369 use for locking and unlocking, overriding FILENAME and VISIT.\n\
4370 The optional seventh arg MUSTBENEW, if non-nil, insists on a check\n\
4371 for an existing file with the same name. If MUSTBENEW is `excl',\n\
4372 that means to get an error if the file already exists; never overwrite.\n\
4373 If MUSTBENEW is neither nil nor `excl', that means ask for\n\
4374 confirmation before overwriting, but do go ahead and overwrite the file\n\
4375 if the user confirms.\n\
4376 Kludgy feature: if START is a string, then that string is written\n\
4377 to the file, instead of any buffer contents, and END is ignored.\n\
4379 This does code conversion according to the value of\n\
4380 `coding-system-for-write', `buffer-file-coding-system', or\n\
4381 `file-coding-system-alist', and sets the variable\n\
4382 `last-coding-system-used' to the coding system actually used.")
4384 (start
, end
, filename
, append
, visit
, lockname
, mustbenew
)
4385 Lisp_Object start
, end
, filename
, append
, visit
, lockname
, mustbenew
;
4393 int count
= specpdl_ptr
- specpdl
;
4396 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
4398 Lisp_Object handler
;
4399 Lisp_Object visit_file
;
4400 Lisp_Object annotations
;
4401 Lisp_Object encoded_filename
;
4402 int visiting
, quietly
;
4403 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
4404 struct buffer
*given_buffer
;
4406 int buffer_file_type
= O_BINARY
;
4408 struct coding_system coding
;
4410 if (current_buffer
->base_buffer
&& ! NILP (visit
))
4411 error ("Cannot do file visiting in an indirect buffer");
4413 if (!NILP (start
) && !STRINGP (start
))
4414 validate_region (&start
, &end
);
4416 GCPRO4 (start
, filename
, visit
, lockname
);
4418 /* Decide the coding-system to encode the data with. */
4424 else if (!NILP (Vcoding_system_for_write
))
4425 val
= Vcoding_system_for_write
;
4428 /* If the variable `buffer-file-coding-system' is set locally,
4429 it means that the file was read with some kind of code
4430 conversion or the varialbe is explicitely set by users. We
4431 had better write it out with the same coding system even if
4432 `enable-multibyte-characters' is nil.
4434 If it is not set locally, we anyway have to convert EOL
4435 format if the default value of `buffer-file-coding-system'
4436 tells that it is not Unix-like (LF only) format. */
4437 int using_default_coding
= 0;
4438 int force_raw_text
= 0;
4440 val
= current_buffer
->buffer_file_coding_system
;
4442 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4445 if (NILP (current_buffer
->enable_multibyte_characters
))
4451 /* Check file-coding-system-alist. */
4452 Lisp_Object args
[7], coding_systems
;
4454 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4455 args
[3] = filename
; args
[4] = append
; args
[5] = visit
;
4457 coding_systems
= Ffind_operation_coding_system (7, args
);
4458 if (CONSP (coding_systems
) && !NILP (XCDR (coding_systems
)))
4459 val
= XCDR (coding_systems
);
4463 && !NILP (current_buffer
->buffer_file_coding_system
))
4465 /* If we still have not decided a coding system, use the
4466 default value of buffer-file-coding-system. */
4467 val
= current_buffer
->buffer_file_coding_system
;
4468 using_default_coding
= 1;
4472 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4473 /* Confirm that VAL can surely encode the current region. */
4474 val
= call3 (Vselect_safe_coding_system_function
, start
, end
, val
);
4476 setup_coding_system (Fcheck_coding_system (val
), &coding
);
4477 if (coding
.eol_type
== CODING_EOL_UNDECIDED
4478 && !using_default_coding
)
4480 if (! EQ (default_buffer_file_coding
.symbol
,
4481 buffer_defaults
.buffer_file_coding_system
))
4482 setup_coding_system (buffer_defaults
.buffer_file_coding_system
,
4483 &default_buffer_file_coding
);
4484 if (default_buffer_file_coding
.eol_type
!= CODING_EOL_UNDECIDED
)
4486 Lisp_Object subsidiaries
;
4488 coding
.eol_type
= default_buffer_file_coding
.eol_type
;
4489 subsidiaries
= Fget (coding
.symbol
, Qeol_type
);
4490 if (VECTORP (subsidiaries
)
4491 && XVECTOR (subsidiaries
)->size
== 3)
4493 = XVECTOR (subsidiaries
)->contents
[coding
.eol_type
];
4498 setup_raw_text_coding_system (&coding
);
4499 goto done_setup_coding
;
4502 setup_coding_system (Fcheck_coding_system (val
), &coding
);
4505 if (!STRINGP (start
) && !NILP (current_buffer
->selective_display
))
4506 coding
.mode
|= CODING_MODE_SELECTIVE_DISPLAY
;
4509 Vlast_coding_system_used
= coding
.symbol
;
4511 filename
= Fexpand_file_name (filename
, Qnil
);
4513 if (! NILP (mustbenew
) && !EQ (mustbenew
, Qexcl
))
4514 barf_or_query_if_file_exists (filename
, "overwrite", 1, 0, 1);
4516 if (STRINGP (visit
))
4517 visit_file
= Fexpand_file_name (visit
, Qnil
);
4519 visit_file
= filename
;
4522 visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
4523 quietly
= !NILP (visit
);
4527 if (NILP (lockname
))
4528 lockname
= visit_file
;
4530 GCPRO5 (start
, filename
, annotations
, visit_file
, lockname
);
4532 /* If the file name has special constructs in it,
4533 call the corresponding file handler. */
4534 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
4535 /* If FILENAME has no handler, see if VISIT has one. */
4536 if (NILP (handler
) && STRINGP (visit
))
4537 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
4539 if (!NILP (handler
))
4542 val
= call6 (handler
, Qwrite_region
, start
, end
,
4543 filename
, append
, visit
);
4547 SAVE_MODIFF
= MODIFF
;
4548 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4549 current_buffer
->filename
= visit_file
;
4555 /* Special kludge to simplify auto-saving. */
4558 XSETFASTINT (start
, BEG
);
4559 XSETFASTINT (end
, Z
);
4562 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
4563 count1
= specpdl_ptr
- specpdl
;
4565 given_buffer
= current_buffer
;
4566 annotations
= build_annotations (start
, end
, coding
.pre_write_conversion
);
4567 if (current_buffer
!= given_buffer
)
4569 XSETFASTINT (start
, BEGV
);
4570 XSETFASTINT (end
, ZV
);
4573 #ifdef CLASH_DETECTION
4576 #if 0 /* This causes trouble for GNUS. */
4577 /* If we've locked this file for some other buffer,
4578 query before proceeding. */
4579 if (!visiting
&& EQ (Ffile_locked_p (lockname
), Qt
))
4580 call2 (intern ("ask-user-about-lock"), filename
, Vuser_login_name
);
4583 lock_file (lockname
);
4585 #endif /* CLASH_DETECTION */
4587 encoded_filename
= ENCODE_FILE (filename
);
4589 fn
= XSTRING (encoded_filename
)->data
;
4593 desc
= emacs_open (fn
, O_WRONLY
| buffer_file_type
, 0);
4594 #else /* not DOS_NT */
4595 desc
= emacs_open (fn
, O_WRONLY
, 0);
4596 #endif /* not DOS_NT */
4598 if (desc
< 0 && (NILP (append
) || errno
== ENOENT
))
4600 if (auto_saving
) /* Overwrite any previous version of autosave file */
4602 vms_truncate (fn
); /* if fn exists, truncate to zero length */
4603 desc
= emacs_open (fn
, O_RDWR
, 0);
4605 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
4606 ? XSTRING (current_buffer
->filename
)->data
: 0,
4609 else /* Write to temporary name and rename if no errors */
4611 Lisp_Object temp_name
;
4612 temp_name
= Ffile_name_directory (filename
);
4614 if (!NILP (temp_name
))
4616 temp_name
= Fmake_temp_name (concat2 (temp_name
,
4617 build_string ("$$SAVE$$")));
4618 fname
= XSTRING (filename
)->data
;
4619 fn
= XSTRING (temp_name
)->data
;
4620 desc
= creat_copy_attrs (fname
, fn
);
4623 /* If we can't open the temporary file, try creating a new
4624 version of the original file. VMS "creat" creates a
4625 new version rather than truncating an existing file. */
4628 desc
= creat (fn
, 0666);
4629 #if 0 /* This can clobber an existing file and fail to replace it,
4630 if the user runs out of space. */
4633 /* We can't make a new version;
4634 try to truncate and rewrite existing version if any. */
4636 desc
= emacs_open (fn
, O_RDWR
, 0);
4642 desc
= creat (fn
, 0666);
4646 desc
= emacs_open (fn
,
4647 O_WRONLY
| O_TRUNC
| O_CREAT
| buffer_file_type
4648 | (mustbenew
== Qexcl
? O_EXCL
: 0),
4649 S_IREAD
| S_IWRITE
);
4650 #else /* not DOS_NT */
4651 desc
= emacs_open (fn
, O_WRONLY
| O_TRUNC
| O_CREAT
4652 | (EQ (mustbenew
, Qexcl
) ? O_EXCL
: 0),
4653 auto_saving
? auto_save_mode_bits
: 0666);
4654 #endif /* not DOS_NT */
4655 #endif /* not VMS */
4659 #ifdef CLASH_DETECTION
4661 if (!auto_saving
) unlock_file (lockname
);
4663 #endif /* CLASH_DETECTION */
4665 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
4668 record_unwind_protect (close_file_unwind
, make_number (desc
));
4670 if (!NILP (append
) && !NILP (Ffile_regular_p (filename
)))
4674 if (NUMBERP (append
))
4675 ret
= lseek (desc
, XINT (append
), 1);
4677 ret
= lseek (desc
, 0, 2);
4680 #ifdef CLASH_DETECTION
4681 if (!auto_saving
) unlock_file (lockname
);
4682 #endif /* CLASH_DETECTION */
4684 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
4692 * Kludge Warning: The VMS C RTL likes to insert carriage returns
4693 * if we do writes that don't end with a carriage return. Furthermore
4694 * it cannot handle writes of more then 16K. The modified
4695 * version of "sys_write" in SYSDEP.C (see comment there) copes with
4696 * this EXCEPT for the last record (iff it doesn't end with a carriage
4697 * return). This implies that if your buffer doesn't end with a carriage
4698 * return, you get one free... tough. However it also means that if
4699 * we make two calls to sys_write (a la the following code) you can
4700 * get one at the gap as well. The easiest way to fix this (honest)
4701 * is to move the gap to the next newline (or the end of the buffer).
4706 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4707 move_gap (find_next_newline (GPT
, 1));
4709 /* Whether VMS or not, we must move the gap to the next of newline
4710 when we must put designation sequences at beginning of line. */
4711 if (INTEGERP (start
)
4712 && coding
.type
== coding_type_iso2022
4713 && coding
.flags
& CODING_FLAG_ISO_DESIGNATE_AT_BOL
4714 && GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4716 int opoint
= PT
, opoint_byte
= PT_BYTE
;
4717 scan_newline (PT
, PT_BYTE
, ZV
, ZV_BYTE
, 1, 0);
4718 move_gap_both (PT
, PT_BYTE
);
4719 SET_PT_BOTH (opoint
, opoint_byte
);
4726 if (STRINGP (start
))
4728 failure
= 0 > a_write (desc
, start
, 0, XSTRING (start
)->size
,
4729 &annotations
, &coding
);
4732 else if (XINT (start
) != XINT (end
))
4734 tem
= CHAR_TO_BYTE (XINT (start
));
4736 if (XINT (start
) < GPT
)
4738 failure
= 0 > a_write (desc
, Qnil
, XINT (start
),
4739 min (GPT
, XINT (end
)) - XINT (start
),
4740 &annotations
, &coding
);
4744 if (XINT (end
) > GPT
&& !failure
)
4746 tem
= max (XINT (start
), GPT
);
4747 failure
= 0 > a_write (desc
, Qnil
, tem
, XINT (end
) - tem
,
4748 &annotations
, &coding
);
4754 /* If file was empty, still need to write the annotations */
4755 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4756 failure
= 0 > a_write (desc
, Qnil
, XINT (end
), 0, &annotations
, &coding
);
4760 if (CODING_REQUIRE_FLUSHING (&coding
)
4761 && !(coding
.mode
& CODING_MODE_LAST_BLOCK
)
4764 /* We have to flush out a data. */
4765 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4766 failure
= 0 > e_write (desc
, Qnil
, 0, 0, &coding
);
4773 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
4774 Disk full in NFS may be reported here. */
4775 /* mib says that closing the file will try to write as fast as NFS can do
4776 it, and that means the fsync here is not crucial for autosave files. */
4777 if (!auto_saving
&& fsync (desc
) < 0)
4779 /* If fsync fails with EINTR, don't treat that as serious. */
4781 failure
= 1, save_errno
= errno
;
4785 /* Spurious "file has changed on disk" warnings have been
4786 observed on Suns as well.
4787 It seems that `close' can change the modtime, under nfs.
4789 (This has supposedly been fixed in Sunos 4,
4790 but who knows about all the other machines with NFS?) */
4793 /* On VMS and APOLLO, must do the stat after the close
4794 since closing changes the modtime. */
4797 /* Recall that #if defined does not work on VMS. */
4804 /* NFS can report a write failure now. */
4805 if (emacs_close (desc
) < 0)
4806 failure
= 1, save_errno
= errno
;
4809 /* If we wrote to a temporary name and had no errors, rename to real name. */
4813 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
4821 /* Discard the unwind protect for close_file_unwind. */
4822 specpdl_ptr
= specpdl
+ count1
;
4823 /* Restore the original current buffer. */
4824 visit_file
= unbind_to (count
, visit_file
);
4826 #ifdef CLASH_DETECTION
4828 unlock_file (lockname
);
4829 #endif /* CLASH_DETECTION */
4831 /* Do this before reporting IO error
4832 to avoid a "file has changed on disk" warning on
4833 next attempt to save. */
4835 current_buffer
->modtime
= st
.st_mtime
;
4838 error ("IO error writing %s: %s", XSTRING (filename
)->data
,
4839 emacs_strerror (save_errno
));
4843 SAVE_MODIFF
= MODIFF
;
4844 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4845 current_buffer
->filename
= visit_file
;
4846 update_mode_lines
++;
4852 message_with_string ("Wrote %s", visit_file
, 1);
4857 Lisp_Object
merge ();
4859 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
4860 "Return t if (car A) is numerically less than (car B).")
4864 return Flss (Fcar (a
), Fcar (b
));
4867 /* Build the complete list of annotations appropriate for writing out
4868 the text between START and END, by calling all the functions in
4869 write-region-annotate-functions and merging the lists they return.
4870 If one of these functions switches to a different buffer, we assume
4871 that buffer contains altered text. Therefore, the caller must
4872 make sure to restore the current buffer in all cases,
4873 as save-excursion would do. */
4876 build_annotations (start
, end
, pre_write_conversion
)
4877 Lisp_Object start
, end
, pre_write_conversion
;
4879 Lisp_Object annotations
;
4881 struct gcpro gcpro1
, gcpro2
;
4882 Lisp_Object original_buffer
;
4884 XSETBUFFER (original_buffer
, current_buffer
);
4887 p
= Vwrite_region_annotate_functions
;
4888 GCPRO2 (annotations
, p
);
4891 struct buffer
*given_buffer
= current_buffer
;
4892 Vwrite_region_annotations_so_far
= annotations
;
4893 res
= call2 (Fcar (p
), start
, end
);
4894 /* If the function makes a different buffer current,
4895 assume that means this buffer contains altered text to be output.
4896 Reset START and END from the buffer bounds
4897 and discard all previous annotations because they should have
4898 been dealt with by this function. */
4899 if (current_buffer
!= given_buffer
)
4901 XSETFASTINT (start
, BEGV
);
4902 XSETFASTINT (end
, ZV
);
4905 Flength (res
); /* Check basic validity of return value */
4906 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4910 /* Now do the same for annotation functions implied by the file-format */
4911 if (auto_saving
&& (!EQ (Vauto_save_file_format
, Qt
)))
4912 p
= Vauto_save_file_format
;
4914 p
= current_buffer
->file_format
;
4917 struct buffer
*given_buffer
= current_buffer
;
4918 Vwrite_region_annotations_so_far
= annotations
;
4919 res
= call4 (Qformat_annotate_function
, Fcar (p
), start
, end
,
4921 if (current_buffer
!= given_buffer
)
4923 XSETFASTINT (start
, BEGV
);
4924 XSETFASTINT (end
, ZV
);
4928 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4932 /* At last, do the same for the function PRE_WRITE_CONVERSION
4933 implied by the current coding-system. */
4934 if (!NILP (pre_write_conversion
))
4936 struct buffer
*given_buffer
= current_buffer
;
4937 Vwrite_region_annotations_so_far
= annotations
;
4938 res
= call2 (pre_write_conversion
, start
, end
);
4940 annotations
= (current_buffer
!= given_buffer
4942 : merge (annotations
, res
, Qcar_less_than_car
));
4949 /* Write to descriptor DESC the NCHARS chars starting at POS of STRING.
4950 If STRING is nil, POS is the character position in the current buffer.
4951 Intersperse with them the annotations from *ANNOT
4952 which fall within the range of POS to POS + NCHARS,
4953 each at its appropriate position.
4955 We modify *ANNOT by discarding elements as we use them up.
4957 The return value is negative in case of system call failure. */
4960 a_write (desc
, string
, pos
, nchars
, annot
, coding
)
4963 register int nchars
;
4966 struct coding_system
*coding
;
4970 int lastpos
= pos
+ nchars
;
4972 while (NILP (*annot
) || CONSP (*annot
))
4974 tem
= Fcar_safe (Fcar (*annot
));
4977 nextpos
= XFASTINT (tem
);
4979 /* If there are no more annotations in this range,
4980 output the rest of the range all at once. */
4981 if (! (nextpos
>= pos
&& nextpos
<= lastpos
))
4982 return e_write (desc
, string
, pos
, lastpos
, coding
);
4984 /* Output buffer text up to the next annotation's position. */
4987 if (0 > e_write (desc
, string
, pos
, nextpos
, coding
))
4991 /* Output the annotation. */
4992 tem
= Fcdr (Fcar (*annot
));
4995 if (0 > e_write (desc
, tem
, 0, XSTRING (tem
)->size
, coding
))
4998 *annot
= Fcdr (*annot
);
5003 #ifndef WRITE_BUF_SIZE
5004 #define WRITE_BUF_SIZE (16 * 1024)
5007 /* Write text in the range START and END into descriptor DESC,
5008 encoding them with coding system CODING. If STRING is nil, START
5009 and END are character positions of the current buffer, else they
5010 are indexes to the string STRING. */
5013 e_write (desc
, string
, start
, end
, coding
)
5017 struct coding_system
*coding
;
5019 register char *addr
;
5020 register int nbytes
;
5021 char buf
[WRITE_BUF_SIZE
];
5023 int require_encoding_p
;
5026 coding
->composing
= COMPOSITION_DISABLED
;
5027 if (coding
->composing
!= COMPOSITION_DISABLED
)
5028 coding_save_composition (coding
, start
, end
, string
);
5030 if (STRINGP (string
))
5032 addr
= XSTRING (string
)->data
;
5033 nbytes
= STRING_BYTES (XSTRING (string
));
5034 coding
->src_multibyte
= STRING_MULTIBYTE (string
);
5036 else if (start
< end
)
5038 /* It is assured that the gap is not in the range START and END-1. */
5039 addr
= CHAR_POS_ADDR (start
);
5040 nbytes
= CHAR_TO_BYTE (end
) - CHAR_TO_BYTE (start
);
5041 coding
->src_multibyte
5042 = !NILP (current_buffer
->enable_multibyte_characters
);
5048 coding
->src_multibyte
= 1;
5051 /* We used to have a code for handling selective display here. But,
5052 now it is handled within encode_coding. */
5057 result
= encode_coding (coding
, addr
, buf
, nbytes
, WRITE_BUF_SIZE
);
5058 if (coding
->produced
> 0)
5060 coding
->produced
-= emacs_write (desc
, buf
, coding
->produced
);
5061 if (coding
->produced
)
5067 nbytes
-= coding
->consumed
;
5068 addr
+= coding
->consumed
;
5069 if (result
== CODING_FINISH_INSUFFICIENT_SRC
5072 /* The source text ends by an incomplete multibyte form.
5073 There's no way other than write it out as is. */
5074 nbytes
-= emacs_write (desc
, addr
, nbytes
);
5083 start
+= coding
->consumed_char
;
5084 if (coding
->cmp_data
)
5085 coding_adjust_composition_offset (coding
, start
);
5088 if (coding
->cmp_data
)
5089 coding_free_composition_data (coding
);
5094 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
5095 Sverify_visited_file_modtime
, 1, 1, 0,
5096 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
5097 This means that the file has not been changed since it was visited or saved.")
5103 Lisp_Object handler
;
5104 Lisp_Object filename
;
5106 CHECK_BUFFER (buf
, 0);
5109 if (!STRINGP (b
->filename
)) return Qt
;
5110 if (b
->modtime
== 0) return Qt
;
5112 /* If the file name has special constructs in it,
5113 call the corresponding file handler. */
5114 handler
= Ffind_file_name_handler (b
->filename
,
5115 Qverify_visited_file_modtime
);
5116 if (!NILP (handler
))
5117 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
5119 filename
= ENCODE_FILE (b
->filename
);
5121 if (stat (XSTRING (filename
)->data
, &st
) < 0)
5123 /* If the file doesn't exist now and didn't exist before,
5124 we say that it isn't modified, provided the error is a tame one. */
5125 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
5130 if (st
.st_mtime
== b
->modtime
5131 /* If both are positive, accept them if they are off by one second. */
5132 || (st
.st_mtime
> 0 && b
->modtime
> 0
5133 && (st
.st_mtime
== b
->modtime
+ 1
5134 || st
.st_mtime
== b
->modtime
- 1)))
5139 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
5140 Sclear_visited_file_modtime
, 0, 0, 0,
5141 "Clear out records of last mod time of visited file.\n\
5142 Next attempt to save will certainly not complain of a discrepancy.")
5145 current_buffer
->modtime
= 0;
5149 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
5150 Svisited_file_modtime
, 0, 0, 0,
5151 "Return the current buffer's recorded visited file modification time.\n\
5152 The value is a list of the form (HIGH . LOW), like the time values\n\
5153 that `file-attributes' returns.")
5156 return long_to_cons ((unsigned long) current_buffer
->modtime
);
5159 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
5160 Sset_visited_file_modtime
, 0, 1, 0,
5161 "Update buffer's recorded modification time from the visited file's time.\n\
5162 Useful if the buffer was not read from the file normally\n\
5163 or if the file itself has been changed for some known benign reason.\n\
5164 An argument specifies the modification time value to use\n\
5165 \(instead of that of the visited file), in the form of a list\n\
5166 \(HIGH . LOW) or (HIGH LOW).")
5168 Lisp_Object time_list
;
5170 if (!NILP (time_list
))
5171 current_buffer
->modtime
= cons_to_long (time_list
);
5174 register Lisp_Object filename
;
5176 Lisp_Object handler
;
5178 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
5180 /* If the file name has special constructs in it,
5181 call the corresponding file handler. */
5182 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
5183 if (!NILP (handler
))
5184 /* The handler can find the file name the same way we did. */
5185 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
5187 filename
= ENCODE_FILE (filename
);
5189 if (stat (XSTRING (filename
)->data
, &st
) >= 0)
5190 current_buffer
->modtime
= st
.st_mtime
;
5200 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 1);
5201 Fsleep_for (make_number (1), Qnil
);
5202 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 0);
5203 Fsleep_for (make_number (1), Qnil
);
5204 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 0);
5205 Fsleep_for (make_number (1), Qnil
);
5214 /* Get visited file's mode to become the auto save file's mode. */
5215 if (! NILP (current_buffer
->filename
)
5216 && stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
5217 /* But make sure we can overwrite it later! */
5218 auto_save_mode_bits
= st
.st_mode
| 0600;
5220 auto_save_mode_bits
= 0666;
5223 Fwrite_region (Qnil
, Qnil
,
5224 current_buffer
->auto_save_file_name
,
5225 Qnil
, Qlambda
, Qnil
, Qnil
);
5229 do_auto_save_unwind (stream
) /* used as unwind-protect function */
5234 fclose ((FILE *) (XFASTINT (XCAR (stream
)) << 16
5235 | XFASTINT (XCDR (stream
))));
5240 do_auto_save_unwind_1 (value
) /* used as unwind-protect function */
5243 minibuffer_auto_raise
= XINT (value
);
5247 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
5248 "Auto-save all buffers that need it.\n\
5249 This is all buffers that have auto-saving enabled\n\
5250 and are changed since last auto-saved.\n\
5251 Auto-saving writes the buffer into a file\n\
5252 so that your editing is not lost if the system crashes.\n\
5253 This file is not the file you visited; that changes only when you save.\n\
5254 Normally we run the normal hook `auto-save-hook' before saving.\n\n\
5255 A non-nil NO-MESSAGE argument means do not print any message if successful.\n\
5256 A non-nil CURRENT-ONLY argument means save only current buffer.")
5257 (no_message
, current_only
)
5258 Lisp_Object no_message
, current_only
;
5260 struct buffer
*old
= current_buffer
, *b
;
5261 Lisp_Object tail
, buf
;
5263 int do_handled_files
;
5266 Lisp_Object lispstream
;
5267 int count
= specpdl_ptr
- specpdl
;
5268 int orig_minibuffer_auto_raise
= minibuffer_auto_raise
;
5269 int message_p
= push_message ();
5271 /* Ordinarily don't quit within this function,
5272 but don't make it impossible to quit (in case we get hung in I/O). */
5276 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
5277 point to non-strings reached from Vbuffer_alist. */
5282 if (!NILP (Vrun_hooks
))
5283 call1 (Vrun_hooks
, intern ("auto-save-hook"));
5285 if (STRINGP (Vauto_save_list_file_name
))
5287 Lisp_Object listfile
, dir
;
5289 listfile
= Fexpand_file_name (Vauto_save_list_file_name
, Qnil
);
5291 dir
= Ffile_name_directory (listfile
);
5292 if (NILP (Ffile_directory_p (dir
)))
5293 call2 (Qmake_directory
, dir
, Qt
);
5295 stream
= fopen (XSTRING (listfile
)->data
, "w");
5298 /* Arrange to close that file whether or not we get an error.
5299 Also reset auto_saving to 0. */
5300 lispstream
= Fcons (Qnil
, Qnil
);
5301 XSETFASTINT (XCAR (lispstream
), (EMACS_UINT
)stream
>> 16);
5302 XSETFASTINT (XCDR (lispstream
), (EMACS_UINT
)stream
& 0xffff);
5313 record_unwind_protect (do_auto_save_unwind
, lispstream
);
5314 record_unwind_protect (do_auto_save_unwind_1
,
5315 make_number (minibuffer_auto_raise
));
5316 minibuffer_auto_raise
= 0;
5319 /* First, save all files which don't have handlers. If Emacs is
5320 crashing, the handlers may tweak what is causing Emacs to crash
5321 in the first place, and it would be a shame if Emacs failed to
5322 autosave perfectly ordinary files because it couldn't handle some
5324 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
5325 for (tail
= Vbuffer_alist
; GC_CONSP (tail
); tail
= XCDR (tail
))
5327 buf
= XCDR (XCAR (tail
));
5330 /* Record all the buffers that have auto save mode
5331 in the special file that lists them. For each of these buffers,
5332 Record visited name (if any) and auto save name. */
5333 if (STRINGP (b
->auto_save_file_name
)
5334 && stream
!= NULL
&& do_handled_files
== 0)
5336 if (!NILP (b
->filename
))
5338 fwrite (XSTRING (b
->filename
)->data
, 1,
5339 STRING_BYTES (XSTRING (b
->filename
)), stream
);
5341 putc ('\n', stream
);
5342 fwrite (XSTRING (b
->auto_save_file_name
)->data
, 1,
5343 STRING_BYTES (XSTRING (b
->auto_save_file_name
)), stream
);
5344 putc ('\n', stream
);
5347 if (!NILP (current_only
)
5348 && b
!= current_buffer
)
5351 /* Don't auto-save indirect buffers.
5352 The base buffer takes care of it. */
5356 /* Check for auto save enabled
5357 and file changed since last auto save
5358 and file changed since last real save. */
5359 if (STRINGP (b
->auto_save_file_name
)
5360 && BUF_SAVE_MODIFF (b
) < BUF_MODIFF (b
)
5361 && b
->auto_save_modified
< BUF_MODIFF (b
)
5362 /* -1 means we've turned off autosaving for a while--see below. */
5363 && XINT (b
->save_length
) >= 0
5364 && (do_handled_files
5365 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
5368 EMACS_TIME before_time
, after_time
;
5370 EMACS_GET_TIME (before_time
);
5372 /* If we had a failure, don't try again for 20 minutes. */
5373 if (b
->auto_save_failure_time
>= 0
5374 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
5377 if ((XFASTINT (b
->save_length
) * 10
5378 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
5379 /* A short file is likely to change a large fraction;
5380 spare the user annoying messages. */
5381 && XFASTINT (b
->save_length
) > 5000
5382 /* These messages are frequent and annoying for `*mail*'. */
5383 && !EQ (b
->filename
, Qnil
)
5384 && NILP (no_message
))
5386 /* It has shrunk too much; turn off auto-saving here. */
5387 minibuffer_auto_raise
= orig_minibuffer_auto_raise
;
5388 message_with_string ("Buffer %s has shrunk a lot; auto save turned off there",
5390 minibuffer_auto_raise
= 0;
5391 /* Turn off auto-saving until there's a real save,
5392 and prevent any more warnings. */
5393 XSETINT (b
->save_length
, -1);
5394 Fsleep_for (make_number (1), Qnil
);
5397 set_buffer_internal (b
);
5398 if (!auto_saved
&& NILP (no_message
))
5399 message1 ("Auto-saving...");
5400 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
5402 b
->auto_save_modified
= BUF_MODIFF (b
);
5403 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
5404 set_buffer_internal (old
);
5406 EMACS_GET_TIME (after_time
);
5408 /* If auto-save took more than 60 seconds,
5409 assume it was an NFS failure that got a timeout. */
5410 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
5411 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
5415 /* Prevent another auto save till enough input events come in. */
5416 record_auto_save ();
5418 if (auto_saved
&& NILP (no_message
))
5422 sit_for (1, 0, 0, 0, 0);
5426 message1 ("Auto-saving...done");
5432 unbind_to (count
, Qnil
);
5436 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
5437 Sset_buffer_auto_saved
, 0, 0, 0,
5438 "Mark current buffer as auto-saved with its current text.\n\
5439 No auto-save file will be written until the buffer changes again.")
5442 current_buffer
->auto_save_modified
= MODIFF
;
5443 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
5444 current_buffer
->auto_save_failure_time
= -1;
5448 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
5449 Sclear_buffer_auto_save_failure
, 0, 0, 0,
5450 "Clear any record of a recent auto-save failure in the current buffer.")
5453 current_buffer
->auto_save_failure_time
= -1;
5457 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
5459 "Return t if buffer has been auto-saved since last read in or saved.")
5462 return (SAVE_MODIFF
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
5465 /* Reading and completing file names */
5466 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
5468 /* In the string VAL, change each $ to $$ and return the result. */
5471 double_dollars (val
)
5474 register unsigned char *old
, *new;
5478 osize
= STRING_BYTES (XSTRING (val
));
5480 /* Count the number of $ characters. */
5481 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
5482 if (*old
++ == '$') count
++;
5485 old
= XSTRING (val
)->data
;
5486 val
= make_uninit_multibyte_string (XSTRING (val
)->size
+ count
,
5488 new = XSTRING (val
)->data
;
5489 for (n
= osize
; n
> 0; n
--)
5502 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
5504 "Internal subroutine for read-file-name. Do not call this.")
5505 (string
, dir
, action
)
5506 Lisp_Object string
, dir
, action
;
5507 /* action is nil for complete, t for return list of completions,
5508 lambda for verify final value */
5510 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
5512 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
5514 CHECK_STRING (string
, 0);
5521 /* No need to protect ACTION--we only compare it with t and nil. */
5522 GCPRO5 (string
, realdir
, name
, specdir
, orig_string
);
5524 if (XSTRING (string
)->size
== 0)
5526 if (EQ (action
, Qlambda
))
5534 orig_string
= string
;
5535 string
= Fsubstitute_in_file_name (string
);
5536 changed
= NILP (Fstring_equal (string
, orig_string
));
5537 name
= Ffile_name_nondirectory (string
);
5538 val
= Ffile_name_directory (string
);
5540 realdir
= Fexpand_file_name (val
, realdir
);
5545 specdir
= Ffile_name_directory (string
);
5546 val
= Ffile_name_completion (name
, realdir
);
5551 return double_dollars (string
);
5555 if (!NILP (specdir
))
5556 val
= concat2 (specdir
, val
);
5558 return double_dollars (val
);
5561 #endif /* not VMS */
5565 if (EQ (action
, Qt
))
5566 return Ffile_name_all_completions (name
, realdir
);
5567 /* Only other case actually used is ACTION = lambda */
5569 /* Supposedly this helps commands such as `cd' that read directory names,
5570 but can someone explain how it helps them? -- RMS */
5571 if (XSTRING (name
)->size
== 0)
5574 return Ffile_exists_p (string
);
5577 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
5578 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
5579 Value is not expanded---you must call `expand-file-name' yourself.\n\
5580 Default name to DEFAULT-FILENAME if user enters a null string.\n\
5581 (If DEFAULT-FILENAME is omitted, the visited file name is used,\n\
5582 except that if INITIAL is specified, that combined with DIR is used.)\n\
5583 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
5584 Non-nil and non-t means also require confirmation after completion.\n\
5585 Fifth arg INITIAL specifies text to start with.\n\
5586 DIR defaults to current buffer's directory default.")
5587 (prompt
, dir
, default_filename
, mustmatch
, initial
)
5588 Lisp_Object prompt
, dir
, default_filename
, mustmatch
, initial
;
5590 Lisp_Object val
, insdef
, tem
;
5591 struct gcpro gcpro1
, gcpro2
;
5592 register char *homedir
;
5593 int replace_in_history
= 0;
5594 int add_to_history
= 0;
5598 dir
= current_buffer
->directory
;
5599 if (NILP (default_filename
))
5601 if (! NILP (initial
))
5602 default_filename
= Fexpand_file_name (initial
, dir
);
5604 default_filename
= current_buffer
->filename
;
5607 /* If dir starts with user's homedir, change that to ~. */
5608 homedir
= (char *) egetenv ("HOME");
5610 homedir
= strcpy (alloca (strlen (homedir
) + 1), homedir
);
5611 CORRECT_DIR_SEPS (homedir
);
5615 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5616 && IS_DIRECTORY_SEP (XSTRING (dir
)->data
[strlen (homedir
)]))
5618 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5619 STRING_BYTES (XSTRING (dir
)) - strlen (homedir
) + 1);
5620 XSTRING (dir
)->data
[0] = '~';
5622 /* Likewise for default_filename. */
5624 && STRINGP (default_filename
)
5625 && !strncmp (homedir
, XSTRING (default_filename
)->data
, strlen (homedir
))
5626 && IS_DIRECTORY_SEP (XSTRING (default_filename
)->data
[strlen (homedir
)]))
5629 = make_string (XSTRING (default_filename
)->data
+ strlen (homedir
) - 1,
5630 STRING_BYTES (XSTRING (default_filename
)) - strlen (homedir
) + 1);
5631 XSTRING (default_filename
)->data
[0] = '~';
5633 if (!NILP (default_filename
))
5635 CHECK_STRING (default_filename
, 3);
5636 default_filename
= double_dollars (default_filename
);
5639 if (insert_default_directory
&& STRINGP (dir
))
5642 if (!NILP (initial
))
5644 Lisp_Object args
[2], pos
;
5648 insdef
= Fconcat (2, args
);
5649 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
5650 insdef
= Fcons (double_dollars (insdef
), pos
);
5653 insdef
= double_dollars (insdef
);
5655 else if (STRINGP (initial
))
5656 insdef
= Fcons (double_dollars (initial
), make_number (0));
5660 count
= specpdl_ptr
- specpdl
;
5662 specbind (intern ("completion-ignore-case"), Qt
);
5665 specbind (intern ("minibuffer-completing-file-name"), Qt
);
5667 GCPRO2 (insdef
, default_filename
);
5669 #if defined (USE_MOTIF) || defined (HAVE_NTGUI)
5670 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
5674 /* If DIR contains a file name, split it. */
5676 file
= Ffile_name_nondirectory (dir
);
5677 if (XSTRING (file
)->size
&& NILP (default_filename
))
5679 default_filename
= file
;
5680 dir
= Ffile_name_directory (dir
);
5682 if (!NILP(default_filename
))
5683 default_filename
= Fexpand_file_name (default_filename
, dir
);
5684 val
= Fx_file_dialog (prompt
, dir
, default_filename
, mustmatch
);
5689 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5690 dir
, mustmatch
, insdef
,
5691 Qfile_name_history
, default_filename
, Qnil
);
5693 tem
= Fsymbol_value (Qfile_name_history
);
5694 if (CONSP (tem
) && EQ (XCAR (tem
), val
))
5695 replace_in_history
= 1;
5697 /* If Fcompleting_read returned the inserted default string itself
5698 (rather than a new string with the same contents),
5699 it has to mean that the user typed RET with the minibuffer empty.
5700 In that case, we really want to return ""
5701 so that commands such as set-visited-file-name can distinguish. */
5702 if (EQ (val
, default_filename
))
5704 /* In this case, Fcompleting_read has not added an element
5705 to the history. Maybe we should. */
5706 if (! replace_in_history
)
5709 val
= build_string ("");
5712 unbind_to (count
, Qnil
);
5715 error ("No file name specified");
5717 tem
= Fstring_equal (val
, CONSP (insdef
) ? XCAR (insdef
) : insdef
);
5719 if (!NILP (tem
) && !NILP (default_filename
))
5720 val
= default_filename
;
5721 else if (XSTRING (val
)->size
== 0 && NILP (insdef
))
5723 if (!NILP (default_filename
))
5724 val
= default_filename
;
5726 error ("No default file name");
5728 val
= Fsubstitute_in_file_name (val
);
5730 if (replace_in_history
)
5731 /* Replace what Fcompleting_read added to the history
5732 with what we will actually return. */
5733 XCAR (Fsymbol_value (Qfile_name_history
)) = double_dollars (val
);
5734 else if (add_to_history
)
5736 /* Add the value to the history--but not if it matches
5737 the last value already there. */
5738 Lisp_Object val1
= double_dollars (val
);
5739 tem
= Fsymbol_value (Qfile_name_history
);
5740 if (! CONSP (tem
) || NILP (Fequal (XCAR (tem
), val1
)))
5741 Fset (Qfile_name_history
,
5752 /* Must be set before any path manipulation is performed. */
5753 XSETFASTINT (Vdirectory_sep_char
, '/');
5760 Qexpand_file_name
= intern ("expand-file-name");
5761 Qsubstitute_in_file_name
= intern ("substitute-in-file-name");
5762 Qdirectory_file_name
= intern ("directory-file-name");
5763 Qfile_name_directory
= intern ("file-name-directory");
5764 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
5765 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
5766 Qfile_name_as_directory
= intern ("file-name-as-directory");
5767 Qcopy_file
= intern ("copy-file");
5768 Qmake_directory_internal
= intern ("make-directory-internal");
5769 Qmake_directory
= intern ("make-directory");
5770 Qdelete_directory
= intern ("delete-directory");
5771 Qdelete_file
= intern ("delete-file");
5772 Qrename_file
= intern ("rename-file");
5773 Qadd_name_to_file
= intern ("add-name-to-file");
5774 Qmake_symbolic_link
= intern ("make-symbolic-link");
5775 Qfile_exists_p
= intern ("file-exists-p");
5776 Qfile_executable_p
= intern ("file-executable-p");
5777 Qfile_readable_p
= intern ("file-readable-p");
5778 Qfile_writable_p
= intern ("file-writable-p");
5779 Qfile_symlink_p
= intern ("file-symlink-p");
5780 Qaccess_file
= intern ("access-file");
5781 Qfile_directory_p
= intern ("file-directory-p");
5782 Qfile_regular_p
= intern ("file-regular-p");
5783 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
5784 Qfile_modes
= intern ("file-modes");
5785 Qset_file_modes
= intern ("set-file-modes");
5786 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
5787 Qinsert_file_contents
= intern ("insert-file-contents");
5788 Qwrite_region
= intern ("write-region");
5789 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
5790 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
5792 staticpro (&Qexpand_file_name
);
5793 staticpro (&Qsubstitute_in_file_name
);
5794 staticpro (&Qdirectory_file_name
);
5795 staticpro (&Qfile_name_directory
);
5796 staticpro (&Qfile_name_nondirectory
);
5797 staticpro (&Qunhandled_file_name_directory
);
5798 staticpro (&Qfile_name_as_directory
);
5799 staticpro (&Qcopy_file
);
5800 staticpro (&Qmake_directory_internal
);
5801 staticpro (&Qmake_directory
);
5802 staticpro (&Qdelete_directory
);
5803 staticpro (&Qdelete_file
);
5804 staticpro (&Qrename_file
);
5805 staticpro (&Qadd_name_to_file
);
5806 staticpro (&Qmake_symbolic_link
);
5807 staticpro (&Qfile_exists_p
);
5808 staticpro (&Qfile_executable_p
);
5809 staticpro (&Qfile_readable_p
);
5810 staticpro (&Qfile_writable_p
);
5811 staticpro (&Qaccess_file
);
5812 staticpro (&Qfile_symlink_p
);
5813 staticpro (&Qfile_directory_p
);
5814 staticpro (&Qfile_regular_p
);
5815 staticpro (&Qfile_accessible_directory_p
);
5816 staticpro (&Qfile_modes
);
5817 staticpro (&Qset_file_modes
);
5818 staticpro (&Qfile_newer_than_file_p
);
5819 staticpro (&Qinsert_file_contents
);
5820 staticpro (&Qwrite_region
);
5821 staticpro (&Qverify_visited_file_modtime
);
5822 staticpro (&Qset_visited_file_modtime
);
5824 Qfile_name_history
= intern ("file-name-history");
5825 Fset (Qfile_name_history
, Qnil
);
5826 staticpro (&Qfile_name_history
);
5828 Qfile_error
= intern ("file-error");
5829 staticpro (&Qfile_error
);
5830 Qfile_already_exists
= intern ("file-already-exists");
5831 staticpro (&Qfile_already_exists
);
5832 Qfile_date_error
= intern ("file-date-error");
5833 staticpro (&Qfile_date_error
);
5834 Qexcl
= intern ("excl");
5838 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
5839 staticpro (&Qfind_buffer_file_type
);
5842 DEFVAR_LISP ("file-name-coding-system", &Vfile_name_coding_system
,
5843 "*Coding system for encoding file names.\n\
5844 If it is nil, default-file-name-coding-system (which see) is used.");
5845 Vfile_name_coding_system
= Qnil
;
5847 DEFVAR_LISP ("default-file-name-coding-system",
5848 &Vdefault_file_name_coding_system
,
5849 "Default coding system for encoding file names.\n\
5850 This variable is used only when file-name-coding-system is nil.\n\
5852 This variable is set/changed by the command set-language-environment.\n\
5853 User should not set this variable manually,\n\
5854 instead use file-name-coding-system to get a constant encoding\n\
5855 of file names regardless of the current language environment.");
5856 Vdefault_file_name_coding_system
= Qnil
;
5858 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format
,
5859 "*Format in which to write auto-save files.\n\
5860 Should be a list of symbols naming formats that are defined in `format-alist'.\n\
5861 If it is t, which is the default, auto-save files are written in the\n\
5862 same format as a regular save would use.");
5863 Vauto_save_file_format
= Qt
;
5865 Qformat_decode
= intern ("format-decode");
5866 staticpro (&Qformat_decode
);
5867 Qformat_annotate_function
= intern ("format-annotate-function");
5868 staticpro (&Qformat_annotate_function
);
5870 Qcar_less_than_car
= intern ("car-less-than-car");
5871 staticpro (&Qcar_less_than_car
);
5873 Fput (Qfile_error
, Qerror_conditions
,
5874 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
5875 Fput (Qfile_error
, Qerror_message
,
5876 build_string ("File error"));
5878 Fput (Qfile_already_exists
, Qerror_conditions
,
5879 Fcons (Qfile_already_exists
,
5880 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5881 Fput (Qfile_already_exists
, Qerror_message
,
5882 build_string ("File already exists"));
5884 Fput (Qfile_date_error
, Qerror_conditions
,
5885 Fcons (Qfile_date_error
,
5886 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5887 Fput (Qfile_date_error
, Qerror_message
,
5888 build_string ("Cannot set file date"));
5890 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
5891 "*Non-nil means when reading a filename start with default dir in minibuffer.");
5892 insert_default_directory
= 1;
5894 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
5895 "*Non-nil means write new files with record format `stmlf'.\n\
5896 nil means use format `var'. This variable is meaningful only on VMS.");
5897 vms_stmlf_recfm
= 0;
5899 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char
,
5900 "Directory separator character for built-in functions that return file names.\n\
5901 The value should be either ?/ or ?\\ (any other value is treated as ?\\).\n\
5902 This variable affects the built-in functions only on Windows,\n\
5903 on other platforms, it is initialized so that Lisp code can find out\n\
5904 what the normal separator is.");
5906 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
5907 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
5908 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
5911 The first argument given to HANDLER is the name of the I/O primitive\n\
5912 to be handled; the remaining arguments are the arguments that were\n\
5913 passed to that primitive. For example, if you do\n\
5914 (file-exists-p FILENAME)\n\
5915 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
5916 (funcall HANDLER 'file-exists-p FILENAME)\n\
5917 The function `find-file-name-handler' checks this list for a handler\n\
5918 for its argument.");
5919 Vfile_name_handler_alist
= Qnil
;
5921 DEFVAR_LISP ("set-auto-coding-function",
5922 &Vset_auto_coding_function
,
5923 "If non-nil, a function to call to decide a coding system of file.\n\
5924 Two arguments are passed to this function: the file name\n\
5925 and the length of a file contents following the point.\n\
5926 This function should return a coding system to decode the file contents.\n\
5927 It should check the file name against `auto-coding-alist'.\n\
5928 If no coding system is decided, it should check a coding system\n\
5929 specified in the heading lines with the format:\n\
5930 -*- ... coding: CODING-SYSTEM; ... -*-\n\
5931 or local variable spec of the tailing lines with `coding:' tag.");
5932 Vset_auto_coding_function
= Qnil
;
5934 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
5935 "A list of functions to be called at the end of `insert-file-contents'.\n\
5936 Each is passed one argument, the number of bytes inserted. It should return\n\
5937 the new byte count, and leave point the same. If `insert-file-contents' is\n\
5938 intercepted by a handler from `file-name-handler-alist', that handler is\n\
5939 responsible for calling the after-insert-file-functions if appropriate.");
5940 Vafter_insert_file_functions
= Qnil
;
5942 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
5943 "A list of functions to be called at the start of `write-region'.\n\
5944 Each is passed two arguments, START and END as for `write-region'.\n\
5945 These are usually two numbers but not always; see the documentation\n\
5946 for `write-region'. The function should return a list of pairs\n\
5947 of the form (POSITION . STRING), consisting of strings to be effectively\n\
5948 inserted at the specified positions of the file being written (1 means to\n\
5949 insert before the first byte written). The POSITIONs must be sorted into\n\
5950 increasing order. If there are several functions in the list, the several\n\
5951 lists are merged destructively.");
5952 Vwrite_region_annotate_functions
= Qnil
;
5954 DEFVAR_LISP ("write-region-annotations-so-far",
5955 &Vwrite_region_annotations_so_far
,
5956 "When an annotation function is called, this holds the previous annotations.\n\
5957 These are the annotations made by other annotation functions\n\
5958 that were already called. See also `write-region-annotate-functions'.");
5959 Vwrite_region_annotations_so_far
= Qnil
;
5961 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
5962 "A list of file name handlers that temporarily should not be used.\n\
5963 This applies only to the operation `inhibit-file-name-operation'.");
5964 Vinhibit_file_name_handlers
= Qnil
;
5966 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
5967 "The operation for which `inhibit-file-name-handlers' is applicable.");
5968 Vinhibit_file_name_operation
= Qnil
;
5970 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
5971 "File name in which we write a list of all auto save file names.\n\
5972 This variable is initialized automatically from `auto-save-list-file-prefix'\n\
5973 shortly after Emacs reads your `.emacs' file, if you have not yet given it\n\
5975 Vauto_save_list_file_name
= Qnil
;
5977 defsubr (&Sfind_file_name_handler
);
5978 defsubr (&Sfile_name_directory
);
5979 defsubr (&Sfile_name_nondirectory
);
5980 defsubr (&Sunhandled_file_name_directory
);
5981 defsubr (&Sfile_name_as_directory
);
5982 defsubr (&Sdirectory_file_name
);
5983 defsubr (&Smake_temp_name
);
5984 defsubr (&Sexpand_file_name
);
5985 defsubr (&Ssubstitute_in_file_name
);
5986 defsubr (&Scopy_file
);
5987 defsubr (&Smake_directory_internal
);
5988 defsubr (&Sdelete_directory
);
5989 defsubr (&Sdelete_file
);
5990 defsubr (&Srename_file
);
5991 defsubr (&Sadd_name_to_file
);
5993 defsubr (&Smake_symbolic_link
);
5994 #endif /* S_IFLNK */
5996 defsubr (&Sdefine_logical_name
);
5999 defsubr (&Ssysnetunam
);
6000 #endif /* HPUX_NET */
6001 defsubr (&Sfile_name_absolute_p
);
6002 defsubr (&Sfile_exists_p
);
6003 defsubr (&Sfile_executable_p
);
6004 defsubr (&Sfile_readable_p
);
6005 defsubr (&Sfile_writable_p
);
6006 defsubr (&Saccess_file
);
6007 defsubr (&Sfile_symlink_p
);
6008 defsubr (&Sfile_directory_p
);
6009 defsubr (&Sfile_accessible_directory_p
);
6010 defsubr (&Sfile_regular_p
);
6011 defsubr (&Sfile_modes
);
6012 defsubr (&Sset_file_modes
);
6013 defsubr (&Sset_default_file_modes
);
6014 defsubr (&Sdefault_file_modes
);
6015 defsubr (&Sfile_newer_than_file_p
);
6016 defsubr (&Sinsert_file_contents
);
6017 defsubr (&Swrite_region
);
6018 defsubr (&Scar_less_than_car
);
6019 defsubr (&Sverify_visited_file_modtime
);
6020 defsubr (&Sclear_visited_file_modtime
);
6021 defsubr (&Svisited_file_modtime
);
6022 defsubr (&Sset_visited_file_modtime
);
6023 defsubr (&Sdo_auto_save
);
6024 defsubr (&Sset_buffer_auto_saved
);
6025 defsubr (&Sclear_buffer_auto_save_failure
);
6026 defsubr (&Srecent_auto_save_p
);
6028 defsubr (&Sread_file_name_internal
);
6029 defsubr (&Sread_file_name
);
6032 defsubr (&Sunix_sync
);