1 /* File IO for GNU Emacs.
2 Copyright (C) 1985,86,87,88,93,94,95,96,97,1998 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
23 #if defined (USG5) || defined (BSD_SYSTEM) || defined (LINUX)
28 #include <sys/types.h>
35 #if !defined (S_ISLNK) && defined (S_IFLNK)
36 # define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
39 #if !defined (S_ISFIFO) && defined (S_IFIFO)
40 # define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO)
43 #if !defined (S_ISREG) && defined (S_IFREG)
44 # define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
55 #include <sys/param.h>
77 extern char *strerror ();
94 #include "intervals.h"
105 #endif /* not WINDOWSNT */
108 #define CORRECT_DIR_SEPS(s) \
109 do { if ('/' == DIRECTORY_SEP) dostounix_filename (s); \
110 else unixtodos_filename (s); \
112 /* On Windows, drive letters must be alphabetic - on DOS, the Netware
113 redirector allows the six letters between 'Z' and 'a' as well. */
115 #define IS_DRIVE(x) ((x) >= 'A' && (x) <= 'z')
118 #define IS_DRIVE(x) isalpha (x)
120 /* Need to lower-case the drive letter, or else expanded
121 filenames will sometimes compare inequal, because
122 `expand-file-name' doesn't always down-case the drive letter. */
123 #define DRIVE_LETTER(x) (tolower (x))
152 #define min(a, b) ((a) < (b) ? (a) : (b))
153 #define max(a, b) ((a) > (b) ? (a) : (b))
155 /* Nonzero during writing of auto-save files */
158 /* Set by auto_save_1 to mode of original file so Fwrite_region will create
159 a new file with the same mode as the original */
160 int auto_save_mode_bits
;
162 /* Coding system for file names, or nil if none. */
163 Lisp_Object Vfile_name_coding_system
;
165 /* Coding system for file names used only when
166 Vfile_name_coding_system is nil. */
167 Lisp_Object Vdefault_file_name_coding_system
;
169 /* Alist of elements (REGEXP . HANDLER) for file names
170 whose I/O is done with a special handler. */
171 Lisp_Object Vfile_name_handler_alist
;
173 /* Format for auto-save files */
174 Lisp_Object Vauto_save_file_format
;
176 /* Lisp functions for translating file formats */
177 Lisp_Object Qformat_decode
, Qformat_annotate_function
;
179 /* Function to be called to decide a coding system of a reading file. */
180 Lisp_Object Vset_auto_coding_function
;
182 /* Functions to be called to process text properties in inserted file. */
183 Lisp_Object Vafter_insert_file_functions
;
185 /* Functions to be called to create text property annotations for file. */
186 Lisp_Object Vwrite_region_annotate_functions
;
188 /* During build_annotations, each time an annotation function is called,
189 this holds the annotations made by the previous functions. */
190 Lisp_Object Vwrite_region_annotations_so_far
;
192 /* File name in which we write a list of all our auto save files. */
193 Lisp_Object Vauto_save_list_file_name
;
195 /* Nonzero means, when reading a filename in the minibuffer,
196 start out by inserting the default directory into the minibuffer. */
197 int insert_default_directory
;
199 /* On VMS, nonzero means write new files with record format stmlf.
200 Zero means use var format. */
203 /* On NT, specifies the directory separator character, used (eg.) when
204 expanding file names. This can be bound to / or \. */
205 Lisp_Object Vdirectory_sep_char
;
207 extern Lisp_Object Vuser_login_name
;
209 extern int minibuf_level
;
211 extern int minibuffer_auto_raise
;
213 /* These variables describe handlers that have "already" had a chance
214 to handle the current operation.
216 Vinhibit_file_name_handlers is a list of file name handlers.
217 Vinhibit_file_name_operation is the operation being handled.
218 If we try to handle that operation, we ignore those handlers. */
220 static Lisp_Object Vinhibit_file_name_handlers
;
221 static Lisp_Object Vinhibit_file_name_operation
;
223 Lisp_Object Qfile_error
, Qfile_already_exists
, Qfile_date_error
;
225 Lisp_Object Qfile_name_history
;
227 Lisp_Object Qcar_less_than_car
;
229 static int a_write
P_ ((int, char *, int, int,
230 Lisp_Object
*, struct coding_system
*));
231 static int e_write
P_ ((int, char *, int, struct coding_system
*));
234 report_file_error (string
, data
)
238 Lisp_Object errstring
;
240 errstring
= build_string (strerror (errno
));
242 /* System error messages are capitalized. Downcase the initial
243 unless it is followed by a slash. */
244 if (XSTRING (errstring
)->data
[1] != '/')
245 XSTRING (errstring
)->data
[0] = DOWNCASE (XSTRING (errstring
)->data
[0]);
248 Fsignal (Qfile_error
,
249 Fcons (build_string (string
), Fcons (errstring
, data
)));
253 close_file_unwind (fd
)
256 close (XFASTINT (fd
));
260 /* Restore point, having saved it as a marker. */
263 restore_point_unwind (location
)
264 Lisp_Object location
;
266 Fgoto_char (location
);
267 Fset_marker (location
, Qnil
, Qnil
);
271 Lisp_Object Qexpand_file_name
;
272 Lisp_Object Qsubstitute_in_file_name
;
273 Lisp_Object Qdirectory_file_name
;
274 Lisp_Object Qfile_name_directory
;
275 Lisp_Object Qfile_name_nondirectory
;
276 Lisp_Object Qunhandled_file_name_directory
;
277 Lisp_Object Qfile_name_as_directory
;
278 Lisp_Object Qcopy_file
;
279 Lisp_Object Qmake_directory_internal
;
280 Lisp_Object Qdelete_directory
;
281 Lisp_Object Qdelete_file
;
282 Lisp_Object Qrename_file
;
283 Lisp_Object Qadd_name_to_file
;
284 Lisp_Object Qmake_symbolic_link
;
285 Lisp_Object Qfile_exists_p
;
286 Lisp_Object Qfile_executable_p
;
287 Lisp_Object Qfile_readable_p
;
288 Lisp_Object Qfile_writable_p
;
289 Lisp_Object Qfile_symlink_p
;
290 Lisp_Object Qaccess_file
;
291 Lisp_Object Qfile_directory_p
;
292 Lisp_Object Qfile_regular_p
;
293 Lisp_Object Qfile_accessible_directory_p
;
294 Lisp_Object Qfile_modes
;
295 Lisp_Object Qset_file_modes
;
296 Lisp_Object Qfile_newer_than_file_p
;
297 Lisp_Object Qinsert_file_contents
;
298 Lisp_Object Qwrite_region
;
299 Lisp_Object Qverify_visited_file_modtime
;
300 Lisp_Object Qset_visited_file_modtime
;
302 DEFUN ("find-file-name-handler", Ffind_file_name_handler
, Sfind_file_name_handler
, 2, 2, 0,
303 "Return FILENAME's handler function for OPERATION, if it has one.\n\
304 Otherwise, return nil.\n\
305 A file name is handled if one of the regular expressions in\n\
306 `file-name-handler-alist' matches it.\n\n\
307 If OPERATION equals `inhibit-file-name-operation', then we ignore\n\
308 any handlers that are members of `inhibit-file-name-handlers',\n\
309 but we still do run any other handlers. This lets handlers\n\
310 use the standard functions without calling themselves recursively.")
311 (filename
, operation
)
312 Lisp_Object filename
, operation
;
314 /* This function must not munge the match data. */
315 Lisp_Object chain
, inhibited_handlers
;
317 CHECK_STRING (filename
, 0);
319 if (EQ (operation
, Vinhibit_file_name_operation
))
320 inhibited_handlers
= Vinhibit_file_name_handlers
;
322 inhibited_handlers
= Qnil
;
324 for (chain
= Vfile_name_handler_alist
; CONSP (chain
);
325 chain
= XCONS (chain
)->cdr
)
328 elt
= XCONS (chain
)->car
;
332 string
= XCONS (elt
)->car
;
333 if (STRINGP (string
) && fast_string_match (string
, filename
) >= 0)
335 Lisp_Object handler
, tem
;
337 handler
= XCONS (elt
)->cdr
;
338 tem
= Fmemq (handler
, inhibited_handlers
);
349 DEFUN ("file-name-directory", Ffile_name_directory
, Sfile_name_directory
,
351 "Return the directory component in file name FILENAME.\n\
352 Return nil if FILENAME does not include a directory.\n\
353 Otherwise return a directory spec.\n\
354 Given a Unix syntax file name, returns a string ending in slash;\n\
355 on VMS, perhaps instead a string ending in `:', `]' or `>'.")
357 Lisp_Object filename
;
359 register unsigned char *beg
;
360 register unsigned char *p
;
363 CHECK_STRING (filename
, 0);
365 /* If the file name has special constructs in it,
366 call the corresponding file handler. */
367 handler
= Ffind_file_name_handler (filename
, Qfile_name_directory
);
369 return call2 (handler
, Qfile_name_directory
, filename
);
371 #ifdef FILE_SYSTEM_CASE
372 filename
= FILE_SYSTEM_CASE (filename
);
374 beg
= XSTRING (filename
)->data
;
376 beg
= strcpy (alloca (strlen (beg
) + 1), beg
);
378 p
= beg
+ XSTRING (filename
)->size_byte
;
380 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
382 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
385 /* only recognise drive specifier at beginning */
386 && !(p
[-1] == ':' && p
== beg
+ 2)
393 /* Expansion of "c:" to drive and default directory. */
394 if (p
== beg
+ 2 && beg
[1] == ':')
396 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
397 unsigned char *res
= alloca (MAXPATHLEN
+ 1);
398 if (getdefdir (toupper (*beg
) - 'A' + 1, res
))
400 if (!IS_DIRECTORY_SEP (res
[strlen (res
) - 1]))
403 p
= beg
+ strlen (beg
);
406 CORRECT_DIR_SEPS (beg
);
409 if (STRING_MULTIBYTE (filename
))
410 return make_string (beg
, p
- beg
);
411 return make_unibyte_string (beg
, p
- beg
);
414 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory
,
415 Sfile_name_nondirectory
, 1, 1, 0,
416 "Return file name FILENAME sans its directory.\n\
417 For example, in a Unix-syntax file name,\n\
418 this is everything after the last slash,\n\
419 or the entire name if it contains no slash.")
421 Lisp_Object filename
;
423 register unsigned char *beg
, *p
, *end
;
426 CHECK_STRING (filename
, 0);
428 /* If the file name has special constructs in it,
429 call the corresponding file handler. */
430 handler
= Ffind_file_name_handler (filename
, Qfile_name_nondirectory
);
432 return call2 (handler
, Qfile_name_nondirectory
, filename
);
434 beg
= XSTRING (filename
)->data
;
435 end
= p
= beg
+ XSTRING (filename
)->size_byte
;
437 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
439 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
442 /* only recognise drive specifier at beginning */
443 && !(p
[-1] == ':' && p
== beg
+ 2)
448 if (STRING_MULTIBYTE (filename
))
449 return make_string (p
, end
- p
);
450 return make_unibyte_string (p
, end
- p
);
453 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory
,
454 Sunhandled_file_name_directory
, 1, 1, 0,
455 "Return a directly usable directory name somehow associated with FILENAME.\n\
456 A `directly usable' directory name is one that may be used without the\n\
457 intervention of any file handler.\n\
458 If FILENAME is a directly usable file itself, return\n\
459 \(file-name-directory FILENAME).\n\
460 The `call-process' and `start-process' functions use this function to\n\
461 get a current directory to run processes in.")
463 Lisp_Object filename
;
467 /* If the file name has special constructs in it,
468 call the corresponding file handler. */
469 handler
= Ffind_file_name_handler (filename
, Qunhandled_file_name_directory
);
471 return call2 (handler
, Qunhandled_file_name_directory
, filename
);
473 return Ffile_name_directory (filename
);
478 file_name_as_directory (out
, in
)
481 int size
= strlen (in
) - 1;
493 /* Is it already a directory string? */
494 if (in
[size
] == ':' || in
[size
] == ']' || in
[size
] == '>')
496 /* Is it a VMS directory file name? If so, hack VMS syntax. */
497 else if (! index (in
, '/')
498 && ((size
> 3 && ! strcmp (&in
[size
- 3], ".DIR"))
499 || (size
> 3 && ! strcmp (&in
[size
- 3], ".dir"))
500 || (size
> 5 && (! strncmp (&in
[size
- 5], ".DIR", 4)
501 || ! strncmp (&in
[size
- 5], ".dir", 4))
502 && (in
[size
- 1] == '.' || in
[size
- 1] == ';')
503 && in
[size
] == '1')))
505 register char *p
, *dot
;
509 dir:x.dir --> dir:[x]
510 dir:[x]y.dir --> dir:[x.y] */
512 while (p
!= in
&& *p
!= ':' && *p
!= '>' && *p
!= ']') p
--;
515 strncpy (out
, in
, p
- in
);
534 dot
= index (p
, '.');
537 /* blindly remove any extension */
538 size
= strlen (out
) + (dot
- p
);
539 strncat (out
, p
, dot
- p
);
550 /* For Unix syntax, Append a slash if necessary */
551 if (!IS_DIRECTORY_SEP (out
[size
]))
553 out
[size
+ 1] = DIRECTORY_SEP
;
554 out
[size
+ 2] = '\0';
557 CORRECT_DIR_SEPS (out
);
563 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
564 Sfile_name_as_directory
, 1, 1, 0,
565 "Return a string representing file FILENAME interpreted as a directory.\n\
566 This operation exists because a directory is also a file, but its name as\n\
567 a directory is different from its name as a file.\n\
568 The result can be used as the value of `default-directory'\n\
569 or passed as second argument to `expand-file-name'.\n\
570 For a Unix-syntax file name, just appends a slash.\n\
571 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
578 CHECK_STRING (file
, 0);
582 /* If the file name has special constructs in it,
583 call the corresponding file handler. */
584 handler
= Ffind_file_name_handler (file
, Qfile_name_as_directory
);
586 return call2 (handler
, Qfile_name_as_directory
, file
);
588 buf
= (char *) alloca (XSTRING (file
)->size_byte
+ 10);
589 return build_string (file_name_as_directory (buf
, XSTRING (file
)->data
));
593 * Convert from directory name to filename.
595 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
596 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
597 * On UNIX, it's simple: just make sure there isn't a terminating /
599 * Value is nonzero if the string output is different from the input.
602 directory_file_name (src
, dst
)
610 struct FAB fab
= cc$rms_fab
;
611 struct NAM nam
= cc$rms_nam
;
612 char esa
[NAM$C_MAXRSS
];
617 if (! index (src
, '/')
618 && (src
[slen
- 1] == ']'
619 || src
[slen
- 1] == ':'
620 || src
[slen
- 1] == '>'))
622 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
624 fab
.fab$b_fns
= slen
;
625 fab
.fab$l_nam
= &nam
;
626 fab
.fab$l_fop
= FAB$M_NAM
;
629 nam
.nam$b_ess
= sizeof esa
;
630 nam
.nam$b_nop
|= NAM$M_SYNCHK
;
632 /* We call SYS$PARSE to handle such things as [--] for us. */
633 if (SYS$
PARSE (&fab
, 0, 0) == RMS$_NORMAL
)
635 slen
= nam
.nam$b_esl
;
636 if (esa
[slen
- 1] == ';' && esa
[slen
- 2] == '.')
641 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
643 /* what about when we have logical_name:???? */
644 if (src
[slen
- 1] == ':')
645 { /* Xlate logical name and see what we get */
646 ptr
= strcpy (dst
, src
); /* upper case for getenv */
649 if ('a' <= *ptr
&& *ptr
<= 'z')
653 dst
[slen
- 1] = 0; /* remove colon */
654 if (!(src
= egetenv (dst
)))
656 /* should we jump to the beginning of this procedure?
657 Good points: allows us to use logical names that xlate
659 Bad points: can be a problem if we just translated to a device
661 For now, I'll punt and always expect VMS names, and hope for
664 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
665 { /* no recursion here! */
671 { /* not a directory spec */
676 bracket
= src
[slen
- 1];
678 /* If bracket is ']' or '>', bracket - 2 is the corresponding
680 ptr
= index (src
, bracket
- 2);
682 { /* no opening bracket */
686 if (!(rptr
= rindex (src
, '.')))
689 strncpy (dst
, src
, slen
);
693 dst
[slen
++] = bracket
;
698 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
699 then translate the device and recurse. */
700 if (dst
[slen
- 1] == ':'
701 && dst
[slen
- 2] != ':' /* skip decnet nodes */
702 && strcmp (src
+ slen
, "[000000]") == 0)
704 dst
[slen
- 1] = '\0';
705 if ((ptr
= egetenv (dst
))
706 && (rlen
= strlen (ptr
) - 1) > 0
707 && (ptr
[rlen
] == ']' || ptr
[rlen
] == '>')
708 && ptr
[rlen
- 1] == '.')
710 char * buf
= (char *) alloca (strlen (ptr
) + 1);
714 return directory_file_name (buf
, dst
);
719 strcat (dst
, "[000000]");
723 rlen
= strlen (rptr
) - 1;
724 strncat (dst
, rptr
, rlen
);
725 dst
[slen
+ rlen
] = '\0';
726 strcat (dst
, ".DIR.1");
730 /* Process as Unix format: just remove any final slash.
731 But leave "/" unchanged; do not change it to "". */
734 /* Handle // as root for apollo's. */
735 if ((slen
> 2 && dst
[slen
- 1] == '/')
736 || (slen
> 1 && dst
[0] != '/' && dst
[slen
- 1] == '/'))
740 && IS_DIRECTORY_SEP (dst
[slen
- 1])
742 && !IS_ANY_SEP (dst
[slen
- 2])
748 CORRECT_DIR_SEPS (dst
);
753 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
755 "Returns the file name of the directory named DIRECTORY.\n\
756 This is the name of the file that holds the data for the directory DIRECTORY.\n\
757 This operation exists because a directory is also a file, but its name as\n\
758 a directory is different from its name as a file.\n\
759 In Unix-syntax, this function just removes the final slash.\n\
760 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
761 it returns a file name such as \"[X]Y.DIR.1\".")
763 Lisp_Object directory
;
768 CHECK_STRING (directory
, 0);
770 if (NILP (directory
))
773 /* If the file name has special constructs in it,
774 call the corresponding file handler. */
775 handler
= Ffind_file_name_handler (directory
, Qdirectory_file_name
);
777 return call2 (handler
, Qdirectory_file_name
, directory
);
780 /* 20 extra chars is insufficient for VMS, since we might perform a
781 logical name translation. an equivalence string can be up to 255
782 chars long, so grab that much extra space... - sss */
783 buf
= (char *) alloca (XSTRING (directory
)->size_byte
+ 20 + 255);
785 buf
= (char *) alloca (XSTRING (directory
)->size_byte
+ 20);
787 directory_file_name (XSTRING (directory
)->data
, buf
);
788 return build_string (buf
);
791 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
792 "Generate temporary file name (string) starting with PREFIX (a string).\n\
793 The Emacs process number forms part of the result,\n\
794 so there is no danger of generating a name being used by another process.\n\
795 In addition, this function makes an attempt to choose a name\n\
796 which has no existing file.")
802 /* Don't use too many characters of the restricted 8+3 DOS
804 val
= concat2 (prefix
, build_string ("a.XXX"));
806 val
= concat2 (prefix
, build_string ("XXXXXX"));
808 mktemp (XSTRING (val
)->data
);
810 CORRECT_DIR_SEPS (XSTRING (val
)->data
);
815 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
816 "Convert filename NAME to absolute, and canonicalize it.\n\
817 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative\n\
818 (does not start with slash); if DEFAULT-DIRECTORY is nil or missing,\n\
819 the current buffer's value of default-directory is used.\n\
820 File name components that are `.' are removed, and \n\
821 so are file name components followed by `..', along with the `..' itself;\n\
822 note that these simplifications are done without checking the resulting\n\
823 file names in the file system.\n\
824 An initial `~/' expands to your home directory.\n\
825 An initial `~USER/' expands to USER's home directory.\n\
826 See also the function `substitute-in-file-name'.")
827 (name
, default_directory
)
828 Lisp_Object name
, default_directory
;
832 register unsigned char *newdir
, *p
, *o
;
834 unsigned char *target
;
837 unsigned char * colon
= 0;
838 unsigned char * close
= 0;
839 unsigned char * slash
= 0;
840 unsigned char * brack
= 0;
841 int lbrack
= 0, rbrack
= 0;
846 int collapse_newdir
= 1;
851 CHECK_STRING (name
, 0);
853 /* If the file name has special constructs in it,
854 call the corresponding file handler. */
855 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
857 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
859 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
860 if (NILP (default_directory
))
861 default_directory
= current_buffer
->directory
;
862 if (! STRINGP (default_directory
))
863 default_directory
= build_string ("/");
865 if (!NILP (default_directory
))
867 handler
= Ffind_file_name_handler (default_directory
, Qexpand_file_name
);
869 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
872 o
= XSTRING (default_directory
)->data
;
874 /* Make sure DEFAULT_DIRECTORY is properly expanded.
875 It would be better to do this down below where we actually use
876 default_directory. Unfortunately, calling Fexpand_file_name recursively
877 could invoke GC, and the strings might be relocated. This would
878 be annoying because we have pointers into strings lying around
879 that would need adjusting, and people would add new pointers to
880 the code and forget to adjust them, resulting in intermittent bugs.
881 Putting this call here avoids all that crud.
883 The EQ test avoids infinite recursion. */
884 if (! NILP (default_directory
) && !EQ (default_directory
, name
)
885 /* Save time in some common cases - as long as default_directory
886 is not relative, it can be canonicalized with name below (if it
887 is needed at all) without requiring it to be expanded now. */
889 /* Detect MSDOS file names with drive specifiers. */
890 && ! (IS_DRIVE (o
[0]) && (IS_DEVICE_SEP (o
[1]) && IS_DIRECTORY_SEP (o
[2])))
892 /* Detect Windows file names in UNC format. */
893 && ! (IS_DIRECTORY_SEP (o
[0]) && IS_DIRECTORY_SEP (o
[1]))
895 #else /* not DOS_NT */
896 /* Detect Unix absolute file names (/... alone is not absolute on
898 && ! (IS_DIRECTORY_SEP (o
[0]))
899 #endif /* not DOS_NT */
905 default_directory
= Fexpand_file_name (default_directory
, Qnil
);
910 /* Filenames on VMS are always upper case. */
911 name
= Fupcase (name
);
913 #ifdef FILE_SYSTEM_CASE
914 name
= FILE_SYSTEM_CASE (name
);
917 nm
= XSTRING (name
)->data
;
920 /* We will force directory separators to be either all \ or /, so make
921 a local copy to modify, even if there ends up being no change. */
922 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
924 /* Find and remove drive specifier if present; this makes nm absolute
925 even if the rest of the name appears to be relative. */
927 unsigned char *colon
= rindex (nm
, ':');
930 /* Only recognize colon as part of drive specifier if there is a
931 single alphabetic character preceeding the colon (and if the
932 character before the drive letter, if present, is a directory
933 separator); this is to support the remote system syntax used by
934 ange-ftp, and the "po:username" syntax for POP mailboxes. */
938 else if (IS_DRIVE (colon
[-1])
939 && (colon
== nm
+ 1 || IS_DIRECTORY_SEP (colon
[-2])))
946 while (--colon
>= nm
)
953 /* If we see "c://somedir", we want to strip the first slash after the
954 colon when stripping the drive letter. Otherwise, this expands to
956 if (drive
&& IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
958 #endif /* WINDOWSNT */
962 /* Discard any previous drive specifier if nm is now in UNC format. */
963 if (IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
969 /* If nm is absolute, look for /./ or /../ sequences; if none are
970 found, we can probably return right away. We will avoid allocating
971 a new string if name is already fully expanded. */
973 IS_DIRECTORY_SEP (nm
[0])
978 && (drive
|| IS_DIRECTORY_SEP (nm
[1]))
985 /* If it turns out that the filename we want to return is just a
986 suffix of FILENAME, we don't need to go through and edit
987 things; we just need to construct a new string using data
988 starting at the middle of FILENAME. If we set lose to a
989 non-zero value, that means we've discovered that we can't do
996 /* Since we know the name is absolute, we can assume that each
997 element starts with a "/". */
999 /* "." and ".." are hairy. */
1000 if (IS_DIRECTORY_SEP (p
[0])
1002 && (IS_DIRECTORY_SEP (p
[2])
1004 || (p
[2] == '.' && (IS_DIRECTORY_SEP (p
[3])
1011 /* if dev:[dir]/, move nm to / */
1012 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1013 nm
= (brack
? brack
+ 1 : colon
+ 1);
1014 lbrack
= rbrack
= 0;
1022 /* VMS pre V4.4,convert '-'s in filenames. */
1023 if (lbrack
== rbrack
)
1025 if (dots
< 2) /* this is to allow negative version numbers */
1030 if (lbrack
> rbrack
&&
1031 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1032 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1038 /* count open brackets, reset close bracket pointer */
1039 if (p
[0] == '[' || p
[0] == '<')
1040 lbrack
++, brack
= 0;
1041 /* count close brackets, set close bracket pointer */
1042 if (p
[0] == ']' || p
[0] == '>')
1043 rbrack
++, brack
= p
;
1044 /* detect ][ or >< */
1045 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1047 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1048 nm
= p
+ 1, lose
= 1;
1049 if (p
[0] == ':' && (colon
|| slash
))
1050 /* if dev1:[dir]dev2:, move nm to dev2: */
1056 /* if /name/dev:, move nm to dev: */
1059 /* if node::dev:, move colon following dev */
1060 else if (colon
&& colon
[-1] == ':')
1062 /* if dev1:dev2:, move nm to dev2: */
1063 else if (colon
&& colon
[-1] != ':')
1068 if (p
[0] == ':' && !colon
)
1074 if (lbrack
== rbrack
)
1077 else if (p
[0] == '.')
1085 if (index (nm
, '/'))
1086 return build_string (sys_translate_unix (nm
));
1089 /* Make sure directories are all separated with / or \ as
1090 desired, but avoid allocation of a new string when not
1092 CORRECT_DIR_SEPS (nm
);
1094 if (IS_DIRECTORY_SEP (nm
[1]))
1096 if (strcmp (nm
, XSTRING (name
)->data
) != 0)
1097 name
= build_string (nm
);
1101 /* drive must be set, so this is okay */
1102 if (strcmp (nm
- 2, XSTRING (name
)->data
) != 0)
1104 name
= make_string (nm
- 2, p
- nm
+ 2);
1105 XSTRING (name
)->data
[0] = DRIVE_LETTER (drive
);
1106 XSTRING (name
)->data
[1] = ':';
1109 #else /* not DOS_NT */
1110 if (nm
== XSTRING (name
)->data
)
1112 return build_string (nm
);
1113 #endif /* not DOS_NT */
1117 /* At this point, nm might or might not be an absolute file name. We
1118 need to expand ~ or ~user if present, otherwise prefix nm with
1119 default_directory if nm is not absolute, and finally collapse /./
1120 and /foo/../ sequences.
1122 We set newdir to be the appropriate prefix if one is needed:
1123 - the relevant user directory if nm starts with ~ or ~user
1124 - the specified drive's working dir (DOS/NT only) if nm does not
1126 - the value of default_directory.
1128 Note that these prefixes are not guaranteed to be absolute (except
1129 for the working dir of a drive). Therefore, to ensure we always
1130 return an absolute name, if the final prefix is not absolute we
1131 append it to the current working directory. */
1135 if (nm
[0] == '~') /* prefix ~ */
1137 if (IS_DIRECTORY_SEP (nm
[1])
1141 || nm
[1] == 0) /* ~ by itself */
1143 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1144 newdir
= (unsigned char *) "";
1147 collapse_newdir
= 0;
1150 nm
++; /* Don't leave the slash in nm. */
1153 else /* ~user/filename */
1155 for (p
= nm
; *p
&& (!IS_DIRECTORY_SEP (*p
)
1160 o
= (unsigned char *) alloca (p
- nm
+ 1);
1161 bcopy ((char *) nm
, o
, p
- nm
);
1164 pw
= (struct passwd
*) getpwnam (o
+ 1);
1167 newdir
= (unsigned char *) pw
-> pw_dir
;
1169 nm
= p
+ 1; /* skip the terminator */
1173 collapse_newdir
= 0;
1178 /* If we don't find a user of that name, leave the name
1179 unchanged; don't move nm forward to p. */
1184 /* On DOS and Windows, nm is absolute if a drive name was specified;
1185 use the drive's current directory as the prefix if needed. */
1186 if (!newdir
&& drive
)
1188 /* Get default directory if needed to make nm absolute. */
1189 if (!IS_DIRECTORY_SEP (nm
[0]))
1191 newdir
= alloca (MAXPATHLEN
+ 1);
1192 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1197 /* Either nm starts with /, or drive isn't mounted. */
1198 newdir
= alloca (4);
1199 newdir
[0] = DRIVE_LETTER (drive
);
1207 /* Finally, if no prefix has been specified and nm is not absolute,
1208 then it must be expanded relative to default_directory. */
1212 /* /... alone is not absolute on DOS and Windows. */
1213 && !IS_DIRECTORY_SEP (nm
[0])
1216 && !(IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1223 newdir
= XSTRING (default_directory
)->data
;
1229 /* First ensure newdir is an absolute name. */
1231 /* Detect MSDOS file names with drive specifiers. */
1232 ! (IS_DRIVE (newdir
[0])
1233 && IS_DEVICE_SEP (newdir
[1]) && IS_DIRECTORY_SEP (newdir
[2]))
1235 /* Detect Windows file names in UNC format. */
1236 && ! (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1240 /* Effectively, let newdir be (expand-file-name newdir cwd).
1241 Because of the admonition against calling expand-file-name
1242 when we have pointers into lisp strings, we accomplish this
1243 indirectly by prepending newdir to nm if necessary, and using
1244 cwd (or the wd of newdir's drive) as the new newdir. */
1246 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1251 if (!IS_DIRECTORY_SEP (nm
[0]))
1253 char * tmp
= alloca (strlen (newdir
) + strlen (nm
) + 2);
1254 file_name_as_directory (tmp
, newdir
);
1258 newdir
= alloca (MAXPATHLEN
+ 1);
1261 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1268 /* Strip off drive name from prefix, if present. */
1269 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1275 /* Keep only a prefix from newdir if nm starts with slash
1276 (//server/share for UNC, nothing otherwise). */
1277 if (IS_DIRECTORY_SEP (nm
[0]) && collapse_newdir
)
1280 if (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1282 newdir
= strcpy (alloca (strlen (newdir
) + 1), newdir
);
1284 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1286 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1298 /* Get rid of any slash at the end of newdir, unless newdir is
1299 just // (an incomplete UNC name). */
1300 length
= strlen (newdir
);
1301 if (length
> 0 && IS_DIRECTORY_SEP (newdir
[length
- 1])
1303 && !(length
== 2 && IS_DIRECTORY_SEP (newdir
[0]))
1307 unsigned char *temp
= (unsigned char *) alloca (length
);
1308 bcopy (newdir
, temp
, length
- 1);
1309 temp
[length
- 1] = 0;
1317 /* Now concatenate the directory and name to new space in the stack frame */
1318 tlen
+= strlen (nm
) + 1;
1320 /* Add reserved space for drive name. (The Microsoft x86 compiler
1321 produces incorrect code if the following two lines are combined.) */
1322 target
= (unsigned char *) alloca (tlen
+ 2);
1324 #else /* not DOS_NT */
1325 target
= (unsigned char *) alloca (tlen
);
1326 #endif /* not DOS_NT */
1332 if (nm
[0] == 0 || IS_DIRECTORY_SEP (nm
[0]))
1333 strcpy (target
, newdir
);
1336 file_name_as_directory (target
, newdir
);
1339 strcat (target
, nm
);
1341 if (index (target
, '/'))
1342 strcpy (target
, sys_translate_unix (target
));
1345 /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */
1347 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1355 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1361 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1362 /* brackets are offset from each other by 2 */
1365 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1366 /* convert [foo][bar] to [bar] */
1367 while (o
[-1] != '[' && o
[-1] != '<')
1369 else if (*p
== '-' && *o
!= '.')
1372 else if (p
[0] == '-' && o
[-1] == '.' &&
1373 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1374 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1378 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1379 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1381 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1383 /* else [foo.-] ==> [-] */
1389 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1390 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1396 if (!IS_DIRECTORY_SEP (*p
))
1400 else if (IS_DIRECTORY_SEP (p
[0])
1402 && (IS_DIRECTORY_SEP (p
[2])
1405 /* If "/." is the entire filename, keep the "/". Otherwise,
1406 just delete the whole "/.". */
1407 if (o
== target
&& p
[2] == '\0')
1411 else if (IS_DIRECTORY_SEP (p
[0]) && p
[1] == '.' && p
[2] == '.'
1412 /* `/../' is the "superroot" on certain file systems. */
1414 && (IS_DIRECTORY_SEP (p
[3]) || p
[3] == 0))
1416 while (o
!= target
&& (--o
) && !IS_DIRECTORY_SEP (*o
))
1418 /* Keep initial / only if this is the whole name. */
1419 if (o
== target
&& IS_ANY_SEP (*o
) && p
[3] == 0)
1427 #endif /* not VMS */
1431 /* At last, set drive name. */
1433 /* Except for network file name. */
1434 if (!(IS_DIRECTORY_SEP (target
[0]) && IS_DIRECTORY_SEP (target
[1])))
1435 #endif /* WINDOWSNT */
1437 if (!drive
) abort ();
1439 target
[0] = DRIVE_LETTER (drive
);
1442 CORRECT_DIR_SEPS (target
);
1445 return make_string (target
, o
- target
);
1449 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'. */
1450 DEAFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
1451 "Convert FILENAME to absolute, and canonicalize it.\n\
1452 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1453 (does not start with slash); if DEFAULT is nil or missing,\n\
1454 the current buffer's value of default-directory is used.\n\
1455 Filenames containing `.' or `..' as components are simplified;\n\
1456 initial `~/' expands to your home directory.\n\
1457 See also the function `substitute-in-file-name'.")
1459 Lisp_Object name
, defalt
;
1463 register unsigned char *newdir
, *p
, *o
;
1465 unsigned char *target
;
1469 unsigned char * colon
= 0;
1470 unsigned char * close
= 0;
1471 unsigned char * slash
= 0;
1472 unsigned char * brack
= 0;
1473 int lbrack
= 0, rbrack
= 0;
1477 CHECK_STRING (name
, 0);
1480 /* Filenames on VMS are always upper case. */
1481 name
= Fupcase (name
);
1484 nm
= XSTRING (name
)->data
;
1486 /* If nm is absolute, flush ...// and detect /./ and /../.
1487 If no /./ or /../ we can return right away. */
1499 if (p
[0] == '/' && p
[1] == '/'
1501 /* // at start of filename is meaningful on Apollo system. */
1506 if (p
[0] == '/' && p
[1] == '~')
1507 nm
= p
+ 1, lose
= 1;
1508 if (p
[0] == '/' && p
[1] == '.'
1509 && (p
[2] == '/' || p
[2] == 0
1510 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1516 /* if dev:[dir]/, move nm to / */
1517 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1518 nm
= (brack
? brack
+ 1 : colon
+ 1);
1519 lbrack
= rbrack
= 0;
1527 /* VMS pre V4.4,convert '-'s in filenames. */
1528 if (lbrack
== rbrack
)
1530 if (dots
< 2) /* this is to allow negative version numbers */
1535 if (lbrack
> rbrack
&&
1536 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1537 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1543 /* count open brackets, reset close bracket pointer */
1544 if (p
[0] == '[' || p
[0] == '<')
1545 lbrack
++, brack
= 0;
1546 /* count close brackets, set close bracket pointer */
1547 if (p
[0] == ']' || p
[0] == '>')
1548 rbrack
++, brack
= p
;
1549 /* detect ][ or >< */
1550 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1552 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1553 nm
= p
+ 1, lose
= 1;
1554 if (p
[0] == ':' && (colon
|| slash
))
1555 /* if dev1:[dir]dev2:, move nm to dev2: */
1561 /* If /name/dev:, move nm to dev: */
1564 /* If node::dev:, move colon following dev */
1565 else if (colon
&& colon
[-1] == ':')
1567 /* If dev1:dev2:, move nm to dev2: */
1568 else if (colon
&& colon
[-1] != ':')
1573 if (p
[0] == ':' && !colon
)
1579 if (lbrack
== rbrack
)
1582 else if (p
[0] == '.')
1590 if (index (nm
, '/'))
1591 return build_string (sys_translate_unix (nm
));
1593 if (nm
== XSTRING (name
)->data
)
1595 return build_string (nm
);
1599 /* Now determine directory to start with and put it in NEWDIR */
1603 if (nm
[0] == '~') /* prefix ~ */
1608 || nm
[1] == 0)/* ~/filename */
1610 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1611 newdir
= (unsigned char *) "";
1614 nm
++; /* Don't leave the slash in nm. */
1617 else /* ~user/filename */
1619 /* Get past ~ to user */
1620 unsigned char *user
= nm
+ 1;
1621 /* Find end of name. */
1622 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1623 int len
= ptr
? ptr
- user
: strlen (user
);
1625 unsigned char *ptr1
= index (user
, ':');
1626 if (ptr1
!= 0 && ptr1
- user
< len
)
1629 /* Copy the user name into temp storage. */
1630 o
= (unsigned char *) alloca (len
+ 1);
1631 bcopy ((char *) user
, o
, len
);
1634 /* Look up the user name. */
1635 pw
= (struct passwd
*) getpwnam (o
+ 1);
1637 error ("\"%s\" isn't a registered user", o
+ 1);
1639 newdir
= (unsigned char *) pw
->pw_dir
;
1641 /* Discard the user name from NM. */
1648 #endif /* not VMS */
1652 defalt
= current_buffer
->directory
;
1653 CHECK_STRING (defalt
, 1);
1654 newdir
= XSTRING (defalt
)->data
;
1657 /* Now concatenate the directory and name to new space in the stack frame */
1659 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1660 target
= (unsigned char *) alloca (tlen
);
1666 if (nm
[0] == 0 || nm
[0] == '/')
1667 strcpy (target
, newdir
);
1670 file_name_as_directory (target
, newdir
);
1673 strcat (target
, nm
);
1675 if (index (target
, '/'))
1676 strcpy (target
, sys_translate_unix (target
));
1679 /* Now canonicalize by removing /. and /foo/.. if they appear */
1687 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1693 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1694 /* brackets are offset from each other by 2 */
1697 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1698 /* convert [foo][bar] to [bar] */
1699 while (o
[-1] != '[' && o
[-1] != '<')
1701 else if (*p
== '-' && *o
!= '.')
1704 else if (p
[0] == '-' && o
[-1] == '.' &&
1705 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1706 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1710 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1711 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1713 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1715 /* else [foo.-] ==> [-] */
1721 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1722 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1732 else if (!strncmp (p
, "//", 2)
1734 /* // at start of filename is meaningful in Apollo system. */
1742 else if (p
[0] == '/' && p
[1] == '.' &&
1743 (p
[2] == '/' || p
[2] == 0))
1745 else if (!strncmp (p
, "/..", 3)
1746 /* `/../' is the "superroot" on certain file systems. */
1748 && (p
[3] == '/' || p
[3] == 0))
1750 while (o
!= target
&& *--o
!= '/')
1753 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1757 if (o
== target
&& *o
== '/')
1765 #endif /* not VMS */
1768 return make_string (target
, o
- target
);
1772 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1773 Ssubstitute_in_file_name
, 1, 1, 0,
1774 "Substitute environment variables referred to in FILENAME.\n\
1775 `$FOO' where FOO is an environment variable name means to substitute\n\
1776 the value of that variable. The variable name should be terminated\n\
1777 with a character not a letter, digit or underscore; otherwise, enclose\n\
1778 the entire variable name in braces.\n\
1779 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1780 On VMS, `$' substitution is not done; this function does little and only\n\
1781 duplicates what `expand-file-name' does.")
1783 Lisp_Object filename
;
1787 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1788 unsigned char *target
;
1790 int substituted
= 0;
1792 Lisp_Object handler
;
1794 CHECK_STRING (filename
, 0);
1796 /* If the file name has special constructs in it,
1797 call the corresponding file handler. */
1798 handler
= Ffind_file_name_handler (filename
, Qsubstitute_in_file_name
);
1799 if (!NILP (handler
))
1800 return call2 (handler
, Qsubstitute_in_file_name
, filename
);
1802 nm
= XSTRING (filename
)->data
;
1804 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
1805 CORRECT_DIR_SEPS (nm
);
1806 substituted
= (strcmp (nm
, XSTRING (filename
)->data
) != 0);
1808 endp
= nm
+ XSTRING (filename
)->size_byte
;
1810 /* If /~ or // appears, discard everything through first slash. */
1812 for (p
= nm
; p
!= endp
; p
++)
1815 #if defined (APOLLO) || defined (WINDOWSNT)
1816 /* // at start of file name is meaningful in Apollo and
1817 WindowsNT systems. */
1818 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != nm
)
1819 #else /* not (APOLLO || WINDOWSNT) */
1820 || IS_DIRECTORY_SEP (p
[0])
1821 #endif /* not (APOLLO || WINDOWSNT) */
1826 || p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>'
1828 || IS_DIRECTORY_SEP (p
[-1])))
1834 /* see comment in expand-file-name about drive specifiers */
1835 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
1836 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
1845 return build_string (nm
);
1848 /* See if any variables are substituted into the string
1849 and find the total length of their values in `total' */
1851 for (p
= nm
; p
!= endp
;)
1861 /* "$$" means a single "$" */
1870 while (p
!= endp
&& *p
!= '}') p
++;
1871 if (*p
!= '}') goto missingclose
;
1877 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1881 /* Copy out the variable name */
1882 target
= (unsigned char *) alloca (s
- o
+ 1);
1883 strncpy (target
, o
, s
- o
);
1886 strupr (target
); /* $home == $HOME etc. */
1889 /* Get variable value */
1890 o
= (unsigned char *) egetenv (target
);
1891 if (!o
) goto badvar
;
1892 total
+= strlen (o
);
1899 /* If substitution required, recopy the string and do it */
1900 /* Make space in stack frame for the new copy */
1901 xnm
= (unsigned char *) alloca (XSTRING (filename
)->size_byte
+ total
+ 1);
1904 /* Copy the rest of the name through, replacing $ constructs with values */
1921 while (p
!= endp
&& *p
!= '}') p
++;
1922 if (*p
!= '}') goto missingclose
;
1928 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1932 /* Copy out the variable name */
1933 target
= (unsigned char *) alloca (s
- o
+ 1);
1934 strncpy (target
, o
, s
- o
);
1937 strupr (target
); /* $home == $HOME etc. */
1940 /* Get variable value */
1941 o
= (unsigned char *) egetenv (target
);
1945 if (STRING_MULTIBYTE (filename
))
1947 /* If the original string is multibyte,
1948 convert what we substitute into multibyte. */
1949 unsigned char workbuf
[4], *str
;
1955 c
= unibyte_char_to_multibyte (c
);
1956 if (! SINGLE_BYTE_CHAR_P (c
))
1958 len
= CHAR_STRING (c
, workbuf
, str
);
1959 bcopy (str
, x
, len
);
1975 /* If /~ or // appears, discard everything through first slash. */
1977 for (p
= xnm
; p
!= x
; p
++)
1979 #if defined (APOLLO) || defined (WINDOWSNT)
1980 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != xnm
)
1981 #else /* not (APOLLO || WINDOWSNT) */
1982 || IS_DIRECTORY_SEP (p
[0])
1983 #endif /* not (APOLLO || WINDOWSNT) */
1985 && p
!= xnm
&& IS_DIRECTORY_SEP (p
[-1]))
1988 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
1989 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
1993 if (STRING_MULTIBYTE (filename
))
1994 return make_string (xnm
, x
- xnm
);
1995 return make_unibyte_string (xnm
, x
- xnm
);
1998 error ("Bad format environment-variable substitution");
2000 error ("Missing \"}\" in environment-variable substitution");
2002 error ("Substituting nonexistent environment variable \"%s\"", target
);
2005 #endif /* not VMS */
2008 /* A slightly faster and more convenient way to get
2009 (directory-file-name (expand-file-name FOO)). */
2012 expand_and_dir_to_file (filename
, defdir
)
2013 Lisp_Object filename
, defdir
;
2015 register Lisp_Object absname
;
2017 absname
= Fexpand_file_name (filename
, defdir
);
2020 register int c
= XSTRING (absname
)->data
[XSTRING (absname
)->size_byte
- 1];
2021 if (c
== ':' || c
== ']' || c
== '>')
2022 absname
= Fdirectory_file_name (absname
);
2025 /* Remove final slash, if any (unless this is the root dir).
2026 stat behaves differently depending! */
2027 if (XSTRING (absname
)->size
> 1
2028 && IS_DIRECTORY_SEP (XSTRING (absname
)->data
[XSTRING (absname
)->size_byte
- 1])
2029 && !IS_DEVICE_SEP (XSTRING (absname
)->data
[XSTRING (absname
)->size_byte
-2]))
2030 /* We cannot take shortcuts; they might be wrong for magic file names. */
2031 absname
= Fdirectory_file_name (absname
);
2036 /* Signal an error if the file ABSNAME already exists.
2037 If INTERACTIVE is nonzero, ask the user whether to proceed,
2038 and bypass the error if the user says to go ahead.
2039 QUERYSTRING is a name for the action that is being considered
2042 *STATPTR is used to store the stat information if the file exists.
2043 If the file does not exist, STATPTR->st_mode is set to 0.
2044 If STATPTR is null, we don't store into it. */
2047 barf_or_query_if_file_exists (absname
, querystring
, interactive
, statptr
)
2048 Lisp_Object absname
;
2049 unsigned char *querystring
;
2051 struct stat
*statptr
;
2053 register Lisp_Object tem
;
2054 struct stat statbuf
;
2055 struct gcpro gcpro1
;
2057 /* stat is a good way to tell whether the file exists,
2058 regardless of what access permissions it has. */
2059 if (stat (XSTRING (absname
)->data
, &statbuf
) >= 0)
2062 Fsignal (Qfile_already_exists
,
2063 Fcons (build_string ("File already exists"),
2064 Fcons (absname
, Qnil
)));
2066 tem
= do_yes_or_no_p (format1 ("File %s already exists; %s anyway? ",
2067 XSTRING (absname
)->data
, querystring
));
2070 Fsignal (Qfile_already_exists
,
2071 Fcons (build_string ("File already exists"),
2072 Fcons (absname
, Qnil
)));
2079 statptr
->st_mode
= 0;
2084 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
2085 "fCopy file: \nFCopy %s to file: \np\nP",
2086 "Copy FILE to NEWNAME. Both args must be strings.\n\
2087 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
2088 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
2089 A number as third arg means request confirmation if NEWNAME already exists.\n\
2090 This is what happens in interactive use with M-x.\n\
2091 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
2092 last-modified time as the old one. (This works on only some systems.)\n\
2093 A prefix arg makes KEEP-TIME non-nil.")
2094 (file
, newname
, ok_if_already_exists
, keep_date
)
2095 Lisp_Object file
, newname
, ok_if_already_exists
, keep_date
;
2098 char buf
[16 * 1024];
2099 struct stat st
, out_st
;
2100 Lisp_Object handler
;
2101 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2102 int count
= specpdl_ptr
- specpdl
;
2103 int input_file_statable_p
;
2104 Lisp_Object encoded_file
, encoded_newname
;
2106 encoded_file
= encoded_newname
= Qnil
;
2107 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2108 CHECK_STRING (file
, 0);
2109 CHECK_STRING (newname
, 1);
2111 file
= Fexpand_file_name (file
, Qnil
);
2112 newname
= Fexpand_file_name (newname
, Qnil
);
2114 /* If the input file name has special constructs in it,
2115 call the corresponding file handler. */
2116 handler
= Ffind_file_name_handler (file
, Qcopy_file
);
2117 /* Likewise for output file name. */
2119 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
2120 if (!NILP (handler
))
2121 RETURN_UNGCPRO (call5 (handler
, Qcopy_file
, file
, newname
,
2122 ok_if_already_exists
, keep_date
));
2124 encoded_file
= ENCODE_FILE (file
);
2125 encoded_newname
= ENCODE_FILE (newname
);
2127 if (NILP (ok_if_already_exists
)
2128 || INTEGERP (ok_if_already_exists
))
2129 barf_or_query_if_file_exists (encoded_newname
, "copy to it",
2130 INTEGERP (ok_if_already_exists
), &out_st
);
2131 else if (stat (XSTRING (encoded_newname
)->data
, &out_st
) < 0)
2134 ifd
= open (XSTRING (encoded_file
)->data
, O_RDONLY
);
2136 report_file_error ("Opening input file", Fcons (file
, Qnil
));
2138 record_unwind_protect (close_file_unwind
, make_number (ifd
));
2140 /* We can only copy regular files and symbolic links. Other files are not
2142 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
2144 #if !defined (MSDOS) || __DJGPP__ > 1
2145 if (out_st
.st_mode
!= 0
2146 && st
.st_dev
== out_st
.st_dev
&& st
.st_ino
== out_st
.st_ino
)
2149 report_file_error ("Input and output files are the same",
2150 Fcons (file
, Fcons (newname
, Qnil
)));
2154 #if defined (S_ISREG) && defined (S_ISLNK)
2155 if (input_file_statable_p
)
2157 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
2159 #if defined (EISDIR)
2160 /* Get a better looking error message. */
2163 report_file_error ("Non-regular file", Fcons (file
, Qnil
));
2166 #endif /* S_ISREG && S_ISLNK */
2169 /* Create the copy file with the same record format as the input file */
2170 ofd
= sys_creat (XSTRING (encoded_newname
)->data
, 0666, ifd
);
2173 /* System's default file type was set to binary by _fmode in emacs.c. */
2174 ofd
= creat (XSTRING (encoded_newname
)->data
, S_IREAD
| S_IWRITE
);
2175 #else /* not MSDOS */
2176 ofd
= creat (XSTRING (encoded_newname
)->data
, 0666);
2177 #endif /* not MSDOS */
2180 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
2182 record_unwind_protect (close_file_unwind
, make_number (ofd
));
2186 while ((n
= read (ifd
, buf
, sizeof buf
)) > 0)
2187 if (write (ofd
, buf
, n
) != n
)
2188 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2191 /* Closing the output clobbers the file times on some systems. */
2192 if (close (ofd
) < 0)
2193 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2195 if (input_file_statable_p
)
2197 if (!NILP (keep_date
))
2199 EMACS_TIME atime
, mtime
;
2200 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
2201 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
2202 if (set_file_times (XSTRING (encoded_newname
)->data
,
2204 Fsignal (Qfile_date_error
,
2205 Fcons (build_string ("Cannot set file date"),
2206 Fcons (newname
, Qnil
)));
2209 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2211 #if defined (__DJGPP__) && __DJGPP__ > 1
2212 /* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
2213 and if it can't, it tells so. Otherwise, under MSDOS we usually
2214 get only the READ bit, which will make the copied file read-only,
2215 so it's better not to chmod at all. */
2216 if ((_djstat_flags
& _STFAIL_WRITEBIT
) == 0)
2217 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2218 #endif /* DJGPP version 2 or newer */
2224 /* Discard the unwind protects. */
2225 specpdl_ptr
= specpdl
+ count
;
2231 DEFUN ("make-directory-internal", Fmake_directory_internal
,
2232 Smake_directory_internal
, 1, 1, 0,
2233 "Create a new directory named DIRECTORY.")
2235 Lisp_Object directory
;
2238 Lisp_Object handler
;
2239 Lisp_Object encoded_dir
;
2241 CHECK_STRING (directory
, 0);
2242 directory
= Fexpand_file_name (directory
, Qnil
);
2244 handler
= Ffind_file_name_handler (directory
, Qmake_directory_internal
);
2245 if (!NILP (handler
))
2246 return call2 (handler
, Qmake_directory_internal
, directory
);
2248 encoded_dir
= ENCODE_FILE (directory
);
2250 dir
= XSTRING (encoded_dir
)->data
;
2253 if (mkdir (dir
) != 0)
2255 if (mkdir (dir
, 0777) != 0)
2257 report_file_error ("Creating directory", Flist (1, &directory
));
2262 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
2263 "Delete the directory named DIRECTORY.")
2265 Lisp_Object directory
;
2268 Lisp_Object handler
;
2269 Lisp_Object encoded_dir
;
2271 CHECK_STRING (directory
, 0);
2272 directory
= Fdirectory_file_name (Fexpand_file_name (directory
, Qnil
));
2274 handler
= Ffind_file_name_handler (directory
, Qdelete_directory
);
2275 if (!NILP (handler
))
2276 return call2 (handler
, Qdelete_directory
, directory
);
2278 encoded_dir
= ENCODE_FILE (directory
);
2280 dir
= XSTRING (encoded_dir
)->data
;
2282 if (rmdir (dir
) != 0)
2283 report_file_error ("Removing directory", Flist (1, &directory
));
2288 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
2289 "Delete file named FILENAME.\n\
2290 If file has multiple names, it continues to exist with the other names.")
2292 Lisp_Object filename
;
2294 Lisp_Object handler
;
2295 Lisp_Object encoded_file
;
2297 CHECK_STRING (filename
, 0);
2298 filename
= Fexpand_file_name (filename
, Qnil
);
2300 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
2301 if (!NILP (handler
))
2302 return call2 (handler
, Qdelete_file
, filename
);
2304 encoded_file
= ENCODE_FILE (filename
);
2306 if (0 > unlink (XSTRING (encoded_file
)->data
))
2307 report_file_error ("Removing old name", Flist (1, &filename
));
2312 internal_delete_file_1 (ignore
)
2318 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */
2321 internal_delete_file (filename
)
2322 Lisp_Object filename
;
2324 return NILP (internal_condition_case_1 (Fdelete_file
, filename
,
2325 Qt
, internal_delete_file_1
));
2328 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
2329 "fRename file: \nFRename %s to file: \np",
2330 "Rename FILE as NEWNAME. Both args strings.\n\
2331 If file has names other than FILE, it continues to have those names.\n\
2332 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2333 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2334 A number as third arg means request confirmation if NEWNAME already exists.\n\
2335 This is what happens in interactive use with M-x.")
2336 (file
, newname
, ok_if_already_exists
)
2337 Lisp_Object file
, newname
, ok_if_already_exists
;
2340 Lisp_Object args
[2];
2342 Lisp_Object handler
;
2343 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2344 Lisp_Object encoded_file
, encoded_newname
;
2346 encoded_file
= encoded_newname
= Qnil
;
2347 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2348 CHECK_STRING (file
, 0);
2349 CHECK_STRING (newname
, 1);
2350 file
= Fexpand_file_name (file
, Qnil
);
2351 newname
= Fexpand_file_name (newname
, Qnil
);
2353 /* If the file name has special constructs in it,
2354 call the corresponding file handler. */
2355 handler
= Ffind_file_name_handler (file
, Qrename_file
);
2357 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
2358 if (!NILP (handler
))
2359 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
2360 file
, newname
, ok_if_already_exists
));
2362 encoded_file
= ENCODE_FILE (file
);
2363 encoded_newname
= ENCODE_FILE (newname
);
2365 if (NILP (ok_if_already_exists
)
2366 || INTEGERP (ok_if_already_exists
))
2367 barf_or_query_if_file_exists (encoded_newname
, "rename to it",
2368 INTEGERP (ok_if_already_exists
), 0);
2370 if (0 > rename (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2372 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
)
2373 || 0 > unlink (XSTRING (encoded_file
)->data
))
2378 Fcopy_file (file
, newname
,
2379 /* We have already prompted if it was an integer,
2380 so don't have copy-file prompt again. */
2381 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
2382 Fdelete_file (file
);
2389 report_file_error ("Renaming", Flist (2, args
));
2392 report_file_error ("Renaming", Flist (2, &file
));
2399 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
2400 "fAdd name to file: \nFName to add to %s: \np",
2401 "Give FILE additional name NEWNAME. Both args strings.\n\
2402 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2403 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2404 A number as third arg means request confirmation if NEWNAME already exists.\n\
2405 This is what happens in interactive use with M-x.")
2406 (file
, newname
, ok_if_already_exists
)
2407 Lisp_Object file
, newname
, ok_if_already_exists
;
2410 Lisp_Object args
[2];
2412 Lisp_Object handler
;
2413 Lisp_Object encoded_file
, encoded_newname
;
2414 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2416 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2417 encoded_file
= encoded_newname
= Qnil
;
2418 CHECK_STRING (file
, 0);
2419 CHECK_STRING (newname
, 1);
2420 file
= Fexpand_file_name (file
, Qnil
);
2421 newname
= Fexpand_file_name (newname
, Qnil
);
2423 /* If the file name has special constructs in it,
2424 call the corresponding file handler. */
2425 handler
= Ffind_file_name_handler (file
, Qadd_name_to_file
);
2426 if (!NILP (handler
))
2427 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2428 newname
, ok_if_already_exists
));
2430 /* If the new name has special constructs in it,
2431 call the corresponding file handler. */
2432 handler
= Ffind_file_name_handler (newname
, Qadd_name_to_file
);
2433 if (!NILP (handler
))
2434 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2435 newname
, ok_if_already_exists
));
2437 encoded_file
= ENCODE_FILE (file
);
2438 encoded_newname
= ENCODE_FILE (newname
);
2440 if (NILP (ok_if_already_exists
)
2441 || INTEGERP (ok_if_already_exists
))
2442 barf_or_query_if_file_exists (encoded_newname
, "make it a new name",
2443 INTEGERP (ok_if_already_exists
), 0);
2445 unlink (XSTRING (newname
)->data
);
2446 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2451 report_file_error ("Adding new name", Flist (2, args
));
2453 report_file_error ("Adding new name", Flist (2, &file
));
2462 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2463 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2464 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
2465 Signals a `file-already-exists' error if a file LINKNAME already exists\n\
2466 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2467 A number as third arg means request confirmation if LINKNAME already exists.\n\
2468 This happens for interactive use with M-x.")
2469 (filename
, linkname
, ok_if_already_exists
)
2470 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2473 Lisp_Object args
[2];
2475 Lisp_Object handler
;
2476 Lisp_Object encoded_filename
, encoded_linkname
;
2477 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2479 GCPRO4 (filename
, linkname
, encoded_filename
, encoded_linkname
);
2480 encoded_filename
= encoded_linkname
= Qnil
;
2481 CHECK_STRING (filename
, 0);
2482 CHECK_STRING (linkname
, 1);
2483 /* If the link target has a ~, we must expand it to get
2484 a truly valid file name. Otherwise, do not expand;
2485 we want to permit links to relative file names. */
2486 if (XSTRING (filename
)->data
[0] == '~')
2487 filename
= Fexpand_file_name (filename
, Qnil
);
2488 linkname
= Fexpand_file_name (linkname
, Qnil
);
2490 /* If the file name has special constructs in it,
2491 call the corresponding file handler. */
2492 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2493 if (!NILP (handler
))
2494 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2495 linkname
, ok_if_already_exists
));
2497 /* If the new link name has special constructs in it,
2498 call the corresponding file handler. */
2499 handler
= Ffind_file_name_handler (linkname
, Qmake_symbolic_link
);
2500 if (!NILP (handler
))
2501 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2502 linkname
, ok_if_already_exists
));
2504 encoded_filename
= ENCODE_FILE (filename
);
2505 encoded_linkname
= ENCODE_FILE (linkname
);
2507 if (NILP (ok_if_already_exists
)
2508 || INTEGERP (ok_if_already_exists
))
2509 barf_or_query_if_file_exists (encoded_linkname
, "make it a link",
2510 INTEGERP (ok_if_already_exists
), 0);
2511 if (0 > symlink (XSTRING (encoded_filename
)->data
,
2512 XSTRING (encoded_linkname
)->data
))
2514 /* If we didn't complain already, silently delete existing file. */
2515 if (errno
== EEXIST
)
2517 unlink (XSTRING (encoded_linkname
)->data
);
2518 if (0 <= symlink (XSTRING (encoded_filename
)->data
,
2519 XSTRING (encoded_linkname
)->data
))
2529 report_file_error ("Making symbolic link", Flist (2, args
));
2531 report_file_error ("Making symbolic link", Flist (2, &filename
));
2537 #endif /* S_IFLNK */
2541 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2542 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2543 "Define the job-wide logical name NAME to have the value STRING.\n\
2544 If STRING is nil or a null string, the logical name NAME is deleted.")
2549 CHECK_STRING (name
, 0);
2551 delete_logical_name (XSTRING (name
)->data
);
2554 CHECK_STRING (string
, 1);
2556 if (XSTRING (string
)->size
== 0)
2557 delete_logical_name (XSTRING (name
)->data
);
2559 define_logical_name (XSTRING (name
)->data
, XSTRING (string
)->data
);
2568 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2569 "Open a network connection to PATH using LOGIN as the login string.")
2571 Lisp_Object path
, login
;
2575 CHECK_STRING (path
, 0);
2576 CHECK_STRING (login
, 0);
2578 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2580 if (netresult
== -1)
2585 #endif /* HPUX_NET */
2587 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2589 "Return t if file FILENAME specifies an absolute file name.\n\
2590 On Unix, this is a name starting with a `/' or a `~'.")
2592 Lisp_Object filename
;
2596 CHECK_STRING (filename
, 0);
2597 ptr
= XSTRING (filename
)->data
;
2598 if (IS_DIRECTORY_SEP (*ptr
) || *ptr
== '~'
2600 /* ??? This criterion is probably wrong for '<'. */
2601 || index (ptr
, ':') || index (ptr
, '<')
2602 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2606 || (IS_DRIVE (*ptr
) && ptr
[1] == ':' && IS_DIRECTORY_SEP (ptr
[2]))
2614 /* Return nonzero if file FILENAME exists and can be executed. */
2617 check_executable (filename
)
2621 int len
= strlen (filename
);
2624 if (stat (filename
, &st
) < 0)
2626 #if defined (WINDOWSNT) || (defined (MSDOS) && __DJGPP__ > 1)
2627 return ((st
.st_mode
& S_IEXEC
) != 0);
2629 return (S_ISREG (st
.st_mode
)
2631 && (stricmp ((suffix
= filename
+ len
-4), ".com") == 0
2632 || stricmp (suffix
, ".exe") == 0
2633 || stricmp (suffix
, ".bat") == 0)
2634 || (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2635 #endif /* not WINDOWSNT */
2636 #else /* not DOS_NT */
2637 #ifdef HAVE_EUIDACCESS
2638 return (euidaccess (filename
, 1) >= 0);
2640 /* Access isn't quite right because it uses the real uid
2641 and we really want to test with the effective uid.
2642 But Unix doesn't give us a right way to do it. */
2643 return (access (filename
, 1) >= 0);
2645 #endif /* not DOS_NT */
2648 /* Return nonzero if file FILENAME exists and can be written. */
2651 check_writable (filename
)
2656 if (stat (filename
, &st
) < 0)
2658 return (st
.st_mode
& S_IWRITE
|| (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2659 #else /* not MSDOS */
2660 #ifdef HAVE_EUIDACCESS
2661 return (euidaccess (filename
, 2) >= 0);
2663 /* Access isn't quite right because it uses the real uid
2664 and we really want to test with the effective uid.
2665 But Unix doesn't give us a right way to do it.
2666 Opening with O_WRONLY could work for an ordinary file,
2667 but would lose for directories. */
2668 return (access (filename
, 2) >= 0);
2670 #endif /* not MSDOS */
2673 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2674 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
2675 See also `file-readable-p' and `file-attributes'.")
2677 Lisp_Object filename
;
2679 Lisp_Object absname
;
2680 Lisp_Object handler
;
2681 struct stat statbuf
;
2683 CHECK_STRING (filename
, 0);
2684 absname
= Fexpand_file_name (filename
, Qnil
);
2686 /* If the file name has special constructs in it,
2687 call the corresponding file handler. */
2688 handler
= Ffind_file_name_handler (absname
, Qfile_exists_p
);
2689 if (!NILP (handler
))
2690 return call2 (handler
, Qfile_exists_p
, absname
);
2692 absname
= ENCODE_FILE (absname
);
2694 return (stat (XSTRING (absname
)->data
, &statbuf
) >= 0) ? Qt
: Qnil
;
2697 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2698 "Return t if FILENAME can be executed by you.\n\
2699 For a directory, this means you can access files in that directory.")
2701 Lisp_Object filename
;
2704 Lisp_Object absname
;
2705 Lisp_Object handler
;
2707 CHECK_STRING (filename
, 0);
2708 absname
= Fexpand_file_name (filename
, Qnil
);
2710 /* If the file name has special constructs in it,
2711 call the corresponding file handler. */
2712 handler
= Ffind_file_name_handler (absname
, Qfile_executable_p
);
2713 if (!NILP (handler
))
2714 return call2 (handler
, Qfile_executable_p
, absname
);
2716 absname
= ENCODE_FILE (absname
);
2718 return (check_executable (XSTRING (absname
)->data
) ? Qt
: Qnil
);
2721 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2722 "Return t if file FILENAME exists and you can read it.\n\
2723 See also `file-exists-p' and `file-attributes'.")
2725 Lisp_Object filename
;
2727 Lisp_Object absname
;
2728 Lisp_Object handler
;
2731 struct stat statbuf
;
2733 CHECK_STRING (filename
, 0);
2734 absname
= Fexpand_file_name (filename
, Qnil
);
2736 /* If the file name has special constructs in it,
2737 call the corresponding file handler. */
2738 handler
= Ffind_file_name_handler (absname
, Qfile_readable_p
);
2739 if (!NILP (handler
))
2740 return call2 (handler
, Qfile_readable_p
, absname
);
2742 absname
= ENCODE_FILE (absname
);
2745 /* Under MS-DOS and Windows, open does not work for directories. */
2746 if (access (XSTRING (absname
)->data
, 0) == 0)
2749 #else /* not DOS_NT */
2751 #if defined (S_ISFIFO) && defined (O_NONBLOCK)
2752 /* Opening a fifo without O_NONBLOCK can wait.
2753 We don't want to wait. But we don't want to mess wth O_NONBLOCK
2754 except in the case of a fifo, on a system which handles it. */
2755 desc
= stat (XSTRING (absname
)->data
, &statbuf
);
2758 if (S_ISFIFO (statbuf
.st_mode
))
2759 flags
|= O_NONBLOCK
;
2761 desc
= open (XSTRING (absname
)->data
, flags
);
2766 #endif /* not DOS_NT */
2769 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2771 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
2772 "Return t if file FILENAME can be written or created by you.")
2774 Lisp_Object filename
;
2776 Lisp_Object absname
, dir
, encoded
;
2777 Lisp_Object handler
;
2778 struct stat statbuf
;
2780 CHECK_STRING (filename
, 0);
2781 absname
= Fexpand_file_name (filename
, Qnil
);
2783 /* If the file name has special constructs in it,
2784 call the corresponding file handler. */
2785 handler
= Ffind_file_name_handler (absname
, Qfile_writable_p
);
2786 if (!NILP (handler
))
2787 return call2 (handler
, Qfile_writable_p
, absname
);
2789 encoded
= ENCODE_FILE (absname
);
2790 if (stat (XSTRING (encoded
)->data
, &statbuf
) >= 0)
2791 return (check_writable (XSTRING (encoded
)->data
)
2794 dir
= Ffile_name_directory (absname
);
2797 dir
= Fdirectory_file_name (dir
);
2801 dir
= Fdirectory_file_name (dir
);
2804 dir
= ENCODE_FILE (dir
);
2805 return (check_writable (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "")
2809 DEFUN ("access-file", Faccess_file
, Saccess_file
, 2, 2, 0,
2810 "Access file FILENAME, and get an error if that does not work.\n\
2811 The second argument STRING is used in the error message.\n\
2812 If there is no error, we return nil.")
2814 Lisp_Object filename
, string
;
2816 Lisp_Object handler
, encoded_filename
;
2819 CHECK_STRING (filename
, 0);
2821 /* If the file name has special constructs in it,
2822 call the corresponding file handler. */
2823 handler
= Ffind_file_name_handler (filename
, Qaccess_file
);
2824 if (!NILP (handler
))
2825 return call3 (handler
, Qaccess_file
, filename
, string
);
2827 encoded_filename
= ENCODE_FILE (filename
);
2829 fd
= open (XSTRING (encoded_filename
)->data
, O_RDONLY
);
2831 report_file_error (XSTRING (string
)->data
, Fcons (filename
, Qnil
));
2837 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
2838 "Return non-nil if file FILENAME is the name of a symbolic link.\n\
2839 The value is the name of the file to which it is linked.\n\
2840 Otherwise returns nil.")
2842 Lisp_Object filename
;
2849 Lisp_Object handler
;
2851 CHECK_STRING (filename
, 0);
2852 filename
= Fexpand_file_name (filename
, Qnil
);
2854 /* If the file name has special constructs in it,
2855 call the corresponding file handler. */
2856 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
2857 if (!NILP (handler
))
2858 return call2 (handler
, Qfile_symlink_p
, filename
);
2860 filename
= ENCODE_FILE (filename
);
2865 buf
= (char *) xmalloc (bufsize
);
2866 bzero (buf
, bufsize
);
2867 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
2868 if (valsize
< bufsize
) break;
2869 /* Buffer was not long enough */
2878 val
= make_string (buf
, valsize
);
2880 val
= DECODE_FILE (val
);
2882 #else /* not S_IFLNK */
2884 #endif /* not S_IFLNK */
2887 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
2888 "Return t if FILENAME names an existing directory.")
2890 Lisp_Object filename
;
2892 register Lisp_Object absname
;
2894 Lisp_Object handler
;
2896 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2898 /* If the file name has special constructs in it,
2899 call the corresponding file handler. */
2900 handler
= Ffind_file_name_handler (absname
, Qfile_directory_p
);
2901 if (!NILP (handler
))
2902 return call2 (handler
, Qfile_directory_p
, absname
);
2904 absname
= ENCODE_FILE (absname
);
2906 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2908 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
2911 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
2912 "Return t if file FILENAME is the name of a directory as a file,\n\
2913 and files in that directory can be opened by you. In order to use a\n\
2914 directory as a buffer's current directory, this predicate must return true.\n\
2915 A directory name spec may be given instead; then the value is t\n\
2916 if the directory so specified exists and really is a readable and\n\
2917 searchable directory.")
2919 Lisp_Object filename
;
2921 Lisp_Object handler
;
2923 struct gcpro gcpro1
;
2925 /* If the file name has special constructs in it,
2926 call the corresponding file handler. */
2927 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
2928 if (!NILP (handler
))
2929 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
2931 /* It's an unlikely combination, but yes we really do need to gcpro:
2932 Suppose that file-accessible-directory-p has no handler, but
2933 file-directory-p does have a handler; this handler causes a GC which
2934 relocates the string in `filename'; and finally file-directory-p
2935 returns non-nil. Then we would end up passing a garbaged string
2936 to file-executable-p. */
2938 tem
= (NILP (Ffile_directory_p (filename
))
2939 || NILP (Ffile_executable_p (filename
)));
2941 return tem
? Qnil
: Qt
;
2944 DEFUN ("file-regular-p", Ffile_regular_p
, Sfile_regular_p
, 1, 1, 0,
2945 "Return t if file FILENAME is the name of a regular file.\n\
2946 This is the sort of file that holds an ordinary stream of data bytes.")
2948 Lisp_Object filename
;
2950 register Lisp_Object absname
;
2952 Lisp_Object handler
;
2954 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2956 /* If the file name has special constructs in it,
2957 call the corresponding file handler. */
2958 handler
= Ffind_file_name_handler (absname
, Qfile_regular_p
);
2959 if (!NILP (handler
))
2960 return call2 (handler
, Qfile_regular_p
, absname
);
2962 absname
= ENCODE_FILE (absname
);
2964 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2966 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
2969 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
2970 "Return mode bits of file named FILENAME, as an integer.")
2972 Lisp_Object filename
;
2974 Lisp_Object absname
;
2976 Lisp_Object handler
;
2978 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2980 /* If the file name has special constructs in it,
2981 call the corresponding file handler. */
2982 handler
= Ffind_file_name_handler (absname
, Qfile_modes
);
2983 if (!NILP (handler
))
2984 return call2 (handler
, Qfile_modes
, absname
);
2986 absname
= ENCODE_FILE (absname
);
2988 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2990 #if defined (MSDOS) && __DJGPP__ < 2
2991 if (check_executable (XSTRING (absname
)->data
))
2992 st
.st_mode
|= S_IEXEC
;
2993 #endif /* MSDOS && __DJGPP__ < 2 */
2995 return make_number (st
.st_mode
& 07777);
2998 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
2999 "Set mode bits of file named FILENAME to MODE (an integer).\n\
3000 Only the 12 low bits of MODE are used.")
3002 Lisp_Object filename
, mode
;
3004 Lisp_Object absname
, encoded_absname
;
3005 Lisp_Object handler
;
3007 absname
= Fexpand_file_name (filename
, current_buffer
->directory
);
3008 CHECK_NUMBER (mode
, 1);
3010 /* If the file name has special constructs in it,
3011 call the corresponding file handler. */
3012 handler
= Ffind_file_name_handler (absname
, Qset_file_modes
);
3013 if (!NILP (handler
))
3014 return call3 (handler
, Qset_file_modes
, absname
, mode
);
3016 encoded_absname
= ENCODE_FILE (absname
);
3018 if (chmod (XSTRING (encoded_absname
)->data
, XINT (mode
)) < 0)
3019 report_file_error ("Doing chmod", Fcons (absname
, Qnil
));
3024 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
3025 "Set the file permission bits for newly created files.\n\
3026 The argument MODE should be an integer; only the low 9 bits are used.\n\
3027 This setting is inherited by subprocesses.")
3031 CHECK_NUMBER (mode
, 0);
3033 umask ((~ XINT (mode
)) & 0777);
3038 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
3039 "Return the default file protection for created files.\n\
3040 The value is an integer.")
3046 realmask
= umask (0);
3049 XSETINT (value
, (~ realmask
) & 0777);
3055 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
3056 "Tell Unix to finish all pending disk updates.")
3065 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
3066 "Return t if file FILE1 is newer than file FILE2.\n\
3067 If FILE1 does not exist, the answer is nil;\n\
3068 otherwise, if FILE2 does not exist, the answer is t.")
3070 Lisp_Object file1
, file2
;
3072 Lisp_Object absname1
, absname2
;
3075 Lisp_Object handler
;
3076 struct gcpro gcpro1
, gcpro2
;
3078 CHECK_STRING (file1
, 0);
3079 CHECK_STRING (file2
, 0);
3082 GCPRO2 (absname1
, file2
);
3083 absname1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
3084 absname2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
3087 /* If the file name has special constructs in it,
3088 call the corresponding file handler. */
3089 handler
= Ffind_file_name_handler (absname1
, Qfile_newer_than_file_p
);
3091 handler
= Ffind_file_name_handler (absname2
, Qfile_newer_than_file_p
);
3092 if (!NILP (handler
))
3093 return call3 (handler
, Qfile_newer_than_file_p
, absname1
, absname2
);
3095 GCPRO2 (absname1
, absname2
);
3096 absname1
= ENCODE_FILE (absname1
);
3097 absname2
= ENCODE_FILE (absname2
);
3100 if (stat (XSTRING (absname1
)->data
, &st
) < 0)
3103 mtime1
= st
.st_mtime
;
3105 if (stat (XSTRING (absname2
)->data
, &st
) < 0)
3108 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
3112 Lisp_Object Qfind_buffer_file_type
;
3115 #ifndef READ_BUF_SIZE
3116 #define READ_BUF_SIZE (64 << 10)
3119 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
3121 "Insert contents of file FILENAME after point.\n\
3122 Returns list of absolute file name and number of bytes inserted.\n\
3123 If second argument VISIT is non-nil, the buffer's visited filename\n\
3124 and last save file modtime are set, and it is marked unmodified.\n\
3125 If visiting and the file does not exist, visiting is completed\n\
3126 before the error is signaled.\n\
3127 The optional third and fourth arguments BEG and END\n\
3128 specify what portion of the file to insert.\n\
3129 These arguments count bytes in the file, not characters in the buffer.\n\
3130 If VISIT is non-nil, BEG and END must be nil.\n\
3132 If optional fifth argument REPLACE is non-nil,\n\
3133 it means replace the current buffer contents (in the accessible portion)\n\
3134 with the file contents. This is better than simply deleting and inserting\n\
3135 the whole thing because (1) it preserves some marker positions\n\
3136 and (2) it puts less data in the undo list.\n\
3137 When REPLACE is non-nil, the value is the number of characters actually read,\n\
3138 which is often less than the number of characters to be read.\n\
3139 This does code conversion according to the value of\n\
3140 `coding-system-for-read' or `file-coding-system-alist',\n\
3141 and sets the variable `last-coding-system-used' to the coding system\n\
3143 (filename
, visit
, beg
, end
, replace
)
3144 Lisp_Object filename
, visit
, beg
, end
, replace
;
3149 register int how_much
;
3150 register int unprocessed
;
3151 int count
= specpdl_ptr
- specpdl
;
3152 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3153 Lisp_Object handler
, val
, insval
, orig_filename
;
3156 int not_regular
= 0;
3157 char read_buf
[READ_BUF_SIZE
];
3158 struct coding_system coding
;
3159 unsigned char buffer
[1 << 14];
3160 int replace_handled
= 0;
3161 int set_coding_system
= 0;
3163 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3164 error ("Cannot do file visiting in an indirect buffer");
3166 if (!NILP (current_buffer
->read_only
))
3167 Fbarf_if_buffer_read_only ();
3171 orig_filename
= Qnil
;
3173 GCPRO4 (filename
, val
, p
, orig_filename
);
3175 CHECK_STRING (filename
, 0);
3176 filename
= Fexpand_file_name (filename
, Qnil
);
3178 /* If the file name has special constructs in it,
3179 call the corresponding file handler. */
3180 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
3181 if (!NILP (handler
))
3183 val
= call6 (handler
, Qinsert_file_contents
, filename
,
3184 visit
, beg
, end
, replace
);
3188 orig_filename
= filename
;
3189 filename
= ENCODE_FILE (filename
);
3194 if (stat (XSTRING (filename
)->data
, &st
) < 0)
3196 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0
3197 || fstat (fd
, &st
) < 0)
3198 #endif /* not APOLLO */
3200 if (fd
>= 0) close (fd
);
3203 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3206 if (!NILP (Vcoding_system_for_read
))
3207 current_buffer
->buffer_file_coding_system
= Vcoding_system_for_read
;
3212 /* This code will need to be changed in order to work on named
3213 pipes, and it's probably just not worth it. So we should at
3214 least signal an error. */
3215 if (!S_ISREG (st
.st_mode
))
3222 if (! NILP (replace
) || ! NILP (beg
) || ! NILP (end
))
3223 Fsignal (Qfile_error
,
3224 Fcons (build_string ("not a regular file"),
3225 Fcons (orig_filename
, Qnil
)));
3230 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0)
3233 /* Replacement should preserve point as it preserves markers. */
3234 if (!NILP (replace
))
3235 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
3237 record_unwind_protect (close_file_unwind
, make_number (fd
));
3239 /* Supposedly happens on VMS. */
3240 if (! not_regular
&& st
.st_size
< 0)
3241 error ("File size is negative");
3243 if (!NILP (beg
) || !NILP (end
))
3245 error ("Attempt to visit less than an entire file");
3248 CHECK_NUMBER (beg
, 0);
3250 XSETFASTINT (beg
, 0);
3253 CHECK_NUMBER (end
, 0);
3258 XSETINT (end
, st
.st_size
);
3259 if (XINT (end
) != st
.st_size
)
3260 error ("Maximum buffer size exceeded");
3264 /* Decide the coding-system of the file. */
3266 Lisp_Object val
= Qnil
;
3268 if (!NILP (Vcoding_system_for_read
))
3269 val
= Vcoding_system_for_read
;
3272 if (! NILP (Vset_auto_coding_function
))
3274 /* Find a coding system specified in the heading two lines
3275 or in the tailing several lines of the file. We assume
3276 that the 1K-byte and 3K-byte for heading and tailing
3277 respectively are sufficient fot this purpose. */
3278 int how_many
, nread
;
3280 if (st
.st_size
<= (1024 * 4))
3281 nread
= read (fd
, read_buf
, 1024 * 4);
3284 nread
= read (fd
, read_buf
, 1024);
3287 if (lseek (fd
, st
.st_size
- (1024 * 3), 0) < 0)
3288 report_file_error ("Setting file position",
3289 Fcons (orig_filename
, Qnil
));
3290 nread
+= read (fd
, read_buf
+ nread
, 1024 * 3);
3295 error ("IO error reading %s: %s",
3296 XSTRING (orig_filename
)->data
, strerror (errno
));
3300 /* Always make this a unibyte string
3301 because we have not yet decoded it. */
3302 tem
= make_unibyte_string (read_buf
, nread
);
3303 val
= call1 (Vset_auto_coding_function
, tem
);
3304 /* Rewind the file for the actual read done later. */
3305 if (lseek (fd
, 0, 0) < 0)
3306 report_file_error ("Setting file position",
3307 Fcons (orig_filename
, Qnil
));
3312 Lisp_Object args
[6], coding_systems
;
3314 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
,
3315 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = replace
;
3316 coding_systems
= Ffind_operation_coding_system (6, args
);
3317 if (CONSP (coding_systems
)) val
= XCONS (coding_systems
)->car
;
3321 if (NILP (Vcoding_system_for_read
)
3322 && NILP (current_buffer
->enable_multibyte_characters
))
3324 /* We must suppress all text conversion except for end-of-line
3326 struct coding_system coding_temp
;
3328 setup_coding_system (Fcheck_coding_system (val
), &coding_temp
);
3329 setup_coding_system (Qraw_text
, &coding
);
3330 coding
.eol_type
= coding_temp
.eol_type
;
3333 setup_coding_system (Fcheck_coding_system (val
), &coding
);
3336 /* If requested, replace the accessible part of the buffer
3337 with the file contents. Avoid replacing text at the
3338 beginning or end of the buffer that matches the file contents;
3339 that preserves markers pointing to the unchanged parts.
3341 Here we implement this feature in an optimized way
3342 for the case where code conversion is NOT needed.
3343 The following if-statement handles the case of conversion
3344 in a less optimal way.
3346 If the code conversion is "automatic" then we try using this
3347 method and hope for the best.
3348 But if we discover the need for conversion, we give up on this method
3349 and let the following if-statement handle the replace job. */
3351 && ! CODING_REQUIRE_DECODING (&coding
))
3353 /* same_at_start and same_at_end count bytes,
3354 because file access counts bytes
3355 and BEG and END count bytes. */
3356 int same_at_start
= BEGV_BYTE
;
3357 int same_at_end
= ZV_BYTE
;
3359 /* There is still a possibility we will find the need to do code
3360 conversion. If that happens, we set this variable to 1 to
3361 give up on handling REPLACE in the optimized way. */
3362 int giveup_match_end
= 0;
3364 if (XINT (beg
) != 0)
3366 if (lseek (fd
, XINT (beg
), 0) < 0)
3367 report_file_error ("Setting file position",
3368 Fcons (orig_filename
, Qnil
));
3373 /* Count how many chars at the start of the file
3374 match the text at the beginning of the buffer. */
3379 nread
= read (fd
, buffer
, sizeof buffer
);
3381 error ("IO error reading %s: %s",
3382 XSTRING (orig_filename
)->data
, strerror (errno
));
3383 else if (nread
== 0)
3386 if (coding
.type
== coding_type_undecided
)
3387 detect_coding (&coding
, buffer
, nread
);
3388 if (CODING_REQUIRE_DECODING (&coding
))
3389 /* We found that the file should be decoded somehow.
3390 Let's give up here. */
3392 giveup_match_end
= 1;
3396 if (coding
.eol_type
== CODING_EOL_UNDECIDED
)
3397 detect_eol (&coding
, buffer
, nread
);
3398 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3399 && coding
.eol_type
!= CODING_EOL_LF
)
3400 /* We found that the format of eol should be decoded.
3401 Let's give up here. */
3403 giveup_match_end
= 1;
3408 while (bufpos
< nread
&& same_at_start
< ZV_BYTE
3409 && FETCH_BYTE (same_at_start
) == buffer
[bufpos
])
3410 same_at_start
++, bufpos
++;
3411 /* If we found a discrepancy, stop the scan.
3412 Otherwise loop around and scan the next bufferful. */
3413 if (bufpos
!= nread
)
3417 /* If the file matches the buffer completely,
3418 there's no need to replace anything. */
3419 if (same_at_start
- BEGV_BYTE
== XINT (end
))
3423 /* Truncate the buffer to the size of the file. */
3424 del_range_1 (same_at_start
, same_at_end
, 0);
3429 /* Count how many chars at the end of the file
3430 match the text at the end of the buffer. But, if we have
3431 already found that decoding is necessary, don't waste time. */
3432 while (!giveup_match_end
)
3434 int total_read
, nread
, bufpos
, curpos
, trial
;
3436 /* At what file position are we now scanning? */
3437 curpos
= XINT (end
) - (ZV_BYTE
- same_at_end
);
3438 /* If the entire file matches the buffer tail, stop the scan. */
3441 /* How much can we scan in the next step? */
3442 trial
= min (curpos
, sizeof buffer
);
3443 if (lseek (fd
, curpos
- trial
, 0) < 0)
3444 report_file_error ("Setting file position",
3445 Fcons (orig_filename
, Qnil
));
3448 while (total_read
< trial
)
3450 nread
= read (fd
, buffer
+ total_read
, trial
- total_read
);
3452 error ("IO error reading %s: %s",
3453 XSTRING (orig_filename
)->data
, strerror (errno
));
3454 total_read
+= nread
;
3456 /* Scan this bufferful from the end, comparing with
3457 the Emacs buffer. */
3458 bufpos
= total_read
;
3459 /* Compare with same_at_start to avoid counting some buffer text
3460 as matching both at the file's beginning and at the end. */
3461 while (bufpos
> 0 && same_at_end
> same_at_start
3462 && FETCH_BYTE (same_at_end
- 1) == buffer
[bufpos
- 1])
3463 same_at_end
--, bufpos
--;
3465 /* If we found a discrepancy, stop the scan.
3466 Otherwise loop around and scan the preceding bufferful. */
3469 /* If this discrepancy is because of code conversion,
3470 we cannot use this method; giveup and try the other. */
3471 if (same_at_end
> same_at_start
3472 && FETCH_BYTE (same_at_end
- 1) >= 0200
3473 && ! NILP (current_buffer
->enable_multibyte_characters
)
3474 && (CODING_MAY_REQUIRE_DECODING (&coding
)))
3475 giveup_match_end
= 1;
3481 if (! giveup_match_end
)
3485 /* We win! We can handle REPLACE the optimized way. */
3487 /* Extends the end of non-matching text area to multibyte
3488 character boundary. */
3489 if (! NILP (current_buffer
->enable_multibyte_characters
))
3490 while (same_at_end
< ZV_BYTE
3491 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
3494 /* Don't try to reuse the same piece of text twice. */
3495 overlap
= (same_at_start
- BEGV_BYTE
3496 - (same_at_end
+ st
.st_size
- ZV
));
3498 same_at_end
+= overlap
;
3500 /* Arrange to read only the nonmatching middle part of the file. */
3501 XSETFASTINT (beg
, XINT (beg
) + (same_at_start
- BEGV_BYTE
));
3502 XSETFASTINT (end
, XINT (end
) - (ZV_BYTE
- same_at_end
));
3504 del_range_byte (same_at_start
, same_at_end
, 0);
3505 /* Insert from the file at the proper position. */
3506 temp
= BYTE_TO_CHAR (same_at_start
);
3507 SET_PT_BOTH (temp
, same_at_start
);
3509 /* If display currently starts at beginning of line,
3510 keep it that way. */
3511 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3512 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3514 replace_handled
= 1;
3518 /* If requested, replace the accessible part of the buffer
3519 with the file contents. Avoid replacing text at the
3520 beginning or end of the buffer that matches the file contents;
3521 that preserves markers pointing to the unchanged parts.
3523 Here we implement this feature for the case where code conversion
3524 is needed, in a simple way that needs a lot of memory.
3525 The preceding if-statement handles the case of no conversion
3526 in a more optimized way. */
3527 if (!NILP (replace
) && ! replace_handled
)
3529 int same_at_start
= BEGV_BYTE
;
3530 int same_at_end
= ZV_BYTE
;
3533 /* Make sure that the gap is large enough. */
3534 int bufsize
= 2 * st
.st_size
;
3535 unsigned char *conversion_buffer
= (unsigned char *) xmalloc (bufsize
);
3538 /* First read the whole file, performing code conversion into
3539 CONVERSION_BUFFER. */
3541 if (lseek (fd
, XINT (beg
), 0) < 0)
3543 free (conversion_buffer
);
3544 report_file_error ("Setting file position",
3545 Fcons (orig_filename
, Qnil
));
3548 total
= st
.st_size
; /* Total bytes in the file. */
3549 how_much
= 0; /* Bytes read from file so far. */
3550 inserted
= 0; /* Bytes put into CONVERSION_BUFFER so far. */
3551 unprocessed
= 0; /* Bytes not processed in previous loop. */
3553 while (how_much
< total
)
3555 /* try is reserved in some compilers (Microsoft C) */
3556 int trytry
= min (total
- how_much
, READ_BUF_SIZE
- unprocessed
);
3557 char *destination
= read_buf
+ unprocessed
;
3560 /* Allow quitting out of the actual I/O. */
3563 this = read (fd
, destination
, trytry
);
3566 if (this < 0 || this + unprocessed
== 0)
3574 if (CODING_MAY_REQUIRE_DECODING (&coding
))
3576 int require
, result
;
3578 this += unprocessed
;
3580 /* If we are using more space than estimated,
3581 make CONVERSION_BUFFER bigger. */
3582 require
= decoding_buffer_size (&coding
, this);
3583 if (inserted
+ require
+ 2 * (total
- how_much
) > bufsize
)
3585 bufsize
= inserted
+ require
+ 2 * (total
- how_much
);
3586 conversion_buffer
= (unsigned char *) xrealloc (conversion_buffer
, bufsize
);
3589 /* Convert this batch with results in CONVERSION_BUFFER. */
3590 if (how_much
>= total
) /* This is the last block. */
3591 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
3592 result
= decode_coding (&coding
, read_buf
,
3593 conversion_buffer
+ inserted
,
3594 this, bufsize
- inserted
);
3596 /* Save for next iteration whatever we didn't convert. */
3597 unprocessed
= this - coding
.consumed
;
3598 bcopy (read_buf
+ coding
.consumed
, read_buf
, unprocessed
);
3599 this = coding
.produced
;
3605 /* At this point, INSERTED is how many characters (i.e. bytes)
3606 are present in CONVERSION_BUFFER.
3607 HOW_MUCH should equal TOTAL,
3608 or should be <= 0 if we couldn't read the file. */
3612 free (conversion_buffer
);
3615 error ("IO error reading %s: %s",
3616 XSTRING (orig_filename
)->data
, strerror (errno
));
3617 else if (how_much
== -2)
3618 error ("maximum buffer size exceeded");
3621 /* Compare the beginning of the converted file
3622 with the buffer text. */
3625 while (bufpos
< inserted
&& same_at_start
< same_at_end
3626 && FETCH_BYTE (same_at_start
) == conversion_buffer
[bufpos
])
3627 same_at_start
++, bufpos
++;
3629 /* If the file matches the buffer completely,
3630 there's no need to replace anything. */
3632 if (bufpos
== inserted
)
3634 free (conversion_buffer
);
3637 /* Truncate the buffer to the size of the file. */
3638 del_range_1 (same_at_start
, same_at_end
, 0);
3642 /* Scan this bufferful from the end, comparing with
3643 the Emacs buffer. */
3646 /* Compare with same_at_start to avoid counting some buffer text
3647 as matching both at the file's beginning and at the end. */
3648 while (bufpos
> 0 && same_at_end
> same_at_start
3649 && FETCH_BYTE (same_at_end
- 1) == conversion_buffer
[bufpos
- 1])
3650 same_at_end
--, bufpos
--;
3652 /* Don't try to reuse the same piece of text twice. */
3653 overlap
= same_at_start
- BEGV_BYTE
- (same_at_end
+ inserted
- ZV_BYTE
);
3655 same_at_end
+= overlap
;
3657 /* If display currently starts at beginning of line,
3658 keep it that way. */
3659 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3660 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3662 /* Replace the chars that we need to replace,
3663 and update INSERTED to equal the number of bytes
3664 we are taking from the file. */
3665 inserted
-= (Z_BYTE
- same_at_end
) + (same_at_start
- BEG_BYTE
);
3666 del_range_byte (same_at_start
, same_at_end
, 0);
3667 SET_PT_BOTH (GPT
, GPT_BYTE
);
3669 insert_1 (conversion_buffer
+ same_at_start
- BEG_BYTE
, inserted
,
3672 free (conversion_buffer
);
3681 register Lisp_Object temp
;
3683 total
= XINT (end
) - XINT (beg
);
3685 /* Make sure point-max won't overflow after this insertion. */
3686 XSETINT (temp
, total
);
3687 if (total
!= XINT (temp
))
3688 error ("Maximum buffer size exceeded");
3691 /* For a special file, all we can do is guess. */
3692 total
= READ_BUF_SIZE
;
3694 if (NILP (visit
) && total
> 0)
3695 prepare_to_modify_buffer (PT
, PT
, NULL
);
3698 if (GAP_SIZE
< total
)
3699 make_gap (total
- GAP_SIZE
);
3701 if (XINT (beg
) != 0 || !NILP (replace
))
3703 if (lseek (fd
, XINT (beg
), 0) < 0)
3704 report_file_error ("Setting file position",
3705 Fcons (orig_filename
, Qnil
));
3708 /* In the following loop, HOW_MUCH contains the total bytes read so
3709 far for a regular file, and not changed for a special file. But,
3710 before exiting the loop, it is set to a negative value if I/O
3713 /* Total bytes inserted. */
3715 /* Here, we don't do code conversion in the loop. It is done by
3716 code_convert_region after all data are read into the buffer. */
3717 while (how_much
< total
)
3719 /* try is reserved in some compilers (Microsoft C) */
3720 int trytry
= min (total
- how_much
, READ_BUF_SIZE
);
3723 /* For a special file, GAP_SIZE should be checked every time. */
3724 if (not_regular
&& GAP_SIZE
< trytry
)
3725 make_gap (total
- GAP_SIZE
);
3727 /* Allow quitting out of the actual I/O. */
3730 this = read (fd
, BYTE_POS_ADDR (PT_BYTE
+ inserted
- 1) + 1, trytry
);
3747 /* For a regular file, where TOTAL is the real size,
3748 count HOW_MUCH to compare with it.
3749 For a special file, where TOTAL is just a buffer size,
3750 so don't bother counting in HOW_MUCH.
3751 (INSERTED is where we count the number of characters inserted.) */
3758 /* Put an anchor to ensure multi-byte form ends at gap. */
3763 /* Discard the unwind protect for closing the file. */
3767 error ("IO error reading %s: %s",
3768 XSTRING (orig_filename
)->data
, strerror (errno
));
3772 if (CODING_MAY_REQUIRE_DECODING (&coding
))
3774 code_convert_region (PT
, PT_BYTE
, PT
+ inserted
, PT_BYTE
+ inserted
,
3776 inserted
= (NILP (current_buffer
->enable_multibyte_characters
)
3777 ? coding
.produced
: coding
.produced_char
);
3781 /* Use the conversion type to determine buffer-file-type
3782 (find-buffer-file-type is now used to help determine the
3784 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3785 && coding
.eol_type
!= CODING_EOL_LF
)
3786 current_buffer
->buffer_file_type
= Qnil
;
3788 current_buffer
->buffer_file_type
= Qt
;
3791 record_insert (PT
, inserted
);
3793 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
3794 offset_intervals (current_buffer
, PT
, inserted
);
3797 if (! NILP (coding
.post_read_conversion
))
3801 val
= call1 (coding
.post_read_conversion
, make_number (inserted
));
3804 CHECK_NUMBER (val
, 0);
3805 inserted
= XFASTINT (val
);
3810 set_coding_system
= 1;
3817 if (!EQ (current_buffer
->undo_list
, Qt
))
3818 current_buffer
->undo_list
= Qnil
;
3820 stat (XSTRING (filename
)->data
, &st
);
3825 current_buffer
->modtime
= st
.st_mtime
;
3826 current_buffer
->filename
= orig_filename
;
3829 SAVE_MODIFF
= MODIFF
;
3830 current_buffer
->auto_save_modified
= MODIFF
;
3831 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
3832 #ifdef CLASH_DETECTION
3835 if (!NILP (current_buffer
->file_truename
))
3836 unlock_file (current_buffer
->file_truename
);
3837 unlock_file (filename
);
3839 #endif /* CLASH_DETECTION */
3841 Fsignal (Qfile_error
,
3842 Fcons (build_string ("not a regular file"),
3843 Fcons (orig_filename
, Qnil
)));
3845 /* If visiting nonexistent file, return nil. */
3846 if (current_buffer
->modtime
== -1)
3847 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3850 /* Decode file format */
3853 insval
= call3 (Qformat_decode
,
3854 Qnil
, make_number (inserted
), visit
);
3855 CHECK_NUMBER (insval
, 0);
3856 inserted
= XFASTINT (insval
);
3859 /* Call after-change hooks for the inserted text, aside from the case
3860 of normal visiting (not with REPLACE), which is done in a new buffer
3861 "before" the buffer is changed. */
3862 if (inserted
> 0 && total
> 0
3863 && (NILP (visit
) || !NILP (replace
)))
3864 signal_after_change (PT
, 0, inserted
);
3866 if (set_coding_system
)
3867 Vlast_coding_system_used
= coding
.symbol
;
3871 p
= Vafter_insert_file_functions
;
3874 insval
= call1 (Fcar (p
), make_number (inserted
));
3877 CHECK_NUMBER (insval
, 0);
3878 inserted
= XFASTINT (insval
);
3885 /* ??? Retval needs to be dealt with in all cases consistently. */
3887 val
= Fcons (orig_filename
,
3888 Fcons (make_number (inserted
),
3891 RETURN_UNGCPRO (unbind_to (count
, val
));
3894 static Lisp_Object build_annotations
P_ ((Lisp_Object
, Lisp_Object
,
3897 /* If build_annotations switched buffers, switch back to BUF.
3898 Kill the temporary buffer that was selected in the meantime.
3900 Since this kill only the last temporary buffer, some buffers remain
3901 not killed if build_annotations switched buffers more than once.
3905 build_annotations_unwind (buf
)
3910 if (XBUFFER (buf
) == current_buffer
)
3912 tembuf
= Fcurrent_buffer ();
3914 Fkill_buffer (tembuf
);
3918 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 7,
3919 "r\nFWrite region to file: \ni\ni\ni\np",
3920 "Write current region into specified file.\n\
3921 When called from a program, takes three arguments:\n\
3922 START, END and FILENAME. START and END are buffer positions.\n\
3923 Optional fourth argument APPEND if non-nil means\n\
3924 append to existing file contents (if any).\n\
3925 Optional fifth argument VISIT if t means\n\
3926 set the last-save-file-modtime of buffer to this file's modtime\n\
3927 and mark buffer not modified.\n\
3928 If VISIT is a string, it is a second file name;\n\
3929 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
3930 VISIT is also the file name to lock and unlock for clash detection.\n\
3931 If VISIT is neither t nor nil nor a string,\n\
3932 that means do not print the \"Wrote file\" message.\n\
3933 The optional sixth arg LOCKNAME, if non-nil, specifies the name to\n\
3934 use for locking and unlocking, overriding FILENAME and VISIT.\n\
3935 The optional seventh arg CONFIRM, if non-nil, says ask for confirmation\n\
3936 before overwriting an existing file.\n\
3937 Kludgy feature: if START is a string, then that string is written\n\
3938 to the file, instead of any buffer contents, and END is ignored.")
3939 (start
, end
, filename
, append
, visit
, lockname
, confirm
)
3940 Lisp_Object start
, end
, filename
, append
, visit
, lockname
, confirm
;
3948 int count
= specpdl_ptr
- specpdl
;
3951 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
3953 Lisp_Object handler
;
3954 Lisp_Object visit_file
;
3955 Lisp_Object annotations
;
3956 Lisp_Object encoded_filename
;
3957 int visiting
, quietly
;
3958 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
3959 struct buffer
*given_buffer
;
3961 int buffer_file_type
= O_BINARY
;
3963 struct coding_system coding
;
3965 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3966 error ("Cannot do file visiting in an indirect buffer");
3968 if (!NILP (start
) && !STRINGP (start
))
3969 validate_region (&start
, &end
);
3971 GCPRO4 (start
, filename
, visit
, lockname
);
3973 /* Decide the coding-system to encode the data with. */
3979 else if (!NILP (Vcoding_system_for_write
))
3980 val
= Vcoding_system_for_write
;
3981 else if (NILP (current_buffer
->enable_multibyte_characters
))
3983 /* If the variable `buffer-file-coding-system' is set locally,
3984 it means that the file was read with some kind of code
3985 conversion or the varialbe is explicitely set by users. We
3986 had better write it out with the same coding system even if
3987 `enable-multibyte-characters' is nil.
3989 If it is not set locally, we anyway have to convert EOL
3990 format if the default value of `buffer-file-coding-system'
3991 tells that it is not Unix-like (LF only) format. */
3992 val
= current_buffer
->buffer_file_coding_system
;
3993 if (NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
3995 struct coding_system coding_temp
;
3997 setup_coding_system (Fcheck_coding_system (val
), &coding_temp
);
3998 if (coding_temp
.eol_type
== CODING_EOL_CRLF
3999 || coding_temp
.eol_type
== CODING_EOL_CR
)
4001 setup_coding_system (Qraw_text
, &coding
);
4002 coding
.eol_type
= coding_temp
.eol_type
;
4003 goto done_setup_coding
;
4010 Lisp_Object args
[7], coding_systems
;
4012 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4013 args
[3] = filename
; args
[4] = append
; args
[5] = visit
;
4015 coding_systems
= Ffind_operation_coding_system (7, args
);
4016 val
= (CONSP (coding_systems
) && !NILP (XCONS (coding_systems
)->cdr
)
4017 ? XCONS (coding_systems
)->cdr
4018 : current_buffer
->buffer_file_coding_system
);
4019 /* Confirm that VAL can surely encode the current region. */
4020 if (Ffboundp (Vselect_safe_coding_system_function
))
4021 val
= call3 (Vselect_safe_coding_system_function
, start
, end
, val
);
4023 setup_coding_system (Fcheck_coding_system (val
), &coding
);
4026 if (!STRINGP (start
) && !NILP (current_buffer
->selective_display
))
4027 coding
.mode
|= CODING_MODE_SELECTIVE_DISPLAY
;
4030 Vlast_coding_system_used
= coding
.symbol
;
4032 filename
= Fexpand_file_name (filename
, Qnil
);
4034 if (! NILP (confirm
))
4035 barf_or_query_if_file_exists (filename
, "overwrite", 1, 0);
4037 if (STRINGP (visit
))
4038 visit_file
= Fexpand_file_name (visit
, Qnil
);
4040 visit_file
= filename
;
4043 visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
4044 quietly
= !NILP (visit
);
4048 if (NILP (lockname
))
4049 lockname
= visit_file
;
4051 GCPRO5 (start
, filename
, annotations
, visit_file
, lockname
);
4053 /* If the file name has special constructs in it,
4054 call the corresponding file handler. */
4055 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
4056 /* If FILENAME has no handler, see if VISIT has one. */
4057 if (NILP (handler
) && STRINGP (visit
))
4058 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
4060 if (!NILP (handler
))
4063 val
= call6 (handler
, Qwrite_region
, start
, end
,
4064 filename
, append
, visit
);
4068 SAVE_MODIFF
= MODIFF
;
4069 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4070 current_buffer
->filename
= visit_file
;
4076 /* Special kludge to simplify auto-saving. */
4079 XSETFASTINT (start
, BEG
);
4080 XSETFASTINT (end
, Z
);
4083 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
4084 count1
= specpdl_ptr
- specpdl
;
4086 given_buffer
= current_buffer
;
4087 annotations
= build_annotations (start
, end
, coding
.pre_write_conversion
);
4088 if (current_buffer
!= given_buffer
)
4090 XSETFASTINT (start
, BEGV
);
4091 XSETFASTINT (end
, ZV
);
4094 #ifdef CLASH_DETECTION
4097 #if 0 /* This causes trouble for GNUS. */
4098 /* If we've locked this file for some other buffer,
4099 query before proceeding. */
4100 if (!visiting
&& EQ (Ffile_locked_p (lockname
), Qt
))
4101 call2 (intern ("ask-user-about-lock"), filename
, Vuser_login_name
);
4104 lock_file (lockname
);
4106 #endif /* CLASH_DETECTION */
4108 encoded_filename
= ENCODE_FILE (filename
);
4110 fn
= XSTRING (encoded_filename
)->data
;
4114 desc
= open (fn
, O_WRONLY
| buffer_file_type
);
4115 #else /* not DOS_NT */
4116 desc
= open (fn
, O_WRONLY
);
4117 #endif /* not DOS_NT */
4119 if (desc
< 0 && (NILP (append
) || errno
== ENOENT
))
4121 if (auto_saving
) /* Overwrite any previous version of autosave file */
4123 vms_truncate (fn
); /* if fn exists, truncate to zero length */
4124 desc
= open (fn
, O_RDWR
);
4126 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
4127 ? XSTRING (current_buffer
->filename
)->data
: 0,
4130 else /* Write to temporary name and rename if no errors */
4132 Lisp_Object temp_name
;
4133 temp_name
= Ffile_name_directory (filename
);
4135 if (!NILP (temp_name
))
4137 temp_name
= Fmake_temp_name (concat2 (temp_name
,
4138 build_string ("$$SAVE$$")));
4139 fname
= XSTRING (filename
)->data
;
4140 fn
= XSTRING (temp_name
)->data
;
4141 desc
= creat_copy_attrs (fname
, fn
);
4144 /* If we can't open the temporary file, try creating a new
4145 version of the original file. VMS "creat" creates a
4146 new version rather than truncating an existing file. */
4149 desc
= creat (fn
, 0666);
4150 #if 0 /* This can clobber an existing file and fail to replace it,
4151 if the user runs out of space. */
4154 /* We can't make a new version;
4155 try to truncate and rewrite existing version if any. */
4157 desc
= open (fn
, O_RDWR
);
4163 desc
= creat (fn
, 0666);
4168 O_WRONLY
| O_TRUNC
| O_CREAT
| buffer_file_type
,
4169 S_IREAD
| S_IWRITE
);
4170 #else /* not DOS_NT */
4171 desc
= creat (fn
, auto_saving
? auto_save_mode_bits
: 0666);
4172 #endif /* not DOS_NT */
4173 #endif /* not VMS */
4179 #ifdef CLASH_DETECTION
4181 if (!auto_saving
) unlock_file (lockname
);
4183 #endif /* CLASH_DETECTION */
4184 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
4187 record_unwind_protect (close_file_unwind
, make_number (desc
));
4190 if (lseek (desc
, 0, 2) < 0)
4192 #ifdef CLASH_DETECTION
4193 if (!auto_saving
) unlock_file (lockname
);
4194 #endif /* CLASH_DETECTION */
4195 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
4200 * Kludge Warning: The VMS C RTL likes to insert carriage returns
4201 * if we do writes that don't end with a carriage return. Furthermore
4202 * it cannot handle writes of more then 16K. The modified
4203 * version of "sys_write" in SYSDEP.C (see comment there) copes with
4204 * this EXCEPT for the last record (iff it doesn't end with a carriage
4205 * return). This implies that if your buffer doesn't end with a carriage
4206 * return, you get one free... tough. However it also means that if
4207 * we make two calls to sys_write (a la the following code) you can
4208 * get one at the gap as well. The easiest way to fix this (honest)
4209 * is to move the gap to the next newline (or the end of the buffer).
4214 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4215 move_gap (find_next_newline (GPT
, 1));
4217 /* Whether VMS or not, we must move the gap to the next of newline
4218 when we must put designation sequences at beginning of line. */
4219 if (INTEGERP (start
)
4220 && coding
.type
== coding_type_iso2022
4221 && coding
.flags
& CODING_FLAG_ISO_DESIGNATE_AT_BOL
4222 && GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4224 int opoint
= PT
, opoint_byte
= PT_BYTE
;
4225 scan_newline (PT
, PT_BYTE
, ZV
, ZV_BYTE
, 1, 0);
4226 move_gap_both (PT
, PT_BYTE
);
4227 SET_PT_BOTH (opoint
, opoint_byte
);
4234 if (STRINGP (start
))
4236 failure
= 0 > a_write (desc
, XSTRING (start
)->data
,
4237 XSTRING (start
)->size_byte
, 0, &annotations
,
4241 else if (XINT (start
) != XINT (end
))
4243 register int end1
= CHAR_TO_BYTE (XINT (end
));
4245 tem
= CHAR_TO_BYTE (XINT (start
));
4247 if (XINT (start
) < GPT
)
4249 failure
= 0 > a_write (desc
, BYTE_POS_ADDR (tem
),
4250 min (GPT_BYTE
, end1
) - tem
, tem
, &annotations
,
4255 if (XINT (end
) > GPT
&& !failure
)
4257 tem
= max (tem
, GPT_BYTE
);
4258 failure
= 0 > a_write (desc
, BYTE_POS_ADDR (tem
), end1
- tem
,
4259 tem
, &annotations
, &coding
);
4265 /* If file was empty, still need to write the annotations */
4266 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4267 failure
= 0 > a_write (desc
, "", 0, XINT (start
), &annotations
, &coding
);
4271 if (CODING_REQUIRE_FLUSHING (&coding
)
4272 && !(coding
.mode
& CODING_MODE_LAST_BLOCK
)
4275 /* We have to flush out a data. */
4276 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4277 failure
= 0 > e_write (desc
, "", 0, &coding
);
4284 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
4285 Disk full in NFS may be reported here. */
4286 /* mib says that closing the file will try to write as fast as NFS can do
4287 it, and that means the fsync here is not crucial for autosave files. */
4288 if (!auto_saving
&& fsync (desc
) < 0)
4290 /* If fsync fails with EINTR, don't treat that as serious. */
4292 failure
= 1, save_errno
= errno
;
4296 /* Spurious "file has changed on disk" warnings have been
4297 observed on Suns as well.
4298 It seems that `close' can change the modtime, under nfs.
4300 (This has supposedly been fixed in Sunos 4,
4301 but who knows about all the other machines with NFS?) */
4304 /* On VMS and APOLLO, must do the stat after the close
4305 since closing changes the modtime. */
4308 /* Recall that #if defined does not work on VMS. */
4315 /* NFS can report a write failure now. */
4316 if (close (desc
) < 0)
4317 failure
= 1, save_errno
= errno
;
4320 /* If we wrote to a temporary name and had no errors, rename to real name. */
4324 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
4332 /* Discard the unwind protect for close_file_unwind. */
4333 specpdl_ptr
= specpdl
+ count1
;
4334 /* Restore the original current buffer. */
4335 visit_file
= unbind_to (count
, visit_file
);
4337 #ifdef CLASH_DETECTION
4339 unlock_file (lockname
);
4340 #endif /* CLASH_DETECTION */
4342 /* Do this before reporting IO error
4343 to avoid a "file has changed on disk" warning on
4344 next attempt to save. */
4346 current_buffer
->modtime
= st
.st_mtime
;
4349 error ("IO error writing %s: %s", XSTRING (filename
)->data
,
4350 strerror (save_errno
));
4354 SAVE_MODIFF
= MODIFF
;
4355 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4356 current_buffer
->filename
= visit_file
;
4357 update_mode_lines
++;
4363 message_with_string ("Wrote %s", visit_file
, 1);
4368 Lisp_Object
merge ();
4370 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
4371 "Return t if (car A) is numerically less than (car B).")
4375 return Flss (Fcar (a
), Fcar (b
));
4378 /* Build the complete list of annotations appropriate for writing out
4379 the text between START and END, by calling all the functions in
4380 write-region-annotate-functions and merging the lists they return.
4381 If one of these functions switches to a different buffer, we assume
4382 that buffer contains altered text. Therefore, the caller must
4383 make sure to restore the current buffer in all cases,
4384 as save-excursion would do. */
4387 build_annotations (start
, end
, pre_write_conversion
)
4388 Lisp_Object start
, end
, pre_write_conversion
;
4390 Lisp_Object annotations
;
4392 struct gcpro gcpro1
, gcpro2
;
4393 Lisp_Object original_buffer
;
4395 XSETBUFFER (original_buffer
, current_buffer
);
4398 p
= Vwrite_region_annotate_functions
;
4399 GCPRO2 (annotations
, p
);
4402 struct buffer
*given_buffer
= current_buffer
;
4403 Vwrite_region_annotations_so_far
= annotations
;
4404 res
= call2 (Fcar (p
), start
, end
);
4405 /* If the function makes a different buffer current,
4406 assume that means this buffer contains altered text to be output.
4407 Reset START and END from the buffer bounds
4408 and discard all previous annotations because they should have
4409 been dealt with by this function. */
4410 if (current_buffer
!= given_buffer
)
4412 XSETFASTINT (start
, BEGV
);
4413 XSETFASTINT (end
, ZV
);
4416 Flength (res
); /* Check basic validity of return value */
4417 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4421 /* Now do the same for annotation functions implied by the file-format */
4422 if (auto_saving
&& (!EQ (Vauto_save_file_format
, Qt
)))
4423 p
= Vauto_save_file_format
;
4425 p
= current_buffer
->file_format
;
4428 struct buffer
*given_buffer
= current_buffer
;
4429 Vwrite_region_annotations_so_far
= annotations
;
4430 res
= call4 (Qformat_annotate_function
, Fcar (p
), start
, end
,
4432 if (current_buffer
!= given_buffer
)
4434 XSETFASTINT (start
, BEGV
);
4435 XSETFASTINT (end
, ZV
);
4439 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4443 /* At last, do the same for the function PRE_WRITE_CONVERSION
4444 implied by the current coding-system. */
4445 if (!NILP (pre_write_conversion
))
4447 struct buffer
*given_buffer
= current_buffer
;
4448 Vwrite_region_annotations_so_far
= annotations
;
4449 res
= call2 (pre_write_conversion
, start
, end
);
4451 annotations
= (current_buffer
!= given_buffer
4453 : merge (annotations
, res
, Qcar_less_than_car
));
4460 /* Write to descriptor DESC the NBYTES bytes starting at ADDR,
4461 assuming they start at byte position BYTEPOS in the buffer.
4462 Intersperse with them the annotations from *ANNOT
4463 which fall within the range of byte positions BYTEPOS to BYTEPOS + NBYTES,
4464 each at its appropriate position.
4466 We modify *ANNOT by discarding elements as we use them up.
4468 The return value is negative in case of system call failure. */
4471 a_write (desc
, addr
, nbytes
, bytepos
, annot
, coding
)
4473 register char *addr
;
4474 register int nbytes
;
4477 struct coding_system
*coding
;
4481 int lastpos
= bytepos
+ nbytes
;
4483 while (NILP (*annot
) || CONSP (*annot
))
4485 tem
= Fcar_safe (Fcar (*annot
));
4486 nextpos
= bytepos
- 1;
4488 nextpos
= CHAR_TO_BYTE (XFASTINT (tem
));
4490 /* If there are no more annotations in this range,
4491 output the rest of the range all at once. */
4492 if (! (nextpos
>= bytepos
&& nextpos
<= lastpos
))
4493 return e_write (desc
, addr
, lastpos
- bytepos
, coding
);
4495 /* Output buffer text up to the next annotation's position. */
4496 if (nextpos
> bytepos
)
4498 if (0 > e_write (desc
, addr
, nextpos
- bytepos
, coding
))
4500 addr
+= nextpos
- bytepos
;
4503 /* Output the annotation. */
4504 tem
= Fcdr (Fcar (*annot
));
4507 if (0 > e_write (desc
, XSTRING (tem
)->data
, XSTRING (tem
)->size_byte
,
4511 *annot
= Fcdr (*annot
);
4515 #ifndef WRITE_BUF_SIZE
4516 #define WRITE_BUF_SIZE (16 * 1024)
4519 /* Write NBYTES bytes starting at ADDR into descriptor DESC,
4520 encoding them with coding system CODING. */
4523 e_write (desc
, addr
, nbytes
, coding
)
4525 register char *addr
;
4526 register int nbytes
;
4527 struct coding_system
*coding
;
4529 char buf
[WRITE_BUF_SIZE
];
4531 /* We used to have a code for handling selective display here. But,
4532 now it is handled within encode_coding. */
4535 encode_coding (coding
, addr
, buf
, nbytes
, WRITE_BUF_SIZE
);
4536 nbytes
-= coding
->consumed
, addr
+= coding
->consumed
;
4537 if (coding
->produced
> 0)
4539 coding
->produced
-= write (desc
, buf
, coding
->produced
);
4540 if (coding
->produced
) return -1;
4548 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
4549 Sverify_visited_file_modtime
, 1, 1, 0,
4550 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
4551 This means that the file has not been changed since it was visited or saved.")
4557 Lisp_Object handler
;
4558 Lisp_Object filename
;
4560 CHECK_BUFFER (buf
, 0);
4563 if (!STRINGP (b
->filename
)) return Qt
;
4564 if (b
->modtime
== 0) return Qt
;
4566 /* If the file name has special constructs in it,
4567 call the corresponding file handler. */
4568 handler
= Ffind_file_name_handler (b
->filename
,
4569 Qverify_visited_file_modtime
);
4570 if (!NILP (handler
))
4571 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
4573 filename
= ENCODE_FILE (b
->filename
);
4575 if (stat (XSTRING (filename
)->data
, &st
) < 0)
4577 /* If the file doesn't exist now and didn't exist before,
4578 we say that it isn't modified, provided the error is a tame one. */
4579 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
4584 if (st
.st_mtime
== b
->modtime
4585 /* If both are positive, accept them if they are off by one second. */
4586 || (st
.st_mtime
> 0 && b
->modtime
> 0
4587 && (st
.st_mtime
== b
->modtime
+ 1
4588 || st
.st_mtime
== b
->modtime
- 1)))
4593 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
4594 Sclear_visited_file_modtime
, 0, 0, 0,
4595 "Clear out records of last mod time of visited file.\n\
4596 Next attempt to save will certainly not complain of a discrepancy.")
4599 current_buffer
->modtime
= 0;
4603 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
4604 Svisited_file_modtime
, 0, 0, 0,
4605 "Return the current buffer's recorded visited file modification time.\n\
4606 The value is a list of the form (HIGH . LOW), like the time values\n\
4607 that `file-attributes' returns.")
4610 return long_to_cons ((unsigned long) current_buffer
->modtime
);
4613 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
4614 Sset_visited_file_modtime
, 0, 1, 0,
4615 "Update buffer's recorded modification time from the visited file's time.\n\
4616 Useful if the buffer was not read from the file normally\n\
4617 or if the file itself has been changed for some known benign reason.\n\
4618 An argument specifies the modification time value to use\n\
4619 \(instead of that of the visited file), in the form of a list\n\
4620 \(HIGH . LOW) or (HIGH LOW).")
4622 Lisp_Object time_list
;
4624 if (!NILP (time_list
))
4625 current_buffer
->modtime
= cons_to_long (time_list
);
4628 register Lisp_Object filename
;
4630 Lisp_Object handler
;
4632 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
4634 /* If the file name has special constructs in it,
4635 call the corresponding file handler. */
4636 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
4637 if (!NILP (handler
))
4638 /* The handler can find the file name the same way we did. */
4639 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
4641 filename
= ENCODE_FILE (filename
);
4643 if (stat (XSTRING (filename
)->data
, &st
) >= 0)
4644 current_buffer
->modtime
= st
.st_mtime
;
4654 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 1);
4655 Fsleep_for (make_number (1), Qnil
);
4656 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 0);
4657 Fsleep_for (make_number (1), Qnil
);
4658 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 0);
4659 Fsleep_for (make_number (1), Qnil
);
4669 /* Get visited file's mode to become the auto save file's mode. */
4670 if (stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
4671 /* But make sure we can overwrite it later! */
4672 auto_save_mode_bits
= st
.st_mode
| 0600;
4674 auto_save_mode_bits
= 0666;
4677 Fwrite_region (Qnil
, Qnil
,
4678 current_buffer
->auto_save_file_name
,
4679 Qnil
, Qlambda
, Qnil
, Qnil
);
4683 do_auto_save_unwind (stream
) /* used as unwind-protect function */
4688 fclose ((FILE *) (XFASTINT (XCONS (stream
)->car
) << 16
4689 | XFASTINT (XCONS (stream
)->cdr
)));
4694 do_auto_save_unwind_1 (value
) /* used as unwind-protect function */
4697 minibuffer_auto_raise
= XINT (value
);
4701 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
4702 "Auto-save all buffers that need it.\n\
4703 This is all buffers that have auto-saving enabled\n\
4704 and are changed since last auto-saved.\n\
4705 Auto-saving writes the buffer into a file\n\
4706 so that your editing is not lost if the system crashes.\n\
4707 This file is not the file you visited; that changes only when you save.\n\
4708 Normally we run the normal hook `auto-save-hook' before saving.\n\n\
4709 A non-nil NO-MESSAGE argument means do not print any message if successful.\n\
4710 A non-nil CURRENT-ONLY argument means save only current buffer.")
4711 (no_message
, current_only
)
4712 Lisp_Object no_message
, current_only
;
4714 struct buffer
*old
= current_buffer
, *b
;
4715 Lisp_Object tail
, buf
;
4717 char *omessage
= echo_area_glyphs
;
4718 int omessage_length
= echo_area_glyphs_length
;
4719 int oldmultibyte
= message_enable_multibyte
;
4720 int do_handled_files
;
4723 Lisp_Object lispstream
;
4724 int count
= specpdl_ptr
- specpdl
;
4726 int orig_minibuffer_auto_raise
= minibuffer_auto_raise
;
4728 /* Ordinarily don't quit within this function,
4729 but don't make it impossible to quit (in case we get hung in I/O). */
4733 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
4734 point to non-strings reached from Vbuffer_alist. */
4739 if (!NILP (Vrun_hooks
))
4740 call1 (Vrun_hooks
, intern ("auto-save-hook"));
4742 if (STRINGP (Vauto_save_list_file_name
))
4744 Lisp_Object listfile
;
4745 listfile
= Fexpand_file_name (Vauto_save_list_file_name
, Qnil
);
4746 stream
= fopen (XSTRING (listfile
)->data
, "w");
4749 /* Arrange to close that file whether or not we get an error.
4750 Also reset auto_saving to 0. */
4751 lispstream
= Fcons (Qnil
, Qnil
);
4752 XSETFASTINT (XCONS (lispstream
)->car
, (EMACS_UINT
)stream
>> 16);
4753 XSETFASTINT (XCONS (lispstream
)->cdr
, (EMACS_UINT
)stream
& 0xffff);
4764 record_unwind_protect (do_auto_save_unwind
, lispstream
);
4765 record_unwind_protect (do_auto_save_unwind_1
,
4766 make_number (minibuffer_auto_raise
));
4767 minibuffer_auto_raise
= 0;
4770 /* First, save all files which don't have handlers. If Emacs is
4771 crashing, the handlers may tweak what is causing Emacs to crash
4772 in the first place, and it would be a shame if Emacs failed to
4773 autosave perfectly ordinary files because it couldn't handle some
4775 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
4776 for (tail
= Vbuffer_alist
; GC_CONSP (tail
); tail
= XCONS (tail
)->cdr
)
4778 buf
= XCONS (XCONS (tail
)->car
)->cdr
;
4781 /* Record all the buffers that have auto save mode
4782 in the special file that lists them. For each of these buffers,
4783 Record visited name (if any) and auto save name. */
4784 if (STRINGP (b
->auto_save_file_name
)
4785 && stream
!= NULL
&& do_handled_files
== 0)
4787 if (!NILP (b
->filename
))
4789 fwrite (XSTRING (b
->filename
)->data
, 1,
4790 XSTRING (b
->filename
)->size_byte
, stream
);
4792 putc ('\n', stream
);
4793 fwrite (XSTRING (b
->auto_save_file_name
)->data
, 1,
4794 XSTRING (b
->auto_save_file_name
)->size_byte
, stream
);
4795 putc ('\n', stream
);
4798 if (!NILP (current_only
)
4799 && b
!= current_buffer
)
4802 /* Don't auto-save indirect buffers.
4803 The base buffer takes care of it. */
4807 /* Check for auto save enabled
4808 and file changed since last auto save
4809 and file changed since last real save. */
4810 if (STRINGP (b
->auto_save_file_name
)
4811 && BUF_SAVE_MODIFF (b
) < BUF_MODIFF (b
)
4812 && b
->auto_save_modified
< BUF_MODIFF (b
)
4813 /* -1 means we've turned off autosaving for a while--see below. */
4814 && XINT (b
->save_length
) >= 0
4815 && (do_handled_files
4816 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
4819 EMACS_TIME before_time
, after_time
;
4821 EMACS_GET_TIME (before_time
);
4823 /* If we had a failure, don't try again for 20 minutes. */
4824 if (b
->auto_save_failure_time
>= 0
4825 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
4828 if ((XFASTINT (b
->save_length
) * 10
4829 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
4830 /* A short file is likely to change a large fraction;
4831 spare the user annoying messages. */
4832 && XFASTINT (b
->save_length
) > 5000
4833 /* These messages are frequent and annoying for `*mail*'. */
4834 && !EQ (b
->filename
, Qnil
)
4835 && NILP (no_message
))
4837 /* It has shrunk too much; turn off auto-saving here. */
4838 minibuffer_auto_raise
= orig_minibuffer_auto_raise
;
4839 message_with_string ("Buffer %s has shrunk a lot; auto save turned off there",
4841 minibuffer_auto_raise
= 0;
4842 /* Turn off auto-saving until there's a real save,
4843 and prevent any more warnings. */
4844 XSETINT (b
->save_length
, -1);
4845 Fsleep_for (make_number (1), Qnil
);
4848 set_buffer_internal (b
);
4849 if (!auto_saved
&& NILP (no_message
))
4850 message1 ("Auto-saving...");
4851 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
4853 b
->auto_save_modified
= BUF_MODIFF (b
);
4854 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4855 set_buffer_internal (old
);
4857 EMACS_GET_TIME (after_time
);
4859 /* If auto-save took more than 60 seconds,
4860 assume it was an NFS failure that got a timeout. */
4861 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
4862 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
4866 /* Prevent another auto save till enough input events come in. */
4867 record_auto_save ();
4869 if (auto_saved
&& NILP (no_message
))
4873 sit_for (1, 0, 0, 0, 0);
4874 message2 (omessage
, omessage_length
, oldmultibyte
);
4877 message1 ("Auto-saving...done");
4882 unbind_to (count
, Qnil
);
4886 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
4887 Sset_buffer_auto_saved
, 0, 0, 0,
4888 "Mark current buffer as auto-saved with its current text.\n\
4889 No auto-save file will be written until the buffer changes again.")
4892 current_buffer
->auto_save_modified
= MODIFF
;
4893 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4894 current_buffer
->auto_save_failure_time
= -1;
4898 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
4899 Sclear_buffer_auto_save_failure
, 0, 0, 0,
4900 "Clear any record of a recent auto-save failure in the current buffer.")
4903 current_buffer
->auto_save_failure_time
= -1;
4907 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
4909 "Return t if buffer has been auto-saved since last read in or saved.")
4912 return (SAVE_MODIFF
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
4915 /* Reading and completing file names */
4916 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
4918 /* In the string VAL, change each $ to $$ and return the result. */
4921 double_dollars (val
)
4924 register unsigned char *old
, *new;
4928 osize
= XSTRING (val
)->size_byte
;
4930 /* Count the number of $ characters. */
4931 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
4932 if (*old
++ == '$') count
++;
4935 old
= XSTRING (val
)->data
;
4936 val
= make_uninit_multibyte_string (XSTRING (val
)->size
+ count
,
4938 new = XSTRING (val
)->data
;
4939 for (n
= osize
; n
> 0; n
--)
4952 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
4954 "Internal subroutine for read-file-name. Do not call this.")
4955 (string
, dir
, action
)
4956 Lisp_Object string
, dir
, action
;
4957 /* action is nil for complete, t for return list of completions,
4958 lambda for verify final value */
4960 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
4962 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
4964 CHECK_STRING (string
, 0);
4971 /* No need to protect ACTION--we only compare it with t and nil. */
4972 GCPRO5 (string
, realdir
, name
, specdir
, orig_string
);
4974 if (XSTRING (string
)->size
== 0)
4976 if (EQ (action
, Qlambda
))
4984 orig_string
= string
;
4985 string
= Fsubstitute_in_file_name (string
);
4986 changed
= NILP (Fstring_equal (string
, orig_string
));
4987 name
= Ffile_name_nondirectory (string
);
4988 val
= Ffile_name_directory (string
);
4990 realdir
= Fexpand_file_name (val
, realdir
);
4995 specdir
= Ffile_name_directory (string
);
4996 val
= Ffile_name_completion (name
, realdir
);
5001 return double_dollars (string
);
5005 if (!NILP (specdir
))
5006 val
= concat2 (specdir
, val
);
5008 return double_dollars (val
);
5011 #endif /* not VMS */
5015 if (EQ (action
, Qt
))
5016 return Ffile_name_all_completions (name
, realdir
);
5017 /* Only other case actually used is ACTION = lambda */
5019 /* Supposedly this helps commands such as `cd' that read directory names,
5020 but can someone explain how it helps them? -- RMS */
5021 if (XSTRING (name
)->size
== 0)
5024 return Ffile_exists_p (string
);
5027 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
5028 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
5029 Value is not expanded---you must call `expand-file-name' yourself.\n\
5030 Default name to DEFAULT-FILENAME if user enters a null string.\n\
5031 (If DEFAULT-FILENAME is omitted, the visited file name is used,\n\
5032 except that if INITIAL is specified, that combined with DIR is used.)\n\
5033 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
5034 Non-nil and non-t means also require confirmation after completion.\n\
5035 Fifth arg INITIAL specifies text to start with.\n\
5036 DIR defaults to current buffer's directory default.")
5037 (prompt
, dir
, default_filename
, mustmatch
, initial
)
5038 Lisp_Object prompt
, dir
, default_filename
, mustmatch
, initial
;
5040 Lisp_Object val
, insdef
, insdef1
, tem
;
5041 struct gcpro gcpro1
, gcpro2
;
5042 register char *homedir
;
5043 int replace_in_history
= 0;
5044 int add_to_history
= 0;
5048 dir
= current_buffer
->directory
;
5049 if (NILP (default_filename
))
5051 if (! NILP (initial
))
5052 default_filename
= Fexpand_file_name (initial
, dir
);
5054 default_filename
= current_buffer
->filename
;
5057 /* If dir starts with user's homedir, change that to ~. */
5058 homedir
= (char *) egetenv ("HOME");
5060 homedir
= strcpy (alloca (strlen (homedir
) + 1), homedir
);
5061 CORRECT_DIR_SEPS (homedir
);
5065 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5066 && IS_DIRECTORY_SEP (XSTRING (dir
)->data
[strlen (homedir
)]))
5068 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5069 XSTRING (dir
)->size_byte
- strlen (homedir
) + 1);
5070 XSTRING (dir
)->data
[0] = '~';
5073 if (insert_default_directory
&& STRINGP (dir
))
5076 if (!NILP (initial
))
5078 Lisp_Object args
[2], pos
;
5082 insdef
= Fconcat (2, args
);
5083 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
5084 insdef1
= Fcons (double_dollars (insdef
), pos
);
5087 insdef1
= double_dollars (insdef
);
5089 else if (STRINGP (initial
))
5092 insdef1
= Fcons (double_dollars (insdef
), make_number (0));
5095 insdef
= Qnil
, insdef1
= Qnil
;
5098 count
= specpdl_ptr
- specpdl
;
5099 specbind (intern ("completion-ignore-case"), Qt
);
5102 GCPRO2 (insdef
, default_filename
);
5103 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5104 dir
, mustmatch
, insdef1
,
5105 Qfile_name_history
, default_filename
, Qnil
);
5107 tem
= Fsymbol_value (Qfile_name_history
);
5108 if (CONSP (tem
) && EQ (XCONS (tem
)->car
, val
))
5109 replace_in_history
= 1;
5111 /* If Fcompleting_read returned the inserted default string itself
5112 (rather than a new string with the same contents),
5113 it has to mean that the user typed RET with the minibuffer empty.
5114 In that case, we really want to return ""
5115 so that commands such as set-visited-file-name can distinguish. */
5116 if (EQ (val
, default_filename
))
5118 /* In this case, Fcompleting_read has not added an element
5119 to the history. Maybe we should. */
5120 if (! replace_in_history
)
5123 val
= build_string ("");
5127 unbind_to (count
, Qnil
);
5132 error ("No file name specified");
5134 tem
= Fstring_equal (val
, insdef
);
5136 if (!NILP (tem
) && !NILP (default_filename
))
5137 val
= default_filename
;
5138 else if (XSTRING (val
)->size
== 0 && NILP (insdef
))
5140 if (!NILP (default_filename
))
5141 val
= default_filename
;
5143 error ("No default file name");
5145 val
= Fsubstitute_in_file_name (val
);
5147 if (replace_in_history
)
5148 /* Replace what Fcompleting_read added to the history
5149 with what we will actually return. */
5150 XCONS (Fsymbol_value (Qfile_name_history
))->car
= val
;
5151 else if (add_to_history
)
5153 /* Add the value to the history--but not if it matches
5154 the last value already there. */
5155 tem
= Fsymbol_value (Qfile_name_history
);
5156 if (! CONSP (tem
) || NILP (Fequal (XCONS (tem
)->car
, val
)))
5157 Fset (Qfile_name_history
,
5165 Qexpand_file_name
= intern ("expand-file-name");
5166 Qsubstitute_in_file_name
= intern ("substitute-in-file-name");
5167 Qdirectory_file_name
= intern ("directory-file-name");
5168 Qfile_name_directory
= intern ("file-name-directory");
5169 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
5170 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
5171 Qfile_name_as_directory
= intern ("file-name-as-directory");
5172 Qcopy_file
= intern ("copy-file");
5173 Qmake_directory_internal
= intern ("make-directory-internal");
5174 Qdelete_directory
= intern ("delete-directory");
5175 Qdelete_file
= intern ("delete-file");
5176 Qrename_file
= intern ("rename-file");
5177 Qadd_name_to_file
= intern ("add-name-to-file");
5178 Qmake_symbolic_link
= intern ("make-symbolic-link");
5179 Qfile_exists_p
= intern ("file-exists-p");
5180 Qfile_executable_p
= intern ("file-executable-p");
5181 Qfile_readable_p
= intern ("file-readable-p");
5182 Qfile_writable_p
= intern ("file-writable-p");
5183 Qfile_symlink_p
= intern ("file-symlink-p");
5184 Qaccess_file
= intern ("access-file");
5185 Qfile_directory_p
= intern ("file-directory-p");
5186 Qfile_regular_p
= intern ("file-regular-p");
5187 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
5188 Qfile_modes
= intern ("file-modes");
5189 Qset_file_modes
= intern ("set-file-modes");
5190 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
5191 Qinsert_file_contents
= intern ("insert-file-contents");
5192 Qwrite_region
= intern ("write-region");
5193 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
5194 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
5196 staticpro (&Qexpand_file_name
);
5197 staticpro (&Qsubstitute_in_file_name
);
5198 staticpro (&Qdirectory_file_name
);
5199 staticpro (&Qfile_name_directory
);
5200 staticpro (&Qfile_name_nondirectory
);
5201 staticpro (&Qunhandled_file_name_directory
);
5202 staticpro (&Qfile_name_as_directory
);
5203 staticpro (&Qcopy_file
);
5204 staticpro (&Qmake_directory_internal
);
5205 staticpro (&Qdelete_directory
);
5206 staticpro (&Qdelete_file
);
5207 staticpro (&Qrename_file
);
5208 staticpro (&Qadd_name_to_file
);
5209 staticpro (&Qmake_symbolic_link
);
5210 staticpro (&Qfile_exists_p
);
5211 staticpro (&Qfile_executable_p
);
5212 staticpro (&Qfile_readable_p
);
5213 staticpro (&Qfile_writable_p
);
5214 staticpro (&Qaccess_file
);
5215 staticpro (&Qfile_symlink_p
);
5216 staticpro (&Qfile_directory_p
);
5217 staticpro (&Qfile_regular_p
);
5218 staticpro (&Qfile_accessible_directory_p
);
5219 staticpro (&Qfile_modes
);
5220 staticpro (&Qset_file_modes
);
5221 staticpro (&Qfile_newer_than_file_p
);
5222 staticpro (&Qinsert_file_contents
);
5223 staticpro (&Qwrite_region
);
5224 staticpro (&Qverify_visited_file_modtime
);
5225 staticpro (&Qset_visited_file_modtime
);
5227 Qfile_name_history
= intern ("file-name-history");
5228 Fset (Qfile_name_history
, Qnil
);
5229 staticpro (&Qfile_name_history
);
5231 Qfile_error
= intern ("file-error");
5232 staticpro (&Qfile_error
);
5233 Qfile_already_exists
= intern ("file-already-exists");
5234 staticpro (&Qfile_already_exists
);
5235 Qfile_date_error
= intern ("file-date-error");
5236 staticpro (&Qfile_date_error
);
5239 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
5240 staticpro (&Qfind_buffer_file_type
);
5243 DEFVAR_LISP ("file-name-coding-system", &Vfile_name_coding_system
,
5244 "*Coding system for encoding file names.\n\
5245 If it is nil, default-file-name-coding-system (which see) is used.");
5246 Vfile_name_coding_system
= Qnil
;
5248 DEFVAR_LISP ("default-file-name-coding-system",
5249 &Vdefault_file_name_coding_system
,
5250 "Default coding system for encoding file names.\n\
5251 This variable is used only when file-name-coding-system is nil.\n\
5253 This variable is set/changed by the command set-language-environment.\n\
5254 User should not set this variable manually,\n\
5255 instead use file-name-coding-system to get a constant encoding\n\
5256 of file names regardless of the current language environment.");
5257 Vdefault_file_name_coding_system
= Qnil
;
5259 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format
,
5260 "*Format in which to write auto-save files.\n\
5261 Should be a list of symbols naming formats that are defined in `format-alist'.\n\
5262 If it is t, which is the default, auto-save files are written in the\n\
5263 same format as a regular save would use.");
5264 Vauto_save_file_format
= Qt
;
5266 Qformat_decode
= intern ("format-decode");
5267 staticpro (&Qformat_decode
);
5268 Qformat_annotate_function
= intern ("format-annotate-function");
5269 staticpro (&Qformat_annotate_function
);
5271 Qcar_less_than_car
= intern ("car-less-than-car");
5272 staticpro (&Qcar_less_than_car
);
5274 Fput (Qfile_error
, Qerror_conditions
,
5275 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
5276 Fput (Qfile_error
, Qerror_message
,
5277 build_string ("File error"));
5279 Fput (Qfile_already_exists
, Qerror_conditions
,
5280 Fcons (Qfile_already_exists
,
5281 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5282 Fput (Qfile_already_exists
, Qerror_message
,
5283 build_string ("File already exists"));
5285 Fput (Qfile_date_error
, Qerror_conditions
,
5286 Fcons (Qfile_date_error
,
5287 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5288 Fput (Qfile_date_error
, Qerror_message
,
5289 build_string ("Cannot set file date"));
5291 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
5292 "*Non-nil means when reading a filename start with default dir in minibuffer.");
5293 insert_default_directory
= 1;
5295 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
5296 "*Non-nil means write new files with record format `stmlf'.\n\
5297 nil means use format `var'. This variable is meaningful only on VMS.");
5298 vms_stmlf_recfm
= 0;
5300 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char
,
5301 "Directory separator character for built-in functions that return file names.\n\
5302 The value should be either ?/ or ?\\ (any other value is treated as ?\\).\n\
5303 This variable affects the built-in functions only on Windows,\n\
5304 on other platforms, it is initialized so that Lisp code can find out\n\
5305 what the normal separator is.");
5306 XSETFASTINT (Vdirectory_sep_char
, '/');
5308 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
5309 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
5310 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
5313 The first argument given to HANDLER is the name of the I/O primitive\n\
5314 to be handled; the remaining arguments are the arguments that were\n\
5315 passed to that primitive. For example, if you do\n\
5316 (file-exists-p FILENAME)\n\
5317 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
5318 (funcall HANDLER 'file-exists-p FILENAME)\n\
5319 The function `find-file-name-handler' checks this list for a handler\n\
5320 for its argument.");
5321 Vfile_name_handler_alist
= Qnil
;
5323 DEFVAR_LISP ("set-auto-coding-function",
5324 &Vset_auto_coding_function
,
5325 "If non-nil, a function to call to decide a coding system of file.\n\
5326 One argument is passed to this function: the string of concatination\n\
5327 or the heading 1K-byte and the tailing 3K-byte of a file to be read.\n\
5328 This function should return a coding system to decode the file contents\n\
5329 specified in the heading lines with the format:\n\
5330 -*- ... coding: CODING-SYSTEM; ... -*-\n\
5331 or local variable spec of the tailing lines with `coding:' tag.");
5332 Vset_auto_coding_function
= Qnil
;
5334 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
5335 "A list of functions to be called at the end of `insert-file-contents'.\n\
5336 Each is passed one argument, the number of bytes inserted. It should return\n\
5337 the new byte count, and leave point the same. If `insert-file-contents' is\n\
5338 intercepted by a handler from `file-name-handler-alist', that handler is\n\
5339 responsible for calling the after-insert-file-functions if appropriate.");
5340 Vafter_insert_file_functions
= Qnil
;
5342 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
5343 "A list of functions to be called at the start of `write-region'.\n\
5344 Each is passed two arguments, START and END as for `write-region'.\n\
5345 These are usually two numbers but not always; see the documentation\n\
5346 for `write-region'. The function should return a list of pairs\n\
5347 of the form (POSITION . STRING), consisting of strings to be effectively\n\
5348 inserted at the specified positions of the file being written (1 means to\n\
5349 insert before the first byte written). The POSITIONs must be sorted into\n\
5350 increasing order. If there are several functions in the list, the several\n\
5351 lists are merged destructively.");
5352 Vwrite_region_annotate_functions
= Qnil
;
5354 DEFVAR_LISP ("write-region-annotations-so-far",
5355 &Vwrite_region_annotations_so_far
,
5356 "When an annotation function is called, this holds the previous annotations.\n\
5357 These are the annotations made by other annotation functions\n\
5358 that were already called. See also `write-region-annotate-functions'.");
5359 Vwrite_region_annotations_so_far
= Qnil
;
5361 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
5362 "A list of file name handlers that temporarily should not be used.\n\
5363 This applies only to the operation `inhibit-file-name-operation'.");
5364 Vinhibit_file_name_handlers
= Qnil
;
5366 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
5367 "The operation for which `inhibit-file-name-handlers' is applicable.");
5368 Vinhibit_file_name_operation
= Qnil
;
5370 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
5371 "File name in which we write a list of all auto save file names.\n\
5372 This variable is initialized automatically from `auto-save-list-file-prefix'\n\
5373 shortly after Emacs reads your `.emacs' file, if you have not yet given it\n\
5375 Vauto_save_list_file_name
= Qnil
;
5377 defsubr (&Sfind_file_name_handler
);
5378 defsubr (&Sfile_name_directory
);
5379 defsubr (&Sfile_name_nondirectory
);
5380 defsubr (&Sunhandled_file_name_directory
);
5381 defsubr (&Sfile_name_as_directory
);
5382 defsubr (&Sdirectory_file_name
);
5383 defsubr (&Smake_temp_name
);
5384 defsubr (&Sexpand_file_name
);
5385 defsubr (&Ssubstitute_in_file_name
);
5386 defsubr (&Scopy_file
);
5387 defsubr (&Smake_directory_internal
);
5388 defsubr (&Sdelete_directory
);
5389 defsubr (&Sdelete_file
);
5390 defsubr (&Srename_file
);
5391 defsubr (&Sadd_name_to_file
);
5393 defsubr (&Smake_symbolic_link
);
5394 #endif /* S_IFLNK */
5396 defsubr (&Sdefine_logical_name
);
5399 defsubr (&Ssysnetunam
);
5400 #endif /* HPUX_NET */
5401 defsubr (&Sfile_name_absolute_p
);
5402 defsubr (&Sfile_exists_p
);
5403 defsubr (&Sfile_executable_p
);
5404 defsubr (&Sfile_readable_p
);
5405 defsubr (&Sfile_writable_p
);
5406 defsubr (&Saccess_file
);
5407 defsubr (&Sfile_symlink_p
);
5408 defsubr (&Sfile_directory_p
);
5409 defsubr (&Sfile_accessible_directory_p
);
5410 defsubr (&Sfile_regular_p
);
5411 defsubr (&Sfile_modes
);
5412 defsubr (&Sset_file_modes
);
5413 defsubr (&Sset_default_file_modes
);
5414 defsubr (&Sdefault_file_modes
);
5415 defsubr (&Sfile_newer_than_file_p
);
5416 defsubr (&Sinsert_file_contents
);
5417 defsubr (&Swrite_region
);
5418 defsubr (&Scar_less_than_car
);
5419 defsubr (&Sverify_visited_file_modtime
);
5420 defsubr (&Sclear_visited_file_modtime
);
5421 defsubr (&Svisited_file_modtime
);
5422 defsubr (&Sset_visited_file_modtime
);
5423 defsubr (&Sdo_auto_save
);
5424 defsubr (&Sset_buffer_auto_saved
);
5425 defsubr (&Sclear_buffer_auto_save_failure
);
5426 defsubr (&Srecent_auto_save_p
);
5428 defsubr (&Sread_file_name_internal
);
5429 defsubr (&Sread_file_name
);
5432 defsubr (&Sunix_sync
);