1 /* File IO for GNU Emacs.
2 Copyright (C) 1985,86,87,88,93,94,95,96,97,98,99,2000, 2001
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 #define _GNU_SOURCE /* for euidaccess */
26 #if defined (USG5) || defined (BSD_SYSTEM) || defined (LINUX)
31 #include <sys/types.h>
38 #if !defined (S_ISLNK) && defined (S_IFLNK)
39 # define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
42 #if !defined (S_ISFIFO) && defined (S_IFIFO)
43 # define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO)
46 #if !defined (S_ISREG) && defined (S_IFREG)
47 # define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
88 #include "intervals.h"
99 #endif /* not WINDOWSNT */
103 #include <sys/param.h>
111 #define CORRECT_DIR_SEPS(s) \
112 do { if ('/' == DIRECTORY_SEP) dostounix_filename (s); \
113 else unixtodos_filename (s); \
115 /* On Windows, drive letters must be alphabetic - on DOS, the Netware
116 redirector allows the six letters between 'Z' and 'a' as well. */
118 #define IS_DRIVE(x) ((x) >= 'A' && (x) <= 'z')
121 #define IS_DRIVE(x) isalpha (x)
123 /* Need to lower-case the drive letter, or else expanded
124 filenames will sometimes compare inequal, because
125 `expand-file-name' doesn't always down-case the drive letter. */
126 #define DRIVE_LETTER(x) (tolower (x))
147 #include "commands.h"
148 extern int use_dialog_box
;
162 #define min(a, b) ((a) < (b) ? (a) : (b))
163 #define max(a, b) ((a) > (b) ? (a) : (b))
165 /* Nonzero during writing of auto-save files */
168 /* Set by auto_save_1 to mode of original file so Fwrite_region will create
169 a new file with the same mode as the original */
170 int auto_save_mode_bits
;
172 /* Coding system for file names, or nil if none. */
173 Lisp_Object Vfile_name_coding_system
;
175 /* Coding system for file names used only when
176 Vfile_name_coding_system is nil. */
177 Lisp_Object Vdefault_file_name_coding_system
;
179 /* Alist of elements (REGEXP . HANDLER) for file names
180 whose I/O is done with a special handler. */
181 Lisp_Object Vfile_name_handler_alist
;
183 /* Format for auto-save files */
184 Lisp_Object Vauto_save_file_format
;
186 /* Lisp functions for translating file formats */
187 Lisp_Object Qformat_decode
, Qformat_annotate_function
;
189 /* Function to be called to decide a coding system of a reading file. */
190 Lisp_Object Vset_auto_coding_function
;
192 /* Functions to be called to process text properties in inserted file. */
193 Lisp_Object Vafter_insert_file_functions
;
195 /* Functions to be called to create text property annotations for file. */
196 Lisp_Object Vwrite_region_annotate_functions
;
198 /* During build_annotations, each time an annotation function is called,
199 this holds the annotations made by the previous functions. */
200 Lisp_Object Vwrite_region_annotations_so_far
;
202 /* File name in which we write a list of all our auto save files. */
203 Lisp_Object Vauto_save_list_file_name
;
205 /* Nonzero means, when reading a filename in the minibuffer,
206 start out by inserting the default directory into the minibuffer. */
207 int insert_default_directory
;
209 /* On VMS, nonzero means write new files with record format stmlf.
210 Zero means use var format. */
213 /* On NT, specifies the directory separator character, used (eg.) when
214 expanding file names. This can be bound to / or \. */
215 Lisp_Object Vdirectory_sep_char
;
217 extern Lisp_Object Vuser_login_name
;
220 extern Lisp_Object Vw32_get_true_file_attributes
;
223 extern int minibuf_level
;
225 extern int minibuffer_auto_raise
;
227 /* These variables describe handlers that have "already" had a chance
228 to handle the current operation.
230 Vinhibit_file_name_handlers is a list of file name handlers.
231 Vinhibit_file_name_operation is the operation being handled.
232 If we try to handle that operation, we ignore those handlers. */
234 static Lisp_Object Vinhibit_file_name_handlers
;
235 static Lisp_Object Vinhibit_file_name_operation
;
237 Lisp_Object Qfile_error
, Qfile_already_exists
, Qfile_date_error
;
239 Lisp_Object Qfile_name_history
;
241 Lisp_Object Qcar_less_than_car
;
243 static int a_write
P_ ((int, Lisp_Object
, int, int,
244 Lisp_Object
*, struct coding_system
*));
245 static int e_write
P_ ((int, Lisp_Object
, int, int, struct coding_system
*));
249 report_file_error (string
, data
)
253 Lisp_Object errstring
;
256 synchronize_system_messages_locale ();
257 errstring
= code_convert_string_norecord (build_string (strerror (errorno
)),
258 Vlocale_coding_system
, 0);
264 Fsignal (Qfile_already_exists
, Fcons (errstring
, data
));
267 /* System error messages are capitalized. Downcase the initial
268 unless it is followed by a slash. */
269 if (XSTRING (errstring
)->data
[1] != '/')
270 XSTRING (errstring
)->data
[0] = DOWNCASE (XSTRING (errstring
)->data
[0]);
272 Fsignal (Qfile_error
,
273 Fcons (build_string (string
), Fcons (errstring
, data
)));
278 close_file_unwind (fd
)
281 emacs_close (XFASTINT (fd
));
285 /* Restore point, having saved it as a marker. */
288 restore_point_unwind (location
)
289 Lisp_Object location
;
291 Fgoto_char (location
);
292 Fset_marker (location
, Qnil
, Qnil
);
296 Lisp_Object Qexpand_file_name
;
297 Lisp_Object Qsubstitute_in_file_name
;
298 Lisp_Object Qdirectory_file_name
;
299 Lisp_Object Qfile_name_directory
;
300 Lisp_Object Qfile_name_nondirectory
;
301 Lisp_Object Qunhandled_file_name_directory
;
302 Lisp_Object Qfile_name_as_directory
;
303 Lisp_Object Qcopy_file
;
304 Lisp_Object Qmake_directory_internal
;
305 Lisp_Object Qmake_directory
;
306 Lisp_Object Qdelete_directory
;
307 Lisp_Object Qdelete_file
;
308 Lisp_Object Qrename_file
;
309 Lisp_Object Qadd_name_to_file
;
310 Lisp_Object Qmake_symbolic_link
;
311 Lisp_Object Qfile_exists_p
;
312 Lisp_Object Qfile_executable_p
;
313 Lisp_Object Qfile_readable_p
;
314 Lisp_Object Qfile_writable_p
;
315 Lisp_Object Qfile_symlink_p
;
316 Lisp_Object Qaccess_file
;
317 Lisp_Object Qfile_directory_p
;
318 Lisp_Object Qfile_regular_p
;
319 Lisp_Object Qfile_accessible_directory_p
;
320 Lisp_Object Qfile_modes
;
321 Lisp_Object Qset_file_modes
;
322 Lisp_Object Qfile_newer_than_file_p
;
323 Lisp_Object Qinsert_file_contents
;
324 Lisp_Object Qwrite_region
;
325 Lisp_Object Qverify_visited_file_modtime
;
326 Lisp_Object Qset_visited_file_modtime
;
328 DEFUN ("find-file-name-handler", Ffind_file_name_handler
, Sfind_file_name_handler
, 2, 2, 0,
329 "Return FILENAME's handler function for OPERATION, if it has one.\n\
330 Otherwise, return nil.\n\
331 A file name is handled if one of the regular expressions in\n\
332 `file-name-handler-alist' matches it.\n\n\
333 If OPERATION equals `inhibit-file-name-operation', then we ignore\n\
334 any handlers that are members of `inhibit-file-name-handlers',\n\
335 but we still do run any other handlers. This lets handlers\n\
336 use the standard functions without calling themselves recursively.")
337 (filename
, operation
)
338 Lisp_Object filename
, operation
;
340 /* This function must not munge the match data. */
341 Lisp_Object chain
, inhibited_handlers
;
343 CHECK_STRING (filename
, 0);
345 if (EQ (operation
, Vinhibit_file_name_operation
))
346 inhibited_handlers
= Vinhibit_file_name_handlers
;
348 inhibited_handlers
= Qnil
;
350 for (chain
= Vfile_name_handler_alist
; CONSP (chain
);
351 chain
= XCDR (chain
))
359 if (STRINGP (string
) && fast_string_match (string
, filename
) >= 0)
361 Lisp_Object handler
, tem
;
363 handler
= XCDR (elt
);
364 tem
= Fmemq (handler
, inhibited_handlers
);
375 DEFUN ("file-name-directory", Ffile_name_directory
, Sfile_name_directory
,
377 "Return the directory component in file name FILENAME.\n\
378 Return nil if FILENAME does not include a directory.\n\
379 Otherwise return a directory spec.\n\
380 Given a Unix syntax file name, returns a string ending in slash;\n\
381 on VMS, perhaps instead a string ending in `:', `]' or `>'.")
383 Lisp_Object filename
;
385 register unsigned char *beg
;
386 register unsigned char *p
;
389 CHECK_STRING (filename
, 0);
391 /* If the file name has special constructs in it,
392 call the corresponding file handler. */
393 handler
= Ffind_file_name_handler (filename
, Qfile_name_directory
);
395 return call2 (handler
, Qfile_name_directory
, filename
);
397 #ifdef FILE_SYSTEM_CASE
398 filename
= FILE_SYSTEM_CASE (filename
);
400 beg
= XSTRING (filename
)->data
;
402 beg
= strcpy (alloca (strlen (beg
) + 1), beg
);
404 p
= beg
+ STRING_BYTES (XSTRING (filename
));
406 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
408 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
411 /* only recognise drive specifier at the beginning */
413 /* handle the "/:d:foo" and "/:foo" cases correctly */
414 && ((p
== beg
+ 2 && !IS_DIRECTORY_SEP (*beg
))
415 || (p
== beg
+ 4 && IS_DIRECTORY_SEP (*beg
))))
422 /* Expansion of "c:" to drive and default directory. */
425 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
426 unsigned char *res
= alloca (MAXPATHLEN
+ 1);
427 unsigned char *r
= res
;
429 if (p
== beg
+ 4 && IS_DIRECTORY_SEP (*beg
) && beg
[1] == ':')
431 strncpy (res
, beg
, 2);
436 if (getdefdir (toupper (*beg
) - 'A' + 1, r
))
438 if (!IS_DIRECTORY_SEP (res
[strlen (res
) - 1]))
441 p
= beg
+ strlen (beg
);
444 CORRECT_DIR_SEPS (beg
);
447 if (STRING_MULTIBYTE (filename
))
448 return make_string (beg
, p
- beg
);
449 return make_unibyte_string (beg
, p
- beg
);
452 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory
,
453 Sfile_name_nondirectory
, 1, 1, 0,
454 "Return file name FILENAME sans its directory.\n\
455 For example, in a Unix-syntax file name,\n\
456 this is everything after the last slash,\n\
457 or the entire name if it contains no slash.")
459 Lisp_Object filename
;
461 register unsigned char *beg
, *p
, *end
;
464 CHECK_STRING (filename
, 0);
466 /* If the file name has special constructs in it,
467 call the corresponding file handler. */
468 handler
= Ffind_file_name_handler (filename
, Qfile_name_nondirectory
);
470 return call2 (handler
, Qfile_name_nondirectory
, filename
);
472 beg
= XSTRING (filename
)->data
;
473 end
= p
= beg
+ STRING_BYTES (XSTRING (filename
));
475 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
477 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
480 /* only recognise drive specifier at beginning */
482 /* handle the "/:d:foo" case correctly */
483 && (p
== beg
+ 2 || (p
== beg
+ 4 && IS_DIRECTORY_SEP (*beg
))))
488 if (STRING_MULTIBYTE (filename
))
489 return make_string (p
, end
- p
);
490 return make_unibyte_string (p
, end
- p
);
493 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory
,
494 Sunhandled_file_name_directory
, 1, 1, 0,
495 "Return a directly usable directory name somehow associated with FILENAME.\n\
496 A `directly usable' directory name is one that may be used without the\n\
497 intervention of any file handler.\n\
498 If FILENAME is a directly usable file itself, return\n\
499 \(file-name-directory FILENAME).\n\
500 The `call-process' and `start-process' functions use this function to\n\
501 get a current directory to run processes in.")
503 Lisp_Object filename
;
507 /* If the file name has special constructs in it,
508 call the corresponding file handler. */
509 handler
= Ffind_file_name_handler (filename
, Qunhandled_file_name_directory
);
511 return call2 (handler
, Qunhandled_file_name_directory
, filename
);
513 return Ffile_name_directory (filename
);
518 file_name_as_directory (out
, in
)
521 int size
= strlen (in
) - 1;
534 /* Is it already a directory string? */
535 if (in
[size
] == ':' || in
[size
] == ']' || in
[size
] == '>')
537 /* Is it a VMS directory file name? If so, hack VMS syntax. */
538 else if (! index (in
, '/')
539 && ((size
> 3 && ! strcmp (&in
[size
- 3], ".DIR"))
540 || (size
> 3 && ! strcmp (&in
[size
- 3], ".dir"))
541 || (size
> 5 && (! strncmp (&in
[size
- 5], ".DIR", 4)
542 || ! strncmp (&in
[size
- 5], ".dir", 4))
543 && (in
[size
- 1] == '.' || in
[size
- 1] == ';')
544 && in
[size
] == '1')))
546 register char *p
, *dot
;
550 dir:x.dir --> dir:[x]
551 dir:[x]y.dir --> dir:[x.y] */
553 while (p
!= in
&& *p
!= ':' && *p
!= '>' && *p
!= ']') p
--;
556 strncpy (out
, in
, p
- in
);
575 dot
= index (p
, '.');
578 /* blindly remove any extension */
579 size
= strlen (out
) + (dot
- p
);
580 strncat (out
, p
, dot
- p
);
591 /* For Unix syntax, Append a slash if necessary */
592 if (!IS_DIRECTORY_SEP (out
[size
]))
594 out
[size
+ 1] = DIRECTORY_SEP
;
595 out
[size
+ 2] = '\0';
598 CORRECT_DIR_SEPS (out
);
604 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
605 Sfile_name_as_directory
, 1, 1, 0,
606 "Return a string representing file FILENAME interpreted as a directory.\n\
607 This operation exists because a directory is also a file, but its name as\n\
608 a directory is different from its name as a file.\n\
609 The result can be used as the value of `default-directory'\n\
610 or passed as second argument to `expand-file-name'.\n\
611 For a Unix-syntax file name, just appends a slash.\n\
612 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
619 CHECK_STRING (file
, 0);
623 /* If the file name has special constructs in it,
624 call the corresponding file handler. */
625 handler
= Ffind_file_name_handler (file
, Qfile_name_as_directory
);
627 return call2 (handler
, Qfile_name_as_directory
, file
);
629 buf
= (char *) alloca (STRING_BYTES (XSTRING (file
)) + 10);
630 return build_string (file_name_as_directory (buf
, XSTRING (file
)->data
));
634 * Convert from directory name to filename.
636 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
637 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
638 * On UNIX, it's simple: just make sure there isn't a terminating /
640 * Value is nonzero if the string output is different from the input.
644 directory_file_name (src
, dst
)
652 struct FAB fab
= cc$rms_fab
;
653 struct NAM nam
= cc$rms_nam
;
654 char esa
[NAM$C_MAXRSS
];
659 if (! index (src
, '/')
660 && (src
[slen
- 1] == ']'
661 || src
[slen
- 1] == ':'
662 || src
[slen
- 1] == '>'))
664 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
666 fab
.fab$b_fns
= slen
;
667 fab
.fab$l_nam
= &nam
;
668 fab
.fab$l_fop
= FAB$M_NAM
;
671 nam
.nam$b_ess
= sizeof esa
;
672 nam
.nam$b_nop
|= NAM$M_SYNCHK
;
674 /* We call SYS$PARSE to handle such things as [--] for us. */
675 if (SYS$
PARSE (&fab
, 0, 0) == RMS$_NORMAL
)
677 slen
= nam
.nam$b_esl
;
678 if (esa
[slen
- 1] == ';' && esa
[slen
- 2] == '.')
683 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
685 /* what about when we have logical_name:???? */
686 if (src
[slen
- 1] == ':')
687 { /* Xlate logical name and see what we get */
688 ptr
= strcpy (dst
, src
); /* upper case for getenv */
691 if ('a' <= *ptr
&& *ptr
<= 'z')
695 dst
[slen
- 1] = 0; /* remove colon */
696 if (!(src
= egetenv (dst
)))
698 /* should we jump to the beginning of this procedure?
699 Good points: allows us to use logical names that xlate
701 Bad points: can be a problem if we just translated to a device
703 For now, I'll punt and always expect VMS names, and hope for
706 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
707 { /* no recursion here! */
713 { /* not a directory spec */
718 bracket
= src
[slen
- 1];
720 /* If bracket is ']' or '>', bracket - 2 is the corresponding
722 ptr
= index (src
, bracket
- 2);
724 { /* no opening bracket */
728 if (!(rptr
= rindex (src
, '.')))
731 strncpy (dst
, src
, slen
);
735 dst
[slen
++] = bracket
;
740 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
741 then translate the device and recurse. */
742 if (dst
[slen
- 1] == ':'
743 && dst
[slen
- 2] != ':' /* skip decnet nodes */
744 && strcmp (src
+ slen
, "[000000]") == 0)
746 dst
[slen
- 1] = '\0';
747 if ((ptr
= egetenv (dst
))
748 && (rlen
= strlen (ptr
) - 1) > 0
749 && (ptr
[rlen
] == ']' || ptr
[rlen
] == '>')
750 && ptr
[rlen
- 1] == '.')
752 char * buf
= (char *) alloca (strlen (ptr
) + 1);
756 return directory_file_name (buf
, dst
);
761 strcat (dst
, "[000000]");
765 rlen
= strlen (rptr
) - 1;
766 strncat (dst
, rptr
, rlen
);
767 dst
[slen
+ rlen
] = '\0';
768 strcat (dst
, ".DIR.1");
772 /* Process as Unix format: just remove any final slash.
773 But leave "/" unchanged; do not change it to "". */
776 /* Handle // as root for apollo's. */
777 if ((slen
> 2 && dst
[slen
- 1] == '/')
778 || (slen
> 1 && dst
[0] != '/' && dst
[slen
- 1] == '/'))
782 && IS_DIRECTORY_SEP (dst
[slen
- 1])
784 && !IS_ANY_SEP (dst
[slen
- 2])
790 CORRECT_DIR_SEPS (dst
);
795 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
797 "Returns the file name of the directory named DIRECTORY.\n\
798 This is the name of the file that holds the data for the directory DIRECTORY.\n\
799 This operation exists because a directory is also a file, but its name as\n\
800 a directory is different from its name as a file.\n\
801 In Unix-syntax, this function just removes the final slash.\n\
802 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
803 it returns a file name such as \"[X]Y.DIR.1\".")
805 Lisp_Object directory
;
810 CHECK_STRING (directory
, 0);
812 if (NILP (directory
))
815 /* If the file name has special constructs in it,
816 call the corresponding file handler. */
817 handler
= Ffind_file_name_handler (directory
, Qdirectory_file_name
);
819 return call2 (handler
, Qdirectory_file_name
, directory
);
822 /* 20 extra chars is insufficient for VMS, since we might perform a
823 logical name translation. an equivalence string can be up to 255
824 chars long, so grab that much extra space... - sss */
825 buf
= (char *) alloca (STRING_BYTES (XSTRING (directory
)) + 20 + 255);
827 buf
= (char *) alloca (STRING_BYTES (XSTRING (directory
)) + 20);
829 directory_file_name (XSTRING (directory
)->data
, buf
);
830 return build_string (buf
);
833 static char make_temp_name_tbl
[64] =
835 'A','B','C','D','E','F','G','H',
836 'I','J','K','L','M','N','O','P',
837 'Q','R','S','T','U','V','W','X',
838 'Y','Z','a','b','c','d','e','f',
839 'g','h','i','j','k','l','m','n',
840 'o','p','q','r','s','t','u','v',
841 'w','x','y','z','0','1','2','3',
842 '4','5','6','7','8','9','-','_'
845 static unsigned make_temp_name_count
, make_temp_name_count_initialized_p
;
847 /* Value is a temporary file name starting with PREFIX, a string.
849 The Emacs process number forms part of the result, so there is
850 no danger of generating a name being used by another process.
851 In addition, this function makes an attempt to choose a name
852 which has no existing file. To make this work, PREFIX should be
853 an absolute file name.
855 BASE64_P non-zero means add the pid as 3 characters in base64
856 encoding. In this case, 6 characters will be added to PREFIX to
857 form the file name. Otherwise, if Emacs is running on a system
858 with long file names, add the pid as a decimal number.
860 This function signals an error if no unique file name could be
864 make_temp_name (prefix
, base64_p
)
871 unsigned char *p
, *data
;
875 CHECK_STRING (prefix
, 0);
877 /* VAL is created by adding 6 characters to PREFIX. The first
878 three are the PID of this process, in base 64, and the second
879 three are incremented if the file already exists. This ensures
880 262144 unique file names per PID per PREFIX. */
882 pid
= (int) getpid ();
886 pidbuf
[0] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
887 pidbuf
[1] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
888 pidbuf
[2] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
893 #ifdef HAVE_LONG_FILE_NAMES
894 sprintf (pidbuf
, "%d", pid
);
895 pidlen
= strlen (pidbuf
);
897 pidbuf
[0] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
898 pidbuf
[1] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
899 pidbuf
[2] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
904 len
= XSTRING (prefix
)->size
;
905 val
= make_uninit_string (len
+ 3 + pidlen
);
906 data
= XSTRING (val
)->data
;
907 bcopy(XSTRING (prefix
)->data
, data
, len
);
910 bcopy (pidbuf
, p
, pidlen
);
913 /* Here we try to minimize useless stat'ing when this function is
914 invoked many times successively with the same PREFIX. We achieve
915 this by initializing count to a random value, and incrementing it
918 We don't want make-temp-name to be called while dumping,
919 because then make_temp_name_count_initialized_p would get set
920 and then make_temp_name_count would not be set when Emacs starts. */
922 if (!make_temp_name_count_initialized_p
)
924 make_temp_name_count
= (unsigned) time (NULL
);
925 make_temp_name_count_initialized_p
= 1;
931 unsigned num
= make_temp_name_count
;
933 p
[0] = make_temp_name_tbl
[num
& 63], num
>>= 6;
934 p
[1] = make_temp_name_tbl
[num
& 63], num
>>= 6;
935 p
[2] = make_temp_name_tbl
[num
& 63], num
>>= 6;
937 /* Poor man's congruential RN generator. Replace with
938 ++make_temp_name_count for debugging. */
939 make_temp_name_count
+= 25229;
940 make_temp_name_count
%= 225307;
942 if (stat (data
, &ignored
) < 0)
944 /* We want to return only if errno is ENOENT. */
948 /* The error here is dubious, but there is little else we
949 can do. The alternatives are to return nil, which is
950 as bad as (and in many cases worse than) throwing the
951 error, or to ignore the error, which will likely result
952 in looping through 225307 stat's, which is not only
953 dog-slow, but also useless since it will fallback to
954 the errow below, anyway. */
955 report_file_error ("Cannot create temporary name for prefix",
956 Fcons (prefix
, Qnil
));
961 error ("Cannot create temporary name for prefix `%s'",
962 XSTRING (prefix
)->data
);
967 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
968 "Generate temporary file name (string) starting with PREFIX (a string).\n\
969 The Emacs process number forms part of the result,\n\
970 so there is no danger of generating a name being used by another process.\n\
972 In addition, this function makes an attempt to choose a name\n\
973 which has no existing file. To make this work,\n\
974 PREFIX should be an absolute file name.\n\
976 There is a race condition between calling `make-temp-name' and creating the\n\
977 file which opens all kinds of security holes. For that reason, you should\n\
978 probably use `make-temp-file' instead.")
982 return make_temp_name (prefix
, 0);
987 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
988 "Convert filename NAME to absolute, and canonicalize it.\n\
989 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative\n\
990 (does not start with slash); if DEFAULT-DIRECTORY is nil or missing,\n\
991 the current buffer's value of default-directory is used.\n\
992 File name components that are `.' are removed, and \n\
993 so are file name components followed by `..', along with the `..' itself;\n\
994 note that these simplifications are done without checking the resulting\n\
995 file names in the file system.\n\
996 An initial `~/' expands to your home directory.\n\
997 An initial `~USER/' expands to USER's home directory.\n\
998 See also the function `substitute-in-file-name'.")
999 (name
, default_directory
)
1000 Lisp_Object name
, default_directory
;
1004 register unsigned char *newdir
, *p
, *o
;
1006 unsigned char *target
;
1009 unsigned char * colon
= 0;
1010 unsigned char * close
= 0;
1011 unsigned char * slash
= 0;
1012 unsigned char * brack
= 0;
1013 int lbrack
= 0, rbrack
= 0;
1018 int collapse_newdir
= 1;
1022 Lisp_Object handler
;
1024 CHECK_STRING (name
, 0);
1026 /* If the file name has special constructs in it,
1027 call the corresponding file handler. */
1028 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
1029 if (!NILP (handler
))
1030 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
1032 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
1033 if (NILP (default_directory
))
1034 default_directory
= current_buffer
->directory
;
1035 if (! STRINGP (default_directory
))
1036 default_directory
= build_string ("/");
1038 if (!NILP (default_directory
))
1040 handler
= Ffind_file_name_handler (default_directory
, Qexpand_file_name
);
1041 if (!NILP (handler
))
1042 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
1045 o
= XSTRING (default_directory
)->data
;
1047 /* Make sure DEFAULT_DIRECTORY is properly expanded.
1048 It would be better to do this down below where we actually use
1049 default_directory. Unfortunately, calling Fexpand_file_name recursively
1050 could invoke GC, and the strings might be relocated. This would
1051 be annoying because we have pointers into strings lying around
1052 that would need adjusting, and people would add new pointers to
1053 the code and forget to adjust them, resulting in intermittent bugs.
1054 Putting this call here avoids all that crud.
1056 The EQ test avoids infinite recursion. */
1057 if (! NILP (default_directory
) && !EQ (default_directory
, name
)
1058 /* Save time in some common cases - as long as default_directory
1059 is not relative, it can be canonicalized with name below (if it
1060 is needed at all) without requiring it to be expanded now. */
1062 /* Detect MSDOS file names with drive specifiers. */
1063 && ! (IS_DRIVE (o
[0]) && IS_DEVICE_SEP (o
[1]) && IS_DIRECTORY_SEP (o
[2]))
1065 /* Detect Windows file names in UNC format. */
1066 && ! (IS_DIRECTORY_SEP (o
[0]) && IS_DIRECTORY_SEP (o
[1]))
1068 #else /* not DOS_NT */
1069 /* Detect Unix absolute file names (/... alone is not absolute on
1071 && ! (IS_DIRECTORY_SEP (o
[0]))
1072 #endif /* not DOS_NT */
1075 struct gcpro gcpro1
;
1078 default_directory
= Fexpand_file_name (default_directory
, Qnil
);
1083 /* Filenames on VMS are always upper case. */
1084 name
= Fupcase (name
);
1086 #ifdef FILE_SYSTEM_CASE
1087 name
= FILE_SYSTEM_CASE (name
);
1090 nm
= XSTRING (name
)->data
;
1093 /* We will force directory separators to be either all \ or /, so make
1094 a local copy to modify, even if there ends up being no change. */
1095 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
1097 /* Note if special escape prefix is present, but remove for now. */
1098 if (nm
[0] == '/' && nm
[1] == ':')
1104 /* Find and remove drive specifier if present; this makes nm absolute
1105 even if the rest of the name appears to be relative. Only look for
1106 drive specifier at the beginning. */
1107 if (IS_DRIVE (nm
[0]) && IS_DEVICE_SEP (nm
[1]))
1114 /* If we see "c://somedir", we want to strip the first slash after the
1115 colon when stripping the drive letter. Otherwise, this expands to
1117 if (drive
&& IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1119 #endif /* WINDOWSNT */
1123 /* Discard any previous drive specifier if nm is now in UNC format. */
1124 if (IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1130 /* If nm is absolute, look for `/./' or `/../' or `//''sequences; if
1131 none are found, we can probably return right away. We will avoid
1132 allocating a new string if name is already fully expanded. */
1134 IS_DIRECTORY_SEP (nm
[0])
1136 && drive
&& !is_escaped
1139 && (drive
|| IS_DIRECTORY_SEP (nm
[1])) && !is_escaped
1146 /* If it turns out that the filename we want to return is just a
1147 suffix of FILENAME, we don't need to go through and edit
1148 things; we just need to construct a new string using data
1149 starting at the middle of FILENAME. If we set lose to a
1150 non-zero value, that means we've discovered that we can't do
1157 /* Since we know the name is absolute, we can assume that each
1158 element starts with a "/". */
1160 /* "." and ".." are hairy. */
1161 if (IS_DIRECTORY_SEP (p
[0])
1163 && (IS_DIRECTORY_SEP (p
[2])
1165 || (p
[2] == '.' && (IS_DIRECTORY_SEP (p
[3])
1168 /* We want to replace multiple `/' in a row with a single
1171 && IS_DIRECTORY_SEP (p
[0])
1172 && IS_DIRECTORY_SEP (p
[1]))
1179 /* if dev:[dir]/, move nm to / */
1180 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1181 nm
= (brack
? brack
+ 1 : colon
+ 1);
1182 lbrack
= rbrack
= 0;
1190 /* VMS pre V4.4,convert '-'s in filenames. */
1191 if (lbrack
== rbrack
)
1193 if (dots
< 2) /* this is to allow negative version numbers */
1198 if (lbrack
> rbrack
&&
1199 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1200 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1206 /* count open brackets, reset close bracket pointer */
1207 if (p
[0] == '[' || p
[0] == '<')
1208 lbrack
++, brack
= 0;
1209 /* count close brackets, set close bracket pointer */
1210 if (p
[0] == ']' || p
[0] == '>')
1211 rbrack
++, brack
= p
;
1212 /* detect ][ or >< */
1213 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1215 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1216 nm
= p
+ 1, lose
= 1;
1217 if (p
[0] == ':' && (colon
|| slash
))
1218 /* if dev1:[dir]dev2:, move nm to dev2: */
1224 /* if /name/dev:, move nm to dev: */
1227 /* if node::dev:, move colon following dev */
1228 else if (colon
&& colon
[-1] == ':')
1230 /* if dev1:dev2:, move nm to dev2: */
1231 else if (colon
&& colon
[-1] != ':')
1236 if (p
[0] == ':' && !colon
)
1242 if (lbrack
== rbrack
)
1245 else if (p
[0] == '.')
1253 if (index (nm
, '/'))
1254 return build_string (sys_translate_unix (nm
));
1257 /* Make sure directories are all separated with / or \ as
1258 desired, but avoid allocation of a new string when not
1260 CORRECT_DIR_SEPS (nm
);
1262 if (IS_DIRECTORY_SEP (nm
[1]))
1264 if (strcmp (nm
, XSTRING (name
)->data
) != 0)
1265 name
= build_string (nm
);
1269 /* drive must be set, so this is okay */
1270 if (strcmp (nm
- 2, XSTRING (name
)->data
) != 0)
1272 name
= make_string (nm
- 2, p
- nm
+ 2);
1273 XSTRING (name
)->data
[0] = DRIVE_LETTER (drive
);
1274 XSTRING (name
)->data
[1] = ':';
1277 #else /* not DOS_NT */
1278 if (nm
== XSTRING (name
)->data
)
1280 return build_string (nm
);
1281 #endif /* not DOS_NT */
1285 /* At this point, nm might or might not be an absolute file name. We
1286 need to expand ~ or ~user if present, otherwise prefix nm with
1287 default_directory if nm is not absolute, and finally collapse /./
1288 and /foo/../ sequences.
1290 We set newdir to be the appropriate prefix if one is needed:
1291 - the relevant user directory if nm starts with ~ or ~user
1292 - the specified drive's working dir (DOS/NT only) if nm does not
1294 - the value of default_directory.
1296 Note that these prefixes are not guaranteed to be absolute (except
1297 for the working dir of a drive). Therefore, to ensure we always
1298 return an absolute name, if the final prefix is not absolute we
1299 append it to the current working directory. */
1303 if (nm
[0] == '~') /* prefix ~ */
1305 if (IS_DIRECTORY_SEP (nm
[1])
1309 || nm
[1] == 0) /* ~ by itself */
1311 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1312 newdir
= (unsigned char *) "";
1315 collapse_newdir
= 0;
1318 nm
++; /* Don't leave the slash in nm. */
1321 else /* ~user/filename */
1323 for (p
= nm
; *p
&& (!IS_DIRECTORY_SEP (*p
)
1328 o
= (unsigned char *) alloca (p
- nm
+ 1);
1329 bcopy ((char *) nm
, o
, p
- nm
);
1332 pw
= (struct passwd
*) getpwnam (o
+ 1);
1335 newdir
= (unsigned char *) pw
-> pw_dir
;
1337 nm
= p
+ 1; /* skip the terminator */
1341 collapse_newdir
= 0;
1346 /* If we don't find a user of that name, leave the name
1347 unchanged; don't move nm forward to p. */
1352 /* On DOS and Windows, nm is absolute if a drive name was specified;
1353 use the drive's current directory as the prefix if needed. */
1354 if (!newdir
&& drive
)
1356 /* Get default directory if needed to make nm absolute. */
1357 if (!IS_DIRECTORY_SEP (nm
[0]))
1359 newdir
= alloca (MAXPATHLEN
+ 1);
1360 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1365 /* Either nm starts with /, or drive isn't mounted. */
1366 newdir
= alloca (4);
1367 newdir
[0] = DRIVE_LETTER (drive
);
1375 /* Finally, if no prefix has been specified and nm is not absolute,
1376 then it must be expanded relative to default_directory. */
1380 /* /... alone is not absolute on DOS and Windows. */
1381 && !IS_DIRECTORY_SEP (nm
[0])
1384 && !(IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1391 newdir
= XSTRING (default_directory
)->data
;
1393 /* Note if special escape prefix is present, but remove for now. */
1394 if (newdir
[0] == '/' && newdir
[1] == ':')
1405 /* First ensure newdir is an absolute name. */
1407 /* Detect MSDOS file names with drive specifiers. */
1408 ! (IS_DRIVE (newdir
[0])
1409 && IS_DEVICE_SEP (newdir
[1]) && IS_DIRECTORY_SEP (newdir
[2]))
1411 /* Detect Windows file names in UNC format. */
1412 && ! (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1416 /* Effectively, let newdir be (expand-file-name newdir cwd).
1417 Because of the admonition against calling expand-file-name
1418 when we have pointers into lisp strings, we accomplish this
1419 indirectly by prepending newdir to nm if necessary, and using
1420 cwd (or the wd of newdir's drive) as the new newdir. */
1422 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1427 if (!IS_DIRECTORY_SEP (nm
[0]))
1429 char * tmp
= alloca (strlen (newdir
) + strlen (nm
) + 2);
1430 file_name_as_directory (tmp
, newdir
);
1434 newdir
= alloca (MAXPATHLEN
+ 1);
1437 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1444 /* Strip off drive name from prefix, if present. */
1445 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1451 /* Keep only a prefix from newdir if nm starts with slash
1452 (//server/share for UNC, nothing otherwise). */
1453 if (IS_DIRECTORY_SEP (nm
[0]) && collapse_newdir
)
1456 if (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1458 newdir
= strcpy (alloca (strlen (newdir
) + 1), newdir
);
1460 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1462 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1474 /* Get rid of any slash at the end of newdir, unless newdir is
1475 just / or // (an incomplete UNC name). */
1476 length
= strlen (newdir
);
1477 if (length
> 1 && IS_DIRECTORY_SEP (newdir
[length
- 1])
1479 && !(length
== 2 && IS_DIRECTORY_SEP (newdir
[0]))
1483 unsigned char *temp
= (unsigned char *) alloca (length
);
1484 bcopy (newdir
, temp
, length
- 1);
1485 temp
[length
- 1] = 0;
1493 /* Now concatenate the directory and name to new space in the stack frame */
1494 tlen
+= strlen (nm
) + 1;
1496 /* Reserve space for drive specifier and escape prefix, since either
1497 or both may need to be inserted. (The Microsoft x86 compiler
1498 produces incorrect code if the following two lines are combined.) */
1499 target
= (unsigned char *) alloca (tlen
+ 4);
1501 #else /* not DOS_NT */
1502 target
= (unsigned char *) alloca (tlen
);
1503 #endif /* not DOS_NT */
1509 if (nm
[0] == 0 || IS_DIRECTORY_SEP (nm
[0]))
1512 /* If newdir is effectively "C:/", then the drive letter will have
1513 been stripped and newdir will be "/". Concatenating with an
1514 absolute directory in nm produces "//", which will then be
1515 incorrectly treated as a network share. Ignore newdir in
1516 this case (keeping the drive letter). */
1517 if (!(drive
&& nm
[0] && IS_DIRECTORY_SEP (newdir
[0])
1518 && newdir
[1] == '\0'))
1520 strcpy (target
, newdir
);
1524 file_name_as_directory (target
, newdir
);
1527 strcat (target
, nm
);
1529 if (index (target
, '/'))
1530 strcpy (target
, sys_translate_unix (target
));
1533 /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */
1535 /* Now canonicalize by removing `//', `/.' and `/foo/..' if they
1544 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1550 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1551 /* brackets are offset from each other by 2 */
1554 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1555 /* convert [foo][bar] to [bar] */
1556 while (o
[-1] != '[' && o
[-1] != '<')
1558 else if (*p
== '-' && *o
!= '.')
1561 else if (p
[0] == '-' && o
[-1] == '.' &&
1562 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1563 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1567 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1568 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1570 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1572 /* else [foo.-] ==> [-] */
1578 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1579 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1585 if (!IS_DIRECTORY_SEP (*p
))
1589 else if (IS_DIRECTORY_SEP (p
[0])
1591 && (IS_DIRECTORY_SEP (p
[2])
1594 /* If "/." is the entire filename, keep the "/". Otherwise,
1595 just delete the whole "/.". */
1596 if (o
== target
&& p
[2] == '\0')
1600 else if (IS_DIRECTORY_SEP (p
[0]) && p
[1] == '.' && p
[2] == '.'
1601 /* `/../' is the "superroot" on certain file systems. */
1603 && (IS_DIRECTORY_SEP (p
[3]) || p
[3] == 0))
1605 while (o
!= target
&& (--o
) && !IS_DIRECTORY_SEP (*o
))
1607 /* Keep initial / only if this is the whole name. */
1608 if (o
== target
&& IS_ANY_SEP (*o
) && p
[3] == 0)
1613 && IS_DIRECTORY_SEP (p
[0]) && IS_DIRECTORY_SEP (p
[1]))
1615 /* Collapse multiple `/' in a row. */
1617 while (IS_DIRECTORY_SEP (*p
))
1624 #endif /* not VMS */
1628 /* At last, set drive name. */
1630 /* Except for network file name. */
1631 if (!(IS_DIRECTORY_SEP (target
[0]) && IS_DIRECTORY_SEP (target
[1])))
1632 #endif /* WINDOWSNT */
1634 if (!drive
) abort ();
1636 target
[0] = DRIVE_LETTER (drive
);
1639 /* Reinsert the escape prefix if required. */
1646 CORRECT_DIR_SEPS (target
);
1649 return make_string (target
, o
- target
);
1653 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'. */
1654 DEAFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
1655 "Convert FILENAME to absolute, and canonicalize it.\n\
1656 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1657 (does not start with slash); if DEFAULT is nil or missing,\n\
1658 the current buffer's value of default-directory is used.\n\
1659 Filenames containing `.' or `..' as components are simplified;\n\
1660 initial `~/' expands to your home directory.\n\
1661 See also the function `substitute-in-file-name'.")
1663 Lisp_Object name
, defalt
;
1667 register unsigned char *newdir
, *p
, *o
;
1669 unsigned char *target
;
1673 unsigned char * colon
= 0;
1674 unsigned char * close
= 0;
1675 unsigned char * slash
= 0;
1676 unsigned char * brack
= 0;
1677 int lbrack
= 0, rbrack
= 0;
1681 CHECK_STRING (name
, 0);
1684 /* Filenames on VMS are always upper case. */
1685 name
= Fupcase (name
);
1688 nm
= XSTRING (name
)->data
;
1690 /* If nm is absolute, flush ...// and detect /./ and /../.
1691 If no /./ or /../ we can return right away. */
1703 if (p
[0] == '/' && p
[1] == '/'
1705 /* // at start of filename is meaningful on Apollo system. */
1710 if (p
[0] == '/' && p
[1] == '~')
1711 nm
= p
+ 1, lose
= 1;
1712 if (p
[0] == '/' && p
[1] == '.'
1713 && (p
[2] == '/' || p
[2] == 0
1714 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1720 /* if dev:[dir]/, move nm to / */
1721 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1722 nm
= (brack
? brack
+ 1 : colon
+ 1);
1723 lbrack
= rbrack
= 0;
1731 /* VMS pre V4.4,convert '-'s in filenames. */
1732 if (lbrack
== rbrack
)
1734 if (dots
< 2) /* this is to allow negative version numbers */
1739 if (lbrack
> rbrack
&&
1740 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1741 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1747 /* count open brackets, reset close bracket pointer */
1748 if (p
[0] == '[' || p
[0] == '<')
1749 lbrack
++, brack
= 0;
1750 /* count close brackets, set close bracket pointer */
1751 if (p
[0] == ']' || p
[0] == '>')
1752 rbrack
++, brack
= p
;
1753 /* detect ][ or >< */
1754 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1756 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1757 nm
= p
+ 1, lose
= 1;
1758 if (p
[0] == ':' && (colon
|| slash
))
1759 /* if dev1:[dir]dev2:, move nm to dev2: */
1765 /* If /name/dev:, move nm to dev: */
1768 /* If node::dev:, move colon following dev */
1769 else if (colon
&& colon
[-1] == ':')
1771 /* If dev1:dev2:, move nm to dev2: */
1772 else if (colon
&& colon
[-1] != ':')
1777 if (p
[0] == ':' && !colon
)
1783 if (lbrack
== rbrack
)
1786 else if (p
[0] == '.')
1794 if (index (nm
, '/'))
1795 return build_string (sys_translate_unix (nm
));
1797 if (nm
== XSTRING (name
)->data
)
1799 return build_string (nm
);
1803 /* Now determine directory to start with and put it in NEWDIR */
1807 if (nm
[0] == '~') /* prefix ~ */
1812 || nm
[1] == 0)/* ~/filename */
1814 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1815 newdir
= (unsigned char *) "";
1818 nm
++; /* Don't leave the slash in nm. */
1821 else /* ~user/filename */
1823 /* Get past ~ to user */
1824 unsigned char *user
= nm
+ 1;
1825 /* Find end of name. */
1826 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1827 int len
= ptr
? ptr
- user
: strlen (user
);
1829 unsigned char *ptr1
= index (user
, ':');
1830 if (ptr1
!= 0 && ptr1
- user
< len
)
1833 /* Copy the user name into temp storage. */
1834 o
= (unsigned char *) alloca (len
+ 1);
1835 bcopy ((char *) user
, o
, len
);
1838 /* Look up the user name. */
1839 pw
= (struct passwd
*) getpwnam (o
+ 1);
1841 error ("\"%s\" isn't a registered user", o
+ 1);
1843 newdir
= (unsigned char *) pw
->pw_dir
;
1845 /* Discard the user name from NM. */
1852 #endif /* not VMS */
1856 defalt
= current_buffer
->directory
;
1857 CHECK_STRING (defalt
, 1);
1858 newdir
= XSTRING (defalt
)->data
;
1861 /* Now concatenate the directory and name to new space in the stack frame */
1863 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1864 target
= (unsigned char *) alloca (tlen
);
1870 if (nm
[0] == 0 || nm
[0] == '/')
1871 strcpy (target
, newdir
);
1874 file_name_as_directory (target
, newdir
);
1877 strcat (target
, nm
);
1879 if (index (target
, '/'))
1880 strcpy (target
, sys_translate_unix (target
));
1883 /* Now canonicalize by removing /. and /foo/.. if they appear */
1891 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1897 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1898 /* brackets are offset from each other by 2 */
1901 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1902 /* convert [foo][bar] to [bar] */
1903 while (o
[-1] != '[' && o
[-1] != '<')
1905 else if (*p
== '-' && *o
!= '.')
1908 else if (p
[0] == '-' && o
[-1] == '.' &&
1909 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1910 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1914 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1915 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1917 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1919 /* else [foo.-] ==> [-] */
1925 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1926 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1936 else if (!strncmp (p
, "//", 2)
1938 /* // at start of filename is meaningful in Apollo system. */
1946 else if (p
[0] == '/' && p
[1] == '.' &&
1947 (p
[2] == '/' || p
[2] == 0))
1949 else if (!strncmp (p
, "/..", 3)
1950 /* `/../' is the "superroot" on certain file systems. */
1952 && (p
[3] == '/' || p
[3] == 0))
1954 while (o
!= target
&& *--o
!= '/')
1957 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1961 if (o
== target
&& *o
== '/')
1969 #endif /* not VMS */
1972 return make_string (target
, o
- target
);
1976 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1977 Ssubstitute_in_file_name
, 1, 1, 0,
1978 "Substitute environment variables referred to in FILENAME.\n\
1979 `$FOO' where FOO is an environment variable name means to substitute\n\
1980 the value of that variable. The variable name should be terminated\n\
1981 with a character not a letter, digit or underscore; otherwise, enclose\n\
1982 the entire variable name in braces.\n\
1983 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1984 On VMS, `$' substitution is not done; this function does little and only\n\
1985 duplicates what `expand-file-name' does.")
1987 Lisp_Object filename
;
1991 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1992 unsigned char *target
= NULL
;
1994 int substituted
= 0;
1996 Lisp_Object handler
;
1998 CHECK_STRING (filename
, 0);
2000 /* If the file name has special constructs in it,
2001 call the corresponding file handler. */
2002 handler
= Ffind_file_name_handler (filename
, Qsubstitute_in_file_name
);
2003 if (!NILP (handler
))
2004 return call2 (handler
, Qsubstitute_in_file_name
, filename
);
2006 nm
= XSTRING (filename
)->data
;
2008 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
2009 CORRECT_DIR_SEPS (nm
);
2010 substituted
= (strcmp (nm
, XSTRING (filename
)->data
) != 0);
2012 endp
= nm
+ STRING_BYTES (XSTRING (filename
));
2014 /* If /~ or // appears, discard everything through first slash. */
2016 for (p
= nm
; p
!= endp
; p
++)
2019 #if defined (APOLLO) || defined (WINDOWSNT)
2020 /* // at start of file name is meaningful in Apollo and
2021 WindowsNT systems. */
2022 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != nm
)
2023 #else /* not (APOLLO || WINDOWSNT) */
2024 || IS_DIRECTORY_SEP (p
[0])
2025 #endif /* not (APOLLO || WINDOWSNT) */
2030 || p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>'
2032 || IS_DIRECTORY_SEP (p
[-1])))
2038 /* see comment in expand-file-name about drive specifiers */
2039 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
2040 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
2049 return build_string (nm
);
2052 /* See if any variables are substituted into the string
2053 and find the total length of their values in `total' */
2055 for (p
= nm
; p
!= endp
;)
2065 /* "$$" means a single "$" */
2074 while (p
!= endp
&& *p
!= '}') p
++;
2075 if (*p
!= '}') goto missingclose
;
2081 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
2085 /* Copy out the variable name */
2086 target
= (unsigned char *) alloca (s
- o
+ 1);
2087 strncpy (target
, o
, s
- o
);
2090 strupr (target
); /* $home == $HOME etc. */
2093 /* Get variable value */
2094 o
= (unsigned char *) egetenv (target
);
2095 if (!o
) goto badvar
;
2096 total
+= strlen (o
);
2103 /* If substitution required, recopy the string and do it */
2104 /* Make space in stack frame for the new copy */
2105 xnm
= (unsigned char *) alloca (STRING_BYTES (XSTRING (filename
)) + total
+ 1);
2108 /* Copy the rest of the name through, replacing $ constructs with values */
2125 while (p
!= endp
&& *p
!= '}') p
++;
2126 if (*p
!= '}') goto missingclose
;
2132 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
2136 /* Copy out the variable name */
2137 target
= (unsigned char *) alloca (s
- o
+ 1);
2138 strncpy (target
, o
, s
- o
);
2141 strupr (target
); /* $home == $HOME etc. */
2144 /* Get variable value */
2145 o
= (unsigned char *) egetenv (target
);
2149 if (STRING_MULTIBYTE (filename
))
2151 /* If the original string is multibyte,
2152 convert what we substitute into multibyte. */
2155 int c
= unibyte_char_to_multibyte (*o
++);
2156 x
+= CHAR_STRING (c
, x
);
2168 /* If /~ or // appears, discard everything through first slash. */
2170 for (p
= xnm
; p
!= x
; p
++)
2172 #if defined (APOLLO) || defined (WINDOWSNT)
2173 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != xnm
)
2174 #else /* not (APOLLO || WINDOWSNT) */
2175 || IS_DIRECTORY_SEP (p
[0])
2176 #endif /* not (APOLLO || WINDOWSNT) */
2178 && p
!= xnm
&& IS_DIRECTORY_SEP (p
[-1]))
2181 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
2182 && p
> xnm
&& IS_DIRECTORY_SEP (p
[-1]))
2186 if (STRING_MULTIBYTE (filename
))
2187 return make_string (xnm
, x
- xnm
);
2188 return make_unibyte_string (xnm
, x
- xnm
);
2191 error ("Bad format environment-variable substitution");
2193 error ("Missing \"}\" in environment-variable substitution");
2195 error ("Substituting nonexistent environment variable \"%s\"", target
);
2198 #endif /* not VMS */
2202 /* A slightly faster and more convenient way to get
2203 (directory-file-name (expand-file-name FOO)). */
2206 expand_and_dir_to_file (filename
, defdir
)
2207 Lisp_Object filename
, defdir
;
2209 register Lisp_Object absname
;
2211 absname
= Fexpand_file_name (filename
, defdir
);
2214 register int c
= XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
)) - 1];
2215 if (c
== ':' || c
== ']' || c
== '>')
2216 absname
= Fdirectory_file_name (absname
);
2219 /* Remove final slash, if any (unless this is the root dir).
2220 stat behaves differently depending! */
2221 if (XSTRING (absname
)->size
> 1
2222 && IS_DIRECTORY_SEP (XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
)) - 1])
2223 && !IS_DEVICE_SEP (XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
))-2]))
2224 /* We cannot take shortcuts; they might be wrong for magic file names. */
2225 absname
= Fdirectory_file_name (absname
);
2230 /* Signal an error if the file ABSNAME already exists.
2231 If INTERACTIVE is nonzero, ask the user whether to proceed,
2232 and bypass the error if the user says to go ahead.
2233 QUERYSTRING is a name for the action that is being considered
2236 *STATPTR is used to store the stat information if the file exists.
2237 If the file does not exist, STATPTR->st_mode is set to 0.
2238 If STATPTR is null, we don't store into it.
2240 If QUICK is nonzero, we ask for y or n, not yes or no. */
2243 barf_or_query_if_file_exists (absname
, querystring
, interactive
, statptr
, quick
)
2244 Lisp_Object absname
;
2245 unsigned char *querystring
;
2247 struct stat
*statptr
;
2250 register Lisp_Object tem
, encoded_filename
;
2251 struct stat statbuf
;
2252 struct gcpro gcpro1
;
2254 encoded_filename
= ENCODE_FILE (absname
);
2256 /* stat is a good way to tell whether the file exists,
2257 regardless of what access permissions it has. */
2258 if (stat (XSTRING (encoded_filename
)->data
, &statbuf
) >= 0)
2261 Fsignal (Qfile_already_exists
,
2262 Fcons (build_string ("File already exists"),
2263 Fcons (absname
, Qnil
)));
2265 tem
= format1 ("File %s already exists; %s anyway? ",
2266 XSTRING (absname
)->data
, querystring
);
2268 tem
= Fy_or_n_p (tem
);
2270 tem
= do_yes_or_no_p (tem
);
2273 Fsignal (Qfile_already_exists
,
2274 Fcons (build_string ("File already exists"),
2275 Fcons (absname
, Qnil
)));
2282 statptr
->st_mode
= 0;
2287 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
2288 "fCopy file: \nFCopy %s to file: \np\nP",
2289 "Copy FILE to NEWNAME. Both args must be strings.\n\
2290 If NEWNAME names a directory, copy FILE there.\n\
2291 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
2292 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
2293 A number as third arg means request confirmation if NEWNAME already exists.\n\
2294 This is what happens in interactive use with M-x.\n\
2295 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
2296 last-modified time as the old one. (This works on only some systems.)\n\
2297 A prefix arg makes KEEP-TIME non-nil.")
2298 (file
, newname
, ok_if_already_exists
, keep_time
)
2299 Lisp_Object file
, newname
, ok_if_already_exists
, keep_time
;
2302 char buf
[16 * 1024];
2303 struct stat st
, out_st
;
2304 Lisp_Object handler
;
2305 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2306 int count
= specpdl_ptr
- specpdl
;
2307 int input_file_statable_p
;
2308 Lisp_Object encoded_file
, encoded_newname
;
2310 encoded_file
= encoded_newname
= Qnil
;
2311 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2312 CHECK_STRING (file
, 0);
2313 CHECK_STRING (newname
, 1);
2315 if (!NILP (Ffile_directory_p (newname
)))
2316 newname
= Fexpand_file_name (file
, newname
);
2318 newname
= Fexpand_file_name (newname
, Qnil
);
2320 file
= Fexpand_file_name (file
, Qnil
);
2322 /* If the input file name has special constructs in it,
2323 call the corresponding file handler. */
2324 handler
= Ffind_file_name_handler (file
, Qcopy_file
);
2325 /* Likewise for output file name. */
2327 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
2328 if (!NILP (handler
))
2329 RETURN_UNGCPRO (call5 (handler
, Qcopy_file
, file
, newname
,
2330 ok_if_already_exists
, keep_time
));
2332 encoded_file
= ENCODE_FILE (file
);
2333 encoded_newname
= ENCODE_FILE (newname
);
2335 if (NILP (ok_if_already_exists
)
2336 || INTEGERP (ok_if_already_exists
))
2337 barf_or_query_if_file_exists (encoded_newname
, "copy to it",
2338 INTEGERP (ok_if_already_exists
), &out_st
, 0);
2339 else if (stat (XSTRING (encoded_newname
)->data
, &out_st
) < 0)
2343 if (!CopyFile (XSTRING (encoded_file
)->data
,
2344 XSTRING (encoded_newname
)->data
,
2346 report_file_error ("Copying file", Fcons (file
, Fcons (newname
, Qnil
)));
2347 else if (NILP (keep_time
))
2350 EMACS_GET_TIME (now
);
2351 if (set_file_times (XSTRING (encoded_newname
)->data
,
2353 Fsignal (Qfile_date_error
,
2354 Fcons (build_string ("Cannot set file date"),
2355 Fcons (newname
, Qnil
)));
2357 #else /* not WINDOWSNT */
2358 ifd
= emacs_open (XSTRING (encoded_file
)->data
, O_RDONLY
, 0);
2360 report_file_error ("Opening input file", Fcons (file
, Qnil
));
2362 record_unwind_protect (close_file_unwind
, make_number (ifd
));
2364 /* We can only copy regular files and symbolic links. Other files are not
2366 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
2368 #if !defined (DOS_NT) || __DJGPP__ > 1
2369 if (out_st
.st_mode
!= 0
2370 && st
.st_dev
== out_st
.st_dev
&& st
.st_ino
== out_st
.st_ino
)
2373 report_file_error ("Input and output files are the same",
2374 Fcons (file
, Fcons (newname
, Qnil
)));
2378 #if defined (S_ISREG) && defined (S_ISLNK)
2379 if (input_file_statable_p
)
2381 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
2383 #if defined (EISDIR)
2384 /* Get a better looking error message. */
2387 report_file_error ("Non-regular file", Fcons (file
, Qnil
));
2390 #endif /* S_ISREG && S_ISLNK */
2393 /* Create the copy file with the same record format as the input file */
2394 ofd
= sys_creat (XSTRING (encoded_newname
)->data
, 0666, ifd
);
2397 /* System's default file type was set to binary by _fmode in emacs.c. */
2398 ofd
= creat (XSTRING (encoded_newname
)->data
, S_IREAD
| S_IWRITE
);
2399 #else /* not MSDOS */
2400 ofd
= creat (XSTRING (encoded_newname
)->data
, 0666);
2401 #endif /* not MSDOS */
2404 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
2406 record_unwind_protect (close_file_unwind
, make_number (ofd
));
2410 while ((n
= emacs_read (ifd
, buf
, sizeof buf
)) > 0)
2411 if (emacs_write (ofd
, buf
, n
) != n
)
2412 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2415 /* Closing the output clobbers the file times on some systems. */
2416 if (emacs_close (ofd
) < 0)
2417 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2419 if (input_file_statable_p
)
2421 if (!NILP (keep_time
))
2423 EMACS_TIME atime
, mtime
;
2424 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
2425 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
2426 if (set_file_times (XSTRING (encoded_newname
)->data
,
2428 Fsignal (Qfile_date_error
,
2429 Fcons (build_string ("Cannot set file date"),
2430 Fcons (newname
, Qnil
)));
2433 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2435 #if defined (__DJGPP__) && __DJGPP__ > 1
2436 /* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
2437 and if it can't, it tells so. Otherwise, under MSDOS we usually
2438 get only the READ bit, which will make the copied file read-only,
2439 so it's better not to chmod at all. */
2440 if ((_djstat_flags
& _STFAIL_WRITEBIT
) == 0)
2441 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2442 #endif /* DJGPP version 2 or newer */
2447 #endif /* WINDOWSNT */
2449 /* Discard the unwind protects. */
2450 specpdl_ptr
= specpdl
+ count
;
2456 DEFUN ("make-directory-internal", Fmake_directory_internal
,
2457 Smake_directory_internal
, 1, 1, 0,
2458 "Create a new directory named DIRECTORY.")
2460 Lisp_Object directory
;
2463 Lisp_Object handler
;
2464 Lisp_Object encoded_dir
;
2466 CHECK_STRING (directory
, 0);
2467 directory
= Fexpand_file_name (directory
, Qnil
);
2469 handler
= Ffind_file_name_handler (directory
, Qmake_directory_internal
);
2470 if (!NILP (handler
))
2471 return call2 (handler
, Qmake_directory_internal
, directory
);
2473 encoded_dir
= ENCODE_FILE (directory
);
2475 dir
= XSTRING (encoded_dir
)->data
;
2478 if (mkdir (dir
) != 0)
2480 if (mkdir (dir
, 0777) != 0)
2482 report_file_error ("Creating directory", Flist (1, &directory
));
2487 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
2488 "Delete the directory named DIRECTORY.")
2490 Lisp_Object directory
;
2493 Lisp_Object handler
;
2494 Lisp_Object encoded_dir
;
2496 CHECK_STRING (directory
, 0);
2497 directory
= Fdirectory_file_name (Fexpand_file_name (directory
, Qnil
));
2499 handler
= Ffind_file_name_handler (directory
, Qdelete_directory
);
2500 if (!NILP (handler
))
2501 return call2 (handler
, Qdelete_directory
, directory
);
2503 encoded_dir
= ENCODE_FILE (directory
);
2505 dir
= XSTRING (encoded_dir
)->data
;
2507 if (rmdir (dir
) != 0)
2508 report_file_error ("Removing directory", Flist (1, &directory
));
2513 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
2514 "Delete file named FILENAME.\n\
2515 If file has multiple names, it continues to exist with the other names.")
2517 Lisp_Object filename
;
2519 Lisp_Object handler
;
2520 Lisp_Object encoded_file
;
2522 CHECK_STRING (filename
, 0);
2523 filename
= Fexpand_file_name (filename
, Qnil
);
2525 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
2526 if (!NILP (handler
))
2527 return call2 (handler
, Qdelete_file
, filename
);
2529 encoded_file
= ENCODE_FILE (filename
);
2531 if (0 > unlink (XSTRING (encoded_file
)->data
))
2532 report_file_error ("Removing old name", Flist (1, &filename
));
2537 internal_delete_file_1 (ignore
)
2543 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */
2546 internal_delete_file (filename
)
2547 Lisp_Object filename
;
2549 return NILP (internal_condition_case_1 (Fdelete_file
, filename
,
2550 Qt
, internal_delete_file_1
));
2553 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
2554 "fRename file: \nFRename %s to file: \np",
2555 "Rename FILE as NEWNAME. Both args strings.\n\
2556 If file has names other than FILE, it continues to have those names.\n\
2557 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2558 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2559 A number as third arg means request confirmation if NEWNAME already exists.\n\
2560 This is what happens in interactive use with M-x.")
2561 (file
, newname
, ok_if_already_exists
)
2562 Lisp_Object file
, newname
, ok_if_already_exists
;
2565 Lisp_Object args
[2];
2567 Lisp_Object handler
;
2568 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2569 Lisp_Object encoded_file
, encoded_newname
;
2571 encoded_file
= encoded_newname
= Qnil
;
2572 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2573 CHECK_STRING (file
, 0);
2574 CHECK_STRING (newname
, 1);
2575 file
= Fexpand_file_name (file
, Qnil
);
2576 newname
= Fexpand_file_name (newname
, Qnil
);
2578 /* If the file name has special constructs in it,
2579 call the corresponding file handler. */
2580 handler
= Ffind_file_name_handler (file
, Qrename_file
);
2582 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
2583 if (!NILP (handler
))
2584 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
2585 file
, newname
, ok_if_already_exists
));
2587 encoded_file
= ENCODE_FILE (file
);
2588 encoded_newname
= ENCODE_FILE (newname
);
2591 /* If the file names are identical but for the case, don't ask for
2592 confirmation: they simply want to change the letter-case of the
2594 if (NILP (Fstring_equal (Fdowncase (file
), Fdowncase (newname
))))
2596 if (NILP (ok_if_already_exists
)
2597 || INTEGERP (ok_if_already_exists
))
2598 barf_or_query_if_file_exists (encoded_newname
, "rename to it",
2599 INTEGERP (ok_if_already_exists
), 0, 0);
2601 if (0 > rename (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2603 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
)
2604 || 0 > unlink (XSTRING (encoded_file
)->data
))
2609 Fcopy_file (file
, newname
,
2610 /* We have already prompted if it was an integer,
2611 so don't have copy-file prompt again. */
2612 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
2613 Fdelete_file (file
);
2620 report_file_error ("Renaming", Flist (2, args
));
2623 report_file_error ("Renaming", Flist (2, &file
));
2630 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
2631 "fAdd name to file: \nFName to add to %s: \np",
2632 "Give FILE additional name NEWNAME. Both args strings.\n\
2633 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2634 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2635 A number as third arg means request confirmation if NEWNAME already exists.\n\
2636 This is what happens in interactive use with M-x.")
2637 (file
, newname
, ok_if_already_exists
)
2638 Lisp_Object file
, newname
, ok_if_already_exists
;
2641 Lisp_Object args
[2];
2643 Lisp_Object handler
;
2644 Lisp_Object encoded_file
, encoded_newname
;
2645 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2647 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2648 encoded_file
= encoded_newname
= Qnil
;
2649 CHECK_STRING (file
, 0);
2650 CHECK_STRING (newname
, 1);
2651 file
= Fexpand_file_name (file
, Qnil
);
2652 newname
= Fexpand_file_name (newname
, Qnil
);
2654 /* If the file name has special constructs in it,
2655 call the corresponding file handler. */
2656 handler
= Ffind_file_name_handler (file
, Qadd_name_to_file
);
2657 if (!NILP (handler
))
2658 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2659 newname
, ok_if_already_exists
));
2661 /* If the new name has special constructs in it,
2662 call the corresponding file handler. */
2663 handler
= Ffind_file_name_handler (newname
, Qadd_name_to_file
);
2664 if (!NILP (handler
))
2665 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2666 newname
, ok_if_already_exists
));
2668 encoded_file
= ENCODE_FILE (file
);
2669 encoded_newname
= ENCODE_FILE (newname
);
2671 if (NILP (ok_if_already_exists
)
2672 || INTEGERP (ok_if_already_exists
))
2673 barf_or_query_if_file_exists (encoded_newname
, "make it a new name",
2674 INTEGERP (ok_if_already_exists
), 0, 0);
2676 unlink (XSTRING (newname
)->data
);
2677 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2682 report_file_error ("Adding new name", Flist (2, args
));
2684 report_file_error ("Adding new name", Flist (2, &file
));
2693 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2694 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2695 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
2696 Signals a `file-already-exists' error if a file LINKNAME already exists\n\
2697 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2698 A number as third arg means request confirmation if LINKNAME already exists.\n\
2699 This happens for interactive use with M-x.")
2700 (filename
, linkname
, ok_if_already_exists
)
2701 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2704 Lisp_Object args
[2];
2706 Lisp_Object handler
;
2707 Lisp_Object encoded_filename
, encoded_linkname
;
2708 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2710 GCPRO4 (filename
, linkname
, encoded_filename
, encoded_linkname
);
2711 encoded_filename
= encoded_linkname
= Qnil
;
2712 CHECK_STRING (filename
, 0);
2713 CHECK_STRING (linkname
, 1);
2714 /* If the link target has a ~, we must expand it to get
2715 a truly valid file name. Otherwise, do not expand;
2716 we want to permit links to relative file names. */
2717 if (XSTRING (filename
)->data
[0] == '~')
2718 filename
= Fexpand_file_name (filename
, Qnil
);
2719 linkname
= Fexpand_file_name (linkname
, Qnil
);
2721 /* If the file name has special constructs in it,
2722 call the corresponding file handler. */
2723 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2724 if (!NILP (handler
))
2725 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2726 linkname
, ok_if_already_exists
));
2728 /* If the new link name has special constructs in it,
2729 call the corresponding file handler. */
2730 handler
= Ffind_file_name_handler (linkname
, Qmake_symbolic_link
);
2731 if (!NILP (handler
))
2732 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2733 linkname
, ok_if_already_exists
));
2735 encoded_filename
= ENCODE_FILE (filename
);
2736 encoded_linkname
= ENCODE_FILE (linkname
);
2738 if (NILP (ok_if_already_exists
)
2739 || INTEGERP (ok_if_already_exists
))
2740 barf_or_query_if_file_exists (encoded_linkname
, "make it a link",
2741 INTEGERP (ok_if_already_exists
), 0, 0);
2742 if (0 > symlink (XSTRING (encoded_filename
)->data
,
2743 XSTRING (encoded_linkname
)->data
))
2745 /* If we didn't complain already, silently delete existing file. */
2746 if (errno
== EEXIST
)
2748 unlink (XSTRING (encoded_linkname
)->data
);
2749 if (0 <= symlink (XSTRING (encoded_filename
)->data
,
2750 XSTRING (encoded_linkname
)->data
))
2760 report_file_error ("Making symbolic link", Flist (2, args
));
2762 report_file_error ("Making symbolic link", Flist (2, &filename
));
2768 #endif /* S_IFLNK */
2772 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2773 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2774 "Define the job-wide logical name NAME to have the value STRING.\n\
2775 If STRING is nil or a null string, the logical name NAME is deleted.")
2780 CHECK_STRING (name
, 0);
2782 delete_logical_name (XSTRING (name
)->data
);
2785 CHECK_STRING (string
, 1);
2787 if (XSTRING (string
)->size
== 0)
2788 delete_logical_name (XSTRING (name
)->data
);
2790 define_logical_name (XSTRING (name
)->data
, XSTRING (string
)->data
);
2799 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2800 "Open a network connection to PATH using LOGIN as the login string.")
2802 Lisp_Object path
, login
;
2806 CHECK_STRING (path
, 0);
2807 CHECK_STRING (login
, 0);
2809 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2811 if (netresult
== -1)
2816 #endif /* HPUX_NET */
2818 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2820 "Return t if file FILENAME specifies an absolute file name.\n\
2821 On Unix, this is a name starting with a `/' or a `~'.")
2823 Lisp_Object filename
;
2827 CHECK_STRING (filename
, 0);
2828 ptr
= XSTRING (filename
)->data
;
2829 if (IS_DIRECTORY_SEP (*ptr
) || *ptr
== '~'
2831 /* ??? This criterion is probably wrong for '<'. */
2832 || index (ptr
, ':') || index (ptr
, '<')
2833 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2837 || (IS_DRIVE (*ptr
) && ptr
[1] == ':' && IS_DIRECTORY_SEP (ptr
[2]))
2845 /* Return nonzero if file FILENAME exists and can be executed. */
2848 check_executable (filename
)
2852 int len
= strlen (filename
);
2855 if (stat (filename
, &st
) < 0)
2857 #if defined (WINDOWSNT) || (defined (MSDOS) && __DJGPP__ > 1)
2858 return ((st
.st_mode
& S_IEXEC
) != 0);
2860 return (S_ISREG (st
.st_mode
)
2862 && (stricmp ((suffix
= filename
+ len
-4), ".com") == 0
2863 || stricmp (suffix
, ".exe") == 0
2864 || stricmp (suffix
, ".bat") == 0)
2865 || (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2866 #endif /* not WINDOWSNT */
2867 #else /* not DOS_NT */
2868 #ifdef HAVE_EUIDACCESS
2869 return (euidaccess (filename
, 1) >= 0);
2871 /* Access isn't quite right because it uses the real uid
2872 and we really want to test with the effective uid.
2873 But Unix doesn't give us a right way to do it. */
2874 return (access (filename
, 1) >= 0);
2876 #endif /* not DOS_NT */
2879 /* Return nonzero if file FILENAME exists and can be written. */
2882 check_writable (filename
)
2887 if (stat (filename
, &st
) < 0)
2889 return (st
.st_mode
& S_IWRITE
|| (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2890 #else /* not MSDOS */
2891 #ifdef HAVE_EUIDACCESS
2892 return (euidaccess (filename
, 2) >= 0);
2894 /* Access isn't quite right because it uses the real uid
2895 and we really want to test with the effective uid.
2896 But Unix doesn't give us a right way to do it.
2897 Opening with O_WRONLY could work for an ordinary file,
2898 but would lose for directories. */
2899 return (access (filename
, 2) >= 0);
2901 #endif /* not MSDOS */
2904 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2905 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
2906 See also `file-readable-p' and `file-attributes'.")
2908 Lisp_Object filename
;
2910 Lisp_Object absname
;
2911 Lisp_Object handler
;
2912 struct stat statbuf
;
2914 CHECK_STRING (filename
, 0);
2915 absname
= Fexpand_file_name (filename
, Qnil
);
2917 /* If the file name has special constructs in it,
2918 call the corresponding file handler. */
2919 handler
= Ffind_file_name_handler (absname
, Qfile_exists_p
);
2920 if (!NILP (handler
))
2921 return call2 (handler
, Qfile_exists_p
, absname
);
2923 absname
= ENCODE_FILE (absname
);
2925 return (stat (XSTRING (absname
)->data
, &statbuf
) >= 0) ? Qt
: Qnil
;
2928 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2929 "Return t if FILENAME can be executed by you.\n\
2930 For a directory, this means you can access files in that directory.")
2932 Lisp_Object filename
;
2935 Lisp_Object absname
;
2936 Lisp_Object handler
;
2938 CHECK_STRING (filename
, 0);
2939 absname
= Fexpand_file_name (filename
, Qnil
);
2941 /* If the file name has special constructs in it,
2942 call the corresponding file handler. */
2943 handler
= Ffind_file_name_handler (absname
, Qfile_executable_p
);
2944 if (!NILP (handler
))
2945 return call2 (handler
, Qfile_executable_p
, absname
);
2947 absname
= ENCODE_FILE (absname
);
2949 return (check_executable (XSTRING (absname
)->data
) ? Qt
: Qnil
);
2952 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2953 "Return t if file FILENAME exists and you can read it.\n\
2954 See also `file-exists-p' and `file-attributes'.")
2956 Lisp_Object filename
;
2958 Lisp_Object absname
;
2959 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_readable_p
);
2970 if (!NILP (handler
))
2971 return call2 (handler
, Qfile_readable_p
, absname
);
2973 absname
= ENCODE_FILE (absname
);
2975 #if defined(DOS_NT) || defined(macintosh)
2976 /* Under MS-DOS, Windows, and Macintosh, open does not work for
2978 if (access (XSTRING (absname
)->data
, 0) == 0)
2981 #else /* not DOS_NT and not macintosh */
2983 #if defined (S_ISFIFO) && defined (O_NONBLOCK)
2984 /* Opening a fifo without O_NONBLOCK can wait.
2985 We don't want to wait. But we don't want to mess wth O_NONBLOCK
2986 except in the case of a fifo, on a system which handles it. */
2987 desc
= stat (XSTRING (absname
)->data
, &statbuf
);
2990 if (S_ISFIFO (statbuf
.st_mode
))
2991 flags
|= O_NONBLOCK
;
2993 desc
= emacs_open (XSTRING (absname
)->data
, flags
, 0);
2998 #endif /* not DOS_NT and not macintosh */
3001 /* Having this before file-symlink-p mysteriously caused it to be forgotten
3003 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
3004 "Return t if file FILENAME can be written or created by you.")
3006 Lisp_Object filename
;
3008 Lisp_Object absname
, dir
, encoded
;
3009 Lisp_Object handler
;
3010 struct stat statbuf
;
3012 CHECK_STRING (filename
, 0);
3013 absname
= Fexpand_file_name (filename
, Qnil
);
3015 /* If the file name has special constructs in it,
3016 call the corresponding file handler. */
3017 handler
= Ffind_file_name_handler (absname
, Qfile_writable_p
);
3018 if (!NILP (handler
))
3019 return call2 (handler
, Qfile_writable_p
, absname
);
3021 encoded
= ENCODE_FILE (absname
);
3022 if (stat (XSTRING (encoded
)->data
, &statbuf
) >= 0)
3023 return (check_writable (XSTRING (encoded
)->data
)
3026 dir
= Ffile_name_directory (absname
);
3029 dir
= Fdirectory_file_name (dir
);
3033 dir
= Fdirectory_file_name (dir
);
3036 dir
= ENCODE_FILE (dir
);
3038 /* The read-only attribute of the parent directory doesn't affect
3039 whether a file or directory can be created within it. Some day we
3040 should check ACLs though, which do affect this. */
3041 if (stat (XSTRING (dir
)->data
, &statbuf
) < 0)
3043 return (statbuf
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
3045 return (check_writable (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "")
3050 DEFUN ("access-file", Faccess_file
, Saccess_file
, 2, 2, 0,
3051 "Access file FILENAME, and get an error if that does not work.\n\
3052 The second argument STRING is used in the error message.\n\
3053 If there is no error, we return nil.")
3055 Lisp_Object filename
, string
;
3057 Lisp_Object handler
, encoded_filename
;
3060 CHECK_STRING (filename
, 0);
3061 CHECK_STRING (string
, 1);
3063 /* If the file name has special constructs in it,
3064 call the corresponding file handler. */
3065 handler
= Ffind_file_name_handler (filename
, Qaccess_file
);
3066 if (!NILP (handler
))
3067 return call3 (handler
, Qaccess_file
, filename
, string
);
3069 encoded_filename
= ENCODE_FILE (filename
);
3071 fd
= emacs_open (XSTRING (encoded_filename
)->data
, O_RDONLY
, 0);
3073 report_file_error (XSTRING (string
)->data
, Fcons (filename
, Qnil
));
3079 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
3080 "Return non-nil if file FILENAME is the name of a symbolic link.\n\
3081 The value is the name of the file to which it is linked.\n\
3082 Otherwise returns nil.")
3084 Lisp_Object filename
;
3091 Lisp_Object handler
;
3093 CHECK_STRING (filename
, 0);
3094 filename
= Fexpand_file_name (filename
, Qnil
);
3096 /* If the file name has special constructs in it,
3097 call the corresponding file handler. */
3098 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
3099 if (!NILP (handler
))
3100 return call2 (handler
, Qfile_symlink_p
, filename
);
3102 filename
= ENCODE_FILE (filename
);
3109 buf
= (char *) xrealloc (buf
, bufsize
);
3110 bzero (buf
, bufsize
);
3113 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
3117 /* HP-UX reports ERANGE if buffer is too small. */
3118 if (errno
== ERANGE
)
3128 while (valsize
>= bufsize
);
3130 val
= make_string (buf
, valsize
);
3131 if (buf
[0] == '/' && index (buf
, ':'))
3132 val
= concat2 (build_string ("/:"), val
);
3134 val
= DECODE_FILE (val
);
3136 #else /* not S_IFLNK */
3138 #endif /* not S_IFLNK */
3141 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
3142 "Return t if FILENAME names an existing directory.\n\
3143 Symbolic links to directories count as directories.\n\
3144 See `file-symlink-p' to distinguish symlinks.")
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_directory_p
);
3157 if (!NILP (handler
))
3158 return call2 (handler
, Qfile_directory_p
, absname
);
3160 absname
= ENCODE_FILE (absname
);
3162 if (stat (XSTRING (absname
)->data
, &st
) < 0)
3164 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
3167 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
3168 "Return t if file FILENAME is the name of a directory as a file,\n\
3169 and files in that directory can be opened by you. In order to use a\n\
3170 directory as a buffer's current directory, this predicate must return true.\n\
3171 A directory name spec may be given instead; then the value is t\n\
3172 if the directory so specified exists and really is a readable and\n\
3173 searchable directory.")
3175 Lisp_Object filename
;
3177 Lisp_Object handler
;
3179 struct gcpro gcpro1
;
3181 /* If the file name has special constructs in it,
3182 call the corresponding file handler. */
3183 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
3184 if (!NILP (handler
))
3185 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
3187 /* It's an unlikely combination, but yes we really do need to gcpro:
3188 Suppose that file-accessible-directory-p has no handler, but
3189 file-directory-p does have a handler; this handler causes a GC which
3190 relocates the string in `filename'; and finally file-directory-p
3191 returns non-nil. Then we would end up passing a garbaged string
3192 to file-executable-p. */
3194 tem
= (NILP (Ffile_directory_p (filename
))
3195 || NILP (Ffile_executable_p (filename
)));
3197 return tem
? Qnil
: Qt
;
3200 DEFUN ("file-regular-p", Ffile_regular_p
, Sfile_regular_p
, 1, 1, 0,
3201 "Return t if file FILENAME is the name of a regular file.\n\
3202 This is the sort of file that holds an ordinary stream of data bytes.")
3204 Lisp_Object filename
;
3206 register Lisp_Object absname
;
3208 Lisp_Object handler
;
3210 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
3212 /* If the file name has special constructs in it,
3213 call the corresponding file handler. */
3214 handler
= Ffind_file_name_handler (absname
, Qfile_regular_p
);
3215 if (!NILP (handler
))
3216 return call2 (handler
, Qfile_regular_p
, absname
);
3218 absname
= ENCODE_FILE (absname
);
3223 Lisp_Object tem
= Vw32_get_true_file_attributes
;
3225 /* Tell stat to use expensive method to get accurate info. */
3226 Vw32_get_true_file_attributes
= Qt
;
3227 result
= stat (XSTRING (absname
)->data
, &st
);
3228 Vw32_get_true_file_attributes
= tem
;
3232 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
3235 if (stat (XSTRING (absname
)->data
, &st
) < 0)
3237 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
3241 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
3242 "Return mode bits of file named FILENAME, as an integer.")
3244 Lisp_Object filename
;
3246 Lisp_Object absname
;
3248 Lisp_Object handler
;
3250 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
3252 /* If the file name has special constructs in it,
3253 call the corresponding file handler. */
3254 handler
= Ffind_file_name_handler (absname
, Qfile_modes
);
3255 if (!NILP (handler
))
3256 return call2 (handler
, Qfile_modes
, absname
);
3258 absname
= ENCODE_FILE (absname
);
3260 if (stat (XSTRING (absname
)->data
, &st
) < 0)
3262 #if defined (MSDOS) && __DJGPP__ < 2
3263 if (check_executable (XSTRING (absname
)->data
))
3264 st
.st_mode
|= S_IEXEC
;
3265 #endif /* MSDOS && __DJGPP__ < 2 */
3267 return make_number (st
.st_mode
& 07777);
3270 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
3271 "Set mode bits of file named FILENAME to MODE (an integer).\n\
3272 Only the 12 low bits of MODE are used.")
3274 Lisp_Object filename
, mode
;
3276 Lisp_Object absname
, encoded_absname
;
3277 Lisp_Object handler
;
3279 absname
= Fexpand_file_name (filename
, current_buffer
->directory
);
3280 CHECK_NUMBER (mode
, 1);
3282 /* If the file name has special constructs in it,
3283 call the corresponding file handler. */
3284 handler
= Ffind_file_name_handler (absname
, Qset_file_modes
);
3285 if (!NILP (handler
))
3286 return call3 (handler
, Qset_file_modes
, absname
, mode
);
3288 encoded_absname
= ENCODE_FILE (absname
);
3290 if (chmod (XSTRING (encoded_absname
)->data
, XINT (mode
)) < 0)
3291 report_file_error ("Doing chmod", Fcons (absname
, Qnil
));
3296 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
3297 "Set the file permission bits for newly created files.\n\
3298 The argument MODE should be an integer; only the low 9 bits are used.\n\
3299 This setting is inherited by subprocesses.")
3303 CHECK_NUMBER (mode
, 0);
3305 umask ((~ XINT (mode
)) & 0777);
3310 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
3311 "Return the default file protection for created files.\n\
3312 The value is an integer.")
3318 realmask
= umask (0);
3321 XSETINT (value
, (~ realmask
) & 0777);
3331 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
3332 "Tell Unix to finish all pending disk updates.")
3341 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
3342 "Return t if file FILE1 is newer than file FILE2.\n\
3343 If FILE1 does not exist, the answer is nil;\n\
3344 otherwise, if FILE2 does not exist, the answer is t.")
3346 Lisp_Object file1
, file2
;
3348 Lisp_Object absname1
, absname2
;
3351 Lisp_Object handler
;
3352 struct gcpro gcpro1
, gcpro2
;
3354 CHECK_STRING (file1
, 0);
3355 CHECK_STRING (file2
, 0);
3358 GCPRO2 (absname1
, file2
);
3359 absname1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
3360 absname2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
3363 /* If the file name has special constructs in it,
3364 call the corresponding file handler. */
3365 handler
= Ffind_file_name_handler (absname1
, Qfile_newer_than_file_p
);
3367 handler
= Ffind_file_name_handler (absname2
, Qfile_newer_than_file_p
);
3368 if (!NILP (handler
))
3369 return call3 (handler
, Qfile_newer_than_file_p
, absname1
, absname2
);
3371 GCPRO2 (absname1
, absname2
);
3372 absname1
= ENCODE_FILE (absname1
);
3373 absname2
= ENCODE_FILE (absname2
);
3376 if (stat (XSTRING (absname1
)->data
, &st
) < 0)
3379 mtime1
= st
.st_mtime
;
3381 if (stat (XSTRING (absname2
)->data
, &st
) < 0)
3384 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
3388 Lisp_Object Qfind_buffer_file_type
;
3391 #ifndef READ_BUF_SIZE
3392 #define READ_BUF_SIZE (64 << 10)
3395 extern void adjust_markers_for_delete
P_ ((int, int, int, int));
3397 /* This function is called after Lisp functions to decide a coding
3398 system are called, or when they cause an error. Before they are
3399 called, the current buffer is set unibyte and it contains only a
3400 newly inserted text (thus the buffer was empty before the
3403 The functions may set markers, overlays, text properties, or even
3404 alter the buffer contents, change the current buffer.
3406 Here, we reset all those changes by:
3407 o set back the current buffer.
3408 o move all markers and overlays to BEG.
3409 o remove all text properties.
3410 o set back the buffer multibyteness. */
3413 decide_coding_unwind (unwind_data
)
3414 Lisp_Object unwind_data
;
3416 Lisp_Object multibyte
, undo_list
, buffer
;
3418 multibyte
= XCAR (unwind_data
);
3419 unwind_data
= XCDR (unwind_data
);
3420 undo_list
= XCAR (unwind_data
);
3421 buffer
= XCDR (unwind_data
);
3423 if (current_buffer
!= XBUFFER (buffer
))
3424 set_buffer_internal (XBUFFER (buffer
));
3425 adjust_markers_for_delete (BEG
, BEG_BYTE
, Z
, Z_BYTE
);
3426 adjust_overlays_for_delete (BEG
, Z
- BEG
);
3427 BUF_INTERVALS (current_buffer
) = 0;
3428 TEMP_SET_PT_BOTH (BEG
, BEG_BYTE
);
3430 /* Now we are safe to change the buffer's multibyteness directly. */
3431 current_buffer
->enable_multibyte_characters
= multibyte
;
3432 current_buffer
->undo_list
= undo_list
;
3438 /* Used to pass values from insert-file-contents to read_non_regular. */
3440 static int non_regular_fd
;
3441 static int non_regular_inserted
;
3442 static int non_regular_nbytes
;
3445 /* Read from a non-regular file.
3446 Read non_regular_trytry bytes max from non_regular_fd.
3447 Non_regular_inserted specifies where to put the read bytes.
3448 Value is the number of bytes read. */
3457 nbytes
= emacs_read (non_regular_fd
,
3458 BEG_ADDR
+ PT_BYTE
- 1 + non_regular_inserted
,
3459 non_regular_nbytes
);
3460 Fsignal (Qquit
, Qnil
);
3462 return make_number (nbytes
);
3466 /* Condition-case handler used when reading from non-regular files
3467 in insert-file-contents. */
3470 read_non_regular_quit ()
3476 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
3478 "Insert contents of file FILENAME after point.\n\
3479 Returns list of absolute file name and number of bytes inserted.\n\
3480 If second argument VISIT is non-nil, the buffer's visited filename\n\
3481 and last save file modtime are set, and it is marked unmodified.\n\
3482 If visiting and the file does not exist, visiting is completed\n\
3483 before the error is signaled.\n\
3484 The optional third and fourth arguments BEG and END\n\
3485 specify what portion of the file to insert.\n\
3486 These arguments count bytes in the file, not characters in the buffer.\n\
3487 If VISIT is non-nil, BEG and END must be nil.\n\
3489 If optional fifth argument REPLACE is non-nil,\n\
3490 it means replace the current buffer contents (in the accessible portion)\n\
3491 with the file contents. This is better than simply deleting and inserting\n\
3492 the whole thing because (1) it preserves some marker positions\n\
3493 and (2) it puts less data in the undo list.\n\
3494 When REPLACE is non-nil, the value is the number of characters actually read,\n\
3495 which is often less than the number of characters to be read.\n\
3497 This does code conversion according to the value of\n\
3498 `coding-system-for-read' or `file-coding-system-alist',\n\
3499 and sets the variable `last-coding-system-used' to the coding system\n\
3501 (filename
, visit
, beg
, end
, replace
)
3502 Lisp_Object filename
, visit
, beg
, end
, replace
;
3507 register int how_much
;
3508 register int unprocessed
;
3509 int count
= BINDING_STACK_SIZE ();
3510 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3511 Lisp_Object handler
, val
, insval
, orig_filename
;
3514 int not_regular
= 0;
3515 unsigned char read_buf
[READ_BUF_SIZE
];
3516 struct coding_system coding
;
3517 unsigned char buffer
[1 << 14];
3518 int replace_handled
= 0;
3519 int set_coding_system
= 0;
3520 int coding_system_decided
= 0;
3524 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3525 error ("Cannot do file visiting in an indirect buffer");
3527 if (!NILP (current_buffer
->read_only
))
3528 Fbarf_if_buffer_read_only ();
3532 orig_filename
= Qnil
;
3534 GCPRO4 (filename
, val
, p
, orig_filename
);
3536 CHECK_STRING (filename
, 0);
3537 filename
= Fexpand_file_name (filename
, Qnil
);
3539 /* If the file name has special constructs in it,
3540 call the corresponding file handler. */
3541 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
3542 if (!NILP (handler
))
3544 val
= call6 (handler
, Qinsert_file_contents
, filename
,
3545 visit
, beg
, end
, replace
);
3546 if (CONSP (val
) && CONSP (XCDR (val
)))
3547 inserted
= XINT (XCAR (XCDR (val
)));
3551 orig_filename
= filename
;
3552 filename
= ENCODE_FILE (filename
);
3558 Lisp_Object tem
= Vw32_get_true_file_attributes
;
3560 /* Tell stat to use expensive method to get accurate info. */
3561 Vw32_get_true_file_attributes
= Qt
;
3562 total
= stat (XSTRING (filename
)->data
, &st
);
3563 Vw32_get_true_file_attributes
= tem
;
3568 if (stat (XSTRING (filename
)->data
, &st
) < 0)
3570 if ((fd
= emacs_open (XSTRING (filename
)->data
, O_RDONLY
, 0)) < 0
3571 || fstat (fd
, &st
) < 0)
3572 #endif /* not APOLLO */
3573 #endif /* WINDOWSNT */
3575 if (fd
>= 0) emacs_close (fd
);
3578 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3581 if (!NILP (Vcoding_system_for_read
))
3582 Fset (Qbuffer_file_coding_system
, Vcoding_system_for_read
);
3587 /* This code will need to be changed in order to work on named
3588 pipes, and it's probably just not worth it. So we should at
3589 least signal an error. */
3590 if (!S_ISREG (st
.st_mode
))
3597 if (! NILP (replace
) || ! NILP (beg
) || ! NILP (end
))
3598 Fsignal (Qfile_error
,
3599 Fcons (build_string ("not a regular file"),
3600 Fcons (orig_filename
, Qnil
)));
3605 if ((fd
= emacs_open (XSTRING (filename
)->data
, O_RDONLY
, 0)) < 0)
3608 /* Replacement should preserve point as it preserves markers. */
3609 if (!NILP (replace
))
3610 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
3612 record_unwind_protect (close_file_unwind
, make_number (fd
));
3614 /* Supposedly happens on VMS. */
3615 if (! not_regular
&& st
.st_size
< 0)
3616 error ("File size is negative");
3618 /* Prevent redisplay optimizations. */
3619 current_buffer
->clip_changed
= 1;
3623 if (!NILP (beg
) || !NILP (end
))
3624 error ("Attempt to visit less than an entire file");
3625 if (BEG
< Z
&& NILP (replace
))
3626 error ("Cannot do file visiting in a non-empty buffer");
3630 CHECK_NUMBER (beg
, 0);
3632 XSETFASTINT (beg
, 0);
3635 CHECK_NUMBER (end
, 0);
3640 XSETINT (end
, st
.st_size
);
3642 /* Arithmetic overflow can occur if an Emacs integer cannot
3643 represent the file size, or if the calculations below
3644 overflow. The calculations below double the file size
3645 twice, so check that it can be multiplied by 4 safely. */
3646 if (XINT (end
) != st
.st_size
3647 || ((int) st
.st_size
* 4) / 4 != st
.st_size
)
3648 error ("Maximum buffer size exceeded");
3650 /* The file size returned from stat may be zero, but data
3651 may be readable nonetheless, for example when this is a
3652 file in the /proc filesystem. */
3653 if (st
.st_size
== 0)
3654 XSETINT (end
, READ_BUF_SIZE
);
3660 /* Decide the coding system to use for reading the file now
3661 because we can't use an optimized method for handling
3662 `coding:' tag if the current buffer is not empty. */
3666 if (!NILP (Vcoding_system_for_read
))
3667 val
= Vcoding_system_for_read
;
3668 else if (! NILP (replace
))
3669 /* In REPLACE mode, we can use the same coding system
3670 that was used to visit the file. */
3671 val
= current_buffer
->buffer_file_coding_system
;
3674 /* Don't try looking inside a file for a coding system
3675 specification if it is not seekable. */
3676 if (! not_regular
&& ! NILP (Vset_auto_coding_function
))
3678 /* Find a coding system specified in the heading two
3679 lines or in the tailing several lines of the file.
3680 We assume that the 1K-byte and 3K-byte for heading
3681 and tailing respectively are sufficient for this
3685 if (st
.st_size
<= (1024 * 4))
3686 nread
= emacs_read (fd
, read_buf
, 1024 * 4);
3689 nread
= emacs_read (fd
, read_buf
, 1024);
3692 if (lseek (fd
, st
.st_size
- (1024 * 3), 0) < 0)
3693 report_file_error ("Setting file position",
3694 Fcons (orig_filename
, Qnil
));
3695 nread
+= emacs_read (fd
, read_buf
+ nread
, 1024 * 3);
3700 error ("IO error reading %s: %s",
3701 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3704 struct buffer
*prev
= current_buffer
;
3707 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
3709 /* The call to temp_output_buffer_setup binds
3711 count1
= specpdl_ptr
- specpdl
;
3712 temp_output_buffer_setup (" *code-converting-work*");
3714 set_buffer_internal (XBUFFER (Vstandard_output
));
3715 current_buffer
->enable_multibyte_characters
= Qnil
;
3716 insert_1_both (read_buf
, nread
, nread
, 0, 0, 0);
3717 TEMP_SET_PT_BOTH (BEG
, BEG_BYTE
);
3718 val
= call2 (Vset_auto_coding_function
,
3719 filename
, make_number (nread
));
3720 set_buffer_internal (prev
);
3722 /* Remove the binding for standard-output. */
3723 unbind_to (count1
, Qnil
);
3725 /* Discard the unwind protect for recovering the
3729 /* Rewind the file for the actual read done later. */
3730 if (lseek (fd
, 0, 0) < 0)
3731 report_file_error ("Setting file position",
3732 Fcons (orig_filename
, Qnil
));
3738 /* If we have not yet decided a coding system, check
3739 file-coding-system-alist. */
3740 Lisp_Object args
[6], coding_systems
;
3742 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
;
3743 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = replace
;
3744 coding_systems
= Ffind_operation_coding_system (6, args
);
3745 if (CONSP (coding_systems
))
3746 val
= XCAR (coding_systems
);
3750 setup_coding_system (Fcheck_coding_system (val
), &coding
);
3751 /* Ensure we set Vlast_coding_system_used. */
3752 set_coding_system
= 1;
3754 if (NILP (current_buffer
->enable_multibyte_characters
)
3756 /* We must suppress all character code conversion except for
3757 end-of-line conversion. */
3758 setup_raw_text_coding_system (&coding
);
3760 coding
.src_multibyte
= 0;
3761 coding
.dst_multibyte
3762 = !NILP (current_buffer
->enable_multibyte_characters
);
3763 coding_system_decided
= 1;
3766 /* If requested, replace the accessible part of the buffer
3767 with the file contents. Avoid replacing text at the
3768 beginning or end of the buffer that matches the file contents;
3769 that preserves markers pointing to the unchanged parts.
3771 Here we implement this feature in an optimized way
3772 for the case where code conversion is NOT needed.
3773 The following if-statement handles the case of conversion
3774 in a less optimal way.
3776 If the code conversion is "automatic" then we try using this
3777 method and hope for the best.
3778 But if we discover the need for conversion, we give up on this method
3779 and let the following if-statement handle the replace job. */
3782 && !(coding
.common_flags
& CODING_REQUIRE_DECODING_MASK
))
3784 /* same_at_start and same_at_end count bytes,
3785 because file access counts bytes
3786 and BEG and END count bytes. */
3787 int same_at_start
= BEGV_BYTE
;
3788 int same_at_end
= ZV_BYTE
;
3790 /* There is still a possibility we will find the need to do code
3791 conversion. If that happens, we set this variable to 1 to
3792 give up on handling REPLACE in the optimized way. */
3793 int giveup_match_end
= 0;
3795 if (XINT (beg
) != 0)
3797 if (lseek (fd
, XINT (beg
), 0) < 0)
3798 report_file_error ("Setting file position",
3799 Fcons (orig_filename
, Qnil
));
3804 /* Count how many chars at the start of the file
3805 match the text at the beginning of the buffer. */
3810 nread
= emacs_read (fd
, buffer
, sizeof buffer
);
3812 error ("IO error reading %s: %s",
3813 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3814 else if (nread
== 0)
3817 if (coding
.type
== coding_type_undecided
)
3818 detect_coding (&coding
, buffer
, nread
);
3819 if (coding
.common_flags
& CODING_REQUIRE_DECODING_MASK
)
3820 /* We found that the file should be decoded somehow.
3821 Let's give up here. */
3823 giveup_match_end
= 1;
3827 if (coding
.eol_type
== CODING_EOL_UNDECIDED
)
3828 detect_eol (&coding
, buffer
, nread
);
3829 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3830 && coding
.eol_type
!= CODING_EOL_LF
)
3831 /* We found that the format of eol should be decoded.
3832 Let's give up here. */
3834 giveup_match_end
= 1;
3839 while (bufpos
< nread
&& same_at_start
< ZV_BYTE
3840 && FETCH_BYTE (same_at_start
) == buffer
[bufpos
])
3841 same_at_start
++, bufpos
++;
3842 /* If we found a discrepancy, stop the scan.
3843 Otherwise loop around and scan the next bufferful. */
3844 if (bufpos
!= nread
)
3848 /* If the file matches the buffer completely,
3849 there's no need to replace anything. */
3850 if (same_at_start
- BEGV_BYTE
== XINT (end
))
3854 /* Truncate the buffer to the size of the file. */
3855 del_range_1 (same_at_start
, same_at_end
, 0, 0);
3860 /* Count how many chars at the end of the file
3861 match the text at the end of the buffer. But, if we have
3862 already found that decoding is necessary, don't waste time. */
3863 while (!giveup_match_end
)
3865 int total_read
, nread
, bufpos
, curpos
, trial
;
3867 /* At what file position are we now scanning? */
3868 curpos
= XINT (end
) - (ZV_BYTE
- same_at_end
);
3869 /* If the entire file matches the buffer tail, stop the scan. */
3872 /* How much can we scan in the next step? */
3873 trial
= min (curpos
, sizeof buffer
);
3874 if (lseek (fd
, curpos
- trial
, 0) < 0)
3875 report_file_error ("Setting file position",
3876 Fcons (orig_filename
, Qnil
));
3878 total_read
= nread
= 0;
3879 while (total_read
< trial
)
3881 nread
= emacs_read (fd
, buffer
+ total_read
, trial
- total_read
);
3883 error ("IO error reading %s: %s",
3884 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3885 else if (nread
== 0)
3887 total_read
+= nread
;
3890 /* Scan this bufferful from the end, comparing with
3891 the Emacs buffer. */
3892 bufpos
= total_read
;
3894 /* Compare with same_at_start to avoid counting some buffer text
3895 as matching both at the file's beginning and at the end. */
3896 while (bufpos
> 0 && same_at_end
> same_at_start
3897 && FETCH_BYTE (same_at_end
- 1) == buffer
[bufpos
- 1])
3898 same_at_end
--, bufpos
--;
3900 /* If we found a discrepancy, stop the scan.
3901 Otherwise loop around and scan the preceding bufferful. */
3904 /* If this discrepancy is because of code conversion,
3905 we cannot use this method; giveup and try the other. */
3906 if (same_at_end
> same_at_start
3907 && FETCH_BYTE (same_at_end
- 1) >= 0200
3908 && ! NILP (current_buffer
->enable_multibyte_characters
)
3909 && (CODING_MAY_REQUIRE_DECODING (&coding
)))
3910 giveup_match_end
= 1;
3919 if (! giveup_match_end
)
3923 /* We win! We can handle REPLACE the optimized way. */
3925 /* Extend the start of non-matching text area to multibyte
3926 character boundary. */
3927 if (! NILP (current_buffer
->enable_multibyte_characters
))
3928 while (same_at_start
> BEGV_BYTE
3929 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start
)))
3932 /* Extend the end of non-matching text area to multibyte
3933 character boundary. */
3934 if (! NILP (current_buffer
->enable_multibyte_characters
))
3935 while (same_at_end
< ZV_BYTE
3936 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
3939 /* Don't try to reuse the same piece of text twice. */
3940 overlap
= (same_at_start
- BEGV_BYTE
3941 - (same_at_end
+ st
.st_size
- ZV
));
3943 same_at_end
+= overlap
;
3945 /* Arrange to read only the nonmatching middle part of the file. */
3946 XSETFASTINT (beg
, XINT (beg
) + (same_at_start
- BEGV_BYTE
));
3947 XSETFASTINT (end
, XINT (end
) - (ZV_BYTE
- same_at_end
));
3949 del_range_byte (same_at_start
, same_at_end
, 0);
3950 /* Insert from the file at the proper position. */
3951 temp
= BYTE_TO_CHAR (same_at_start
);
3952 SET_PT_BOTH (temp
, same_at_start
);
3954 /* If display currently starts at beginning of line,
3955 keep it that way. */
3956 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3957 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3959 replace_handled
= 1;
3963 /* If requested, replace the accessible part of the buffer
3964 with the file contents. Avoid replacing text at the
3965 beginning or end of the buffer that matches the file contents;
3966 that preserves markers pointing to the unchanged parts.
3968 Here we implement this feature for the case where code conversion
3969 is needed, in a simple way that needs a lot of memory.
3970 The preceding if-statement handles the case of no conversion
3971 in a more optimized way. */
3972 if (!NILP (replace
) && ! replace_handled
&& BEGV
< ZV
)
3974 int same_at_start
= BEGV_BYTE
;
3975 int same_at_end
= ZV_BYTE
;
3978 /* Make sure that the gap is large enough. */
3979 int bufsize
= 2 * st
.st_size
;
3980 unsigned char *conversion_buffer
= (unsigned char *) xmalloc (bufsize
);
3983 /* First read the whole file, performing code conversion into
3984 CONVERSION_BUFFER. */
3986 if (lseek (fd
, XINT (beg
), 0) < 0)
3988 xfree (conversion_buffer
);
3989 report_file_error ("Setting file position",
3990 Fcons (orig_filename
, Qnil
));
3993 total
= st
.st_size
; /* Total bytes in the file. */
3994 how_much
= 0; /* Bytes read from file so far. */
3995 inserted
= 0; /* Bytes put into CONVERSION_BUFFER so far. */
3996 unprocessed
= 0; /* Bytes not processed in previous loop. */
3998 while (how_much
< total
)
4000 /* try is reserved in some compilers (Microsoft C) */
4001 int trytry
= min (total
- how_much
, READ_BUF_SIZE
- unprocessed
);
4002 unsigned char *destination
= read_buf
+ unprocessed
;
4005 /* Allow quitting out of the actual I/O. */
4008 this = emacs_read (fd
, destination
, trytry
);
4011 if (this < 0 || this + unprocessed
== 0)
4019 if (CODING_MAY_REQUIRE_DECODING (&coding
))
4021 int require
, result
;
4023 this += unprocessed
;
4025 /* If we are using more space than estimated,
4026 make CONVERSION_BUFFER bigger. */
4027 require
= decoding_buffer_size (&coding
, this);
4028 if (inserted
+ require
+ 2 * (total
- how_much
) > bufsize
)
4030 bufsize
= inserted
+ require
+ 2 * (total
- how_much
);
4031 conversion_buffer
= (unsigned char *) xrealloc (conversion_buffer
, bufsize
);
4034 /* Convert this batch with results in CONVERSION_BUFFER. */
4035 if (how_much
>= total
) /* This is the last block. */
4036 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4037 if (coding
.composing
!= COMPOSITION_DISABLED
)
4038 coding_allocate_composition_data (&coding
, BEGV
);
4039 result
= decode_coding (&coding
, read_buf
,
4040 conversion_buffer
+ inserted
,
4041 this, bufsize
- inserted
);
4043 /* Save for next iteration whatever we didn't convert. */
4044 unprocessed
= this - coding
.consumed
;
4045 bcopy (read_buf
+ coding
.consumed
, read_buf
, unprocessed
);
4046 if (!NILP (current_buffer
->enable_multibyte_characters
))
4047 this = coding
.produced
;
4049 this = str_as_unibyte (conversion_buffer
+ inserted
,
4056 /* At this point, INSERTED is how many characters (i.e. bytes)
4057 are present in CONVERSION_BUFFER.
4058 HOW_MUCH should equal TOTAL,
4059 or should be <= 0 if we couldn't read the file. */
4063 xfree (conversion_buffer
);
4066 error ("IO error reading %s: %s",
4067 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
4068 else if (how_much
== -2)
4069 error ("maximum buffer size exceeded");
4072 /* Compare the beginning of the converted file
4073 with the buffer text. */
4076 while (bufpos
< inserted
&& same_at_start
< same_at_end
4077 && FETCH_BYTE (same_at_start
) == conversion_buffer
[bufpos
])
4078 same_at_start
++, bufpos
++;
4080 /* If the file matches the buffer completely,
4081 there's no need to replace anything. */
4083 if (bufpos
== inserted
)
4085 xfree (conversion_buffer
);
4088 /* Truncate the buffer to the size of the file. */
4089 del_range_byte (same_at_start
, same_at_end
, 0);
4094 /* Extend the start of non-matching text area to multibyte
4095 character boundary. */
4096 if (! NILP (current_buffer
->enable_multibyte_characters
))
4097 while (same_at_start
> BEGV_BYTE
4098 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start
)))
4101 /* Scan this bufferful from the end, comparing with
4102 the Emacs buffer. */
4105 /* Compare with same_at_start to avoid counting some buffer text
4106 as matching both at the file's beginning and at the end. */
4107 while (bufpos
> 0 && same_at_end
> same_at_start
4108 && FETCH_BYTE (same_at_end
- 1) == conversion_buffer
[bufpos
- 1])
4109 same_at_end
--, bufpos
--;
4111 /* Extend the end of non-matching text area to multibyte
4112 character boundary. */
4113 if (! NILP (current_buffer
->enable_multibyte_characters
))
4114 while (same_at_end
< ZV_BYTE
4115 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
4118 /* Don't try to reuse the same piece of text twice. */
4119 overlap
= same_at_start
- BEGV_BYTE
- (same_at_end
+ inserted
- ZV_BYTE
);
4121 same_at_end
+= overlap
;
4123 /* If display currently starts at beginning of line,
4124 keep it that way. */
4125 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
4126 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
4128 /* Replace the chars that we need to replace,
4129 and update INSERTED to equal the number of bytes
4130 we are taking from the file. */
4131 inserted
-= (Z_BYTE
- same_at_end
) + (same_at_start
- BEG_BYTE
);
4133 if (same_at_end
!= same_at_start
)
4135 del_range_byte (same_at_start
, same_at_end
, 0);
4137 same_at_start
= GPT_BYTE
;
4141 temp
= BYTE_TO_CHAR (same_at_start
);
4143 /* Insert from the file at the proper position. */
4144 SET_PT_BOTH (temp
, same_at_start
);
4145 insert_1 (conversion_buffer
+ same_at_start
- BEG_BYTE
, inserted
,
4147 if (coding
.cmp_data
&& coding
.cmp_data
->used
)
4148 coding_restore_composition (&coding
, Fcurrent_buffer ());
4149 coding_free_composition_data (&coding
);
4151 /* Set `inserted' to the number of inserted characters. */
4152 inserted
= PT
- temp
;
4154 xfree (conversion_buffer
);
4163 register Lisp_Object temp
;
4165 total
= XINT (end
) - XINT (beg
);
4167 /* Make sure point-max won't overflow after this insertion. */
4168 XSETINT (temp
, total
);
4169 if (total
!= XINT (temp
))
4170 error ("Maximum buffer size exceeded");
4173 /* For a special file, all we can do is guess. */
4174 total
= READ_BUF_SIZE
;
4176 if (NILP (visit
) && total
> 0)
4177 prepare_to_modify_buffer (PT
, PT
, NULL
);
4180 if (GAP_SIZE
< total
)
4181 make_gap (total
- GAP_SIZE
);
4183 if (XINT (beg
) != 0 || !NILP (replace
))
4185 if (lseek (fd
, XINT (beg
), 0) < 0)
4186 report_file_error ("Setting file position",
4187 Fcons (orig_filename
, Qnil
));
4190 /* In the following loop, HOW_MUCH contains the total bytes read so
4191 far for a regular file, and not changed for a special file. But,
4192 before exiting the loop, it is set to a negative value if I/O
4196 /* Total bytes inserted. */
4199 /* Here, we don't do code conversion in the loop. It is done by
4200 code_convert_region after all data are read into the buffer. */
4202 int gap_size
= GAP_SIZE
;
4204 while (how_much
< total
)
4206 /* try is reserved in some compilers (Microsoft C) */
4207 int trytry
= min (total
- how_much
, READ_BUF_SIZE
);
4214 /* Maybe make more room. */
4215 if (gap_size
< trytry
)
4217 make_gap (total
- gap_size
);
4218 gap_size
= GAP_SIZE
;
4221 /* Read from the file, capturing `quit'. When an
4222 error occurs, end the loop, and arrange for a quit
4223 to be signaled after decoding the text we read. */
4224 non_regular_fd
= fd
;
4225 non_regular_inserted
= inserted
;
4226 non_regular_nbytes
= trytry
;
4227 val
= internal_condition_case_1 (read_non_regular
, Qnil
, Qerror
,
4228 read_non_regular_quit
);
4239 /* Allow quitting out of the actual I/O. We don't make text
4240 part of the buffer until all the reading is done, so a C-g
4241 here doesn't do any harm. */
4244 this = emacs_read (fd
, BEG_ADDR
+ PT_BYTE
- 1 + inserted
, trytry
);
4256 /* For a regular file, where TOTAL is the real size,
4257 count HOW_MUCH to compare with it.
4258 For a special file, where TOTAL is just a buffer size,
4259 so don't bother counting in HOW_MUCH.
4260 (INSERTED is where we count the number of characters inserted.) */
4267 /* Make the text read part of the buffer. */
4268 GAP_SIZE
-= inserted
;
4270 GPT_BYTE
+= inserted
;
4272 ZV_BYTE
+= inserted
;
4277 /* Put an anchor to ensure multi-byte form ends at gap. */
4282 /* Discard the unwind protect for closing the file. */
4286 error ("IO error reading %s: %s",
4287 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
4291 if (! coding_system_decided
)
4293 /* The coding system is not yet decided. Decide it by an
4294 optimized method for handling `coding:' tag.
4296 Note that we can get here only if the buffer was empty
4297 before the insertion. */
4301 if (!NILP (Vcoding_system_for_read
))
4302 val
= Vcoding_system_for_read
;
4305 /* Since we are sure that the current buffer was empty
4306 before the insertion, we can toggle
4307 enable-multibyte-characters directly here without taking
4308 care of marker adjustment and byte combining problem. By
4309 this way, we can run Lisp program safely before decoding
4310 the inserted text. */
4311 Lisp_Object unwind_data
;
4312 int count
= specpdl_ptr
- specpdl
;
4314 unwind_data
= Fcons (current_buffer
->enable_multibyte_characters
,
4315 Fcons (current_buffer
->undo_list
,
4316 Fcurrent_buffer ()));
4317 current_buffer
->enable_multibyte_characters
= Qnil
;
4318 current_buffer
->undo_list
= Qt
;
4319 record_unwind_protect (decide_coding_unwind
, unwind_data
);
4321 if (inserted
> 0 && ! NILP (Vset_auto_coding_function
))
4323 val
= call2 (Vset_auto_coding_function
,
4324 filename
, make_number (inserted
));
4329 /* If the coding system is not yet decided, check
4330 file-coding-system-alist. */
4331 Lisp_Object args
[6], coding_systems
;
4333 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
;
4334 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = Qnil
;
4335 coding_systems
= Ffind_operation_coding_system (6, args
);
4336 if (CONSP (coding_systems
))
4337 val
= XCAR (coding_systems
);
4340 unbind_to (count
, Qnil
);
4341 inserted
= Z_BYTE
- BEG_BYTE
;
4344 /* The following kludgy code is to avoid some compiler bug.
4346 setup_coding_system (val, &coding);
4349 struct coding_system temp_coding
;
4350 setup_coding_system (val
, &temp_coding
);
4351 bcopy (&temp_coding
, &coding
, sizeof coding
);
4353 /* Ensure we set Vlast_coding_system_used. */
4354 set_coding_system
= 1;
4356 if (NILP (current_buffer
->enable_multibyte_characters
)
4358 /* We must suppress all character code conversion except for
4359 end-of-line conversion. */
4360 setup_raw_text_coding_system (&coding
);
4361 coding
.src_multibyte
= 0;
4362 coding
.dst_multibyte
4363 = !NILP (current_buffer
->enable_multibyte_characters
);
4367 /* Can't do this if part of the buffer might be preserved. */
4369 && (coding
.type
== coding_type_no_conversion
4370 || coding
.type
== coding_type_raw_text
))
4372 /* Visiting a file with these coding system makes the buffer
4374 current_buffer
->enable_multibyte_characters
= Qnil
;
4375 coding
.dst_multibyte
= 0;
4378 if (inserted
> 0 || coding
.type
== coding_type_ccl
)
4380 if (CODING_MAY_REQUIRE_DECODING (&coding
))
4382 code_convert_region (PT
, PT_BYTE
, PT
+ inserted
, PT_BYTE
+ inserted
,
4384 inserted
= coding
.produced_char
;
4387 adjust_after_insert (PT
, PT_BYTE
, PT
+ inserted
, PT_BYTE
+ inserted
,
4392 /* Use the conversion type to determine buffer-file-type
4393 (find-buffer-file-type is now used to help determine the
4395 if ((coding
.eol_type
== CODING_EOL_UNDECIDED
4396 || coding
.eol_type
== CODING_EOL_LF
)
4397 && ! CODING_REQUIRE_DECODING (&coding
))
4398 current_buffer
->buffer_file_type
= Qt
;
4400 current_buffer
->buffer_file_type
= Qnil
;
4407 if (!EQ (current_buffer
->undo_list
, Qt
))
4408 current_buffer
->undo_list
= Qnil
;
4410 stat (XSTRING (filename
)->data
, &st
);
4415 current_buffer
->modtime
= st
.st_mtime
;
4416 current_buffer
->filename
= orig_filename
;
4419 SAVE_MODIFF
= MODIFF
;
4420 current_buffer
->auto_save_modified
= MODIFF
;
4421 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4422 #ifdef CLASH_DETECTION
4425 if (!NILP (current_buffer
->file_truename
))
4426 unlock_file (current_buffer
->file_truename
);
4427 unlock_file (filename
);
4429 #endif /* CLASH_DETECTION */
4431 Fsignal (Qfile_error
,
4432 Fcons (build_string ("not a regular file"),
4433 Fcons (orig_filename
, Qnil
)));
4436 /* Decode file format */
4439 int empty_undo_list_p
= 0;
4441 /* If we're anyway going to discard undo information, don't
4442 record it in the first place. The buffer's undo list at this
4443 point is either nil or t when visiting a file. */
4446 empty_undo_list_p
= NILP (current_buffer
->undo_list
);
4447 current_buffer
->undo_list
= Qt
;
4450 insval
= call3 (Qformat_decode
,
4451 Qnil
, make_number (inserted
), visit
);
4452 CHECK_NUMBER (insval
, 0);
4453 inserted
= XFASTINT (insval
);
4456 current_buffer
->undo_list
= empty_undo_list_p
? Qnil
: Qt
;
4459 if (set_coding_system
)
4460 Vlast_coding_system_used
= coding
.symbol
;
4462 /* Call after-change hooks for the inserted text, aside from the case
4463 of normal visiting (not with REPLACE), which is done in a new buffer
4464 "before" the buffer is changed. */
4465 if (inserted
> 0 && total
> 0
4466 && (NILP (visit
) || !NILP (replace
)))
4468 signal_after_change (PT
, 0, inserted
);
4469 update_compositions (PT
, PT
, CHECK_BORDER
);
4472 p
= Vafter_insert_file_functions
;
4475 insval
= call1 (Fcar (p
), make_number (inserted
));
4478 CHECK_NUMBER (insval
, 0);
4479 inserted
= XFASTINT (insval
);
4486 && current_buffer
->modtime
== -1)
4488 /* If visiting nonexistent file, return nil. */
4489 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
4493 Fsignal (Qquit
, Qnil
);
4495 /* ??? Retval needs to be dealt with in all cases consistently. */
4497 val
= Fcons (orig_filename
,
4498 Fcons (make_number (inserted
),
4501 RETURN_UNGCPRO (unbind_to (count
, val
));
4504 static Lisp_Object build_annotations
P_ ((Lisp_Object
, Lisp_Object
,
4507 /* If build_annotations switched buffers, switch back to BUF.
4508 Kill the temporary buffer that was selected in the meantime.
4510 Since this kill only the last temporary buffer, some buffers remain
4511 not killed if build_annotations switched buffers more than once.
4515 build_annotations_unwind (buf
)
4520 if (XBUFFER (buf
) == current_buffer
)
4522 tembuf
= Fcurrent_buffer ();
4524 Fkill_buffer (tembuf
);
4528 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 7,
4529 "r\nFWrite region to file: \ni\ni\ni\np",
4530 "Write current region into specified file.\n\
4531 When called from a program, takes three arguments:\n\
4532 START, END and FILENAME. START and END are buffer positions.\n\
4533 Optional fourth argument APPEND if non-nil means\n\
4534 append to existing file contents (if any). If it is an integer,\n\
4535 seek to that offset in the file before writing.\n\
4536 Optional fifth argument VISIT if t means\n\
4537 set the last-save-file-modtime of buffer to this file's modtime\n\
4538 and mark buffer not modified.\n\
4539 If VISIT is a string, it is a second file name;\n\
4540 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
4541 VISIT is also the file name to lock and unlock for clash detection.\n\
4542 If VISIT is neither t nor nil nor a string,\n\
4543 that means do not print the \"Wrote file\" message.\n\
4544 The optional sixth arg LOCKNAME, if non-nil, specifies the name to\n\
4545 use for locking and unlocking, overriding FILENAME and VISIT.\n\
4546 The optional seventh arg MUSTBENEW, if non-nil, insists on a check\n\
4547 for an existing file with the same name. If MUSTBENEW is `excl',\n\
4548 that means to get an error if the file already exists; never overwrite.\n\
4549 If MUSTBENEW is neither nil nor `excl', that means ask for\n\
4550 confirmation before overwriting, but do go ahead and overwrite the file\n\
4551 if the user confirms.\n\
4552 Kludgy feature: if START is a string, then that string is written\n\
4553 to the file, instead of any buffer contents, and END is ignored.\n\
4555 This does code conversion according to the value of\n\
4556 `coding-system-for-write', `buffer-file-coding-system', or\n\
4557 `file-coding-system-alist', and sets the variable\n\
4558 `last-coding-system-used' to the coding system actually used.")
4560 (start
, end
, filename
, append
, visit
, lockname
, mustbenew
)
4561 Lisp_Object start
, end
, filename
, append
, visit
, lockname
, mustbenew
;
4569 int count
= specpdl_ptr
- specpdl
;
4572 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
4574 Lisp_Object handler
;
4575 Lisp_Object visit_file
;
4576 Lisp_Object annotations
;
4577 Lisp_Object encoded_filename
;
4578 int visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
4579 int quietly
= !NILP (visit
);
4580 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
4581 struct buffer
*given_buffer
;
4583 int buffer_file_type
= O_BINARY
;
4585 struct coding_system coding
;
4587 if (current_buffer
->base_buffer
&& visiting
)
4588 error ("Cannot do file visiting in an indirect buffer");
4590 if (!NILP (start
) && !STRINGP (start
))
4591 validate_region (&start
, &end
);
4593 GCPRO4 (start
, filename
, visit
, lockname
);
4595 /* Decide the coding-system to encode the data with. */
4601 else if (!NILP (Vcoding_system_for_write
))
4602 val
= Vcoding_system_for_write
;
4605 /* If the variable `buffer-file-coding-system' is set locally,
4606 it means that the file was read with some kind of code
4607 conversion or the variable is explicitly set by users. We
4608 had better write it out with the same coding system even if
4609 `enable-multibyte-characters' is nil.
4611 If it is not set locally, we anyway have to convert EOL
4612 format if the default value of `buffer-file-coding-system'
4613 tells that it is not Unix-like (LF only) format. */
4614 int using_default_coding
= 0;
4615 int force_raw_text
= 0;
4617 val
= current_buffer
->buffer_file_coding_system
;
4619 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4622 if (NILP (current_buffer
->enable_multibyte_characters
))
4628 /* Check file-coding-system-alist. */
4629 Lisp_Object args
[7], coding_systems
;
4631 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4632 args
[3] = filename
; args
[4] = append
; args
[5] = visit
;
4634 coding_systems
= Ffind_operation_coding_system (7, args
);
4635 if (CONSP (coding_systems
) && !NILP (XCDR (coding_systems
)))
4636 val
= XCDR (coding_systems
);
4640 && !NILP (current_buffer
->buffer_file_coding_system
))
4642 /* If we still have not decided a coding system, use the
4643 default value of buffer-file-coding-system. */
4644 val
= current_buffer
->buffer_file_coding_system
;
4645 using_default_coding
= 1;
4649 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4650 /* Confirm that VAL can surely encode the current region. */
4651 val
= call3 (Vselect_safe_coding_system_function
, start
, end
, val
);
4653 setup_coding_system (Fcheck_coding_system (val
), &coding
);
4654 if (coding
.eol_type
== CODING_EOL_UNDECIDED
4655 && !using_default_coding
)
4657 if (! EQ (default_buffer_file_coding
.symbol
,
4658 buffer_defaults
.buffer_file_coding_system
))
4659 setup_coding_system (buffer_defaults
.buffer_file_coding_system
,
4660 &default_buffer_file_coding
);
4661 if (default_buffer_file_coding
.eol_type
!= CODING_EOL_UNDECIDED
)
4663 Lisp_Object subsidiaries
;
4665 coding
.eol_type
= default_buffer_file_coding
.eol_type
;
4666 subsidiaries
= Fget (coding
.symbol
, Qeol_type
);
4667 if (VECTORP (subsidiaries
)
4668 && XVECTOR (subsidiaries
)->size
== 3)
4670 = XVECTOR (subsidiaries
)->contents
[coding
.eol_type
];
4675 setup_raw_text_coding_system (&coding
);
4676 goto done_setup_coding
;
4679 setup_coding_system (Fcheck_coding_system (val
), &coding
);
4682 if (!STRINGP (start
) && !NILP (current_buffer
->selective_display
))
4683 coding
.mode
|= CODING_MODE_SELECTIVE_DISPLAY
;
4686 Vlast_coding_system_used
= coding
.symbol
;
4688 filename
= Fexpand_file_name (filename
, Qnil
);
4690 if (! NILP (mustbenew
) && !EQ (mustbenew
, Qexcl
))
4691 barf_or_query_if_file_exists (filename
, "overwrite", 1, 0, 1);
4693 if (STRINGP (visit
))
4694 visit_file
= Fexpand_file_name (visit
, Qnil
);
4696 visit_file
= filename
;
4701 if (NILP (lockname
))
4702 lockname
= visit_file
;
4704 GCPRO5 (start
, filename
, annotations
, visit_file
, lockname
);
4706 /* If the file name has special constructs in it,
4707 call the corresponding file handler. */
4708 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
4709 /* If FILENAME has no handler, see if VISIT has one. */
4710 if (NILP (handler
) && STRINGP (visit
))
4711 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
4713 if (!NILP (handler
))
4716 val
= call6 (handler
, Qwrite_region
, start
, end
,
4717 filename
, append
, visit
);
4721 SAVE_MODIFF
= MODIFF
;
4722 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4723 current_buffer
->filename
= visit_file
;
4729 /* Special kludge to simplify auto-saving. */
4732 XSETFASTINT (start
, BEG
);
4733 XSETFASTINT (end
, Z
);
4736 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
4737 count1
= specpdl_ptr
- specpdl
;
4739 given_buffer
= current_buffer
;
4740 annotations
= build_annotations (start
, end
, coding
.pre_write_conversion
);
4741 if (current_buffer
!= given_buffer
)
4743 XSETFASTINT (start
, BEGV
);
4744 XSETFASTINT (end
, ZV
);
4747 #ifdef CLASH_DETECTION
4750 #if 0 /* This causes trouble for GNUS. */
4751 /* If we've locked this file for some other buffer,
4752 query before proceeding. */
4753 if (!visiting
&& EQ (Ffile_locked_p (lockname
), Qt
))
4754 call2 (intern ("ask-user-about-lock"), filename
, Vuser_login_name
);
4757 lock_file (lockname
);
4759 #endif /* CLASH_DETECTION */
4761 encoded_filename
= ENCODE_FILE (filename
);
4763 fn
= XSTRING (encoded_filename
)->data
;
4767 desc
= emacs_open (fn
, O_WRONLY
| buffer_file_type
, 0);
4768 #else /* not DOS_NT */
4769 desc
= emacs_open (fn
, O_WRONLY
, 0);
4770 #endif /* not DOS_NT */
4772 if (desc
< 0 && (NILP (append
) || errno
== ENOENT
))
4774 if (auto_saving
) /* Overwrite any previous version of autosave file */
4776 vms_truncate (fn
); /* if fn exists, truncate to zero length */
4777 desc
= emacs_open (fn
, O_RDWR
, 0);
4779 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
4780 ? XSTRING (current_buffer
->filename
)->data
: 0,
4783 else /* Write to temporary name and rename if no errors */
4785 Lisp_Object temp_name
;
4786 temp_name
= Ffile_name_directory (filename
);
4788 if (!NILP (temp_name
))
4790 temp_name
= Fmake_temp_name (concat2 (temp_name
,
4791 build_string ("$$SAVE$$")));
4792 fname
= XSTRING (filename
)->data
;
4793 fn
= XSTRING (temp_name
)->data
;
4794 desc
= creat_copy_attrs (fname
, fn
);
4797 /* If we can't open the temporary file, try creating a new
4798 version of the original file. VMS "creat" creates a
4799 new version rather than truncating an existing file. */
4802 desc
= creat (fn
, 0666);
4803 #if 0 /* This can clobber an existing file and fail to replace it,
4804 if the user runs out of space. */
4807 /* We can't make a new version;
4808 try to truncate and rewrite existing version if any. */
4810 desc
= emacs_open (fn
, O_RDWR
, 0);
4816 desc
= creat (fn
, 0666);
4820 desc
= emacs_open (fn
,
4821 O_WRONLY
| O_CREAT
| buffer_file_type
4822 | (EQ (mustbenew
, Qexcl
) ? O_EXCL
: O_TRUNC
),
4823 S_IREAD
| S_IWRITE
);
4824 #else /* not DOS_NT */
4825 desc
= emacs_open (fn
, O_WRONLY
| O_TRUNC
| O_CREAT
4826 | (EQ (mustbenew
, Qexcl
) ? O_EXCL
: 0),
4827 auto_saving
? auto_save_mode_bits
: 0666);
4828 #endif /* not DOS_NT */
4829 #endif /* not VMS */
4833 #ifdef CLASH_DETECTION
4835 if (!auto_saving
) unlock_file (lockname
);
4837 #endif /* CLASH_DETECTION */
4839 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
4842 record_unwind_protect (close_file_unwind
, make_number (desc
));
4844 if (!NILP (append
) && !NILP (Ffile_regular_p (filename
)))
4848 if (NUMBERP (append
))
4849 ret
= lseek (desc
, XINT (append
), 1);
4851 ret
= lseek (desc
, 0, 2);
4854 #ifdef CLASH_DETECTION
4855 if (!auto_saving
) unlock_file (lockname
);
4856 #endif /* CLASH_DETECTION */
4858 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
4866 * Kludge Warning: The VMS C RTL likes to insert carriage returns
4867 * if we do writes that don't end with a carriage return. Furthermore
4868 * it cannot handle writes of more then 16K. The modified
4869 * version of "sys_write" in SYSDEP.C (see comment there) copes with
4870 * this EXCEPT for the last record (iff it doesn't end with a carriage
4871 * return). This implies that if your buffer doesn't end with a carriage
4872 * return, you get one free... tough. However it also means that if
4873 * we make two calls to sys_write (a la the following code) you can
4874 * get one at the gap as well. The easiest way to fix this (honest)
4875 * is to move the gap to the next newline (or the end of the buffer).
4880 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4881 move_gap (find_next_newline (GPT
, 1));
4883 /* Whether VMS or not, we must move the gap to the next of newline
4884 when we must put designation sequences at beginning of line. */
4885 if (INTEGERP (start
)
4886 && coding
.type
== coding_type_iso2022
4887 && coding
.flags
& CODING_FLAG_ISO_DESIGNATE_AT_BOL
4888 && GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4890 int opoint
= PT
, opoint_byte
= PT_BYTE
;
4891 scan_newline (PT
, PT_BYTE
, ZV
, ZV_BYTE
, 1, 0);
4892 move_gap_both (PT
, PT_BYTE
);
4893 SET_PT_BOTH (opoint
, opoint_byte
);
4900 if (STRINGP (start
))
4902 failure
= 0 > a_write (desc
, start
, 0, XSTRING (start
)->size
,
4903 &annotations
, &coding
);
4906 else if (XINT (start
) != XINT (end
))
4908 tem
= CHAR_TO_BYTE (XINT (start
));
4910 if (XINT (start
) < GPT
)
4912 failure
= 0 > a_write (desc
, Qnil
, XINT (start
),
4913 min (GPT
, XINT (end
)) - XINT (start
),
4914 &annotations
, &coding
);
4918 if (XINT (end
) > GPT
&& !failure
)
4920 tem
= max (XINT (start
), GPT
);
4921 failure
= 0 > a_write (desc
, Qnil
, tem
, XINT (end
) - tem
,
4922 &annotations
, &coding
);
4928 /* If file was empty, still need to write the annotations */
4929 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4930 failure
= 0 > a_write (desc
, Qnil
, XINT (end
), 0, &annotations
, &coding
);
4934 if (CODING_REQUIRE_FLUSHING (&coding
)
4935 && !(coding
.mode
& CODING_MODE_LAST_BLOCK
)
4938 /* We have to flush out a data. */
4939 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4940 failure
= 0 > e_write (desc
, Qnil
, 0, 0, &coding
);
4947 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
4948 Disk full in NFS may be reported here. */
4949 /* mib says that closing the file will try to write as fast as NFS can do
4950 it, and that means the fsync here is not crucial for autosave files. */
4951 if (!auto_saving
&& fsync (desc
) < 0)
4953 /* If fsync fails with EINTR, don't treat that as serious. */
4955 failure
= 1, save_errno
= errno
;
4959 /* Spurious "file has changed on disk" warnings have been
4960 observed on Suns as well.
4961 It seems that `close' can change the modtime, under nfs.
4963 (This has supposedly been fixed in Sunos 4,
4964 but who knows about all the other machines with NFS?) */
4967 /* On VMS and APOLLO, must do the stat after the close
4968 since closing changes the modtime. */
4971 /* Recall that #if defined does not work on VMS. */
4978 /* NFS can report a write failure now. */
4979 if (emacs_close (desc
) < 0)
4980 failure
= 1, save_errno
= errno
;
4983 /* If we wrote to a temporary name and had no errors, rename to real name. */
4987 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
4995 /* Discard the unwind protect for close_file_unwind. */
4996 specpdl_ptr
= specpdl
+ count1
;
4997 /* Restore the original current buffer. */
4998 visit_file
= unbind_to (count
, visit_file
);
5000 #ifdef CLASH_DETECTION
5002 unlock_file (lockname
);
5003 #endif /* CLASH_DETECTION */
5005 /* Do this before reporting IO error
5006 to avoid a "file has changed on disk" warning on
5007 next attempt to save. */
5009 current_buffer
->modtime
= st
.st_mtime
;
5012 error ("IO error writing %s: %s", XSTRING (filename
)->data
,
5013 emacs_strerror (save_errno
));
5017 SAVE_MODIFF
= MODIFF
;
5018 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
5019 current_buffer
->filename
= visit_file
;
5020 update_mode_lines
++;
5026 message_with_string ("Wrote %s", visit_file
, 1);
5031 Lisp_Object
merge ();
5033 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
5034 "Return t if (car A) is numerically less than (car B).")
5038 return Flss (Fcar (a
), Fcar (b
));
5041 /* Build the complete list of annotations appropriate for writing out
5042 the text between START and END, by calling all the functions in
5043 write-region-annotate-functions and merging the lists they return.
5044 If one of these functions switches to a different buffer, we assume
5045 that buffer contains altered text. Therefore, the caller must
5046 make sure to restore the current buffer in all cases,
5047 as save-excursion would do. */
5050 build_annotations (start
, end
, pre_write_conversion
)
5051 Lisp_Object start
, end
, pre_write_conversion
;
5053 Lisp_Object annotations
;
5055 struct gcpro gcpro1
, gcpro2
;
5056 Lisp_Object original_buffer
;
5059 XSETBUFFER (original_buffer
, current_buffer
);
5062 p
= Vwrite_region_annotate_functions
;
5063 GCPRO2 (annotations
, p
);
5066 struct buffer
*given_buffer
= current_buffer
;
5067 Vwrite_region_annotations_so_far
= annotations
;
5068 res
= call2 (Fcar (p
), start
, end
);
5069 /* If the function makes a different buffer current,
5070 assume that means this buffer contains altered text to be output.
5071 Reset START and END from the buffer bounds
5072 and discard all previous annotations because they should have
5073 been dealt with by this function. */
5074 if (current_buffer
!= given_buffer
)
5076 XSETFASTINT (start
, BEGV
);
5077 XSETFASTINT (end
, ZV
);
5080 Flength (res
); /* Check basic validity of return value */
5081 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
5085 /* Now do the same for annotation functions implied by the file-format */
5086 if (auto_saving
&& (!EQ (Vauto_save_file_format
, Qt
)))
5087 p
= Vauto_save_file_format
;
5089 p
= current_buffer
->file_format
;
5090 for (i
= 0; !NILP (p
); p
= Fcdr (p
), ++i
)
5092 struct buffer
*given_buffer
= current_buffer
;
5094 Vwrite_region_annotations_so_far
= annotations
;
5096 /* Value is either a list of annotations or nil if the function
5097 has written annotations to a temporary buffer, which is now
5099 res
= call5 (Qformat_annotate_function
, Fcar (p
), start
, end
,
5100 original_buffer
, make_number (i
));
5101 if (current_buffer
!= given_buffer
)
5103 XSETFASTINT (start
, BEGV
);
5104 XSETFASTINT (end
, ZV
);
5109 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
5112 /* At last, do the same for the function PRE_WRITE_CONVERSION
5113 implied by the current coding-system. */
5114 if (!NILP (pre_write_conversion
))
5116 struct buffer
*given_buffer
= current_buffer
;
5117 Vwrite_region_annotations_so_far
= annotations
;
5118 res
= call2 (pre_write_conversion
, start
, end
);
5120 annotations
= (current_buffer
!= given_buffer
5122 : merge (annotations
, res
, Qcar_less_than_car
));
5129 /* Write to descriptor DESC the NCHARS chars starting at POS of STRING.
5130 If STRING is nil, POS is the character position in the current buffer.
5131 Intersperse with them the annotations from *ANNOT
5132 which fall within the range of POS to POS + NCHARS,
5133 each at its appropriate position.
5135 We modify *ANNOT by discarding elements as we use them up.
5137 The return value is negative in case of system call failure. */
5140 a_write (desc
, string
, pos
, nchars
, annot
, coding
)
5143 register int nchars
;
5146 struct coding_system
*coding
;
5150 int lastpos
= pos
+ nchars
;
5152 while (NILP (*annot
) || CONSP (*annot
))
5154 tem
= Fcar_safe (Fcar (*annot
));
5157 nextpos
= XFASTINT (tem
);
5159 /* If there are no more annotations in this range,
5160 output the rest of the range all at once. */
5161 if (! (nextpos
>= pos
&& nextpos
<= lastpos
))
5162 return e_write (desc
, string
, pos
, lastpos
, coding
);
5164 /* Output buffer text up to the next annotation's position. */
5167 if (0 > e_write (desc
, string
, pos
, nextpos
, coding
))
5171 /* Output the annotation. */
5172 tem
= Fcdr (Fcar (*annot
));
5175 if (0 > e_write (desc
, tem
, 0, XSTRING (tem
)->size
, coding
))
5178 *annot
= Fcdr (*annot
);
5183 #ifndef WRITE_BUF_SIZE
5184 #define WRITE_BUF_SIZE (16 * 1024)
5187 /* Write text in the range START and END into descriptor DESC,
5188 encoding them with coding system CODING. If STRING is nil, START
5189 and END are character positions of the current buffer, else they
5190 are indexes to the string STRING. */
5193 e_write (desc
, string
, start
, end
, coding
)
5197 struct coding_system
*coding
;
5199 register char *addr
;
5200 register int nbytes
;
5201 char buf
[WRITE_BUF_SIZE
];
5205 coding
->composing
= COMPOSITION_DISABLED
;
5206 if (coding
->composing
!= COMPOSITION_DISABLED
)
5207 coding_save_composition (coding
, start
, end
, string
);
5209 if (STRINGP (string
))
5211 addr
= XSTRING (string
)->data
;
5212 nbytes
= STRING_BYTES (XSTRING (string
));
5213 coding
->src_multibyte
= STRING_MULTIBYTE (string
);
5215 else if (start
< end
)
5217 /* It is assured that the gap is not in the range START and END-1. */
5218 addr
= CHAR_POS_ADDR (start
);
5219 nbytes
= CHAR_TO_BYTE (end
) - CHAR_TO_BYTE (start
);
5220 coding
->src_multibyte
5221 = !NILP (current_buffer
->enable_multibyte_characters
);
5227 coding
->src_multibyte
= 1;
5230 /* We used to have a code for handling selective display here. But,
5231 now it is handled within encode_coding. */
5236 result
= encode_coding (coding
, addr
, buf
, nbytes
, WRITE_BUF_SIZE
);
5237 if (coding
->produced
> 0)
5239 coding
->produced
-= emacs_write (desc
, buf
, coding
->produced
);
5240 if (coding
->produced
)
5246 nbytes
-= coding
->consumed
;
5247 addr
+= coding
->consumed
;
5248 if (result
== CODING_FINISH_INSUFFICIENT_SRC
5251 /* The source text ends by an incomplete multibyte form.
5252 There's no way other than write it out as is. */
5253 nbytes
-= emacs_write (desc
, addr
, nbytes
);
5262 start
+= coding
->consumed_char
;
5263 if (coding
->cmp_data
)
5264 coding_adjust_composition_offset (coding
, start
);
5267 if (coding
->cmp_data
)
5268 coding_free_composition_data (coding
);
5273 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
5274 Sverify_visited_file_modtime
, 1, 1, 0,
5275 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
5276 This means that the file has not been changed since it was visited or saved.")
5282 Lisp_Object handler
;
5283 Lisp_Object filename
;
5285 CHECK_BUFFER (buf
, 0);
5288 if (!STRINGP (b
->filename
)) return Qt
;
5289 if (b
->modtime
== 0) return Qt
;
5291 /* If the file name has special constructs in it,
5292 call the corresponding file handler. */
5293 handler
= Ffind_file_name_handler (b
->filename
,
5294 Qverify_visited_file_modtime
);
5295 if (!NILP (handler
))
5296 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
5298 filename
= ENCODE_FILE (b
->filename
);
5300 if (stat (XSTRING (filename
)->data
, &st
) < 0)
5302 /* If the file doesn't exist now and didn't exist before,
5303 we say that it isn't modified, provided the error is a tame one. */
5304 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
5309 if (st
.st_mtime
== b
->modtime
5310 /* If both are positive, accept them if they are off by one second. */
5311 || (st
.st_mtime
> 0 && b
->modtime
> 0
5312 && (st
.st_mtime
== b
->modtime
+ 1
5313 || st
.st_mtime
== b
->modtime
- 1)))
5318 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
5319 Sclear_visited_file_modtime
, 0, 0, 0,
5320 "Clear out records of last mod time of visited file.\n\
5321 Next attempt to save will certainly not complain of a discrepancy.")
5324 current_buffer
->modtime
= 0;
5328 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
5329 Svisited_file_modtime
, 0, 0, 0,
5330 "Return the current buffer's recorded visited file modification time.\n\
5331 The value is a list of the form (HIGH . LOW), like the time values\n\
5332 that `file-attributes' returns.")
5335 return long_to_cons ((unsigned long) current_buffer
->modtime
);
5338 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
5339 Sset_visited_file_modtime
, 0, 1, 0,
5340 "Update buffer's recorded modification time from the visited file's time.\n\
5341 Useful if the buffer was not read from the file normally\n\
5342 or if the file itself has been changed for some known benign reason.\n\
5343 An argument specifies the modification time value to use\n\
5344 \(instead of that of the visited file), in the form of a list\n\
5345 \(HIGH . LOW) or (HIGH LOW).")
5347 Lisp_Object time_list
;
5349 if (!NILP (time_list
))
5350 current_buffer
->modtime
= cons_to_long (time_list
);
5353 register Lisp_Object filename
;
5355 Lisp_Object handler
;
5357 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
5359 /* If the file name has special constructs in it,
5360 call the corresponding file handler. */
5361 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
5362 if (!NILP (handler
))
5363 /* The handler can find the file name the same way we did. */
5364 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
5366 filename
= ENCODE_FILE (filename
);
5368 if (stat (XSTRING (filename
)->data
, &st
) >= 0)
5369 current_buffer
->modtime
= st
.st_mtime
;
5376 auto_save_error (error
)
5379 Lisp_Object args
[3], msg
;
5381 struct gcpro gcpro1
;
5385 args
[0] = build_string ("Auto-saving %s: %s");
5386 args
[1] = current_buffer
->name
;
5387 args
[2] = Ferror_message_string (error
);
5388 msg
= Fformat (3, args
);
5390 nbytes
= STRING_BYTES (XSTRING (msg
));
5392 for (i
= 0; i
< 3; ++i
)
5395 message2 (XSTRING (msg
)->data
, nbytes
, STRING_MULTIBYTE (msg
));
5397 message2_nolog (XSTRING (msg
)->data
, nbytes
, STRING_MULTIBYTE (msg
));
5398 Fsleep_for (make_number (1), Qnil
);
5410 /* Get visited file's mode to become the auto save file's mode. */
5411 if (! NILP (current_buffer
->filename
)
5412 && stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
5413 /* But make sure we can overwrite it later! */
5414 auto_save_mode_bits
= st
.st_mode
| 0600;
5416 auto_save_mode_bits
= 0666;
5419 Fwrite_region (Qnil
, Qnil
,
5420 current_buffer
->auto_save_file_name
,
5421 Qnil
, Qlambda
, Qnil
, Qnil
);
5425 do_auto_save_unwind (stream
) /* used as unwind-protect function */
5430 fclose ((FILE *) (XFASTINT (XCAR (stream
)) << 16
5431 | XFASTINT (XCDR (stream
))));
5437 do_auto_save_unwind_1 (value
) /* used as unwind-protect function */
5440 minibuffer_auto_raise
= XINT (value
);
5444 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
5445 "Auto-save all buffers that need it.\n\
5446 This is all buffers that have auto-saving enabled\n\
5447 and are changed since last auto-saved.\n\
5448 Auto-saving writes the buffer into a file\n\
5449 so that your editing is not lost if the system crashes.\n\
5450 This file is not the file you visited; that changes only when you save.\n\
5451 Normally we run the normal hook `auto-save-hook' before saving.\n\n\
5452 A non-nil NO-MESSAGE argument means do not print any message if successful.\n\
5453 A non-nil CURRENT-ONLY argument means save only current buffer.")
5454 (no_message
, current_only
)
5455 Lisp_Object no_message
, current_only
;
5457 struct buffer
*old
= current_buffer
, *b
;
5458 Lisp_Object tail
, buf
;
5460 int do_handled_files
;
5463 Lisp_Object lispstream
;
5464 int count
= specpdl_ptr
- specpdl
;
5465 int orig_minibuffer_auto_raise
= minibuffer_auto_raise
;
5466 int message_p
= push_message ();
5468 /* Ordinarily don't quit within this function,
5469 but don't make it impossible to quit (in case we get hung in I/O). */
5473 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
5474 point to non-strings reached from Vbuffer_alist. */
5479 if (!NILP (Vrun_hooks
))
5480 call1 (Vrun_hooks
, intern ("auto-save-hook"));
5482 if (STRINGP (Vauto_save_list_file_name
))
5484 Lisp_Object listfile
;
5486 listfile
= Fexpand_file_name (Vauto_save_list_file_name
, Qnil
);
5488 /* Don't try to create the directory when shutting down Emacs,
5489 because creating the directory might signal an error, and
5490 that would leave Emacs in a strange state. */
5491 if (!NILP (Vrun_hooks
))
5494 dir
= Ffile_name_directory (listfile
);
5495 if (NILP (Ffile_directory_p (dir
)))
5496 call2 (Qmake_directory
, dir
, Qt
);
5499 stream
= fopen (XSTRING (listfile
)->data
, "w");
5502 /* Arrange to close that file whether or not we get an error.
5503 Also reset auto_saving to 0. */
5504 lispstream
= Fcons (Qnil
, Qnil
);
5505 XSETFASTINT (XCAR (lispstream
), (EMACS_UINT
)stream
>> 16);
5506 XSETFASTINT (XCDR (lispstream
), (EMACS_UINT
)stream
& 0xffff);
5517 record_unwind_protect (do_auto_save_unwind
, lispstream
);
5518 record_unwind_protect (do_auto_save_unwind_1
,
5519 make_number (minibuffer_auto_raise
));
5520 minibuffer_auto_raise
= 0;
5523 /* First, save all files which don't have handlers. If Emacs is
5524 crashing, the handlers may tweak what is causing Emacs to crash
5525 in the first place, and it would be a shame if Emacs failed to
5526 autosave perfectly ordinary files because it couldn't handle some
5528 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
5529 for (tail
= Vbuffer_alist
; GC_CONSP (tail
); tail
= XCDR (tail
))
5531 buf
= XCDR (XCAR (tail
));
5534 /* Record all the buffers that have auto save mode
5535 in the special file that lists them. For each of these buffers,
5536 Record visited name (if any) and auto save name. */
5537 if (STRINGP (b
->auto_save_file_name
)
5538 && stream
!= NULL
&& do_handled_files
== 0)
5540 if (!NILP (b
->filename
))
5542 fwrite (XSTRING (b
->filename
)->data
, 1,
5543 STRING_BYTES (XSTRING (b
->filename
)), stream
);
5545 putc ('\n', stream
);
5546 fwrite (XSTRING (b
->auto_save_file_name
)->data
, 1,
5547 STRING_BYTES (XSTRING (b
->auto_save_file_name
)), stream
);
5548 putc ('\n', stream
);
5551 if (!NILP (current_only
)
5552 && b
!= current_buffer
)
5555 /* Don't auto-save indirect buffers.
5556 The base buffer takes care of it. */
5560 /* Check for auto save enabled
5561 and file changed since last auto save
5562 and file changed since last real save. */
5563 if (STRINGP (b
->auto_save_file_name
)
5564 && BUF_SAVE_MODIFF (b
) < BUF_MODIFF (b
)
5565 && b
->auto_save_modified
< BUF_MODIFF (b
)
5566 /* -1 means we've turned off autosaving for a while--see below. */
5567 && XINT (b
->save_length
) >= 0
5568 && (do_handled_files
5569 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
5572 EMACS_TIME before_time
, after_time
;
5574 EMACS_GET_TIME (before_time
);
5576 /* If we had a failure, don't try again for 20 minutes. */
5577 if (b
->auto_save_failure_time
>= 0
5578 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
5581 if ((XFASTINT (b
->save_length
) * 10
5582 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
5583 /* A short file is likely to change a large fraction;
5584 spare the user annoying messages. */
5585 && XFASTINT (b
->save_length
) > 5000
5586 /* These messages are frequent and annoying for `*mail*'. */
5587 && !EQ (b
->filename
, Qnil
)
5588 && NILP (no_message
))
5590 /* It has shrunk too much; turn off auto-saving here. */
5591 minibuffer_auto_raise
= orig_minibuffer_auto_raise
;
5592 message_with_string ("Buffer %s has shrunk a lot; auto save turned off there",
5594 minibuffer_auto_raise
= 0;
5595 /* Turn off auto-saving until there's a real save,
5596 and prevent any more warnings. */
5597 XSETINT (b
->save_length
, -1);
5598 Fsleep_for (make_number (1), Qnil
);
5601 set_buffer_internal (b
);
5602 if (!auto_saved
&& NILP (no_message
))
5603 message1 ("Auto-saving...");
5604 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
5606 b
->auto_save_modified
= BUF_MODIFF (b
);
5607 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
5608 set_buffer_internal (old
);
5610 EMACS_GET_TIME (after_time
);
5612 /* If auto-save took more than 60 seconds,
5613 assume it was an NFS failure that got a timeout. */
5614 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
5615 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
5619 /* Prevent another auto save till enough input events come in. */
5620 record_auto_save ();
5622 if (auto_saved
&& NILP (no_message
))
5626 sit_for (1, 0, 0, 0, 0);
5630 message1 ("Auto-saving...done");
5635 unbind_to (count
, Qnil
);
5639 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
5640 Sset_buffer_auto_saved
, 0, 0, 0,
5641 "Mark current buffer as auto-saved with its current text.\n\
5642 No auto-save file will be written until the buffer changes again.")
5645 current_buffer
->auto_save_modified
= MODIFF
;
5646 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
5647 current_buffer
->auto_save_failure_time
= -1;
5651 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
5652 Sclear_buffer_auto_save_failure
, 0, 0, 0,
5653 "Clear any record of a recent auto-save failure in the current buffer.")
5656 current_buffer
->auto_save_failure_time
= -1;
5660 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
5662 "Return t if buffer has been auto-saved since last read in or saved.")
5665 return (SAVE_MODIFF
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
5668 /* Reading and completing file names */
5669 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
5671 /* In the string VAL, change each $ to $$ and return the result. */
5674 double_dollars (val
)
5677 register unsigned char *old
, *new;
5681 osize
= STRING_BYTES (XSTRING (val
));
5683 /* Count the number of $ characters. */
5684 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
5685 if (*old
++ == '$') count
++;
5688 old
= XSTRING (val
)->data
;
5689 val
= make_uninit_multibyte_string (XSTRING (val
)->size
+ count
,
5691 new = XSTRING (val
)->data
;
5692 for (n
= osize
; n
> 0; n
--)
5705 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
5707 "Internal subroutine for read-file-name. Do not call this.")
5708 (string
, dir
, action
)
5709 Lisp_Object string
, dir
, action
;
5710 /* action is nil for complete, t for return list of completions,
5711 lambda for verify final value */
5713 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
5715 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
5717 CHECK_STRING (string
, 0);
5724 /* No need to protect ACTION--we only compare it with t and nil. */
5725 GCPRO5 (string
, realdir
, name
, specdir
, orig_string
);
5727 if (XSTRING (string
)->size
== 0)
5729 if (EQ (action
, Qlambda
))
5737 orig_string
= string
;
5738 string
= Fsubstitute_in_file_name (string
);
5739 changed
= NILP (Fstring_equal (string
, orig_string
));
5740 name
= Ffile_name_nondirectory (string
);
5741 val
= Ffile_name_directory (string
);
5743 realdir
= Fexpand_file_name (val
, realdir
);
5748 specdir
= Ffile_name_directory (string
);
5749 val
= Ffile_name_completion (name
, realdir
);
5754 return double_dollars (string
);
5758 if (!NILP (specdir
))
5759 val
= concat2 (specdir
, val
);
5761 return double_dollars (val
);
5764 #endif /* not VMS */
5768 if (EQ (action
, Qt
))
5769 return Ffile_name_all_completions (name
, realdir
);
5770 /* Only other case actually used is ACTION = lambda */
5772 /* Supposedly this helps commands such as `cd' that read directory names,
5773 but can someone explain how it helps them? -- RMS */
5774 if (XSTRING (name
)->size
== 0)
5777 return Ffile_exists_p (string
);
5780 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
5781 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
5782 Value is not expanded---you must call `expand-file-name' yourself.\n\
5783 Default name to DEFAULT-FILENAME if user enters a null string.\n\
5784 (If DEFAULT-FILENAME is omitted, the visited file name is used,\n\
5785 except that if INITIAL is specified, that combined with DIR is used.)\n\
5786 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
5787 Non-nil and non-t means also require confirmation after completion.\n\
5788 Fifth arg INITIAL specifies text to start with.\n\
5789 DIR defaults to current buffer's directory default.\n\
5791 If this command was invoked with the mouse, use a file dialog box if\n\
5792 `use-dialog-box' is non-nil, and the window system or X toolkit in use\n\
5793 provides a file dialog box..")
5794 (prompt
, dir
, default_filename
, mustmatch
, initial
)
5795 Lisp_Object prompt
, dir
, default_filename
, mustmatch
, initial
;
5797 Lisp_Object val
, insdef
, tem
;
5798 struct gcpro gcpro1
, gcpro2
;
5799 register char *homedir
;
5800 int replace_in_history
= 0;
5801 int add_to_history
= 0;
5805 dir
= current_buffer
->directory
;
5806 if (NILP (default_filename
))
5808 if (! NILP (initial
))
5809 default_filename
= Fexpand_file_name (initial
, dir
);
5811 default_filename
= current_buffer
->filename
;
5814 /* If dir starts with user's homedir, change that to ~. */
5815 homedir
= (char *) egetenv ("HOME");
5817 /* homedir can be NULL in temacs, since Vprocess_environment is not
5818 yet set up. We shouldn't crash in that case. */
5821 homedir
= strcpy (alloca (strlen (homedir
) + 1), homedir
);
5822 CORRECT_DIR_SEPS (homedir
);
5827 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5828 && IS_DIRECTORY_SEP (XSTRING (dir
)->data
[strlen (homedir
)]))
5830 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5831 STRING_BYTES (XSTRING (dir
)) - strlen (homedir
) + 1);
5832 XSTRING (dir
)->data
[0] = '~';
5834 /* Likewise for default_filename. */
5836 && STRINGP (default_filename
)
5837 && !strncmp (homedir
, XSTRING (default_filename
)->data
, strlen (homedir
))
5838 && IS_DIRECTORY_SEP (XSTRING (default_filename
)->data
[strlen (homedir
)]))
5841 = make_string (XSTRING (default_filename
)->data
+ strlen (homedir
) - 1,
5842 STRING_BYTES (XSTRING (default_filename
)) - strlen (homedir
) + 1);
5843 XSTRING (default_filename
)->data
[0] = '~';
5845 if (!NILP (default_filename
))
5847 CHECK_STRING (default_filename
, 3);
5848 default_filename
= double_dollars (default_filename
);
5851 if (insert_default_directory
&& STRINGP (dir
))
5854 if (!NILP (initial
))
5856 Lisp_Object args
[2], pos
;
5860 insdef
= Fconcat (2, args
);
5861 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
5862 insdef
= Fcons (double_dollars (insdef
), pos
);
5865 insdef
= double_dollars (insdef
);
5867 else if (STRINGP (initial
))
5868 insdef
= Fcons (double_dollars (initial
), make_number (0));
5872 count
= specpdl_ptr
- specpdl
;
5874 specbind (intern ("completion-ignore-case"), Qt
);
5877 specbind (intern ("minibuffer-completing-file-name"), Qt
);
5879 GCPRO2 (insdef
, default_filename
);
5881 #if defined (USE_MOTIF) || defined (HAVE_NTGUI)
5882 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
5886 /* If DIR contains a file name, split it. */
5888 file
= Ffile_name_nondirectory (dir
);
5889 if (XSTRING (file
)->size
&& NILP (default_filename
))
5891 default_filename
= file
;
5892 dir
= Ffile_name_directory (dir
);
5894 if (!NILP(default_filename
))
5895 default_filename
= Fexpand_file_name (default_filename
, dir
);
5896 val
= Fx_file_dialog (prompt
, dir
, default_filename
, mustmatch
);
5901 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5902 dir
, mustmatch
, insdef
,
5903 Qfile_name_history
, default_filename
, Qnil
);
5905 tem
= Fsymbol_value (Qfile_name_history
);
5906 if (CONSP (tem
) && EQ (XCAR (tem
), val
))
5907 replace_in_history
= 1;
5909 /* If Fcompleting_read returned the inserted default string itself
5910 (rather than a new string with the same contents),
5911 it has to mean that the user typed RET with the minibuffer empty.
5912 In that case, we really want to return ""
5913 so that commands such as set-visited-file-name can distinguish. */
5914 if (EQ (val
, default_filename
))
5916 /* In this case, Fcompleting_read has not added an element
5917 to the history. Maybe we should. */
5918 if (! replace_in_history
)
5921 val
= build_string ("");
5924 unbind_to (count
, Qnil
);
5927 error ("No file name specified");
5929 tem
= Fstring_equal (val
, CONSP (insdef
) ? XCAR (insdef
) : insdef
);
5931 if (!NILP (tem
) && !NILP (default_filename
))
5932 val
= default_filename
;
5933 else if (XSTRING (val
)->size
== 0 && NILP (insdef
))
5935 if (!NILP (default_filename
))
5936 val
= default_filename
;
5938 error ("No default file name");
5940 val
= Fsubstitute_in_file_name (val
);
5942 if (replace_in_history
)
5943 /* Replace what Fcompleting_read added to the history
5944 with what we will actually return. */
5945 XCAR (Fsymbol_value (Qfile_name_history
)) = double_dollars (val
);
5946 else if (add_to_history
)
5948 /* Add the value to the history--but not if it matches
5949 the last value already there. */
5950 Lisp_Object val1
= double_dollars (val
);
5951 tem
= Fsymbol_value (Qfile_name_history
);
5952 if (! CONSP (tem
) || NILP (Fequal (XCAR (tem
), val1
)))
5953 Fset (Qfile_name_history
,
5964 /* Must be set before any path manipulation is performed. */
5965 XSETFASTINT (Vdirectory_sep_char
, '/');
5972 Qexpand_file_name
= intern ("expand-file-name");
5973 Qsubstitute_in_file_name
= intern ("substitute-in-file-name");
5974 Qdirectory_file_name
= intern ("directory-file-name");
5975 Qfile_name_directory
= intern ("file-name-directory");
5976 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
5977 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
5978 Qfile_name_as_directory
= intern ("file-name-as-directory");
5979 Qcopy_file
= intern ("copy-file");
5980 Qmake_directory_internal
= intern ("make-directory-internal");
5981 Qmake_directory
= intern ("make-directory");
5982 Qdelete_directory
= intern ("delete-directory");
5983 Qdelete_file
= intern ("delete-file");
5984 Qrename_file
= intern ("rename-file");
5985 Qadd_name_to_file
= intern ("add-name-to-file");
5986 Qmake_symbolic_link
= intern ("make-symbolic-link");
5987 Qfile_exists_p
= intern ("file-exists-p");
5988 Qfile_executable_p
= intern ("file-executable-p");
5989 Qfile_readable_p
= intern ("file-readable-p");
5990 Qfile_writable_p
= intern ("file-writable-p");
5991 Qfile_symlink_p
= intern ("file-symlink-p");
5992 Qaccess_file
= intern ("access-file");
5993 Qfile_directory_p
= intern ("file-directory-p");
5994 Qfile_regular_p
= intern ("file-regular-p");
5995 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
5996 Qfile_modes
= intern ("file-modes");
5997 Qset_file_modes
= intern ("set-file-modes");
5998 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
5999 Qinsert_file_contents
= intern ("insert-file-contents");
6000 Qwrite_region
= intern ("write-region");
6001 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
6002 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
6004 staticpro (&Qexpand_file_name
);
6005 staticpro (&Qsubstitute_in_file_name
);
6006 staticpro (&Qdirectory_file_name
);
6007 staticpro (&Qfile_name_directory
);
6008 staticpro (&Qfile_name_nondirectory
);
6009 staticpro (&Qunhandled_file_name_directory
);
6010 staticpro (&Qfile_name_as_directory
);
6011 staticpro (&Qcopy_file
);
6012 staticpro (&Qmake_directory_internal
);
6013 staticpro (&Qmake_directory
);
6014 staticpro (&Qdelete_directory
);
6015 staticpro (&Qdelete_file
);
6016 staticpro (&Qrename_file
);
6017 staticpro (&Qadd_name_to_file
);
6018 staticpro (&Qmake_symbolic_link
);
6019 staticpro (&Qfile_exists_p
);
6020 staticpro (&Qfile_executable_p
);
6021 staticpro (&Qfile_readable_p
);
6022 staticpro (&Qfile_writable_p
);
6023 staticpro (&Qaccess_file
);
6024 staticpro (&Qfile_symlink_p
);
6025 staticpro (&Qfile_directory_p
);
6026 staticpro (&Qfile_regular_p
);
6027 staticpro (&Qfile_accessible_directory_p
);
6028 staticpro (&Qfile_modes
);
6029 staticpro (&Qset_file_modes
);
6030 staticpro (&Qfile_newer_than_file_p
);
6031 staticpro (&Qinsert_file_contents
);
6032 staticpro (&Qwrite_region
);
6033 staticpro (&Qverify_visited_file_modtime
);
6034 staticpro (&Qset_visited_file_modtime
);
6036 Qfile_name_history
= intern ("file-name-history");
6037 Fset (Qfile_name_history
, Qnil
);
6038 staticpro (&Qfile_name_history
);
6040 Qfile_error
= intern ("file-error");
6041 staticpro (&Qfile_error
);
6042 Qfile_already_exists
= intern ("file-already-exists");
6043 staticpro (&Qfile_already_exists
);
6044 Qfile_date_error
= intern ("file-date-error");
6045 staticpro (&Qfile_date_error
);
6046 Qexcl
= intern ("excl");
6050 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
6051 staticpro (&Qfind_buffer_file_type
);
6054 DEFVAR_LISP ("file-name-coding-system", &Vfile_name_coding_system
,
6055 "*Coding system for encoding file names.\n\
6056 If it is nil, default-file-name-coding-system (which see) is used.");
6057 Vfile_name_coding_system
= Qnil
;
6059 DEFVAR_LISP ("default-file-name-coding-system",
6060 &Vdefault_file_name_coding_system
,
6061 "Default coding system for encoding file names.\n\
6062 This variable is used only when file-name-coding-system is nil.\n\
6064 This variable is set/changed by the command set-language-environment.\n\
6065 User should not set this variable manually,\n\
6066 instead use file-name-coding-system to get a constant encoding\n\
6067 of file names regardless of the current language environment.");
6068 Vdefault_file_name_coding_system
= Qnil
;
6070 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format
,
6071 "*Format in which to write auto-save files.\n\
6072 Should be a list of symbols naming formats that are defined in `format-alist'.\n\
6073 If it is t, which is the default, auto-save files are written in the\n\
6074 same format as a regular save would use.");
6075 Vauto_save_file_format
= Qt
;
6077 Qformat_decode
= intern ("format-decode");
6078 staticpro (&Qformat_decode
);
6079 Qformat_annotate_function
= intern ("format-annotate-function");
6080 staticpro (&Qformat_annotate_function
);
6082 Qcar_less_than_car
= intern ("car-less-than-car");
6083 staticpro (&Qcar_less_than_car
);
6085 Fput (Qfile_error
, Qerror_conditions
,
6086 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
6087 Fput (Qfile_error
, Qerror_message
,
6088 build_string ("File error"));
6090 Fput (Qfile_already_exists
, Qerror_conditions
,
6091 Fcons (Qfile_already_exists
,
6092 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
6093 Fput (Qfile_already_exists
, Qerror_message
,
6094 build_string ("File already exists"));
6096 Fput (Qfile_date_error
, Qerror_conditions
,
6097 Fcons (Qfile_date_error
,
6098 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
6099 Fput (Qfile_date_error
, Qerror_message
,
6100 build_string ("Cannot set file date"));
6102 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
6103 "*Non-nil means when reading a filename start with default dir in minibuffer.");
6104 insert_default_directory
= 1;
6106 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
6107 "*Non-nil means write new files with record format `stmlf'.\n\
6108 nil means use format `var'. This variable is meaningful only on VMS.");
6109 vms_stmlf_recfm
= 0;
6111 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char
,
6112 "Directory separator character for built-in functions that return file names.\n\
6113 The value should be either ?/ or ?\\ (any other value is treated as ?\\).\n\
6114 This variable affects the built-in functions only on Windows,\n\
6115 on other platforms, it is initialized so that Lisp code can find out\n\
6116 what the normal separator is.\n\
6118 WARNING: This variable is deprecated and will be removed in the near\n\
6119 future. DO NOT USE IT.");
6121 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
6122 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
6123 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
6126 The first argument given to HANDLER is the name of the I/O primitive\n\
6127 to be handled; the remaining arguments are the arguments that were\n\
6128 passed to that primitive. For example, if you do\n\
6129 (file-exists-p FILENAME)\n\
6130 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
6131 (funcall HANDLER 'file-exists-p FILENAME)\n\
6132 The function `find-file-name-handler' checks this list for a handler\n\
6133 for its argument.");
6134 Vfile_name_handler_alist
= Qnil
;
6136 DEFVAR_LISP ("set-auto-coding-function",
6137 &Vset_auto_coding_function
,
6138 "If non-nil, a function to call to decide a coding system of file.\n\
6139 Two arguments are passed to this function: the file name\n\
6140 and the length of a file contents following the point.\n\
6141 This function should return a coding system to decode the file contents.\n\
6142 It should check the file name against `auto-coding-alist'.\n\
6143 If no coding system is decided, it should check a coding system\n\
6144 specified in the heading lines with the format:\n\
6145 -*- ... coding: CODING-SYSTEM; ... -*-\n\
6146 or local variable spec of the tailing lines with `coding:' tag.");
6147 Vset_auto_coding_function
= Qnil
;
6149 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
6150 "A list of functions to be called at the end of `insert-file-contents'.\n\
6151 Each is passed one argument, the number of bytes inserted. It should return\n\
6152 the new byte count, and leave point the same. If `insert-file-contents' is\n\
6153 intercepted by a handler from `file-name-handler-alist', that handler is\n\
6154 responsible for calling the after-insert-file-functions if appropriate.");
6155 Vafter_insert_file_functions
= Qnil
;
6157 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
6158 "A list of functions to be called at the start of `write-region'.\n\
6159 Each is passed two arguments, START and END as for `write-region'.\n\
6160 These are usually two numbers but not always; see the documentation\n\
6161 for `write-region'. The function should return a list of pairs\n\
6162 of the form (POSITION . STRING), consisting of strings to be effectively\n\
6163 inserted at the specified positions of the file being written (1 means to\n\
6164 insert before the first byte written). The POSITIONs must be sorted into\n\
6165 increasing order. If there are several functions in the list, the several\n\
6166 lists are merged destructively.");
6167 Vwrite_region_annotate_functions
= Qnil
;
6169 DEFVAR_LISP ("write-region-annotations-so-far",
6170 &Vwrite_region_annotations_so_far
,
6171 "When an annotation function is called, this holds the previous annotations.\n\
6172 These are the annotations made by other annotation functions\n\
6173 that were already called. See also `write-region-annotate-functions'.");
6174 Vwrite_region_annotations_so_far
= Qnil
;
6176 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
6177 "A list of file name handlers that temporarily should not be used.\n\
6178 This applies only to the operation `inhibit-file-name-operation'.");
6179 Vinhibit_file_name_handlers
= Qnil
;
6181 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
6182 "The operation for which `inhibit-file-name-handlers' is applicable.");
6183 Vinhibit_file_name_operation
= Qnil
;
6185 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
6186 "File name in which we write a list of all auto save file names.\n\
6187 This variable is initialized automatically from `auto-save-list-file-prefix'\n\
6188 shortly after Emacs reads your `.emacs' file, if you have not yet given it\n\
6190 Vauto_save_list_file_name
= Qnil
;
6192 defsubr (&Sfind_file_name_handler
);
6193 defsubr (&Sfile_name_directory
);
6194 defsubr (&Sfile_name_nondirectory
);
6195 defsubr (&Sunhandled_file_name_directory
);
6196 defsubr (&Sfile_name_as_directory
);
6197 defsubr (&Sdirectory_file_name
);
6198 defsubr (&Smake_temp_name
);
6199 defsubr (&Sexpand_file_name
);
6200 defsubr (&Ssubstitute_in_file_name
);
6201 defsubr (&Scopy_file
);
6202 defsubr (&Smake_directory_internal
);
6203 defsubr (&Sdelete_directory
);
6204 defsubr (&Sdelete_file
);
6205 defsubr (&Srename_file
);
6206 defsubr (&Sadd_name_to_file
);
6208 defsubr (&Smake_symbolic_link
);
6209 #endif /* S_IFLNK */
6211 defsubr (&Sdefine_logical_name
);
6214 defsubr (&Ssysnetunam
);
6215 #endif /* HPUX_NET */
6216 defsubr (&Sfile_name_absolute_p
);
6217 defsubr (&Sfile_exists_p
);
6218 defsubr (&Sfile_executable_p
);
6219 defsubr (&Sfile_readable_p
);
6220 defsubr (&Sfile_writable_p
);
6221 defsubr (&Saccess_file
);
6222 defsubr (&Sfile_symlink_p
);
6223 defsubr (&Sfile_directory_p
);
6224 defsubr (&Sfile_accessible_directory_p
);
6225 defsubr (&Sfile_regular_p
);
6226 defsubr (&Sfile_modes
);
6227 defsubr (&Sset_file_modes
);
6228 defsubr (&Sset_default_file_modes
);
6229 defsubr (&Sdefault_file_modes
);
6230 defsubr (&Sfile_newer_than_file_p
);
6231 defsubr (&Sinsert_file_contents
);
6232 defsubr (&Swrite_region
);
6233 defsubr (&Scar_less_than_car
);
6234 defsubr (&Sverify_visited_file_modtime
);
6235 defsubr (&Sclear_visited_file_modtime
);
6236 defsubr (&Svisited_file_modtime
);
6237 defsubr (&Sset_visited_file_modtime
);
6238 defsubr (&Sdo_auto_save
);
6239 defsubr (&Sset_buffer_auto_saved
);
6240 defsubr (&Sclear_buffer_auto_save_failure
);
6241 defsubr (&Srecent_auto_save_p
);
6243 defsubr (&Sread_file_name_internal
);
6244 defsubr (&Sread_file_name
);
6247 defsubr (&Sunix_sync
);