1 /* File IO for GNU Emacs.
2 Copyright (C) 1985, 1986, 1987, 1988, 1993, 1994 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, 675 Mass Ave, Cambridge, MA 02139, USA. */
22 #include <sys/types.h>
29 #if !defined (S_ISLNK) && defined (S_IFLNK)
30 # define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
33 #if !defined (S_ISREG) && defined (S_IFREG)
34 # define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
45 #include <sys/param.h>
63 extern char *strerror ();
78 #include "intervals.h"
104 #define min(a, b) ((a) < (b) ? (a) : (b))
105 #define max(a, b) ((a) > (b) ? (a) : (b))
107 /* Nonzero during writing of auto-save files */
110 /* Set by auto_save_1 to mode of original file so Fwrite_region will create
111 a new file with the same mode as the original */
112 int auto_save_mode_bits
;
114 /* Alist of elements (REGEXP . HANDLER) for file names
115 whose I/O is done with a special handler. */
116 Lisp_Object Vfile_name_handler_alist
;
118 /* Functions to be called to process text properties in inserted file. */
119 Lisp_Object Vafter_insert_file_functions
;
121 /* Functions to be called to create text property annotations for file. */
122 Lisp_Object Vwrite_region_annotate_functions
;
124 /* During build_annotations, each time an annotation function is called,
125 this holds the annotations made by the previous functions. */
126 Lisp_Object Vwrite_region_annotations_so_far
;
128 /* File name in which we write a list of all our auto save files. */
129 Lisp_Object Vauto_save_list_file_name
;
131 /* Nonzero means, when reading a filename in the minibuffer,
132 start out by inserting the default directory into the minibuffer. */
133 int insert_default_directory
;
135 /* On VMS, nonzero means write new files with record format stmlf.
136 Zero means use var format. */
139 /* These variables describe handlers that have "already" had a chance
140 to handle the current operation.
142 Vinhibit_file_name_handlers is a list of file name handlers.
143 Vinhibit_file_name_operation is the operation being handled.
144 If we try to handle that operation, we ignore those handlers. */
146 static Lisp_Object Vinhibit_file_name_handlers
;
147 static Lisp_Object Vinhibit_file_name_operation
;
149 Lisp_Object Qfile_error
, Qfile_already_exists
;
151 Lisp_Object Qfile_name_history
;
153 Lisp_Object Qcar_less_than_car
;
155 report_file_error (string
, data
)
159 Lisp_Object errstring
;
161 errstring
= build_string (strerror (errno
));
163 /* System error messages are capitalized. Downcase the initial
164 unless it is followed by a slash. */
165 if (XSTRING (errstring
)->data
[1] != '/')
166 XSTRING (errstring
)->data
[0] = DOWNCASE (XSTRING (errstring
)->data
[0]);
169 Fsignal (Qfile_error
,
170 Fcons (build_string (string
), Fcons (errstring
, data
)));
173 close_file_unwind (fd
)
176 close (XFASTINT (fd
));
179 /* Restore point, having saved it as a marker. */
181 restore_point_unwind (location
)
182 Lisp_Object location
;
184 SET_PT (marker_position (location
));
185 Fset_marker (location
, Qnil
, Qnil
);
188 Lisp_Object Qexpand_file_name
;
189 Lisp_Object Qdirectory_file_name
;
190 Lisp_Object Qfile_name_directory
;
191 Lisp_Object Qfile_name_nondirectory
;
192 Lisp_Object Qunhandled_file_name_directory
;
193 Lisp_Object Qfile_name_as_directory
;
194 Lisp_Object Qcopy_file
;
195 Lisp_Object Qmake_directory_internal
;
196 Lisp_Object Qdelete_directory
;
197 Lisp_Object Qdelete_file
;
198 Lisp_Object Qrename_file
;
199 Lisp_Object Qadd_name_to_file
;
200 Lisp_Object Qmake_symbolic_link
;
201 Lisp_Object Qfile_exists_p
;
202 Lisp_Object Qfile_executable_p
;
203 Lisp_Object Qfile_readable_p
;
204 Lisp_Object Qfile_symlink_p
;
205 Lisp_Object Qfile_writable_p
;
206 Lisp_Object Qfile_directory_p
;
207 Lisp_Object Qfile_accessible_directory_p
;
208 Lisp_Object Qfile_modes
;
209 Lisp_Object Qset_file_modes
;
210 Lisp_Object Qfile_newer_than_file_p
;
211 Lisp_Object Qinsert_file_contents
;
212 Lisp_Object Qwrite_region
;
213 Lisp_Object Qverify_visited_file_modtime
;
214 Lisp_Object Qset_visited_file_modtime
;
216 DEFUN ("find-file-name-handler", Ffind_file_name_handler
, Sfind_file_name_handler
, 2, 2, 0,
217 "Return FILENAME's handler function for OPERATION, if it has one.\n\
218 Otherwise, return nil.\n\
219 A file name is handled if one of the regular expressions in\n\
220 `file-name-handler-alist' matches it.\n\n\
221 If OPERATION equals `inhibit-file-name-operation', then we ignore\n\
222 any handlers that are members of `inhibit-file-name-handlers',\n\
223 but we still do run any other handlers. This lets handlers\n\
224 use the standard functions without calling themselves recursively.")
225 (filename
, operation
)
226 Lisp_Object filename
, operation
;
228 /* This function must not munge the match data. */
229 Lisp_Object chain
, inhibited_handlers
;
231 CHECK_STRING (filename
, 0);
233 if (EQ (operation
, Vinhibit_file_name_operation
))
234 inhibited_handlers
= Vinhibit_file_name_handlers
;
236 inhibited_handlers
= Qnil
;
238 for (chain
= Vfile_name_handler_alist
; XTYPE (chain
) == Lisp_Cons
;
239 chain
= XCONS (chain
)->cdr
)
242 elt
= XCONS (chain
)->car
;
243 if (XTYPE (elt
) == Lisp_Cons
)
246 string
= XCONS (elt
)->car
;
247 if (XTYPE (string
) == Lisp_String
248 && fast_string_match (string
, filename
) >= 0)
250 Lisp_Object handler
, tem
;
252 handler
= XCONS (elt
)->cdr
;
253 tem
= Fmemq (handler
, inhibited_handlers
);
264 DEFUN ("file-name-directory", Ffile_name_directory
, Sfile_name_directory
,
266 "Return the directory component in file name NAME.\n\
267 Return nil if NAME does not include a directory.\n\
268 Otherwise return a directory spec.\n\
269 Given a Unix syntax file name, returns a string ending in slash;\n\
270 on VMS, perhaps instead a string ending in `:', `]' or `>'.")
274 register unsigned char *beg
;
275 register unsigned char *p
;
278 CHECK_STRING (file
, 0);
280 /* If the file name has special constructs in it,
281 call the corresponding file handler. */
282 handler
= Ffind_file_name_handler (file
, Qfile_name_directory
);
284 return call2 (handler
, Qfile_name_directory
, file
);
286 #ifdef FILE_SYSTEM_CASE
287 file
= FILE_SYSTEM_CASE (file
);
289 beg
= XSTRING (file
)->data
;
290 p
= beg
+ XSTRING (file
)->size
;
292 while (p
!= beg
&& p
[-1] != '/'
294 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
297 && p
[-1] != ':' && p
[-1] != '\\'
304 /* Expansion of "c:" to drive and default directory. */
305 if (p
== beg
+ 2 && beg
[1] == ':')
307 int drive
= (*beg
) - 'a';
308 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
309 unsigned char *res
= alloca (MAXPATHLEN
+ 5);
310 if (getdefdir (drive
+ 1, res
+ 2))
312 res
[0] = drive
+ 'a';
314 if (res
[strlen (res
) - 1] != '/')
317 p
= beg
+ strlen (beg
);
321 return make_string (beg
, p
- beg
);
324 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory
, Sfile_name_nondirectory
,
326 "Return file name NAME sans its directory.\n\
327 For example, in a Unix-syntax file name,\n\
328 this is everything after the last slash,\n\
329 or the entire name if it contains no slash.")
333 register unsigned char *beg
, *p
, *end
;
336 CHECK_STRING (file
, 0);
338 /* If the file name has special constructs in it,
339 call the corresponding file handler. */
340 handler
= Ffind_file_name_handler (file
, Qfile_name_nondirectory
);
342 return call2 (handler
, Qfile_name_nondirectory
, file
);
344 beg
= XSTRING (file
)->data
;
345 end
= p
= beg
+ XSTRING (file
)->size
;
347 while (p
!= beg
&& p
[-1] != '/'
349 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
352 && p
[-1] != ':' && p
[-1] != '\\'
356 return make_string (p
, end
- p
);
359 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory
, Sunhandled_file_name_directory
, 1, 1, 0,
360 "Return a directly usable directory name somehow associated with FILENAME.\n\
361 A `directly usable' directory name is one that may be used without the\n\
362 intervention of any file handler.\n\
363 If FILENAME is a directly usable file itself, return\n\
364 (file-name-directory FILENAME).\n\
365 The `call-process' and `start-process' functions use this function to\n\
366 get a current directory to run processes in.")
368 Lisp_Object filename
;
372 /* If the file name has special constructs in it,
373 call the corresponding file handler. */
374 handler
= Ffind_file_name_handler (filename
, Qunhandled_file_name_directory
);
376 return call2 (handler
, Qunhandled_file_name_directory
, filename
);
378 return Ffile_name_directory (filename
);
383 file_name_as_directory (out
, in
)
386 int size
= strlen (in
) - 1;
391 /* Is it already a directory string? */
392 if (in
[size
] == ':' || in
[size
] == ']' || in
[size
] == '>')
394 /* Is it a VMS directory file name? If so, hack VMS syntax. */
395 else if (! index (in
, '/')
396 && ((size
> 3 && ! strcmp (&in
[size
- 3], ".DIR"))
397 || (size
> 3 && ! strcmp (&in
[size
- 3], ".dir"))
398 || (size
> 5 && (! strncmp (&in
[size
- 5], ".DIR", 4)
399 || ! strncmp (&in
[size
- 5], ".dir", 4))
400 && (in
[size
- 1] == '.' || in
[size
- 1] == ';')
401 && in
[size
] == '1')))
403 register char *p
, *dot
;
407 dir:x.dir --> dir:[x]
408 dir:[x]y.dir --> dir:[x.y] */
410 while (p
!= in
&& *p
!= ':' && *p
!= '>' && *p
!= ']') p
--;
413 strncpy (out
, in
, p
- in
);
432 dot
= index (p
, '.');
435 /* blindly remove any extension */
436 size
= strlen (out
) + (dot
- p
);
437 strncat (out
, p
, dot
- p
);
448 /* For Unix syntax, Append a slash if necessary */
450 if (out
[size
] != ':' && out
[size
] != '/' && out
[size
] != '\\')
452 if (out
[size
] != '/')
459 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
460 Sfile_name_as_directory
, 1, 1, 0,
461 "Return a string representing file FILENAME interpreted as a directory.\n\
462 This operation exists because a directory is also a file, but its name as\n\
463 a directory is different from its name as a file.\n\
464 The result can be used as the value of `default-directory'\n\
465 or passed as second argument to `expand-file-name'.\n\
466 For a Unix-syntax file name, just appends a slash.\n\
467 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
474 CHECK_STRING (file
, 0);
478 /* If the file name has special constructs in it,
479 call the corresponding file handler. */
480 handler
= Ffind_file_name_handler (file
, Qfile_name_as_directory
);
482 return call2 (handler
, Qfile_name_as_directory
, file
);
484 buf
= (char *) alloca (XSTRING (file
)->size
+ 10);
485 return build_string (file_name_as_directory (buf
, XSTRING (file
)->data
));
489 * Convert from directory name to filename.
491 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
492 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
493 * On UNIX, it's simple: just make sure there is a terminating /
495 * Value is nonzero if the string output is different from the input.
498 directory_file_name (src
, dst
)
506 struct FAB fab
= cc$rms_fab
;
507 struct NAM nam
= cc$rms_nam
;
508 char esa
[NAM$C_MAXRSS
];
513 if (! index (src
, '/')
514 && (src
[slen
- 1] == ']'
515 || src
[slen
- 1] == ':'
516 || src
[slen
- 1] == '>'))
518 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
520 fab
.fab$b_fns
= slen
;
521 fab
.fab$l_nam
= &nam
;
522 fab
.fab$l_fop
= FAB$M_NAM
;
525 nam
.nam$b_ess
= sizeof esa
;
526 nam
.nam$b_nop
|= NAM$M_SYNCHK
;
528 /* We call SYS$PARSE to handle such things as [--] for us. */
529 if (SYS$
PARSE(&fab
, 0, 0) == RMS$_NORMAL
)
531 slen
= nam
.nam$b_esl
;
532 if (esa
[slen
- 1] == ';' && esa
[slen
- 2] == '.')
537 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
539 /* what about when we have logical_name:???? */
540 if (src
[slen
- 1] == ':')
541 { /* Xlate logical name and see what we get */
542 ptr
= strcpy (dst
, src
); /* upper case for getenv */
545 if ('a' <= *ptr
&& *ptr
<= 'z')
549 dst
[slen
- 1] = 0; /* remove colon */
550 if (!(src
= egetenv (dst
)))
552 /* should we jump to the beginning of this procedure?
553 Good points: allows us to use logical names that xlate
555 Bad points: can be a problem if we just translated to a device
557 For now, I'll punt and always expect VMS names, and hope for
560 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
561 { /* no recursion here! */
567 { /* not a directory spec */
572 bracket
= src
[slen
- 1];
574 /* If bracket is ']' or '>', bracket - 2 is the corresponding
576 ptr
= index (src
, bracket
- 2);
578 { /* no opening bracket */
582 if (!(rptr
= rindex (src
, '.')))
585 strncpy (dst
, src
, slen
);
589 dst
[slen
++] = bracket
;
594 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
595 then translate the device and recurse. */
596 if (dst
[slen
- 1] == ':'
597 && dst
[slen
- 2] != ':' /* skip decnet nodes */
598 && strcmp(src
+ slen
, "[000000]") == 0)
600 dst
[slen
- 1] = '\0';
601 if ((ptr
= egetenv (dst
))
602 && (rlen
= strlen (ptr
) - 1) > 0
603 && (ptr
[rlen
] == ']' || ptr
[rlen
] == '>')
604 && ptr
[rlen
- 1] == '.')
606 char * buf
= (char *) alloca (strlen (ptr
) + 1);
610 return directory_file_name (buf
, dst
);
615 strcat (dst
, "[000000]");
619 rlen
= strlen (rptr
) - 1;
620 strncat (dst
, rptr
, rlen
);
621 dst
[slen
+ rlen
] = '\0';
622 strcat (dst
, ".DIR.1");
626 /* Process as Unix format: just remove any final slash.
627 But leave "/" unchanged; do not change it to "". */
631 && (dst
[slen
- 1] == '/' || dst
[slen
- 1] == '/')
632 && dst
[slen
- 2] != ':'
634 && dst
[slen
- 1] == '/'
641 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
643 "Returns the file name of the directory named DIR.\n\
644 This is the name of the file that holds the data for the directory DIR.\n\
645 This operation exists because a directory is also a file, but its name as\n\
646 a directory is different from its name as a file.\n\
647 In Unix-syntax, this function just removes the final slash.\n\
648 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
649 it returns a file name such as \"[X]Y.DIR.1\".")
651 Lisp_Object directory
;
656 CHECK_STRING (directory
, 0);
658 if (NILP (directory
))
661 /* If the file name has special constructs in it,
662 call the corresponding file handler. */
663 handler
= Ffind_file_name_handler (directory
, Qdirectory_file_name
);
665 return call2 (handler
, Qdirectory_file_name
, directory
);
668 /* 20 extra chars is insufficient for VMS, since we might perform a
669 logical name translation. an equivalence string can be up to 255
670 chars long, so grab that much extra space... - sss */
671 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20 + 255);
673 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20);
675 directory_file_name (XSTRING (directory
)->data
, buf
);
676 return build_string (buf
);
679 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
680 "Generate temporary file name (string) starting with PREFIX (a string).\n\
681 The Emacs process number forms part of the result,\n\
682 so there is no danger of generating a name being used by another process.")
687 val
= concat2 (prefix
, build_string ("XXXXXX"));
688 mktemp (XSTRING (val
)->data
);
692 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
693 "Convert FILENAME to absolute, and canonicalize it.\n\
694 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
695 (does not start with slash); if DEFAULT is nil or missing,\n\
696 the current buffer's value of default-directory is used.\n\
697 Path components that are `.' are removed, and \n\
698 path components followed by `..' are removed, along with the `..' itself;\n\
699 note that these simplifications are done without checking the resulting\n\
700 paths in the file system.\n\
701 An initial `~/' expands to your home directory.\n\
702 An initial `~USER/' expands to USER's home directory.\n\
703 See also the function `substitute-in-file-name'.")
705 Lisp_Object name
, defalt
;
709 register unsigned char *newdir
, *p
, *o
;
711 unsigned char *target
;
714 unsigned char * colon
= 0;
715 unsigned char * close
= 0;
716 unsigned char * slash
= 0;
717 unsigned char * brack
= 0;
718 int lbrack
= 0, rbrack
= 0;
721 #ifdef MSDOS /* Demacs 1.1.2 91/10/20 Manabu Higashida */
724 unsigned char *tmp
, *defdir
;
728 CHECK_STRING (name
, 0);
730 /* If the file name has special constructs in it,
731 call the corresponding file handler. */
732 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
734 return call3 (handler
, Qexpand_file_name
, name
, defalt
);
736 /* Use the buffer's default-directory if DEFALT is omitted. */
738 defalt
= current_buffer
->directory
;
739 CHECK_STRING (defalt
, 1);
741 /* Make sure DEFALT is properly expanded.
742 It would be better to do this down below where we actually use
743 defalt. Unfortunately, calling Fexpand_file_name recursively
744 could invoke GC, and the strings might be relocated. This would
745 be annoying because we have pointers into strings lying around
746 that would need adjusting, and people would add new pointers to
747 the code and forget to adjust them, resulting in intermittent bugs.
748 Putting this call here avoids all that crud.
750 The EQ test avoids infinite recursion. */
751 if (! NILP (defalt
) && !EQ (defalt
, name
)
752 /* This saves time in a common case. */
753 && XSTRING (defalt
)->data
[0] != '/')
758 defalt
= Fexpand_file_name (defalt
, Qnil
);
763 /* Filenames on VMS are always upper case. */
764 name
= Fupcase (name
);
766 #ifdef FILE_SYSTEM_CASE
767 name
= FILE_SYSTEM_CASE (name
);
770 nm
= XSTRING (name
)->data
;
773 /* First map all backslashes to slashes. */
774 dostounix_filename (nm
= strcpy (alloca (strlen (nm
) + 1), nm
));
776 /* Now strip drive name. */
778 unsigned char *colon
= rindex (nm
, ':');
784 drive
= tolower (colon
[-1]) - 'a';
788 defdir
= alloca (MAXPATHLEN
+ 1);
789 relpath
= getdefdir (drive
+ 1, defdir
);
795 /* If nm is absolute, flush ...// and detect /./ and /../.
796 If no /./ or /../ we can return right away. */
804 /* If it turns out that the filename we want to return is just a
805 suffix of FILENAME, we don't need to go through and edit
806 things; we just need to construct a new string using data
807 starting at the middle of FILENAME. If we set lose to a
808 non-zero value, that means we've discovered that we can't do
815 /* Since we know the path is absolute, we can assume that each
816 element starts with a "/". */
818 /* "//" anywhere isn't necessarily hairy; we just start afresh
819 with the second slash. */
820 if (p
[0] == '/' && p
[1] == '/'
822 /* // at start of filename is meaningful on Apollo system */
828 /* "~" is hairy as the start of any path element. */
829 if (p
[0] == '/' && p
[1] == '~')
830 nm
= p
+ 1, lose
= 1;
832 /* "." and ".." are hairy. */
837 || (p
[2] == '.' && (p
[3] == '/'
844 /* if dev:[dir]/, move nm to / */
845 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
846 nm
= (brack
? brack
+ 1 : colon
+ 1);
855 /* VMS pre V4.4,convert '-'s in filenames. */
856 if (lbrack
== rbrack
)
858 if (dots
< 2) /* this is to allow negative version numbers */
863 if (lbrack
> rbrack
&&
864 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
865 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
871 /* count open brackets, reset close bracket pointer */
872 if (p
[0] == '[' || p
[0] == '<')
874 /* count close brackets, set close bracket pointer */
875 if (p
[0] == ']' || p
[0] == '>')
877 /* detect ][ or >< */
878 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
880 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
881 nm
= p
+ 1, lose
= 1;
882 if (p
[0] == ':' && (colon
|| slash
))
883 /* if dev1:[dir]dev2:, move nm to dev2: */
889 /* if /pathname/dev:, move nm to dev: */
892 /* if node::dev:, move colon following dev */
893 else if (colon
&& colon
[-1] == ':')
895 /* if dev1:dev2:, move nm to dev2: */
896 else if (colon
&& colon
[-1] != ':')
901 if (p
[0] == ':' && !colon
)
907 if (lbrack
== rbrack
)
910 else if (p
[0] == '.')
919 return build_string (sys_translate_unix (nm
));
922 if (nm
== XSTRING (name
)->data
)
924 return build_string (nm
);
929 /* Now determine directory to start with and put it in newdir */
933 if (nm
[0] == '~') /* prefix ~ */
939 || nm
[1] == 0) /* ~ by itself */
941 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
942 newdir
= (unsigned char *) "";
944 dostounix_filename (newdir
);
948 nm
++; /* Don't leave the slash in nm. */
951 else /* ~user/filename */
953 for (p
= nm
; *p
&& (*p
!= '/'
958 o
= (unsigned char *) alloca (p
- nm
+ 1);
959 bcopy ((char *) nm
, o
, p
- nm
);
962 pw
= (struct passwd
*) getpwnam (o
+ 1);
965 newdir
= (unsigned char *) pw
-> pw_dir
;
967 nm
= p
+ 1; /* skip the terminator */
973 /* If we don't find a user of that name, leave the name
974 unchanged; don't move nm forward to p. */
987 newdir
= XSTRING (defalt
)->data
;
991 if (newdir
== 0 && relpath
)
996 /* Get rid of any slash at the end of newdir. */
997 int length
= strlen (newdir
);
998 /* Adding `length > 1 &&' makes ~ expand into / when homedir
999 is the root dir. People disagree about whether that is right.
1000 Anyway, we can't take the risk of this change now. */
1002 if (newdir
[1] != ':' && length
> 1)
1004 if (newdir
[length
- 1] == '/')
1006 unsigned char *temp
= (unsigned char *) alloca (length
);
1007 bcopy (newdir
, temp
, length
- 1);
1008 temp
[length
- 1] = 0;
1016 /* Now concatenate the directory and name to new space in the stack frame */
1017 tlen
+= strlen (nm
) + 1;
1019 /* Add reserved space for drive name. */
1020 target
= (unsigned char *) alloca (tlen
+ 2) + 2;
1022 target
= (unsigned char *) alloca (tlen
);
1029 if (nm
[0] == 0 || nm
[0] == '/')
1030 strcpy (target
, newdir
);
1033 file_name_as_directory (target
, newdir
);
1036 strcat (target
, nm
);
1038 if (index (target
, '/'))
1039 strcpy (target
, sys_translate_unix (target
));
1042 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1050 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1056 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1057 /* brackets are offset from each other by 2 */
1060 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1061 /* convert [foo][bar] to [bar] */
1062 while (o
[-1] != '[' && o
[-1] != '<')
1064 else if (*p
== '-' && *o
!= '.')
1067 else if (p
[0] == '-' && o
[-1] == '.' &&
1068 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1069 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1073 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1074 if (p
[1] == '.') /* foo.-.bar ==> bar*/
1076 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1078 /* else [foo.-] ==> [-] */
1084 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1085 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1095 else if (!strncmp (p
, "//", 2)
1097 /* // at start of filename is meaningful in Apollo system */
1105 else if (p
[0] == '/'
1110 /* If "/." is the entire filename, keep the "/". Otherwise,
1111 just delete the whole "/.". */
1112 if (o
== target
&& p
[2] == '\0')
1116 else if (!strncmp (p
, "/..", 3)
1117 /* `/../' is the "superroot" on certain file systems. */
1119 && (p
[3] == '/' || p
[3] == 0))
1121 while (o
!= target
&& *--o
!= '/')
1124 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1128 if (o
== target
&& *o
== '/')
1136 #endif /* not VMS */
1140 /* at last, set drive name. */
1141 if (target
[1] != ':')
1144 target
[0] = (drive
< 0 ? getdisk () : drive
) + 'a';
1149 return make_string (target
, o
- target
);
1152 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'.
1153 DEAFUN ("expand-file-name", Fexpand_file_name, Sexpand_file_name, 1, 2, 0,
1154 "Convert FILENAME to absolute, and canonicalize it.\n\
1155 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1156 (does not start with slash); if DEFAULT is nil or missing,\n\
1157 the current buffer's value of default-directory is used.\n\
1158 Filenames containing `.' or `..' as components are simplified;\n\
1159 initial `~/' expands to your home directory.\n\
1160 See also the function `substitute-in-file-name'.")
1162 Lisp_Object name, defalt;
1166 register unsigned char *newdir, *p, *o;
1168 unsigned char *target;
1172 unsigned char * colon = 0;
1173 unsigned char * close = 0;
1174 unsigned char * slash = 0;
1175 unsigned char * brack = 0;
1176 int lbrack = 0, rbrack = 0;
1180 CHECK_STRING (name
, 0);
1183 /* Filenames on VMS are always upper case. */
1184 name
= Fupcase (name
);
1187 nm
= XSTRING (name
)->data
;
1189 /* If nm is absolute, flush ...// and detect /./ and /../.
1190 If no /./ or /../ we can return right away. */
1202 if (p
[0] == '/' && p
[1] == '/'
1204 /* // at start of filename is meaningful on Apollo system */
1209 if (p
[0] == '/' && p
[1] == '~')
1210 nm
= p
+ 1, lose
= 1;
1211 if (p
[0] == '/' && p
[1] == '.'
1212 && (p
[2] == '/' || p
[2] == 0
1213 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1219 /* if dev:[dir]/, move nm to / */
1220 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1221 nm
= (brack
? brack
+ 1 : colon
+ 1);
1222 lbrack
= rbrack
= 0;
1230 /* VMS pre V4.4,convert '-'s in filenames. */
1231 if (lbrack
== rbrack
)
1233 if (dots
< 2) /* this is to allow negative version numbers */
1238 if (lbrack
> rbrack
&&
1239 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1240 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1246 /* count open brackets, reset close bracket pointer */
1247 if (p
[0] == '[' || p
[0] == '<')
1248 lbrack
++, brack
= 0;
1249 /* count close brackets, set close bracket pointer */
1250 if (p
[0] == ']' || p
[0] == '>')
1251 rbrack
++, brack
= p
;
1252 /* detect ][ or >< */
1253 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1255 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1256 nm
= p
+ 1, lose
= 1;
1257 if (p
[0] == ':' && (colon
|| slash
))
1258 /* if dev1:[dir]dev2:, move nm to dev2: */
1264 /* if /pathname/dev:, move nm to dev: */
1267 /* if node::dev:, move colon following dev */
1268 else if (colon
&& colon
[-1] == ':')
1270 /* if dev1:dev2:, move nm to dev2: */
1271 else if (colon
&& colon
[-1] != ':')
1276 if (p
[0] == ':' && !colon
)
1282 if (lbrack
== rbrack
)
1285 else if (p
[0] == '.')
1293 if (index (nm
, '/'))
1294 return build_string (sys_translate_unix (nm
));
1296 if (nm
== XSTRING (name
)->data
)
1298 return build_string (nm
);
1302 /* Now determine directory to start with and put it in NEWDIR */
1306 if (nm
[0] == '~') /* prefix ~ */
1311 || nm
[1] == 0)/* ~/filename */
1313 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1314 newdir
= (unsigned char *) "";
1317 nm
++; /* Don't leave the slash in nm. */
1320 else /* ~user/filename */
1322 /* Get past ~ to user */
1323 unsigned char *user
= nm
+ 1;
1324 /* Find end of name. */
1325 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1326 int len
= ptr
? ptr
- user
: strlen (user
);
1328 unsigned char *ptr1
= index (user
, ':');
1329 if (ptr1
!= 0 && ptr1
- user
< len
)
1332 /* Copy the user name into temp storage. */
1333 o
= (unsigned char *) alloca (len
+ 1);
1334 bcopy ((char *) user
, o
, len
);
1337 /* Look up the user name. */
1338 pw
= (struct passwd
*) getpwnam (o
+ 1);
1340 error ("\"%s\" isn't a registered user", o
+ 1);
1342 newdir
= (unsigned char *) pw
->pw_dir
;
1344 /* Discard the user name from NM. */
1351 #endif /* not VMS */
1355 defalt
= current_buffer
->directory
;
1356 CHECK_STRING (defalt
, 1);
1357 newdir
= XSTRING (defalt
)->data
;
1360 /* Now concatenate the directory and name to new space in the stack frame */
1362 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1363 target
= (unsigned char *) alloca (tlen
);
1369 if (nm
[0] == 0 || nm
[0] == '/')
1370 strcpy (target
, newdir
);
1373 file_name_as_directory (target
, newdir
);
1376 strcat (target
, nm
);
1378 if (index (target
, '/'))
1379 strcpy (target
, sys_translate_unix (target
));
1382 /* Now canonicalize by removing /. and /foo/.. if they appear */
1390 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1396 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1397 /* brackets are offset from each other by 2 */
1400 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1401 /* convert [foo][bar] to [bar] */
1402 while (o
[-1] != '[' && o
[-1] != '<')
1404 else if (*p
== '-' && *o
!= '.')
1407 else if (p
[0] == '-' && o
[-1] == '.' &&
1408 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1409 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1413 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1414 if (p
[1] == '.') /* foo.-.bar ==> bar*/
1416 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1418 /* else [foo.-] ==> [-] */
1424 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1425 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1435 else if (!strncmp (p
, "//", 2)
1437 /* // at start of filename is meaningful in Apollo system */
1445 else if (p
[0] == '/' && p
[1] == '.' &&
1446 (p
[2] == '/' || p
[2] == 0))
1448 else if (!strncmp (p
, "/..", 3)
1449 /* `/../' is the "superroot" on certain file systems. */
1451 && (p
[3] == '/' || p
[3] == 0))
1453 while (o
!= target
&& *--o
!= '/')
1456 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1460 if (o
== target
&& *o
== '/')
1468 #endif /* not VMS */
1471 return make_string (target
, o
- target
);
1475 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1476 Ssubstitute_in_file_name
, 1, 1, 0,
1477 "Substitute environment variables referred to in FILENAME.\n\
1478 `$FOO' where FOO is an environment variable name means to substitute\n\
1479 the value of that variable. The variable name should be terminated\n\
1480 with a character not a letter, digit or underscore; otherwise, enclose\n\
1481 the entire variable name in braces.\n\
1482 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1483 On VMS, `$' substitution is not done; this function does little and only\n\
1484 duplicates what `expand-file-name' does.")
1490 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1491 unsigned char *target
;
1493 int substituted
= 0;
1496 CHECK_STRING (string
, 0);
1498 nm
= XSTRING (string
)->data
;
1500 dostounix_filename (nm
= strcpy (alloca (strlen (nm
) + 1), nm
));
1501 substituted
= !strcmp (nm
, XSTRING (string
)->data
);
1503 endp
= nm
+ XSTRING (string
)->size
;
1505 /* If /~ or // appears, discard everything through first slash. */
1507 for (p
= nm
; p
!= endp
; p
++)
1511 /* // at start of file name is meaningful in Apollo system */
1512 (p
[0] == '/' && p
- 1 != nm
)
1513 #else /* not APOLLO */
1515 #endif /* not APOLLO */
1519 (p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>' ||
1530 if (p
[0] && p
[1] == ':')
1539 return build_string (nm
);
1542 /* See if any variables are substituted into the string
1543 and find the total length of their values in `total' */
1545 for (p
= nm
; p
!= endp
;)
1555 /* "$$" means a single "$" */
1564 while (p
!= endp
&& *p
!= '}') p
++;
1565 if (*p
!= '}') goto missingclose
;
1571 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1575 /* Copy out the variable name */
1576 target
= (unsigned char *) alloca (s
- o
+ 1);
1577 strncpy (target
, o
, s
- o
);
1580 strupr (target
); /* $home == $HOME etc. */
1583 /* Get variable value */
1584 o
= (unsigned char *) egetenv (target
);
1585 if (!o
) goto badvar
;
1586 total
+= strlen (o
);
1593 /* If substitution required, recopy the string and do it */
1594 /* Make space in stack frame for the new copy */
1595 xnm
= (unsigned char *) alloca (XSTRING (string
)->size
+ total
+ 1);
1598 /* Copy the rest of the name through, replacing $ constructs with values */
1615 while (p
!= endp
&& *p
!= '}') p
++;
1616 if (*p
!= '}') goto missingclose
;
1622 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1626 /* Copy out the variable name */
1627 target
= (unsigned char *) alloca (s
- o
+ 1);
1628 strncpy (target
, o
, s
- o
);
1631 strupr (target
); /* $home == $HOME etc. */
1634 /* Get variable value */
1635 o
= (unsigned char *) egetenv (target
);
1645 /* If /~ or // appears, discard everything through first slash. */
1647 for (p
= xnm
; p
!= x
; p
++)
1650 /* // at start of file name is meaningful in Apollo system */
1651 (p
[0] == '/' && p
- 1 != xnm
)
1652 #else /* not APOLLO */
1654 #endif /* not APOLLO */
1656 && p
!= nm
&& p
[-1] == '/')
1659 else if (p
[0] && p
[1] == ':')
1663 return make_string (xnm
, x
- xnm
);
1666 error ("Bad format environment-variable substitution");
1668 error ("Missing \"}\" in environment-variable substitution");
1670 error ("Substituting nonexistent environment variable \"%s\"", target
);
1673 #endif /* not VMS */
1676 /* A slightly faster and more convenient way to get
1677 (directory-file-name (expand-file-name FOO)). */
1680 expand_and_dir_to_file (filename
, defdir
)
1681 Lisp_Object filename
, defdir
;
1683 register Lisp_Object abspath
;
1685 abspath
= Fexpand_file_name (filename
, defdir
);
1688 register int c
= XSTRING (abspath
)->data
[XSTRING (abspath
)->size
- 1];
1689 if (c
== ':' || c
== ']' || c
== '>')
1690 abspath
= Fdirectory_file_name (abspath
);
1693 /* Remove final slash, if any (unless path is root).
1694 stat behaves differently depending! */
1695 if (XSTRING (abspath
)->size
> 1
1696 && XSTRING (abspath
)->data
[XSTRING (abspath
)->size
- 1] == '/')
1697 /* We cannot take shortcuts; they might be wrong for magic file names. */
1698 abspath
= Fdirectory_file_name (abspath
);
1703 barf_or_query_if_file_exists (absname
, querystring
, interactive
)
1704 Lisp_Object absname
;
1705 unsigned char *querystring
;
1708 register Lisp_Object tem
;
1709 struct gcpro gcpro1
;
1711 if (access (XSTRING (absname
)->data
, 4) >= 0)
1714 Fsignal (Qfile_already_exists
,
1715 Fcons (build_string ("File already exists"),
1716 Fcons (absname
, Qnil
)));
1718 tem
= do_yes_or_no_p (format1 ("File %s already exists; %s anyway? ",
1719 XSTRING (absname
)->data
, querystring
));
1722 Fsignal (Qfile_already_exists
,
1723 Fcons (build_string ("File already exists"),
1724 Fcons (absname
, Qnil
)));
1729 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
1730 "fCopy file: \nFCopy %s to file: \np\nP",
1731 "Copy FILE to NEWNAME. Both args must be strings.\n\
1732 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
1733 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
1734 A number as third arg means request confirmation if NEWNAME already exists.\n\
1735 This is what happens in interactive use with M-x.\n\
1736 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
1737 last-modified time as the old one. (This works on only some systems.)\n\
1738 A prefix arg makes KEEP-TIME non-nil.")
1739 (filename
, newname
, ok_if_already_exists
, keep_date
)
1740 Lisp_Object filename
, newname
, ok_if_already_exists
, keep_date
;
1743 char buf
[16 * 1024];
1745 Lisp_Object handler
;
1746 struct gcpro gcpro1
, gcpro2
;
1747 int count
= specpdl_ptr
- specpdl
;
1748 Lisp_Object args
[6];
1749 int input_file_statable_p
;
1751 GCPRO2 (filename
, newname
);
1752 CHECK_STRING (filename
, 0);
1753 CHECK_STRING (newname
, 1);
1754 filename
= Fexpand_file_name (filename
, Qnil
);
1755 newname
= Fexpand_file_name (newname
, Qnil
);
1757 /* If the input file name has special constructs in it,
1758 call the corresponding file handler. */
1759 handler
= Ffind_file_name_handler (filename
, Qcopy_file
);
1760 /* Likewise for output file name. */
1762 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
1763 if (!NILP (handler
))
1764 RETURN_UNGCPRO (call5 (handler
, Qcopy_file
, filename
, newname
,
1765 ok_if_already_exists
, keep_date
));
1767 if (NILP (ok_if_already_exists
)
1768 || XTYPE (ok_if_already_exists
) == Lisp_Int
)
1769 barf_or_query_if_file_exists (newname
, "copy to it",
1770 XTYPE (ok_if_already_exists
) == Lisp_Int
);
1772 ifd
= open (XSTRING (filename
)->data
, 0);
1774 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
1776 record_unwind_protect (close_file_unwind
, make_number (ifd
));
1778 /* We can only copy regular files and symbolic links. Other files are not
1780 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
1782 #if defined (S_ISREG) && defined (S_ISLNK)
1783 if (input_file_statable_p
)
1785 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
1787 #if defined (EISDIR)
1788 /* Get a better looking error message. */
1791 report_file_error ("Non-regular file", Fcons (filename
, Qnil
));
1794 #endif /* S_ISREG && S_ISLNK */
1797 /* Create the copy file with the same record format as the input file */
1798 ofd
= sys_creat (XSTRING (newname
)->data
, 0666, ifd
);
1801 /* System's default file type was set to binary by _fmode in emacs.c. */
1802 ofd
= creat (XSTRING (newname
)->data
, S_IREAD
| S_IWRITE
);
1803 #else /* not MSDOS */
1804 ofd
= creat (XSTRING (newname
)->data
, 0666);
1805 #endif /* not MSDOS */
1808 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
1810 record_unwind_protect (close_file_unwind
, make_number (ofd
));
1814 while ((n
= read (ifd
, buf
, sizeof buf
)) > 0)
1815 if (write (ofd
, buf
, n
) != n
)
1816 report_file_error ("I/O error", Fcons (newname
, Qnil
));
1819 /* Closing the output clobbers the file times on some systems. */
1820 if (close (ofd
) < 0)
1821 report_file_error ("I/O error", Fcons (newname
, Qnil
));
1823 if (input_file_statable_p
)
1825 if (!NILP (keep_date
))
1827 EMACS_TIME atime
, mtime
;
1828 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
1829 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
1830 EMACS_SET_UTIMES (XSTRING (newname
)->data
, atime
, mtime
);
1833 if (!egetenv ("USE_DOMAIN_ACLS"))
1835 chmod (XSTRING (newname
)->data
, st
.st_mode
& 07777);
1840 /* Discard the unwind protects. */
1841 specpdl_ptr
= specpdl
+ count
;
1847 DEFUN ("make-directory-internal", Fmake_directory_internal
,
1848 Smake_directory_internal
, 1, 1, 0,
1849 "Create a directory. One argument, a file name string.")
1851 Lisp_Object dirname
;
1854 Lisp_Object handler
;
1856 CHECK_STRING (dirname
, 0);
1857 dirname
= Fexpand_file_name (dirname
, Qnil
);
1859 handler
= Ffind_file_name_handler (dirname
, Qmake_directory_internal
);
1860 if (!NILP (handler
))
1861 return call3 (handler
, Qmake_directory_internal
, dirname
, Qnil
);
1863 dir
= XSTRING (dirname
)->data
;
1865 if (mkdir (dir
, 0777) != 0)
1866 report_file_error ("Creating directory", Flist (1, &dirname
));
1871 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
1872 "Delete a directory. One argument, a file name or directory name string.")
1874 Lisp_Object dirname
;
1877 Lisp_Object handler
;
1879 CHECK_STRING (dirname
, 0);
1880 dirname
= Fdirectory_file_name (Fexpand_file_name (dirname
, Qnil
));
1881 dir
= XSTRING (dirname
)->data
;
1883 handler
= Ffind_file_name_handler (dirname
, Qdelete_directory
);
1884 if (!NILP (handler
))
1885 return call2 (handler
, Qdelete_directory
, dirname
);
1887 if (rmdir (dir
) != 0)
1888 report_file_error ("Removing directory", Flist (1, &dirname
));
1893 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
1894 "Delete specified file. One argument, a file name string.\n\
1895 If file has multiple names, it continues to exist with the other names.")
1897 Lisp_Object filename
;
1899 Lisp_Object handler
;
1900 CHECK_STRING (filename
, 0);
1901 filename
= Fexpand_file_name (filename
, Qnil
);
1903 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
1904 if (!NILP (handler
))
1905 return call2 (handler
, Qdelete_file
, filename
);
1907 if (0 > unlink (XSTRING (filename
)->data
))
1908 report_file_error ("Removing old name", Flist (1, &filename
));
1912 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
1913 "fRename file: \nFRename %s to file: \np",
1914 "Rename FILE as NEWNAME. Both args strings.\n\
1915 If file has names other than FILE, it continues to have those names.\n\
1916 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
1917 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
1918 A number as third arg means request confirmation if NEWNAME already exists.\n\
1919 This is what happens in interactive use with M-x.")
1920 (filename
, newname
, ok_if_already_exists
)
1921 Lisp_Object filename
, newname
, ok_if_already_exists
;
1924 Lisp_Object args
[2];
1926 Lisp_Object handler
;
1927 struct gcpro gcpro1
, gcpro2
;
1929 GCPRO2 (filename
, newname
);
1930 CHECK_STRING (filename
, 0);
1931 CHECK_STRING (newname
, 1);
1932 filename
= Fexpand_file_name (filename
, Qnil
);
1933 newname
= Fexpand_file_name (newname
, Qnil
);
1935 /* If the file name has special constructs in it,
1936 call the corresponding file handler. */
1937 handler
= Ffind_file_name_handler (filename
, Qrename_file
);
1939 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
1940 if (!NILP (handler
))
1941 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
1942 filename
, newname
, ok_if_already_exists
));
1944 if (NILP (ok_if_already_exists
)
1945 || XTYPE (ok_if_already_exists
) == Lisp_Int
)
1946 barf_or_query_if_file_exists (newname
, "rename to it",
1947 XTYPE (ok_if_already_exists
) == Lisp_Int
);
1949 if (0 > rename (XSTRING (filename
)->data
, XSTRING (newname
)->data
))
1951 if (0 > link (XSTRING (filename
)->data
, XSTRING (newname
)->data
)
1952 || 0 > unlink (XSTRING (filename
)->data
))
1957 Fcopy_file (filename
, newname
,
1958 /* We have already prompted if it was an integer,
1959 so don't have copy-file prompt again. */
1960 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
1961 Fdelete_file (filename
);
1968 report_file_error ("Renaming", Flist (2, args
));
1971 report_file_error ("Renaming", Flist (2, &filename
));
1978 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
1979 "fAdd name to file: \nFName to add to %s: \np",
1980 "Give FILE additional name NEWNAME. Both args strings.\n\
1981 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
1982 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
1983 A number as third arg means request confirmation if NEWNAME already exists.\n\
1984 This is what happens in interactive use with M-x.")
1985 (filename
, newname
, ok_if_already_exists
)
1986 Lisp_Object filename
, newname
, ok_if_already_exists
;
1989 Lisp_Object args
[2];
1991 Lisp_Object handler
;
1992 struct gcpro gcpro1
, gcpro2
;
1994 GCPRO2 (filename
, newname
);
1995 CHECK_STRING (filename
, 0);
1996 CHECK_STRING (newname
, 1);
1997 filename
= Fexpand_file_name (filename
, Qnil
);
1998 newname
= Fexpand_file_name (newname
, Qnil
);
2000 /* If the file name has special constructs in it,
2001 call the corresponding file handler. */
2002 handler
= Ffind_file_name_handler (filename
, Qadd_name_to_file
);
2003 if (!NILP (handler
))
2004 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, filename
,
2005 newname
, ok_if_already_exists
));
2007 if (NILP (ok_if_already_exists
)
2008 || XTYPE (ok_if_already_exists
) == Lisp_Int
)
2009 barf_or_query_if_file_exists (newname
, "make it a new name",
2010 XTYPE (ok_if_already_exists
) == Lisp_Int
);
2011 unlink (XSTRING (newname
)->data
);
2012 if (0 > link (XSTRING (filename
)->data
, XSTRING (newname
)->data
))
2017 report_file_error ("Adding new name", Flist (2, args
));
2019 report_file_error ("Adding new name", Flist (2, &filename
));
2028 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2029 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2030 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
2031 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2032 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2033 A number as third arg means request confirmation if NEWNAME already exists.\n\
2034 This happens for interactive use with M-x.")
2035 (filename
, linkname
, ok_if_already_exists
)
2036 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2039 Lisp_Object args
[2];
2041 Lisp_Object handler
;
2042 struct gcpro gcpro1
, gcpro2
;
2044 GCPRO2 (filename
, linkname
);
2045 CHECK_STRING (filename
, 0);
2046 CHECK_STRING (linkname
, 1);
2047 /* If the link target has a ~, we must expand it to get
2048 a truly valid file name. Otherwise, do not expand;
2049 we want to permit links to relative file names. */
2050 if (XSTRING (filename
)->data
[0] == '~')
2051 filename
= Fexpand_file_name (filename
, Qnil
);
2052 linkname
= Fexpand_file_name (linkname
, Qnil
);
2054 /* If the file name has special constructs in it,
2055 call the corresponding file handler. */
2056 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2057 if (!NILP (handler
))
2058 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2059 linkname
, ok_if_already_exists
));
2061 if (NILP (ok_if_already_exists
)
2062 || XTYPE (ok_if_already_exists
) == Lisp_Int
)
2063 barf_or_query_if_file_exists (linkname
, "make it a link",
2064 XTYPE (ok_if_already_exists
) == Lisp_Int
);
2065 if (0 > symlink (XSTRING (filename
)->data
, XSTRING (linkname
)->data
))
2067 /* If we didn't complain already, silently delete existing file. */
2068 if (errno
== EEXIST
)
2070 unlink (XSTRING (linkname
)->data
);
2071 if (0 <= symlink (XSTRING (filename
)->data
, XSTRING (linkname
)->data
))
2078 report_file_error ("Making symbolic link", Flist (2, args
));
2080 report_file_error ("Making symbolic link", Flist (2, &filename
));
2086 #endif /* S_IFLNK */
2090 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2091 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2092 "Define the job-wide logical name NAME to have the value STRING.\n\
2093 If STRING is nil or a null string, the logical name NAME is deleted.")
2095 Lisp_Object varname
;
2098 CHECK_STRING (varname
, 0);
2100 delete_logical_name (XSTRING (varname
)->data
);
2103 CHECK_STRING (string
, 1);
2105 if (XSTRING (string
)->size
== 0)
2106 delete_logical_name (XSTRING (varname
)->data
);
2108 define_logical_name (XSTRING (varname
)->data
, XSTRING (string
)->data
);
2117 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2118 "Open a network connection to PATH using LOGIN as the login string.")
2120 Lisp_Object path
, login
;
2124 CHECK_STRING (path
, 0);
2125 CHECK_STRING (login
, 0);
2127 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2129 if (netresult
== -1)
2134 #endif /* HPUX_NET */
2136 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2138 "Return t if file FILENAME specifies an absolute path name.\n\
2139 On Unix, this is a name starting with a `/' or a `~'.")
2141 Lisp_Object filename
;
2145 CHECK_STRING (filename
, 0);
2146 ptr
= XSTRING (filename
)->data
;
2147 if (*ptr
== '/' || *ptr
== '~'
2149 /* ??? This criterion is probably wrong for '<'. */
2150 || index (ptr
, ':') || index (ptr
, '<')
2151 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2155 || (*ptr
!= 0 && ptr
[1] == ':' && (ptr
[2] == '/' || ptr
[2] == '\\'))
2163 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2164 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
2165 See also `file-readable-p' and `file-attributes'.")
2167 Lisp_Object filename
;
2169 Lisp_Object abspath
;
2170 Lisp_Object handler
;
2172 CHECK_STRING (filename
, 0);
2173 abspath
= Fexpand_file_name (filename
, Qnil
);
2175 /* If the file name has special constructs in it,
2176 call the corresponding file handler. */
2177 handler
= Ffind_file_name_handler (abspath
, Qfile_exists_p
);
2178 if (!NILP (handler
))
2179 return call2 (handler
, Qfile_exists_p
, abspath
);
2181 return (access (XSTRING (abspath
)->data
, 0) >= 0) ? Qt
: Qnil
;
2184 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2185 "Return t if FILENAME can be executed by you.\n\
2186 For a directory, this means you can access files in that directory.")
2188 Lisp_Object filename
;
2191 Lisp_Object abspath
;
2192 Lisp_Object handler
;
2194 CHECK_STRING (filename
, 0);
2195 abspath
= Fexpand_file_name (filename
, Qnil
);
2197 /* If the file name has special constructs in it,
2198 call the corresponding file handler. */
2199 handler
= Ffind_file_name_handler (abspath
, Qfile_executable_p
);
2200 if (!NILP (handler
))
2201 return call2 (handler
, Qfile_executable_p
, abspath
);
2203 return (access (XSTRING (abspath
)->data
, 1) >= 0) ? Qt
: Qnil
;
2206 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2207 "Return t if file FILENAME exists and you can read it.\n\
2208 See also `file-exists-p' and `file-attributes'.")
2210 Lisp_Object filename
;
2212 Lisp_Object abspath
;
2213 Lisp_Object handler
;
2215 CHECK_STRING (filename
, 0);
2216 abspath
= Fexpand_file_name (filename
, Qnil
);
2218 /* If the file name has special constructs in it,
2219 call the corresponding file handler. */
2220 handler
= Ffind_file_name_handler (abspath
, Qfile_readable_p
);
2221 if (!NILP (handler
))
2222 return call2 (handler
, Qfile_readable_p
, abspath
);
2224 return (access (XSTRING (abspath
)->data
, 4) >= 0) ? Qt
: Qnil
;
2227 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
2228 "Return non-nil if file FILENAME is the name of a symbolic link.\n\
2229 The value is the name of the file to which it is linked.\n\
2230 Otherwise returns nil.")
2232 Lisp_Object filename
;
2239 Lisp_Object handler
;
2241 CHECK_STRING (filename
, 0);
2242 filename
= Fexpand_file_name (filename
, Qnil
);
2244 /* If the file name has special constructs in it,
2245 call the corresponding file handler. */
2246 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
2247 if (!NILP (handler
))
2248 return call2 (handler
, Qfile_symlink_p
, filename
);
2253 buf
= (char *) xmalloc (bufsize
);
2254 bzero (buf
, bufsize
);
2255 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
2256 if (valsize
< bufsize
) break;
2257 /* Buffer was not long enough */
2266 val
= make_string (buf
, valsize
);
2269 #else /* not S_IFLNK */
2271 #endif /* not S_IFLNK */
2274 #ifdef SOLARIS_BROKEN_ACCESS
2275 /* In Solaris 2.1, the readonly-ness of the filesystem is not
2276 considered by the access system call. This is Sun's bug, but we
2277 still have to make Emacs work. */
2279 #include <sys/statvfs.h>
2285 struct statvfs statvfsb
;
2287 if (statvfs(path
, &statvfsb
))
2288 return 1; /* error from statvfs, be conservative and say not wrtable */
2290 /* Otherwise, fsys is ro if bit is set. */
2291 return statvfsb
.f_flag
& ST_RDONLY
;
2294 /* But on every other os, access has already done the right thing. */
2295 #define ro_fsys(path) 0
2298 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2300 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
2301 "Return t if file FILENAME can be written or created by you.")
2303 Lisp_Object filename
;
2305 Lisp_Object abspath
, dir
;
2306 Lisp_Object handler
;
2308 CHECK_STRING (filename
, 0);
2309 abspath
= Fexpand_file_name (filename
, Qnil
);
2311 /* If the file name has special constructs in it,
2312 call the corresponding file handler. */
2313 handler
= Ffind_file_name_handler (abspath
, Qfile_writable_p
);
2314 if (!NILP (handler
))
2315 return call2 (handler
, Qfile_writable_p
, abspath
);
2317 if (access (XSTRING (abspath
)->data
, 0) >= 0)
2318 return ((access (XSTRING (abspath
)->data
, 2) >= 0
2319 && ! ro_fsys ((char *) XSTRING (abspath
)->data
))
2321 dir
= Ffile_name_directory (abspath
);
2324 dir
= Fdirectory_file_name (dir
);
2328 dir
= Fdirectory_file_name (dir
);
2330 return ((access (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "", 2) >= 0
2331 && ! ro_fsys ((char *) XSTRING (dir
)->data
))
2335 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
2336 "Return t if file FILENAME is the name of a directory as a file.\n\
2337 A directory name spec may be given instead; then the value is t\n\
2338 if the directory so specified exists and really is a directory.")
2340 Lisp_Object filename
;
2342 register Lisp_Object abspath
;
2344 Lisp_Object handler
;
2346 abspath
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2348 /* If the file name has special constructs in it,
2349 call the corresponding file handler. */
2350 handler
= Ffind_file_name_handler (abspath
, Qfile_directory_p
);
2351 if (!NILP (handler
))
2352 return call2 (handler
, Qfile_directory_p
, abspath
);
2354 if (stat (XSTRING (abspath
)->data
, &st
) < 0)
2356 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
2359 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
2360 "Return t if file FILENAME is the name of a directory as a file,\n\
2361 and files in that directory can be opened by you. In order to use a\n\
2362 directory as a buffer's current directory, this predicate must return true.\n\
2363 A directory name spec may be given instead; then the value is t\n\
2364 if the directory so specified exists and really is a readable and\n\
2365 searchable directory.")
2367 Lisp_Object filename
;
2369 Lisp_Object handler
;
2371 /* If the file name has special constructs in it,
2372 call the corresponding file handler. */
2373 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
2374 if (!NILP (handler
))
2375 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
2377 if (NILP (Ffile_directory_p (filename
))
2378 || NILP (Ffile_executable_p (filename
)))
2384 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
2385 "Return mode bits of FILE, as an integer.")
2387 Lisp_Object filename
;
2389 Lisp_Object abspath
;
2391 Lisp_Object handler
;
2393 abspath
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2395 /* If the file name has special constructs in it,
2396 call the corresponding file handler. */
2397 handler
= Ffind_file_name_handler (abspath
, Qfile_modes
);
2398 if (!NILP (handler
))
2399 return call2 (handler
, Qfile_modes
, abspath
);
2401 if (stat (XSTRING (abspath
)->data
, &st
) < 0)
2407 if (S_ISREG (st
.st_mode
)
2408 && (len
= XSTRING (abspath
)->size
) >= 5
2409 && (stricmp ((suffix
= XSTRING (abspath
)->data
+ len
-4), ".com") == 0
2410 || stricmp (suffix
, ".exe") == 0
2411 || stricmp (suffix
, ".bat") == 0))
2412 st
.st_mode
|= S_IEXEC
;
2416 return make_number (st
.st_mode
& 07777);
2419 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
2420 "Set mode bits of FILE to MODE (an integer).\n\
2421 Only the 12 low bits of MODE are used.")
2423 Lisp_Object filename
, mode
;
2425 Lisp_Object abspath
;
2426 Lisp_Object handler
;
2428 abspath
= Fexpand_file_name (filename
, current_buffer
->directory
);
2429 CHECK_NUMBER (mode
, 1);
2431 /* If the file name has special constructs in it,
2432 call the corresponding file handler. */
2433 handler
= Ffind_file_name_handler (abspath
, Qset_file_modes
);
2434 if (!NILP (handler
))
2435 return call3 (handler
, Qset_file_modes
, abspath
, mode
);
2438 if (chmod (XSTRING (abspath
)->data
, XINT (mode
)) < 0)
2439 report_file_error ("Doing chmod", Fcons (abspath
, Qnil
));
2441 if (!egetenv ("USE_DOMAIN_ACLS"))
2444 struct timeval tvp
[2];
2446 /* chmod on apollo also change the file's modtime; need to save the
2447 modtime and then restore it. */
2448 if (stat (XSTRING (abspath
)->data
, &st
) < 0)
2450 report_file_error ("Doing chmod", Fcons (abspath
, Qnil
));
2454 if (chmod (XSTRING (abspath
)->data
, XINT (mode
)) < 0)
2455 report_file_error ("Doing chmod", Fcons (abspath
, Qnil
));
2457 /* reset the old accessed and modified times. */
2458 tvp
[0].tv_sec
= st
.st_atime
+ 1; /* +1 due to an Apollo roundoff bug */
2460 tvp
[1].tv_sec
= st
.st_mtime
+ 1; /* +1 due to an Apollo roundoff bug */
2463 if (utimes (XSTRING (abspath
)->data
, tvp
) < 0)
2464 report_file_error ("Doing utimes", Fcons (abspath
, Qnil
));
2471 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
2472 "Set the file permission bits for newly created files.\n\
2473 The argument MODE should be an integer; only the low 9 bits are used.\n\
2474 This setting is inherited by subprocesses.")
2478 CHECK_NUMBER (mode
, 0);
2480 umask ((~ XINT (mode
)) & 0777);
2485 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
2486 "Return the default file protection for created files.\n\
2487 The value is an integer.")
2493 realmask
= umask (0);
2496 XSET (value
, Lisp_Int
, (~ realmask
) & 0777);
2502 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
2503 "Tell Unix to finish all pending disk updates.")
2512 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
2513 "Return t if file FILE1 is newer than file FILE2.\n\
2514 If FILE1 does not exist, the answer is nil;\n\
2515 otherwise, if FILE2 does not exist, the answer is t.")
2517 Lisp_Object file1
, file2
;
2519 Lisp_Object abspath1
, abspath2
;
2522 Lisp_Object handler
;
2523 struct gcpro gcpro1
, gcpro2
;
2525 CHECK_STRING (file1
, 0);
2526 CHECK_STRING (file2
, 0);
2529 GCPRO2 (abspath1
, file2
);
2530 abspath1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
2531 abspath2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
2534 /* If the file name has special constructs in it,
2535 call the corresponding file handler. */
2536 handler
= Ffind_file_name_handler (abspath1
, Qfile_newer_than_file_p
);
2538 handler
= Ffind_file_name_handler (abspath2
, Qfile_newer_than_file_p
);
2539 if (!NILP (handler
))
2540 return call3 (handler
, Qfile_newer_than_file_p
, abspath1
, abspath2
);
2542 if (stat (XSTRING (abspath1
)->data
, &st
) < 0)
2545 mtime1
= st
.st_mtime
;
2547 if (stat (XSTRING (abspath2
)->data
, &st
) < 0)
2550 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
2554 Lisp_Object Qfind_buffer_file_type
;
2557 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
2559 "Insert contents of file FILENAME after point.\n\
2560 Returns list of absolute file name and length of data inserted.\n\
2561 If second argument VISIT is non-nil, the buffer's visited filename\n\
2562 and last save file modtime are set, and it is marked unmodified.\n\
2563 If visiting and the file does not exist, visiting is completed\n\
2564 before the error is signaled.\n\n\
2565 The optional third and fourth arguments BEG and END\n\
2566 specify what portion of the file to insert.\n\
2567 If VISIT is non-nil, BEG and END must be nil.\n\
2568 If optional fifth argument REPLACE is non-nil,\n\
2569 it means replace the current buffer contents (in the accessible portion)\n\
2570 with the file contents. This is better than simply deleting and inserting\n\
2571 the whole thing because (1) it preserves some marker positions\n\
2572 and (2) it puts less data in the undo list.")
2573 (filename
, visit
, beg
, end
, replace
)
2574 Lisp_Object filename
, visit
, beg
, end
, replace
;
2578 register int inserted
= 0;
2579 register int how_much
;
2580 int count
= specpdl_ptr
- specpdl
;
2581 struct gcpro gcpro1
, gcpro2
;
2582 Lisp_Object handler
, val
, insval
;
2589 GCPRO2 (filename
, p
);
2590 if (!NILP (current_buffer
->read_only
))
2591 Fbarf_if_buffer_read_only();
2593 CHECK_STRING (filename
, 0);
2594 filename
= Fexpand_file_name (filename
, Qnil
);
2596 /* If the file name has special constructs in it,
2597 call the corresponding file handler. */
2598 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
2599 if (!NILP (handler
))
2601 val
= call6 (handler
, Qinsert_file_contents
, filename
,
2602 visit
, beg
, end
, replace
);
2609 if (stat (XSTRING (filename
)->data
, &st
) < 0)
2611 if ((fd
= open (XSTRING (filename
)->data
, 0)) < 0
2612 || fstat (fd
, &st
) < 0)
2613 #endif /* not APOLLO */
2615 if (fd
>= 0) close (fd
);
2618 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
2625 /* This code will need to be changed in order to work on named
2626 pipes, and it's probably just not worth it. So we should at
2627 least signal an error. */
2628 if (!S_ISREG (st
.st_mode
))
2629 Fsignal (Qfile_error
,
2630 Fcons (build_string ("not a regular file"),
2631 Fcons (filename
, Qnil
)));
2635 if ((fd
= open (XSTRING (filename
)->data
, 0)) < 0)
2638 /* Replacement should preserve point as it preserves markers. */
2639 if (!NILP (replace
))
2640 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
2642 record_unwind_protect (close_file_unwind
, make_number (fd
));
2644 /* Supposedly happens on VMS. */
2646 error ("File size is negative");
2648 if (!NILP (beg
) || !NILP (end
))
2650 error ("Attempt to visit less than an entire file");
2653 CHECK_NUMBER (beg
, 0);
2658 CHECK_NUMBER (end
, 0);
2661 XSETINT (end
, st
.st_size
);
2662 if (XINT (end
) != st
.st_size
)
2663 error ("maximum buffer size exceeded");
2666 /* If requested, replace the accessible part of the buffer
2667 with the file contents. Avoid replacing text at the
2668 beginning or end of the buffer that matches the file contents;
2669 that preserves markers pointing to the unchanged parts. */
2671 /* On MSDOS, replace mode doesn't really work, except for binary files,
2672 and it's not worth supporting just for them. */
2673 if (!NILP (replace
))
2677 XFASTINT (end
) = st
.st_size
;
2678 del_range_1 (BEGV
, ZV
, 0);
2681 if (!NILP (replace
))
2683 unsigned char buffer
[1 << 14];
2684 int same_at_start
= BEGV
;
2685 int same_at_end
= ZV
;
2690 /* Count how many chars at the start of the file
2691 match the text at the beginning of the buffer. */
2696 nread
= read (fd
, buffer
, sizeof buffer
);
2698 error ("IO error reading %s: %s",
2699 XSTRING (filename
)->data
, strerror (errno
));
2700 else if (nread
== 0)
2703 while (bufpos
< nread
&& same_at_start
< ZV
2704 && FETCH_CHAR (same_at_start
) == buffer
[bufpos
])
2705 same_at_start
++, bufpos
++;
2706 /* If we found a discrepancy, stop the scan.
2707 Otherwise loop around and scan the next bufferfull. */
2708 if (bufpos
!= nread
)
2712 /* If the file matches the buffer completely,
2713 there's no need to replace anything. */
2714 if (same_at_start
- BEGV
== st
.st_size
)
2718 /* Truncate the buffer to the size of the file. */
2719 del_range_1 (same_at_start
, same_at_end
, 0);
2724 /* Count how many chars at the end of the file
2725 match the text at the end of the buffer. */
2728 int total_read
, nread
, bufpos
, curpos
, trial
;
2730 /* At what file position are we now scanning? */
2731 curpos
= st
.st_size
- (ZV
- same_at_end
);
2732 /* If the entire file matches the buffer tail, stop the scan. */
2735 /* How much can we scan in the next step? */
2736 trial
= min (curpos
, sizeof buffer
);
2737 if (lseek (fd
, curpos
- trial
, 0) < 0)
2738 report_file_error ("Setting file position",
2739 Fcons (filename
, Qnil
));
2742 while (total_read
< trial
)
2744 nread
= read (fd
, buffer
+ total_read
, trial
- total_read
);
2746 error ("IO error reading %s: %s",
2747 XSTRING (filename
)->data
, strerror (errno
));
2748 total_read
+= nread
;
2750 /* Scan this bufferfull from the end, comparing with
2751 the Emacs buffer. */
2752 bufpos
= total_read
;
2753 /* Compare with same_at_start to avoid counting some buffer text
2754 as matching both at the file's beginning and at the end. */
2755 while (bufpos
> 0 && same_at_end
> same_at_start
2756 && FETCH_CHAR (same_at_end
- 1) == buffer
[bufpos
- 1])
2757 same_at_end
--, bufpos
--;
2758 /* If we found a discrepancy, stop the scan.
2759 Otherwise loop around and scan the preceding bufferfull. */
2765 /* Don't try to reuse the same piece of text twice. */
2766 overlap
= same_at_start
- BEGV
- (same_at_end
+ st
.st_size
- ZV
);
2768 same_at_end
+= overlap
;
2770 /* Arrange to read only the nonmatching middle part of the file. */
2771 XFASTINT (beg
) = same_at_start
- BEGV
;
2772 XFASTINT (end
) = st
.st_size
- (ZV
- same_at_end
);
2774 del_range_1 (same_at_start
, same_at_end
, 0);
2775 /* Insert from the file at the proper position. */
2776 SET_PT (same_at_start
);
2780 total
= XINT (end
) - XINT (beg
);
2783 register Lisp_Object temp
;
2785 /* Make sure point-max won't overflow after this insertion. */
2786 XSET (temp
, Lisp_Int
, total
);
2787 if (total
!= XINT (temp
))
2788 error ("maximum buffer size exceeded");
2791 if (NILP (visit
) && total
> 0)
2792 prepare_to_modify_buffer (point
, point
);
2795 if (GAP_SIZE
< total
)
2796 make_gap (total
- GAP_SIZE
);
2798 if (XINT (beg
) != 0 || !NILP (replace
))
2800 if (lseek (fd
, XINT (beg
), 0) < 0)
2801 report_file_error ("Setting file position", Fcons (filename
, Qnil
));
2805 while (inserted
< total
)
2807 int try = min (total
- inserted
, 64 << 10);
2810 /* Allow quitting out of the actual I/O. */
2813 this = read (fd
, &FETCH_CHAR (point
+ inserted
- 1) + 1, try);
2830 /* Demacs 1.1.1 91/10/16 HIRANO Satoshi, MW July 1993 */
2831 /* Determine file type from name and remove LFs from CR-LFs if the file
2832 is deemed to be a text file. */
2834 struct gcpro gcpro1
;
2838 current_buffer
->buffer_file_type
2839 = call1 (Qfind_buffer_file_type
, filename
);
2841 if (NILP (current_buffer
->buffer_file_type
))
2844 = inserted
- crlf_to_lf (inserted
, &FETCH_CHAR (point
- 1) + 1);
2847 GPT
-= reduced_size
;
2848 GAP_SIZE
+= reduced_size
;
2849 inserted
-= reduced_size
;
2856 record_insert (point
, inserted
);
2858 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
2859 offset_intervals (current_buffer
, point
, inserted
);
2865 /* Discard the unwind protect for closing the file. */
2869 error ("IO error reading %s: %s",
2870 XSTRING (filename
)->data
, strerror (errno
));
2877 if (!EQ (current_buffer
->undo_list
, Qt
))
2878 current_buffer
->undo_list
= Qnil
;
2880 stat (XSTRING (filename
)->data
, &st
);
2885 current_buffer
->modtime
= st
.st_mtime
;
2886 current_buffer
->filename
= filename
;
2889 current_buffer
->save_modified
= MODIFF
;
2890 current_buffer
->auto_save_modified
= MODIFF
;
2891 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
2892 #ifdef CLASH_DETECTION
2895 if (!NILP (current_buffer
->filename
))
2896 unlock_file (current_buffer
->filename
);
2897 unlock_file (filename
);
2899 #endif /* CLASH_DETECTION */
2900 /* If visiting nonexistent file, return nil. */
2901 if (current_buffer
->modtime
== -1)
2902 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
2905 if (inserted
> 0 && NILP (visit
) && total
> 0)
2906 signal_after_change (point
, 0, inserted
);
2910 p
= Vafter_insert_file_functions
;
2913 insval
= call1 (Fcar (p
), make_number (inserted
));
2916 CHECK_NUMBER (insval
, 0);
2917 inserted
= XFASTINT (insval
);
2925 val
= Fcons (filename
,
2926 Fcons (make_number (inserted
),
2929 RETURN_UNGCPRO (unbind_to (count
, val
));
2932 static Lisp_Object
build_annotations ();
2934 /* If build_annotations switched buffers, switch back to BUF.
2935 Kill the temporary buffer that was selected in the meantime. */
2938 build_annotations_unwind (buf
)
2943 if (XBUFFER (buf
) == current_buffer
)
2945 tembuf
= Fcurrent_buffer ();
2947 Fkill_buffer (tembuf
);
2951 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 5,
2952 "r\nFWrite region to file: ",
2953 "Write current region into specified file.\n\
2954 When called from a program, takes three arguments:\n\
2955 START, END and FILENAME. START and END are buffer positions.\n\
2956 Optional fourth argument APPEND if non-nil means\n\
2957 append to existing file contents (if any).\n\
2958 Optional fifth argument VISIT if t means\n\
2959 set the last-save-file-modtime of buffer to this file's modtime\n\
2960 and mark buffer not modified.\n\
2961 If VISIT is a string, it is a second file name;\n\
2962 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
2963 VISIT is also the file name to lock and unlock for clash detection.\n\
2964 If VISIT is neither t nor nil nor a string,\n\
2965 that means do not print the \"Wrote file\" message.\n\
2966 Kludgy feature: if START is a string, then that string is written\n\
2967 to the file, instead of any buffer contents, and END is ignored.")
2968 (start
, end
, filename
, append
, visit
)
2969 Lisp_Object start
, end
, filename
, append
, visit
;
2977 int count
= specpdl_ptr
- specpdl
;
2980 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
2982 Lisp_Object handler
;
2983 Lisp_Object visit_file
;
2984 Lisp_Object annotations
;
2985 int visiting
, quietly
;
2986 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2987 struct buffer
*given_buffer
;
2989 int buffer_file_type
2990 = NILP (current_buffer
->buffer_file_type
) ? O_TEXT
: O_BINARY
;
2993 if (!NILP (start
) && !STRINGP (start
))
2994 validate_region (&start
, &end
);
2996 filename
= Fexpand_file_name (filename
, Qnil
);
2997 if (STRINGP (visit
))
2998 visit_file
= Fexpand_file_name (visit
, Qnil
);
3000 visit_file
= filename
;
3002 visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
3003 quietly
= !NILP (visit
);
3007 GCPRO4 (start
, filename
, annotations
, visit_file
);
3009 /* If the file name has special constructs in it,
3010 call the corresponding file handler. */
3011 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
3012 /* If FILENAME has no handler, see if VISIT has one. */
3013 if (NILP (handler
) && XTYPE (visit
) == Lisp_String
)
3014 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
3016 if (!NILP (handler
))
3019 val
= call6 (handler
, Qwrite_region
, start
, end
,
3020 filename
, append
, visit
);
3024 current_buffer
->save_modified
= MODIFF
;
3025 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3026 current_buffer
->filename
= visit_file
;
3032 /* Special kludge to simplify auto-saving. */
3035 XFASTINT (start
) = BEG
;
3039 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
3040 count1
= specpdl_ptr
- specpdl
;
3042 given_buffer
= current_buffer
;
3043 annotations
= build_annotations (start
, end
);
3044 if (current_buffer
!= given_buffer
)
3050 #ifdef CLASH_DETECTION
3052 lock_file (visit_file
);
3053 #endif /* CLASH_DETECTION */
3055 fn
= XSTRING (filename
)->data
;
3059 desc
= open (fn
, O_WRONLY
| buffer_file_type
);
3061 desc
= open (fn
, O_WRONLY
);
3066 if (auto_saving
) /* Overwrite any previous version of autosave file */
3068 vms_truncate (fn
); /* if fn exists, truncate to zero length */
3069 desc
= open (fn
, O_RDWR
);
3071 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
3072 ? XSTRING (current_buffer
->filename
)->data
: 0,
3075 else /* Write to temporary name and rename if no errors */
3077 Lisp_Object temp_name
;
3078 temp_name
= Ffile_name_directory (filename
);
3080 if (!NILP (temp_name
))
3082 temp_name
= Fmake_temp_name (concat2 (temp_name
,
3083 build_string ("$$SAVE$$")));
3084 fname
= XSTRING (filename
)->data
;
3085 fn
= XSTRING (temp_name
)->data
;
3086 desc
= creat_copy_attrs (fname
, fn
);
3089 /* If we can't open the temporary file, try creating a new
3090 version of the original file. VMS "creat" creates a
3091 new version rather than truncating an existing file. */
3094 desc
= creat (fn
, 0666);
3095 #if 0 /* This can clobber an existing file and fail to replace it,
3096 if the user runs out of space. */
3099 /* We can't make a new version;
3100 try to truncate and rewrite existing version if any. */
3102 desc
= open (fn
, O_RDWR
);
3108 desc
= creat (fn
, 0666);
3113 O_WRONLY
| O_TRUNC
| O_CREAT
| buffer_file_type
,
3114 S_IREAD
| S_IWRITE
);
3115 #else /* not MSDOS */
3116 desc
= creat (fn
, auto_saving
? auto_save_mode_bits
: 0666);
3117 #endif /* not MSDOS */
3118 #endif /* not VMS */
3124 #ifdef CLASH_DETECTION
3126 if (!auto_saving
) unlock_file (visit_file
);
3128 #endif /* CLASH_DETECTION */
3129 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
3132 record_unwind_protect (close_file_unwind
, make_number (desc
));
3135 if (lseek (desc
, 0, 2) < 0)
3137 #ifdef CLASH_DETECTION
3138 if (!auto_saving
) unlock_file (visit_file
);
3139 #endif /* CLASH_DETECTION */
3140 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
3145 * Kludge Warning: The VMS C RTL likes to insert carriage returns
3146 * if we do writes that don't end with a carriage return. Furthermore
3147 * it cannot handle writes of more then 16K. The modified
3148 * version of "sys_write" in SYSDEP.C (see comment there) copes with
3149 * this EXCEPT for the last record (iff it doesn't end with a carriage
3150 * return). This implies that if your buffer doesn't end with a carriage
3151 * return, you get one free... tough. However it also means that if
3152 * we make two calls to sys_write (a la the following code) you can
3153 * get one at the gap as well. The easiest way to fix this (honest)
3154 * is to move the gap to the next newline (or the end of the buffer).
3159 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
3160 move_gap (find_next_newline (GPT
, 1));
3166 if (STRINGP (start
))
3168 failure
= 0 > a_write (desc
, XSTRING (start
)->data
,
3169 XSTRING (start
)->size
, 0, &annotations
);
3172 else if (XINT (start
) != XINT (end
))
3175 if (XINT (start
) < GPT
)
3177 register int end1
= XINT (end
);
3179 failure
= 0 > a_write (desc
, &FETCH_CHAR (tem
),
3180 min (GPT
, end1
) - tem
, tem
, &annotations
);
3181 nwritten
+= min (GPT
, end1
) - tem
;
3185 if (XINT (end
) > GPT
&& !failure
)
3188 tem
= max (tem
, GPT
);
3189 failure
= 0 > a_write (desc
, &FETCH_CHAR (tem
), XINT (end
) - tem
,
3191 nwritten
+= XINT (end
) - tem
;
3197 /* If file was empty, still need to write the annotations */
3198 failure
= 0 > a_write (desc
, "", 0, XINT (start
), &annotations
);
3206 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
3207 Disk full in NFS may be reported here. */
3208 /* mib says that closing the file will try to write as fast as NFS can do
3209 it, and that means the fsync here is not crucial for autosave files. */
3210 if (!auto_saving
&& fsync (desc
) < 0)
3211 failure
= 1, save_errno
= errno
;
3214 /* Spurious "file has changed on disk" warnings have been
3215 observed on Suns as well.
3216 It seems that `close' can change the modtime, under nfs.
3218 (This has supposedly been fixed in Sunos 4,
3219 but who knows about all the other machines with NFS?) */
3222 /* On VMS and APOLLO, must do the stat after the close
3223 since closing changes the modtime. */
3226 /* Recall that #if defined does not work on VMS. */
3233 /* NFS can report a write failure now. */
3234 if (close (desc
) < 0)
3235 failure
= 1, save_errno
= errno
;
3238 /* If we wrote to a temporary name and had no errors, rename to real name. */
3242 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
3250 /* Discard the unwind protect for close_file_unwind. */
3251 specpdl_ptr
= specpdl
+ count1
;
3252 /* Restore the original current buffer. */
3255 #ifdef CLASH_DETECTION
3257 unlock_file (visit_file
);
3258 #endif /* CLASH_DETECTION */
3260 /* Do this before reporting IO error
3261 to avoid a "file has changed on disk" warning on
3262 next attempt to save. */
3264 current_buffer
->modtime
= st
.st_mtime
;
3267 error ("IO error writing %s: %s", fn
, strerror (save_errno
));
3271 current_buffer
->save_modified
= MODIFF
;
3272 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3273 current_buffer
->filename
= visit_file
;
3274 update_mode_lines
++;
3280 message ("Wrote %s", XSTRING (visit_file
)->data
);
3285 Lisp_Object
merge ();
3287 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
3288 "Return t if (car A) is numerically less than (car B).")
3292 return Flss (Fcar (a
), Fcar (b
));
3295 /* Build the complete list of annotations appropriate for writing out
3296 the text between START and END, by calling all the functions in
3297 write-region-annotate-functions and merging the lists they return.
3298 If one of these functions switches to a different buffer, we assume
3299 that buffer contains altered text. Therefore, the caller must
3300 make sure to restore the current buffer in all cases,
3301 as save-excursion would do. */
3304 build_annotations (start
, end
)
3305 Lisp_Object start
, end
;
3307 Lisp_Object annotations
;
3309 struct gcpro gcpro1
, gcpro2
;
3312 p
= Vwrite_region_annotate_functions
;
3313 GCPRO2 (annotations
, p
);
3316 struct buffer
*given_buffer
= current_buffer
;
3317 Vwrite_region_annotations_so_far
= annotations
;
3318 res
= call2 (Fcar (p
), start
, end
);
3319 /* If the function makes a different buffer current,
3320 assume that means this buffer contains altered text to be output.
3321 Reset START and END from the buffer bounds
3322 and discard all previous annotations because they should have
3323 been dealt with by this function. */
3324 if (current_buffer
!= given_buffer
)
3331 Flength (res
); /* Check basic validity of return value */
3332 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
3339 /* Write to descriptor DESC the LEN characters starting at ADDR,
3340 assuming they start at position POS in the buffer.
3341 Intersperse with them the annotations from *ANNOT
3342 (those which fall within the range of positions POS to POS + LEN),
3343 each at its appropriate position.
3345 Modify *ANNOT by discarding elements as we output them.
3346 The return value is negative in case of system call failure. */
3349 a_write (desc
, addr
, len
, pos
, annot
)
3351 register char *addr
;
3358 int lastpos
= pos
+ len
;
3360 while (NILP (*annot
) || CONSP (*annot
))
3362 tem
= Fcar_safe (Fcar (*annot
));
3363 if (INTEGERP (tem
) && XINT (tem
) >= pos
&& XFASTINT (tem
) <= lastpos
)
3364 nextpos
= XFASTINT (tem
);
3366 return e_write (desc
, addr
, lastpos
- pos
);
3369 if (0 > e_write (desc
, addr
, nextpos
- pos
))
3371 addr
+= nextpos
- pos
;
3374 tem
= Fcdr (Fcar (*annot
));
3377 if (0 > e_write (desc
, XSTRING (tem
)->data
, XSTRING (tem
)->size
))
3380 *annot
= Fcdr (*annot
);
3385 e_write (desc
, addr
, len
)
3387 register char *addr
;
3390 char buf
[16 * 1024];
3391 register char *p
, *end
;
3393 if (!EQ (current_buffer
->selective_display
, Qt
))
3394 return write (desc
, addr
, len
) - len
;
3398 end
= p
+ sizeof buf
;
3403 if (write (desc
, buf
, sizeof buf
) != sizeof buf
)
3412 if (write (desc
, buf
, p
- buf
) != p
- buf
)
3418 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
3419 Sverify_visited_file_modtime
, 1, 1, 0,
3420 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
3421 This means that the file has not been changed since it was visited or saved.")
3427 Lisp_Object handler
;
3429 CHECK_BUFFER (buf
, 0);
3432 if (XTYPE (b
->filename
) != Lisp_String
) return Qt
;
3433 if (b
->modtime
== 0) return Qt
;
3435 /* If the file name has special constructs in it,
3436 call the corresponding file handler. */
3437 handler
= Ffind_file_name_handler (b
->filename
,
3438 Qverify_visited_file_modtime
);
3439 if (!NILP (handler
))
3440 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
3442 if (stat (XSTRING (b
->filename
)->data
, &st
) < 0)
3444 /* If the file doesn't exist now and didn't exist before,
3445 we say that it isn't modified, provided the error is a tame one. */
3446 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
3451 if (st
.st_mtime
== b
->modtime
3452 /* If both are positive, accept them if they are off by one second. */
3453 || (st
.st_mtime
> 0 && b
->modtime
> 0
3454 && (st
.st_mtime
== b
->modtime
+ 1
3455 || st
.st_mtime
== b
->modtime
- 1)))
3460 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
3461 Sclear_visited_file_modtime
, 0, 0, 0,
3462 "Clear out records of last mod time of visited file.\n\
3463 Next attempt to save will certainly not complain of a discrepancy.")
3466 current_buffer
->modtime
= 0;
3470 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
3471 Svisited_file_modtime
, 0, 0, 0,
3472 "Return the current buffer's recorded visited file modification time.\n\
3473 The value is a list of the form (HIGH . LOW), like the time values\n\
3474 that `file-attributes' returns.")
3477 return long_to_cons (current_buffer
->modtime
);
3480 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
3481 Sset_visited_file_modtime
, 0, 1, 0,
3482 "Update buffer's recorded modification time from the visited file's time.\n\
3483 Useful if the buffer was not read from the file normally\n\
3484 or if the file itself has been changed for some known benign reason.\n\
3485 An argument specifies the modification time value to use\n\
3486 \(instead of that of the visited file), in the form of a list\n\
3487 \(HIGH . LOW) or (HIGH LOW).")
3489 Lisp_Object time_list
;
3491 if (!NILP (time_list
))
3492 current_buffer
->modtime
= cons_to_long (time_list
);
3495 register Lisp_Object filename
;
3497 Lisp_Object handler
;
3499 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
3501 /* If the file name has special constructs in it,
3502 call the corresponding file handler. */
3503 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
3504 if (!NILP (handler
))
3505 /* The handler can find the file name the same way we did. */
3506 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
3507 else if (stat (XSTRING (filename
)->data
, &st
) >= 0)
3508 current_buffer
->modtime
= st
.st_mtime
;
3517 unsigned char *name
= XSTRING (current_buffer
->name
)->data
;
3520 message ("Autosaving...error for %s", name
);
3521 Fsleep_for (make_number (1), Qnil
);
3522 message ("Autosaving...error!for %s", name
);
3523 Fsleep_for (make_number (1), Qnil
);
3524 message ("Autosaving...error for %s", name
);
3525 Fsleep_for (make_number (1), Qnil
);
3535 /* Get visited file's mode to become the auto save file's mode. */
3536 if (stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
3537 /* But make sure we can overwrite it later! */
3538 auto_save_mode_bits
= st
.st_mode
| 0600;
3540 auto_save_mode_bits
= 0666;
3543 Fwrite_region (Qnil
, Qnil
,
3544 current_buffer
->auto_save_file_name
,
3549 do_auto_save_unwind (desc
) /* used as unwind-protect function */
3552 close (XINT (desc
));
3556 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
3557 "Auto-save all buffers that need it.\n\
3558 This is all buffers that have auto-saving enabled\n\
3559 and are changed since last auto-saved.\n\
3560 Auto-saving writes the buffer into a file\n\
3561 so that your editing is not lost if the system crashes.\n\
3562 This file is not the file you visited; that changes only when you save.\n\
3563 Normally we run the normal hook `auto-save-hook' before saving.\n\n\
3564 Non-nil first argument means do not print any message if successful.\n\
3565 Non-nil second argument means save only current buffer.")
3566 (no_message
, current_only
)
3567 Lisp_Object no_message
, current_only
;
3569 struct buffer
*old
= current_buffer
, *b
;
3570 Lisp_Object tail
, buf
;
3572 char *omessage
= echo_area_glyphs
;
3573 int omessage_length
= echo_area_glyphs_length
;
3574 extern int minibuf_level
;
3575 int do_handled_files
;
3578 Lisp_Object lispstream
;
3579 int count
= specpdl_ptr
- specpdl
;
3582 /* Ordinarily don't quit within this function,
3583 but don't make it impossible to quit (in case we get hung in I/O). */
3587 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
3588 point to non-strings reached from Vbuffer_alist. */
3594 if (!NILP (Vrun_hooks
))
3595 call1 (Vrun_hooks
, intern ("auto-save-hook"));
3597 if (STRINGP (Vauto_save_list_file_name
))
3600 listdesc
= open (XSTRING (Vauto_save_list_file_name
)->data
,
3601 O_WRONLY
| O_TRUNC
| O_CREAT
| O_TEXT
,
3602 S_IREAD
| S_IWRITE
);
3603 #else /* not MSDOS */
3604 listdesc
= creat (XSTRING (Vauto_save_list_file_name
)->data
, 0666);
3605 #endif /* not MSDOS */
3610 /* Arrange to close that file whether or not we get an error. */
3612 record_unwind_protect (do_auto_save_unwind
, make_number (listdesc
));
3614 /* First, save all files which don't have handlers. If Emacs is
3615 crashing, the handlers may tweak what is causing Emacs to crash
3616 in the first place, and it would be a shame if Emacs failed to
3617 autosave perfectly ordinary files because it couldn't handle some
3619 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
3620 for (tail
= Vbuffer_alist
; XGCTYPE (tail
) == Lisp_Cons
;
3621 tail
= XCONS (tail
)->cdr
)
3623 buf
= XCONS (XCONS (tail
)->car
)->cdr
;
3626 /* Record all the buffers that have auto save mode
3627 in the special file that lists them. */
3628 if (XTYPE (b
->auto_save_file_name
) == Lisp_String
3629 && listdesc
>= 0 && do_handled_files
== 0)
3631 write (listdesc
, XSTRING (b
->auto_save_file_name
)->data
,
3632 XSTRING (b
->auto_save_file_name
)->size
);
3633 write (listdesc
, "\n", 1);
3636 if (!NILP (current_only
)
3637 && b
!= current_buffer
)
3640 /* Check for auto save enabled
3641 and file changed since last auto save
3642 and file changed since last real save. */
3643 if (XTYPE (b
->auto_save_file_name
) == Lisp_String
3644 && b
->save_modified
< BUF_MODIFF (b
)
3645 && b
->auto_save_modified
< BUF_MODIFF (b
)
3646 /* -1 means we've turned off autosaving for a while--see below. */
3647 && XINT (b
->save_length
) >= 0
3648 && (do_handled_files
3649 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
3652 EMACS_TIME before_time
, after_time
;
3654 EMACS_GET_TIME (before_time
);
3656 /* If we had a failure, don't try again for 20 minutes. */
3657 if (b
->auto_save_failure_time
>= 0
3658 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
3661 if ((XFASTINT (b
->save_length
) * 10
3662 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
3663 /* A short file is likely to change a large fraction;
3664 spare the user annoying messages. */
3665 && XFASTINT (b
->save_length
) > 5000
3666 /* These messages are frequent and annoying for `*mail*'. */
3667 && !EQ (b
->filename
, Qnil
)
3668 && NILP (no_message
))
3670 /* It has shrunk too much; turn off auto-saving here. */
3671 message ("Buffer %s has shrunk a lot; auto save turned off there",
3672 XSTRING (b
->name
)->data
);
3673 /* Turn off auto-saving until there's a real save,
3674 and prevent any more warnings. */
3675 XSET (b
->save_length
, Lisp_Int
, -1);
3676 Fsleep_for (make_number (1), Qnil
);
3679 set_buffer_internal (b
);
3680 if (!auto_saved
&& NILP (no_message
))
3681 message1 ("Auto-saving...");
3682 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
3684 b
->auto_save_modified
= BUF_MODIFF (b
);
3685 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3686 set_buffer_internal (old
);
3688 EMACS_GET_TIME (after_time
);
3690 /* If auto-save took more than 60 seconds,
3691 assume it was an NFS failure that got a timeout. */
3692 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
3693 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
3697 /* Prevent another auto save till enough input events come in. */
3698 record_auto_save ();
3700 if (auto_saved
&& NILP (no_message
))
3703 message2 (omessage
, omessage_length
);
3705 message1 ("Auto-saving...done");
3711 unbind_to (count
, Qnil
);
3715 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
3716 Sset_buffer_auto_saved
, 0, 0, 0,
3717 "Mark current buffer as auto-saved with its current text.\n\
3718 No auto-save file will be written until the buffer changes again.")
3721 current_buffer
->auto_save_modified
= MODIFF
;
3722 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3723 current_buffer
->auto_save_failure_time
= -1;
3727 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
3728 Sclear_buffer_auto_save_failure
, 0, 0, 0,
3729 "Clear any record of a recent auto-save failure in the current buffer.")
3732 current_buffer
->auto_save_failure_time
= -1;
3736 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
3738 "Return t if buffer has been auto-saved since last read in or saved.")
3741 return (current_buffer
->save_modified
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
3744 /* Reading and completing file names */
3745 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
3747 /* In the string VAL, change each $ to $$ and return the result. */
3750 double_dollars (val
)
3753 register unsigned char *old
, *new;
3757 osize
= XSTRING (val
)->size
;
3758 /* Quote "$" as "$$" to get it past substitute-in-file-name */
3759 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
3760 if (*old
++ == '$') count
++;
3763 old
= XSTRING (val
)->data
;
3764 val
= Fmake_string (make_number (osize
+ count
), make_number (0));
3765 new = XSTRING (val
)->data
;
3766 for (n
= osize
; n
> 0; n
--)
3779 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
3781 "Internal subroutine for read-file-name. Do not call this.")
3782 (string
, dir
, action
)
3783 Lisp_Object string
, dir
, action
;
3784 /* action is nil for complete, t for return list of completions,
3785 lambda for verify final value */
3787 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
3789 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3796 /* No need to protect ACTION--we only compare it with t and nil. */
3797 GCPRO4 (string
, realdir
, name
, specdir
);
3799 if (XSTRING (string
)->size
== 0)
3801 if (EQ (action
, Qlambda
))
3809 orig_string
= string
;
3810 string
= Fsubstitute_in_file_name (string
);
3811 changed
= NILP (Fstring_equal (string
, orig_string
));
3812 name
= Ffile_name_nondirectory (string
);
3813 val
= Ffile_name_directory (string
);
3815 realdir
= Fexpand_file_name (val
, realdir
);
3820 specdir
= Ffile_name_directory (string
);
3821 val
= Ffile_name_completion (name
, realdir
);
3823 if (XTYPE (val
) != Lisp_String
)
3830 if (!NILP (specdir
))
3831 val
= concat2 (specdir
, val
);
3833 return double_dollars (val
);
3836 #endif /* not VMS */
3840 if (EQ (action
, Qt
))
3841 return Ffile_name_all_completions (name
, realdir
);
3842 /* Only other case actually used is ACTION = lambda */
3844 /* Supposedly this helps commands such as `cd' that read directory names,
3845 but can someone explain how it helps them? -- RMS */
3846 if (XSTRING (name
)->size
== 0)
3849 return Ffile_exists_p (string
);
3852 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
3853 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
3854 Value is not expanded---you must call `expand-file-name' yourself.\n\
3855 Default name to DEFAULT if user enters a null string.\n\
3856 (If DEFAULT is omitted, the visited file name is used.)\n\
3857 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
3858 Non-nil and non-t means also require confirmation after completion.\n\
3859 Fifth arg INITIAL specifies text to start with.\n\
3860 DIR defaults to current buffer's directory default.")
3861 (prompt
, dir
, defalt
, mustmatch
, initial
)
3862 Lisp_Object prompt
, dir
, defalt
, mustmatch
, initial
;
3864 Lisp_Object val
, insdef
, insdef1
, tem
;
3865 struct gcpro gcpro1
, gcpro2
;
3866 register char *homedir
;
3870 dir
= current_buffer
->directory
;
3872 defalt
= current_buffer
->filename
;
3874 /* If dir starts with user's homedir, change that to ~. */
3875 homedir
= (char *) egetenv ("HOME");
3877 && XTYPE (dir
) == Lisp_String
3878 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
3879 && XSTRING (dir
)->data
[strlen (homedir
)] == '/')
3881 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
3882 XSTRING (dir
)->size
- strlen (homedir
) + 1);
3883 XSTRING (dir
)->data
[0] = '~';
3886 if (insert_default_directory
)
3889 if (!NILP (initial
))
3891 Lisp_Object args
[2], pos
;
3895 insdef
= Fconcat (2, args
);
3896 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
3897 insdef1
= Fcons (double_dollars (insdef
), pos
);
3900 insdef1
= double_dollars (insdef
);
3902 else if (!NILP (initial
))
3905 insdef1
= Fcons (double_dollars (insdef
), 0);
3908 insdef
= Qnil
, insdef1
= Qnil
;
3911 count
= specpdl_ptr
- specpdl
;
3912 specbind (intern ("completion-ignore-case"), Qt
);
3915 GCPRO2 (insdef
, defalt
);
3916 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
3917 dir
, mustmatch
, insdef1
,
3918 Qfile_name_history
);
3921 unbind_to (count
, Qnil
);
3926 error ("No file name specified");
3927 tem
= Fstring_equal (val
, insdef
);
3928 if (!NILP (tem
) && !NILP (defalt
))
3930 if (XSTRING (val
)->size
== 0 && NILP (insdef
))
3935 error ("No default file name");
3937 return Fsubstitute_in_file_name (val
);
3940 #if 0 /* Old version */
3941 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
3942 /* Don't confuse make-docfile by having two doc strings for this function.
3943 make-docfile does not pay attention to #if, for good reason! */
3945 (prompt
, dir
, defalt
, mustmatch
, initial
)
3946 Lisp_Object prompt
, dir
, defalt
, mustmatch
, initial
;
3948 Lisp_Object val
, insdef
, tem
;
3949 struct gcpro gcpro1
, gcpro2
;
3950 register char *homedir
;
3954 dir
= current_buffer
->directory
;
3956 defalt
= current_buffer
->filename
;
3958 /* If dir starts with user's homedir, change that to ~. */
3959 homedir
= (char *) egetenv ("HOME");
3961 && XTYPE (dir
) == Lisp_String
3962 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
3963 && XSTRING (dir
)->data
[strlen (homedir
)] == '/')
3965 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
3966 XSTRING (dir
)->size
- strlen (homedir
) + 1);
3967 XSTRING (dir
)->data
[0] = '~';
3970 if (!NILP (initial
))
3972 else if (insert_default_directory
)
3975 insdef
= build_string ("");
3978 count
= specpdl_ptr
- specpdl
;
3979 specbind (intern ("completion-ignore-case"), Qt
);
3982 GCPRO2 (insdef
, defalt
);
3983 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
3985 insert_default_directory
? insdef
: Qnil
,
3986 Qfile_name_history
);
3989 unbind_to (count
, Qnil
);
3994 error ("No file name specified");
3995 tem
= Fstring_equal (val
, insdef
);
3996 if (!NILP (tem
) && !NILP (defalt
))
3998 return Fsubstitute_in_file_name (val
);
4000 #endif /* Old version */
4004 Qexpand_file_name
= intern ("expand-file-name");
4005 Qdirectory_file_name
= intern ("directory-file-name");
4006 Qfile_name_directory
= intern ("file-name-directory");
4007 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
4008 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
4009 Qfile_name_as_directory
= intern ("file-name-as-directory");
4010 Qcopy_file
= intern ("copy-file");
4011 Qmake_directory_internal
= intern ("make-directory-internal");
4012 Qdelete_directory
= intern ("delete-directory");
4013 Qdelete_file
= intern ("delete-file");
4014 Qrename_file
= intern ("rename-file");
4015 Qadd_name_to_file
= intern ("add-name-to-file");
4016 Qmake_symbolic_link
= intern ("make-symbolic-link");
4017 Qfile_exists_p
= intern ("file-exists-p");
4018 Qfile_executable_p
= intern ("file-executable-p");
4019 Qfile_readable_p
= intern ("file-readable-p");
4020 Qfile_symlink_p
= intern ("file-symlink-p");
4021 Qfile_writable_p
= intern ("file-writable-p");
4022 Qfile_directory_p
= intern ("file-directory-p");
4023 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
4024 Qfile_modes
= intern ("file-modes");
4025 Qset_file_modes
= intern ("set-file-modes");
4026 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
4027 Qinsert_file_contents
= intern ("insert-file-contents");
4028 Qwrite_region
= intern ("write-region");
4029 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
4030 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
4032 staticpro (&Qexpand_file_name
);
4033 staticpro (&Qdirectory_file_name
);
4034 staticpro (&Qfile_name_directory
);
4035 staticpro (&Qfile_name_nondirectory
);
4036 staticpro (&Qunhandled_file_name_directory
);
4037 staticpro (&Qfile_name_as_directory
);
4038 staticpro (&Qcopy_file
);
4039 staticpro (&Qmake_directory_internal
);
4040 staticpro (&Qdelete_directory
);
4041 staticpro (&Qdelete_file
);
4042 staticpro (&Qrename_file
);
4043 staticpro (&Qadd_name_to_file
);
4044 staticpro (&Qmake_symbolic_link
);
4045 staticpro (&Qfile_exists_p
);
4046 staticpro (&Qfile_executable_p
);
4047 staticpro (&Qfile_readable_p
);
4048 staticpro (&Qfile_symlink_p
);
4049 staticpro (&Qfile_writable_p
);
4050 staticpro (&Qfile_directory_p
);
4051 staticpro (&Qfile_accessible_directory_p
);
4052 staticpro (&Qfile_modes
);
4053 staticpro (&Qset_file_modes
);
4054 staticpro (&Qfile_newer_than_file_p
);
4055 staticpro (&Qinsert_file_contents
);
4056 staticpro (&Qwrite_region
);
4057 staticpro (&Qverify_visited_file_modtime
);
4059 Qfile_name_history
= intern ("file-name-history");
4060 Fset (Qfile_name_history
, Qnil
);
4061 staticpro (&Qfile_name_history
);
4063 Qfile_error
= intern ("file-error");
4064 staticpro (&Qfile_error
);
4065 Qfile_already_exists
= intern("file-already-exists");
4066 staticpro (&Qfile_already_exists
);
4069 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
4070 staticpro (&Qfind_buffer_file_type
);
4073 Qcar_less_than_car
= intern ("car-less-than-car");
4074 staticpro (&Qcar_less_than_car
);
4076 Fput (Qfile_error
, Qerror_conditions
,
4077 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
4078 Fput (Qfile_error
, Qerror_message
,
4079 build_string ("File error"));
4081 Fput (Qfile_already_exists
, Qerror_conditions
,
4082 Fcons (Qfile_already_exists
,
4083 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
4084 Fput (Qfile_already_exists
, Qerror_message
,
4085 build_string ("File already exists"));
4087 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
4088 "*Non-nil means when reading a filename start with default dir in minibuffer.");
4089 insert_default_directory
= 1;
4091 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
4092 "*Non-nil means write new files with record format `stmlf'.\n\
4093 nil means use format `var'. This variable is meaningful only on VMS.");
4094 vms_stmlf_recfm
= 0;
4096 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
4097 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
4098 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
4101 The first argument given to HANDLER is the name of the I/O primitive\n\
4102 to be handled; the remaining arguments are the arguments that were\n\
4103 passed to that primitive. For example, if you do\n\
4104 (file-exists-p FILENAME)\n\
4105 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
4106 (funcall HANDLER 'file-exists-p FILENAME)\n\
4107 The function `find-file-name-handler' checks this list for a handler\n\
4108 for its argument.");
4109 Vfile_name_handler_alist
= Qnil
;
4111 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
4112 "A list of functions to be called at the end of `insert-file-contents'.\n\
4113 Each is passed one argument, the number of bytes inserted. It should return\n\
4114 the new byte count, and leave point the same. If `insert-file-contents' is\n\
4115 intercepted by a handler from `file-name-handler-alist', that handler is\n\
4116 responsible for calling the after-insert-file-functions if appropriate.");
4117 Vafter_insert_file_functions
= Qnil
;
4119 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
4120 "A list of functions to be called at the start of `write-region'.\n\
4121 Each is passed two arguments, START and END as for `write-region'. It should\n\
4122 return a list of pairs (POSITION . STRING) of strings to be effectively\n\
4123 inserted at the specified positions of the file being written (1 means to\n\
4124 insert before the first byte written). The POSITIONs must be sorted into\n\
4125 increasing order. If there are several functions in the list, the several\n\
4126 lists are merged destructively.");
4127 Vwrite_region_annotate_functions
= Qnil
;
4129 DEFVAR_LISP ("write-region-annotations-so-far",
4130 &Vwrite_region_annotations_so_far
,
4131 "When an annotation function is called, this holds the previous annotations.\n\
4132 These are the annotations made by other annotation functions\n\
4133 that were already called. See also `write-region-annotate-functions'.");
4134 Vwrite_region_annotations_so_far
= Qnil
;
4136 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
4137 "A list of file name handlers that temporarily should not be used.\n\
4138 This applies only to the operation `inhibit-file-name-operation'.");
4139 Vinhibit_file_name_handlers
= Qnil
;
4141 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
4142 "The operation for which `inhibit-file-name-handlers' is applicable.");
4143 Vinhibit_file_name_operation
= Qnil
;
4145 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
4146 "File name in which we write a list of all auto save file names.");
4147 Vauto_save_list_file_name
= Qnil
;
4149 defsubr (&Sfind_file_name_handler
);
4150 defsubr (&Sfile_name_directory
);
4151 defsubr (&Sfile_name_nondirectory
);
4152 defsubr (&Sunhandled_file_name_directory
);
4153 defsubr (&Sfile_name_as_directory
);
4154 defsubr (&Sdirectory_file_name
);
4155 defsubr (&Smake_temp_name
);
4156 defsubr (&Sexpand_file_name
);
4157 defsubr (&Ssubstitute_in_file_name
);
4158 defsubr (&Scopy_file
);
4159 defsubr (&Smake_directory_internal
);
4160 defsubr (&Sdelete_directory
);
4161 defsubr (&Sdelete_file
);
4162 defsubr (&Srename_file
);
4163 defsubr (&Sadd_name_to_file
);
4165 defsubr (&Smake_symbolic_link
);
4166 #endif /* S_IFLNK */
4168 defsubr (&Sdefine_logical_name
);
4171 defsubr (&Ssysnetunam
);
4172 #endif /* HPUX_NET */
4173 defsubr (&Sfile_name_absolute_p
);
4174 defsubr (&Sfile_exists_p
);
4175 defsubr (&Sfile_executable_p
);
4176 defsubr (&Sfile_readable_p
);
4177 defsubr (&Sfile_writable_p
);
4178 defsubr (&Sfile_symlink_p
);
4179 defsubr (&Sfile_directory_p
);
4180 defsubr (&Sfile_accessible_directory_p
);
4181 defsubr (&Sfile_modes
);
4182 defsubr (&Sset_file_modes
);
4183 defsubr (&Sset_default_file_modes
);
4184 defsubr (&Sdefault_file_modes
);
4185 defsubr (&Sfile_newer_than_file_p
);
4186 defsubr (&Sinsert_file_contents
);
4187 defsubr (&Swrite_region
);
4188 defsubr (&Scar_less_than_car
);
4189 defsubr (&Sverify_visited_file_modtime
);
4190 defsubr (&Sclear_visited_file_modtime
);
4191 defsubr (&Svisited_file_modtime
);
4192 defsubr (&Sset_visited_file_modtime
);
4193 defsubr (&Sdo_auto_save
);
4194 defsubr (&Sset_buffer_auto_saved
);
4195 defsubr (&Sclear_buffer_auto_save_failure
);
4196 defsubr (&Srecent_auto_save_p
);
4198 defsubr (&Sread_file_name_internal
);
4199 defsubr (&Sread_file_name
);
4202 defsubr (&Sunix_sync
);