1 /* File IO for GNU Emacs.
2 Copyright (C) 1985,86,87,88,93,94,95,96,97,98,99,2000
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 #define _GNU_SOURCE /* for euidaccess */
26 #if defined (USG5) || defined (BSD_SYSTEM) || defined (LINUX)
31 #include <sys/types.h>
38 #if !defined (S_ISLNK) && defined (S_IFLNK)
39 # define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
42 #if !defined (S_ISFIFO) && defined (S_IFIFO)
43 # define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO)
46 #if !defined (S_ISREG) && defined (S_IFREG)
47 # define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
86 #include "intervals.h"
97 #endif /* not WINDOWSNT */
101 #include <sys/param.h>
109 #define CORRECT_DIR_SEPS(s) \
110 do { if ('/' == DIRECTORY_SEP) dostounix_filename (s); \
111 else unixtodos_filename (s); \
113 /* On Windows, drive letters must be alphabetic - on DOS, the Netware
114 redirector allows the six letters between 'Z' and 'a' as well. */
116 #define IS_DRIVE(x) ((x) >= 'A' && (x) <= 'z')
119 #define IS_DRIVE(x) isalpha (x)
121 /* Need to lower-case the drive letter, or else expanded
122 filenames will sometimes compare inequal, because
123 `expand-file-name' doesn't always down-case the drive letter. */
124 #define DRIVE_LETTER(x) (tolower (x))
145 #include "commands.h"
146 extern int use_dialog_box
;
160 #define min(a, b) ((a) < (b) ? (a) : (b))
161 #define max(a, b) ((a) > (b) ? (a) : (b))
163 /* Nonzero during writing of auto-save files */
166 /* Set by auto_save_1 to mode of original file so Fwrite_region will create
167 a new file with the same mode as the original */
168 int auto_save_mode_bits
;
170 /* Coding system for file names, or nil if none. */
171 Lisp_Object Vfile_name_coding_system
;
173 /* Coding system for file names used only when
174 Vfile_name_coding_system is nil. */
175 Lisp_Object Vdefault_file_name_coding_system
;
177 /* Alist of elements (REGEXP . HANDLER) for file names
178 whose I/O is done with a special handler. */
179 Lisp_Object Vfile_name_handler_alist
;
181 /* Format for auto-save files */
182 Lisp_Object Vauto_save_file_format
;
184 /* Lisp functions for translating file formats */
185 Lisp_Object Qformat_decode
, Qformat_annotate_function
;
187 /* Function to be called to decide a coding system of a reading file. */
188 Lisp_Object Vset_auto_coding_function
;
190 /* Functions to be called to process text properties in inserted file. */
191 Lisp_Object Vafter_insert_file_functions
;
193 /* Functions to be called to create text property annotations for file. */
194 Lisp_Object Vwrite_region_annotate_functions
;
196 /* During build_annotations, each time an annotation function is called,
197 this holds the annotations made by the previous functions. */
198 Lisp_Object Vwrite_region_annotations_so_far
;
200 /* File name in which we write a list of all our auto save files. */
201 Lisp_Object Vauto_save_list_file_name
;
203 /* Nonzero means, when reading a filename in the minibuffer,
204 start out by inserting the default directory into the minibuffer. */
205 int insert_default_directory
;
207 /* On VMS, nonzero means write new files with record format stmlf.
208 Zero means use var format. */
211 /* On NT, specifies the directory separator character, used (eg.) when
212 expanding file names. This can be bound to / or \. */
213 Lisp_Object Vdirectory_sep_char
;
215 extern Lisp_Object Vuser_login_name
;
218 extern Lisp_Object Vw32_get_true_file_attributes
;
221 extern int minibuf_level
;
223 extern int minibuffer_auto_raise
;
225 /* These variables describe handlers that have "already" had a chance
226 to handle the current operation.
228 Vinhibit_file_name_handlers is a list of file name handlers.
229 Vinhibit_file_name_operation is the operation being handled.
230 If we try to handle that operation, we ignore those handlers. */
232 static Lisp_Object Vinhibit_file_name_handlers
;
233 static Lisp_Object Vinhibit_file_name_operation
;
235 Lisp_Object Qfile_error
, Qfile_already_exists
, Qfile_date_error
;
237 Lisp_Object Qfile_name_history
;
239 Lisp_Object Qcar_less_than_car
;
241 static int a_write
P_ ((int, Lisp_Object
, int, int,
242 Lisp_Object
*, struct coding_system
*));
243 static int e_write
P_ ((int, Lisp_Object
, int, int, struct coding_system
*));
247 report_file_error (string
, data
)
251 Lisp_Object errstring
;
254 synchronize_system_messages_locale ();
255 errstring
= code_convert_string_norecord (build_string (strerror (errorno
)),
256 Vlocale_coding_system
, 0);
262 Fsignal (Qfile_already_exists
, Fcons (errstring
, data
));
265 /* System error messages are capitalized. Downcase the initial
266 unless it is followed by a slash. */
267 if (XSTRING (errstring
)->data
[1] != '/')
268 XSTRING (errstring
)->data
[0] = DOWNCASE (XSTRING (errstring
)->data
[0]);
270 Fsignal (Qfile_error
,
271 Fcons (build_string (string
), Fcons (errstring
, data
)));
276 close_file_unwind (fd
)
279 emacs_close (XFASTINT (fd
));
283 /* Restore point, having saved it as a marker. */
286 restore_point_unwind (location
)
287 Lisp_Object location
;
289 Fgoto_char (location
);
290 Fset_marker (location
, Qnil
, Qnil
);
294 Lisp_Object Qexpand_file_name
;
295 Lisp_Object Qsubstitute_in_file_name
;
296 Lisp_Object Qdirectory_file_name
;
297 Lisp_Object Qfile_name_directory
;
298 Lisp_Object Qfile_name_nondirectory
;
299 Lisp_Object Qunhandled_file_name_directory
;
300 Lisp_Object Qfile_name_as_directory
;
301 Lisp_Object Qcopy_file
;
302 Lisp_Object Qmake_directory_internal
;
303 Lisp_Object Qmake_directory
;
304 Lisp_Object Qdelete_directory
;
305 Lisp_Object Qdelete_file
;
306 Lisp_Object Qrename_file
;
307 Lisp_Object Qadd_name_to_file
;
308 Lisp_Object Qmake_symbolic_link
;
309 Lisp_Object Qfile_exists_p
;
310 Lisp_Object Qfile_executable_p
;
311 Lisp_Object Qfile_readable_p
;
312 Lisp_Object Qfile_writable_p
;
313 Lisp_Object Qfile_symlink_p
;
314 Lisp_Object Qaccess_file
;
315 Lisp_Object Qfile_directory_p
;
316 Lisp_Object Qfile_regular_p
;
317 Lisp_Object Qfile_accessible_directory_p
;
318 Lisp_Object Qfile_modes
;
319 Lisp_Object Qset_file_modes
;
320 Lisp_Object Qfile_newer_than_file_p
;
321 Lisp_Object Qinsert_file_contents
;
322 Lisp_Object Qwrite_region
;
323 Lisp_Object Qverify_visited_file_modtime
;
324 Lisp_Object Qset_visited_file_modtime
;
326 DEFUN ("find-file-name-handler", Ffind_file_name_handler
, Sfind_file_name_handler
, 2, 2, 0,
327 "Return FILENAME's handler function for OPERATION, if it has one.\n\
328 Otherwise, return nil.\n\
329 A file name is handled if one of the regular expressions in\n\
330 `file-name-handler-alist' matches it.\n\n\
331 If OPERATION equals `inhibit-file-name-operation', then we ignore\n\
332 any handlers that are members of `inhibit-file-name-handlers',\n\
333 but we still do run any other handlers. This lets handlers\n\
334 use the standard functions without calling themselves recursively.")
335 (filename
, operation
)
336 Lisp_Object filename
, operation
;
338 /* This function must not munge the match data. */
339 Lisp_Object chain
, inhibited_handlers
;
341 CHECK_STRING (filename
, 0);
343 if (EQ (operation
, Vinhibit_file_name_operation
))
344 inhibited_handlers
= Vinhibit_file_name_handlers
;
346 inhibited_handlers
= Qnil
;
348 for (chain
= Vfile_name_handler_alist
; CONSP (chain
);
349 chain
= XCDR (chain
))
357 if (STRINGP (string
) && fast_string_match (string
, filename
) >= 0)
359 Lisp_Object handler
, tem
;
361 handler
= XCDR (elt
);
362 tem
= Fmemq (handler
, inhibited_handlers
);
373 DEFUN ("file-name-directory", Ffile_name_directory
, Sfile_name_directory
,
375 "Return the directory component in file name FILENAME.\n\
376 Return nil if FILENAME does not include a directory.\n\
377 Otherwise return a directory spec.\n\
378 Given a Unix syntax file name, returns a string ending in slash;\n\
379 on VMS, perhaps instead a string ending in `:', `]' or `>'.")
381 Lisp_Object filename
;
383 register unsigned char *beg
;
384 register unsigned char *p
;
387 CHECK_STRING (filename
, 0);
389 /* If the file name has special constructs in it,
390 call the corresponding file handler. */
391 handler
= Ffind_file_name_handler (filename
, Qfile_name_directory
);
393 return call2 (handler
, Qfile_name_directory
, filename
);
395 #ifdef FILE_SYSTEM_CASE
396 filename
= FILE_SYSTEM_CASE (filename
);
398 beg
= XSTRING (filename
)->data
;
400 beg
= strcpy (alloca (strlen (beg
) + 1), beg
);
402 p
= beg
+ STRING_BYTES (XSTRING (filename
));
404 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
406 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
409 /* only recognise drive specifier at the beginning */
411 /* handle the "/:d:foo" and "/:foo" cases correctly */
412 && ((p
== beg
+ 2 && !IS_DIRECTORY_SEP (*beg
))
413 || (p
== beg
+ 4 && IS_DIRECTORY_SEP (*beg
))))
420 /* Expansion of "c:" to drive and default directory. */
423 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
424 unsigned char *res
= alloca (MAXPATHLEN
+ 1);
425 unsigned char *r
= res
;
427 if (p
== beg
+ 4 && IS_DIRECTORY_SEP (*beg
) && beg
[1] == ':')
429 strncpy (res
, beg
, 2);
434 if (getdefdir (toupper (*beg
) - 'A' + 1, r
))
436 if (!IS_DIRECTORY_SEP (res
[strlen (res
) - 1]))
439 p
= beg
+ strlen (beg
);
442 CORRECT_DIR_SEPS (beg
);
445 if (STRING_MULTIBYTE (filename
))
446 return make_string (beg
, p
- beg
);
447 return make_unibyte_string (beg
, p
- beg
);
450 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory
,
451 Sfile_name_nondirectory
, 1, 1, 0,
452 "Return file name FILENAME sans its directory.\n\
453 For example, in a Unix-syntax file name,\n\
454 this is everything after the last slash,\n\
455 or the entire name if it contains no slash.")
457 Lisp_Object filename
;
459 register unsigned char *beg
, *p
, *end
;
462 CHECK_STRING (filename
, 0);
464 /* If the file name has special constructs in it,
465 call the corresponding file handler. */
466 handler
= Ffind_file_name_handler (filename
, Qfile_name_nondirectory
);
468 return call2 (handler
, Qfile_name_nondirectory
, filename
);
470 beg
= XSTRING (filename
)->data
;
471 end
= p
= beg
+ STRING_BYTES (XSTRING (filename
));
473 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
475 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
478 /* only recognise drive specifier at beginning */
480 /* handle the "/:d:foo" case correctly */
481 && (p
== beg
+ 2 || (p
== beg
+ 4 && IS_DIRECTORY_SEP (*beg
))))
486 if (STRING_MULTIBYTE (filename
))
487 return make_string (p
, end
- p
);
488 return make_unibyte_string (p
, end
- p
);
491 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory
,
492 Sunhandled_file_name_directory
, 1, 1, 0,
493 "Return a directly usable directory name somehow associated with FILENAME.\n\
494 A `directly usable' directory name is one that may be used without the\n\
495 intervention of any file handler.\n\
496 If FILENAME is a directly usable file itself, return\n\
497 \(file-name-directory FILENAME).\n\
498 The `call-process' and `start-process' functions use this function to\n\
499 get a current directory to run processes in.")
501 Lisp_Object filename
;
505 /* If the file name has special constructs in it,
506 call the corresponding file handler. */
507 handler
= Ffind_file_name_handler (filename
, Qunhandled_file_name_directory
);
509 return call2 (handler
, Qunhandled_file_name_directory
, filename
);
511 return Ffile_name_directory (filename
);
516 file_name_as_directory (out
, in
)
519 int size
= strlen (in
) - 1;
532 /* Is it already a directory string? */
533 if (in
[size
] == ':' || in
[size
] == ']' || in
[size
] == '>')
535 /* Is it a VMS directory file name? If so, hack VMS syntax. */
536 else if (! index (in
, '/')
537 && ((size
> 3 && ! strcmp (&in
[size
- 3], ".DIR"))
538 || (size
> 3 && ! strcmp (&in
[size
- 3], ".dir"))
539 || (size
> 5 && (! strncmp (&in
[size
- 5], ".DIR", 4)
540 || ! strncmp (&in
[size
- 5], ".dir", 4))
541 && (in
[size
- 1] == '.' || in
[size
- 1] == ';')
542 && in
[size
] == '1')))
544 register char *p
, *dot
;
548 dir:x.dir --> dir:[x]
549 dir:[x]y.dir --> dir:[x.y] */
551 while (p
!= in
&& *p
!= ':' && *p
!= '>' && *p
!= ']') p
--;
554 strncpy (out
, in
, p
- in
);
573 dot
= index (p
, '.');
576 /* blindly remove any extension */
577 size
= strlen (out
) + (dot
- p
);
578 strncat (out
, p
, dot
- p
);
589 /* For Unix syntax, Append a slash if necessary */
590 if (!IS_DIRECTORY_SEP (out
[size
]))
592 out
[size
+ 1] = DIRECTORY_SEP
;
593 out
[size
+ 2] = '\0';
596 CORRECT_DIR_SEPS (out
);
602 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
603 Sfile_name_as_directory
, 1, 1, 0,
604 "Return a string representing file FILENAME interpreted as a directory.\n\
605 This operation exists because a directory is also a file, but its name as\n\
606 a directory is different from its name as a file.\n\
607 The result can be used as the value of `default-directory'\n\
608 or passed as second argument to `expand-file-name'.\n\
609 For a Unix-syntax file name, just appends a slash.\n\
610 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
617 CHECK_STRING (file
, 0);
621 /* If the file name has special constructs in it,
622 call the corresponding file handler. */
623 handler
= Ffind_file_name_handler (file
, Qfile_name_as_directory
);
625 return call2 (handler
, Qfile_name_as_directory
, file
);
627 buf
= (char *) alloca (STRING_BYTES (XSTRING (file
)) + 10);
628 return build_string (file_name_as_directory (buf
, XSTRING (file
)->data
));
632 * Convert from directory name to filename.
634 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
635 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
636 * On UNIX, it's simple: just make sure there isn't a terminating /
638 * Value is nonzero if the string output is different from the input.
642 directory_file_name (src
, dst
)
650 struct FAB fab
= cc$rms_fab
;
651 struct NAM nam
= cc$rms_nam
;
652 char esa
[NAM$C_MAXRSS
];
657 if (! index (src
, '/')
658 && (src
[slen
- 1] == ']'
659 || src
[slen
- 1] == ':'
660 || src
[slen
- 1] == '>'))
662 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
664 fab
.fab$b_fns
= slen
;
665 fab
.fab$l_nam
= &nam
;
666 fab
.fab$l_fop
= FAB$M_NAM
;
669 nam
.nam$b_ess
= sizeof esa
;
670 nam
.nam$b_nop
|= NAM$M_SYNCHK
;
672 /* We call SYS$PARSE to handle such things as [--] for us. */
673 if (SYS$
PARSE (&fab
, 0, 0) == RMS$_NORMAL
)
675 slen
= nam
.nam$b_esl
;
676 if (esa
[slen
- 1] == ';' && esa
[slen
- 2] == '.')
681 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
683 /* what about when we have logical_name:???? */
684 if (src
[slen
- 1] == ':')
685 { /* Xlate logical name and see what we get */
686 ptr
= strcpy (dst
, src
); /* upper case for getenv */
689 if ('a' <= *ptr
&& *ptr
<= 'z')
693 dst
[slen
- 1] = 0; /* remove colon */
694 if (!(src
= egetenv (dst
)))
696 /* should we jump to the beginning of this procedure?
697 Good points: allows us to use logical names that xlate
699 Bad points: can be a problem if we just translated to a device
701 For now, I'll punt and always expect VMS names, and hope for
704 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
705 { /* no recursion here! */
711 { /* not a directory spec */
716 bracket
= src
[slen
- 1];
718 /* If bracket is ']' or '>', bracket - 2 is the corresponding
720 ptr
= index (src
, bracket
- 2);
722 { /* no opening bracket */
726 if (!(rptr
= rindex (src
, '.')))
729 strncpy (dst
, src
, slen
);
733 dst
[slen
++] = bracket
;
738 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
739 then translate the device and recurse. */
740 if (dst
[slen
- 1] == ':'
741 && dst
[slen
- 2] != ':' /* skip decnet nodes */
742 && strcmp (src
+ slen
, "[000000]") == 0)
744 dst
[slen
- 1] = '\0';
745 if ((ptr
= egetenv (dst
))
746 && (rlen
= strlen (ptr
) - 1) > 0
747 && (ptr
[rlen
] == ']' || ptr
[rlen
] == '>')
748 && ptr
[rlen
- 1] == '.')
750 char * buf
= (char *) alloca (strlen (ptr
) + 1);
754 return directory_file_name (buf
, dst
);
759 strcat (dst
, "[000000]");
763 rlen
= strlen (rptr
) - 1;
764 strncat (dst
, rptr
, rlen
);
765 dst
[slen
+ rlen
] = '\0';
766 strcat (dst
, ".DIR.1");
770 /* Process as Unix format: just remove any final slash.
771 But leave "/" unchanged; do not change it to "". */
774 /* Handle // as root for apollo's. */
775 if ((slen
> 2 && dst
[slen
- 1] == '/')
776 || (slen
> 1 && dst
[0] != '/' && dst
[slen
- 1] == '/'))
780 && IS_DIRECTORY_SEP (dst
[slen
- 1])
782 && !IS_ANY_SEP (dst
[slen
- 2])
788 CORRECT_DIR_SEPS (dst
);
793 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
795 "Returns the file name of the directory named DIRECTORY.\n\
796 This is the name of the file that holds the data for the directory DIRECTORY.\n\
797 This operation exists because a directory is also a file, but its name as\n\
798 a directory is different from its name as a file.\n\
799 In Unix-syntax, this function just removes the final slash.\n\
800 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
801 it returns a file name such as \"[X]Y.DIR.1\".")
803 Lisp_Object directory
;
808 CHECK_STRING (directory
, 0);
810 if (NILP (directory
))
813 /* If the file name has special constructs in it,
814 call the corresponding file handler. */
815 handler
= Ffind_file_name_handler (directory
, Qdirectory_file_name
);
817 return call2 (handler
, Qdirectory_file_name
, directory
);
820 /* 20 extra chars is insufficient for VMS, since we might perform a
821 logical name translation. an equivalence string can be up to 255
822 chars long, so grab that much extra space... - sss */
823 buf
= (char *) alloca (STRING_BYTES (XSTRING (directory
)) + 20 + 255);
825 buf
= (char *) alloca (STRING_BYTES (XSTRING (directory
)) + 20);
827 directory_file_name (XSTRING (directory
)->data
, buf
);
828 return build_string (buf
);
831 static char make_temp_name_tbl
[64] =
833 'A','B','C','D','E','F','G','H',
834 'I','J','K','L','M','N','O','P',
835 'Q','R','S','T','U','V','W','X',
836 'Y','Z','a','b','c','d','e','f',
837 'g','h','i','j','k','l','m','n',
838 'o','p','q','r','s','t','u','v',
839 'w','x','y','z','0','1','2','3',
840 '4','5','6','7','8','9','-','_'
843 static unsigned make_temp_name_count
, make_temp_name_count_initialized_p
;
845 /* Value is a temporary file name starting with PREFIX, a string.
847 The Emacs process number forms part of the result, so there is
848 no danger of generating a name being used by another process.
849 In addition, this function makes an attempt to choose a name
850 which has no existing file. To make this work, PREFIX should be
851 an absolute file name.
853 BASE64_P non-zero means add the pid as 3 characters in base64
854 encoding. In this case, 6 characters will be added to PREFIX to
855 form the file name. Otherwise, if Emacs is running on a system
856 with long file names, add the pid as a decimal number.
858 This function signals an error if no unique file name could be
862 make_temp_name (prefix
, base64_p
)
869 unsigned char *p
, *data
;
873 CHECK_STRING (prefix
, 0);
875 /* VAL is created by adding 6 characters to PREFIX. The first
876 three are the PID of this process, in base 64, and the second
877 three are incremented if the file already exists. This ensures
878 262144 unique file names per PID per PREFIX. */
880 pid
= (int) getpid ();
884 pidbuf
[0] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
885 pidbuf
[1] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
886 pidbuf
[2] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
891 #ifdef HAVE_LONG_FILE_NAMES
892 sprintf (pidbuf
, "%d", pid
);
893 pidlen
= strlen (pidbuf
);
895 pidbuf
[0] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
896 pidbuf
[1] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
897 pidbuf
[2] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
902 len
= XSTRING (prefix
)->size
;
903 val
= make_uninit_string (len
+ 3 + pidlen
);
904 data
= XSTRING (val
)->data
;
905 bcopy(XSTRING (prefix
)->data
, data
, len
);
908 bcopy (pidbuf
, p
, pidlen
);
911 /* Here we try to minimize useless stat'ing when this function is
912 invoked many times successively with the same PREFIX. We achieve
913 this by initializing count to a random value, and incrementing it
916 We don't want make-temp-name to be called while dumping,
917 because then make_temp_name_count_initialized_p would get set
918 and then make_temp_name_count would not be set when Emacs starts. */
920 if (!make_temp_name_count_initialized_p
)
922 make_temp_name_count
= (unsigned) time (NULL
);
923 make_temp_name_count_initialized_p
= 1;
929 unsigned num
= make_temp_name_count
;
931 p
[0] = make_temp_name_tbl
[num
& 63], num
>>= 6;
932 p
[1] = make_temp_name_tbl
[num
& 63], num
>>= 6;
933 p
[2] = make_temp_name_tbl
[num
& 63], num
>>= 6;
935 /* Poor man's congruential RN generator. Replace with
936 ++make_temp_name_count for debugging. */
937 make_temp_name_count
+= 25229;
938 make_temp_name_count
%= 225307;
940 if (stat (data
, &ignored
) < 0)
942 /* We want to return only if errno is ENOENT. */
946 /* The error here is dubious, but there is little else we
947 can do. The alternatives are to return nil, which is
948 as bad as (and in many cases worse than) throwing the
949 error, or to ignore the error, which will likely result
950 in looping through 225307 stat's, which is not only
951 dog-slow, but also useless since it will fallback to
952 the errow below, anyway. */
953 report_file_error ("Cannot create temporary name for prefix",
954 Fcons (prefix
, Qnil
));
959 error ("Cannot create temporary name for prefix `%s'",
960 XSTRING (prefix
)->data
);
965 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
966 "Generate temporary file name (string) starting with PREFIX (a string).\n\
967 The Emacs process number forms part of the result,\n\
968 so there is no danger of generating a name being used by another process.\n\
970 In addition, this function makes an attempt to choose a name\n\
971 which has no existing file. To make this work,\n\
972 PREFIX should be an absolute file name.\n\
974 There is a race condition between calling `make-temp-name' and creating the\n\
975 file which opens all kinds of security holes. For that reason, you should\n\
976 probably use `make-temp-file' instead.")
980 return make_temp_name (prefix
, 0);
985 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
986 "Convert filename NAME to absolute, and canonicalize it.\n\
987 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative\n\
988 (does not start with slash); if DEFAULT-DIRECTORY is nil or missing,\n\
989 the current buffer's value of default-directory is used.\n\
990 File name components that are `.' are removed, and \n\
991 so are file name components followed by `..', along with the `..' itself;\n\
992 note that these simplifications are done without checking the resulting\n\
993 file names in the file system.\n\
994 An initial `~/' expands to your home directory.\n\
995 An initial `~USER/' expands to USER's home directory.\n\
996 See also the function `substitute-in-file-name'.")
997 (name
, default_directory
)
998 Lisp_Object name
, default_directory
;
1002 register unsigned char *newdir
, *p
, *o
;
1004 unsigned char *target
;
1007 unsigned char * colon
= 0;
1008 unsigned char * close
= 0;
1009 unsigned char * slash
= 0;
1010 unsigned char * brack
= 0;
1011 int lbrack
= 0, rbrack
= 0;
1016 int collapse_newdir
= 1;
1020 Lisp_Object handler
;
1022 CHECK_STRING (name
, 0);
1024 /* If the file name has special constructs in it,
1025 call the corresponding file handler. */
1026 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
1027 if (!NILP (handler
))
1028 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
1030 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
1031 if (NILP (default_directory
))
1032 default_directory
= current_buffer
->directory
;
1033 if (! STRINGP (default_directory
))
1034 default_directory
= build_string ("/");
1036 if (!NILP (default_directory
))
1038 handler
= Ffind_file_name_handler (default_directory
, Qexpand_file_name
);
1039 if (!NILP (handler
))
1040 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
1043 o
= XSTRING (default_directory
)->data
;
1045 /* Make sure DEFAULT_DIRECTORY is properly expanded.
1046 It would be better to do this down below where we actually use
1047 default_directory. Unfortunately, calling Fexpand_file_name recursively
1048 could invoke GC, and the strings might be relocated. This would
1049 be annoying because we have pointers into strings lying around
1050 that would need adjusting, and people would add new pointers to
1051 the code and forget to adjust them, resulting in intermittent bugs.
1052 Putting this call here avoids all that crud.
1054 The EQ test avoids infinite recursion. */
1055 if (! NILP (default_directory
) && !EQ (default_directory
, name
)
1056 /* Save time in some common cases - as long as default_directory
1057 is not relative, it can be canonicalized with name below (if it
1058 is needed at all) without requiring it to be expanded now. */
1060 /* Detect MSDOS file names with drive specifiers. */
1061 && ! (IS_DRIVE (o
[0]) && IS_DEVICE_SEP (o
[1]) && IS_DIRECTORY_SEP (o
[2]))
1063 /* Detect Windows file names in UNC format. */
1064 && ! (IS_DIRECTORY_SEP (o
[0]) && IS_DIRECTORY_SEP (o
[1]))
1066 #else /* not DOS_NT */
1067 /* Detect Unix absolute file names (/... alone is not absolute on
1069 && ! (IS_DIRECTORY_SEP (o
[0]))
1070 #endif /* not DOS_NT */
1073 struct gcpro gcpro1
;
1076 default_directory
= Fexpand_file_name (default_directory
, Qnil
);
1081 /* Filenames on VMS are always upper case. */
1082 name
= Fupcase (name
);
1084 #ifdef FILE_SYSTEM_CASE
1085 name
= FILE_SYSTEM_CASE (name
);
1088 nm
= XSTRING (name
)->data
;
1091 /* We will force directory separators to be either all \ or /, so make
1092 a local copy to modify, even if there ends up being no change. */
1093 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
1095 /* Note if special escape prefix is present, but remove for now. */
1096 if (nm
[0] == '/' && nm
[1] == ':')
1102 /* Find and remove drive specifier if present; this makes nm absolute
1103 even if the rest of the name appears to be relative. Only look for
1104 drive specifier at the beginning. */
1105 if (IS_DRIVE (nm
[0]) && IS_DEVICE_SEP (nm
[1]))
1112 /* If we see "c://somedir", we want to strip the first slash after the
1113 colon when stripping the drive letter. Otherwise, this expands to
1115 if (drive
&& IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1117 #endif /* WINDOWSNT */
1121 /* Discard any previous drive specifier if nm is now in UNC format. */
1122 if (IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1128 /* If nm is absolute, look for /./ or /../ sequences; if none are
1129 found, we can probably return right away. We will avoid allocating
1130 a new string if name is already fully expanded. */
1132 IS_DIRECTORY_SEP (nm
[0])
1134 && drive
&& !is_escaped
1137 && (drive
|| IS_DIRECTORY_SEP (nm
[1])) && !is_escaped
1144 /* If it turns out that the filename we want to return is just a
1145 suffix of FILENAME, we don't need to go through and edit
1146 things; we just need to construct a new string using data
1147 starting at the middle of FILENAME. If we set lose to a
1148 non-zero value, that means we've discovered that we can't do
1155 /* Since we know the name is absolute, we can assume that each
1156 element starts with a "/". */
1158 /* "." and ".." are hairy. */
1159 if (IS_DIRECTORY_SEP (p
[0])
1161 && (IS_DIRECTORY_SEP (p
[2])
1163 || (p
[2] == '.' && (IS_DIRECTORY_SEP (p
[3])
1170 /* if dev:[dir]/, move nm to / */
1171 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1172 nm
= (brack
? brack
+ 1 : colon
+ 1);
1173 lbrack
= rbrack
= 0;
1181 /* VMS pre V4.4,convert '-'s in filenames. */
1182 if (lbrack
== rbrack
)
1184 if (dots
< 2) /* this is to allow negative version numbers */
1189 if (lbrack
> rbrack
&&
1190 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1191 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1197 /* count open brackets, reset close bracket pointer */
1198 if (p
[0] == '[' || p
[0] == '<')
1199 lbrack
++, brack
= 0;
1200 /* count close brackets, set close bracket pointer */
1201 if (p
[0] == ']' || p
[0] == '>')
1202 rbrack
++, brack
= p
;
1203 /* detect ][ or >< */
1204 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1206 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1207 nm
= p
+ 1, lose
= 1;
1208 if (p
[0] == ':' && (colon
|| slash
))
1209 /* if dev1:[dir]dev2:, move nm to dev2: */
1215 /* if /name/dev:, move nm to dev: */
1218 /* if node::dev:, move colon following dev */
1219 else if (colon
&& colon
[-1] == ':')
1221 /* if dev1:dev2:, move nm to dev2: */
1222 else if (colon
&& colon
[-1] != ':')
1227 if (p
[0] == ':' && !colon
)
1233 if (lbrack
== rbrack
)
1236 else if (p
[0] == '.')
1244 if (index (nm
, '/'))
1245 return build_string (sys_translate_unix (nm
));
1248 /* Make sure directories are all separated with / or \ as
1249 desired, but avoid allocation of a new string when not
1251 CORRECT_DIR_SEPS (nm
);
1253 if (IS_DIRECTORY_SEP (nm
[1]))
1255 if (strcmp (nm
, XSTRING (name
)->data
) != 0)
1256 name
= build_string (nm
);
1260 /* drive must be set, so this is okay */
1261 if (strcmp (nm
- 2, XSTRING (name
)->data
) != 0)
1263 name
= make_string (nm
- 2, p
- nm
+ 2);
1264 XSTRING (name
)->data
[0] = DRIVE_LETTER (drive
);
1265 XSTRING (name
)->data
[1] = ':';
1268 #else /* not DOS_NT */
1269 if (nm
== XSTRING (name
)->data
)
1271 return build_string (nm
);
1272 #endif /* not DOS_NT */
1276 /* At this point, nm might or might not be an absolute file name. We
1277 need to expand ~ or ~user if present, otherwise prefix nm with
1278 default_directory if nm is not absolute, and finally collapse /./
1279 and /foo/../ sequences.
1281 We set newdir to be the appropriate prefix if one is needed:
1282 - the relevant user directory if nm starts with ~ or ~user
1283 - the specified drive's working dir (DOS/NT only) if nm does not
1285 - the value of default_directory.
1287 Note that these prefixes are not guaranteed to be absolute (except
1288 for the working dir of a drive). Therefore, to ensure we always
1289 return an absolute name, if the final prefix is not absolute we
1290 append it to the current working directory. */
1294 if (nm
[0] == '~') /* prefix ~ */
1296 if (IS_DIRECTORY_SEP (nm
[1])
1300 || nm
[1] == 0) /* ~ by itself */
1302 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1303 newdir
= (unsigned char *) "";
1306 collapse_newdir
= 0;
1309 nm
++; /* Don't leave the slash in nm. */
1312 else /* ~user/filename */
1314 for (p
= nm
; *p
&& (!IS_DIRECTORY_SEP (*p
)
1319 o
= (unsigned char *) alloca (p
- nm
+ 1);
1320 bcopy ((char *) nm
, o
, p
- nm
);
1323 pw
= (struct passwd
*) getpwnam (o
+ 1);
1326 newdir
= (unsigned char *) pw
-> pw_dir
;
1328 nm
= p
+ 1; /* skip the terminator */
1332 collapse_newdir
= 0;
1337 /* If we don't find a user of that name, leave the name
1338 unchanged; don't move nm forward to p. */
1343 /* On DOS and Windows, nm is absolute if a drive name was specified;
1344 use the drive's current directory as the prefix if needed. */
1345 if (!newdir
&& drive
)
1347 /* Get default directory if needed to make nm absolute. */
1348 if (!IS_DIRECTORY_SEP (nm
[0]))
1350 newdir
= alloca (MAXPATHLEN
+ 1);
1351 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1356 /* Either nm starts with /, or drive isn't mounted. */
1357 newdir
= alloca (4);
1358 newdir
[0] = DRIVE_LETTER (drive
);
1366 /* Finally, if no prefix has been specified and nm is not absolute,
1367 then it must be expanded relative to default_directory. */
1371 /* /... alone is not absolute on DOS and Windows. */
1372 && !IS_DIRECTORY_SEP (nm
[0])
1375 && !(IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1382 newdir
= XSTRING (default_directory
)->data
;
1384 /* Note if special escape prefix is present, but remove for now. */
1385 if (newdir
[0] == '/' && newdir
[1] == ':')
1396 /* First ensure newdir is an absolute name. */
1398 /* Detect MSDOS file names with drive specifiers. */
1399 ! (IS_DRIVE (newdir
[0])
1400 && IS_DEVICE_SEP (newdir
[1]) && IS_DIRECTORY_SEP (newdir
[2]))
1402 /* Detect Windows file names in UNC format. */
1403 && ! (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1407 /* Effectively, let newdir be (expand-file-name newdir cwd).
1408 Because of the admonition against calling expand-file-name
1409 when we have pointers into lisp strings, we accomplish this
1410 indirectly by prepending newdir to nm if necessary, and using
1411 cwd (or the wd of newdir's drive) as the new newdir. */
1413 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1418 if (!IS_DIRECTORY_SEP (nm
[0]))
1420 char * tmp
= alloca (strlen (newdir
) + strlen (nm
) + 2);
1421 file_name_as_directory (tmp
, newdir
);
1425 newdir
= alloca (MAXPATHLEN
+ 1);
1428 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1435 /* Strip off drive name from prefix, if present. */
1436 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1442 /* Keep only a prefix from newdir if nm starts with slash
1443 (//server/share for UNC, nothing otherwise). */
1444 if (IS_DIRECTORY_SEP (nm
[0]) && collapse_newdir
)
1447 if (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1449 newdir
= strcpy (alloca (strlen (newdir
) + 1), newdir
);
1451 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1453 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1465 /* Get rid of any slash at the end of newdir, unless newdir is
1466 just / or // (an incomplete UNC name). */
1467 length
= strlen (newdir
);
1468 if (length
> 1 && IS_DIRECTORY_SEP (newdir
[length
- 1])
1470 && !(length
== 2 && IS_DIRECTORY_SEP (newdir
[0]))
1474 unsigned char *temp
= (unsigned char *) alloca (length
);
1475 bcopy (newdir
, temp
, length
- 1);
1476 temp
[length
- 1] = 0;
1484 /* Now concatenate the directory and name to new space in the stack frame */
1485 tlen
+= strlen (nm
) + 1;
1487 /* Reserve space for drive specifier and escape prefix, since either
1488 or both may need to be inserted. (The Microsoft x86 compiler
1489 produces incorrect code if the following two lines are combined.) */
1490 target
= (unsigned char *) alloca (tlen
+ 4);
1492 #else /* not DOS_NT */
1493 target
= (unsigned char *) alloca (tlen
);
1494 #endif /* not DOS_NT */
1500 if (nm
[0] == 0 || IS_DIRECTORY_SEP (nm
[0]))
1503 /* If newdir is effectively "C:/", then the drive letter will have
1504 been stripped and newdir will be "/". Concatenating with an
1505 absolute directory in nm produces "//", which will then be
1506 incorrectly treated as a network share. Ignore newdir in
1507 this case (keeping the drive letter). */
1508 if (!(drive
&& nm
[0] && IS_DIRECTORY_SEP (newdir
[0])
1509 && newdir
[1] == '\0'))
1511 strcpy (target
, newdir
);
1515 file_name_as_directory (target
, newdir
);
1518 strcat (target
, nm
);
1520 if (index (target
, '/'))
1521 strcpy (target
, sys_translate_unix (target
));
1524 /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */
1526 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1534 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1540 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1541 /* brackets are offset from each other by 2 */
1544 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1545 /* convert [foo][bar] to [bar] */
1546 while (o
[-1] != '[' && o
[-1] != '<')
1548 else if (*p
== '-' && *o
!= '.')
1551 else if (p
[0] == '-' && o
[-1] == '.' &&
1552 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1553 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1557 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1558 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1560 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1562 /* else [foo.-] ==> [-] */
1568 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1569 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1575 if (!IS_DIRECTORY_SEP (*p
))
1579 else if (IS_DIRECTORY_SEP (p
[0])
1581 && (IS_DIRECTORY_SEP (p
[2])
1584 /* If "/." is the entire filename, keep the "/". Otherwise,
1585 just delete the whole "/.". */
1586 if (o
== target
&& p
[2] == '\0')
1590 else if (IS_DIRECTORY_SEP (p
[0]) && p
[1] == '.' && p
[2] == '.'
1591 /* `/../' is the "superroot" on certain file systems. */
1593 && (IS_DIRECTORY_SEP (p
[3]) || p
[3] == 0))
1595 while (o
!= target
&& (--o
) && !IS_DIRECTORY_SEP (*o
))
1597 /* Keep initial / only if this is the whole name. */
1598 if (o
== target
&& IS_ANY_SEP (*o
) && p
[3] == 0)
1606 #endif /* not VMS */
1610 /* At last, set drive name. */
1612 /* Except for network file name. */
1613 if (!(IS_DIRECTORY_SEP (target
[0]) && IS_DIRECTORY_SEP (target
[1])))
1614 #endif /* WINDOWSNT */
1616 if (!drive
) abort ();
1618 target
[0] = DRIVE_LETTER (drive
);
1621 /* Reinsert the escape prefix if required. */
1628 CORRECT_DIR_SEPS (target
);
1631 return make_string (target
, o
- target
);
1635 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'. */
1636 DEAFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
1637 "Convert FILENAME to absolute, and canonicalize it.\n\
1638 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1639 (does not start with slash); if DEFAULT is nil or missing,\n\
1640 the current buffer's value of default-directory is used.\n\
1641 Filenames containing `.' or `..' as components are simplified;\n\
1642 initial `~/' expands to your home directory.\n\
1643 See also the function `substitute-in-file-name'.")
1645 Lisp_Object name
, defalt
;
1649 register unsigned char *newdir
, *p
, *o
;
1651 unsigned char *target
;
1655 unsigned char * colon
= 0;
1656 unsigned char * close
= 0;
1657 unsigned char * slash
= 0;
1658 unsigned char * brack
= 0;
1659 int lbrack
= 0, rbrack
= 0;
1663 CHECK_STRING (name
, 0);
1666 /* Filenames on VMS are always upper case. */
1667 name
= Fupcase (name
);
1670 nm
= XSTRING (name
)->data
;
1672 /* If nm is absolute, flush ...// and detect /./ and /../.
1673 If no /./ or /../ we can return right away. */
1685 if (p
[0] == '/' && p
[1] == '/'
1687 /* // at start of filename is meaningful on Apollo system. */
1692 if (p
[0] == '/' && p
[1] == '~')
1693 nm
= p
+ 1, lose
= 1;
1694 if (p
[0] == '/' && p
[1] == '.'
1695 && (p
[2] == '/' || p
[2] == 0
1696 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1702 /* if dev:[dir]/, move nm to / */
1703 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1704 nm
= (brack
? brack
+ 1 : colon
+ 1);
1705 lbrack
= rbrack
= 0;
1713 /* VMS pre V4.4,convert '-'s in filenames. */
1714 if (lbrack
== rbrack
)
1716 if (dots
< 2) /* this is to allow negative version numbers */
1721 if (lbrack
> rbrack
&&
1722 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1723 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1729 /* count open brackets, reset close bracket pointer */
1730 if (p
[0] == '[' || p
[0] == '<')
1731 lbrack
++, brack
= 0;
1732 /* count close brackets, set close bracket pointer */
1733 if (p
[0] == ']' || p
[0] == '>')
1734 rbrack
++, brack
= p
;
1735 /* detect ][ or >< */
1736 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1738 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1739 nm
= p
+ 1, lose
= 1;
1740 if (p
[0] == ':' && (colon
|| slash
))
1741 /* if dev1:[dir]dev2:, move nm to dev2: */
1747 /* If /name/dev:, move nm to dev: */
1750 /* If node::dev:, move colon following dev */
1751 else if (colon
&& colon
[-1] == ':')
1753 /* If dev1:dev2:, move nm to dev2: */
1754 else if (colon
&& colon
[-1] != ':')
1759 if (p
[0] == ':' && !colon
)
1765 if (lbrack
== rbrack
)
1768 else if (p
[0] == '.')
1776 if (index (nm
, '/'))
1777 return build_string (sys_translate_unix (nm
));
1779 if (nm
== XSTRING (name
)->data
)
1781 return build_string (nm
);
1785 /* Now determine directory to start with and put it in NEWDIR */
1789 if (nm
[0] == '~') /* prefix ~ */
1794 || nm
[1] == 0)/* ~/filename */
1796 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1797 newdir
= (unsigned char *) "";
1800 nm
++; /* Don't leave the slash in nm. */
1803 else /* ~user/filename */
1805 /* Get past ~ to user */
1806 unsigned char *user
= nm
+ 1;
1807 /* Find end of name. */
1808 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1809 int len
= ptr
? ptr
- user
: strlen (user
);
1811 unsigned char *ptr1
= index (user
, ':');
1812 if (ptr1
!= 0 && ptr1
- user
< len
)
1815 /* Copy the user name into temp storage. */
1816 o
= (unsigned char *) alloca (len
+ 1);
1817 bcopy ((char *) user
, o
, len
);
1820 /* Look up the user name. */
1821 pw
= (struct passwd
*) getpwnam (o
+ 1);
1823 error ("\"%s\" isn't a registered user", o
+ 1);
1825 newdir
= (unsigned char *) pw
->pw_dir
;
1827 /* Discard the user name from NM. */
1834 #endif /* not VMS */
1838 defalt
= current_buffer
->directory
;
1839 CHECK_STRING (defalt
, 1);
1840 newdir
= XSTRING (defalt
)->data
;
1843 /* Now concatenate the directory and name to new space in the stack frame */
1845 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1846 target
= (unsigned char *) alloca (tlen
);
1852 if (nm
[0] == 0 || nm
[0] == '/')
1853 strcpy (target
, newdir
);
1856 file_name_as_directory (target
, newdir
);
1859 strcat (target
, nm
);
1861 if (index (target
, '/'))
1862 strcpy (target
, sys_translate_unix (target
));
1865 /* Now canonicalize by removing /. and /foo/.. if they appear */
1873 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1879 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1880 /* brackets are offset from each other by 2 */
1883 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1884 /* convert [foo][bar] to [bar] */
1885 while (o
[-1] != '[' && o
[-1] != '<')
1887 else if (*p
== '-' && *o
!= '.')
1890 else if (p
[0] == '-' && o
[-1] == '.' &&
1891 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1892 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1896 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1897 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1899 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1901 /* else [foo.-] ==> [-] */
1907 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1908 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1918 else if (!strncmp (p
, "//", 2)
1920 /* // at start of filename is meaningful in Apollo system. */
1928 else if (p
[0] == '/' && p
[1] == '.' &&
1929 (p
[2] == '/' || p
[2] == 0))
1931 else if (!strncmp (p
, "/..", 3)
1932 /* `/../' is the "superroot" on certain file systems. */
1934 && (p
[3] == '/' || p
[3] == 0))
1936 while (o
!= target
&& *--o
!= '/')
1939 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1943 if (o
== target
&& *o
== '/')
1951 #endif /* not VMS */
1954 return make_string (target
, o
- target
);
1958 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1959 Ssubstitute_in_file_name
, 1, 1, 0,
1960 "Substitute environment variables referred to in FILENAME.\n\
1961 `$FOO' where FOO is an environment variable name means to substitute\n\
1962 the value of that variable. The variable name should be terminated\n\
1963 with a character not a letter, digit or underscore; otherwise, enclose\n\
1964 the entire variable name in braces.\n\
1965 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1966 On VMS, `$' substitution is not done; this function does little and only\n\
1967 duplicates what `expand-file-name' does.")
1969 Lisp_Object filename
;
1973 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1974 unsigned char *target
;
1976 int substituted
= 0;
1978 Lisp_Object handler
;
1980 CHECK_STRING (filename
, 0);
1982 /* If the file name has special constructs in it,
1983 call the corresponding file handler. */
1984 handler
= Ffind_file_name_handler (filename
, Qsubstitute_in_file_name
);
1985 if (!NILP (handler
))
1986 return call2 (handler
, Qsubstitute_in_file_name
, filename
);
1988 nm
= XSTRING (filename
)->data
;
1990 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
1991 CORRECT_DIR_SEPS (nm
);
1992 substituted
= (strcmp (nm
, XSTRING (filename
)->data
) != 0);
1994 endp
= nm
+ STRING_BYTES (XSTRING (filename
));
1996 /* If /~ or // appears, discard everything through first slash. */
1998 for (p
= nm
; p
!= endp
; p
++)
2001 #if defined (APOLLO) || defined (WINDOWSNT)
2002 /* // at start of file name is meaningful in Apollo and
2003 WindowsNT systems. */
2004 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != nm
)
2005 #else /* not (APOLLO || WINDOWSNT) */
2006 || IS_DIRECTORY_SEP (p
[0])
2007 #endif /* not (APOLLO || WINDOWSNT) */
2012 || p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>'
2014 || IS_DIRECTORY_SEP (p
[-1])))
2020 /* see comment in expand-file-name about drive specifiers */
2021 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
2022 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
2031 return build_string (nm
);
2034 /* See if any variables are substituted into the string
2035 and find the total length of their values in `total' */
2037 for (p
= nm
; p
!= endp
;)
2047 /* "$$" means a single "$" */
2056 while (p
!= endp
&& *p
!= '}') p
++;
2057 if (*p
!= '}') goto missingclose
;
2063 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
2067 /* Copy out the variable name */
2068 target
= (unsigned char *) alloca (s
- o
+ 1);
2069 strncpy (target
, o
, s
- o
);
2072 strupr (target
); /* $home == $HOME etc. */
2075 /* Get variable value */
2076 o
= (unsigned char *) egetenv (target
);
2077 if (!o
) goto badvar
;
2078 total
+= strlen (o
);
2085 /* If substitution required, recopy the string and do it */
2086 /* Make space in stack frame for the new copy */
2087 xnm
= (unsigned char *) alloca (STRING_BYTES (XSTRING (filename
)) + total
+ 1);
2090 /* Copy the rest of the name through, replacing $ constructs with values */
2107 while (p
!= endp
&& *p
!= '}') p
++;
2108 if (*p
!= '}') goto missingclose
;
2114 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
2118 /* Copy out the variable name */
2119 target
= (unsigned char *) alloca (s
- o
+ 1);
2120 strncpy (target
, o
, s
- o
);
2123 strupr (target
); /* $home == $HOME etc. */
2126 /* Get variable value */
2127 o
= (unsigned char *) egetenv (target
);
2131 if (STRING_MULTIBYTE (filename
))
2133 /* If the original string is multibyte,
2134 convert what we substitute into multibyte. */
2137 int c
= unibyte_char_to_multibyte (*o
++);
2138 x
+= CHAR_STRING (c
, x
);
2150 /* If /~ or // appears, discard everything through first slash. */
2152 for (p
= xnm
; p
!= x
; p
++)
2154 #if defined (APOLLO) || defined (WINDOWSNT)
2155 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != xnm
)
2156 #else /* not (APOLLO || WINDOWSNT) */
2157 || IS_DIRECTORY_SEP (p
[0])
2158 #endif /* not (APOLLO || WINDOWSNT) */
2160 && p
!= xnm
&& IS_DIRECTORY_SEP (p
[-1]))
2163 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
2164 && p
> xnm
&& IS_DIRECTORY_SEP (p
[-1]))
2168 if (STRING_MULTIBYTE (filename
))
2169 return make_string (xnm
, x
- xnm
);
2170 return make_unibyte_string (xnm
, x
- xnm
);
2173 error ("Bad format environment-variable substitution");
2175 error ("Missing \"}\" in environment-variable substitution");
2177 error ("Substituting nonexistent environment variable \"%s\"", target
);
2180 #endif /* not VMS */
2183 /* A slightly faster and more convenient way to get
2184 (directory-file-name (expand-file-name FOO)). */
2187 expand_and_dir_to_file (filename
, defdir
)
2188 Lisp_Object filename
, defdir
;
2190 register Lisp_Object absname
;
2192 absname
= Fexpand_file_name (filename
, defdir
);
2195 register int c
= XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
)) - 1];
2196 if (c
== ':' || c
== ']' || c
== '>')
2197 absname
= Fdirectory_file_name (absname
);
2200 /* Remove final slash, if any (unless this is the root dir).
2201 stat behaves differently depending! */
2202 if (XSTRING (absname
)->size
> 1
2203 && IS_DIRECTORY_SEP (XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
)) - 1])
2204 && !IS_DEVICE_SEP (XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
))-2]))
2205 /* We cannot take shortcuts; they might be wrong for magic file names. */
2206 absname
= Fdirectory_file_name (absname
);
2211 /* Signal an error if the file ABSNAME already exists.
2212 If INTERACTIVE is nonzero, ask the user whether to proceed,
2213 and bypass the error if the user says to go ahead.
2214 QUERYSTRING is a name for the action that is being considered
2217 *STATPTR is used to store the stat information if the file exists.
2218 If the file does not exist, STATPTR->st_mode is set to 0.
2219 If STATPTR is null, we don't store into it.
2221 If QUICK is nonzero, we ask for y or n, not yes or no. */
2224 barf_or_query_if_file_exists (absname
, querystring
, interactive
, statptr
, quick
)
2225 Lisp_Object absname
;
2226 unsigned char *querystring
;
2228 struct stat
*statptr
;
2231 register Lisp_Object tem
, encoded_filename
;
2232 struct stat statbuf
;
2233 struct gcpro gcpro1
;
2235 encoded_filename
= ENCODE_FILE (absname
);
2237 /* stat is a good way to tell whether the file exists,
2238 regardless of what access permissions it has. */
2239 if (stat (XSTRING (encoded_filename
)->data
, &statbuf
) >= 0)
2242 Fsignal (Qfile_already_exists
,
2243 Fcons (build_string ("File already exists"),
2244 Fcons (absname
, Qnil
)));
2246 tem
= format1 ("File %s already exists; %s anyway? ",
2247 XSTRING (absname
)->data
, querystring
);
2249 tem
= Fy_or_n_p (tem
);
2251 tem
= do_yes_or_no_p (tem
);
2254 Fsignal (Qfile_already_exists
,
2255 Fcons (build_string ("File already exists"),
2256 Fcons (absname
, Qnil
)));
2263 statptr
->st_mode
= 0;
2268 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
2269 "fCopy file: \nFCopy %s to file: \np\nP",
2270 "Copy FILE to NEWNAME. Both args must be strings.\n\
2271 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
2272 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
2273 A number as third arg means request confirmation if NEWNAME already exists.\n\
2274 This is what happens in interactive use with M-x.\n\
2275 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
2276 last-modified time as the old one. (This works on only some systems.)\n\
2277 A prefix arg makes KEEP-TIME non-nil.")
2278 (file
, newname
, ok_if_already_exists
, keep_date
)
2279 Lisp_Object file
, newname
, ok_if_already_exists
, keep_date
;
2282 char buf
[16 * 1024];
2283 struct stat st
, out_st
;
2284 Lisp_Object handler
;
2285 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2286 int count
= specpdl_ptr
- specpdl
;
2287 int input_file_statable_p
;
2288 Lisp_Object encoded_file
, encoded_newname
;
2290 encoded_file
= encoded_newname
= Qnil
;
2291 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2292 CHECK_STRING (file
, 0);
2293 CHECK_STRING (newname
, 1);
2295 file
= Fexpand_file_name (file
, Qnil
);
2296 newname
= Fexpand_file_name (newname
, Qnil
);
2298 /* If the input file name has special constructs in it,
2299 call the corresponding file handler. */
2300 handler
= Ffind_file_name_handler (file
, Qcopy_file
);
2301 /* Likewise for output file name. */
2303 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
2304 if (!NILP (handler
))
2305 RETURN_UNGCPRO (call5 (handler
, Qcopy_file
, file
, newname
,
2306 ok_if_already_exists
, keep_date
));
2308 encoded_file
= ENCODE_FILE (file
);
2309 encoded_newname
= ENCODE_FILE (newname
);
2311 if (NILP (ok_if_already_exists
)
2312 || INTEGERP (ok_if_already_exists
))
2313 barf_or_query_if_file_exists (encoded_newname
, "copy to it",
2314 INTEGERP (ok_if_already_exists
), &out_st
, 0);
2315 else if (stat (XSTRING (encoded_newname
)->data
, &out_st
) < 0)
2318 ifd
= emacs_open (XSTRING (encoded_file
)->data
, O_RDONLY
, 0);
2320 report_file_error ("Opening input file", Fcons (file
, Qnil
));
2322 record_unwind_protect (close_file_unwind
, make_number (ifd
));
2324 /* We can only copy regular files and symbolic links. Other files are not
2326 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
2328 #if !defined (DOS_NT) || __DJGPP__ > 1
2329 if (out_st
.st_mode
!= 0
2330 && st
.st_dev
== out_st
.st_dev
&& st
.st_ino
== out_st
.st_ino
)
2333 report_file_error ("Input and output files are the same",
2334 Fcons (file
, Fcons (newname
, Qnil
)));
2338 #if defined (S_ISREG) && defined (S_ISLNK)
2339 if (input_file_statable_p
)
2341 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
2343 #if defined (EISDIR)
2344 /* Get a better looking error message. */
2347 report_file_error ("Non-regular file", Fcons (file
, Qnil
));
2350 #endif /* S_ISREG && S_ISLNK */
2353 /* Create the copy file with the same record format as the input file */
2354 ofd
= sys_creat (XSTRING (encoded_newname
)->data
, 0666, ifd
);
2357 /* System's default file type was set to binary by _fmode in emacs.c. */
2358 ofd
= creat (XSTRING (encoded_newname
)->data
, S_IREAD
| S_IWRITE
);
2359 #else /* not MSDOS */
2360 ofd
= creat (XSTRING (encoded_newname
)->data
, 0666);
2361 #endif /* not MSDOS */
2364 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
2366 record_unwind_protect (close_file_unwind
, make_number (ofd
));
2370 while ((n
= emacs_read (ifd
, buf
, sizeof buf
)) > 0)
2371 if (emacs_write (ofd
, buf
, n
) != n
)
2372 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2375 /* Closing the output clobbers the file times on some systems. */
2376 if (emacs_close (ofd
) < 0)
2377 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2379 if (input_file_statable_p
)
2381 if (!NILP (keep_date
))
2383 EMACS_TIME atime
, mtime
;
2384 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
2385 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
2386 if (set_file_times (XSTRING (encoded_newname
)->data
,
2388 Fsignal (Qfile_date_error
,
2389 Fcons (build_string ("Cannot set file date"),
2390 Fcons (newname
, Qnil
)));
2393 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2395 #if defined (__DJGPP__) && __DJGPP__ > 1
2396 /* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
2397 and if it can't, it tells so. Otherwise, under MSDOS we usually
2398 get only the READ bit, which will make the copied file read-only,
2399 so it's better not to chmod at all. */
2400 if ((_djstat_flags
& _STFAIL_WRITEBIT
) == 0)
2401 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2402 #endif /* DJGPP version 2 or newer */
2408 /* Discard the unwind protects. */
2409 specpdl_ptr
= specpdl
+ count
;
2415 DEFUN ("make-directory-internal", Fmake_directory_internal
,
2416 Smake_directory_internal
, 1, 1, 0,
2417 "Create a new directory named DIRECTORY.")
2419 Lisp_Object directory
;
2422 Lisp_Object handler
;
2423 Lisp_Object encoded_dir
;
2425 CHECK_STRING (directory
, 0);
2426 directory
= Fexpand_file_name (directory
, Qnil
);
2428 handler
= Ffind_file_name_handler (directory
, Qmake_directory_internal
);
2429 if (!NILP (handler
))
2430 return call2 (handler
, Qmake_directory_internal
, directory
);
2432 encoded_dir
= ENCODE_FILE (directory
);
2434 dir
= XSTRING (encoded_dir
)->data
;
2437 if (mkdir (dir
) != 0)
2439 if (mkdir (dir
, 0777) != 0)
2441 report_file_error ("Creating directory", Flist (1, &directory
));
2446 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
2447 "Delete the directory named DIRECTORY.")
2449 Lisp_Object directory
;
2452 Lisp_Object handler
;
2453 Lisp_Object encoded_dir
;
2455 CHECK_STRING (directory
, 0);
2456 directory
= Fdirectory_file_name (Fexpand_file_name (directory
, Qnil
));
2458 handler
= Ffind_file_name_handler (directory
, Qdelete_directory
);
2459 if (!NILP (handler
))
2460 return call2 (handler
, Qdelete_directory
, directory
);
2462 encoded_dir
= ENCODE_FILE (directory
);
2464 dir
= XSTRING (encoded_dir
)->data
;
2466 if (rmdir (dir
) != 0)
2467 report_file_error ("Removing directory", Flist (1, &directory
));
2472 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
2473 "Delete file named FILENAME.\n\
2474 If file has multiple names, it continues to exist with the other names.")
2476 Lisp_Object filename
;
2478 Lisp_Object handler
;
2479 Lisp_Object encoded_file
;
2481 CHECK_STRING (filename
, 0);
2482 filename
= Fexpand_file_name (filename
, Qnil
);
2484 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
2485 if (!NILP (handler
))
2486 return call2 (handler
, Qdelete_file
, filename
);
2488 encoded_file
= ENCODE_FILE (filename
);
2490 if (0 > unlink (XSTRING (encoded_file
)->data
))
2491 report_file_error ("Removing old name", Flist (1, &filename
));
2496 internal_delete_file_1 (ignore
)
2502 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */
2505 internal_delete_file (filename
)
2506 Lisp_Object filename
;
2508 return NILP (internal_condition_case_1 (Fdelete_file
, filename
,
2509 Qt
, internal_delete_file_1
));
2512 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
2513 "fRename file: \nFRename %s to file: \np",
2514 "Rename FILE as NEWNAME. Both args strings.\n\
2515 If file has names other than FILE, it continues to have those names.\n\
2516 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2517 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2518 A number as third arg means request confirmation if NEWNAME already exists.\n\
2519 This is what happens in interactive use with M-x.")
2520 (file
, newname
, ok_if_already_exists
)
2521 Lisp_Object file
, newname
, ok_if_already_exists
;
2524 Lisp_Object args
[2];
2526 Lisp_Object handler
;
2527 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2528 Lisp_Object encoded_file
, encoded_newname
;
2530 encoded_file
= encoded_newname
= Qnil
;
2531 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2532 CHECK_STRING (file
, 0);
2533 CHECK_STRING (newname
, 1);
2534 file
= Fexpand_file_name (file
, Qnil
);
2535 newname
= Fexpand_file_name (newname
, Qnil
);
2537 /* If the file name has special constructs in it,
2538 call the corresponding file handler. */
2539 handler
= Ffind_file_name_handler (file
, Qrename_file
);
2541 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
2542 if (!NILP (handler
))
2543 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
2544 file
, newname
, ok_if_already_exists
));
2546 encoded_file
= ENCODE_FILE (file
);
2547 encoded_newname
= ENCODE_FILE (newname
);
2550 /* If the file names are identical but for the case, don't ask for
2551 confirmation: they simply want to change the letter-case of the
2553 if (NILP (Fstring_equal (Fdowncase (file
), Fdowncase (newname
))))
2555 if (NILP (ok_if_already_exists
)
2556 || INTEGERP (ok_if_already_exists
))
2557 barf_or_query_if_file_exists (encoded_newname
, "rename to it",
2558 INTEGERP (ok_if_already_exists
), 0, 0);
2560 if (0 > rename (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2562 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
)
2563 || 0 > unlink (XSTRING (encoded_file
)->data
))
2568 Fcopy_file (file
, newname
,
2569 /* We have already prompted if it was an integer,
2570 so don't have copy-file prompt again. */
2571 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
2572 Fdelete_file (file
);
2579 report_file_error ("Renaming", Flist (2, args
));
2582 report_file_error ("Renaming", Flist (2, &file
));
2589 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
2590 "fAdd name to file: \nFName to add to %s: \np",
2591 "Give FILE additional name NEWNAME. Both args strings.\n\
2592 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2593 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2594 A number as third arg means request confirmation if NEWNAME already exists.\n\
2595 This is what happens in interactive use with M-x.")
2596 (file
, newname
, ok_if_already_exists
)
2597 Lisp_Object file
, newname
, ok_if_already_exists
;
2600 Lisp_Object args
[2];
2602 Lisp_Object handler
;
2603 Lisp_Object encoded_file
, encoded_newname
;
2604 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2606 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2607 encoded_file
= encoded_newname
= Qnil
;
2608 CHECK_STRING (file
, 0);
2609 CHECK_STRING (newname
, 1);
2610 file
= Fexpand_file_name (file
, Qnil
);
2611 newname
= Fexpand_file_name (newname
, Qnil
);
2613 /* If the file name has special constructs in it,
2614 call the corresponding file handler. */
2615 handler
= Ffind_file_name_handler (file
, Qadd_name_to_file
);
2616 if (!NILP (handler
))
2617 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2618 newname
, ok_if_already_exists
));
2620 /* If the new name has special constructs in it,
2621 call the corresponding file handler. */
2622 handler
= Ffind_file_name_handler (newname
, Qadd_name_to_file
);
2623 if (!NILP (handler
))
2624 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2625 newname
, ok_if_already_exists
));
2627 encoded_file
= ENCODE_FILE (file
);
2628 encoded_newname
= ENCODE_FILE (newname
);
2630 if (NILP (ok_if_already_exists
)
2631 || INTEGERP (ok_if_already_exists
))
2632 barf_or_query_if_file_exists (encoded_newname
, "make it a new name",
2633 INTEGERP (ok_if_already_exists
), 0, 0);
2635 unlink (XSTRING (newname
)->data
);
2636 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2641 report_file_error ("Adding new name", Flist (2, args
));
2643 report_file_error ("Adding new name", Flist (2, &file
));
2652 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2653 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2654 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
2655 Signals a `file-already-exists' error if a file LINKNAME already exists\n\
2656 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2657 A number as third arg means request confirmation if LINKNAME already exists.\n\
2658 This happens for interactive use with M-x.")
2659 (filename
, linkname
, ok_if_already_exists
)
2660 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2663 Lisp_Object args
[2];
2665 Lisp_Object handler
;
2666 Lisp_Object encoded_filename
, encoded_linkname
;
2667 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2669 GCPRO4 (filename
, linkname
, encoded_filename
, encoded_linkname
);
2670 encoded_filename
= encoded_linkname
= Qnil
;
2671 CHECK_STRING (filename
, 0);
2672 CHECK_STRING (linkname
, 1);
2673 /* If the link target has a ~, we must expand it to get
2674 a truly valid file name. Otherwise, do not expand;
2675 we want to permit links to relative file names. */
2676 if (XSTRING (filename
)->data
[0] == '~')
2677 filename
= Fexpand_file_name (filename
, Qnil
);
2678 linkname
= Fexpand_file_name (linkname
, Qnil
);
2680 /* If the file name has special constructs in it,
2681 call the corresponding file handler. */
2682 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2683 if (!NILP (handler
))
2684 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2685 linkname
, ok_if_already_exists
));
2687 /* If the new link name has special constructs in it,
2688 call the corresponding file handler. */
2689 handler
= Ffind_file_name_handler (linkname
, Qmake_symbolic_link
);
2690 if (!NILP (handler
))
2691 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2692 linkname
, ok_if_already_exists
));
2694 encoded_filename
= ENCODE_FILE (filename
);
2695 encoded_linkname
= ENCODE_FILE (linkname
);
2697 if (NILP (ok_if_already_exists
)
2698 || INTEGERP (ok_if_already_exists
))
2699 barf_or_query_if_file_exists (encoded_linkname
, "make it a link",
2700 INTEGERP (ok_if_already_exists
), 0, 0);
2701 if (0 > symlink (XSTRING (encoded_filename
)->data
,
2702 XSTRING (encoded_linkname
)->data
))
2704 /* If we didn't complain already, silently delete existing file. */
2705 if (errno
== EEXIST
)
2707 unlink (XSTRING (encoded_linkname
)->data
);
2708 if (0 <= symlink (XSTRING (encoded_filename
)->data
,
2709 XSTRING (encoded_linkname
)->data
))
2719 report_file_error ("Making symbolic link", Flist (2, args
));
2721 report_file_error ("Making symbolic link", Flist (2, &filename
));
2727 #endif /* S_IFLNK */
2731 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2732 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2733 "Define the job-wide logical name NAME to have the value STRING.\n\
2734 If STRING is nil or a null string, the logical name NAME is deleted.")
2739 CHECK_STRING (name
, 0);
2741 delete_logical_name (XSTRING (name
)->data
);
2744 CHECK_STRING (string
, 1);
2746 if (XSTRING (string
)->size
== 0)
2747 delete_logical_name (XSTRING (name
)->data
);
2749 define_logical_name (XSTRING (name
)->data
, XSTRING (string
)->data
);
2758 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2759 "Open a network connection to PATH using LOGIN as the login string.")
2761 Lisp_Object path
, login
;
2765 CHECK_STRING (path
, 0);
2766 CHECK_STRING (login
, 0);
2768 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2770 if (netresult
== -1)
2775 #endif /* HPUX_NET */
2777 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2779 "Return t if file FILENAME specifies an absolute file name.\n\
2780 On Unix, this is a name starting with a `/' or a `~'.")
2782 Lisp_Object filename
;
2786 CHECK_STRING (filename
, 0);
2787 ptr
= XSTRING (filename
)->data
;
2788 if (IS_DIRECTORY_SEP (*ptr
) || *ptr
== '~'
2790 /* ??? This criterion is probably wrong for '<'. */
2791 || index (ptr
, ':') || index (ptr
, '<')
2792 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2796 || (IS_DRIVE (*ptr
) && ptr
[1] == ':' && IS_DIRECTORY_SEP (ptr
[2]))
2804 /* Return nonzero if file FILENAME exists and can be executed. */
2807 check_executable (filename
)
2811 int len
= strlen (filename
);
2814 if (stat (filename
, &st
) < 0)
2816 #if defined (WINDOWSNT) || (defined (MSDOS) && __DJGPP__ > 1)
2817 return ((st
.st_mode
& S_IEXEC
) != 0);
2819 return (S_ISREG (st
.st_mode
)
2821 && (stricmp ((suffix
= filename
+ len
-4), ".com") == 0
2822 || stricmp (suffix
, ".exe") == 0
2823 || stricmp (suffix
, ".bat") == 0)
2824 || (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2825 #endif /* not WINDOWSNT */
2826 #else /* not DOS_NT */
2827 #ifdef HAVE_EUIDACCESS
2828 return (euidaccess (filename
, 1) >= 0);
2830 /* Access isn't quite right because it uses the real uid
2831 and we really want to test with the effective uid.
2832 But Unix doesn't give us a right way to do it. */
2833 return (access (filename
, 1) >= 0);
2835 #endif /* not DOS_NT */
2838 /* Return nonzero if file FILENAME exists and can be written. */
2841 check_writable (filename
)
2846 if (stat (filename
, &st
) < 0)
2848 return (st
.st_mode
& S_IWRITE
|| (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2849 #else /* not MSDOS */
2850 #ifdef HAVE_EUIDACCESS
2851 return (euidaccess (filename
, 2) >= 0);
2853 /* Access isn't quite right because it uses the real uid
2854 and we really want to test with the effective uid.
2855 But Unix doesn't give us a right way to do it.
2856 Opening with O_WRONLY could work for an ordinary file,
2857 but would lose for directories. */
2858 return (access (filename
, 2) >= 0);
2860 #endif /* not MSDOS */
2863 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2864 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
2865 See also `file-readable-p' and `file-attributes'.")
2867 Lisp_Object filename
;
2869 Lisp_Object absname
;
2870 Lisp_Object handler
;
2871 struct stat statbuf
;
2873 CHECK_STRING (filename
, 0);
2874 absname
= Fexpand_file_name (filename
, Qnil
);
2876 /* If the file name has special constructs in it,
2877 call the corresponding file handler. */
2878 handler
= Ffind_file_name_handler (absname
, Qfile_exists_p
);
2879 if (!NILP (handler
))
2880 return call2 (handler
, Qfile_exists_p
, absname
);
2882 absname
= ENCODE_FILE (absname
);
2884 return (stat (XSTRING (absname
)->data
, &statbuf
) >= 0) ? Qt
: Qnil
;
2887 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2888 "Return t if FILENAME can be executed by you.\n\
2889 For a directory, this means you can access files in that directory.")
2891 Lisp_Object filename
;
2894 Lisp_Object absname
;
2895 Lisp_Object handler
;
2897 CHECK_STRING (filename
, 0);
2898 absname
= Fexpand_file_name (filename
, Qnil
);
2900 /* If the file name has special constructs in it,
2901 call the corresponding file handler. */
2902 handler
= Ffind_file_name_handler (absname
, Qfile_executable_p
);
2903 if (!NILP (handler
))
2904 return call2 (handler
, Qfile_executable_p
, absname
);
2906 absname
= ENCODE_FILE (absname
);
2908 return (check_executable (XSTRING (absname
)->data
) ? Qt
: Qnil
);
2911 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2912 "Return t if file FILENAME exists and you can read it.\n\
2913 See also `file-exists-p' and `file-attributes'.")
2915 Lisp_Object filename
;
2917 Lisp_Object absname
;
2918 Lisp_Object handler
;
2921 struct stat statbuf
;
2923 CHECK_STRING (filename
, 0);
2924 absname
= Fexpand_file_name (filename
, Qnil
);
2926 /* If the file name has special constructs in it,
2927 call the corresponding file handler. */
2928 handler
= Ffind_file_name_handler (absname
, Qfile_readable_p
);
2929 if (!NILP (handler
))
2930 return call2 (handler
, Qfile_readable_p
, absname
);
2932 absname
= ENCODE_FILE (absname
);
2935 /* Under MS-DOS and Windows, open does not work for directories. */
2936 if (access (XSTRING (absname
)->data
, 0) == 0)
2939 #else /* not DOS_NT */
2941 #if defined (S_ISFIFO) && defined (O_NONBLOCK)
2942 /* Opening a fifo without O_NONBLOCK can wait.
2943 We don't want to wait. But we don't want to mess wth O_NONBLOCK
2944 except in the case of a fifo, on a system which handles it. */
2945 desc
= stat (XSTRING (absname
)->data
, &statbuf
);
2948 if (S_ISFIFO (statbuf
.st_mode
))
2949 flags
|= O_NONBLOCK
;
2951 desc
= emacs_open (XSTRING (absname
)->data
, flags
, 0);
2956 #endif /* not DOS_NT */
2959 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2961 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
2962 "Return t if file FILENAME can be written or created by you.")
2964 Lisp_Object filename
;
2966 Lisp_Object absname
, dir
, encoded
;
2967 Lisp_Object handler
;
2968 struct stat statbuf
;
2970 CHECK_STRING (filename
, 0);
2971 absname
= Fexpand_file_name (filename
, Qnil
);
2973 /* If the file name has special constructs in it,
2974 call the corresponding file handler. */
2975 handler
= Ffind_file_name_handler (absname
, Qfile_writable_p
);
2976 if (!NILP (handler
))
2977 return call2 (handler
, Qfile_writable_p
, absname
);
2979 encoded
= ENCODE_FILE (absname
);
2980 if (stat (XSTRING (encoded
)->data
, &statbuf
) >= 0)
2981 return (check_writable (XSTRING (encoded
)->data
)
2984 dir
= Ffile_name_directory (absname
);
2987 dir
= Fdirectory_file_name (dir
);
2991 dir
= Fdirectory_file_name (dir
);
2994 dir
= ENCODE_FILE (dir
);
2996 /* The read-only attribute of the parent directory doesn't affect
2997 whether a file or directory can be created within it. Some day we
2998 should check ACLs though, which do affect this. */
2999 if (stat (XSTRING (dir
)->data
, &statbuf
) < 0)
3001 return (statbuf
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
3003 return (check_writable (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "")
3008 DEFUN ("access-file", Faccess_file
, Saccess_file
, 2, 2, 0,
3009 "Access file FILENAME, and get an error if that does not work.\n\
3010 The second argument STRING is used in the error message.\n\
3011 If there is no error, we return nil.")
3013 Lisp_Object filename
, string
;
3015 Lisp_Object handler
, encoded_filename
;
3018 CHECK_STRING (filename
, 0);
3019 CHECK_STRING (string
, 1);
3021 /* If the file name has special constructs in it,
3022 call the corresponding file handler. */
3023 handler
= Ffind_file_name_handler (filename
, Qaccess_file
);
3024 if (!NILP (handler
))
3025 return call3 (handler
, Qaccess_file
, filename
, string
);
3027 encoded_filename
= ENCODE_FILE (filename
);
3029 fd
= emacs_open (XSTRING (encoded_filename
)->data
, O_RDONLY
, 0);
3031 report_file_error (XSTRING (string
)->data
, Fcons (filename
, Qnil
));
3037 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
3038 "Return non-nil if file FILENAME is the name of a symbolic link.\n\
3039 The value is the name of the file to which it is linked.\n\
3040 Otherwise returns nil.")
3042 Lisp_Object filename
;
3049 Lisp_Object handler
;
3051 CHECK_STRING (filename
, 0);
3052 filename
= Fexpand_file_name (filename
, Qnil
);
3054 /* If the file name has special constructs in it,
3055 call the corresponding file handler. */
3056 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
3057 if (!NILP (handler
))
3058 return call2 (handler
, Qfile_symlink_p
, filename
);
3060 filename
= ENCODE_FILE (filename
);
3065 buf
= (char *) xmalloc (bufsize
);
3066 bzero (buf
, bufsize
);
3067 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
3068 if (valsize
< bufsize
) break;
3069 /* Buffer was not long enough */
3078 val
= make_string (buf
, valsize
);
3079 if (buf
[0] == '/' && index (buf
, ':'))
3080 val
= concat2 (build_string ("/:"), val
);
3082 val
= DECODE_FILE (val
);
3084 #else /* not S_IFLNK */
3086 #endif /* not S_IFLNK */
3089 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
3090 "Return t if FILENAME names an existing directory.\n\
3091 Symbolic links to directories count as directories.\n\
3092 See `file-symlink-p' to distinguish symlinks.")
3094 Lisp_Object filename
;
3096 register Lisp_Object absname
;
3098 Lisp_Object handler
;
3100 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
3102 /* If the file name has special constructs in it,
3103 call the corresponding file handler. */
3104 handler
= Ffind_file_name_handler (absname
, Qfile_directory_p
);
3105 if (!NILP (handler
))
3106 return call2 (handler
, Qfile_directory_p
, absname
);
3108 absname
= ENCODE_FILE (absname
);
3110 if (stat (XSTRING (absname
)->data
, &st
) < 0)
3112 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
3115 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
3116 "Return t if file FILENAME is the name of a directory as a file,\n\
3117 and files in that directory can be opened by you. In order to use a\n\
3118 directory as a buffer's current directory, this predicate must return true.\n\
3119 A directory name spec may be given instead; then the value is t\n\
3120 if the directory so specified exists and really is a readable and\n\
3121 searchable directory.")
3123 Lisp_Object filename
;
3125 Lisp_Object handler
;
3127 struct gcpro gcpro1
;
3129 /* If the file name has special constructs in it,
3130 call the corresponding file handler. */
3131 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
3132 if (!NILP (handler
))
3133 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
3135 /* It's an unlikely combination, but yes we really do need to gcpro:
3136 Suppose that file-accessible-directory-p has no handler, but
3137 file-directory-p does have a handler; this handler causes a GC which
3138 relocates the string in `filename'; and finally file-directory-p
3139 returns non-nil. Then we would end up passing a garbaged string
3140 to file-executable-p. */
3142 tem
= (NILP (Ffile_directory_p (filename
))
3143 || NILP (Ffile_executable_p (filename
)));
3145 return tem
? Qnil
: Qt
;
3148 DEFUN ("file-regular-p", Ffile_regular_p
, Sfile_regular_p
, 1, 1, 0,
3149 "Return t if file FILENAME is the name of a regular file.\n\
3150 This is the sort of file that holds an ordinary stream of data bytes.")
3152 Lisp_Object filename
;
3154 register Lisp_Object absname
;
3156 Lisp_Object handler
;
3158 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
3160 /* If the file name has special constructs in it,
3161 call the corresponding file handler. */
3162 handler
= Ffind_file_name_handler (absname
, Qfile_regular_p
);
3163 if (!NILP (handler
))
3164 return call2 (handler
, Qfile_regular_p
, absname
);
3166 absname
= ENCODE_FILE (absname
);
3171 Lisp_Object tem
= Vw32_get_true_file_attributes
;
3173 /* Tell stat to use expensive method to get accurate info. */
3174 Vw32_get_true_file_attributes
= Qt
;
3175 result
= stat (XSTRING (absname
)->data
, &st
);
3176 Vw32_get_true_file_attributes
= tem
;
3180 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
3183 if (stat (XSTRING (absname
)->data
, &st
) < 0)
3185 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
3189 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
3190 "Return mode bits of file named FILENAME, as an integer.")
3192 Lisp_Object filename
;
3194 Lisp_Object absname
;
3196 Lisp_Object handler
;
3198 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
3200 /* If the file name has special constructs in it,
3201 call the corresponding file handler. */
3202 handler
= Ffind_file_name_handler (absname
, Qfile_modes
);
3203 if (!NILP (handler
))
3204 return call2 (handler
, Qfile_modes
, absname
);
3206 absname
= ENCODE_FILE (absname
);
3208 if (stat (XSTRING (absname
)->data
, &st
) < 0)
3210 #if defined (MSDOS) && __DJGPP__ < 2
3211 if (check_executable (XSTRING (absname
)->data
))
3212 st
.st_mode
|= S_IEXEC
;
3213 #endif /* MSDOS && __DJGPP__ < 2 */
3215 return make_number (st
.st_mode
& 07777);
3218 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
3219 "Set mode bits of file named FILENAME to MODE (an integer).\n\
3220 Only the 12 low bits of MODE are used.")
3222 Lisp_Object filename
, mode
;
3224 Lisp_Object absname
, encoded_absname
;
3225 Lisp_Object handler
;
3227 absname
= Fexpand_file_name (filename
, current_buffer
->directory
);
3228 CHECK_NUMBER (mode
, 1);
3230 /* If the file name has special constructs in it,
3231 call the corresponding file handler. */
3232 handler
= Ffind_file_name_handler (absname
, Qset_file_modes
);
3233 if (!NILP (handler
))
3234 return call3 (handler
, Qset_file_modes
, absname
, mode
);
3236 encoded_absname
= ENCODE_FILE (absname
);
3238 if (chmod (XSTRING (encoded_absname
)->data
, XINT (mode
)) < 0)
3239 report_file_error ("Doing chmod", Fcons (absname
, Qnil
));
3244 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
3245 "Set the file permission bits for newly created files.\n\
3246 The argument MODE should be an integer; only the low 9 bits are used.\n\
3247 This setting is inherited by subprocesses.")
3251 CHECK_NUMBER (mode
, 0);
3253 umask ((~ XINT (mode
)) & 0777);
3258 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
3259 "Return the default file protection for created files.\n\
3260 The value is an integer.")
3266 realmask
= umask (0);
3269 XSETINT (value
, (~ realmask
) & 0777);
3279 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
3280 "Tell Unix to finish all pending disk updates.")
3289 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
3290 "Return t if file FILE1 is newer than file FILE2.\n\
3291 If FILE1 does not exist, the answer is nil;\n\
3292 otherwise, if FILE2 does not exist, the answer is t.")
3294 Lisp_Object file1
, file2
;
3296 Lisp_Object absname1
, absname2
;
3299 Lisp_Object handler
;
3300 struct gcpro gcpro1
, gcpro2
;
3302 CHECK_STRING (file1
, 0);
3303 CHECK_STRING (file2
, 0);
3306 GCPRO2 (absname1
, file2
);
3307 absname1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
3308 absname2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
3311 /* If the file name has special constructs in it,
3312 call the corresponding file handler. */
3313 handler
= Ffind_file_name_handler (absname1
, Qfile_newer_than_file_p
);
3315 handler
= Ffind_file_name_handler (absname2
, Qfile_newer_than_file_p
);
3316 if (!NILP (handler
))
3317 return call3 (handler
, Qfile_newer_than_file_p
, absname1
, absname2
);
3319 GCPRO2 (absname1
, absname2
);
3320 absname1
= ENCODE_FILE (absname1
);
3321 absname2
= ENCODE_FILE (absname2
);
3324 if (stat (XSTRING (absname1
)->data
, &st
) < 0)
3327 mtime1
= st
.st_mtime
;
3329 if (stat (XSTRING (absname2
)->data
, &st
) < 0)
3332 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
3336 Lisp_Object Qfind_buffer_file_type
;
3339 #ifndef READ_BUF_SIZE
3340 #define READ_BUF_SIZE (64 << 10)
3343 extern void adjust_markers_for_delete
P_ ((int, int, int, int));
3345 /* This function is called after Lisp functions to decide a coding
3346 system are called, or when they cause an error. Before they are
3347 called, the current buffer is set unibyte and it contains only a
3348 newly inserted text (thus the buffer was empty before the
3351 The functions may set markers, overlays, text properties, or even
3352 alter the buffer contents, change the current buffer.
3354 Here, we reset all those changes by:
3355 o set back the current buffer.
3356 o move all markers and overlays to BEG.
3357 o remove all text properties.
3358 o set back the buffer multibyteness. */
3361 decide_coding_unwind (unwind_data
)
3362 Lisp_Object unwind_data
;
3364 Lisp_Object multibyte
, undo_list
, buffer
;
3366 multibyte
= XCAR (unwind_data
);
3367 unwind_data
= XCDR (unwind_data
);
3368 undo_list
= XCAR (unwind_data
);
3369 buffer
= XCDR (unwind_data
);
3371 if (current_buffer
!= XBUFFER (buffer
))
3372 set_buffer_internal (XBUFFER (buffer
));
3373 adjust_markers_for_delete (BEG
, BEG_BYTE
, Z
, Z_BYTE
);
3374 adjust_overlays_for_delete (BEG
, Z
- BEG
);
3375 BUF_INTERVALS (current_buffer
) = 0;
3376 TEMP_SET_PT_BOTH (BEG
, BEG_BYTE
);
3378 /* Now we are safe to change the buffer's multibyteness directly. */
3379 current_buffer
->enable_multibyte_characters
= multibyte
;
3380 current_buffer
->undo_list
= undo_list
;
3385 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
3387 "Insert contents of file FILENAME after point.\n\
3388 Returns list of absolute file name and number of bytes inserted.\n\
3389 If second argument VISIT is non-nil, the buffer's visited filename\n\
3390 and last save file modtime are set, and it is marked unmodified.\n\
3391 If visiting and the file does not exist, visiting is completed\n\
3392 before the error is signaled.\n\
3393 The optional third and fourth arguments BEG and END\n\
3394 specify what portion of the file to insert.\n\
3395 These arguments count bytes in the file, not characters in the buffer.\n\
3396 If VISIT is non-nil, BEG and END must be nil.\n\
3398 If optional fifth argument REPLACE is non-nil,\n\
3399 it means replace the current buffer contents (in the accessible portion)\n\
3400 with the file contents. This is better than simply deleting and inserting\n\
3401 the whole thing because (1) it preserves some marker positions\n\
3402 and (2) it puts less data in the undo list.\n\
3403 When REPLACE is non-nil, the value is the number of characters actually read,\n\
3404 which is often less than the number of characters to be read.\n\
3406 This does code conversion according to the value of\n\
3407 `coding-system-for-read' or `file-coding-system-alist',\n\
3408 and sets the variable `last-coding-system-used' to the coding system\n\
3410 (filename
, visit
, beg
, end
, replace
)
3411 Lisp_Object filename
, visit
, beg
, end
, replace
;
3416 register int how_much
;
3417 register int unprocessed
;
3418 int count
= specpdl_ptr
- specpdl
;
3419 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3420 Lisp_Object handler
, val
, insval
, orig_filename
;
3423 int not_regular
= 0;
3424 unsigned char read_buf
[READ_BUF_SIZE
];
3425 struct coding_system coding
;
3426 unsigned char buffer
[1 << 14];
3427 int replace_handled
= 0;
3428 int set_coding_system
= 0;
3429 int coding_system_decided
= 0;
3431 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3432 error ("Cannot do file visiting in an indirect buffer");
3434 if (!NILP (current_buffer
->read_only
))
3435 Fbarf_if_buffer_read_only ();
3439 orig_filename
= Qnil
;
3441 GCPRO4 (filename
, val
, p
, orig_filename
);
3443 CHECK_STRING (filename
, 0);
3444 filename
= Fexpand_file_name (filename
, Qnil
);
3446 /* If the file name has special constructs in it,
3447 call the corresponding file handler. */
3448 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
3449 if (!NILP (handler
))
3451 val
= call6 (handler
, Qinsert_file_contents
, filename
,
3452 visit
, beg
, end
, replace
);
3453 if (CONSP (val
) && CONSP (XCDR (val
)))
3454 inserted
= XINT (XCAR (XCDR (val
)));
3458 orig_filename
= filename
;
3459 filename
= ENCODE_FILE (filename
);
3465 Lisp_Object tem
= Vw32_get_true_file_attributes
;
3467 /* Tell stat to use expensive method to get accurate info. */
3468 Vw32_get_true_file_attributes
= Qt
;
3469 total
= stat (XSTRING (filename
)->data
, &st
);
3470 Vw32_get_true_file_attributes
= tem
;
3475 if (stat (XSTRING (filename
)->data
, &st
) < 0)
3477 if ((fd
= emacs_open (XSTRING (filename
)->data
, O_RDONLY
, 0)) < 0
3478 || fstat (fd
, &st
) < 0)
3479 #endif /* not APOLLO */
3480 #endif /* WINDOWSNT */
3482 if (fd
>= 0) emacs_close (fd
);
3485 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3488 if (!NILP (Vcoding_system_for_read
))
3489 Fset (Qbuffer_file_coding_system
, Vcoding_system_for_read
);
3494 /* This code will need to be changed in order to work on named
3495 pipes, and it's probably just not worth it. So we should at
3496 least signal an error. */
3497 if (!S_ISREG (st
.st_mode
))
3504 if (! NILP (replace
) || ! NILP (beg
) || ! NILP (end
))
3505 Fsignal (Qfile_error
,
3506 Fcons (build_string ("not a regular file"),
3507 Fcons (orig_filename
, Qnil
)));
3512 if ((fd
= emacs_open (XSTRING (filename
)->data
, O_RDONLY
, 0)) < 0)
3515 /* Replacement should preserve point as it preserves markers. */
3516 if (!NILP (replace
))
3517 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
3519 record_unwind_protect (close_file_unwind
, make_number (fd
));
3521 /* Supposedly happens on VMS. */
3522 if (! not_regular
&& st
.st_size
< 0)
3523 error ("File size is negative");
3525 /* Prevent redisplay optimizations. */
3526 current_buffer
->clip_changed
= 1;
3530 if (!NILP (beg
) || !NILP (end
))
3531 error ("Attempt to visit less than an entire file");
3532 if (BEG
< Z
&& NILP (replace
))
3533 error ("Cannot do file visiting in a non-empty buffer");
3537 CHECK_NUMBER (beg
, 0);
3539 XSETFASTINT (beg
, 0);
3542 CHECK_NUMBER (end
, 0);
3547 XSETINT (end
, st
.st_size
);
3549 /* Arithmetic overflow can occur if an Emacs integer cannot
3550 represent the file size, or if the calculations below
3551 overflow. The calculations below double the file size
3552 twice, so check that it can be multiplied by 4 safely. */
3553 if (XINT (end
) != st
.st_size
3554 || ((int) st
.st_size
* 4) / 4 != st
.st_size
)
3555 error ("Maximum buffer size exceeded");
3561 /* Decide the coding system to use for reading the file now
3562 because we can't use an optimized method for handling
3563 `coding:' tag if the current buffer is not empty. */
3567 if (!NILP (Vcoding_system_for_read
))
3568 val
= Vcoding_system_for_read
;
3569 else if (! NILP (replace
))
3570 /* In REPLACE mode, we can use the same coding system
3571 that was used to visit the file. */
3572 val
= current_buffer
->buffer_file_coding_system
;
3575 /* Don't try looking inside a file for a coding system
3576 specification if it is not seekable. */
3577 if (! not_regular
&& ! NILP (Vset_auto_coding_function
))
3579 /* Find a coding system specified in the heading two
3580 lines or in the tailing several lines of the file.
3581 We assume that the 1K-byte and 3K-byte for heading
3582 and tailing respectively are sufficient for this
3586 if (st
.st_size
<= (1024 * 4))
3587 nread
= emacs_read (fd
, read_buf
, 1024 * 4);
3590 nread
= emacs_read (fd
, read_buf
, 1024);
3593 if (lseek (fd
, st
.st_size
- (1024 * 3), 0) < 0)
3594 report_file_error ("Setting file position",
3595 Fcons (orig_filename
, Qnil
));
3596 nread
+= emacs_read (fd
, read_buf
+ nread
, 1024 * 3);
3601 error ("IO error reading %s: %s",
3602 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3605 struct buffer
*prev
= current_buffer
;
3608 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
3610 /* The call to temp_output_buffer_setup binds
3612 count1
= specpdl_ptr
- specpdl
;
3613 temp_output_buffer_setup (" *code-converting-work*");
3615 set_buffer_internal (XBUFFER (Vstandard_output
));
3616 current_buffer
->enable_multibyte_characters
= Qnil
;
3617 insert_1_both (read_buf
, nread
, nread
, 0, 0, 0);
3618 TEMP_SET_PT_BOTH (BEG
, BEG_BYTE
);
3619 val
= call2 (Vset_auto_coding_function
,
3620 filename
, make_number (nread
));
3621 set_buffer_internal (prev
);
3623 /* Remove the binding for standard-output. */
3624 unbind_to (count1
, Qnil
);
3626 /* Discard the unwind protect for recovering the
3630 /* Rewind the file for the actual read done later. */
3631 if (lseek (fd
, 0, 0) < 0)
3632 report_file_error ("Setting file position",
3633 Fcons (orig_filename
, Qnil
));
3639 /* If we have not yet decided a coding system, check
3640 file-coding-system-alist. */
3641 Lisp_Object args
[6], coding_systems
;
3643 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
;
3644 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = replace
;
3645 coding_systems
= Ffind_operation_coding_system (6, args
);
3646 if (CONSP (coding_systems
))
3647 val
= XCAR (coding_systems
);
3651 setup_coding_system (Fcheck_coding_system (val
), &coding
);
3652 /* Ensure we set Vlast_coding_system_used. */
3653 set_coding_system
= 1;
3655 if (NILP (current_buffer
->enable_multibyte_characters
)
3657 /* We must suppress all character code conversion except for
3658 end-of-line conversion. */
3659 setup_raw_text_coding_system (&coding
);
3661 coding
.src_multibyte
= 0;
3662 coding
.dst_multibyte
3663 = !NILP (current_buffer
->enable_multibyte_characters
);
3664 coding_system_decided
= 1;
3667 /* If requested, replace the accessible part of the buffer
3668 with the file contents. Avoid replacing text at the
3669 beginning or end of the buffer that matches the file contents;
3670 that preserves markers pointing to the unchanged parts.
3672 Here we implement this feature in an optimized way
3673 for the case where code conversion is NOT needed.
3674 The following if-statement handles the case of conversion
3675 in a less optimal way.
3677 If the code conversion is "automatic" then we try using this
3678 method and hope for the best.
3679 But if we discover the need for conversion, we give up on this method
3680 and let the following if-statement handle the replace job. */
3683 && !(coding
.common_flags
& CODING_REQUIRE_DECODING_MASK
))
3685 /* same_at_start and same_at_end count bytes,
3686 because file access counts bytes
3687 and BEG and END count bytes. */
3688 int same_at_start
= BEGV_BYTE
;
3689 int same_at_end
= ZV_BYTE
;
3691 /* There is still a possibility we will find the need to do code
3692 conversion. If that happens, we set this variable to 1 to
3693 give up on handling REPLACE in the optimized way. */
3694 int giveup_match_end
= 0;
3696 if (XINT (beg
) != 0)
3698 if (lseek (fd
, XINT (beg
), 0) < 0)
3699 report_file_error ("Setting file position",
3700 Fcons (orig_filename
, Qnil
));
3705 /* Count how many chars at the start of the file
3706 match the text at the beginning of the buffer. */
3711 nread
= emacs_read (fd
, buffer
, sizeof buffer
);
3713 error ("IO error reading %s: %s",
3714 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3715 else if (nread
== 0)
3718 if (coding
.type
== coding_type_undecided
)
3719 detect_coding (&coding
, buffer
, nread
);
3720 if (coding
.common_flags
& CODING_REQUIRE_DECODING_MASK
)
3721 /* We found that the file should be decoded somehow.
3722 Let's give up here. */
3724 giveup_match_end
= 1;
3728 if (coding
.eol_type
== CODING_EOL_UNDECIDED
)
3729 detect_eol (&coding
, buffer
, nread
);
3730 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3731 && coding
.eol_type
!= CODING_EOL_LF
)
3732 /* We found that the format of eol should be decoded.
3733 Let's give up here. */
3735 giveup_match_end
= 1;
3740 while (bufpos
< nread
&& same_at_start
< ZV_BYTE
3741 && FETCH_BYTE (same_at_start
) == buffer
[bufpos
])
3742 same_at_start
++, bufpos
++;
3743 /* If we found a discrepancy, stop the scan.
3744 Otherwise loop around and scan the next bufferful. */
3745 if (bufpos
!= nread
)
3749 /* If the file matches the buffer completely,
3750 there's no need to replace anything. */
3751 if (same_at_start
- BEGV_BYTE
== XINT (end
))
3755 /* Truncate the buffer to the size of the file. */
3756 del_range_1 (same_at_start
, same_at_end
, 0, 0);
3761 /* Count how many chars at the end of the file
3762 match the text at the end of the buffer. But, if we have
3763 already found that decoding is necessary, don't waste time. */
3764 while (!giveup_match_end
)
3766 int total_read
, nread
, bufpos
, curpos
, trial
;
3768 /* At what file position are we now scanning? */
3769 curpos
= XINT (end
) - (ZV_BYTE
- same_at_end
);
3770 /* If the entire file matches the buffer tail, stop the scan. */
3773 /* How much can we scan in the next step? */
3774 trial
= min (curpos
, sizeof buffer
);
3775 if (lseek (fd
, curpos
- trial
, 0) < 0)
3776 report_file_error ("Setting file position",
3777 Fcons (orig_filename
, Qnil
));
3780 while (total_read
< trial
)
3782 nread
= emacs_read (fd
, buffer
+ total_read
, trial
- total_read
);
3784 error ("IO error reading %s: %s",
3785 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3786 total_read
+= nread
;
3788 /* Scan this bufferful from the end, comparing with
3789 the Emacs buffer. */
3790 bufpos
= total_read
;
3791 /* Compare with same_at_start to avoid counting some buffer text
3792 as matching both at the file's beginning and at the end. */
3793 while (bufpos
> 0 && same_at_end
> same_at_start
3794 && FETCH_BYTE (same_at_end
- 1) == buffer
[bufpos
- 1])
3795 same_at_end
--, bufpos
--;
3797 /* If we found a discrepancy, stop the scan.
3798 Otherwise loop around and scan the preceding bufferful. */
3801 /* If this discrepancy is because of code conversion,
3802 we cannot use this method; giveup and try the other. */
3803 if (same_at_end
> same_at_start
3804 && FETCH_BYTE (same_at_end
- 1) >= 0200
3805 && ! NILP (current_buffer
->enable_multibyte_characters
)
3806 && (CODING_MAY_REQUIRE_DECODING (&coding
)))
3807 giveup_match_end
= 1;
3813 if (! giveup_match_end
)
3817 /* We win! We can handle REPLACE the optimized way. */
3819 /* Extend the start of non-matching text area to multibyte
3820 character boundary. */
3821 if (! NILP (current_buffer
->enable_multibyte_characters
))
3822 while (same_at_start
> BEGV_BYTE
3823 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start
)))
3826 /* Extend the end of non-matching text area to multibyte
3827 character boundary. */
3828 if (! NILP (current_buffer
->enable_multibyte_characters
))
3829 while (same_at_end
< ZV_BYTE
3830 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
3833 /* Don't try to reuse the same piece of text twice. */
3834 overlap
= (same_at_start
- BEGV_BYTE
3835 - (same_at_end
+ st
.st_size
- ZV
));
3837 same_at_end
+= overlap
;
3839 /* Arrange to read only the nonmatching middle part of the file. */
3840 XSETFASTINT (beg
, XINT (beg
) + (same_at_start
- BEGV_BYTE
));
3841 XSETFASTINT (end
, XINT (end
) - (ZV_BYTE
- same_at_end
));
3843 del_range_byte (same_at_start
, same_at_end
, 0);
3844 /* Insert from the file at the proper position. */
3845 temp
= BYTE_TO_CHAR (same_at_start
);
3846 SET_PT_BOTH (temp
, same_at_start
);
3848 /* If display currently starts at beginning of line,
3849 keep it that way. */
3850 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3851 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3853 replace_handled
= 1;
3857 /* If requested, replace the accessible part of the buffer
3858 with the file contents. Avoid replacing text at the
3859 beginning or end of the buffer that matches the file contents;
3860 that preserves markers pointing to the unchanged parts.
3862 Here we implement this feature for the case where code conversion
3863 is needed, in a simple way that needs a lot of memory.
3864 The preceding if-statement handles the case of no conversion
3865 in a more optimized way. */
3866 if (!NILP (replace
) && ! replace_handled
&& BEGV
< ZV
)
3868 int same_at_start
= BEGV_BYTE
;
3869 int same_at_end
= ZV_BYTE
;
3872 /* Make sure that the gap is large enough. */
3873 int bufsize
= 2 * st
.st_size
;
3874 unsigned char *conversion_buffer
= (unsigned char *) xmalloc (bufsize
);
3877 /* First read the whole file, performing code conversion into
3878 CONVERSION_BUFFER. */
3880 if (lseek (fd
, XINT (beg
), 0) < 0)
3882 xfree (conversion_buffer
);
3883 report_file_error ("Setting file position",
3884 Fcons (orig_filename
, Qnil
));
3887 total
= st
.st_size
; /* Total bytes in the file. */
3888 how_much
= 0; /* Bytes read from file so far. */
3889 inserted
= 0; /* Bytes put into CONVERSION_BUFFER so far. */
3890 unprocessed
= 0; /* Bytes not processed in previous loop. */
3892 while (how_much
< total
)
3894 /* try is reserved in some compilers (Microsoft C) */
3895 int trytry
= min (total
- how_much
, READ_BUF_SIZE
- unprocessed
);
3896 unsigned char *destination
= read_buf
+ unprocessed
;
3899 /* Allow quitting out of the actual I/O. */
3902 this = emacs_read (fd
, destination
, trytry
);
3905 if (this < 0 || this + unprocessed
== 0)
3913 if (CODING_MAY_REQUIRE_DECODING (&coding
))
3915 int require
, result
;
3917 this += unprocessed
;
3919 /* If we are using more space than estimated,
3920 make CONVERSION_BUFFER bigger. */
3921 require
= decoding_buffer_size (&coding
, this);
3922 if (inserted
+ require
+ 2 * (total
- how_much
) > bufsize
)
3924 bufsize
= inserted
+ require
+ 2 * (total
- how_much
);
3925 conversion_buffer
= (unsigned char *) xrealloc (conversion_buffer
, bufsize
);
3928 /* Convert this batch with results in CONVERSION_BUFFER. */
3929 if (how_much
>= total
) /* This is the last block. */
3930 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
3931 result
= decode_coding (&coding
, read_buf
,
3932 conversion_buffer
+ inserted
,
3933 this, bufsize
- inserted
);
3935 /* Save for next iteration whatever we didn't convert. */
3936 unprocessed
= this - coding
.consumed
;
3937 bcopy (read_buf
+ coding
.consumed
, read_buf
, unprocessed
);
3938 if (!NILP (current_buffer
->enable_multibyte_characters
))
3939 this = coding
.produced
;
3941 this = str_as_unibyte (conversion_buffer
+ inserted
,
3948 /* At this point, INSERTED is how many characters (i.e. bytes)
3949 are present in CONVERSION_BUFFER.
3950 HOW_MUCH should equal TOTAL,
3951 or should be <= 0 if we couldn't read the file. */
3955 xfree (conversion_buffer
);
3958 error ("IO error reading %s: %s",
3959 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3960 else if (how_much
== -2)
3961 error ("maximum buffer size exceeded");
3964 /* Compare the beginning of the converted file
3965 with the buffer text. */
3968 while (bufpos
< inserted
&& same_at_start
< same_at_end
3969 && FETCH_BYTE (same_at_start
) == conversion_buffer
[bufpos
])
3970 same_at_start
++, bufpos
++;
3972 /* If the file matches the buffer completely,
3973 there's no need to replace anything. */
3975 if (bufpos
== inserted
)
3977 xfree (conversion_buffer
);
3980 /* Truncate the buffer to the size of the file. */
3981 del_range_byte (same_at_start
, same_at_end
, 0);
3986 /* Extend the start of non-matching text area to multibyte
3987 character boundary. */
3988 if (! NILP (current_buffer
->enable_multibyte_characters
))
3989 while (same_at_start
> BEGV_BYTE
3990 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start
)))
3993 /* Scan this bufferful from the end, comparing with
3994 the Emacs buffer. */
3997 /* Compare with same_at_start to avoid counting some buffer text
3998 as matching both at the file's beginning and at the end. */
3999 while (bufpos
> 0 && same_at_end
> same_at_start
4000 && FETCH_BYTE (same_at_end
- 1) == conversion_buffer
[bufpos
- 1])
4001 same_at_end
--, bufpos
--;
4003 /* Extend the end of non-matching text area to multibyte
4004 character boundary. */
4005 if (! NILP (current_buffer
->enable_multibyte_characters
))
4006 while (same_at_end
< ZV_BYTE
4007 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
4010 /* Don't try to reuse the same piece of text twice. */
4011 overlap
= same_at_start
- BEGV_BYTE
- (same_at_end
+ inserted
- ZV_BYTE
);
4013 same_at_end
+= overlap
;
4015 /* If display currently starts at beginning of line,
4016 keep it that way. */
4017 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
4018 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
4020 /* Replace the chars that we need to replace,
4021 and update INSERTED to equal the number of bytes
4022 we are taking from the file. */
4023 inserted
-= (Z_BYTE
- same_at_end
) + (same_at_start
- BEG_BYTE
);
4025 if (same_at_end
!= same_at_start
)
4027 del_range_byte (same_at_start
, same_at_end
, 0);
4029 same_at_start
= GPT_BYTE
;
4033 temp
= BYTE_TO_CHAR (same_at_start
);
4035 /* Insert from the file at the proper position. */
4036 SET_PT_BOTH (temp
, same_at_start
);
4037 insert_1 (conversion_buffer
+ same_at_start
- BEG_BYTE
, inserted
,
4039 /* Set `inserted' to the number of inserted characters. */
4040 inserted
= PT
- temp
;
4042 xfree (conversion_buffer
);
4051 register Lisp_Object temp
;
4053 total
= XINT (end
) - XINT (beg
);
4055 /* Make sure point-max won't overflow after this insertion. */
4056 XSETINT (temp
, total
);
4057 if (total
!= XINT (temp
))
4058 error ("Maximum buffer size exceeded");
4061 /* For a special file, all we can do is guess. */
4062 total
= READ_BUF_SIZE
;
4064 if (NILP (visit
) && total
> 0)
4065 prepare_to_modify_buffer (PT
, PT
, NULL
);
4068 if (GAP_SIZE
< total
)
4069 make_gap (total
- GAP_SIZE
);
4071 if (XINT (beg
) != 0 || !NILP (replace
))
4073 if (lseek (fd
, XINT (beg
), 0) < 0)
4074 report_file_error ("Setting file position",
4075 Fcons (orig_filename
, Qnil
));
4078 /* In the following loop, HOW_MUCH contains the total bytes read so
4079 far for a regular file, and not changed for a special file. But,
4080 before exiting the loop, it is set to a negative value if I/O
4083 /* Total bytes inserted. */
4085 /* Here, we don't do code conversion in the loop. It is done by
4086 code_convert_region after all data are read into the buffer. */
4087 while (how_much
< total
)
4089 /* try is reserved in some compilers (Microsoft C) */
4090 int trytry
= min (total
- how_much
, READ_BUF_SIZE
);
4093 /* For a special file, GAP_SIZE should be checked every time. */
4094 if (not_regular
&& GAP_SIZE
< trytry
)
4095 make_gap (total
- GAP_SIZE
);
4097 /* Allow quitting out of the actual I/O. */
4100 this = emacs_read (fd
, BYTE_POS_ADDR (PT_BYTE
+ inserted
- 1) + 1,
4118 /* For a regular file, where TOTAL is the real size,
4119 count HOW_MUCH to compare with it.
4120 For a special file, where TOTAL is just a buffer size,
4121 so don't bother counting in HOW_MUCH.
4122 (INSERTED is where we count the number of characters inserted.) */
4129 /* Put an anchor to ensure multi-byte form ends at gap. */
4134 /* Discard the unwind protect for closing the file. */
4138 error ("IO error reading %s: %s",
4139 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
4143 if (! coding_system_decided
)
4145 /* The coding system is not yet decided. Decide it by an
4146 optimized method for handling `coding:' tag.
4148 Note that we can get here only if the buffer was empty
4149 before the insertion. */
4153 if (!NILP (Vcoding_system_for_read
))
4154 val
= Vcoding_system_for_read
;
4157 /* Since we are sure that the current buffer was empty
4158 before the insertion, we can toggle
4159 enable-multibyte-characters directly here without taking
4160 care of marker adjustment and byte combining problem. By
4161 this way, we can run Lisp program safely before decoding
4162 the inserted text. */
4163 Lisp_Object unwind_data
;
4164 int count
= specpdl_ptr
- specpdl
;
4166 unwind_data
= Fcons (current_buffer
->enable_multibyte_characters
,
4167 Fcons (current_buffer
->undo_list
,
4168 Fcurrent_buffer ()));
4169 current_buffer
->enable_multibyte_characters
= Qnil
;
4170 current_buffer
->undo_list
= Qt
;
4171 record_unwind_protect (decide_coding_unwind
, unwind_data
);
4173 if (inserted
> 0 && ! NILP (Vset_auto_coding_function
))
4175 val
= call2 (Vset_auto_coding_function
,
4176 filename
, make_number (inserted
));
4181 /* If the coding system is not yet decided, check
4182 file-coding-system-alist. */
4183 Lisp_Object args
[6], coding_systems
;
4185 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
;
4186 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = Qnil
;
4187 coding_systems
= Ffind_operation_coding_system (6, args
);
4188 if (CONSP (coding_systems
))
4189 val
= XCAR (coding_systems
);
4192 unbind_to (count
, Qnil
);
4193 inserted
= Z_BYTE
- BEG_BYTE
;
4196 /* The following kludgy code is to avoid some compiler bug.
4198 setup_coding_system (val, &coding);
4201 struct coding_system temp_coding
;
4202 setup_coding_system (val
, &temp_coding
);
4203 bcopy (&temp_coding
, &coding
, sizeof coding
);
4205 /* Ensure we set Vlast_coding_system_used. */
4206 set_coding_system
= 1;
4208 if (NILP (current_buffer
->enable_multibyte_characters
)
4210 /* We must suppress all character code conversion except for
4211 end-of-line conversion. */
4212 setup_raw_text_coding_system (&coding
);
4213 coding
.src_multibyte
= 0;
4214 coding
.dst_multibyte
4215 = !NILP (current_buffer
->enable_multibyte_characters
);
4219 && (coding
.type
== coding_type_no_conversion
4220 || coding
.type
== coding_type_raw_text
))
4222 /* Visiting a file with these coding system always make the buffer
4224 current_buffer
->enable_multibyte_characters
= Qnil
;
4225 coding
.dst_multibyte
= 0;
4228 if (inserted
> 0 || coding
.type
== coding_type_ccl
)
4230 if (CODING_MAY_REQUIRE_DECODING (&coding
))
4232 code_convert_region (PT
, PT_BYTE
, PT
+ inserted
, PT_BYTE
+ inserted
,
4234 inserted
= coding
.produced_char
;
4237 adjust_after_insert (PT
, PT_BYTE
, PT
+ inserted
, PT_BYTE
+ inserted
,
4242 /* Use the conversion type to determine buffer-file-type
4243 (find-buffer-file-type is now used to help determine the
4245 if ((coding
.eol_type
== CODING_EOL_UNDECIDED
4246 || coding
.eol_type
== CODING_EOL_LF
)
4247 && ! CODING_REQUIRE_DECODING (&coding
))
4248 current_buffer
->buffer_file_type
= Qt
;
4250 current_buffer
->buffer_file_type
= Qnil
;
4257 if (!EQ (current_buffer
->undo_list
, Qt
))
4258 current_buffer
->undo_list
= Qnil
;
4260 stat (XSTRING (filename
)->data
, &st
);
4265 current_buffer
->modtime
= st
.st_mtime
;
4266 current_buffer
->filename
= orig_filename
;
4269 SAVE_MODIFF
= MODIFF
;
4270 current_buffer
->auto_save_modified
= MODIFF
;
4271 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4272 #ifdef CLASH_DETECTION
4275 if (!NILP (current_buffer
->file_truename
))
4276 unlock_file (current_buffer
->file_truename
);
4277 unlock_file (filename
);
4279 #endif /* CLASH_DETECTION */
4281 Fsignal (Qfile_error
,
4282 Fcons (build_string ("not a regular file"),
4283 Fcons (orig_filename
, Qnil
)));
4286 /* Decode file format */
4289 insval
= call3 (Qformat_decode
,
4290 Qnil
, make_number (inserted
), visit
);
4291 CHECK_NUMBER (insval
, 0);
4292 inserted
= XFASTINT (insval
);
4295 if (set_coding_system
)
4296 Vlast_coding_system_used
= coding
.symbol
;
4298 /* Call after-change hooks for the inserted text, aside from the case
4299 of normal visiting (not with REPLACE), which is done in a new buffer
4300 "before" the buffer is changed. */
4301 if (inserted
> 0 && total
> 0
4302 && (NILP (visit
) || !NILP (replace
)))
4304 signal_after_change (PT
, 0, inserted
);
4305 update_compositions (PT
, PT
, CHECK_BORDER
);
4308 p
= Vafter_insert_file_functions
;
4311 insval
= call1 (Fcar (p
), make_number (inserted
));
4314 CHECK_NUMBER (insval
, 0);
4315 inserted
= XFASTINT (insval
);
4322 && current_buffer
->modtime
== -1)
4324 /* If visiting nonexistent file, return nil. */
4325 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
4328 /* ??? Retval needs to be dealt with in all cases consistently. */
4330 val
= Fcons (orig_filename
,
4331 Fcons (make_number (inserted
),
4334 RETURN_UNGCPRO (unbind_to (count
, val
));
4337 static Lisp_Object build_annotations
P_ ((Lisp_Object
, Lisp_Object
,
4340 /* If build_annotations switched buffers, switch back to BUF.
4341 Kill the temporary buffer that was selected in the meantime.
4343 Since this kill only the last temporary buffer, some buffers remain
4344 not killed if build_annotations switched buffers more than once.
4348 build_annotations_unwind (buf
)
4353 if (XBUFFER (buf
) == current_buffer
)
4355 tembuf
= Fcurrent_buffer ();
4357 Fkill_buffer (tembuf
);
4361 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 7,
4362 "r\nFWrite region to file: \ni\ni\ni\np",
4363 "Write current region into specified file.\n\
4364 When called from a program, takes three arguments:\n\
4365 START, END and FILENAME. START and END are buffer positions.\n\
4366 Optional fourth argument APPEND if non-nil means\n\
4367 append to existing file contents (if any). If it is an integer,\n\
4368 seek to that offset in the file before writing.\n\
4369 Optional fifth argument VISIT if t means\n\
4370 set the last-save-file-modtime of buffer to this file's modtime\n\
4371 and mark buffer not modified.\n\
4372 If VISIT is a string, it is a second file name;\n\
4373 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
4374 VISIT is also the file name to lock and unlock for clash detection.\n\
4375 If VISIT is neither t nor nil nor a string,\n\
4376 that means do not print the \"Wrote file\" message.\n\
4377 The optional sixth arg LOCKNAME, if non-nil, specifies the name to\n\
4378 use for locking and unlocking, overriding FILENAME and VISIT.\n\
4379 The optional seventh arg MUSTBENEW, if non-nil, insists on a check\n\
4380 for an existing file with the same name. If MUSTBENEW is `excl',\n\
4381 that means to get an error if the file already exists; never overwrite.\n\
4382 If MUSTBENEW is neither nil nor `excl', that means ask for\n\
4383 confirmation before overwriting, but do go ahead and overwrite the file\n\
4384 if the user confirms.\n\
4385 Kludgy feature: if START is a string, then that string is written\n\
4386 to the file, instead of any buffer contents, and END is ignored.\n\
4388 This does code conversion according to the value of\n\
4389 `coding-system-for-write', `buffer-file-coding-system', or\n\
4390 `file-coding-system-alist', and sets the variable\n\
4391 `last-coding-system-used' to the coding system actually used.")
4393 (start
, end
, filename
, append
, visit
, lockname
, mustbenew
)
4394 Lisp_Object start
, end
, filename
, append
, visit
, lockname
, mustbenew
;
4402 int count
= specpdl_ptr
- specpdl
;
4405 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
4407 Lisp_Object handler
;
4408 Lisp_Object visit_file
;
4409 Lisp_Object annotations
;
4410 Lisp_Object encoded_filename
;
4411 int visiting
, quietly
;
4412 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
4413 struct buffer
*given_buffer
;
4415 int buffer_file_type
= O_BINARY
;
4417 struct coding_system coding
;
4419 if (current_buffer
->base_buffer
&& ! NILP (visit
))
4420 error ("Cannot do file visiting in an indirect buffer");
4422 if (!NILP (start
) && !STRINGP (start
))
4423 validate_region (&start
, &end
);
4425 GCPRO4 (start
, filename
, visit
, lockname
);
4427 /* Decide the coding-system to encode the data with. */
4433 else if (!NILP (Vcoding_system_for_write
))
4434 val
= Vcoding_system_for_write
;
4437 /* If the variable `buffer-file-coding-system' is set locally,
4438 it means that the file was read with some kind of code
4439 conversion or the varialbe is explicitely set by users. We
4440 had better write it out with the same coding system even if
4441 `enable-multibyte-characters' is nil.
4443 If it is not set locally, we anyway have to convert EOL
4444 format if the default value of `buffer-file-coding-system'
4445 tells that it is not Unix-like (LF only) format. */
4446 int using_default_coding
= 0;
4447 int force_raw_text
= 0;
4449 val
= current_buffer
->buffer_file_coding_system
;
4451 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4454 if (NILP (current_buffer
->enable_multibyte_characters
))
4460 /* Check file-coding-system-alist. */
4461 Lisp_Object args
[7], coding_systems
;
4463 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4464 args
[3] = filename
; args
[4] = append
; args
[5] = visit
;
4466 coding_systems
= Ffind_operation_coding_system (7, args
);
4467 if (CONSP (coding_systems
) && !NILP (XCDR (coding_systems
)))
4468 val
= XCDR (coding_systems
);
4472 && !NILP (current_buffer
->buffer_file_coding_system
))
4474 /* If we still have not decided a coding system, use the
4475 default value of buffer-file-coding-system. */
4476 val
= current_buffer
->buffer_file_coding_system
;
4477 using_default_coding
= 1;
4481 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4482 /* Confirm that VAL can surely encode the current region. */
4483 val
= call3 (Vselect_safe_coding_system_function
, start
, end
, val
);
4485 setup_coding_system (Fcheck_coding_system (val
), &coding
);
4486 if (coding
.eol_type
== CODING_EOL_UNDECIDED
4487 && !using_default_coding
)
4489 if (! EQ (default_buffer_file_coding
.symbol
,
4490 buffer_defaults
.buffer_file_coding_system
))
4491 setup_coding_system (buffer_defaults
.buffer_file_coding_system
,
4492 &default_buffer_file_coding
);
4493 if (default_buffer_file_coding
.eol_type
!= CODING_EOL_UNDECIDED
)
4495 Lisp_Object subsidiaries
;
4497 coding
.eol_type
= default_buffer_file_coding
.eol_type
;
4498 subsidiaries
= Fget (coding
.symbol
, Qeol_type
);
4499 if (VECTORP (subsidiaries
)
4500 && XVECTOR (subsidiaries
)->size
== 3)
4502 = XVECTOR (subsidiaries
)->contents
[coding
.eol_type
];
4507 setup_raw_text_coding_system (&coding
);
4508 goto done_setup_coding
;
4511 setup_coding_system (Fcheck_coding_system (val
), &coding
);
4514 if (!STRINGP (start
) && !NILP (current_buffer
->selective_display
))
4515 coding
.mode
|= CODING_MODE_SELECTIVE_DISPLAY
;
4518 Vlast_coding_system_used
= coding
.symbol
;
4520 filename
= Fexpand_file_name (filename
, Qnil
);
4522 if (! NILP (mustbenew
) && !EQ (mustbenew
, Qexcl
))
4523 barf_or_query_if_file_exists (filename
, "overwrite", 1, 0, 1);
4525 if (STRINGP (visit
))
4526 visit_file
= Fexpand_file_name (visit
, Qnil
);
4528 visit_file
= filename
;
4531 visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
4532 quietly
= !NILP (visit
);
4536 if (NILP (lockname
))
4537 lockname
= visit_file
;
4539 GCPRO5 (start
, filename
, annotations
, visit_file
, lockname
);
4541 /* If the file name has special constructs in it,
4542 call the corresponding file handler. */
4543 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
4544 /* If FILENAME has no handler, see if VISIT has one. */
4545 if (NILP (handler
) && STRINGP (visit
))
4546 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
4548 if (!NILP (handler
))
4551 val
= call6 (handler
, Qwrite_region
, start
, end
,
4552 filename
, append
, visit
);
4556 SAVE_MODIFF
= MODIFF
;
4557 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4558 current_buffer
->filename
= visit_file
;
4564 /* Special kludge to simplify auto-saving. */
4567 XSETFASTINT (start
, BEG
);
4568 XSETFASTINT (end
, Z
);
4571 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
4572 count1
= specpdl_ptr
- specpdl
;
4574 given_buffer
= current_buffer
;
4575 annotations
= build_annotations (start
, end
, coding
.pre_write_conversion
);
4576 if (current_buffer
!= given_buffer
)
4578 XSETFASTINT (start
, BEGV
);
4579 XSETFASTINT (end
, ZV
);
4582 #ifdef CLASH_DETECTION
4585 #if 0 /* This causes trouble for GNUS. */
4586 /* If we've locked this file for some other buffer,
4587 query before proceeding. */
4588 if (!visiting
&& EQ (Ffile_locked_p (lockname
), Qt
))
4589 call2 (intern ("ask-user-about-lock"), filename
, Vuser_login_name
);
4592 lock_file (lockname
);
4594 #endif /* CLASH_DETECTION */
4596 encoded_filename
= ENCODE_FILE (filename
);
4598 fn
= XSTRING (encoded_filename
)->data
;
4602 desc
= emacs_open (fn
, O_WRONLY
| buffer_file_type
, 0);
4603 #else /* not DOS_NT */
4604 desc
= emacs_open (fn
, O_WRONLY
, 0);
4605 #endif /* not DOS_NT */
4607 if (desc
< 0 && (NILP (append
) || errno
== ENOENT
))
4609 if (auto_saving
) /* Overwrite any previous version of autosave file */
4611 vms_truncate (fn
); /* if fn exists, truncate to zero length */
4612 desc
= emacs_open (fn
, O_RDWR
, 0);
4614 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
4615 ? XSTRING (current_buffer
->filename
)->data
: 0,
4618 else /* Write to temporary name and rename if no errors */
4620 Lisp_Object temp_name
;
4621 temp_name
= Ffile_name_directory (filename
);
4623 if (!NILP (temp_name
))
4625 temp_name
= Fmake_temp_name (concat2 (temp_name
,
4626 build_string ("$$SAVE$$")));
4627 fname
= XSTRING (filename
)->data
;
4628 fn
= XSTRING (temp_name
)->data
;
4629 desc
= creat_copy_attrs (fname
, fn
);
4632 /* If we can't open the temporary file, try creating a new
4633 version of the original file. VMS "creat" creates a
4634 new version rather than truncating an existing file. */
4637 desc
= creat (fn
, 0666);
4638 #if 0 /* This can clobber an existing file and fail to replace it,
4639 if the user runs out of space. */
4642 /* We can't make a new version;
4643 try to truncate and rewrite existing version if any. */
4645 desc
= emacs_open (fn
, O_RDWR
, 0);
4651 desc
= creat (fn
, 0666);
4655 desc
= emacs_open (fn
,
4656 O_WRONLY
| O_TRUNC
| O_CREAT
| buffer_file_type
4657 | (mustbenew
== Qexcl
? O_EXCL
: 0),
4658 S_IREAD
| S_IWRITE
);
4659 #else /* not DOS_NT */
4660 desc
= emacs_open (fn
, O_WRONLY
| O_TRUNC
| O_CREAT
4661 | (EQ (mustbenew
, Qexcl
) ? O_EXCL
: 0),
4662 auto_saving
? auto_save_mode_bits
: 0666);
4663 #endif /* not DOS_NT */
4664 #endif /* not VMS */
4668 #ifdef CLASH_DETECTION
4670 if (!auto_saving
) unlock_file (lockname
);
4672 #endif /* CLASH_DETECTION */
4674 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
4677 record_unwind_protect (close_file_unwind
, make_number (desc
));
4679 if (!NILP (append
) && !NILP (Ffile_regular_p (filename
)))
4683 if (NUMBERP (append
))
4684 ret
= lseek (desc
, XINT (append
), 1);
4686 ret
= lseek (desc
, 0, 2);
4689 #ifdef CLASH_DETECTION
4690 if (!auto_saving
) unlock_file (lockname
);
4691 #endif /* CLASH_DETECTION */
4693 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
4701 * Kludge Warning: The VMS C RTL likes to insert carriage returns
4702 * if we do writes that don't end with a carriage return. Furthermore
4703 * it cannot handle writes of more then 16K. The modified
4704 * version of "sys_write" in SYSDEP.C (see comment there) copes with
4705 * this EXCEPT for the last record (iff it doesn't end with a carriage
4706 * return). This implies that if your buffer doesn't end with a carriage
4707 * return, you get one free... tough. However it also means that if
4708 * we make two calls to sys_write (a la the following code) you can
4709 * get one at the gap as well. The easiest way to fix this (honest)
4710 * is to move the gap to the next newline (or the end of the buffer).
4715 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4716 move_gap (find_next_newline (GPT
, 1));
4718 /* Whether VMS or not, we must move the gap to the next of newline
4719 when we must put designation sequences at beginning of line. */
4720 if (INTEGERP (start
)
4721 && coding
.type
== coding_type_iso2022
4722 && coding
.flags
& CODING_FLAG_ISO_DESIGNATE_AT_BOL
4723 && GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4725 int opoint
= PT
, opoint_byte
= PT_BYTE
;
4726 scan_newline (PT
, PT_BYTE
, ZV
, ZV_BYTE
, 1, 0);
4727 move_gap_both (PT
, PT_BYTE
);
4728 SET_PT_BOTH (opoint
, opoint_byte
);
4735 if (STRINGP (start
))
4737 failure
= 0 > a_write (desc
, start
, 0, XSTRING (start
)->size
,
4738 &annotations
, &coding
);
4741 else if (XINT (start
) != XINT (end
))
4743 tem
= CHAR_TO_BYTE (XINT (start
));
4745 if (XINT (start
) < GPT
)
4747 failure
= 0 > a_write (desc
, Qnil
, XINT (start
),
4748 min (GPT
, XINT (end
)) - XINT (start
),
4749 &annotations
, &coding
);
4753 if (XINT (end
) > GPT
&& !failure
)
4755 tem
= max (XINT (start
), GPT
);
4756 failure
= 0 > a_write (desc
, Qnil
, tem
, XINT (end
) - tem
,
4757 &annotations
, &coding
);
4763 /* If file was empty, still need to write the annotations */
4764 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4765 failure
= 0 > a_write (desc
, Qnil
, XINT (end
), 0, &annotations
, &coding
);
4769 if (CODING_REQUIRE_FLUSHING (&coding
)
4770 && !(coding
.mode
& CODING_MODE_LAST_BLOCK
)
4773 /* We have to flush out a data. */
4774 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4775 failure
= 0 > e_write (desc
, Qnil
, 0, 0, &coding
);
4782 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
4783 Disk full in NFS may be reported here. */
4784 /* mib says that closing the file will try to write as fast as NFS can do
4785 it, and that means the fsync here is not crucial for autosave files. */
4786 if (!auto_saving
&& fsync (desc
) < 0)
4788 /* If fsync fails with EINTR, don't treat that as serious. */
4790 failure
= 1, save_errno
= errno
;
4794 /* Spurious "file has changed on disk" warnings have been
4795 observed on Suns as well.
4796 It seems that `close' can change the modtime, under nfs.
4798 (This has supposedly been fixed in Sunos 4,
4799 but who knows about all the other machines with NFS?) */
4802 /* On VMS and APOLLO, must do the stat after the close
4803 since closing changes the modtime. */
4806 /* Recall that #if defined does not work on VMS. */
4813 /* NFS can report a write failure now. */
4814 if (emacs_close (desc
) < 0)
4815 failure
= 1, save_errno
= errno
;
4818 /* If we wrote to a temporary name and had no errors, rename to real name. */
4822 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
4830 /* Discard the unwind protect for close_file_unwind. */
4831 specpdl_ptr
= specpdl
+ count1
;
4832 /* Restore the original current buffer. */
4833 visit_file
= unbind_to (count
, visit_file
);
4835 #ifdef CLASH_DETECTION
4837 unlock_file (lockname
);
4838 #endif /* CLASH_DETECTION */
4840 /* Do this before reporting IO error
4841 to avoid a "file has changed on disk" warning on
4842 next attempt to save. */
4844 current_buffer
->modtime
= st
.st_mtime
;
4847 error ("IO error writing %s: %s", XSTRING (filename
)->data
,
4848 emacs_strerror (save_errno
));
4852 SAVE_MODIFF
= MODIFF
;
4853 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4854 current_buffer
->filename
= visit_file
;
4855 update_mode_lines
++;
4861 message_with_string ("Wrote %s", visit_file
, 1);
4866 Lisp_Object
merge ();
4868 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
4869 "Return t if (car A) is numerically less than (car B).")
4873 return Flss (Fcar (a
), Fcar (b
));
4876 /* Build the complete list of annotations appropriate for writing out
4877 the text between START and END, by calling all the functions in
4878 write-region-annotate-functions and merging the lists they return.
4879 If one of these functions switches to a different buffer, we assume
4880 that buffer contains altered text. Therefore, the caller must
4881 make sure to restore the current buffer in all cases,
4882 as save-excursion would do. */
4885 build_annotations (start
, end
, pre_write_conversion
)
4886 Lisp_Object start
, end
, pre_write_conversion
;
4888 Lisp_Object annotations
;
4890 struct gcpro gcpro1
, gcpro2
;
4891 Lisp_Object original_buffer
;
4893 XSETBUFFER (original_buffer
, current_buffer
);
4896 p
= Vwrite_region_annotate_functions
;
4897 GCPRO2 (annotations
, p
);
4900 struct buffer
*given_buffer
= current_buffer
;
4901 Vwrite_region_annotations_so_far
= annotations
;
4902 res
= call2 (Fcar (p
), start
, end
);
4903 /* If the function makes a different buffer current,
4904 assume that means this buffer contains altered text to be output.
4905 Reset START and END from the buffer bounds
4906 and discard all previous annotations because they should have
4907 been dealt with by this function. */
4908 if (current_buffer
!= given_buffer
)
4910 XSETFASTINT (start
, BEGV
);
4911 XSETFASTINT (end
, ZV
);
4914 Flength (res
); /* Check basic validity of return value */
4915 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4919 /* Now do the same for annotation functions implied by the file-format */
4920 if (auto_saving
&& (!EQ (Vauto_save_file_format
, Qt
)))
4921 p
= Vauto_save_file_format
;
4923 p
= current_buffer
->file_format
;
4926 struct buffer
*given_buffer
= current_buffer
;
4927 Vwrite_region_annotations_so_far
= annotations
;
4928 res
= call4 (Qformat_annotate_function
, Fcar (p
), start
, end
,
4930 if (current_buffer
!= given_buffer
)
4932 XSETFASTINT (start
, BEGV
);
4933 XSETFASTINT (end
, ZV
);
4937 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4941 /* At last, do the same for the function PRE_WRITE_CONVERSION
4942 implied by the current coding-system. */
4943 if (!NILP (pre_write_conversion
))
4945 struct buffer
*given_buffer
= current_buffer
;
4946 Vwrite_region_annotations_so_far
= annotations
;
4947 res
= call2 (pre_write_conversion
, start
, end
);
4949 annotations
= (current_buffer
!= given_buffer
4951 : merge (annotations
, res
, Qcar_less_than_car
));
4958 /* Write to descriptor DESC the NCHARS chars starting at POS of STRING.
4959 If STRING is nil, POS is the character position in the current buffer.
4960 Intersperse with them the annotations from *ANNOT
4961 which fall within the range of POS to POS + NCHARS,
4962 each at its appropriate position.
4964 We modify *ANNOT by discarding elements as we use them up.
4966 The return value is negative in case of system call failure. */
4969 a_write (desc
, string
, pos
, nchars
, annot
, coding
)
4972 register int nchars
;
4975 struct coding_system
*coding
;
4979 int lastpos
= pos
+ nchars
;
4981 while (NILP (*annot
) || CONSP (*annot
))
4983 tem
= Fcar_safe (Fcar (*annot
));
4986 nextpos
= XFASTINT (tem
);
4988 /* If there are no more annotations in this range,
4989 output the rest of the range all at once. */
4990 if (! (nextpos
>= pos
&& nextpos
<= lastpos
))
4991 return e_write (desc
, string
, pos
, lastpos
, coding
);
4993 /* Output buffer text up to the next annotation's position. */
4996 if (0 > e_write (desc
, string
, pos
, nextpos
, coding
))
5000 /* Output the annotation. */
5001 tem
= Fcdr (Fcar (*annot
));
5004 if (0 > e_write (desc
, tem
, 0, XSTRING (tem
)->size
, coding
))
5007 *annot
= Fcdr (*annot
);
5012 #ifndef WRITE_BUF_SIZE
5013 #define WRITE_BUF_SIZE (16 * 1024)
5016 /* Write text in the range START and END into descriptor DESC,
5017 encoding them with coding system CODING. If STRING is nil, START
5018 and END are character positions of the current buffer, else they
5019 are indexes to the string STRING. */
5022 e_write (desc
, string
, start
, end
, coding
)
5026 struct coding_system
*coding
;
5028 register char *addr
;
5029 register int nbytes
;
5030 char buf
[WRITE_BUF_SIZE
];
5032 int require_encoding_p
;
5035 coding
->composing
= COMPOSITION_DISABLED
;
5036 if (coding
->composing
!= COMPOSITION_DISABLED
)
5037 coding_save_composition (coding
, start
, end
, string
);
5039 if (STRINGP (string
))
5041 addr
= XSTRING (string
)->data
;
5042 nbytes
= STRING_BYTES (XSTRING (string
));
5043 coding
->src_multibyte
= STRING_MULTIBYTE (string
);
5045 else if (start
< end
)
5047 /* It is assured that the gap is not in the range START and END-1. */
5048 addr
= CHAR_POS_ADDR (start
);
5049 nbytes
= CHAR_TO_BYTE (end
) - CHAR_TO_BYTE (start
);
5050 coding
->src_multibyte
5051 = !NILP (current_buffer
->enable_multibyte_characters
);
5057 coding
->src_multibyte
= 1;
5060 /* We used to have a code for handling selective display here. But,
5061 now it is handled within encode_coding. */
5066 result
= encode_coding (coding
, addr
, buf
, nbytes
, WRITE_BUF_SIZE
);
5067 if (coding
->produced
> 0)
5069 coding
->produced
-= emacs_write (desc
, buf
, coding
->produced
);
5070 if (coding
->produced
)
5076 nbytes
-= coding
->consumed
;
5077 addr
+= coding
->consumed
;
5078 if (result
== CODING_FINISH_INSUFFICIENT_SRC
5081 /* The source text ends by an incomplete multibyte form.
5082 There's no way other than write it out as is. */
5083 nbytes
-= emacs_write (desc
, addr
, nbytes
);
5092 start
+= coding
->consumed_char
;
5093 if (coding
->cmp_data
)
5094 coding_adjust_composition_offset (coding
, start
);
5097 if (coding
->cmp_data
)
5098 coding_free_composition_data (coding
);
5103 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
5104 Sverify_visited_file_modtime
, 1, 1, 0,
5105 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
5106 This means that the file has not been changed since it was visited or saved.")
5112 Lisp_Object handler
;
5113 Lisp_Object filename
;
5115 CHECK_BUFFER (buf
, 0);
5118 if (!STRINGP (b
->filename
)) return Qt
;
5119 if (b
->modtime
== 0) return Qt
;
5121 /* If the file name has special constructs in it,
5122 call the corresponding file handler. */
5123 handler
= Ffind_file_name_handler (b
->filename
,
5124 Qverify_visited_file_modtime
);
5125 if (!NILP (handler
))
5126 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
5128 filename
= ENCODE_FILE (b
->filename
);
5130 if (stat (XSTRING (filename
)->data
, &st
) < 0)
5132 /* If the file doesn't exist now and didn't exist before,
5133 we say that it isn't modified, provided the error is a tame one. */
5134 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
5139 if (st
.st_mtime
== b
->modtime
5140 /* If both are positive, accept them if they are off by one second. */
5141 || (st
.st_mtime
> 0 && b
->modtime
> 0
5142 && (st
.st_mtime
== b
->modtime
+ 1
5143 || st
.st_mtime
== b
->modtime
- 1)))
5148 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
5149 Sclear_visited_file_modtime
, 0, 0, 0,
5150 "Clear out records of last mod time of visited file.\n\
5151 Next attempt to save will certainly not complain of a discrepancy.")
5154 current_buffer
->modtime
= 0;
5158 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
5159 Svisited_file_modtime
, 0, 0, 0,
5160 "Return the current buffer's recorded visited file modification time.\n\
5161 The value is a list of the form (HIGH . LOW), like the time values\n\
5162 that `file-attributes' returns.")
5165 return long_to_cons ((unsigned long) current_buffer
->modtime
);
5168 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
5169 Sset_visited_file_modtime
, 0, 1, 0,
5170 "Update buffer's recorded modification time from the visited file's time.\n\
5171 Useful if the buffer was not read from the file normally\n\
5172 or if the file itself has been changed for some known benign reason.\n\
5173 An argument specifies the modification time value to use\n\
5174 \(instead of that of the visited file), in the form of a list\n\
5175 \(HIGH . LOW) or (HIGH LOW).")
5177 Lisp_Object time_list
;
5179 if (!NILP (time_list
))
5180 current_buffer
->modtime
= cons_to_long (time_list
);
5183 register Lisp_Object filename
;
5185 Lisp_Object handler
;
5187 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
5189 /* If the file name has special constructs in it,
5190 call the corresponding file handler. */
5191 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
5192 if (!NILP (handler
))
5193 /* The handler can find the file name the same way we did. */
5194 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
5196 filename
= ENCODE_FILE (filename
);
5198 if (stat (XSTRING (filename
)->data
, &st
) >= 0)
5199 current_buffer
->modtime
= st
.st_mtime
;
5209 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 1);
5210 Fsleep_for (make_number (1), Qnil
);
5211 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 0);
5212 Fsleep_for (make_number (1), Qnil
);
5213 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 0);
5214 Fsleep_for (make_number (1), Qnil
);
5223 /* Get visited file's mode to become the auto save file's mode. */
5224 if (! NILP (current_buffer
->filename
)
5225 && stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
5226 /* But make sure we can overwrite it later! */
5227 auto_save_mode_bits
= st
.st_mode
| 0600;
5229 auto_save_mode_bits
= 0666;
5232 Fwrite_region (Qnil
, Qnil
,
5233 current_buffer
->auto_save_file_name
,
5234 Qnil
, Qlambda
, Qnil
, Qnil
);
5238 do_auto_save_unwind (stream
) /* used as unwind-protect function */
5243 fclose ((FILE *) (XFASTINT (XCAR (stream
)) << 16
5244 | XFASTINT (XCDR (stream
))));
5249 do_auto_save_unwind_1 (value
) /* used as unwind-protect function */
5252 minibuffer_auto_raise
= XINT (value
);
5256 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
5257 "Auto-save all buffers that need it.\n\
5258 This is all buffers that have auto-saving enabled\n\
5259 and are changed since last auto-saved.\n\
5260 Auto-saving writes the buffer into a file\n\
5261 so that your editing is not lost if the system crashes.\n\
5262 This file is not the file you visited; that changes only when you save.\n\
5263 Normally we run the normal hook `auto-save-hook' before saving.\n\n\
5264 A non-nil NO-MESSAGE argument means do not print any message if successful.\n\
5265 A non-nil CURRENT-ONLY argument means save only current buffer.")
5266 (no_message
, current_only
)
5267 Lisp_Object no_message
, current_only
;
5269 struct buffer
*old
= current_buffer
, *b
;
5270 Lisp_Object tail
, buf
;
5272 int do_handled_files
;
5275 Lisp_Object lispstream
;
5276 int count
= specpdl_ptr
- specpdl
;
5277 int orig_minibuffer_auto_raise
= minibuffer_auto_raise
;
5278 int message_p
= push_message ();
5280 /* Ordinarily don't quit within this function,
5281 but don't make it impossible to quit (in case we get hung in I/O). */
5285 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
5286 point to non-strings reached from Vbuffer_alist. */
5291 if (!NILP (Vrun_hooks
))
5292 call1 (Vrun_hooks
, intern ("auto-save-hook"));
5294 if (STRINGP (Vauto_save_list_file_name
))
5296 Lisp_Object listfile
, dir
;
5298 listfile
= Fexpand_file_name (Vauto_save_list_file_name
, Qnil
);
5300 dir
= Ffile_name_directory (listfile
);
5301 if (NILP (Ffile_directory_p (dir
)))
5302 call2 (Qmake_directory
, dir
, Qt
);
5304 stream
= fopen (XSTRING (listfile
)->data
, "w");
5307 /* Arrange to close that file whether or not we get an error.
5308 Also reset auto_saving to 0. */
5309 lispstream
= Fcons (Qnil
, Qnil
);
5310 XSETFASTINT (XCAR (lispstream
), (EMACS_UINT
)stream
>> 16);
5311 XSETFASTINT (XCDR (lispstream
), (EMACS_UINT
)stream
& 0xffff);
5322 record_unwind_protect (do_auto_save_unwind
, lispstream
);
5323 record_unwind_protect (do_auto_save_unwind_1
,
5324 make_number (minibuffer_auto_raise
));
5325 minibuffer_auto_raise
= 0;
5328 /* First, save all files which don't have handlers. If Emacs is
5329 crashing, the handlers may tweak what is causing Emacs to crash
5330 in the first place, and it would be a shame if Emacs failed to
5331 autosave perfectly ordinary files because it couldn't handle some
5333 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
5334 for (tail
= Vbuffer_alist
; GC_CONSP (tail
); tail
= XCDR (tail
))
5336 buf
= XCDR (XCAR (tail
));
5339 /* Record all the buffers that have auto save mode
5340 in the special file that lists them. For each of these buffers,
5341 Record visited name (if any) and auto save name. */
5342 if (STRINGP (b
->auto_save_file_name
)
5343 && stream
!= NULL
&& do_handled_files
== 0)
5345 if (!NILP (b
->filename
))
5347 fwrite (XSTRING (b
->filename
)->data
, 1,
5348 STRING_BYTES (XSTRING (b
->filename
)), stream
);
5350 putc ('\n', stream
);
5351 fwrite (XSTRING (b
->auto_save_file_name
)->data
, 1,
5352 STRING_BYTES (XSTRING (b
->auto_save_file_name
)), stream
);
5353 putc ('\n', stream
);
5356 if (!NILP (current_only
)
5357 && b
!= current_buffer
)
5360 /* Don't auto-save indirect buffers.
5361 The base buffer takes care of it. */
5365 /* Check for auto save enabled
5366 and file changed since last auto save
5367 and file changed since last real save. */
5368 if (STRINGP (b
->auto_save_file_name
)
5369 && BUF_SAVE_MODIFF (b
) < BUF_MODIFF (b
)
5370 && b
->auto_save_modified
< BUF_MODIFF (b
)
5371 /* -1 means we've turned off autosaving for a while--see below. */
5372 && XINT (b
->save_length
) >= 0
5373 && (do_handled_files
5374 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
5377 EMACS_TIME before_time
, after_time
;
5379 EMACS_GET_TIME (before_time
);
5381 /* If we had a failure, don't try again for 20 minutes. */
5382 if (b
->auto_save_failure_time
>= 0
5383 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
5386 if ((XFASTINT (b
->save_length
) * 10
5387 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
5388 /* A short file is likely to change a large fraction;
5389 spare the user annoying messages. */
5390 && XFASTINT (b
->save_length
) > 5000
5391 /* These messages are frequent and annoying for `*mail*'. */
5392 && !EQ (b
->filename
, Qnil
)
5393 && NILP (no_message
))
5395 /* It has shrunk too much; turn off auto-saving here. */
5396 minibuffer_auto_raise
= orig_minibuffer_auto_raise
;
5397 message_with_string ("Buffer %s has shrunk a lot; auto save turned off there",
5399 minibuffer_auto_raise
= 0;
5400 /* Turn off auto-saving until there's a real save,
5401 and prevent any more warnings. */
5402 XSETINT (b
->save_length
, -1);
5403 Fsleep_for (make_number (1), Qnil
);
5406 set_buffer_internal (b
);
5407 if (!auto_saved
&& NILP (no_message
))
5408 message1 ("Auto-saving...");
5409 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
5411 b
->auto_save_modified
= BUF_MODIFF (b
);
5412 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
5413 set_buffer_internal (old
);
5415 EMACS_GET_TIME (after_time
);
5417 /* If auto-save took more than 60 seconds,
5418 assume it was an NFS failure that got a timeout. */
5419 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
5420 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
5424 /* Prevent another auto save till enough input events come in. */
5425 record_auto_save ();
5427 if (auto_saved
&& NILP (no_message
))
5431 sit_for (1, 0, 0, 0, 0);
5435 message1 ("Auto-saving...done");
5441 unbind_to (count
, Qnil
);
5445 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
5446 Sset_buffer_auto_saved
, 0, 0, 0,
5447 "Mark current buffer as auto-saved with its current text.\n\
5448 No auto-save file will be written until the buffer changes again.")
5451 current_buffer
->auto_save_modified
= MODIFF
;
5452 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
5453 current_buffer
->auto_save_failure_time
= -1;
5457 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
5458 Sclear_buffer_auto_save_failure
, 0, 0, 0,
5459 "Clear any record of a recent auto-save failure in the current buffer.")
5462 current_buffer
->auto_save_failure_time
= -1;
5466 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
5468 "Return t if buffer has been auto-saved since last read in or saved.")
5471 return (SAVE_MODIFF
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
5474 /* Reading and completing file names */
5475 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
5477 /* In the string VAL, change each $ to $$ and return the result. */
5480 double_dollars (val
)
5483 register unsigned char *old
, *new;
5487 osize
= STRING_BYTES (XSTRING (val
));
5489 /* Count the number of $ characters. */
5490 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
5491 if (*old
++ == '$') count
++;
5494 old
= XSTRING (val
)->data
;
5495 val
= make_uninit_multibyte_string (XSTRING (val
)->size
+ count
,
5497 new = XSTRING (val
)->data
;
5498 for (n
= osize
; n
> 0; n
--)
5511 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
5513 "Internal subroutine for read-file-name. Do not call this.")
5514 (string
, dir
, action
)
5515 Lisp_Object string
, dir
, action
;
5516 /* action is nil for complete, t for return list of completions,
5517 lambda for verify final value */
5519 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
5521 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
5523 CHECK_STRING (string
, 0);
5530 /* No need to protect ACTION--we only compare it with t and nil. */
5531 GCPRO5 (string
, realdir
, name
, specdir
, orig_string
);
5533 if (XSTRING (string
)->size
== 0)
5535 if (EQ (action
, Qlambda
))
5543 orig_string
= string
;
5544 string
= Fsubstitute_in_file_name (string
);
5545 changed
= NILP (Fstring_equal (string
, orig_string
));
5546 name
= Ffile_name_nondirectory (string
);
5547 val
= Ffile_name_directory (string
);
5549 realdir
= Fexpand_file_name (val
, realdir
);
5554 specdir
= Ffile_name_directory (string
);
5555 val
= Ffile_name_completion (name
, realdir
);
5560 return double_dollars (string
);
5564 if (!NILP (specdir
))
5565 val
= concat2 (specdir
, val
);
5567 return double_dollars (val
);
5570 #endif /* not VMS */
5574 if (EQ (action
, Qt
))
5575 return Ffile_name_all_completions (name
, realdir
);
5576 /* Only other case actually used is ACTION = lambda */
5578 /* Supposedly this helps commands such as `cd' that read directory names,
5579 but can someone explain how it helps them? -- RMS */
5580 if (XSTRING (name
)->size
== 0)
5583 return Ffile_exists_p (string
);
5586 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
5587 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
5588 Value is not expanded---you must call `expand-file-name' yourself.\n\
5589 Default name to DEFAULT-FILENAME if user enters a null string.\n\
5590 (If DEFAULT-FILENAME is omitted, the visited file name is used,\n\
5591 except that if INITIAL is specified, that combined with DIR is used.)\n\
5592 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
5593 Non-nil and non-t means also require confirmation after completion.\n\
5594 Fifth arg INITIAL specifies text to start with.\n\
5595 DIR defaults to current buffer's directory default.")
5596 (prompt
, dir
, default_filename
, mustmatch
, initial
)
5597 Lisp_Object prompt
, dir
, default_filename
, mustmatch
, initial
;
5599 Lisp_Object val
, insdef
, tem
;
5600 struct gcpro gcpro1
, gcpro2
;
5601 register char *homedir
;
5602 int replace_in_history
= 0;
5603 int add_to_history
= 0;
5607 dir
= current_buffer
->directory
;
5608 if (NILP (default_filename
))
5610 if (! NILP (initial
))
5611 default_filename
= Fexpand_file_name (initial
, dir
);
5613 default_filename
= current_buffer
->filename
;
5616 /* If dir starts with user's homedir, change that to ~. */
5617 homedir
= (char *) egetenv ("HOME");
5619 homedir
= strcpy (alloca (strlen (homedir
) + 1), homedir
);
5620 CORRECT_DIR_SEPS (homedir
);
5624 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5625 && IS_DIRECTORY_SEP (XSTRING (dir
)->data
[strlen (homedir
)]))
5627 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5628 STRING_BYTES (XSTRING (dir
)) - strlen (homedir
) + 1);
5629 XSTRING (dir
)->data
[0] = '~';
5631 /* Likewise for default_filename. */
5633 && STRINGP (default_filename
)
5634 && !strncmp (homedir
, XSTRING (default_filename
)->data
, strlen (homedir
))
5635 && IS_DIRECTORY_SEP (XSTRING (default_filename
)->data
[strlen (homedir
)]))
5638 = make_string (XSTRING (default_filename
)->data
+ strlen (homedir
) - 1,
5639 STRING_BYTES (XSTRING (default_filename
)) - strlen (homedir
) + 1);
5640 XSTRING (default_filename
)->data
[0] = '~';
5642 if (!NILP (default_filename
))
5644 CHECK_STRING (default_filename
, 3);
5645 default_filename
= double_dollars (default_filename
);
5648 if (insert_default_directory
&& STRINGP (dir
))
5651 if (!NILP (initial
))
5653 Lisp_Object args
[2], pos
;
5657 insdef
= Fconcat (2, args
);
5658 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
5659 insdef
= Fcons (double_dollars (insdef
), pos
);
5662 insdef
= double_dollars (insdef
);
5664 else if (STRINGP (initial
))
5665 insdef
= Fcons (double_dollars (initial
), make_number (0));
5669 count
= specpdl_ptr
- specpdl
;
5671 specbind (intern ("completion-ignore-case"), Qt
);
5674 specbind (intern ("minibuffer-completing-file-name"), Qt
);
5676 GCPRO2 (insdef
, default_filename
);
5678 #if defined (USE_MOTIF) || defined (HAVE_NTGUI)
5679 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
5683 /* If DIR contains a file name, split it. */
5685 file
= Ffile_name_nondirectory (dir
);
5686 if (XSTRING (file
)->size
&& NILP (default_filename
))
5688 default_filename
= file
;
5689 dir
= Ffile_name_directory (dir
);
5691 if (!NILP(default_filename
))
5692 default_filename
= Fexpand_file_name (default_filename
, dir
);
5693 val
= Fx_file_dialog (prompt
, dir
, default_filename
, mustmatch
);
5698 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5699 dir
, mustmatch
, insdef
,
5700 Qfile_name_history
, default_filename
, Qnil
);
5702 tem
= Fsymbol_value (Qfile_name_history
);
5703 if (CONSP (tem
) && EQ (XCAR (tem
), val
))
5704 replace_in_history
= 1;
5706 /* If Fcompleting_read returned the inserted default string itself
5707 (rather than a new string with the same contents),
5708 it has to mean that the user typed RET with the minibuffer empty.
5709 In that case, we really want to return ""
5710 so that commands such as set-visited-file-name can distinguish. */
5711 if (EQ (val
, default_filename
))
5713 /* In this case, Fcompleting_read has not added an element
5714 to the history. Maybe we should. */
5715 if (! replace_in_history
)
5718 val
= build_string ("");
5721 unbind_to (count
, Qnil
);
5724 error ("No file name specified");
5726 tem
= Fstring_equal (val
, CONSP (insdef
) ? XCAR (insdef
) : insdef
);
5728 if (!NILP (tem
) && !NILP (default_filename
))
5729 val
= default_filename
;
5730 else if (XSTRING (val
)->size
== 0 && NILP (insdef
))
5732 if (!NILP (default_filename
))
5733 val
= default_filename
;
5735 error ("No default file name");
5737 val
= Fsubstitute_in_file_name (val
);
5739 if (replace_in_history
)
5740 /* Replace what Fcompleting_read added to the history
5741 with what we will actually return. */
5742 XCAR (Fsymbol_value (Qfile_name_history
)) = double_dollars (val
);
5743 else if (add_to_history
)
5745 /* Add the value to the history--but not if it matches
5746 the last value already there. */
5747 Lisp_Object val1
= double_dollars (val
);
5748 tem
= Fsymbol_value (Qfile_name_history
);
5749 if (! CONSP (tem
) || NILP (Fequal (XCAR (tem
), val1
)))
5750 Fset (Qfile_name_history
,
5761 /* Must be set before any path manipulation is performed. */
5762 XSETFASTINT (Vdirectory_sep_char
, '/');
5769 Qexpand_file_name
= intern ("expand-file-name");
5770 Qsubstitute_in_file_name
= intern ("substitute-in-file-name");
5771 Qdirectory_file_name
= intern ("directory-file-name");
5772 Qfile_name_directory
= intern ("file-name-directory");
5773 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
5774 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
5775 Qfile_name_as_directory
= intern ("file-name-as-directory");
5776 Qcopy_file
= intern ("copy-file");
5777 Qmake_directory_internal
= intern ("make-directory-internal");
5778 Qmake_directory
= intern ("make-directory");
5779 Qdelete_directory
= intern ("delete-directory");
5780 Qdelete_file
= intern ("delete-file");
5781 Qrename_file
= intern ("rename-file");
5782 Qadd_name_to_file
= intern ("add-name-to-file");
5783 Qmake_symbolic_link
= intern ("make-symbolic-link");
5784 Qfile_exists_p
= intern ("file-exists-p");
5785 Qfile_executable_p
= intern ("file-executable-p");
5786 Qfile_readable_p
= intern ("file-readable-p");
5787 Qfile_writable_p
= intern ("file-writable-p");
5788 Qfile_symlink_p
= intern ("file-symlink-p");
5789 Qaccess_file
= intern ("access-file");
5790 Qfile_directory_p
= intern ("file-directory-p");
5791 Qfile_regular_p
= intern ("file-regular-p");
5792 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
5793 Qfile_modes
= intern ("file-modes");
5794 Qset_file_modes
= intern ("set-file-modes");
5795 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
5796 Qinsert_file_contents
= intern ("insert-file-contents");
5797 Qwrite_region
= intern ("write-region");
5798 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
5799 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
5801 staticpro (&Qexpand_file_name
);
5802 staticpro (&Qsubstitute_in_file_name
);
5803 staticpro (&Qdirectory_file_name
);
5804 staticpro (&Qfile_name_directory
);
5805 staticpro (&Qfile_name_nondirectory
);
5806 staticpro (&Qunhandled_file_name_directory
);
5807 staticpro (&Qfile_name_as_directory
);
5808 staticpro (&Qcopy_file
);
5809 staticpro (&Qmake_directory_internal
);
5810 staticpro (&Qmake_directory
);
5811 staticpro (&Qdelete_directory
);
5812 staticpro (&Qdelete_file
);
5813 staticpro (&Qrename_file
);
5814 staticpro (&Qadd_name_to_file
);
5815 staticpro (&Qmake_symbolic_link
);
5816 staticpro (&Qfile_exists_p
);
5817 staticpro (&Qfile_executable_p
);
5818 staticpro (&Qfile_readable_p
);
5819 staticpro (&Qfile_writable_p
);
5820 staticpro (&Qaccess_file
);
5821 staticpro (&Qfile_symlink_p
);
5822 staticpro (&Qfile_directory_p
);
5823 staticpro (&Qfile_regular_p
);
5824 staticpro (&Qfile_accessible_directory_p
);
5825 staticpro (&Qfile_modes
);
5826 staticpro (&Qset_file_modes
);
5827 staticpro (&Qfile_newer_than_file_p
);
5828 staticpro (&Qinsert_file_contents
);
5829 staticpro (&Qwrite_region
);
5830 staticpro (&Qverify_visited_file_modtime
);
5831 staticpro (&Qset_visited_file_modtime
);
5833 Qfile_name_history
= intern ("file-name-history");
5834 Fset (Qfile_name_history
, Qnil
);
5835 staticpro (&Qfile_name_history
);
5837 Qfile_error
= intern ("file-error");
5838 staticpro (&Qfile_error
);
5839 Qfile_already_exists
= intern ("file-already-exists");
5840 staticpro (&Qfile_already_exists
);
5841 Qfile_date_error
= intern ("file-date-error");
5842 staticpro (&Qfile_date_error
);
5843 Qexcl
= intern ("excl");
5847 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
5848 staticpro (&Qfind_buffer_file_type
);
5851 DEFVAR_LISP ("file-name-coding-system", &Vfile_name_coding_system
,
5852 "*Coding system for encoding file names.\n\
5853 If it is nil, default-file-name-coding-system (which see) is used.");
5854 Vfile_name_coding_system
= Qnil
;
5856 DEFVAR_LISP ("default-file-name-coding-system",
5857 &Vdefault_file_name_coding_system
,
5858 "Default coding system for encoding file names.\n\
5859 This variable is used only when file-name-coding-system is nil.\n\
5861 This variable is set/changed by the command set-language-environment.\n\
5862 User should not set this variable manually,\n\
5863 instead use file-name-coding-system to get a constant encoding\n\
5864 of file names regardless of the current language environment.");
5865 Vdefault_file_name_coding_system
= Qnil
;
5867 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format
,
5868 "*Format in which to write auto-save files.\n\
5869 Should be a list of symbols naming formats that are defined in `format-alist'.\n\
5870 If it is t, which is the default, auto-save files are written in the\n\
5871 same format as a regular save would use.");
5872 Vauto_save_file_format
= Qt
;
5874 Qformat_decode
= intern ("format-decode");
5875 staticpro (&Qformat_decode
);
5876 Qformat_annotate_function
= intern ("format-annotate-function");
5877 staticpro (&Qformat_annotate_function
);
5879 Qcar_less_than_car
= intern ("car-less-than-car");
5880 staticpro (&Qcar_less_than_car
);
5882 Fput (Qfile_error
, Qerror_conditions
,
5883 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
5884 Fput (Qfile_error
, Qerror_message
,
5885 build_string ("File error"));
5887 Fput (Qfile_already_exists
, Qerror_conditions
,
5888 Fcons (Qfile_already_exists
,
5889 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5890 Fput (Qfile_already_exists
, Qerror_message
,
5891 build_string ("File already exists"));
5893 Fput (Qfile_date_error
, Qerror_conditions
,
5894 Fcons (Qfile_date_error
,
5895 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5896 Fput (Qfile_date_error
, Qerror_message
,
5897 build_string ("Cannot set file date"));
5899 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
5900 "*Non-nil means when reading a filename start with default dir in minibuffer.");
5901 insert_default_directory
= 1;
5903 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
5904 "*Non-nil means write new files with record format `stmlf'.\n\
5905 nil means use format `var'. This variable is meaningful only on VMS.");
5906 vms_stmlf_recfm
= 0;
5908 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char
,
5909 "Directory separator character for built-in functions that return file names.\n\
5910 The value should be either ?/ or ?\\ (any other value is treated as ?\\).\n\
5911 This variable affects the built-in functions only on Windows,\n\
5912 on other platforms, it is initialized so that Lisp code can find out\n\
5913 what the normal separator is.");
5915 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
5916 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
5917 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
5920 The first argument given to HANDLER is the name of the I/O primitive\n\
5921 to be handled; the remaining arguments are the arguments that were\n\
5922 passed to that primitive. For example, if you do\n\
5923 (file-exists-p FILENAME)\n\
5924 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
5925 (funcall HANDLER 'file-exists-p FILENAME)\n\
5926 The function `find-file-name-handler' checks this list for a handler\n\
5927 for its argument.");
5928 Vfile_name_handler_alist
= Qnil
;
5930 DEFVAR_LISP ("set-auto-coding-function",
5931 &Vset_auto_coding_function
,
5932 "If non-nil, a function to call to decide a coding system of file.\n\
5933 Two arguments are passed to this function: the file name\n\
5934 and the length of a file contents following the point.\n\
5935 This function should return a coding system to decode the file contents.\n\
5936 It should check the file name against `auto-coding-alist'.\n\
5937 If no coding system is decided, it should check a coding system\n\
5938 specified in the heading lines with the format:\n\
5939 -*- ... coding: CODING-SYSTEM; ... -*-\n\
5940 or local variable spec of the tailing lines with `coding:' tag.");
5941 Vset_auto_coding_function
= Qnil
;
5943 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
5944 "A list of functions to be called at the end of `insert-file-contents'.\n\
5945 Each is passed one argument, the number of bytes inserted. It should return\n\
5946 the new byte count, and leave point the same. If `insert-file-contents' is\n\
5947 intercepted by a handler from `file-name-handler-alist', that handler is\n\
5948 responsible for calling the after-insert-file-functions if appropriate.");
5949 Vafter_insert_file_functions
= Qnil
;
5951 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
5952 "A list of functions to be called at the start of `write-region'.\n\
5953 Each is passed two arguments, START and END as for `write-region'.\n\
5954 These are usually two numbers but not always; see the documentation\n\
5955 for `write-region'. The function should return a list of pairs\n\
5956 of the form (POSITION . STRING), consisting of strings to be effectively\n\
5957 inserted at the specified positions of the file being written (1 means to\n\
5958 insert before the first byte written). The POSITIONs must be sorted into\n\
5959 increasing order. If there are several functions in the list, the several\n\
5960 lists are merged destructively.");
5961 Vwrite_region_annotate_functions
= Qnil
;
5963 DEFVAR_LISP ("write-region-annotations-so-far",
5964 &Vwrite_region_annotations_so_far
,
5965 "When an annotation function is called, this holds the previous annotations.\n\
5966 These are the annotations made by other annotation functions\n\
5967 that were already called. See also `write-region-annotate-functions'.");
5968 Vwrite_region_annotations_so_far
= Qnil
;
5970 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
5971 "A list of file name handlers that temporarily should not be used.\n\
5972 This applies only to the operation `inhibit-file-name-operation'.");
5973 Vinhibit_file_name_handlers
= Qnil
;
5975 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
5976 "The operation for which `inhibit-file-name-handlers' is applicable.");
5977 Vinhibit_file_name_operation
= Qnil
;
5979 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
5980 "File name in which we write a list of all auto save file names.\n\
5981 This variable is initialized automatically from `auto-save-list-file-prefix'\n\
5982 shortly after Emacs reads your `.emacs' file, if you have not yet given it\n\
5984 Vauto_save_list_file_name
= Qnil
;
5986 defsubr (&Sfind_file_name_handler
);
5987 defsubr (&Sfile_name_directory
);
5988 defsubr (&Sfile_name_nondirectory
);
5989 defsubr (&Sunhandled_file_name_directory
);
5990 defsubr (&Sfile_name_as_directory
);
5991 defsubr (&Sdirectory_file_name
);
5992 defsubr (&Smake_temp_name
);
5993 defsubr (&Sexpand_file_name
);
5994 defsubr (&Ssubstitute_in_file_name
);
5995 defsubr (&Scopy_file
);
5996 defsubr (&Smake_directory_internal
);
5997 defsubr (&Sdelete_directory
);
5998 defsubr (&Sdelete_file
);
5999 defsubr (&Srename_file
);
6000 defsubr (&Sadd_name_to_file
);
6002 defsubr (&Smake_symbolic_link
);
6003 #endif /* S_IFLNK */
6005 defsubr (&Sdefine_logical_name
);
6008 defsubr (&Ssysnetunam
);
6009 #endif /* HPUX_NET */
6010 defsubr (&Sfile_name_absolute_p
);
6011 defsubr (&Sfile_exists_p
);
6012 defsubr (&Sfile_executable_p
);
6013 defsubr (&Sfile_readable_p
);
6014 defsubr (&Sfile_writable_p
);
6015 defsubr (&Saccess_file
);
6016 defsubr (&Sfile_symlink_p
);
6017 defsubr (&Sfile_directory_p
);
6018 defsubr (&Sfile_accessible_directory_p
);
6019 defsubr (&Sfile_regular_p
);
6020 defsubr (&Sfile_modes
);
6021 defsubr (&Sset_file_modes
);
6022 defsubr (&Sset_default_file_modes
);
6023 defsubr (&Sdefault_file_modes
);
6024 defsubr (&Sfile_newer_than_file_p
);
6025 defsubr (&Sinsert_file_contents
);
6026 defsubr (&Swrite_region
);
6027 defsubr (&Scar_less_than_car
);
6028 defsubr (&Sverify_visited_file_modtime
);
6029 defsubr (&Sclear_visited_file_modtime
);
6030 defsubr (&Svisited_file_modtime
);
6031 defsubr (&Sset_visited_file_modtime
);
6032 defsubr (&Sdo_auto_save
);
6033 defsubr (&Sset_buffer_auto_saved
);
6034 defsubr (&Sclear_buffer_auto_save_failure
);
6035 defsubr (&Srecent_auto_save_p
);
6037 defsubr (&Sread_file_name_internal
);
6038 defsubr (&Sread_file_name
);
6041 defsubr (&Sunix_sync
);