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
;
234 report_file_error (string
, data
)
238 Lisp_Object errstring
;
240 errstring
= build_string (strerror (errno
));
242 /* System error messages are capitalized. Downcase the initial
243 unless it is followed by a slash. */
244 if (XSTRING (errstring
)->data
[1] != '/')
245 XSTRING (errstring
)->data
[0] = DOWNCASE (XSTRING (errstring
)->data
[0]);
248 Fsignal (Qfile_error
,
249 Fcons (build_string (string
), Fcons (errstring
, data
)));
253 close_file_unwind (fd
)
256 close (XFASTINT (fd
));
260 /* Restore point, having saved it as a marker. */
263 restore_point_unwind (location
)
264 Lisp_Object location
;
266 SET_PT (marker_position (location
));
267 Fset_marker (location
, Qnil
, Qnil
);
271 Lisp_Object Qexpand_file_name
;
272 Lisp_Object Qsubstitute_in_file_name
;
273 Lisp_Object Qdirectory_file_name
;
274 Lisp_Object Qfile_name_directory
;
275 Lisp_Object Qfile_name_nondirectory
;
276 Lisp_Object Qunhandled_file_name_directory
;
277 Lisp_Object Qfile_name_as_directory
;
278 Lisp_Object Qcopy_file
;
279 Lisp_Object Qmake_directory_internal
;
280 Lisp_Object Qdelete_directory
;
281 Lisp_Object Qdelete_file
;
282 Lisp_Object Qrename_file
;
283 Lisp_Object Qadd_name_to_file
;
284 Lisp_Object Qmake_symbolic_link
;
285 Lisp_Object Qfile_exists_p
;
286 Lisp_Object Qfile_executable_p
;
287 Lisp_Object Qfile_readable_p
;
288 Lisp_Object Qfile_writable_p
;
289 Lisp_Object Qfile_symlink_p
;
290 Lisp_Object Qaccess_file
;
291 Lisp_Object Qfile_directory_p
;
292 Lisp_Object Qfile_regular_p
;
293 Lisp_Object Qfile_accessible_directory_p
;
294 Lisp_Object Qfile_modes
;
295 Lisp_Object Qset_file_modes
;
296 Lisp_Object Qfile_newer_than_file_p
;
297 Lisp_Object Qinsert_file_contents
;
298 Lisp_Object Qwrite_region
;
299 Lisp_Object Qverify_visited_file_modtime
;
300 Lisp_Object Qset_visited_file_modtime
;
302 DEFUN ("find-file-name-handler", Ffind_file_name_handler
, Sfind_file_name_handler
, 2, 2, 0,
303 "Return FILENAME's handler function for OPERATION, if it has one.\n\
304 Otherwise, return nil.\n\
305 A file name is handled if one of the regular expressions in\n\
306 `file-name-handler-alist' matches it.\n\n\
307 If OPERATION equals `inhibit-file-name-operation', then we ignore\n\
308 any handlers that are members of `inhibit-file-name-handlers',\n\
309 but we still do run any other handlers. This lets handlers\n\
310 use the standard functions without calling themselves recursively.")
311 (filename
, operation
)
312 Lisp_Object filename
, operation
;
314 /* This function must not munge the match data. */
315 Lisp_Object chain
, inhibited_handlers
;
317 CHECK_STRING (filename
, 0);
319 if (EQ (operation
, Vinhibit_file_name_operation
))
320 inhibited_handlers
= Vinhibit_file_name_handlers
;
322 inhibited_handlers
= Qnil
;
324 for (chain
= Vfile_name_handler_alist
; CONSP (chain
);
325 chain
= XCONS (chain
)->cdr
)
328 elt
= XCONS (chain
)->car
;
332 string
= XCONS (elt
)->car
;
333 if (STRINGP (string
) && fast_string_match (string
, filename
) >= 0)
335 Lisp_Object handler
, tem
;
337 handler
= XCONS (elt
)->cdr
;
338 tem
= Fmemq (handler
, inhibited_handlers
);
349 DEFUN ("file-name-directory", Ffile_name_directory
, Sfile_name_directory
,
351 "Return the directory component in file name FILENAME.\n\
352 Return nil if FILENAME does not include a directory.\n\
353 Otherwise return a directory spec.\n\
354 Given a Unix syntax file name, returns a string ending in slash;\n\
355 on VMS, perhaps instead a string ending in `:', `]' or `>'.")
357 Lisp_Object filename
;
359 register unsigned char *beg
;
360 register unsigned char *p
;
363 CHECK_STRING (filename
, 0);
365 /* If the file name has special constructs in it,
366 call the corresponding file handler. */
367 handler
= Ffind_file_name_handler (filename
, Qfile_name_directory
);
369 return call2 (handler
, Qfile_name_directory
, filename
);
371 #ifdef FILE_SYSTEM_CASE
372 filename
= FILE_SYSTEM_CASE (filename
);
374 beg
= XSTRING (filename
)->data
;
376 beg
= strcpy (alloca (strlen (beg
) + 1), beg
);
378 p
= beg
+ XSTRING (filename
)->size
;
380 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
382 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
385 /* only recognise drive specifier at beginning */
386 && !(p
[-1] == ':' && p
== beg
+ 2)
393 /* Expansion of "c:" to drive and default directory. */
394 if (p
== beg
+ 2 && beg
[1] == ':')
396 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
397 unsigned char *res
= alloca (MAXPATHLEN
+ 1);
398 if (getdefdir (toupper (*beg
) - 'A' + 1, res
))
400 if (!IS_DIRECTORY_SEP (res
[strlen (res
) - 1]))
403 p
= beg
+ strlen (beg
);
406 CORRECT_DIR_SEPS (beg
);
408 return make_string (beg
, p
- beg
);
411 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory
, Sfile_name_nondirectory
,
413 "Return file name FILENAME sans its directory.\n\
414 For example, in a Unix-syntax file name,\n\
415 this is everything after the last slash,\n\
416 or the entire name if it contains no slash.")
418 Lisp_Object filename
;
420 register unsigned char *beg
, *p
, *end
;
423 CHECK_STRING (filename
, 0);
425 /* If the file name has special constructs in it,
426 call the corresponding file handler. */
427 handler
= Ffind_file_name_handler (filename
, Qfile_name_nondirectory
);
429 return call2 (handler
, Qfile_name_nondirectory
, filename
);
431 beg
= XSTRING (filename
)->data
;
432 end
= p
= beg
+ XSTRING (filename
)->size
;
434 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
436 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
439 /* only recognise drive specifier at beginning */
440 && !(p
[-1] == ':' && p
== beg
+ 2)
444 return make_string (p
, end
- p
);
447 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory
, Sunhandled_file_name_directory
, 1, 1, 0,
448 "Return a directly usable directory name somehow associated with FILENAME.\n\
449 A `directly usable' directory name is one that may be used without the\n\
450 intervention of any file handler.\n\
451 If FILENAME is a directly usable file itself, return\n\
452 (file-name-directory FILENAME).\n\
453 The `call-process' and `start-process' functions use this function to\n\
454 get a current directory to run processes in.")
456 Lisp_Object filename
;
460 /* If the file name has special constructs in it,
461 call the corresponding file handler. */
462 handler
= Ffind_file_name_handler (filename
, Qunhandled_file_name_directory
);
464 return call2 (handler
, Qunhandled_file_name_directory
, filename
);
466 return Ffile_name_directory (filename
);
471 file_name_as_directory (out
, in
)
474 int size
= strlen (in
) - 1;
479 /* Is it already a directory string? */
480 if (in
[size
] == ':' || in
[size
] == ']' || in
[size
] == '>')
482 /* Is it a VMS directory file name? If so, hack VMS syntax. */
483 else if (! index (in
, '/')
484 && ((size
> 3 && ! strcmp (&in
[size
- 3], ".DIR"))
485 || (size
> 3 && ! strcmp (&in
[size
- 3], ".dir"))
486 || (size
> 5 && (! strncmp (&in
[size
- 5], ".DIR", 4)
487 || ! strncmp (&in
[size
- 5], ".dir", 4))
488 && (in
[size
- 1] == '.' || in
[size
- 1] == ';')
489 && in
[size
] == '1')))
491 register char *p
, *dot
;
495 dir:x.dir --> dir:[x]
496 dir:[x]y.dir --> dir:[x.y] */
498 while (p
!= in
&& *p
!= ':' && *p
!= '>' && *p
!= ']') p
--;
501 strncpy (out
, in
, p
- in
);
520 dot
= index (p
, '.');
523 /* blindly remove any extension */
524 size
= strlen (out
) + (dot
- p
);
525 strncat (out
, p
, dot
- p
);
536 /* For Unix syntax, Append a slash if necessary */
537 if (!IS_DIRECTORY_SEP (out
[size
]))
539 out
[size
+ 1] = DIRECTORY_SEP
;
540 out
[size
+ 2] = '\0';
543 CORRECT_DIR_SEPS (out
);
549 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
550 Sfile_name_as_directory
, 1, 1, 0,
551 "Return a string representing file FILENAME interpreted as a directory.\n\
552 This operation exists because a directory is also a file, but its name as\n\
553 a directory is different from its name as a file.\n\
554 The result can be used as the value of `default-directory'\n\
555 or passed as second argument to `expand-file-name'.\n\
556 For a Unix-syntax file name, just appends a slash.\n\
557 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
564 CHECK_STRING (file
, 0);
568 /* If the file name has special constructs in it,
569 call the corresponding file handler. */
570 handler
= Ffind_file_name_handler (file
, Qfile_name_as_directory
);
572 return call2 (handler
, Qfile_name_as_directory
, file
);
574 buf
= (char *) alloca (XSTRING (file
)->size
+ 10);
575 return build_string (file_name_as_directory (buf
, XSTRING (file
)->data
));
579 * Convert from directory name to filename.
581 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
582 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
583 * On UNIX, it's simple: just make sure there isn't a terminating /
585 * Value is nonzero if the string output is different from the input.
588 directory_file_name (src
, dst
)
596 struct FAB fab
= cc$rms_fab
;
597 struct NAM nam
= cc$rms_nam
;
598 char esa
[NAM$C_MAXRSS
];
603 if (! index (src
, '/')
604 && (src
[slen
- 1] == ']'
605 || src
[slen
- 1] == ':'
606 || src
[slen
- 1] == '>'))
608 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
610 fab
.fab$b_fns
= slen
;
611 fab
.fab$l_nam
= &nam
;
612 fab
.fab$l_fop
= FAB$M_NAM
;
615 nam
.nam$b_ess
= sizeof esa
;
616 nam
.nam$b_nop
|= NAM$M_SYNCHK
;
618 /* We call SYS$PARSE to handle such things as [--] for us. */
619 if (SYS$
PARSE (&fab
, 0, 0) == RMS$_NORMAL
)
621 slen
= nam
.nam$b_esl
;
622 if (esa
[slen
- 1] == ';' && esa
[slen
- 2] == '.')
627 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
629 /* what about when we have logical_name:???? */
630 if (src
[slen
- 1] == ':')
631 { /* Xlate logical name and see what we get */
632 ptr
= strcpy (dst
, src
); /* upper case for getenv */
635 if ('a' <= *ptr
&& *ptr
<= 'z')
639 dst
[slen
- 1] = 0; /* remove colon */
640 if (!(src
= egetenv (dst
)))
642 /* should we jump to the beginning of this procedure?
643 Good points: allows us to use logical names that xlate
645 Bad points: can be a problem if we just translated to a device
647 For now, I'll punt and always expect VMS names, and hope for
650 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
651 { /* no recursion here! */
657 { /* not a directory spec */
662 bracket
= src
[slen
- 1];
664 /* If bracket is ']' or '>', bracket - 2 is the corresponding
666 ptr
= index (src
, bracket
- 2);
668 { /* no opening bracket */
672 if (!(rptr
= rindex (src
, '.')))
675 strncpy (dst
, src
, slen
);
679 dst
[slen
++] = bracket
;
684 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
685 then translate the device and recurse. */
686 if (dst
[slen
- 1] == ':'
687 && dst
[slen
- 2] != ':' /* skip decnet nodes */
688 && strcmp (src
+ slen
, "[000000]") == 0)
690 dst
[slen
- 1] = '\0';
691 if ((ptr
= egetenv (dst
))
692 && (rlen
= strlen (ptr
) - 1) > 0
693 && (ptr
[rlen
] == ']' || ptr
[rlen
] == '>')
694 && ptr
[rlen
- 1] == '.')
696 char * buf
= (char *) alloca (strlen (ptr
) + 1);
700 return directory_file_name (buf
, dst
);
705 strcat (dst
, "[000000]");
709 rlen
= strlen (rptr
) - 1;
710 strncat (dst
, rptr
, rlen
);
711 dst
[slen
+ rlen
] = '\0';
712 strcat (dst
, ".DIR.1");
716 /* Process as Unix format: just remove any final slash.
717 But leave "/" unchanged; do not change it to "". */
720 /* Handle // as root for apollo's. */
721 if ((slen
> 2 && dst
[slen
- 1] == '/')
722 || (slen
> 1 && dst
[0] != '/' && dst
[slen
- 1] == '/'))
726 && IS_DIRECTORY_SEP (dst
[slen
- 1])
728 && !IS_ANY_SEP (dst
[slen
- 2])
734 CORRECT_DIR_SEPS (dst
);
739 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
741 "Returns the file name of the directory named DIRECTORY.\n\
742 This is the name of the file that holds the data for the directory DIRECTORY.\n\
743 This operation exists because a directory is also a file, but its name as\n\
744 a directory is different from its name as a file.\n\
745 In Unix-syntax, this function just removes the final slash.\n\
746 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
747 it returns a file name such as \"[X]Y.DIR.1\".")
749 Lisp_Object directory
;
754 CHECK_STRING (directory
, 0);
756 if (NILP (directory
))
759 /* If the file name has special constructs in it,
760 call the corresponding file handler. */
761 handler
= Ffind_file_name_handler (directory
, Qdirectory_file_name
);
763 return call2 (handler
, Qdirectory_file_name
, directory
);
766 /* 20 extra chars is insufficient for VMS, since we might perform a
767 logical name translation. an equivalence string can be up to 255
768 chars long, so grab that much extra space... - sss */
769 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20 + 255);
771 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20);
773 directory_file_name (XSTRING (directory
)->data
, buf
);
774 return build_string (buf
);
777 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
778 "Generate temporary file name (string) starting with PREFIX (a string).\n\
779 The Emacs process number forms part of the result,\n\
780 so there is no danger of generating a name being used by another process.\n\
781 In addition, this function makes an attempt to choose a name\n\
782 which has no existing file.")
788 /* Don't use too many characters of the restricted 8+3 DOS
790 val
= concat2 (prefix
, build_string ("a.XXX"));
792 val
= concat2 (prefix
, build_string ("XXXXXX"));
794 mktemp (XSTRING (val
)->data
);
796 CORRECT_DIR_SEPS (XSTRING (val
)->data
);
801 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
802 "Convert filename NAME to absolute, and canonicalize it.\n\
803 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative\n\
804 (does not start with slash); if DEFAULT-DIRECTORY is nil or missing,\n\
805 the current buffer's value of default-directory is used.\n\
806 File name components that are `.' are removed, and \n\
807 so are file name components followed by `..', along with the `..' itself;\n\
808 note that these simplifications are done without checking the resulting\n\
809 file names in the file system.\n\
810 An initial `~/' expands to your home directory.\n\
811 An initial `~USER/' expands to USER's home directory.\n\
812 See also the function `substitute-in-file-name'.")
813 (name
, default_directory
)
814 Lisp_Object name
, default_directory
;
818 register unsigned char *newdir
, *p
, *o
;
820 unsigned char *target
;
823 unsigned char * colon
= 0;
824 unsigned char * close
= 0;
825 unsigned char * slash
= 0;
826 unsigned char * brack
= 0;
827 int lbrack
= 0, rbrack
= 0;
832 int collapse_newdir
= 1;
837 CHECK_STRING (name
, 0);
839 /* If the file name has special constructs in it,
840 call the corresponding file handler. */
841 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
843 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
845 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
846 if (NILP (default_directory
))
847 default_directory
= current_buffer
->directory
;
848 if (! STRINGP (default_directory
))
849 default_directory
= build_string ("/");
851 if (!NILP (default_directory
))
853 handler
= Ffind_file_name_handler (default_directory
, Qexpand_file_name
);
855 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
858 o
= XSTRING (default_directory
)->data
;
860 /* Make sure DEFAULT_DIRECTORY is properly expanded.
861 It would be better to do this down below where we actually use
862 default_directory. Unfortunately, calling Fexpand_file_name recursively
863 could invoke GC, and the strings might be relocated. This would
864 be annoying because we have pointers into strings lying around
865 that would need adjusting, and people would add new pointers to
866 the code and forget to adjust them, resulting in intermittent bugs.
867 Putting this call here avoids all that crud.
869 The EQ test avoids infinite recursion. */
870 if (! NILP (default_directory
) && !EQ (default_directory
, name
)
871 /* Save time in some common cases - as long as default_directory
872 is not relative, it can be canonicalized with name below (if it
873 is needed at all) without requiring it to be expanded now. */
875 /* Detect MSDOS file names with drive specifiers. */
876 && ! (IS_DRIVE (o
[0]) && (IS_DEVICE_SEP (o
[1]) && IS_DIRECTORY_SEP (o
[2])))
878 /* Detect Windows file names in UNC format. */
879 && ! (IS_DIRECTORY_SEP (o
[0]) && IS_DIRECTORY_SEP (o
[1]))
881 #else /* not DOS_NT */
882 /* Detect Unix absolute file names (/... alone is not absolute on
884 && ! (IS_DIRECTORY_SEP (o
[0]))
885 #endif /* not DOS_NT */
891 default_directory
= Fexpand_file_name (default_directory
, Qnil
);
896 /* Filenames on VMS are always upper case. */
897 name
= Fupcase (name
);
899 #ifdef FILE_SYSTEM_CASE
900 name
= FILE_SYSTEM_CASE (name
);
903 nm
= XSTRING (name
)->data
;
906 /* We will force directory separators to be either all \ or /, so make
907 a local copy to modify, even if there ends up being no change. */
908 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
910 /* Find and remove drive specifier if present; this makes nm absolute
911 even if the rest of the name appears to be relative. */
913 unsigned char *colon
= rindex (nm
, ':');
916 /* Only recognize colon as part of drive specifier if there is a
917 single alphabetic character preceeding the colon (and if the
918 character before the drive letter, if present, is a directory
919 separator); this is to support the remote system syntax used by
920 ange-ftp, and the "po:username" syntax for POP mailboxes. */
924 else if (IS_DRIVE (colon
[-1])
925 && (colon
== nm
+ 1 || IS_DIRECTORY_SEP (colon
[-2])))
932 while (--colon
>= nm
)
939 /* If we see "c://somedir", we want to strip the first slash after the
940 colon when stripping the drive letter. Otherwise, this expands to
942 if (drive
&& IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
944 #endif /* WINDOWSNT */
948 /* Discard any previous drive specifier if nm is now in UNC format. */
949 if (IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
955 /* If nm is absolute, look for /./ or /../ sequences; if none are
956 found, we can probably return right away. We will avoid allocating
957 a new string if name is already fully expanded. */
959 IS_DIRECTORY_SEP (nm
[0])
964 && (drive
|| IS_DIRECTORY_SEP (nm
[1]))
971 /* If it turns out that the filename we want to return is just a
972 suffix of FILENAME, we don't need to go through and edit
973 things; we just need to construct a new string using data
974 starting at the middle of FILENAME. If we set lose to a
975 non-zero value, that means we've discovered that we can't do
982 /* Since we know the name is absolute, we can assume that each
983 element starts with a "/". */
985 /* "." and ".." are hairy. */
986 if (IS_DIRECTORY_SEP (p
[0])
988 && (IS_DIRECTORY_SEP (p
[2])
990 || (p
[2] == '.' && (IS_DIRECTORY_SEP (p
[3])
997 /* if dev:[dir]/, move nm to / */
998 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
999 nm
= (brack
? brack
+ 1 : colon
+ 1);
1000 lbrack
= rbrack
= 0;
1008 /* VMS pre V4.4,convert '-'s in filenames. */
1009 if (lbrack
== rbrack
)
1011 if (dots
< 2) /* this is to allow negative version numbers */
1016 if (lbrack
> rbrack
&&
1017 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1018 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1024 /* count open brackets, reset close bracket pointer */
1025 if (p
[0] == '[' || p
[0] == '<')
1026 lbrack
++, brack
= 0;
1027 /* count close brackets, set close bracket pointer */
1028 if (p
[0] == ']' || p
[0] == '>')
1029 rbrack
++, brack
= p
;
1030 /* detect ][ or >< */
1031 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1033 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1034 nm
= p
+ 1, lose
= 1;
1035 if (p
[0] == ':' && (colon
|| slash
))
1036 /* if dev1:[dir]dev2:, move nm to dev2: */
1042 /* if /name/dev:, move nm to dev: */
1045 /* if node::dev:, move colon following dev */
1046 else if (colon
&& colon
[-1] == ':')
1048 /* if dev1:dev2:, move nm to dev2: */
1049 else if (colon
&& colon
[-1] != ':')
1054 if (p
[0] == ':' && !colon
)
1060 if (lbrack
== rbrack
)
1063 else if (p
[0] == '.')
1071 if (index (nm
, '/'))
1072 return build_string (sys_translate_unix (nm
));
1075 /* Make sure directories are all separated with / or \ as
1076 desired, but avoid allocation of a new string when not
1078 CORRECT_DIR_SEPS (nm
);
1080 if (IS_DIRECTORY_SEP (nm
[1]))
1082 if (strcmp (nm
, XSTRING (name
)->data
) != 0)
1083 name
= build_string (nm
);
1087 /* drive must be set, so this is okay */
1088 if (strcmp (nm
- 2, XSTRING (name
)->data
) != 0)
1090 name
= make_string (nm
- 2, p
- nm
+ 2);
1091 XSTRING (name
)->data
[0] = DRIVE_LETTER (drive
);
1092 XSTRING (name
)->data
[1] = ':';
1095 #else /* not DOS_NT */
1096 if (nm
== XSTRING (name
)->data
)
1098 return build_string (nm
);
1099 #endif /* not DOS_NT */
1103 /* At this point, nm might or might not be an absolute file name. We
1104 need to expand ~ or ~user if present, otherwise prefix nm with
1105 default_directory if nm is not absolute, and finally collapse /./
1106 and /foo/../ sequences.
1108 We set newdir to be the appropriate prefix if one is needed:
1109 - the relevant user directory if nm starts with ~ or ~user
1110 - the specified drive's working dir (DOS/NT only) if nm does not
1112 - the value of default_directory.
1114 Note that these prefixes are not guaranteed to be absolute (except
1115 for the working dir of a drive). Therefore, to ensure we always
1116 return an absolute name, if the final prefix is not absolute we
1117 append it to the current working directory. */
1121 if (nm
[0] == '~') /* prefix ~ */
1123 if (IS_DIRECTORY_SEP (nm
[1])
1127 || nm
[1] == 0) /* ~ by itself */
1129 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1130 newdir
= (unsigned char *) "";
1133 collapse_newdir
= 0;
1136 nm
++; /* Don't leave the slash in nm. */
1139 else /* ~user/filename */
1141 for (p
= nm
; *p
&& (!IS_DIRECTORY_SEP (*p
)
1146 o
= (unsigned char *) alloca (p
- nm
+ 1);
1147 bcopy ((char *) nm
, o
, p
- nm
);
1150 pw
= (struct passwd
*) getpwnam (o
+ 1);
1153 newdir
= (unsigned char *) pw
-> pw_dir
;
1155 nm
= p
+ 1; /* skip the terminator */
1159 collapse_newdir
= 0;
1164 /* If we don't find a user of that name, leave the name
1165 unchanged; don't move nm forward to p. */
1170 /* On DOS and Windows, nm is absolute if a drive name was specified;
1171 use the drive's current directory as the prefix if needed. */
1172 if (!newdir
&& drive
)
1174 /* Get default directory if needed to make nm absolute. */
1175 if (!IS_DIRECTORY_SEP (nm
[0]))
1177 newdir
= alloca (MAXPATHLEN
+ 1);
1178 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1183 /* Either nm starts with /, or drive isn't mounted. */
1184 newdir
= alloca (4);
1185 newdir
[0] = DRIVE_LETTER (drive
);
1193 /* Finally, if no prefix has been specified and nm is not absolute,
1194 then it must be expanded relative to default_directory. */
1198 /* /... alone is not absolute on DOS and Windows. */
1199 && !IS_DIRECTORY_SEP (nm
[0])
1202 && !(IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1209 newdir
= XSTRING (default_directory
)->data
;
1215 /* First ensure newdir is an absolute name. */
1217 /* Detect MSDOS file names with drive specifiers. */
1218 ! (IS_DRIVE (newdir
[0])
1219 && IS_DEVICE_SEP (newdir
[1]) && IS_DIRECTORY_SEP (newdir
[2]))
1221 /* Detect Windows file names in UNC format. */
1222 && ! (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1226 /* Effectively, let newdir be (expand-file-name newdir cwd).
1227 Because of the admonition against calling expand-file-name
1228 when we have pointers into lisp strings, we accomplish this
1229 indirectly by prepending newdir to nm if necessary, and using
1230 cwd (or the wd of newdir's drive) as the new newdir. */
1232 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1237 if (!IS_DIRECTORY_SEP (nm
[0]))
1239 char * tmp
= alloca (strlen (newdir
) + strlen (nm
) + 2);
1240 file_name_as_directory (tmp
, newdir
);
1244 newdir
= alloca (MAXPATHLEN
+ 1);
1247 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1254 /* Strip off drive name from prefix, if present. */
1255 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1261 /* Keep only a prefix from newdir if nm starts with slash
1262 (//server/share for UNC, nothing otherwise). */
1263 if (IS_DIRECTORY_SEP (nm
[0]) && collapse_newdir
)
1266 if (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1268 newdir
= strcpy (alloca (strlen (newdir
) + 1), newdir
);
1270 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1272 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1284 /* Get rid of any slash at the end of newdir, unless newdir is
1285 just // (an incomplete UNC name). */
1286 length
= strlen (newdir
);
1287 if (length
> 0 && IS_DIRECTORY_SEP (newdir
[length
- 1])
1289 && !(length
== 2 && IS_DIRECTORY_SEP (newdir
[0]))
1293 unsigned char *temp
= (unsigned char *) alloca (length
);
1294 bcopy (newdir
, temp
, length
- 1);
1295 temp
[length
- 1] = 0;
1303 /* Now concatenate the directory and name to new space in the stack frame */
1304 tlen
+= strlen (nm
) + 1;
1306 /* Add reserved space for drive name. (The Microsoft x86 compiler
1307 produces incorrect code if the following two lines are combined.) */
1308 target
= (unsigned char *) alloca (tlen
+ 2);
1310 #else /* not DOS_NT */
1311 target
= (unsigned char *) alloca (tlen
);
1312 #endif /* not DOS_NT */
1318 if (nm
[0] == 0 || IS_DIRECTORY_SEP (nm
[0]))
1319 strcpy (target
, newdir
);
1322 file_name_as_directory (target
, newdir
);
1325 strcat (target
, nm
);
1327 if (index (target
, '/'))
1328 strcpy (target
, sys_translate_unix (target
));
1331 /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */
1333 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1341 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1347 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1348 /* brackets are offset from each other by 2 */
1351 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1352 /* convert [foo][bar] to [bar] */
1353 while (o
[-1] != '[' && o
[-1] != '<')
1355 else if (*p
== '-' && *o
!= '.')
1358 else if (p
[0] == '-' && o
[-1] == '.' &&
1359 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1360 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1364 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1365 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1367 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1369 /* else [foo.-] ==> [-] */
1375 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1376 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1382 if (!IS_DIRECTORY_SEP (*p
))
1386 else if (IS_DIRECTORY_SEP (p
[0])
1388 && (IS_DIRECTORY_SEP (p
[2])
1391 /* If "/." is the entire filename, keep the "/". Otherwise,
1392 just delete the whole "/.". */
1393 if (o
== target
&& p
[2] == '\0')
1397 else if (IS_DIRECTORY_SEP (p
[0]) && p
[1] == '.' && p
[2] == '.'
1398 /* `/../' is the "superroot" on certain file systems. */
1400 && (IS_DIRECTORY_SEP (p
[3]) || p
[3] == 0))
1402 while (o
!= target
&& (--o
) && !IS_DIRECTORY_SEP (*o
))
1404 /* Keep initial / only if this is the whole name. */
1405 if (o
== target
&& IS_ANY_SEP (*o
) && p
[3] == 0)
1413 #endif /* not VMS */
1417 /* At last, set drive name. */
1419 /* Except for network file name. */
1420 if (!(IS_DIRECTORY_SEP (target
[0]) && IS_DIRECTORY_SEP (target
[1])))
1421 #endif /* WINDOWSNT */
1423 if (!drive
) abort ();
1425 target
[0] = DRIVE_LETTER (drive
);
1428 CORRECT_DIR_SEPS (target
);
1431 return make_string (target
, o
- target
);
1435 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'. */
1436 DEAFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
1437 "Convert FILENAME to absolute, and canonicalize it.\n\
1438 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1439 (does not start with slash); if DEFAULT is nil or missing,\n\
1440 the current buffer's value of default-directory is used.\n\
1441 Filenames containing `.' or `..' as components are simplified;\n\
1442 initial `~/' expands to your home directory.\n\
1443 See also the function `substitute-in-file-name'.")
1445 Lisp_Object name
, defalt
;
1449 register unsigned char *newdir
, *p
, *o
;
1451 unsigned char *target
;
1455 unsigned char * colon
= 0;
1456 unsigned char * close
= 0;
1457 unsigned char * slash
= 0;
1458 unsigned char * brack
= 0;
1459 int lbrack
= 0, rbrack
= 0;
1463 CHECK_STRING (name
, 0);
1466 /* Filenames on VMS are always upper case. */
1467 name
= Fupcase (name
);
1470 nm
= XSTRING (name
)->data
;
1472 /* If nm is absolute, flush ...// and detect /./ and /../.
1473 If no /./ or /../ we can return right away. */
1485 if (p
[0] == '/' && p
[1] == '/'
1487 /* // at start of filename is meaningful on Apollo system. */
1492 if (p
[0] == '/' && p
[1] == '~')
1493 nm
= p
+ 1, lose
= 1;
1494 if (p
[0] == '/' && p
[1] == '.'
1495 && (p
[2] == '/' || p
[2] == 0
1496 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1502 /* if dev:[dir]/, move nm to / */
1503 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1504 nm
= (brack
? brack
+ 1 : colon
+ 1);
1505 lbrack
= rbrack
= 0;
1513 /* VMS pre V4.4,convert '-'s in filenames. */
1514 if (lbrack
== rbrack
)
1516 if (dots
< 2) /* this is to allow negative version numbers */
1521 if (lbrack
> rbrack
&&
1522 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1523 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1529 /* count open brackets, reset close bracket pointer */
1530 if (p
[0] == '[' || p
[0] == '<')
1531 lbrack
++, brack
= 0;
1532 /* count close brackets, set close bracket pointer */
1533 if (p
[0] == ']' || p
[0] == '>')
1534 rbrack
++, brack
= p
;
1535 /* detect ][ or >< */
1536 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1538 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1539 nm
= p
+ 1, lose
= 1;
1540 if (p
[0] == ':' && (colon
|| slash
))
1541 /* if dev1:[dir]dev2:, move nm to dev2: */
1547 /* If /name/dev:, move nm to dev: */
1550 /* If node::dev:, move colon following dev */
1551 else if (colon
&& colon
[-1] == ':')
1553 /* If dev1:dev2:, move nm to dev2: */
1554 else if (colon
&& colon
[-1] != ':')
1559 if (p
[0] == ':' && !colon
)
1565 if (lbrack
== rbrack
)
1568 else if (p
[0] == '.')
1576 if (index (nm
, '/'))
1577 return build_string (sys_translate_unix (nm
));
1579 if (nm
== XSTRING (name
)->data
)
1581 return build_string (nm
);
1585 /* Now determine directory to start with and put it in NEWDIR */
1589 if (nm
[0] == '~') /* prefix ~ */
1594 || nm
[1] == 0)/* ~/filename */
1596 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1597 newdir
= (unsigned char *) "";
1600 nm
++; /* Don't leave the slash in nm. */
1603 else /* ~user/filename */
1605 /* Get past ~ to user */
1606 unsigned char *user
= nm
+ 1;
1607 /* Find end of name. */
1608 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1609 int len
= ptr
? ptr
- user
: strlen (user
);
1611 unsigned char *ptr1
= index (user
, ':');
1612 if (ptr1
!= 0 && ptr1
- user
< len
)
1615 /* Copy the user name into temp storage. */
1616 o
= (unsigned char *) alloca (len
+ 1);
1617 bcopy ((char *) user
, o
, len
);
1620 /* Look up the user name. */
1621 pw
= (struct passwd
*) getpwnam (o
+ 1);
1623 error ("\"%s\" isn't a registered user", o
+ 1);
1625 newdir
= (unsigned char *) pw
->pw_dir
;
1627 /* Discard the user name from NM. */
1634 #endif /* not VMS */
1638 defalt
= current_buffer
->directory
;
1639 CHECK_STRING (defalt
, 1);
1640 newdir
= XSTRING (defalt
)->data
;
1643 /* Now concatenate the directory and name to new space in the stack frame */
1645 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1646 target
= (unsigned char *) alloca (tlen
);
1652 if (nm
[0] == 0 || nm
[0] == '/')
1653 strcpy (target
, newdir
);
1656 file_name_as_directory (target
, newdir
);
1659 strcat (target
, nm
);
1661 if (index (target
, '/'))
1662 strcpy (target
, sys_translate_unix (target
));
1665 /* Now canonicalize by removing /. and /foo/.. if they appear */
1673 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1679 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1680 /* brackets are offset from each other by 2 */
1683 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1684 /* convert [foo][bar] to [bar] */
1685 while (o
[-1] != '[' && o
[-1] != '<')
1687 else if (*p
== '-' && *o
!= '.')
1690 else if (p
[0] == '-' && o
[-1] == '.' &&
1691 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1692 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1696 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1697 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1699 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1701 /* else [foo.-] ==> [-] */
1707 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1708 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1718 else if (!strncmp (p
, "//", 2)
1720 /* // at start of filename is meaningful in Apollo system. */
1728 else if (p
[0] == '/' && p
[1] == '.' &&
1729 (p
[2] == '/' || p
[2] == 0))
1731 else if (!strncmp (p
, "/..", 3)
1732 /* `/../' is the "superroot" on certain file systems. */
1734 && (p
[3] == '/' || p
[3] == 0))
1736 while (o
!= target
&& *--o
!= '/')
1739 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1743 if (o
== target
&& *o
== '/')
1751 #endif /* not VMS */
1754 return make_string (target
, o
- target
);
1758 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1759 Ssubstitute_in_file_name
, 1, 1, 0,
1760 "Substitute environment variables referred to in FILENAME.\n\
1761 `$FOO' where FOO is an environment variable name means to substitute\n\
1762 the value of that variable. The variable name should be terminated\n\
1763 with a character not a letter, digit or underscore; otherwise, enclose\n\
1764 the entire variable name in braces.\n\
1765 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1766 On VMS, `$' substitution is not done; this function does little and only\n\
1767 duplicates what `expand-file-name' does.")
1769 Lisp_Object filename
;
1773 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1774 unsigned char *target
;
1776 int substituted
= 0;
1778 Lisp_Object handler
;
1780 CHECK_STRING (filename
, 0);
1782 /* If the file name has special constructs in it,
1783 call the corresponding file handler. */
1784 handler
= Ffind_file_name_handler (filename
, Qsubstitute_in_file_name
);
1785 if (!NILP (handler
))
1786 return call2 (handler
, Qsubstitute_in_file_name
, filename
);
1788 nm
= XSTRING (filename
)->data
;
1790 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
1791 CORRECT_DIR_SEPS (nm
);
1792 substituted
= (strcmp (nm
, XSTRING (filename
)->data
) != 0);
1794 endp
= nm
+ XSTRING (filename
)->size
;
1796 /* If /~ or // appears, discard everything through first slash. */
1798 for (p
= nm
; p
!= endp
; p
++)
1801 #if defined (APOLLO) || defined (WINDOWSNT)
1802 /* // at start of file name is meaningful in Apollo and
1803 WindowsNT systems. */
1804 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != nm
)
1805 #else /* not (APOLLO || WINDOWSNT) */
1806 || IS_DIRECTORY_SEP (p
[0])
1807 #endif /* not (APOLLO || WINDOWSNT) */
1812 || p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>'
1814 || IS_DIRECTORY_SEP (p
[-1])))
1820 /* see comment in expand-file-name about drive specifiers */
1821 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
1822 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
1831 return build_string (nm
);
1834 /* See if any variables are substituted into the string
1835 and find the total length of their values in `total' */
1837 for (p
= nm
; p
!= endp
;)
1847 /* "$$" means a single "$" */
1856 while (p
!= endp
&& *p
!= '}') p
++;
1857 if (*p
!= '}') goto missingclose
;
1863 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1867 /* Copy out the variable name */
1868 target
= (unsigned char *) alloca (s
- o
+ 1);
1869 strncpy (target
, o
, s
- o
);
1872 strupr (target
); /* $home == $HOME etc. */
1875 /* Get variable value */
1876 o
= (unsigned char *) egetenv (target
);
1877 if (!o
) goto badvar
;
1878 total
+= strlen (o
);
1885 /* If substitution required, recopy the string and do it */
1886 /* Make space in stack frame for the new copy */
1887 xnm
= (unsigned char *) alloca (XSTRING (filename
)->size
+ total
+ 1);
1890 /* Copy the rest of the name through, replacing $ constructs with values */
1907 while (p
!= endp
&& *p
!= '}') p
++;
1908 if (*p
!= '}') goto missingclose
;
1914 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1918 /* Copy out the variable name */
1919 target
= (unsigned char *) alloca (s
- o
+ 1);
1920 strncpy (target
, o
, s
- o
);
1923 strupr (target
); /* $home == $HOME etc. */
1926 /* Get variable value */
1927 o
= (unsigned char *) egetenv (target
);
1937 /* If /~ or // appears, discard everything through first slash. */
1939 for (p
= xnm
; p
!= x
; p
++)
1941 #if defined (APOLLO) || defined (WINDOWSNT)
1942 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != xnm
)
1943 #else /* not (APOLLO || WINDOWSNT) */
1944 || IS_DIRECTORY_SEP (p
[0])
1945 #endif /* not (APOLLO || WINDOWSNT) */
1947 && p
!= xnm
&& IS_DIRECTORY_SEP (p
[-1]))
1950 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
1951 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
1955 return make_string (xnm
, x
- xnm
);
1958 error ("Bad format environment-variable substitution");
1960 error ("Missing \"}\" in environment-variable substitution");
1962 error ("Substituting nonexistent environment variable \"%s\"", target
);
1965 #endif /* not VMS */
1968 /* A slightly faster and more convenient way to get
1969 (directory-file-name (expand-file-name FOO)). */
1972 expand_and_dir_to_file (filename
, defdir
)
1973 Lisp_Object filename
, defdir
;
1975 register Lisp_Object absname
;
1977 absname
= Fexpand_file_name (filename
, defdir
);
1980 register int c
= XSTRING (absname
)->data
[XSTRING (absname
)->size
- 1];
1981 if (c
== ':' || c
== ']' || c
== '>')
1982 absname
= Fdirectory_file_name (absname
);
1985 /* Remove final slash, if any (unless this is the root dir).
1986 stat behaves differently depending! */
1987 if (XSTRING (absname
)->size
> 1
1988 && IS_DIRECTORY_SEP (XSTRING (absname
)->data
[XSTRING (absname
)->size
- 1])
1989 && !IS_DEVICE_SEP (XSTRING (absname
)->data
[XSTRING (absname
)->size
-2]))
1990 /* We cannot take shortcuts; they might be wrong for magic file names. */
1991 absname
= Fdirectory_file_name (absname
);
1996 /* Signal an error if the file ABSNAME already exists.
1997 If INTERACTIVE is nonzero, ask the user whether to proceed,
1998 and bypass the error if the user says to go ahead.
1999 QUERYSTRING is a name for the action that is being considered
2001 *STATPTR is used to store the stat information if the file exists.
2002 If the file does not exist, STATPTR->st_mode is set to 0. */
2005 barf_or_query_if_file_exists (absname
, querystring
, interactive
, statptr
)
2006 Lisp_Object absname
;
2007 unsigned char *querystring
;
2009 struct stat
*statptr
;
2011 register Lisp_Object tem
;
2012 struct stat statbuf
;
2013 struct gcpro gcpro1
;
2015 /* stat is a good way to tell whether the file exists,
2016 regardless of what access permissions it has. */
2017 if (stat (XSTRING (absname
)->data
, &statbuf
) >= 0)
2020 Fsignal (Qfile_already_exists
,
2021 Fcons (build_string ("File already exists"),
2022 Fcons (absname
, Qnil
)));
2024 tem
= do_yes_or_no_p (format1 ("File %s already exists; %s anyway? ",
2025 XSTRING (absname
)->data
, querystring
));
2028 Fsignal (Qfile_already_exists
,
2029 Fcons (build_string ("File already exists"),
2030 Fcons (absname
, Qnil
)));
2037 statptr
->st_mode
= 0;
2042 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
2043 "fCopy file: \nFCopy %s to file: \np\nP",
2044 "Copy FILE to NEWNAME. Both args must be strings.\n\
2045 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
2046 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
2047 A number as third arg means request confirmation if NEWNAME already exists.\n\
2048 This is what happens in interactive use with M-x.\n\
2049 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
2050 last-modified time as the old one. (This works on only some systems.)\n\
2051 A prefix arg makes KEEP-TIME non-nil.")
2052 (file
, newname
, ok_if_already_exists
, keep_date
)
2053 Lisp_Object file
, newname
, ok_if_already_exists
, keep_date
;
2056 char buf
[16 * 1024];
2057 struct stat st
, out_st
;
2058 Lisp_Object handler
;
2059 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2060 int count
= specpdl_ptr
- specpdl
;
2061 int input_file_statable_p
;
2062 Lisp_Object encoded_file
, encoded_newname
;
2064 encoded_file
= encoded_newname
= Qnil
;
2065 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2066 CHECK_STRING (file
, 0);
2067 CHECK_STRING (newname
, 1);
2069 file
= Fexpand_file_name (file
, Qnil
);
2070 newname
= Fexpand_file_name (newname
, Qnil
);
2072 /* If the input file name has special constructs in it,
2073 call the corresponding file handler. */
2074 handler
= Ffind_file_name_handler (file
, Qcopy_file
);
2075 /* Likewise for output file name. */
2077 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
2078 if (!NILP (handler
))
2079 RETURN_UNGCPRO (call5 (handler
, Qcopy_file
, file
, newname
,
2080 ok_if_already_exists
, keep_date
));
2082 encoded_file
= ENCODE_FILE (file
);
2083 encoded_newname
= ENCODE_FILE (newname
);
2085 if (NILP (ok_if_already_exists
)
2086 || INTEGERP (ok_if_already_exists
))
2087 barf_or_query_if_file_exists (encoded_newname
, "copy to it",
2088 INTEGERP (ok_if_already_exists
), &out_st
);
2089 else if (stat (XSTRING (encoded_newname
)->data
, &out_st
) < 0)
2092 ifd
= open (XSTRING (encoded_file
)->data
, O_RDONLY
);
2094 report_file_error ("Opening input file", Fcons (file
, Qnil
));
2096 record_unwind_protect (close_file_unwind
, make_number (ifd
));
2098 /* We can only copy regular files and symbolic links. Other files are not
2100 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
2102 #if !defined (MSDOS) || __DJGPP__ > 1
2103 if (out_st
.st_mode
!= 0
2104 && st
.st_dev
== out_st
.st_dev
&& st
.st_ino
== out_st
.st_ino
)
2107 report_file_error ("Input and output files are the same",
2108 Fcons (file
, Fcons (newname
, Qnil
)));
2112 #if defined (S_ISREG) && defined (S_ISLNK)
2113 if (input_file_statable_p
)
2115 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
2117 #if defined (EISDIR)
2118 /* Get a better looking error message. */
2121 report_file_error ("Non-regular file", Fcons (file
, Qnil
));
2124 #endif /* S_ISREG && S_ISLNK */
2127 /* Create the copy file with the same record format as the input file */
2128 ofd
= sys_creat (XSTRING (encoded_newname
)->data
, 0666, ifd
);
2131 /* System's default file type was set to binary by _fmode in emacs.c. */
2132 ofd
= creat (XSTRING (encoded_newname
)->data
, S_IREAD
| S_IWRITE
);
2133 #else /* not MSDOS */
2134 ofd
= creat (XSTRING (encoded_newname
)->data
, 0666);
2135 #endif /* not MSDOS */
2138 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
2140 record_unwind_protect (close_file_unwind
, make_number (ofd
));
2144 while ((n
= read (ifd
, buf
, sizeof buf
)) > 0)
2145 if (write (ofd
, buf
, n
) != n
)
2146 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2149 /* Closing the output clobbers the file times on some systems. */
2150 if (close (ofd
) < 0)
2151 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2153 if (input_file_statable_p
)
2155 if (!NILP (keep_date
))
2157 EMACS_TIME atime
, mtime
;
2158 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
2159 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
2160 if (set_file_times (XSTRING (encoded_newname
)->data
,
2162 Fsignal (Qfile_date_error
,
2163 Fcons (build_string ("Cannot set file date"),
2164 Fcons (newname
, Qnil
)));
2167 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2169 #if defined (__DJGPP__) && __DJGPP__ > 1
2170 /* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
2171 and if it can't, it tells so. Otherwise, under MSDOS we usually
2172 get only the READ bit, which will make the copied file read-only,
2173 so it's better not to chmod at all. */
2174 if ((_djstat_flags
& _STFAIL_WRITEBIT
) == 0)
2175 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2176 #endif /* DJGPP version 2 or newer */
2182 /* Discard the unwind protects. */
2183 specpdl_ptr
= specpdl
+ count
;
2189 DEFUN ("make-directory-internal", Fmake_directory_internal
,
2190 Smake_directory_internal
, 1, 1, 0,
2191 "Create a new directory named DIRECTORY.")
2193 Lisp_Object directory
;
2196 Lisp_Object handler
;
2197 Lisp_Object encoded_dir
;
2199 CHECK_STRING (directory
, 0);
2200 directory
= Fexpand_file_name (directory
, Qnil
);
2202 handler
= Ffind_file_name_handler (directory
, Qmake_directory_internal
);
2203 if (!NILP (handler
))
2204 return call2 (handler
, Qmake_directory_internal
, directory
);
2206 encoded_dir
= ENCODE_FILE (directory
);
2208 dir
= XSTRING (encoded_dir
)->data
;
2211 if (mkdir (dir
) != 0)
2213 if (mkdir (dir
, 0777) != 0)
2215 report_file_error ("Creating directory", Flist (1, &directory
));
2220 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
2221 "Delete the directory named DIRECTORY.")
2223 Lisp_Object directory
;
2226 Lisp_Object handler
;
2227 Lisp_Object encoded_dir
;
2229 CHECK_STRING (directory
, 0);
2230 directory
= Fdirectory_file_name (Fexpand_file_name (directory
, Qnil
));
2232 handler
= Ffind_file_name_handler (directory
, Qdelete_directory
);
2233 if (!NILP (handler
))
2234 return call2 (handler
, Qdelete_directory
, directory
);
2236 encoded_dir
= ENCODE_FILE (directory
);
2238 dir
= XSTRING (encoded_dir
)->data
;
2240 if (rmdir (dir
) != 0)
2241 report_file_error ("Removing directory", Flist (1, &directory
));
2246 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
2247 "Delete file named FILENAME.\n\
2248 If file has multiple names, it continues to exist with the other names.")
2250 Lisp_Object filename
;
2252 Lisp_Object handler
;
2253 Lisp_Object encoded_file
;
2255 CHECK_STRING (filename
, 0);
2256 filename
= Fexpand_file_name (filename
, Qnil
);
2258 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
2259 if (!NILP (handler
))
2260 return call2 (handler
, Qdelete_file
, filename
);
2262 encoded_file
= ENCODE_FILE (filename
);
2264 if (0 > unlink (XSTRING (encoded_file
)->data
))
2265 report_file_error ("Removing old name", Flist (1, &filename
));
2270 internal_delete_file_1 (ignore
)
2276 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */
2279 internal_delete_file (filename
)
2280 Lisp_Object filename
;
2282 return NILP (internal_condition_case_1 (Fdelete_file
, filename
,
2283 Qt
, internal_delete_file_1
));
2286 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
2287 "fRename file: \nFRename %s to file: \np",
2288 "Rename FILE as NEWNAME. Both args strings.\n\
2289 If file has names other than FILE, it continues to have those names.\n\
2290 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2291 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2292 A number as third arg means request confirmation if NEWNAME already exists.\n\
2293 This is what happens in interactive use with M-x.")
2294 (file
, newname
, ok_if_already_exists
)
2295 Lisp_Object file
, newname
, ok_if_already_exists
;
2298 Lisp_Object args
[2];
2300 Lisp_Object handler
;
2301 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2302 Lisp_Object encoded_file
, encoded_newname
;
2304 encoded_file
= encoded_newname
= Qnil
;
2305 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2306 CHECK_STRING (file
, 0);
2307 CHECK_STRING (newname
, 1);
2308 file
= Fexpand_file_name (file
, Qnil
);
2309 newname
= Fexpand_file_name (newname
, Qnil
);
2311 /* If the file name has special constructs in it,
2312 call the corresponding file handler. */
2313 handler
= Ffind_file_name_handler (file
, Qrename_file
);
2315 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
2316 if (!NILP (handler
))
2317 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
2318 file
, newname
, ok_if_already_exists
));
2320 encoded_file
= ENCODE_FILE (file
);
2321 encoded_newname
= ENCODE_FILE (newname
);
2323 if (NILP (ok_if_already_exists
)
2324 || INTEGERP (ok_if_already_exists
))
2325 barf_or_query_if_file_exists (encoded_newname
, "rename to it",
2326 INTEGERP (ok_if_already_exists
), 0);
2328 if (0 > rename (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2330 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
)
2331 || 0 > unlink (XSTRING (encoded_file
)->data
))
2336 Fcopy_file (file
, newname
,
2337 /* We have already prompted if it was an integer,
2338 so don't have copy-file prompt again. */
2339 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
2340 Fdelete_file (file
);
2347 report_file_error ("Renaming", Flist (2, args
));
2350 report_file_error ("Renaming", Flist (2, &file
));
2357 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
2358 "fAdd name to file: \nFName to add to %s: \np",
2359 "Give FILE additional name NEWNAME. Both args strings.\n\
2360 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2361 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2362 A number as third arg means request confirmation if NEWNAME already exists.\n\
2363 This is what happens in interactive use with M-x.")
2364 (file
, newname
, ok_if_already_exists
)
2365 Lisp_Object file
, newname
, ok_if_already_exists
;
2368 Lisp_Object args
[2];
2370 Lisp_Object handler
;
2371 Lisp_Object encoded_file
, encoded_newname
;
2372 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2374 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2375 encoded_file
= encoded_newname
= Qnil
;
2376 CHECK_STRING (file
, 0);
2377 CHECK_STRING (newname
, 1);
2378 file
= Fexpand_file_name (file
, Qnil
);
2379 newname
= Fexpand_file_name (newname
, Qnil
);
2381 /* If the file name has special constructs in it,
2382 call the corresponding file handler. */
2383 handler
= Ffind_file_name_handler (file
, Qadd_name_to_file
);
2384 if (!NILP (handler
))
2385 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2386 newname
, ok_if_already_exists
));
2388 /* If the new name has special constructs in it,
2389 call the corresponding file handler. */
2390 handler
= Ffind_file_name_handler (newname
, Qadd_name_to_file
);
2391 if (!NILP (handler
))
2392 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2393 newname
, ok_if_already_exists
));
2395 encoded_file
= ENCODE_FILE (file
);
2396 encoded_newname
= ENCODE_FILE (newname
);
2398 if (NILP (ok_if_already_exists
)
2399 || INTEGERP (ok_if_already_exists
))
2400 barf_or_query_if_file_exists (encoded_newname
, "make it a new name",
2401 INTEGERP (ok_if_already_exists
), 0);
2403 unlink (XSTRING (newname
)->data
);
2404 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2409 report_file_error ("Adding new name", Flist (2, args
));
2411 report_file_error ("Adding new name", Flist (2, &file
));
2420 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2421 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2422 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
2423 Signals a `file-already-exists' error if a file LINKNAME already exists\n\
2424 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2425 A number as third arg means request confirmation if LINKNAME already exists.\n\
2426 This happens for interactive use with M-x.")
2427 (filename
, linkname
, ok_if_already_exists
)
2428 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2431 Lisp_Object args
[2];
2433 Lisp_Object handler
;
2434 Lisp_Object encoded_filename
, encoded_linkname
;
2435 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2437 GCPRO4 (filename
, linkname
, encoded_filename
, encoded_linkname
);
2438 encoded_filename
= encoded_linkname
= Qnil
;
2439 CHECK_STRING (filename
, 0);
2440 CHECK_STRING (linkname
, 1);
2441 /* If the link target has a ~, we must expand it to get
2442 a truly valid file name. Otherwise, do not expand;
2443 we want to permit links to relative file names. */
2444 if (XSTRING (filename
)->data
[0] == '~')
2445 filename
= Fexpand_file_name (filename
, Qnil
);
2446 linkname
= Fexpand_file_name (linkname
, Qnil
);
2448 /* If the file name has special constructs in it,
2449 call the corresponding file handler. */
2450 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2451 if (!NILP (handler
))
2452 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2453 linkname
, ok_if_already_exists
));
2455 /* If the new link name has special constructs in it,
2456 call the corresponding file handler. */
2457 handler
= Ffind_file_name_handler (linkname
, Qmake_symbolic_link
);
2458 if (!NILP (handler
))
2459 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2460 linkname
, ok_if_already_exists
));
2462 encoded_filename
= ENCODE_FILE (filename
);
2463 encoded_linkname
= ENCODE_FILE (linkname
);
2465 if (NILP (ok_if_already_exists
)
2466 || INTEGERP (ok_if_already_exists
))
2467 barf_or_query_if_file_exists (encoded_linkname
, "make it a link",
2468 INTEGERP (ok_if_already_exists
), 0);
2469 if (0 > symlink (XSTRING (encoded_filename
)->data
,
2470 XSTRING (encoded_linkname
)->data
))
2472 /* If we didn't complain already, silently delete existing file. */
2473 if (errno
== EEXIST
)
2475 unlink (XSTRING (encoded_linkname
)->data
);
2476 if (0 <= symlink (XSTRING (encoded_filename
)->data
,
2477 XSTRING (encoded_linkname
)->data
))
2487 report_file_error ("Making symbolic link", Flist (2, args
));
2489 report_file_error ("Making symbolic link", Flist (2, &filename
));
2495 #endif /* S_IFLNK */
2499 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2500 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2501 "Define the job-wide logical name NAME to have the value STRING.\n\
2502 If STRING is nil or a null string, the logical name NAME is deleted.")
2507 CHECK_STRING (name
, 0);
2509 delete_logical_name (XSTRING (name
)->data
);
2512 CHECK_STRING (string
, 1);
2514 if (XSTRING (string
)->size
== 0)
2515 delete_logical_name (XSTRING (name
)->data
);
2517 define_logical_name (XSTRING (name
)->data
, XSTRING (string
)->data
);
2526 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2527 "Open a network connection to PATH using LOGIN as the login string.")
2529 Lisp_Object path
, login
;
2533 CHECK_STRING (path
, 0);
2534 CHECK_STRING (login
, 0);
2536 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2538 if (netresult
== -1)
2543 #endif /* HPUX_NET */
2545 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2547 "Return t if file FILENAME specifies an absolute file name.\n\
2548 On Unix, this is a name starting with a `/' or a `~'.")
2550 Lisp_Object filename
;
2554 CHECK_STRING (filename
, 0);
2555 ptr
= XSTRING (filename
)->data
;
2556 if (IS_DIRECTORY_SEP (*ptr
) || *ptr
== '~'
2558 /* ??? This criterion is probably wrong for '<'. */
2559 || index (ptr
, ':') || index (ptr
, '<')
2560 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2564 || (IS_DRIVE (*ptr
) && ptr
[1] == ':' && IS_DIRECTORY_SEP (ptr
[2]))
2572 /* Return nonzero if file FILENAME exists and can be executed. */
2575 check_executable (filename
)
2579 int len
= strlen (filename
);
2582 if (stat (filename
, &st
) < 0)
2584 #if defined (WINDOWSNT) || (defined (MSDOS) && __DJGPP__ > 1)
2585 return ((st
.st_mode
& S_IEXEC
) != 0);
2587 return (S_ISREG (st
.st_mode
)
2589 && (stricmp ((suffix
= filename
+ len
-4), ".com") == 0
2590 || stricmp (suffix
, ".exe") == 0
2591 || stricmp (suffix
, ".bat") == 0)
2592 || (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2593 #endif /* not WINDOWSNT */
2594 #else /* not DOS_NT */
2595 #ifdef HAVE_EUIDACCESS
2596 return (euidaccess (filename
, 1) >= 0);
2598 /* Access isn't quite right because it uses the real uid
2599 and we really want to test with the effective uid.
2600 But Unix doesn't give us a right way to do it. */
2601 return (access (filename
, 1) >= 0);
2603 #endif /* not DOS_NT */
2606 /* Return nonzero if file FILENAME exists and can be written. */
2609 check_writable (filename
)
2614 if (stat (filename
, &st
) < 0)
2616 return (st
.st_mode
& S_IWRITE
|| (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2617 #else /* not MSDOS */
2618 #ifdef HAVE_EUIDACCESS
2619 return (euidaccess (filename
, 2) >= 0);
2621 /* Access isn't quite right because it uses the real uid
2622 and we really want to test with the effective uid.
2623 But Unix doesn't give us a right way to do it.
2624 Opening with O_WRONLY could work for an ordinary file,
2625 but would lose for directories. */
2626 return (access (filename
, 2) >= 0);
2628 #endif /* not MSDOS */
2631 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2632 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
2633 See also `file-readable-p' and `file-attributes'.")
2635 Lisp_Object filename
;
2637 Lisp_Object absname
;
2638 Lisp_Object handler
;
2639 struct stat statbuf
;
2641 CHECK_STRING (filename
, 0);
2642 absname
= Fexpand_file_name (filename
, Qnil
);
2644 /* If the file name has special constructs in it,
2645 call the corresponding file handler. */
2646 handler
= Ffind_file_name_handler (absname
, Qfile_exists_p
);
2647 if (!NILP (handler
))
2648 return call2 (handler
, Qfile_exists_p
, absname
);
2650 absname
= ENCODE_FILE (absname
);
2652 return (stat (XSTRING (absname
)->data
, &statbuf
) >= 0) ? Qt
: Qnil
;
2655 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2656 "Return t if FILENAME can be executed by you.\n\
2657 For a directory, this means you can access files in that directory.")
2659 Lisp_Object filename
;
2662 Lisp_Object absname
;
2663 Lisp_Object handler
;
2665 CHECK_STRING (filename
, 0);
2666 absname
= Fexpand_file_name (filename
, Qnil
);
2668 /* If the file name has special constructs in it,
2669 call the corresponding file handler. */
2670 handler
= Ffind_file_name_handler (absname
, Qfile_executable_p
);
2671 if (!NILP (handler
))
2672 return call2 (handler
, Qfile_executable_p
, absname
);
2674 absname
= ENCODE_FILE (absname
);
2676 return (check_executable (XSTRING (absname
)->data
) ? Qt
: Qnil
);
2679 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2680 "Return t if file FILENAME exists and you can read it.\n\
2681 See also `file-exists-p' and `file-attributes'.")
2683 Lisp_Object filename
;
2685 Lisp_Object absname
;
2686 Lisp_Object handler
;
2689 struct stat statbuf
;
2691 CHECK_STRING (filename
, 0);
2692 absname
= Fexpand_file_name (filename
, Qnil
);
2694 /* If the file name has special constructs in it,
2695 call the corresponding file handler. */
2696 handler
= Ffind_file_name_handler (absname
, Qfile_readable_p
);
2697 if (!NILP (handler
))
2698 return call2 (handler
, Qfile_readable_p
, absname
);
2700 absname
= ENCODE_FILE (absname
);
2703 /* Under MS-DOS and Windows, open does not work for directories. */
2704 if (access (XSTRING (absname
)->data
, 0) == 0)
2707 #else /* not DOS_NT */
2709 #if defined (S_ISFIFO) && defined (O_NONBLOCK)
2710 /* Opening a fifo without O_NONBLOCK can wait.
2711 We don't want to wait. But we don't want to mess wth O_NONBLOCK
2712 except in the case of a fifo, on a system which handles it. */
2713 desc
= stat (XSTRING (absname
)->data
, &statbuf
);
2716 if (S_ISFIFO (statbuf
.st_mode
))
2717 flags
|= O_NONBLOCK
;
2719 desc
= open (XSTRING (absname
)->data
, flags
);
2724 #endif /* not DOS_NT */
2727 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2729 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
2730 "Return t if file FILENAME can be written or created by you.")
2732 Lisp_Object filename
;
2734 Lisp_Object absname
, dir
, encoded
;
2735 Lisp_Object handler
;
2736 struct stat statbuf
;
2738 CHECK_STRING (filename
, 0);
2739 absname
= Fexpand_file_name (filename
, Qnil
);
2741 /* If the file name has special constructs in it,
2742 call the corresponding file handler. */
2743 handler
= Ffind_file_name_handler (absname
, Qfile_writable_p
);
2744 if (!NILP (handler
))
2745 return call2 (handler
, Qfile_writable_p
, absname
);
2747 encoded
= ENCODE_FILE (absname
);
2748 if (stat (XSTRING (encoded
)->data
, &statbuf
) >= 0)
2749 return (check_writable (XSTRING (encoded
)->data
)
2752 dir
= Ffile_name_directory (absname
);
2755 dir
= Fdirectory_file_name (dir
);
2759 dir
= Fdirectory_file_name (dir
);
2762 dir
= ENCODE_FILE (dir
);
2763 return (check_writable (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "")
2767 DEFUN ("access-file", Faccess_file
, Saccess_file
, 2, 2, 0,
2768 "Access file FILENAME, and get an error if that does not work.\n\
2769 The second argument STRING is used in the error message.\n\
2770 If there is no error, we return nil.")
2772 Lisp_Object filename
, string
;
2774 Lisp_Object handler
, encoded_filename
;
2777 CHECK_STRING (filename
, 0);
2779 /* If the file name has special constructs in it,
2780 call the corresponding file handler. */
2781 handler
= Ffind_file_name_handler (filename
, Qaccess_file
);
2782 if (!NILP (handler
))
2783 return call3 (handler
, Qaccess_file
, filename
, string
);
2785 encoded_filename
= ENCODE_FILE (filename
);
2787 fd
= open (XSTRING (encoded_filename
)->data
, O_RDONLY
);
2789 report_file_error (XSTRING (string
)->data
, Fcons (filename
, Qnil
));
2795 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
2796 "Return non-nil if file FILENAME is the name of a symbolic link.\n\
2797 The value is the name of the file to which it is linked.\n\
2798 Otherwise returns nil.")
2800 Lisp_Object filename
;
2807 Lisp_Object handler
;
2809 CHECK_STRING (filename
, 0);
2810 filename
= Fexpand_file_name (filename
, Qnil
);
2812 /* If the file name has special constructs in it,
2813 call the corresponding file handler. */
2814 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
2815 if (!NILP (handler
))
2816 return call2 (handler
, Qfile_symlink_p
, filename
);
2818 filename
= ENCODE_FILE (filename
);
2823 buf
= (char *) xmalloc (bufsize
);
2824 bzero (buf
, bufsize
);
2825 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
2826 if (valsize
< bufsize
) break;
2827 /* Buffer was not long enough */
2836 val
= make_string (buf
, valsize
);
2838 return Fdecode_coding_string (val
, Vfile_name_coding_system
, Qt
);
2839 #else /* not S_IFLNK */
2841 #endif /* not S_IFLNK */
2844 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
2845 "Return t if FILENAME names an existing directory.")
2847 Lisp_Object filename
;
2849 register Lisp_Object absname
;
2851 Lisp_Object handler
;
2853 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2855 /* If the file name has special constructs in it,
2856 call the corresponding file handler. */
2857 handler
= Ffind_file_name_handler (absname
, Qfile_directory_p
);
2858 if (!NILP (handler
))
2859 return call2 (handler
, Qfile_directory_p
, absname
);
2861 absname
= ENCODE_FILE (absname
);
2863 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2865 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
2868 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
2869 "Return t if file FILENAME is the name of a directory as a file,\n\
2870 and files in that directory can be opened by you. In order to use a\n\
2871 directory as a buffer's current directory, this predicate must return true.\n\
2872 A directory name spec may be given instead; then the value is t\n\
2873 if the directory so specified exists and really is a readable and\n\
2874 searchable directory.")
2876 Lisp_Object filename
;
2878 Lisp_Object handler
;
2880 struct gcpro gcpro1
;
2882 /* If the file name has special constructs in it,
2883 call the corresponding file handler. */
2884 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
2885 if (!NILP (handler
))
2886 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
2888 /* It's an unlikely combination, but yes we really do need to gcpro:
2889 Suppose that file-accessible-directory-p has no handler, but
2890 file-directory-p does have a handler; this handler causes a GC which
2891 relocates the string in `filename'; and finally file-directory-p
2892 returns non-nil. Then we would end up passing a garbaged string
2893 to file-executable-p. */
2895 tem
= (NILP (Ffile_directory_p (filename
))
2896 || NILP (Ffile_executable_p (filename
)));
2898 return tem
? Qnil
: Qt
;
2901 DEFUN ("file-regular-p", Ffile_regular_p
, Sfile_regular_p
, 1, 1, 0,
2902 "Return t if file FILENAME is the name of a regular file.\n\
2903 This is the sort of file that holds an ordinary stream of data bytes.")
2905 Lisp_Object filename
;
2907 register Lisp_Object absname
;
2909 Lisp_Object handler
;
2911 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2913 /* If the file name has special constructs in it,
2914 call the corresponding file handler. */
2915 handler
= Ffind_file_name_handler (absname
, Qfile_regular_p
);
2916 if (!NILP (handler
))
2917 return call2 (handler
, Qfile_regular_p
, absname
);
2919 absname
= ENCODE_FILE (absname
);
2921 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2923 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
2926 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
2927 "Return mode bits of file named FILENAME, as an integer.")
2929 Lisp_Object filename
;
2931 Lisp_Object absname
;
2933 Lisp_Object handler
;
2935 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2937 /* If the file name has special constructs in it,
2938 call the corresponding file handler. */
2939 handler
= Ffind_file_name_handler (absname
, Qfile_modes
);
2940 if (!NILP (handler
))
2941 return call2 (handler
, Qfile_modes
, absname
);
2943 absname
= ENCODE_FILE (absname
);
2945 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2947 #if defined (MSDOS) && __DJGPP__ < 2
2948 if (check_executable (XSTRING (absname
)->data
))
2949 st
.st_mode
|= S_IEXEC
;
2950 #endif /* MSDOS && __DJGPP__ < 2 */
2952 return make_number (st
.st_mode
& 07777);
2955 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
2956 "Set mode bits of file named FILENAME to MODE (an integer).\n\
2957 Only the 12 low bits of MODE are used.")
2959 Lisp_Object filename
, mode
;
2961 Lisp_Object absname
, encoded_absname
;
2962 Lisp_Object handler
;
2964 absname
= Fexpand_file_name (filename
, current_buffer
->directory
);
2965 CHECK_NUMBER (mode
, 1);
2967 /* If the file name has special constructs in it,
2968 call the corresponding file handler. */
2969 handler
= Ffind_file_name_handler (absname
, Qset_file_modes
);
2970 if (!NILP (handler
))
2971 return call3 (handler
, Qset_file_modes
, absname
, mode
);
2973 encoded_absname
= ENCODE_FILE (absname
);
2975 if (chmod (XSTRING (encoded_absname
)->data
, XINT (mode
)) < 0)
2976 report_file_error ("Doing chmod", Fcons (absname
, Qnil
));
2981 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
2982 "Set the file permission bits for newly created files.\n\
2983 The argument MODE should be an integer; only the low 9 bits are used.\n\
2984 This setting is inherited by subprocesses.")
2988 CHECK_NUMBER (mode
, 0);
2990 umask ((~ XINT (mode
)) & 0777);
2995 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
2996 "Return the default file protection for created files.\n\
2997 The value is an integer.")
3003 realmask
= umask (0);
3006 XSETINT (value
, (~ realmask
) & 0777);
3012 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
3013 "Tell Unix to finish all pending disk updates.")
3022 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
3023 "Return t if file FILE1 is newer than file FILE2.\n\
3024 If FILE1 does not exist, the answer is nil;\n\
3025 otherwise, if FILE2 does not exist, the answer is t.")
3027 Lisp_Object file1
, file2
;
3029 Lisp_Object absname1
, absname2
;
3032 Lisp_Object handler
;
3033 struct gcpro gcpro1
, gcpro2
;
3035 CHECK_STRING (file1
, 0);
3036 CHECK_STRING (file2
, 0);
3039 GCPRO2 (absname1
, file2
);
3040 absname1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
3041 absname2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
3044 /* If the file name has special constructs in it,
3045 call the corresponding file handler. */
3046 handler
= Ffind_file_name_handler (absname1
, Qfile_newer_than_file_p
);
3048 handler
= Ffind_file_name_handler (absname2
, Qfile_newer_than_file_p
);
3049 if (!NILP (handler
))
3050 return call3 (handler
, Qfile_newer_than_file_p
, absname1
, absname2
);
3052 GCPRO2 (absname1
, absname2
);
3053 absname1
= ENCODE_FILE (absname1
);
3054 absname2
= ENCODE_FILE (absname2
);
3057 if (stat (XSTRING (absname1
)->data
, &st
) < 0)
3060 mtime1
= st
.st_mtime
;
3062 if (stat (XSTRING (absname2
)->data
, &st
) < 0)
3065 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
3069 Lisp_Object Qfind_buffer_file_type
;
3072 #ifndef READ_BUF_SIZE
3073 #define READ_BUF_SIZE (64 << 10)
3076 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
3078 "Insert contents of file FILENAME after point.\n\
3079 Returns list of absolute file name and length of data inserted.\n\
3080 If second argument VISIT is non-nil, the buffer's visited filename\n\
3081 and last save file modtime are set, and it is marked unmodified.\n\
3082 If visiting and the file does not exist, visiting is completed\n\
3083 before the error is signaled.\n\
3084 The optional third and fourth arguments BEG and END\n\
3085 specify what portion of the file to insert.\n\
3086 If VISIT is non-nil, BEG and END must be nil.\n\
3088 If optional fifth argument REPLACE is non-nil,\n\
3089 it means replace the current buffer contents (in the accessible portion)\n\
3090 with the file contents. This is better than simply deleting and inserting\n\
3091 the whole thing because (1) it preserves some marker positions\n\
3092 and (2) it puts less data in the undo list.\n\
3093 When REPLACE is non-nil, the value is the number of characters actually read,\n\
3094 which is often less than the number of characters to be read.\n\
3095 This does code conversion according to the value of\n\
3096 `coding-system-for-read' or `file-coding-system-alist',\n\
3097 and sets the variable `last-coding-system-used' to the coding system\n\
3099 (filename
, visit
, beg
, end
, replace
)
3100 Lisp_Object filename
, visit
, beg
, end
, replace
;
3104 register int inserted
= 0;
3105 register int how_much
;
3106 register int unprocessed
;
3107 int count
= specpdl_ptr
- specpdl
;
3108 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3109 Lisp_Object handler
, val
, insval
, orig_filename
;
3112 int not_regular
= 0;
3113 char read_buf
[READ_BUF_SIZE
];
3114 struct coding_system coding
;
3115 unsigned char buffer
[1 << 14];
3116 int replace_handled
= 0;
3118 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3119 error ("Cannot do file visiting in an indirect buffer");
3121 if (!NILP (current_buffer
->read_only
))
3122 Fbarf_if_buffer_read_only ();
3126 orig_filename
= Qnil
;
3128 GCPRO4 (filename
, val
, p
, orig_filename
);
3130 CHECK_STRING (filename
, 0);
3131 filename
= Fexpand_file_name (filename
, Qnil
);
3133 /* If the file name has special constructs in it,
3134 call the corresponding file handler. */
3135 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
3136 if (!NILP (handler
))
3138 val
= call6 (handler
, Qinsert_file_contents
, filename
,
3139 visit
, beg
, end
, replace
);
3143 orig_filename
= filename
;
3144 filename
= ENCODE_FILE (filename
);
3149 if (stat (XSTRING (filename
)->data
, &st
) < 0)
3151 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0
3152 || fstat (fd
, &st
) < 0)
3153 #endif /* not APOLLO */
3155 if (fd
>= 0) close (fd
);
3158 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3161 if (!NILP (Vcoding_system_for_read
))
3162 current_buffer
->buffer_file_coding_system
= Vcoding_system_for_read
;
3167 /* This code will need to be changed in order to work on named
3168 pipes, and it's probably just not worth it. So we should at
3169 least signal an error. */
3170 if (!S_ISREG (st
.st_mode
))
3177 if (! NILP (replace
) || ! NILP (beg
) || ! NILP (end
))
3178 Fsignal (Qfile_error
,
3179 Fcons (build_string ("not a regular file"),
3180 Fcons (orig_filename
, Qnil
)));
3185 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0)
3188 /* Replacement should preserve point as it preserves markers. */
3189 if (!NILP (replace
))
3190 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
3192 record_unwind_protect (close_file_unwind
, make_number (fd
));
3194 /* Supposedly happens on VMS. */
3195 if (! not_regular
&& st
.st_size
< 0)
3196 error ("File size is negative");
3198 if (!NILP (beg
) || !NILP (end
))
3200 error ("Attempt to visit less than an entire file");
3203 CHECK_NUMBER (beg
, 0);
3205 XSETFASTINT (beg
, 0);
3208 CHECK_NUMBER (end
, 0);
3213 XSETINT (end
, st
.st_size
);
3214 if (XINT (end
) != st
.st_size
)
3215 error ("Maximum buffer size exceeded");
3219 /* Decide the coding-system of the file. */
3221 Lisp_Object val
= Qnil
;
3223 if (!NILP (Vcoding_system_for_read
))
3224 val
= Vcoding_system_for_read
;
3225 else if (NILP (current_buffer
->enable_multibyte_characters
))
3229 if (! NILP (Vset_auto_coding_function
))
3231 /* Find a coding system specified in the heading two lines
3232 or in the tailing several lines of the file. We assume
3233 that the 1K-byte and 3K-byte for heading and tailing
3234 respectively are sufficient fot this purpose. */
3235 int how_many
, nread
;
3237 if (st
.st_size
<= (1024 * 4))
3238 nread
= read (fd
, read_buf
, 1024 * 4);
3241 nread
= read (fd
, read_buf
, 1024);
3244 if (lseek (fd
, st
.st_size
- (1024 * 3), 0) < 0)
3245 report_file_error ("Setting file position",
3246 Fcons (orig_filename
, Qnil
));
3247 nread
+= read (fd
, read_buf
+ nread
, 1024 * 3);
3252 error ("IO error reading %s: %s",
3253 XSTRING (orig_filename
)->data
, strerror (errno
));
3256 val
= call1 (Vset_auto_coding_function
,
3257 make_string (read_buf
, nread
));
3258 /* Rewind the file for the actual read done later. */
3259 if (lseek (fd
, 0, 0) < 0)
3260 report_file_error ("Setting file position",
3261 Fcons (orig_filename
, Qnil
));
3266 Lisp_Object args
[6], coding_systems
;
3268 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
,
3269 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = replace
;
3270 coding_systems
= Ffind_operation_coding_system (6, args
);
3271 if (CONSP (coding_systems
)) val
= XCONS (coding_systems
)->car
;
3274 setup_coding_system (Fcheck_coding_system (val
), &coding
);
3277 /* If requested, replace the accessible part of the buffer
3278 with the file contents. Avoid replacing text at the
3279 beginning or end of the buffer that matches the file contents;
3280 that preserves markers pointing to the unchanged parts.
3282 Here we implement this feature in an optimized way
3283 for the case where code conversion is NOT needed.
3284 The following if-statement handles the case of conversion
3285 in a less optimal way.
3287 If the code conversion is "automatic" then we try using this
3288 method and hope for the best.
3289 But if we discover the need for conversion, we give up on this method
3290 and let the following if-statement handle the replace job. */
3292 && ! CODING_REQUIRE_DECODING (&coding
))
3294 int same_at_start
= BEGV
;
3295 int same_at_end
= ZV
;
3297 /* There is still a possibility we will find the need to do code
3298 conversion. If that happens, we set this variable to 1 to
3299 give up on handling REPLACE in the optimized way. */
3300 int giveup_match_end
= 0;
3302 if (XINT (beg
) != 0)
3304 if (lseek (fd
, XINT (beg
), 0) < 0)
3305 report_file_error ("Setting file position",
3306 Fcons (orig_filename
, Qnil
));
3311 /* Count how many chars at the start of the file
3312 match the text at the beginning of the buffer. */
3317 nread
= read (fd
, buffer
, sizeof buffer
);
3319 error ("IO error reading %s: %s",
3320 XSTRING (orig_filename
)->data
, strerror (errno
));
3321 else if (nread
== 0)
3324 if (coding
.type
== coding_type_undecided
)
3325 detect_coding (&coding
, buffer
, nread
);
3326 if (CODING_REQUIRE_DECODING (&coding
))
3327 /* We found that the file should be decoded somehow.
3328 Let's give up here. */
3330 giveup_match_end
= 1;
3334 if (coding
.eol_type
== CODING_EOL_UNDECIDED
)
3335 detect_eol (&coding
, buffer
, nread
);
3336 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3337 && coding
.eol_type
!= CODING_EOL_LF
)
3338 /* We found that the format of eol should be decoded.
3339 Let's give up here. */
3341 giveup_match_end
= 1;
3346 while (bufpos
< nread
&& same_at_start
< ZV
3347 && FETCH_BYTE (same_at_start
) == buffer
[bufpos
])
3348 same_at_start
++, bufpos
++;
3349 /* If we found a discrepancy, stop the scan.
3350 Otherwise loop around and scan the next bufferful. */
3351 if (bufpos
!= nread
)
3355 /* If the file matches the buffer completely,
3356 there's no need to replace anything. */
3357 if (same_at_start
- BEGV
== XINT (end
))
3361 /* Truncate the buffer to the size of the file. */
3362 del_range_1 (same_at_start
, same_at_end
, 0);
3367 /* Count how many chars at the end of the file
3368 match the text at the end of the buffer. But, if we have
3369 already found that decoding is necessary, don't waste time. */
3370 while (!giveup_match_end
)
3372 int total_read
, nread
, bufpos
, curpos
, trial
;
3374 /* At what file position are we now scanning? */
3375 curpos
= XINT (end
) - (ZV
- same_at_end
);
3376 /* If the entire file matches the buffer tail, stop the scan. */
3379 /* How much can we scan in the next step? */
3380 trial
= min (curpos
, sizeof buffer
);
3381 if (lseek (fd
, curpos
- trial
, 0) < 0)
3382 report_file_error ("Setting file position",
3383 Fcons (orig_filename
, Qnil
));
3386 while (total_read
< trial
)
3388 nread
= read (fd
, buffer
+ total_read
, trial
- total_read
);
3390 error ("IO error reading %s: %s",
3391 XSTRING (orig_filename
)->data
, strerror (errno
));
3392 total_read
+= nread
;
3394 /* Scan this bufferful from the end, comparing with
3395 the Emacs buffer. */
3396 bufpos
= total_read
;
3397 /* Compare with same_at_start to avoid counting some buffer text
3398 as matching both at the file's beginning and at the end. */
3399 while (bufpos
> 0 && same_at_end
> same_at_start
3400 && FETCH_BYTE (same_at_end
- 1) == buffer
[bufpos
- 1])
3401 same_at_end
--, bufpos
--;
3403 /* If we found a discrepancy, stop the scan.
3404 Otherwise loop around and scan the preceding bufferful. */
3407 /* If this discrepancy is because of code conversion,
3408 we cannot use this method; giveup and try the other. */
3409 if (same_at_end
> same_at_start
3410 && FETCH_BYTE (same_at_end
- 1) >= 0200
3411 && ! NILP (current_buffer
->enable_multibyte_characters
)
3412 && (CODING_REQUIRE_DECODING (&coding
)
3413 || CODING_REQUIRE_DETECTION (&coding
)))
3414 giveup_match_end
= 1;
3420 if (! giveup_match_end
)
3422 /* We win! We can handle REPLACE the optimized way. */
3424 /* Extends the end of non-matching text area to multibyte
3425 character boundary. */
3426 if (! NILP (current_buffer
->enable_multibyte_characters
))
3427 while (same_at_end
< ZV
&& ! CHAR_HEAD_P (POS_ADDR (same_at_end
)))
3430 /* Don't try to reuse the same piece of text twice. */
3431 overlap
= same_at_start
- BEGV
- (same_at_end
+ st
.st_size
- ZV
);
3433 same_at_end
+= overlap
;
3435 /* Arrange to read only the nonmatching middle part of the file. */
3436 XSETFASTINT (beg
, XINT (beg
) + (same_at_start
- BEGV
));
3437 XSETFASTINT (end
, XINT (end
) - (ZV
- same_at_end
));
3439 del_range_1 (same_at_start
, same_at_end
, 0);
3440 /* Insert from the file at the proper position. */
3441 SET_PT (same_at_start
);
3443 /* If display currently starts at beginning of line,
3444 keep it that way. */
3445 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3446 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3448 replace_handled
= 1;
3452 /* If requested, replace the accessible part of the buffer
3453 with the file contents. Avoid replacing text at the
3454 beginning or end of the buffer that matches the file contents;
3455 that preserves markers pointing to the unchanged parts.
3457 Here we implement this feature for the case where code conversion
3458 is needed, in a simple way that needs a lot of memory.
3459 The preceding if-statement handles the case of no conversion
3460 in a more optimized way. */
3461 if (!NILP (replace
) && ! replace_handled
)
3463 int same_at_start
= BEGV
;
3464 int same_at_end
= ZV
;
3467 /* Make sure that the gap is large enough. */
3468 int bufsize
= 2 * st
.st_size
;
3469 unsigned char *conversion_buffer
= (unsigned char *) xmalloc (bufsize
);
3471 /* First read the whole file, performing code conversion into
3472 CONVERSION_BUFFER. */
3474 if (lseek (fd
, XINT (beg
), 0) < 0)
3476 free (conversion_buffer
);
3477 report_file_error ("Setting file position",
3478 Fcons (orig_filename
, Qnil
));
3481 total
= st
.st_size
; /* Total bytes in the file. */
3482 how_much
= 0; /* Bytes read from file so far. */
3483 inserted
= 0; /* Bytes put into CONVERSION_BUFFER so far. */
3484 unprocessed
= 0; /* Bytes not processed in previous loop. */
3486 while (how_much
< total
)
3488 /* try is reserved in some compilers (Microsoft C) */
3489 int trytry
= min (total
- how_much
, READ_BUF_SIZE
- unprocessed
);
3490 char *destination
= read_buf
+ unprocessed
;
3493 /* Allow quitting out of the actual I/O. */
3496 this = read (fd
, destination
, trytry
);
3499 if (this < 0 || this + unprocessed
== 0)
3507 if (CODING_REQUIRE_DECODING (&coding
)
3508 || CODING_REQUIRE_DETECTION (&coding
))
3510 int require
, produced
, consumed
;
3512 this += unprocessed
;
3514 /* If we are using more space than estimated,
3515 make CONVERSION_BUFFER bigger. */
3516 require
= decoding_buffer_size (&coding
, this);
3517 if (inserted
+ require
+ 2 * (total
- how_much
) > bufsize
)
3519 bufsize
= inserted
+ require
+ 2 * (total
- how_much
);
3520 conversion_buffer
= (unsigned char *) xrealloc (conversion_buffer
, bufsize
);
3523 /* Convert this batch with results in CONVERSION_BUFFER. */
3524 if (how_much
>= total
) /* This is the last block. */
3525 coding
.last_block
= 1;
3526 produced
= decode_coding (&coding
, read_buf
,
3527 conversion_buffer
+ inserted
,
3528 this, bufsize
- inserted
,
3531 /* Save for next iteration whatever we didn't convert. */
3532 unprocessed
= this - consumed
;
3533 bcopy (read_buf
+ consumed
, read_buf
, unprocessed
);
3540 /* At this point, INSERTED is how many characters
3541 are present in CONVERSION_BUFFER.
3542 HOW_MUCH should equal TOTAL,
3543 or should be <= 0 if we couldn't read the file. */
3547 free (conversion_buffer
);
3550 error ("IO error reading %s: %s",
3551 XSTRING (orig_filename
)->data
, strerror (errno
));
3552 else if (how_much
== -2)
3553 error ("maximum buffer size exceeded");
3556 /* Compare the beginning of the converted file
3557 with the buffer text. */
3560 while (bufpos
< inserted
&& same_at_start
< same_at_end
3561 && FETCH_BYTE (same_at_start
) == conversion_buffer
[bufpos
])
3562 same_at_start
++, bufpos
++;
3564 /* If the file matches the buffer completely,
3565 there's no need to replace anything. */
3567 if (bufpos
== inserted
)
3569 free (conversion_buffer
);
3572 /* Truncate the buffer to the size of the file. */
3573 del_range_1 (same_at_start
, same_at_end
, 0);
3577 /* Scan this bufferful from the end, comparing with
3578 the Emacs buffer. */
3581 /* Compare with same_at_start to avoid counting some buffer text
3582 as matching both at the file's beginning and at the end. */
3583 while (bufpos
> 0 && same_at_end
> same_at_start
3584 && FETCH_BYTE (same_at_end
- 1) == conversion_buffer
[bufpos
- 1])
3585 same_at_end
--, bufpos
--;
3587 /* Don't try to reuse the same piece of text twice. */
3588 overlap
= same_at_start
- BEGV
- (same_at_end
+ inserted
- ZV
);
3590 same_at_end
+= overlap
;
3592 /* If display currently starts at beginning of line,
3593 keep it that way. */
3594 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3595 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3597 /* Replace the chars that we need to replace,
3598 and update INSERTED to equal the number of bytes
3599 we are taking from the file. */
3600 inserted
-= (Z
- same_at_end
) + (same_at_start
- BEG
);
3601 move_gap (same_at_start
);
3602 del_range_1 (same_at_start
, same_at_end
, 0);
3603 SET_PT (same_at_start
);
3604 insert_1 (conversion_buffer
+ same_at_start
- BEG
, inserted
, 0, 0);
3606 free (conversion_buffer
);
3615 register Lisp_Object temp
;
3617 total
= XINT (end
) - XINT (beg
);
3619 /* Make sure point-max won't overflow after this insertion. */
3620 XSETINT (temp
, total
);
3621 if (total
!= XINT (temp
))
3622 error ("Maximum buffer size exceeded");
3625 /* For a special file, all we can do is guess. */
3626 total
= READ_BUF_SIZE
;
3628 if (NILP (visit
) && total
> 0)
3629 prepare_to_modify_buffer (PT
, PT
, NULL
);
3632 if (GAP_SIZE
< total
)
3633 make_gap (total
- GAP_SIZE
);
3635 if (XINT (beg
) != 0 || !NILP (replace
))
3637 if (lseek (fd
, XINT (beg
), 0) < 0)
3638 report_file_error ("Setting file position",
3639 Fcons (orig_filename
, Qnil
));
3642 /* In the following loop, HOW_MUCH contains the total bytes read so
3643 far. Before exiting the loop, it is set to -1 if I/O error
3644 occurs, set to -2 if the maximum buffer size is exceeded. */
3646 /* Total bytes inserted. */
3648 /* Bytes not processed in the previous loop because short gap size. */
3650 while (how_much
< total
)
3652 /* try is reserved in some compilers (Microsoft C) */
3653 int trytry
= min (total
- how_much
, READ_BUF_SIZE
- unprocessed
);
3654 char *destination
= (! (CODING_REQUIRE_DECODING (&coding
)
3655 || CODING_REQUIRE_DETECTION (&coding
))
3656 ? (char *) (POS_ADDR (PT
+ inserted
- 1) + 1)
3657 : read_buf
+ unprocessed
);
3660 /* Allow quitting out of the actual I/O. */
3663 this = read (fd
, destination
, trytry
);
3666 if (this < 0 || this + unprocessed
== 0)
3672 /* For a regular file, where TOTAL is the real size,
3673 count HOW_MUCH to compare with it.
3674 For a special file, where TOTAL is just a buffer size,
3675 so don't bother counting in HOW_MUCH.
3676 (INSERTED is where we count the number of characters inserted.) */
3680 if (CODING_REQUIRE_DECODING (&coding
)
3681 || CODING_REQUIRE_DETECTION (&coding
))
3683 int require
, produced
, consumed
;
3685 this += unprocessed
;
3686 /* Make sure that the gap is large enough. */
3687 require
= decoding_buffer_size (&coding
, this);
3688 if (GAP_SIZE
< require
)
3689 make_gap (require
- GAP_SIZE
);
3693 if (how_much
>= total
) /* This is the last block. */
3694 coding
.last_block
= 1;
3698 /* If we encounter EOF, say it is the last block. (The
3699 data this will apply to is the UNPROCESSED characters
3700 carried over from the last batch.) */
3702 coding
.last_block
= 1;
3705 produced
= decode_coding (&coding
, read_buf
,
3706 POS_ADDR (PT
+ inserted
- 1) + 1,
3707 this, GAP_SIZE
, &consumed
);
3712 XSET (temp
, Lisp_Int
, Z
+ produced
);
3713 if (Z
+ produced
!= XINT (temp
))
3719 unprocessed
= this - consumed
;
3720 bcopy (read_buf
+ consumed
, read_buf
, unprocessed
);
3729 /* Put an anchor to ensure multi-byte form ends at gap. */
3736 /* Use the conversion type to determine buffer-file-type
3737 (find-buffer-file-type is now used to help determine the
3739 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3740 && coding
.eol_type
!= CODING_EOL_LF
)
3741 current_buffer
->buffer_file_type
= Qnil
;
3743 current_buffer
->buffer_file_type
= Qt
;
3746 /* We don't have to consider file type of MSDOS because all files
3747 are read as binary and end-of-line format has already been
3748 decoded appropriately. */
3751 /* Demacs 1.1.1 91/10/16 HIRANO Satoshi, MW July 1993 */
3752 /* Determine file type from name and remove LFs from CR-LFs if the file
3753 is deemed to be a text file. */
3755 current_buffer
->buffer_file_type
3756 = call1 (Qfind_buffer_file_type
, orig_filename
);
3757 if (NILP (current_buffer
->buffer_file_type
))
3760 = inserted
- crlf_to_lf (inserted
, POS_ADDR (PT
- 1) + 1);
3763 GPT
-= reduced_size
;
3764 GAP_SIZE
+= reduced_size
;
3765 inserted
-= reduced_size
;
3773 record_insert (PT
, inserted
);
3775 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
3776 offset_intervals (current_buffer
, PT
, inserted
);
3782 /* Discard the unwind protect for closing the file. */
3786 error ("IO error reading %s: %s",
3787 XSTRING (orig_filename
)->data
, strerror (errno
));
3788 else if (how_much
== -2)
3789 error ("maximum buffer size exceeded");
3796 if (!EQ (current_buffer
->undo_list
, Qt
))
3797 current_buffer
->undo_list
= Qnil
;
3799 stat (XSTRING (filename
)->data
, &st
);
3804 current_buffer
->modtime
= st
.st_mtime
;
3805 current_buffer
->filename
= orig_filename
;
3808 SAVE_MODIFF
= MODIFF
;
3809 current_buffer
->auto_save_modified
= MODIFF
;
3810 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
3811 #ifdef CLASH_DETECTION
3814 if (!NILP (current_buffer
->file_truename
))
3815 unlock_file (current_buffer
->file_truename
);
3816 unlock_file (filename
);
3818 #endif /* CLASH_DETECTION */
3820 Fsignal (Qfile_error
,
3821 Fcons (build_string ("not a regular file"),
3822 Fcons (orig_filename
, Qnil
)));
3824 /* If visiting nonexistent file, return nil. */
3825 if (current_buffer
->modtime
== -1)
3826 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3829 /* Decode file format */
3832 insval
= call3 (Qformat_decode
,
3833 Qnil
, make_number (inserted
), visit
);
3834 CHECK_NUMBER (insval
, 0);
3835 inserted
= XFASTINT (insval
);
3838 /* Call after-change hooks for the inserted text, aside from the case
3839 of normal visiting (not with REPLACE), which is done in a new buffer
3840 "before" the buffer is changed. */
3841 if (inserted
> 0 && total
> 0
3842 && (NILP (visit
) || !NILP (replace
)))
3843 signal_after_change (PT
, 0, inserted
);
3845 Vlast_coding_system_used
= coding
.symbol
;
3849 p
= Vafter_insert_file_functions
;
3850 if (!NILP (coding
.post_read_conversion
))
3851 p
= Fcons (coding
.post_read_conversion
, p
);
3855 insval
= call1 (Fcar (p
), make_number (inserted
));
3858 CHECK_NUMBER (insval
, 0);
3859 inserted
= XFASTINT (insval
);
3867 val
= Fcons (orig_filename
,
3868 Fcons (make_number (inserted
),
3871 RETURN_UNGCPRO (unbind_to (count
, val
));
3874 static Lisp_Object
build_annotations ();
3875 extern Lisp_Object
Ffile_locked_p ();
3877 /* If build_annotations switched buffers, switch back to BUF.
3878 Kill the temporary buffer that was selected in the meantime.
3880 Since this kill only the last temporary buffer, some buffers remain
3881 not killed if build_annotations switched buffers more than once.
3885 build_annotations_unwind (buf
)
3890 if (XBUFFER (buf
) == current_buffer
)
3892 tembuf
= Fcurrent_buffer ();
3894 Fkill_buffer (tembuf
);
3898 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 6,
3899 "r\nFWrite region to file: ",
3900 "Write current region into specified file.\n\
3901 When called from a program, takes three arguments:\n\
3902 START, END and FILENAME. START and END are buffer positions.\n\
3903 Optional fourth argument APPEND if non-nil means\n\
3904 append to existing file contents (if any).\n\
3905 Optional fifth argument VISIT if t means\n\
3906 set the last-save-file-modtime of buffer to this file's modtime\n\
3907 and mark buffer not modified.\n\
3908 If VISIT is a string, it is a second file name;\n\
3909 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
3910 VISIT is also the file name to lock and unlock for clash detection.\n\
3911 If VISIT is neither t nor nil nor a string,\n\
3912 that means do not print the \"Wrote file\" message.\n\
3913 The optional sixth arg LOCKNAME, if non-nil, specifies the name to\n\
3914 use for locking and unlocking, overriding FILENAME and VISIT.\n\
3915 Kludgy feature: if START is a string, then that string is written\n\
3916 to the file, instead of any buffer contents, and END is ignored.")
3917 (start
, end
, filename
, append
, visit
, lockname
)
3918 Lisp_Object start
, end
, filename
, append
, visit
, lockname
;
3926 int count
= specpdl_ptr
- specpdl
;
3929 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
3931 Lisp_Object handler
;
3932 Lisp_Object visit_file
;
3933 Lisp_Object annotations
;
3934 Lisp_Object encoded_filename
;
3935 int visiting
, quietly
;
3936 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
3937 struct buffer
*given_buffer
;
3939 int buffer_file_type
= O_BINARY
;
3941 struct coding_system coding
;
3943 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3944 error ("Cannot do file visiting in an indirect buffer");
3946 if (!NILP (start
) && !STRINGP (start
))
3947 validate_region (&start
, &end
);
3949 GCPRO4 (start
, filename
, visit
, lockname
);
3951 /* Decide the coding-system to encode the data with. */
3957 else if (!NILP (Vcoding_system_for_write
))
3958 val
= Vcoding_system_for_write
;
3959 else if (NILP (current_buffer
->enable_multibyte_characters
))
3961 /* If the variable `buffer-file-coding-system' is set locally,
3962 it means that the file was read with some kind of code
3963 conversion or the varialbe is explicitely set by users. We
3964 had better write it out with the same coding system even if
3965 `enable-multibyte-characters' is nil.
3967 If is is not set locally, we anyway have to convert EOL
3968 format if the default value of `buffer-file-coding-system'
3969 tells that it is not Unix-like (LF only) format. */
3970 val
= current_buffer
->buffer_file_coding_system
;
3971 if (NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
3973 struct coding_system coding_temp
;
3975 setup_coding_system (Fcheck_coding_system (val
), &coding_temp
);
3976 if (coding_temp
.eol_type
== CODING_EOL_CRLF
3977 || coding_temp
.eol_type
== CODING_EOL_CR
)
3979 setup_coding_system (Qemacs_mule
, &coding
);
3980 coding
.eol_type
= coding_temp
.eol_type
;
3981 goto done_setup_coding
;
3988 Lisp_Object args
[7], coding_systems
;
3990 args
[0] = Qwrite_region
, args
[1] = start
, args
[2] = end
,
3991 args
[3] = filename
, args
[4] = append
, args
[5] = visit
,
3993 coding_systems
= Ffind_operation_coding_system (7, args
);
3994 val
= (CONSP (coding_systems
) && !NILP (XCONS (coding_systems
)->cdr
)
3995 ? XCONS (coding_systems
)->cdr
3996 : current_buffer
->buffer_file_coding_system
);
3998 setup_coding_system (Fcheck_coding_system (val
), &coding
);
4001 if (!STRINGP (start
) && !NILP (current_buffer
->selective_display
))
4002 coding
.selective
= 1;
4005 Vlast_coding_system_used
= coding
.symbol
;
4007 filename
= Fexpand_file_name (filename
, Qnil
);
4008 if (STRINGP (visit
))
4009 visit_file
= Fexpand_file_name (visit
, Qnil
);
4011 visit_file
= filename
;
4014 visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
4015 quietly
= !NILP (visit
);
4019 if (NILP (lockname
))
4020 lockname
= visit_file
;
4022 GCPRO5 (start
, filename
, annotations
, visit_file
, lockname
);
4024 /* If the file name has special constructs in it,
4025 call the corresponding file handler. */
4026 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
4027 /* If FILENAME has no handler, see if VISIT has one. */
4028 if (NILP (handler
) && STRINGP (visit
))
4029 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
4031 if (!NILP (handler
))
4034 val
= call6 (handler
, Qwrite_region
, start
, end
,
4035 filename
, append
, visit
);
4039 SAVE_MODIFF
= MODIFF
;
4040 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4041 current_buffer
->filename
= visit_file
;
4047 /* Special kludge to simplify auto-saving. */
4050 XSETFASTINT (start
, BEG
);
4051 XSETFASTINT (end
, Z
);
4054 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
4055 count1
= specpdl_ptr
- specpdl
;
4057 given_buffer
= current_buffer
;
4058 annotations
= build_annotations (start
, end
, coding
.pre_write_conversion
);
4059 if (current_buffer
!= given_buffer
)
4061 XSETFASTINT (start
, BEGV
);
4062 XSETFASTINT (end
, ZV
);
4065 #ifdef CLASH_DETECTION
4068 #if 0 /* This causes trouble for GNUS. */
4069 /* If we've locked this file for some other buffer,
4070 query before proceeding. */
4071 if (!visiting
&& EQ (Ffile_locked_p (lockname
), Qt
))
4072 call2 (intern ("ask-user-about-lock"), filename
, Vuser_login_name
);
4075 lock_file (lockname
);
4077 #endif /* CLASH_DETECTION */
4079 encoded_filename
= ENCODE_FILE (filename
);
4081 fn
= XSTRING (encoded_filename
)->data
;
4085 desc
= open (fn
, O_WRONLY
| buffer_file_type
);
4086 #else /* not DOS_NT */
4087 desc
= open (fn
, O_WRONLY
);
4088 #endif /* not DOS_NT */
4090 if (desc
< 0 && (NILP (append
) || errno
== ENOENT
))
4092 if (auto_saving
) /* Overwrite any previous version of autosave file */
4094 vms_truncate (fn
); /* if fn exists, truncate to zero length */
4095 desc
= open (fn
, O_RDWR
);
4097 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
4098 ? XSTRING (current_buffer
->filename
)->data
: 0,
4101 else /* Write to temporary name and rename if no errors */
4103 Lisp_Object temp_name
;
4104 temp_name
= Ffile_name_directory (filename
);
4106 if (!NILP (temp_name
))
4108 temp_name
= Fmake_temp_name (concat2 (temp_name
,
4109 build_string ("$$SAVE$$")));
4110 fname
= XSTRING (filename
)->data
;
4111 fn
= XSTRING (temp_name
)->data
;
4112 desc
= creat_copy_attrs (fname
, fn
);
4115 /* If we can't open the temporary file, try creating a new
4116 version of the original file. VMS "creat" creates a
4117 new version rather than truncating an existing file. */
4120 desc
= creat (fn
, 0666);
4121 #if 0 /* This can clobber an existing file and fail to replace it,
4122 if the user runs out of space. */
4125 /* We can't make a new version;
4126 try to truncate and rewrite existing version if any. */
4128 desc
= open (fn
, O_RDWR
);
4134 desc
= creat (fn
, 0666);
4139 O_WRONLY
| O_TRUNC
| O_CREAT
| buffer_file_type
,
4140 S_IREAD
| S_IWRITE
);
4141 #else /* not DOS_NT */
4142 desc
= creat (fn
, auto_saving
? auto_save_mode_bits
: 0666);
4143 #endif /* not DOS_NT */
4144 #endif /* not VMS */
4150 #ifdef CLASH_DETECTION
4152 if (!auto_saving
) unlock_file (lockname
);
4154 #endif /* CLASH_DETECTION */
4155 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
4158 record_unwind_protect (close_file_unwind
, make_number (desc
));
4161 if (lseek (desc
, 0, 2) < 0)
4163 #ifdef CLASH_DETECTION
4164 if (!auto_saving
) unlock_file (lockname
);
4165 #endif /* CLASH_DETECTION */
4166 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
4171 * Kludge Warning: The VMS C RTL likes to insert carriage returns
4172 * if we do writes that don't end with a carriage return. Furthermore
4173 * it cannot handle writes of more then 16K. The modified
4174 * version of "sys_write" in SYSDEP.C (see comment there) copes with
4175 * this EXCEPT for the last record (iff it doesn't end with a carriage
4176 * return). This implies that if your buffer doesn't end with a carriage
4177 * return, you get one free... tough. However it also means that if
4178 * we make two calls to sys_write (a la the following code) you can
4179 * get one at the gap as well. The easiest way to fix this (honest)
4180 * is to move the gap to the next newline (or the end of the buffer).
4185 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4186 move_gap (find_next_newline (GPT
, 1));
4188 /* Whether VMS or not, we must move the gap to the next of newline
4189 when we must put designation sequences at beginning of line. */
4190 if (INTEGERP (start
)
4191 && coding
.type
== coding_type_iso2022
4192 && coding
.flags
& CODING_FLAG_ISO_DESIGNATE_AT_BOL
4193 && GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4194 move_gap (find_next_newline (GPT
, 1));
4200 if (STRINGP (start
))
4202 failure
= 0 > a_write (desc
, XSTRING (start
)->data
,
4203 XSTRING (start
)->size
, 0, &annotations
, &coding
);
4206 else if (XINT (start
) != XINT (end
))
4209 if (XINT (start
) < GPT
)
4211 register int end1
= XINT (end
);
4213 failure
= 0 > a_write (desc
, POS_ADDR (tem
),
4214 min (GPT
, end1
) - tem
, tem
, &annotations
,
4216 nwritten
+= min (GPT
, end1
) - tem
;
4220 if (XINT (end
) > GPT
&& !failure
)
4223 tem
= max (tem
, GPT
);
4224 failure
= 0 > a_write (desc
, POS_ADDR (tem
), XINT (end
) - tem
,
4225 tem
, &annotations
, &coding
);
4226 nwritten
+= XINT (end
) - tem
;
4232 /* If file was empty, still need to write the annotations */
4233 coding
.last_block
= 1;
4234 failure
= 0 > a_write (desc
, "", 0, XINT (start
), &annotations
, &coding
);
4238 if (CODING_REQUIRE_FLUSHING (&coding
) && !coding
.last_block
)
4240 /* We have to flush out a data. */
4241 coding
.last_block
= 1;
4242 failure
= 0 > e_write (desc
, "", 0, &coding
);
4249 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
4250 Disk full in NFS may be reported here. */
4251 /* mib says that closing the file will try to write as fast as NFS can do
4252 it, and that means the fsync here is not crucial for autosave files. */
4253 if (!auto_saving
&& fsync (desc
) < 0)
4255 /* If fsync fails with EINTR, don't treat that as serious. */
4257 failure
= 1, save_errno
= errno
;
4261 /* Spurious "file has changed on disk" warnings have been
4262 observed on Suns as well.
4263 It seems that `close' can change the modtime, under nfs.
4265 (This has supposedly been fixed in Sunos 4,
4266 but who knows about all the other machines with NFS?) */
4269 /* On VMS and APOLLO, must do the stat after the close
4270 since closing changes the modtime. */
4273 /* Recall that #if defined does not work on VMS. */
4280 /* NFS can report a write failure now. */
4281 if (close (desc
) < 0)
4282 failure
= 1, save_errno
= errno
;
4285 /* If we wrote to a temporary name and had no errors, rename to real name. */
4289 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
4297 /* Discard the unwind protect for close_file_unwind. */
4298 specpdl_ptr
= specpdl
+ count1
;
4299 /* Restore the original current buffer. */
4300 visit_file
= unbind_to (count
, visit_file
);
4302 #ifdef CLASH_DETECTION
4304 unlock_file (lockname
);
4305 #endif /* CLASH_DETECTION */
4307 /* Do this before reporting IO error
4308 to avoid a "file has changed on disk" warning on
4309 next attempt to save. */
4311 current_buffer
->modtime
= st
.st_mtime
;
4314 error ("IO error writing %s: %s", XSTRING (filename
)->data
,
4315 strerror (save_errno
));
4319 SAVE_MODIFF
= MODIFF
;
4320 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4321 current_buffer
->filename
= visit_file
;
4322 update_mode_lines
++;
4328 message ("Wrote %s", XSTRING (visit_file
)->data
);
4333 Lisp_Object
merge ();
4335 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
4336 "Return t if (car A) is numerically less than (car B).")
4340 return Flss (Fcar (a
), Fcar (b
));
4343 /* Build the complete list of annotations appropriate for writing out
4344 the text between START and END, by calling all the functions in
4345 write-region-annotate-functions and merging the lists they return.
4346 If one of these functions switches to a different buffer, we assume
4347 that buffer contains altered text. Therefore, the caller must
4348 make sure to restore the current buffer in all cases,
4349 as save-excursion would do. */
4352 build_annotations (start
, end
, pre_write_conversion
)
4353 Lisp_Object start
, end
, pre_write_conversion
;
4355 Lisp_Object annotations
;
4357 struct gcpro gcpro1
, gcpro2
;
4358 Lisp_Object original_buffer
;
4360 XSETBUFFER (original_buffer
, current_buffer
);
4363 p
= Vwrite_region_annotate_functions
;
4364 GCPRO2 (annotations
, p
);
4367 struct buffer
*given_buffer
= current_buffer
;
4368 Vwrite_region_annotations_so_far
= annotations
;
4369 res
= call2 (Fcar (p
), start
, end
);
4370 /* If the function makes a different buffer current,
4371 assume that means this buffer contains altered text to be output.
4372 Reset START and END from the buffer bounds
4373 and discard all previous annotations because they should have
4374 been dealt with by this function. */
4375 if (current_buffer
!= given_buffer
)
4377 XSETFASTINT (start
, BEGV
);
4378 XSETFASTINT (end
, ZV
);
4381 Flength (res
); /* Check basic validity of return value */
4382 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4386 /* Now do the same for annotation functions implied by the file-format */
4387 if (auto_saving
&& (!EQ (Vauto_save_file_format
, Qt
)))
4388 p
= Vauto_save_file_format
;
4390 p
= current_buffer
->file_format
;
4393 struct buffer
*given_buffer
= current_buffer
;
4394 Vwrite_region_annotations_so_far
= annotations
;
4395 res
= call4 (Qformat_annotate_function
, Fcar (p
), start
, end
,
4397 if (current_buffer
!= given_buffer
)
4399 XSETFASTINT (start
, BEGV
);
4400 XSETFASTINT (end
, ZV
);
4404 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4408 /* At last, do the same for the function PRE_WRITE_CONVERSION
4409 implied by the current coding-system. */
4410 if (!NILP (pre_write_conversion
))
4412 struct buffer
*given_buffer
= current_buffer
;
4413 Vwrite_region_annotations_so_far
= annotations
;
4414 res
= call2 (pre_write_conversion
, start
, end
);
4416 annotations
= (current_buffer
!= given_buffer
4418 : merge (annotations
, res
, Qcar_less_than_car
));
4425 /* Write to descriptor DESC the LEN characters starting at ADDR,
4426 assuming they start at position POS in the buffer.
4427 Intersperse with them the annotations from *ANNOT
4428 (those which fall within the range of positions POS to POS + LEN),
4429 each at its appropriate position.
4431 Modify *ANNOT by discarding elements as we output them.
4432 The return value is negative in case of system call failure. */
4435 a_write (desc
, addr
, len
, pos
, annot
, coding
)
4437 register char *addr
;
4441 struct coding_system
*coding
;
4445 int lastpos
= pos
+ len
;
4447 while (NILP (*annot
) || CONSP (*annot
))
4449 tem
= Fcar_safe (Fcar (*annot
));
4450 if (INTEGERP (tem
) && XINT (tem
) >= pos
&& XFASTINT (tem
) <= lastpos
)
4451 nextpos
= XFASTINT (tem
);
4453 return e_write (desc
, addr
, lastpos
- pos
, coding
);
4456 if (0 > e_write (desc
, addr
, nextpos
- pos
, coding
))
4458 addr
+= nextpos
- pos
;
4461 tem
= Fcdr (Fcar (*annot
));
4464 if (0 > e_write (desc
, XSTRING (tem
)->data
, XSTRING (tem
)->size
,
4468 *annot
= Fcdr (*annot
);
4472 #ifndef WRITE_BUF_SIZE
4473 #define WRITE_BUF_SIZE (16 * 1024)
4477 e_write (desc
, addr
, len
, coding
)
4479 register char *addr
;
4481 struct coding_system
*coding
;
4483 char buf
[WRITE_BUF_SIZE
];
4484 int produced
, consumed
;
4486 /* We used to have a code for handling selective display here. But,
4487 now it is handled within encode_coding. */
4490 produced
= encode_coding (coding
, addr
, buf
, len
, WRITE_BUF_SIZE
,
4492 len
-= consumed
, addr
+= consumed
;
4495 produced
-= write (desc
, buf
, produced
);
4496 if (produced
) return -1;
4504 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
4505 Sverify_visited_file_modtime
, 1, 1, 0,
4506 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
4507 This means that the file has not been changed since it was visited or saved.")
4513 Lisp_Object handler
;
4514 Lisp_Object filename
;
4516 CHECK_BUFFER (buf
, 0);
4519 if (!STRINGP (b
->filename
)) return Qt
;
4520 if (b
->modtime
== 0) return Qt
;
4522 /* If the file name has special constructs in it,
4523 call the corresponding file handler. */
4524 handler
= Ffind_file_name_handler (b
->filename
,
4525 Qverify_visited_file_modtime
);
4526 if (!NILP (handler
))
4527 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
4529 filename
= ENCODE_FILE (b
->filename
);
4531 if (stat (XSTRING (filename
)->data
, &st
) < 0)
4533 /* If the file doesn't exist now and didn't exist before,
4534 we say that it isn't modified, provided the error is a tame one. */
4535 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
4540 if (st
.st_mtime
== b
->modtime
4541 /* If both are positive, accept them if they are off by one second. */
4542 || (st
.st_mtime
> 0 && b
->modtime
> 0
4543 && (st
.st_mtime
== b
->modtime
+ 1
4544 || st
.st_mtime
== b
->modtime
- 1)))
4549 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
4550 Sclear_visited_file_modtime
, 0, 0, 0,
4551 "Clear out records of last mod time of visited file.\n\
4552 Next attempt to save will certainly not complain of a discrepancy.")
4555 current_buffer
->modtime
= 0;
4559 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
4560 Svisited_file_modtime
, 0, 0, 0,
4561 "Return the current buffer's recorded visited file modification time.\n\
4562 The value is a list of the form (HIGH . LOW), like the time values\n\
4563 that `file-attributes' returns.")
4566 return long_to_cons ((unsigned long) current_buffer
->modtime
);
4569 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
4570 Sset_visited_file_modtime
, 0, 1, 0,
4571 "Update buffer's recorded modification time from the visited file's time.\n\
4572 Useful if the buffer was not read from the file normally\n\
4573 or if the file itself has been changed for some known benign reason.\n\
4574 An argument specifies the modification time value to use\n\
4575 \(instead of that of the visited file), in the form of a list\n\
4576 \(HIGH . LOW) or (HIGH LOW).")
4578 Lisp_Object time_list
;
4580 if (!NILP (time_list
))
4581 current_buffer
->modtime
= cons_to_long (time_list
);
4584 register Lisp_Object filename
;
4586 Lisp_Object handler
;
4588 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
4590 /* If the file name has special constructs in it,
4591 call the corresponding file handler. */
4592 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
4593 if (!NILP (handler
))
4594 /* The handler can find the file name the same way we did. */
4595 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
4597 filename
= ENCODE_FILE (filename
);
4599 if (stat (XSTRING (filename
)->data
, &st
) >= 0)
4600 current_buffer
->modtime
= st
.st_mtime
;
4610 message ("Autosaving...error for %s", XSTRING (current_buffer
->name
)->data
);
4611 Fsleep_for (make_number (1), Qnil
);
4612 message ("Autosaving...error!for %s", XSTRING (current_buffer
->name
)->data
);
4613 Fsleep_for (make_number (1), Qnil
);
4614 message ("Autosaving...error for %s", XSTRING (current_buffer
->name
)->data
);
4615 Fsleep_for (make_number (1), Qnil
);
4625 /* Get visited file's mode to become the auto save file's mode. */
4626 if (stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
4627 /* But make sure we can overwrite it later! */
4628 auto_save_mode_bits
= st
.st_mode
| 0600;
4630 auto_save_mode_bits
= 0666;
4633 Fwrite_region (Qnil
, Qnil
,
4634 current_buffer
->auto_save_file_name
,
4635 Qnil
, Qlambda
, Qnil
);
4639 do_auto_save_unwind (stream
) /* used as unwind-protect function */
4644 fclose ((FILE *) (XFASTINT (XCONS (stream
)->car
) << 16
4645 | XFASTINT (XCONS (stream
)->cdr
)));
4650 do_auto_save_unwind_1 (value
) /* used as unwind-protect function */
4653 minibuffer_auto_raise
= XINT (value
);
4657 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
4658 "Auto-save all buffers that need it.\n\
4659 This is all buffers that have auto-saving enabled\n\
4660 and are changed since last auto-saved.\n\
4661 Auto-saving writes the buffer into a file\n\
4662 so that your editing is not lost if the system crashes.\n\
4663 This file is not the file you visited; that changes only when you save.\n\
4664 Normally we run the normal hook `auto-save-hook' before saving.\n\n\
4665 A non-nil NO-MESSAGE argument means do not print any message if successful.\n\
4666 A non-nil CURRENT-ONLY argument means save only current buffer.")
4667 (no_message
, current_only
)
4668 Lisp_Object no_message
, current_only
;
4670 struct buffer
*old
= current_buffer
, *b
;
4671 Lisp_Object tail
, buf
;
4673 char *omessage
= echo_area_glyphs
;
4674 int omessage_length
= echo_area_glyphs_length
;
4675 int do_handled_files
;
4678 Lisp_Object lispstream
;
4679 int count
= specpdl_ptr
- specpdl
;
4681 int orig_minibuffer_auto_raise
= minibuffer_auto_raise
;
4683 /* Ordinarily don't quit within this function,
4684 but don't make it impossible to quit (in case we get hung in I/O). */
4688 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
4689 point to non-strings reached from Vbuffer_alist. */
4694 if (!NILP (Vrun_hooks
))
4695 call1 (Vrun_hooks
, intern ("auto-save-hook"));
4697 if (STRINGP (Vauto_save_list_file_name
))
4699 Lisp_Object listfile
;
4700 listfile
= Fexpand_file_name (Vauto_save_list_file_name
, Qnil
);
4701 stream
= fopen (XSTRING (listfile
)->data
, "w");
4704 /* Arrange to close that file whether or not we get an error.
4705 Also reset auto_saving to 0. */
4706 lispstream
= Fcons (Qnil
, Qnil
);
4707 XSETFASTINT (XCONS (lispstream
)->car
, (EMACS_UINT
)stream
>> 16);
4708 XSETFASTINT (XCONS (lispstream
)->cdr
, (EMACS_UINT
)stream
& 0xffff);
4719 record_unwind_protect (do_auto_save_unwind
, lispstream
);
4720 record_unwind_protect (do_auto_save_unwind_1
,
4721 make_number (minibuffer_auto_raise
));
4722 minibuffer_auto_raise
= 0;
4725 /* First, save all files which don't have handlers. If Emacs is
4726 crashing, the handlers may tweak what is causing Emacs to crash
4727 in the first place, and it would be a shame if Emacs failed to
4728 autosave perfectly ordinary files because it couldn't handle some
4730 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
4731 for (tail
= Vbuffer_alist
; GC_CONSP (tail
); tail
= XCONS (tail
)->cdr
)
4733 buf
= XCONS (XCONS (tail
)->car
)->cdr
;
4736 /* Record all the buffers that have auto save mode
4737 in the special file that lists them. For each of these buffers,
4738 Record visited name (if any) and auto save name. */
4739 if (STRINGP (b
->auto_save_file_name
)
4740 && stream
!= NULL
&& do_handled_files
== 0)
4742 if (!NILP (b
->filename
))
4744 fwrite (XSTRING (b
->filename
)->data
, 1,
4745 XSTRING (b
->filename
)->size
, stream
);
4747 putc ('\n', stream
);
4748 fwrite (XSTRING (b
->auto_save_file_name
)->data
, 1,
4749 XSTRING (b
->auto_save_file_name
)->size
, stream
);
4750 putc ('\n', stream
);
4753 if (!NILP (current_only
)
4754 && b
!= current_buffer
)
4757 /* Don't auto-save indirect buffers.
4758 The base buffer takes care of it. */
4762 /* Check for auto save enabled
4763 and file changed since last auto save
4764 and file changed since last real save. */
4765 if (STRINGP (b
->auto_save_file_name
)
4766 && BUF_SAVE_MODIFF (b
) < BUF_MODIFF (b
)
4767 && b
->auto_save_modified
< BUF_MODIFF (b
)
4768 /* -1 means we've turned off autosaving for a while--see below. */
4769 && XINT (b
->save_length
) >= 0
4770 && (do_handled_files
4771 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
4774 EMACS_TIME before_time
, after_time
;
4776 EMACS_GET_TIME (before_time
);
4778 /* If we had a failure, don't try again for 20 minutes. */
4779 if (b
->auto_save_failure_time
>= 0
4780 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
4783 if ((XFASTINT (b
->save_length
) * 10
4784 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
4785 /* A short file is likely to change a large fraction;
4786 spare the user annoying messages. */
4787 && XFASTINT (b
->save_length
) > 5000
4788 /* These messages are frequent and annoying for `*mail*'. */
4789 && !EQ (b
->filename
, Qnil
)
4790 && NILP (no_message
))
4792 /* It has shrunk too much; turn off auto-saving here. */
4793 minibuffer_auto_raise
= orig_minibuffer_auto_raise
;
4794 message ("Buffer %s has shrunk a lot; auto save turned off there",
4795 XSTRING (b
->name
)->data
);
4796 minibuffer_auto_raise
= 0;
4797 /* Turn off auto-saving until there's a real save,
4798 and prevent any more warnings. */
4799 XSETINT (b
->save_length
, -1);
4800 Fsleep_for (make_number (1), Qnil
);
4803 set_buffer_internal (b
);
4804 if (!auto_saved
&& NILP (no_message
))
4805 message1 ("Auto-saving...");
4806 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
4808 b
->auto_save_modified
= BUF_MODIFF (b
);
4809 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4810 set_buffer_internal (old
);
4812 EMACS_GET_TIME (after_time
);
4814 /* If auto-save took more than 60 seconds,
4815 assume it was an NFS failure that got a timeout. */
4816 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
4817 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
4821 /* Prevent another auto save till enough input events come in. */
4822 record_auto_save ();
4824 if (auto_saved
&& NILP (no_message
))
4828 sit_for (1, 0, 0, 0, 0);
4829 message2 (omessage
, omessage_length
);
4832 message1 ("Auto-saving...done");
4837 unbind_to (count
, Qnil
);
4841 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
4842 Sset_buffer_auto_saved
, 0, 0, 0,
4843 "Mark current buffer as auto-saved with its current text.\n\
4844 No auto-save file will be written until the buffer changes again.")
4847 current_buffer
->auto_save_modified
= MODIFF
;
4848 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4849 current_buffer
->auto_save_failure_time
= -1;
4853 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
4854 Sclear_buffer_auto_save_failure
, 0, 0, 0,
4855 "Clear any record of a recent auto-save failure in the current buffer.")
4858 current_buffer
->auto_save_failure_time
= -1;
4862 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
4864 "Return t if buffer has been auto-saved since last read in or saved.")
4867 return (SAVE_MODIFF
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
4870 /* Reading and completing file names */
4871 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
4873 /* In the string VAL, change each $ to $$ and return the result. */
4876 double_dollars (val
)
4879 register unsigned char *old
, *new;
4883 osize
= XSTRING (val
)->size
;
4884 /* Quote "$" as "$$" to get it past substitute-in-file-name */
4885 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
4886 if (*old
++ == '$') count
++;
4889 old
= XSTRING (val
)->data
;
4890 val
= Fmake_string (make_number (osize
+ count
), make_number (0));
4891 new = XSTRING (val
)->data
;
4892 for (n
= osize
; n
> 0; n
--)
4905 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
4907 "Internal subroutine for read-file-name. Do not call this.")
4908 (string
, dir
, action
)
4909 Lisp_Object string
, dir
, action
;
4910 /* action is nil for complete, t for return list of completions,
4911 lambda for verify final value */
4913 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
4915 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
4917 CHECK_STRING (string
, 0);
4924 /* No need to protect ACTION--we only compare it with t and nil. */
4925 GCPRO5 (string
, realdir
, name
, specdir
, orig_string
);
4927 if (XSTRING (string
)->size
== 0)
4929 if (EQ (action
, Qlambda
))
4937 orig_string
= string
;
4938 string
= Fsubstitute_in_file_name (string
);
4939 changed
= NILP (Fstring_equal (string
, orig_string
));
4940 name
= Ffile_name_nondirectory (string
);
4941 val
= Ffile_name_directory (string
);
4943 realdir
= Fexpand_file_name (val
, realdir
);
4948 specdir
= Ffile_name_directory (string
);
4949 val
= Ffile_name_completion (name
, realdir
);
4954 return double_dollars (string
);
4958 if (!NILP (specdir
))
4959 val
= concat2 (specdir
, val
);
4961 return double_dollars (val
);
4964 #endif /* not VMS */
4968 if (EQ (action
, Qt
))
4969 return Ffile_name_all_completions (name
, realdir
);
4970 /* Only other case actually used is ACTION = lambda */
4972 /* Supposedly this helps commands such as `cd' that read directory names,
4973 but can someone explain how it helps them? -- RMS */
4974 if (XSTRING (name
)->size
== 0)
4977 return Ffile_exists_p (string
);
4980 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
4981 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
4982 Value is not expanded---you must call `expand-file-name' yourself.\n\
4983 Default name to DEFAULT-FILENAME if user enters a null string.\n\
4984 (If DEFAULT-FILENAME is omitted, the visited file name is used,\n\
4985 except that if INITIAL is specified, that combined with DIR is used.)\n\
4986 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
4987 Non-nil and non-t means also require confirmation after completion.\n\
4988 Fifth arg INITIAL specifies text to start with.\n\
4989 DIR defaults to current buffer's directory default.")
4990 (prompt
, dir
, default_filename
, mustmatch
, initial
)
4991 Lisp_Object prompt
, dir
, default_filename
, mustmatch
, initial
;
4993 Lisp_Object val
, insdef
, insdef1
, tem
;
4994 struct gcpro gcpro1
, gcpro2
;
4995 register char *homedir
;
4999 dir
= current_buffer
->directory
;
5000 if (NILP (default_filename
))
5002 if (! NILP (initial
))
5003 default_filename
= Fexpand_file_name (initial
, dir
);
5005 default_filename
= current_buffer
->filename
;
5008 /* If dir starts with user's homedir, change that to ~. */
5009 homedir
= (char *) egetenv ("HOME");
5011 homedir
= strcpy (alloca (strlen (homedir
) + 1), homedir
);
5012 CORRECT_DIR_SEPS (homedir
);
5016 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5017 && IS_DIRECTORY_SEP (XSTRING (dir
)->data
[strlen (homedir
)]))
5019 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5020 XSTRING (dir
)->size
- strlen (homedir
) + 1);
5021 XSTRING (dir
)->data
[0] = '~';
5024 if (insert_default_directory
&& STRINGP (dir
))
5027 if (!NILP (initial
))
5029 Lisp_Object args
[2], pos
;
5033 insdef
= Fconcat (2, args
);
5034 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
5035 insdef1
= Fcons (double_dollars (insdef
), pos
);
5038 insdef1
= double_dollars (insdef
);
5040 else if (STRINGP (initial
))
5043 insdef1
= Fcons (double_dollars (insdef
), make_number (0));
5046 insdef
= Qnil
, insdef1
= Qnil
;
5049 count
= specpdl_ptr
- specpdl
;
5050 specbind (intern ("completion-ignore-case"), Qt
);
5053 GCPRO2 (insdef
, default_filename
);
5054 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5055 dir
, mustmatch
, insdef1
,
5056 Qfile_name_history
, default_filename
, Qnil
);
5057 /* If Fcompleting_read returned the default string itself
5058 (rather than a new string with the same contents),
5059 it has to mean that the user typed RET with the minibuffer empty.
5060 In that case, we really want to return ""
5061 so that commands such as set-visited-file-name can distinguish. */
5062 if (EQ (val
, default_filename
))
5063 val
= build_string ("");
5066 unbind_to (count
, Qnil
);
5071 error ("No file name specified");
5072 tem
= Fstring_equal (val
, insdef
);
5073 if (!NILP (tem
) && !NILP (default_filename
))
5074 return default_filename
;
5075 if (XSTRING (val
)->size
== 0 && NILP (insdef
))
5077 if (!NILP (default_filename
))
5078 return default_filename
;
5080 error ("No default file name");
5082 return Fsubstitute_in_file_name (val
);
5085 #if 0 /* Old version */
5086 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
5087 /* Don't confuse make-docfile by having two doc strings for this function.
5088 make-docfile does not pay attention to #if, for good reason! */
5090 (prompt
, dir
, defalt
, mustmatch
, initial
)
5091 Lisp_Object prompt
, dir
, defalt
, mustmatch
, initial
;
5093 Lisp_Object val
, insdef
, tem
;
5094 struct gcpro gcpro1
, gcpro2
;
5095 register char *homedir
;
5099 dir
= current_buffer
->directory
;
5101 defalt
= current_buffer
->filename
;
5103 /* If dir starts with user's homedir, change that to ~. */
5104 homedir
= (char *) egetenv ("HOME");
5107 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5108 && XSTRING (dir
)->data
[strlen (homedir
)] == '/')
5110 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5111 XSTRING (dir
)->size
- strlen (homedir
) + 1);
5112 XSTRING (dir
)->data
[0] = '~';
5115 if (!NILP (initial
))
5117 else if (insert_default_directory
)
5120 insdef
= build_string ("");
5123 count
= specpdl_ptr
- specpdl
;
5124 specbind (intern ("completion-ignore-case"), Qt
);
5127 GCPRO2 (insdef
, defalt
);
5128 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5130 insert_default_directory
? insdef
: Qnil
,
5131 Qfile_name_history
, Qnil
, Qnil
);
5134 unbind_to (count
, Qnil
);
5139 error ("No file name specified");
5140 tem
= Fstring_equal (val
, insdef
);
5141 if (!NILP (tem
) && !NILP (defalt
))
5143 return Fsubstitute_in_file_name (val
);
5145 #endif /* Old version */
5149 Qexpand_file_name
= intern ("expand-file-name");
5150 Qsubstitute_in_file_name
= intern ("substitute-in-file-name");
5151 Qdirectory_file_name
= intern ("directory-file-name");
5152 Qfile_name_directory
= intern ("file-name-directory");
5153 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
5154 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
5155 Qfile_name_as_directory
= intern ("file-name-as-directory");
5156 Qcopy_file
= intern ("copy-file");
5157 Qmake_directory_internal
= intern ("make-directory-internal");
5158 Qdelete_directory
= intern ("delete-directory");
5159 Qdelete_file
= intern ("delete-file");
5160 Qrename_file
= intern ("rename-file");
5161 Qadd_name_to_file
= intern ("add-name-to-file");
5162 Qmake_symbolic_link
= intern ("make-symbolic-link");
5163 Qfile_exists_p
= intern ("file-exists-p");
5164 Qfile_executable_p
= intern ("file-executable-p");
5165 Qfile_readable_p
= intern ("file-readable-p");
5166 Qfile_writable_p
= intern ("file-writable-p");
5167 Qfile_symlink_p
= intern ("file-symlink-p");
5168 Qaccess_file
= intern ("access-file");
5169 Qfile_directory_p
= intern ("file-directory-p");
5170 Qfile_regular_p
= intern ("file-regular-p");
5171 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
5172 Qfile_modes
= intern ("file-modes");
5173 Qset_file_modes
= intern ("set-file-modes");
5174 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
5175 Qinsert_file_contents
= intern ("insert-file-contents");
5176 Qwrite_region
= intern ("write-region");
5177 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
5178 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
5180 staticpro (&Qexpand_file_name
);
5181 staticpro (&Qsubstitute_in_file_name
);
5182 staticpro (&Qdirectory_file_name
);
5183 staticpro (&Qfile_name_directory
);
5184 staticpro (&Qfile_name_nondirectory
);
5185 staticpro (&Qunhandled_file_name_directory
);
5186 staticpro (&Qfile_name_as_directory
);
5187 staticpro (&Qcopy_file
);
5188 staticpro (&Qmake_directory_internal
);
5189 staticpro (&Qdelete_directory
);
5190 staticpro (&Qdelete_file
);
5191 staticpro (&Qrename_file
);
5192 staticpro (&Qadd_name_to_file
);
5193 staticpro (&Qmake_symbolic_link
);
5194 staticpro (&Qfile_exists_p
);
5195 staticpro (&Qfile_executable_p
);
5196 staticpro (&Qfile_readable_p
);
5197 staticpro (&Qfile_writable_p
);
5198 staticpro (&Qaccess_file
);
5199 staticpro (&Qfile_symlink_p
);
5200 staticpro (&Qfile_directory_p
);
5201 staticpro (&Qfile_regular_p
);
5202 staticpro (&Qfile_accessible_directory_p
);
5203 staticpro (&Qfile_modes
);
5204 staticpro (&Qset_file_modes
);
5205 staticpro (&Qfile_newer_than_file_p
);
5206 staticpro (&Qinsert_file_contents
);
5207 staticpro (&Qwrite_region
);
5208 staticpro (&Qverify_visited_file_modtime
);
5209 staticpro (&Qset_visited_file_modtime
);
5211 Qfile_name_history
= intern ("file-name-history");
5212 Fset (Qfile_name_history
, Qnil
);
5213 staticpro (&Qfile_name_history
);
5215 Qfile_error
= intern ("file-error");
5216 staticpro (&Qfile_error
);
5217 Qfile_already_exists
= intern ("file-already-exists");
5218 staticpro (&Qfile_already_exists
);
5219 Qfile_date_error
= intern ("file-date-error");
5220 staticpro (&Qfile_date_error
);
5223 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
5224 staticpro (&Qfind_buffer_file_type
);
5227 DEFVAR_LISP ("file-name-coding-system", &Vfile_name_coding_system
,
5228 "*Coding system for encoding file names.");
5229 Vfile_name_coding_system
= Qnil
;
5231 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format
,
5232 "*Format in which to write auto-save files.\n\
5233 Should be a list of symbols naming formats that are defined in `format-alist'.\n\
5234 If it is t, which is the default, auto-save files are written in the\n\
5235 same format as a regular save would use.");
5236 Vauto_save_file_format
= Qt
;
5238 Qformat_decode
= intern ("format-decode");
5239 staticpro (&Qformat_decode
);
5240 Qformat_annotate_function
= intern ("format-annotate-function");
5241 staticpro (&Qformat_annotate_function
);
5243 Qcar_less_than_car
= intern ("car-less-than-car");
5244 staticpro (&Qcar_less_than_car
);
5246 Fput (Qfile_error
, Qerror_conditions
,
5247 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
5248 Fput (Qfile_error
, Qerror_message
,
5249 build_string ("File error"));
5251 Fput (Qfile_already_exists
, Qerror_conditions
,
5252 Fcons (Qfile_already_exists
,
5253 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5254 Fput (Qfile_already_exists
, Qerror_message
,
5255 build_string ("File already exists"));
5257 Fput (Qfile_date_error
, Qerror_conditions
,
5258 Fcons (Qfile_date_error
,
5259 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5260 Fput (Qfile_date_error
, Qerror_message
,
5261 build_string ("Cannot set file date"));
5263 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
5264 "*Non-nil means when reading a filename start with default dir in minibuffer.");
5265 insert_default_directory
= 1;
5267 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
5268 "*Non-nil means write new files with record format `stmlf'.\n\
5269 nil means use format `var'. This variable is meaningful only on VMS.");
5270 vms_stmlf_recfm
= 0;
5272 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char
,
5273 "Directory separator character for built-in functions that return file names.\n\
5274 The value should be either ?/ or ?\\ (any other value is treated as ?\\).\n\
5275 This variable affects the built-in functions only on Windows,\n\
5276 on other platforms, it is initialized so that Lisp code can find out\n\
5277 what the normal separator is.");
5278 XSETFASTINT (Vdirectory_sep_char
, '/');
5280 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
5281 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
5282 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
5285 The first argument given to HANDLER is the name of the I/O primitive\n\
5286 to be handled; the remaining arguments are the arguments that were\n\
5287 passed to that primitive. For example, if you do\n\
5288 (file-exists-p FILENAME)\n\
5289 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
5290 (funcall HANDLER 'file-exists-p FILENAME)\n\
5291 The function `find-file-name-handler' checks this list for a handler\n\
5292 for its argument.");
5293 Vfile_name_handler_alist
= Qnil
;
5295 DEFVAR_LISP ("set-auto-coding-function",
5296 &Vset_auto_coding_function
,
5297 "If non-nil, a function to call to decide a coding system of file.\n\
5298 One argument is passed to this function: the string of concatination\n\
5299 or the heading 1K-byte and the tailing 3K-byte of a file to be read.\n\
5300 This function should return a coding system to decode the file contents\n\
5301 specified in the heading lines with the format:\n\
5302 -*- ... coding: CODING-SYSTEM; ... -*-\n\
5303 or local variable spec of the tailing lines with `coding:' tag.");
5304 Vset_auto_coding_function
= Qnil
;
5306 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
5307 "A list of functions to be called at the end of `insert-file-contents'.\n\
5308 Each is passed one argument, the number of bytes inserted. It should return\n\
5309 the new byte count, and leave point the same. If `insert-file-contents' is\n\
5310 intercepted by a handler from `file-name-handler-alist', that handler is\n\
5311 responsible for calling the after-insert-file-functions if appropriate.");
5312 Vafter_insert_file_functions
= Qnil
;
5314 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
5315 "A list of functions to be called at the start of `write-region'.\n\
5316 Each is passed two arguments, START and END as for `write-region'.\n\
5317 These are usually two numbers but not always; see the documentation\n\
5318 for `write-region'. The function should return a list of pairs\n\
5319 of the form (POSITION . STRING), consisting of strings to be effectively\n\
5320 inserted at the specified positions of the file being written (1 means to\n\
5321 insert before the first byte written). The POSITIONs must be sorted into\n\
5322 increasing order. If there are several functions in the list, the several\n\
5323 lists are merged destructively.");
5324 Vwrite_region_annotate_functions
= Qnil
;
5326 DEFVAR_LISP ("write-region-annotations-so-far",
5327 &Vwrite_region_annotations_so_far
,
5328 "When an annotation function is called, this holds the previous annotations.\n\
5329 These are the annotations made by other annotation functions\n\
5330 that were already called. See also `write-region-annotate-functions'.");
5331 Vwrite_region_annotations_so_far
= Qnil
;
5333 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
5334 "A list of file name handlers that temporarily should not be used.\n\
5335 This applies only to the operation `inhibit-file-name-operation'.");
5336 Vinhibit_file_name_handlers
= Qnil
;
5338 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
5339 "The operation for which `inhibit-file-name-handlers' is applicable.");
5340 Vinhibit_file_name_operation
= Qnil
;
5342 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
5343 "File name in which we write a list of all auto save file names.\n\
5344 This variable is initialized automatically from `auto-save-list-file-prefix'\n\
5345 shortly after Emacs reads your `.emacs' file, if you have not yet given it\n\
5347 Vauto_save_list_file_name
= Qnil
;
5349 defsubr (&Sfind_file_name_handler
);
5350 defsubr (&Sfile_name_directory
);
5351 defsubr (&Sfile_name_nondirectory
);
5352 defsubr (&Sunhandled_file_name_directory
);
5353 defsubr (&Sfile_name_as_directory
);
5354 defsubr (&Sdirectory_file_name
);
5355 defsubr (&Smake_temp_name
);
5356 defsubr (&Sexpand_file_name
);
5357 defsubr (&Ssubstitute_in_file_name
);
5358 defsubr (&Scopy_file
);
5359 defsubr (&Smake_directory_internal
);
5360 defsubr (&Sdelete_directory
);
5361 defsubr (&Sdelete_file
);
5362 defsubr (&Srename_file
);
5363 defsubr (&Sadd_name_to_file
);
5365 defsubr (&Smake_symbolic_link
);
5366 #endif /* S_IFLNK */
5368 defsubr (&Sdefine_logical_name
);
5371 defsubr (&Ssysnetunam
);
5372 #endif /* HPUX_NET */
5373 defsubr (&Sfile_name_absolute_p
);
5374 defsubr (&Sfile_exists_p
);
5375 defsubr (&Sfile_executable_p
);
5376 defsubr (&Sfile_readable_p
);
5377 defsubr (&Sfile_writable_p
);
5378 defsubr (&Saccess_file
);
5379 defsubr (&Sfile_symlink_p
);
5380 defsubr (&Sfile_directory_p
);
5381 defsubr (&Sfile_accessible_directory_p
);
5382 defsubr (&Sfile_regular_p
);
5383 defsubr (&Sfile_modes
);
5384 defsubr (&Sset_file_modes
);
5385 defsubr (&Sset_default_file_modes
);
5386 defsubr (&Sdefault_file_modes
);
5387 defsubr (&Sfile_newer_than_file_p
);
5388 defsubr (&Sinsert_file_contents
);
5389 defsubr (&Swrite_region
);
5390 defsubr (&Scar_less_than_car
);
5391 defsubr (&Sverify_visited_file_modtime
);
5392 defsubr (&Sclear_visited_file_modtime
);
5393 defsubr (&Svisited_file_modtime
);
5394 defsubr (&Sset_visited_file_modtime
);
5395 defsubr (&Sdo_auto_save
);
5396 defsubr (&Sset_buffer_auto_saved
);
5397 defsubr (&Sclear_buffer_auto_save_failure
);
5398 defsubr (&Srecent_auto_save_p
);
5400 defsubr (&Sread_file_name_internal
);
5401 defsubr (&Sread_file_name
);
5404 defsubr (&Sunix_sync
);