1 /* File IO for GNU Emacs.
2 Copyright (C) 1985,86,87,88,93,94,95,96,1997 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
23 #if defined (USG5) || defined (BSD_SYSTEM) || defined (LINUX)
28 #include <sys/types.h>
35 #if !defined (S_ISLNK) && defined (S_IFLNK)
36 # define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
39 #if !defined (S_ISFIFO) && defined (S_IFIFO)
40 # define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO)
43 #if !defined (S_ISREG) && defined (S_IFREG)
44 # define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
55 #include <sys/param.h>
77 extern char *strerror ();
94 #include "intervals.h"
105 #endif /* not WINDOWSNT */
108 #define CORRECT_DIR_SEPS(s) \
109 do { if ('/' == DIRECTORY_SEP) dostounix_filename (s); \
110 else unixtodos_filename (s); \
112 /* On Windows, drive letters must be alphabetic - on DOS, the Netware
113 redirector allows the six letters between 'Z' and 'a' as well. */
115 #define IS_DRIVE(x) ((x) >= 'A' && (x) <= 'z')
118 #define IS_DRIVE(x) isalpha (x)
120 /* Need to lower-case the drive letter, or else expanded
121 filenames will sometimes compare inequal, because
122 `expand-file-name' doesn't always down-case the drive letter. */
123 #define DRIVE_LETTER(x) (tolower (x))
152 #define min(a, b) ((a) < (b) ? (a) : (b))
153 #define max(a, b) ((a) > (b) ? (a) : (b))
155 /* Encode the file name NAME using the specified coding system
156 for file names, if any. */
157 #define ENCODE_FILE(name) \
158 (! NILP (Vfile_name_coding_system) \
159 && XFASTINT (Vfile_name_coding_system) != 0 \
160 ? Fencode_coding_string (name, Vfile_name_coding_system, Qt) \
163 /* Nonzero during writing of auto-save files */
166 /* Set by auto_save_1 to mode of original file so Fwrite_region will create
167 a new file with the same mode as the original */
168 int auto_save_mode_bits
;
170 /* Coding system for file names, or nil if none. */
171 Lisp_Object Vfile_name_coding_system
;
173 /* Alist of elements (REGEXP . HANDLER) for file names
174 whose I/O is done with a special handler. */
175 Lisp_Object Vfile_name_handler_alist
;
177 /* Format for auto-save files */
178 Lisp_Object Vauto_save_file_format
;
180 /* Lisp functions for translating file formats */
181 Lisp_Object Qformat_decode
, Qformat_annotate_function
;
183 /* Function to be called to decide a coding system of a reading file. */
184 Lisp_Object Vset_auto_coding_function
;
186 /* Functions to be called to process text properties in inserted file. */
187 Lisp_Object Vafter_insert_file_functions
;
189 /* Functions to be called to create text property annotations for file. */
190 Lisp_Object Vwrite_region_annotate_functions
;
192 /* During build_annotations, each time an annotation function is called,
193 this holds the annotations made by the previous functions. */
194 Lisp_Object Vwrite_region_annotations_so_far
;
196 /* File name in which we write a list of all our auto save files. */
197 Lisp_Object Vauto_save_list_file_name
;
199 /* Nonzero means, when reading a filename in the minibuffer,
200 start out by inserting the default directory into the minibuffer. */
201 int insert_default_directory
;
203 /* On VMS, nonzero means write new files with record format stmlf.
204 Zero means use var format. */
207 /* On NT, specifies the directory separator character, used (eg.) when
208 expanding file names. This can be bound to / or \. */
209 Lisp_Object Vdirectory_sep_char
;
211 extern Lisp_Object Vuser_login_name
;
213 extern int minibuf_level
;
215 extern int minibuffer_auto_raise
;
217 /* These variables describe handlers that have "already" had a chance
218 to handle the current operation.
220 Vinhibit_file_name_handlers is a list of file name handlers.
221 Vinhibit_file_name_operation is the operation being handled.
222 If we try to handle that operation, we ignore those handlers. */
224 static Lisp_Object Vinhibit_file_name_handlers
;
225 static Lisp_Object Vinhibit_file_name_operation
;
227 Lisp_Object Qfile_error
, Qfile_already_exists
, Qfile_date_error
;
229 Lisp_Object Qfile_name_history
;
231 Lisp_Object Qcar_less_than_car
;
233 static int a_write
P_ ((int, char *, int, int,
234 Lisp_Object
, struct coding_system
*));
235 static int e_write
P_ ((int, char *, int, struct coding_system
*));
238 report_file_error (string
, data
)
242 Lisp_Object errstring
;
244 errstring
= build_string (strerror (errno
));
246 /* System error messages are capitalized. Downcase the initial
247 unless it is followed by a slash. */
248 if (XSTRING (errstring
)->data
[1] != '/')
249 XSTRING (errstring
)->data
[0] = DOWNCASE (XSTRING (errstring
)->data
[0]);
252 Fsignal (Qfile_error
,
253 Fcons (build_string (string
), Fcons (errstring
, data
)));
257 close_file_unwind (fd
)
260 close (XFASTINT (fd
));
264 /* Restore point, having saved it as a marker. */
267 restore_point_unwind (location
)
268 Lisp_Object location
;
270 Fgoto_char (location
);
271 Fset_marker (location
, Qnil
, Qnil
);
275 Lisp_Object Qexpand_file_name
;
276 Lisp_Object Qsubstitute_in_file_name
;
277 Lisp_Object Qdirectory_file_name
;
278 Lisp_Object Qfile_name_directory
;
279 Lisp_Object Qfile_name_nondirectory
;
280 Lisp_Object Qunhandled_file_name_directory
;
281 Lisp_Object Qfile_name_as_directory
;
282 Lisp_Object Qcopy_file
;
283 Lisp_Object Qmake_directory_internal
;
284 Lisp_Object Qdelete_directory
;
285 Lisp_Object Qdelete_file
;
286 Lisp_Object Qrename_file
;
287 Lisp_Object Qadd_name_to_file
;
288 Lisp_Object Qmake_symbolic_link
;
289 Lisp_Object Qfile_exists_p
;
290 Lisp_Object Qfile_executable_p
;
291 Lisp_Object Qfile_readable_p
;
292 Lisp_Object Qfile_writable_p
;
293 Lisp_Object Qfile_symlink_p
;
294 Lisp_Object Qaccess_file
;
295 Lisp_Object Qfile_directory_p
;
296 Lisp_Object Qfile_regular_p
;
297 Lisp_Object Qfile_accessible_directory_p
;
298 Lisp_Object Qfile_modes
;
299 Lisp_Object Qset_file_modes
;
300 Lisp_Object Qfile_newer_than_file_p
;
301 Lisp_Object Qinsert_file_contents
;
302 Lisp_Object Qwrite_region
;
303 Lisp_Object Qverify_visited_file_modtime
;
304 Lisp_Object Qset_visited_file_modtime
;
306 DEFUN ("find-file-name-handler", Ffind_file_name_handler
, Sfind_file_name_handler
, 2, 2, 0,
307 "Return FILENAME's handler function for OPERATION, if it has one.\n\
308 Otherwise, return nil.\n\
309 A file name is handled if one of the regular expressions in\n\
310 `file-name-handler-alist' matches it.\n\n\
311 If OPERATION equals `inhibit-file-name-operation', then we ignore\n\
312 any handlers that are members of `inhibit-file-name-handlers',\n\
313 but we still do run any other handlers. This lets handlers\n\
314 use the standard functions without calling themselves recursively.")
315 (filename
, operation
)
316 Lisp_Object filename
, operation
;
318 /* This function must not munge the match data. */
319 Lisp_Object chain
, inhibited_handlers
;
321 CHECK_STRING (filename
, 0);
323 if (EQ (operation
, Vinhibit_file_name_operation
))
324 inhibited_handlers
= Vinhibit_file_name_handlers
;
326 inhibited_handlers
= Qnil
;
328 for (chain
= Vfile_name_handler_alist
; CONSP (chain
);
329 chain
= XCONS (chain
)->cdr
)
332 elt
= XCONS (chain
)->car
;
336 string
= XCONS (elt
)->car
;
337 if (STRINGP (string
) && fast_string_match (string
, filename
) >= 0)
339 Lisp_Object handler
, tem
;
341 handler
= XCONS (elt
)->cdr
;
342 tem
= Fmemq (handler
, inhibited_handlers
);
353 DEFUN ("file-name-directory", Ffile_name_directory
, Sfile_name_directory
,
355 "Return the directory component in file name FILENAME.\n\
356 Return nil if FILENAME does not include a directory.\n\
357 Otherwise return a directory spec.\n\
358 Given a Unix syntax file name, returns a string ending in slash;\n\
359 on VMS, perhaps instead a string ending in `:', `]' or `>'.")
361 Lisp_Object filename
;
363 register unsigned char *beg
;
364 register unsigned char *p
;
367 CHECK_STRING (filename
, 0);
369 /* If the file name has special constructs in it,
370 call the corresponding file handler. */
371 handler
= Ffind_file_name_handler (filename
, Qfile_name_directory
);
373 return call2 (handler
, Qfile_name_directory
, filename
);
375 #ifdef FILE_SYSTEM_CASE
376 filename
= FILE_SYSTEM_CASE (filename
);
378 beg
= XSTRING (filename
)->data
;
380 beg
= strcpy (alloca (strlen (beg
) + 1), beg
);
382 p
= beg
+ XSTRING (filename
)->size
;
384 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
386 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
389 /* only recognise drive specifier at beginning */
390 && !(p
[-1] == ':' && p
== beg
+ 2)
397 /* Expansion of "c:" to drive and default directory. */
398 if (p
== beg
+ 2 && beg
[1] == ':')
400 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
401 unsigned char *res
= alloca (MAXPATHLEN
+ 1);
402 if (getdefdir (toupper (*beg
) - 'A' + 1, res
))
404 if (!IS_DIRECTORY_SEP (res
[strlen (res
) - 1]))
407 p
= beg
+ strlen (beg
);
410 CORRECT_DIR_SEPS (beg
);
412 return make_string (beg
, p
- beg
);
415 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory
, Sfile_name_nondirectory
,
417 "Return file name FILENAME sans its directory.\n\
418 For example, in a Unix-syntax file name,\n\
419 this is everything after the last slash,\n\
420 or the entire name if it contains no slash.")
422 Lisp_Object filename
;
424 register unsigned char *beg
, *p
, *end
;
427 CHECK_STRING (filename
, 0);
429 /* If the file name has special constructs in it,
430 call the corresponding file handler. */
431 handler
= Ffind_file_name_handler (filename
, Qfile_name_nondirectory
);
433 return call2 (handler
, Qfile_name_nondirectory
, filename
);
435 beg
= XSTRING (filename
)->data
;
436 end
= p
= beg
+ XSTRING (filename
)->size
;
438 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
440 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
443 /* only recognise drive specifier at beginning */
444 && !(p
[-1] == ':' && p
== beg
+ 2)
448 return make_string (p
, end
- p
);
451 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory
, Sunhandled_file_name_directory
, 1, 1, 0,
452 "Return a directly usable directory name somehow associated with FILENAME.\n\
453 A `directly usable' directory name is one that may be used without the\n\
454 intervention of any file handler.\n\
455 If FILENAME is a directly usable file itself, return\n\
456 \(file-name-directory FILENAME).\n\
457 The `call-process' and `start-process' functions use this function to\n\
458 get a current directory to run processes in.")
460 Lisp_Object filename
;
464 /* If the file name has special constructs in it,
465 call the corresponding file handler. */
466 handler
= Ffind_file_name_handler (filename
, Qunhandled_file_name_directory
);
468 return call2 (handler
, Qunhandled_file_name_directory
, filename
);
470 return Ffile_name_directory (filename
);
475 file_name_as_directory (out
, in
)
478 int size
= strlen (in
) - 1;
483 /* Is it already a directory string? */
484 if (in
[size
] == ':' || in
[size
] == ']' || in
[size
] == '>')
486 /* Is it a VMS directory file name? If so, hack VMS syntax. */
487 else if (! index (in
, '/')
488 && ((size
> 3 && ! strcmp (&in
[size
- 3], ".DIR"))
489 || (size
> 3 && ! strcmp (&in
[size
- 3], ".dir"))
490 || (size
> 5 && (! strncmp (&in
[size
- 5], ".DIR", 4)
491 || ! strncmp (&in
[size
- 5], ".dir", 4))
492 && (in
[size
- 1] == '.' || in
[size
- 1] == ';')
493 && in
[size
] == '1')))
495 register char *p
, *dot
;
499 dir:x.dir --> dir:[x]
500 dir:[x]y.dir --> dir:[x.y] */
502 while (p
!= in
&& *p
!= ':' && *p
!= '>' && *p
!= ']') p
--;
505 strncpy (out
, in
, p
- in
);
524 dot
= index (p
, '.');
527 /* blindly remove any extension */
528 size
= strlen (out
) + (dot
- p
);
529 strncat (out
, p
, dot
- p
);
540 /* For Unix syntax, Append a slash if necessary */
541 if (!IS_DIRECTORY_SEP (out
[size
]))
543 out
[size
+ 1] = DIRECTORY_SEP
;
544 out
[size
+ 2] = '\0';
547 CORRECT_DIR_SEPS (out
);
553 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
554 Sfile_name_as_directory
, 1, 1, 0,
555 "Return a string representing file FILENAME interpreted as a directory.\n\
556 This operation exists because a directory is also a file, but its name as\n\
557 a directory is different from its name as a file.\n\
558 The result can be used as the value of `default-directory'\n\
559 or passed as second argument to `expand-file-name'.\n\
560 For a Unix-syntax file name, just appends a slash.\n\
561 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
568 CHECK_STRING (file
, 0);
572 /* If the file name has special constructs in it,
573 call the corresponding file handler. */
574 handler
= Ffind_file_name_handler (file
, Qfile_name_as_directory
);
576 return call2 (handler
, Qfile_name_as_directory
, file
);
578 buf
= (char *) alloca (XSTRING (file
)->size
+ 10);
579 return build_string (file_name_as_directory (buf
, XSTRING (file
)->data
));
583 * Convert from directory name to filename.
585 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
586 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
587 * On UNIX, it's simple: just make sure there isn't a terminating /
589 * Value is nonzero if the string output is different from the input.
592 directory_file_name (src
, dst
)
600 struct FAB fab
= cc$rms_fab
;
601 struct NAM nam
= cc$rms_nam
;
602 char esa
[NAM$C_MAXRSS
];
607 if (! index (src
, '/')
608 && (src
[slen
- 1] == ']'
609 || src
[slen
- 1] == ':'
610 || src
[slen
- 1] == '>'))
612 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
614 fab
.fab$b_fns
= slen
;
615 fab
.fab$l_nam
= &nam
;
616 fab
.fab$l_fop
= FAB$M_NAM
;
619 nam
.nam$b_ess
= sizeof esa
;
620 nam
.nam$b_nop
|= NAM$M_SYNCHK
;
622 /* We call SYS$PARSE to handle such things as [--] for us. */
623 if (SYS$
PARSE (&fab
, 0, 0) == RMS$_NORMAL
)
625 slen
= nam
.nam$b_esl
;
626 if (esa
[slen
- 1] == ';' && esa
[slen
- 2] == '.')
631 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
633 /* what about when we have logical_name:???? */
634 if (src
[slen
- 1] == ':')
635 { /* Xlate logical name and see what we get */
636 ptr
= strcpy (dst
, src
); /* upper case for getenv */
639 if ('a' <= *ptr
&& *ptr
<= 'z')
643 dst
[slen
- 1] = 0; /* remove colon */
644 if (!(src
= egetenv (dst
)))
646 /* should we jump to the beginning of this procedure?
647 Good points: allows us to use logical names that xlate
649 Bad points: can be a problem if we just translated to a device
651 For now, I'll punt and always expect VMS names, and hope for
654 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
655 { /* no recursion here! */
661 { /* not a directory spec */
666 bracket
= src
[slen
- 1];
668 /* If bracket is ']' or '>', bracket - 2 is the corresponding
670 ptr
= index (src
, bracket
- 2);
672 { /* no opening bracket */
676 if (!(rptr
= rindex (src
, '.')))
679 strncpy (dst
, src
, slen
);
683 dst
[slen
++] = bracket
;
688 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
689 then translate the device and recurse. */
690 if (dst
[slen
- 1] == ':'
691 && dst
[slen
- 2] != ':' /* skip decnet nodes */
692 && strcmp (src
+ slen
, "[000000]") == 0)
694 dst
[slen
- 1] = '\0';
695 if ((ptr
= egetenv (dst
))
696 && (rlen
= strlen (ptr
) - 1) > 0
697 && (ptr
[rlen
] == ']' || ptr
[rlen
] == '>')
698 && ptr
[rlen
- 1] == '.')
700 char * buf
= (char *) alloca (strlen (ptr
) + 1);
704 return directory_file_name (buf
, dst
);
709 strcat (dst
, "[000000]");
713 rlen
= strlen (rptr
) - 1;
714 strncat (dst
, rptr
, rlen
);
715 dst
[slen
+ rlen
] = '\0';
716 strcat (dst
, ".DIR.1");
720 /* Process as Unix format: just remove any final slash.
721 But leave "/" unchanged; do not change it to "". */
724 /* Handle // as root for apollo's. */
725 if ((slen
> 2 && dst
[slen
- 1] == '/')
726 || (slen
> 1 && dst
[0] != '/' && dst
[slen
- 1] == '/'))
730 && IS_DIRECTORY_SEP (dst
[slen
- 1])
732 && !IS_ANY_SEP (dst
[slen
- 2])
738 CORRECT_DIR_SEPS (dst
);
743 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
745 "Returns the file name of the directory named DIRECTORY.\n\
746 This is the name of the file that holds the data for the directory DIRECTORY.\n\
747 This operation exists because a directory is also a file, but its name as\n\
748 a directory is different from its name as a file.\n\
749 In Unix-syntax, this function just removes the final slash.\n\
750 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
751 it returns a file name such as \"[X]Y.DIR.1\".")
753 Lisp_Object directory
;
758 CHECK_STRING (directory
, 0);
760 if (NILP (directory
))
763 /* If the file name has special constructs in it,
764 call the corresponding file handler. */
765 handler
= Ffind_file_name_handler (directory
, Qdirectory_file_name
);
767 return call2 (handler
, Qdirectory_file_name
, directory
);
770 /* 20 extra chars is insufficient for VMS, since we might perform a
771 logical name translation. an equivalence string can be up to 255
772 chars long, so grab that much extra space... - sss */
773 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20 + 255);
775 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20);
777 directory_file_name (XSTRING (directory
)->data
, buf
);
778 return build_string (buf
);
781 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
782 "Generate temporary file name (string) starting with PREFIX (a string).\n\
783 The Emacs process number forms part of the result,\n\
784 so there is no danger of generating a name being used by another process.\n\
785 In addition, this function makes an attempt to choose a name\n\
786 which has no existing file.")
792 /* Don't use too many characters of the restricted 8+3 DOS
794 val
= concat2 (prefix
, build_string ("a.XXX"));
796 val
= concat2 (prefix
, build_string ("XXXXXX"));
798 mktemp (XSTRING (val
)->data
);
800 CORRECT_DIR_SEPS (XSTRING (val
)->data
);
805 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
806 "Convert filename NAME to absolute, and canonicalize it.\n\
807 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative\n\
808 (does not start with slash); if DEFAULT-DIRECTORY is nil or missing,\n\
809 the current buffer's value of default-directory is used.\n\
810 File name components that are `.' are removed, and \n\
811 so are file name components followed by `..', along with the `..' itself;\n\
812 note that these simplifications are done without checking the resulting\n\
813 file names in the file system.\n\
814 An initial `~/' expands to your home directory.\n\
815 An initial `~USER/' expands to USER's home directory.\n\
816 See also the function `substitute-in-file-name'.")
817 (name
, default_directory
)
818 Lisp_Object name
, default_directory
;
822 register unsigned char *newdir
, *p
, *o
;
824 unsigned char *target
;
827 unsigned char * colon
= 0;
828 unsigned char * close
= 0;
829 unsigned char * slash
= 0;
830 unsigned char * brack
= 0;
831 int lbrack
= 0, rbrack
= 0;
836 int collapse_newdir
= 1;
841 CHECK_STRING (name
, 0);
843 /* If the file name has special constructs in it,
844 call the corresponding file handler. */
845 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
847 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
849 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
850 if (NILP (default_directory
))
851 default_directory
= current_buffer
->directory
;
852 if (! STRINGP (default_directory
))
853 default_directory
= build_string ("/");
855 if (!NILP (default_directory
))
857 handler
= Ffind_file_name_handler (default_directory
, Qexpand_file_name
);
859 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
862 o
= XSTRING (default_directory
)->data
;
864 /* Make sure DEFAULT_DIRECTORY is properly expanded.
865 It would be better to do this down below where we actually use
866 default_directory. Unfortunately, calling Fexpand_file_name recursively
867 could invoke GC, and the strings might be relocated. This would
868 be annoying because we have pointers into strings lying around
869 that would need adjusting, and people would add new pointers to
870 the code and forget to adjust them, resulting in intermittent bugs.
871 Putting this call here avoids all that crud.
873 The EQ test avoids infinite recursion. */
874 if (! NILP (default_directory
) && !EQ (default_directory
, name
)
875 /* Save time in some common cases - as long as default_directory
876 is not relative, it can be canonicalized with name below (if it
877 is needed at all) without requiring it to be expanded now. */
879 /* Detect MSDOS file names with drive specifiers. */
880 && ! (IS_DRIVE (o
[0]) && (IS_DEVICE_SEP (o
[1]) && IS_DIRECTORY_SEP (o
[2])))
882 /* Detect Windows file names in UNC format. */
883 && ! (IS_DIRECTORY_SEP (o
[0]) && IS_DIRECTORY_SEP (o
[1]))
885 #else /* not DOS_NT */
886 /* Detect Unix absolute file names (/... alone is not absolute on
888 && ! (IS_DIRECTORY_SEP (o
[0]))
889 #endif /* not DOS_NT */
895 default_directory
= Fexpand_file_name (default_directory
, Qnil
);
900 /* Filenames on VMS are always upper case. */
901 name
= Fupcase (name
);
903 #ifdef FILE_SYSTEM_CASE
904 name
= FILE_SYSTEM_CASE (name
);
907 nm
= XSTRING (name
)->data
;
910 /* We will force directory separators to be either all \ or /, so make
911 a local copy to modify, even if there ends up being no change. */
912 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
914 /* Find and remove drive specifier if present; this makes nm absolute
915 even if the rest of the name appears to be relative. */
917 unsigned char *colon
= rindex (nm
, ':');
920 /* Only recognize colon as part of drive specifier if there is a
921 single alphabetic character preceeding the colon (and if the
922 character before the drive letter, if present, is a directory
923 separator); this is to support the remote system syntax used by
924 ange-ftp, and the "po:username" syntax for POP mailboxes. */
928 else if (IS_DRIVE (colon
[-1])
929 && (colon
== nm
+ 1 || IS_DIRECTORY_SEP (colon
[-2])))
936 while (--colon
>= nm
)
943 /* If we see "c://somedir", we want to strip the first slash after the
944 colon when stripping the drive letter. Otherwise, this expands to
946 if (drive
&& IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
948 #endif /* WINDOWSNT */
952 /* Discard any previous drive specifier if nm is now in UNC format. */
953 if (IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
959 /* If nm is absolute, look for /./ or /../ sequences; if none are
960 found, we can probably return right away. We will avoid allocating
961 a new string if name is already fully expanded. */
963 IS_DIRECTORY_SEP (nm
[0])
968 && (drive
|| IS_DIRECTORY_SEP (nm
[1]))
975 /* If it turns out that the filename we want to return is just a
976 suffix of FILENAME, we don't need to go through and edit
977 things; we just need to construct a new string using data
978 starting at the middle of FILENAME. If we set lose to a
979 non-zero value, that means we've discovered that we can't do
986 /* Since we know the name is absolute, we can assume that each
987 element starts with a "/". */
989 /* "." and ".." are hairy. */
990 if (IS_DIRECTORY_SEP (p
[0])
992 && (IS_DIRECTORY_SEP (p
[2])
994 || (p
[2] == '.' && (IS_DIRECTORY_SEP (p
[3])
1001 /* if dev:[dir]/, move nm to / */
1002 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1003 nm
= (brack
? brack
+ 1 : colon
+ 1);
1004 lbrack
= rbrack
= 0;
1012 /* VMS pre V4.4,convert '-'s in filenames. */
1013 if (lbrack
== rbrack
)
1015 if (dots
< 2) /* this is to allow negative version numbers */
1020 if (lbrack
> rbrack
&&
1021 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1022 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1028 /* count open brackets, reset close bracket pointer */
1029 if (p
[0] == '[' || p
[0] == '<')
1030 lbrack
++, brack
= 0;
1031 /* count close brackets, set close bracket pointer */
1032 if (p
[0] == ']' || p
[0] == '>')
1033 rbrack
++, brack
= p
;
1034 /* detect ][ or >< */
1035 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1037 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1038 nm
= p
+ 1, lose
= 1;
1039 if (p
[0] == ':' && (colon
|| slash
))
1040 /* if dev1:[dir]dev2:, move nm to dev2: */
1046 /* if /name/dev:, move nm to dev: */
1049 /* if node::dev:, move colon following dev */
1050 else if (colon
&& colon
[-1] == ':')
1052 /* if dev1:dev2:, move nm to dev2: */
1053 else if (colon
&& colon
[-1] != ':')
1058 if (p
[0] == ':' && !colon
)
1064 if (lbrack
== rbrack
)
1067 else if (p
[0] == '.')
1075 if (index (nm
, '/'))
1076 return build_string (sys_translate_unix (nm
));
1079 /* Make sure directories are all separated with / or \ as
1080 desired, but avoid allocation of a new string when not
1082 CORRECT_DIR_SEPS (nm
);
1084 if (IS_DIRECTORY_SEP (nm
[1]))
1086 if (strcmp (nm
, XSTRING (name
)->data
) != 0)
1087 name
= build_string (nm
);
1091 /* drive must be set, so this is okay */
1092 if (strcmp (nm
- 2, XSTRING (name
)->data
) != 0)
1094 name
= make_string (nm
- 2, p
- nm
+ 2);
1095 XSTRING (name
)->data
[0] = DRIVE_LETTER (drive
);
1096 XSTRING (name
)->data
[1] = ':';
1099 #else /* not DOS_NT */
1100 if (nm
== XSTRING (name
)->data
)
1102 return build_string (nm
);
1103 #endif /* not DOS_NT */
1107 /* At this point, nm might or might not be an absolute file name. We
1108 need to expand ~ or ~user if present, otherwise prefix nm with
1109 default_directory if nm is not absolute, and finally collapse /./
1110 and /foo/../ sequences.
1112 We set newdir to be the appropriate prefix if one is needed:
1113 - the relevant user directory if nm starts with ~ or ~user
1114 - the specified drive's working dir (DOS/NT only) if nm does not
1116 - the value of default_directory.
1118 Note that these prefixes are not guaranteed to be absolute (except
1119 for the working dir of a drive). Therefore, to ensure we always
1120 return an absolute name, if the final prefix is not absolute we
1121 append it to the current working directory. */
1125 if (nm
[0] == '~') /* prefix ~ */
1127 if (IS_DIRECTORY_SEP (nm
[1])
1131 || nm
[1] == 0) /* ~ by itself */
1133 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1134 newdir
= (unsigned char *) "";
1137 collapse_newdir
= 0;
1140 nm
++; /* Don't leave the slash in nm. */
1143 else /* ~user/filename */
1145 for (p
= nm
; *p
&& (!IS_DIRECTORY_SEP (*p
)
1150 o
= (unsigned char *) alloca (p
- nm
+ 1);
1151 bcopy ((char *) nm
, o
, p
- nm
);
1154 pw
= (struct passwd
*) getpwnam (o
+ 1);
1157 newdir
= (unsigned char *) pw
-> pw_dir
;
1159 nm
= p
+ 1; /* skip the terminator */
1163 collapse_newdir
= 0;
1168 /* If we don't find a user of that name, leave the name
1169 unchanged; don't move nm forward to p. */
1174 /* On DOS and Windows, nm is absolute if a drive name was specified;
1175 use the drive's current directory as the prefix if needed. */
1176 if (!newdir
&& drive
)
1178 /* Get default directory if needed to make nm absolute. */
1179 if (!IS_DIRECTORY_SEP (nm
[0]))
1181 newdir
= alloca (MAXPATHLEN
+ 1);
1182 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1187 /* Either nm starts with /, or drive isn't mounted. */
1188 newdir
= alloca (4);
1189 newdir
[0] = DRIVE_LETTER (drive
);
1197 /* Finally, if no prefix has been specified and nm is not absolute,
1198 then it must be expanded relative to default_directory. */
1202 /* /... alone is not absolute on DOS and Windows. */
1203 && !IS_DIRECTORY_SEP (nm
[0])
1206 && !(IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1213 newdir
= XSTRING (default_directory
)->data
;
1219 /* First ensure newdir is an absolute name. */
1221 /* Detect MSDOS file names with drive specifiers. */
1222 ! (IS_DRIVE (newdir
[0])
1223 && IS_DEVICE_SEP (newdir
[1]) && IS_DIRECTORY_SEP (newdir
[2]))
1225 /* Detect Windows file names in UNC format. */
1226 && ! (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1230 /* Effectively, let newdir be (expand-file-name newdir cwd).
1231 Because of the admonition against calling expand-file-name
1232 when we have pointers into lisp strings, we accomplish this
1233 indirectly by prepending newdir to nm if necessary, and using
1234 cwd (or the wd of newdir's drive) as the new newdir. */
1236 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1241 if (!IS_DIRECTORY_SEP (nm
[0]))
1243 char * tmp
= alloca (strlen (newdir
) + strlen (nm
) + 2);
1244 file_name_as_directory (tmp
, newdir
);
1248 newdir
= alloca (MAXPATHLEN
+ 1);
1251 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1258 /* Strip off drive name from prefix, if present. */
1259 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1265 /* Keep only a prefix from newdir if nm starts with slash
1266 (//server/share for UNC, nothing otherwise). */
1267 if (IS_DIRECTORY_SEP (nm
[0]) && collapse_newdir
)
1270 if (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1272 newdir
= strcpy (alloca (strlen (newdir
) + 1), newdir
);
1274 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1276 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1288 /* Get rid of any slash at the end of newdir, unless newdir is
1289 just // (an incomplete UNC name). */
1290 length
= strlen (newdir
);
1291 if (length
> 0 && IS_DIRECTORY_SEP (newdir
[length
- 1])
1293 && !(length
== 2 && IS_DIRECTORY_SEP (newdir
[0]))
1297 unsigned char *temp
= (unsigned char *) alloca (length
);
1298 bcopy (newdir
, temp
, length
- 1);
1299 temp
[length
- 1] = 0;
1307 /* Now concatenate the directory and name to new space in the stack frame */
1308 tlen
+= strlen (nm
) + 1;
1310 /* Add reserved space for drive name. (The Microsoft x86 compiler
1311 produces incorrect code if the following two lines are combined.) */
1312 target
= (unsigned char *) alloca (tlen
+ 2);
1314 #else /* not DOS_NT */
1315 target
= (unsigned char *) alloca (tlen
);
1316 #endif /* not DOS_NT */
1322 if (nm
[0] == 0 || IS_DIRECTORY_SEP (nm
[0]))
1323 strcpy (target
, newdir
);
1326 file_name_as_directory (target
, newdir
);
1329 strcat (target
, nm
);
1331 if (index (target
, '/'))
1332 strcpy (target
, sys_translate_unix (target
));
1335 /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */
1337 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1345 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1351 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1352 /* brackets are offset from each other by 2 */
1355 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1356 /* convert [foo][bar] to [bar] */
1357 while (o
[-1] != '[' && o
[-1] != '<')
1359 else if (*p
== '-' && *o
!= '.')
1362 else if (p
[0] == '-' && o
[-1] == '.' &&
1363 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1364 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1368 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1369 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1371 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1373 /* else [foo.-] ==> [-] */
1379 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1380 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1386 if (!IS_DIRECTORY_SEP (*p
))
1390 else if (IS_DIRECTORY_SEP (p
[0])
1392 && (IS_DIRECTORY_SEP (p
[2])
1395 /* If "/." is the entire filename, keep the "/". Otherwise,
1396 just delete the whole "/.". */
1397 if (o
== target
&& p
[2] == '\0')
1401 else if (IS_DIRECTORY_SEP (p
[0]) && p
[1] == '.' && p
[2] == '.'
1402 /* `/../' is the "superroot" on certain file systems. */
1404 && (IS_DIRECTORY_SEP (p
[3]) || p
[3] == 0))
1406 while (o
!= target
&& (--o
) && !IS_DIRECTORY_SEP (*o
))
1408 /* Keep initial / only if this is the whole name. */
1409 if (o
== target
&& IS_ANY_SEP (*o
) && p
[3] == 0)
1417 #endif /* not VMS */
1421 /* At last, set drive name. */
1423 /* Except for network file name. */
1424 if (!(IS_DIRECTORY_SEP (target
[0]) && IS_DIRECTORY_SEP (target
[1])))
1425 #endif /* WINDOWSNT */
1427 if (!drive
) abort ();
1429 target
[0] = DRIVE_LETTER (drive
);
1432 CORRECT_DIR_SEPS (target
);
1435 return make_string (target
, o
- target
);
1439 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'. */
1440 DEAFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
1441 "Convert FILENAME to absolute, and canonicalize it.\n\
1442 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1443 (does not start with slash); if DEFAULT is nil or missing,\n\
1444 the current buffer's value of default-directory is used.\n\
1445 Filenames containing `.' or `..' as components are simplified;\n\
1446 initial `~/' expands to your home directory.\n\
1447 See also the function `substitute-in-file-name'.")
1449 Lisp_Object name
, defalt
;
1453 register unsigned char *newdir
, *p
, *o
;
1455 unsigned char *target
;
1459 unsigned char * colon
= 0;
1460 unsigned char * close
= 0;
1461 unsigned char * slash
= 0;
1462 unsigned char * brack
= 0;
1463 int lbrack
= 0, rbrack
= 0;
1467 CHECK_STRING (name
, 0);
1470 /* Filenames on VMS are always upper case. */
1471 name
= Fupcase (name
);
1474 nm
= XSTRING (name
)->data
;
1476 /* If nm is absolute, flush ...// and detect /./ and /../.
1477 If no /./ or /../ we can return right away. */
1489 if (p
[0] == '/' && p
[1] == '/'
1491 /* // at start of filename is meaningful on Apollo system. */
1496 if (p
[0] == '/' && p
[1] == '~')
1497 nm
= p
+ 1, lose
= 1;
1498 if (p
[0] == '/' && p
[1] == '.'
1499 && (p
[2] == '/' || p
[2] == 0
1500 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1506 /* if dev:[dir]/, move nm to / */
1507 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1508 nm
= (brack
? brack
+ 1 : colon
+ 1);
1509 lbrack
= rbrack
= 0;
1517 /* VMS pre V4.4,convert '-'s in filenames. */
1518 if (lbrack
== rbrack
)
1520 if (dots
< 2) /* this is to allow negative version numbers */
1525 if (lbrack
> rbrack
&&
1526 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1527 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1533 /* count open brackets, reset close bracket pointer */
1534 if (p
[0] == '[' || p
[0] == '<')
1535 lbrack
++, brack
= 0;
1536 /* count close brackets, set close bracket pointer */
1537 if (p
[0] == ']' || p
[0] == '>')
1538 rbrack
++, brack
= p
;
1539 /* detect ][ or >< */
1540 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1542 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1543 nm
= p
+ 1, lose
= 1;
1544 if (p
[0] == ':' && (colon
|| slash
))
1545 /* if dev1:[dir]dev2:, move nm to dev2: */
1551 /* If /name/dev:, move nm to dev: */
1554 /* If node::dev:, move colon following dev */
1555 else if (colon
&& colon
[-1] == ':')
1557 /* If dev1:dev2:, move nm to dev2: */
1558 else if (colon
&& colon
[-1] != ':')
1563 if (p
[0] == ':' && !colon
)
1569 if (lbrack
== rbrack
)
1572 else if (p
[0] == '.')
1580 if (index (nm
, '/'))
1581 return build_string (sys_translate_unix (nm
));
1583 if (nm
== XSTRING (name
)->data
)
1585 return build_string (nm
);
1589 /* Now determine directory to start with and put it in NEWDIR */
1593 if (nm
[0] == '~') /* prefix ~ */
1598 || nm
[1] == 0)/* ~/filename */
1600 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1601 newdir
= (unsigned char *) "";
1604 nm
++; /* Don't leave the slash in nm. */
1607 else /* ~user/filename */
1609 /* Get past ~ to user */
1610 unsigned char *user
= nm
+ 1;
1611 /* Find end of name. */
1612 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1613 int len
= ptr
? ptr
- user
: strlen (user
);
1615 unsigned char *ptr1
= index (user
, ':');
1616 if (ptr1
!= 0 && ptr1
- user
< len
)
1619 /* Copy the user name into temp storage. */
1620 o
= (unsigned char *) alloca (len
+ 1);
1621 bcopy ((char *) user
, o
, len
);
1624 /* Look up the user name. */
1625 pw
= (struct passwd
*) getpwnam (o
+ 1);
1627 error ("\"%s\" isn't a registered user", o
+ 1);
1629 newdir
= (unsigned char *) pw
->pw_dir
;
1631 /* Discard the user name from NM. */
1638 #endif /* not VMS */
1642 defalt
= current_buffer
->directory
;
1643 CHECK_STRING (defalt
, 1);
1644 newdir
= XSTRING (defalt
)->data
;
1647 /* Now concatenate the directory and name to new space in the stack frame */
1649 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1650 target
= (unsigned char *) alloca (tlen
);
1656 if (nm
[0] == 0 || nm
[0] == '/')
1657 strcpy (target
, newdir
);
1660 file_name_as_directory (target
, newdir
);
1663 strcat (target
, nm
);
1665 if (index (target
, '/'))
1666 strcpy (target
, sys_translate_unix (target
));
1669 /* Now canonicalize by removing /. and /foo/.. if they appear */
1677 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1683 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1684 /* brackets are offset from each other by 2 */
1687 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1688 /* convert [foo][bar] to [bar] */
1689 while (o
[-1] != '[' && o
[-1] != '<')
1691 else if (*p
== '-' && *o
!= '.')
1694 else if (p
[0] == '-' && o
[-1] == '.' &&
1695 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1696 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1700 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1701 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1703 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1705 /* else [foo.-] ==> [-] */
1711 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1712 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1722 else if (!strncmp (p
, "//", 2)
1724 /* // at start of filename is meaningful in Apollo system. */
1732 else if (p
[0] == '/' && p
[1] == '.' &&
1733 (p
[2] == '/' || p
[2] == 0))
1735 else if (!strncmp (p
, "/..", 3)
1736 /* `/../' is the "superroot" on certain file systems. */
1738 && (p
[3] == '/' || p
[3] == 0))
1740 while (o
!= target
&& *--o
!= '/')
1743 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1747 if (o
== target
&& *o
== '/')
1755 #endif /* not VMS */
1758 return make_string (target
, o
- target
);
1762 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1763 Ssubstitute_in_file_name
, 1, 1, 0,
1764 "Substitute environment variables referred to in FILENAME.\n\
1765 `$FOO' where FOO is an environment variable name means to substitute\n\
1766 the value of that variable. The variable name should be terminated\n\
1767 with a character not a letter, digit or underscore; otherwise, enclose\n\
1768 the entire variable name in braces.\n\
1769 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1770 On VMS, `$' substitution is not done; this function does little and only\n\
1771 duplicates what `expand-file-name' does.")
1773 Lisp_Object filename
;
1777 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1778 unsigned char *target
;
1780 int substituted
= 0;
1782 Lisp_Object handler
;
1784 CHECK_STRING (filename
, 0);
1786 /* If the file name has special constructs in it,
1787 call the corresponding file handler. */
1788 handler
= Ffind_file_name_handler (filename
, Qsubstitute_in_file_name
);
1789 if (!NILP (handler
))
1790 return call2 (handler
, Qsubstitute_in_file_name
, filename
);
1792 nm
= XSTRING (filename
)->data
;
1794 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
1795 CORRECT_DIR_SEPS (nm
);
1796 substituted
= (strcmp (nm
, XSTRING (filename
)->data
) != 0);
1798 endp
= nm
+ XSTRING (filename
)->size
;
1800 /* If /~ or // appears, discard everything through first slash. */
1802 for (p
= nm
; p
!= endp
; p
++)
1805 #if defined (APOLLO) || defined (WINDOWSNT)
1806 /* // at start of file name is meaningful in Apollo and
1807 WindowsNT systems. */
1808 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != nm
)
1809 #else /* not (APOLLO || WINDOWSNT) */
1810 || IS_DIRECTORY_SEP (p
[0])
1811 #endif /* not (APOLLO || WINDOWSNT) */
1816 || p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>'
1818 || IS_DIRECTORY_SEP (p
[-1])))
1824 /* see comment in expand-file-name about drive specifiers */
1825 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
1826 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
1835 return build_string (nm
);
1838 /* See if any variables are substituted into the string
1839 and find the total length of their values in `total' */
1841 for (p
= nm
; p
!= endp
;)
1851 /* "$$" means a single "$" */
1860 while (p
!= endp
&& *p
!= '}') p
++;
1861 if (*p
!= '}') goto missingclose
;
1867 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1871 /* Copy out the variable name */
1872 target
= (unsigned char *) alloca (s
- o
+ 1);
1873 strncpy (target
, o
, s
- o
);
1876 strupr (target
); /* $home == $HOME etc. */
1879 /* Get variable value */
1880 o
= (unsigned char *) egetenv (target
);
1881 if (!o
) goto badvar
;
1882 total
+= strlen (o
);
1889 /* If substitution required, recopy the string and do it */
1890 /* Make space in stack frame for the new copy */
1891 xnm
= (unsigned char *) alloca (XSTRING (filename
)->size
+ total
+ 1);
1894 /* Copy the rest of the name through, replacing $ constructs with values */
1911 while (p
!= endp
&& *p
!= '}') p
++;
1912 if (*p
!= '}') goto missingclose
;
1918 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1922 /* Copy out the variable name */
1923 target
= (unsigned char *) alloca (s
- o
+ 1);
1924 strncpy (target
, o
, s
- o
);
1927 strupr (target
); /* $home == $HOME etc. */
1930 /* Get variable value */
1931 o
= (unsigned char *) egetenv (target
);
1941 /* If /~ or // appears, discard everything through first slash. */
1943 for (p
= xnm
; p
!= x
; p
++)
1945 #if defined (APOLLO) || defined (WINDOWSNT)
1946 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != xnm
)
1947 #else /* not (APOLLO || WINDOWSNT) */
1948 || IS_DIRECTORY_SEP (p
[0])
1949 #endif /* not (APOLLO || WINDOWSNT) */
1951 && p
!= xnm
&& IS_DIRECTORY_SEP (p
[-1]))
1954 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
1955 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
1959 return make_string (xnm
, x
- xnm
);
1962 error ("Bad format environment-variable substitution");
1964 error ("Missing \"}\" in environment-variable substitution");
1966 error ("Substituting nonexistent environment variable \"%s\"", target
);
1969 #endif /* not VMS */
1972 /* A slightly faster and more convenient way to get
1973 (directory-file-name (expand-file-name FOO)). */
1976 expand_and_dir_to_file (filename
, defdir
)
1977 Lisp_Object filename
, defdir
;
1979 register Lisp_Object absname
;
1981 absname
= Fexpand_file_name (filename
, defdir
);
1984 register int c
= XSTRING (absname
)->data
[XSTRING (absname
)->size
- 1];
1985 if (c
== ':' || c
== ']' || c
== '>')
1986 absname
= Fdirectory_file_name (absname
);
1989 /* Remove final slash, if any (unless this is the root dir).
1990 stat behaves differently depending! */
1991 if (XSTRING (absname
)->size
> 1
1992 && IS_DIRECTORY_SEP (XSTRING (absname
)->data
[XSTRING (absname
)->size
- 1])
1993 && !IS_DEVICE_SEP (XSTRING (absname
)->data
[XSTRING (absname
)->size
-2]))
1994 /* We cannot take shortcuts; they might be wrong for magic file names. */
1995 absname
= Fdirectory_file_name (absname
);
2000 /* Signal an error if the file ABSNAME already exists.
2001 If INTERACTIVE is nonzero, ask the user whether to proceed,
2002 and bypass the error if the user says to go ahead.
2003 QUERYSTRING is a name for the action that is being considered
2005 *STATPTR is used to store the stat information if the file exists.
2006 If the file does not exist, STATPTR->st_mode is set to 0. */
2009 barf_or_query_if_file_exists (absname
, querystring
, interactive
, statptr
)
2010 Lisp_Object absname
;
2011 unsigned char *querystring
;
2013 struct stat
*statptr
;
2015 register Lisp_Object tem
;
2016 struct stat statbuf
;
2017 struct gcpro gcpro1
;
2019 /* stat is a good way to tell whether the file exists,
2020 regardless of what access permissions it has. */
2021 if (stat (XSTRING (absname
)->data
, &statbuf
) >= 0)
2024 Fsignal (Qfile_already_exists
,
2025 Fcons (build_string ("File already exists"),
2026 Fcons (absname
, Qnil
)));
2028 tem
= do_yes_or_no_p (format1 ("File %s already exists; %s anyway? ",
2029 XSTRING (absname
)->data
, querystring
));
2032 Fsignal (Qfile_already_exists
,
2033 Fcons (build_string ("File already exists"),
2034 Fcons (absname
, Qnil
)));
2041 statptr
->st_mode
= 0;
2046 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
2047 "fCopy file: \nFCopy %s to file: \np\nP",
2048 "Copy FILE to NEWNAME. Both args must be strings.\n\
2049 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
2050 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
2051 A number as third arg means request confirmation if NEWNAME already exists.\n\
2052 This is what happens in interactive use with M-x.\n\
2053 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
2054 last-modified time as the old one. (This works on only some systems.)\n\
2055 A prefix arg makes KEEP-TIME non-nil.")
2056 (file
, newname
, ok_if_already_exists
, keep_date
)
2057 Lisp_Object file
, newname
, ok_if_already_exists
, keep_date
;
2060 char buf
[16 * 1024];
2061 struct stat st
, out_st
;
2062 Lisp_Object handler
;
2063 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2064 int count
= specpdl_ptr
- specpdl
;
2065 int input_file_statable_p
;
2066 Lisp_Object encoded_file
, encoded_newname
;
2068 encoded_file
= encoded_newname
= Qnil
;
2069 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2070 CHECK_STRING (file
, 0);
2071 CHECK_STRING (newname
, 1);
2073 file
= Fexpand_file_name (file
, Qnil
);
2074 newname
= Fexpand_file_name (newname
, Qnil
);
2076 /* If the input file name has special constructs in it,
2077 call the corresponding file handler. */
2078 handler
= Ffind_file_name_handler (file
, Qcopy_file
);
2079 /* Likewise for output file name. */
2081 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
2082 if (!NILP (handler
))
2083 RETURN_UNGCPRO (call5 (handler
, Qcopy_file
, file
, newname
,
2084 ok_if_already_exists
, keep_date
));
2086 encoded_file
= ENCODE_FILE (file
);
2087 encoded_newname
= ENCODE_FILE (newname
);
2089 if (NILP (ok_if_already_exists
)
2090 || INTEGERP (ok_if_already_exists
))
2091 barf_or_query_if_file_exists (encoded_newname
, "copy to it",
2092 INTEGERP (ok_if_already_exists
), &out_st
);
2093 else if (stat (XSTRING (encoded_newname
)->data
, &out_st
) < 0)
2096 ifd
= open (XSTRING (encoded_file
)->data
, O_RDONLY
);
2098 report_file_error ("Opening input file", Fcons (file
, Qnil
));
2100 record_unwind_protect (close_file_unwind
, make_number (ifd
));
2102 /* We can only copy regular files and symbolic links. Other files are not
2104 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
2106 #if !defined (MSDOS) || __DJGPP__ > 1
2107 if (out_st
.st_mode
!= 0
2108 && st
.st_dev
== out_st
.st_dev
&& st
.st_ino
== out_st
.st_ino
)
2111 report_file_error ("Input and output files are the same",
2112 Fcons (file
, Fcons (newname
, Qnil
)));
2116 #if defined (S_ISREG) && defined (S_ISLNK)
2117 if (input_file_statable_p
)
2119 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
2121 #if defined (EISDIR)
2122 /* Get a better looking error message. */
2125 report_file_error ("Non-regular file", Fcons (file
, Qnil
));
2128 #endif /* S_ISREG && S_ISLNK */
2131 /* Create the copy file with the same record format as the input file */
2132 ofd
= sys_creat (XSTRING (encoded_newname
)->data
, 0666, ifd
);
2135 /* System's default file type was set to binary by _fmode in emacs.c. */
2136 ofd
= creat (XSTRING (encoded_newname
)->data
, S_IREAD
| S_IWRITE
);
2137 #else /* not MSDOS */
2138 ofd
= creat (XSTRING (encoded_newname
)->data
, 0666);
2139 #endif /* not MSDOS */
2142 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
2144 record_unwind_protect (close_file_unwind
, make_number (ofd
));
2148 while ((n
= read (ifd
, buf
, sizeof buf
)) > 0)
2149 if (write (ofd
, buf
, n
) != n
)
2150 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2153 /* Closing the output clobbers the file times on some systems. */
2154 if (close (ofd
) < 0)
2155 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2157 if (input_file_statable_p
)
2159 if (!NILP (keep_date
))
2161 EMACS_TIME atime
, mtime
;
2162 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
2163 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
2164 if (set_file_times (XSTRING (encoded_newname
)->data
,
2166 Fsignal (Qfile_date_error
,
2167 Fcons (build_string ("Cannot set file date"),
2168 Fcons (newname
, Qnil
)));
2171 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2173 #if defined (__DJGPP__) && __DJGPP__ > 1
2174 /* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
2175 and if it can't, it tells so. Otherwise, under MSDOS we usually
2176 get only the READ bit, which will make the copied file read-only,
2177 so it's better not to chmod at all. */
2178 if ((_djstat_flags
& _STFAIL_WRITEBIT
) == 0)
2179 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2180 #endif /* DJGPP version 2 or newer */
2186 /* Discard the unwind protects. */
2187 specpdl_ptr
= specpdl
+ count
;
2193 DEFUN ("make-directory-internal", Fmake_directory_internal
,
2194 Smake_directory_internal
, 1, 1, 0,
2195 "Create a new directory named DIRECTORY.")
2197 Lisp_Object directory
;
2200 Lisp_Object handler
;
2201 Lisp_Object encoded_dir
;
2203 CHECK_STRING (directory
, 0);
2204 directory
= Fexpand_file_name (directory
, Qnil
);
2206 handler
= Ffind_file_name_handler (directory
, Qmake_directory_internal
);
2207 if (!NILP (handler
))
2208 return call2 (handler
, Qmake_directory_internal
, directory
);
2210 encoded_dir
= ENCODE_FILE (directory
);
2212 dir
= XSTRING (encoded_dir
)->data
;
2215 if (mkdir (dir
) != 0)
2217 if (mkdir (dir
, 0777) != 0)
2219 report_file_error ("Creating directory", Flist (1, &directory
));
2224 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
2225 "Delete the directory named DIRECTORY.")
2227 Lisp_Object directory
;
2230 Lisp_Object handler
;
2231 Lisp_Object encoded_dir
;
2233 CHECK_STRING (directory
, 0);
2234 directory
= Fdirectory_file_name (Fexpand_file_name (directory
, Qnil
));
2236 handler
= Ffind_file_name_handler (directory
, Qdelete_directory
);
2237 if (!NILP (handler
))
2238 return call2 (handler
, Qdelete_directory
, directory
);
2240 encoded_dir
= ENCODE_FILE (directory
);
2242 dir
= XSTRING (encoded_dir
)->data
;
2244 if (rmdir (dir
) != 0)
2245 report_file_error ("Removing directory", Flist (1, &directory
));
2250 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
2251 "Delete file named FILENAME.\n\
2252 If file has multiple names, it continues to exist with the other names.")
2254 Lisp_Object filename
;
2256 Lisp_Object handler
;
2257 Lisp_Object encoded_file
;
2259 CHECK_STRING (filename
, 0);
2260 filename
= Fexpand_file_name (filename
, Qnil
);
2262 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
2263 if (!NILP (handler
))
2264 return call2 (handler
, Qdelete_file
, filename
);
2266 encoded_file
= ENCODE_FILE (filename
);
2268 if (0 > unlink (XSTRING (encoded_file
)->data
))
2269 report_file_error ("Removing old name", Flist (1, &filename
));
2274 internal_delete_file_1 (ignore
)
2280 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */
2283 internal_delete_file (filename
)
2284 Lisp_Object filename
;
2286 return NILP (internal_condition_case_1 (Fdelete_file
, filename
,
2287 Qt
, internal_delete_file_1
));
2290 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
2291 "fRename file: \nFRename %s to file: \np",
2292 "Rename FILE as NEWNAME. Both args strings.\n\
2293 If file has names other than FILE, it continues to have those names.\n\
2294 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2295 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2296 A number as third arg means request confirmation if NEWNAME already exists.\n\
2297 This is what happens in interactive use with M-x.")
2298 (file
, newname
, ok_if_already_exists
)
2299 Lisp_Object file
, newname
, ok_if_already_exists
;
2302 Lisp_Object args
[2];
2304 Lisp_Object handler
;
2305 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2306 Lisp_Object encoded_file
, encoded_newname
;
2308 encoded_file
= encoded_newname
= Qnil
;
2309 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2310 CHECK_STRING (file
, 0);
2311 CHECK_STRING (newname
, 1);
2312 file
= Fexpand_file_name (file
, Qnil
);
2313 newname
= Fexpand_file_name (newname
, Qnil
);
2315 /* If the file name has special constructs in it,
2316 call the corresponding file handler. */
2317 handler
= Ffind_file_name_handler (file
, Qrename_file
);
2319 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
2320 if (!NILP (handler
))
2321 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
2322 file
, newname
, ok_if_already_exists
));
2324 encoded_file
= ENCODE_FILE (file
);
2325 encoded_newname
= ENCODE_FILE (newname
);
2327 if (NILP (ok_if_already_exists
)
2328 || INTEGERP (ok_if_already_exists
))
2329 barf_or_query_if_file_exists (encoded_newname
, "rename to it",
2330 INTEGERP (ok_if_already_exists
), 0);
2332 if (0 > rename (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2334 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
)
2335 || 0 > unlink (XSTRING (encoded_file
)->data
))
2340 Fcopy_file (file
, newname
,
2341 /* We have already prompted if it was an integer,
2342 so don't have copy-file prompt again. */
2343 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
2344 Fdelete_file (file
);
2351 report_file_error ("Renaming", Flist (2, args
));
2354 report_file_error ("Renaming", Flist (2, &file
));
2361 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
2362 "fAdd name to file: \nFName to add to %s: \np",
2363 "Give FILE additional name NEWNAME. Both args strings.\n\
2364 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2365 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2366 A number as third arg means request confirmation if NEWNAME already exists.\n\
2367 This is what happens in interactive use with M-x.")
2368 (file
, newname
, ok_if_already_exists
)
2369 Lisp_Object file
, newname
, ok_if_already_exists
;
2372 Lisp_Object args
[2];
2374 Lisp_Object handler
;
2375 Lisp_Object encoded_file
, encoded_newname
;
2376 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2378 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2379 encoded_file
= encoded_newname
= Qnil
;
2380 CHECK_STRING (file
, 0);
2381 CHECK_STRING (newname
, 1);
2382 file
= Fexpand_file_name (file
, Qnil
);
2383 newname
= Fexpand_file_name (newname
, Qnil
);
2385 /* If the file name has special constructs in it,
2386 call the corresponding file handler. */
2387 handler
= Ffind_file_name_handler (file
, Qadd_name_to_file
);
2388 if (!NILP (handler
))
2389 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2390 newname
, ok_if_already_exists
));
2392 /* If the new name has special constructs in it,
2393 call the corresponding file handler. */
2394 handler
= Ffind_file_name_handler (newname
, Qadd_name_to_file
);
2395 if (!NILP (handler
))
2396 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2397 newname
, ok_if_already_exists
));
2399 encoded_file
= ENCODE_FILE (file
);
2400 encoded_newname
= ENCODE_FILE (newname
);
2402 if (NILP (ok_if_already_exists
)
2403 || INTEGERP (ok_if_already_exists
))
2404 barf_or_query_if_file_exists (encoded_newname
, "make it a new name",
2405 INTEGERP (ok_if_already_exists
), 0);
2407 unlink (XSTRING (newname
)->data
);
2408 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2413 report_file_error ("Adding new name", Flist (2, args
));
2415 report_file_error ("Adding new name", Flist (2, &file
));
2424 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2425 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2426 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
2427 Signals a `file-already-exists' error if a file LINKNAME already exists\n\
2428 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2429 A number as third arg means request confirmation if LINKNAME already exists.\n\
2430 This happens for interactive use with M-x.")
2431 (filename
, linkname
, ok_if_already_exists
)
2432 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2435 Lisp_Object args
[2];
2437 Lisp_Object handler
;
2438 Lisp_Object encoded_filename
, encoded_linkname
;
2439 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2441 GCPRO4 (filename
, linkname
, encoded_filename
, encoded_linkname
);
2442 encoded_filename
= encoded_linkname
= Qnil
;
2443 CHECK_STRING (filename
, 0);
2444 CHECK_STRING (linkname
, 1);
2445 /* If the link target has a ~, we must expand it to get
2446 a truly valid file name. Otherwise, do not expand;
2447 we want to permit links to relative file names. */
2448 if (XSTRING (filename
)->data
[0] == '~')
2449 filename
= Fexpand_file_name (filename
, Qnil
);
2450 linkname
= Fexpand_file_name (linkname
, Qnil
);
2452 /* If the file name has special constructs in it,
2453 call the corresponding file handler. */
2454 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2455 if (!NILP (handler
))
2456 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2457 linkname
, ok_if_already_exists
));
2459 /* If the new link name has special constructs in it,
2460 call the corresponding file handler. */
2461 handler
= Ffind_file_name_handler (linkname
, Qmake_symbolic_link
);
2462 if (!NILP (handler
))
2463 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2464 linkname
, ok_if_already_exists
));
2466 encoded_filename
= ENCODE_FILE (filename
);
2467 encoded_linkname
= ENCODE_FILE (linkname
);
2469 if (NILP (ok_if_already_exists
)
2470 || INTEGERP (ok_if_already_exists
))
2471 barf_or_query_if_file_exists (encoded_linkname
, "make it a link",
2472 INTEGERP (ok_if_already_exists
), 0);
2473 if (0 > symlink (XSTRING (encoded_filename
)->data
,
2474 XSTRING (encoded_linkname
)->data
))
2476 /* If we didn't complain already, silently delete existing file. */
2477 if (errno
== EEXIST
)
2479 unlink (XSTRING (encoded_linkname
)->data
);
2480 if (0 <= symlink (XSTRING (encoded_filename
)->data
,
2481 XSTRING (encoded_linkname
)->data
))
2491 report_file_error ("Making symbolic link", Flist (2, args
));
2493 report_file_error ("Making symbolic link", Flist (2, &filename
));
2499 #endif /* S_IFLNK */
2503 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2504 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2505 "Define the job-wide logical name NAME to have the value STRING.\n\
2506 If STRING is nil or a null string, the logical name NAME is deleted.")
2511 CHECK_STRING (name
, 0);
2513 delete_logical_name (XSTRING (name
)->data
);
2516 CHECK_STRING (string
, 1);
2518 if (XSTRING (string
)->size
== 0)
2519 delete_logical_name (XSTRING (name
)->data
);
2521 define_logical_name (XSTRING (name
)->data
, XSTRING (string
)->data
);
2530 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2531 "Open a network connection to PATH using LOGIN as the login string.")
2533 Lisp_Object path
, login
;
2537 CHECK_STRING (path
, 0);
2538 CHECK_STRING (login
, 0);
2540 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2542 if (netresult
== -1)
2547 #endif /* HPUX_NET */
2549 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2551 "Return t if file FILENAME specifies an absolute file name.\n\
2552 On Unix, this is a name starting with a `/' or a `~'.")
2554 Lisp_Object filename
;
2558 CHECK_STRING (filename
, 0);
2559 ptr
= XSTRING (filename
)->data
;
2560 if (IS_DIRECTORY_SEP (*ptr
) || *ptr
== '~'
2562 /* ??? This criterion is probably wrong for '<'. */
2563 || index (ptr
, ':') || index (ptr
, '<')
2564 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2568 || (IS_DRIVE (*ptr
) && ptr
[1] == ':' && IS_DIRECTORY_SEP (ptr
[2]))
2576 /* Return nonzero if file FILENAME exists and can be executed. */
2579 check_executable (filename
)
2583 int len
= strlen (filename
);
2586 if (stat (filename
, &st
) < 0)
2588 #if defined (WINDOWSNT) || (defined (MSDOS) && __DJGPP__ > 1)
2589 return ((st
.st_mode
& S_IEXEC
) != 0);
2591 return (S_ISREG (st
.st_mode
)
2593 && (stricmp ((suffix
= filename
+ len
-4), ".com") == 0
2594 || stricmp (suffix
, ".exe") == 0
2595 || stricmp (suffix
, ".bat") == 0)
2596 || (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2597 #endif /* not WINDOWSNT */
2598 #else /* not DOS_NT */
2599 #ifdef HAVE_EUIDACCESS
2600 return (euidaccess (filename
, 1) >= 0);
2602 /* Access isn't quite right because it uses the real uid
2603 and we really want to test with the effective uid.
2604 But Unix doesn't give us a right way to do it. */
2605 return (access (filename
, 1) >= 0);
2607 #endif /* not DOS_NT */
2610 /* Return nonzero if file FILENAME exists and can be written. */
2613 check_writable (filename
)
2618 if (stat (filename
, &st
) < 0)
2620 return (st
.st_mode
& S_IWRITE
|| (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2621 #else /* not MSDOS */
2622 #ifdef HAVE_EUIDACCESS
2623 return (euidaccess (filename
, 2) >= 0);
2625 /* Access isn't quite right because it uses the real uid
2626 and we really want to test with the effective uid.
2627 But Unix doesn't give us a right way to do it.
2628 Opening with O_WRONLY could work for an ordinary file,
2629 but would lose for directories. */
2630 return (access (filename
, 2) >= 0);
2632 #endif /* not MSDOS */
2635 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2636 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
2637 See also `file-readable-p' and `file-attributes'.")
2639 Lisp_Object filename
;
2641 Lisp_Object absname
;
2642 Lisp_Object handler
;
2643 struct stat statbuf
;
2645 CHECK_STRING (filename
, 0);
2646 absname
= Fexpand_file_name (filename
, Qnil
);
2648 /* If the file name has special constructs in it,
2649 call the corresponding file handler. */
2650 handler
= Ffind_file_name_handler (absname
, Qfile_exists_p
);
2651 if (!NILP (handler
))
2652 return call2 (handler
, Qfile_exists_p
, absname
);
2654 absname
= ENCODE_FILE (absname
);
2656 return (stat (XSTRING (absname
)->data
, &statbuf
) >= 0) ? Qt
: Qnil
;
2659 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2660 "Return t if FILENAME can be executed by you.\n\
2661 For a directory, this means you can access files in that directory.")
2663 Lisp_Object filename
;
2666 Lisp_Object absname
;
2667 Lisp_Object handler
;
2669 CHECK_STRING (filename
, 0);
2670 absname
= Fexpand_file_name (filename
, Qnil
);
2672 /* If the file name has special constructs in it,
2673 call the corresponding file handler. */
2674 handler
= Ffind_file_name_handler (absname
, Qfile_executable_p
);
2675 if (!NILP (handler
))
2676 return call2 (handler
, Qfile_executable_p
, absname
);
2678 absname
= ENCODE_FILE (absname
);
2680 return (check_executable (XSTRING (absname
)->data
) ? Qt
: Qnil
);
2683 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2684 "Return t if file FILENAME exists and you can read it.\n\
2685 See also `file-exists-p' and `file-attributes'.")
2687 Lisp_Object filename
;
2689 Lisp_Object absname
;
2690 Lisp_Object handler
;
2693 struct stat statbuf
;
2695 CHECK_STRING (filename
, 0);
2696 absname
= Fexpand_file_name (filename
, Qnil
);
2698 /* If the file name has special constructs in it,
2699 call the corresponding file handler. */
2700 handler
= Ffind_file_name_handler (absname
, Qfile_readable_p
);
2701 if (!NILP (handler
))
2702 return call2 (handler
, Qfile_readable_p
, absname
);
2704 absname
= ENCODE_FILE (absname
);
2707 /* Under MS-DOS and Windows, open does not work for directories. */
2708 if (access (XSTRING (absname
)->data
, 0) == 0)
2711 #else /* not DOS_NT */
2713 #if defined (S_ISFIFO) && defined (O_NONBLOCK)
2714 /* Opening a fifo without O_NONBLOCK can wait.
2715 We don't want to wait. But we don't want to mess wth O_NONBLOCK
2716 except in the case of a fifo, on a system which handles it. */
2717 desc
= stat (XSTRING (absname
)->data
, &statbuf
);
2720 if (S_ISFIFO (statbuf
.st_mode
))
2721 flags
|= O_NONBLOCK
;
2723 desc
= open (XSTRING (absname
)->data
, flags
);
2728 #endif /* not DOS_NT */
2731 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2733 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
2734 "Return t if file FILENAME can be written or created by you.")
2736 Lisp_Object filename
;
2738 Lisp_Object absname
, dir
, encoded
;
2739 Lisp_Object handler
;
2740 struct stat statbuf
;
2742 CHECK_STRING (filename
, 0);
2743 absname
= Fexpand_file_name (filename
, Qnil
);
2745 /* If the file name has special constructs in it,
2746 call the corresponding file handler. */
2747 handler
= Ffind_file_name_handler (absname
, Qfile_writable_p
);
2748 if (!NILP (handler
))
2749 return call2 (handler
, Qfile_writable_p
, absname
);
2751 encoded
= ENCODE_FILE (absname
);
2752 if (stat (XSTRING (encoded
)->data
, &statbuf
) >= 0)
2753 return (check_writable (XSTRING (encoded
)->data
)
2756 dir
= Ffile_name_directory (absname
);
2759 dir
= Fdirectory_file_name (dir
);
2763 dir
= Fdirectory_file_name (dir
);
2766 dir
= ENCODE_FILE (dir
);
2767 return (check_writable (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "")
2771 DEFUN ("access-file", Faccess_file
, Saccess_file
, 2, 2, 0,
2772 "Access file FILENAME, and get an error if that does not work.\n\
2773 The second argument STRING is used in the error message.\n\
2774 If there is no error, we return nil.")
2776 Lisp_Object filename
, string
;
2778 Lisp_Object handler
, encoded_filename
;
2781 CHECK_STRING (filename
, 0);
2783 /* If the file name has special constructs in it,
2784 call the corresponding file handler. */
2785 handler
= Ffind_file_name_handler (filename
, Qaccess_file
);
2786 if (!NILP (handler
))
2787 return call3 (handler
, Qaccess_file
, filename
, string
);
2789 encoded_filename
= ENCODE_FILE (filename
);
2791 fd
= open (XSTRING (encoded_filename
)->data
, O_RDONLY
);
2793 report_file_error (XSTRING (string
)->data
, Fcons (filename
, Qnil
));
2799 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
2800 "Return non-nil if file FILENAME is the name of a symbolic link.\n\
2801 The value is the name of the file to which it is linked.\n\
2802 Otherwise returns nil.")
2804 Lisp_Object filename
;
2811 Lisp_Object handler
;
2813 CHECK_STRING (filename
, 0);
2814 filename
= Fexpand_file_name (filename
, Qnil
);
2816 /* If the file name has special constructs in it,
2817 call the corresponding file handler. */
2818 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
2819 if (!NILP (handler
))
2820 return call2 (handler
, Qfile_symlink_p
, filename
);
2822 filename
= ENCODE_FILE (filename
);
2827 buf
= (char *) xmalloc (bufsize
);
2828 bzero (buf
, bufsize
);
2829 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
2830 if (valsize
< bufsize
) break;
2831 /* Buffer was not long enough */
2840 val
= make_string (buf
, valsize
);
2842 return Fdecode_coding_string (val
, Vfile_name_coding_system
, Qt
);
2843 #else /* not S_IFLNK */
2845 #endif /* not S_IFLNK */
2848 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
2849 "Return t if FILENAME names an existing directory.")
2851 Lisp_Object filename
;
2853 register Lisp_Object absname
;
2855 Lisp_Object handler
;
2857 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2859 /* If the file name has special constructs in it,
2860 call the corresponding file handler. */
2861 handler
= Ffind_file_name_handler (absname
, Qfile_directory_p
);
2862 if (!NILP (handler
))
2863 return call2 (handler
, Qfile_directory_p
, absname
);
2865 absname
= ENCODE_FILE (absname
);
2867 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2869 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
2872 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
2873 "Return t if file FILENAME is the name of a directory as a file,\n\
2874 and files in that directory can be opened by you. In order to use a\n\
2875 directory as a buffer's current directory, this predicate must return true.\n\
2876 A directory name spec may be given instead; then the value is t\n\
2877 if the directory so specified exists and really is a readable and\n\
2878 searchable directory.")
2880 Lisp_Object filename
;
2882 Lisp_Object handler
;
2884 struct gcpro gcpro1
;
2886 /* If the file name has special constructs in it,
2887 call the corresponding file handler. */
2888 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
2889 if (!NILP (handler
))
2890 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
2892 /* It's an unlikely combination, but yes we really do need to gcpro:
2893 Suppose that file-accessible-directory-p has no handler, but
2894 file-directory-p does have a handler; this handler causes a GC which
2895 relocates the string in `filename'; and finally file-directory-p
2896 returns non-nil. Then we would end up passing a garbaged string
2897 to file-executable-p. */
2899 tem
= (NILP (Ffile_directory_p (filename
))
2900 || NILP (Ffile_executable_p (filename
)));
2902 return tem
? Qnil
: Qt
;
2905 DEFUN ("file-regular-p", Ffile_regular_p
, Sfile_regular_p
, 1, 1, 0,
2906 "Return t if file FILENAME is the name of a regular file.\n\
2907 This is the sort of file that holds an ordinary stream of data bytes.")
2909 Lisp_Object filename
;
2911 register Lisp_Object absname
;
2913 Lisp_Object handler
;
2915 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2917 /* If the file name has special constructs in it,
2918 call the corresponding file handler. */
2919 handler
= Ffind_file_name_handler (absname
, Qfile_regular_p
);
2920 if (!NILP (handler
))
2921 return call2 (handler
, Qfile_regular_p
, absname
);
2923 absname
= ENCODE_FILE (absname
);
2925 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2927 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
2930 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
2931 "Return mode bits of file named FILENAME, as an integer.")
2933 Lisp_Object filename
;
2935 Lisp_Object absname
;
2937 Lisp_Object handler
;
2939 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2941 /* If the file name has special constructs in it,
2942 call the corresponding file handler. */
2943 handler
= Ffind_file_name_handler (absname
, Qfile_modes
);
2944 if (!NILP (handler
))
2945 return call2 (handler
, Qfile_modes
, absname
);
2947 absname
= ENCODE_FILE (absname
);
2949 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2951 #if defined (MSDOS) && __DJGPP__ < 2
2952 if (check_executable (XSTRING (absname
)->data
))
2953 st
.st_mode
|= S_IEXEC
;
2954 #endif /* MSDOS && __DJGPP__ < 2 */
2956 return make_number (st
.st_mode
& 07777);
2959 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
2960 "Set mode bits of file named FILENAME to MODE (an integer).\n\
2961 Only the 12 low bits of MODE are used.")
2963 Lisp_Object filename
, mode
;
2965 Lisp_Object absname
, encoded_absname
;
2966 Lisp_Object handler
;
2968 absname
= Fexpand_file_name (filename
, current_buffer
->directory
);
2969 CHECK_NUMBER (mode
, 1);
2971 /* If the file name has special constructs in it,
2972 call the corresponding file handler. */
2973 handler
= Ffind_file_name_handler (absname
, Qset_file_modes
);
2974 if (!NILP (handler
))
2975 return call3 (handler
, Qset_file_modes
, absname
, mode
);
2977 encoded_absname
= ENCODE_FILE (absname
);
2979 if (chmod (XSTRING (encoded_absname
)->data
, XINT (mode
)) < 0)
2980 report_file_error ("Doing chmod", Fcons (absname
, Qnil
));
2985 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
2986 "Set the file permission bits for newly created files.\n\
2987 The argument MODE should be an integer; only the low 9 bits are used.\n\
2988 This setting is inherited by subprocesses.")
2992 CHECK_NUMBER (mode
, 0);
2994 umask ((~ XINT (mode
)) & 0777);
2999 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
3000 "Return the default file protection for created files.\n\
3001 The value is an integer.")
3007 realmask
= umask (0);
3010 XSETINT (value
, (~ realmask
) & 0777);
3016 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
3017 "Tell Unix to finish all pending disk updates.")
3026 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
3027 "Return t if file FILE1 is newer than file FILE2.\n\
3028 If FILE1 does not exist, the answer is nil;\n\
3029 otherwise, if FILE2 does not exist, the answer is t.")
3031 Lisp_Object file1
, file2
;
3033 Lisp_Object absname1
, absname2
;
3036 Lisp_Object handler
;
3037 struct gcpro gcpro1
, gcpro2
;
3039 CHECK_STRING (file1
, 0);
3040 CHECK_STRING (file2
, 0);
3043 GCPRO2 (absname1
, file2
);
3044 absname1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
3045 absname2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
3048 /* If the file name has special constructs in it,
3049 call the corresponding file handler. */
3050 handler
= Ffind_file_name_handler (absname1
, Qfile_newer_than_file_p
);
3052 handler
= Ffind_file_name_handler (absname2
, Qfile_newer_than_file_p
);
3053 if (!NILP (handler
))
3054 return call3 (handler
, Qfile_newer_than_file_p
, absname1
, absname2
);
3056 GCPRO2 (absname1
, absname2
);
3057 absname1
= ENCODE_FILE (absname1
);
3058 absname2
= ENCODE_FILE (absname2
);
3061 if (stat (XSTRING (absname1
)->data
, &st
) < 0)
3064 mtime1
= st
.st_mtime
;
3066 if (stat (XSTRING (absname2
)->data
, &st
) < 0)
3069 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
3073 Lisp_Object Qfind_buffer_file_type
;
3076 #ifndef READ_BUF_SIZE
3077 #define READ_BUF_SIZE (64 << 10)
3080 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
3082 "Insert contents of file FILENAME after point.\n\
3083 Returns list of absolute file name and number of bytes inserted.\n\
3084 If second argument VISIT is non-nil, the buffer's visited filename\n\
3085 and last save file modtime are set, and it is marked unmodified.\n\
3086 If visiting and the file does not exist, visiting is completed\n\
3087 before the error is signaled.\n\
3088 The optional third and fourth arguments BEG and END\n\
3089 specify what portion of the file to insert.\n\
3090 These arguments count bytes in the file, not characters in the buffer.\n\
3091 If VISIT is non-nil, BEG and END must be nil.\n\
3093 If optional fifth argument REPLACE is non-nil,\n\
3094 it means replace the current buffer contents (in the accessible portion)\n\
3095 with the file contents. This is better than simply deleting and inserting\n\
3096 the whole thing because (1) it preserves some marker positions\n\
3097 and (2) it puts less data in the undo list.\n\
3098 When REPLACE is non-nil, the value is the number of characters actually read,\n\
3099 which is often less than the number of characters to be read.\n\
3100 This does code conversion according to the value of\n\
3101 `coding-system-for-read' or `file-coding-system-alist',\n\
3102 and sets the variable `last-coding-system-used' to the coding system\n\
3104 (filename
, visit
, beg
, end
, replace
)
3105 Lisp_Object filename
, visit
, beg
, end
, replace
;
3110 int inserted_chars
= 0;
3111 register int how_much
;
3112 register int unprocessed
;
3113 int count
= specpdl_ptr
- specpdl
;
3114 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3115 Lisp_Object handler
, val
, insval
, orig_filename
;
3118 int not_regular
= 0;
3119 char read_buf
[READ_BUF_SIZE
];
3120 struct coding_system coding
;
3121 unsigned char buffer
[1 << 14];
3122 int replace_handled
= 0;
3123 int set_coding_system
= 0;
3125 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3126 error ("Cannot do file visiting in an indirect buffer");
3128 if (!NILP (current_buffer
->read_only
))
3129 Fbarf_if_buffer_read_only ();
3133 orig_filename
= Qnil
;
3135 GCPRO4 (filename
, val
, p
, orig_filename
);
3137 CHECK_STRING (filename
, 0);
3138 filename
= Fexpand_file_name (filename
, Qnil
);
3140 /* If the file name has special constructs in it,
3141 call the corresponding file handler. */
3142 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
3143 if (!NILP (handler
))
3145 val
= call6 (handler
, Qinsert_file_contents
, filename
,
3146 visit
, beg
, end
, replace
);
3150 orig_filename
= filename
;
3151 filename
= ENCODE_FILE (filename
);
3156 if (stat (XSTRING (filename
)->data
, &st
) < 0)
3158 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0
3159 || fstat (fd
, &st
) < 0)
3160 #endif /* not APOLLO */
3162 if (fd
>= 0) close (fd
);
3165 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3168 if (!NILP (Vcoding_system_for_read
))
3169 current_buffer
->buffer_file_coding_system
= Vcoding_system_for_read
;
3174 /* This code will need to be changed in order to work on named
3175 pipes, and it's probably just not worth it. So we should at
3176 least signal an error. */
3177 if (!S_ISREG (st
.st_mode
))
3184 if (! NILP (replace
) || ! NILP (beg
) || ! NILP (end
))
3185 Fsignal (Qfile_error
,
3186 Fcons (build_string ("not a regular file"),
3187 Fcons (orig_filename
, Qnil
)));
3192 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0)
3195 /* Replacement should preserve point as it preserves markers. */
3196 if (!NILP (replace
))
3197 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
3199 record_unwind_protect (close_file_unwind
, make_number (fd
));
3201 /* Supposedly happens on VMS. */
3202 if (! not_regular
&& st
.st_size
< 0)
3203 error ("File size is negative");
3205 if (!NILP (beg
) || !NILP (end
))
3207 error ("Attempt to visit less than an entire file");
3210 CHECK_NUMBER (beg
, 0);
3212 XSETFASTINT (beg
, 0);
3215 CHECK_NUMBER (end
, 0);
3220 XSETINT (end
, st
.st_size
);
3221 if (XINT (end
) != st
.st_size
)
3222 error ("Maximum buffer size exceeded");
3226 /* Decide the coding-system of the file. */
3228 Lisp_Object val
= Qnil
;
3230 if (!NILP (Vcoding_system_for_read
))
3231 val
= Vcoding_system_for_read
;
3232 else if (NILP (current_buffer
->enable_multibyte_characters
))
3236 if (! NILP (Vset_auto_coding_function
))
3238 /* Find a coding system specified in the heading two lines
3239 or in the tailing several lines of the file. We assume
3240 that the 1K-byte and 3K-byte for heading and tailing
3241 respectively are sufficient fot this purpose. */
3242 int how_many
, nread
;
3244 if (st
.st_size
<= (1024 * 4))
3245 nread
= read (fd
, read_buf
, 1024 * 4);
3248 nread
= read (fd
, read_buf
, 1024);
3251 if (lseek (fd
, st
.st_size
- (1024 * 3), 0) < 0)
3252 report_file_error ("Setting file position",
3253 Fcons (orig_filename
, Qnil
));
3254 nread
+= read (fd
, read_buf
+ nread
, 1024 * 3);
3259 error ("IO error reading %s: %s",
3260 XSTRING (orig_filename
)->data
, strerror (errno
));
3263 val
= call1 (Vset_auto_coding_function
,
3264 make_string (read_buf
, nread
));
3265 /* Rewind the file for the actual read done later. */
3266 if (lseek (fd
, 0, 0) < 0)
3267 report_file_error ("Setting file position",
3268 Fcons (orig_filename
, Qnil
));
3273 Lisp_Object args
[6], coding_systems
;
3275 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
,
3276 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = replace
;
3277 coding_systems
= Ffind_operation_coding_system (6, args
);
3278 if (CONSP (coding_systems
)) val
= XCONS (coding_systems
)->car
;
3281 setup_coding_system (Fcheck_coding_system (val
), &coding
);
3284 /* If requested, replace the accessible part of the buffer
3285 with the file contents. Avoid replacing text at the
3286 beginning or end of the buffer that matches the file contents;
3287 that preserves markers pointing to the unchanged parts.
3289 Here we implement this feature in an optimized way
3290 for the case where code conversion is NOT needed.
3291 The following if-statement handles the case of conversion
3292 in a less optimal way.
3294 If the code conversion is "automatic" then we try using this
3295 method and hope for the best.
3296 But if we discover the need for conversion, we give up on this method
3297 and let the following if-statement handle the replace job. */
3299 && ! CODING_REQUIRE_DECODING (&coding
))
3301 /* same_at_start and same_at_end count bytes,
3302 because file access counts bytes
3303 and BEG and END count bytes. */
3304 int same_at_start
= BEGV_BYTE
;
3305 int same_at_end
= ZV_BYTE
;
3307 /* There is still a possibility we will find the need to do code
3308 conversion. If that happens, we set this variable to 1 to
3309 give up on handling REPLACE in the optimized way. */
3310 int giveup_match_end
= 0;
3312 if (XINT (beg
) != 0)
3314 if (lseek (fd
, XINT (beg
), 0) < 0)
3315 report_file_error ("Setting file position",
3316 Fcons (orig_filename
, Qnil
));
3321 /* Count how many chars at the start of the file
3322 match the text at the beginning of the buffer. */
3327 nread
= read (fd
, buffer
, sizeof buffer
);
3329 error ("IO error reading %s: %s",
3330 XSTRING (orig_filename
)->data
, strerror (errno
));
3331 else if (nread
== 0)
3334 if (coding
.type
== coding_type_undecided
)
3335 detect_coding (&coding
, buffer
, nread
);
3336 if (CODING_REQUIRE_DECODING (&coding
))
3337 /* We found that the file should be decoded somehow.
3338 Let's give up here. */
3340 giveup_match_end
= 1;
3344 if (coding
.eol_type
== CODING_EOL_UNDECIDED
)
3345 detect_eol (&coding
, buffer
, nread
);
3346 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3347 && coding
.eol_type
!= CODING_EOL_LF
)
3348 /* We found that the format of eol should be decoded.
3349 Let's give up here. */
3351 giveup_match_end
= 1;
3356 while (bufpos
< nread
&& same_at_start
< ZV_BYTE
3357 && FETCH_BYTE (same_at_start
) == buffer
[bufpos
])
3358 same_at_start
++, bufpos
++;
3359 /* If we found a discrepancy, stop the scan.
3360 Otherwise loop around and scan the next bufferful. */
3361 if (bufpos
!= nread
)
3365 /* If the file matches the buffer completely,
3366 there's no need to replace anything. */
3367 if (same_at_start
- BEGV_BYTE
== XINT (end
))
3371 /* Truncate the buffer to the size of the file. */
3372 del_range_1 (same_at_start
, same_at_end
, 0);
3377 /* Count how many chars at the end of the file
3378 match the text at the end of the buffer. But, if we have
3379 already found that decoding is necessary, don't waste time. */
3380 while (!giveup_match_end
)
3382 int total_read
, nread
, bufpos
, curpos
, trial
;
3384 /* At what file position are we now scanning? */
3385 curpos
= XINT (end
) - (ZV_BYTE
- same_at_end
);
3386 /* If the entire file matches the buffer tail, stop the scan. */
3389 /* How much can we scan in the next step? */
3390 trial
= min (curpos
, sizeof buffer
);
3391 if (lseek (fd
, curpos
- trial
, 0) < 0)
3392 report_file_error ("Setting file position",
3393 Fcons (orig_filename
, Qnil
));
3396 while (total_read
< trial
)
3398 nread
= read (fd
, buffer
+ total_read
, trial
- total_read
);
3400 error ("IO error reading %s: %s",
3401 XSTRING (orig_filename
)->data
, strerror (errno
));
3402 total_read
+= nread
;
3404 /* Scan this bufferful from the end, comparing with
3405 the Emacs buffer. */
3406 bufpos
= total_read
;
3407 /* Compare with same_at_start to avoid counting some buffer text
3408 as matching both at the file's beginning and at the end. */
3409 while (bufpos
> 0 && same_at_end
> same_at_start
3410 && FETCH_BYTE (same_at_end
- 1) == buffer
[bufpos
- 1])
3411 same_at_end
--, bufpos
--;
3413 /* If we found a discrepancy, stop the scan.
3414 Otherwise loop around and scan the preceding bufferful. */
3417 /* If this discrepancy is because of code conversion,
3418 we cannot use this method; giveup and try the other. */
3419 if (same_at_end
> same_at_start
3420 && FETCH_BYTE (same_at_end
- 1) >= 0200
3421 && ! NILP (current_buffer
->enable_multibyte_characters
)
3422 && (CODING_REQUIRE_DECODING (&coding
)
3423 || CODING_REQUIRE_DETECTION (&coding
)))
3424 giveup_match_end
= 1;
3430 if (! giveup_match_end
)
3434 /* We win! We can handle REPLACE the optimized way. */
3436 /* Extends the end of non-matching text area to multibyte
3437 character boundary. */
3438 if (! NILP (current_buffer
->enable_multibyte_characters
))
3439 while (same_at_end
< ZV_BYTE
3440 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
3443 /* Don't try to reuse the same piece of text twice. */
3444 overlap
= (same_at_start
- BEGV_BYTE
3445 - (same_at_end
+ st
.st_size
- ZV
));
3447 same_at_end
+= overlap
;
3449 /* Arrange to read only the nonmatching middle part of the file. */
3450 XSETFASTINT (beg
, XINT (beg
) + (same_at_start
- BEGV_BYTE
));
3451 XSETFASTINT (end
, XINT (end
) - (ZV_BYTE
- same_at_end
));
3453 del_range_byte (same_at_start
, same_at_end
, 0);
3454 /* Insert from the file at the proper position. */
3455 temp
= BYTE_TO_CHAR (same_at_start
);
3456 SET_PT_BOTH (temp
, same_at_start
);
3458 /* If display currently starts at beginning of line,
3459 keep it that way. */
3460 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3461 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3463 replace_handled
= 1;
3467 /* If requested, replace the accessible part of the buffer
3468 with the file contents. Avoid replacing text at the
3469 beginning or end of the buffer that matches the file contents;
3470 that preserves markers pointing to the unchanged parts.
3472 Here we implement this feature for the case where code conversion
3473 is needed, in a simple way that needs a lot of memory.
3474 The preceding if-statement handles the case of no conversion
3475 in a more optimized way. */
3476 if (!NILP (replace
) && ! replace_handled
)
3478 int same_at_start
= BEGV_BYTE
;
3479 int same_at_end
= ZV_BYTE
;
3482 /* Make sure that the gap is large enough. */
3483 int bufsize
= 2 * st
.st_size
;
3484 unsigned char *conversion_buffer
= (unsigned char *) xmalloc (bufsize
);
3487 /* First read the whole file, performing code conversion into
3488 CONVERSION_BUFFER. */
3490 if (lseek (fd
, XINT (beg
), 0) < 0)
3492 free (conversion_buffer
);
3493 report_file_error ("Setting file position",
3494 Fcons (orig_filename
, Qnil
));
3497 total
= st
.st_size
; /* Total bytes in the file. */
3498 how_much
= 0; /* Bytes read from file so far. */
3499 inserted
= 0; /* Bytes put into CONVERSION_BUFFER so far. */
3500 unprocessed
= 0; /* Bytes not processed in previous loop. */
3502 while (how_much
< total
)
3504 /* try is reserved in some compilers (Microsoft C) */
3505 int trytry
= min (total
- how_much
, READ_BUF_SIZE
- unprocessed
);
3506 char *destination
= read_buf
+ unprocessed
;
3509 /* Allow quitting out of the actual I/O. */
3512 this = read (fd
, destination
, trytry
);
3515 if (this < 0 || this + unprocessed
== 0)
3523 if (CODING_REQUIRE_DECODING (&coding
)
3524 || CODING_REQUIRE_DETECTION (&coding
))
3526 int require
, produced
, consumed
;
3528 this += unprocessed
;
3530 /* If we are using more space than estimated,
3531 make CONVERSION_BUFFER bigger. */
3532 require
= decoding_buffer_size (&coding
, this);
3533 if (inserted
+ require
+ 2 * (total
- how_much
) > bufsize
)
3535 bufsize
= inserted
+ require
+ 2 * (total
- how_much
);
3536 conversion_buffer
= (unsigned char *) xrealloc (conversion_buffer
, bufsize
);
3539 /* Convert this batch with results in CONVERSION_BUFFER. */
3540 if (how_much
>= total
) /* This is the last block. */
3541 coding
.last_block
= 1;
3542 produced
= decode_coding (&coding
, read_buf
,
3543 conversion_buffer
+ inserted
,
3544 this, bufsize
- inserted
,
3547 /* Save for next iteration whatever we didn't convert. */
3548 unprocessed
= this - consumed
;
3549 bcopy (read_buf
+ consumed
, read_buf
, unprocessed
);
3556 /* At this point, INSERTED is how many characters
3557 are present in CONVERSION_BUFFER.
3558 HOW_MUCH should equal TOTAL,
3559 or should be <= 0 if we couldn't read the file. */
3563 free (conversion_buffer
);
3566 error ("IO error reading %s: %s",
3567 XSTRING (orig_filename
)->data
, strerror (errno
));
3568 else if (how_much
== -2)
3569 error ("maximum buffer size exceeded");
3572 /* Compare the beginning of the converted file
3573 with the buffer text. */
3576 while (bufpos
< inserted
&& same_at_start
< same_at_end
3577 && FETCH_BYTE (same_at_start
) == conversion_buffer
[bufpos
])
3578 same_at_start
++, bufpos
++;
3580 /* If the file matches the buffer completely,
3581 there's no need to replace anything. */
3583 if (bufpos
== inserted
)
3585 free (conversion_buffer
);
3588 /* Truncate the buffer to the size of the file. */
3589 del_range_1 (same_at_start
, same_at_end
, 0);
3593 /* Scan this bufferful from the end, comparing with
3594 the Emacs buffer. */
3597 /* Compare with same_at_start to avoid counting some buffer text
3598 as matching both at the file's beginning and at the end. */
3599 while (bufpos
> 0 && same_at_end
> same_at_start
3600 && FETCH_BYTE (same_at_end
- 1) == conversion_buffer
[bufpos
- 1])
3601 same_at_end
--, bufpos
--;
3603 /* Don't try to reuse the same piece of text twice. */
3604 overlap
= same_at_start
- BEGV_BYTE
- (same_at_end
+ inserted
- ZV_BYTE
);
3606 same_at_end
+= overlap
;
3608 /* If display currently starts at beginning of line,
3609 keep it that way. */
3610 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3611 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3613 /* Replace the chars that we need to replace,
3614 and update INSERTED to equal the number of bytes
3615 we are taking from the file. */
3616 inserted
-= (Z_BYTE
- same_at_end
) + (same_at_start
- BEG_BYTE
);
3617 del_range_byte (same_at_start
, same_at_end
, 0);
3618 SET_PT_BOTH (GPT
, GPT_BYTE
);
3620 insert_1 (conversion_buffer
+ same_at_start
- BEG_BYTE
, inserted
,
3623 free (conversion_buffer
);
3632 register Lisp_Object temp
;
3634 total
= XINT (end
) - XINT (beg
);
3636 /* Make sure point-max won't overflow after this insertion. */
3637 XSETINT (temp
, total
);
3638 if (total
!= XINT (temp
))
3639 error ("Maximum buffer size exceeded");
3642 /* For a special file, all we can do is guess. */
3643 total
= READ_BUF_SIZE
;
3645 if (NILP (visit
) && total
> 0)
3646 prepare_to_modify_buffer (PT
, PT
, NULL
);
3649 if (GAP_SIZE
< total
)
3650 make_gap (total
- GAP_SIZE
);
3652 if (XINT (beg
) != 0 || !NILP (replace
))
3654 if (lseek (fd
, XINT (beg
), 0) < 0)
3655 report_file_error ("Setting file position",
3656 Fcons (orig_filename
, Qnil
));
3659 /* In the following loop, HOW_MUCH contains the total bytes read so
3660 far. Before exiting the loop, it is set to -1 if I/O error
3661 occurs, set to -2 if the maximum buffer size is exceeded. */
3663 /* Total bytes inserted. */
3665 /* Bytes not processed in the previous loop because short gap size. */
3667 while (how_much
< total
)
3669 /* try is reserved in some compilers (Microsoft C) */
3670 int trytry
= min (total
- how_much
, READ_BUF_SIZE
- unprocessed
);
3671 char *destination
= (! (CODING_REQUIRE_DECODING (&coding
)
3672 || CODING_REQUIRE_DETECTION (&coding
))
3673 ? (char *) (BYTE_POS_ADDR (PT_BYTE
+ inserted
- 1) + 1)
3674 : read_buf
+ unprocessed
);
3675 int this, this_chars
;
3677 /* Allow quitting out of the actual I/O. */
3680 this = read (fd
, destination
, trytry
);
3683 if (this < 0 || this + unprocessed
== 0)
3689 /* For a regular file, where TOTAL is the real size,
3690 count HOW_MUCH to compare with it.
3691 For a special file, where TOTAL is just a buffer size,
3692 so don't bother counting in HOW_MUCH.
3693 (INSERTED is where we count the number of characters inserted.) */
3698 if (CODING_REQUIRE_DECODING (&coding
)
3699 || CODING_REQUIRE_DETECTION (&coding
))
3701 int require
, produced
, consumed
;
3703 this += unprocessed
;
3704 /* Make sure that the gap is large enough. */
3705 require
= decoding_buffer_size (&coding
, this);
3706 if (GAP_SIZE
< require
)
3707 make_gap (require
- GAP_SIZE
);
3711 if (how_much
>= total
) /* This is the last block. */
3712 coding
.last_block
= 1;
3716 /* If we encounter EOF, say it is the last block. (The
3717 data this will apply to is the UNPROCESSED characters
3718 carried over from the last batch.) */
3720 coding
.last_block
= 1;
3723 produced
= decode_coding (&coding
, read_buf
,
3724 BYTE_POS_ADDR (PT_BYTE
+ inserted
- 1) + 1,
3725 this, GAP_SIZE
, &consumed
);
3730 XSET (temp
, Lisp_Int
, Z_BYTE
+ produced
);
3731 if (Z_BYTE
+ produced
!= XINT (temp
))
3737 unprocessed
= this - consumed
;
3738 bcopy (read_buf
+ consumed
, read_buf
, unprocessed
);
3740 this_chars
= chars_in_text (BYTE_POS_ADDR (PT_BYTE
+ inserted
- 1) + 1,
3753 /* Put an anchor to ensure multi-byte form ends at gap. */
3756 inserted_chars
+= this_chars
;
3760 /* Use the conversion type to determine buffer-file-type
3761 (find-buffer-file-type is now used to help determine the
3763 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3764 && coding
.eol_type
!= CODING_EOL_LF
)
3765 current_buffer
->buffer_file_type
= Qnil
;
3767 current_buffer
->buffer_file_type
= Qt
;
3772 record_insert (PT
, inserted_chars
);
3774 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
3775 offset_intervals (current_buffer
, PT
, inserted_chars
);
3781 /* Discard the unwind protect for closing the file. */
3785 error ("IO error reading %s: %s",
3786 XSTRING (orig_filename
)->data
, strerror (errno
));
3787 else if (how_much
== -2)
3788 error ("maximum buffer size exceeded");
3790 set_coding_system
= 1;
3797 if (!EQ (current_buffer
->undo_list
, Qt
))
3798 current_buffer
->undo_list
= Qnil
;
3800 stat (XSTRING (filename
)->data
, &st
);
3805 current_buffer
->modtime
= st
.st_mtime
;
3806 current_buffer
->filename
= orig_filename
;
3809 SAVE_MODIFF
= MODIFF
;
3810 current_buffer
->auto_save_modified
= MODIFF
;
3811 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
3812 #ifdef CLASH_DETECTION
3815 if (!NILP (current_buffer
->file_truename
))
3816 unlock_file (current_buffer
->file_truename
);
3817 unlock_file (filename
);
3819 #endif /* CLASH_DETECTION */
3821 Fsignal (Qfile_error
,
3822 Fcons (build_string ("not a regular file"),
3823 Fcons (orig_filename
, Qnil
)));
3825 /* If visiting nonexistent file, return nil. */
3826 if (current_buffer
->modtime
== -1)
3827 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3830 /* Decode file format */
3831 if (inserted_chars
> 0)
3833 insval
= call3 (Qformat_decode
,
3834 Qnil
, make_number (inserted_chars
), visit
);
3835 CHECK_NUMBER (insval
, 0);
3836 inserted_chars
= XFASTINT (insval
);
3839 /* Call after-change hooks for the inserted text, aside from the case
3840 of normal visiting (not with REPLACE), which is done in a new buffer
3841 "before" the buffer is changed. */
3842 if (inserted_chars
> 0 && total
> 0
3843 && (NILP (visit
) || !NILP (replace
)))
3844 signal_after_change (PT
, 0, inserted_chars
);
3846 if (set_coding_system
)
3847 Vlast_coding_system_used
= coding
.symbol
;
3851 p
= Vafter_insert_file_functions
;
3852 if (!NILP (coding
.post_read_conversion
))
3853 p
= Fcons (coding
.post_read_conversion
, p
);
3857 insval
= call1 (Fcar (p
), make_number (inserted_chars
));
3860 CHECK_NUMBER (insval
, 0);
3861 inserted_chars
= XFASTINT (insval
);
3868 /* ??? Retval needs to be dealt with in all cases consistently. */
3870 val
= Fcons (orig_filename
,
3871 Fcons (make_number (inserted
),
3874 RETURN_UNGCPRO (unbind_to (count
, val
));
3877 static Lisp_Object build_annotations
P_ ((Lisp_Object
, Lisp_Object
,
3880 /* If build_annotations switched buffers, switch back to BUF.
3881 Kill the temporary buffer that was selected in the meantime.
3883 Since this kill only the last temporary buffer, some buffers remain
3884 not killed if build_annotations switched buffers more than once.
3888 build_annotations_unwind (buf
)
3893 if (XBUFFER (buf
) == current_buffer
)
3895 tembuf
= Fcurrent_buffer ();
3897 Fkill_buffer (tembuf
);
3901 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 6,
3902 "r\nFWrite region to file: ",
3903 "Write current region into specified file.\n\
3904 When called from a program, takes three arguments:\n\
3905 START, END and FILENAME. START and END are buffer positions.\n\
3906 Optional fourth argument APPEND if non-nil means\n\
3907 append to existing file contents (if any).\n\
3908 Optional fifth argument VISIT if t means\n\
3909 set the last-save-file-modtime of buffer to this file's modtime\n\
3910 and mark buffer not modified.\n\
3911 If VISIT is a string, it is a second file name;\n\
3912 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
3913 VISIT is also the file name to lock and unlock for clash detection.\n\
3914 If VISIT is neither t nor nil nor a string,\n\
3915 that means do not print the \"Wrote file\" message.\n\
3916 The optional sixth arg LOCKNAME, if non-nil, specifies the name to\n\
3917 use for locking and unlocking, overriding FILENAME and VISIT.\n\
3918 Kludgy feature: if START is a string, then that string is written\n\
3919 to the file, instead of any buffer contents, and END is ignored.")
3920 (start
, end
, filename
, append
, visit
, lockname
)
3921 Lisp_Object start
, end
, filename
, append
, visit
, lockname
;
3929 int count
= specpdl_ptr
- specpdl
;
3932 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
3934 Lisp_Object handler
;
3935 Lisp_Object visit_file
;
3936 Lisp_Object annotations
;
3937 Lisp_Object encoded_filename
;
3938 int visiting
, quietly
;
3939 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
3940 struct buffer
*given_buffer
;
3942 int buffer_file_type
= O_BINARY
;
3944 struct coding_system coding
;
3946 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3947 error ("Cannot do file visiting in an indirect buffer");
3949 if (!NILP (start
) && !STRINGP (start
))
3950 validate_region (&start
, &end
);
3952 GCPRO4 (start
, filename
, visit
, lockname
);
3954 /* Decide the coding-system to encode the data with. */
3960 else if (!NILP (Vcoding_system_for_write
))
3961 val
= Vcoding_system_for_write
;
3962 else if (NILP (current_buffer
->enable_multibyte_characters
))
3964 /* If the variable `buffer-file-coding-system' is set locally,
3965 it means that the file was read with some kind of code
3966 conversion or the varialbe is explicitely set by users. We
3967 had better write it out with the same coding system even if
3968 `enable-multibyte-characters' is nil.
3970 If is is not set locally, we anyway have to convert EOL
3971 format if the default value of `buffer-file-coding-system'
3972 tells that it is not Unix-like (LF only) format. */
3973 val
= current_buffer
->buffer_file_coding_system
;
3974 if (NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
3976 struct coding_system coding_temp
;
3978 setup_coding_system (Fcheck_coding_system (val
), &coding_temp
);
3979 if (coding_temp
.eol_type
== CODING_EOL_CRLF
3980 || coding_temp
.eol_type
== CODING_EOL_CR
)
3982 setup_coding_system (Qemacs_mule
, &coding
);
3983 coding
.eol_type
= coding_temp
.eol_type
;
3984 goto done_setup_coding
;
3991 Lisp_Object args
[7], coding_systems
;
3993 args
[0] = Qwrite_region
, args
[1] = start
, args
[2] = end
,
3994 args
[3] = filename
, args
[4] = append
, args
[5] = visit
,
3996 coding_systems
= Ffind_operation_coding_system (7, args
);
3997 val
= (CONSP (coding_systems
) && !NILP (XCONS (coding_systems
)->cdr
)
3998 ? XCONS (coding_systems
)->cdr
3999 : current_buffer
->buffer_file_coding_system
);
4001 setup_coding_system (Fcheck_coding_system (val
), &coding
);
4004 if (!STRINGP (start
) && !NILP (current_buffer
->selective_display
))
4005 coding
.selective
= 1;
4008 Vlast_coding_system_used
= coding
.symbol
;
4010 filename
= Fexpand_file_name (filename
, Qnil
);
4011 if (STRINGP (visit
))
4012 visit_file
= Fexpand_file_name (visit
, Qnil
);
4014 visit_file
= filename
;
4017 visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
4018 quietly
= !NILP (visit
);
4022 if (NILP (lockname
))
4023 lockname
= visit_file
;
4025 GCPRO5 (start
, filename
, annotations
, visit_file
, lockname
);
4027 /* If the file name has special constructs in it,
4028 call the corresponding file handler. */
4029 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
4030 /* If FILENAME has no handler, see if VISIT has one. */
4031 if (NILP (handler
) && STRINGP (visit
))
4032 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
4034 if (!NILP (handler
))
4037 val
= call6 (handler
, Qwrite_region
, start
, end
,
4038 filename
, append
, visit
);
4042 SAVE_MODIFF
= MODIFF
;
4043 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4044 current_buffer
->filename
= visit_file
;
4050 /* Special kludge to simplify auto-saving. */
4053 XSETFASTINT (start
, BEG
);
4054 XSETFASTINT (end
, Z
);
4057 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
4058 count1
= specpdl_ptr
- specpdl
;
4060 given_buffer
= current_buffer
;
4061 annotations
= build_annotations (start
, end
, coding
.pre_write_conversion
);
4062 if (current_buffer
!= given_buffer
)
4064 XSETFASTINT (start
, BEGV
);
4065 XSETFASTINT (end
, ZV
);
4068 #ifdef CLASH_DETECTION
4071 #if 0 /* This causes trouble for GNUS. */
4072 /* If we've locked this file for some other buffer,
4073 query before proceeding. */
4074 if (!visiting
&& EQ (Ffile_locked_p (lockname
), Qt
))
4075 call2 (intern ("ask-user-about-lock"), filename
, Vuser_login_name
);
4078 lock_file (lockname
);
4080 #endif /* CLASH_DETECTION */
4082 encoded_filename
= ENCODE_FILE (filename
);
4084 fn
= XSTRING (encoded_filename
)->data
;
4088 desc
= open (fn
, O_WRONLY
| buffer_file_type
);
4089 #else /* not DOS_NT */
4090 desc
= open (fn
, O_WRONLY
);
4091 #endif /* not DOS_NT */
4093 if (desc
< 0 && (NILP (append
) || errno
== ENOENT
))
4095 if (auto_saving
) /* Overwrite any previous version of autosave file */
4097 vms_truncate (fn
); /* if fn exists, truncate to zero length */
4098 desc
= open (fn
, O_RDWR
);
4100 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
4101 ? XSTRING (current_buffer
->filename
)->data
: 0,
4104 else /* Write to temporary name and rename if no errors */
4106 Lisp_Object temp_name
;
4107 temp_name
= Ffile_name_directory (filename
);
4109 if (!NILP (temp_name
))
4111 temp_name
= Fmake_temp_name (concat2 (temp_name
,
4112 build_string ("$$SAVE$$")));
4113 fname
= XSTRING (filename
)->data
;
4114 fn
= XSTRING (temp_name
)->data
;
4115 desc
= creat_copy_attrs (fname
, fn
);
4118 /* If we can't open the temporary file, try creating a new
4119 version of the original file. VMS "creat" creates a
4120 new version rather than truncating an existing file. */
4123 desc
= creat (fn
, 0666);
4124 #if 0 /* This can clobber an existing file and fail to replace it,
4125 if the user runs out of space. */
4128 /* We can't make a new version;
4129 try to truncate and rewrite existing version if any. */
4131 desc
= open (fn
, O_RDWR
);
4137 desc
= creat (fn
, 0666);
4142 O_WRONLY
| O_TRUNC
| O_CREAT
| buffer_file_type
,
4143 S_IREAD
| S_IWRITE
);
4144 #else /* not DOS_NT */
4145 desc
= creat (fn
, auto_saving
? auto_save_mode_bits
: 0666);
4146 #endif /* not DOS_NT */
4147 #endif /* not VMS */
4153 #ifdef CLASH_DETECTION
4155 if (!auto_saving
) unlock_file (lockname
);
4157 #endif /* CLASH_DETECTION */
4158 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
4161 record_unwind_protect (close_file_unwind
, make_number (desc
));
4164 if (lseek (desc
, 0, 2) < 0)
4166 #ifdef CLASH_DETECTION
4167 if (!auto_saving
) unlock_file (lockname
);
4168 #endif /* CLASH_DETECTION */
4169 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
4174 * Kludge Warning: The VMS C RTL likes to insert carriage returns
4175 * if we do writes that don't end with a carriage return. Furthermore
4176 * it cannot handle writes of more then 16K. The modified
4177 * version of "sys_write" in SYSDEP.C (see comment there) copes with
4178 * this EXCEPT for the last record (iff it doesn't end with a carriage
4179 * return). This implies that if your buffer doesn't end with a carriage
4180 * return, you get one free... tough. However it also means that if
4181 * we make two calls to sys_write (a la the following code) you can
4182 * get one at the gap as well. The easiest way to fix this (honest)
4183 * is to move the gap to the next newline (or the end of the buffer).
4188 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4189 move_gap (find_next_newline (GPT
, 1));
4191 /* Whether VMS or not, we must move the gap to the next of newline
4192 when we must put designation sequences at beginning of line. */
4193 if (INTEGERP (start
)
4194 && coding
.type
== coding_type_iso2022
4195 && coding
.flags
& CODING_FLAG_ISO_DESIGNATE_AT_BOL
4196 && GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4198 int opoint
= PT
, opoint_byte
= PT_BYTE
;
4199 scan_newline (PT
, PT_BYTE
, ZV
, ZV_BYTE
, 1, 0);
4200 move_gap_both (PT
, PT_BYTE
);
4201 SET_PT_BOTH (opoint
, opoint_byte
);
4208 if (STRINGP (start
))
4210 failure
= 0 > a_write (desc
, XSTRING (start
)->data
,
4211 XSTRING (start
)->size
, 0, &annotations
, &coding
);
4214 else if (XINT (start
) != XINT (end
))
4216 register int end1
= CHAR_TO_BYTE (XINT (end
));
4218 tem
= CHAR_TO_BYTE (XINT (start
));
4220 if (XINT (start
) < GPT
)
4222 failure
= 0 > a_write (desc
, BYTE_POS_ADDR (tem
),
4223 min (GPT_BYTE
, end1
) - tem
, tem
, &annotations
,
4228 if (XINT (end
) > GPT
&& !failure
)
4230 tem
= max (tem
, GPT_BYTE
);
4231 failure
= 0 > a_write (desc
, BYTE_POS_ADDR (tem
), end1
- tem
,
4232 tem
, &annotations
, &coding
);
4238 /* If file was empty, still need to write the annotations */
4239 coding
.last_block
= 1;
4240 failure
= 0 > a_write (desc
, "", 0, XINT (start
), &annotations
, &coding
);
4244 if (CODING_REQUIRE_FLUSHING (&coding
) && !coding
.last_block
)
4246 /* We have to flush out a data. */
4247 coding
.last_block
= 1;
4248 failure
= 0 > e_write (desc
, "", 0, &coding
);
4255 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
4256 Disk full in NFS may be reported here. */
4257 /* mib says that closing the file will try to write as fast as NFS can do
4258 it, and that means the fsync here is not crucial for autosave files. */
4259 if (!auto_saving
&& fsync (desc
) < 0)
4261 /* If fsync fails with EINTR, don't treat that as serious. */
4263 failure
= 1, save_errno
= errno
;
4267 /* Spurious "file has changed on disk" warnings have been
4268 observed on Suns as well.
4269 It seems that `close' can change the modtime, under nfs.
4271 (This has supposedly been fixed in Sunos 4,
4272 but who knows about all the other machines with NFS?) */
4275 /* On VMS and APOLLO, must do the stat after the close
4276 since closing changes the modtime. */
4279 /* Recall that #if defined does not work on VMS. */
4286 /* NFS can report a write failure now. */
4287 if (close (desc
) < 0)
4288 failure
= 1, save_errno
= errno
;
4291 /* If we wrote to a temporary name and had no errors, rename to real name. */
4295 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
4303 /* Discard the unwind protect for close_file_unwind. */
4304 specpdl_ptr
= specpdl
+ count1
;
4305 /* Restore the original current buffer. */
4306 visit_file
= unbind_to (count
, visit_file
);
4308 #ifdef CLASH_DETECTION
4310 unlock_file (lockname
);
4311 #endif /* CLASH_DETECTION */
4313 /* Do this before reporting IO error
4314 to avoid a "file has changed on disk" warning on
4315 next attempt to save. */
4317 current_buffer
->modtime
= st
.st_mtime
;
4320 error ("IO error writing %s: %s", XSTRING (filename
)->data
,
4321 strerror (save_errno
));
4325 SAVE_MODIFF
= MODIFF
;
4326 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4327 current_buffer
->filename
= visit_file
;
4328 update_mode_lines
++;
4334 message ("Wrote %s", XSTRING (visit_file
)->data
);
4339 Lisp_Object
merge ();
4341 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
4342 "Return t if (car A) is numerically less than (car B).")
4346 return Flss (Fcar (a
), Fcar (b
));
4349 /* Build the complete list of annotations appropriate for writing out
4350 the text between START and END, by calling all the functions in
4351 write-region-annotate-functions and merging the lists they return.
4352 If one of these functions switches to a different buffer, we assume
4353 that buffer contains altered text. Therefore, the caller must
4354 make sure to restore the current buffer in all cases,
4355 as save-excursion would do. */
4358 build_annotations (start
, end
, pre_write_conversion
)
4359 Lisp_Object start
, end
, pre_write_conversion
;
4361 Lisp_Object annotations
;
4363 struct gcpro gcpro1
, gcpro2
;
4364 Lisp_Object original_buffer
;
4366 XSETBUFFER (original_buffer
, current_buffer
);
4369 p
= Vwrite_region_annotate_functions
;
4370 GCPRO2 (annotations
, p
);
4373 struct buffer
*given_buffer
= current_buffer
;
4374 Vwrite_region_annotations_so_far
= annotations
;
4375 res
= call2 (Fcar (p
), start
, end
);
4376 /* If the function makes a different buffer current,
4377 assume that means this buffer contains altered text to be output.
4378 Reset START and END from the buffer bounds
4379 and discard all previous annotations because they should have
4380 been dealt with by this function. */
4381 if (current_buffer
!= given_buffer
)
4383 XSETFASTINT (start
, BEGV
);
4384 XSETFASTINT (end
, ZV
);
4387 Flength (res
); /* Check basic validity of return value */
4388 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4392 /* Now do the same for annotation functions implied by the file-format */
4393 if (auto_saving
&& (!EQ (Vauto_save_file_format
, Qt
)))
4394 p
= Vauto_save_file_format
;
4396 p
= current_buffer
->file_format
;
4399 struct buffer
*given_buffer
= current_buffer
;
4400 Vwrite_region_annotations_so_far
= annotations
;
4401 res
= call4 (Qformat_annotate_function
, Fcar (p
), start
, end
,
4403 if (current_buffer
!= given_buffer
)
4405 XSETFASTINT (start
, BEGV
);
4406 XSETFASTINT (end
, ZV
);
4410 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4414 /* At last, do the same for the function PRE_WRITE_CONVERSION
4415 implied by the current coding-system. */
4416 if (!NILP (pre_write_conversion
))
4418 struct buffer
*given_buffer
= current_buffer
;
4419 Vwrite_region_annotations_so_far
= annotations
;
4420 res
= call2 (pre_write_conversion
, start
, end
);
4422 annotations
= (current_buffer
!= given_buffer
4424 : merge (annotations
, res
, Qcar_less_than_car
));
4431 /* Write to descriptor DESC the NBYTES bytes starting at ADDR,
4432 assuming they start at byte position BYTEPOS in the buffer.
4433 Intersperse with them the annotations from *ANNOT
4434 which fall within the range of byte positions BYTEPOS to BYTEPOS + NBYTES,
4435 each at its appropriate position.
4437 We modify *ANNOT by discarding elements as we use them up.
4439 The return value is negative in case of system call failure. */
4442 a_write (desc
, addr
, nbytes
, bytepos
, annot
, coding
)
4444 register char *addr
;
4445 register int nbytes
;
4448 struct coding_system
*coding
;
4452 int lastpos
= bytepos
+ nbytes
;
4454 while (NILP (*annot
) || CONSP (*annot
))
4456 tem
= Fcar_safe (Fcar (*annot
));
4459 nextpos
= CHAR_TO_BYTE (XFASTINT (tem
));
4461 /* If there are no more annotations in this range,
4462 output the rest of the range all at once. */
4463 if (! (nextpos
>= bytepos
&& nextpos
<= lastpos
))
4464 return e_write (desc
, addr
, lastpos
- bytepos
, coding
);
4466 /* Output buffer text up to the next annotation's position. */
4467 if (nextpos
> bytepos
)
4469 if (0 > e_write (desc
, addr
, nextpos
- bytepos
, coding
))
4471 addr
+= nextpos
- bytepos
;
4474 /* Output the annotation. */
4475 tem
= Fcdr (Fcar (*annot
));
4478 if (0 > e_write (desc
, XSTRING (tem
)->data
, XSTRING (tem
)->size
,
4482 *annot
= Fcdr (*annot
);
4486 #ifndef WRITE_BUF_SIZE
4487 #define WRITE_BUF_SIZE (16 * 1024)
4490 /* Write NBYTES bytes starting at ADDR into descriptor DESC,
4491 encoding them with coding system CODING. */
4494 e_write (desc
, addr
, nbytes
, coding
)
4496 register char *addr
;
4497 register int nbytes
;
4498 struct coding_system
*coding
;
4500 char buf
[WRITE_BUF_SIZE
];
4501 int produced
, consumed
;
4503 /* We used to have a code for handling selective display here. But,
4504 now it is handled within encode_coding. */
4507 produced
= encode_coding (coding
, addr
, buf
, nbytes
, WRITE_BUF_SIZE
,
4509 nbytes
-= consumed
, addr
+= consumed
;
4512 produced
-= write (desc
, buf
, produced
);
4513 if (produced
) return -1;
4521 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
4522 Sverify_visited_file_modtime
, 1, 1, 0,
4523 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
4524 This means that the file has not been changed since it was visited or saved.")
4530 Lisp_Object handler
;
4531 Lisp_Object filename
;
4533 CHECK_BUFFER (buf
, 0);
4536 if (!STRINGP (b
->filename
)) return Qt
;
4537 if (b
->modtime
== 0) return Qt
;
4539 /* If the file name has special constructs in it,
4540 call the corresponding file handler. */
4541 handler
= Ffind_file_name_handler (b
->filename
,
4542 Qverify_visited_file_modtime
);
4543 if (!NILP (handler
))
4544 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
4546 filename
= ENCODE_FILE (b
->filename
);
4548 if (stat (XSTRING (filename
)->data
, &st
) < 0)
4550 /* If the file doesn't exist now and didn't exist before,
4551 we say that it isn't modified, provided the error is a tame one. */
4552 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
4557 if (st
.st_mtime
== b
->modtime
4558 /* If both are positive, accept them if they are off by one second. */
4559 || (st
.st_mtime
> 0 && b
->modtime
> 0
4560 && (st
.st_mtime
== b
->modtime
+ 1
4561 || st
.st_mtime
== b
->modtime
- 1)))
4566 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
4567 Sclear_visited_file_modtime
, 0, 0, 0,
4568 "Clear out records of last mod time of visited file.\n\
4569 Next attempt to save will certainly not complain of a discrepancy.")
4572 current_buffer
->modtime
= 0;
4576 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
4577 Svisited_file_modtime
, 0, 0, 0,
4578 "Return the current buffer's recorded visited file modification time.\n\
4579 The value is a list of the form (HIGH . LOW), like the time values\n\
4580 that `file-attributes' returns.")
4583 return long_to_cons ((unsigned long) current_buffer
->modtime
);
4586 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
4587 Sset_visited_file_modtime
, 0, 1, 0,
4588 "Update buffer's recorded modification time from the visited file's time.\n\
4589 Useful if the buffer was not read from the file normally\n\
4590 or if the file itself has been changed for some known benign reason.\n\
4591 An argument specifies the modification time value to use\n\
4592 \(instead of that of the visited file), in the form of a list\n\
4593 \(HIGH . LOW) or (HIGH LOW).")
4595 Lisp_Object time_list
;
4597 if (!NILP (time_list
))
4598 current_buffer
->modtime
= cons_to_long (time_list
);
4601 register Lisp_Object filename
;
4603 Lisp_Object handler
;
4605 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
4607 /* If the file name has special constructs in it,
4608 call the corresponding file handler. */
4609 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
4610 if (!NILP (handler
))
4611 /* The handler can find the file name the same way we did. */
4612 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
4614 filename
= ENCODE_FILE (filename
);
4616 if (stat (XSTRING (filename
)->data
, &st
) >= 0)
4617 current_buffer
->modtime
= st
.st_mtime
;
4627 message ("Autosaving...error for %s", XSTRING (current_buffer
->name
)->data
);
4628 Fsleep_for (make_number (1), Qnil
);
4629 message ("Autosaving...error!for %s", XSTRING (current_buffer
->name
)->data
);
4630 Fsleep_for (make_number (1), Qnil
);
4631 message ("Autosaving...error for %s", XSTRING (current_buffer
->name
)->data
);
4632 Fsleep_for (make_number (1), Qnil
);
4642 /* Get visited file's mode to become the auto save file's mode. */
4643 if (stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
4644 /* But make sure we can overwrite it later! */
4645 auto_save_mode_bits
= st
.st_mode
| 0600;
4647 auto_save_mode_bits
= 0666;
4650 Fwrite_region (Qnil
, Qnil
,
4651 current_buffer
->auto_save_file_name
,
4652 Qnil
, Qlambda
, Qnil
);
4656 do_auto_save_unwind (stream
) /* used as unwind-protect function */
4661 fclose ((FILE *) (XFASTINT (XCONS (stream
)->car
) << 16
4662 | XFASTINT (XCONS (stream
)->cdr
)));
4667 do_auto_save_unwind_1 (value
) /* used as unwind-protect function */
4670 minibuffer_auto_raise
= XINT (value
);
4674 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
4675 "Auto-save all buffers that need it.\n\
4676 This is all buffers that have auto-saving enabled\n\
4677 and are changed since last auto-saved.\n\
4678 Auto-saving writes the buffer into a file\n\
4679 so that your editing is not lost if the system crashes.\n\
4680 This file is not the file you visited; that changes only when you save.\n\
4681 Normally we run the normal hook `auto-save-hook' before saving.\n\n\
4682 A non-nil NO-MESSAGE argument means do not print any message if successful.\n\
4683 A non-nil CURRENT-ONLY argument means save only current buffer.")
4684 (no_message
, current_only
)
4685 Lisp_Object no_message
, current_only
;
4687 struct buffer
*old
= current_buffer
, *b
;
4688 Lisp_Object tail
, buf
;
4690 char *omessage
= echo_area_glyphs
;
4691 int omessage_length
= echo_area_glyphs_length
;
4692 int do_handled_files
;
4695 Lisp_Object lispstream
;
4696 int count
= specpdl_ptr
- specpdl
;
4698 int orig_minibuffer_auto_raise
= minibuffer_auto_raise
;
4700 /* Ordinarily don't quit within this function,
4701 but don't make it impossible to quit (in case we get hung in I/O). */
4705 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
4706 point to non-strings reached from Vbuffer_alist. */
4711 if (!NILP (Vrun_hooks
))
4712 call1 (Vrun_hooks
, intern ("auto-save-hook"));
4714 if (STRINGP (Vauto_save_list_file_name
))
4716 Lisp_Object listfile
;
4717 listfile
= Fexpand_file_name (Vauto_save_list_file_name
, Qnil
);
4718 stream
= fopen (XSTRING (listfile
)->data
, "w");
4721 /* Arrange to close that file whether or not we get an error.
4722 Also reset auto_saving to 0. */
4723 lispstream
= Fcons (Qnil
, Qnil
);
4724 XSETFASTINT (XCONS (lispstream
)->car
, (EMACS_UINT
)stream
>> 16);
4725 XSETFASTINT (XCONS (lispstream
)->cdr
, (EMACS_UINT
)stream
& 0xffff);
4736 record_unwind_protect (do_auto_save_unwind
, lispstream
);
4737 record_unwind_protect (do_auto_save_unwind_1
,
4738 make_number (minibuffer_auto_raise
));
4739 minibuffer_auto_raise
= 0;
4742 /* First, save all files which don't have handlers. If Emacs is
4743 crashing, the handlers may tweak what is causing Emacs to crash
4744 in the first place, and it would be a shame if Emacs failed to
4745 autosave perfectly ordinary files because it couldn't handle some
4747 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
4748 for (tail
= Vbuffer_alist
; GC_CONSP (tail
); tail
= XCONS (tail
)->cdr
)
4750 buf
= XCONS (XCONS (tail
)->car
)->cdr
;
4753 /* Record all the buffers that have auto save mode
4754 in the special file that lists them. For each of these buffers,
4755 Record visited name (if any) and auto save name. */
4756 if (STRINGP (b
->auto_save_file_name
)
4757 && stream
!= NULL
&& do_handled_files
== 0)
4759 if (!NILP (b
->filename
))
4761 fwrite (XSTRING (b
->filename
)->data
, 1,
4762 XSTRING (b
->filename
)->size
, stream
);
4764 putc ('\n', stream
);
4765 fwrite (XSTRING (b
->auto_save_file_name
)->data
, 1,
4766 XSTRING (b
->auto_save_file_name
)->size
, stream
);
4767 putc ('\n', stream
);
4770 if (!NILP (current_only
)
4771 && b
!= current_buffer
)
4774 /* Don't auto-save indirect buffers.
4775 The base buffer takes care of it. */
4779 /* Check for auto save enabled
4780 and file changed since last auto save
4781 and file changed since last real save. */
4782 if (STRINGP (b
->auto_save_file_name
)
4783 && BUF_SAVE_MODIFF (b
) < BUF_MODIFF (b
)
4784 && b
->auto_save_modified
< BUF_MODIFF (b
)
4785 /* -1 means we've turned off autosaving for a while--see below. */
4786 && XINT (b
->save_length
) >= 0
4787 && (do_handled_files
4788 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
4791 EMACS_TIME before_time
, after_time
;
4793 EMACS_GET_TIME (before_time
);
4795 /* If we had a failure, don't try again for 20 minutes. */
4796 if (b
->auto_save_failure_time
>= 0
4797 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
4800 if ((XFASTINT (b
->save_length
) * 10
4801 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
4802 /* A short file is likely to change a large fraction;
4803 spare the user annoying messages. */
4804 && XFASTINT (b
->save_length
) > 5000
4805 /* These messages are frequent and annoying for `*mail*'. */
4806 && !EQ (b
->filename
, Qnil
)
4807 && NILP (no_message
))
4809 /* It has shrunk too much; turn off auto-saving here. */
4810 minibuffer_auto_raise
= orig_minibuffer_auto_raise
;
4811 message ("Buffer %s has shrunk a lot; auto save turned off there",
4812 XSTRING (b
->name
)->data
);
4813 minibuffer_auto_raise
= 0;
4814 /* Turn off auto-saving until there's a real save,
4815 and prevent any more warnings. */
4816 XSETINT (b
->save_length
, -1);
4817 Fsleep_for (make_number (1), Qnil
);
4820 set_buffer_internal (b
);
4821 if (!auto_saved
&& NILP (no_message
))
4822 message1 ("Auto-saving...");
4823 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
4825 b
->auto_save_modified
= BUF_MODIFF (b
);
4826 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4827 set_buffer_internal (old
);
4829 EMACS_GET_TIME (after_time
);
4831 /* If auto-save took more than 60 seconds,
4832 assume it was an NFS failure that got a timeout. */
4833 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
4834 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
4838 /* Prevent another auto save till enough input events come in. */
4839 record_auto_save ();
4841 if (auto_saved
&& NILP (no_message
))
4845 sit_for (1, 0, 0, 0, 0);
4846 message2 (omessage
, omessage_length
);
4849 message1 ("Auto-saving...done");
4854 unbind_to (count
, Qnil
);
4858 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
4859 Sset_buffer_auto_saved
, 0, 0, 0,
4860 "Mark current buffer as auto-saved with its current text.\n\
4861 No auto-save file will be written until the buffer changes again.")
4864 current_buffer
->auto_save_modified
= MODIFF
;
4865 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4866 current_buffer
->auto_save_failure_time
= -1;
4870 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
4871 Sclear_buffer_auto_save_failure
, 0, 0, 0,
4872 "Clear any record of a recent auto-save failure in the current buffer.")
4875 current_buffer
->auto_save_failure_time
= -1;
4879 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
4881 "Return t if buffer has been auto-saved since last read in or saved.")
4884 return (SAVE_MODIFF
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
4887 /* Reading and completing file names */
4888 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
4890 /* In the string VAL, change each $ to $$ and return the result. */
4893 double_dollars (val
)
4896 register unsigned char *old
, *new;
4900 osize
= XSTRING (val
)->size
;
4901 /* Quote "$" as "$$" to get it past substitute-in-file-name */
4902 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
4903 if (*old
++ == '$') count
++;
4906 old
= XSTRING (val
)->data
;
4907 val
= Fmake_string (make_number (osize
+ count
), make_number (0));
4908 new = XSTRING (val
)->data
;
4909 for (n
= osize
; n
> 0; n
--)
4922 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
4924 "Internal subroutine for read-file-name. Do not call this.")
4925 (string
, dir
, action
)
4926 Lisp_Object string
, dir
, action
;
4927 /* action is nil for complete, t for return list of completions,
4928 lambda for verify final value */
4930 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
4932 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
4934 CHECK_STRING (string
, 0);
4941 /* No need to protect ACTION--we only compare it with t and nil. */
4942 GCPRO5 (string
, realdir
, name
, specdir
, orig_string
);
4944 if (XSTRING (string
)->size
== 0)
4946 if (EQ (action
, Qlambda
))
4954 orig_string
= string
;
4955 string
= Fsubstitute_in_file_name (string
);
4956 changed
= NILP (Fstring_equal (string
, orig_string
));
4957 name
= Ffile_name_nondirectory (string
);
4958 val
= Ffile_name_directory (string
);
4960 realdir
= Fexpand_file_name (val
, realdir
);
4965 specdir
= Ffile_name_directory (string
);
4966 val
= Ffile_name_completion (name
, realdir
);
4971 return double_dollars (string
);
4975 if (!NILP (specdir
))
4976 val
= concat2 (specdir
, val
);
4978 return double_dollars (val
);
4981 #endif /* not VMS */
4985 if (EQ (action
, Qt
))
4986 return Ffile_name_all_completions (name
, realdir
);
4987 /* Only other case actually used is ACTION = lambda */
4989 /* Supposedly this helps commands such as `cd' that read directory names,
4990 but can someone explain how it helps them? -- RMS */
4991 if (XSTRING (name
)->size
== 0)
4994 return Ffile_exists_p (string
);
4997 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
4998 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
4999 Value is not expanded---you must call `expand-file-name' yourself.\n\
5000 Default name to DEFAULT-FILENAME if user enters a null string.\n\
5001 (If DEFAULT-FILENAME is omitted, the visited file name is used,\n\
5002 except that if INITIAL is specified, that combined with DIR is used.)\n\
5003 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
5004 Non-nil and non-t means also require confirmation after completion.\n\
5005 Fifth arg INITIAL specifies text to start with.\n\
5006 DIR defaults to current buffer's directory default.")
5007 (prompt
, dir
, default_filename
, mustmatch
, initial
)
5008 Lisp_Object prompt
, dir
, default_filename
, mustmatch
, initial
;
5010 Lisp_Object val
, insdef
, insdef1
, tem
;
5011 struct gcpro gcpro1
, gcpro2
;
5012 register char *homedir
;
5016 dir
= current_buffer
->directory
;
5017 if (NILP (default_filename
))
5019 if (! NILP (initial
))
5020 default_filename
= Fexpand_file_name (initial
, dir
);
5022 default_filename
= current_buffer
->filename
;
5025 /* If dir starts with user's homedir, change that to ~. */
5026 homedir
= (char *) egetenv ("HOME");
5028 homedir
= strcpy (alloca (strlen (homedir
) + 1), homedir
);
5029 CORRECT_DIR_SEPS (homedir
);
5033 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5034 && IS_DIRECTORY_SEP (XSTRING (dir
)->data
[strlen (homedir
)]))
5036 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5037 XSTRING (dir
)->size
- strlen (homedir
) + 1);
5038 XSTRING (dir
)->data
[0] = '~';
5041 if (insert_default_directory
&& STRINGP (dir
))
5044 if (!NILP (initial
))
5046 Lisp_Object args
[2], pos
;
5050 insdef
= Fconcat (2, args
);
5051 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
5052 insdef1
= Fcons (double_dollars (insdef
), pos
);
5055 insdef1
= double_dollars (insdef
);
5057 else if (STRINGP (initial
))
5060 insdef1
= Fcons (double_dollars (insdef
), make_number (0));
5063 insdef
= Qnil
, insdef1
= Qnil
;
5066 count
= specpdl_ptr
- specpdl
;
5067 specbind (intern ("completion-ignore-case"), Qt
);
5070 GCPRO2 (insdef
, default_filename
);
5071 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5072 dir
, mustmatch
, insdef1
,
5073 Qfile_name_history
, default_filename
, Qnil
);
5074 /* If Fcompleting_read returned the default string itself
5075 (rather than a new string with the same contents),
5076 it has to mean that the user typed RET with the minibuffer empty.
5077 In that case, we really want to return ""
5078 so that commands such as set-visited-file-name can distinguish. */
5079 if (EQ (val
, default_filename
))
5080 val
= build_string ("");
5083 unbind_to (count
, Qnil
);
5088 error ("No file name specified");
5089 tem
= Fstring_equal (val
, insdef
);
5090 if (!NILP (tem
) && !NILP (default_filename
))
5091 return default_filename
;
5092 if (XSTRING (val
)->size
== 0 && NILP (insdef
))
5094 if (!NILP (default_filename
))
5095 return default_filename
;
5097 error ("No default file name");
5099 return Fsubstitute_in_file_name (val
);
5102 #if 0 /* Old version */
5103 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
5104 /* Don't confuse make-docfile by having two doc strings for this function.
5105 make-docfile does not pay attention to #if, for good reason! */
5107 (prompt
, dir
, defalt
, mustmatch
, initial
)
5108 Lisp_Object prompt
, dir
, defalt
, mustmatch
, initial
;
5110 Lisp_Object val
, insdef
, tem
;
5111 struct gcpro gcpro1
, gcpro2
;
5112 register char *homedir
;
5116 dir
= current_buffer
->directory
;
5118 defalt
= current_buffer
->filename
;
5120 /* If dir starts with user's homedir, change that to ~. */
5121 homedir
= (char *) egetenv ("HOME");
5124 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5125 && XSTRING (dir
)->data
[strlen (homedir
)] == '/')
5127 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5128 XSTRING (dir
)->size
- strlen (homedir
) + 1);
5129 XSTRING (dir
)->data
[0] = '~';
5132 if (!NILP (initial
))
5134 else if (insert_default_directory
)
5137 insdef
= build_string ("");
5140 count
= specpdl_ptr
- specpdl
;
5141 specbind (intern ("completion-ignore-case"), Qt
);
5144 GCPRO2 (insdef
, defalt
);
5145 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5147 insert_default_directory
? insdef
: Qnil
,
5148 Qfile_name_history
, Qnil
, Qnil
);
5151 unbind_to (count
, Qnil
);
5156 error ("No file name specified");
5157 tem
= Fstring_equal (val
, insdef
);
5158 if (!NILP (tem
) && !NILP (defalt
))
5160 return Fsubstitute_in_file_name (val
);
5162 #endif /* Old version */
5166 Qexpand_file_name
= intern ("expand-file-name");
5167 Qsubstitute_in_file_name
= intern ("substitute-in-file-name");
5168 Qdirectory_file_name
= intern ("directory-file-name");
5169 Qfile_name_directory
= intern ("file-name-directory");
5170 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
5171 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
5172 Qfile_name_as_directory
= intern ("file-name-as-directory");
5173 Qcopy_file
= intern ("copy-file");
5174 Qmake_directory_internal
= intern ("make-directory-internal");
5175 Qdelete_directory
= intern ("delete-directory");
5176 Qdelete_file
= intern ("delete-file");
5177 Qrename_file
= intern ("rename-file");
5178 Qadd_name_to_file
= intern ("add-name-to-file");
5179 Qmake_symbolic_link
= intern ("make-symbolic-link");
5180 Qfile_exists_p
= intern ("file-exists-p");
5181 Qfile_executable_p
= intern ("file-executable-p");
5182 Qfile_readable_p
= intern ("file-readable-p");
5183 Qfile_writable_p
= intern ("file-writable-p");
5184 Qfile_symlink_p
= intern ("file-symlink-p");
5185 Qaccess_file
= intern ("access-file");
5186 Qfile_directory_p
= intern ("file-directory-p");
5187 Qfile_regular_p
= intern ("file-regular-p");
5188 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
5189 Qfile_modes
= intern ("file-modes");
5190 Qset_file_modes
= intern ("set-file-modes");
5191 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
5192 Qinsert_file_contents
= intern ("insert-file-contents");
5193 Qwrite_region
= intern ("write-region");
5194 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
5195 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
5197 staticpro (&Qexpand_file_name
);
5198 staticpro (&Qsubstitute_in_file_name
);
5199 staticpro (&Qdirectory_file_name
);
5200 staticpro (&Qfile_name_directory
);
5201 staticpro (&Qfile_name_nondirectory
);
5202 staticpro (&Qunhandled_file_name_directory
);
5203 staticpro (&Qfile_name_as_directory
);
5204 staticpro (&Qcopy_file
);
5205 staticpro (&Qmake_directory_internal
);
5206 staticpro (&Qdelete_directory
);
5207 staticpro (&Qdelete_file
);
5208 staticpro (&Qrename_file
);
5209 staticpro (&Qadd_name_to_file
);
5210 staticpro (&Qmake_symbolic_link
);
5211 staticpro (&Qfile_exists_p
);
5212 staticpro (&Qfile_executable_p
);
5213 staticpro (&Qfile_readable_p
);
5214 staticpro (&Qfile_writable_p
);
5215 staticpro (&Qaccess_file
);
5216 staticpro (&Qfile_symlink_p
);
5217 staticpro (&Qfile_directory_p
);
5218 staticpro (&Qfile_regular_p
);
5219 staticpro (&Qfile_accessible_directory_p
);
5220 staticpro (&Qfile_modes
);
5221 staticpro (&Qset_file_modes
);
5222 staticpro (&Qfile_newer_than_file_p
);
5223 staticpro (&Qinsert_file_contents
);
5224 staticpro (&Qwrite_region
);
5225 staticpro (&Qverify_visited_file_modtime
);
5226 staticpro (&Qset_visited_file_modtime
);
5228 Qfile_name_history
= intern ("file-name-history");
5229 Fset (Qfile_name_history
, Qnil
);
5230 staticpro (&Qfile_name_history
);
5232 Qfile_error
= intern ("file-error");
5233 staticpro (&Qfile_error
);
5234 Qfile_already_exists
= intern ("file-already-exists");
5235 staticpro (&Qfile_already_exists
);
5236 Qfile_date_error
= intern ("file-date-error");
5237 staticpro (&Qfile_date_error
);
5240 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
5241 staticpro (&Qfind_buffer_file_type
);
5244 DEFVAR_LISP ("file-name-coding-system", &Vfile_name_coding_system
,
5245 "*Coding system for encoding file names.");
5246 Vfile_name_coding_system
= Qnil
;
5248 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format
,
5249 "*Format in which to write auto-save files.\n\
5250 Should be a list of symbols naming formats that are defined in `format-alist'.\n\
5251 If it is t, which is the default, auto-save files are written in the\n\
5252 same format as a regular save would use.");
5253 Vauto_save_file_format
= Qt
;
5255 Qformat_decode
= intern ("format-decode");
5256 staticpro (&Qformat_decode
);
5257 Qformat_annotate_function
= intern ("format-annotate-function");
5258 staticpro (&Qformat_annotate_function
);
5260 Qcar_less_than_car
= intern ("car-less-than-car");
5261 staticpro (&Qcar_less_than_car
);
5263 Fput (Qfile_error
, Qerror_conditions
,
5264 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
5265 Fput (Qfile_error
, Qerror_message
,
5266 build_string ("File error"));
5268 Fput (Qfile_already_exists
, Qerror_conditions
,
5269 Fcons (Qfile_already_exists
,
5270 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5271 Fput (Qfile_already_exists
, Qerror_message
,
5272 build_string ("File already exists"));
5274 Fput (Qfile_date_error
, Qerror_conditions
,
5275 Fcons (Qfile_date_error
,
5276 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5277 Fput (Qfile_date_error
, Qerror_message
,
5278 build_string ("Cannot set file date"));
5280 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
5281 "*Non-nil means when reading a filename start with default dir in minibuffer.");
5282 insert_default_directory
= 1;
5284 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
5285 "*Non-nil means write new files with record format `stmlf'.\n\
5286 nil means use format `var'. This variable is meaningful only on VMS.");
5287 vms_stmlf_recfm
= 0;
5289 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char
,
5290 "Directory separator character for built-in functions that return file names.\n\
5291 The value should be either ?/ or ?\\ (any other value is treated as ?\\).\n\
5292 This variable affects the built-in functions only on Windows,\n\
5293 on other platforms, it is initialized so that Lisp code can find out\n\
5294 what the normal separator is.");
5295 XSETFASTINT (Vdirectory_sep_char
, '/');
5297 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
5298 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
5299 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
5302 The first argument given to HANDLER is the name of the I/O primitive\n\
5303 to be handled; the remaining arguments are the arguments that were\n\
5304 passed to that primitive. For example, if you do\n\
5305 (file-exists-p FILENAME)\n\
5306 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
5307 (funcall HANDLER 'file-exists-p FILENAME)\n\
5308 The function `find-file-name-handler' checks this list for a handler\n\
5309 for its argument.");
5310 Vfile_name_handler_alist
= Qnil
;
5312 DEFVAR_LISP ("set-auto-coding-function",
5313 &Vset_auto_coding_function
,
5314 "If non-nil, a function to call to decide a coding system of file.\n\
5315 One argument is passed to this function: the string of concatination\n\
5316 or the heading 1K-byte and the tailing 3K-byte of a file to be read.\n\
5317 This function should return a coding system to decode the file contents\n\
5318 specified in the heading lines with the format:\n\
5319 -*- ... coding: CODING-SYSTEM; ... -*-\n\
5320 or local variable spec of the tailing lines with `coding:' tag.");
5321 Vset_auto_coding_function
= Qnil
;
5323 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
5324 "A list of functions to be called at the end of `insert-file-contents'.\n\
5325 Each is passed one argument, the number of bytes inserted. It should return\n\
5326 the new byte count, and leave point the same. If `insert-file-contents' is\n\
5327 intercepted by a handler from `file-name-handler-alist', that handler is\n\
5328 responsible for calling the after-insert-file-functions if appropriate.");
5329 Vafter_insert_file_functions
= Qnil
;
5331 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
5332 "A list of functions to be called at the start of `write-region'.\n\
5333 Each is passed two arguments, START and END as for `write-region'.\n\
5334 These are usually two numbers but not always; see the documentation\n\
5335 for `write-region'. The function should return a list of pairs\n\
5336 of the form (POSITION . STRING), consisting of strings to be effectively\n\
5337 inserted at the specified positions of the file being written (1 means to\n\
5338 insert before the first byte written). The POSITIONs must be sorted into\n\
5339 increasing order. If there are several functions in the list, the several\n\
5340 lists are merged destructively.");
5341 Vwrite_region_annotate_functions
= Qnil
;
5343 DEFVAR_LISP ("write-region-annotations-so-far",
5344 &Vwrite_region_annotations_so_far
,
5345 "When an annotation function is called, this holds the previous annotations.\n\
5346 These are the annotations made by other annotation functions\n\
5347 that were already called. See also `write-region-annotate-functions'.");
5348 Vwrite_region_annotations_so_far
= Qnil
;
5350 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
5351 "A list of file name handlers that temporarily should not be used.\n\
5352 This applies only to the operation `inhibit-file-name-operation'.");
5353 Vinhibit_file_name_handlers
= Qnil
;
5355 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
5356 "The operation for which `inhibit-file-name-handlers' is applicable.");
5357 Vinhibit_file_name_operation
= Qnil
;
5359 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
5360 "File name in which we write a list of all auto save file names.\n\
5361 This variable is initialized automatically from `auto-save-list-file-prefix'\n\
5362 shortly after Emacs reads your `.emacs' file, if you have not yet given it\n\
5364 Vauto_save_list_file_name
= Qnil
;
5366 defsubr (&Sfind_file_name_handler
);
5367 defsubr (&Sfile_name_directory
);
5368 defsubr (&Sfile_name_nondirectory
);
5369 defsubr (&Sunhandled_file_name_directory
);
5370 defsubr (&Sfile_name_as_directory
);
5371 defsubr (&Sdirectory_file_name
);
5372 defsubr (&Smake_temp_name
);
5373 defsubr (&Sexpand_file_name
);
5374 defsubr (&Ssubstitute_in_file_name
);
5375 defsubr (&Scopy_file
);
5376 defsubr (&Smake_directory_internal
);
5377 defsubr (&Sdelete_directory
);
5378 defsubr (&Sdelete_file
);
5379 defsubr (&Srename_file
);
5380 defsubr (&Sadd_name_to_file
);
5382 defsubr (&Smake_symbolic_link
);
5383 #endif /* S_IFLNK */
5385 defsubr (&Sdefine_logical_name
);
5388 defsubr (&Ssysnetunam
);
5389 #endif /* HPUX_NET */
5390 defsubr (&Sfile_name_absolute_p
);
5391 defsubr (&Sfile_exists_p
);
5392 defsubr (&Sfile_executable_p
);
5393 defsubr (&Sfile_readable_p
);
5394 defsubr (&Sfile_writable_p
);
5395 defsubr (&Saccess_file
);
5396 defsubr (&Sfile_symlink_p
);
5397 defsubr (&Sfile_directory_p
);
5398 defsubr (&Sfile_accessible_directory_p
);
5399 defsubr (&Sfile_regular_p
);
5400 defsubr (&Sfile_modes
);
5401 defsubr (&Sset_file_modes
);
5402 defsubr (&Sset_default_file_modes
);
5403 defsubr (&Sdefault_file_modes
);
5404 defsubr (&Sfile_newer_than_file_p
);
5405 defsubr (&Sinsert_file_contents
);
5406 defsubr (&Swrite_region
);
5407 defsubr (&Scar_less_than_car
);
5408 defsubr (&Sverify_visited_file_modtime
);
5409 defsubr (&Sclear_visited_file_modtime
);
5410 defsubr (&Svisited_file_modtime
);
5411 defsubr (&Sset_visited_file_modtime
);
5412 defsubr (&Sdo_auto_save
);
5413 defsubr (&Sset_buffer_auto_saved
);
5414 defsubr (&Sclear_buffer_auto_save_failure
);
5415 defsubr (&Srecent_auto_save_p
);
5417 defsubr (&Sread_file_name_internal
);
5418 defsubr (&Sread_file_name
);
5421 defsubr (&Sunix_sync
);