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"
108 #define min(a, b) ((a) < (b) ? (a) : (b))
109 #define max(a, b) ((a) > (b) ? (a) : (b))
111 /* Nonzero during writing of auto-save files */
114 /* Set by auto_save_1 to mode of original file so Fwrite_region will create
115 a new file with the same mode as the original */
116 int auto_save_mode_bits
;
118 /* Alist of elements (REGEXP . HANDLER) for file names
119 whose I/O is done with a special handler. */
120 Lisp_Object Vfile_name_handler_alist
;
122 /* Functions to be called to process text properties in inserted file. */
123 Lisp_Object Vafter_insert_file_functions
;
125 /* Functions to be called to create text property annotations for file. */
126 Lisp_Object Vwrite_region_annotate_functions
;
128 /* During build_annotations, each time an annotation function is called,
129 this holds the annotations made by the previous functions. */
130 Lisp_Object Vwrite_region_annotations_so_far
;
132 /* File name in which we write a list of all our auto save files. */
133 Lisp_Object Vauto_save_list_file_name
;
135 /* Nonzero means, when reading a filename in the minibuffer,
136 start out by inserting the default directory into the minibuffer. */
137 int insert_default_directory
;
139 /* On VMS, nonzero means write new files with record format stmlf.
140 Zero means use var format. */
143 /* These variables describe handlers that have "already" had a chance
144 to handle the current operation.
146 Vinhibit_file_name_handlers is a list of file name handlers.
147 Vinhibit_file_name_operation is the operation being handled.
148 If we try to handle that operation, we ignore those handlers. */
150 static Lisp_Object Vinhibit_file_name_handlers
;
151 static Lisp_Object Vinhibit_file_name_operation
;
153 Lisp_Object Qfile_error
, Qfile_already_exists
;
155 Lisp_Object Qfile_name_history
;
157 Lisp_Object Qcar_less_than_car
;
159 report_file_error (string
, data
)
163 Lisp_Object errstring
;
165 errstring
= build_string (strerror (errno
));
167 /* System error messages are capitalized. Downcase the initial
168 unless it is followed by a slash. */
169 if (XSTRING (errstring
)->data
[1] != '/')
170 XSTRING (errstring
)->data
[0] = DOWNCASE (XSTRING (errstring
)->data
[0]);
173 Fsignal (Qfile_error
,
174 Fcons (build_string (string
), Fcons (errstring
, data
)));
177 close_file_unwind (fd
)
180 close (XFASTINT (fd
));
183 /* Restore point, having saved it as a marker. */
185 restore_point_unwind (location
)
186 Lisp_Object location
;
188 SET_PT (marker_position (location
));
189 Fset_marker (location
, Qnil
, Qnil
);
192 Lisp_Object Qexpand_file_name
;
193 Lisp_Object Qdirectory_file_name
;
194 Lisp_Object Qfile_name_directory
;
195 Lisp_Object Qfile_name_nondirectory
;
196 Lisp_Object Qunhandled_file_name_directory
;
197 Lisp_Object Qfile_name_as_directory
;
198 Lisp_Object Qcopy_file
;
199 Lisp_Object Qmake_directory_internal
;
200 Lisp_Object Qdelete_directory
;
201 Lisp_Object Qdelete_file
;
202 Lisp_Object Qrename_file
;
203 Lisp_Object Qadd_name_to_file
;
204 Lisp_Object Qmake_symbolic_link
;
205 Lisp_Object Qfile_exists_p
;
206 Lisp_Object Qfile_executable_p
;
207 Lisp_Object Qfile_readable_p
;
208 Lisp_Object Qfile_symlink_p
;
209 Lisp_Object Qfile_writable_p
;
210 Lisp_Object Qfile_directory_p
;
211 Lisp_Object Qfile_accessible_directory_p
;
212 Lisp_Object Qfile_modes
;
213 Lisp_Object Qset_file_modes
;
214 Lisp_Object Qfile_newer_than_file_p
;
215 Lisp_Object Qinsert_file_contents
;
216 Lisp_Object Qwrite_region
;
217 Lisp_Object Qverify_visited_file_modtime
;
218 Lisp_Object Qset_visited_file_modtime
;
220 DEFUN ("find-file-name-handler", Ffind_file_name_handler
, Sfind_file_name_handler
, 2, 2, 0,
221 "Return FILENAME's handler function for OPERATION, if it has one.\n\
222 Otherwise, return nil.\n\
223 A file name is handled if one of the regular expressions in\n\
224 `file-name-handler-alist' matches it.\n\n\
225 If OPERATION equals `inhibit-file-name-operation', then we ignore\n\
226 any handlers that are members of `inhibit-file-name-handlers',\n\
227 but we still do run any other handlers. This lets handlers\n\
228 use the standard functions without calling themselves recursively.")
229 (filename
, operation
)
230 Lisp_Object filename
, operation
;
232 /* This function must not munge the match data. */
233 Lisp_Object chain
, inhibited_handlers
;
235 CHECK_STRING (filename
, 0);
237 if (EQ (operation
, Vinhibit_file_name_operation
))
238 inhibited_handlers
= Vinhibit_file_name_handlers
;
240 inhibited_handlers
= Qnil
;
242 for (chain
= Vfile_name_handler_alist
; XTYPE (chain
) == Lisp_Cons
;
243 chain
= XCONS (chain
)->cdr
)
246 elt
= XCONS (chain
)->car
;
247 if (XTYPE (elt
) == Lisp_Cons
)
250 string
= XCONS (elt
)->car
;
251 if (XTYPE (string
) == Lisp_String
252 && fast_string_match (string
, filename
) >= 0)
254 Lisp_Object handler
, tem
;
256 handler
= XCONS (elt
)->cdr
;
257 tem
= Fmemq (handler
, inhibited_handlers
);
268 DEFUN ("file-name-directory", Ffile_name_directory
, Sfile_name_directory
,
270 "Return the directory component in file name NAME.\n\
271 Return nil if NAME does not include a directory.\n\
272 Otherwise return a directory spec.\n\
273 Given a Unix syntax file name, returns a string ending in slash;\n\
274 on VMS, perhaps instead a string ending in `:', `]' or `>'.")
278 register unsigned char *beg
;
279 register unsigned char *p
;
282 CHECK_STRING (file
, 0);
284 /* If the file name has special constructs in it,
285 call the corresponding file handler. */
286 handler
= Ffind_file_name_handler (file
, Qfile_name_directory
);
288 return call2 (handler
, Qfile_name_directory
, file
);
290 #ifdef FILE_SYSTEM_CASE
291 file
= FILE_SYSTEM_CASE (file
);
293 beg
= XSTRING (file
)->data
;
294 p
= beg
+ XSTRING (file
)->size
;
296 while (p
!= beg
&& p
[-1] != '/'
298 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
301 && p
[-1] != ':' && p
[-1] != '\\'
308 /* Expansion of "c:" to drive and default directory. */
309 if (p
== beg
+ 2 && beg
[1] == ':')
311 int drive
= (*beg
) - 'a';
312 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
313 unsigned char *res
= alloca (MAXPATHLEN
+ 5);
314 if (getdefdir (drive
+ 1, res
+ 2))
316 res
[0] = drive
+ 'a';
318 if (res
[strlen (res
) - 1] != '/')
321 p
= beg
+ strlen (beg
);
325 return make_string (beg
, p
- beg
);
328 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory
, Sfile_name_nondirectory
,
330 "Return file name NAME sans its directory.\n\
331 For example, in a Unix-syntax file name,\n\
332 this is everything after the last slash,\n\
333 or the entire name if it contains no slash.")
337 register unsigned char *beg
, *p
, *end
;
340 CHECK_STRING (file
, 0);
342 /* If the file name has special constructs in it,
343 call the corresponding file handler. */
344 handler
= Ffind_file_name_handler (file
, Qfile_name_nondirectory
);
346 return call2 (handler
, Qfile_name_nondirectory
, file
);
348 beg
= XSTRING (file
)->data
;
349 end
= p
= beg
+ XSTRING (file
)->size
;
351 while (p
!= beg
&& p
[-1] != '/'
353 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
356 && p
[-1] != ':' && p
[-1] != '\\'
360 return make_string (p
, end
- p
);
363 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory
, Sunhandled_file_name_directory
, 1, 1, 0,
364 "Return a directly usable directory name somehow associated with FILENAME.\n\
365 A `directly usable' directory name is one that may be used without the\n\
366 intervention of any file handler.\n\
367 If FILENAME is a directly usable file itself, return\n\
368 (file-name-directory FILENAME).\n\
369 The `call-process' and `start-process' functions use this function to\n\
370 get a current directory to run processes in.")
372 Lisp_Object filename
;
376 /* If the file name has special constructs in it,
377 call the corresponding file handler. */
378 handler
= Ffind_file_name_handler (filename
, Qunhandled_file_name_directory
);
380 return call2 (handler
, Qunhandled_file_name_directory
, filename
);
382 return Ffile_name_directory (filename
);
387 file_name_as_directory (out
, in
)
390 int size
= strlen (in
) - 1;
395 /* Is it already a directory string? */
396 if (in
[size
] == ':' || in
[size
] == ']' || in
[size
] == '>')
398 /* Is it a VMS directory file name? If so, hack VMS syntax. */
399 else if (! index (in
, '/')
400 && ((size
> 3 && ! strcmp (&in
[size
- 3], ".DIR"))
401 || (size
> 3 && ! strcmp (&in
[size
- 3], ".dir"))
402 || (size
> 5 && (! strncmp (&in
[size
- 5], ".DIR", 4)
403 || ! strncmp (&in
[size
- 5], ".dir", 4))
404 && (in
[size
- 1] == '.' || in
[size
- 1] == ';')
405 && in
[size
] == '1')))
407 register char *p
, *dot
;
411 dir:x.dir --> dir:[x]
412 dir:[x]y.dir --> dir:[x.y] */
414 while (p
!= in
&& *p
!= ':' && *p
!= '>' && *p
!= ']') p
--;
417 strncpy (out
, in
, p
- in
);
436 dot
= index (p
, '.');
439 /* blindly remove any extension */
440 size
= strlen (out
) + (dot
- p
);
441 strncat (out
, p
, dot
- p
);
452 /* For Unix syntax, Append a slash if necessary */
454 if (out
[size
] != ':' && out
[size
] != '/' && out
[size
] != '\\')
456 if (out
[size
] != '/')
463 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
464 Sfile_name_as_directory
, 1, 1, 0,
465 "Return a string representing file FILENAME interpreted as a directory.\n\
466 This operation exists because a directory is also a file, but its name as\n\
467 a directory is different from its name as a file.\n\
468 The result can be used as the value of `default-directory'\n\
469 or passed as second argument to `expand-file-name'.\n\
470 For a Unix-syntax file name, just appends a slash.\n\
471 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
478 CHECK_STRING (file
, 0);
482 /* If the file name has special constructs in it,
483 call the corresponding file handler. */
484 handler
= Ffind_file_name_handler (file
, Qfile_name_as_directory
);
486 return call2 (handler
, Qfile_name_as_directory
, file
);
488 buf
= (char *) alloca (XSTRING (file
)->size
+ 10);
489 return build_string (file_name_as_directory (buf
, XSTRING (file
)->data
));
493 * Convert from directory name to filename.
495 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
496 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
497 * On UNIX, it's simple: just make sure there is a terminating /
499 * Value is nonzero if the string output is different from the input.
502 directory_file_name (src
, dst
)
510 struct FAB fab
= cc$rms_fab
;
511 struct NAM nam
= cc$rms_nam
;
512 char esa
[NAM$C_MAXRSS
];
517 if (! index (src
, '/')
518 && (src
[slen
- 1] == ']'
519 || src
[slen
- 1] == ':'
520 || src
[slen
- 1] == '>'))
522 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
524 fab
.fab$b_fns
= slen
;
525 fab
.fab$l_nam
= &nam
;
526 fab
.fab$l_fop
= FAB$M_NAM
;
529 nam
.nam$b_ess
= sizeof esa
;
530 nam
.nam$b_nop
|= NAM$M_SYNCHK
;
532 /* We call SYS$PARSE to handle such things as [--] for us. */
533 if (SYS$
PARSE(&fab
, 0, 0) == RMS$_NORMAL
)
535 slen
= nam
.nam$b_esl
;
536 if (esa
[slen
- 1] == ';' && esa
[slen
- 2] == '.')
541 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
543 /* what about when we have logical_name:???? */
544 if (src
[slen
- 1] == ':')
545 { /* Xlate logical name and see what we get */
546 ptr
= strcpy (dst
, src
); /* upper case for getenv */
549 if ('a' <= *ptr
&& *ptr
<= 'z')
553 dst
[slen
- 1] = 0; /* remove colon */
554 if (!(src
= egetenv (dst
)))
556 /* should we jump to the beginning of this procedure?
557 Good points: allows us to use logical names that xlate
559 Bad points: can be a problem if we just translated to a device
561 For now, I'll punt and always expect VMS names, and hope for
564 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
565 { /* no recursion here! */
571 { /* not a directory spec */
576 bracket
= src
[slen
- 1];
578 /* If bracket is ']' or '>', bracket - 2 is the corresponding
580 ptr
= index (src
, bracket
- 2);
582 { /* no opening bracket */
586 if (!(rptr
= rindex (src
, '.')))
589 strncpy (dst
, src
, slen
);
593 dst
[slen
++] = bracket
;
598 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
599 then translate the device and recurse. */
600 if (dst
[slen
- 1] == ':'
601 && dst
[slen
- 2] != ':' /* skip decnet nodes */
602 && strcmp(src
+ slen
, "[000000]") == 0)
604 dst
[slen
- 1] = '\0';
605 if ((ptr
= egetenv (dst
))
606 && (rlen
= strlen (ptr
) - 1) > 0
607 && (ptr
[rlen
] == ']' || ptr
[rlen
] == '>')
608 && ptr
[rlen
- 1] == '.')
610 char * buf
= (char *) alloca (strlen (ptr
) + 1);
614 return directory_file_name (buf
, dst
);
619 strcat (dst
, "[000000]");
623 rlen
= strlen (rptr
) - 1;
624 strncat (dst
, rptr
, rlen
);
625 dst
[slen
+ rlen
] = '\0';
626 strcat (dst
, ".DIR.1");
630 /* Process as Unix format: just remove any final slash.
631 But leave "/" unchanged; do not change it to "". */
635 && (dst
[slen
- 1] == '/' || dst
[slen
- 1] == '/')
636 && dst
[slen
- 2] != ':'
638 && dst
[slen
- 1] == '/'
645 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
647 "Returns the file name of the directory named DIR.\n\
648 This is the name of the file that holds the data for the directory DIR.\n\
649 This operation exists because a directory is also a file, but its name as\n\
650 a directory is different from its name as a file.\n\
651 In Unix-syntax, this function just removes the final slash.\n\
652 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
653 it returns a file name such as \"[X]Y.DIR.1\".")
655 Lisp_Object directory
;
660 CHECK_STRING (directory
, 0);
662 if (NILP (directory
))
665 /* If the file name has special constructs in it,
666 call the corresponding file handler. */
667 handler
= Ffind_file_name_handler (directory
, Qdirectory_file_name
);
669 return call2 (handler
, Qdirectory_file_name
, directory
);
672 /* 20 extra chars is insufficient for VMS, since we might perform a
673 logical name translation. an equivalence string can be up to 255
674 chars long, so grab that much extra space... - sss */
675 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20 + 255);
677 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20);
679 directory_file_name (XSTRING (directory
)->data
, buf
);
680 return build_string (buf
);
683 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
684 "Generate temporary file name (string) starting with PREFIX (a string).\n\
685 The Emacs process number forms part of the result,\n\
686 so there is no danger of generating a name being used by another process.")
691 val
= concat2 (prefix
, build_string ("XXXXXX"));
692 mktemp (XSTRING (val
)->data
);
696 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
697 "Convert FILENAME to absolute, and canonicalize it.\n\
698 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
699 (does not start with slash); if DEFAULT is nil or missing,\n\
700 the current buffer's value of default-directory is used.\n\
701 Path components that are `.' are removed, and \n\
702 path components followed by `..' are removed, along with the `..' itself;\n\
703 note that these simplifications are done without checking the resulting\n\
704 paths in the file system.\n\
705 An initial `~/' expands to your home directory.\n\
706 An initial `~USER/' expands to USER's home directory.\n\
707 See also the function `substitute-in-file-name'.")
709 Lisp_Object name
, defalt
;
713 register unsigned char *newdir
, *p
, *o
;
715 unsigned char *target
;
718 unsigned char * colon
= 0;
719 unsigned char * close
= 0;
720 unsigned char * slash
= 0;
721 unsigned char * brack
= 0;
722 int lbrack
= 0, rbrack
= 0;
725 #ifdef MSDOS /* Demacs 1.1.2 91/10/20 Manabu Higashida */
728 unsigned char *tmp
, *defdir
;
732 CHECK_STRING (name
, 0);
734 /* If the file name has special constructs in it,
735 call the corresponding file handler. */
736 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
738 return call3 (handler
, Qexpand_file_name
, name
, defalt
);
740 /* Use the buffer's default-directory if DEFALT is omitted. */
742 defalt
= current_buffer
->directory
;
743 CHECK_STRING (defalt
, 1);
745 /* Make sure DEFALT is properly expanded.
746 It would be better to do this down below where we actually use
747 defalt. Unfortunately, calling Fexpand_file_name recursively
748 could invoke GC, and the strings might be relocated. This would
749 be annoying because we have pointers into strings lying around
750 that would need adjusting, and people would add new pointers to
751 the code and forget to adjust them, resulting in intermittent bugs.
752 Putting this call here avoids all that crud.
754 The EQ test avoids infinite recursion. */
755 if (! NILP (defalt
) && !EQ (defalt
, name
)
756 /* This saves time in a common case. */
757 && XSTRING (defalt
)->data
[0] != '/')
762 defalt
= Fexpand_file_name (defalt
, Qnil
);
767 /* Filenames on VMS are always upper case. */
768 name
= Fupcase (name
);
770 #ifdef FILE_SYSTEM_CASE
771 name
= FILE_SYSTEM_CASE (name
);
774 nm
= XSTRING (name
)->data
;
777 /* First map all backslashes to slashes. */
778 dostounix_filename (nm
= strcpy (alloca (strlen (nm
) + 1), nm
));
780 /* Now strip drive name. */
782 unsigned char *colon
= rindex (nm
, ':');
788 drive
= tolower (colon
[-1]) - 'a';
792 defdir
= alloca (MAXPATHLEN
+ 1);
793 relpath
= getdefdir (drive
+ 1, defdir
);
799 /* If nm is absolute, flush ...// and detect /./ and /../.
800 If no /./ or /../ we can return right away. */
808 /* If it turns out that the filename we want to return is just a
809 suffix of FILENAME, we don't need to go through and edit
810 things; we just need to construct a new string using data
811 starting at the middle of FILENAME. If we set lose to a
812 non-zero value, that means we've discovered that we can't do
819 /* Since we know the path is absolute, we can assume that each
820 element starts with a "/". */
822 /* "//" anywhere isn't necessarily hairy; we just start afresh
823 with the second slash. */
824 if (p
[0] == '/' && p
[1] == '/'
826 /* // at start of filename is meaningful on Apollo system */
832 /* "~" is hairy as the start of any path element. */
833 if (p
[0] == '/' && p
[1] == '~')
834 nm
= p
+ 1, lose
= 1;
836 /* "." and ".." are hairy. */
841 || (p
[2] == '.' && (p
[3] == '/'
848 /* if dev:[dir]/, move nm to / */
849 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
850 nm
= (brack
? brack
+ 1 : colon
+ 1);
859 /* VMS pre V4.4,convert '-'s in filenames. */
860 if (lbrack
== rbrack
)
862 if (dots
< 2) /* this is to allow negative version numbers */
867 if (lbrack
> rbrack
&&
868 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
869 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
875 /* count open brackets, reset close bracket pointer */
876 if (p
[0] == '[' || p
[0] == '<')
878 /* count close brackets, set close bracket pointer */
879 if (p
[0] == ']' || p
[0] == '>')
881 /* detect ][ or >< */
882 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
884 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
885 nm
= p
+ 1, lose
= 1;
886 if (p
[0] == ':' && (colon
|| slash
))
887 /* if dev1:[dir]dev2:, move nm to dev2: */
893 /* if /pathname/dev:, move nm to dev: */
896 /* if node::dev:, move colon following dev */
897 else if (colon
&& colon
[-1] == ':')
899 /* if dev1:dev2:, move nm to dev2: */
900 else if (colon
&& colon
[-1] != ':')
905 if (p
[0] == ':' && !colon
)
911 if (lbrack
== rbrack
)
914 else if (p
[0] == '.')
923 return build_string (sys_translate_unix (nm
));
926 if (nm
== XSTRING (name
)->data
)
928 return build_string (nm
);
933 /* Now determine directory to start with and put it in newdir */
937 if (nm
[0] == '~') /* prefix ~ */
943 || nm
[1] == 0) /* ~ by itself */
945 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
946 newdir
= (unsigned char *) "";
948 dostounix_filename (newdir
);
952 nm
++; /* Don't leave the slash in nm. */
955 else /* ~user/filename */
957 for (p
= nm
; *p
&& (*p
!= '/'
962 o
= (unsigned char *) alloca (p
- nm
+ 1);
963 bcopy ((char *) nm
, o
, p
- nm
);
966 pw
= (struct passwd
*) getpwnam (o
+ 1);
969 newdir
= (unsigned char *) pw
-> pw_dir
;
971 nm
= p
+ 1; /* skip the terminator */
977 /* If we don't find a user of that name, leave the name
978 unchanged; don't move nm forward to p. */
991 newdir
= XSTRING (defalt
)->data
;
995 if (newdir
== 0 && relpath
)
1000 /* Get rid of any slash at the end of newdir. */
1001 int length
= strlen (newdir
);
1002 /* Adding `length > 1 &&' makes ~ expand into / when homedir
1003 is the root dir. People disagree about whether that is right.
1004 Anyway, we can't take the risk of this change now. */
1006 if (newdir
[1] != ':' && length
> 1)
1008 if (newdir
[length
- 1] == '/')
1010 unsigned char *temp
= (unsigned char *) alloca (length
);
1011 bcopy (newdir
, temp
, length
- 1);
1012 temp
[length
- 1] = 0;
1020 /* Now concatenate the directory and name to new space in the stack frame */
1021 tlen
+= strlen (nm
) + 1;
1023 /* Add reserved space for drive name. */
1024 target
= (unsigned char *) alloca (tlen
+ 2) + 2;
1026 target
= (unsigned char *) alloca (tlen
);
1033 if (nm
[0] == 0 || nm
[0] == '/')
1034 strcpy (target
, newdir
);
1037 file_name_as_directory (target
, newdir
);
1040 strcat (target
, nm
);
1042 if (index (target
, '/'))
1043 strcpy (target
, sys_translate_unix (target
));
1046 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1054 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1060 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1061 /* brackets are offset from each other by 2 */
1064 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1065 /* convert [foo][bar] to [bar] */
1066 while (o
[-1] != '[' && o
[-1] != '<')
1068 else if (*p
== '-' && *o
!= '.')
1071 else if (p
[0] == '-' && o
[-1] == '.' &&
1072 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1073 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1077 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1078 if (p
[1] == '.') /* foo.-.bar ==> bar*/
1080 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1082 /* else [foo.-] ==> [-] */
1088 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1089 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1099 else if (!strncmp (p
, "//", 2)
1101 /* // at start of filename is meaningful in Apollo system */
1109 else if (p
[0] == '/'
1114 /* If "/." is the entire filename, keep the "/". Otherwise,
1115 just delete the whole "/.". */
1116 if (o
== target
&& p
[2] == '\0')
1120 else if (!strncmp (p
, "/..", 3)
1121 /* `/../' is the "superroot" on certain file systems. */
1123 && (p
[3] == '/' || p
[3] == 0))
1125 while (o
!= target
&& *--o
!= '/')
1128 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1132 if (o
== target
&& *o
== '/')
1140 #endif /* not VMS */
1144 /* at last, set drive name. */
1145 if (target
[1] != ':')
1148 target
[0] = (drive
< 0 ? getdisk () : drive
) + 'a';
1153 return make_string (target
, o
- target
);
1156 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'.
1157 DEAFUN ("expand-file-name", Fexpand_file_name, Sexpand_file_name, 1, 2, 0,
1158 "Convert FILENAME to absolute, and canonicalize it.\n\
1159 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1160 (does not start with slash); if DEFAULT is nil or missing,\n\
1161 the current buffer's value of default-directory is used.\n\
1162 Filenames containing `.' or `..' as components are simplified;\n\
1163 initial `~/' expands to your home directory.\n\
1164 See also the function `substitute-in-file-name'.")
1166 Lisp_Object name, defalt;
1170 register unsigned char *newdir, *p, *o;
1172 unsigned char *target;
1176 unsigned char * colon = 0;
1177 unsigned char * close = 0;
1178 unsigned char * slash = 0;
1179 unsigned char * brack = 0;
1180 int lbrack = 0, rbrack = 0;
1184 CHECK_STRING (name
, 0);
1187 /* Filenames on VMS are always upper case. */
1188 name
= Fupcase (name
);
1191 nm
= XSTRING (name
)->data
;
1193 /* If nm is absolute, flush ...// and detect /./ and /../.
1194 If no /./ or /../ we can return right away. */
1206 if (p
[0] == '/' && p
[1] == '/'
1208 /* // at start of filename is meaningful on Apollo system */
1213 if (p
[0] == '/' && p
[1] == '~')
1214 nm
= p
+ 1, lose
= 1;
1215 if (p
[0] == '/' && p
[1] == '.'
1216 && (p
[2] == '/' || p
[2] == 0
1217 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1223 /* if dev:[dir]/, move nm to / */
1224 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1225 nm
= (brack
? brack
+ 1 : colon
+ 1);
1226 lbrack
= rbrack
= 0;
1234 /* VMS pre V4.4,convert '-'s in filenames. */
1235 if (lbrack
== rbrack
)
1237 if (dots
< 2) /* this is to allow negative version numbers */
1242 if (lbrack
> rbrack
&&
1243 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1244 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1250 /* count open brackets, reset close bracket pointer */
1251 if (p
[0] == '[' || p
[0] == '<')
1252 lbrack
++, brack
= 0;
1253 /* count close brackets, set close bracket pointer */
1254 if (p
[0] == ']' || p
[0] == '>')
1255 rbrack
++, brack
= p
;
1256 /* detect ][ or >< */
1257 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1259 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1260 nm
= p
+ 1, lose
= 1;
1261 if (p
[0] == ':' && (colon
|| slash
))
1262 /* if dev1:[dir]dev2:, move nm to dev2: */
1268 /* if /pathname/dev:, move nm to dev: */
1271 /* if node::dev:, move colon following dev */
1272 else if (colon
&& colon
[-1] == ':')
1274 /* if dev1:dev2:, move nm to dev2: */
1275 else if (colon
&& colon
[-1] != ':')
1280 if (p
[0] == ':' && !colon
)
1286 if (lbrack
== rbrack
)
1289 else if (p
[0] == '.')
1297 if (index (nm
, '/'))
1298 return build_string (sys_translate_unix (nm
));
1300 if (nm
== XSTRING (name
)->data
)
1302 return build_string (nm
);
1306 /* Now determine directory to start with and put it in NEWDIR */
1310 if (nm
[0] == '~') /* prefix ~ */
1315 || nm
[1] == 0)/* ~/filename */
1317 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1318 newdir
= (unsigned char *) "";
1321 nm
++; /* Don't leave the slash in nm. */
1324 else /* ~user/filename */
1326 /* Get past ~ to user */
1327 unsigned char *user
= nm
+ 1;
1328 /* Find end of name. */
1329 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1330 int len
= ptr
? ptr
- user
: strlen (user
);
1332 unsigned char *ptr1
= index (user
, ':');
1333 if (ptr1
!= 0 && ptr1
- user
< len
)
1336 /* Copy the user name into temp storage. */
1337 o
= (unsigned char *) alloca (len
+ 1);
1338 bcopy ((char *) user
, o
, len
);
1341 /* Look up the user name. */
1342 pw
= (struct passwd
*) getpwnam (o
+ 1);
1344 error ("\"%s\" isn't a registered user", o
+ 1);
1346 newdir
= (unsigned char *) pw
->pw_dir
;
1348 /* Discard the user name from NM. */
1355 #endif /* not VMS */
1359 defalt
= current_buffer
->directory
;
1360 CHECK_STRING (defalt
, 1);
1361 newdir
= XSTRING (defalt
)->data
;
1364 /* Now concatenate the directory and name to new space in the stack frame */
1366 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1367 target
= (unsigned char *) alloca (tlen
);
1373 if (nm
[0] == 0 || nm
[0] == '/')
1374 strcpy (target
, newdir
);
1377 file_name_as_directory (target
, newdir
);
1380 strcat (target
, nm
);
1382 if (index (target
, '/'))
1383 strcpy (target
, sys_translate_unix (target
));
1386 /* Now canonicalize by removing /. and /foo/.. if they appear */
1394 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1400 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1401 /* brackets are offset from each other by 2 */
1404 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1405 /* convert [foo][bar] to [bar] */
1406 while (o
[-1] != '[' && o
[-1] != '<')
1408 else if (*p
== '-' && *o
!= '.')
1411 else if (p
[0] == '-' && o
[-1] == '.' &&
1412 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1413 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1417 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1418 if (p
[1] == '.') /* foo.-.bar ==> bar*/
1420 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1422 /* else [foo.-] ==> [-] */
1428 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1429 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1439 else if (!strncmp (p
, "//", 2)
1441 /* // at start of filename is meaningful in Apollo system */
1449 else if (p
[0] == '/' && p
[1] == '.' &&
1450 (p
[2] == '/' || p
[2] == 0))
1452 else if (!strncmp (p
, "/..", 3)
1453 /* `/../' is the "superroot" on certain file systems. */
1455 && (p
[3] == '/' || p
[3] == 0))
1457 while (o
!= target
&& *--o
!= '/')
1460 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1464 if (o
== target
&& *o
== '/')
1472 #endif /* not VMS */
1475 return make_string (target
, o
- target
);
1479 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1480 Ssubstitute_in_file_name
, 1, 1, 0,
1481 "Substitute environment variables referred to in FILENAME.\n\
1482 `$FOO' where FOO is an environment variable name means to substitute\n\
1483 the value of that variable. The variable name should be terminated\n\
1484 with a character not a letter, digit or underscore; otherwise, enclose\n\
1485 the entire variable name in braces.\n\
1486 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1487 On VMS, `$' substitution is not done; this function does little and only\n\
1488 duplicates what `expand-file-name' does.")
1494 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1495 unsigned char *target
;
1497 int substituted
= 0;
1500 CHECK_STRING (string
, 0);
1502 nm
= XSTRING (string
)->data
;
1504 dostounix_filename (nm
= strcpy (alloca (strlen (nm
) + 1), nm
));
1505 substituted
= !strcmp (nm
, XSTRING (string
)->data
);
1507 endp
= nm
+ XSTRING (string
)->size
;
1509 /* If /~ or // appears, discard everything through first slash. */
1511 for (p
= nm
; p
!= endp
; p
++)
1515 /* // at start of file name is meaningful in Apollo system */
1516 (p
[0] == '/' && p
- 1 != nm
)
1517 #else /* not APOLLO */
1519 #endif /* not APOLLO */
1523 (p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>' ||
1534 if (p
[0] && p
[1] == ':')
1543 return build_string (nm
);
1546 /* See if any variables are substituted into the string
1547 and find the total length of their values in `total' */
1549 for (p
= nm
; p
!= endp
;)
1559 /* "$$" means a single "$" */
1568 while (p
!= endp
&& *p
!= '}') p
++;
1569 if (*p
!= '}') goto missingclose
;
1575 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1579 /* Copy out the variable name */
1580 target
= (unsigned char *) alloca (s
- o
+ 1);
1581 strncpy (target
, o
, s
- o
);
1584 strupr (target
); /* $home == $HOME etc. */
1587 /* Get variable value */
1588 o
= (unsigned char *) egetenv (target
);
1589 if (!o
) goto badvar
;
1590 total
+= strlen (o
);
1597 /* If substitution required, recopy the string and do it */
1598 /* Make space in stack frame for the new copy */
1599 xnm
= (unsigned char *) alloca (XSTRING (string
)->size
+ total
+ 1);
1602 /* Copy the rest of the name through, replacing $ constructs with values */
1619 while (p
!= endp
&& *p
!= '}') p
++;
1620 if (*p
!= '}') goto missingclose
;
1626 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1630 /* Copy out the variable name */
1631 target
= (unsigned char *) alloca (s
- o
+ 1);
1632 strncpy (target
, o
, s
- o
);
1635 strupr (target
); /* $home == $HOME etc. */
1638 /* Get variable value */
1639 o
= (unsigned char *) egetenv (target
);
1649 /* If /~ or // appears, discard everything through first slash. */
1651 for (p
= xnm
; p
!= x
; p
++)
1654 /* // at start of file name is meaningful in Apollo system */
1655 (p
[0] == '/' && p
- 1 != xnm
)
1656 #else /* not APOLLO */
1658 #endif /* not APOLLO */
1660 && p
!= nm
&& p
[-1] == '/')
1663 else if (p
[0] && p
[1] == ':')
1667 return make_string (xnm
, x
- xnm
);
1670 error ("Bad format environment-variable substitution");
1672 error ("Missing \"}\" in environment-variable substitution");
1674 error ("Substituting nonexistent environment variable \"%s\"", target
);
1677 #endif /* not VMS */
1680 /* A slightly faster and more convenient way to get
1681 (directory-file-name (expand-file-name FOO)). */
1684 expand_and_dir_to_file (filename
, defdir
)
1685 Lisp_Object filename
, defdir
;
1687 register Lisp_Object abspath
;
1689 abspath
= Fexpand_file_name (filename
, defdir
);
1692 register int c
= XSTRING (abspath
)->data
[XSTRING (abspath
)->size
- 1];
1693 if (c
== ':' || c
== ']' || c
== '>')
1694 abspath
= Fdirectory_file_name (abspath
);
1697 /* Remove final slash, if any (unless path is root).
1698 stat behaves differently depending! */
1699 if (XSTRING (abspath
)->size
> 1
1700 && XSTRING (abspath
)->data
[XSTRING (abspath
)->size
- 1] == '/')
1701 /* We cannot take shortcuts; they might be wrong for magic file names. */
1702 abspath
= Fdirectory_file_name (abspath
);
1707 barf_or_query_if_file_exists (absname
, querystring
, interactive
)
1708 Lisp_Object absname
;
1709 unsigned char *querystring
;
1712 register Lisp_Object tem
;
1713 struct stat statbuf
;
1714 struct gcpro gcpro1
;
1716 /* stat is a good way to tell whether the file exists,
1717 regardless of what access permissions it has. */
1718 if (stat (XSTRING (absname
)->data
, &statbuf
) >= 0)
1721 Fsignal (Qfile_already_exists
,
1722 Fcons (build_string ("File already exists"),
1723 Fcons (absname
, Qnil
)));
1725 tem
= do_yes_or_no_p (format1 ("File %s already exists; %s anyway? ",
1726 XSTRING (absname
)->data
, querystring
));
1729 Fsignal (Qfile_already_exists
,
1730 Fcons (build_string ("File already exists"),
1731 Fcons (absname
, Qnil
)));
1736 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
1737 "fCopy file: \nFCopy %s to file: \np\nP",
1738 "Copy FILE to NEWNAME. Both args must be strings.\n\
1739 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
1740 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
1741 A number as third arg means request confirmation if NEWNAME already exists.\n\
1742 This is what happens in interactive use with M-x.\n\
1743 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
1744 last-modified time as the old one. (This works on only some systems.)\n\
1745 A prefix arg makes KEEP-TIME non-nil.")
1746 (filename
, newname
, ok_if_already_exists
, keep_date
)
1747 Lisp_Object filename
, newname
, ok_if_already_exists
, keep_date
;
1750 char buf
[16 * 1024];
1752 Lisp_Object handler
;
1753 struct gcpro gcpro1
, gcpro2
;
1754 int count
= specpdl_ptr
- specpdl
;
1755 int input_file_statable_p
;
1757 GCPRO2 (filename
, newname
);
1758 CHECK_STRING (filename
, 0);
1759 CHECK_STRING (newname
, 1);
1760 filename
= Fexpand_file_name (filename
, Qnil
);
1761 newname
= Fexpand_file_name (newname
, Qnil
);
1763 /* If the input file name has special constructs in it,
1764 call the corresponding file handler. */
1765 handler
= Ffind_file_name_handler (filename
, Qcopy_file
);
1766 /* Likewise for output file name. */
1768 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
1769 if (!NILP (handler
))
1770 RETURN_UNGCPRO (call5 (handler
, Qcopy_file
, filename
, newname
,
1771 ok_if_already_exists
, keep_date
));
1773 if (NILP (ok_if_already_exists
)
1774 || XTYPE (ok_if_already_exists
) == Lisp_Int
)
1775 barf_or_query_if_file_exists (newname
, "copy to it",
1776 XTYPE (ok_if_already_exists
) == Lisp_Int
);
1778 ifd
= open (XSTRING (filename
)->data
, O_RDONLY
);
1780 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
1782 record_unwind_protect (close_file_unwind
, make_number (ifd
));
1784 /* We can only copy regular files and symbolic links. Other files are not
1786 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
1788 #if defined (S_ISREG) && defined (S_ISLNK)
1789 if (input_file_statable_p
)
1791 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
1793 #if defined (EISDIR)
1794 /* Get a better looking error message. */
1797 report_file_error ("Non-regular file", Fcons (filename
, Qnil
));
1800 #endif /* S_ISREG && S_ISLNK */
1803 /* Create the copy file with the same record format as the input file */
1804 ofd
= sys_creat (XSTRING (newname
)->data
, 0666, ifd
);
1807 /* System's default file type was set to binary by _fmode in emacs.c. */
1808 ofd
= creat (XSTRING (newname
)->data
, S_IREAD
| S_IWRITE
);
1809 #else /* not MSDOS */
1810 ofd
= creat (XSTRING (newname
)->data
, 0666);
1811 #endif /* not MSDOS */
1814 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
1816 record_unwind_protect (close_file_unwind
, make_number (ofd
));
1820 while ((n
= read (ifd
, buf
, sizeof buf
)) > 0)
1821 if (write (ofd
, buf
, n
) != n
)
1822 report_file_error ("I/O error", Fcons (newname
, Qnil
));
1825 /* Closing the output clobbers the file times on some systems. */
1826 if (close (ofd
) < 0)
1827 report_file_error ("I/O error", Fcons (newname
, Qnil
));
1829 if (input_file_statable_p
)
1831 if (!NILP (keep_date
))
1833 EMACS_TIME atime
, mtime
;
1834 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
1835 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
1836 EMACS_SET_UTIMES (XSTRING (newname
)->data
, atime
, mtime
);
1839 if (!egetenv ("USE_DOMAIN_ACLS"))
1841 chmod (XSTRING (newname
)->data
, st
.st_mode
& 07777);
1846 /* Discard the unwind protects. */
1847 specpdl_ptr
= specpdl
+ count
;
1853 DEFUN ("make-directory-internal", Fmake_directory_internal
,
1854 Smake_directory_internal
, 1, 1, 0,
1855 "Create a directory. One argument, a file name string.")
1857 Lisp_Object dirname
;
1860 Lisp_Object handler
;
1862 CHECK_STRING (dirname
, 0);
1863 dirname
= Fexpand_file_name (dirname
, Qnil
);
1865 handler
= Ffind_file_name_handler (dirname
, Qmake_directory_internal
);
1866 if (!NILP (handler
))
1867 return call2 (handler
, Qmake_directory_internal
, dirname
);
1869 dir
= XSTRING (dirname
)->data
;
1871 if (mkdir (dir
, 0777) != 0)
1872 report_file_error ("Creating directory", Flist (1, &dirname
));
1877 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
1878 "Delete a directory. One argument, a file name or directory name string.")
1880 Lisp_Object dirname
;
1883 Lisp_Object handler
;
1885 CHECK_STRING (dirname
, 0);
1886 dirname
= Fdirectory_file_name (Fexpand_file_name (dirname
, Qnil
));
1887 dir
= XSTRING (dirname
)->data
;
1889 handler
= Ffind_file_name_handler (dirname
, Qdelete_directory
);
1890 if (!NILP (handler
))
1891 return call2 (handler
, Qdelete_directory
, dirname
);
1893 if (rmdir (dir
) != 0)
1894 report_file_error ("Removing directory", Flist (1, &dirname
));
1899 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
1900 "Delete specified file. One argument, a file name string.\n\
1901 If file has multiple names, it continues to exist with the other names.")
1903 Lisp_Object filename
;
1905 Lisp_Object handler
;
1906 CHECK_STRING (filename
, 0);
1907 filename
= Fexpand_file_name (filename
, Qnil
);
1909 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
1910 if (!NILP (handler
))
1911 return call2 (handler
, Qdelete_file
, filename
);
1913 if (0 > unlink (XSTRING (filename
)->data
))
1914 report_file_error ("Removing old name", Flist (1, &filename
));
1918 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
1919 "fRename file: \nFRename %s to file: \np",
1920 "Rename FILE as NEWNAME. Both args strings.\n\
1921 If file has names other than FILE, it continues to have those names.\n\
1922 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
1923 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
1924 A number as third arg means request confirmation if NEWNAME already exists.\n\
1925 This is what happens in interactive use with M-x.")
1926 (filename
, newname
, ok_if_already_exists
)
1927 Lisp_Object filename
, newname
, ok_if_already_exists
;
1930 Lisp_Object args
[2];
1932 Lisp_Object handler
;
1933 struct gcpro gcpro1
, gcpro2
;
1935 GCPRO2 (filename
, newname
);
1936 CHECK_STRING (filename
, 0);
1937 CHECK_STRING (newname
, 1);
1938 filename
= Fexpand_file_name (filename
, Qnil
);
1939 newname
= Fexpand_file_name (newname
, Qnil
);
1941 /* If the file name has special constructs in it,
1942 call the corresponding file handler. */
1943 handler
= Ffind_file_name_handler (filename
, Qrename_file
);
1945 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
1946 if (!NILP (handler
))
1947 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
1948 filename
, newname
, ok_if_already_exists
));
1950 if (NILP (ok_if_already_exists
)
1951 || XTYPE (ok_if_already_exists
) == Lisp_Int
)
1952 barf_or_query_if_file_exists (newname
, "rename to it",
1953 XTYPE (ok_if_already_exists
) == Lisp_Int
);
1955 if (0 > rename (XSTRING (filename
)->data
, XSTRING (newname
)->data
))
1957 if (0 > link (XSTRING (filename
)->data
, XSTRING (newname
)->data
)
1958 || 0 > unlink (XSTRING (filename
)->data
))
1963 Fcopy_file (filename
, newname
,
1964 /* We have already prompted if it was an integer,
1965 so don't have copy-file prompt again. */
1966 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
1967 Fdelete_file (filename
);
1974 report_file_error ("Renaming", Flist (2, args
));
1977 report_file_error ("Renaming", Flist (2, &filename
));
1984 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
1985 "fAdd name to file: \nFName to add to %s: \np",
1986 "Give FILE additional name NEWNAME. Both args strings.\n\
1987 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
1988 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
1989 A number as third arg means request confirmation if NEWNAME already exists.\n\
1990 This is what happens in interactive use with M-x.")
1991 (filename
, newname
, ok_if_already_exists
)
1992 Lisp_Object filename
, newname
, ok_if_already_exists
;
1995 Lisp_Object args
[2];
1997 Lisp_Object handler
;
1998 struct gcpro gcpro1
, gcpro2
;
2000 GCPRO2 (filename
, newname
);
2001 CHECK_STRING (filename
, 0);
2002 CHECK_STRING (newname
, 1);
2003 filename
= Fexpand_file_name (filename
, Qnil
);
2004 newname
= Fexpand_file_name (newname
, Qnil
);
2006 /* If the file name has special constructs in it,
2007 call the corresponding file handler. */
2008 handler
= Ffind_file_name_handler (filename
, Qadd_name_to_file
);
2009 if (!NILP (handler
))
2010 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, filename
,
2011 newname
, ok_if_already_exists
));
2013 if (NILP (ok_if_already_exists
)
2014 || XTYPE (ok_if_already_exists
) == Lisp_Int
)
2015 barf_or_query_if_file_exists (newname
, "make it a new name",
2016 XTYPE (ok_if_already_exists
) == Lisp_Int
);
2017 unlink (XSTRING (newname
)->data
);
2018 if (0 > link (XSTRING (filename
)->data
, XSTRING (newname
)->data
))
2023 report_file_error ("Adding new name", Flist (2, args
));
2025 report_file_error ("Adding new name", Flist (2, &filename
));
2034 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2035 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2036 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
2037 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2038 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2039 A number as third arg means request confirmation if NEWNAME already exists.\n\
2040 This happens for interactive use with M-x.")
2041 (filename
, linkname
, ok_if_already_exists
)
2042 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2045 Lisp_Object args
[2];
2047 Lisp_Object handler
;
2048 struct gcpro gcpro1
, gcpro2
;
2050 GCPRO2 (filename
, linkname
);
2051 CHECK_STRING (filename
, 0);
2052 CHECK_STRING (linkname
, 1);
2053 /* If the link target has a ~, we must expand it to get
2054 a truly valid file name. Otherwise, do not expand;
2055 we want to permit links to relative file names. */
2056 if (XSTRING (filename
)->data
[0] == '~')
2057 filename
= Fexpand_file_name (filename
, Qnil
);
2058 linkname
= Fexpand_file_name (linkname
, Qnil
);
2060 /* If the file name has special constructs in it,
2061 call the corresponding file handler. */
2062 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2063 if (!NILP (handler
))
2064 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2065 linkname
, ok_if_already_exists
));
2067 if (NILP (ok_if_already_exists
)
2068 || XTYPE (ok_if_already_exists
) == Lisp_Int
)
2069 barf_or_query_if_file_exists (linkname
, "make it a link",
2070 XTYPE (ok_if_already_exists
) == Lisp_Int
);
2071 if (0 > symlink (XSTRING (filename
)->data
, XSTRING (linkname
)->data
))
2073 /* If we didn't complain already, silently delete existing file. */
2074 if (errno
== EEXIST
)
2076 unlink (XSTRING (linkname
)->data
);
2077 if (0 <= symlink (XSTRING (filename
)->data
, XSTRING (linkname
)->data
))
2087 report_file_error ("Making symbolic link", Flist (2, args
));
2089 report_file_error ("Making symbolic link", Flist (2, &filename
));
2095 #endif /* S_IFLNK */
2099 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2100 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2101 "Define the job-wide logical name NAME to have the value STRING.\n\
2102 If STRING is nil or a null string, the logical name NAME is deleted.")
2104 Lisp_Object varname
;
2107 CHECK_STRING (varname
, 0);
2109 delete_logical_name (XSTRING (varname
)->data
);
2112 CHECK_STRING (string
, 1);
2114 if (XSTRING (string
)->size
== 0)
2115 delete_logical_name (XSTRING (varname
)->data
);
2117 define_logical_name (XSTRING (varname
)->data
, XSTRING (string
)->data
);
2126 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2127 "Open a network connection to PATH using LOGIN as the login string.")
2129 Lisp_Object path
, login
;
2133 CHECK_STRING (path
, 0);
2134 CHECK_STRING (login
, 0);
2136 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2138 if (netresult
== -1)
2143 #endif /* HPUX_NET */
2145 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2147 "Return t if file FILENAME specifies an absolute path name.\n\
2148 On Unix, this is a name starting with a `/' or a `~'.")
2150 Lisp_Object filename
;
2154 CHECK_STRING (filename
, 0);
2155 ptr
= XSTRING (filename
)->data
;
2156 if (*ptr
== '/' || *ptr
== '~'
2158 /* ??? This criterion is probably wrong for '<'. */
2159 || index (ptr
, ':') || index (ptr
, '<')
2160 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2164 || (*ptr
!= 0 && ptr
[1] == ':' && (ptr
[2] == '/' || ptr
[2] == '\\'))
2172 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2173 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
2174 See also `file-readable-p' and `file-attributes'.")
2176 Lisp_Object filename
;
2178 Lisp_Object abspath
;
2179 Lisp_Object handler
;
2180 struct stat statbuf
;
2182 CHECK_STRING (filename
, 0);
2183 abspath
= Fexpand_file_name (filename
, Qnil
);
2185 /* If the file name has special constructs in it,
2186 call the corresponding file handler. */
2187 handler
= Ffind_file_name_handler (abspath
, Qfile_exists_p
);
2188 if (!NILP (handler
))
2189 return call2 (handler
, Qfile_exists_p
, abspath
);
2191 return (stat (XSTRING (abspath
)->data
, &statbuf
) >= 0) ? Qt
: Qnil
;
2194 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2195 "Return t if FILENAME can be executed by you.\n\
2196 For a directory, this means you can access files in that directory.")
2198 Lisp_Object filename
;
2201 Lisp_Object abspath
;
2202 Lisp_Object handler
;
2204 CHECK_STRING (filename
, 0);
2205 abspath
= Fexpand_file_name (filename
, Qnil
);
2207 /* If the file name has special constructs in it,
2208 call the corresponding file handler. */
2209 handler
= Ffind_file_name_handler (abspath
, Qfile_executable_p
);
2210 if (!NILP (handler
))
2211 return call2 (handler
, Qfile_executable_p
, abspath
);
2213 return (access (XSTRING (abspath
)->data
, 1) >= 0) ? Qt
: Qnil
;
2216 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2217 "Return t if file FILENAME exists and you can read it.\n\
2218 See also `file-exists-p' and `file-attributes'.")
2220 Lisp_Object filename
;
2222 Lisp_Object abspath
;
2223 Lisp_Object handler
;
2226 CHECK_STRING (filename
, 0);
2227 abspath
= Fexpand_file_name (filename
, Qnil
);
2229 /* If the file name has special constructs in it,
2230 call the corresponding file handler. */
2231 handler
= Ffind_file_name_handler (abspath
, Qfile_readable_p
);
2232 if (!NILP (handler
))
2233 return call2 (handler
, Qfile_readable_p
, abspath
);
2235 desc
= open (XSTRING (abspath
)->data
, O_RDONLY
);
2242 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
2243 "Return non-nil if file FILENAME is the name of a symbolic link.\n\
2244 The value is the name of the file to which it is linked.\n\
2245 Otherwise returns nil.")
2247 Lisp_Object filename
;
2254 Lisp_Object handler
;
2256 CHECK_STRING (filename
, 0);
2257 filename
= Fexpand_file_name (filename
, Qnil
);
2259 /* If the file name has special constructs in it,
2260 call the corresponding file handler. */
2261 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
2262 if (!NILP (handler
))
2263 return call2 (handler
, Qfile_symlink_p
, filename
);
2268 buf
= (char *) xmalloc (bufsize
);
2269 bzero (buf
, bufsize
);
2270 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
2271 if (valsize
< bufsize
) break;
2272 /* Buffer was not long enough */
2281 val
= make_string (buf
, valsize
);
2284 #else /* not S_IFLNK */
2286 #endif /* not S_IFLNK */
2289 #ifdef SOLARIS_BROKEN_ACCESS
2290 /* In Solaris 2.1, the readonly-ness of the filesystem is not
2291 considered by the access system call. This is Sun's bug, but we
2292 still have to make Emacs work. */
2294 #include <sys/statvfs.h>
2300 struct statvfs statvfsb
;
2302 if (statvfs(path
, &statvfsb
))
2303 return 1; /* error from statvfs, be conservative and say not wrtable */
2305 /* Otherwise, fsys is ro if bit is set. */
2306 return statvfsb
.f_flag
& ST_RDONLY
;
2309 /* But on every other os, access has already done the right thing. */
2310 #define ro_fsys(path) 0
2313 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2315 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
2316 "Return t if file FILENAME can be written or created by you.")
2318 Lisp_Object filename
;
2320 Lisp_Object abspath
, dir
;
2321 Lisp_Object handler
;
2323 CHECK_STRING (filename
, 0);
2324 abspath
= Fexpand_file_name (filename
, Qnil
);
2326 /* If the file name has special constructs in it,
2327 call the corresponding file handler. */
2328 handler
= Ffind_file_name_handler (abspath
, Qfile_writable_p
);
2329 if (!NILP (handler
))
2330 return call2 (handler
, Qfile_writable_p
, abspath
);
2332 if (access (XSTRING (abspath
)->data
, 0) >= 0)
2333 return ((access (XSTRING (abspath
)->data
, 2) >= 0
2334 && ! ro_fsys ((char *) XSTRING (abspath
)->data
))
2336 dir
= Ffile_name_directory (abspath
);
2339 dir
= Fdirectory_file_name (dir
);
2343 dir
= Fdirectory_file_name (dir
);
2345 return ((access (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "", 2) >= 0
2346 && ! ro_fsys ((char *) XSTRING (dir
)->data
))
2350 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
2351 "Return t if file FILENAME is the name of a directory as a file.\n\
2352 A directory name spec may be given instead; then the value is t\n\
2353 if the directory so specified exists and really is a directory.")
2355 Lisp_Object filename
;
2357 register Lisp_Object abspath
;
2359 Lisp_Object handler
;
2361 abspath
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2363 /* If the file name has special constructs in it,
2364 call the corresponding file handler. */
2365 handler
= Ffind_file_name_handler (abspath
, Qfile_directory_p
);
2366 if (!NILP (handler
))
2367 return call2 (handler
, Qfile_directory_p
, abspath
);
2369 if (stat (XSTRING (abspath
)->data
, &st
) < 0)
2371 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
2374 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
2375 "Return t if file FILENAME is the name of a directory as a file,\n\
2376 and files in that directory can be opened by you. In order to use a\n\
2377 directory as a buffer's current directory, this predicate must return true.\n\
2378 A directory name spec may be given instead; then the value is t\n\
2379 if the directory so specified exists and really is a readable and\n\
2380 searchable directory.")
2382 Lisp_Object filename
;
2384 Lisp_Object handler
;
2387 /* If the file name has special constructs in it,
2388 call the corresponding file handler. */
2389 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
2390 if (!NILP (handler
))
2391 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
2393 /* Need to gcpro in case the first function call has a handler that
2394 causes filename to be relocated. */
2395 tem
= (NILP (Ffile_directory_p (filename
))
2396 || NILP (Ffile_executable_p (filename
)));
2397 return tem
? Qnil
: Qt
;
2400 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
2401 "Return mode bits of FILE, as an integer.")
2403 Lisp_Object filename
;
2405 Lisp_Object abspath
;
2407 Lisp_Object handler
;
2409 abspath
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2411 /* If the file name has special constructs in it,
2412 call the corresponding file handler. */
2413 handler
= Ffind_file_name_handler (abspath
, Qfile_modes
);
2414 if (!NILP (handler
))
2415 return call2 (handler
, Qfile_modes
, abspath
);
2417 if (stat (XSTRING (abspath
)->data
, &st
) < 0)
2423 if (S_ISREG (st
.st_mode
)
2424 && (len
= XSTRING (abspath
)->size
) >= 5
2425 && (stricmp ((suffix
= XSTRING (abspath
)->data
+ len
-4), ".com") == 0
2426 || stricmp (suffix
, ".exe") == 0
2427 || stricmp (suffix
, ".bat") == 0))
2428 st
.st_mode
|= S_IEXEC
;
2432 return make_number (st
.st_mode
& 07777);
2435 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
2436 "Set mode bits of FILE to MODE (an integer).\n\
2437 Only the 12 low bits of MODE are used.")
2439 Lisp_Object filename
, mode
;
2441 Lisp_Object abspath
;
2442 Lisp_Object handler
;
2444 abspath
= Fexpand_file_name (filename
, current_buffer
->directory
);
2445 CHECK_NUMBER (mode
, 1);
2447 /* If the file name has special constructs in it,
2448 call the corresponding file handler. */
2449 handler
= Ffind_file_name_handler (abspath
, Qset_file_modes
);
2450 if (!NILP (handler
))
2451 return call3 (handler
, Qset_file_modes
, abspath
, mode
);
2454 if (chmod (XSTRING (abspath
)->data
, XINT (mode
)) < 0)
2455 report_file_error ("Doing chmod", Fcons (abspath
, Qnil
));
2457 if (!egetenv ("USE_DOMAIN_ACLS"))
2460 struct timeval tvp
[2];
2462 /* chmod on apollo also change the file's modtime; need to save the
2463 modtime and then restore it. */
2464 if (stat (XSTRING (abspath
)->data
, &st
) < 0)
2466 report_file_error ("Doing chmod", Fcons (abspath
, Qnil
));
2470 if (chmod (XSTRING (abspath
)->data
, XINT (mode
)) < 0)
2471 report_file_error ("Doing chmod", Fcons (abspath
, Qnil
));
2473 /* reset the old accessed and modified times. */
2474 tvp
[0].tv_sec
= st
.st_atime
+ 1; /* +1 due to an Apollo roundoff bug */
2476 tvp
[1].tv_sec
= st
.st_mtime
+ 1; /* +1 due to an Apollo roundoff bug */
2479 if (utimes (XSTRING (abspath
)->data
, tvp
) < 0)
2480 report_file_error ("Doing utimes", Fcons (abspath
, Qnil
));
2487 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
2488 "Set the file permission bits for newly created files.\n\
2489 The argument MODE should be an integer; only the low 9 bits are used.\n\
2490 This setting is inherited by subprocesses.")
2494 CHECK_NUMBER (mode
, 0);
2496 umask ((~ XINT (mode
)) & 0777);
2501 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
2502 "Return the default file protection for created files.\n\
2503 The value is an integer.")
2509 realmask
= umask (0);
2512 XSET (value
, Lisp_Int
, (~ realmask
) & 0777);
2518 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
2519 "Tell Unix to finish all pending disk updates.")
2528 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
2529 "Return t if file FILE1 is newer than file FILE2.\n\
2530 If FILE1 does not exist, the answer is nil;\n\
2531 otherwise, if FILE2 does not exist, the answer is t.")
2533 Lisp_Object file1
, file2
;
2535 Lisp_Object abspath1
, abspath2
;
2538 Lisp_Object handler
;
2539 struct gcpro gcpro1
, gcpro2
;
2541 CHECK_STRING (file1
, 0);
2542 CHECK_STRING (file2
, 0);
2545 GCPRO2 (abspath1
, file2
);
2546 abspath1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
2547 abspath2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
2550 /* If the file name has special constructs in it,
2551 call the corresponding file handler. */
2552 handler
= Ffind_file_name_handler (abspath1
, Qfile_newer_than_file_p
);
2554 handler
= Ffind_file_name_handler (abspath2
, Qfile_newer_than_file_p
);
2555 if (!NILP (handler
))
2556 return call3 (handler
, Qfile_newer_than_file_p
, abspath1
, abspath2
);
2558 if (stat (XSTRING (abspath1
)->data
, &st
) < 0)
2561 mtime1
= st
.st_mtime
;
2563 if (stat (XSTRING (abspath2
)->data
, &st
) < 0)
2566 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
2570 Lisp_Object Qfind_buffer_file_type
;
2573 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
2575 "Insert contents of file FILENAME after point.\n\
2576 Returns list of absolute file name and length of data inserted.\n\
2577 If second argument VISIT is non-nil, the buffer's visited filename\n\
2578 and last save file modtime are set, and it is marked unmodified.\n\
2579 If visiting and the file does not exist, visiting is completed\n\
2580 before the error is signaled.\n\n\
2581 The optional third and fourth arguments BEG and END\n\
2582 specify what portion of the file to insert.\n\
2583 If VISIT is non-nil, BEG and END must be nil.\n\
2584 If optional fifth argument REPLACE is non-nil,\n\
2585 it means replace the current buffer contents (in the accessible portion)\n\
2586 with the file contents. This is better than simply deleting and inserting\n\
2587 the whole thing because (1) it preserves some marker positions\n\
2588 and (2) it puts less data in the undo list.")
2589 (filename
, visit
, beg
, end
, replace
)
2590 Lisp_Object filename
, visit
, beg
, end
, replace
;
2594 register int inserted
= 0;
2595 register int how_much
;
2596 int count
= specpdl_ptr
- specpdl
;
2597 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2598 Lisp_Object handler
, val
, insval
;
2605 GCPRO3 (filename
, val
, p
);
2606 if (!NILP (current_buffer
->read_only
))
2607 Fbarf_if_buffer_read_only();
2609 CHECK_STRING (filename
, 0);
2610 filename
= Fexpand_file_name (filename
, Qnil
);
2612 /* If the file name has special constructs in it,
2613 call the corresponding file handler. */
2614 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
2615 if (!NILP (handler
))
2617 val
= call6 (handler
, Qinsert_file_contents
, filename
,
2618 visit
, beg
, end
, replace
);
2625 if (stat (XSTRING (filename
)->data
, &st
) < 0)
2627 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0
2628 || fstat (fd
, &st
) < 0)
2629 #endif /* not APOLLO */
2631 if (fd
>= 0) close (fd
);
2634 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
2641 /* This code will need to be changed in order to work on named
2642 pipes, and it's probably just not worth it. So we should at
2643 least signal an error. */
2644 if (!S_ISREG (st
.st_mode
))
2645 Fsignal (Qfile_error
,
2646 Fcons (build_string ("not a regular file"),
2647 Fcons (filename
, Qnil
)));
2651 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0)
2654 /* Replacement should preserve point as it preserves markers. */
2655 if (!NILP (replace
))
2656 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
2658 record_unwind_protect (close_file_unwind
, make_number (fd
));
2660 /* Supposedly happens on VMS. */
2662 error ("File size is negative");
2664 if (!NILP (beg
) || !NILP (end
))
2666 error ("Attempt to visit less than an entire file");
2669 CHECK_NUMBER (beg
, 0);
2674 CHECK_NUMBER (end
, 0);
2677 XSETINT (end
, st
.st_size
);
2678 if (XINT (end
) != st
.st_size
)
2679 error ("maximum buffer size exceeded");
2682 /* If requested, replace the accessible part of the buffer
2683 with the file contents. Avoid replacing text at the
2684 beginning or end of the buffer that matches the file contents;
2685 that preserves markers pointing to the unchanged parts. */
2687 /* On MSDOS, replace mode doesn't really work, except for binary files,
2688 and it's not worth supporting just for them. */
2689 if (!NILP (replace
))
2693 XFASTINT (end
) = st
.st_size
;
2694 del_range_1 (BEGV
, ZV
, 0);
2697 if (!NILP (replace
))
2699 unsigned char buffer
[1 << 14];
2700 int same_at_start
= BEGV
;
2701 int same_at_end
= ZV
;
2706 /* Count how many chars at the start of the file
2707 match the text at the beginning of the buffer. */
2712 nread
= read (fd
, buffer
, sizeof buffer
);
2714 error ("IO error reading %s: %s",
2715 XSTRING (filename
)->data
, strerror (errno
));
2716 else if (nread
== 0)
2719 while (bufpos
< nread
&& same_at_start
< ZV
2720 && FETCH_CHAR (same_at_start
) == buffer
[bufpos
])
2721 same_at_start
++, bufpos
++;
2722 /* If we found a discrepancy, stop the scan.
2723 Otherwise loop around and scan the next bufferfull. */
2724 if (bufpos
!= nread
)
2728 /* If the file matches the buffer completely,
2729 there's no need to replace anything. */
2730 if (same_at_start
- BEGV
== st
.st_size
)
2734 /* Truncate the buffer to the size of the file. */
2735 del_range_1 (same_at_start
, same_at_end
, 0);
2740 /* Count how many chars at the end of the file
2741 match the text at the end of the buffer. */
2744 int total_read
, nread
, bufpos
, curpos
, trial
;
2746 /* At what file position are we now scanning? */
2747 curpos
= st
.st_size
- (ZV
- same_at_end
);
2748 /* If the entire file matches the buffer tail, stop the scan. */
2751 /* How much can we scan in the next step? */
2752 trial
= min (curpos
, sizeof buffer
);
2753 if (lseek (fd
, curpos
- trial
, 0) < 0)
2754 report_file_error ("Setting file position",
2755 Fcons (filename
, Qnil
));
2758 while (total_read
< trial
)
2760 nread
= read (fd
, buffer
+ total_read
, trial
- total_read
);
2762 error ("IO error reading %s: %s",
2763 XSTRING (filename
)->data
, strerror (errno
));
2764 total_read
+= nread
;
2766 /* Scan this bufferfull from the end, comparing with
2767 the Emacs buffer. */
2768 bufpos
= total_read
;
2769 /* Compare with same_at_start to avoid counting some buffer text
2770 as matching both at the file's beginning and at the end. */
2771 while (bufpos
> 0 && same_at_end
> same_at_start
2772 && FETCH_CHAR (same_at_end
- 1) == buffer
[bufpos
- 1])
2773 same_at_end
--, bufpos
--;
2774 /* If we found a discrepancy, stop the scan.
2775 Otherwise loop around and scan the preceding bufferfull. */
2781 /* Don't try to reuse the same piece of text twice. */
2782 overlap
= same_at_start
- BEGV
- (same_at_end
+ st
.st_size
- ZV
);
2784 same_at_end
+= overlap
;
2786 /* Arrange to read only the nonmatching middle part of the file. */
2787 XFASTINT (beg
) = same_at_start
- BEGV
;
2788 XFASTINT (end
) = st
.st_size
- (ZV
- same_at_end
);
2790 del_range_1 (same_at_start
, same_at_end
, 0);
2791 /* Insert from the file at the proper position. */
2792 SET_PT (same_at_start
);
2796 total
= XINT (end
) - XINT (beg
);
2799 register Lisp_Object temp
;
2801 /* Make sure point-max won't overflow after this insertion. */
2802 XSET (temp
, Lisp_Int
, total
);
2803 if (total
!= XINT (temp
))
2804 error ("maximum buffer size exceeded");
2807 if (NILP (visit
) && total
> 0)
2808 prepare_to_modify_buffer (point
, point
);
2811 if (GAP_SIZE
< total
)
2812 make_gap (total
- GAP_SIZE
);
2814 if (XINT (beg
) != 0 || !NILP (replace
))
2816 if (lseek (fd
, XINT (beg
), 0) < 0)
2817 report_file_error ("Setting file position", Fcons (filename
, Qnil
));
2821 while (inserted
< total
)
2823 int try = min (total
- inserted
, 64 << 10);
2826 /* Allow quitting out of the actual I/O. */
2829 this = read (fd
, &FETCH_CHAR (point
+ inserted
- 1) + 1, try);
2846 /* Demacs 1.1.1 91/10/16 HIRANO Satoshi, MW July 1993 */
2847 /* Determine file type from name and remove LFs from CR-LFs if the file
2848 is deemed to be a text file. */
2850 struct gcpro gcpro1
;
2854 current_buffer
->buffer_file_type
2855 = call1 (Qfind_buffer_file_type
, filename
);
2857 if (NILP (current_buffer
->buffer_file_type
))
2860 = inserted
- crlf_to_lf (inserted
, &FETCH_CHAR (point
- 1) + 1);
2863 GPT
-= reduced_size
;
2864 GAP_SIZE
+= reduced_size
;
2865 inserted
-= reduced_size
;
2872 record_insert (point
, inserted
);
2874 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
2875 offset_intervals (current_buffer
, point
, inserted
);
2881 /* Discard the unwind protect for closing the file. */
2885 error ("IO error reading %s: %s",
2886 XSTRING (filename
)->data
, strerror (errno
));
2893 if (!EQ (current_buffer
->undo_list
, Qt
))
2894 current_buffer
->undo_list
= Qnil
;
2896 stat (XSTRING (filename
)->data
, &st
);
2901 current_buffer
->modtime
= st
.st_mtime
;
2902 current_buffer
->filename
= filename
;
2905 current_buffer
->save_modified
= MODIFF
;
2906 current_buffer
->auto_save_modified
= MODIFF
;
2907 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
2908 #ifdef CLASH_DETECTION
2911 if (!NILP (current_buffer
->filename
))
2912 unlock_file (current_buffer
->filename
);
2913 unlock_file (filename
);
2915 #endif /* CLASH_DETECTION */
2916 /* If visiting nonexistent file, return nil. */
2917 if (current_buffer
->modtime
== -1)
2918 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
2921 if (inserted
> 0 && NILP (visit
) && total
> 0)
2922 signal_after_change (point
, 0, inserted
);
2926 p
= Vafter_insert_file_functions
;
2929 insval
= call1 (Fcar (p
), make_number (inserted
));
2932 CHECK_NUMBER (insval
, 0);
2933 inserted
= XFASTINT (insval
);
2941 val
= Fcons (filename
,
2942 Fcons (make_number (inserted
),
2945 RETURN_UNGCPRO (unbind_to (count
, val
));
2948 static Lisp_Object
build_annotations ();
2950 /* If build_annotations switched buffers, switch back to BUF.
2951 Kill the temporary buffer that was selected in the meantime. */
2954 build_annotations_unwind (buf
)
2959 if (XBUFFER (buf
) == current_buffer
)
2961 tembuf
= Fcurrent_buffer ();
2963 Fkill_buffer (tembuf
);
2967 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 5,
2968 "r\nFWrite region to file: ",
2969 "Write current region into specified file.\n\
2970 When called from a program, takes three arguments:\n\
2971 START, END and FILENAME. START and END are buffer positions.\n\
2972 Optional fourth argument APPEND if non-nil means\n\
2973 append to existing file contents (if any).\n\
2974 Optional fifth argument VISIT if t means\n\
2975 set the last-save-file-modtime of buffer to this file's modtime\n\
2976 and mark buffer not modified.\n\
2977 If VISIT is a string, it is a second file name;\n\
2978 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
2979 VISIT is also the file name to lock and unlock for clash detection.\n\
2980 If VISIT is neither t nor nil nor a string,\n\
2981 that means do not print the \"Wrote file\" message.\n\
2982 Kludgy feature: if START is a string, then that string is written\n\
2983 to the file, instead of any buffer contents, and END is ignored.")
2984 (start
, end
, filename
, append
, visit
)
2985 Lisp_Object start
, end
, filename
, append
, visit
;
2993 int count
= specpdl_ptr
- specpdl
;
2996 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
2998 Lisp_Object handler
;
2999 Lisp_Object visit_file
;
3000 Lisp_Object annotations
;
3001 int visiting
, quietly
;
3002 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3003 struct buffer
*given_buffer
;
3005 int buffer_file_type
3006 = NILP (current_buffer
->buffer_file_type
) ? O_TEXT
: O_BINARY
;
3009 if (!NILP (start
) && !STRINGP (start
))
3010 validate_region (&start
, &end
);
3012 GCPRO2 (filename
, visit
);
3013 filename
= Fexpand_file_name (filename
, Qnil
);
3014 if (STRINGP (visit
))
3015 visit_file
= Fexpand_file_name (visit
, Qnil
);
3017 visit_file
= filename
;
3020 visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
3021 quietly
= !NILP (visit
);
3025 GCPRO4 (start
, filename
, annotations
, visit_file
);
3027 /* If the file name has special constructs in it,
3028 call the corresponding file handler. */
3029 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
3030 /* If FILENAME has no handler, see if VISIT has one. */
3031 if (NILP (handler
) && XTYPE (visit
) == Lisp_String
)
3032 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
3034 if (!NILP (handler
))
3037 val
= call6 (handler
, Qwrite_region
, start
, end
,
3038 filename
, append
, visit
);
3042 current_buffer
->save_modified
= MODIFF
;
3043 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3044 current_buffer
->filename
= visit_file
;
3050 /* Special kludge to simplify auto-saving. */
3053 XFASTINT (start
) = BEG
;
3057 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
3058 count1
= specpdl_ptr
- specpdl
;
3060 given_buffer
= current_buffer
;
3061 annotations
= build_annotations (start
, end
);
3062 if (current_buffer
!= given_buffer
)
3068 #ifdef CLASH_DETECTION
3070 lock_file (visit_file
);
3071 #endif /* CLASH_DETECTION */
3073 fn
= XSTRING (filename
)->data
;
3077 desc
= open (fn
, O_WRONLY
| buffer_file_type
);
3079 desc
= open (fn
, O_WRONLY
);
3084 if (auto_saving
) /* Overwrite any previous version of autosave file */
3086 vms_truncate (fn
); /* if fn exists, truncate to zero length */
3087 desc
= open (fn
, O_RDWR
);
3089 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
3090 ? XSTRING (current_buffer
->filename
)->data
: 0,
3093 else /* Write to temporary name and rename if no errors */
3095 Lisp_Object temp_name
;
3096 temp_name
= Ffile_name_directory (filename
);
3098 if (!NILP (temp_name
))
3100 temp_name
= Fmake_temp_name (concat2 (temp_name
,
3101 build_string ("$$SAVE$$")));
3102 fname
= XSTRING (filename
)->data
;
3103 fn
= XSTRING (temp_name
)->data
;
3104 desc
= creat_copy_attrs (fname
, fn
);
3107 /* If we can't open the temporary file, try creating a new
3108 version of the original file. VMS "creat" creates a
3109 new version rather than truncating an existing file. */
3112 desc
= creat (fn
, 0666);
3113 #if 0 /* This can clobber an existing file and fail to replace it,
3114 if the user runs out of space. */
3117 /* We can't make a new version;
3118 try to truncate and rewrite existing version if any. */
3120 desc
= open (fn
, O_RDWR
);
3126 desc
= creat (fn
, 0666);
3131 O_WRONLY
| O_TRUNC
| O_CREAT
| buffer_file_type
,
3132 S_IREAD
| S_IWRITE
);
3133 #else /* not MSDOS */
3134 desc
= creat (fn
, auto_saving
? auto_save_mode_bits
: 0666);
3135 #endif /* not MSDOS */
3136 #endif /* not VMS */
3142 #ifdef CLASH_DETECTION
3144 if (!auto_saving
) unlock_file (visit_file
);
3146 #endif /* CLASH_DETECTION */
3147 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
3150 record_unwind_protect (close_file_unwind
, make_number (desc
));
3153 if (lseek (desc
, 0, 2) < 0)
3155 #ifdef CLASH_DETECTION
3156 if (!auto_saving
) unlock_file (visit_file
);
3157 #endif /* CLASH_DETECTION */
3158 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
3163 * Kludge Warning: The VMS C RTL likes to insert carriage returns
3164 * if we do writes that don't end with a carriage return. Furthermore
3165 * it cannot handle writes of more then 16K. The modified
3166 * version of "sys_write" in SYSDEP.C (see comment there) copes with
3167 * this EXCEPT for the last record (iff it doesn't end with a carriage
3168 * return). This implies that if your buffer doesn't end with a carriage
3169 * return, you get one free... tough. However it also means that if
3170 * we make two calls to sys_write (a la the following code) you can
3171 * get one at the gap as well. The easiest way to fix this (honest)
3172 * is to move the gap to the next newline (or the end of the buffer).
3177 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
3178 move_gap (find_next_newline (GPT
, 1));
3184 if (STRINGP (start
))
3186 failure
= 0 > a_write (desc
, XSTRING (start
)->data
,
3187 XSTRING (start
)->size
, 0, &annotations
);
3190 else if (XINT (start
) != XINT (end
))
3193 if (XINT (start
) < GPT
)
3195 register int end1
= XINT (end
);
3197 failure
= 0 > a_write (desc
, &FETCH_CHAR (tem
),
3198 min (GPT
, end1
) - tem
, tem
, &annotations
);
3199 nwritten
+= min (GPT
, end1
) - tem
;
3203 if (XINT (end
) > GPT
&& !failure
)
3206 tem
= max (tem
, GPT
);
3207 failure
= 0 > a_write (desc
, &FETCH_CHAR (tem
), XINT (end
) - tem
,
3209 nwritten
+= XINT (end
) - tem
;
3215 /* If file was empty, still need to write the annotations */
3216 failure
= 0 > a_write (desc
, "", 0, XINT (start
), &annotations
);
3224 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
3225 Disk full in NFS may be reported here. */
3226 /* mib says that closing the file will try to write as fast as NFS can do
3227 it, and that means the fsync here is not crucial for autosave files. */
3228 if (!auto_saving
&& fsync (desc
) < 0)
3229 failure
= 1, save_errno
= errno
;
3232 /* Spurious "file has changed on disk" warnings have been
3233 observed on Suns as well.
3234 It seems that `close' can change the modtime, under nfs.
3236 (This has supposedly been fixed in Sunos 4,
3237 but who knows about all the other machines with NFS?) */
3240 /* On VMS and APOLLO, must do the stat after the close
3241 since closing changes the modtime. */
3244 /* Recall that #if defined does not work on VMS. */
3251 /* NFS can report a write failure now. */
3252 if (close (desc
) < 0)
3253 failure
= 1, save_errno
= errno
;
3256 /* If we wrote to a temporary name and had no errors, rename to real name. */
3260 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
3268 /* Discard the unwind protect for close_file_unwind. */
3269 specpdl_ptr
= specpdl
+ count1
;
3270 /* Restore the original current buffer. */
3271 visit_file
= unbind_to (count
, visit_file
);
3273 #ifdef CLASH_DETECTION
3275 unlock_file (visit_file
);
3276 #endif /* CLASH_DETECTION */
3278 /* Do this before reporting IO error
3279 to avoid a "file has changed on disk" warning on
3280 next attempt to save. */
3282 current_buffer
->modtime
= st
.st_mtime
;
3285 error ("IO error writing %s: %s", fn
, strerror (save_errno
));
3289 current_buffer
->save_modified
= MODIFF
;
3290 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3291 current_buffer
->filename
= visit_file
;
3292 update_mode_lines
++;
3298 message ("Wrote %s", XSTRING (visit_file
)->data
);
3303 Lisp_Object
merge ();
3305 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
3306 "Return t if (car A) is numerically less than (car B).")
3310 return Flss (Fcar (a
), Fcar (b
));
3313 /* Build the complete list of annotations appropriate for writing out
3314 the text between START and END, by calling all the functions in
3315 write-region-annotate-functions and merging the lists they return.
3316 If one of these functions switches to a different buffer, we assume
3317 that buffer contains altered text. Therefore, the caller must
3318 make sure to restore the current buffer in all cases,
3319 as save-excursion would do. */
3322 build_annotations (start
, end
)
3323 Lisp_Object start
, end
;
3325 Lisp_Object annotations
;
3327 struct gcpro gcpro1
, gcpro2
;
3330 p
= Vwrite_region_annotate_functions
;
3331 GCPRO2 (annotations
, p
);
3334 struct buffer
*given_buffer
= current_buffer
;
3335 Vwrite_region_annotations_so_far
= annotations
;
3336 res
= call2 (Fcar (p
), start
, end
);
3337 /* If the function makes a different buffer current,
3338 assume that means this buffer contains altered text to be output.
3339 Reset START and END from the buffer bounds
3340 and discard all previous annotations because they should have
3341 been dealt with by this function. */
3342 if (current_buffer
!= given_buffer
)
3348 Flength (res
); /* Check basic validity of return value */
3349 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
3356 /* Write to descriptor DESC the LEN characters starting at ADDR,
3357 assuming they start at position POS in the buffer.
3358 Intersperse with them the annotations from *ANNOT
3359 (those which fall within the range of positions POS to POS + LEN),
3360 each at its appropriate position.
3362 Modify *ANNOT by discarding elements as we output them.
3363 The return value is negative in case of system call failure. */
3366 a_write (desc
, addr
, len
, pos
, annot
)
3368 register char *addr
;
3375 int lastpos
= pos
+ len
;
3377 while (NILP (*annot
) || CONSP (*annot
))
3379 tem
= Fcar_safe (Fcar (*annot
));
3380 if (INTEGERP (tem
) && XINT (tem
) >= pos
&& XFASTINT (tem
) <= lastpos
)
3381 nextpos
= XFASTINT (tem
);
3383 return e_write (desc
, addr
, lastpos
- pos
);
3386 if (0 > e_write (desc
, addr
, nextpos
- pos
))
3388 addr
+= nextpos
- pos
;
3391 tem
= Fcdr (Fcar (*annot
));
3394 if (0 > e_write (desc
, XSTRING (tem
)->data
, XSTRING (tem
)->size
))
3397 *annot
= Fcdr (*annot
);
3402 e_write (desc
, addr
, len
)
3404 register char *addr
;
3407 char buf
[16 * 1024];
3408 register char *p
, *end
;
3410 if (!EQ (current_buffer
->selective_display
, Qt
))
3411 return write (desc
, addr
, len
) - len
;
3415 end
= p
+ sizeof buf
;
3420 if (write (desc
, buf
, sizeof buf
) != sizeof buf
)
3429 if (write (desc
, buf
, p
- buf
) != p
- buf
)
3435 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
3436 Sverify_visited_file_modtime
, 1, 1, 0,
3437 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
3438 This means that the file has not been changed since it was visited or saved.")
3444 Lisp_Object handler
;
3446 CHECK_BUFFER (buf
, 0);
3449 if (XTYPE (b
->filename
) != Lisp_String
) return Qt
;
3450 if (b
->modtime
== 0) return Qt
;
3452 /* If the file name has special constructs in it,
3453 call the corresponding file handler. */
3454 handler
= Ffind_file_name_handler (b
->filename
,
3455 Qverify_visited_file_modtime
);
3456 if (!NILP (handler
))
3457 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
3459 if (stat (XSTRING (b
->filename
)->data
, &st
) < 0)
3461 /* If the file doesn't exist now and didn't exist before,
3462 we say that it isn't modified, provided the error is a tame one. */
3463 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
3468 if (st
.st_mtime
== b
->modtime
3469 /* If both are positive, accept them if they are off by one second. */
3470 || (st
.st_mtime
> 0 && b
->modtime
> 0
3471 && (st
.st_mtime
== b
->modtime
+ 1
3472 || st
.st_mtime
== b
->modtime
- 1)))
3477 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
3478 Sclear_visited_file_modtime
, 0, 0, 0,
3479 "Clear out records of last mod time of visited file.\n\
3480 Next attempt to save will certainly not complain of a discrepancy.")
3483 current_buffer
->modtime
= 0;
3487 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
3488 Svisited_file_modtime
, 0, 0, 0,
3489 "Return the current buffer's recorded visited file modification time.\n\
3490 The value is a list of the form (HIGH . LOW), like the time values\n\
3491 that `file-attributes' returns.")
3494 return long_to_cons (current_buffer
->modtime
);
3497 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
3498 Sset_visited_file_modtime
, 0, 1, 0,
3499 "Update buffer's recorded modification time from the visited file's time.\n\
3500 Useful if the buffer was not read from the file normally\n\
3501 or if the file itself has been changed for some known benign reason.\n\
3502 An argument specifies the modification time value to use\n\
3503 \(instead of that of the visited file), in the form of a list\n\
3504 \(HIGH . LOW) or (HIGH LOW).")
3506 Lisp_Object time_list
;
3508 if (!NILP (time_list
))
3509 current_buffer
->modtime
= cons_to_long (time_list
);
3512 register Lisp_Object filename
;
3514 Lisp_Object handler
;
3516 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
3518 /* If the file name has special constructs in it,
3519 call the corresponding file handler. */
3520 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
3521 if (!NILP (handler
))
3522 /* The handler can find the file name the same way we did. */
3523 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
3524 else if (stat (XSTRING (filename
)->data
, &st
) >= 0)
3525 current_buffer
->modtime
= st
.st_mtime
;
3535 message ("Autosaving...error for %s", XSTRING (current_buffer
->name
)->data
);
3536 Fsleep_for (make_number (1), Qnil
);
3537 message ("Autosaving...error!for %s", XSTRING (current_buffer
->name
)->data
);
3538 Fsleep_for (make_number (1), Qnil
);
3539 message ("Autosaving...error for %s", XSTRING (current_buffer
->name
)->data
);
3540 Fsleep_for (make_number (1), Qnil
);
3550 /* Get visited file's mode to become the auto save file's mode. */
3551 if (stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
3552 /* But make sure we can overwrite it later! */
3553 auto_save_mode_bits
= st
.st_mode
| 0600;
3555 auto_save_mode_bits
= 0666;
3558 Fwrite_region (Qnil
, Qnil
,
3559 current_buffer
->auto_save_file_name
,
3564 do_auto_save_unwind (desc
) /* used as unwind-protect function */
3567 close (XINT (desc
));
3571 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
3572 "Auto-save all buffers that need it.\n\
3573 This is all buffers that have auto-saving enabled\n\
3574 and are changed since last auto-saved.\n\
3575 Auto-saving writes the buffer into a file\n\
3576 so that your editing is not lost if the system crashes.\n\
3577 This file is not the file you visited; that changes only when you save.\n\
3578 Normally we run the normal hook `auto-save-hook' before saving.\n\n\
3579 Non-nil first argument means do not print any message if successful.\n\
3580 Non-nil second argument means save only current buffer.")
3581 (no_message
, current_only
)
3582 Lisp_Object no_message
, current_only
;
3584 struct buffer
*old
= current_buffer
, *b
;
3585 Lisp_Object tail
, buf
;
3587 char *omessage
= echo_area_glyphs
;
3588 int omessage_length
= echo_area_glyphs_length
;
3589 extern int minibuf_level
;
3590 int do_handled_files
;
3593 int count
= specpdl_ptr
- specpdl
;
3596 /* Ordinarily don't quit within this function,
3597 but don't make it impossible to quit (in case we get hung in I/O). */
3601 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
3602 point to non-strings reached from Vbuffer_alist. */
3608 if (!NILP (Vrun_hooks
))
3609 call1 (Vrun_hooks
, intern ("auto-save-hook"));
3611 if (STRINGP (Vauto_save_list_file_name
))
3614 listdesc
= open (XSTRING (Vauto_save_list_file_name
)->data
,
3615 O_WRONLY
| O_TRUNC
| O_CREAT
| O_TEXT
,
3616 S_IREAD
| S_IWRITE
);
3617 #else /* not MSDOS */
3618 listdesc
= creat (XSTRING (Vauto_save_list_file_name
)->data
, 0666);
3619 #endif /* not MSDOS */
3624 /* Arrange to close that file whether or not we get an error. */
3626 record_unwind_protect (do_auto_save_unwind
, make_number (listdesc
));
3628 /* First, save all files which don't have handlers. If Emacs is
3629 crashing, the handlers may tweak what is causing Emacs to crash
3630 in the first place, and it would be a shame if Emacs failed to
3631 autosave perfectly ordinary files because it couldn't handle some
3633 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
3634 for (tail
= Vbuffer_alist
; XGCTYPE (tail
) == Lisp_Cons
;
3635 tail
= XCONS (tail
)->cdr
)
3637 buf
= XCONS (XCONS (tail
)->car
)->cdr
;
3640 /* Record all the buffers that have auto save mode
3641 in the special file that lists them. */
3642 if (XTYPE (b
->auto_save_file_name
) == Lisp_String
3643 && listdesc
>= 0 && do_handled_files
== 0)
3645 write (listdesc
, XSTRING (b
->auto_save_file_name
)->data
,
3646 XSTRING (b
->auto_save_file_name
)->size
);
3647 write (listdesc
, "\n", 1);
3650 if (!NILP (current_only
)
3651 && b
!= current_buffer
)
3654 /* Check for auto save enabled
3655 and file changed since last auto save
3656 and file changed since last real save. */
3657 if (XTYPE (b
->auto_save_file_name
) == Lisp_String
3658 && b
->save_modified
< BUF_MODIFF (b
)
3659 && b
->auto_save_modified
< BUF_MODIFF (b
)
3660 /* -1 means we've turned off autosaving for a while--see below. */
3661 && XINT (b
->save_length
) >= 0
3662 && (do_handled_files
3663 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
3666 EMACS_TIME before_time
, after_time
;
3668 EMACS_GET_TIME (before_time
);
3670 /* If we had a failure, don't try again for 20 minutes. */
3671 if (b
->auto_save_failure_time
>= 0
3672 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
3675 if ((XFASTINT (b
->save_length
) * 10
3676 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
3677 /* A short file is likely to change a large fraction;
3678 spare the user annoying messages. */
3679 && XFASTINT (b
->save_length
) > 5000
3680 /* These messages are frequent and annoying for `*mail*'. */
3681 && !EQ (b
->filename
, Qnil
)
3682 && NILP (no_message
))
3684 /* It has shrunk too much; turn off auto-saving here. */
3685 message ("Buffer %s has shrunk a lot; auto save turned off there",
3686 XSTRING (b
->name
)->data
);
3687 /* Turn off auto-saving until there's a real save,
3688 and prevent any more warnings. */
3689 XSET (b
->save_length
, Lisp_Int
, -1);
3690 Fsleep_for (make_number (1), Qnil
);
3693 set_buffer_internal (b
);
3694 if (!auto_saved
&& NILP (no_message
))
3695 message1 ("Auto-saving...");
3696 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
3698 b
->auto_save_modified
= BUF_MODIFF (b
);
3699 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3700 set_buffer_internal (old
);
3702 EMACS_GET_TIME (after_time
);
3704 /* If auto-save took more than 60 seconds,
3705 assume it was an NFS failure that got a timeout. */
3706 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
3707 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
3711 /* Prevent another auto save till enough input events come in. */
3712 record_auto_save ();
3714 if (auto_saved
&& NILP (no_message
))
3717 message2 (omessage
, omessage_length
);
3719 message1 ("Auto-saving...done");
3725 unbind_to (count
, Qnil
);
3729 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
3730 Sset_buffer_auto_saved
, 0, 0, 0,
3731 "Mark current buffer as auto-saved with its current text.\n\
3732 No auto-save file will be written until the buffer changes again.")
3735 current_buffer
->auto_save_modified
= MODIFF
;
3736 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3737 current_buffer
->auto_save_failure_time
= -1;
3741 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
3742 Sclear_buffer_auto_save_failure
, 0, 0, 0,
3743 "Clear any record of a recent auto-save failure in the current buffer.")
3746 current_buffer
->auto_save_failure_time
= -1;
3750 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
3752 "Return t if buffer has been auto-saved since last read in or saved.")
3755 return (current_buffer
->save_modified
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
3758 /* Reading and completing file names */
3759 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
3761 /* In the string VAL, change each $ to $$ and return the result. */
3764 double_dollars (val
)
3767 register unsigned char *old
, *new;
3771 osize
= XSTRING (val
)->size
;
3772 /* Quote "$" as "$$" to get it past substitute-in-file-name */
3773 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
3774 if (*old
++ == '$') count
++;
3777 old
= XSTRING (val
)->data
;
3778 val
= Fmake_string (make_number (osize
+ count
), make_number (0));
3779 new = XSTRING (val
)->data
;
3780 for (n
= osize
; n
> 0; n
--)
3793 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
3795 "Internal subroutine for read-file-name. Do not call this.")
3796 (string
, dir
, action
)
3797 Lisp_Object string
, dir
, action
;
3798 /* action is nil for complete, t for return list of completions,
3799 lambda for verify final value */
3801 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
3803 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3810 /* No need to protect ACTION--we only compare it with t and nil. */
3811 GCPRO4 (string
, realdir
, name
, specdir
);
3813 if (XSTRING (string
)->size
== 0)
3815 if (EQ (action
, Qlambda
))
3823 orig_string
= string
;
3824 string
= Fsubstitute_in_file_name (string
);
3825 changed
= NILP (Fstring_equal (string
, orig_string
));
3826 name
= Ffile_name_nondirectory (string
);
3827 val
= Ffile_name_directory (string
);
3829 realdir
= Fexpand_file_name (val
, realdir
);
3834 specdir
= Ffile_name_directory (string
);
3835 val
= Ffile_name_completion (name
, realdir
);
3837 if (XTYPE (val
) != Lisp_String
)
3840 return double_dollars (string
);
3844 if (!NILP (specdir
))
3845 val
= concat2 (specdir
, val
);
3847 return double_dollars (val
);
3850 #endif /* not VMS */
3854 if (EQ (action
, Qt
))
3855 return Ffile_name_all_completions (name
, realdir
);
3856 /* Only other case actually used is ACTION = lambda */
3858 /* Supposedly this helps commands such as `cd' that read directory names,
3859 but can someone explain how it helps them? -- RMS */
3860 if (XSTRING (name
)->size
== 0)
3863 return Ffile_exists_p (string
);
3866 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
3867 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
3868 Value is not expanded---you must call `expand-file-name' yourself.\n\
3869 Default name to DEFAULT if user enters a null string.\n\
3870 (If DEFAULT is omitted, the visited file name is used.)\n\
3871 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
3872 Non-nil and non-t means also require confirmation after completion.\n\
3873 Fifth arg INITIAL specifies text to start with.\n\
3874 DIR defaults to current buffer's directory default.")
3875 (prompt
, dir
, defalt
, mustmatch
, initial
)
3876 Lisp_Object prompt
, dir
, defalt
, mustmatch
, initial
;
3878 Lisp_Object val
, insdef
, insdef1
, tem
;
3879 struct gcpro gcpro1
, gcpro2
;
3880 register char *homedir
;
3884 dir
= current_buffer
->directory
;
3886 defalt
= current_buffer
->filename
;
3888 /* If dir starts with user's homedir, change that to ~. */
3889 homedir
= (char *) egetenv ("HOME");
3891 && XTYPE (dir
) == Lisp_String
3892 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
3893 && XSTRING (dir
)->data
[strlen (homedir
)] == '/')
3895 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
3896 XSTRING (dir
)->size
- strlen (homedir
) + 1);
3897 XSTRING (dir
)->data
[0] = '~';
3900 if (insert_default_directory
)
3903 if (!NILP (initial
))
3905 Lisp_Object args
[2], pos
;
3909 insdef
= Fconcat (2, args
);
3910 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
3911 insdef1
= Fcons (double_dollars (insdef
), pos
);
3914 insdef1
= double_dollars (insdef
);
3916 else if (!NILP (initial
))
3919 insdef1
= Fcons (double_dollars (insdef
), 0);
3922 insdef
= Qnil
, insdef1
= Qnil
;
3925 count
= specpdl_ptr
- specpdl
;
3926 specbind (intern ("completion-ignore-case"), Qt
);
3929 GCPRO2 (insdef
, defalt
);
3930 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
3931 dir
, mustmatch
, insdef1
,
3932 Qfile_name_history
);
3935 unbind_to (count
, Qnil
);
3940 error ("No file name specified");
3941 tem
= Fstring_equal (val
, insdef
);
3942 if (!NILP (tem
) && !NILP (defalt
))
3944 if (XSTRING (val
)->size
== 0 && NILP (insdef
))
3949 error ("No default file name");
3951 return Fsubstitute_in_file_name (val
);
3954 #if 0 /* Old version */
3955 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
3956 /* Don't confuse make-docfile by having two doc strings for this function.
3957 make-docfile does not pay attention to #if, for good reason! */
3959 (prompt
, dir
, defalt
, mustmatch
, initial
)
3960 Lisp_Object prompt
, dir
, defalt
, mustmatch
, initial
;
3962 Lisp_Object val
, insdef
, tem
;
3963 struct gcpro gcpro1
, gcpro2
;
3964 register char *homedir
;
3968 dir
= current_buffer
->directory
;
3970 defalt
= current_buffer
->filename
;
3972 /* If dir starts with user's homedir, change that to ~. */
3973 homedir
= (char *) egetenv ("HOME");
3975 && XTYPE (dir
) == Lisp_String
3976 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
3977 && XSTRING (dir
)->data
[strlen (homedir
)] == '/')
3979 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
3980 XSTRING (dir
)->size
- strlen (homedir
) + 1);
3981 XSTRING (dir
)->data
[0] = '~';
3984 if (!NILP (initial
))
3986 else if (insert_default_directory
)
3989 insdef
= build_string ("");
3992 count
= specpdl_ptr
- specpdl
;
3993 specbind (intern ("completion-ignore-case"), Qt
);
3996 GCPRO2 (insdef
, defalt
);
3997 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
3999 insert_default_directory
? insdef
: Qnil
,
4000 Qfile_name_history
);
4003 unbind_to (count
, Qnil
);
4008 error ("No file name specified");
4009 tem
= Fstring_equal (val
, insdef
);
4010 if (!NILP (tem
) && !NILP (defalt
))
4012 return Fsubstitute_in_file_name (val
);
4014 #endif /* Old version */
4018 Qexpand_file_name
= intern ("expand-file-name");
4019 Qdirectory_file_name
= intern ("directory-file-name");
4020 Qfile_name_directory
= intern ("file-name-directory");
4021 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
4022 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
4023 Qfile_name_as_directory
= intern ("file-name-as-directory");
4024 Qcopy_file
= intern ("copy-file");
4025 Qmake_directory_internal
= intern ("make-directory-internal");
4026 Qdelete_directory
= intern ("delete-directory");
4027 Qdelete_file
= intern ("delete-file");
4028 Qrename_file
= intern ("rename-file");
4029 Qadd_name_to_file
= intern ("add-name-to-file");
4030 Qmake_symbolic_link
= intern ("make-symbolic-link");
4031 Qfile_exists_p
= intern ("file-exists-p");
4032 Qfile_executable_p
= intern ("file-executable-p");
4033 Qfile_readable_p
= intern ("file-readable-p");
4034 Qfile_symlink_p
= intern ("file-symlink-p");
4035 Qfile_writable_p
= intern ("file-writable-p");
4036 Qfile_directory_p
= intern ("file-directory-p");
4037 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
4038 Qfile_modes
= intern ("file-modes");
4039 Qset_file_modes
= intern ("set-file-modes");
4040 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
4041 Qinsert_file_contents
= intern ("insert-file-contents");
4042 Qwrite_region
= intern ("write-region");
4043 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
4044 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
4046 staticpro (&Qexpand_file_name
);
4047 staticpro (&Qdirectory_file_name
);
4048 staticpro (&Qfile_name_directory
);
4049 staticpro (&Qfile_name_nondirectory
);
4050 staticpro (&Qunhandled_file_name_directory
);
4051 staticpro (&Qfile_name_as_directory
);
4052 staticpro (&Qcopy_file
);
4053 staticpro (&Qmake_directory_internal
);
4054 staticpro (&Qdelete_directory
);
4055 staticpro (&Qdelete_file
);
4056 staticpro (&Qrename_file
);
4057 staticpro (&Qadd_name_to_file
);
4058 staticpro (&Qmake_symbolic_link
);
4059 staticpro (&Qfile_exists_p
);
4060 staticpro (&Qfile_executable_p
);
4061 staticpro (&Qfile_readable_p
);
4062 staticpro (&Qfile_symlink_p
);
4063 staticpro (&Qfile_writable_p
);
4064 staticpro (&Qfile_directory_p
);
4065 staticpro (&Qfile_accessible_directory_p
);
4066 staticpro (&Qfile_modes
);
4067 staticpro (&Qset_file_modes
);
4068 staticpro (&Qfile_newer_than_file_p
);
4069 staticpro (&Qinsert_file_contents
);
4070 staticpro (&Qwrite_region
);
4071 staticpro (&Qverify_visited_file_modtime
);
4073 Qfile_name_history
= intern ("file-name-history");
4074 Fset (Qfile_name_history
, Qnil
);
4075 staticpro (&Qfile_name_history
);
4077 Qfile_error
= intern ("file-error");
4078 staticpro (&Qfile_error
);
4079 Qfile_already_exists
= intern("file-already-exists");
4080 staticpro (&Qfile_already_exists
);
4083 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
4084 staticpro (&Qfind_buffer_file_type
);
4087 Qcar_less_than_car
= intern ("car-less-than-car");
4088 staticpro (&Qcar_less_than_car
);
4090 Fput (Qfile_error
, Qerror_conditions
,
4091 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
4092 Fput (Qfile_error
, Qerror_message
,
4093 build_string ("File error"));
4095 Fput (Qfile_already_exists
, Qerror_conditions
,
4096 Fcons (Qfile_already_exists
,
4097 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
4098 Fput (Qfile_already_exists
, Qerror_message
,
4099 build_string ("File already exists"));
4101 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
4102 "*Non-nil means when reading a filename start with default dir in minibuffer.");
4103 insert_default_directory
= 1;
4105 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
4106 "*Non-nil means write new files with record format `stmlf'.\n\
4107 nil means use format `var'. This variable is meaningful only on VMS.");
4108 vms_stmlf_recfm
= 0;
4110 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
4111 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
4112 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
4115 The first argument given to HANDLER is the name of the I/O primitive\n\
4116 to be handled; the remaining arguments are the arguments that were\n\
4117 passed to that primitive. For example, if you do\n\
4118 (file-exists-p FILENAME)\n\
4119 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
4120 (funcall HANDLER 'file-exists-p FILENAME)\n\
4121 The function `find-file-name-handler' checks this list for a handler\n\
4122 for its argument.");
4123 Vfile_name_handler_alist
= Qnil
;
4125 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
4126 "A list of functions to be called at the end of `insert-file-contents'.\n\
4127 Each is passed one argument, the number of bytes inserted. It should return\n\
4128 the new byte count, and leave point the same. If `insert-file-contents' is\n\
4129 intercepted by a handler from `file-name-handler-alist', that handler is\n\
4130 responsible for calling the after-insert-file-functions if appropriate.");
4131 Vafter_insert_file_functions
= Qnil
;
4133 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
4134 "A list of functions to be called at the start of `write-region'.\n\
4135 Each is passed two arguments, START and END as for `write-region'. It should\n\
4136 return a list of pairs (POSITION . STRING) of strings to be effectively\n\
4137 inserted at the specified positions of the file being written (1 means to\n\
4138 insert before the first byte written). The POSITIONs must be sorted into\n\
4139 increasing order. If there are several functions in the list, the several\n\
4140 lists are merged destructively.");
4141 Vwrite_region_annotate_functions
= Qnil
;
4143 DEFVAR_LISP ("write-region-annotations-so-far",
4144 &Vwrite_region_annotations_so_far
,
4145 "When an annotation function is called, this holds the previous annotations.\n\
4146 These are the annotations made by other annotation functions\n\
4147 that were already called. See also `write-region-annotate-functions'.");
4148 Vwrite_region_annotations_so_far
= Qnil
;
4150 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
4151 "A list of file name handlers that temporarily should not be used.\n\
4152 This applies only to the operation `inhibit-file-name-operation'.");
4153 Vinhibit_file_name_handlers
= Qnil
;
4155 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
4156 "The operation for which `inhibit-file-name-handlers' is applicable.");
4157 Vinhibit_file_name_operation
= Qnil
;
4159 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
4160 "File name in which we write a list of all auto save file names.");
4161 Vauto_save_list_file_name
= Qnil
;
4163 defsubr (&Sfind_file_name_handler
);
4164 defsubr (&Sfile_name_directory
);
4165 defsubr (&Sfile_name_nondirectory
);
4166 defsubr (&Sunhandled_file_name_directory
);
4167 defsubr (&Sfile_name_as_directory
);
4168 defsubr (&Sdirectory_file_name
);
4169 defsubr (&Smake_temp_name
);
4170 defsubr (&Sexpand_file_name
);
4171 defsubr (&Ssubstitute_in_file_name
);
4172 defsubr (&Scopy_file
);
4173 defsubr (&Smake_directory_internal
);
4174 defsubr (&Sdelete_directory
);
4175 defsubr (&Sdelete_file
);
4176 defsubr (&Srename_file
);
4177 defsubr (&Sadd_name_to_file
);
4179 defsubr (&Smake_symbolic_link
);
4180 #endif /* S_IFLNK */
4182 defsubr (&Sdefine_logical_name
);
4185 defsubr (&Ssysnetunam
);
4186 #endif /* HPUX_NET */
4187 defsubr (&Sfile_name_absolute_p
);
4188 defsubr (&Sfile_exists_p
);
4189 defsubr (&Sfile_executable_p
);
4190 defsubr (&Sfile_readable_p
);
4191 defsubr (&Sfile_writable_p
);
4192 defsubr (&Sfile_symlink_p
);
4193 defsubr (&Sfile_directory_p
);
4194 defsubr (&Sfile_accessible_directory_p
);
4195 defsubr (&Sfile_modes
);
4196 defsubr (&Sset_file_modes
);
4197 defsubr (&Sset_default_file_modes
);
4198 defsubr (&Sdefault_file_modes
);
4199 defsubr (&Sfile_newer_than_file_p
);
4200 defsubr (&Sinsert_file_contents
);
4201 defsubr (&Swrite_region
);
4202 defsubr (&Scar_less_than_car
);
4203 defsubr (&Sverify_visited_file_modtime
);
4204 defsubr (&Sclear_visited_file_modtime
);
4205 defsubr (&Svisited_file_modtime
);
4206 defsubr (&Sset_visited_file_modtime
);
4207 defsubr (&Sdo_auto_save
);
4208 defsubr (&Sset_buffer_auto_saved
);
4209 defsubr (&Sclear_buffer_auto_save_failure
);
4210 defsubr (&Srecent_auto_save_p
);
4212 defsubr (&Sread_file_name_internal
);
4213 defsubr (&Sread_file_name
);
4216 defsubr (&Sunix_sync
);