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
);
413 if (STRING_MULTIBYTE (filename
))
414 return make_string (beg
, p
- beg
);
415 return make_unibyte_string (beg
, p
- beg
);
418 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory
,
419 Sfile_name_nondirectory
, 1, 1, 0,
420 "Return file name FILENAME sans its directory.\n\
421 For example, in a Unix-syntax file name,\n\
422 this is everything after the last slash,\n\
423 or the entire name if it contains no slash.")
425 Lisp_Object filename
;
427 register unsigned char *beg
, *p
, *end
;
430 CHECK_STRING (filename
, 0);
432 /* If the file name has special constructs in it,
433 call the corresponding file handler. */
434 handler
= Ffind_file_name_handler (filename
, Qfile_name_nondirectory
);
436 return call2 (handler
, Qfile_name_nondirectory
, filename
);
438 beg
= XSTRING (filename
)->data
;
439 end
= p
= beg
+ XSTRING (filename
)->size
;
441 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
443 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
446 /* only recognise drive specifier at beginning */
447 && !(p
[-1] == ':' && p
== beg
+ 2)
452 if (STRING_MULTIBYTE (filename
))
453 return make_string (p
, end
- p
);
454 return make_unibyte_string (p
, end
- p
);
457 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory
,
458 Sunhandled_file_name_directory
, 1, 1, 0,
459 "Return a directly usable directory name somehow associated with FILENAME.\n\
460 A `directly usable' directory name is one that may be used without the\n\
461 intervention of any file handler.\n\
462 If FILENAME is a directly usable file itself, return\n\
463 \(file-name-directory FILENAME).\n\
464 The `call-process' and `start-process' functions use this function to\n\
465 get a current directory to run processes in.")
467 Lisp_Object filename
;
471 /* If the file name has special constructs in it,
472 call the corresponding file handler. */
473 handler
= Ffind_file_name_handler (filename
, Qunhandled_file_name_directory
);
475 return call2 (handler
, Qunhandled_file_name_directory
, filename
);
477 return Ffile_name_directory (filename
);
482 file_name_as_directory (out
, in
)
485 int size
= strlen (in
) - 1;
488 error ("Empty file name");
493 /* Is it already a directory string? */
494 if (in
[size
] == ':' || in
[size
] == ']' || in
[size
] == '>')
496 /* Is it a VMS directory file name? If so, hack VMS syntax. */
497 else if (! index (in
, '/')
498 && ((size
> 3 && ! strcmp (&in
[size
- 3], ".DIR"))
499 || (size
> 3 && ! strcmp (&in
[size
- 3], ".dir"))
500 || (size
> 5 && (! strncmp (&in
[size
- 5], ".DIR", 4)
501 || ! strncmp (&in
[size
- 5], ".dir", 4))
502 && (in
[size
- 1] == '.' || in
[size
- 1] == ';')
503 && in
[size
] == '1')))
505 register char *p
, *dot
;
509 dir:x.dir --> dir:[x]
510 dir:[x]y.dir --> dir:[x.y] */
512 while (p
!= in
&& *p
!= ':' && *p
!= '>' && *p
!= ']') p
--;
515 strncpy (out
, in
, p
- in
);
534 dot
= index (p
, '.');
537 /* blindly remove any extension */
538 size
= strlen (out
) + (dot
- p
);
539 strncat (out
, p
, dot
- p
);
550 /* For Unix syntax, Append a slash if necessary */
551 if (!IS_DIRECTORY_SEP (out
[size
]))
553 out
[size
+ 1] = DIRECTORY_SEP
;
554 out
[size
+ 2] = '\0';
557 CORRECT_DIR_SEPS (out
);
563 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
564 Sfile_name_as_directory
, 1, 1, 0,
565 "Return a string representing file FILENAME interpreted as a directory.\n\
566 This operation exists because a directory is also a file, but its name as\n\
567 a directory is different from its name as a file.\n\
568 The result can be used as the value of `default-directory'\n\
569 or passed as second argument to `expand-file-name'.\n\
570 For a Unix-syntax file name, just appends a slash.\n\
571 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
578 CHECK_STRING (file
, 0);
582 /* If the file name has special constructs in it,
583 call the corresponding file handler. */
584 handler
= Ffind_file_name_handler (file
, Qfile_name_as_directory
);
586 return call2 (handler
, Qfile_name_as_directory
, file
);
588 buf
= (char *) alloca (XSTRING (file
)->size
+ 10);
589 return build_string (file_name_as_directory (buf
, XSTRING (file
)->data
));
593 * Convert from directory name to filename.
595 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
596 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
597 * On UNIX, it's simple: just make sure there isn't a terminating /
599 * Value is nonzero if the string output is different from the input.
602 directory_file_name (src
, dst
)
610 struct FAB fab
= cc$rms_fab
;
611 struct NAM nam
= cc$rms_nam
;
612 char esa
[NAM$C_MAXRSS
];
617 if (! index (src
, '/')
618 && (src
[slen
- 1] == ']'
619 || src
[slen
- 1] == ':'
620 || src
[slen
- 1] == '>'))
622 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
624 fab
.fab$b_fns
= slen
;
625 fab
.fab$l_nam
= &nam
;
626 fab
.fab$l_fop
= FAB$M_NAM
;
629 nam
.nam$b_ess
= sizeof esa
;
630 nam
.nam$b_nop
|= NAM$M_SYNCHK
;
632 /* We call SYS$PARSE to handle such things as [--] for us. */
633 if (SYS$
PARSE (&fab
, 0, 0) == RMS$_NORMAL
)
635 slen
= nam
.nam$b_esl
;
636 if (esa
[slen
- 1] == ';' && esa
[slen
- 2] == '.')
641 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
643 /* what about when we have logical_name:???? */
644 if (src
[slen
- 1] == ':')
645 { /* Xlate logical name and see what we get */
646 ptr
= strcpy (dst
, src
); /* upper case for getenv */
649 if ('a' <= *ptr
&& *ptr
<= 'z')
653 dst
[slen
- 1] = 0; /* remove colon */
654 if (!(src
= egetenv (dst
)))
656 /* should we jump to the beginning of this procedure?
657 Good points: allows us to use logical names that xlate
659 Bad points: can be a problem if we just translated to a device
661 For now, I'll punt and always expect VMS names, and hope for
664 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
665 { /* no recursion here! */
671 { /* not a directory spec */
676 bracket
= src
[slen
- 1];
678 /* If bracket is ']' or '>', bracket - 2 is the corresponding
680 ptr
= index (src
, bracket
- 2);
682 { /* no opening bracket */
686 if (!(rptr
= rindex (src
, '.')))
689 strncpy (dst
, src
, slen
);
693 dst
[slen
++] = bracket
;
698 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
699 then translate the device and recurse. */
700 if (dst
[slen
- 1] == ':'
701 && dst
[slen
- 2] != ':' /* skip decnet nodes */
702 && strcmp (src
+ slen
, "[000000]") == 0)
704 dst
[slen
- 1] = '\0';
705 if ((ptr
= egetenv (dst
))
706 && (rlen
= strlen (ptr
) - 1) > 0
707 && (ptr
[rlen
] == ']' || ptr
[rlen
] == '>')
708 && ptr
[rlen
- 1] == '.')
710 char * buf
= (char *) alloca (strlen (ptr
) + 1);
714 return directory_file_name (buf
, dst
);
719 strcat (dst
, "[000000]");
723 rlen
= strlen (rptr
) - 1;
724 strncat (dst
, rptr
, rlen
);
725 dst
[slen
+ rlen
] = '\0';
726 strcat (dst
, ".DIR.1");
730 /* Process as Unix format: just remove any final slash.
731 But leave "/" unchanged; do not change it to "". */
734 /* Handle // as root for apollo's. */
735 if ((slen
> 2 && dst
[slen
- 1] == '/')
736 || (slen
> 1 && dst
[0] != '/' && dst
[slen
- 1] == '/'))
740 && IS_DIRECTORY_SEP (dst
[slen
- 1])
742 && !IS_ANY_SEP (dst
[slen
- 2])
748 CORRECT_DIR_SEPS (dst
);
753 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
755 "Returns the file name of the directory named DIRECTORY.\n\
756 This is the name of the file that holds the data for the directory DIRECTORY.\n\
757 This operation exists because a directory is also a file, but its name as\n\
758 a directory is different from its name as a file.\n\
759 In Unix-syntax, this function just removes the final slash.\n\
760 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
761 it returns a file name such as \"[X]Y.DIR.1\".")
763 Lisp_Object directory
;
768 CHECK_STRING (directory
, 0);
770 if (NILP (directory
))
773 /* If the file name has special constructs in it,
774 call the corresponding file handler. */
775 handler
= Ffind_file_name_handler (directory
, Qdirectory_file_name
);
777 return call2 (handler
, Qdirectory_file_name
, directory
);
780 /* 20 extra chars is insufficient for VMS, since we might perform a
781 logical name translation. an equivalence string can be up to 255
782 chars long, so grab that much extra space... - sss */
783 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20 + 255);
785 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20);
787 directory_file_name (XSTRING (directory
)->data
, buf
);
788 return build_string (buf
);
791 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
792 "Generate temporary file name (string) starting with PREFIX (a string).\n\
793 The Emacs process number forms part of the result,\n\
794 so there is no danger of generating a name being used by another process.\n\
795 In addition, this function makes an attempt to choose a name\n\
796 which has no existing file.")
802 /* Don't use too many characters of the restricted 8+3 DOS
804 val
= concat2 (prefix
, build_string ("a.XXX"));
806 val
= concat2 (prefix
, build_string ("XXXXXX"));
808 mktemp (XSTRING (val
)->data
);
810 CORRECT_DIR_SEPS (XSTRING (val
)->data
);
815 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
816 "Convert filename NAME to absolute, and canonicalize it.\n\
817 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative\n\
818 (does not start with slash); if DEFAULT-DIRECTORY is nil or missing,\n\
819 the current buffer's value of default-directory is used.\n\
820 File name components that are `.' are removed, and \n\
821 so are file name components followed by `..', along with the `..' itself;\n\
822 note that these simplifications are done without checking the resulting\n\
823 file names in the file system.\n\
824 An initial `~/' expands to your home directory.\n\
825 An initial `~USER/' expands to USER's home directory.\n\
826 See also the function `substitute-in-file-name'.")
827 (name
, default_directory
)
828 Lisp_Object name
, default_directory
;
832 register unsigned char *newdir
, *p
, *o
;
834 unsigned char *target
;
837 unsigned char * colon
= 0;
838 unsigned char * close
= 0;
839 unsigned char * slash
= 0;
840 unsigned char * brack
= 0;
841 int lbrack
= 0, rbrack
= 0;
846 int collapse_newdir
= 1;
851 CHECK_STRING (name
, 0);
853 /* If the file name has special constructs in it,
854 call the corresponding file handler. */
855 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
857 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
859 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
860 if (NILP (default_directory
))
861 default_directory
= current_buffer
->directory
;
862 if (! STRINGP (default_directory
))
863 default_directory
= build_string ("/");
865 if (!NILP (default_directory
))
867 handler
= Ffind_file_name_handler (default_directory
, Qexpand_file_name
);
869 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
872 o
= XSTRING (default_directory
)->data
;
874 /* Make sure DEFAULT_DIRECTORY is properly expanded.
875 It would be better to do this down below where we actually use
876 default_directory. Unfortunately, calling Fexpand_file_name recursively
877 could invoke GC, and the strings might be relocated. This would
878 be annoying because we have pointers into strings lying around
879 that would need adjusting, and people would add new pointers to
880 the code and forget to adjust them, resulting in intermittent bugs.
881 Putting this call here avoids all that crud.
883 The EQ test avoids infinite recursion. */
884 if (! NILP (default_directory
) && !EQ (default_directory
, name
)
885 /* Save time in some common cases - as long as default_directory
886 is not relative, it can be canonicalized with name below (if it
887 is needed at all) without requiring it to be expanded now. */
889 /* Detect MSDOS file names with drive specifiers. */
890 && ! (IS_DRIVE (o
[0]) && (IS_DEVICE_SEP (o
[1]) && IS_DIRECTORY_SEP (o
[2])))
892 /* Detect Windows file names in UNC format. */
893 && ! (IS_DIRECTORY_SEP (o
[0]) && IS_DIRECTORY_SEP (o
[1]))
895 #else /* not DOS_NT */
896 /* Detect Unix absolute file names (/... alone is not absolute on
898 && ! (IS_DIRECTORY_SEP (o
[0]))
899 #endif /* not DOS_NT */
905 default_directory
= Fexpand_file_name (default_directory
, Qnil
);
910 /* Filenames on VMS are always upper case. */
911 name
= Fupcase (name
);
913 #ifdef FILE_SYSTEM_CASE
914 name
= FILE_SYSTEM_CASE (name
);
917 nm
= XSTRING (name
)->data
;
920 /* We will force directory separators to be either all \ or /, so make
921 a local copy to modify, even if there ends up being no change. */
922 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
924 /* Find and remove drive specifier if present; this makes nm absolute
925 even if the rest of the name appears to be relative. */
927 unsigned char *colon
= rindex (nm
, ':');
930 /* Only recognize colon as part of drive specifier if there is a
931 single alphabetic character preceeding the colon (and if the
932 character before the drive letter, if present, is a directory
933 separator); this is to support the remote system syntax used by
934 ange-ftp, and the "po:username" syntax for POP mailboxes. */
938 else if (IS_DRIVE (colon
[-1])
939 && (colon
== nm
+ 1 || IS_DIRECTORY_SEP (colon
[-2])))
946 while (--colon
>= nm
)
953 /* If we see "c://somedir", we want to strip the first slash after the
954 colon when stripping the drive letter. Otherwise, this expands to
956 if (drive
&& IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
958 #endif /* WINDOWSNT */
962 /* Discard any previous drive specifier if nm is now in UNC format. */
963 if (IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
969 /* If nm is absolute, look for /./ or /../ sequences; if none are
970 found, we can probably return right away. We will avoid allocating
971 a new string if name is already fully expanded. */
973 IS_DIRECTORY_SEP (nm
[0])
978 && (drive
|| IS_DIRECTORY_SEP (nm
[1]))
985 /* If it turns out that the filename we want to return is just a
986 suffix of FILENAME, we don't need to go through and edit
987 things; we just need to construct a new string using data
988 starting at the middle of FILENAME. If we set lose to a
989 non-zero value, that means we've discovered that we can't do
996 /* Since we know the name is absolute, we can assume that each
997 element starts with a "/". */
999 /* "." and ".." are hairy. */
1000 if (IS_DIRECTORY_SEP (p
[0])
1002 && (IS_DIRECTORY_SEP (p
[2])
1004 || (p
[2] == '.' && (IS_DIRECTORY_SEP (p
[3])
1011 /* if dev:[dir]/, move nm to / */
1012 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1013 nm
= (brack
? brack
+ 1 : colon
+ 1);
1014 lbrack
= rbrack
= 0;
1022 /* VMS pre V4.4,convert '-'s in filenames. */
1023 if (lbrack
== rbrack
)
1025 if (dots
< 2) /* this is to allow negative version numbers */
1030 if (lbrack
> rbrack
&&
1031 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1032 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1038 /* count open brackets, reset close bracket pointer */
1039 if (p
[0] == '[' || p
[0] == '<')
1040 lbrack
++, brack
= 0;
1041 /* count close brackets, set close bracket pointer */
1042 if (p
[0] == ']' || p
[0] == '>')
1043 rbrack
++, brack
= p
;
1044 /* detect ][ or >< */
1045 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1047 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1048 nm
= p
+ 1, lose
= 1;
1049 if (p
[0] == ':' && (colon
|| slash
))
1050 /* if dev1:[dir]dev2:, move nm to dev2: */
1056 /* if /name/dev:, move nm to dev: */
1059 /* if node::dev:, move colon following dev */
1060 else if (colon
&& colon
[-1] == ':')
1062 /* if dev1:dev2:, move nm to dev2: */
1063 else if (colon
&& colon
[-1] != ':')
1068 if (p
[0] == ':' && !colon
)
1074 if (lbrack
== rbrack
)
1077 else if (p
[0] == '.')
1085 if (index (nm
, '/'))
1086 return build_string (sys_translate_unix (nm
));
1089 /* Make sure directories are all separated with / or \ as
1090 desired, but avoid allocation of a new string when not
1092 CORRECT_DIR_SEPS (nm
);
1094 if (IS_DIRECTORY_SEP (nm
[1]))
1096 if (strcmp (nm
, XSTRING (name
)->data
) != 0)
1097 name
= build_string (nm
);
1101 /* drive must be set, so this is okay */
1102 if (strcmp (nm
- 2, XSTRING (name
)->data
) != 0)
1104 name
= make_string (nm
- 2, p
- nm
+ 2);
1105 XSTRING (name
)->data
[0] = DRIVE_LETTER (drive
);
1106 XSTRING (name
)->data
[1] = ':';
1109 #else /* not DOS_NT */
1110 if (nm
== XSTRING (name
)->data
)
1112 return build_string (nm
);
1113 #endif /* not DOS_NT */
1117 /* At this point, nm might or might not be an absolute file name. We
1118 need to expand ~ or ~user if present, otherwise prefix nm with
1119 default_directory if nm is not absolute, and finally collapse /./
1120 and /foo/../ sequences.
1122 We set newdir to be the appropriate prefix if one is needed:
1123 - the relevant user directory if nm starts with ~ or ~user
1124 - the specified drive's working dir (DOS/NT only) if nm does not
1126 - the value of default_directory.
1128 Note that these prefixes are not guaranteed to be absolute (except
1129 for the working dir of a drive). Therefore, to ensure we always
1130 return an absolute name, if the final prefix is not absolute we
1131 append it to the current working directory. */
1135 if (nm
[0] == '~') /* prefix ~ */
1137 if (IS_DIRECTORY_SEP (nm
[1])
1141 || nm
[1] == 0) /* ~ by itself */
1143 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1144 newdir
= (unsigned char *) "";
1147 collapse_newdir
= 0;
1150 nm
++; /* Don't leave the slash in nm. */
1153 else /* ~user/filename */
1155 for (p
= nm
; *p
&& (!IS_DIRECTORY_SEP (*p
)
1160 o
= (unsigned char *) alloca (p
- nm
+ 1);
1161 bcopy ((char *) nm
, o
, p
- nm
);
1164 pw
= (struct passwd
*) getpwnam (o
+ 1);
1167 newdir
= (unsigned char *) pw
-> pw_dir
;
1169 nm
= p
+ 1; /* skip the terminator */
1173 collapse_newdir
= 0;
1178 /* If we don't find a user of that name, leave the name
1179 unchanged; don't move nm forward to p. */
1184 /* On DOS and Windows, nm is absolute if a drive name was specified;
1185 use the drive's current directory as the prefix if needed. */
1186 if (!newdir
&& drive
)
1188 /* Get default directory if needed to make nm absolute. */
1189 if (!IS_DIRECTORY_SEP (nm
[0]))
1191 newdir
= alloca (MAXPATHLEN
+ 1);
1192 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1197 /* Either nm starts with /, or drive isn't mounted. */
1198 newdir
= alloca (4);
1199 newdir
[0] = DRIVE_LETTER (drive
);
1207 /* Finally, if no prefix has been specified and nm is not absolute,
1208 then it must be expanded relative to default_directory. */
1212 /* /... alone is not absolute on DOS and Windows. */
1213 && !IS_DIRECTORY_SEP (nm
[0])
1216 && !(IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1223 newdir
= XSTRING (default_directory
)->data
;
1229 /* First ensure newdir is an absolute name. */
1231 /* Detect MSDOS file names with drive specifiers. */
1232 ! (IS_DRIVE (newdir
[0])
1233 && IS_DEVICE_SEP (newdir
[1]) && IS_DIRECTORY_SEP (newdir
[2]))
1235 /* Detect Windows file names in UNC format. */
1236 && ! (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1240 /* Effectively, let newdir be (expand-file-name newdir cwd).
1241 Because of the admonition against calling expand-file-name
1242 when we have pointers into lisp strings, we accomplish this
1243 indirectly by prepending newdir to nm if necessary, and using
1244 cwd (or the wd of newdir's drive) as the new newdir. */
1246 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1251 if (!IS_DIRECTORY_SEP (nm
[0]))
1253 char * tmp
= alloca (strlen (newdir
) + strlen (nm
) + 2);
1254 file_name_as_directory (tmp
, newdir
);
1258 newdir
= alloca (MAXPATHLEN
+ 1);
1261 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1268 /* Strip off drive name from prefix, if present. */
1269 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1275 /* Keep only a prefix from newdir if nm starts with slash
1276 (//server/share for UNC, nothing otherwise). */
1277 if (IS_DIRECTORY_SEP (nm
[0]) && collapse_newdir
)
1280 if (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1282 newdir
= strcpy (alloca (strlen (newdir
) + 1), newdir
);
1284 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1286 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1298 /* Get rid of any slash at the end of newdir, unless newdir is
1299 just // (an incomplete UNC name). */
1300 length
= strlen (newdir
);
1301 if (length
> 0 && IS_DIRECTORY_SEP (newdir
[length
- 1])
1303 && !(length
== 2 && IS_DIRECTORY_SEP (newdir
[0]))
1307 unsigned char *temp
= (unsigned char *) alloca (length
);
1308 bcopy (newdir
, temp
, length
- 1);
1309 temp
[length
- 1] = 0;
1317 /* Now concatenate the directory and name to new space in the stack frame */
1318 tlen
+= strlen (nm
) + 1;
1320 /* Add reserved space for drive name. (The Microsoft x86 compiler
1321 produces incorrect code if the following two lines are combined.) */
1322 target
= (unsigned char *) alloca (tlen
+ 2);
1324 #else /* not DOS_NT */
1325 target
= (unsigned char *) alloca (tlen
);
1326 #endif /* not DOS_NT */
1332 if (nm
[0] == 0 || IS_DIRECTORY_SEP (nm
[0]))
1333 strcpy (target
, newdir
);
1336 file_name_as_directory (target
, newdir
);
1339 strcat (target
, nm
);
1341 if (index (target
, '/'))
1342 strcpy (target
, sys_translate_unix (target
));
1345 /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */
1347 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1355 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1361 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1362 /* brackets are offset from each other by 2 */
1365 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1366 /* convert [foo][bar] to [bar] */
1367 while (o
[-1] != '[' && o
[-1] != '<')
1369 else if (*p
== '-' && *o
!= '.')
1372 else if (p
[0] == '-' && o
[-1] == '.' &&
1373 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1374 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1378 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1379 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1381 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1383 /* else [foo.-] ==> [-] */
1389 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1390 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1396 if (!IS_DIRECTORY_SEP (*p
))
1400 else if (IS_DIRECTORY_SEP (p
[0])
1402 && (IS_DIRECTORY_SEP (p
[2])
1405 /* If "/." is the entire filename, keep the "/". Otherwise,
1406 just delete the whole "/.". */
1407 if (o
== target
&& p
[2] == '\0')
1411 else if (IS_DIRECTORY_SEP (p
[0]) && p
[1] == '.' && p
[2] == '.'
1412 /* `/../' is the "superroot" on certain file systems. */
1414 && (IS_DIRECTORY_SEP (p
[3]) || p
[3] == 0))
1416 while (o
!= target
&& (--o
) && !IS_DIRECTORY_SEP (*o
))
1418 /* Keep initial / only if this is the whole name. */
1419 if (o
== target
&& IS_ANY_SEP (*o
) && p
[3] == 0)
1427 #endif /* not VMS */
1431 /* At last, set drive name. */
1433 /* Except for network file name. */
1434 if (!(IS_DIRECTORY_SEP (target
[0]) && IS_DIRECTORY_SEP (target
[1])))
1435 #endif /* WINDOWSNT */
1437 if (!drive
) abort ();
1439 target
[0] = DRIVE_LETTER (drive
);
1442 CORRECT_DIR_SEPS (target
);
1445 return make_string (target
, o
- target
);
1449 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'. */
1450 DEAFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
1451 "Convert FILENAME to absolute, and canonicalize it.\n\
1452 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1453 (does not start with slash); if DEFAULT is nil or missing,\n\
1454 the current buffer's value of default-directory is used.\n\
1455 Filenames containing `.' or `..' as components are simplified;\n\
1456 initial `~/' expands to your home directory.\n\
1457 See also the function `substitute-in-file-name'.")
1459 Lisp_Object name
, defalt
;
1463 register unsigned char *newdir
, *p
, *o
;
1465 unsigned char *target
;
1469 unsigned char * colon
= 0;
1470 unsigned char * close
= 0;
1471 unsigned char * slash
= 0;
1472 unsigned char * brack
= 0;
1473 int lbrack
= 0, rbrack
= 0;
1477 CHECK_STRING (name
, 0);
1480 /* Filenames on VMS are always upper case. */
1481 name
= Fupcase (name
);
1484 nm
= XSTRING (name
)->data
;
1486 /* If nm is absolute, flush ...// and detect /./ and /../.
1487 If no /./ or /../ we can return right away. */
1499 if (p
[0] == '/' && p
[1] == '/'
1501 /* // at start of filename is meaningful on Apollo system. */
1506 if (p
[0] == '/' && p
[1] == '~')
1507 nm
= p
+ 1, lose
= 1;
1508 if (p
[0] == '/' && p
[1] == '.'
1509 && (p
[2] == '/' || p
[2] == 0
1510 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1516 /* if dev:[dir]/, move nm to / */
1517 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1518 nm
= (brack
? brack
+ 1 : colon
+ 1);
1519 lbrack
= rbrack
= 0;
1527 /* VMS pre V4.4,convert '-'s in filenames. */
1528 if (lbrack
== rbrack
)
1530 if (dots
< 2) /* this is to allow negative version numbers */
1535 if (lbrack
> rbrack
&&
1536 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1537 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1543 /* count open brackets, reset close bracket pointer */
1544 if (p
[0] == '[' || p
[0] == '<')
1545 lbrack
++, brack
= 0;
1546 /* count close brackets, set close bracket pointer */
1547 if (p
[0] == ']' || p
[0] == '>')
1548 rbrack
++, brack
= p
;
1549 /* detect ][ or >< */
1550 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1552 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1553 nm
= p
+ 1, lose
= 1;
1554 if (p
[0] == ':' && (colon
|| slash
))
1555 /* if dev1:[dir]dev2:, move nm to dev2: */
1561 /* If /name/dev:, move nm to dev: */
1564 /* If node::dev:, move colon following dev */
1565 else if (colon
&& colon
[-1] == ':')
1567 /* If dev1:dev2:, move nm to dev2: */
1568 else if (colon
&& colon
[-1] != ':')
1573 if (p
[0] == ':' && !colon
)
1579 if (lbrack
== rbrack
)
1582 else if (p
[0] == '.')
1590 if (index (nm
, '/'))
1591 return build_string (sys_translate_unix (nm
));
1593 if (nm
== XSTRING (name
)->data
)
1595 return build_string (nm
);
1599 /* Now determine directory to start with and put it in NEWDIR */
1603 if (nm
[0] == '~') /* prefix ~ */
1608 || nm
[1] == 0)/* ~/filename */
1610 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1611 newdir
= (unsigned char *) "";
1614 nm
++; /* Don't leave the slash in nm. */
1617 else /* ~user/filename */
1619 /* Get past ~ to user */
1620 unsigned char *user
= nm
+ 1;
1621 /* Find end of name. */
1622 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1623 int len
= ptr
? ptr
- user
: strlen (user
);
1625 unsigned char *ptr1
= index (user
, ':');
1626 if (ptr1
!= 0 && ptr1
- user
< len
)
1629 /* Copy the user name into temp storage. */
1630 o
= (unsigned char *) alloca (len
+ 1);
1631 bcopy ((char *) user
, o
, len
);
1634 /* Look up the user name. */
1635 pw
= (struct passwd
*) getpwnam (o
+ 1);
1637 error ("\"%s\" isn't a registered user", o
+ 1);
1639 newdir
= (unsigned char *) pw
->pw_dir
;
1641 /* Discard the user name from NM. */
1648 #endif /* not VMS */
1652 defalt
= current_buffer
->directory
;
1653 CHECK_STRING (defalt
, 1);
1654 newdir
= XSTRING (defalt
)->data
;
1657 /* Now concatenate the directory and name to new space in the stack frame */
1659 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1660 target
= (unsigned char *) alloca (tlen
);
1666 if (nm
[0] == 0 || nm
[0] == '/')
1667 strcpy (target
, newdir
);
1670 file_name_as_directory (target
, newdir
);
1673 strcat (target
, nm
);
1675 if (index (target
, '/'))
1676 strcpy (target
, sys_translate_unix (target
));
1679 /* Now canonicalize by removing /. and /foo/.. if they appear */
1687 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1693 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1694 /* brackets are offset from each other by 2 */
1697 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1698 /* convert [foo][bar] to [bar] */
1699 while (o
[-1] != '[' && o
[-1] != '<')
1701 else if (*p
== '-' && *o
!= '.')
1704 else if (p
[0] == '-' && o
[-1] == '.' &&
1705 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1706 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1710 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1711 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1713 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1715 /* else [foo.-] ==> [-] */
1721 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1722 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1732 else if (!strncmp (p
, "//", 2)
1734 /* // at start of filename is meaningful in Apollo system. */
1742 else if (p
[0] == '/' && p
[1] == '.' &&
1743 (p
[2] == '/' || p
[2] == 0))
1745 else if (!strncmp (p
, "/..", 3)
1746 /* `/../' is the "superroot" on certain file systems. */
1748 && (p
[3] == '/' || p
[3] == 0))
1750 while (o
!= target
&& *--o
!= '/')
1753 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1757 if (o
== target
&& *o
== '/')
1765 #endif /* not VMS */
1768 return make_string (target
, o
- target
);
1772 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1773 Ssubstitute_in_file_name
, 1, 1, 0,
1774 "Substitute environment variables referred to in FILENAME.\n\
1775 `$FOO' where FOO is an environment variable name means to substitute\n\
1776 the value of that variable. The variable name should be terminated\n\
1777 with a character not a letter, digit or underscore; otherwise, enclose\n\
1778 the entire variable name in braces.\n\
1779 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1780 On VMS, `$' substitution is not done; this function does little and only\n\
1781 duplicates what `expand-file-name' does.")
1783 Lisp_Object filename
;
1787 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1788 unsigned char *target
;
1790 int substituted
= 0;
1792 Lisp_Object handler
;
1794 CHECK_STRING (filename
, 0);
1796 /* If the file name has special constructs in it,
1797 call the corresponding file handler. */
1798 handler
= Ffind_file_name_handler (filename
, Qsubstitute_in_file_name
);
1799 if (!NILP (handler
))
1800 return call2 (handler
, Qsubstitute_in_file_name
, filename
);
1802 nm
= XSTRING (filename
)->data
;
1804 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
1805 CORRECT_DIR_SEPS (nm
);
1806 substituted
= (strcmp (nm
, XSTRING (filename
)->data
) != 0);
1808 endp
= nm
+ XSTRING (filename
)->size
;
1810 /* If /~ or // appears, discard everything through first slash. */
1812 for (p
= nm
; p
!= endp
; p
++)
1815 #if defined (APOLLO) || defined (WINDOWSNT)
1816 /* // at start of file name is meaningful in Apollo and
1817 WindowsNT systems. */
1818 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != nm
)
1819 #else /* not (APOLLO || WINDOWSNT) */
1820 || IS_DIRECTORY_SEP (p
[0])
1821 #endif /* not (APOLLO || WINDOWSNT) */
1826 || p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>'
1828 || IS_DIRECTORY_SEP (p
[-1])))
1834 /* see comment in expand-file-name about drive specifiers */
1835 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
1836 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
1845 return build_string (nm
);
1848 /* See if any variables are substituted into the string
1849 and find the total length of their values in `total' */
1851 for (p
= nm
; p
!= endp
;)
1861 /* "$$" means a single "$" */
1870 while (p
!= endp
&& *p
!= '}') p
++;
1871 if (*p
!= '}') goto missingclose
;
1877 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1881 /* Copy out the variable name */
1882 target
= (unsigned char *) alloca (s
- o
+ 1);
1883 strncpy (target
, o
, s
- o
);
1886 strupr (target
); /* $home == $HOME etc. */
1889 /* Get variable value */
1890 o
= (unsigned char *) egetenv (target
);
1891 if (!o
) goto badvar
;
1892 total
+= strlen (o
);
1899 /* If substitution required, recopy the string and do it */
1900 /* Make space in stack frame for the new copy */
1901 xnm
= (unsigned char *) alloca (XSTRING (filename
)->size
+ total
+ 1);
1904 /* Copy the rest of the name through, replacing $ constructs with values */
1921 while (p
!= endp
&& *p
!= '}') p
++;
1922 if (*p
!= '}') goto missingclose
;
1928 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1932 /* Copy out the variable name */
1933 target
= (unsigned char *) alloca (s
- o
+ 1);
1934 strncpy (target
, o
, s
- o
);
1937 strupr (target
); /* $home == $HOME etc. */
1940 /* Get variable value */
1941 o
= (unsigned char *) egetenv (target
);
1945 if (STRING_MULTIBYTE (filename
))
1947 /* If the original string is multibyte,
1948 convert what we substitute into multibyte. */
1949 unsigned char workbuf
[4], *str
;
1951 extern int nonascii_insert_offset
;
1958 c
+= nonascii_insert_offset
;
1959 len
= CHAR_STRING (c
, workbuf
, str
);
1960 bcopy (str
, x
, len
);
1976 /* If /~ or // appears, discard everything through first slash. */
1978 for (p
= xnm
; p
!= x
; p
++)
1980 #if defined (APOLLO) || defined (WINDOWSNT)
1981 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != xnm
)
1982 #else /* not (APOLLO || WINDOWSNT) */
1983 || IS_DIRECTORY_SEP (p
[0])
1984 #endif /* not (APOLLO || WINDOWSNT) */
1986 && p
!= xnm
&& IS_DIRECTORY_SEP (p
[-1]))
1989 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
1990 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
1994 if (STRING_MULTIBYTE (filename
))
1995 return make_string (xnm
, x
- xnm
);
1996 return make_unibyte_string (xnm
, x
- xnm
);
1999 error ("Bad format environment-variable substitution");
2001 error ("Missing \"}\" in environment-variable substitution");
2003 error ("Substituting nonexistent environment variable \"%s\"", target
);
2006 #endif /* not VMS */
2009 /* A slightly faster and more convenient way to get
2010 (directory-file-name (expand-file-name FOO)). */
2013 expand_and_dir_to_file (filename
, defdir
)
2014 Lisp_Object filename
, defdir
;
2016 register Lisp_Object absname
;
2018 absname
= Fexpand_file_name (filename
, defdir
);
2021 register int c
= XSTRING (absname
)->data
[XSTRING (absname
)->size
- 1];
2022 if (c
== ':' || c
== ']' || c
== '>')
2023 absname
= Fdirectory_file_name (absname
);
2026 /* Remove final slash, if any (unless this is the root dir).
2027 stat behaves differently depending! */
2028 if (XSTRING (absname
)->size
> 1
2029 && IS_DIRECTORY_SEP (XSTRING (absname
)->data
[XSTRING (absname
)->size
- 1])
2030 && !IS_DEVICE_SEP (XSTRING (absname
)->data
[XSTRING (absname
)->size
-2]))
2031 /* We cannot take shortcuts; they might be wrong for magic file names. */
2032 absname
= Fdirectory_file_name (absname
);
2037 /* Signal an error if the file ABSNAME already exists.
2038 If INTERACTIVE is nonzero, ask the user whether to proceed,
2039 and bypass the error if the user says to go ahead.
2040 QUERYSTRING is a name for the action that is being considered
2042 *STATPTR is used to store the stat information if the file exists.
2043 If the file does not exist, STATPTR->st_mode is set to 0. */
2046 barf_or_query_if_file_exists (absname
, querystring
, interactive
, statptr
)
2047 Lisp_Object absname
;
2048 unsigned char *querystring
;
2050 struct stat
*statptr
;
2052 register Lisp_Object tem
;
2053 struct stat statbuf
;
2054 struct gcpro gcpro1
;
2056 /* stat is a good way to tell whether the file exists,
2057 regardless of what access permissions it has. */
2058 if (stat (XSTRING (absname
)->data
, &statbuf
) >= 0)
2061 Fsignal (Qfile_already_exists
,
2062 Fcons (build_string ("File already exists"),
2063 Fcons (absname
, Qnil
)));
2065 tem
= do_yes_or_no_p (format1 ("File %s already exists; %s anyway? ",
2066 XSTRING (absname
)->data
, querystring
));
2069 Fsignal (Qfile_already_exists
,
2070 Fcons (build_string ("File already exists"),
2071 Fcons (absname
, Qnil
)));
2078 statptr
->st_mode
= 0;
2083 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
2084 "fCopy file: \nFCopy %s to file: \np\nP",
2085 "Copy FILE to NEWNAME. Both args must be strings.\n\
2086 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
2087 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
2088 A number as third arg means request confirmation if NEWNAME already exists.\n\
2089 This is what happens in interactive use with M-x.\n\
2090 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
2091 last-modified time as the old one. (This works on only some systems.)\n\
2092 A prefix arg makes KEEP-TIME non-nil.")
2093 (file
, newname
, ok_if_already_exists
, keep_date
)
2094 Lisp_Object file
, newname
, ok_if_already_exists
, keep_date
;
2097 char buf
[16 * 1024];
2098 struct stat st
, out_st
;
2099 Lisp_Object handler
;
2100 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2101 int count
= specpdl_ptr
- specpdl
;
2102 int input_file_statable_p
;
2103 Lisp_Object encoded_file
, encoded_newname
;
2105 encoded_file
= encoded_newname
= Qnil
;
2106 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2107 CHECK_STRING (file
, 0);
2108 CHECK_STRING (newname
, 1);
2110 file
= Fexpand_file_name (file
, Qnil
);
2111 newname
= Fexpand_file_name (newname
, Qnil
);
2113 /* If the input file name has special constructs in it,
2114 call the corresponding file handler. */
2115 handler
= Ffind_file_name_handler (file
, Qcopy_file
);
2116 /* Likewise for output file name. */
2118 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
2119 if (!NILP (handler
))
2120 RETURN_UNGCPRO (call5 (handler
, Qcopy_file
, file
, newname
,
2121 ok_if_already_exists
, keep_date
));
2123 encoded_file
= ENCODE_FILE (file
);
2124 encoded_newname
= ENCODE_FILE (newname
);
2126 if (NILP (ok_if_already_exists
)
2127 || INTEGERP (ok_if_already_exists
))
2128 barf_or_query_if_file_exists (encoded_newname
, "copy to it",
2129 INTEGERP (ok_if_already_exists
), &out_st
);
2130 else if (stat (XSTRING (encoded_newname
)->data
, &out_st
) < 0)
2133 ifd
= open (XSTRING (encoded_file
)->data
, O_RDONLY
);
2135 report_file_error ("Opening input file", Fcons (file
, Qnil
));
2137 record_unwind_protect (close_file_unwind
, make_number (ifd
));
2139 /* We can only copy regular files and symbolic links. Other files are not
2141 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
2143 #if !defined (MSDOS) || __DJGPP__ > 1
2144 if (out_st
.st_mode
!= 0
2145 && st
.st_dev
== out_st
.st_dev
&& st
.st_ino
== out_st
.st_ino
)
2148 report_file_error ("Input and output files are the same",
2149 Fcons (file
, Fcons (newname
, Qnil
)));
2153 #if defined (S_ISREG) && defined (S_ISLNK)
2154 if (input_file_statable_p
)
2156 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
2158 #if defined (EISDIR)
2159 /* Get a better looking error message. */
2162 report_file_error ("Non-regular file", Fcons (file
, Qnil
));
2165 #endif /* S_ISREG && S_ISLNK */
2168 /* Create the copy file with the same record format as the input file */
2169 ofd
= sys_creat (XSTRING (encoded_newname
)->data
, 0666, ifd
);
2172 /* System's default file type was set to binary by _fmode in emacs.c. */
2173 ofd
= creat (XSTRING (encoded_newname
)->data
, S_IREAD
| S_IWRITE
);
2174 #else /* not MSDOS */
2175 ofd
= creat (XSTRING (encoded_newname
)->data
, 0666);
2176 #endif /* not MSDOS */
2179 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
2181 record_unwind_protect (close_file_unwind
, make_number (ofd
));
2185 while ((n
= read (ifd
, buf
, sizeof buf
)) > 0)
2186 if (write (ofd
, buf
, n
) != n
)
2187 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2190 /* Closing the output clobbers the file times on some systems. */
2191 if (close (ofd
) < 0)
2192 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2194 if (input_file_statable_p
)
2196 if (!NILP (keep_date
))
2198 EMACS_TIME atime
, mtime
;
2199 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
2200 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
2201 if (set_file_times (XSTRING (encoded_newname
)->data
,
2203 Fsignal (Qfile_date_error
,
2204 Fcons (build_string ("Cannot set file date"),
2205 Fcons (newname
, Qnil
)));
2208 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2210 #if defined (__DJGPP__) && __DJGPP__ > 1
2211 /* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
2212 and if it can't, it tells so. Otherwise, under MSDOS we usually
2213 get only the READ bit, which will make the copied file read-only,
2214 so it's better not to chmod at all. */
2215 if ((_djstat_flags
& _STFAIL_WRITEBIT
) == 0)
2216 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2217 #endif /* DJGPP version 2 or newer */
2223 /* Discard the unwind protects. */
2224 specpdl_ptr
= specpdl
+ count
;
2230 DEFUN ("make-directory-internal", Fmake_directory_internal
,
2231 Smake_directory_internal
, 1, 1, 0,
2232 "Create a new directory named DIRECTORY.")
2234 Lisp_Object directory
;
2237 Lisp_Object handler
;
2238 Lisp_Object encoded_dir
;
2240 CHECK_STRING (directory
, 0);
2241 directory
= Fexpand_file_name (directory
, Qnil
);
2243 handler
= Ffind_file_name_handler (directory
, Qmake_directory_internal
);
2244 if (!NILP (handler
))
2245 return call2 (handler
, Qmake_directory_internal
, directory
);
2247 encoded_dir
= ENCODE_FILE (directory
);
2249 dir
= XSTRING (encoded_dir
)->data
;
2252 if (mkdir (dir
) != 0)
2254 if (mkdir (dir
, 0777) != 0)
2256 report_file_error ("Creating directory", Flist (1, &directory
));
2261 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
2262 "Delete the directory named DIRECTORY.")
2264 Lisp_Object directory
;
2267 Lisp_Object handler
;
2268 Lisp_Object encoded_dir
;
2270 CHECK_STRING (directory
, 0);
2271 directory
= Fdirectory_file_name (Fexpand_file_name (directory
, Qnil
));
2273 handler
= Ffind_file_name_handler (directory
, Qdelete_directory
);
2274 if (!NILP (handler
))
2275 return call2 (handler
, Qdelete_directory
, directory
);
2277 encoded_dir
= ENCODE_FILE (directory
);
2279 dir
= XSTRING (encoded_dir
)->data
;
2281 if (rmdir (dir
) != 0)
2282 report_file_error ("Removing directory", Flist (1, &directory
));
2287 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
2288 "Delete file named FILENAME.\n\
2289 If file has multiple names, it continues to exist with the other names.")
2291 Lisp_Object filename
;
2293 Lisp_Object handler
;
2294 Lisp_Object encoded_file
;
2296 CHECK_STRING (filename
, 0);
2297 filename
= Fexpand_file_name (filename
, Qnil
);
2299 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
2300 if (!NILP (handler
))
2301 return call2 (handler
, Qdelete_file
, filename
);
2303 encoded_file
= ENCODE_FILE (filename
);
2305 if (0 > unlink (XSTRING (encoded_file
)->data
))
2306 report_file_error ("Removing old name", Flist (1, &filename
));
2311 internal_delete_file_1 (ignore
)
2317 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */
2320 internal_delete_file (filename
)
2321 Lisp_Object filename
;
2323 return NILP (internal_condition_case_1 (Fdelete_file
, filename
,
2324 Qt
, internal_delete_file_1
));
2327 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
2328 "fRename file: \nFRename %s to file: \np",
2329 "Rename FILE as NEWNAME. Both args strings.\n\
2330 If file has names other than FILE, it continues to have those names.\n\
2331 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2332 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2333 A number as third arg means request confirmation if NEWNAME already exists.\n\
2334 This is what happens in interactive use with M-x.")
2335 (file
, newname
, ok_if_already_exists
)
2336 Lisp_Object file
, newname
, ok_if_already_exists
;
2339 Lisp_Object args
[2];
2341 Lisp_Object handler
;
2342 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2343 Lisp_Object encoded_file
, encoded_newname
;
2345 encoded_file
= encoded_newname
= Qnil
;
2346 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2347 CHECK_STRING (file
, 0);
2348 CHECK_STRING (newname
, 1);
2349 file
= Fexpand_file_name (file
, Qnil
);
2350 newname
= Fexpand_file_name (newname
, Qnil
);
2352 /* If the file name has special constructs in it,
2353 call the corresponding file handler. */
2354 handler
= Ffind_file_name_handler (file
, Qrename_file
);
2356 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
2357 if (!NILP (handler
))
2358 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
2359 file
, newname
, ok_if_already_exists
));
2361 encoded_file
= ENCODE_FILE (file
);
2362 encoded_newname
= ENCODE_FILE (newname
);
2364 if (NILP (ok_if_already_exists
)
2365 || INTEGERP (ok_if_already_exists
))
2366 barf_or_query_if_file_exists (encoded_newname
, "rename to it",
2367 INTEGERP (ok_if_already_exists
), 0);
2369 if (0 > rename (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2371 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
)
2372 || 0 > unlink (XSTRING (encoded_file
)->data
))
2377 Fcopy_file (file
, newname
,
2378 /* We have already prompted if it was an integer,
2379 so don't have copy-file prompt again. */
2380 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
2381 Fdelete_file (file
);
2388 report_file_error ("Renaming", Flist (2, args
));
2391 report_file_error ("Renaming", Flist (2, &file
));
2398 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
2399 "fAdd name to file: \nFName to add to %s: \np",
2400 "Give FILE additional name NEWNAME. Both args strings.\n\
2401 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2402 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2403 A number as third arg means request confirmation if NEWNAME already exists.\n\
2404 This is what happens in interactive use with M-x.")
2405 (file
, newname
, ok_if_already_exists
)
2406 Lisp_Object file
, newname
, ok_if_already_exists
;
2409 Lisp_Object args
[2];
2411 Lisp_Object handler
;
2412 Lisp_Object encoded_file
, encoded_newname
;
2413 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2415 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2416 encoded_file
= encoded_newname
= Qnil
;
2417 CHECK_STRING (file
, 0);
2418 CHECK_STRING (newname
, 1);
2419 file
= Fexpand_file_name (file
, Qnil
);
2420 newname
= Fexpand_file_name (newname
, Qnil
);
2422 /* If the file name has special constructs in it,
2423 call the corresponding file handler. */
2424 handler
= Ffind_file_name_handler (file
, Qadd_name_to_file
);
2425 if (!NILP (handler
))
2426 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2427 newname
, ok_if_already_exists
));
2429 /* If the new name has special constructs in it,
2430 call the corresponding file handler. */
2431 handler
= Ffind_file_name_handler (newname
, Qadd_name_to_file
);
2432 if (!NILP (handler
))
2433 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2434 newname
, ok_if_already_exists
));
2436 encoded_file
= ENCODE_FILE (file
);
2437 encoded_newname
= ENCODE_FILE (newname
);
2439 if (NILP (ok_if_already_exists
)
2440 || INTEGERP (ok_if_already_exists
))
2441 barf_or_query_if_file_exists (encoded_newname
, "make it a new name",
2442 INTEGERP (ok_if_already_exists
), 0);
2444 unlink (XSTRING (newname
)->data
);
2445 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2450 report_file_error ("Adding new name", Flist (2, args
));
2452 report_file_error ("Adding new name", Flist (2, &file
));
2461 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2462 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2463 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
2464 Signals a `file-already-exists' error if a file LINKNAME already exists\n\
2465 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2466 A number as third arg means request confirmation if LINKNAME already exists.\n\
2467 This happens for interactive use with M-x.")
2468 (filename
, linkname
, ok_if_already_exists
)
2469 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2472 Lisp_Object args
[2];
2474 Lisp_Object handler
;
2475 Lisp_Object encoded_filename
, encoded_linkname
;
2476 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2478 GCPRO4 (filename
, linkname
, encoded_filename
, encoded_linkname
);
2479 encoded_filename
= encoded_linkname
= Qnil
;
2480 CHECK_STRING (filename
, 0);
2481 CHECK_STRING (linkname
, 1);
2482 /* If the link target has a ~, we must expand it to get
2483 a truly valid file name. Otherwise, do not expand;
2484 we want to permit links to relative file names. */
2485 if (XSTRING (filename
)->data
[0] == '~')
2486 filename
= Fexpand_file_name (filename
, Qnil
);
2487 linkname
= Fexpand_file_name (linkname
, Qnil
);
2489 /* If the file name has special constructs in it,
2490 call the corresponding file handler. */
2491 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2492 if (!NILP (handler
))
2493 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2494 linkname
, ok_if_already_exists
));
2496 /* If the new link name has special constructs in it,
2497 call the corresponding file handler. */
2498 handler
= Ffind_file_name_handler (linkname
, Qmake_symbolic_link
);
2499 if (!NILP (handler
))
2500 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2501 linkname
, ok_if_already_exists
));
2503 encoded_filename
= ENCODE_FILE (filename
);
2504 encoded_linkname
= ENCODE_FILE (linkname
);
2506 if (NILP (ok_if_already_exists
)
2507 || INTEGERP (ok_if_already_exists
))
2508 barf_or_query_if_file_exists (encoded_linkname
, "make it a link",
2509 INTEGERP (ok_if_already_exists
), 0);
2510 if (0 > symlink (XSTRING (encoded_filename
)->data
,
2511 XSTRING (encoded_linkname
)->data
))
2513 /* If we didn't complain already, silently delete existing file. */
2514 if (errno
== EEXIST
)
2516 unlink (XSTRING (encoded_linkname
)->data
);
2517 if (0 <= symlink (XSTRING (encoded_filename
)->data
,
2518 XSTRING (encoded_linkname
)->data
))
2528 report_file_error ("Making symbolic link", Flist (2, args
));
2530 report_file_error ("Making symbolic link", Flist (2, &filename
));
2536 #endif /* S_IFLNK */
2540 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2541 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2542 "Define the job-wide logical name NAME to have the value STRING.\n\
2543 If STRING is nil or a null string, the logical name NAME is deleted.")
2548 CHECK_STRING (name
, 0);
2550 delete_logical_name (XSTRING (name
)->data
);
2553 CHECK_STRING (string
, 1);
2555 if (XSTRING (string
)->size
== 0)
2556 delete_logical_name (XSTRING (name
)->data
);
2558 define_logical_name (XSTRING (name
)->data
, XSTRING (string
)->data
);
2567 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2568 "Open a network connection to PATH using LOGIN as the login string.")
2570 Lisp_Object path
, login
;
2574 CHECK_STRING (path
, 0);
2575 CHECK_STRING (login
, 0);
2577 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2579 if (netresult
== -1)
2584 #endif /* HPUX_NET */
2586 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2588 "Return t if file FILENAME specifies an absolute file name.\n\
2589 On Unix, this is a name starting with a `/' or a `~'.")
2591 Lisp_Object filename
;
2595 CHECK_STRING (filename
, 0);
2596 ptr
= XSTRING (filename
)->data
;
2597 if (IS_DIRECTORY_SEP (*ptr
) || *ptr
== '~'
2599 /* ??? This criterion is probably wrong for '<'. */
2600 || index (ptr
, ':') || index (ptr
, '<')
2601 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2605 || (IS_DRIVE (*ptr
) && ptr
[1] == ':' && IS_DIRECTORY_SEP (ptr
[2]))
2613 /* Return nonzero if file FILENAME exists and can be executed. */
2616 check_executable (filename
)
2620 int len
= strlen (filename
);
2623 if (stat (filename
, &st
) < 0)
2625 #if defined (WINDOWSNT) || (defined (MSDOS) && __DJGPP__ > 1)
2626 return ((st
.st_mode
& S_IEXEC
) != 0);
2628 return (S_ISREG (st
.st_mode
)
2630 && (stricmp ((suffix
= filename
+ len
-4), ".com") == 0
2631 || stricmp (suffix
, ".exe") == 0
2632 || stricmp (suffix
, ".bat") == 0)
2633 || (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2634 #endif /* not WINDOWSNT */
2635 #else /* not DOS_NT */
2636 #ifdef HAVE_EUIDACCESS
2637 return (euidaccess (filename
, 1) >= 0);
2639 /* Access isn't quite right because it uses the real uid
2640 and we really want to test with the effective uid.
2641 But Unix doesn't give us a right way to do it. */
2642 return (access (filename
, 1) >= 0);
2644 #endif /* not DOS_NT */
2647 /* Return nonzero if file FILENAME exists and can be written. */
2650 check_writable (filename
)
2655 if (stat (filename
, &st
) < 0)
2657 return (st
.st_mode
& S_IWRITE
|| (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2658 #else /* not MSDOS */
2659 #ifdef HAVE_EUIDACCESS
2660 return (euidaccess (filename
, 2) >= 0);
2662 /* Access isn't quite right because it uses the real uid
2663 and we really want to test with the effective uid.
2664 But Unix doesn't give us a right way to do it.
2665 Opening with O_WRONLY could work for an ordinary file,
2666 but would lose for directories. */
2667 return (access (filename
, 2) >= 0);
2669 #endif /* not MSDOS */
2672 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2673 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
2674 See also `file-readable-p' and `file-attributes'.")
2676 Lisp_Object filename
;
2678 Lisp_Object absname
;
2679 Lisp_Object handler
;
2680 struct stat statbuf
;
2682 CHECK_STRING (filename
, 0);
2683 absname
= Fexpand_file_name (filename
, Qnil
);
2685 /* If the file name has special constructs in it,
2686 call the corresponding file handler. */
2687 handler
= Ffind_file_name_handler (absname
, Qfile_exists_p
);
2688 if (!NILP (handler
))
2689 return call2 (handler
, Qfile_exists_p
, absname
);
2691 absname
= ENCODE_FILE (absname
);
2693 return (stat (XSTRING (absname
)->data
, &statbuf
) >= 0) ? Qt
: Qnil
;
2696 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2697 "Return t if FILENAME can be executed by you.\n\
2698 For a directory, this means you can access files in that directory.")
2700 Lisp_Object filename
;
2703 Lisp_Object absname
;
2704 Lisp_Object handler
;
2706 CHECK_STRING (filename
, 0);
2707 absname
= Fexpand_file_name (filename
, Qnil
);
2709 /* If the file name has special constructs in it,
2710 call the corresponding file handler. */
2711 handler
= Ffind_file_name_handler (absname
, Qfile_executable_p
);
2712 if (!NILP (handler
))
2713 return call2 (handler
, Qfile_executable_p
, absname
);
2715 absname
= ENCODE_FILE (absname
);
2717 return (check_executable (XSTRING (absname
)->data
) ? Qt
: Qnil
);
2720 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2721 "Return t if file FILENAME exists and you can read it.\n\
2722 See also `file-exists-p' and `file-attributes'.")
2724 Lisp_Object filename
;
2726 Lisp_Object absname
;
2727 Lisp_Object handler
;
2730 struct stat statbuf
;
2732 CHECK_STRING (filename
, 0);
2733 absname
= Fexpand_file_name (filename
, Qnil
);
2735 /* If the file name has special constructs in it,
2736 call the corresponding file handler. */
2737 handler
= Ffind_file_name_handler (absname
, Qfile_readable_p
);
2738 if (!NILP (handler
))
2739 return call2 (handler
, Qfile_readable_p
, absname
);
2741 absname
= ENCODE_FILE (absname
);
2744 /* Under MS-DOS and Windows, open does not work for directories. */
2745 if (access (XSTRING (absname
)->data
, 0) == 0)
2748 #else /* not DOS_NT */
2750 #if defined (S_ISFIFO) && defined (O_NONBLOCK)
2751 /* Opening a fifo without O_NONBLOCK can wait.
2752 We don't want to wait. But we don't want to mess wth O_NONBLOCK
2753 except in the case of a fifo, on a system which handles it. */
2754 desc
= stat (XSTRING (absname
)->data
, &statbuf
);
2757 if (S_ISFIFO (statbuf
.st_mode
))
2758 flags
|= O_NONBLOCK
;
2760 desc
= open (XSTRING (absname
)->data
, flags
);
2765 #endif /* not DOS_NT */
2768 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2770 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
2771 "Return t if file FILENAME can be written or created by you.")
2773 Lisp_Object filename
;
2775 Lisp_Object absname
, dir
, encoded
;
2776 Lisp_Object handler
;
2777 struct stat statbuf
;
2779 CHECK_STRING (filename
, 0);
2780 absname
= Fexpand_file_name (filename
, Qnil
);
2782 /* If the file name has special constructs in it,
2783 call the corresponding file handler. */
2784 handler
= Ffind_file_name_handler (absname
, Qfile_writable_p
);
2785 if (!NILP (handler
))
2786 return call2 (handler
, Qfile_writable_p
, absname
);
2788 encoded
= ENCODE_FILE (absname
);
2789 if (stat (XSTRING (encoded
)->data
, &statbuf
) >= 0)
2790 return (check_writable (XSTRING (encoded
)->data
)
2793 dir
= Ffile_name_directory (absname
);
2796 dir
= Fdirectory_file_name (dir
);
2800 dir
= Fdirectory_file_name (dir
);
2803 dir
= ENCODE_FILE (dir
);
2804 return (check_writable (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "")
2808 DEFUN ("access-file", Faccess_file
, Saccess_file
, 2, 2, 0,
2809 "Access file FILENAME, and get an error if that does not work.\n\
2810 The second argument STRING is used in the error message.\n\
2811 If there is no error, we return nil.")
2813 Lisp_Object filename
, string
;
2815 Lisp_Object handler
, encoded_filename
;
2818 CHECK_STRING (filename
, 0);
2820 /* If the file name has special constructs in it,
2821 call the corresponding file handler. */
2822 handler
= Ffind_file_name_handler (filename
, Qaccess_file
);
2823 if (!NILP (handler
))
2824 return call3 (handler
, Qaccess_file
, filename
, string
);
2826 encoded_filename
= ENCODE_FILE (filename
);
2828 fd
= open (XSTRING (encoded_filename
)->data
, O_RDONLY
);
2830 report_file_error (XSTRING (string
)->data
, Fcons (filename
, Qnil
));
2836 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
2837 "Return non-nil if file FILENAME is the name of a symbolic link.\n\
2838 The value is the name of the file to which it is linked.\n\
2839 Otherwise returns nil.")
2841 Lisp_Object filename
;
2848 Lisp_Object handler
;
2850 CHECK_STRING (filename
, 0);
2851 filename
= Fexpand_file_name (filename
, Qnil
);
2853 /* If the file name has special constructs in it,
2854 call the corresponding file handler. */
2855 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
2856 if (!NILP (handler
))
2857 return call2 (handler
, Qfile_symlink_p
, filename
);
2859 filename
= ENCODE_FILE (filename
);
2864 buf
= (char *) xmalloc (bufsize
);
2865 bzero (buf
, bufsize
);
2866 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
2867 if (valsize
< bufsize
) break;
2868 /* Buffer was not long enough */
2877 val
= make_string (buf
, valsize
);
2879 return Fdecode_coding_string (val
, Vfile_name_coding_system
, Qt
);
2880 #else /* not S_IFLNK */
2882 #endif /* not S_IFLNK */
2885 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
2886 "Return t if FILENAME names an existing directory.")
2888 Lisp_Object filename
;
2890 register Lisp_Object absname
;
2892 Lisp_Object handler
;
2894 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2896 /* If the file name has special constructs in it,
2897 call the corresponding file handler. */
2898 handler
= Ffind_file_name_handler (absname
, Qfile_directory_p
);
2899 if (!NILP (handler
))
2900 return call2 (handler
, Qfile_directory_p
, absname
);
2902 absname
= ENCODE_FILE (absname
);
2904 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2906 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
2909 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
2910 "Return t if file FILENAME is the name of a directory as a file,\n\
2911 and files in that directory can be opened by you. In order to use a\n\
2912 directory as a buffer's current directory, this predicate must return true.\n\
2913 A directory name spec may be given instead; then the value is t\n\
2914 if the directory so specified exists and really is a readable and\n\
2915 searchable directory.")
2917 Lisp_Object filename
;
2919 Lisp_Object handler
;
2921 struct gcpro gcpro1
;
2923 /* If the file name has special constructs in it,
2924 call the corresponding file handler. */
2925 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
2926 if (!NILP (handler
))
2927 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
2929 /* It's an unlikely combination, but yes we really do need to gcpro:
2930 Suppose that file-accessible-directory-p has no handler, but
2931 file-directory-p does have a handler; this handler causes a GC which
2932 relocates the string in `filename'; and finally file-directory-p
2933 returns non-nil. Then we would end up passing a garbaged string
2934 to file-executable-p. */
2936 tem
= (NILP (Ffile_directory_p (filename
))
2937 || NILP (Ffile_executable_p (filename
)));
2939 return tem
? Qnil
: Qt
;
2942 DEFUN ("file-regular-p", Ffile_regular_p
, Sfile_regular_p
, 1, 1, 0,
2943 "Return t if file FILENAME is the name of a regular file.\n\
2944 This is the sort of file that holds an ordinary stream of data bytes.")
2946 Lisp_Object filename
;
2948 register Lisp_Object absname
;
2950 Lisp_Object handler
;
2952 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2954 /* If the file name has special constructs in it,
2955 call the corresponding file handler. */
2956 handler
= Ffind_file_name_handler (absname
, Qfile_regular_p
);
2957 if (!NILP (handler
))
2958 return call2 (handler
, Qfile_regular_p
, absname
);
2960 absname
= ENCODE_FILE (absname
);
2962 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2964 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
2967 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
2968 "Return mode bits of file named FILENAME, as an integer.")
2970 Lisp_Object filename
;
2972 Lisp_Object absname
;
2974 Lisp_Object handler
;
2976 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2978 /* If the file name has special constructs in it,
2979 call the corresponding file handler. */
2980 handler
= Ffind_file_name_handler (absname
, Qfile_modes
);
2981 if (!NILP (handler
))
2982 return call2 (handler
, Qfile_modes
, absname
);
2984 absname
= ENCODE_FILE (absname
);
2986 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2988 #if defined (MSDOS) && __DJGPP__ < 2
2989 if (check_executable (XSTRING (absname
)->data
))
2990 st
.st_mode
|= S_IEXEC
;
2991 #endif /* MSDOS && __DJGPP__ < 2 */
2993 return make_number (st
.st_mode
& 07777);
2996 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
2997 "Set mode bits of file named FILENAME to MODE (an integer).\n\
2998 Only the 12 low bits of MODE are used.")
3000 Lisp_Object filename
, mode
;
3002 Lisp_Object absname
, encoded_absname
;
3003 Lisp_Object handler
;
3005 absname
= Fexpand_file_name (filename
, current_buffer
->directory
);
3006 CHECK_NUMBER (mode
, 1);
3008 /* If the file name has special constructs in it,
3009 call the corresponding file handler. */
3010 handler
= Ffind_file_name_handler (absname
, Qset_file_modes
);
3011 if (!NILP (handler
))
3012 return call3 (handler
, Qset_file_modes
, absname
, mode
);
3014 encoded_absname
= ENCODE_FILE (absname
);
3016 if (chmod (XSTRING (encoded_absname
)->data
, XINT (mode
)) < 0)
3017 report_file_error ("Doing chmod", Fcons (absname
, Qnil
));
3022 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
3023 "Set the file permission bits for newly created files.\n\
3024 The argument MODE should be an integer; only the low 9 bits are used.\n\
3025 This setting is inherited by subprocesses.")
3029 CHECK_NUMBER (mode
, 0);
3031 umask ((~ XINT (mode
)) & 0777);
3036 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
3037 "Return the default file protection for created files.\n\
3038 The value is an integer.")
3044 realmask
= umask (0);
3047 XSETINT (value
, (~ realmask
) & 0777);
3053 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
3054 "Tell Unix to finish all pending disk updates.")
3063 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
3064 "Return t if file FILE1 is newer than file FILE2.\n\
3065 If FILE1 does not exist, the answer is nil;\n\
3066 otherwise, if FILE2 does not exist, the answer is t.")
3068 Lisp_Object file1
, file2
;
3070 Lisp_Object absname1
, absname2
;
3073 Lisp_Object handler
;
3074 struct gcpro gcpro1
, gcpro2
;
3076 CHECK_STRING (file1
, 0);
3077 CHECK_STRING (file2
, 0);
3080 GCPRO2 (absname1
, file2
);
3081 absname1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
3082 absname2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
3085 /* If the file name has special constructs in it,
3086 call the corresponding file handler. */
3087 handler
= Ffind_file_name_handler (absname1
, Qfile_newer_than_file_p
);
3089 handler
= Ffind_file_name_handler (absname2
, Qfile_newer_than_file_p
);
3090 if (!NILP (handler
))
3091 return call3 (handler
, Qfile_newer_than_file_p
, absname1
, absname2
);
3093 GCPRO2 (absname1
, absname2
);
3094 absname1
= ENCODE_FILE (absname1
);
3095 absname2
= ENCODE_FILE (absname2
);
3098 if (stat (XSTRING (absname1
)->data
, &st
) < 0)
3101 mtime1
= st
.st_mtime
;
3103 if (stat (XSTRING (absname2
)->data
, &st
) < 0)
3106 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
3110 Lisp_Object Qfind_buffer_file_type
;
3113 #ifndef READ_BUF_SIZE
3114 #define READ_BUF_SIZE (64 << 10)
3117 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
3119 "Insert contents of file FILENAME after point.\n\
3120 Returns list of absolute file name and number of bytes inserted.\n\
3121 If second argument VISIT is non-nil, the buffer's visited filename\n\
3122 and last save file modtime are set, and it is marked unmodified.\n\
3123 If visiting and the file does not exist, visiting is completed\n\
3124 before the error is signaled.\n\
3125 The optional third and fourth arguments BEG and END\n\
3126 specify what portion of the file to insert.\n\
3127 These arguments count bytes in the file, not characters in the buffer.\n\
3128 If VISIT is non-nil, BEG and END must be nil.\n\
3130 If optional fifth argument REPLACE is non-nil,\n\
3131 it means replace the current buffer contents (in the accessible portion)\n\
3132 with the file contents. This is better than simply deleting and inserting\n\
3133 the whole thing because (1) it preserves some marker positions\n\
3134 and (2) it puts less data in the undo list.\n\
3135 When REPLACE is non-nil, the value is the number of characters actually read,\n\
3136 which is often less than the number of characters to be read.\n\
3137 This does code conversion according to the value of\n\
3138 `coding-system-for-read' or `file-coding-system-alist',\n\
3139 and sets the variable `last-coding-system-used' to the coding system\n\
3141 (filename
, visit
, beg
, end
, replace
)
3142 Lisp_Object filename
, visit
, beg
, end
, replace
;
3147 int inserted_chars
= 0;
3148 register int how_much
;
3149 register int unprocessed
;
3150 int count
= specpdl_ptr
- specpdl
;
3151 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3152 Lisp_Object handler
, val
, insval
, orig_filename
;
3155 int not_regular
= 0;
3156 char read_buf
[READ_BUF_SIZE
];
3157 struct coding_system coding
;
3158 unsigned char buffer
[1 << 14];
3159 int replace_handled
= 0;
3160 int set_coding_system
= 0;
3162 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3163 error ("Cannot do file visiting in an indirect buffer");
3165 if (!NILP (current_buffer
->read_only
))
3166 Fbarf_if_buffer_read_only ();
3170 orig_filename
= Qnil
;
3172 GCPRO4 (filename
, val
, p
, orig_filename
);
3174 CHECK_STRING (filename
, 0);
3175 filename
= Fexpand_file_name (filename
, Qnil
);
3177 /* If the file name has special constructs in it,
3178 call the corresponding file handler. */
3179 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
3180 if (!NILP (handler
))
3182 val
= call6 (handler
, Qinsert_file_contents
, filename
,
3183 visit
, beg
, end
, replace
);
3187 orig_filename
= filename
;
3188 filename
= ENCODE_FILE (filename
);
3193 if (stat (XSTRING (filename
)->data
, &st
) < 0)
3195 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0
3196 || fstat (fd
, &st
) < 0)
3197 #endif /* not APOLLO */
3199 if (fd
>= 0) close (fd
);
3202 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3205 if (!NILP (Vcoding_system_for_read
))
3206 current_buffer
->buffer_file_coding_system
= Vcoding_system_for_read
;
3211 /* This code will need to be changed in order to work on named
3212 pipes, and it's probably just not worth it. So we should at
3213 least signal an error. */
3214 if (!S_ISREG (st
.st_mode
))
3221 if (! NILP (replace
) || ! NILP (beg
) || ! NILP (end
))
3222 Fsignal (Qfile_error
,
3223 Fcons (build_string ("not a regular file"),
3224 Fcons (orig_filename
, Qnil
)));
3229 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0)
3232 /* Replacement should preserve point as it preserves markers. */
3233 if (!NILP (replace
))
3234 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
3236 record_unwind_protect (close_file_unwind
, make_number (fd
));
3238 /* Supposedly happens on VMS. */
3239 if (! not_regular
&& st
.st_size
< 0)
3240 error ("File size is negative");
3242 if (!NILP (beg
) || !NILP (end
))
3244 error ("Attempt to visit less than an entire file");
3247 CHECK_NUMBER (beg
, 0);
3249 XSETFASTINT (beg
, 0);
3252 CHECK_NUMBER (end
, 0);
3257 XSETINT (end
, st
.st_size
);
3258 if (XINT (end
) != st
.st_size
)
3259 error ("Maximum buffer size exceeded");
3263 /* Decide the coding-system of the file. */
3265 Lisp_Object val
= Qnil
;
3267 if (!NILP (Vcoding_system_for_read
))
3268 val
= Vcoding_system_for_read
;
3269 else if (NILP (current_buffer
->enable_multibyte_characters
))
3273 if (! NILP (Vset_auto_coding_function
))
3275 /* Find a coding system specified in the heading two lines
3276 or in the tailing several lines of the file. We assume
3277 that the 1K-byte and 3K-byte for heading and tailing
3278 respectively are sufficient fot this purpose. */
3279 int how_many
, nread
;
3281 if (st
.st_size
<= (1024 * 4))
3282 nread
= read (fd
, read_buf
, 1024 * 4);
3285 nread
= read (fd
, read_buf
, 1024);
3288 if (lseek (fd
, st
.st_size
- (1024 * 3), 0) < 0)
3289 report_file_error ("Setting file position",
3290 Fcons (orig_filename
, Qnil
));
3291 nread
+= read (fd
, read_buf
+ nread
, 1024 * 3);
3296 error ("IO error reading %s: %s",
3297 XSTRING (orig_filename
)->data
, strerror (errno
));
3301 /* Always make this a unibyte string
3302 because we have not yet decoded it. */
3303 tem
= make_unibyte_string (read_buf
, nread
);
3304 val
= call1 (Vset_auto_coding_function
, tem
);
3305 /* Rewind the file for the actual read done later. */
3306 if (lseek (fd
, 0, 0) < 0)
3307 report_file_error ("Setting file position",
3308 Fcons (orig_filename
, Qnil
));
3313 Lisp_Object args
[6], coding_systems
;
3315 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
,
3316 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = replace
;
3317 coding_systems
= Ffind_operation_coding_system (6, args
);
3318 if (CONSP (coding_systems
)) val
= XCONS (coding_systems
)->car
;
3321 setup_coding_system (Fcheck_coding_system (val
), &coding
);
3324 /* If requested, replace the accessible part of the buffer
3325 with the file contents. Avoid replacing text at the
3326 beginning or end of the buffer that matches the file contents;
3327 that preserves markers pointing to the unchanged parts.
3329 Here we implement this feature in an optimized way
3330 for the case where code conversion is NOT needed.
3331 The following if-statement handles the case of conversion
3332 in a less optimal way.
3334 If the code conversion is "automatic" then we try using this
3335 method and hope for the best.
3336 But if we discover the need for conversion, we give up on this method
3337 and let the following if-statement handle the replace job. */
3339 && ! CODING_REQUIRE_DECODING (&coding
))
3341 /* same_at_start and same_at_end count bytes,
3342 because file access counts bytes
3343 and BEG and END count bytes. */
3344 int same_at_start
= BEGV_BYTE
;
3345 int same_at_end
= ZV_BYTE
;
3347 /* There is still a possibility we will find the need to do code
3348 conversion. If that happens, we set this variable to 1 to
3349 give up on handling REPLACE in the optimized way. */
3350 int giveup_match_end
= 0;
3352 if (XINT (beg
) != 0)
3354 if (lseek (fd
, XINT (beg
), 0) < 0)
3355 report_file_error ("Setting file position",
3356 Fcons (orig_filename
, Qnil
));
3361 /* Count how many chars at the start of the file
3362 match the text at the beginning of the buffer. */
3367 nread
= read (fd
, buffer
, sizeof buffer
);
3369 error ("IO error reading %s: %s",
3370 XSTRING (orig_filename
)->data
, strerror (errno
));
3371 else if (nread
== 0)
3374 if (coding
.type
== coding_type_undecided
)
3375 detect_coding (&coding
, buffer
, nread
);
3376 if (CODING_REQUIRE_DECODING (&coding
))
3377 /* We found that the file should be decoded somehow.
3378 Let's give up here. */
3380 giveup_match_end
= 1;
3384 if (coding
.eol_type
== CODING_EOL_UNDECIDED
)
3385 detect_eol (&coding
, buffer
, nread
);
3386 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3387 && coding
.eol_type
!= CODING_EOL_LF
)
3388 /* We found that the format of eol should be decoded.
3389 Let's give up here. */
3391 giveup_match_end
= 1;
3396 while (bufpos
< nread
&& same_at_start
< ZV_BYTE
3397 && FETCH_BYTE (same_at_start
) == buffer
[bufpos
])
3398 same_at_start
++, bufpos
++;
3399 /* If we found a discrepancy, stop the scan.
3400 Otherwise loop around and scan the next bufferful. */
3401 if (bufpos
!= nread
)
3405 /* If the file matches the buffer completely,
3406 there's no need to replace anything. */
3407 if (same_at_start
- BEGV_BYTE
== XINT (end
))
3411 /* Truncate the buffer to the size of the file. */
3412 del_range_1 (same_at_start
, same_at_end
, 0);
3417 /* Count how many chars at the end of the file
3418 match the text at the end of the buffer. But, if we have
3419 already found that decoding is necessary, don't waste time. */
3420 while (!giveup_match_end
)
3422 int total_read
, nread
, bufpos
, curpos
, trial
;
3424 /* At what file position are we now scanning? */
3425 curpos
= XINT (end
) - (ZV_BYTE
- same_at_end
);
3426 /* If the entire file matches the buffer tail, stop the scan. */
3429 /* How much can we scan in the next step? */
3430 trial
= min (curpos
, sizeof buffer
);
3431 if (lseek (fd
, curpos
- trial
, 0) < 0)
3432 report_file_error ("Setting file position",
3433 Fcons (orig_filename
, Qnil
));
3436 while (total_read
< trial
)
3438 nread
= read (fd
, buffer
+ total_read
, trial
- total_read
);
3440 error ("IO error reading %s: %s",
3441 XSTRING (orig_filename
)->data
, strerror (errno
));
3442 total_read
+= nread
;
3444 /* Scan this bufferful from the end, comparing with
3445 the Emacs buffer. */
3446 bufpos
= total_read
;
3447 /* Compare with same_at_start to avoid counting some buffer text
3448 as matching both at the file's beginning and at the end. */
3449 while (bufpos
> 0 && same_at_end
> same_at_start
3450 && FETCH_BYTE (same_at_end
- 1) == buffer
[bufpos
- 1])
3451 same_at_end
--, bufpos
--;
3453 /* If we found a discrepancy, stop the scan.
3454 Otherwise loop around and scan the preceding bufferful. */
3457 /* If this discrepancy is because of code conversion,
3458 we cannot use this method; giveup and try the other. */
3459 if (same_at_end
> same_at_start
3460 && FETCH_BYTE (same_at_end
- 1) >= 0200
3461 && ! NILP (current_buffer
->enable_multibyte_characters
)
3462 && (CODING_REQUIRE_DECODING (&coding
)
3463 || CODING_REQUIRE_DETECTION (&coding
)))
3464 giveup_match_end
= 1;
3470 if (! giveup_match_end
)
3474 /* We win! We can handle REPLACE the optimized way. */
3476 /* Extends the end of non-matching text area to multibyte
3477 character boundary. */
3478 if (! NILP (current_buffer
->enable_multibyte_characters
))
3479 while (same_at_end
< ZV_BYTE
3480 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
3483 /* Don't try to reuse the same piece of text twice. */
3484 overlap
= (same_at_start
- BEGV_BYTE
3485 - (same_at_end
+ st
.st_size
- ZV
));
3487 same_at_end
+= overlap
;
3489 /* Arrange to read only the nonmatching middle part of the file. */
3490 XSETFASTINT (beg
, XINT (beg
) + (same_at_start
- BEGV_BYTE
));
3491 XSETFASTINT (end
, XINT (end
) - (ZV_BYTE
- same_at_end
));
3493 del_range_byte (same_at_start
, same_at_end
, 0);
3494 /* Insert from the file at the proper position. */
3495 temp
= BYTE_TO_CHAR (same_at_start
);
3496 SET_PT_BOTH (temp
, same_at_start
);
3498 /* If display currently starts at beginning of line,
3499 keep it that way. */
3500 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3501 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3503 replace_handled
= 1;
3507 /* If requested, replace the accessible part of the buffer
3508 with the file contents. Avoid replacing text at the
3509 beginning or end of the buffer that matches the file contents;
3510 that preserves markers pointing to the unchanged parts.
3512 Here we implement this feature for the case where code conversion
3513 is needed, in a simple way that needs a lot of memory.
3514 The preceding if-statement handles the case of no conversion
3515 in a more optimized way. */
3516 if (!NILP (replace
) && ! replace_handled
)
3518 int same_at_start
= BEGV_BYTE
;
3519 int same_at_end
= ZV_BYTE
;
3522 /* Make sure that the gap is large enough. */
3523 int bufsize
= 2 * st
.st_size
;
3524 unsigned char *conversion_buffer
= (unsigned char *) xmalloc (bufsize
);
3527 /* First read the whole file, performing code conversion into
3528 CONVERSION_BUFFER. */
3530 if (lseek (fd
, XINT (beg
), 0) < 0)
3532 free (conversion_buffer
);
3533 report_file_error ("Setting file position",
3534 Fcons (orig_filename
, Qnil
));
3537 total
= st
.st_size
; /* Total bytes in the file. */
3538 how_much
= 0; /* Bytes read from file so far. */
3539 inserted
= 0; /* Bytes put into CONVERSION_BUFFER so far. */
3540 unprocessed
= 0; /* Bytes not processed in previous loop. */
3542 while (how_much
< total
)
3544 /* try is reserved in some compilers (Microsoft C) */
3545 int trytry
= min (total
- how_much
, READ_BUF_SIZE
- unprocessed
);
3546 char *destination
= read_buf
+ unprocessed
;
3549 /* Allow quitting out of the actual I/O. */
3552 this = read (fd
, destination
, trytry
);
3555 if (this < 0 || this + unprocessed
== 0)
3563 if (CODING_REQUIRE_DECODING (&coding
)
3564 || CODING_REQUIRE_DETECTION (&coding
))
3566 int require
, produced
, consumed
;
3568 this += unprocessed
;
3570 /* If we are using more space than estimated,
3571 make CONVERSION_BUFFER bigger. */
3572 require
= decoding_buffer_size (&coding
, this);
3573 if (inserted
+ require
+ 2 * (total
- how_much
) > bufsize
)
3575 bufsize
= inserted
+ require
+ 2 * (total
- how_much
);
3576 conversion_buffer
= (unsigned char *) xrealloc (conversion_buffer
, bufsize
);
3579 /* Convert this batch with results in CONVERSION_BUFFER. */
3580 if (how_much
>= total
) /* This is the last block. */
3581 coding
.last_block
= 1;
3582 produced
= decode_coding (&coding
, read_buf
,
3583 conversion_buffer
+ inserted
,
3584 this, bufsize
- inserted
,
3587 /* Save for next iteration whatever we didn't convert. */
3588 unprocessed
= this - consumed
;
3589 bcopy (read_buf
+ consumed
, read_buf
, unprocessed
);
3596 /* At this point, INSERTED is how many characters
3597 are present in CONVERSION_BUFFER.
3598 HOW_MUCH should equal TOTAL,
3599 or should be <= 0 if we couldn't read the file. */
3603 free (conversion_buffer
);
3606 error ("IO error reading %s: %s",
3607 XSTRING (orig_filename
)->data
, strerror (errno
));
3608 else if (how_much
== -2)
3609 error ("maximum buffer size exceeded");
3612 /* Compare the beginning of the converted file
3613 with the buffer text. */
3616 while (bufpos
< inserted
&& same_at_start
< same_at_end
3617 && FETCH_BYTE (same_at_start
) == conversion_buffer
[bufpos
])
3618 same_at_start
++, bufpos
++;
3620 /* If the file matches the buffer completely,
3621 there's no need to replace anything. */
3623 if (bufpos
== inserted
)
3625 free (conversion_buffer
);
3628 /* Truncate the buffer to the size of the file. */
3629 del_range_1 (same_at_start
, same_at_end
, 0);
3633 /* Scan this bufferful from the end, comparing with
3634 the Emacs buffer. */
3637 /* Compare with same_at_start to avoid counting some buffer text
3638 as matching both at the file's beginning and at the end. */
3639 while (bufpos
> 0 && same_at_end
> same_at_start
3640 && FETCH_BYTE (same_at_end
- 1) == conversion_buffer
[bufpos
- 1])
3641 same_at_end
--, bufpos
--;
3643 /* Don't try to reuse the same piece of text twice. */
3644 overlap
= same_at_start
- BEGV_BYTE
- (same_at_end
+ inserted
- ZV_BYTE
);
3646 same_at_end
+= overlap
;
3648 /* If display currently starts at beginning of line,
3649 keep it that way. */
3650 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3651 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3653 /* Replace the chars that we need to replace,
3654 and update INSERTED to equal the number of bytes
3655 we are taking from the file. */
3656 inserted
-= (Z_BYTE
- same_at_end
) + (same_at_start
- BEG_BYTE
);
3657 del_range_byte (same_at_start
, same_at_end
, 0);
3658 SET_PT_BOTH (GPT
, GPT_BYTE
);
3660 insert_1 (conversion_buffer
+ same_at_start
- BEG_BYTE
, inserted
,
3663 free (conversion_buffer
);
3672 register Lisp_Object temp
;
3674 total
= XINT (end
) - XINT (beg
);
3676 /* Make sure point-max won't overflow after this insertion. */
3677 XSETINT (temp
, total
);
3678 if (total
!= XINT (temp
))
3679 error ("Maximum buffer size exceeded");
3682 /* For a special file, all we can do is guess. */
3683 total
= READ_BUF_SIZE
;
3685 if (NILP (visit
) && total
> 0)
3686 prepare_to_modify_buffer (PT
, PT
, NULL
);
3689 if (GAP_SIZE
< total
)
3690 make_gap (total
- GAP_SIZE
);
3692 if (XINT (beg
) != 0 || !NILP (replace
))
3694 if (lseek (fd
, XINT (beg
), 0) < 0)
3695 report_file_error ("Setting file position",
3696 Fcons (orig_filename
, Qnil
));
3699 /* In the following loop, HOW_MUCH contains the total bytes read so
3700 far. Before exiting the loop, it is set to -1 if I/O error
3701 occurs, set to -2 if the maximum buffer size is exceeded. */
3703 /* Total bytes inserted. */
3705 /* Bytes not processed in the previous loop because short gap size. */
3707 while (how_much
< total
)
3709 /* try is reserved in some compilers (Microsoft C) */
3710 int trytry
= min (total
- how_much
, READ_BUF_SIZE
- unprocessed
);
3711 char *destination
= (! (CODING_REQUIRE_DECODING (&coding
)
3712 || CODING_REQUIRE_DETECTION (&coding
))
3713 ? (char *) (BYTE_POS_ADDR (PT_BYTE
+ inserted
- 1) + 1)
3714 : read_buf
+ unprocessed
);
3715 int this, this_chars
;
3717 /* Allow quitting out of the actual I/O. */
3720 this = read (fd
, destination
, trytry
);
3723 if (this < 0 || this + unprocessed
== 0)
3729 /* For a regular file, where TOTAL is the real size,
3730 count HOW_MUCH to compare with it.
3731 For a special file, where TOTAL is just a buffer size,
3732 so don't bother counting in HOW_MUCH.
3733 (INSERTED is where we count the number of characters inserted.) */
3737 if (CODING_REQUIRE_DECODING (&coding
)
3738 || CODING_REQUIRE_DETECTION (&coding
))
3740 int require
, produced
, consumed
;
3742 this += unprocessed
;
3743 /* Make sure that the gap is large enough. */
3744 require
= decoding_buffer_size (&coding
, this);
3745 if (GAP_SIZE
< require
)
3746 make_gap (require
- GAP_SIZE
);
3750 if (how_much
>= total
) /* This is the last block. */
3751 coding
.last_block
= 1;
3755 /* If we encounter EOF, say it is the last block. (The
3756 data this will apply to is the UNPROCESSED characters
3757 carried over from the last batch.) */
3759 coding
.last_block
= 1;
3762 produced
= decode_coding (&coding
, read_buf
,
3763 BYTE_POS_ADDR (PT_BYTE
+ inserted
- 1) + 1,
3764 this, GAP_SIZE
, &consumed
);
3769 XSET (temp
, Lisp_Int
, Z_BYTE
+ produced
);
3770 if (Z_BYTE
+ produced
!= XINT (temp
))
3776 unprocessed
= this - consumed
;
3777 bcopy (read_buf
+ consumed
, read_buf
, unprocessed
);
3779 this_chars
= chars_in_text (BYTE_POS_ADDR (PT_BYTE
+ inserted
- 1) + 1,
3782 else if (! NILP (current_buffer
->enable_multibyte_characters
))
3783 this_chars
= chars_in_text (BYTE_POS_ADDR (PT_BYTE
+ inserted
- 1) + 1,
3797 /* Put an anchor to ensure multi-byte form ends at gap. */
3800 inserted_chars
+= this_chars
;
3804 /* Use the conversion type to determine buffer-file-type
3805 (find-buffer-file-type is now used to help determine the
3807 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3808 && coding
.eol_type
!= CODING_EOL_LF
)
3809 current_buffer
->buffer_file_type
= Qnil
;
3811 current_buffer
->buffer_file_type
= Qt
;
3816 record_insert (PT
, inserted_chars
);
3818 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
3819 offset_intervals (current_buffer
, PT
, inserted_chars
);
3825 /* Discard the unwind protect for closing the file. */
3829 error ("IO error reading %s: %s",
3830 XSTRING (orig_filename
)->data
, strerror (errno
));
3831 else if (how_much
== -2)
3832 error ("Maximum buffer size exceeded");
3834 set_coding_system
= 1;
3841 if (!EQ (current_buffer
->undo_list
, Qt
))
3842 current_buffer
->undo_list
= Qnil
;
3844 stat (XSTRING (filename
)->data
, &st
);
3849 current_buffer
->modtime
= st
.st_mtime
;
3850 current_buffer
->filename
= orig_filename
;
3853 SAVE_MODIFF
= MODIFF
;
3854 current_buffer
->auto_save_modified
= MODIFF
;
3855 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
3856 #ifdef CLASH_DETECTION
3859 if (!NILP (current_buffer
->file_truename
))
3860 unlock_file (current_buffer
->file_truename
);
3861 unlock_file (filename
);
3863 #endif /* CLASH_DETECTION */
3865 Fsignal (Qfile_error
,
3866 Fcons (build_string ("not a regular file"),
3867 Fcons (orig_filename
, Qnil
)));
3869 /* If visiting nonexistent file, return nil. */
3870 if (current_buffer
->modtime
== -1)
3871 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3874 /* Decode file format */
3875 if (inserted_chars
> 0)
3877 insval
= call3 (Qformat_decode
,
3878 Qnil
, make_number (inserted_chars
), visit
);
3879 CHECK_NUMBER (insval
, 0);
3880 inserted_chars
= XFASTINT (insval
);
3883 /* Call after-change hooks for the inserted text, aside from the case
3884 of normal visiting (not with REPLACE), which is done in a new buffer
3885 "before" the buffer is changed. */
3886 if (inserted_chars
> 0 && total
> 0
3887 && (NILP (visit
) || !NILP (replace
)))
3888 signal_after_change (PT
, 0, inserted_chars
);
3890 if (set_coding_system
)
3891 Vlast_coding_system_used
= coding
.symbol
;
3895 p
= Vafter_insert_file_functions
;
3896 if (!NILP (coding
.post_read_conversion
))
3897 p
= Fcons (coding
.post_read_conversion
, p
);
3901 insval
= call1 (Fcar (p
), make_number (inserted_chars
));
3904 CHECK_NUMBER (insval
, 0);
3905 inserted_chars
= XFASTINT (insval
);
3912 /* ??? Retval needs to be dealt with in all cases consistently. */
3914 val
= Fcons (orig_filename
,
3915 Fcons (make_number (inserted
),
3918 RETURN_UNGCPRO (unbind_to (count
, val
));
3921 static Lisp_Object build_annotations
P_ ((Lisp_Object
, Lisp_Object
,
3924 /* If build_annotations switched buffers, switch back to BUF.
3925 Kill the temporary buffer that was selected in the meantime.
3927 Since this kill only the last temporary buffer, some buffers remain
3928 not killed if build_annotations switched buffers more than once.
3932 build_annotations_unwind (buf
)
3937 if (XBUFFER (buf
) == current_buffer
)
3939 tembuf
= Fcurrent_buffer ();
3941 Fkill_buffer (tembuf
);
3945 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 6,
3946 "r\nFWrite region to file: ",
3947 "Write current region into specified file.\n\
3948 When called from a program, takes three arguments:\n\
3949 START, END and FILENAME. START and END are buffer positions.\n\
3950 Optional fourth argument APPEND if non-nil means\n\
3951 append to existing file contents (if any).\n\
3952 Optional fifth argument VISIT if t means\n\
3953 set the last-save-file-modtime of buffer to this file's modtime\n\
3954 and mark buffer not modified.\n\
3955 If VISIT is a string, it is a second file name;\n\
3956 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
3957 VISIT is also the file name to lock and unlock for clash detection.\n\
3958 If VISIT is neither t nor nil nor a string,\n\
3959 that means do not print the \"Wrote file\" message.\n\
3960 The optional sixth arg LOCKNAME, if non-nil, specifies the name to\n\
3961 use for locking and unlocking, overriding FILENAME and VISIT.\n\
3962 Kludgy feature: if START is a string, then that string is written\n\
3963 to the file, instead of any buffer contents, and END is ignored.")
3964 (start
, end
, filename
, append
, visit
, lockname
)
3965 Lisp_Object start
, end
, filename
, append
, visit
, lockname
;
3973 int count
= specpdl_ptr
- specpdl
;
3976 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
3978 Lisp_Object handler
;
3979 Lisp_Object visit_file
;
3980 Lisp_Object annotations
;
3981 Lisp_Object encoded_filename
;
3982 int visiting
, quietly
;
3983 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
3984 struct buffer
*given_buffer
;
3986 int buffer_file_type
= O_BINARY
;
3988 struct coding_system coding
;
3990 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3991 error ("Cannot do file visiting in an indirect buffer");
3993 if (!NILP (start
) && !STRINGP (start
))
3994 validate_region (&start
, &end
);
3996 GCPRO4 (start
, filename
, visit
, lockname
);
3998 /* Decide the coding-system to encode the data with. */
4004 else if (!NILP (Vcoding_system_for_write
))
4005 val
= Vcoding_system_for_write
;
4006 else if (NILP (current_buffer
->enable_multibyte_characters
))
4008 /* If the variable `buffer-file-coding-system' is set locally,
4009 it means that the file was read with some kind of code
4010 conversion or the varialbe is explicitely set by users. We
4011 had better write it out with the same coding system even if
4012 `enable-multibyte-characters' is nil.
4014 If is is not set locally, we anyway have to convert EOL
4015 format if the default value of `buffer-file-coding-system'
4016 tells that it is not Unix-like (LF only) format. */
4017 val
= current_buffer
->buffer_file_coding_system
;
4018 if (NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4020 struct coding_system coding_temp
;
4022 setup_coding_system (Fcheck_coding_system (val
), &coding_temp
);
4023 if (coding_temp
.eol_type
== CODING_EOL_CRLF
4024 || coding_temp
.eol_type
== CODING_EOL_CR
)
4026 setup_coding_system (Qemacs_mule
, &coding
);
4027 coding
.eol_type
= coding_temp
.eol_type
;
4028 goto done_setup_coding
;
4035 Lisp_Object args
[7], coding_systems
;
4037 args
[0] = Qwrite_region
, args
[1] = start
, args
[2] = end
,
4038 args
[3] = filename
, args
[4] = append
, args
[5] = visit
,
4040 coding_systems
= Ffind_operation_coding_system (7, args
);
4041 val
= (CONSP (coding_systems
) && !NILP (XCONS (coding_systems
)->cdr
)
4042 ? XCONS (coding_systems
)->cdr
4043 : current_buffer
->buffer_file_coding_system
);
4045 setup_coding_system (Fcheck_coding_system (val
), &coding
);
4048 if (!STRINGP (start
) && !NILP (current_buffer
->selective_display
))
4049 coding
.selective
= 1;
4052 Vlast_coding_system_used
= coding
.symbol
;
4054 filename
= Fexpand_file_name (filename
, Qnil
);
4055 if (STRINGP (visit
))
4056 visit_file
= Fexpand_file_name (visit
, Qnil
);
4058 visit_file
= filename
;
4061 visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
4062 quietly
= !NILP (visit
);
4066 if (NILP (lockname
))
4067 lockname
= visit_file
;
4069 GCPRO5 (start
, filename
, annotations
, visit_file
, lockname
);
4071 /* If the file name has special constructs in it,
4072 call the corresponding file handler. */
4073 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
4074 /* If FILENAME has no handler, see if VISIT has one. */
4075 if (NILP (handler
) && STRINGP (visit
))
4076 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
4078 if (!NILP (handler
))
4081 val
= call6 (handler
, Qwrite_region
, start
, end
,
4082 filename
, append
, visit
);
4086 SAVE_MODIFF
= MODIFF
;
4087 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4088 current_buffer
->filename
= visit_file
;
4094 /* Special kludge to simplify auto-saving. */
4097 XSETFASTINT (start
, BEG
);
4098 XSETFASTINT (end
, Z
);
4101 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
4102 count1
= specpdl_ptr
- specpdl
;
4104 given_buffer
= current_buffer
;
4105 annotations
= build_annotations (start
, end
, coding
.pre_write_conversion
);
4106 if (current_buffer
!= given_buffer
)
4108 XSETFASTINT (start
, BEGV
);
4109 XSETFASTINT (end
, ZV
);
4112 #ifdef CLASH_DETECTION
4115 #if 0 /* This causes trouble for GNUS. */
4116 /* If we've locked this file for some other buffer,
4117 query before proceeding. */
4118 if (!visiting
&& EQ (Ffile_locked_p (lockname
), Qt
))
4119 call2 (intern ("ask-user-about-lock"), filename
, Vuser_login_name
);
4122 lock_file (lockname
);
4124 #endif /* CLASH_DETECTION */
4126 encoded_filename
= ENCODE_FILE (filename
);
4128 fn
= XSTRING (encoded_filename
)->data
;
4132 desc
= open (fn
, O_WRONLY
| buffer_file_type
);
4133 #else /* not DOS_NT */
4134 desc
= open (fn
, O_WRONLY
);
4135 #endif /* not DOS_NT */
4137 if (desc
< 0 && (NILP (append
) || errno
== ENOENT
))
4139 if (auto_saving
) /* Overwrite any previous version of autosave file */
4141 vms_truncate (fn
); /* if fn exists, truncate to zero length */
4142 desc
= open (fn
, O_RDWR
);
4144 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
4145 ? XSTRING (current_buffer
->filename
)->data
: 0,
4148 else /* Write to temporary name and rename if no errors */
4150 Lisp_Object temp_name
;
4151 temp_name
= Ffile_name_directory (filename
);
4153 if (!NILP (temp_name
))
4155 temp_name
= Fmake_temp_name (concat2 (temp_name
,
4156 build_string ("$$SAVE$$")));
4157 fname
= XSTRING (filename
)->data
;
4158 fn
= XSTRING (temp_name
)->data
;
4159 desc
= creat_copy_attrs (fname
, fn
);
4162 /* If we can't open the temporary file, try creating a new
4163 version of the original file. VMS "creat" creates a
4164 new version rather than truncating an existing file. */
4167 desc
= creat (fn
, 0666);
4168 #if 0 /* This can clobber an existing file and fail to replace it,
4169 if the user runs out of space. */
4172 /* We can't make a new version;
4173 try to truncate and rewrite existing version if any. */
4175 desc
= open (fn
, O_RDWR
);
4181 desc
= creat (fn
, 0666);
4186 O_WRONLY
| O_TRUNC
| O_CREAT
| buffer_file_type
,
4187 S_IREAD
| S_IWRITE
);
4188 #else /* not DOS_NT */
4189 desc
= creat (fn
, auto_saving
? auto_save_mode_bits
: 0666);
4190 #endif /* not DOS_NT */
4191 #endif /* not VMS */
4197 #ifdef CLASH_DETECTION
4199 if (!auto_saving
) unlock_file (lockname
);
4201 #endif /* CLASH_DETECTION */
4202 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
4205 record_unwind_protect (close_file_unwind
, make_number (desc
));
4208 if (lseek (desc
, 0, 2) < 0)
4210 #ifdef CLASH_DETECTION
4211 if (!auto_saving
) unlock_file (lockname
);
4212 #endif /* CLASH_DETECTION */
4213 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
4218 * Kludge Warning: The VMS C RTL likes to insert carriage returns
4219 * if we do writes that don't end with a carriage return. Furthermore
4220 * it cannot handle writes of more then 16K. The modified
4221 * version of "sys_write" in SYSDEP.C (see comment there) copes with
4222 * this EXCEPT for the last record (iff it doesn't end with a carriage
4223 * return). This implies that if your buffer doesn't end with a carriage
4224 * return, you get one free... tough. However it also means that if
4225 * we make two calls to sys_write (a la the following code) you can
4226 * get one at the gap as well. The easiest way to fix this (honest)
4227 * is to move the gap to the next newline (or the end of the buffer).
4232 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4233 move_gap (find_next_newline (GPT
, 1));
4235 /* Whether VMS or not, we must move the gap to the next of newline
4236 when we must put designation sequences at beginning of line. */
4237 if (INTEGERP (start
)
4238 && coding
.type
== coding_type_iso2022
4239 && coding
.flags
& CODING_FLAG_ISO_DESIGNATE_AT_BOL
4240 && GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4242 int opoint
= PT
, opoint_byte
= PT_BYTE
;
4243 scan_newline (PT
, PT_BYTE
, ZV
, ZV_BYTE
, 1, 0);
4244 move_gap_both (PT
, PT_BYTE
);
4245 SET_PT_BOTH (opoint
, opoint_byte
);
4252 if (STRINGP (start
))
4254 failure
= 0 > a_write (desc
, XSTRING (start
)->data
,
4255 XSTRING (start
)->size
, 0, &annotations
, &coding
);
4258 else if (XINT (start
) != XINT (end
))
4260 register int end1
= CHAR_TO_BYTE (XINT (end
));
4262 tem
= CHAR_TO_BYTE (XINT (start
));
4264 if (XINT (start
) < GPT
)
4266 failure
= 0 > a_write (desc
, BYTE_POS_ADDR (tem
),
4267 min (GPT_BYTE
, end1
) - tem
, tem
, &annotations
,
4272 if (XINT (end
) > GPT
&& !failure
)
4274 tem
= max (tem
, GPT_BYTE
);
4275 failure
= 0 > a_write (desc
, BYTE_POS_ADDR (tem
), end1
- tem
,
4276 tem
, &annotations
, &coding
);
4282 /* If file was empty, still need to write the annotations */
4283 coding
.last_block
= 1;
4284 failure
= 0 > a_write (desc
, "", 0, XINT (start
), &annotations
, &coding
);
4288 if (CODING_REQUIRE_FLUSHING (&coding
) && !coding
.last_block
4291 /* We have to flush out a data. */
4292 coding
.last_block
= 1;
4293 failure
= 0 > e_write (desc
, "", 0, &coding
);
4300 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
4301 Disk full in NFS may be reported here. */
4302 /* mib says that closing the file will try to write as fast as NFS can do
4303 it, and that means the fsync here is not crucial for autosave files. */
4304 if (!auto_saving
&& fsync (desc
) < 0)
4306 /* If fsync fails with EINTR, don't treat that as serious. */
4308 failure
= 1, save_errno
= errno
;
4312 /* Spurious "file has changed on disk" warnings have been
4313 observed on Suns as well.
4314 It seems that `close' can change the modtime, under nfs.
4316 (This has supposedly been fixed in Sunos 4,
4317 but who knows about all the other machines with NFS?) */
4320 /* On VMS and APOLLO, must do the stat after the close
4321 since closing changes the modtime. */
4324 /* Recall that #if defined does not work on VMS. */
4331 /* NFS can report a write failure now. */
4332 if (close (desc
) < 0)
4333 failure
= 1, save_errno
= errno
;
4336 /* If we wrote to a temporary name and had no errors, rename to real name. */
4340 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
4348 /* Discard the unwind protect for close_file_unwind. */
4349 specpdl_ptr
= specpdl
+ count1
;
4350 /* Restore the original current buffer. */
4351 visit_file
= unbind_to (count
, visit_file
);
4353 #ifdef CLASH_DETECTION
4355 unlock_file (lockname
);
4356 #endif /* CLASH_DETECTION */
4358 /* Do this before reporting IO error
4359 to avoid a "file has changed on disk" warning on
4360 next attempt to save. */
4362 current_buffer
->modtime
= st
.st_mtime
;
4365 error ("IO error writing %s: %s", XSTRING (filename
)->data
,
4366 strerror (save_errno
));
4370 SAVE_MODIFF
= MODIFF
;
4371 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4372 current_buffer
->filename
= visit_file
;
4373 update_mode_lines
++;
4379 message_with_string ("Wrote %s", visit_file
, 1);
4384 Lisp_Object
merge ();
4386 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
4387 "Return t if (car A) is numerically less than (car B).")
4391 return Flss (Fcar (a
), Fcar (b
));
4394 /* Build the complete list of annotations appropriate for writing out
4395 the text between START and END, by calling all the functions in
4396 write-region-annotate-functions and merging the lists they return.
4397 If one of these functions switches to a different buffer, we assume
4398 that buffer contains altered text. Therefore, the caller must
4399 make sure to restore the current buffer in all cases,
4400 as save-excursion would do. */
4403 build_annotations (start
, end
, pre_write_conversion
)
4404 Lisp_Object start
, end
, pre_write_conversion
;
4406 Lisp_Object annotations
;
4408 struct gcpro gcpro1
, gcpro2
;
4409 Lisp_Object original_buffer
;
4411 XSETBUFFER (original_buffer
, current_buffer
);
4414 p
= Vwrite_region_annotate_functions
;
4415 GCPRO2 (annotations
, p
);
4418 struct buffer
*given_buffer
= current_buffer
;
4419 Vwrite_region_annotations_so_far
= annotations
;
4420 res
= call2 (Fcar (p
), start
, end
);
4421 /* If the function makes a different buffer current,
4422 assume that means this buffer contains altered text to be output.
4423 Reset START and END from the buffer bounds
4424 and discard all previous annotations because they should have
4425 been dealt with by this function. */
4426 if (current_buffer
!= given_buffer
)
4428 XSETFASTINT (start
, BEGV
);
4429 XSETFASTINT (end
, ZV
);
4432 Flength (res
); /* Check basic validity of return value */
4433 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4437 /* Now do the same for annotation functions implied by the file-format */
4438 if (auto_saving
&& (!EQ (Vauto_save_file_format
, Qt
)))
4439 p
= Vauto_save_file_format
;
4441 p
= current_buffer
->file_format
;
4444 struct buffer
*given_buffer
= current_buffer
;
4445 Vwrite_region_annotations_so_far
= annotations
;
4446 res
= call4 (Qformat_annotate_function
, Fcar (p
), start
, end
,
4448 if (current_buffer
!= given_buffer
)
4450 XSETFASTINT (start
, BEGV
);
4451 XSETFASTINT (end
, ZV
);
4455 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4459 /* At last, do the same for the function PRE_WRITE_CONVERSION
4460 implied by the current coding-system. */
4461 if (!NILP (pre_write_conversion
))
4463 struct buffer
*given_buffer
= current_buffer
;
4464 Vwrite_region_annotations_so_far
= annotations
;
4465 res
= call2 (pre_write_conversion
, start
, end
);
4467 annotations
= (current_buffer
!= given_buffer
4469 : merge (annotations
, res
, Qcar_less_than_car
));
4476 /* Write to descriptor DESC the NBYTES bytes starting at ADDR,
4477 assuming they start at byte position BYTEPOS in the buffer.
4478 Intersperse with them the annotations from *ANNOT
4479 which fall within the range of byte positions BYTEPOS to BYTEPOS + NBYTES,
4480 each at its appropriate position.
4482 We modify *ANNOT by discarding elements as we use them up.
4484 The return value is negative in case of system call failure. */
4487 a_write (desc
, addr
, nbytes
, bytepos
, annot
, coding
)
4489 register char *addr
;
4490 register int nbytes
;
4493 struct coding_system
*coding
;
4497 int lastpos
= bytepos
+ nbytes
;
4499 while (NILP (*annot
) || CONSP (*annot
))
4501 tem
= Fcar_safe (Fcar (*annot
));
4504 nextpos
= CHAR_TO_BYTE (XFASTINT (tem
));
4506 /* If there are no more annotations in this range,
4507 output the rest of the range all at once. */
4508 if (! (nextpos
>= bytepos
&& nextpos
<= lastpos
))
4509 return e_write (desc
, addr
, lastpos
- bytepos
, coding
);
4511 /* Output buffer text up to the next annotation's position. */
4512 if (nextpos
> bytepos
)
4514 if (0 > e_write (desc
, addr
, nextpos
- bytepos
, coding
))
4516 addr
+= nextpos
- bytepos
;
4519 /* Output the annotation. */
4520 tem
= Fcdr (Fcar (*annot
));
4523 if (0 > e_write (desc
, XSTRING (tem
)->data
, XSTRING (tem
)->size
,
4527 *annot
= Fcdr (*annot
);
4531 #ifndef WRITE_BUF_SIZE
4532 #define WRITE_BUF_SIZE (16 * 1024)
4535 /* Write NBYTES bytes starting at ADDR into descriptor DESC,
4536 encoding them with coding system CODING. */
4539 e_write (desc
, addr
, nbytes
, coding
)
4541 register char *addr
;
4542 register int nbytes
;
4543 struct coding_system
*coding
;
4545 char buf
[WRITE_BUF_SIZE
];
4546 int produced
, consumed
;
4548 /* We used to have a code for handling selective display here. But,
4549 now it is handled within encode_coding. */
4552 produced
= encode_coding (coding
, addr
, buf
, nbytes
, WRITE_BUF_SIZE
,
4554 nbytes
-= consumed
, addr
+= consumed
;
4557 produced
-= write (desc
, buf
, produced
);
4558 if (produced
) return -1;
4566 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
4567 Sverify_visited_file_modtime
, 1, 1, 0,
4568 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
4569 This means that the file has not been changed since it was visited or saved.")
4575 Lisp_Object handler
;
4576 Lisp_Object filename
;
4578 CHECK_BUFFER (buf
, 0);
4581 if (!STRINGP (b
->filename
)) return Qt
;
4582 if (b
->modtime
== 0) return Qt
;
4584 /* If the file name has special constructs in it,
4585 call the corresponding file handler. */
4586 handler
= Ffind_file_name_handler (b
->filename
,
4587 Qverify_visited_file_modtime
);
4588 if (!NILP (handler
))
4589 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
4591 filename
= ENCODE_FILE (b
->filename
);
4593 if (stat (XSTRING (filename
)->data
, &st
) < 0)
4595 /* If the file doesn't exist now and didn't exist before,
4596 we say that it isn't modified, provided the error is a tame one. */
4597 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
4602 if (st
.st_mtime
== b
->modtime
4603 /* If both are positive, accept them if they are off by one second. */
4604 || (st
.st_mtime
> 0 && b
->modtime
> 0
4605 && (st
.st_mtime
== b
->modtime
+ 1
4606 || st
.st_mtime
== b
->modtime
- 1)))
4611 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
4612 Sclear_visited_file_modtime
, 0, 0, 0,
4613 "Clear out records of last mod time of visited file.\n\
4614 Next attempt to save will certainly not complain of a discrepancy.")
4617 current_buffer
->modtime
= 0;
4621 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
4622 Svisited_file_modtime
, 0, 0, 0,
4623 "Return the current buffer's recorded visited file modification time.\n\
4624 The value is a list of the form (HIGH . LOW), like the time values\n\
4625 that `file-attributes' returns.")
4628 return long_to_cons ((unsigned long) current_buffer
->modtime
);
4631 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
4632 Sset_visited_file_modtime
, 0, 1, 0,
4633 "Update buffer's recorded modification time from the visited file's time.\n\
4634 Useful if the buffer was not read from the file normally\n\
4635 or if the file itself has been changed for some known benign reason.\n\
4636 An argument specifies the modification time value to use\n\
4637 \(instead of that of the visited file), in the form of a list\n\
4638 \(HIGH . LOW) or (HIGH LOW).")
4640 Lisp_Object time_list
;
4642 if (!NILP (time_list
))
4643 current_buffer
->modtime
= cons_to_long (time_list
);
4646 register Lisp_Object filename
;
4648 Lisp_Object handler
;
4650 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
4652 /* If the file name has special constructs in it,
4653 call the corresponding file handler. */
4654 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
4655 if (!NILP (handler
))
4656 /* The handler can find the file name the same way we did. */
4657 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
4659 filename
= ENCODE_FILE (filename
);
4661 if (stat (XSTRING (filename
)->data
, &st
) >= 0)
4662 current_buffer
->modtime
= st
.st_mtime
;
4672 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 1);
4673 Fsleep_for (make_number (1), Qnil
);
4674 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 0);
4675 Fsleep_for (make_number (1), Qnil
);
4676 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 0);
4677 Fsleep_for (make_number (1), Qnil
);
4687 /* Get visited file's mode to become the auto save file's mode. */
4688 if (stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
4689 /* But make sure we can overwrite it later! */
4690 auto_save_mode_bits
= st
.st_mode
| 0600;
4692 auto_save_mode_bits
= 0666;
4695 Fwrite_region (Qnil
, Qnil
,
4696 current_buffer
->auto_save_file_name
,
4697 Qnil
, Qlambda
, Qnil
);
4701 do_auto_save_unwind (stream
) /* used as unwind-protect function */
4706 fclose ((FILE *) (XFASTINT (XCONS (stream
)->car
) << 16
4707 | XFASTINT (XCONS (stream
)->cdr
)));
4712 do_auto_save_unwind_1 (value
) /* used as unwind-protect function */
4715 minibuffer_auto_raise
= XINT (value
);
4719 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
4720 "Auto-save all buffers that need it.\n\
4721 This is all buffers that have auto-saving enabled\n\
4722 and are changed since last auto-saved.\n\
4723 Auto-saving writes the buffer into a file\n\
4724 so that your editing is not lost if the system crashes.\n\
4725 This file is not the file you visited; that changes only when you save.\n\
4726 Normally we run the normal hook `auto-save-hook' before saving.\n\n\
4727 A non-nil NO-MESSAGE argument means do not print any message if successful.\n\
4728 A non-nil CURRENT-ONLY argument means save only current buffer.")
4729 (no_message
, current_only
)
4730 Lisp_Object no_message
, current_only
;
4732 struct buffer
*old
= current_buffer
, *b
;
4733 Lisp_Object tail
, buf
;
4735 char *omessage
= echo_area_glyphs
;
4736 int omessage_length
= echo_area_glyphs_length
;
4737 int oldmultibyte
= message_enable_multibyte
;
4738 int do_handled_files
;
4741 Lisp_Object lispstream
;
4742 int count
= specpdl_ptr
- specpdl
;
4744 int orig_minibuffer_auto_raise
= minibuffer_auto_raise
;
4746 /* Ordinarily don't quit within this function,
4747 but don't make it impossible to quit (in case we get hung in I/O). */
4751 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
4752 point to non-strings reached from Vbuffer_alist. */
4757 if (!NILP (Vrun_hooks
))
4758 call1 (Vrun_hooks
, intern ("auto-save-hook"));
4760 if (STRINGP (Vauto_save_list_file_name
))
4762 Lisp_Object listfile
;
4763 listfile
= Fexpand_file_name (Vauto_save_list_file_name
, Qnil
);
4764 stream
= fopen (XSTRING (listfile
)->data
, "w");
4767 /* Arrange to close that file whether or not we get an error.
4768 Also reset auto_saving to 0. */
4769 lispstream
= Fcons (Qnil
, Qnil
);
4770 XSETFASTINT (XCONS (lispstream
)->car
, (EMACS_UINT
)stream
>> 16);
4771 XSETFASTINT (XCONS (lispstream
)->cdr
, (EMACS_UINT
)stream
& 0xffff);
4782 record_unwind_protect (do_auto_save_unwind
, lispstream
);
4783 record_unwind_protect (do_auto_save_unwind_1
,
4784 make_number (minibuffer_auto_raise
));
4785 minibuffer_auto_raise
= 0;
4788 /* First, save all files which don't have handlers. If Emacs is
4789 crashing, the handlers may tweak what is causing Emacs to crash
4790 in the first place, and it would be a shame if Emacs failed to
4791 autosave perfectly ordinary files because it couldn't handle some
4793 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
4794 for (tail
= Vbuffer_alist
; GC_CONSP (tail
); tail
= XCONS (tail
)->cdr
)
4796 buf
= XCONS (XCONS (tail
)->car
)->cdr
;
4799 /* Record all the buffers that have auto save mode
4800 in the special file that lists them. For each of these buffers,
4801 Record visited name (if any) and auto save name. */
4802 if (STRINGP (b
->auto_save_file_name
)
4803 && stream
!= NULL
&& do_handled_files
== 0)
4805 if (!NILP (b
->filename
))
4807 fwrite (XSTRING (b
->filename
)->data
, 1,
4808 XSTRING (b
->filename
)->size
, stream
);
4810 putc ('\n', stream
);
4811 fwrite (XSTRING (b
->auto_save_file_name
)->data
, 1,
4812 XSTRING (b
->auto_save_file_name
)->size
, stream
);
4813 putc ('\n', stream
);
4816 if (!NILP (current_only
)
4817 && b
!= current_buffer
)
4820 /* Don't auto-save indirect buffers.
4821 The base buffer takes care of it. */
4825 /* Check for auto save enabled
4826 and file changed since last auto save
4827 and file changed since last real save. */
4828 if (STRINGP (b
->auto_save_file_name
)
4829 && BUF_SAVE_MODIFF (b
) < BUF_MODIFF (b
)
4830 && b
->auto_save_modified
< BUF_MODIFF (b
)
4831 /* -1 means we've turned off autosaving for a while--see below. */
4832 && XINT (b
->save_length
) >= 0
4833 && (do_handled_files
4834 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
4837 EMACS_TIME before_time
, after_time
;
4839 EMACS_GET_TIME (before_time
);
4841 /* If we had a failure, don't try again for 20 minutes. */
4842 if (b
->auto_save_failure_time
>= 0
4843 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
4846 if ((XFASTINT (b
->save_length
) * 10
4847 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
4848 /* A short file is likely to change a large fraction;
4849 spare the user annoying messages. */
4850 && XFASTINT (b
->save_length
) > 5000
4851 /* These messages are frequent and annoying for `*mail*'. */
4852 && !EQ (b
->filename
, Qnil
)
4853 && NILP (no_message
))
4855 /* It has shrunk too much; turn off auto-saving here. */
4856 minibuffer_auto_raise
= orig_minibuffer_auto_raise
;
4857 message_with_string ("Buffer %s has shrunk a lot; auto save turned off there",
4859 minibuffer_auto_raise
= 0;
4860 /* Turn off auto-saving until there's a real save,
4861 and prevent any more warnings. */
4862 XSETINT (b
->save_length
, -1);
4863 Fsleep_for (make_number (1), Qnil
);
4866 set_buffer_internal (b
);
4867 if (!auto_saved
&& NILP (no_message
))
4868 message1 ("Auto-saving...");
4869 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
4871 b
->auto_save_modified
= BUF_MODIFF (b
);
4872 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4873 set_buffer_internal (old
);
4875 EMACS_GET_TIME (after_time
);
4877 /* If auto-save took more than 60 seconds,
4878 assume it was an NFS failure that got a timeout. */
4879 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
4880 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
4884 /* Prevent another auto save till enough input events come in. */
4885 record_auto_save ();
4887 if (auto_saved
&& NILP (no_message
))
4891 sit_for (1, 0, 0, 0, 0);
4892 message2 (omessage
, omessage_length
, oldmultibyte
);
4895 message1 ("Auto-saving...done");
4900 unbind_to (count
, Qnil
);
4904 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
4905 Sset_buffer_auto_saved
, 0, 0, 0,
4906 "Mark current buffer as auto-saved with its current text.\n\
4907 No auto-save file will be written until the buffer changes again.")
4910 current_buffer
->auto_save_modified
= MODIFF
;
4911 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4912 current_buffer
->auto_save_failure_time
= -1;
4916 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
4917 Sclear_buffer_auto_save_failure
, 0, 0, 0,
4918 "Clear any record of a recent auto-save failure in the current buffer.")
4921 current_buffer
->auto_save_failure_time
= -1;
4925 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
4927 "Return t if buffer has been auto-saved since last read in or saved.")
4930 return (SAVE_MODIFF
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
4933 /* Reading and completing file names */
4934 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
4936 /* In the string VAL, change each $ to $$ and return the result. */
4939 double_dollars (val
)
4942 register unsigned char *old
, *new;
4946 osize
= XSTRING (val
)->size_byte
;
4948 /* Count the number of $ characters. */
4949 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
4950 if (*old
++ == '$') count
++;
4953 old
= XSTRING (val
)->data
;
4954 val
= make_uninit_multibyte_string (XSTRING (val
)->size
+ count
,
4956 new = XSTRING (val
)->data
;
4957 for (n
= osize
; n
> 0; n
--)
4970 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
4972 "Internal subroutine for read-file-name. Do not call this.")
4973 (string
, dir
, action
)
4974 Lisp_Object string
, dir
, action
;
4975 /* action is nil for complete, t for return list of completions,
4976 lambda for verify final value */
4978 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
4980 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
4982 CHECK_STRING (string
, 0);
4989 /* No need to protect ACTION--we only compare it with t and nil. */
4990 GCPRO5 (string
, realdir
, name
, specdir
, orig_string
);
4992 if (XSTRING (string
)->size
== 0)
4994 if (EQ (action
, Qlambda
))
5002 orig_string
= string
;
5003 string
= Fsubstitute_in_file_name (string
);
5004 changed
= NILP (Fstring_equal (string
, orig_string
));
5005 name
= Ffile_name_nondirectory (string
);
5006 val
= Ffile_name_directory (string
);
5008 realdir
= Fexpand_file_name (val
, realdir
);
5013 specdir
= Ffile_name_directory (string
);
5014 val
= Ffile_name_completion (name
, realdir
);
5019 return double_dollars (string
);
5023 if (!NILP (specdir
))
5024 val
= concat2 (specdir
, val
);
5026 return double_dollars (val
);
5029 #endif /* not VMS */
5033 if (EQ (action
, Qt
))
5034 return Ffile_name_all_completions (name
, realdir
);
5035 /* Only other case actually used is ACTION = lambda */
5037 /* Supposedly this helps commands such as `cd' that read directory names,
5038 but can someone explain how it helps them? -- RMS */
5039 if (XSTRING (name
)->size
== 0)
5042 return Ffile_exists_p (string
);
5045 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
5046 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
5047 Value is not expanded---you must call `expand-file-name' yourself.\n\
5048 Default name to DEFAULT-FILENAME if user enters a null string.\n\
5049 (If DEFAULT-FILENAME is omitted, the visited file name is used,\n\
5050 except that if INITIAL is specified, that combined with DIR is used.)\n\
5051 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
5052 Non-nil and non-t means also require confirmation after completion.\n\
5053 Fifth arg INITIAL specifies text to start with.\n\
5054 DIR defaults to current buffer's directory default.")
5055 (prompt
, dir
, default_filename
, mustmatch
, initial
)
5056 Lisp_Object prompt
, dir
, default_filename
, mustmatch
, initial
;
5058 Lisp_Object val
, insdef
, insdef1
, tem
;
5059 struct gcpro gcpro1
, gcpro2
;
5060 register char *homedir
;
5064 dir
= current_buffer
->directory
;
5065 if (NILP (default_filename
))
5067 if (! NILP (initial
))
5068 default_filename
= Fexpand_file_name (initial
, dir
);
5070 default_filename
= current_buffer
->filename
;
5073 /* If dir starts with user's homedir, change that to ~. */
5074 homedir
= (char *) egetenv ("HOME");
5076 homedir
= strcpy (alloca (strlen (homedir
) + 1), homedir
);
5077 CORRECT_DIR_SEPS (homedir
);
5081 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5082 && IS_DIRECTORY_SEP (XSTRING (dir
)->data
[strlen (homedir
)]))
5084 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5085 XSTRING (dir
)->size
- strlen (homedir
) + 1);
5086 XSTRING (dir
)->data
[0] = '~';
5089 if (insert_default_directory
&& STRINGP (dir
))
5092 if (!NILP (initial
))
5094 Lisp_Object args
[2], pos
;
5098 insdef
= Fconcat (2, args
);
5099 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
5100 insdef1
= Fcons (double_dollars (insdef
), pos
);
5103 insdef1
= double_dollars (insdef
);
5105 else if (STRINGP (initial
))
5108 insdef1
= Fcons (double_dollars (insdef
), make_number (0));
5111 insdef
= Qnil
, insdef1
= Qnil
;
5114 count
= specpdl_ptr
- specpdl
;
5115 specbind (intern ("completion-ignore-case"), Qt
);
5118 GCPRO2 (insdef
, default_filename
);
5119 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5120 dir
, mustmatch
, insdef1
,
5121 Qfile_name_history
, default_filename
, Qnil
);
5122 /* If Fcompleting_read returned the default string itself
5123 (rather than a new string with the same contents),
5124 it has to mean that the user typed RET with the minibuffer empty.
5125 In that case, we really want to return ""
5126 so that commands such as set-visited-file-name can distinguish. */
5127 if (EQ (val
, default_filename
))
5128 val
= build_string ("");
5131 unbind_to (count
, Qnil
);
5136 error ("No file name specified");
5137 tem
= Fstring_equal (val
, insdef
);
5138 if (!NILP (tem
) && !NILP (default_filename
))
5139 return default_filename
;
5140 if (XSTRING (val
)->size
== 0 && NILP (insdef
))
5142 if (!NILP (default_filename
))
5143 return default_filename
;
5145 error ("No default file name");
5147 return Fsubstitute_in_file_name (val
);
5150 #if 0 /* Old version */
5151 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
5152 /* Don't confuse make-docfile by having two doc strings for this function.
5153 make-docfile does not pay attention to #if, for good reason! */
5155 (prompt
, dir
, defalt
, mustmatch
, initial
)
5156 Lisp_Object prompt
, dir
, defalt
, mustmatch
, initial
;
5158 Lisp_Object val
, insdef
, tem
;
5159 struct gcpro gcpro1
, gcpro2
;
5160 register char *homedir
;
5164 dir
= current_buffer
->directory
;
5166 defalt
= current_buffer
->filename
;
5168 /* If dir starts with user's homedir, change that to ~. */
5169 homedir
= (char *) egetenv ("HOME");
5172 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5173 && XSTRING (dir
)->data
[strlen (homedir
)] == '/')
5175 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5176 XSTRING (dir
)->size
- strlen (homedir
) + 1);
5177 XSTRING (dir
)->data
[0] = '~';
5180 if (!NILP (initial
))
5182 else if (insert_default_directory
)
5185 insdef
= build_string ("");
5188 count
= specpdl_ptr
- specpdl
;
5189 specbind (intern ("completion-ignore-case"), Qt
);
5192 GCPRO2 (insdef
, defalt
);
5193 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5195 insert_default_directory
? insdef
: Qnil
,
5196 Qfile_name_history
, Qnil
, Qnil
);
5199 unbind_to (count
, Qnil
);
5204 error ("No file name specified");
5205 tem
= Fstring_equal (val
, insdef
);
5206 if (!NILP (tem
) && !NILP (defalt
))
5208 return Fsubstitute_in_file_name (val
);
5210 #endif /* Old version */
5214 Qexpand_file_name
= intern ("expand-file-name");
5215 Qsubstitute_in_file_name
= intern ("substitute-in-file-name");
5216 Qdirectory_file_name
= intern ("directory-file-name");
5217 Qfile_name_directory
= intern ("file-name-directory");
5218 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
5219 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
5220 Qfile_name_as_directory
= intern ("file-name-as-directory");
5221 Qcopy_file
= intern ("copy-file");
5222 Qmake_directory_internal
= intern ("make-directory-internal");
5223 Qdelete_directory
= intern ("delete-directory");
5224 Qdelete_file
= intern ("delete-file");
5225 Qrename_file
= intern ("rename-file");
5226 Qadd_name_to_file
= intern ("add-name-to-file");
5227 Qmake_symbolic_link
= intern ("make-symbolic-link");
5228 Qfile_exists_p
= intern ("file-exists-p");
5229 Qfile_executable_p
= intern ("file-executable-p");
5230 Qfile_readable_p
= intern ("file-readable-p");
5231 Qfile_writable_p
= intern ("file-writable-p");
5232 Qfile_symlink_p
= intern ("file-symlink-p");
5233 Qaccess_file
= intern ("access-file");
5234 Qfile_directory_p
= intern ("file-directory-p");
5235 Qfile_regular_p
= intern ("file-regular-p");
5236 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
5237 Qfile_modes
= intern ("file-modes");
5238 Qset_file_modes
= intern ("set-file-modes");
5239 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
5240 Qinsert_file_contents
= intern ("insert-file-contents");
5241 Qwrite_region
= intern ("write-region");
5242 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
5243 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
5245 staticpro (&Qexpand_file_name
);
5246 staticpro (&Qsubstitute_in_file_name
);
5247 staticpro (&Qdirectory_file_name
);
5248 staticpro (&Qfile_name_directory
);
5249 staticpro (&Qfile_name_nondirectory
);
5250 staticpro (&Qunhandled_file_name_directory
);
5251 staticpro (&Qfile_name_as_directory
);
5252 staticpro (&Qcopy_file
);
5253 staticpro (&Qmake_directory_internal
);
5254 staticpro (&Qdelete_directory
);
5255 staticpro (&Qdelete_file
);
5256 staticpro (&Qrename_file
);
5257 staticpro (&Qadd_name_to_file
);
5258 staticpro (&Qmake_symbolic_link
);
5259 staticpro (&Qfile_exists_p
);
5260 staticpro (&Qfile_executable_p
);
5261 staticpro (&Qfile_readable_p
);
5262 staticpro (&Qfile_writable_p
);
5263 staticpro (&Qaccess_file
);
5264 staticpro (&Qfile_symlink_p
);
5265 staticpro (&Qfile_directory_p
);
5266 staticpro (&Qfile_regular_p
);
5267 staticpro (&Qfile_accessible_directory_p
);
5268 staticpro (&Qfile_modes
);
5269 staticpro (&Qset_file_modes
);
5270 staticpro (&Qfile_newer_than_file_p
);
5271 staticpro (&Qinsert_file_contents
);
5272 staticpro (&Qwrite_region
);
5273 staticpro (&Qverify_visited_file_modtime
);
5274 staticpro (&Qset_visited_file_modtime
);
5276 Qfile_name_history
= intern ("file-name-history");
5277 Fset (Qfile_name_history
, Qnil
);
5278 staticpro (&Qfile_name_history
);
5280 Qfile_error
= intern ("file-error");
5281 staticpro (&Qfile_error
);
5282 Qfile_already_exists
= intern ("file-already-exists");
5283 staticpro (&Qfile_already_exists
);
5284 Qfile_date_error
= intern ("file-date-error");
5285 staticpro (&Qfile_date_error
);
5288 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
5289 staticpro (&Qfind_buffer_file_type
);
5292 DEFVAR_LISP ("file-name-coding-system", &Vfile_name_coding_system
,
5293 "*Coding system for encoding file names.");
5294 Vfile_name_coding_system
= Qnil
;
5296 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format
,
5297 "*Format in which to write auto-save files.\n\
5298 Should be a list of symbols naming formats that are defined in `format-alist'.\n\
5299 If it is t, which is the default, auto-save files are written in the\n\
5300 same format as a regular save would use.");
5301 Vauto_save_file_format
= Qt
;
5303 Qformat_decode
= intern ("format-decode");
5304 staticpro (&Qformat_decode
);
5305 Qformat_annotate_function
= intern ("format-annotate-function");
5306 staticpro (&Qformat_annotate_function
);
5308 Qcar_less_than_car
= intern ("car-less-than-car");
5309 staticpro (&Qcar_less_than_car
);
5311 Fput (Qfile_error
, Qerror_conditions
,
5312 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
5313 Fput (Qfile_error
, Qerror_message
,
5314 build_string ("File error"));
5316 Fput (Qfile_already_exists
, Qerror_conditions
,
5317 Fcons (Qfile_already_exists
,
5318 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5319 Fput (Qfile_already_exists
, Qerror_message
,
5320 build_string ("File already exists"));
5322 Fput (Qfile_date_error
, Qerror_conditions
,
5323 Fcons (Qfile_date_error
,
5324 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5325 Fput (Qfile_date_error
, Qerror_message
,
5326 build_string ("Cannot set file date"));
5328 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
5329 "*Non-nil means when reading a filename start with default dir in minibuffer.");
5330 insert_default_directory
= 1;
5332 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
5333 "*Non-nil means write new files with record format `stmlf'.\n\
5334 nil means use format `var'. This variable is meaningful only on VMS.");
5335 vms_stmlf_recfm
= 0;
5337 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char
,
5338 "Directory separator character for built-in functions that return file names.\n\
5339 The value should be either ?/ or ?\\ (any other value is treated as ?\\).\n\
5340 This variable affects the built-in functions only on Windows,\n\
5341 on other platforms, it is initialized so that Lisp code can find out\n\
5342 what the normal separator is.");
5343 XSETFASTINT (Vdirectory_sep_char
, '/');
5345 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
5346 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
5347 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
5350 The first argument given to HANDLER is the name of the I/O primitive\n\
5351 to be handled; the remaining arguments are the arguments that were\n\
5352 passed to that primitive. For example, if you do\n\
5353 (file-exists-p FILENAME)\n\
5354 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
5355 (funcall HANDLER 'file-exists-p FILENAME)\n\
5356 The function `find-file-name-handler' checks this list for a handler\n\
5357 for its argument.");
5358 Vfile_name_handler_alist
= Qnil
;
5360 DEFVAR_LISP ("set-auto-coding-function",
5361 &Vset_auto_coding_function
,
5362 "If non-nil, a function to call to decide a coding system of file.\n\
5363 One argument is passed to this function: the string of concatination\n\
5364 or the heading 1K-byte and the tailing 3K-byte of a file to be read.\n\
5365 This function should return a coding system to decode the file contents\n\
5366 specified in the heading lines with the format:\n\
5367 -*- ... coding: CODING-SYSTEM; ... -*-\n\
5368 or local variable spec of the tailing lines with `coding:' tag.");
5369 Vset_auto_coding_function
= Qnil
;
5371 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
5372 "A list of functions to be called at the end of `insert-file-contents'.\n\
5373 Each is passed one argument, the number of bytes inserted. It should return\n\
5374 the new byte count, and leave point the same. If `insert-file-contents' is\n\
5375 intercepted by a handler from `file-name-handler-alist', that handler is\n\
5376 responsible for calling the after-insert-file-functions if appropriate.");
5377 Vafter_insert_file_functions
= Qnil
;
5379 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
5380 "A list of functions to be called at the start of `write-region'.\n\
5381 Each is passed two arguments, START and END as for `write-region'.\n\
5382 These are usually two numbers but not always; see the documentation\n\
5383 for `write-region'. The function should return a list of pairs\n\
5384 of the form (POSITION . STRING), consisting of strings to be effectively\n\
5385 inserted at the specified positions of the file being written (1 means to\n\
5386 insert before the first byte written). The POSITIONs must be sorted into\n\
5387 increasing order. If there are several functions in the list, the several\n\
5388 lists are merged destructively.");
5389 Vwrite_region_annotate_functions
= Qnil
;
5391 DEFVAR_LISP ("write-region-annotations-so-far",
5392 &Vwrite_region_annotations_so_far
,
5393 "When an annotation function is called, this holds the previous annotations.\n\
5394 These are the annotations made by other annotation functions\n\
5395 that were already called. See also `write-region-annotate-functions'.");
5396 Vwrite_region_annotations_so_far
= Qnil
;
5398 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
5399 "A list of file name handlers that temporarily should not be used.\n\
5400 This applies only to the operation `inhibit-file-name-operation'.");
5401 Vinhibit_file_name_handlers
= Qnil
;
5403 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
5404 "The operation for which `inhibit-file-name-handlers' is applicable.");
5405 Vinhibit_file_name_operation
= Qnil
;
5407 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
5408 "File name in which we write a list of all auto save file names.\n\
5409 This variable is initialized automatically from `auto-save-list-file-prefix'\n\
5410 shortly after Emacs reads your `.emacs' file, if you have not yet given it\n\
5412 Vauto_save_list_file_name
= Qnil
;
5414 defsubr (&Sfind_file_name_handler
);
5415 defsubr (&Sfile_name_directory
);
5416 defsubr (&Sfile_name_nondirectory
);
5417 defsubr (&Sunhandled_file_name_directory
);
5418 defsubr (&Sfile_name_as_directory
);
5419 defsubr (&Sdirectory_file_name
);
5420 defsubr (&Smake_temp_name
);
5421 defsubr (&Sexpand_file_name
);
5422 defsubr (&Ssubstitute_in_file_name
);
5423 defsubr (&Scopy_file
);
5424 defsubr (&Smake_directory_internal
);
5425 defsubr (&Sdelete_directory
);
5426 defsubr (&Sdelete_file
);
5427 defsubr (&Srename_file
);
5428 defsubr (&Sadd_name_to_file
);
5430 defsubr (&Smake_symbolic_link
);
5431 #endif /* S_IFLNK */
5433 defsubr (&Sdefine_logical_name
);
5436 defsubr (&Ssysnetunam
);
5437 #endif /* HPUX_NET */
5438 defsubr (&Sfile_name_absolute_p
);
5439 defsubr (&Sfile_exists_p
);
5440 defsubr (&Sfile_executable_p
);
5441 defsubr (&Sfile_readable_p
);
5442 defsubr (&Sfile_writable_p
);
5443 defsubr (&Saccess_file
);
5444 defsubr (&Sfile_symlink_p
);
5445 defsubr (&Sfile_directory_p
);
5446 defsubr (&Sfile_accessible_directory_p
);
5447 defsubr (&Sfile_regular_p
);
5448 defsubr (&Sfile_modes
);
5449 defsubr (&Sset_file_modes
);
5450 defsubr (&Sset_default_file_modes
);
5451 defsubr (&Sdefault_file_modes
);
5452 defsubr (&Sfile_newer_than_file_p
);
5453 defsubr (&Sinsert_file_contents
);
5454 defsubr (&Swrite_region
);
5455 defsubr (&Scar_less_than_car
);
5456 defsubr (&Sverify_visited_file_modtime
);
5457 defsubr (&Sclear_visited_file_modtime
);
5458 defsubr (&Svisited_file_modtime
);
5459 defsubr (&Sset_visited_file_modtime
);
5460 defsubr (&Sdo_auto_save
);
5461 defsubr (&Sset_buffer_auto_saved
);
5462 defsubr (&Sclear_buffer_auto_save_failure
);
5463 defsubr (&Srecent_auto_save_p
);
5465 defsubr (&Sread_file_name_internal
);
5466 defsubr (&Sread_file_name
);
5469 defsubr (&Sunix_sync
);