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
; CONSP (chain
);
243 chain
= XCONS (chain
)->cdr
)
246 elt
= XCONS (chain
)->car
;
250 string
= XCONS (elt
)->car
;
251 if (STRINGP (string
) && fast_string_match (string
, filename
) >= 0)
253 Lisp_Object handler
, tem
;
255 handler
= XCONS (elt
)->cdr
;
256 tem
= Fmemq (handler
, inhibited_handlers
);
267 DEFUN ("file-name-directory", Ffile_name_directory
, Sfile_name_directory
,
269 "Return the directory component in file name NAME.\n\
270 Return nil if NAME does not include a directory.\n\
271 Otherwise return a directory spec.\n\
272 Given a Unix syntax file name, returns a string ending in slash;\n\
273 on VMS, perhaps instead a string ending in `:', `]' or `>'.")
277 register unsigned char *beg
;
278 register unsigned char *p
;
281 CHECK_STRING (file
, 0);
283 /* If the file name has special constructs in it,
284 call the corresponding file handler. */
285 handler
= Ffind_file_name_handler (file
, Qfile_name_directory
);
287 return call2 (handler
, Qfile_name_directory
, file
);
289 #ifdef FILE_SYSTEM_CASE
290 file
= FILE_SYSTEM_CASE (file
);
292 beg
= XSTRING (file
)->data
;
293 p
= beg
+ XSTRING (file
)->size
;
295 while (p
!= beg
&& p
[-1] != '/'
297 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
300 && p
[-1] != ':' && p
[-1] != '\\'
307 /* Expansion of "c:" to drive and default directory. */
308 if (p
== beg
+ 2 && beg
[1] == ':')
310 int drive
= (*beg
) - 'a';
311 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
312 unsigned char *res
= alloca (MAXPATHLEN
+ 5);
313 if (getdefdir (drive
+ 1, res
+ 2))
315 res
[0] = drive
+ 'a';
317 if (res
[strlen (res
) - 1] != '/')
320 p
= beg
+ strlen (beg
);
324 return make_string (beg
, p
- beg
);
327 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory
, Sfile_name_nondirectory
,
329 "Return file name NAME sans its directory.\n\
330 For example, in a Unix-syntax file name,\n\
331 this is everything after the last slash,\n\
332 or the entire name if it contains no slash.")
336 register unsigned char *beg
, *p
, *end
;
339 CHECK_STRING (file
, 0);
341 /* If the file name has special constructs in it,
342 call the corresponding file handler. */
343 handler
= Ffind_file_name_handler (file
, Qfile_name_nondirectory
);
345 return call2 (handler
, Qfile_name_nondirectory
, file
);
347 beg
= XSTRING (file
)->data
;
348 end
= p
= beg
+ XSTRING (file
)->size
;
350 while (p
!= beg
&& p
[-1] != '/'
352 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
355 && p
[-1] != ':' && p
[-1] != '\\'
359 return make_string (p
, end
- p
);
362 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory
, Sunhandled_file_name_directory
, 1, 1, 0,
363 "Return a directly usable directory name somehow associated with FILENAME.\n\
364 A `directly usable' directory name is one that may be used without the\n\
365 intervention of any file handler.\n\
366 If FILENAME is a directly usable file itself, return\n\
367 (file-name-directory FILENAME).\n\
368 The `call-process' and `start-process' functions use this function to\n\
369 get a current directory to run processes in.")
371 Lisp_Object filename
;
375 /* If the file name has special constructs in it,
376 call the corresponding file handler. */
377 handler
= Ffind_file_name_handler (filename
, Qunhandled_file_name_directory
);
379 return call2 (handler
, Qunhandled_file_name_directory
, filename
);
381 return Ffile_name_directory (filename
);
386 file_name_as_directory (out
, in
)
389 int size
= strlen (in
) - 1;
394 /* Is it already a directory string? */
395 if (in
[size
] == ':' || in
[size
] == ']' || in
[size
] == '>')
397 /* Is it a VMS directory file name? If so, hack VMS syntax. */
398 else if (! index (in
, '/')
399 && ((size
> 3 && ! strcmp (&in
[size
- 3], ".DIR"))
400 || (size
> 3 && ! strcmp (&in
[size
- 3], ".dir"))
401 || (size
> 5 && (! strncmp (&in
[size
- 5], ".DIR", 4)
402 || ! strncmp (&in
[size
- 5], ".dir", 4))
403 && (in
[size
- 1] == '.' || in
[size
- 1] == ';')
404 && in
[size
] == '1')))
406 register char *p
, *dot
;
410 dir:x.dir --> dir:[x]
411 dir:[x]y.dir --> dir:[x.y] */
413 while (p
!= in
&& *p
!= ':' && *p
!= '>' && *p
!= ']') p
--;
416 strncpy (out
, in
, p
- in
);
435 dot
= index (p
, '.');
438 /* blindly remove any extension */
439 size
= strlen (out
) + (dot
- p
);
440 strncat (out
, p
, dot
- p
);
451 /* For Unix syntax, Append a slash if necessary */
453 if (out
[size
] != ':' && out
[size
] != '/' && out
[size
] != '\\')
455 if (out
[size
] != '/')
462 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
463 Sfile_name_as_directory
, 1, 1, 0,
464 "Return a string representing file FILENAME interpreted as a directory.\n\
465 This operation exists because a directory is also a file, but its name as\n\
466 a directory is different from its name as a file.\n\
467 The result can be used as the value of `default-directory'\n\
468 or passed as second argument to `expand-file-name'.\n\
469 For a Unix-syntax file name, just appends a slash.\n\
470 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
477 CHECK_STRING (file
, 0);
481 /* If the file name has special constructs in it,
482 call the corresponding file handler. */
483 handler
= Ffind_file_name_handler (file
, Qfile_name_as_directory
);
485 return call2 (handler
, Qfile_name_as_directory
, file
);
487 buf
= (char *) alloca (XSTRING (file
)->size
+ 10);
488 return build_string (file_name_as_directory (buf
, XSTRING (file
)->data
));
492 * Convert from directory name to filename.
494 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
495 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
496 * On UNIX, it's simple: just make sure there is a terminating /
498 * Value is nonzero if the string output is different from the input.
501 directory_file_name (src
, dst
)
509 struct FAB fab
= cc$rms_fab
;
510 struct NAM nam
= cc$rms_nam
;
511 char esa
[NAM$C_MAXRSS
];
516 if (! index (src
, '/')
517 && (src
[slen
- 1] == ']'
518 || src
[slen
- 1] == ':'
519 || src
[slen
- 1] == '>'))
521 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
523 fab
.fab$b_fns
= slen
;
524 fab
.fab$l_nam
= &nam
;
525 fab
.fab$l_fop
= FAB$M_NAM
;
528 nam
.nam$b_ess
= sizeof esa
;
529 nam
.nam$b_nop
|= NAM$M_SYNCHK
;
531 /* We call SYS$PARSE to handle such things as [--] for us. */
532 if (SYS$
PARSE(&fab
, 0, 0) == RMS$_NORMAL
)
534 slen
= nam
.nam$b_esl
;
535 if (esa
[slen
- 1] == ';' && esa
[slen
- 2] == '.')
540 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
542 /* what about when we have logical_name:???? */
543 if (src
[slen
- 1] == ':')
544 { /* Xlate logical name and see what we get */
545 ptr
= strcpy (dst
, src
); /* upper case for getenv */
548 if ('a' <= *ptr
&& *ptr
<= 'z')
552 dst
[slen
- 1] = 0; /* remove colon */
553 if (!(src
= egetenv (dst
)))
555 /* should we jump to the beginning of this procedure?
556 Good points: allows us to use logical names that xlate
558 Bad points: can be a problem if we just translated to a device
560 For now, I'll punt and always expect VMS names, and hope for
563 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
564 { /* no recursion here! */
570 { /* not a directory spec */
575 bracket
= src
[slen
- 1];
577 /* If bracket is ']' or '>', bracket - 2 is the corresponding
579 ptr
= index (src
, bracket
- 2);
581 { /* no opening bracket */
585 if (!(rptr
= rindex (src
, '.')))
588 strncpy (dst
, src
, slen
);
592 dst
[slen
++] = bracket
;
597 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
598 then translate the device and recurse. */
599 if (dst
[slen
- 1] == ':'
600 && dst
[slen
- 2] != ':' /* skip decnet nodes */
601 && strcmp(src
+ slen
, "[000000]") == 0)
603 dst
[slen
- 1] = '\0';
604 if ((ptr
= egetenv (dst
))
605 && (rlen
= strlen (ptr
) - 1) > 0
606 && (ptr
[rlen
] == ']' || ptr
[rlen
] == '>')
607 && ptr
[rlen
- 1] == '.')
609 char * buf
= (char *) alloca (strlen (ptr
) + 1);
613 return directory_file_name (buf
, dst
);
618 strcat (dst
, "[000000]");
622 rlen
= strlen (rptr
) - 1;
623 strncat (dst
, rptr
, rlen
);
624 dst
[slen
+ rlen
] = '\0';
625 strcat (dst
, ".DIR.1");
629 /* Process as Unix format: just remove any final slash.
630 But leave "/" unchanged; do not change it to "". */
634 && (dst
[slen
- 1] == '/' || dst
[slen
- 1] == '/')
635 && dst
[slen
- 2] != ':'
637 && dst
[slen
- 1] == '/'
644 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
646 "Returns the file name of the directory named DIR.\n\
647 This is the name of the file that holds the data for the directory DIR.\n\
648 This operation exists because a directory is also a file, but its name as\n\
649 a directory is different from its name as a file.\n\
650 In Unix-syntax, this function just removes the final slash.\n\
651 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
652 it returns a file name such as \"[X]Y.DIR.1\".")
654 Lisp_Object directory
;
659 CHECK_STRING (directory
, 0);
661 if (NILP (directory
))
664 /* If the file name has special constructs in it,
665 call the corresponding file handler. */
666 handler
= Ffind_file_name_handler (directory
, Qdirectory_file_name
);
668 return call2 (handler
, Qdirectory_file_name
, directory
);
671 /* 20 extra chars is insufficient for VMS, since we might perform a
672 logical name translation. an equivalence string can be up to 255
673 chars long, so grab that much extra space... - sss */
674 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20 + 255);
676 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20);
678 directory_file_name (XSTRING (directory
)->data
, buf
);
679 return build_string (buf
);
682 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
683 "Generate temporary file name (string) starting with PREFIX (a string).\n\
684 The Emacs process number forms part of the result,\n\
685 so there is no danger of generating a name being used by another process.")
690 val
= concat2 (prefix
, build_string ("XXXXXX"));
691 mktemp (XSTRING (val
)->data
);
695 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
696 "Convert FILENAME to absolute, and canonicalize it.\n\
697 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
698 (does not start with slash); if DEFAULT is nil or missing,\n\
699 the current buffer's value of default-directory is used.\n\
700 Path components that are `.' are removed, and \n\
701 path components followed by `..' are removed, along with the `..' itself;\n\
702 note that these simplifications are done without checking the resulting\n\
703 paths in the file system.\n\
704 An initial `~/' expands to your home directory.\n\
705 An initial `~USER/' expands to USER's home directory.\n\
706 See also the function `substitute-in-file-name'.")
708 Lisp_Object name
, defalt
;
712 register unsigned char *newdir
, *p
, *o
;
714 unsigned char *target
;
717 unsigned char * colon
= 0;
718 unsigned char * close
= 0;
719 unsigned char * slash
= 0;
720 unsigned char * brack
= 0;
721 int lbrack
= 0, rbrack
= 0;
724 #ifdef MSDOS /* Demacs 1.1.2 91/10/20 Manabu Higashida */
727 unsigned char *tmp
, *defdir
;
731 CHECK_STRING (name
, 0);
733 /* If the file name has special constructs in it,
734 call the corresponding file handler. */
735 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
737 return call3 (handler
, Qexpand_file_name
, name
, defalt
);
739 /* Use the buffer's default-directory if DEFALT is omitted. */
741 defalt
= current_buffer
->directory
;
742 CHECK_STRING (defalt
, 1);
744 /* Make sure DEFALT is properly expanded.
745 It would be better to do this down below where we actually use
746 defalt. Unfortunately, calling Fexpand_file_name recursively
747 could invoke GC, and the strings might be relocated. This would
748 be annoying because we have pointers into strings lying around
749 that would need adjusting, and people would add new pointers to
750 the code and forget to adjust them, resulting in intermittent bugs.
751 Putting this call here avoids all that crud.
753 The EQ test avoids infinite recursion. */
754 if (! NILP (defalt
) && !EQ (defalt
, name
)
755 /* This saves time in a common case. */
756 && XSTRING (defalt
)->data
[0] != '/')
761 defalt
= Fexpand_file_name (defalt
, Qnil
);
766 /* Filenames on VMS are always upper case. */
767 name
= Fupcase (name
);
769 #ifdef FILE_SYSTEM_CASE
770 name
= FILE_SYSTEM_CASE (name
);
773 nm
= XSTRING (name
)->data
;
776 /* First map all backslashes to slashes. */
777 dostounix_filename (nm
= strcpy (alloca (strlen (nm
) + 1), nm
));
779 /* Now strip drive name. */
781 unsigned char *colon
= rindex (nm
, ':');
787 drive
= tolower (colon
[-1]) - 'a';
791 defdir
= alloca (MAXPATHLEN
+ 1);
792 relpath
= getdefdir (drive
+ 1, defdir
);
798 /* If nm is absolute, flush ...// and detect /./ and /../.
799 If no /./ or /../ we can return right away. */
807 /* If it turns out that the filename we want to return is just a
808 suffix of FILENAME, we don't need to go through and edit
809 things; we just need to construct a new string using data
810 starting at the middle of FILENAME. If we set lose to a
811 non-zero value, that means we've discovered that we can't do
818 /* Since we know the path is absolute, we can assume that each
819 element starts with a "/". */
821 /* "//" anywhere isn't necessarily hairy; we just start afresh
822 with the second slash. */
823 if (p
[0] == '/' && p
[1] == '/'
825 /* // at start of filename is meaningful on Apollo system */
831 /* "~" is hairy as the start of any path element. */
832 if (p
[0] == '/' && p
[1] == '~')
833 nm
= p
+ 1, lose
= 1;
835 /* "." and ".." are hairy. */
840 || (p
[2] == '.' && (p
[3] == '/'
847 /* if dev:[dir]/, move nm to / */
848 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
849 nm
= (brack
? brack
+ 1 : colon
+ 1);
858 /* VMS pre V4.4,convert '-'s in filenames. */
859 if (lbrack
== rbrack
)
861 if (dots
< 2) /* this is to allow negative version numbers */
866 if (lbrack
> rbrack
&&
867 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
868 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
874 /* count open brackets, reset close bracket pointer */
875 if (p
[0] == '[' || p
[0] == '<')
877 /* count close brackets, set close bracket pointer */
878 if (p
[0] == ']' || p
[0] == '>')
880 /* detect ][ or >< */
881 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
883 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
884 nm
= p
+ 1, lose
= 1;
885 if (p
[0] == ':' && (colon
|| slash
))
886 /* if dev1:[dir]dev2:, move nm to dev2: */
892 /* if /pathname/dev:, move nm to dev: */
895 /* if node::dev:, move colon following dev */
896 else if (colon
&& colon
[-1] == ':')
898 /* if dev1:dev2:, move nm to dev2: */
899 else if (colon
&& colon
[-1] != ':')
904 if (p
[0] == ':' && !colon
)
910 if (lbrack
== rbrack
)
913 else if (p
[0] == '.')
922 return build_string (sys_translate_unix (nm
));
925 if (nm
== XSTRING (name
)->data
)
927 return build_string (nm
);
932 /* Now determine directory to start with and put it in newdir */
936 if (nm
[0] == '~') /* prefix ~ */
942 || nm
[1] == 0) /* ~ by itself */
944 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
945 newdir
= (unsigned char *) "";
947 dostounix_filename (newdir
);
951 nm
++; /* Don't leave the slash in nm. */
954 else /* ~user/filename */
956 for (p
= nm
; *p
&& (*p
!= '/'
961 o
= (unsigned char *) alloca (p
- nm
+ 1);
962 bcopy ((char *) nm
, o
, p
- nm
);
965 pw
= (struct passwd
*) getpwnam (o
+ 1);
968 newdir
= (unsigned char *) pw
-> pw_dir
;
970 nm
= p
+ 1; /* skip the terminator */
976 /* If we don't find a user of that name, leave the name
977 unchanged; don't move nm forward to p. */
990 newdir
= XSTRING (defalt
)->data
;
994 if (newdir
== 0 && relpath
)
999 /* Get rid of any slash at the end of newdir. */
1000 int length
= strlen (newdir
);
1001 /* Adding `length > 1 &&' makes ~ expand into / when homedir
1002 is the root dir. People disagree about whether that is right.
1003 Anyway, we can't take the risk of this change now. */
1005 if (newdir
[1] != ':' && length
> 1)
1007 if (newdir
[length
- 1] == '/')
1009 unsigned char *temp
= (unsigned char *) alloca (length
);
1010 bcopy (newdir
, temp
, length
- 1);
1011 temp
[length
- 1] = 0;
1019 /* Now concatenate the directory and name to new space in the stack frame */
1020 tlen
+= strlen (nm
) + 1;
1022 /* Add reserved space for drive name. */
1023 target
= (unsigned char *) alloca (tlen
+ 2) + 2;
1025 target
= (unsigned char *) alloca (tlen
);
1032 if (nm
[0] == 0 || nm
[0] == '/')
1033 strcpy (target
, newdir
);
1036 file_name_as_directory (target
, newdir
);
1039 strcat (target
, nm
);
1041 if (index (target
, '/'))
1042 strcpy (target
, sys_translate_unix (target
));
1045 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1053 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1059 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1060 /* brackets are offset from each other by 2 */
1063 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1064 /* convert [foo][bar] to [bar] */
1065 while (o
[-1] != '[' && o
[-1] != '<')
1067 else if (*p
== '-' && *o
!= '.')
1070 else if (p
[0] == '-' && o
[-1] == '.' &&
1071 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1072 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1076 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1077 if (p
[1] == '.') /* foo.-.bar ==> bar*/
1079 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1081 /* else [foo.-] ==> [-] */
1087 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1088 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1098 else if (!strncmp (p
, "//", 2)
1100 /* // at start of filename is meaningful in Apollo system */
1108 else if (p
[0] == '/'
1113 /* If "/." is the entire filename, keep the "/". Otherwise,
1114 just delete the whole "/.". */
1115 if (o
== target
&& p
[2] == '\0')
1119 else if (!strncmp (p
, "/..", 3)
1120 /* `/../' is the "superroot" on certain file systems. */
1122 && (p
[3] == '/' || p
[3] == 0))
1124 while (o
!= target
&& *--o
!= '/')
1127 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1131 if (o
== target
&& *o
== '/')
1139 #endif /* not VMS */
1143 /* at last, set drive name. */
1144 if (target
[1] != ':')
1147 target
[0] = (drive
< 0 ? getdisk () : drive
) + 'a';
1152 return make_string (target
, o
- target
);
1155 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'.
1156 DEAFUN ("expand-file-name", Fexpand_file_name, Sexpand_file_name, 1, 2, 0,
1157 "Convert FILENAME to absolute, and canonicalize it.\n\
1158 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1159 (does not start with slash); if DEFAULT is nil or missing,\n\
1160 the current buffer's value of default-directory is used.\n\
1161 Filenames containing `.' or `..' as components are simplified;\n\
1162 initial `~/' expands to your home directory.\n\
1163 See also the function `substitute-in-file-name'.")
1165 Lisp_Object name, defalt;
1169 register unsigned char *newdir, *p, *o;
1171 unsigned char *target;
1175 unsigned char * colon = 0;
1176 unsigned char * close = 0;
1177 unsigned char * slash = 0;
1178 unsigned char * brack = 0;
1179 int lbrack = 0, rbrack = 0;
1183 CHECK_STRING (name
, 0);
1186 /* Filenames on VMS are always upper case. */
1187 name
= Fupcase (name
);
1190 nm
= XSTRING (name
)->data
;
1192 /* If nm is absolute, flush ...// and detect /./ and /../.
1193 If no /./ or /../ we can return right away. */
1205 if (p
[0] == '/' && p
[1] == '/'
1207 /* // at start of filename is meaningful on Apollo system */
1212 if (p
[0] == '/' && p
[1] == '~')
1213 nm
= p
+ 1, lose
= 1;
1214 if (p
[0] == '/' && p
[1] == '.'
1215 && (p
[2] == '/' || p
[2] == 0
1216 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1222 /* if dev:[dir]/, move nm to / */
1223 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1224 nm
= (brack
? brack
+ 1 : colon
+ 1);
1225 lbrack
= rbrack
= 0;
1233 /* VMS pre V4.4,convert '-'s in filenames. */
1234 if (lbrack
== rbrack
)
1236 if (dots
< 2) /* this is to allow negative version numbers */
1241 if (lbrack
> rbrack
&&
1242 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1243 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1249 /* count open brackets, reset close bracket pointer */
1250 if (p
[0] == '[' || p
[0] == '<')
1251 lbrack
++, brack
= 0;
1252 /* count close brackets, set close bracket pointer */
1253 if (p
[0] == ']' || p
[0] == '>')
1254 rbrack
++, brack
= p
;
1255 /* detect ][ or >< */
1256 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1258 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1259 nm
= p
+ 1, lose
= 1;
1260 if (p
[0] == ':' && (colon
|| slash
))
1261 /* if dev1:[dir]dev2:, move nm to dev2: */
1267 /* if /pathname/dev:, move nm to dev: */
1270 /* if node::dev:, move colon following dev */
1271 else if (colon
&& colon
[-1] == ':')
1273 /* if dev1:dev2:, move nm to dev2: */
1274 else if (colon
&& colon
[-1] != ':')
1279 if (p
[0] == ':' && !colon
)
1285 if (lbrack
== rbrack
)
1288 else if (p
[0] == '.')
1296 if (index (nm
, '/'))
1297 return build_string (sys_translate_unix (nm
));
1299 if (nm
== XSTRING (name
)->data
)
1301 return build_string (nm
);
1305 /* Now determine directory to start with and put it in NEWDIR */
1309 if (nm
[0] == '~') /* prefix ~ */
1314 || nm
[1] == 0)/* ~/filename */
1316 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1317 newdir
= (unsigned char *) "";
1320 nm
++; /* Don't leave the slash in nm. */
1323 else /* ~user/filename */
1325 /* Get past ~ to user */
1326 unsigned char *user
= nm
+ 1;
1327 /* Find end of name. */
1328 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1329 int len
= ptr
? ptr
- user
: strlen (user
);
1331 unsigned char *ptr1
= index (user
, ':');
1332 if (ptr1
!= 0 && ptr1
- user
< len
)
1335 /* Copy the user name into temp storage. */
1336 o
= (unsigned char *) alloca (len
+ 1);
1337 bcopy ((char *) user
, o
, len
);
1340 /* Look up the user name. */
1341 pw
= (struct passwd
*) getpwnam (o
+ 1);
1343 error ("\"%s\" isn't a registered user", o
+ 1);
1345 newdir
= (unsigned char *) pw
->pw_dir
;
1347 /* Discard the user name from NM. */
1354 #endif /* not VMS */
1358 defalt
= current_buffer
->directory
;
1359 CHECK_STRING (defalt
, 1);
1360 newdir
= XSTRING (defalt
)->data
;
1363 /* Now concatenate the directory and name to new space in the stack frame */
1365 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1366 target
= (unsigned char *) alloca (tlen
);
1372 if (nm
[0] == 0 || nm
[0] == '/')
1373 strcpy (target
, newdir
);
1376 file_name_as_directory (target
, newdir
);
1379 strcat (target
, nm
);
1381 if (index (target
, '/'))
1382 strcpy (target
, sys_translate_unix (target
));
1385 /* Now canonicalize by removing /. and /foo/.. if they appear */
1393 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1399 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1400 /* brackets are offset from each other by 2 */
1403 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1404 /* convert [foo][bar] to [bar] */
1405 while (o
[-1] != '[' && o
[-1] != '<')
1407 else if (*p
== '-' && *o
!= '.')
1410 else if (p
[0] == '-' && o
[-1] == '.' &&
1411 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1412 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1416 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1417 if (p
[1] == '.') /* foo.-.bar ==> bar*/
1419 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1421 /* else [foo.-] ==> [-] */
1427 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1428 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1438 else if (!strncmp (p
, "//", 2)
1440 /* // at start of filename is meaningful in Apollo system */
1448 else if (p
[0] == '/' && p
[1] == '.' &&
1449 (p
[2] == '/' || p
[2] == 0))
1451 else if (!strncmp (p
, "/..", 3)
1452 /* `/../' is the "superroot" on certain file systems. */
1454 && (p
[3] == '/' || p
[3] == 0))
1456 while (o
!= target
&& *--o
!= '/')
1459 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1463 if (o
== target
&& *o
== '/')
1471 #endif /* not VMS */
1474 return make_string (target
, o
- target
);
1478 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1479 Ssubstitute_in_file_name
, 1, 1, 0,
1480 "Substitute environment variables referred to in FILENAME.\n\
1481 `$FOO' where FOO is an environment variable name means to substitute\n\
1482 the value of that variable. The variable name should be terminated\n\
1483 with a character not a letter, digit or underscore; otherwise, enclose\n\
1484 the entire variable name in braces.\n\
1485 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1486 On VMS, `$' substitution is not done; this function does little and only\n\
1487 duplicates what `expand-file-name' does.")
1493 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1494 unsigned char *target
;
1496 int substituted
= 0;
1499 CHECK_STRING (string
, 0);
1501 nm
= XSTRING (string
)->data
;
1503 dostounix_filename (nm
= strcpy (alloca (strlen (nm
) + 1), nm
));
1504 substituted
= !strcmp (nm
, XSTRING (string
)->data
);
1506 endp
= nm
+ XSTRING (string
)->size
;
1508 /* If /~ or // appears, discard everything through first slash. */
1510 for (p
= nm
; p
!= endp
; p
++)
1514 /* // at start of file name is meaningful in Apollo system */
1515 (p
[0] == '/' && p
- 1 != nm
)
1516 #else /* not APOLLO */
1518 #endif /* not APOLLO */
1522 (p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>' ||
1533 if (p
[0] && p
[1] == ':')
1542 return build_string (nm
);
1545 /* See if any variables are substituted into the string
1546 and find the total length of their values in `total' */
1548 for (p
= nm
; p
!= endp
;)
1558 /* "$$" means a single "$" */
1567 while (p
!= endp
&& *p
!= '}') p
++;
1568 if (*p
!= '}') goto missingclose
;
1574 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1578 /* Copy out the variable name */
1579 target
= (unsigned char *) alloca (s
- o
+ 1);
1580 strncpy (target
, o
, s
- o
);
1583 strupr (target
); /* $home == $HOME etc. */
1586 /* Get variable value */
1587 o
= (unsigned char *) egetenv (target
);
1588 if (!o
) goto badvar
;
1589 total
+= strlen (o
);
1596 /* If substitution required, recopy the string and do it */
1597 /* Make space in stack frame for the new copy */
1598 xnm
= (unsigned char *) alloca (XSTRING (string
)->size
+ total
+ 1);
1601 /* Copy the rest of the name through, replacing $ constructs with values */
1618 while (p
!= endp
&& *p
!= '}') p
++;
1619 if (*p
!= '}') goto missingclose
;
1625 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1629 /* Copy out the variable name */
1630 target
= (unsigned char *) alloca (s
- o
+ 1);
1631 strncpy (target
, o
, s
- o
);
1634 strupr (target
); /* $home == $HOME etc. */
1637 /* Get variable value */
1638 o
= (unsigned char *) egetenv (target
);
1648 /* If /~ or // appears, discard everything through first slash. */
1650 for (p
= xnm
; p
!= x
; p
++)
1653 /* // at start of file name is meaningful in Apollo system */
1654 (p
[0] == '/' && p
- 1 != xnm
)
1655 #else /* not APOLLO */
1657 #endif /* not APOLLO */
1659 && p
!= nm
&& p
[-1] == '/')
1662 else if (p
[0] && p
[1] == ':')
1666 return make_string (xnm
, x
- xnm
);
1669 error ("Bad format environment-variable substitution");
1671 error ("Missing \"}\" in environment-variable substitution");
1673 error ("Substituting nonexistent environment variable \"%s\"", target
);
1676 #endif /* not VMS */
1679 /* A slightly faster and more convenient way to get
1680 (directory-file-name (expand-file-name FOO)). */
1683 expand_and_dir_to_file (filename
, defdir
)
1684 Lisp_Object filename
, defdir
;
1686 register Lisp_Object abspath
;
1688 abspath
= Fexpand_file_name (filename
, defdir
);
1691 register int c
= XSTRING (abspath
)->data
[XSTRING (abspath
)->size
- 1];
1692 if (c
== ':' || c
== ']' || c
== '>')
1693 abspath
= Fdirectory_file_name (abspath
);
1696 /* Remove final slash, if any (unless path is root).
1697 stat behaves differently depending! */
1698 if (XSTRING (abspath
)->size
> 1
1699 && XSTRING (abspath
)->data
[XSTRING (abspath
)->size
- 1] == '/')
1700 /* We cannot take shortcuts; they might be wrong for magic file names. */
1701 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 || INTEGERP (ok_if_already_exists
))
1775 barf_or_query_if_file_exists (newname
, "copy to it",
1776 INTEGERP (ok_if_already_exists
));
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 if (set_file_times (XSTRING (newname
)->data
, atime
, mtime
))
1837 report_file_error ("I/O error", Fcons (newname
, Qnil
));
1840 if (!egetenv ("USE_DOMAIN_ACLS"))
1842 chmod (XSTRING (newname
)->data
, st
.st_mode
& 07777);
1847 /* Discard the unwind protects. */
1848 specpdl_ptr
= specpdl
+ count
;
1854 DEFUN ("make-directory-internal", Fmake_directory_internal
,
1855 Smake_directory_internal
, 1, 1, 0,
1856 "Create a directory. One argument, a file name string.")
1858 Lisp_Object dirname
;
1861 Lisp_Object handler
;
1863 CHECK_STRING (dirname
, 0);
1864 dirname
= Fexpand_file_name (dirname
, Qnil
);
1866 handler
= Ffind_file_name_handler (dirname
, Qmake_directory_internal
);
1867 if (!NILP (handler
))
1868 return call2 (handler
, Qmake_directory_internal
, dirname
);
1870 dir
= XSTRING (dirname
)->data
;
1872 if (mkdir (dir
, 0777) != 0)
1873 report_file_error ("Creating directory", Flist (1, &dirname
));
1878 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
1879 "Delete a directory. One argument, a file name or directory name string.")
1881 Lisp_Object dirname
;
1884 Lisp_Object handler
;
1886 CHECK_STRING (dirname
, 0);
1887 dirname
= Fdirectory_file_name (Fexpand_file_name (dirname
, Qnil
));
1888 dir
= XSTRING (dirname
)->data
;
1890 handler
= Ffind_file_name_handler (dirname
, Qdelete_directory
);
1891 if (!NILP (handler
))
1892 return call2 (handler
, Qdelete_directory
, dirname
);
1894 if (rmdir (dir
) != 0)
1895 report_file_error ("Removing directory", Flist (1, &dirname
));
1900 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
1901 "Delete specified file. One argument, a file name string.\n\
1902 If file has multiple names, it continues to exist with the other names.")
1904 Lisp_Object filename
;
1906 Lisp_Object handler
;
1907 CHECK_STRING (filename
, 0);
1908 filename
= Fexpand_file_name (filename
, Qnil
);
1910 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
1911 if (!NILP (handler
))
1912 return call2 (handler
, Qdelete_file
, filename
);
1914 if (0 > unlink (XSTRING (filename
)->data
))
1915 report_file_error ("Removing old name", Flist (1, &filename
));
1919 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
1920 "fRename file: \nFRename %s to file: \np",
1921 "Rename FILE as NEWNAME. Both args strings.\n\
1922 If file has names other than FILE, it continues to have those names.\n\
1923 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
1924 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
1925 A number as third arg means request confirmation if NEWNAME already exists.\n\
1926 This is what happens in interactive use with M-x.")
1927 (filename
, newname
, ok_if_already_exists
)
1928 Lisp_Object filename
, newname
, ok_if_already_exists
;
1931 Lisp_Object args
[2];
1933 Lisp_Object handler
;
1934 struct gcpro gcpro1
, gcpro2
;
1936 GCPRO2 (filename
, newname
);
1937 CHECK_STRING (filename
, 0);
1938 CHECK_STRING (newname
, 1);
1939 filename
= Fexpand_file_name (filename
, Qnil
);
1940 newname
= Fexpand_file_name (newname
, Qnil
);
1942 /* If the file name has special constructs in it,
1943 call the corresponding file handler. */
1944 handler
= Ffind_file_name_handler (filename
, Qrename_file
);
1946 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
1947 if (!NILP (handler
))
1948 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
1949 filename
, newname
, ok_if_already_exists
));
1951 if (NILP (ok_if_already_exists
)
1952 || INTEGERP (ok_if_already_exists
))
1953 barf_or_query_if_file_exists (newname
, "rename to it",
1954 INTEGERP (ok_if_already_exists
));
1956 if (0 > rename (XSTRING (filename
)->data
, XSTRING (newname
)->data
))
1958 if (0 > link (XSTRING (filename
)->data
, XSTRING (newname
)->data
)
1959 || 0 > unlink (XSTRING (filename
)->data
))
1964 Fcopy_file (filename
, newname
,
1965 /* We have already prompted if it was an integer,
1966 so don't have copy-file prompt again. */
1967 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
1968 Fdelete_file (filename
);
1975 report_file_error ("Renaming", Flist (2, args
));
1978 report_file_error ("Renaming", Flist (2, &filename
));
1985 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
1986 "fAdd name to file: \nFName to add to %s: \np",
1987 "Give FILE additional name NEWNAME. Both args strings.\n\
1988 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
1989 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
1990 A number as third arg means request confirmation if NEWNAME already exists.\n\
1991 This is what happens in interactive use with M-x.")
1992 (filename
, newname
, ok_if_already_exists
)
1993 Lisp_Object filename
, newname
, ok_if_already_exists
;
1996 Lisp_Object args
[2];
1998 Lisp_Object handler
;
1999 struct gcpro gcpro1
, gcpro2
;
2001 GCPRO2 (filename
, newname
);
2002 CHECK_STRING (filename
, 0);
2003 CHECK_STRING (newname
, 1);
2004 filename
= Fexpand_file_name (filename
, Qnil
);
2005 newname
= Fexpand_file_name (newname
, Qnil
);
2007 /* If the file name has special constructs in it,
2008 call the corresponding file handler. */
2009 handler
= Ffind_file_name_handler (filename
, Qadd_name_to_file
);
2010 if (!NILP (handler
))
2011 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, filename
,
2012 newname
, ok_if_already_exists
));
2014 if (NILP (ok_if_already_exists
)
2015 || INTEGERP (ok_if_already_exists
))
2016 barf_or_query_if_file_exists (newname
, "make it a new name",
2017 INTEGERP (ok_if_already_exists
));
2018 unlink (XSTRING (newname
)->data
);
2019 if (0 > link (XSTRING (filename
)->data
, XSTRING (newname
)->data
))
2024 report_file_error ("Adding new name", Flist (2, args
));
2026 report_file_error ("Adding new name", Flist (2, &filename
));
2035 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2036 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2037 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
2038 Signals a `file-already-exists' error if a file LINKNAME already exists\n\
2039 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2040 A number as third arg means request confirmation if LINKNAME already exists.\n\
2041 This happens for interactive use with M-x.")
2042 (filename
, linkname
, ok_if_already_exists
)
2043 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2046 Lisp_Object args
[2];
2048 Lisp_Object handler
;
2049 struct gcpro gcpro1
, gcpro2
;
2051 GCPRO2 (filename
, linkname
);
2052 CHECK_STRING (filename
, 0);
2053 CHECK_STRING (linkname
, 1);
2054 /* If the link target has a ~, we must expand it to get
2055 a truly valid file name. Otherwise, do not expand;
2056 we want to permit links to relative file names. */
2057 if (XSTRING (filename
)->data
[0] == '~')
2058 filename
= Fexpand_file_name (filename
, Qnil
);
2059 linkname
= Fexpand_file_name (linkname
, Qnil
);
2061 /* If the file name has special constructs in it,
2062 call the corresponding file handler. */
2063 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2064 if (!NILP (handler
))
2065 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2066 linkname
, ok_if_already_exists
));
2068 if (NILP (ok_if_already_exists
)
2069 || INTEGERP (ok_if_already_exists
))
2070 barf_or_query_if_file_exists (linkname
, "make it a link",
2071 INTEGERP (ok_if_already_exists
));
2072 if (0 > symlink (XSTRING (filename
)->data
, XSTRING (linkname
)->data
))
2074 /* If we didn't complain already, silently delete existing file. */
2075 if (errno
== EEXIST
)
2077 unlink (XSTRING (linkname
)->data
);
2078 if (0 <= symlink (XSTRING (filename
)->data
, XSTRING (linkname
)->data
))
2088 report_file_error ("Making symbolic link", Flist (2, args
));
2090 report_file_error ("Making symbolic link", Flist (2, &filename
));
2096 #endif /* S_IFLNK */
2100 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2101 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2102 "Define the job-wide logical name NAME to have the value STRING.\n\
2103 If STRING is nil or a null string, the logical name NAME is deleted.")
2105 Lisp_Object varname
;
2108 CHECK_STRING (varname
, 0);
2110 delete_logical_name (XSTRING (varname
)->data
);
2113 CHECK_STRING (string
, 1);
2115 if (XSTRING (string
)->size
== 0)
2116 delete_logical_name (XSTRING (varname
)->data
);
2118 define_logical_name (XSTRING (varname
)->data
, XSTRING (string
)->data
);
2127 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2128 "Open a network connection to PATH using LOGIN as the login string.")
2130 Lisp_Object path
, login
;
2134 CHECK_STRING (path
, 0);
2135 CHECK_STRING (login
, 0);
2137 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2139 if (netresult
== -1)
2144 #endif /* HPUX_NET */
2146 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2148 "Return t if file FILENAME specifies an absolute path name.\n\
2149 On Unix, this is a name starting with a `/' or a `~'.")
2151 Lisp_Object filename
;
2155 CHECK_STRING (filename
, 0);
2156 ptr
= XSTRING (filename
)->data
;
2157 if (*ptr
== '/' || *ptr
== '~'
2159 /* ??? This criterion is probably wrong for '<'. */
2160 || index (ptr
, ':') || index (ptr
, '<')
2161 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2165 || (*ptr
!= 0 && ptr
[1] == ':' && (ptr
[2] == '/' || ptr
[2] == '\\'))
2173 /* Return nonzero if file FILENAME exists and can be executed. */
2176 check_executable (filename
)
2180 return (eaccess (filename
, 1) >= 0);
2182 /* Access isn't quite right because it uses the real uid
2183 and we really want to test with the effective uid.
2184 But Unix doesn't give us a right way to do it. */
2185 return (access (filename
, 1) >= 0);
2189 /* Return nonzero if file FILENAME exists and can be written. */
2192 check_writable (filename
)
2196 return (eaccess (filename
, 2) >= 0);
2198 /* Access isn't quite right because it uses the real uid
2199 and we really want to test with the effective uid.
2200 But Unix doesn't give us a right way to do it.
2201 Opening with O_WRONLY could work for an ordinary file,
2202 but would lose for directories. */
2203 return (access (filename
, 2) >= 0);
2207 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2208 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
2209 See also `file-readable-p' and `file-attributes'.")
2211 Lisp_Object filename
;
2213 Lisp_Object abspath
;
2214 Lisp_Object handler
;
2215 struct stat statbuf
;
2217 CHECK_STRING (filename
, 0);
2218 abspath
= Fexpand_file_name (filename
, Qnil
);
2220 /* If the file name has special constructs in it,
2221 call the corresponding file handler. */
2222 handler
= Ffind_file_name_handler (abspath
, Qfile_exists_p
);
2223 if (!NILP (handler
))
2224 return call2 (handler
, Qfile_exists_p
, abspath
);
2226 return (stat (XSTRING (abspath
)->data
, &statbuf
) >= 0) ? Qt
: Qnil
;
2229 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2230 "Return t if FILENAME can be executed by you.\n\
2231 For a directory, this means you can access files in that directory.")
2233 Lisp_Object filename
;
2236 Lisp_Object abspath
;
2237 Lisp_Object handler
;
2239 CHECK_STRING (filename
, 0);
2240 abspath
= Fexpand_file_name (filename
, Qnil
);
2242 /* If the file name has special constructs in it,
2243 call the corresponding file handler. */
2244 handler
= Ffind_file_name_handler (abspath
, Qfile_executable_p
);
2245 if (!NILP (handler
))
2246 return call2 (handler
, Qfile_executable_p
, abspath
);
2248 return (check_executable (XSTRING (abspath
)->data
) ? Qt
: Qnil
);
2251 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2252 "Return t if file FILENAME exists and you can read it.\n\
2253 See also `file-exists-p' and `file-attributes'.")
2255 Lisp_Object filename
;
2257 Lisp_Object abspath
;
2258 Lisp_Object handler
;
2261 CHECK_STRING (filename
, 0);
2262 abspath
= Fexpand_file_name (filename
, Qnil
);
2264 /* If the file name has special constructs in it,
2265 call the corresponding file handler. */
2266 handler
= Ffind_file_name_handler (abspath
, Qfile_readable_p
);
2267 if (!NILP (handler
))
2268 return call2 (handler
, Qfile_readable_p
, abspath
);
2270 desc
= open (XSTRING (abspath
)->data
, O_RDONLY
);
2277 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
2278 "Return non-nil if file FILENAME is the name of a symbolic link.\n\
2279 The value is the name of the file to which it is linked.\n\
2280 Otherwise returns nil.")
2282 Lisp_Object filename
;
2289 Lisp_Object handler
;
2291 CHECK_STRING (filename
, 0);
2292 filename
= Fexpand_file_name (filename
, Qnil
);
2294 /* If the file name has special constructs in it,
2295 call the corresponding file handler. */
2296 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
2297 if (!NILP (handler
))
2298 return call2 (handler
, Qfile_symlink_p
, filename
);
2303 buf
= (char *) xmalloc (bufsize
);
2304 bzero (buf
, bufsize
);
2305 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
2306 if (valsize
< bufsize
) break;
2307 /* Buffer was not long enough */
2316 val
= make_string (buf
, valsize
);
2319 #else /* not S_IFLNK */
2321 #endif /* not S_IFLNK */
2324 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2326 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
2327 "Return t if file FILENAME can be written or created by you.")
2329 Lisp_Object filename
;
2331 Lisp_Object abspath
, dir
;
2332 Lisp_Object handler
;
2333 struct stat statbuf
;
2335 CHECK_STRING (filename
, 0);
2336 abspath
= Fexpand_file_name (filename
, Qnil
);
2338 /* If the file name has special constructs in it,
2339 call the corresponding file handler. */
2340 handler
= Ffind_file_name_handler (abspath
, Qfile_writable_p
);
2341 if (!NILP (handler
))
2342 return call2 (handler
, Qfile_writable_p
, abspath
);
2344 if (stat (XSTRING (abspath
)->data
, &statbuf
) >= 0)
2345 return (check_writable (XSTRING (abspath
)->data
)
2347 dir
= Ffile_name_directory (abspath
);
2350 dir
= Fdirectory_file_name (dir
);
2354 dir
= Fdirectory_file_name (dir
);
2356 return (check_writable (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "")
2360 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
2361 "Return t if file FILENAME is the name of a directory as a file.\n\
2362 A directory name spec may be given instead; then the value is t\n\
2363 if the directory so specified exists and really is a directory.")
2365 Lisp_Object filename
;
2367 register Lisp_Object abspath
;
2369 Lisp_Object handler
;
2371 abspath
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2373 /* If the file name has special constructs in it,
2374 call the corresponding file handler. */
2375 handler
= Ffind_file_name_handler (abspath
, Qfile_directory_p
);
2376 if (!NILP (handler
))
2377 return call2 (handler
, Qfile_directory_p
, abspath
);
2379 if (stat (XSTRING (abspath
)->data
, &st
) < 0)
2381 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
2384 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
2385 "Return t if file FILENAME is the name of a directory as a file,\n\
2386 and files in that directory can be opened by you. In order to use a\n\
2387 directory as a buffer's current directory, this predicate must return true.\n\
2388 A directory name spec may be given instead; then the value is t\n\
2389 if the directory so specified exists and really is a readable and\n\
2390 searchable directory.")
2392 Lisp_Object filename
;
2394 Lisp_Object handler
;
2396 struct gcpro gcpro1
;
2398 /* If the file name has special constructs in it,
2399 call the corresponding file handler. */
2400 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
2401 if (!NILP (handler
))
2402 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
2404 /* It's an unlikely combination, but yes we really do need to gcpro:
2405 Suppose that file-accessible-directory-p has no handler, but
2406 file-directory-p does have a handler; this handler causes a GC which
2407 relocates the string in `filename'; and finally file-directory-p
2408 returns non-nil. Then we would end up passing a garbaged string
2409 to file-executable-p. */
2411 tem
= (NILP (Ffile_directory_p (filename
))
2412 || NILP (Ffile_executable_p (filename
)));
2414 return tem
? Qnil
: Qt
;
2417 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
2418 "Return mode bits of FILE, as an integer.")
2420 Lisp_Object filename
;
2422 Lisp_Object abspath
;
2424 Lisp_Object handler
;
2426 abspath
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2428 /* If the file name has special constructs in it,
2429 call the corresponding file handler. */
2430 handler
= Ffind_file_name_handler (abspath
, Qfile_modes
);
2431 if (!NILP (handler
))
2432 return call2 (handler
, Qfile_modes
, abspath
);
2434 if (stat (XSTRING (abspath
)->data
, &st
) < 0)
2440 if (S_ISREG (st
.st_mode
)
2441 && (len
= XSTRING (abspath
)->size
) >= 5
2442 && (stricmp ((suffix
= XSTRING (abspath
)->data
+ len
-4), ".com") == 0
2443 || stricmp (suffix
, ".exe") == 0
2444 || stricmp (suffix
, ".bat") == 0))
2445 st
.st_mode
|= S_IEXEC
;
2449 return make_number (st
.st_mode
& 07777);
2452 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
2453 "Set mode bits of FILE to MODE (an integer).\n\
2454 Only the 12 low bits of MODE are used.")
2456 Lisp_Object filename
, mode
;
2458 Lisp_Object abspath
;
2459 Lisp_Object handler
;
2461 abspath
= Fexpand_file_name (filename
, current_buffer
->directory
);
2462 CHECK_NUMBER (mode
, 1);
2464 /* If the file name has special constructs in it,
2465 call the corresponding file handler. */
2466 handler
= Ffind_file_name_handler (abspath
, Qset_file_modes
);
2467 if (!NILP (handler
))
2468 return call3 (handler
, Qset_file_modes
, abspath
, mode
);
2471 if (chmod (XSTRING (abspath
)->data
, XINT (mode
)) < 0)
2472 report_file_error ("Doing chmod", Fcons (abspath
, Qnil
));
2474 if (!egetenv ("USE_DOMAIN_ACLS"))
2477 struct timeval tvp
[2];
2479 /* chmod on apollo also change the file's modtime; need to save the
2480 modtime and then restore it. */
2481 if (stat (XSTRING (abspath
)->data
, &st
) < 0)
2483 report_file_error ("Doing chmod", Fcons (abspath
, Qnil
));
2487 if (chmod (XSTRING (abspath
)->data
, XINT (mode
)) < 0)
2488 report_file_error ("Doing chmod", Fcons (abspath
, Qnil
));
2490 /* reset the old accessed and modified times. */
2491 tvp
[0].tv_sec
= st
.st_atime
+ 1; /* +1 due to an Apollo roundoff bug */
2493 tvp
[1].tv_sec
= st
.st_mtime
+ 1; /* +1 due to an Apollo roundoff bug */
2496 if (utimes (XSTRING (abspath
)->data
, tvp
) < 0)
2497 report_file_error ("Doing utimes", Fcons (abspath
, Qnil
));
2504 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
2505 "Set the file permission bits for newly created files.\n\
2506 The argument MODE should be an integer; only the low 9 bits are used.\n\
2507 This setting is inherited by subprocesses.")
2511 CHECK_NUMBER (mode
, 0);
2513 umask ((~ XINT (mode
)) & 0777);
2518 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
2519 "Return the default file protection for created files.\n\
2520 The value is an integer.")
2526 realmask
= umask (0);
2529 XSETINT (value
, (~ realmask
) & 0777);
2535 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
2536 "Tell Unix to finish all pending disk updates.")
2545 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
2546 "Return t if file FILE1 is newer than file FILE2.\n\
2547 If FILE1 does not exist, the answer is nil;\n\
2548 otherwise, if FILE2 does not exist, the answer is t.")
2550 Lisp_Object file1
, file2
;
2552 Lisp_Object abspath1
, abspath2
;
2555 Lisp_Object handler
;
2556 struct gcpro gcpro1
, gcpro2
;
2558 CHECK_STRING (file1
, 0);
2559 CHECK_STRING (file2
, 0);
2562 GCPRO2 (abspath1
, file2
);
2563 abspath1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
2564 abspath2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
2567 /* If the file name has special constructs in it,
2568 call the corresponding file handler. */
2569 handler
= Ffind_file_name_handler (abspath1
, Qfile_newer_than_file_p
);
2571 handler
= Ffind_file_name_handler (abspath2
, Qfile_newer_than_file_p
);
2572 if (!NILP (handler
))
2573 return call3 (handler
, Qfile_newer_than_file_p
, abspath1
, abspath2
);
2575 if (stat (XSTRING (abspath1
)->data
, &st
) < 0)
2578 mtime1
= st
.st_mtime
;
2580 if (stat (XSTRING (abspath2
)->data
, &st
) < 0)
2583 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
2587 Lisp_Object Qfind_buffer_file_type
;
2590 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
2592 "Insert contents of file FILENAME after point.\n\
2593 Returns list of absolute file name and length of data inserted.\n\
2594 If second argument VISIT is non-nil, the buffer's visited filename\n\
2595 and last save file modtime are set, and it is marked unmodified.\n\
2596 If visiting and the file does not exist, visiting is completed\n\
2597 before the error is signaled.\n\n\
2598 The optional third and fourth arguments BEG and END\n\
2599 specify what portion of the file to insert.\n\
2600 If VISIT is non-nil, BEG and END must be nil.\n\
2601 If optional fifth argument REPLACE is non-nil,\n\
2602 it means replace the current buffer contents (in the accessible portion)\n\
2603 with the file contents. This is better than simply deleting and inserting\n\
2604 the whole thing because (1) it preserves some marker positions\n\
2605 and (2) it puts less data in the undo list.")
2606 (filename
, visit
, beg
, end
, replace
)
2607 Lisp_Object filename
, visit
, beg
, end
, replace
;
2611 register int inserted
= 0;
2612 register int how_much
;
2613 int count
= specpdl_ptr
- specpdl
;
2614 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2615 Lisp_Object handler
, val
, insval
;
2622 GCPRO3 (filename
, val
, p
);
2623 if (!NILP (current_buffer
->read_only
))
2624 Fbarf_if_buffer_read_only();
2626 CHECK_STRING (filename
, 0);
2627 filename
= Fexpand_file_name (filename
, Qnil
);
2629 /* If the file name has special constructs in it,
2630 call the corresponding file handler. */
2631 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
2632 if (!NILP (handler
))
2634 val
= call6 (handler
, Qinsert_file_contents
, filename
,
2635 visit
, beg
, end
, replace
);
2642 if (stat (XSTRING (filename
)->data
, &st
) < 0)
2644 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0
2645 || fstat (fd
, &st
) < 0)
2646 #endif /* not APOLLO */
2648 if (fd
>= 0) close (fd
);
2651 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
2658 /* This code will need to be changed in order to work on named
2659 pipes, and it's probably just not worth it. So we should at
2660 least signal an error. */
2661 if (!S_ISREG (st
.st_mode
))
2662 Fsignal (Qfile_error
,
2663 Fcons (build_string ("not a regular file"),
2664 Fcons (filename
, Qnil
)));
2668 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0)
2671 /* Replacement should preserve point as it preserves markers. */
2672 if (!NILP (replace
))
2673 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
2675 record_unwind_protect (close_file_unwind
, make_number (fd
));
2677 /* Supposedly happens on VMS. */
2679 error ("File size is negative");
2681 if (!NILP (beg
) || !NILP (end
))
2683 error ("Attempt to visit less than an entire file");
2686 CHECK_NUMBER (beg
, 0);
2691 CHECK_NUMBER (end
, 0);
2694 XSETINT (end
, st
.st_size
);
2695 if (XINT (end
) != st
.st_size
)
2696 error ("maximum buffer size exceeded");
2699 /* If requested, replace the accessible part of the buffer
2700 with the file contents. Avoid replacing text at the
2701 beginning or end of the buffer that matches the file contents;
2702 that preserves markers pointing to the unchanged parts. */
2704 /* On MSDOS, replace mode doesn't really work, except for binary files,
2705 and it's not worth supporting just for them. */
2706 if (!NILP (replace
))
2710 XFASTINT (end
) = st
.st_size
;
2711 del_range_1 (BEGV
, ZV
, 0);
2714 if (!NILP (replace
))
2716 unsigned char buffer
[1 << 14];
2717 int same_at_start
= BEGV
;
2718 int same_at_end
= ZV
;
2723 /* Count how many chars at the start of the file
2724 match the text at the beginning of the buffer. */
2729 nread
= read (fd
, buffer
, sizeof buffer
);
2731 error ("IO error reading %s: %s",
2732 XSTRING (filename
)->data
, strerror (errno
));
2733 else if (nread
== 0)
2736 while (bufpos
< nread
&& same_at_start
< ZV
2737 && FETCH_CHAR (same_at_start
) == buffer
[bufpos
])
2738 same_at_start
++, bufpos
++;
2739 /* If we found a discrepancy, stop the scan.
2740 Otherwise loop around and scan the next bufferfull. */
2741 if (bufpos
!= nread
)
2745 /* If the file matches the buffer completely,
2746 there's no need to replace anything. */
2747 if (same_at_start
- BEGV
== st
.st_size
)
2751 /* Truncate the buffer to the size of the file. */
2752 del_range_1 (same_at_start
, same_at_end
, 0);
2757 /* Count how many chars at the end of the file
2758 match the text at the end of the buffer. */
2761 int total_read
, nread
, bufpos
, curpos
, trial
;
2763 /* At what file position are we now scanning? */
2764 curpos
= st
.st_size
- (ZV
- same_at_end
);
2765 /* If the entire file matches the buffer tail, stop the scan. */
2768 /* How much can we scan in the next step? */
2769 trial
= min (curpos
, sizeof buffer
);
2770 if (lseek (fd
, curpos
- trial
, 0) < 0)
2771 report_file_error ("Setting file position",
2772 Fcons (filename
, Qnil
));
2775 while (total_read
< trial
)
2777 nread
= read (fd
, buffer
+ total_read
, trial
- total_read
);
2779 error ("IO error reading %s: %s",
2780 XSTRING (filename
)->data
, strerror (errno
));
2781 total_read
+= nread
;
2783 /* Scan this bufferfull from the end, comparing with
2784 the Emacs buffer. */
2785 bufpos
= total_read
;
2786 /* Compare with same_at_start to avoid counting some buffer text
2787 as matching both at the file's beginning and at the end. */
2788 while (bufpos
> 0 && same_at_end
> same_at_start
2789 && FETCH_CHAR (same_at_end
- 1) == buffer
[bufpos
- 1])
2790 same_at_end
--, bufpos
--;
2791 /* If we found a discrepancy, stop the scan.
2792 Otherwise loop around and scan the preceding bufferfull. */
2798 /* Don't try to reuse the same piece of text twice. */
2799 overlap
= same_at_start
- BEGV
- (same_at_end
+ st
.st_size
- ZV
);
2801 same_at_end
+= overlap
;
2803 /* Arrange to read only the nonmatching middle part of the file. */
2804 XFASTINT (beg
) = same_at_start
- BEGV
;
2805 XFASTINT (end
) = st
.st_size
- (ZV
- same_at_end
);
2807 del_range_1 (same_at_start
, same_at_end
, 0);
2808 /* Insert from the file at the proper position. */
2809 SET_PT (same_at_start
);
2813 total
= XINT (end
) - XINT (beg
);
2816 register Lisp_Object temp
;
2818 /* Make sure point-max won't overflow after this insertion. */
2819 XSETINT (temp
, total
);
2820 if (total
!= XINT (temp
))
2821 error ("maximum buffer size exceeded");
2824 if (NILP (visit
) && total
> 0)
2825 prepare_to_modify_buffer (point
, point
);
2828 if (GAP_SIZE
< total
)
2829 make_gap (total
- GAP_SIZE
);
2831 if (XINT (beg
) != 0 || !NILP (replace
))
2833 if (lseek (fd
, XINT (beg
), 0) < 0)
2834 report_file_error ("Setting file position", Fcons (filename
, Qnil
));
2838 while (inserted
< total
)
2840 int try = min (total
- inserted
, 64 << 10);
2843 /* Allow quitting out of the actual I/O. */
2846 this = read (fd
, &FETCH_CHAR (point
+ inserted
- 1) + 1, try);
2863 /* Demacs 1.1.1 91/10/16 HIRANO Satoshi, MW July 1993 */
2864 /* Determine file type from name and remove LFs from CR-LFs if the file
2865 is deemed to be a text file. */
2867 current_buffer
->buffer_file_type
2868 = call1 (Qfind_buffer_file_type
, filename
);
2869 if (NILP (current_buffer
->buffer_file_type
))
2872 = inserted
- crlf_to_lf (inserted
, &FETCH_CHAR (point
- 1) + 1);
2875 GPT
-= reduced_size
;
2876 GAP_SIZE
+= reduced_size
;
2877 inserted
-= reduced_size
;
2884 record_insert (point
, inserted
);
2886 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
2887 offset_intervals (current_buffer
, point
, inserted
);
2893 /* Discard the unwind protect for closing the file. */
2897 error ("IO error reading %s: %s",
2898 XSTRING (filename
)->data
, strerror (errno
));
2905 if (!EQ (current_buffer
->undo_list
, Qt
))
2906 current_buffer
->undo_list
= Qnil
;
2908 stat (XSTRING (filename
)->data
, &st
);
2913 current_buffer
->modtime
= st
.st_mtime
;
2914 current_buffer
->filename
= filename
;
2917 current_buffer
->save_modified
= MODIFF
;
2918 current_buffer
->auto_save_modified
= MODIFF
;
2919 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
2920 #ifdef CLASH_DETECTION
2923 if (!NILP (current_buffer
->filename
))
2924 unlock_file (current_buffer
->filename
);
2925 unlock_file (filename
);
2927 #endif /* CLASH_DETECTION */
2928 /* If visiting nonexistent file, return nil. */
2929 if (current_buffer
->modtime
== -1)
2930 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
2933 if (inserted
> 0 && NILP (visit
) && total
> 0)
2934 signal_after_change (point
, 0, inserted
);
2938 p
= Vafter_insert_file_functions
;
2941 insval
= call1 (Fcar (p
), make_number (inserted
));
2944 CHECK_NUMBER (insval
, 0);
2945 inserted
= XFASTINT (insval
);
2953 val
= Fcons (filename
,
2954 Fcons (make_number (inserted
),
2957 RETURN_UNGCPRO (unbind_to (count
, val
));
2960 static Lisp_Object
build_annotations ();
2962 /* If build_annotations switched buffers, switch back to BUF.
2963 Kill the temporary buffer that was selected in the meantime. */
2966 build_annotations_unwind (buf
)
2971 if (XBUFFER (buf
) == current_buffer
)
2973 tembuf
= Fcurrent_buffer ();
2975 Fkill_buffer (tembuf
);
2979 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 5,
2980 "r\nFWrite region to file: ",
2981 "Write current region into specified file.\n\
2982 When called from a program, takes three arguments:\n\
2983 START, END and FILENAME. START and END are buffer positions.\n\
2984 Optional fourth argument APPEND if non-nil means\n\
2985 append to existing file contents (if any).\n\
2986 Optional fifth argument VISIT if t means\n\
2987 set the last-save-file-modtime of buffer to this file's modtime\n\
2988 and mark buffer not modified.\n\
2989 If VISIT is a string, it is a second file name;\n\
2990 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
2991 VISIT is also the file name to lock and unlock for clash detection.\n\
2992 If VISIT is neither t nor nil nor a string,\n\
2993 that means do not print the \"Wrote file\" message.\n\
2994 Kludgy feature: if START is a string, then that string is written\n\
2995 to the file, instead of any buffer contents, and END is ignored.")
2996 (start
, end
, filename
, append
, visit
)
2997 Lisp_Object start
, end
, filename
, append
, visit
;
3005 int count
= specpdl_ptr
- specpdl
;
3008 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
3010 Lisp_Object handler
;
3011 Lisp_Object visit_file
;
3012 Lisp_Object annotations
;
3013 int visiting
, quietly
;
3014 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3015 struct buffer
*given_buffer
;
3017 int buffer_file_type
3018 = NILP (current_buffer
->buffer_file_type
) ? O_TEXT
: O_BINARY
;
3021 if (!NILP (start
) && !STRINGP (start
))
3022 validate_region (&start
, &end
);
3024 GCPRO2 (filename
, visit
);
3025 filename
= Fexpand_file_name (filename
, Qnil
);
3026 if (STRINGP (visit
))
3027 visit_file
= Fexpand_file_name (visit
, Qnil
);
3029 visit_file
= filename
;
3032 visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
3033 quietly
= !NILP (visit
);
3037 GCPRO4 (start
, filename
, annotations
, visit_file
);
3039 /* If the file name has special constructs in it,
3040 call the corresponding file handler. */
3041 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
3042 /* If FILENAME has no handler, see if VISIT has one. */
3043 if (NILP (handler
) && STRINGP (visit
))
3044 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
3046 if (!NILP (handler
))
3049 val
= call6 (handler
, Qwrite_region
, start
, end
,
3050 filename
, append
, visit
);
3054 current_buffer
->save_modified
= MODIFF
;
3055 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3056 current_buffer
->filename
= visit_file
;
3062 /* Special kludge to simplify auto-saving. */
3065 XFASTINT (start
) = BEG
;
3069 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
3070 count1
= specpdl_ptr
- specpdl
;
3072 given_buffer
= current_buffer
;
3073 annotations
= build_annotations (start
, end
);
3074 if (current_buffer
!= given_buffer
)
3080 #ifdef CLASH_DETECTION
3082 lock_file (visit_file
);
3083 #endif /* CLASH_DETECTION */
3085 fn
= XSTRING (filename
)->data
;
3089 desc
= open (fn
, O_WRONLY
| buffer_file_type
);
3091 desc
= open (fn
, O_WRONLY
);
3096 if (auto_saving
) /* Overwrite any previous version of autosave file */
3098 vms_truncate (fn
); /* if fn exists, truncate to zero length */
3099 desc
= open (fn
, O_RDWR
);
3101 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
3102 ? XSTRING (current_buffer
->filename
)->data
: 0,
3105 else /* Write to temporary name and rename if no errors */
3107 Lisp_Object temp_name
;
3108 temp_name
= Ffile_name_directory (filename
);
3110 if (!NILP (temp_name
))
3112 temp_name
= Fmake_temp_name (concat2 (temp_name
,
3113 build_string ("$$SAVE$$")));
3114 fname
= XSTRING (filename
)->data
;
3115 fn
= XSTRING (temp_name
)->data
;
3116 desc
= creat_copy_attrs (fname
, fn
);
3119 /* If we can't open the temporary file, try creating a new
3120 version of the original file. VMS "creat" creates a
3121 new version rather than truncating an existing file. */
3124 desc
= creat (fn
, 0666);
3125 #if 0 /* This can clobber an existing file and fail to replace it,
3126 if the user runs out of space. */
3129 /* We can't make a new version;
3130 try to truncate and rewrite existing version if any. */
3132 desc
= open (fn
, O_RDWR
);
3138 desc
= creat (fn
, 0666);
3143 O_WRONLY
| O_TRUNC
| O_CREAT
| buffer_file_type
,
3144 S_IREAD
| S_IWRITE
);
3145 #else /* not MSDOS */
3146 desc
= creat (fn
, auto_saving
? auto_save_mode_bits
: 0666);
3147 #endif /* not MSDOS */
3148 #endif /* not VMS */
3154 #ifdef CLASH_DETECTION
3156 if (!auto_saving
) unlock_file (visit_file
);
3158 #endif /* CLASH_DETECTION */
3159 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
3162 record_unwind_protect (close_file_unwind
, make_number (desc
));
3165 if (lseek (desc
, 0, 2) < 0)
3167 #ifdef CLASH_DETECTION
3168 if (!auto_saving
) unlock_file (visit_file
);
3169 #endif /* CLASH_DETECTION */
3170 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
3175 * Kludge Warning: The VMS C RTL likes to insert carriage returns
3176 * if we do writes that don't end with a carriage return. Furthermore
3177 * it cannot handle writes of more then 16K. The modified
3178 * version of "sys_write" in SYSDEP.C (see comment there) copes with
3179 * this EXCEPT for the last record (iff it doesn't end with a carriage
3180 * return). This implies that if your buffer doesn't end with a carriage
3181 * return, you get one free... tough. However it also means that if
3182 * we make two calls to sys_write (a la the following code) you can
3183 * get one at the gap as well. The easiest way to fix this (honest)
3184 * is to move the gap to the next newline (or the end of the buffer).
3189 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
3190 move_gap (find_next_newline (GPT
, 1));
3196 if (STRINGP (start
))
3198 failure
= 0 > a_write (desc
, XSTRING (start
)->data
,
3199 XSTRING (start
)->size
, 0, &annotations
);
3202 else if (XINT (start
) != XINT (end
))
3205 if (XINT (start
) < GPT
)
3207 register int end1
= XINT (end
);
3209 failure
= 0 > a_write (desc
, &FETCH_CHAR (tem
),
3210 min (GPT
, end1
) - tem
, tem
, &annotations
);
3211 nwritten
+= min (GPT
, end1
) - tem
;
3215 if (XINT (end
) > GPT
&& !failure
)
3218 tem
= max (tem
, GPT
);
3219 failure
= 0 > a_write (desc
, &FETCH_CHAR (tem
), XINT (end
) - tem
,
3221 nwritten
+= XINT (end
) - tem
;
3227 /* If file was empty, still need to write the annotations */
3228 failure
= 0 > a_write (desc
, "", 0, XINT (start
), &annotations
);
3236 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
3237 Disk full in NFS may be reported here. */
3238 /* mib says that closing the file will try to write as fast as NFS can do
3239 it, and that means the fsync here is not crucial for autosave files. */
3240 if (!auto_saving
&& fsync (desc
) < 0)
3241 failure
= 1, save_errno
= errno
;
3244 /* Spurious "file has changed on disk" warnings have been
3245 observed on Suns as well.
3246 It seems that `close' can change the modtime, under nfs.
3248 (This has supposedly been fixed in Sunos 4,
3249 but who knows about all the other machines with NFS?) */
3252 /* On VMS and APOLLO, must do the stat after the close
3253 since closing changes the modtime. */
3256 /* Recall that #if defined does not work on VMS. */
3263 /* NFS can report a write failure now. */
3264 if (close (desc
) < 0)
3265 failure
= 1, save_errno
= errno
;
3268 /* If we wrote to a temporary name and had no errors, rename to real name. */
3272 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
3280 /* Discard the unwind protect for close_file_unwind. */
3281 specpdl_ptr
= specpdl
+ count1
;
3282 /* Restore the original current buffer. */
3283 visit_file
= unbind_to (count
, visit_file
);
3285 #ifdef CLASH_DETECTION
3287 unlock_file (visit_file
);
3288 #endif /* CLASH_DETECTION */
3290 /* Do this before reporting IO error
3291 to avoid a "file has changed on disk" warning on
3292 next attempt to save. */
3294 current_buffer
->modtime
= st
.st_mtime
;
3297 error ("IO error writing %s: %s", fn
, strerror (save_errno
));
3301 current_buffer
->save_modified
= MODIFF
;
3302 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3303 current_buffer
->filename
= visit_file
;
3304 update_mode_lines
++;
3310 message ("Wrote %s", XSTRING (visit_file
)->data
);
3315 Lisp_Object
merge ();
3317 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
3318 "Return t if (car A) is numerically less than (car B).")
3322 return Flss (Fcar (a
), Fcar (b
));
3325 /* Build the complete list of annotations appropriate for writing out
3326 the text between START and END, by calling all the functions in
3327 write-region-annotate-functions and merging the lists they return.
3328 If one of these functions switches to a different buffer, we assume
3329 that buffer contains altered text. Therefore, the caller must
3330 make sure to restore the current buffer in all cases,
3331 as save-excursion would do. */
3334 build_annotations (start
, end
)
3335 Lisp_Object start
, end
;
3337 Lisp_Object annotations
;
3339 struct gcpro gcpro1
, gcpro2
;
3342 p
= Vwrite_region_annotate_functions
;
3343 GCPRO2 (annotations
, p
);
3346 struct buffer
*given_buffer
= current_buffer
;
3347 Vwrite_region_annotations_so_far
= annotations
;
3348 res
= call2 (Fcar (p
), start
, end
);
3349 /* If the function makes a different buffer current,
3350 assume that means this buffer contains altered text to be output.
3351 Reset START and END from the buffer bounds
3352 and discard all previous annotations because they should have
3353 been dealt with by this function. */
3354 if (current_buffer
!= given_buffer
)
3360 Flength (res
); /* Check basic validity of return value */
3361 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
3368 /* Write to descriptor DESC the LEN characters starting at ADDR,
3369 assuming they start at position POS in the buffer.
3370 Intersperse with them the annotations from *ANNOT
3371 (those which fall within the range of positions POS to POS + LEN),
3372 each at its appropriate position.
3374 Modify *ANNOT by discarding elements as we output them.
3375 The return value is negative in case of system call failure. */
3378 a_write (desc
, addr
, len
, pos
, annot
)
3380 register char *addr
;
3387 int lastpos
= pos
+ len
;
3389 while (NILP (*annot
) || CONSP (*annot
))
3391 tem
= Fcar_safe (Fcar (*annot
));
3392 if (INTEGERP (tem
) && XINT (tem
) >= pos
&& XFASTINT (tem
) <= lastpos
)
3393 nextpos
= XFASTINT (tem
);
3395 return e_write (desc
, addr
, lastpos
- pos
);
3398 if (0 > e_write (desc
, addr
, nextpos
- pos
))
3400 addr
+= nextpos
- pos
;
3403 tem
= Fcdr (Fcar (*annot
));
3406 if (0 > e_write (desc
, XSTRING (tem
)->data
, XSTRING (tem
)->size
))
3409 *annot
= Fcdr (*annot
);
3414 e_write (desc
, addr
, len
)
3416 register char *addr
;
3419 char buf
[16 * 1024];
3420 register char *p
, *end
;
3422 if (!EQ (current_buffer
->selective_display
, Qt
))
3423 return write (desc
, addr
, len
) - len
;
3427 end
= p
+ sizeof buf
;
3432 if (write (desc
, buf
, sizeof buf
) != sizeof buf
)
3441 if (write (desc
, buf
, p
- buf
) != p
- buf
)
3447 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
3448 Sverify_visited_file_modtime
, 1, 1, 0,
3449 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
3450 This means that the file has not been changed since it was visited or saved.")
3456 Lisp_Object handler
;
3458 CHECK_BUFFER (buf
, 0);
3461 if (!STRINGP (b
->filename
)) return Qt
;
3462 if (b
->modtime
== 0) return Qt
;
3464 /* If the file name has special constructs in it,
3465 call the corresponding file handler. */
3466 handler
= Ffind_file_name_handler (b
->filename
,
3467 Qverify_visited_file_modtime
);
3468 if (!NILP (handler
))
3469 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
3471 if (stat (XSTRING (b
->filename
)->data
, &st
) < 0)
3473 /* If the file doesn't exist now and didn't exist before,
3474 we say that it isn't modified, provided the error is a tame one. */
3475 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
3480 if (st
.st_mtime
== b
->modtime
3481 /* If both are positive, accept them if they are off by one second. */
3482 || (st
.st_mtime
> 0 && b
->modtime
> 0
3483 && (st
.st_mtime
== b
->modtime
+ 1
3484 || st
.st_mtime
== b
->modtime
- 1)))
3489 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
3490 Sclear_visited_file_modtime
, 0, 0, 0,
3491 "Clear out records of last mod time of visited file.\n\
3492 Next attempt to save will certainly not complain of a discrepancy.")
3495 current_buffer
->modtime
= 0;
3499 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
3500 Svisited_file_modtime
, 0, 0, 0,
3501 "Return the current buffer's recorded visited file modification time.\n\
3502 The value is a list of the form (HIGH . LOW), like the time values\n\
3503 that `file-attributes' returns.")
3506 return long_to_cons (current_buffer
->modtime
);
3509 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
3510 Sset_visited_file_modtime
, 0, 1, 0,
3511 "Update buffer's recorded modification time from the visited file's time.\n\
3512 Useful if the buffer was not read from the file normally\n\
3513 or if the file itself has been changed for some known benign reason.\n\
3514 An argument specifies the modification time value to use\n\
3515 \(instead of that of the visited file), in the form of a list\n\
3516 \(HIGH . LOW) or (HIGH LOW).")
3518 Lisp_Object time_list
;
3520 if (!NILP (time_list
))
3521 current_buffer
->modtime
= cons_to_long (time_list
);
3524 register Lisp_Object filename
;
3526 Lisp_Object handler
;
3528 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
3530 /* If the file name has special constructs in it,
3531 call the corresponding file handler. */
3532 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
3533 if (!NILP (handler
))
3534 /* The handler can find the file name the same way we did. */
3535 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
3536 else if (stat (XSTRING (filename
)->data
, &st
) >= 0)
3537 current_buffer
->modtime
= st
.st_mtime
;
3547 message ("Autosaving...error for %s", XSTRING (current_buffer
->name
)->data
);
3548 Fsleep_for (make_number (1), Qnil
);
3549 message ("Autosaving...error!for %s", XSTRING (current_buffer
->name
)->data
);
3550 Fsleep_for (make_number (1), Qnil
);
3551 message ("Autosaving...error for %s", XSTRING (current_buffer
->name
)->data
);
3552 Fsleep_for (make_number (1), Qnil
);
3562 /* Get visited file's mode to become the auto save file's mode. */
3563 if (stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
3564 /* But make sure we can overwrite it later! */
3565 auto_save_mode_bits
= st
.st_mode
| 0600;
3567 auto_save_mode_bits
= 0666;
3570 Fwrite_region (Qnil
, Qnil
,
3571 current_buffer
->auto_save_file_name
,
3576 do_auto_save_unwind (desc
) /* used as unwind-protect function */
3579 close (XINT (desc
));
3583 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
3584 "Auto-save all buffers that need it.\n\
3585 This is all buffers that have auto-saving enabled\n\
3586 and are changed since last auto-saved.\n\
3587 Auto-saving writes the buffer into a file\n\
3588 so that your editing is not lost if the system crashes.\n\
3589 This file is not the file you visited; that changes only when you save.\n\
3590 Normally we run the normal hook `auto-save-hook' before saving.\n\n\
3591 Non-nil first argument means do not print any message if successful.\n\
3592 Non-nil second argument means save only current buffer.")
3593 (no_message
, current_only
)
3594 Lisp_Object no_message
, current_only
;
3596 struct buffer
*old
= current_buffer
, *b
;
3597 Lisp_Object tail
, buf
;
3599 char *omessage
= echo_area_glyphs
;
3600 int omessage_length
= echo_area_glyphs_length
;
3601 extern int minibuf_level
;
3602 int do_handled_files
;
3605 int count
= specpdl_ptr
- specpdl
;
3608 /* Ordinarily don't quit within this function,
3609 but don't make it impossible to quit (in case we get hung in I/O). */
3613 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
3614 point to non-strings reached from Vbuffer_alist. */
3620 if (!NILP (Vrun_hooks
))
3621 call1 (Vrun_hooks
, intern ("auto-save-hook"));
3623 if (STRINGP (Vauto_save_list_file_name
))
3626 listdesc
= open (XSTRING (Vauto_save_list_file_name
)->data
,
3627 O_WRONLY
| O_TRUNC
| O_CREAT
| O_TEXT
,
3628 S_IREAD
| S_IWRITE
);
3629 #else /* not MSDOS */
3630 listdesc
= creat (XSTRING (Vauto_save_list_file_name
)->data
, 0666);
3631 #endif /* not MSDOS */
3636 /* Arrange to close that file whether or not we get an error. */
3638 record_unwind_protect (do_auto_save_unwind
, make_number (listdesc
));
3640 /* First, save all files which don't have handlers. If Emacs is
3641 crashing, the handlers may tweak what is causing Emacs to crash
3642 in the first place, and it would be a shame if Emacs failed to
3643 autosave perfectly ordinary files because it couldn't handle some
3645 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
3646 for (tail
= Vbuffer_alist
; XGCTYPE (tail
) == Lisp_Cons
;
3647 tail
= XCONS (tail
)->cdr
)
3649 buf
= XCONS (XCONS (tail
)->car
)->cdr
;
3652 /* Record all the buffers that have auto save mode
3653 in the special file that lists them. */
3654 if (STRINGP (b
->auto_save_file_name
)
3655 && listdesc
>= 0 && do_handled_files
== 0)
3657 write (listdesc
, XSTRING (b
->auto_save_file_name
)->data
,
3658 XSTRING (b
->auto_save_file_name
)->size
);
3659 write (listdesc
, "\n", 1);
3662 if (!NILP (current_only
)
3663 && b
!= current_buffer
)
3666 /* Check for auto save enabled
3667 and file changed since last auto save
3668 and file changed since last real save. */
3669 if (STRINGP (b
->auto_save_file_name
)
3670 && b
->save_modified
< BUF_MODIFF (b
)
3671 && b
->auto_save_modified
< BUF_MODIFF (b
)
3672 /* -1 means we've turned off autosaving for a while--see below. */
3673 && XINT (b
->save_length
) >= 0
3674 && (do_handled_files
3675 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
3678 EMACS_TIME before_time
, after_time
;
3680 EMACS_GET_TIME (before_time
);
3682 /* If we had a failure, don't try again for 20 minutes. */
3683 if (b
->auto_save_failure_time
>= 0
3684 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
3687 if ((XFASTINT (b
->save_length
) * 10
3688 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
3689 /* A short file is likely to change a large fraction;
3690 spare the user annoying messages. */
3691 && XFASTINT (b
->save_length
) > 5000
3692 /* These messages are frequent and annoying for `*mail*'. */
3693 && !EQ (b
->filename
, Qnil
)
3694 && NILP (no_message
))
3696 /* It has shrunk too much; turn off auto-saving here. */
3697 message ("Buffer %s has shrunk a lot; auto save turned off there",
3698 XSTRING (b
->name
)->data
);
3699 /* Turn off auto-saving until there's a real save,
3700 and prevent any more warnings. */
3701 XSETINT (b
->save_length
, -1);
3702 Fsleep_for (make_number (1), Qnil
);
3705 set_buffer_internal (b
);
3706 if (!auto_saved
&& NILP (no_message
))
3707 message1 ("Auto-saving...");
3708 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
3710 b
->auto_save_modified
= BUF_MODIFF (b
);
3711 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3712 set_buffer_internal (old
);
3714 EMACS_GET_TIME (after_time
);
3716 /* If auto-save took more than 60 seconds,
3717 assume it was an NFS failure that got a timeout. */
3718 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
3719 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
3723 /* Prevent another auto save till enough input events come in. */
3724 record_auto_save ();
3726 if (auto_saved
&& NILP (no_message
))
3729 message2 (omessage
, omessage_length
);
3731 message1 ("Auto-saving...done");
3737 unbind_to (count
, Qnil
);
3741 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
3742 Sset_buffer_auto_saved
, 0, 0, 0,
3743 "Mark current buffer as auto-saved with its current text.\n\
3744 No auto-save file will be written until the buffer changes again.")
3747 current_buffer
->auto_save_modified
= MODIFF
;
3748 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3749 current_buffer
->auto_save_failure_time
= -1;
3753 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
3754 Sclear_buffer_auto_save_failure
, 0, 0, 0,
3755 "Clear any record of a recent auto-save failure in the current buffer.")
3758 current_buffer
->auto_save_failure_time
= -1;
3762 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
3764 "Return t if buffer has been auto-saved since last read in or saved.")
3767 return (current_buffer
->save_modified
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
3770 /* Reading and completing file names */
3771 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
3773 /* In the string VAL, change each $ to $$ and return the result. */
3776 double_dollars (val
)
3779 register unsigned char *old
, *new;
3783 osize
= XSTRING (val
)->size
;
3784 /* Quote "$" as "$$" to get it past substitute-in-file-name */
3785 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
3786 if (*old
++ == '$') count
++;
3789 old
= XSTRING (val
)->data
;
3790 val
= Fmake_string (make_number (osize
+ count
), make_number (0));
3791 new = XSTRING (val
)->data
;
3792 for (n
= osize
; n
> 0; n
--)
3805 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
3807 "Internal subroutine for read-file-name. Do not call this.")
3808 (string
, dir
, action
)
3809 Lisp_Object string
, dir
, action
;
3810 /* action is nil for complete, t for return list of completions,
3811 lambda for verify final value */
3813 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
3815 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3822 /* No need to protect ACTION--we only compare it with t and nil. */
3823 GCPRO4 (string
, realdir
, name
, specdir
);
3825 if (XSTRING (string
)->size
== 0)
3827 if (EQ (action
, Qlambda
))
3835 orig_string
= string
;
3836 string
= Fsubstitute_in_file_name (string
);
3837 changed
= NILP (Fstring_equal (string
, orig_string
));
3838 name
= Ffile_name_nondirectory (string
);
3839 val
= Ffile_name_directory (string
);
3841 realdir
= Fexpand_file_name (val
, realdir
);
3846 specdir
= Ffile_name_directory (string
);
3847 val
= Ffile_name_completion (name
, realdir
);
3852 return double_dollars (string
);
3856 if (!NILP (specdir
))
3857 val
= concat2 (specdir
, val
);
3859 return double_dollars (val
);
3862 #endif /* not VMS */
3866 if (EQ (action
, Qt
))
3867 return Ffile_name_all_completions (name
, realdir
);
3868 /* Only other case actually used is ACTION = lambda */
3870 /* Supposedly this helps commands such as `cd' that read directory names,
3871 but can someone explain how it helps them? -- RMS */
3872 if (XSTRING (name
)->size
== 0)
3875 return Ffile_exists_p (string
);
3878 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
3879 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
3880 Value is not expanded---you must call `expand-file-name' yourself.\n\
3881 Default name to DEFAULT if user enters a null string.\n\
3882 (If DEFAULT is omitted, the visited file name is used,\n\
3883 except that if INITIAL is specified, that combined with DIR is used.)\n\
3884 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
3885 Non-nil and non-t means also require confirmation after completion.\n\
3886 Fifth arg INITIAL specifies text to start with.\n\
3887 DIR defaults to current buffer's directory default.")
3888 (prompt
, dir
, defalt
, mustmatch
, initial
)
3889 Lisp_Object prompt
, dir
, defalt
, mustmatch
, initial
;
3891 Lisp_Object val
, insdef
, insdef1
, tem
;
3892 struct gcpro gcpro1
, gcpro2
;
3893 register char *homedir
;
3897 dir
= current_buffer
->directory
;
3900 if (! NILP (initial
))
3901 defalt
= Fexpand_file_name (initial
, dir
);
3903 defalt
= current_buffer
->filename
;
3906 /* If dir starts with user's homedir, change that to ~. */
3907 homedir
= (char *) egetenv ("HOME");
3910 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
3911 && XSTRING (dir
)->data
[strlen (homedir
)] == '/')
3913 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
3914 XSTRING (dir
)->size
- strlen (homedir
) + 1);
3915 XSTRING (dir
)->data
[0] = '~';
3918 if (insert_default_directory
)
3921 if (!NILP (initial
))
3923 Lisp_Object args
[2], pos
;
3927 insdef
= Fconcat (2, args
);
3928 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
3929 insdef1
= Fcons (double_dollars (insdef
), pos
);
3932 insdef1
= double_dollars (insdef
);
3934 else if (!NILP (initial
))
3937 insdef1
= Fcons (double_dollars (insdef
), 0);
3940 insdef
= Qnil
, insdef1
= Qnil
;
3943 count
= specpdl_ptr
- specpdl
;
3944 specbind (intern ("completion-ignore-case"), Qt
);
3947 GCPRO2 (insdef
, defalt
);
3948 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
3949 dir
, mustmatch
, insdef1
,
3950 Qfile_name_history
);
3953 unbind_to (count
, Qnil
);
3958 error ("No file name specified");
3959 tem
= Fstring_equal (val
, insdef
);
3960 if (!NILP (tem
) && !NILP (defalt
))
3962 if (XSTRING (val
)->size
== 0 && NILP (insdef
))
3967 error ("No default file name");
3969 return Fsubstitute_in_file_name (val
);
3972 #if 0 /* Old version */
3973 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
3974 /* Don't confuse make-docfile by having two doc strings for this function.
3975 make-docfile does not pay attention to #if, for good reason! */
3977 (prompt
, dir
, defalt
, mustmatch
, initial
)
3978 Lisp_Object prompt
, dir
, defalt
, mustmatch
, initial
;
3980 Lisp_Object val
, insdef
, tem
;
3981 struct gcpro gcpro1
, gcpro2
;
3982 register char *homedir
;
3986 dir
= current_buffer
->directory
;
3988 defalt
= current_buffer
->filename
;
3990 /* If dir starts with user's homedir, change that to ~. */
3991 homedir
= (char *) egetenv ("HOME");
3994 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
3995 && XSTRING (dir
)->data
[strlen (homedir
)] == '/')
3997 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
3998 XSTRING (dir
)->size
- strlen (homedir
) + 1);
3999 XSTRING (dir
)->data
[0] = '~';
4002 if (!NILP (initial
))
4004 else if (insert_default_directory
)
4007 insdef
= build_string ("");
4010 count
= specpdl_ptr
- specpdl
;
4011 specbind (intern ("completion-ignore-case"), Qt
);
4014 GCPRO2 (insdef
, defalt
);
4015 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
4017 insert_default_directory
? insdef
: Qnil
,
4018 Qfile_name_history
);
4021 unbind_to (count
, Qnil
);
4026 error ("No file name specified");
4027 tem
= Fstring_equal (val
, insdef
);
4028 if (!NILP (tem
) && !NILP (defalt
))
4030 return Fsubstitute_in_file_name (val
);
4032 #endif /* Old version */
4036 Qexpand_file_name
= intern ("expand-file-name");
4037 Qdirectory_file_name
= intern ("directory-file-name");
4038 Qfile_name_directory
= intern ("file-name-directory");
4039 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
4040 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
4041 Qfile_name_as_directory
= intern ("file-name-as-directory");
4042 Qcopy_file
= intern ("copy-file");
4043 Qmake_directory_internal
= intern ("make-directory-internal");
4044 Qdelete_directory
= intern ("delete-directory");
4045 Qdelete_file
= intern ("delete-file");
4046 Qrename_file
= intern ("rename-file");
4047 Qadd_name_to_file
= intern ("add-name-to-file");
4048 Qmake_symbolic_link
= intern ("make-symbolic-link");
4049 Qfile_exists_p
= intern ("file-exists-p");
4050 Qfile_executable_p
= intern ("file-executable-p");
4051 Qfile_readable_p
= intern ("file-readable-p");
4052 Qfile_symlink_p
= intern ("file-symlink-p");
4053 Qfile_writable_p
= intern ("file-writable-p");
4054 Qfile_directory_p
= intern ("file-directory-p");
4055 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
4056 Qfile_modes
= intern ("file-modes");
4057 Qset_file_modes
= intern ("set-file-modes");
4058 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
4059 Qinsert_file_contents
= intern ("insert-file-contents");
4060 Qwrite_region
= intern ("write-region");
4061 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
4062 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
4064 staticpro (&Qexpand_file_name
);
4065 staticpro (&Qdirectory_file_name
);
4066 staticpro (&Qfile_name_directory
);
4067 staticpro (&Qfile_name_nondirectory
);
4068 staticpro (&Qunhandled_file_name_directory
);
4069 staticpro (&Qfile_name_as_directory
);
4070 staticpro (&Qcopy_file
);
4071 staticpro (&Qmake_directory_internal
);
4072 staticpro (&Qdelete_directory
);
4073 staticpro (&Qdelete_file
);
4074 staticpro (&Qrename_file
);
4075 staticpro (&Qadd_name_to_file
);
4076 staticpro (&Qmake_symbolic_link
);
4077 staticpro (&Qfile_exists_p
);
4078 staticpro (&Qfile_executable_p
);
4079 staticpro (&Qfile_readable_p
);
4080 staticpro (&Qfile_symlink_p
);
4081 staticpro (&Qfile_writable_p
);
4082 staticpro (&Qfile_directory_p
);
4083 staticpro (&Qfile_accessible_directory_p
);
4084 staticpro (&Qfile_modes
);
4085 staticpro (&Qset_file_modes
);
4086 staticpro (&Qfile_newer_than_file_p
);
4087 staticpro (&Qinsert_file_contents
);
4088 staticpro (&Qwrite_region
);
4089 staticpro (&Qverify_visited_file_modtime
);
4091 Qfile_name_history
= intern ("file-name-history");
4092 Fset (Qfile_name_history
, Qnil
);
4093 staticpro (&Qfile_name_history
);
4095 Qfile_error
= intern ("file-error");
4096 staticpro (&Qfile_error
);
4097 Qfile_already_exists
= intern("file-already-exists");
4098 staticpro (&Qfile_already_exists
);
4101 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
4102 staticpro (&Qfind_buffer_file_type
);
4105 Qcar_less_than_car
= intern ("car-less-than-car");
4106 staticpro (&Qcar_less_than_car
);
4108 Fput (Qfile_error
, Qerror_conditions
,
4109 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
4110 Fput (Qfile_error
, Qerror_message
,
4111 build_string ("File error"));
4113 Fput (Qfile_already_exists
, Qerror_conditions
,
4114 Fcons (Qfile_already_exists
,
4115 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
4116 Fput (Qfile_already_exists
, Qerror_message
,
4117 build_string ("File already exists"));
4119 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
4120 "*Non-nil means when reading a filename start with default dir in minibuffer.");
4121 insert_default_directory
= 1;
4123 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
4124 "*Non-nil means write new files with record format `stmlf'.\n\
4125 nil means use format `var'. This variable is meaningful only on VMS.");
4126 vms_stmlf_recfm
= 0;
4128 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
4129 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
4130 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
4133 The first argument given to HANDLER is the name of the I/O primitive\n\
4134 to be handled; the remaining arguments are the arguments that were\n\
4135 passed to that primitive. For example, if you do\n\
4136 (file-exists-p FILENAME)\n\
4137 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
4138 (funcall HANDLER 'file-exists-p FILENAME)\n\
4139 The function `find-file-name-handler' checks this list for a handler\n\
4140 for its argument.");
4141 Vfile_name_handler_alist
= Qnil
;
4143 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
4144 "A list of functions to be called at the end of `insert-file-contents'.\n\
4145 Each is passed one argument, the number of bytes inserted. It should return\n\
4146 the new byte count, and leave point the same. If `insert-file-contents' is\n\
4147 intercepted by a handler from `file-name-handler-alist', that handler is\n\
4148 responsible for calling the after-insert-file-functions if appropriate.");
4149 Vafter_insert_file_functions
= Qnil
;
4151 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
4152 "A list of functions to be called at the start of `write-region'.\n\
4153 Each is passed two arguments, START and END as for `write-region'. It should\n\
4154 return a list of pairs (POSITION . STRING) of strings to be effectively\n\
4155 inserted at the specified positions of the file being written (1 means to\n\
4156 insert before the first byte written). The POSITIONs must be sorted into\n\
4157 increasing order. If there are several functions in the list, the several\n\
4158 lists are merged destructively.");
4159 Vwrite_region_annotate_functions
= Qnil
;
4161 DEFVAR_LISP ("write-region-annotations-so-far",
4162 &Vwrite_region_annotations_so_far
,
4163 "When an annotation function is called, this holds the previous annotations.\n\
4164 These are the annotations made by other annotation functions\n\
4165 that were already called. See also `write-region-annotate-functions'.");
4166 Vwrite_region_annotations_so_far
= Qnil
;
4168 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
4169 "A list of file name handlers that temporarily should not be used.\n\
4170 This applies only to the operation `inhibit-file-name-operation'.");
4171 Vinhibit_file_name_handlers
= Qnil
;
4173 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
4174 "The operation for which `inhibit-file-name-handlers' is applicable.");
4175 Vinhibit_file_name_operation
= Qnil
;
4177 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
4178 "File name in which we write a list of all auto save file names.");
4179 Vauto_save_list_file_name
= Qnil
;
4181 defsubr (&Sfind_file_name_handler
);
4182 defsubr (&Sfile_name_directory
);
4183 defsubr (&Sfile_name_nondirectory
);
4184 defsubr (&Sunhandled_file_name_directory
);
4185 defsubr (&Sfile_name_as_directory
);
4186 defsubr (&Sdirectory_file_name
);
4187 defsubr (&Smake_temp_name
);
4188 defsubr (&Sexpand_file_name
);
4189 defsubr (&Ssubstitute_in_file_name
);
4190 defsubr (&Scopy_file
);
4191 defsubr (&Smake_directory_internal
);
4192 defsubr (&Sdelete_directory
);
4193 defsubr (&Sdelete_file
);
4194 defsubr (&Srename_file
);
4195 defsubr (&Sadd_name_to_file
);
4197 defsubr (&Smake_symbolic_link
);
4198 #endif /* S_IFLNK */
4200 defsubr (&Sdefine_logical_name
);
4203 defsubr (&Ssysnetunam
);
4204 #endif /* HPUX_NET */
4205 defsubr (&Sfile_name_absolute_p
);
4206 defsubr (&Sfile_exists_p
);
4207 defsubr (&Sfile_executable_p
);
4208 defsubr (&Sfile_readable_p
);
4209 defsubr (&Sfile_writable_p
);
4210 defsubr (&Sfile_symlink_p
);
4211 defsubr (&Sfile_directory_p
);
4212 defsubr (&Sfile_accessible_directory_p
);
4213 defsubr (&Sfile_modes
);
4214 defsubr (&Sset_file_modes
);
4215 defsubr (&Sset_default_file_modes
);
4216 defsubr (&Sdefault_file_modes
);
4217 defsubr (&Sfile_newer_than_file_p
);
4218 defsubr (&Sinsert_file_contents
);
4219 defsubr (&Swrite_region
);
4220 defsubr (&Scar_less_than_car
);
4221 defsubr (&Sverify_visited_file_modtime
);
4222 defsubr (&Sclear_visited_file_modtime
);
4223 defsubr (&Svisited_file_modtime
);
4224 defsubr (&Sset_visited_file_modtime
);
4225 defsubr (&Sdo_auto_save
);
4226 defsubr (&Sset_buffer_auto_saved
);
4227 defsubr (&Sclear_buffer_auto_save_failure
);
4228 defsubr (&Srecent_auto_save_p
);
4230 defsubr (&Sread_file_name_internal
);
4231 defsubr (&Sread_file_name
);
4234 defsubr (&Sunix_sync
);