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
);
3847 p
= Vafter_insert_file_functions
;
3848 if (!NILP (coding
.post_read_conversion
))
3849 p
= Fcons (coding
.post_read_conversion
, p
);
3853 insval
= call1 (Fcar (p
), make_number (inserted
));
3856 CHECK_NUMBER (insval
, 0);
3857 inserted
= XFASTINT (insval
);
3865 val
= Fcons (orig_filename
,
3866 Fcons (make_number (inserted
),
3869 RETURN_UNGCPRO (unbind_to (count
, val
));
3872 static Lisp_Object
build_annotations ();
3873 extern Lisp_Object
Ffile_locked_p ();
3875 /* If build_annotations switched buffers, switch back to BUF.
3876 Kill the temporary buffer that was selected in the meantime.
3878 Since this kill only the last temporary buffer, some buffers remain
3879 not killed if build_annotations switched buffers more than once.
3883 build_annotations_unwind (buf
)
3888 if (XBUFFER (buf
) == current_buffer
)
3890 tembuf
= Fcurrent_buffer ();
3892 Fkill_buffer (tembuf
);
3896 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 6,
3897 "r\nFWrite region to file: ",
3898 "Write current region into specified file.\n\
3899 When called from a program, takes three arguments:\n\
3900 START, END and FILENAME. START and END are buffer positions.\n\
3901 Optional fourth argument APPEND if non-nil means\n\
3902 append to existing file contents (if any).\n\
3903 Optional fifth argument VISIT if t means\n\
3904 set the last-save-file-modtime of buffer to this file's modtime\n\
3905 and mark buffer not modified.\n\
3906 If VISIT is a string, it is a second file name;\n\
3907 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
3908 VISIT is also the file name to lock and unlock for clash detection.\n\
3909 If VISIT is neither t nor nil nor a string,\n\
3910 that means do not print the \"Wrote file\" message.\n\
3911 The optional sixth arg LOCKNAME, if non-nil, specifies the name to\n\
3912 use for locking and unlocking, overriding FILENAME and VISIT.\n\
3913 Kludgy feature: if START is a string, then that string is written\n\
3914 to the file, instead of any buffer contents, and END is ignored.")
3915 (start
, end
, filename
, append
, visit
, lockname
)
3916 Lisp_Object start
, end
, filename
, append
, visit
, lockname
;
3924 int count
= specpdl_ptr
- specpdl
;
3927 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
3929 Lisp_Object handler
;
3930 Lisp_Object visit_file
;
3931 Lisp_Object annotations
;
3932 Lisp_Object encoded_filename
;
3933 int visiting
, quietly
;
3934 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
3935 struct buffer
*given_buffer
;
3937 int buffer_file_type
= O_BINARY
;
3939 struct coding_system coding
;
3941 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3942 error ("Cannot do file visiting in an indirect buffer");
3944 if (!NILP (start
) && !STRINGP (start
))
3945 validate_region (&start
, &end
);
3947 GCPRO4 (start
, filename
, visit
, lockname
);
3949 /* Decide the coding-system to encode the data with. */
3955 else if (!NILP (Vcoding_system_for_write
))
3956 val
= Vcoding_system_for_write
;
3957 else if (NILP (current_buffer
->enable_multibyte_characters
))
3959 /* If the variable `buffer-file-coding-system' is set locally,
3960 it means that the file was read with some kind of code
3961 conversion or the varialbe is explicitely set by users. We
3962 had better write it out with the same coding system even if
3963 `enable-multibyte-characters' is nil.
3965 If is is not set locally, we anyway have to convert EOL
3966 format if the default value of `buffer-file-coding-system'
3967 tells that it is not Unix-like (LF only) format. */
3968 val
= current_buffer
->buffer_file_coding_system
;
3969 if (NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
3971 struct coding_system coding_temp
;
3973 setup_coding_system (Fcheck_coding_system (val
), &coding_temp
);
3974 if (coding_temp
.eol_type
== CODING_EOL_CRLF
3975 || coding_temp
.eol_type
== CODING_EOL_CR
)
3977 setup_coding_system (Qemacs_mule
, &coding
);
3978 coding
.eol_type
= coding_temp
.eol_type
;
3979 goto done_setup_coding
;
3986 Lisp_Object args
[7], coding_systems
;
3988 args
[0] = Qwrite_region
, args
[1] = start
, args
[2] = end
,
3989 args
[3] = filename
, args
[4] = append
, args
[5] = visit
,
3991 coding_systems
= Ffind_operation_coding_system (7, args
);
3992 val
= (CONSP (coding_systems
) && !NILP (XCONS (coding_systems
)->cdr
)
3993 ? XCONS (coding_systems
)->cdr
3994 : current_buffer
->buffer_file_coding_system
);
3996 setup_coding_system (Fcheck_coding_system (val
), &coding
);
3999 if (!STRINGP (start
) && !NILP (current_buffer
->selective_display
))
4000 coding
.selective
= 1;
4003 filename
= Fexpand_file_name (filename
, Qnil
);
4004 if (STRINGP (visit
))
4005 visit_file
= Fexpand_file_name (visit
, Qnil
);
4007 visit_file
= filename
;
4010 visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
4011 quietly
= !NILP (visit
);
4015 if (NILP (lockname
))
4016 lockname
= visit_file
;
4018 GCPRO5 (start
, filename
, annotations
, visit_file
, lockname
);
4020 /* If the file name has special constructs in it,
4021 call the corresponding file handler. */
4022 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
4023 /* If FILENAME has no handler, see if VISIT has one. */
4024 if (NILP (handler
) && STRINGP (visit
))
4025 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
4027 if (!NILP (handler
))
4030 val
= call6 (handler
, Qwrite_region
, start
, end
,
4031 filename
, append
, visit
);
4035 SAVE_MODIFF
= MODIFF
;
4036 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4037 current_buffer
->filename
= visit_file
;
4043 /* Special kludge to simplify auto-saving. */
4046 XSETFASTINT (start
, BEG
);
4047 XSETFASTINT (end
, Z
);
4050 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
4051 count1
= specpdl_ptr
- specpdl
;
4053 given_buffer
= current_buffer
;
4054 annotations
= build_annotations (start
, end
, coding
.pre_write_conversion
);
4055 if (current_buffer
!= given_buffer
)
4057 XSETFASTINT (start
, BEGV
);
4058 XSETFASTINT (end
, ZV
);
4061 #ifdef CLASH_DETECTION
4064 #if 0 /* This causes trouble for GNUS. */
4065 /* If we've locked this file for some other buffer,
4066 query before proceeding. */
4067 if (!visiting
&& EQ (Ffile_locked_p (lockname
), Qt
))
4068 call2 (intern ("ask-user-about-lock"), filename
, Vuser_login_name
);
4071 lock_file (lockname
);
4073 #endif /* CLASH_DETECTION */
4075 encoded_filename
= ENCODE_FILE (filename
);
4077 fn
= XSTRING (encoded_filename
)->data
;
4081 desc
= open (fn
, O_WRONLY
| buffer_file_type
);
4082 #else /* not DOS_NT */
4083 desc
= open (fn
, O_WRONLY
);
4084 #endif /* not DOS_NT */
4086 if (desc
< 0 && (NILP (append
) || errno
== ENOENT
))
4088 if (auto_saving
) /* Overwrite any previous version of autosave file */
4090 vms_truncate (fn
); /* if fn exists, truncate to zero length */
4091 desc
= open (fn
, O_RDWR
);
4093 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
4094 ? XSTRING (current_buffer
->filename
)->data
: 0,
4097 else /* Write to temporary name and rename if no errors */
4099 Lisp_Object temp_name
;
4100 temp_name
= Ffile_name_directory (filename
);
4102 if (!NILP (temp_name
))
4104 temp_name
= Fmake_temp_name (concat2 (temp_name
,
4105 build_string ("$$SAVE$$")));
4106 fname
= XSTRING (filename
)->data
;
4107 fn
= XSTRING (temp_name
)->data
;
4108 desc
= creat_copy_attrs (fname
, fn
);
4111 /* If we can't open the temporary file, try creating a new
4112 version of the original file. VMS "creat" creates a
4113 new version rather than truncating an existing file. */
4116 desc
= creat (fn
, 0666);
4117 #if 0 /* This can clobber an existing file and fail to replace it,
4118 if the user runs out of space. */
4121 /* We can't make a new version;
4122 try to truncate and rewrite existing version if any. */
4124 desc
= open (fn
, O_RDWR
);
4130 desc
= creat (fn
, 0666);
4135 O_WRONLY
| O_TRUNC
| O_CREAT
| buffer_file_type
,
4136 S_IREAD
| S_IWRITE
);
4137 #else /* not DOS_NT */
4138 desc
= creat (fn
, auto_saving
? auto_save_mode_bits
: 0666);
4139 #endif /* not DOS_NT */
4140 #endif /* not VMS */
4146 #ifdef CLASH_DETECTION
4148 if (!auto_saving
) unlock_file (lockname
);
4150 #endif /* CLASH_DETECTION */
4151 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
4154 record_unwind_protect (close_file_unwind
, make_number (desc
));
4157 if (lseek (desc
, 0, 2) < 0)
4159 #ifdef CLASH_DETECTION
4160 if (!auto_saving
) unlock_file (lockname
);
4161 #endif /* CLASH_DETECTION */
4162 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
4167 * Kludge Warning: The VMS C RTL likes to insert carriage returns
4168 * if we do writes that don't end with a carriage return. Furthermore
4169 * it cannot handle writes of more then 16K. The modified
4170 * version of "sys_write" in SYSDEP.C (see comment there) copes with
4171 * this EXCEPT for the last record (iff it doesn't end with a carriage
4172 * return). This implies that if your buffer doesn't end with a carriage
4173 * return, you get one free... tough. However it also means that if
4174 * we make two calls to sys_write (a la the following code) you can
4175 * get one at the gap as well. The easiest way to fix this (honest)
4176 * is to move the gap to the next newline (or the end of the buffer).
4181 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4182 move_gap (find_next_newline (GPT
, 1));
4184 /* Whether VMS or not, we must move the gap to the next of newline
4185 when we must put designation sequences at beginning of line. */
4186 if (INTEGERP (start
)
4187 && coding
.type
== coding_type_iso2022
4188 && coding
.flags
& CODING_FLAG_ISO_DESIGNATE_AT_BOL
4189 && GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4190 move_gap (find_next_newline (GPT
, 1));
4196 if (STRINGP (start
))
4198 failure
= 0 > a_write (desc
, XSTRING (start
)->data
,
4199 XSTRING (start
)->size
, 0, &annotations
, &coding
);
4202 else if (XINT (start
) != XINT (end
))
4205 if (XINT (start
) < GPT
)
4207 register int end1
= XINT (end
);
4209 failure
= 0 > a_write (desc
, POS_ADDR (tem
),
4210 min (GPT
, end1
) - tem
, tem
, &annotations
,
4212 nwritten
+= min (GPT
, end1
) - tem
;
4216 if (XINT (end
) > GPT
&& !failure
)
4219 tem
= max (tem
, GPT
);
4220 failure
= 0 > a_write (desc
, POS_ADDR (tem
), XINT (end
) - tem
,
4221 tem
, &annotations
, &coding
);
4222 nwritten
+= XINT (end
) - tem
;
4228 /* If file was empty, still need to write the annotations */
4229 coding
.last_block
= 1;
4230 failure
= 0 > a_write (desc
, "", 0, XINT (start
), &annotations
, &coding
);
4234 if (CODING_REQUIRE_FLUSHING (&coding
) && !coding
.last_block
)
4236 /* We have to flush out a data. */
4237 coding
.last_block
= 1;
4238 failure
= 0 > e_write (desc
, "", 0, &coding
);
4245 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
4246 Disk full in NFS may be reported here. */
4247 /* mib says that closing the file will try to write as fast as NFS can do
4248 it, and that means the fsync here is not crucial for autosave files. */
4249 if (!auto_saving
&& fsync (desc
) < 0)
4251 /* If fsync fails with EINTR, don't treat that as serious. */
4253 failure
= 1, save_errno
= errno
;
4257 /* Spurious "file has changed on disk" warnings have been
4258 observed on Suns as well.
4259 It seems that `close' can change the modtime, under nfs.
4261 (This has supposedly been fixed in Sunos 4,
4262 but who knows about all the other machines with NFS?) */
4265 /* On VMS and APOLLO, must do the stat after the close
4266 since closing changes the modtime. */
4269 /* Recall that #if defined does not work on VMS. */
4276 /* NFS can report a write failure now. */
4277 if (close (desc
) < 0)
4278 failure
= 1, save_errno
= errno
;
4281 /* If we wrote to a temporary name and had no errors, rename to real name. */
4285 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
4293 /* Discard the unwind protect for close_file_unwind. */
4294 specpdl_ptr
= specpdl
+ count1
;
4295 /* Restore the original current buffer. */
4296 visit_file
= unbind_to (count
, visit_file
);
4298 #ifdef CLASH_DETECTION
4300 unlock_file (lockname
);
4301 #endif /* CLASH_DETECTION */
4303 /* Do this before reporting IO error
4304 to avoid a "file has changed on disk" warning on
4305 next attempt to save. */
4307 current_buffer
->modtime
= st
.st_mtime
;
4310 error ("IO error writing %s: %s", XSTRING (filename
)->data
,
4311 strerror (save_errno
));
4315 SAVE_MODIFF
= MODIFF
;
4316 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4317 current_buffer
->filename
= visit_file
;
4318 update_mode_lines
++;
4324 message ("Wrote %s", XSTRING (visit_file
)->data
);
4329 Lisp_Object
merge ();
4331 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
4332 "Return t if (car A) is numerically less than (car B).")
4336 return Flss (Fcar (a
), Fcar (b
));
4339 /* Build the complete list of annotations appropriate for writing out
4340 the text between START and END, by calling all the functions in
4341 write-region-annotate-functions and merging the lists they return.
4342 If one of these functions switches to a different buffer, we assume
4343 that buffer contains altered text. Therefore, the caller must
4344 make sure to restore the current buffer in all cases,
4345 as save-excursion would do. */
4348 build_annotations (start
, end
, pre_write_conversion
)
4349 Lisp_Object start
, end
, pre_write_conversion
;
4351 Lisp_Object annotations
;
4353 struct gcpro gcpro1
, gcpro2
;
4354 Lisp_Object original_buffer
;
4356 XSETBUFFER (original_buffer
, current_buffer
);
4359 p
= Vwrite_region_annotate_functions
;
4360 GCPRO2 (annotations
, p
);
4363 struct buffer
*given_buffer
= current_buffer
;
4364 Vwrite_region_annotations_so_far
= annotations
;
4365 res
= call2 (Fcar (p
), start
, end
);
4366 /* If the function makes a different buffer current,
4367 assume that means this buffer contains altered text to be output.
4368 Reset START and END from the buffer bounds
4369 and discard all previous annotations because they should have
4370 been dealt with by this function. */
4371 if (current_buffer
!= given_buffer
)
4373 XSETFASTINT (start
, BEGV
);
4374 XSETFASTINT (end
, ZV
);
4377 Flength (res
); /* Check basic validity of return value */
4378 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4382 /* Now do the same for annotation functions implied by the file-format */
4383 if (auto_saving
&& (!EQ (Vauto_save_file_format
, Qt
)))
4384 p
= Vauto_save_file_format
;
4386 p
= current_buffer
->file_format
;
4389 struct buffer
*given_buffer
= current_buffer
;
4390 Vwrite_region_annotations_so_far
= annotations
;
4391 res
= call4 (Qformat_annotate_function
, Fcar (p
), start
, end
,
4393 if (current_buffer
!= given_buffer
)
4395 XSETFASTINT (start
, BEGV
);
4396 XSETFASTINT (end
, ZV
);
4400 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4404 /* At last, do the same for the function PRE_WRITE_CONVERSION
4405 implied by the current coding-system. */
4406 if (!NILP (pre_write_conversion
))
4408 struct buffer
*given_buffer
= current_buffer
;
4409 Vwrite_region_annotations_so_far
= annotations
;
4410 res
= call2 (pre_write_conversion
, start
, end
);
4412 annotations
= (current_buffer
!= given_buffer
4414 : merge (annotations
, res
, Qcar_less_than_car
));
4421 /* Write to descriptor DESC the LEN characters starting at ADDR,
4422 assuming they start at position POS in the buffer.
4423 Intersperse with them the annotations from *ANNOT
4424 (those which fall within the range of positions POS to POS + LEN),
4425 each at its appropriate position.
4427 Modify *ANNOT by discarding elements as we output them.
4428 The return value is negative in case of system call failure. */
4431 a_write (desc
, addr
, len
, pos
, annot
, coding
)
4433 register char *addr
;
4437 struct coding_system
*coding
;
4441 int lastpos
= pos
+ len
;
4443 while (NILP (*annot
) || CONSP (*annot
))
4445 tem
= Fcar_safe (Fcar (*annot
));
4446 if (INTEGERP (tem
) && XINT (tem
) >= pos
&& XFASTINT (tem
) <= lastpos
)
4447 nextpos
= XFASTINT (tem
);
4449 return e_write (desc
, addr
, lastpos
- pos
, coding
);
4452 if (0 > e_write (desc
, addr
, nextpos
- pos
, coding
))
4454 addr
+= nextpos
- pos
;
4457 tem
= Fcdr (Fcar (*annot
));
4460 if (0 > e_write (desc
, XSTRING (tem
)->data
, XSTRING (tem
)->size
,
4464 *annot
= Fcdr (*annot
);
4468 #ifndef WRITE_BUF_SIZE
4469 #define WRITE_BUF_SIZE (16 * 1024)
4473 e_write (desc
, addr
, len
, coding
)
4475 register char *addr
;
4477 struct coding_system
*coding
;
4479 char buf
[WRITE_BUF_SIZE
];
4480 int produced
, consumed
;
4482 /* We used to have a code for handling selective display here. But,
4483 now it is handled within encode_coding. */
4486 produced
= encode_coding (coding
, addr
, buf
, len
, WRITE_BUF_SIZE
,
4488 len
-= consumed
, addr
+= consumed
;
4491 produced
-= write (desc
, buf
, produced
);
4492 if (produced
) return -1;
4500 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
4501 Sverify_visited_file_modtime
, 1, 1, 0,
4502 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
4503 This means that the file has not been changed since it was visited or saved.")
4509 Lisp_Object handler
;
4510 Lisp_Object filename
;
4512 CHECK_BUFFER (buf
, 0);
4515 if (!STRINGP (b
->filename
)) return Qt
;
4516 if (b
->modtime
== 0) return Qt
;
4518 /* If the file name has special constructs in it,
4519 call the corresponding file handler. */
4520 handler
= Ffind_file_name_handler (b
->filename
,
4521 Qverify_visited_file_modtime
);
4522 if (!NILP (handler
))
4523 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
4525 filename
= ENCODE_FILE (b
->filename
);
4527 if (stat (XSTRING (filename
)->data
, &st
) < 0)
4529 /* If the file doesn't exist now and didn't exist before,
4530 we say that it isn't modified, provided the error is a tame one. */
4531 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
4536 if (st
.st_mtime
== b
->modtime
4537 /* If both are positive, accept them if they are off by one second. */
4538 || (st
.st_mtime
> 0 && b
->modtime
> 0
4539 && (st
.st_mtime
== b
->modtime
+ 1
4540 || st
.st_mtime
== b
->modtime
- 1)))
4545 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
4546 Sclear_visited_file_modtime
, 0, 0, 0,
4547 "Clear out records of last mod time of visited file.\n\
4548 Next attempt to save will certainly not complain of a discrepancy.")
4551 current_buffer
->modtime
= 0;
4555 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
4556 Svisited_file_modtime
, 0, 0, 0,
4557 "Return the current buffer's recorded visited file modification time.\n\
4558 The value is a list of the form (HIGH . LOW), like the time values\n\
4559 that `file-attributes' returns.")
4562 return long_to_cons ((unsigned long) current_buffer
->modtime
);
4565 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
4566 Sset_visited_file_modtime
, 0, 1, 0,
4567 "Update buffer's recorded modification time from the visited file's time.\n\
4568 Useful if the buffer was not read from the file normally\n\
4569 or if the file itself has been changed for some known benign reason.\n\
4570 An argument specifies the modification time value to use\n\
4571 \(instead of that of the visited file), in the form of a list\n\
4572 \(HIGH . LOW) or (HIGH LOW).")
4574 Lisp_Object time_list
;
4576 if (!NILP (time_list
))
4577 current_buffer
->modtime
= cons_to_long (time_list
);
4580 register Lisp_Object filename
;
4582 Lisp_Object handler
;
4584 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
4586 /* If the file name has special constructs in it,
4587 call the corresponding file handler. */
4588 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
4589 if (!NILP (handler
))
4590 /* The handler can find the file name the same way we did. */
4591 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
4593 filename
= ENCODE_FILE (filename
);
4595 if (stat (XSTRING (filename
)->data
, &st
) >= 0)
4596 current_buffer
->modtime
= st
.st_mtime
;
4606 message ("Autosaving...error for %s", XSTRING (current_buffer
->name
)->data
);
4607 Fsleep_for (make_number (1), Qnil
);
4608 message ("Autosaving...error!for %s", XSTRING (current_buffer
->name
)->data
);
4609 Fsleep_for (make_number (1), Qnil
);
4610 message ("Autosaving...error for %s", XSTRING (current_buffer
->name
)->data
);
4611 Fsleep_for (make_number (1), Qnil
);
4621 /* Get visited file's mode to become the auto save file's mode. */
4622 if (stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
4623 /* But make sure we can overwrite it later! */
4624 auto_save_mode_bits
= st
.st_mode
| 0600;
4626 auto_save_mode_bits
= 0666;
4629 Fwrite_region (Qnil
, Qnil
,
4630 current_buffer
->auto_save_file_name
,
4631 Qnil
, Qlambda
, Qnil
);
4635 do_auto_save_unwind (stream
) /* used as unwind-protect function */
4640 fclose ((FILE *) (XFASTINT (XCONS (stream
)->car
) << 16
4641 | XFASTINT (XCONS (stream
)->cdr
)));
4646 do_auto_save_unwind_1 (value
) /* used as unwind-protect function */
4649 minibuffer_auto_raise
= XINT (value
);
4653 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
4654 "Auto-save all buffers that need it.\n\
4655 This is all buffers that have auto-saving enabled\n\
4656 and are changed since last auto-saved.\n\
4657 Auto-saving writes the buffer into a file\n\
4658 so that your editing is not lost if the system crashes.\n\
4659 This file is not the file you visited; that changes only when you save.\n\
4660 Normally we run the normal hook `auto-save-hook' before saving.\n\n\
4661 A non-nil NO-MESSAGE argument means do not print any message if successful.\n\
4662 A non-nil CURRENT-ONLY argument means save only current buffer.")
4663 (no_message
, current_only
)
4664 Lisp_Object no_message
, current_only
;
4666 struct buffer
*old
= current_buffer
, *b
;
4667 Lisp_Object tail
, buf
;
4669 char *omessage
= echo_area_glyphs
;
4670 int omessage_length
= echo_area_glyphs_length
;
4671 int do_handled_files
;
4674 Lisp_Object lispstream
;
4675 int count
= specpdl_ptr
- specpdl
;
4677 int orig_minibuffer_auto_raise
= minibuffer_auto_raise
;
4679 /* Ordinarily don't quit within this function,
4680 but don't make it impossible to quit (in case we get hung in I/O). */
4684 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
4685 point to non-strings reached from Vbuffer_alist. */
4690 if (!NILP (Vrun_hooks
))
4691 call1 (Vrun_hooks
, intern ("auto-save-hook"));
4693 if (STRINGP (Vauto_save_list_file_name
))
4695 Lisp_Object listfile
;
4696 listfile
= Fexpand_file_name (Vauto_save_list_file_name
, Qnil
);
4697 stream
= fopen (XSTRING (listfile
)->data
, "w");
4700 /* Arrange to close that file whether or not we get an error.
4701 Also reset auto_saving to 0. */
4702 lispstream
= Fcons (Qnil
, Qnil
);
4703 XSETFASTINT (XCONS (lispstream
)->car
, (EMACS_UINT
)stream
>> 16);
4704 XSETFASTINT (XCONS (lispstream
)->cdr
, (EMACS_UINT
)stream
& 0xffff);
4715 record_unwind_protect (do_auto_save_unwind
, lispstream
);
4716 record_unwind_protect (do_auto_save_unwind_1
,
4717 make_number (minibuffer_auto_raise
));
4718 minibuffer_auto_raise
= 0;
4721 /* First, save all files which don't have handlers. If Emacs is
4722 crashing, the handlers may tweak what is causing Emacs to crash
4723 in the first place, and it would be a shame if Emacs failed to
4724 autosave perfectly ordinary files because it couldn't handle some
4726 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
4727 for (tail
= Vbuffer_alist
; GC_CONSP (tail
); tail
= XCONS (tail
)->cdr
)
4729 buf
= XCONS (XCONS (tail
)->car
)->cdr
;
4732 /* Record all the buffers that have auto save mode
4733 in the special file that lists them. For each of these buffers,
4734 Record visited name (if any) and auto save name. */
4735 if (STRINGP (b
->auto_save_file_name
)
4736 && stream
!= NULL
&& do_handled_files
== 0)
4738 if (!NILP (b
->filename
))
4740 fwrite (XSTRING (b
->filename
)->data
, 1,
4741 XSTRING (b
->filename
)->size
, stream
);
4743 putc ('\n', stream
);
4744 fwrite (XSTRING (b
->auto_save_file_name
)->data
, 1,
4745 XSTRING (b
->auto_save_file_name
)->size
, stream
);
4746 putc ('\n', stream
);
4749 if (!NILP (current_only
)
4750 && b
!= current_buffer
)
4753 /* Don't auto-save indirect buffers.
4754 The base buffer takes care of it. */
4758 /* Check for auto save enabled
4759 and file changed since last auto save
4760 and file changed since last real save. */
4761 if (STRINGP (b
->auto_save_file_name
)
4762 && BUF_SAVE_MODIFF (b
) < BUF_MODIFF (b
)
4763 && b
->auto_save_modified
< BUF_MODIFF (b
)
4764 /* -1 means we've turned off autosaving for a while--see below. */
4765 && XINT (b
->save_length
) >= 0
4766 && (do_handled_files
4767 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
4770 EMACS_TIME before_time
, after_time
;
4772 EMACS_GET_TIME (before_time
);
4774 /* If we had a failure, don't try again for 20 minutes. */
4775 if (b
->auto_save_failure_time
>= 0
4776 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
4779 if ((XFASTINT (b
->save_length
) * 10
4780 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
4781 /* A short file is likely to change a large fraction;
4782 spare the user annoying messages. */
4783 && XFASTINT (b
->save_length
) > 5000
4784 /* These messages are frequent and annoying for `*mail*'. */
4785 && !EQ (b
->filename
, Qnil
)
4786 && NILP (no_message
))
4788 /* It has shrunk too much; turn off auto-saving here. */
4789 minibuffer_auto_raise
= orig_minibuffer_auto_raise
;
4790 message ("Buffer %s has shrunk a lot; auto save turned off there",
4791 XSTRING (b
->name
)->data
);
4792 minibuffer_auto_raise
= 0;
4793 /* Turn off auto-saving until there's a real save,
4794 and prevent any more warnings. */
4795 XSETINT (b
->save_length
, -1);
4796 Fsleep_for (make_number (1), Qnil
);
4799 set_buffer_internal (b
);
4800 if (!auto_saved
&& NILP (no_message
))
4801 message1 ("Auto-saving...");
4802 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
4804 b
->auto_save_modified
= BUF_MODIFF (b
);
4805 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4806 set_buffer_internal (old
);
4808 EMACS_GET_TIME (after_time
);
4810 /* If auto-save took more than 60 seconds,
4811 assume it was an NFS failure that got a timeout. */
4812 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
4813 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
4817 /* Prevent another auto save till enough input events come in. */
4818 record_auto_save ();
4820 if (auto_saved
&& NILP (no_message
))
4824 sit_for (1, 0, 0, 0, 0);
4825 message2 (omessage
, omessage_length
);
4828 message1 ("Auto-saving...done");
4833 unbind_to (count
, Qnil
);
4837 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
4838 Sset_buffer_auto_saved
, 0, 0, 0,
4839 "Mark current buffer as auto-saved with its current text.\n\
4840 No auto-save file will be written until the buffer changes again.")
4843 current_buffer
->auto_save_modified
= MODIFF
;
4844 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4845 current_buffer
->auto_save_failure_time
= -1;
4849 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
4850 Sclear_buffer_auto_save_failure
, 0, 0, 0,
4851 "Clear any record of a recent auto-save failure in the current buffer.")
4854 current_buffer
->auto_save_failure_time
= -1;
4858 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
4860 "Return t if buffer has been auto-saved since last read in or saved.")
4863 return (SAVE_MODIFF
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
4866 /* Reading and completing file names */
4867 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
4869 /* In the string VAL, change each $ to $$ and return the result. */
4872 double_dollars (val
)
4875 register unsigned char *old
, *new;
4879 osize
= XSTRING (val
)->size
;
4880 /* Quote "$" as "$$" to get it past substitute-in-file-name */
4881 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
4882 if (*old
++ == '$') count
++;
4885 old
= XSTRING (val
)->data
;
4886 val
= Fmake_string (make_number (osize
+ count
), make_number (0));
4887 new = XSTRING (val
)->data
;
4888 for (n
= osize
; n
> 0; n
--)
4901 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
4903 "Internal subroutine for read-file-name. Do not call this.")
4904 (string
, dir
, action
)
4905 Lisp_Object string
, dir
, action
;
4906 /* action is nil for complete, t for return list of completions,
4907 lambda for verify final value */
4909 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
4911 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
4913 CHECK_STRING (string
, 0);
4920 /* No need to protect ACTION--we only compare it with t and nil. */
4921 GCPRO5 (string
, realdir
, name
, specdir
, orig_string
);
4923 if (XSTRING (string
)->size
== 0)
4925 if (EQ (action
, Qlambda
))
4933 orig_string
= string
;
4934 string
= Fsubstitute_in_file_name (string
);
4935 changed
= NILP (Fstring_equal (string
, orig_string
));
4936 name
= Ffile_name_nondirectory (string
);
4937 val
= Ffile_name_directory (string
);
4939 realdir
= Fexpand_file_name (val
, realdir
);
4944 specdir
= Ffile_name_directory (string
);
4945 val
= Ffile_name_completion (name
, realdir
);
4950 return double_dollars (string
);
4954 if (!NILP (specdir
))
4955 val
= concat2 (specdir
, val
);
4957 return double_dollars (val
);
4960 #endif /* not VMS */
4964 if (EQ (action
, Qt
))
4965 return Ffile_name_all_completions (name
, realdir
);
4966 /* Only other case actually used is ACTION = lambda */
4968 /* Supposedly this helps commands such as `cd' that read directory names,
4969 but can someone explain how it helps them? -- RMS */
4970 if (XSTRING (name
)->size
== 0)
4973 return Ffile_exists_p (string
);
4976 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
4977 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
4978 Value is not expanded---you must call `expand-file-name' yourself.\n\
4979 Default name to DEFAULT-FILENAME if user enters a null string.\n\
4980 (If DEFAULT-FILENAME is omitted, the visited file name is used,\n\
4981 except that if INITIAL is specified, that combined with DIR is used.)\n\
4982 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
4983 Non-nil and non-t means also require confirmation after completion.\n\
4984 Fifth arg INITIAL specifies text to start with.\n\
4985 DIR defaults to current buffer's directory default.")
4986 (prompt
, dir
, default_filename
, mustmatch
, initial
)
4987 Lisp_Object prompt
, dir
, default_filename
, mustmatch
, initial
;
4989 Lisp_Object val
, insdef
, insdef1
, tem
;
4990 struct gcpro gcpro1
, gcpro2
;
4991 register char *homedir
;
4995 dir
= current_buffer
->directory
;
4996 if (NILP (default_filename
))
4998 if (! NILP (initial
))
4999 default_filename
= Fexpand_file_name (initial
, dir
);
5001 default_filename
= current_buffer
->filename
;
5004 /* If dir starts with user's homedir, change that to ~. */
5005 homedir
= (char *) egetenv ("HOME");
5007 homedir
= strcpy (alloca (strlen (homedir
) + 1), homedir
);
5008 CORRECT_DIR_SEPS (homedir
);
5012 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5013 && IS_DIRECTORY_SEP (XSTRING (dir
)->data
[strlen (homedir
)]))
5015 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5016 XSTRING (dir
)->size
- strlen (homedir
) + 1);
5017 XSTRING (dir
)->data
[0] = '~';
5020 if (insert_default_directory
&& STRINGP (dir
))
5023 if (!NILP (initial
))
5025 Lisp_Object args
[2], pos
;
5029 insdef
= Fconcat (2, args
);
5030 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
5031 insdef1
= Fcons (double_dollars (insdef
), pos
);
5034 insdef1
= double_dollars (insdef
);
5036 else if (STRINGP (initial
))
5039 insdef1
= Fcons (double_dollars (insdef
), make_number (0));
5042 insdef
= Qnil
, insdef1
= Qnil
;
5045 count
= specpdl_ptr
- specpdl
;
5046 specbind (intern ("completion-ignore-case"), Qt
);
5049 GCPRO2 (insdef
, default_filename
);
5050 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5051 dir
, mustmatch
, insdef1
,
5052 Qfile_name_history
, default_filename
, Qnil
);
5053 /* If Fcompleting_read returned the default string itself
5054 (rather than a new string with the same contents),
5055 it has to mean that the user typed RET with the minibuffer empty.
5056 In that case, we really want to return ""
5057 so that commands such as set-visited-file-name can distinguish. */
5058 if (EQ (val
, default_filename
))
5059 val
= build_string ("");
5062 unbind_to (count
, Qnil
);
5067 error ("No file name specified");
5068 tem
= Fstring_equal (val
, insdef
);
5069 if (!NILP (tem
) && !NILP (default_filename
))
5070 return default_filename
;
5071 if (XSTRING (val
)->size
== 0 && NILP (insdef
))
5073 if (!NILP (default_filename
))
5074 return default_filename
;
5076 error ("No default file name");
5078 return Fsubstitute_in_file_name (val
);
5081 #if 0 /* Old version */
5082 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
5083 /* Don't confuse make-docfile by having two doc strings for this function.
5084 make-docfile does not pay attention to #if, for good reason! */
5086 (prompt
, dir
, defalt
, mustmatch
, initial
)
5087 Lisp_Object prompt
, dir
, defalt
, mustmatch
, initial
;
5089 Lisp_Object val
, insdef
, tem
;
5090 struct gcpro gcpro1
, gcpro2
;
5091 register char *homedir
;
5095 dir
= current_buffer
->directory
;
5097 defalt
= current_buffer
->filename
;
5099 /* If dir starts with user's homedir, change that to ~. */
5100 homedir
= (char *) egetenv ("HOME");
5103 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5104 && XSTRING (dir
)->data
[strlen (homedir
)] == '/')
5106 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5107 XSTRING (dir
)->size
- strlen (homedir
) + 1);
5108 XSTRING (dir
)->data
[0] = '~';
5111 if (!NILP (initial
))
5113 else if (insert_default_directory
)
5116 insdef
= build_string ("");
5119 count
= specpdl_ptr
- specpdl
;
5120 specbind (intern ("completion-ignore-case"), Qt
);
5123 GCPRO2 (insdef
, defalt
);
5124 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5126 insert_default_directory
? insdef
: Qnil
,
5127 Qfile_name_history
, Qnil
, Qnil
);
5130 unbind_to (count
, Qnil
);
5135 error ("No file name specified");
5136 tem
= Fstring_equal (val
, insdef
);
5137 if (!NILP (tem
) && !NILP (defalt
))
5139 return Fsubstitute_in_file_name (val
);
5141 #endif /* Old version */
5145 Qexpand_file_name
= intern ("expand-file-name");
5146 Qsubstitute_in_file_name
= intern ("substitute-in-file-name");
5147 Qdirectory_file_name
= intern ("directory-file-name");
5148 Qfile_name_directory
= intern ("file-name-directory");
5149 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
5150 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
5151 Qfile_name_as_directory
= intern ("file-name-as-directory");
5152 Qcopy_file
= intern ("copy-file");
5153 Qmake_directory_internal
= intern ("make-directory-internal");
5154 Qdelete_directory
= intern ("delete-directory");
5155 Qdelete_file
= intern ("delete-file");
5156 Qrename_file
= intern ("rename-file");
5157 Qadd_name_to_file
= intern ("add-name-to-file");
5158 Qmake_symbolic_link
= intern ("make-symbolic-link");
5159 Qfile_exists_p
= intern ("file-exists-p");
5160 Qfile_executable_p
= intern ("file-executable-p");
5161 Qfile_readable_p
= intern ("file-readable-p");
5162 Qfile_writable_p
= intern ("file-writable-p");
5163 Qfile_symlink_p
= intern ("file-symlink-p");
5164 Qaccess_file
= intern ("access-file");
5165 Qfile_directory_p
= intern ("file-directory-p");
5166 Qfile_regular_p
= intern ("file-regular-p");
5167 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
5168 Qfile_modes
= intern ("file-modes");
5169 Qset_file_modes
= intern ("set-file-modes");
5170 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
5171 Qinsert_file_contents
= intern ("insert-file-contents");
5172 Qwrite_region
= intern ("write-region");
5173 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
5174 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
5176 staticpro (&Qexpand_file_name
);
5177 staticpro (&Qsubstitute_in_file_name
);
5178 staticpro (&Qdirectory_file_name
);
5179 staticpro (&Qfile_name_directory
);
5180 staticpro (&Qfile_name_nondirectory
);
5181 staticpro (&Qunhandled_file_name_directory
);
5182 staticpro (&Qfile_name_as_directory
);
5183 staticpro (&Qcopy_file
);
5184 staticpro (&Qmake_directory_internal
);
5185 staticpro (&Qdelete_directory
);
5186 staticpro (&Qdelete_file
);
5187 staticpro (&Qrename_file
);
5188 staticpro (&Qadd_name_to_file
);
5189 staticpro (&Qmake_symbolic_link
);
5190 staticpro (&Qfile_exists_p
);
5191 staticpro (&Qfile_executable_p
);
5192 staticpro (&Qfile_readable_p
);
5193 staticpro (&Qfile_writable_p
);
5194 staticpro (&Qaccess_file
);
5195 staticpro (&Qfile_symlink_p
);
5196 staticpro (&Qfile_directory_p
);
5197 staticpro (&Qfile_regular_p
);
5198 staticpro (&Qfile_accessible_directory_p
);
5199 staticpro (&Qfile_modes
);
5200 staticpro (&Qset_file_modes
);
5201 staticpro (&Qfile_newer_than_file_p
);
5202 staticpro (&Qinsert_file_contents
);
5203 staticpro (&Qwrite_region
);
5204 staticpro (&Qverify_visited_file_modtime
);
5205 staticpro (&Qset_visited_file_modtime
);
5207 Qfile_name_history
= intern ("file-name-history");
5208 Fset (Qfile_name_history
, Qnil
);
5209 staticpro (&Qfile_name_history
);
5211 Qfile_error
= intern ("file-error");
5212 staticpro (&Qfile_error
);
5213 Qfile_already_exists
= intern ("file-already-exists");
5214 staticpro (&Qfile_already_exists
);
5215 Qfile_date_error
= intern ("file-date-error");
5216 staticpro (&Qfile_date_error
);
5219 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
5220 staticpro (&Qfind_buffer_file_type
);
5223 DEFVAR_LISP ("file-name-coding-system", &Vfile_name_coding_system
,
5224 "*Coding system for encoding file names.");
5225 Vfile_name_coding_system
= Qnil
;
5227 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format
,
5228 "*Format in which to write auto-save files.\n\
5229 Should be a list of symbols naming formats that are defined in `format-alist'.\n\
5230 If it is t, which is the default, auto-save files are written in the\n\
5231 same format as a regular save would use.");
5232 Vauto_save_file_format
= Qt
;
5234 Qformat_decode
= intern ("format-decode");
5235 staticpro (&Qformat_decode
);
5236 Qformat_annotate_function
= intern ("format-annotate-function");
5237 staticpro (&Qformat_annotate_function
);
5239 Qcar_less_than_car
= intern ("car-less-than-car");
5240 staticpro (&Qcar_less_than_car
);
5242 Fput (Qfile_error
, Qerror_conditions
,
5243 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
5244 Fput (Qfile_error
, Qerror_message
,
5245 build_string ("File error"));
5247 Fput (Qfile_already_exists
, Qerror_conditions
,
5248 Fcons (Qfile_already_exists
,
5249 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5250 Fput (Qfile_already_exists
, Qerror_message
,
5251 build_string ("File already exists"));
5253 Fput (Qfile_date_error
, Qerror_conditions
,
5254 Fcons (Qfile_date_error
,
5255 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5256 Fput (Qfile_date_error
, Qerror_message
,
5257 build_string ("Cannot set file date"));
5259 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
5260 "*Non-nil means when reading a filename start with default dir in minibuffer.");
5261 insert_default_directory
= 1;
5263 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
5264 "*Non-nil means write new files with record format `stmlf'.\n\
5265 nil means use format `var'. This variable is meaningful only on VMS.");
5266 vms_stmlf_recfm
= 0;
5268 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char
,
5269 "Directory separator character for built-in functions that return file names.\n\
5270 The value should be either ?/ or ?\\ (any other value is treated as ?\\).\n\
5271 This variable affects the built-in functions only on Windows,\n\
5272 on other platforms, it is initialized so that Lisp code can find out\n\
5273 what the normal separator is.");
5274 XSETFASTINT (Vdirectory_sep_char
, '/');
5276 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
5277 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
5278 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
5281 The first argument given to HANDLER is the name of the I/O primitive\n\
5282 to be handled; the remaining arguments are the arguments that were\n\
5283 passed to that primitive. For example, if you do\n\
5284 (file-exists-p FILENAME)\n\
5285 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
5286 (funcall HANDLER 'file-exists-p FILENAME)\n\
5287 The function `find-file-name-handler' checks this list for a handler\n\
5288 for its argument.");
5289 Vfile_name_handler_alist
= Qnil
;
5291 DEFVAR_LISP ("set-auto-coding-function",
5292 &Vset_auto_coding_function
,
5293 "If non-nil, a function to call to decide a coding system of file.\n\
5294 One argument is passed to this function: the string of concatination\n\
5295 or the heading 1K-byte and the tailing 3K-byte of a file to be read.\n\
5296 This function should return a coding system to decode the file contents\n\
5297 specified in the heading lines with the format:\n\
5298 -*- ... coding: CODING-SYSTEM; ... -*-\n\
5299 or local variable spec of the tailing lines with `coding:' tag.");
5300 Vset_auto_coding_function
= Qnil
;
5302 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
5303 "A list of functions to be called at the end of `insert-file-contents'.\n\
5304 Each is passed one argument, the number of bytes inserted. It should return\n\
5305 the new byte count, and leave point the same. If `insert-file-contents' is\n\
5306 intercepted by a handler from `file-name-handler-alist', that handler is\n\
5307 responsible for calling the after-insert-file-functions if appropriate.");
5308 Vafter_insert_file_functions
= Qnil
;
5310 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
5311 "A list of functions to be called at the start of `write-region'.\n\
5312 Each is passed two arguments, START and END as for `write-region'.\n\
5313 These are usually two numbers but not always; see the documentation\n\
5314 for `write-region'. The function should return a list of pairs\n\
5315 of the form (POSITION . STRING), consisting of strings to be effectively\n\
5316 inserted at the specified positions of the file being written (1 means to\n\
5317 insert before the first byte written). The POSITIONs must be sorted into\n\
5318 increasing order. If there are several functions in the list, the several\n\
5319 lists are merged destructively.");
5320 Vwrite_region_annotate_functions
= Qnil
;
5322 DEFVAR_LISP ("write-region-annotations-so-far",
5323 &Vwrite_region_annotations_so_far
,
5324 "When an annotation function is called, this holds the previous annotations.\n\
5325 These are the annotations made by other annotation functions\n\
5326 that were already called. See also `write-region-annotate-functions'.");
5327 Vwrite_region_annotations_so_far
= Qnil
;
5329 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
5330 "A list of file name handlers that temporarily should not be used.\n\
5331 This applies only to the operation `inhibit-file-name-operation'.");
5332 Vinhibit_file_name_handlers
= Qnil
;
5334 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
5335 "The operation for which `inhibit-file-name-handlers' is applicable.");
5336 Vinhibit_file_name_operation
= Qnil
;
5338 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
5339 "File name in which we write a list of all auto save file names.\n\
5340 This variable is initialized automatically from `auto-save-list-file-prefix'\n\
5341 shortly after Emacs reads your `.emacs' file, if you have not yet given it\n\
5343 Vauto_save_list_file_name
= Qnil
;
5345 defsubr (&Sfind_file_name_handler
);
5346 defsubr (&Sfile_name_directory
);
5347 defsubr (&Sfile_name_nondirectory
);
5348 defsubr (&Sunhandled_file_name_directory
);
5349 defsubr (&Sfile_name_as_directory
);
5350 defsubr (&Sdirectory_file_name
);
5351 defsubr (&Smake_temp_name
);
5352 defsubr (&Sexpand_file_name
);
5353 defsubr (&Ssubstitute_in_file_name
);
5354 defsubr (&Scopy_file
);
5355 defsubr (&Smake_directory_internal
);
5356 defsubr (&Sdelete_directory
);
5357 defsubr (&Sdelete_file
);
5358 defsubr (&Srename_file
);
5359 defsubr (&Sadd_name_to_file
);
5361 defsubr (&Smake_symbolic_link
);
5362 #endif /* S_IFLNK */
5364 defsubr (&Sdefine_logical_name
);
5367 defsubr (&Ssysnetunam
);
5368 #endif /* HPUX_NET */
5369 defsubr (&Sfile_name_absolute_p
);
5370 defsubr (&Sfile_exists_p
);
5371 defsubr (&Sfile_executable_p
);
5372 defsubr (&Sfile_readable_p
);
5373 defsubr (&Sfile_writable_p
);
5374 defsubr (&Saccess_file
);
5375 defsubr (&Sfile_symlink_p
);
5376 defsubr (&Sfile_directory_p
);
5377 defsubr (&Sfile_accessible_directory_p
);
5378 defsubr (&Sfile_regular_p
);
5379 defsubr (&Sfile_modes
);
5380 defsubr (&Sset_file_modes
);
5381 defsubr (&Sset_default_file_modes
);
5382 defsubr (&Sdefault_file_modes
);
5383 defsubr (&Sfile_newer_than_file_p
);
5384 defsubr (&Sinsert_file_contents
);
5385 defsubr (&Swrite_region
);
5386 defsubr (&Scar_less_than_car
);
5387 defsubr (&Sverify_visited_file_modtime
);
5388 defsubr (&Sclear_visited_file_modtime
);
5389 defsubr (&Svisited_file_modtime
);
5390 defsubr (&Sset_visited_file_modtime
);
5391 defsubr (&Sdo_auto_save
);
5392 defsubr (&Sset_buffer_auto_saved
);
5393 defsubr (&Sclear_buffer_auto_save_failure
);
5394 defsubr (&Srecent_auto_save_p
);
5396 defsubr (&Sread_file_name_internal
);
5397 defsubr (&Sread_file_name
);
5400 defsubr (&Sunix_sync
);