1 /* File IO for GNU Emacs.
2 Copyright (C) 1985,86,87,88,93,94,95,96,1997 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 /* Encode the file name NAME using the specified coding system
156 for file names, if any. */
157 #define ENCODE_FILE(name) \
158 (! NILP (Vfile_name_coding_system) \
159 && XFASTINT (Vfile_name_coding_system) != 0 \
160 ? Fencode_coding_string (name, Vfile_name_coding_system, Qt) \
163 /* Nonzero during writing of auto-save files */
166 /* Set by auto_save_1 to mode of original file so Fwrite_region will create
167 a new file with the same mode as the original */
168 int auto_save_mode_bits
;
170 /* Coding system for file names, or nil if none. */
171 Lisp_Object Vfile_name_coding_system
;
173 /* Alist of elements (REGEXP . HANDLER) for file names
174 whose I/O is done with a special handler. */
175 Lisp_Object Vfile_name_handler_alist
;
177 /* Format for auto-save files */
178 Lisp_Object Vauto_save_file_format
;
180 /* Lisp functions for translating file formats */
181 Lisp_Object Qformat_decode
, Qformat_annotate_function
;
183 /* Function to be called to decide a coding system of a reading file. */
184 Lisp_Object Vset_auto_coding_function
;
186 /* Functions to be called to process text properties in inserted file. */
187 Lisp_Object Vafter_insert_file_functions
;
189 /* Functions to be called to create text property annotations for file. */
190 Lisp_Object Vwrite_region_annotate_functions
;
192 /* During build_annotations, each time an annotation function is called,
193 this holds the annotations made by the previous functions. */
194 Lisp_Object Vwrite_region_annotations_so_far
;
196 /* File name in which we write a list of all our auto save files. */
197 Lisp_Object Vauto_save_list_file_name
;
199 /* Nonzero means, when reading a filename in the minibuffer,
200 start out by inserting the default directory into the minibuffer. */
201 int insert_default_directory
;
203 /* On VMS, nonzero means write new files with record format stmlf.
204 Zero means use var format. */
207 /* On NT, specifies the directory separator character, used (eg.) when
208 expanding file names. This can be bound to / or \. */
209 Lisp_Object Vdirectory_sep_char
;
211 extern Lisp_Object Vuser_login_name
;
213 extern int minibuf_level
;
215 extern int minibuffer_auto_raise
;
217 /* These variables describe handlers that have "already" had a chance
218 to handle the current operation.
220 Vinhibit_file_name_handlers is a list of file name handlers.
221 Vinhibit_file_name_operation is the operation being handled.
222 If we try to handle that operation, we ignore those handlers. */
224 static Lisp_Object Vinhibit_file_name_handlers
;
225 static Lisp_Object Vinhibit_file_name_operation
;
227 Lisp_Object Qfile_error
, Qfile_already_exists
, Qfile_date_error
;
229 Lisp_Object Qfile_name_history
;
231 Lisp_Object Qcar_less_than_car
;
233 report_file_error (string
, data
)
237 Lisp_Object errstring
;
239 errstring
= build_string (strerror (errno
));
241 /* System error messages are capitalized. Downcase the initial
242 unless it is followed by a slash. */
243 if (XSTRING (errstring
)->data
[1] != '/')
244 XSTRING (errstring
)->data
[0] = DOWNCASE (XSTRING (errstring
)->data
[0]);
247 Fsignal (Qfile_error
,
248 Fcons (build_string (string
), Fcons (errstring
, data
)));
251 close_file_unwind (fd
)
254 close (XFASTINT (fd
));
257 /* Restore point, having saved it as a marker. */
259 restore_point_unwind (location
)
260 Lisp_Object location
;
262 SET_PT (marker_position (location
));
263 Fset_marker (location
, Qnil
, Qnil
);
266 Lisp_Object Qexpand_file_name
;
267 Lisp_Object Qsubstitute_in_file_name
;
268 Lisp_Object Qdirectory_file_name
;
269 Lisp_Object Qfile_name_directory
;
270 Lisp_Object Qfile_name_nondirectory
;
271 Lisp_Object Qunhandled_file_name_directory
;
272 Lisp_Object Qfile_name_as_directory
;
273 Lisp_Object Qcopy_file
;
274 Lisp_Object Qmake_directory_internal
;
275 Lisp_Object Qdelete_directory
;
276 Lisp_Object Qdelete_file
;
277 Lisp_Object Qrename_file
;
278 Lisp_Object Qadd_name_to_file
;
279 Lisp_Object Qmake_symbolic_link
;
280 Lisp_Object Qfile_exists_p
;
281 Lisp_Object Qfile_executable_p
;
282 Lisp_Object Qfile_readable_p
;
283 Lisp_Object Qfile_writable_p
;
284 Lisp_Object Qfile_symlink_p
;
285 Lisp_Object Qaccess_file
;
286 Lisp_Object Qfile_directory_p
;
287 Lisp_Object Qfile_regular_p
;
288 Lisp_Object Qfile_accessible_directory_p
;
289 Lisp_Object Qfile_modes
;
290 Lisp_Object Qset_file_modes
;
291 Lisp_Object Qfile_newer_than_file_p
;
292 Lisp_Object Qinsert_file_contents
;
293 Lisp_Object Qwrite_region
;
294 Lisp_Object Qverify_visited_file_modtime
;
295 Lisp_Object Qset_visited_file_modtime
;
297 DEFUN ("find-file-name-handler", Ffind_file_name_handler
, Sfind_file_name_handler
, 2, 2, 0,
298 "Return FILENAME's handler function for OPERATION, if it has one.\n\
299 Otherwise, return nil.\n\
300 A file name is handled if one of the regular expressions in\n\
301 `file-name-handler-alist' matches it.\n\n\
302 If OPERATION equals `inhibit-file-name-operation', then we ignore\n\
303 any handlers that are members of `inhibit-file-name-handlers',\n\
304 but we still do run any other handlers. This lets handlers\n\
305 use the standard functions without calling themselves recursively.")
306 (filename
, operation
)
307 Lisp_Object filename
, operation
;
309 /* This function must not munge the match data. */
310 Lisp_Object chain
, inhibited_handlers
;
312 CHECK_STRING (filename
, 0);
314 if (EQ (operation
, Vinhibit_file_name_operation
))
315 inhibited_handlers
= Vinhibit_file_name_handlers
;
317 inhibited_handlers
= Qnil
;
319 for (chain
= Vfile_name_handler_alist
; CONSP (chain
);
320 chain
= XCONS (chain
)->cdr
)
323 elt
= XCONS (chain
)->car
;
327 string
= XCONS (elt
)->car
;
328 if (STRINGP (string
) && fast_string_match (string
, filename
) >= 0)
330 Lisp_Object handler
, tem
;
332 handler
= XCONS (elt
)->cdr
;
333 tem
= Fmemq (handler
, inhibited_handlers
);
344 DEFUN ("file-name-directory", Ffile_name_directory
, Sfile_name_directory
,
346 "Return the directory component in file name FILENAME.\n\
347 Return nil if FILENAME does not include a directory.\n\
348 Otherwise return a directory spec.\n\
349 Given a Unix syntax file name, returns a string ending in slash;\n\
350 on VMS, perhaps instead a string ending in `:', `]' or `>'.")
352 Lisp_Object filename
;
354 register unsigned char *beg
;
355 register unsigned char *p
;
358 CHECK_STRING (filename
, 0);
360 /* If the file name has special constructs in it,
361 call the corresponding file handler. */
362 handler
= Ffind_file_name_handler (filename
, Qfile_name_directory
);
364 return call2 (handler
, Qfile_name_directory
, filename
);
366 #ifdef FILE_SYSTEM_CASE
367 filename
= FILE_SYSTEM_CASE (filename
);
369 beg
= XSTRING (filename
)->data
;
371 beg
= strcpy (alloca (strlen (beg
) + 1), beg
);
373 p
= beg
+ XSTRING (filename
)->size
;
375 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
377 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
380 /* only recognise drive specifier at beginning */
381 && !(p
[-1] == ':' && p
== beg
+ 2)
388 /* Expansion of "c:" to drive and default directory. */
389 if (p
== beg
+ 2 && beg
[1] == ':')
391 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
392 unsigned char *res
= alloca (MAXPATHLEN
+ 1);
393 if (getdefdir (toupper (*beg
) - 'A' + 1, res
))
395 if (!IS_DIRECTORY_SEP (res
[strlen (res
) - 1]))
398 p
= beg
+ strlen (beg
);
401 CORRECT_DIR_SEPS (beg
);
403 return make_string (beg
, p
- beg
);
406 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory
, Sfile_name_nondirectory
,
408 "Return file name FILENAME sans its directory.\n\
409 For example, in a Unix-syntax file name,\n\
410 this is everything after the last slash,\n\
411 or the entire name if it contains no slash.")
413 Lisp_Object filename
;
415 register unsigned char *beg
, *p
, *end
;
418 CHECK_STRING (filename
, 0);
420 /* If the file name has special constructs in it,
421 call the corresponding file handler. */
422 handler
= Ffind_file_name_handler (filename
, Qfile_name_nondirectory
);
424 return call2 (handler
, Qfile_name_nondirectory
, filename
);
426 beg
= XSTRING (filename
)->data
;
427 end
= p
= beg
+ XSTRING (filename
)->size
;
429 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
431 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
434 /* only recognise drive specifier at beginning */
435 && !(p
[-1] == ':' && p
== beg
+ 2)
439 return make_string (p
, end
- p
);
442 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory
, Sunhandled_file_name_directory
, 1, 1, 0,
443 "Return a directly usable directory name somehow associated with FILENAME.\n\
444 A `directly usable' directory name is one that may be used without the\n\
445 intervention of any file handler.\n\
446 If FILENAME is a directly usable file itself, return\n\
447 (file-name-directory FILENAME).\n\
448 The `call-process' and `start-process' functions use this function to\n\
449 get a current directory to run processes in.")
451 Lisp_Object filename
;
455 /* If the file name has special constructs in it,
456 call the corresponding file handler. */
457 handler
= Ffind_file_name_handler (filename
, Qunhandled_file_name_directory
);
459 return call2 (handler
, Qunhandled_file_name_directory
, filename
);
461 return Ffile_name_directory (filename
);
466 file_name_as_directory (out
, in
)
469 int size
= strlen (in
) - 1;
474 /* Is it already a directory string? */
475 if (in
[size
] == ':' || in
[size
] == ']' || in
[size
] == '>')
477 /* Is it a VMS directory file name? If so, hack VMS syntax. */
478 else if (! index (in
, '/')
479 && ((size
> 3 && ! strcmp (&in
[size
- 3], ".DIR"))
480 || (size
> 3 && ! strcmp (&in
[size
- 3], ".dir"))
481 || (size
> 5 && (! strncmp (&in
[size
- 5], ".DIR", 4)
482 || ! strncmp (&in
[size
- 5], ".dir", 4))
483 && (in
[size
- 1] == '.' || in
[size
- 1] == ';')
484 && in
[size
] == '1')))
486 register char *p
, *dot
;
490 dir:x.dir --> dir:[x]
491 dir:[x]y.dir --> dir:[x.y] */
493 while (p
!= in
&& *p
!= ':' && *p
!= '>' && *p
!= ']') p
--;
496 strncpy (out
, in
, p
- in
);
515 dot
= index (p
, '.');
518 /* blindly remove any extension */
519 size
= strlen (out
) + (dot
- p
);
520 strncat (out
, p
, dot
- p
);
531 /* For Unix syntax, Append a slash if necessary */
532 if (!IS_DIRECTORY_SEP (out
[size
]))
534 out
[size
+ 1] = DIRECTORY_SEP
;
535 out
[size
+ 2] = '\0';
538 CORRECT_DIR_SEPS (out
);
544 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
545 Sfile_name_as_directory
, 1, 1, 0,
546 "Return a string representing file FILENAME interpreted as a directory.\n\
547 This operation exists because a directory is also a file, but its name as\n\
548 a directory is different from its name as a file.\n\
549 The result can be used as the value of `default-directory'\n\
550 or passed as second argument to `expand-file-name'.\n\
551 For a Unix-syntax file name, just appends a slash.\n\
552 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
559 CHECK_STRING (file
, 0);
563 /* If the file name has special constructs in it,
564 call the corresponding file handler. */
565 handler
= Ffind_file_name_handler (file
, Qfile_name_as_directory
);
567 return call2 (handler
, Qfile_name_as_directory
, file
);
569 buf
= (char *) alloca (XSTRING (file
)->size
+ 10);
570 return build_string (file_name_as_directory (buf
, XSTRING (file
)->data
));
574 * Convert from directory name to filename.
576 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
577 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
578 * On UNIX, it's simple: just make sure there isn't a terminating /
580 * Value is nonzero if the string output is different from the input.
583 directory_file_name (src
, dst
)
591 struct FAB fab
= cc$rms_fab
;
592 struct NAM nam
= cc$rms_nam
;
593 char esa
[NAM$C_MAXRSS
];
598 if (! index (src
, '/')
599 && (src
[slen
- 1] == ']'
600 || src
[slen
- 1] == ':'
601 || src
[slen
- 1] == '>'))
603 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
605 fab
.fab$b_fns
= slen
;
606 fab
.fab$l_nam
= &nam
;
607 fab
.fab$l_fop
= FAB$M_NAM
;
610 nam
.nam$b_ess
= sizeof esa
;
611 nam
.nam$b_nop
|= NAM$M_SYNCHK
;
613 /* We call SYS$PARSE to handle such things as [--] for us. */
614 if (SYS$
PARSE (&fab
, 0, 0) == RMS$_NORMAL
)
616 slen
= nam
.nam$b_esl
;
617 if (esa
[slen
- 1] == ';' && esa
[slen
- 2] == '.')
622 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
624 /* what about when we have logical_name:???? */
625 if (src
[slen
- 1] == ':')
626 { /* Xlate logical name and see what we get */
627 ptr
= strcpy (dst
, src
); /* upper case for getenv */
630 if ('a' <= *ptr
&& *ptr
<= 'z')
634 dst
[slen
- 1] = 0; /* remove colon */
635 if (!(src
= egetenv (dst
)))
637 /* should we jump to the beginning of this procedure?
638 Good points: allows us to use logical names that xlate
640 Bad points: can be a problem if we just translated to a device
642 For now, I'll punt and always expect VMS names, and hope for
645 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
646 { /* no recursion here! */
652 { /* not a directory spec */
657 bracket
= src
[slen
- 1];
659 /* If bracket is ']' or '>', bracket - 2 is the corresponding
661 ptr
= index (src
, bracket
- 2);
663 { /* no opening bracket */
667 if (!(rptr
= rindex (src
, '.')))
670 strncpy (dst
, src
, slen
);
674 dst
[slen
++] = bracket
;
679 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
680 then translate the device and recurse. */
681 if (dst
[slen
- 1] == ':'
682 && dst
[slen
- 2] != ':' /* skip decnet nodes */
683 && strcmp (src
+ slen
, "[000000]") == 0)
685 dst
[slen
- 1] = '\0';
686 if ((ptr
= egetenv (dst
))
687 && (rlen
= strlen (ptr
) - 1) > 0
688 && (ptr
[rlen
] == ']' || ptr
[rlen
] == '>')
689 && ptr
[rlen
- 1] == '.')
691 char * buf
= (char *) alloca (strlen (ptr
) + 1);
695 return directory_file_name (buf
, dst
);
700 strcat (dst
, "[000000]");
704 rlen
= strlen (rptr
) - 1;
705 strncat (dst
, rptr
, rlen
);
706 dst
[slen
+ rlen
] = '\0';
707 strcat (dst
, ".DIR.1");
711 /* Process as Unix format: just remove any final slash.
712 But leave "/" unchanged; do not change it to "". */
715 /* Handle // as root for apollo's. */
716 if ((slen
> 2 && dst
[slen
- 1] == '/')
717 || (slen
> 1 && dst
[0] != '/' && dst
[slen
- 1] == '/'))
721 && IS_DIRECTORY_SEP (dst
[slen
- 1])
723 && !IS_ANY_SEP (dst
[slen
- 2])
729 CORRECT_DIR_SEPS (dst
);
734 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
736 "Returns the file name of the directory named DIRECTORY.\n\
737 This is the name of the file that holds the data for the directory DIRECTORY.\n\
738 This operation exists because a directory is also a file, but its name as\n\
739 a directory is different from its name as a file.\n\
740 In Unix-syntax, this function just removes the final slash.\n\
741 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
742 it returns a file name such as \"[X]Y.DIR.1\".")
744 Lisp_Object directory
;
749 CHECK_STRING (directory
, 0);
751 if (NILP (directory
))
754 /* If the file name has special constructs in it,
755 call the corresponding file handler. */
756 handler
= Ffind_file_name_handler (directory
, Qdirectory_file_name
);
758 return call2 (handler
, Qdirectory_file_name
, directory
);
761 /* 20 extra chars is insufficient for VMS, since we might perform a
762 logical name translation. an equivalence string can be up to 255
763 chars long, so grab that much extra space... - sss */
764 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20 + 255);
766 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20);
768 directory_file_name (XSTRING (directory
)->data
, buf
);
769 return build_string (buf
);
772 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
773 "Generate temporary file name (string) starting with PREFIX (a string).\n\
774 The Emacs process number forms part of the result,\n\
775 so there is no danger of generating a name being used by another process.\n\
776 In addition, this function makes an attempt to choose a name\n\
777 which has no existing file.")
783 /* Don't use too many characters of the restricted 8+3 DOS
785 val
= concat2 (prefix
, build_string ("a.XXX"));
787 val
= concat2 (prefix
, build_string ("XXXXXX"));
789 mktemp (XSTRING (val
)->data
);
791 CORRECT_DIR_SEPS (XSTRING (val
)->data
);
796 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
797 "Convert filename NAME to absolute, and canonicalize it.\n\
798 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative\n\
799 (does not start with slash); if DEFAULT-DIRECTORY is nil or missing,\n\
800 the current buffer's value of default-directory is used.\n\
801 File name components that are `.' are removed, and \n\
802 so are file name components followed by `..', along with the `..' itself;\n\
803 note that these simplifications are done without checking the resulting\n\
804 file names in the file system.\n\
805 An initial `~/' expands to your home directory.\n\
806 An initial `~USER/' expands to USER's home directory.\n\
807 See also the function `substitute-in-file-name'.")
808 (name
, default_directory
)
809 Lisp_Object name
, default_directory
;
813 register unsigned char *newdir
, *p
, *o
;
815 unsigned char *target
;
818 unsigned char * colon
= 0;
819 unsigned char * close
= 0;
820 unsigned char * slash
= 0;
821 unsigned char * brack
= 0;
822 int lbrack
= 0, rbrack
= 0;
827 int collapse_newdir
= 1;
832 CHECK_STRING (name
, 0);
834 /* If the file name has special constructs in it,
835 call the corresponding file handler. */
836 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
838 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
840 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
841 if (NILP (default_directory
))
842 default_directory
= current_buffer
->directory
;
843 if (! STRINGP (default_directory
))
844 default_directory
= build_string ("/");
846 if (!NILP (default_directory
))
848 handler
= Ffind_file_name_handler (default_directory
, Qexpand_file_name
);
850 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
853 o
= XSTRING (default_directory
)->data
;
855 /* Make sure DEFAULT_DIRECTORY is properly expanded.
856 It would be better to do this down below where we actually use
857 default_directory. Unfortunately, calling Fexpand_file_name recursively
858 could invoke GC, and the strings might be relocated. This would
859 be annoying because we have pointers into strings lying around
860 that would need adjusting, and people would add new pointers to
861 the code and forget to adjust them, resulting in intermittent bugs.
862 Putting this call here avoids all that crud.
864 The EQ test avoids infinite recursion. */
865 if (! NILP (default_directory
) && !EQ (default_directory
, name
)
866 /* Save time in some common cases - as long as default_directory
867 is not relative, it can be canonicalized with name below (if it
868 is needed at all) without requiring it to be expanded now. */
870 /* Detect MSDOS file names with drive specifiers. */
871 && ! (IS_DRIVE (o
[0]) && (IS_DEVICE_SEP (o
[1]) && IS_DIRECTORY_SEP (o
[2])))
873 /* Detect Windows file names in UNC format. */
874 && ! (IS_DIRECTORY_SEP (o
[0]) && IS_DIRECTORY_SEP (o
[1]))
876 #else /* not DOS_NT */
877 /* Detect Unix absolute file names (/... alone is not absolute on
879 && ! (IS_DIRECTORY_SEP (o
[0]))
880 #endif /* not DOS_NT */
886 default_directory
= Fexpand_file_name (default_directory
, Qnil
);
891 /* Filenames on VMS are always upper case. */
892 name
= Fupcase (name
);
894 #ifdef FILE_SYSTEM_CASE
895 name
= FILE_SYSTEM_CASE (name
);
898 nm
= XSTRING (name
)->data
;
901 /* We will force directory separators to be either all \ or /, so make
902 a local copy to modify, even if there ends up being no change. */
903 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
905 /* Find and remove drive specifier if present; this makes nm absolute
906 even if the rest of the name appears to be relative. */
908 unsigned char *colon
= rindex (nm
, ':');
911 /* Only recognize colon as part of drive specifier if there is a
912 single alphabetic character preceeding the colon (and if the
913 character before the drive letter, if present, is a directory
914 separator); this is to support the remote system syntax used by
915 ange-ftp, and the "po:username" syntax for POP mailboxes. */
919 else if (IS_DRIVE (colon
[-1])
920 && (colon
== nm
+ 1 || IS_DIRECTORY_SEP (colon
[-2])))
927 while (--colon
>= nm
)
934 /* If we see "c://somedir", we want to strip the first slash after the
935 colon when stripping the drive letter. Otherwise, this expands to
937 if (drive
&& IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
939 #endif /* WINDOWSNT */
943 /* Discard any previous drive specifier if nm is now in UNC format. */
944 if (IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
950 /* If nm is absolute, look for /./ or /../ sequences; if none are
951 found, we can probably return right away. We will avoid allocating
952 a new string if name is already fully expanded. */
954 IS_DIRECTORY_SEP (nm
[0])
959 && (drive
|| IS_DIRECTORY_SEP (nm
[1]))
966 /* If it turns out that the filename we want to return is just a
967 suffix of FILENAME, we don't need to go through and edit
968 things; we just need to construct a new string using data
969 starting at the middle of FILENAME. If we set lose to a
970 non-zero value, that means we've discovered that we can't do
977 /* Since we know the name is absolute, we can assume that each
978 element starts with a "/". */
980 /* "." and ".." are hairy. */
981 if (IS_DIRECTORY_SEP (p
[0])
983 && (IS_DIRECTORY_SEP (p
[2])
985 || (p
[2] == '.' && (IS_DIRECTORY_SEP (p
[3])
992 /* if dev:[dir]/, move nm to / */
993 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
994 nm
= (brack
? brack
+ 1 : colon
+ 1);
1003 /* VMS pre V4.4,convert '-'s in filenames. */
1004 if (lbrack
== rbrack
)
1006 if (dots
< 2) /* this is to allow negative version numbers */
1011 if (lbrack
> rbrack
&&
1012 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1013 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1019 /* count open brackets, reset close bracket pointer */
1020 if (p
[0] == '[' || p
[0] == '<')
1021 lbrack
++, brack
= 0;
1022 /* count close brackets, set close bracket pointer */
1023 if (p
[0] == ']' || p
[0] == '>')
1024 rbrack
++, brack
= p
;
1025 /* detect ][ or >< */
1026 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1028 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1029 nm
= p
+ 1, lose
= 1;
1030 if (p
[0] == ':' && (colon
|| slash
))
1031 /* if dev1:[dir]dev2:, move nm to dev2: */
1037 /* if /name/dev:, move nm to dev: */
1040 /* if node::dev:, move colon following dev */
1041 else if (colon
&& colon
[-1] == ':')
1043 /* if dev1:dev2:, move nm to dev2: */
1044 else if (colon
&& colon
[-1] != ':')
1049 if (p
[0] == ':' && !colon
)
1055 if (lbrack
== rbrack
)
1058 else if (p
[0] == '.')
1066 if (index (nm
, '/'))
1067 return build_string (sys_translate_unix (nm
));
1070 /* Make sure directories are all separated with / or \ as
1071 desired, but avoid allocation of a new string when not
1073 CORRECT_DIR_SEPS (nm
);
1075 if (IS_DIRECTORY_SEP (nm
[1]))
1077 if (strcmp (nm
, XSTRING (name
)->data
) != 0)
1078 name
= build_string (nm
);
1082 /* drive must be set, so this is okay */
1083 if (strcmp (nm
- 2, XSTRING (name
)->data
) != 0)
1085 name
= make_string (nm
- 2, p
- nm
+ 2);
1086 XSTRING (name
)->data
[0] = DRIVE_LETTER (drive
);
1087 XSTRING (name
)->data
[1] = ':';
1090 #else /* not DOS_NT */
1091 if (nm
== XSTRING (name
)->data
)
1093 return build_string (nm
);
1094 #endif /* not DOS_NT */
1098 /* At this point, nm might or might not be an absolute file name. We
1099 need to expand ~ or ~user if present, otherwise prefix nm with
1100 default_directory if nm is not absolute, and finally collapse /./
1101 and /foo/../ sequences.
1103 We set newdir to be the appropriate prefix if one is needed:
1104 - the relevant user directory if nm starts with ~ or ~user
1105 - the specified drive's working dir (DOS/NT only) if nm does not
1107 - the value of default_directory.
1109 Note that these prefixes are not guaranteed to be absolute (except
1110 for the working dir of a drive). Therefore, to ensure we always
1111 return an absolute name, if the final prefix is not absolute we
1112 append it to the current working directory. */
1116 if (nm
[0] == '~') /* prefix ~ */
1118 if (IS_DIRECTORY_SEP (nm
[1])
1122 || nm
[1] == 0) /* ~ by itself */
1124 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1125 newdir
= (unsigned char *) "";
1128 collapse_newdir
= 0;
1131 nm
++; /* Don't leave the slash in nm. */
1134 else /* ~user/filename */
1136 for (p
= nm
; *p
&& (!IS_DIRECTORY_SEP (*p
)
1141 o
= (unsigned char *) alloca (p
- nm
+ 1);
1142 bcopy ((char *) nm
, o
, p
- nm
);
1145 pw
= (struct passwd
*) getpwnam (o
+ 1);
1148 newdir
= (unsigned char *) pw
-> pw_dir
;
1150 nm
= p
+ 1; /* skip the terminator */
1154 collapse_newdir
= 0;
1159 /* If we don't find a user of that name, leave the name
1160 unchanged; don't move nm forward to p. */
1165 /* On DOS and Windows, nm is absolute if a drive name was specified;
1166 use the drive's current directory as the prefix if needed. */
1167 if (!newdir
&& drive
)
1169 /* Get default directory if needed to make nm absolute. */
1170 if (!IS_DIRECTORY_SEP (nm
[0]))
1172 newdir
= alloca (MAXPATHLEN
+ 1);
1173 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1178 /* Either nm starts with /, or drive isn't mounted. */
1179 newdir
= alloca (4);
1180 newdir
[0] = DRIVE_LETTER (drive
);
1188 /* Finally, if no prefix has been specified and nm is not absolute,
1189 then it must be expanded relative to default_directory. */
1193 /* /... alone is not absolute on DOS and Windows. */
1194 && !IS_DIRECTORY_SEP (nm
[0])
1197 && !(IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1204 newdir
= XSTRING (default_directory
)->data
;
1210 /* First ensure newdir is an absolute name. */
1212 /* Detect MSDOS file names with drive specifiers. */
1213 ! (IS_DRIVE (newdir
[0])
1214 && IS_DEVICE_SEP (newdir
[1]) && IS_DIRECTORY_SEP (newdir
[2]))
1216 /* Detect Windows file names in UNC format. */
1217 && ! (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1221 /* Effectively, let newdir be (expand-file-name newdir cwd).
1222 Because of the admonition against calling expand-file-name
1223 when we have pointers into lisp strings, we accomplish this
1224 indirectly by prepending newdir to nm if necessary, and using
1225 cwd (or the wd of newdir's drive) as the new newdir. */
1227 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1232 if (!IS_DIRECTORY_SEP (nm
[0]))
1234 char * tmp
= alloca (strlen (newdir
) + strlen (nm
) + 2);
1235 file_name_as_directory (tmp
, newdir
);
1239 newdir
= alloca (MAXPATHLEN
+ 1);
1242 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1249 /* Strip off drive name from prefix, if present. */
1250 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1256 /* Keep only a prefix from newdir if nm starts with slash
1257 (//server/share for UNC, nothing otherwise). */
1258 if (IS_DIRECTORY_SEP (nm
[0]) && collapse_newdir
)
1261 if (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1263 newdir
= strcpy (alloca (strlen (newdir
) + 1), newdir
);
1265 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1267 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1279 /* Get rid of any slash at the end of newdir, unless newdir is
1280 just // (an incomplete UNC name). */
1281 length
= strlen (newdir
);
1282 if (length
> 0 && IS_DIRECTORY_SEP (newdir
[length
- 1])
1284 && !(length
== 2 && IS_DIRECTORY_SEP (newdir
[0]))
1288 unsigned char *temp
= (unsigned char *) alloca (length
);
1289 bcopy (newdir
, temp
, length
- 1);
1290 temp
[length
- 1] = 0;
1298 /* Now concatenate the directory and name to new space in the stack frame */
1299 tlen
+= strlen (nm
) + 1;
1301 /* Add reserved space for drive name. (The Microsoft x86 compiler
1302 produces incorrect code if the following two lines are combined.) */
1303 target
= (unsigned char *) alloca (tlen
+ 2);
1305 #else /* not DOS_NT */
1306 target
= (unsigned char *) alloca (tlen
);
1307 #endif /* not DOS_NT */
1313 if (nm
[0] == 0 || IS_DIRECTORY_SEP (nm
[0]))
1314 strcpy (target
, newdir
);
1317 file_name_as_directory (target
, newdir
);
1320 strcat (target
, nm
);
1322 if (index (target
, '/'))
1323 strcpy (target
, sys_translate_unix (target
));
1326 /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */
1328 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1336 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1342 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1343 /* brackets are offset from each other by 2 */
1346 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1347 /* convert [foo][bar] to [bar] */
1348 while (o
[-1] != '[' && o
[-1] != '<')
1350 else if (*p
== '-' && *o
!= '.')
1353 else if (p
[0] == '-' && o
[-1] == '.' &&
1354 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1355 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1359 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1360 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1362 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1364 /* else [foo.-] ==> [-] */
1370 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1371 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1377 if (!IS_DIRECTORY_SEP (*p
))
1381 else if (IS_DIRECTORY_SEP (p
[0])
1383 && (IS_DIRECTORY_SEP (p
[2])
1386 /* If "/." is the entire filename, keep the "/". Otherwise,
1387 just delete the whole "/.". */
1388 if (o
== target
&& p
[2] == '\0')
1392 else if (IS_DIRECTORY_SEP (p
[0]) && p
[1] == '.' && p
[2] == '.'
1393 /* `/../' is the "superroot" on certain file systems. */
1395 && (IS_DIRECTORY_SEP (p
[3]) || p
[3] == 0))
1397 while (o
!= target
&& (--o
) && !IS_DIRECTORY_SEP (*o
))
1399 /* Keep initial / only if this is the whole name. */
1400 if (o
== target
&& IS_ANY_SEP (*o
) && p
[3] == 0)
1408 #endif /* not VMS */
1412 /* At last, set drive name. */
1414 /* Except for network file name. */
1415 if (!(IS_DIRECTORY_SEP (target
[0]) && IS_DIRECTORY_SEP (target
[1])))
1416 #endif /* WINDOWSNT */
1418 if (!drive
) abort ();
1420 target
[0] = DRIVE_LETTER (drive
);
1423 CORRECT_DIR_SEPS (target
);
1426 return make_string (target
, o
- target
);
1430 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'. */
1431 DEAFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
1432 "Convert FILENAME to absolute, and canonicalize it.\n\
1433 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1434 (does not start with slash); if DEFAULT is nil or missing,\n\
1435 the current buffer's value of default-directory is used.\n\
1436 Filenames containing `.' or `..' as components are simplified;\n\
1437 initial `~/' expands to your home directory.\n\
1438 See also the function `substitute-in-file-name'.")
1440 Lisp_Object name
, defalt
;
1444 register unsigned char *newdir
, *p
, *o
;
1446 unsigned char *target
;
1450 unsigned char * colon
= 0;
1451 unsigned char * close
= 0;
1452 unsigned char * slash
= 0;
1453 unsigned char * brack
= 0;
1454 int lbrack
= 0, rbrack
= 0;
1458 CHECK_STRING (name
, 0);
1461 /* Filenames on VMS are always upper case. */
1462 name
= Fupcase (name
);
1465 nm
= XSTRING (name
)->data
;
1467 /* If nm is absolute, flush ...// and detect /./ and /../.
1468 If no /./ or /../ we can return right away. */
1480 if (p
[0] == '/' && p
[1] == '/'
1482 /* // at start of filename is meaningful on Apollo system. */
1487 if (p
[0] == '/' && p
[1] == '~')
1488 nm
= p
+ 1, lose
= 1;
1489 if (p
[0] == '/' && p
[1] == '.'
1490 && (p
[2] == '/' || p
[2] == 0
1491 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1497 /* if dev:[dir]/, move nm to / */
1498 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1499 nm
= (brack
? brack
+ 1 : colon
+ 1);
1500 lbrack
= rbrack
= 0;
1508 /* VMS pre V4.4,convert '-'s in filenames. */
1509 if (lbrack
== rbrack
)
1511 if (dots
< 2) /* this is to allow negative version numbers */
1516 if (lbrack
> rbrack
&&
1517 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1518 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1524 /* count open brackets, reset close bracket pointer */
1525 if (p
[0] == '[' || p
[0] == '<')
1526 lbrack
++, brack
= 0;
1527 /* count close brackets, set close bracket pointer */
1528 if (p
[0] == ']' || p
[0] == '>')
1529 rbrack
++, brack
= p
;
1530 /* detect ][ or >< */
1531 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1533 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1534 nm
= p
+ 1, lose
= 1;
1535 if (p
[0] == ':' && (colon
|| slash
))
1536 /* if dev1:[dir]dev2:, move nm to dev2: */
1542 /* If /name/dev:, move nm to dev: */
1545 /* If node::dev:, move colon following dev */
1546 else if (colon
&& colon
[-1] == ':')
1548 /* If dev1:dev2:, move nm to dev2: */
1549 else if (colon
&& colon
[-1] != ':')
1554 if (p
[0] == ':' && !colon
)
1560 if (lbrack
== rbrack
)
1563 else if (p
[0] == '.')
1571 if (index (nm
, '/'))
1572 return build_string (sys_translate_unix (nm
));
1574 if (nm
== XSTRING (name
)->data
)
1576 return build_string (nm
);
1580 /* Now determine directory to start with and put it in NEWDIR */
1584 if (nm
[0] == '~') /* prefix ~ */
1589 || nm
[1] == 0)/* ~/filename */
1591 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1592 newdir
= (unsigned char *) "";
1595 nm
++; /* Don't leave the slash in nm. */
1598 else /* ~user/filename */
1600 /* Get past ~ to user */
1601 unsigned char *user
= nm
+ 1;
1602 /* Find end of name. */
1603 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1604 int len
= ptr
? ptr
- user
: strlen (user
);
1606 unsigned char *ptr1
= index (user
, ':');
1607 if (ptr1
!= 0 && ptr1
- user
< len
)
1610 /* Copy the user name into temp storage. */
1611 o
= (unsigned char *) alloca (len
+ 1);
1612 bcopy ((char *) user
, o
, len
);
1615 /* Look up the user name. */
1616 pw
= (struct passwd
*) getpwnam (o
+ 1);
1618 error ("\"%s\" isn't a registered user", o
+ 1);
1620 newdir
= (unsigned char *) pw
->pw_dir
;
1622 /* Discard the user name from NM. */
1629 #endif /* not VMS */
1633 defalt
= current_buffer
->directory
;
1634 CHECK_STRING (defalt
, 1);
1635 newdir
= XSTRING (defalt
)->data
;
1638 /* Now concatenate the directory and name to new space in the stack frame */
1640 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1641 target
= (unsigned char *) alloca (tlen
);
1647 if (nm
[0] == 0 || nm
[0] == '/')
1648 strcpy (target
, newdir
);
1651 file_name_as_directory (target
, newdir
);
1654 strcat (target
, nm
);
1656 if (index (target
, '/'))
1657 strcpy (target
, sys_translate_unix (target
));
1660 /* Now canonicalize by removing /. and /foo/.. if they appear */
1668 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1674 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1675 /* brackets are offset from each other by 2 */
1678 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1679 /* convert [foo][bar] to [bar] */
1680 while (o
[-1] != '[' && o
[-1] != '<')
1682 else if (*p
== '-' && *o
!= '.')
1685 else if (p
[0] == '-' && o
[-1] == '.' &&
1686 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1687 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1691 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1692 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1694 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1696 /* else [foo.-] ==> [-] */
1702 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1703 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1713 else if (!strncmp (p
, "//", 2)
1715 /* // at start of filename is meaningful in Apollo system. */
1723 else if (p
[0] == '/' && p
[1] == '.' &&
1724 (p
[2] == '/' || p
[2] == 0))
1726 else if (!strncmp (p
, "/..", 3)
1727 /* `/../' is the "superroot" on certain file systems. */
1729 && (p
[3] == '/' || p
[3] == 0))
1731 while (o
!= target
&& *--o
!= '/')
1734 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1738 if (o
== target
&& *o
== '/')
1746 #endif /* not VMS */
1749 return make_string (target
, o
- target
);
1753 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1754 Ssubstitute_in_file_name
, 1, 1, 0,
1755 "Substitute environment variables referred to in FILENAME.\n\
1756 `$FOO' where FOO is an environment variable name means to substitute\n\
1757 the value of that variable. The variable name should be terminated\n\
1758 with a character not a letter, digit or underscore; otherwise, enclose\n\
1759 the entire variable name in braces.\n\
1760 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1761 On VMS, `$' substitution is not done; this function does little and only\n\
1762 duplicates what `expand-file-name' does.")
1764 Lisp_Object filename
;
1768 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1769 unsigned char *target
;
1771 int substituted
= 0;
1773 Lisp_Object handler
;
1775 CHECK_STRING (filename
, 0);
1777 /* If the file name has special constructs in it,
1778 call the corresponding file handler. */
1779 handler
= Ffind_file_name_handler (filename
, Qsubstitute_in_file_name
);
1780 if (!NILP (handler
))
1781 return call2 (handler
, Qsubstitute_in_file_name
, filename
);
1783 nm
= XSTRING (filename
)->data
;
1785 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
1786 CORRECT_DIR_SEPS (nm
);
1787 substituted
= (strcmp (nm
, XSTRING (filename
)->data
) != 0);
1789 endp
= nm
+ XSTRING (filename
)->size
;
1791 /* If /~ or // appears, discard everything through first slash. */
1793 for (p
= nm
; p
!= endp
; p
++)
1796 #if defined (APOLLO) || defined (WINDOWSNT)
1797 /* // at start of file name is meaningful in Apollo and
1798 WindowsNT systems. */
1799 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != nm
)
1800 #else /* not (APOLLO || WINDOWSNT) */
1801 || IS_DIRECTORY_SEP (p
[0])
1802 #endif /* not (APOLLO || WINDOWSNT) */
1807 || p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>'
1809 || IS_DIRECTORY_SEP (p
[-1])))
1815 /* see comment in expand-file-name about drive specifiers */
1816 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
1817 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
1826 return build_string (nm
);
1829 /* See if any variables are substituted into the string
1830 and find the total length of their values in `total' */
1832 for (p
= nm
; p
!= endp
;)
1842 /* "$$" means a single "$" */
1851 while (p
!= endp
&& *p
!= '}') p
++;
1852 if (*p
!= '}') goto missingclose
;
1858 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1862 /* Copy out the variable name */
1863 target
= (unsigned char *) alloca (s
- o
+ 1);
1864 strncpy (target
, o
, s
- o
);
1867 strupr (target
); /* $home == $HOME etc. */
1870 /* Get variable value */
1871 o
= (unsigned char *) egetenv (target
);
1872 if (!o
) goto badvar
;
1873 total
+= strlen (o
);
1880 /* If substitution required, recopy the string and do it */
1881 /* Make space in stack frame for the new copy */
1882 xnm
= (unsigned char *) alloca (XSTRING (filename
)->size
+ total
+ 1);
1885 /* Copy the rest of the name through, replacing $ constructs with values */
1902 while (p
!= endp
&& *p
!= '}') p
++;
1903 if (*p
!= '}') goto missingclose
;
1909 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1913 /* Copy out the variable name */
1914 target
= (unsigned char *) alloca (s
- o
+ 1);
1915 strncpy (target
, o
, s
- o
);
1918 strupr (target
); /* $home == $HOME etc. */
1921 /* Get variable value */
1922 o
= (unsigned char *) egetenv (target
);
1932 /* If /~ or // appears, discard everything through first slash. */
1934 for (p
= xnm
; p
!= x
; p
++)
1936 #if defined (APOLLO) || defined (WINDOWSNT)
1937 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != xnm
)
1938 #else /* not (APOLLO || WINDOWSNT) */
1939 || IS_DIRECTORY_SEP (p
[0])
1940 #endif /* not (APOLLO || WINDOWSNT) */
1942 && p
!= xnm
&& IS_DIRECTORY_SEP (p
[-1]))
1945 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
1946 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
1950 return make_string (xnm
, x
- xnm
);
1953 error ("Bad format environment-variable substitution");
1955 error ("Missing \"}\" in environment-variable substitution");
1957 error ("Substituting nonexistent environment variable \"%s\"", target
);
1960 #endif /* not VMS */
1963 /* A slightly faster and more convenient way to get
1964 (directory-file-name (expand-file-name FOO)). */
1967 expand_and_dir_to_file (filename
, defdir
)
1968 Lisp_Object filename
, defdir
;
1970 register Lisp_Object absname
;
1972 absname
= Fexpand_file_name (filename
, defdir
);
1975 register int c
= XSTRING (absname
)->data
[XSTRING (absname
)->size
- 1];
1976 if (c
== ':' || c
== ']' || c
== '>')
1977 absname
= Fdirectory_file_name (absname
);
1980 /* Remove final slash, if any (unless this is the root dir).
1981 stat behaves differently depending! */
1982 if (XSTRING (absname
)->size
> 1
1983 && IS_DIRECTORY_SEP (XSTRING (absname
)->data
[XSTRING (absname
)->size
- 1])
1984 && !IS_DEVICE_SEP (XSTRING (absname
)->data
[XSTRING (absname
)->size
-2]))
1985 /* We cannot take shortcuts; they might be wrong for magic file names. */
1986 absname
= Fdirectory_file_name (absname
);
1991 /* Signal an error if the file ABSNAME already exists.
1992 If INTERACTIVE is nonzero, ask the user whether to proceed,
1993 and bypass the error if the user says to go ahead.
1994 QUERYSTRING is a name for the action that is being considered
1996 *STATPTR is used to store the stat information if the file exists.
1997 If the file does not exist, STATPTR->st_mode is set to 0. */
2000 barf_or_query_if_file_exists (absname
, querystring
, interactive
, statptr
)
2001 Lisp_Object absname
;
2002 unsigned char *querystring
;
2004 struct stat
*statptr
;
2006 register Lisp_Object tem
;
2007 struct stat statbuf
;
2008 struct gcpro gcpro1
;
2010 /* stat is a good way to tell whether the file exists,
2011 regardless of what access permissions it has. */
2012 if (stat (XSTRING (absname
)->data
, &statbuf
) >= 0)
2015 Fsignal (Qfile_already_exists
,
2016 Fcons (build_string ("File already exists"),
2017 Fcons (absname
, Qnil
)));
2019 tem
= do_yes_or_no_p (format1 ("File %s already exists; %s anyway? ",
2020 XSTRING (absname
)->data
, querystring
));
2023 Fsignal (Qfile_already_exists
,
2024 Fcons (build_string ("File already exists"),
2025 Fcons (absname
, Qnil
)));
2032 statptr
->st_mode
= 0;
2037 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
2038 "fCopy file: \nFCopy %s to file: \np\nP",
2039 "Copy FILE to NEWNAME. Both args must be strings.\n\
2040 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
2041 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
2042 A number as third arg means request confirmation if NEWNAME already exists.\n\
2043 This is what happens in interactive use with M-x.\n\
2044 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
2045 last-modified time as the old one. (This works on only some systems.)\n\
2046 A prefix arg makes KEEP-TIME non-nil.")
2047 (file
, newname
, ok_if_already_exists
, keep_date
)
2048 Lisp_Object file
, newname
, ok_if_already_exists
, keep_date
;
2051 char buf
[16 * 1024];
2052 struct stat st
, out_st
;
2053 Lisp_Object handler
;
2054 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2055 int count
= specpdl_ptr
- specpdl
;
2056 int input_file_statable_p
;
2057 Lisp_Object encoded_file
, encoded_newname
;
2059 encoded_file
= encoded_newname
= Qnil
;
2060 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2061 CHECK_STRING (file
, 0);
2062 CHECK_STRING (newname
, 1);
2064 file
= Fexpand_file_name (file
, Qnil
);
2065 newname
= Fexpand_file_name (newname
, Qnil
);
2067 /* If the input file name has special constructs in it,
2068 call the corresponding file handler. */
2069 handler
= Ffind_file_name_handler (file
, Qcopy_file
);
2070 /* Likewise for output file name. */
2072 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
2073 if (!NILP (handler
))
2074 RETURN_UNGCPRO (call5 (handler
, Qcopy_file
, file
, newname
,
2075 ok_if_already_exists
, keep_date
));
2077 encoded_file
= ENCODE_FILE (file
);
2078 encoded_newname
= ENCODE_FILE (newname
);
2080 if (NILP (ok_if_already_exists
)
2081 || INTEGERP (ok_if_already_exists
))
2082 barf_or_query_if_file_exists (encoded_newname
, "copy to it",
2083 INTEGERP (ok_if_already_exists
), &out_st
);
2084 else if (stat (XSTRING (encoded_newname
)->data
, &out_st
) < 0)
2087 ifd
= open (XSTRING (encoded_file
)->data
, O_RDONLY
);
2089 report_file_error ("Opening input file", Fcons (file
, Qnil
));
2091 record_unwind_protect (close_file_unwind
, make_number (ifd
));
2093 /* We can only copy regular files and symbolic links. Other files are not
2095 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
2097 #if !defined (MSDOS) || __DJGPP__ > 1
2098 if (out_st
.st_mode
!= 0
2099 && st
.st_dev
== out_st
.st_dev
&& st
.st_ino
== out_st
.st_ino
)
2102 report_file_error ("Input and output files are the same",
2103 Fcons (file
, Fcons (newname
, Qnil
)));
2107 #if defined (S_ISREG) && defined (S_ISLNK)
2108 if (input_file_statable_p
)
2110 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
2112 #if defined (EISDIR)
2113 /* Get a better looking error message. */
2116 report_file_error ("Non-regular file", Fcons (file
, Qnil
));
2119 #endif /* S_ISREG && S_ISLNK */
2122 /* Create the copy file with the same record format as the input file */
2123 ofd
= sys_creat (XSTRING (encoded_newname
)->data
, 0666, ifd
);
2126 /* System's default file type was set to binary by _fmode in emacs.c. */
2127 ofd
= creat (XSTRING (encoded_newname
)->data
, S_IREAD
| S_IWRITE
);
2128 #else /* not MSDOS */
2129 ofd
= creat (XSTRING (encoded_newname
)->data
, 0666);
2130 #endif /* not MSDOS */
2133 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
2135 record_unwind_protect (close_file_unwind
, make_number (ofd
));
2139 while ((n
= read (ifd
, buf
, sizeof buf
)) > 0)
2140 if (write (ofd
, buf
, n
) != n
)
2141 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2144 /* Closing the output clobbers the file times on some systems. */
2145 if (close (ofd
) < 0)
2146 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2148 if (input_file_statable_p
)
2150 if (!NILP (keep_date
))
2152 EMACS_TIME atime
, mtime
;
2153 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
2154 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
2155 if (set_file_times (XSTRING (encoded_newname
)->data
,
2157 Fsignal (Qfile_date_error
,
2158 Fcons (build_string ("Cannot set file date"),
2159 Fcons (newname
, Qnil
)));
2162 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2164 #if defined (__DJGPP__) && __DJGPP__ > 1
2165 /* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
2166 and if it can't, it tells so. Otherwise, under MSDOS we usually
2167 get only the READ bit, which will make the copied file read-only,
2168 so it's better not to chmod at all. */
2169 if ((_djstat_flags
& _STFAIL_WRITEBIT
) == 0)
2170 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2171 #endif /* DJGPP version 2 or newer */
2177 /* Discard the unwind protects. */
2178 specpdl_ptr
= specpdl
+ count
;
2184 DEFUN ("make-directory-internal", Fmake_directory_internal
,
2185 Smake_directory_internal
, 1, 1, 0,
2186 "Create a new directory named DIRECTORY.")
2188 Lisp_Object directory
;
2191 Lisp_Object handler
;
2192 Lisp_Object encoded_dir
;
2194 CHECK_STRING (directory
, 0);
2195 directory
= Fexpand_file_name (directory
, Qnil
);
2197 handler
= Ffind_file_name_handler (directory
, Qmake_directory_internal
);
2198 if (!NILP (handler
))
2199 return call2 (handler
, Qmake_directory_internal
, directory
);
2201 encoded_dir
= ENCODE_FILE (directory
);
2203 dir
= XSTRING (encoded_dir
)->data
;
2206 if (mkdir (dir
) != 0)
2208 if (mkdir (dir
, 0777) != 0)
2210 report_file_error ("Creating directory", Flist (1, &directory
));
2215 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
2216 "Delete the directory named DIRECTORY.")
2218 Lisp_Object directory
;
2221 Lisp_Object handler
;
2222 Lisp_Object encoded_dir
;
2224 CHECK_STRING (directory
, 0);
2225 directory
= Fdirectory_file_name (Fexpand_file_name (directory
, Qnil
));
2227 handler
= Ffind_file_name_handler (directory
, Qdelete_directory
);
2228 if (!NILP (handler
))
2229 return call2 (handler
, Qdelete_directory
, directory
);
2231 encoded_dir
= ENCODE_FILE (directory
);
2233 dir
= XSTRING (encoded_dir
)->data
;
2235 if (rmdir (dir
) != 0)
2236 report_file_error ("Removing directory", Flist (1, &directory
));
2241 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
2242 "Delete file named FILENAME.\n\
2243 If file has multiple names, it continues to exist with the other names.")
2245 Lisp_Object filename
;
2247 Lisp_Object handler
;
2248 Lisp_Object encoded_file
;
2250 CHECK_STRING (filename
, 0);
2251 filename
= Fexpand_file_name (filename
, Qnil
);
2253 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
2254 if (!NILP (handler
))
2255 return call2 (handler
, Qdelete_file
, filename
);
2257 encoded_file
= ENCODE_FILE (filename
);
2259 if (0 > unlink (XSTRING (encoded_file
)->data
))
2260 report_file_error ("Removing old name", Flist (1, &filename
));
2265 internal_delete_file_1 (ignore
)
2271 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */
2274 internal_delete_file (filename
)
2275 Lisp_Object filename
;
2277 return NILP (internal_condition_case_1 (Fdelete_file
, filename
,
2278 Qt
, internal_delete_file_1
));
2281 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
2282 "fRename file: \nFRename %s to file: \np",
2283 "Rename FILE as NEWNAME. Both args strings.\n\
2284 If file has names other than FILE, it continues to have those names.\n\
2285 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2286 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2287 A number as third arg means request confirmation if NEWNAME already exists.\n\
2288 This is what happens in interactive use with M-x.")
2289 (file
, newname
, ok_if_already_exists
)
2290 Lisp_Object file
, newname
, ok_if_already_exists
;
2293 Lisp_Object args
[2];
2295 Lisp_Object handler
;
2296 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2297 Lisp_Object encoded_file
, encoded_newname
;
2299 encoded_file
= encoded_newname
= Qnil
;
2300 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2301 CHECK_STRING (file
, 0);
2302 CHECK_STRING (newname
, 1);
2303 file
= Fexpand_file_name (file
, Qnil
);
2304 newname
= Fexpand_file_name (newname
, Qnil
);
2306 /* If the file name has special constructs in it,
2307 call the corresponding file handler. */
2308 handler
= Ffind_file_name_handler (file
, Qrename_file
);
2310 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
2311 if (!NILP (handler
))
2312 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
2313 file
, newname
, ok_if_already_exists
));
2315 encoded_file
= ENCODE_FILE (file
);
2316 encoded_newname
= ENCODE_FILE (newname
);
2318 if (NILP (ok_if_already_exists
)
2319 || INTEGERP (ok_if_already_exists
))
2320 barf_or_query_if_file_exists (encoded_newname
, "rename to it",
2321 INTEGERP (ok_if_already_exists
), 0);
2323 if (0 > rename (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2325 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
)
2326 || 0 > unlink (XSTRING (encoded_file
)->data
))
2331 Fcopy_file (file
, newname
,
2332 /* We have already prompted if it was an integer,
2333 so don't have copy-file prompt again. */
2334 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
2335 Fdelete_file (file
);
2342 report_file_error ("Renaming", Flist (2, args
));
2345 report_file_error ("Renaming", Flist (2, &file
));
2352 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
2353 "fAdd name to file: \nFName to add to %s: \np",
2354 "Give FILE additional name NEWNAME. Both args strings.\n\
2355 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2356 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2357 A number as third arg means request confirmation if NEWNAME already exists.\n\
2358 This is what happens in interactive use with M-x.")
2359 (file
, newname
, ok_if_already_exists
)
2360 Lisp_Object file
, newname
, ok_if_already_exists
;
2363 Lisp_Object args
[2];
2365 Lisp_Object handler
;
2366 Lisp_Object encoded_file
, encoded_newname
;
2367 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2369 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2370 encoded_file
= encoded_newname
= Qnil
;
2371 CHECK_STRING (file
, 0);
2372 CHECK_STRING (newname
, 1);
2373 file
= Fexpand_file_name (file
, Qnil
);
2374 newname
= Fexpand_file_name (newname
, Qnil
);
2376 /* If the file name has special constructs in it,
2377 call the corresponding file handler. */
2378 handler
= Ffind_file_name_handler (file
, Qadd_name_to_file
);
2379 if (!NILP (handler
))
2380 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2381 newname
, ok_if_already_exists
));
2383 /* If the new name has special constructs in it,
2384 call the corresponding file handler. */
2385 handler
= Ffind_file_name_handler (newname
, Qadd_name_to_file
);
2386 if (!NILP (handler
))
2387 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2388 newname
, ok_if_already_exists
));
2390 encoded_file
= ENCODE_FILE (file
);
2391 encoded_newname
= ENCODE_FILE (newname
);
2393 if (NILP (ok_if_already_exists
)
2394 || INTEGERP (ok_if_already_exists
))
2395 barf_or_query_if_file_exists (encoded_newname
, "make it a new name",
2396 INTEGERP (ok_if_already_exists
), 0);
2398 unlink (XSTRING (newname
)->data
);
2399 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2404 report_file_error ("Adding new name", Flist (2, args
));
2406 report_file_error ("Adding new name", Flist (2, &file
));
2415 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2416 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2417 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
2418 Signals a `file-already-exists' error if a file LINKNAME already exists\n\
2419 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2420 A number as third arg means request confirmation if LINKNAME already exists.\n\
2421 This happens for interactive use with M-x.")
2422 (filename
, linkname
, ok_if_already_exists
)
2423 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2426 Lisp_Object args
[2];
2428 Lisp_Object handler
;
2429 Lisp_Object encoded_filename
, encoded_linkname
;
2430 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2432 GCPRO4 (filename
, linkname
, encoded_filename
, encoded_linkname
);
2433 encoded_filename
= encoded_linkname
= Qnil
;
2434 CHECK_STRING (filename
, 0);
2435 CHECK_STRING (linkname
, 1);
2436 /* If the link target has a ~, we must expand it to get
2437 a truly valid file name. Otherwise, do not expand;
2438 we want to permit links to relative file names. */
2439 if (XSTRING (filename
)->data
[0] == '~')
2440 filename
= Fexpand_file_name (filename
, Qnil
);
2441 linkname
= Fexpand_file_name (linkname
, Qnil
);
2443 /* If the file name has special constructs in it,
2444 call the corresponding file handler. */
2445 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2446 if (!NILP (handler
))
2447 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2448 linkname
, ok_if_already_exists
));
2450 /* If the new link name has special constructs in it,
2451 call the corresponding file handler. */
2452 handler
= Ffind_file_name_handler (linkname
, Qmake_symbolic_link
);
2453 if (!NILP (handler
))
2454 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2455 linkname
, ok_if_already_exists
));
2457 encoded_filename
= ENCODE_FILE (filename
);
2458 encoded_linkname
= ENCODE_FILE (linkname
);
2460 if (NILP (ok_if_already_exists
)
2461 || INTEGERP (ok_if_already_exists
))
2462 barf_or_query_if_file_exists (encoded_linkname
, "make it a link",
2463 INTEGERP (ok_if_already_exists
), 0);
2464 if (0 > symlink (XSTRING (encoded_filename
)->data
,
2465 XSTRING (encoded_linkname
)->data
))
2467 /* If we didn't complain already, silently delete existing file. */
2468 if (errno
== EEXIST
)
2470 unlink (XSTRING (encoded_linkname
)->data
);
2471 if (0 <= symlink (XSTRING (encoded_filename
)->data
,
2472 XSTRING (encoded_linkname
)->data
))
2482 report_file_error ("Making symbolic link", Flist (2, args
));
2484 report_file_error ("Making symbolic link", Flist (2, &filename
));
2490 #endif /* S_IFLNK */
2494 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2495 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2496 "Define the job-wide logical name NAME to have the value STRING.\n\
2497 If STRING is nil or a null string, the logical name NAME is deleted.")
2502 CHECK_STRING (name
, 0);
2504 delete_logical_name (XSTRING (name
)->data
);
2507 CHECK_STRING (string
, 1);
2509 if (XSTRING (string
)->size
== 0)
2510 delete_logical_name (XSTRING (name
)->data
);
2512 define_logical_name (XSTRING (name
)->data
, XSTRING (string
)->data
);
2521 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2522 "Open a network connection to PATH using LOGIN as the login string.")
2524 Lisp_Object path
, login
;
2528 CHECK_STRING (path
, 0);
2529 CHECK_STRING (login
, 0);
2531 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2533 if (netresult
== -1)
2538 #endif /* HPUX_NET */
2540 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2542 "Return t if file FILENAME specifies an absolute file name.\n\
2543 On Unix, this is a name starting with a `/' or a `~'.")
2545 Lisp_Object filename
;
2549 CHECK_STRING (filename
, 0);
2550 ptr
= XSTRING (filename
)->data
;
2551 if (IS_DIRECTORY_SEP (*ptr
) || *ptr
== '~'
2553 /* ??? This criterion is probably wrong for '<'. */
2554 || index (ptr
, ':') || index (ptr
, '<')
2555 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2559 || (IS_DRIVE (*ptr
) && ptr
[1] == ':' && IS_DIRECTORY_SEP (ptr
[2]))
2567 /* Return nonzero if file FILENAME exists and can be executed. */
2570 check_executable (filename
)
2574 int len
= strlen (filename
);
2577 if (stat (filename
, &st
) < 0)
2579 #if defined (WINDOWSNT) || (defined (MSDOS) && __DJGPP__ > 1)
2580 return ((st
.st_mode
& S_IEXEC
) != 0);
2582 return (S_ISREG (st
.st_mode
)
2584 && (stricmp ((suffix
= filename
+ len
-4), ".com") == 0
2585 || stricmp (suffix
, ".exe") == 0
2586 || stricmp (suffix
, ".bat") == 0)
2587 || (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2588 #endif /* not WINDOWSNT */
2589 #else /* not DOS_NT */
2590 #ifdef HAVE_EUIDACCESS
2591 return (euidaccess (filename
, 1) >= 0);
2593 /* Access isn't quite right because it uses the real uid
2594 and we really want to test with the effective uid.
2595 But Unix doesn't give us a right way to do it. */
2596 return (access (filename
, 1) >= 0);
2598 #endif /* not DOS_NT */
2601 /* Return nonzero if file FILENAME exists and can be written. */
2604 check_writable (filename
)
2609 if (stat (filename
, &st
) < 0)
2611 return (st
.st_mode
& S_IWRITE
|| (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2612 #else /* not MSDOS */
2613 #ifdef HAVE_EUIDACCESS
2614 return (euidaccess (filename
, 2) >= 0);
2616 /* Access isn't quite right because it uses the real uid
2617 and we really want to test with the effective uid.
2618 But Unix doesn't give us a right way to do it.
2619 Opening with O_WRONLY could work for an ordinary file,
2620 but would lose for directories. */
2621 return (access (filename
, 2) >= 0);
2623 #endif /* not MSDOS */
2626 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2627 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
2628 See also `file-readable-p' and `file-attributes'.")
2630 Lisp_Object filename
;
2632 Lisp_Object absname
;
2633 Lisp_Object handler
;
2634 struct stat statbuf
;
2636 CHECK_STRING (filename
, 0);
2637 absname
= Fexpand_file_name (filename
, Qnil
);
2639 /* If the file name has special constructs in it,
2640 call the corresponding file handler. */
2641 handler
= Ffind_file_name_handler (absname
, Qfile_exists_p
);
2642 if (!NILP (handler
))
2643 return call2 (handler
, Qfile_exists_p
, absname
);
2645 absname
= ENCODE_FILE (absname
);
2647 return (stat (XSTRING (absname
)->data
, &statbuf
) >= 0) ? Qt
: Qnil
;
2650 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2651 "Return t if FILENAME can be executed by you.\n\
2652 For a directory, this means you can access files in that directory.")
2654 Lisp_Object filename
;
2657 Lisp_Object absname
;
2658 Lisp_Object handler
;
2660 CHECK_STRING (filename
, 0);
2661 absname
= Fexpand_file_name (filename
, Qnil
);
2663 /* If the file name has special constructs in it,
2664 call the corresponding file handler. */
2665 handler
= Ffind_file_name_handler (absname
, Qfile_executable_p
);
2666 if (!NILP (handler
))
2667 return call2 (handler
, Qfile_executable_p
, absname
);
2669 absname
= ENCODE_FILE (absname
);
2671 return (check_executable (XSTRING (absname
)->data
) ? Qt
: Qnil
);
2674 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2675 "Return t if file FILENAME exists and you can read it.\n\
2676 See also `file-exists-p' and `file-attributes'.")
2678 Lisp_Object filename
;
2680 Lisp_Object absname
;
2681 Lisp_Object handler
;
2684 struct stat statbuf
;
2686 CHECK_STRING (filename
, 0);
2687 absname
= Fexpand_file_name (filename
, Qnil
);
2689 /* If the file name has special constructs in it,
2690 call the corresponding file handler. */
2691 handler
= Ffind_file_name_handler (absname
, Qfile_readable_p
);
2692 if (!NILP (handler
))
2693 return call2 (handler
, Qfile_readable_p
, absname
);
2695 absname
= ENCODE_FILE (absname
);
2698 /* Under MS-DOS and Windows, open does not work for directories. */
2699 if (access (XSTRING (absname
)->data
, 0) == 0)
2702 #else /* not DOS_NT */
2704 #if defined (S_ISFIFO) && defined (O_NONBLOCK)
2705 /* Opening a fifo without O_NONBLOCK can wait.
2706 We don't want to wait. But we don't want to mess wth O_NONBLOCK
2707 except in the case of a fifo, on a system which handles it. */
2708 desc
= stat (XSTRING (absname
)->data
, &statbuf
);
2711 if (S_ISFIFO (statbuf
.st_mode
))
2712 flags
|= O_NONBLOCK
;
2714 desc
= open (XSTRING (absname
)->data
, flags
);
2719 #endif /* not DOS_NT */
2722 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2724 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
2725 "Return t if file FILENAME can be written or created by you.")
2727 Lisp_Object filename
;
2729 Lisp_Object absname
, dir
, encoded
;
2730 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_writable_p
);
2739 if (!NILP (handler
))
2740 return call2 (handler
, Qfile_writable_p
, absname
);
2742 encoded
= ENCODE_FILE (absname
);
2743 if (stat (XSTRING (encoded
)->data
, &statbuf
) >= 0)
2744 return (check_writable (XSTRING (encoded
)->data
)
2747 dir
= Ffile_name_directory (absname
);
2750 dir
= Fdirectory_file_name (dir
);
2754 dir
= Fdirectory_file_name (dir
);
2757 dir
= ENCODE_FILE (dir
);
2758 return (check_writable (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "")
2762 DEFUN ("access-file", Faccess_file
, Saccess_file
, 2, 2, 0,
2763 "Access file FILENAME, and get an error if that does not work.\n\
2764 The second argument STRING is used in the error message.\n\
2765 If there is no error, we return nil.")
2767 Lisp_Object filename
, string
;
2769 Lisp_Object handler
, encoded_filename
;
2772 CHECK_STRING (filename
, 0);
2774 /* If the file name has special constructs in it,
2775 call the corresponding file handler. */
2776 handler
= Ffind_file_name_handler (filename
, Qaccess_file
);
2777 if (!NILP (handler
))
2778 return call3 (handler
, Qaccess_file
, filename
, string
);
2780 encoded_filename
= ENCODE_FILE (filename
);
2782 fd
= open (XSTRING (encoded_filename
)->data
, O_RDONLY
);
2784 report_file_error (XSTRING (string
)->data
, Fcons (filename
, Qnil
));
2790 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
2791 "Return non-nil if file FILENAME is the name of a symbolic link.\n\
2792 The value is the name of the file to which it is linked.\n\
2793 Otherwise returns nil.")
2795 Lisp_Object filename
;
2802 Lisp_Object handler
;
2804 CHECK_STRING (filename
, 0);
2805 filename
= Fexpand_file_name (filename
, Qnil
);
2807 /* If the file name has special constructs in it,
2808 call the corresponding file handler. */
2809 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
2810 if (!NILP (handler
))
2811 return call2 (handler
, Qfile_symlink_p
, filename
);
2813 filename
= ENCODE_FILE (filename
);
2818 buf
= (char *) xmalloc (bufsize
);
2819 bzero (buf
, bufsize
);
2820 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
2821 if (valsize
< bufsize
) break;
2822 /* Buffer was not long enough */
2831 val
= make_string (buf
, valsize
);
2833 return Fdecode_coding_string (val
, Vfile_name_coding_system
, Qt
);
2834 #else /* not S_IFLNK */
2836 #endif /* not S_IFLNK */
2839 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
2840 "Return t if FILENAME names an existing directory.")
2842 Lisp_Object filename
;
2844 register Lisp_Object absname
;
2846 Lisp_Object handler
;
2848 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2850 /* If the file name has special constructs in it,
2851 call the corresponding file handler. */
2852 handler
= Ffind_file_name_handler (absname
, Qfile_directory_p
);
2853 if (!NILP (handler
))
2854 return call2 (handler
, Qfile_directory_p
, absname
);
2856 absname
= ENCODE_FILE (absname
);
2858 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2860 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
2863 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
2864 "Return t if file FILENAME is the name of a directory as a file,\n\
2865 and files in that directory can be opened by you. In order to use a\n\
2866 directory as a buffer's current directory, this predicate must return true.\n\
2867 A directory name spec may be given instead; then the value is t\n\
2868 if the directory so specified exists and really is a readable and\n\
2869 searchable directory.")
2871 Lisp_Object filename
;
2873 Lisp_Object handler
;
2875 struct gcpro gcpro1
;
2877 /* If the file name has special constructs in it,
2878 call the corresponding file handler. */
2879 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
2880 if (!NILP (handler
))
2881 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
2883 /* It's an unlikely combination, but yes we really do need to gcpro:
2884 Suppose that file-accessible-directory-p has no handler, but
2885 file-directory-p does have a handler; this handler causes a GC which
2886 relocates the string in `filename'; and finally file-directory-p
2887 returns non-nil. Then we would end up passing a garbaged string
2888 to file-executable-p. */
2890 tem
= (NILP (Ffile_directory_p (filename
))
2891 || NILP (Ffile_executable_p (filename
)));
2893 return tem
? Qnil
: Qt
;
2896 DEFUN ("file-regular-p", Ffile_regular_p
, Sfile_regular_p
, 1, 1, 0,
2897 "Return t if file FILENAME is the name of a regular file.\n\
2898 This is the sort of file that holds an ordinary stream of data bytes.")
2900 Lisp_Object filename
;
2902 register Lisp_Object absname
;
2904 Lisp_Object handler
;
2906 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2908 /* If the file name has special constructs in it,
2909 call the corresponding file handler. */
2910 handler
= Ffind_file_name_handler (absname
, Qfile_regular_p
);
2911 if (!NILP (handler
))
2912 return call2 (handler
, Qfile_regular_p
, absname
);
2914 absname
= ENCODE_FILE (absname
);
2916 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2918 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
2921 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
2922 "Return mode bits of file named FILENAME, as an integer.")
2924 Lisp_Object filename
;
2926 Lisp_Object absname
;
2928 Lisp_Object handler
;
2930 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2932 /* If the file name has special constructs in it,
2933 call the corresponding file handler. */
2934 handler
= Ffind_file_name_handler (absname
, Qfile_modes
);
2935 if (!NILP (handler
))
2936 return call2 (handler
, Qfile_modes
, absname
);
2938 absname
= ENCODE_FILE (absname
);
2940 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2942 #if defined (MSDOS) && __DJGPP__ < 2
2943 if (check_executable (XSTRING (absname
)->data
))
2944 st
.st_mode
|= S_IEXEC
;
2945 #endif /* MSDOS && __DJGPP__ < 2 */
2947 return make_number (st
.st_mode
& 07777);
2950 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
2951 "Set mode bits of file named FILENAME to MODE (an integer).\n\
2952 Only the 12 low bits of MODE are used.")
2954 Lisp_Object filename
, mode
;
2956 Lisp_Object absname
, encoded_absname
;
2957 Lisp_Object handler
;
2959 absname
= Fexpand_file_name (filename
, current_buffer
->directory
);
2960 CHECK_NUMBER (mode
, 1);
2962 /* If the file name has special constructs in it,
2963 call the corresponding file handler. */
2964 handler
= Ffind_file_name_handler (absname
, Qset_file_modes
);
2965 if (!NILP (handler
))
2966 return call3 (handler
, Qset_file_modes
, absname
, mode
);
2968 encoded_absname
= ENCODE_FILE (absname
);
2970 if (chmod (XSTRING (encoded_absname
)->data
, XINT (mode
)) < 0)
2971 report_file_error ("Doing chmod", Fcons (absname
, Qnil
));
2976 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
2977 "Set the file permission bits for newly created files.\n\
2978 The argument MODE should be an integer; only the low 9 bits are used.\n\
2979 This setting is inherited by subprocesses.")
2983 CHECK_NUMBER (mode
, 0);
2985 umask ((~ XINT (mode
)) & 0777);
2990 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
2991 "Return the default file protection for created files.\n\
2992 The value is an integer.")
2998 realmask
= umask (0);
3001 XSETINT (value
, (~ realmask
) & 0777);
3007 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
3008 "Tell Unix to finish all pending disk updates.")
3017 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
3018 "Return t if file FILE1 is newer than file FILE2.\n\
3019 If FILE1 does not exist, the answer is nil;\n\
3020 otherwise, if FILE2 does not exist, the answer is t.")
3022 Lisp_Object file1
, file2
;
3024 Lisp_Object absname1
, absname2
;
3027 Lisp_Object handler
;
3028 struct gcpro gcpro1
, gcpro2
;
3030 CHECK_STRING (file1
, 0);
3031 CHECK_STRING (file2
, 0);
3034 GCPRO2 (absname1
, file2
);
3035 absname1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
3036 absname2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
3039 /* If the file name has special constructs in it,
3040 call the corresponding file handler. */
3041 handler
= Ffind_file_name_handler (absname1
, Qfile_newer_than_file_p
);
3043 handler
= Ffind_file_name_handler (absname2
, Qfile_newer_than_file_p
);
3044 if (!NILP (handler
))
3045 return call3 (handler
, Qfile_newer_than_file_p
, absname1
, absname2
);
3047 GCPRO2 (absname1
, absname2
);
3048 absname1
= ENCODE_FILE (absname1
);
3049 absname2
= ENCODE_FILE (absname2
);
3052 if (stat (XSTRING (absname1
)->data
, &st
) < 0)
3055 mtime1
= st
.st_mtime
;
3057 if (stat (XSTRING (absname2
)->data
, &st
) < 0)
3060 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
3064 Lisp_Object Qfind_buffer_file_type
;
3067 #ifndef READ_BUF_SIZE
3068 #define READ_BUF_SIZE (64 << 10)
3071 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
3073 "Insert contents of file FILENAME after point.\n\
3074 Returns list of absolute file name and length of data inserted.\n\
3075 If second argument VISIT is non-nil, the buffer's visited filename\n\
3076 and last save file modtime are set, and it is marked unmodified.\n\
3077 If visiting and the file does not exist, visiting is completed\n\
3078 before the error is signaled.\n\
3079 The optional third and fourth arguments BEG and END\n\
3080 specify what portion of the file to insert.\n\
3081 If VISIT is non-nil, BEG and END must be nil.\n\
3083 If optional fifth argument REPLACE is non-nil,\n\
3084 it means replace the current buffer contents (in the accessible portion)\n\
3085 with the file contents. This is better than simply deleting and inserting\n\
3086 the whole thing because (1) it preserves some marker positions\n\
3087 and (2) it puts less data in the undo list.\n\
3088 When REPLACE is non-nil, the value is the number of characters actually read,\n\
3089 which is often less than the number of characters to be read.\n\
3090 This does code conversion according to the value of\n\
3091 `coding-system-for-read' or `file-coding-system-alist',\n\
3092 and sets the variable `last-coding-system-used' to the coding system\n\
3094 (filename
, visit
, beg
, end
, replace
)
3095 Lisp_Object filename
, visit
, beg
, end
, replace
;
3099 register int inserted
= 0;
3100 register int how_much
;
3101 register int unprocessed
;
3102 int count
= specpdl_ptr
- specpdl
;
3103 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3104 Lisp_Object handler
, val
, insval
, orig_filename
;
3107 int not_regular
= 0;
3108 char read_buf
[READ_BUF_SIZE
];
3109 struct coding_system coding
;
3110 unsigned char buffer
[1 << 14];
3111 int replace_handled
= 0;
3113 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3114 error ("Cannot do file visiting in an indirect buffer");
3116 if (!NILP (current_buffer
->read_only
))
3117 Fbarf_if_buffer_read_only ();
3121 orig_filename
= Qnil
;
3123 GCPRO4 (filename
, val
, p
, orig_filename
);
3125 CHECK_STRING (filename
, 0);
3126 filename
= Fexpand_file_name (filename
, Qnil
);
3128 /* If the file name has special constructs in it,
3129 call the corresponding file handler. */
3130 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
3131 if (!NILP (handler
))
3133 val
= call6 (handler
, Qinsert_file_contents
, filename
,
3134 visit
, beg
, end
, replace
);
3138 orig_filename
= filename
;
3139 filename
= ENCODE_FILE (filename
);
3144 if (stat (XSTRING (filename
)->data
, &st
) < 0)
3146 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0
3147 || fstat (fd
, &st
) < 0)
3148 #endif /* not APOLLO */
3150 if (fd
>= 0) close (fd
);
3153 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3156 if (!NILP (Vcoding_system_for_read
))
3157 current_buffer
->buffer_file_coding_system
= Vcoding_system_for_read
;
3162 /* This code will need to be changed in order to work on named
3163 pipes, and it's probably just not worth it. So we should at
3164 least signal an error. */
3165 if (!S_ISREG (st
.st_mode
))
3172 if (! NILP (replace
) || ! NILP (beg
) || ! NILP (end
))
3173 Fsignal (Qfile_error
,
3174 Fcons (build_string ("not a regular file"),
3175 Fcons (orig_filename
, Qnil
)));
3180 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0)
3183 /* Replacement should preserve point as it preserves markers. */
3184 if (!NILP (replace
))
3185 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
3187 record_unwind_protect (close_file_unwind
, make_number (fd
));
3189 /* Supposedly happens on VMS. */
3190 if (! not_regular
&& st
.st_size
< 0)
3191 error ("File size is negative");
3193 if (!NILP (beg
) || !NILP (end
))
3195 error ("Attempt to visit less than an entire file");
3198 CHECK_NUMBER (beg
, 0);
3200 XSETFASTINT (beg
, 0);
3203 CHECK_NUMBER (end
, 0);
3208 XSETINT (end
, st
.st_size
);
3209 if (XINT (end
) != st
.st_size
)
3210 error ("Maximum buffer size exceeded");
3214 /* Decide the coding-system of the file. */
3216 Lisp_Object val
= Qnil
;
3218 if (!NILP (Vcoding_system_for_read
))
3219 val
= Vcoding_system_for_read
;
3220 else if (NILP (current_buffer
->enable_multibyte_characters
))
3224 if (! NILP (Vset_auto_coding_function
))
3226 /* Find a coding system specified in the heading two lines
3227 or in the tailing several lines of the file. We assume
3228 that the 1K-byte and 3K-byte for heading and tailing
3229 respectively are sufficient fot this purpose. */
3230 int how_many
, nread
;
3232 if (st
.st_size
<= (1024 * 4))
3233 nread
= read (fd
, read_buf
, 1024 * 4);
3236 nread
= read (fd
, read_buf
, 1024);
3239 if (lseek (fd
, st
.st_size
- (1024 * 3), 0) < 0)
3240 report_file_error ("Setting file position",
3241 Fcons (orig_filename
, Qnil
));
3242 nread
+= read (fd
, read_buf
+ nread
, 1024 * 3);
3247 error ("IO error reading %s: %s",
3248 XSTRING (orig_filename
)->data
, strerror (errno
));
3251 val
= call1 (Vset_auto_coding_function
,
3252 make_string (read_buf
, nread
));
3253 /* Rewind the file for the actual read done later. */
3254 if (lseek (fd
, 0, 0) < 0)
3255 report_file_error ("Setting file position",
3256 Fcons (orig_filename
, Qnil
));
3261 Lisp_Object args
[6], coding_systems
;
3263 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
,
3264 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = replace
;
3265 coding_systems
= Ffind_operation_coding_system (6, args
);
3266 if (CONSP (coding_systems
)) val
= XCONS (coding_systems
)->car
;
3269 setup_coding_system (Fcheck_coding_system (val
), &coding
);
3272 /* If requested, replace the accessible part of the buffer
3273 with the file contents. Avoid replacing text at the
3274 beginning or end of the buffer that matches the file contents;
3275 that preserves markers pointing to the unchanged parts.
3277 Here we implement this feature in an optimized way
3278 for the case where code conversion is NOT needed.
3279 The following if-statement handles the case of conversion
3280 in a less optimal way.
3282 If the code conversion is "automatic" then we try using this
3283 method and hope for the best.
3284 But if we discover the need for conversion, we give up on this method
3285 and let the following if-statement handle the replace job. */
3287 && ! CODING_REQUIRE_DECODING (&coding
))
3289 int same_at_start
= BEGV
;
3290 int same_at_end
= ZV
;
3292 /* There is still a possibility we will find the need to do code
3293 conversion. If that happens, we set this variable to 1 to
3294 give up on handling REPLACE in the optimized way. */
3295 int giveup_match_end
= 0;
3297 if (XINT (beg
) != 0)
3299 if (lseek (fd
, XINT (beg
), 0) < 0)
3300 report_file_error ("Setting file position",
3301 Fcons (orig_filename
, Qnil
));
3306 /* Count how many chars at the start of the file
3307 match the text at the beginning of the buffer. */
3312 nread
= read (fd
, buffer
, sizeof buffer
);
3314 error ("IO error reading %s: %s",
3315 XSTRING (orig_filename
)->data
, strerror (errno
));
3316 else if (nread
== 0)
3319 if (coding
.type
== coding_type_undecided
)
3320 detect_coding (&coding
, buffer
, nread
);
3321 if (CODING_REQUIRE_DECODING (&coding
))
3322 /* We found that the file should be decoded somehow.
3323 Let's give up here. */
3325 giveup_match_end
= 1;
3329 if (coding
.eol_type
== CODING_EOL_UNDECIDED
)
3330 detect_eol (&coding
, buffer
, nread
);
3331 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3332 && coding
.eol_type
!= CODING_EOL_LF
)
3333 /* We found that the format of eol should be decoded.
3334 Let's give up here. */
3336 giveup_match_end
= 1;
3341 while (bufpos
< nread
&& same_at_start
< ZV
3342 && FETCH_BYTE (same_at_start
) == buffer
[bufpos
])
3343 same_at_start
++, bufpos
++;
3344 /* If we found a discrepancy, stop the scan.
3345 Otherwise loop around and scan the next bufferful. */
3346 if (bufpos
!= nread
)
3350 /* If the file matches the buffer completely,
3351 there's no need to replace anything. */
3352 if (same_at_start
- BEGV
== XINT (end
))
3356 /* Truncate the buffer to the size of the file. */
3357 del_range_1 (same_at_start
, same_at_end
, 0);
3362 /* Count how many chars at the end of the file
3363 match the text at the end of the buffer. But, if we have
3364 already found that decoding is necessary, don't waste time. */
3365 while (!giveup_match_end
)
3367 int total_read
, nread
, bufpos
, curpos
, trial
;
3369 /* At what file position are we now scanning? */
3370 curpos
= XINT (end
) - (ZV
- same_at_end
);
3371 /* If the entire file matches the buffer tail, stop the scan. */
3374 /* How much can we scan in the next step? */
3375 trial
= min (curpos
, sizeof buffer
);
3376 if (lseek (fd
, curpos
- trial
, 0) < 0)
3377 report_file_error ("Setting file position",
3378 Fcons (orig_filename
, Qnil
));
3381 while (total_read
< trial
)
3383 nread
= read (fd
, buffer
+ total_read
, trial
- total_read
);
3385 error ("IO error reading %s: %s",
3386 XSTRING (orig_filename
)->data
, strerror (errno
));
3387 total_read
+= nread
;
3389 /* Scan this bufferful from the end, comparing with
3390 the Emacs buffer. */
3391 bufpos
= total_read
;
3392 /* Compare with same_at_start to avoid counting some buffer text
3393 as matching both at the file's beginning and at the end. */
3394 while (bufpos
> 0 && same_at_end
> same_at_start
3395 && FETCH_BYTE (same_at_end
- 1) == buffer
[bufpos
- 1])
3396 same_at_end
--, bufpos
--;
3398 /* If we found a discrepancy, stop the scan.
3399 Otherwise loop around and scan the preceding bufferful. */
3402 /* If this discrepancy is because of code conversion,
3403 we cannot use this method; giveup and try the other. */
3404 if (same_at_end
> same_at_start
3405 && FETCH_BYTE (same_at_end
- 1) >= 0200
3406 && ! NILP (current_buffer
->enable_multibyte_characters
)
3407 && (CODING_REQUIRE_DECODING (&coding
)
3408 || CODING_REQUIRE_DETECTION (&coding
)))
3409 giveup_match_end
= 1;
3415 if (! giveup_match_end
)
3417 /* We win! We can handle REPLACE the optimized way. */
3419 /* Extends the end of non-matching text area to multibyte
3420 character boundary. */
3421 if (! NILP (current_buffer
->enable_multibyte_characters
))
3422 while (same_at_end
< ZV
&& ! CHAR_HEAD_P (POS_ADDR (same_at_end
)))
3425 /* Don't try to reuse the same piece of text twice. */
3426 overlap
= same_at_start
- BEGV
- (same_at_end
+ st
.st_size
- ZV
);
3428 same_at_end
+= overlap
;
3430 /* Arrange to read only the nonmatching middle part of the file. */
3431 XSETFASTINT (beg
, XINT (beg
) + (same_at_start
- BEGV
));
3432 XSETFASTINT (end
, XINT (end
) - (ZV
- same_at_end
));
3434 del_range_1 (same_at_start
, same_at_end
, 0);
3435 /* Insert from the file at the proper position. */
3436 SET_PT (same_at_start
);
3438 /* If display currently starts at beginning of line,
3439 keep it that way. */
3440 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3441 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3443 replace_handled
= 1;
3447 /* If requested, replace the accessible part of the buffer
3448 with the file contents. Avoid replacing text at the
3449 beginning or end of the buffer that matches the file contents;
3450 that preserves markers pointing to the unchanged parts.
3452 Here we implement this feature for the case where code conversion
3453 is needed, in a simple way that needs a lot of memory.
3454 The preceding if-statement handles the case of no conversion
3455 in a more optimized way. */
3456 if (!NILP (replace
) && ! replace_handled
)
3458 int same_at_start
= BEGV
;
3459 int same_at_end
= ZV
;
3462 /* Make sure that the gap is large enough. */
3463 int bufsize
= 2 * st
.st_size
;
3464 unsigned char *conversion_buffer
= (unsigned char *) xmalloc (bufsize
);
3466 /* First read the whole file, performing code conversion into
3467 CONVERSION_BUFFER. */
3469 if (lseek (fd
, XINT (beg
), 0) < 0)
3471 free (conversion_buffer
);
3472 report_file_error ("Setting file position",
3473 Fcons (orig_filename
, Qnil
));
3476 total
= st
.st_size
; /* Total bytes in the file. */
3477 how_much
= 0; /* Bytes read from file so far. */
3478 inserted
= 0; /* Bytes put into CONVERSION_BUFFER so far. */
3479 unprocessed
= 0; /* Bytes not processed in previous loop. */
3481 while (how_much
< total
)
3483 /* try is reserved in some compilers (Microsoft C) */
3484 int trytry
= min (total
- how_much
, READ_BUF_SIZE
- unprocessed
);
3485 char *destination
= read_buf
+ unprocessed
;
3488 /* Allow quitting out of the actual I/O. */
3491 this = read (fd
, destination
, trytry
);
3494 if (this < 0 || this + unprocessed
== 0)
3502 if (CODING_REQUIRE_DECODING (&coding
)
3503 || CODING_REQUIRE_DETECTION (&coding
))
3505 int require
, produced
, consumed
;
3507 this += unprocessed
;
3509 /* If we are using more space than estimated,
3510 make CONVERSION_BUFFER bigger. */
3511 require
= decoding_buffer_size (&coding
, this);
3512 if (inserted
+ require
+ 2 * (total
- how_much
) > bufsize
)
3514 bufsize
= inserted
+ require
+ 2 * (total
- how_much
);
3515 conversion_buffer
= (unsigned char *) xrealloc (conversion_buffer
, bufsize
);
3518 /* Convert this batch with results in CONVERSION_BUFFER. */
3519 if (how_much
>= total
) /* This is the last block. */
3520 coding
.last_block
= 1;
3521 produced
= decode_coding (&coding
, read_buf
,
3522 conversion_buffer
+ inserted
,
3523 this, bufsize
- inserted
,
3526 /* Save for next iteration whatever we didn't convert. */
3527 unprocessed
= this - consumed
;
3528 bcopy (read_buf
+ consumed
, read_buf
, unprocessed
);
3535 /* At this point, INSERTED is how many characters
3536 are present in CONVERSION_BUFFER.
3537 HOW_MUCH should equal TOTAL,
3538 or should be <= 0 if we couldn't read the file. */
3542 free (conversion_buffer
);
3545 error ("IO error reading %s: %s",
3546 XSTRING (orig_filename
)->data
, strerror (errno
));
3547 else if (how_much
== -2)
3548 error ("maximum buffer size exceeded");
3551 /* Compare the beginning of the converted file
3552 with the buffer text. */
3555 while (bufpos
< inserted
&& same_at_start
< same_at_end
3556 && FETCH_BYTE (same_at_start
) == conversion_buffer
[bufpos
])
3557 same_at_start
++, bufpos
++;
3559 /* If the file matches the buffer completely,
3560 there's no need to replace anything. */
3562 if (bufpos
== inserted
)
3564 free (conversion_buffer
);
3567 /* Truncate the buffer to the size of the file. */
3568 del_range_1 (same_at_start
, same_at_end
, 0);
3572 /* Scan this bufferful from the end, comparing with
3573 the Emacs buffer. */
3576 /* Compare with same_at_start to avoid counting some buffer text
3577 as matching both at the file's beginning and at the end. */
3578 while (bufpos
> 0 && same_at_end
> same_at_start
3579 && FETCH_BYTE (same_at_end
- 1) == conversion_buffer
[bufpos
- 1])
3580 same_at_end
--, bufpos
--;
3582 /* Don't try to reuse the same piece of text twice. */
3583 overlap
= same_at_start
- BEGV
- (same_at_end
+ inserted
- ZV
);
3585 same_at_end
+= overlap
;
3587 /* If display currently starts at beginning of line,
3588 keep it that way. */
3589 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3590 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3592 /* Replace the chars that we need to replace,
3593 and update INSERTED to equal the number of bytes
3594 we are taking from the file. */
3595 inserted
-= (Z
- same_at_end
) + (same_at_start
- BEG
);
3596 move_gap (same_at_start
);
3597 del_range_1 (same_at_start
, same_at_end
, 0);
3598 SET_PT (same_at_start
);
3599 insert_1 (conversion_buffer
+ same_at_start
- BEG
, inserted
, 0, 0);
3601 free (conversion_buffer
);
3610 register Lisp_Object temp
;
3612 total
= XINT (end
) - XINT (beg
);
3614 /* Make sure point-max won't overflow after this insertion. */
3615 XSETINT (temp
, total
);
3616 if (total
!= XINT (temp
))
3617 error ("Maximum buffer size exceeded");
3620 /* For a special file, all we can do is guess. */
3621 total
= READ_BUF_SIZE
;
3623 if (NILP (visit
) && total
> 0)
3624 prepare_to_modify_buffer (PT
, PT
, NULL
);
3627 if (GAP_SIZE
< total
)
3628 make_gap (total
- GAP_SIZE
);
3630 if (XINT (beg
) != 0 || !NILP (replace
))
3632 if (lseek (fd
, XINT (beg
), 0) < 0)
3633 report_file_error ("Setting file position",
3634 Fcons (orig_filename
, Qnil
));
3637 /* In the following loop, HOW_MUCH contains the total bytes read so
3638 far. Before exiting the loop, it is set to -1 if I/O error
3639 occurs, set to -2 if the maximum buffer size is exceeded. */
3641 /* Total bytes inserted. */
3643 /* Bytes not processed in the previous loop because short gap size. */
3645 while (how_much
< total
)
3647 /* try is reserved in some compilers (Microsoft C) */
3648 int trytry
= min (total
- how_much
, READ_BUF_SIZE
- unprocessed
);
3649 char *destination
= (! (CODING_REQUIRE_DECODING (&coding
)
3650 || CODING_REQUIRE_DETECTION (&coding
))
3651 ? (char *) (POS_ADDR (PT
+ inserted
- 1) + 1)
3652 : read_buf
+ unprocessed
);
3655 /* Allow quitting out of the actual I/O. */
3658 this = read (fd
, destination
, trytry
);
3661 if (this < 0 || this + unprocessed
== 0)
3667 /* For a regular file, where TOTAL is the real size,
3668 count HOW_MUCH to compare with it.
3669 For a special file, where TOTAL is just a buffer size,
3670 so don't bother counting in HOW_MUCH.
3671 (INSERTED is where we count the number of characters inserted.) */
3675 if (CODING_REQUIRE_DECODING (&coding
)
3676 || CODING_REQUIRE_DETECTION (&coding
))
3678 int require
, produced
, consumed
;
3680 this += unprocessed
;
3681 /* Make sure that the gap is large enough. */
3682 require
= decoding_buffer_size (&coding
, this);
3683 if (GAP_SIZE
< require
)
3684 make_gap (require
- GAP_SIZE
);
3688 if (how_much
>= total
) /* This is the last block. */
3689 coding
.last_block
= 1;
3693 /* If we encounter EOF, say it is the last block. (The
3694 data this will apply to is the UNPROCESSED characters
3695 carried over from the last batch.) */
3697 coding
.last_block
= 1;
3700 produced
= decode_coding (&coding
, read_buf
,
3701 POS_ADDR (PT
+ inserted
- 1) + 1,
3702 this, GAP_SIZE
, &consumed
);
3707 XSET (temp
, Lisp_Int
, Z
+ produced
);
3708 if (Z
+ produced
!= XINT (temp
))
3714 unprocessed
= this - consumed
;
3715 bcopy (read_buf
+ consumed
, read_buf
, unprocessed
);
3724 /* Put an anchor to ensure multi-byte form ends at gap. */
3731 /* Use the conversion type to determine buffer-file-type
3732 (find-buffer-file-type is now used to help determine the
3734 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3735 && coding
.eol_type
!= CODING_EOL_LF
)
3736 current_buffer
->buffer_file_type
= Qnil
;
3738 current_buffer
->buffer_file_type
= Qt
;
3741 /* We don't have to consider file type of MSDOS because all files
3742 are read as binary and end-of-line format has already been
3743 decoded appropriately. */
3746 /* Demacs 1.1.1 91/10/16 HIRANO Satoshi, MW July 1993 */
3747 /* Determine file type from name and remove LFs from CR-LFs if the file
3748 is deemed to be a text file. */
3750 current_buffer
->buffer_file_type
3751 = call1 (Qfind_buffer_file_type
, orig_filename
);
3752 if (NILP (current_buffer
->buffer_file_type
))
3755 = inserted
- crlf_to_lf (inserted
, POS_ADDR (PT
- 1) + 1);
3758 GPT
-= reduced_size
;
3759 GAP_SIZE
+= reduced_size
;
3760 inserted
-= reduced_size
;
3768 record_insert (PT
, inserted
);
3770 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
3771 offset_intervals (current_buffer
, PT
, inserted
);
3777 /* Discard the unwind protect for closing the file. */
3781 error ("IO error reading %s: %s",
3782 XSTRING (orig_filename
)->data
, strerror (errno
));
3783 else if (how_much
== -2)
3784 error ("maximum buffer size exceeded");
3791 if (!EQ (current_buffer
->undo_list
, Qt
))
3792 current_buffer
->undo_list
= Qnil
;
3794 stat (XSTRING (filename
)->data
, &st
);
3799 current_buffer
->modtime
= st
.st_mtime
;
3800 current_buffer
->filename
= orig_filename
;
3803 SAVE_MODIFF
= MODIFF
;
3804 current_buffer
->auto_save_modified
= MODIFF
;
3805 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
3806 #ifdef CLASH_DETECTION
3809 if (!NILP (current_buffer
->file_truename
))
3810 unlock_file (current_buffer
->file_truename
);
3811 unlock_file (filename
);
3813 #endif /* CLASH_DETECTION */
3815 Fsignal (Qfile_error
,
3816 Fcons (build_string ("not a regular file"),
3817 Fcons (orig_filename
, Qnil
)));
3819 /* If visiting nonexistent file, return nil. */
3820 if (current_buffer
->modtime
== -1)
3821 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3824 /* Decode file format */
3827 insval
= call3 (Qformat_decode
,
3828 Qnil
, make_number (inserted
), visit
);
3829 CHECK_NUMBER (insval
, 0);
3830 inserted
= XFASTINT (insval
);
3833 /* Call after-change hooks for the inserted text, aside from the case
3834 of normal visiting (not with REPLACE), which is done in a new buffer
3835 "before" the buffer is changed. */
3836 if (inserted
> 0 && total
> 0
3837 && (NILP (visit
) || !NILP (replace
)))
3838 signal_after_change (PT
, 0, inserted
);
3842 p
= Vafter_insert_file_functions
;
3843 if (!NILP (coding
.post_read_conversion
))
3844 p
= Fcons (coding
.post_read_conversion
, p
);
3848 insval
= call1 (Fcar (p
), make_number (inserted
));
3851 CHECK_NUMBER (insval
, 0);
3852 inserted
= XFASTINT (insval
);
3860 val
= Fcons (orig_filename
,
3861 Fcons (make_number (inserted
),
3864 RETURN_UNGCPRO (unbind_to (count
, val
));
3867 static Lisp_Object
build_annotations ();
3868 extern Lisp_Object
Ffile_locked_p ();
3870 /* If build_annotations switched buffers, switch back to BUF.
3871 Kill the temporary buffer that was selected in the meantime.
3873 Since this kill only the last temporary buffer, some buffers remain
3874 not killed if build_annotations switched buffers more than once.
3878 build_annotations_unwind (buf
)
3883 if (XBUFFER (buf
) == current_buffer
)
3885 tembuf
= Fcurrent_buffer ();
3887 Fkill_buffer (tembuf
);
3891 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 6,
3892 "r\nFWrite region to file: ",
3893 "Write current region into specified file.\n\
3894 When called from a program, takes three arguments:\n\
3895 START, END and FILENAME. START and END are buffer positions.\n\
3896 Optional fourth argument APPEND if non-nil means\n\
3897 append to existing file contents (if any).\n\
3898 Optional fifth argument VISIT if t means\n\
3899 set the last-save-file-modtime of buffer to this file's modtime\n\
3900 and mark buffer not modified.\n\
3901 If VISIT is a string, it is a second file name;\n\
3902 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
3903 VISIT is also the file name to lock and unlock for clash detection.\n\
3904 If VISIT is neither t nor nil nor a string,\n\
3905 that means do not print the \"Wrote file\" message.\n\
3906 The optional sixth arg LOCKNAME, if non-nil, specifies the name to\n\
3907 use for locking and unlocking, overriding FILENAME and VISIT.\n\
3908 Kludgy feature: if START is a string, then that string is written\n\
3909 to the file, instead of any buffer contents, and END is ignored.")
3910 (start
, end
, filename
, append
, visit
, lockname
)
3911 Lisp_Object start
, end
, filename
, append
, visit
, lockname
;
3919 int count
= specpdl_ptr
- specpdl
;
3922 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
3924 Lisp_Object handler
;
3925 Lisp_Object visit_file
;
3926 Lisp_Object annotations
;
3927 Lisp_Object encoded_filename
;
3928 int visiting
, quietly
;
3929 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
3930 struct buffer
*given_buffer
;
3932 int buffer_file_type
= O_BINARY
;
3934 struct coding_system coding
;
3936 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3937 error ("Cannot do file visiting in an indirect buffer");
3939 if (!NILP (start
) && !STRINGP (start
))
3940 validate_region (&start
, &end
);
3942 GCPRO4 (start
, filename
, visit
, lockname
);
3944 /* Decide the coding-system to encode the data with. */
3950 else if (!NILP (Vcoding_system_for_write
))
3951 val
= Vcoding_system_for_write
;
3952 else if (NILP (current_buffer
->enable_multibyte_characters
))
3954 /* If the variable `buffer-file-coding-system' is set locally,
3955 it means that the file was read with some kind of code
3956 conversion or the varialbe is explicitely set by users. We
3957 had better write it out with the same coding system even if
3958 `enable-multibyte-characters' is nil.
3960 If is is not set locally, we anyway have to convert EOL
3961 format if the default value of `buffer-file-coding-system'
3962 tells that it is not Unix-like (LF only) format. */
3963 val
= current_buffer
->buffer_file_coding_system
;
3964 if (NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
3966 struct coding_system coding_temp
;
3968 setup_coding_system (Fcheck_coding_system (val
), &coding_temp
);
3969 if (coding_temp
.eol_type
== CODING_EOL_CRLF
3970 || coding_temp
.eol_type
== CODING_EOL_CR
)
3972 setup_coding_system (Qemacs_mule
, &coding
);
3973 coding
.eol_type
= coding_temp
.eol_type
;
3974 goto done_setup_coding
;
3981 Lisp_Object args
[7], coding_systems
;
3983 args
[0] = Qwrite_region
, args
[1] = start
, args
[2] = end
,
3984 args
[3] = filename
, args
[4] = append
, args
[5] = visit
,
3986 coding_systems
= Ffind_operation_coding_system (7, args
);
3987 val
= (CONSP (coding_systems
) && !NILP (XCONS (coding_systems
)->cdr
)
3988 ? XCONS (coding_systems
)->cdr
3989 : current_buffer
->buffer_file_coding_system
);
3991 setup_coding_system (Fcheck_coding_system (val
), &coding
);
3994 if (!STRINGP (start
) && !NILP (current_buffer
->selective_display
))
3995 coding
.selective
= 1;
3998 filename
= Fexpand_file_name (filename
, Qnil
);
3999 if (STRINGP (visit
))
4000 visit_file
= Fexpand_file_name (visit
, Qnil
);
4002 visit_file
= filename
;
4005 visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
4006 quietly
= !NILP (visit
);
4010 if (NILP (lockname
))
4011 lockname
= visit_file
;
4013 GCPRO5 (start
, filename
, annotations
, visit_file
, lockname
);
4015 /* If the file name has special constructs in it,
4016 call the corresponding file handler. */
4017 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
4018 /* If FILENAME has no handler, see if VISIT has one. */
4019 if (NILP (handler
) && STRINGP (visit
))
4020 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
4022 if (!NILP (handler
))
4025 val
= call6 (handler
, Qwrite_region
, start
, end
,
4026 filename
, append
, visit
);
4030 SAVE_MODIFF
= MODIFF
;
4031 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4032 current_buffer
->filename
= visit_file
;
4038 /* Special kludge to simplify auto-saving. */
4041 XSETFASTINT (start
, BEG
);
4042 XSETFASTINT (end
, Z
);
4045 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
4046 count1
= specpdl_ptr
- specpdl
;
4048 given_buffer
= current_buffer
;
4049 annotations
= build_annotations (start
, end
, coding
.pre_write_conversion
);
4050 if (current_buffer
!= given_buffer
)
4052 XSETFASTINT (start
, BEGV
);
4053 XSETFASTINT (end
, ZV
);
4056 #ifdef CLASH_DETECTION
4059 #if 0 /* This causes trouble for GNUS. */
4060 /* If we've locked this file for some other buffer,
4061 query before proceeding. */
4062 if (!visiting
&& EQ (Ffile_locked_p (lockname
), Qt
))
4063 call2 (intern ("ask-user-about-lock"), filename
, Vuser_login_name
);
4066 lock_file (lockname
);
4068 #endif /* CLASH_DETECTION */
4070 encoded_filename
= ENCODE_FILE (filename
);
4072 fn
= XSTRING (encoded_filename
)->data
;
4076 desc
= open (fn
, O_WRONLY
| buffer_file_type
);
4077 #else /* not DOS_NT */
4078 desc
= open (fn
, O_WRONLY
);
4079 #endif /* not DOS_NT */
4081 if (desc
< 0 && (NILP (append
) || errno
== ENOENT
))
4083 if (auto_saving
) /* Overwrite any previous version of autosave file */
4085 vms_truncate (fn
); /* if fn exists, truncate to zero length */
4086 desc
= open (fn
, O_RDWR
);
4088 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
4089 ? XSTRING (current_buffer
->filename
)->data
: 0,
4092 else /* Write to temporary name and rename if no errors */
4094 Lisp_Object temp_name
;
4095 temp_name
= Ffile_name_directory (filename
);
4097 if (!NILP (temp_name
))
4099 temp_name
= Fmake_temp_name (concat2 (temp_name
,
4100 build_string ("$$SAVE$$")));
4101 fname
= XSTRING (filename
)->data
;
4102 fn
= XSTRING (temp_name
)->data
;
4103 desc
= creat_copy_attrs (fname
, fn
);
4106 /* If we can't open the temporary file, try creating a new
4107 version of the original file. VMS "creat" creates a
4108 new version rather than truncating an existing file. */
4111 desc
= creat (fn
, 0666);
4112 #if 0 /* This can clobber an existing file and fail to replace it,
4113 if the user runs out of space. */
4116 /* We can't make a new version;
4117 try to truncate and rewrite existing version if any. */
4119 desc
= open (fn
, O_RDWR
);
4125 desc
= creat (fn
, 0666);
4130 O_WRONLY
| O_TRUNC
| O_CREAT
| buffer_file_type
,
4131 S_IREAD
| S_IWRITE
);
4132 #else /* not DOS_NT */
4133 desc
= creat (fn
, auto_saving
? auto_save_mode_bits
: 0666);
4134 #endif /* not DOS_NT */
4135 #endif /* not VMS */
4141 #ifdef CLASH_DETECTION
4143 if (!auto_saving
) unlock_file (lockname
);
4145 #endif /* CLASH_DETECTION */
4146 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
4149 record_unwind_protect (close_file_unwind
, make_number (desc
));
4152 if (lseek (desc
, 0, 2) < 0)
4154 #ifdef CLASH_DETECTION
4155 if (!auto_saving
) unlock_file (lockname
);
4156 #endif /* CLASH_DETECTION */
4157 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
4162 * Kludge Warning: The VMS C RTL likes to insert carriage returns
4163 * if we do writes that don't end with a carriage return. Furthermore
4164 * it cannot handle writes of more then 16K. The modified
4165 * version of "sys_write" in SYSDEP.C (see comment there) copes with
4166 * this EXCEPT for the last record (iff it doesn't end with a carriage
4167 * return). This implies that if your buffer doesn't end with a carriage
4168 * return, you get one free... tough. However it also means that if
4169 * we make two calls to sys_write (a la the following code) you can
4170 * get one at the gap as well. The easiest way to fix this (honest)
4171 * is to move the gap to the next newline (or the end of the buffer).
4176 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4177 move_gap (find_next_newline (GPT
, 1));
4179 /* Whether VMS or not, we must move the gap to the next of newline
4180 when we must put designation sequences at beginning of line. */
4181 if (INTEGERP (start
)
4182 && coding
.type
== coding_type_iso2022
4183 && coding
.flags
& CODING_FLAG_ISO_DESIGNATE_AT_BOL
4184 && GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4185 move_gap (find_next_newline (GPT
, 1));
4191 if (STRINGP (start
))
4193 failure
= 0 > a_write (desc
, XSTRING (start
)->data
,
4194 XSTRING (start
)->size
, 0, &annotations
, &coding
);
4197 else if (XINT (start
) != XINT (end
))
4200 if (XINT (start
) < GPT
)
4202 register int end1
= XINT (end
);
4204 failure
= 0 > a_write (desc
, POS_ADDR (tem
),
4205 min (GPT
, end1
) - tem
, tem
, &annotations
,
4207 nwritten
+= min (GPT
, end1
) - tem
;
4211 if (XINT (end
) > GPT
&& !failure
)
4214 tem
= max (tem
, GPT
);
4215 failure
= 0 > a_write (desc
, POS_ADDR (tem
), XINT (end
) - tem
,
4216 tem
, &annotations
, &coding
);
4217 nwritten
+= XINT (end
) - tem
;
4223 /* If file was empty, still need to write the annotations */
4224 coding
.last_block
= 1;
4225 failure
= 0 > a_write (desc
, "", 0, XINT (start
), &annotations
, &coding
);
4229 if (CODING_REQUIRE_FLUSHING (&coding
) && !coding
.last_block
)
4231 /* We have to flush out a data. */
4232 coding
.last_block
= 1;
4233 failure
= 0 > e_write (desc
, "", 0, &coding
);
4240 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
4241 Disk full in NFS may be reported here. */
4242 /* mib says that closing the file will try to write as fast as NFS can do
4243 it, and that means the fsync here is not crucial for autosave files. */
4244 if (!auto_saving
&& fsync (desc
) < 0)
4246 /* If fsync fails with EINTR, don't treat that as serious. */
4248 failure
= 1, save_errno
= errno
;
4252 /* Spurious "file has changed on disk" warnings have been
4253 observed on Suns as well.
4254 It seems that `close' can change the modtime, under nfs.
4256 (This has supposedly been fixed in Sunos 4,
4257 but who knows about all the other machines with NFS?) */
4260 /* On VMS and APOLLO, must do the stat after the close
4261 since closing changes the modtime. */
4264 /* Recall that #if defined does not work on VMS. */
4271 /* NFS can report a write failure now. */
4272 if (close (desc
) < 0)
4273 failure
= 1, save_errno
= errno
;
4276 /* If we wrote to a temporary name and had no errors, rename to real name. */
4280 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
4288 /* Discard the unwind protect for close_file_unwind. */
4289 specpdl_ptr
= specpdl
+ count1
;
4290 /* Restore the original current buffer. */
4291 visit_file
= unbind_to (count
, visit_file
);
4293 #ifdef CLASH_DETECTION
4295 unlock_file (lockname
);
4296 #endif /* CLASH_DETECTION */
4298 /* Do this before reporting IO error
4299 to avoid a "file has changed on disk" warning on
4300 next attempt to save. */
4302 current_buffer
->modtime
= st
.st_mtime
;
4305 error ("IO error writing %s: %s", XSTRING (filename
)->data
,
4306 strerror (save_errno
));
4310 SAVE_MODIFF
= MODIFF
;
4311 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4312 current_buffer
->filename
= visit_file
;
4313 update_mode_lines
++;
4319 message ("Wrote %s", XSTRING (visit_file
)->data
);
4324 Lisp_Object
merge ();
4326 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
4327 "Return t if (car A) is numerically less than (car B).")
4331 return Flss (Fcar (a
), Fcar (b
));
4334 /* Build the complete list of annotations appropriate for writing out
4335 the text between START and END, by calling all the functions in
4336 write-region-annotate-functions and merging the lists they return.
4337 If one of these functions switches to a different buffer, we assume
4338 that buffer contains altered text. Therefore, the caller must
4339 make sure to restore the current buffer in all cases,
4340 as save-excursion would do. */
4343 build_annotations (start
, end
, pre_write_conversion
)
4344 Lisp_Object start
, end
, pre_write_conversion
;
4346 Lisp_Object annotations
;
4348 struct gcpro gcpro1
, gcpro2
;
4349 Lisp_Object original_buffer
;
4351 XSETBUFFER (original_buffer
, current_buffer
);
4354 p
= Vwrite_region_annotate_functions
;
4355 GCPRO2 (annotations
, p
);
4358 struct buffer
*given_buffer
= current_buffer
;
4359 Vwrite_region_annotations_so_far
= annotations
;
4360 res
= call2 (Fcar (p
), start
, end
);
4361 /* If the function makes a different buffer current,
4362 assume that means this buffer contains altered text to be output.
4363 Reset START and END from the buffer bounds
4364 and discard all previous annotations because they should have
4365 been dealt with by this function. */
4366 if (current_buffer
!= given_buffer
)
4368 XSETFASTINT (start
, BEGV
);
4369 XSETFASTINT (end
, ZV
);
4372 Flength (res
); /* Check basic validity of return value */
4373 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4377 /* Now do the same for annotation functions implied by the file-format */
4378 if (auto_saving
&& (!EQ (Vauto_save_file_format
, Qt
)))
4379 p
= Vauto_save_file_format
;
4381 p
= current_buffer
->file_format
;
4384 struct buffer
*given_buffer
= current_buffer
;
4385 Vwrite_region_annotations_so_far
= annotations
;
4386 res
= call4 (Qformat_annotate_function
, Fcar (p
), start
, end
,
4388 if (current_buffer
!= given_buffer
)
4390 XSETFASTINT (start
, BEGV
);
4391 XSETFASTINT (end
, ZV
);
4395 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4399 /* At last, do the same for the function PRE_WRITE_CONVERSION
4400 implied by the current coding-system. */
4401 if (!NILP (pre_write_conversion
))
4403 struct buffer
*given_buffer
= current_buffer
;
4404 Vwrite_region_annotations_so_far
= annotations
;
4405 res
= call2 (pre_write_conversion
, start
, end
);
4407 annotations
= (current_buffer
!= given_buffer
4409 : merge (annotations
, res
, Qcar_less_than_car
));
4416 /* Write to descriptor DESC the LEN characters starting at ADDR,
4417 assuming they start at position POS in the buffer.
4418 Intersperse with them the annotations from *ANNOT
4419 (those which fall within the range of positions POS to POS + LEN),
4420 each at its appropriate position.
4422 Modify *ANNOT by discarding elements as we output them.
4423 The return value is negative in case of system call failure. */
4426 a_write (desc
, addr
, len
, pos
, annot
, coding
)
4428 register char *addr
;
4432 struct coding_system
*coding
;
4436 int lastpos
= pos
+ len
;
4438 while (NILP (*annot
) || CONSP (*annot
))
4440 tem
= Fcar_safe (Fcar (*annot
));
4441 if (INTEGERP (tem
) && XINT (tem
) >= pos
&& XFASTINT (tem
) <= lastpos
)
4442 nextpos
= XFASTINT (tem
);
4444 return e_write (desc
, addr
, lastpos
- pos
, coding
);
4447 if (0 > e_write (desc
, addr
, nextpos
- pos
, coding
))
4449 addr
+= nextpos
- pos
;
4452 tem
= Fcdr (Fcar (*annot
));
4455 if (0 > e_write (desc
, XSTRING (tem
)->data
, XSTRING (tem
)->size
,
4459 *annot
= Fcdr (*annot
);
4463 #ifndef WRITE_BUF_SIZE
4464 #define WRITE_BUF_SIZE (16 * 1024)
4468 e_write (desc
, addr
, len
, coding
)
4470 register char *addr
;
4472 struct coding_system
*coding
;
4474 char buf
[WRITE_BUF_SIZE
];
4475 int produced
, consumed
;
4477 /* We used to have a code for handling selective display here. But,
4478 now it is handled within encode_coding. */
4481 produced
= encode_coding (coding
, addr
, buf
, len
, WRITE_BUF_SIZE
,
4483 len
-= consumed
, addr
+= consumed
;
4486 produced
-= write (desc
, buf
, produced
);
4487 if (produced
) return -1;
4495 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
4496 Sverify_visited_file_modtime
, 1, 1, 0,
4497 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
4498 This means that the file has not been changed since it was visited or saved.")
4504 Lisp_Object handler
;
4505 Lisp_Object filename
;
4507 CHECK_BUFFER (buf
, 0);
4510 if (!STRINGP (b
->filename
)) return Qt
;
4511 if (b
->modtime
== 0) return Qt
;
4513 /* If the file name has special constructs in it,
4514 call the corresponding file handler. */
4515 handler
= Ffind_file_name_handler (b
->filename
,
4516 Qverify_visited_file_modtime
);
4517 if (!NILP (handler
))
4518 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
4520 filename
= ENCODE_FILE (b
->filename
);
4522 if (stat (XSTRING (filename
)->data
, &st
) < 0)
4524 /* If the file doesn't exist now and didn't exist before,
4525 we say that it isn't modified, provided the error is a tame one. */
4526 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
4531 if (st
.st_mtime
== b
->modtime
4532 /* If both are positive, accept them if they are off by one second. */
4533 || (st
.st_mtime
> 0 && b
->modtime
> 0
4534 && (st
.st_mtime
== b
->modtime
+ 1
4535 || st
.st_mtime
== b
->modtime
- 1)))
4540 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
4541 Sclear_visited_file_modtime
, 0, 0, 0,
4542 "Clear out records of last mod time of visited file.\n\
4543 Next attempt to save will certainly not complain of a discrepancy.")
4546 current_buffer
->modtime
= 0;
4550 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
4551 Svisited_file_modtime
, 0, 0, 0,
4552 "Return the current buffer's recorded visited file modification time.\n\
4553 The value is a list of the form (HIGH . LOW), like the time values\n\
4554 that `file-attributes' returns.")
4557 return long_to_cons ((unsigned long) current_buffer
->modtime
);
4560 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
4561 Sset_visited_file_modtime
, 0, 1, 0,
4562 "Update buffer's recorded modification time from the visited file's time.\n\
4563 Useful if the buffer was not read from the file normally\n\
4564 or if the file itself has been changed for some known benign reason.\n\
4565 An argument specifies the modification time value to use\n\
4566 \(instead of that of the visited file), in the form of a list\n\
4567 \(HIGH . LOW) or (HIGH LOW).")
4569 Lisp_Object time_list
;
4571 if (!NILP (time_list
))
4572 current_buffer
->modtime
= cons_to_long (time_list
);
4575 register Lisp_Object filename
;
4577 Lisp_Object handler
;
4579 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
4581 /* If the file name has special constructs in it,
4582 call the corresponding file handler. */
4583 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
4584 if (!NILP (handler
))
4585 /* The handler can find the file name the same way we did. */
4586 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
4588 filename
= ENCODE_FILE (filename
);
4590 if (stat (XSTRING (filename
)->data
, &st
) >= 0)
4591 current_buffer
->modtime
= st
.st_mtime
;
4601 message ("Autosaving...error for %s", XSTRING (current_buffer
->name
)->data
);
4602 Fsleep_for (make_number (1), Qnil
);
4603 message ("Autosaving...error!for %s", XSTRING (current_buffer
->name
)->data
);
4604 Fsleep_for (make_number (1), Qnil
);
4605 message ("Autosaving...error for %s", XSTRING (current_buffer
->name
)->data
);
4606 Fsleep_for (make_number (1), Qnil
);
4616 /* Get visited file's mode to become the auto save file's mode. */
4617 if (stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
4618 /* But make sure we can overwrite it later! */
4619 auto_save_mode_bits
= st
.st_mode
| 0600;
4621 auto_save_mode_bits
= 0666;
4624 Fwrite_region (Qnil
, Qnil
,
4625 current_buffer
->auto_save_file_name
,
4626 Qnil
, Qlambda
, Qnil
);
4630 do_auto_save_unwind (stream
) /* used as unwind-protect function */
4635 fclose ((FILE *) (XFASTINT (XCONS (stream
)->car
) << 16
4636 | XFASTINT (XCONS (stream
)->cdr
)));
4641 do_auto_save_unwind_1 (value
) /* used as unwind-protect function */
4644 minibuffer_auto_raise
= XINT (value
);
4648 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
4649 "Auto-save all buffers that need it.\n\
4650 This is all buffers that have auto-saving enabled\n\
4651 and are changed since last auto-saved.\n\
4652 Auto-saving writes the buffer into a file\n\
4653 so that your editing is not lost if the system crashes.\n\
4654 This file is not the file you visited; that changes only when you save.\n\
4655 Normally we run the normal hook `auto-save-hook' before saving.\n\n\
4656 A non-nil NO-MESSAGE argument means do not print any message if successful.\n\
4657 A non-nil CURRENT-ONLY argument means save only current buffer.")
4658 (no_message
, current_only
)
4659 Lisp_Object no_message
, current_only
;
4661 struct buffer
*old
= current_buffer
, *b
;
4662 Lisp_Object tail
, buf
;
4664 char *omessage
= echo_area_glyphs
;
4665 int omessage_length
= echo_area_glyphs_length
;
4666 int do_handled_files
;
4669 Lisp_Object lispstream
;
4670 int count
= specpdl_ptr
- specpdl
;
4672 int orig_minibuffer_auto_raise
= minibuffer_auto_raise
;
4674 /* Ordinarily don't quit within this function,
4675 but don't make it impossible to quit (in case we get hung in I/O). */
4679 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
4680 point to non-strings reached from Vbuffer_alist. */
4685 if (!NILP (Vrun_hooks
))
4686 call1 (Vrun_hooks
, intern ("auto-save-hook"));
4688 if (STRINGP (Vauto_save_list_file_name
))
4690 Lisp_Object listfile
;
4691 listfile
= Fexpand_file_name (Vauto_save_list_file_name
, Qnil
);
4692 stream
= fopen (XSTRING (listfile
)->data
, "w");
4695 /* Arrange to close that file whether or not we get an error.
4696 Also reset auto_saving to 0. */
4697 lispstream
= Fcons (Qnil
, Qnil
);
4698 XSETFASTINT (XCONS (lispstream
)->car
, (EMACS_UINT
)stream
>> 16);
4699 XSETFASTINT (XCONS (lispstream
)->cdr
, (EMACS_UINT
)stream
& 0xffff);
4710 record_unwind_protect (do_auto_save_unwind
, lispstream
);
4711 record_unwind_protect (do_auto_save_unwind_1
,
4712 make_number (minibuffer_auto_raise
));
4713 minibuffer_auto_raise
= 0;
4716 /* First, save all files which don't have handlers. If Emacs is
4717 crashing, the handlers may tweak what is causing Emacs to crash
4718 in the first place, and it would be a shame if Emacs failed to
4719 autosave perfectly ordinary files because it couldn't handle some
4721 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
4722 for (tail
= Vbuffer_alist
; GC_CONSP (tail
); tail
= XCONS (tail
)->cdr
)
4724 buf
= XCONS (XCONS (tail
)->car
)->cdr
;
4727 /* Record all the buffers that have auto save mode
4728 in the special file that lists them. For each of these buffers,
4729 Record visited name (if any) and auto save name. */
4730 if (STRINGP (b
->auto_save_file_name
)
4731 && stream
!= NULL
&& do_handled_files
== 0)
4733 if (!NILP (b
->filename
))
4735 fwrite (XSTRING (b
->filename
)->data
, 1,
4736 XSTRING (b
->filename
)->size
, stream
);
4738 putc ('\n', stream
);
4739 fwrite (XSTRING (b
->auto_save_file_name
)->data
, 1,
4740 XSTRING (b
->auto_save_file_name
)->size
, stream
);
4741 putc ('\n', stream
);
4744 if (!NILP (current_only
)
4745 && b
!= current_buffer
)
4748 /* Don't auto-save indirect buffers.
4749 The base buffer takes care of it. */
4753 /* Check for auto save enabled
4754 and file changed since last auto save
4755 and file changed since last real save. */
4756 if (STRINGP (b
->auto_save_file_name
)
4757 && BUF_SAVE_MODIFF (b
) < BUF_MODIFF (b
)
4758 && b
->auto_save_modified
< BUF_MODIFF (b
)
4759 /* -1 means we've turned off autosaving for a while--see below. */
4760 && XINT (b
->save_length
) >= 0
4761 && (do_handled_files
4762 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
4765 EMACS_TIME before_time
, after_time
;
4767 EMACS_GET_TIME (before_time
);
4769 /* If we had a failure, don't try again for 20 minutes. */
4770 if (b
->auto_save_failure_time
>= 0
4771 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
4774 if ((XFASTINT (b
->save_length
) * 10
4775 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
4776 /* A short file is likely to change a large fraction;
4777 spare the user annoying messages. */
4778 && XFASTINT (b
->save_length
) > 5000
4779 /* These messages are frequent and annoying for `*mail*'. */
4780 && !EQ (b
->filename
, Qnil
)
4781 && NILP (no_message
))
4783 /* It has shrunk too much; turn off auto-saving here. */
4784 minibuffer_auto_raise
= orig_minibuffer_auto_raise
;
4785 message ("Buffer %s has shrunk a lot; auto save turned off there",
4786 XSTRING (b
->name
)->data
);
4787 minibuffer_auto_raise
= 0;
4788 /* Turn off auto-saving until there's a real save,
4789 and prevent any more warnings. */
4790 XSETINT (b
->save_length
, -1);
4791 Fsleep_for (make_number (1), Qnil
);
4794 set_buffer_internal (b
);
4795 if (!auto_saved
&& NILP (no_message
))
4796 message1 ("Auto-saving...");
4797 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
4799 b
->auto_save_modified
= BUF_MODIFF (b
);
4800 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4801 set_buffer_internal (old
);
4803 EMACS_GET_TIME (after_time
);
4805 /* If auto-save took more than 60 seconds,
4806 assume it was an NFS failure that got a timeout. */
4807 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
4808 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
4812 /* Prevent another auto save till enough input events come in. */
4813 record_auto_save ();
4815 if (auto_saved
&& NILP (no_message
))
4819 sit_for (1, 0, 0, 0, 0);
4820 message2 (omessage
, omessage_length
);
4823 message1 ("Auto-saving...done");
4828 unbind_to (count
, Qnil
);
4832 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
4833 Sset_buffer_auto_saved
, 0, 0, 0,
4834 "Mark current buffer as auto-saved with its current text.\n\
4835 No auto-save file will be written until the buffer changes again.")
4838 current_buffer
->auto_save_modified
= MODIFF
;
4839 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4840 current_buffer
->auto_save_failure_time
= -1;
4844 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
4845 Sclear_buffer_auto_save_failure
, 0, 0, 0,
4846 "Clear any record of a recent auto-save failure in the current buffer.")
4849 current_buffer
->auto_save_failure_time
= -1;
4853 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
4855 "Return t if buffer has been auto-saved since last read in or saved.")
4858 return (SAVE_MODIFF
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
4861 /* Reading and completing file names */
4862 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
4864 /* In the string VAL, change each $ to $$ and return the result. */
4867 double_dollars (val
)
4870 register unsigned char *old
, *new;
4874 osize
= XSTRING (val
)->size
;
4875 /* Quote "$" as "$$" to get it past substitute-in-file-name */
4876 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
4877 if (*old
++ == '$') count
++;
4880 old
= XSTRING (val
)->data
;
4881 val
= Fmake_string (make_number (osize
+ count
), make_number (0));
4882 new = XSTRING (val
)->data
;
4883 for (n
= osize
; n
> 0; n
--)
4896 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
4898 "Internal subroutine for read-file-name. Do not call this.")
4899 (string
, dir
, action
)
4900 Lisp_Object string
, dir
, action
;
4901 /* action is nil for complete, t for return list of completions,
4902 lambda for verify final value */
4904 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
4906 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
4908 CHECK_STRING (string
, 0);
4915 /* No need to protect ACTION--we only compare it with t and nil. */
4916 GCPRO5 (string
, realdir
, name
, specdir
, orig_string
);
4918 if (XSTRING (string
)->size
== 0)
4920 if (EQ (action
, Qlambda
))
4928 orig_string
= string
;
4929 string
= Fsubstitute_in_file_name (string
);
4930 changed
= NILP (Fstring_equal (string
, orig_string
));
4931 name
= Ffile_name_nondirectory (string
);
4932 val
= Ffile_name_directory (string
);
4934 realdir
= Fexpand_file_name (val
, realdir
);
4939 specdir
= Ffile_name_directory (string
);
4940 val
= Ffile_name_completion (name
, realdir
);
4945 return double_dollars (string
);
4949 if (!NILP (specdir
))
4950 val
= concat2 (specdir
, val
);
4952 return double_dollars (val
);
4955 #endif /* not VMS */
4959 if (EQ (action
, Qt
))
4960 return Ffile_name_all_completions (name
, realdir
);
4961 /* Only other case actually used is ACTION = lambda */
4963 /* Supposedly this helps commands such as `cd' that read directory names,
4964 but can someone explain how it helps them? -- RMS */
4965 if (XSTRING (name
)->size
== 0)
4968 return Ffile_exists_p (string
);
4971 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
4972 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
4973 Value is not expanded---you must call `expand-file-name' yourself.\n\
4974 Default name to DEFAULT-FILENAME if user enters a null string.\n\
4975 (If DEFAULT-FILENAME is omitted, the visited file name is used,\n\
4976 except that if INITIAL is specified, that combined with DIR is used.)\n\
4977 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
4978 Non-nil and non-t means also require confirmation after completion.\n\
4979 Fifth arg INITIAL specifies text to start with.\n\
4980 DIR defaults to current buffer's directory default.")
4981 (prompt
, dir
, default_filename
, mustmatch
, initial
)
4982 Lisp_Object prompt
, dir
, default_filename
, mustmatch
, initial
;
4984 Lisp_Object val
, insdef
, insdef1
, tem
;
4985 struct gcpro gcpro1
, gcpro2
;
4986 register char *homedir
;
4990 dir
= current_buffer
->directory
;
4991 if (NILP (default_filename
))
4993 if (! NILP (initial
))
4994 default_filename
= Fexpand_file_name (initial
, dir
);
4996 default_filename
= current_buffer
->filename
;
4999 /* If dir starts with user's homedir, change that to ~. */
5000 homedir
= (char *) egetenv ("HOME");
5002 homedir
= strcpy (alloca (strlen (homedir
) + 1), homedir
);
5003 CORRECT_DIR_SEPS (homedir
);
5007 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5008 && IS_DIRECTORY_SEP (XSTRING (dir
)->data
[strlen (homedir
)]))
5010 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5011 XSTRING (dir
)->size
- strlen (homedir
) + 1);
5012 XSTRING (dir
)->data
[0] = '~';
5015 if (insert_default_directory
&& STRINGP (dir
))
5018 if (!NILP (initial
))
5020 Lisp_Object args
[2], pos
;
5024 insdef
= Fconcat (2, args
);
5025 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
5026 insdef1
= Fcons (double_dollars (insdef
), pos
);
5029 insdef1
= double_dollars (insdef
);
5031 else if (STRINGP (initial
))
5034 insdef1
= Fcons (double_dollars (insdef
), make_number (0));
5037 insdef
= Qnil
, insdef1
= Qnil
;
5040 count
= specpdl_ptr
- specpdl
;
5041 specbind (intern ("completion-ignore-case"), Qt
);
5044 GCPRO2 (insdef
, default_filename
);
5045 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5046 dir
, mustmatch
, insdef1
,
5047 Qfile_name_history
, default_filename
, Qnil
);
5048 /* If Fcompleting_read returned the default string itself
5049 (rather than a new string with the same contents),
5050 it has to mean that the user typed RET with the minibuffer empty.
5051 In that case, we really want to return ""
5052 so that commands such as set-visited-file-name can distinguish. */
5053 if (EQ (val
, default_filename
))
5054 val
= build_string ("");
5057 unbind_to (count
, Qnil
);
5062 error ("No file name specified");
5063 tem
= Fstring_equal (val
, insdef
);
5064 if (!NILP (tem
) && !NILP (default_filename
))
5065 return default_filename
;
5066 if (XSTRING (val
)->size
== 0 && NILP (insdef
))
5068 if (!NILP (default_filename
))
5069 return default_filename
;
5071 error ("No default file name");
5073 return Fsubstitute_in_file_name (val
);
5076 #if 0 /* Old version */
5077 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
5078 /* Don't confuse make-docfile by having two doc strings for this function.
5079 make-docfile does not pay attention to #if, for good reason! */
5081 (prompt
, dir
, defalt
, mustmatch
, initial
)
5082 Lisp_Object prompt
, dir
, defalt
, mustmatch
, initial
;
5084 Lisp_Object val
, insdef
, tem
;
5085 struct gcpro gcpro1
, gcpro2
;
5086 register char *homedir
;
5090 dir
= current_buffer
->directory
;
5092 defalt
= current_buffer
->filename
;
5094 /* If dir starts with user's homedir, change that to ~. */
5095 homedir
= (char *) egetenv ("HOME");
5098 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5099 && XSTRING (dir
)->data
[strlen (homedir
)] == '/')
5101 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5102 XSTRING (dir
)->size
- strlen (homedir
) + 1);
5103 XSTRING (dir
)->data
[0] = '~';
5106 if (!NILP (initial
))
5108 else if (insert_default_directory
)
5111 insdef
= build_string ("");
5114 count
= specpdl_ptr
- specpdl
;
5115 specbind (intern ("completion-ignore-case"), Qt
);
5118 GCPRO2 (insdef
, defalt
);
5119 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5121 insert_default_directory
? insdef
: Qnil
,
5122 Qfile_name_history
, Qnil
, Qnil
);
5125 unbind_to (count
, Qnil
);
5130 error ("No file name specified");
5131 tem
= Fstring_equal (val
, insdef
);
5132 if (!NILP (tem
) && !NILP (defalt
))
5134 return Fsubstitute_in_file_name (val
);
5136 #endif /* Old version */
5140 Qexpand_file_name
= intern ("expand-file-name");
5141 Qsubstitute_in_file_name
= intern ("substitute-in-file-name");
5142 Qdirectory_file_name
= intern ("directory-file-name");
5143 Qfile_name_directory
= intern ("file-name-directory");
5144 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
5145 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
5146 Qfile_name_as_directory
= intern ("file-name-as-directory");
5147 Qcopy_file
= intern ("copy-file");
5148 Qmake_directory_internal
= intern ("make-directory-internal");
5149 Qdelete_directory
= intern ("delete-directory");
5150 Qdelete_file
= intern ("delete-file");
5151 Qrename_file
= intern ("rename-file");
5152 Qadd_name_to_file
= intern ("add-name-to-file");
5153 Qmake_symbolic_link
= intern ("make-symbolic-link");
5154 Qfile_exists_p
= intern ("file-exists-p");
5155 Qfile_executable_p
= intern ("file-executable-p");
5156 Qfile_readable_p
= intern ("file-readable-p");
5157 Qfile_writable_p
= intern ("file-writable-p");
5158 Qfile_symlink_p
= intern ("file-symlink-p");
5159 Qaccess_file
= intern ("access-file");
5160 Qfile_directory_p
= intern ("file-directory-p");
5161 Qfile_regular_p
= intern ("file-regular-p");
5162 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
5163 Qfile_modes
= intern ("file-modes");
5164 Qset_file_modes
= intern ("set-file-modes");
5165 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
5166 Qinsert_file_contents
= intern ("insert-file-contents");
5167 Qwrite_region
= intern ("write-region");
5168 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
5169 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
5171 staticpro (&Qexpand_file_name
);
5172 staticpro (&Qsubstitute_in_file_name
);
5173 staticpro (&Qdirectory_file_name
);
5174 staticpro (&Qfile_name_directory
);
5175 staticpro (&Qfile_name_nondirectory
);
5176 staticpro (&Qunhandled_file_name_directory
);
5177 staticpro (&Qfile_name_as_directory
);
5178 staticpro (&Qcopy_file
);
5179 staticpro (&Qmake_directory_internal
);
5180 staticpro (&Qdelete_directory
);
5181 staticpro (&Qdelete_file
);
5182 staticpro (&Qrename_file
);
5183 staticpro (&Qadd_name_to_file
);
5184 staticpro (&Qmake_symbolic_link
);
5185 staticpro (&Qfile_exists_p
);
5186 staticpro (&Qfile_executable_p
);
5187 staticpro (&Qfile_readable_p
);
5188 staticpro (&Qfile_writable_p
);
5189 staticpro (&Qaccess_file
);
5190 staticpro (&Qfile_symlink_p
);
5191 staticpro (&Qfile_directory_p
);
5192 staticpro (&Qfile_regular_p
);
5193 staticpro (&Qfile_accessible_directory_p
);
5194 staticpro (&Qfile_modes
);
5195 staticpro (&Qset_file_modes
);
5196 staticpro (&Qfile_newer_than_file_p
);
5197 staticpro (&Qinsert_file_contents
);
5198 staticpro (&Qwrite_region
);
5199 staticpro (&Qverify_visited_file_modtime
);
5200 staticpro (&Qset_visited_file_modtime
);
5202 Qfile_name_history
= intern ("file-name-history");
5203 Fset (Qfile_name_history
, Qnil
);
5204 staticpro (&Qfile_name_history
);
5206 Qfile_error
= intern ("file-error");
5207 staticpro (&Qfile_error
);
5208 Qfile_already_exists
= intern ("file-already-exists");
5209 staticpro (&Qfile_already_exists
);
5210 Qfile_date_error
= intern ("file-date-error");
5211 staticpro (&Qfile_date_error
);
5214 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
5215 staticpro (&Qfind_buffer_file_type
);
5218 DEFVAR_LISP ("file-name-coding-system", &Vfile_name_coding_system
,
5219 "*Coding system for encoding file names.");
5220 Vfile_name_coding_system
= Qnil
;
5222 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format
,
5223 "*Format in which to write auto-save files.\n\
5224 Should be a list of symbols naming formats that are defined in `format-alist'.\n\
5225 If it is t, which is the default, auto-save files are written in the\n\
5226 same format as a regular save would use.");
5227 Vauto_save_file_format
= Qt
;
5229 Qformat_decode
= intern ("format-decode");
5230 staticpro (&Qformat_decode
);
5231 Qformat_annotate_function
= intern ("format-annotate-function");
5232 staticpro (&Qformat_annotate_function
);
5234 Qcar_less_than_car
= intern ("car-less-than-car");
5235 staticpro (&Qcar_less_than_car
);
5237 Fput (Qfile_error
, Qerror_conditions
,
5238 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
5239 Fput (Qfile_error
, Qerror_message
,
5240 build_string ("File error"));
5242 Fput (Qfile_already_exists
, Qerror_conditions
,
5243 Fcons (Qfile_already_exists
,
5244 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5245 Fput (Qfile_already_exists
, Qerror_message
,
5246 build_string ("File already exists"));
5248 Fput (Qfile_date_error
, Qerror_conditions
,
5249 Fcons (Qfile_date_error
,
5250 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5251 Fput (Qfile_date_error
, Qerror_message
,
5252 build_string ("Cannot set file date"));
5254 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
5255 "*Non-nil means when reading a filename start with default dir in minibuffer.");
5256 insert_default_directory
= 1;
5258 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
5259 "*Non-nil means write new files with record format `stmlf'.\n\
5260 nil means use format `var'. This variable is meaningful only on VMS.");
5261 vms_stmlf_recfm
= 0;
5263 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char
,
5264 "Directory separator character for built-in functions that return file names.\n\
5265 The value should be either ?/ or ?\\ (any other value is treated as ?\\).\n\
5266 This variable affects the built-in functions only on Windows,\n\
5267 on other platforms, it is initialized so that Lisp code can find out\n\
5268 what the normal separator is.");
5269 XSETFASTINT (Vdirectory_sep_char
, '/');
5271 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
5272 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
5273 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
5276 The first argument given to HANDLER is the name of the I/O primitive\n\
5277 to be handled; the remaining arguments are the arguments that were\n\
5278 passed to that primitive. For example, if you do\n\
5279 (file-exists-p FILENAME)\n\
5280 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
5281 (funcall HANDLER 'file-exists-p FILENAME)\n\
5282 The function `find-file-name-handler' checks this list for a handler\n\
5283 for its argument.");
5284 Vfile_name_handler_alist
= Qnil
;
5286 DEFVAR_LISP ("set-auto-coding-function",
5287 &Vset_auto_coding_function
,
5288 "If non-nil, a function to call to decide a coding system of file.\n\
5289 One argument is passed to this function: the string of concatination\n\
5290 or the heading 1K-byte and the tailing 3K-byte of a file to be read.\n\
5291 This function should return a coding system to decode the file contents\n\
5292 specified in the heading lines with the format:\n\
5293 -*- ... coding: CODING-SYSTEM; ... -*-\n\
5294 or local variable spec of the tailing lines with `coding:' tag.");
5295 Vset_auto_coding_function
= Qnil
;
5297 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
5298 "A list of functions to be called at the end of `insert-file-contents'.\n\
5299 Each is passed one argument, the number of bytes inserted. It should return\n\
5300 the new byte count, and leave point the same. If `insert-file-contents' is\n\
5301 intercepted by a handler from `file-name-handler-alist', that handler is\n\
5302 responsible for calling the after-insert-file-functions if appropriate.");
5303 Vafter_insert_file_functions
= Qnil
;
5305 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
5306 "A list of functions to be called at the start of `write-region'.\n\
5307 Each is passed two arguments, START and END as for `write-region'.\n\
5308 These are usually two numbers but not always; see the documentation\n\
5309 for `write-region'. The function should return a list of pairs\n\
5310 of the form (POSITION . STRING), consisting of strings to be effectively\n\
5311 inserted at the specified positions of the file being written (1 means to\n\
5312 insert before the first byte written). The POSITIONs must be sorted into\n\
5313 increasing order. If there are several functions in the list, the several\n\
5314 lists are merged destructively.");
5315 Vwrite_region_annotate_functions
= Qnil
;
5317 DEFVAR_LISP ("write-region-annotations-so-far",
5318 &Vwrite_region_annotations_so_far
,
5319 "When an annotation function is called, this holds the previous annotations.\n\
5320 These are the annotations made by other annotation functions\n\
5321 that were already called. See also `write-region-annotate-functions'.");
5322 Vwrite_region_annotations_so_far
= Qnil
;
5324 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
5325 "A list of file name handlers that temporarily should not be used.\n\
5326 This applies only to the operation `inhibit-file-name-operation'.");
5327 Vinhibit_file_name_handlers
= Qnil
;
5329 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
5330 "The operation for which `inhibit-file-name-handlers' is applicable.");
5331 Vinhibit_file_name_operation
= Qnil
;
5333 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
5334 "File name in which we write a list of all auto save file names.\n\
5335 This variable is initialized automatically from `auto-save-list-file-prefix'\n\
5336 shortly after Emacs reads your `.emacs' file, if you have not yet given it\n\
5338 Vauto_save_list_file_name
= Qnil
;
5340 defsubr (&Sfind_file_name_handler
);
5341 defsubr (&Sfile_name_directory
);
5342 defsubr (&Sfile_name_nondirectory
);
5343 defsubr (&Sunhandled_file_name_directory
);
5344 defsubr (&Sfile_name_as_directory
);
5345 defsubr (&Sdirectory_file_name
);
5346 defsubr (&Smake_temp_name
);
5347 defsubr (&Sexpand_file_name
);
5348 defsubr (&Ssubstitute_in_file_name
);
5349 defsubr (&Scopy_file
);
5350 defsubr (&Smake_directory_internal
);
5351 defsubr (&Sdelete_directory
);
5352 defsubr (&Sdelete_file
);
5353 defsubr (&Srename_file
);
5354 defsubr (&Sadd_name_to_file
);
5356 defsubr (&Smake_symbolic_link
);
5357 #endif /* S_IFLNK */
5359 defsubr (&Sdefine_logical_name
);
5362 defsubr (&Ssysnetunam
);
5363 #endif /* HPUX_NET */
5364 defsubr (&Sfile_name_absolute_p
);
5365 defsubr (&Sfile_exists_p
);
5366 defsubr (&Sfile_executable_p
);
5367 defsubr (&Sfile_readable_p
);
5368 defsubr (&Sfile_writable_p
);
5369 defsubr (&Saccess_file
);
5370 defsubr (&Sfile_symlink_p
);
5371 defsubr (&Sfile_directory_p
);
5372 defsubr (&Sfile_accessible_directory_p
);
5373 defsubr (&Sfile_regular_p
);
5374 defsubr (&Sfile_modes
);
5375 defsubr (&Sset_file_modes
);
5376 defsubr (&Sset_default_file_modes
);
5377 defsubr (&Sdefault_file_modes
);
5378 defsubr (&Sfile_newer_than_file_p
);
5379 defsubr (&Sinsert_file_contents
);
5380 defsubr (&Swrite_region
);
5381 defsubr (&Scar_less_than_car
);
5382 defsubr (&Sverify_visited_file_modtime
);
5383 defsubr (&Sclear_visited_file_modtime
);
5384 defsubr (&Svisited_file_modtime
);
5385 defsubr (&Sset_visited_file_modtime
);
5386 defsubr (&Sdo_auto_save
);
5387 defsubr (&Sset_buffer_auto_saved
);
5388 defsubr (&Sclear_buffer_auto_save_failure
);
5389 defsubr (&Srecent_auto_save_p
);
5391 defsubr (&Sread_file_name_internal
);
5392 defsubr (&Sread_file_name
);
5395 defsubr (&Sunix_sync
);