1 /* File IO for GNU Emacs.
2 Copyright (C) 1985, 1986, 1987, 1988, 1993, 1994 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
22 #include <sys/types.h>
29 #if !defined (S_ISLNK) && defined (S_IFLNK)
30 # define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
33 #if !defined (S_ISREG) && defined (S_IFREG)
34 # define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
45 #include <sys/param.h>
63 extern char *strerror ();
78 #include "intervals.h"
104 #define min(a, b) ((a) < (b) ? (a) : (b))
105 #define max(a, b) ((a) > (b) ? (a) : (b))
107 /* Nonzero during writing of auto-save files */
110 /* Set by auto_save_1 to mode of original file so Fwrite_region will create
111 a new file with the same mode as the original */
112 int auto_save_mode_bits
;
114 /* Alist of elements (REGEXP . HANDLER) for file names
115 whose I/O is done with a special handler. */
116 Lisp_Object Vfile_name_handler_alist
;
118 /* Functions to be called to process text properties in inserted file. */
119 Lisp_Object Vafter_insert_file_functions
;
121 /* Functions to be called to create text property annotations for file. */
122 Lisp_Object Vwrite_region_annotate_functions
;
124 /* File name in which we write a list of all our auto save files. */
125 Lisp_Object Vauto_save_list_file_name
;
127 /* Nonzero means, when reading a filename in the minibuffer,
128 start out by inserting the default directory into the minibuffer. */
129 int insert_default_directory
;
131 /* On VMS, nonzero means write new files with record format stmlf.
132 Zero means use var format. */
135 /* These variables describe handlers that have "already" had a chance
136 to handle the current operation.
138 Vinhibit_file_name_handlers is a list of file name handlers.
139 Vinhibit_file_name_operation is the operation being handled.
140 If we try to handle that operation, we ignore those handlers. */
142 static Lisp_Object Vinhibit_file_name_handlers
;
143 static Lisp_Object Vinhibit_file_name_operation
;
145 Lisp_Object Qfile_error
, Qfile_already_exists
;
147 Lisp_Object Qfile_name_history
;
149 Lisp_Object Qcar_less_than_car
;
151 report_file_error (string
, data
)
155 Lisp_Object errstring
;
157 errstring
= build_string (strerror (errno
));
159 /* System error messages are capitalized. Downcase the initial
160 unless it is followed by a slash. */
161 if (XSTRING (errstring
)->data
[1] != '/')
162 XSTRING (errstring
)->data
[0] = DOWNCASE (XSTRING (errstring
)->data
[0]);
165 Fsignal (Qfile_error
,
166 Fcons (build_string (string
), Fcons (errstring
, data
)));
169 close_file_unwind (fd
)
172 close (XFASTINT (fd
));
175 /* Restore point, having saved it as a marker. */
177 restore_point_unwind (location
)
178 Lisp_Object location
;
180 SET_PT (marker_position (location
));
181 Fset_marker (location
, Qnil
, Qnil
);
184 Lisp_Object Qexpand_file_name
;
185 Lisp_Object Qdirectory_file_name
;
186 Lisp_Object Qfile_name_directory
;
187 Lisp_Object Qfile_name_nondirectory
;
188 Lisp_Object Qunhandled_file_name_directory
;
189 Lisp_Object Qfile_name_as_directory
;
190 Lisp_Object Qcopy_file
;
191 Lisp_Object Qmake_directory_internal
;
192 Lisp_Object Qdelete_directory
;
193 Lisp_Object Qdelete_file
;
194 Lisp_Object Qrename_file
;
195 Lisp_Object Qadd_name_to_file
;
196 Lisp_Object Qmake_symbolic_link
;
197 Lisp_Object Qfile_exists_p
;
198 Lisp_Object Qfile_executable_p
;
199 Lisp_Object Qfile_readable_p
;
200 Lisp_Object Qfile_symlink_p
;
201 Lisp_Object Qfile_writable_p
;
202 Lisp_Object Qfile_directory_p
;
203 Lisp_Object Qfile_accessible_directory_p
;
204 Lisp_Object Qfile_modes
;
205 Lisp_Object Qset_file_modes
;
206 Lisp_Object Qfile_newer_than_file_p
;
207 Lisp_Object Qinsert_file_contents
;
208 Lisp_Object Qwrite_region
;
209 Lisp_Object Qverify_visited_file_modtime
;
210 Lisp_Object Qset_visited_file_modtime
;
212 DEFUN ("find-file-name-handler", Ffind_file_name_handler
, Sfind_file_name_handler
, 2, 2, 0,
213 "Return FILENAME's handler function for OPERATION, if it has one.\n\
214 Otherwise, return nil.\n\
215 A file name is handled if one of the regular expressions in\n\
216 `file-name-handler-alist' matches it.\n\n\
217 If OPERATION equals `inhibit-file-name-operation', then we ignore\n\
218 any handlers that are members of `inhibit-file-name-handlers',\n\
219 but we still do run any other handlers. This lets handlers\n\
220 use the standard functions without calling themselves recursively.")
221 (filename
, operation
)
222 Lisp_Object filename
, operation
;
224 /* This function must not munge the match data. */
225 Lisp_Object chain
, inhibited_handlers
;
227 CHECK_STRING (filename
, 0);
229 if (EQ (operation
, Vinhibit_file_name_operation
))
230 inhibited_handlers
= Vinhibit_file_name_handlers
;
232 inhibited_handlers
= Qnil
;
234 for (chain
= Vfile_name_handler_alist
; XTYPE (chain
) == Lisp_Cons
;
235 chain
= XCONS (chain
)->cdr
)
238 elt
= XCONS (chain
)->car
;
239 if (XTYPE (elt
) == Lisp_Cons
)
242 string
= XCONS (elt
)->car
;
243 if (XTYPE (string
) == Lisp_String
244 && fast_string_match (string
, filename
) >= 0)
246 Lisp_Object handler
, tem
;
248 handler
= XCONS (elt
)->cdr
;
249 tem
= Fmemq (handler
, inhibited_handlers
);
260 DEFUN ("file-name-directory", Ffile_name_directory
, Sfile_name_directory
,
262 "Return the directory component in file name NAME.\n\
263 Return nil if NAME does not include a directory.\n\
264 Otherwise return a directory spec.\n\
265 Given a Unix syntax file name, returns a string ending in slash;\n\
266 on VMS, perhaps instead a string ending in `:', `]' or `>'.")
270 register unsigned char *beg
;
271 register unsigned char *p
;
274 CHECK_STRING (file
, 0);
276 /* If the file name has special constructs in it,
277 call the corresponding file handler. */
278 handler
= Ffind_file_name_handler (file
, Qfile_name_directory
);
280 return call2 (handler
, Qfile_name_directory
, file
);
282 #ifdef FILE_SYSTEM_CASE
283 file
= FILE_SYSTEM_CASE (file
);
285 beg
= XSTRING (file
)->data
;
286 p
= beg
+ XSTRING (file
)->size
;
288 while (p
!= beg
&& p
[-1] != '/'
290 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
293 && p
[-1] != ':' && p
[-1] != '\\'
300 /* Expansion of "c:" to drive and default directory. */
301 if (p
== beg
+ 2 && beg
[1] == ':')
303 int drive
= (*beg
) - 'a';
304 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
305 unsigned char *res
= alloca (MAXPATHLEN
+ 5);
306 if (getdefdir (drive
+ 1, res
+ 2))
308 res
[0] = drive
+ 'a';
310 if (res
[strlen (res
) - 1] != '/')
313 p
= beg
+ strlen (beg
);
317 return make_string (beg
, p
- beg
);
320 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory
, Sfile_name_nondirectory
,
322 "Return file name NAME sans its directory.\n\
323 For example, in a Unix-syntax file name,\n\
324 this is everything after the last slash,\n\
325 or the entire name if it contains no slash.")
329 register unsigned char *beg
, *p
, *end
;
332 CHECK_STRING (file
, 0);
334 /* If the file name has special constructs in it,
335 call the corresponding file handler. */
336 handler
= Ffind_file_name_handler (file
, Qfile_name_nondirectory
);
338 return call2 (handler
, Qfile_name_nondirectory
, file
);
340 beg
= XSTRING (file
)->data
;
341 end
= p
= beg
+ XSTRING (file
)->size
;
343 while (p
!= beg
&& p
[-1] != '/'
345 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
348 && p
[-1] != ':' && p
[-1] != '\\'
352 return make_string (p
, end
- p
);
355 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory
, Sunhandled_file_name_directory
, 1, 1, 0,
356 "Return a directly usable directory name somehow associated with FILENAME.\n\
357 A `directly usable' directory name is one that may be used without the\n\
358 intervention of any file handler.\n\
359 If FILENAME is a directly usable file itself, return\n\
360 (file-name-directory FILENAME).\n\
361 The `call-process' and `start-process' functions use this function to\n\
362 get a current directory to run processes in.")
364 Lisp_Object filename
;
368 /* If the file name has special constructs in it,
369 call the corresponding file handler. */
370 handler
= Ffind_file_name_handler (filename
, Qunhandled_file_name_directory
);
372 return call2 (handler
, Qunhandled_file_name_directory
, filename
);
374 return Ffile_name_directory (filename
);
379 file_name_as_directory (out
, in
)
382 int size
= strlen (in
) - 1;
387 /* Is it already a directory string? */
388 if (in
[size
] == ':' || in
[size
] == ']' || in
[size
] == '>')
390 /* Is it a VMS directory file name? If so, hack VMS syntax. */
391 else if (! index (in
, '/')
392 && ((size
> 3 && ! strcmp (&in
[size
- 3], ".DIR"))
393 || (size
> 3 && ! strcmp (&in
[size
- 3], ".dir"))
394 || (size
> 5 && (! strncmp (&in
[size
- 5], ".DIR", 4)
395 || ! strncmp (&in
[size
- 5], ".dir", 4))
396 && (in
[size
- 1] == '.' || in
[size
- 1] == ';')
397 && in
[size
] == '1')))
399 register char *p
, *dot
;
403 dir:x.dir --> dir:[x]
404 dir:[x]y.dir --> dir:[x.y] */
406 while (p
!= in
&& *p
!= ':' && *p
!= '>' && *p
!= ']') p
--;
409 strncpy (out
, in
, p
- in
);
428 dot
= index (p
, '.');
431 /* blindly remove any extension */
432 size
= strlen (out
) + (dot
- p
);
433 strncat (out
, p
, dot
- p
);
444 /* For Unix syntax, Append a slash if necessary */
446 if (out
[size
] != ':' && out
[size
] != '/' && out
[size
] != '\\')
448 if (out
[size
] != '/')
455 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
456 Sfile_name_as_directory
, 1, 1, 0,
457 "Return a string representing file FILENAME interpreted as a directory.\n\
458 This operation exists because a directory is also a file, but its name as\n\
459 a directory is different from its name as a file.\n\
460 The result can be used as the value of `default-directory'\n\
461 or passed as second argument to `expand-file-name'.\n\
462 For a Unix-syntax file name, just appends a slash.\n\
463 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
470 CHECK_STRING (file
, 0);
474 /* If the file name has special constructs in it,
475 call the corresponding file handler. */
476 handler
= Ffind_file_name_handler (file
, Qfile_name_as_directory
);
478 return call2 (handler
, Qfile_name_as_directory
, file
);
480 buf
= (char *) alloca (XSTRING (file
)->size
+ 10);
481 return build_string (file_name_as_directory (buf
, XSTRING (file
)->data
));
485 * Convert from directory name to filename.
487 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
488 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
489 * On UNIX, it's simple: just make sure there is a terminating /
491 * Value is nonzero if the string output is different from the input.
494 directory_file_name (src
, dst
)
502 struct FAB fab
= cc$rms_fab
;
503 struct NAM nam
= cc$rms_nam
;
504 char esa
[NAM$C_MAXRSS
];
509 if (! index (src
, '/')
510 && (src
[slen
- 1] == ']'
511 || src
[slen
- 1] == ':'
512 || src
[slen
- 1] == '>'))
514 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
516 fab
.fab$b_fns
= slen
;
517 fab
.fab$l_nam
= &nam
;
518 fab
.fab$l_fop
= FAB$M_NAM
;
521 nam
.nam$b_ess
= sizeof esa
;
522 nam
.nam$b_nop
|= NAM$M_SYNCHK
;
524 /* We call SYS$PARSE to handle such things as [--] for us. */
525 if (SYS$
PARSE(&fab
, 0, 0) == RMS$_NORMAL
)
527 slen
= nam
.nam$b_esl
;
528 if (esa
[slen
- 1] == ';' && esa
[slen
- 2] == '.')
533 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
535 /* what about when we have logical_name:???? */
536 if (src
[slen
- 1] == ':')
537 { /* Xlate logical name and see what we get */
538 ptr
= strcpy (dst
, src
); /* upper case for getenv */
541 if ('a' <= *ptr
&& *ptr
<= 'z')
545 dst
[slen
- 1] = 0; /* remove colon */
546 if (!(src
= egetenv (dst
)))
548 /* should we jump to the beginning of this procedure?
549 Good points: allows us to use logical names that xlate
551 Bad points: can be a problem if we just translated to a device
553 For now, I'll punt and always expect VMS names, and hope for
556 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
557 { /* no recursion here! */
563 { /* not a directory spec */
568 bracket
= src
[slen
- 1];
570 /* If bracket is ']' or '>', bracket - 2 is the corresponding
572 ptr
= index (src
, bracket
- 2);
574 { /* no opening bracket */
578 if (!(rptr
= rindex (src
, '.')))
581 strncpy (dst
, src
, slen
);
585 dst
[slen
++] = bracket
;
590 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
591 then translate the device and recurse. */
592 if (dst
[slen
- 1] == ':'
593 && dst
[slen
- 2] != ':' /* skip decnet nodes */
594 && strcmp(src
+ slen
, "[000000]") == 0)
596 dst
[slen
- 1] = '\0';
597 if ((ptr
= egetenv (dst
))
598 && (rlen
= strlen (ptr
) - 1) > 0
599 && (ptr
[rlen
] == ']' || ptr
[rlen
] == '>')
600 && ptr
[rlen
- 1] == '.')
602 char * buf
= (char *) alloca (strlen (ptr
) + 1);
606 return directory_file_name (buf
, dst
);
611 strcat (dst
, "[000000]");
615 rlen
= strlen (rptr
) - 1;
616 strncat (dst
, rptr
, rlen
);
617 dst
[slen
+ rlen
] = '\0';
618 strcat (dst
, ".DIR.1");
622 /* Process as Unix format: just remove any final slash.
623 But leave "/" unchanged; do not change it to "". */
627 && (dst
[slen
- 1] == '/' || dst
[slen
- 1] == '/')
628 && dst
[slen
- 2] != ':'
630 && dst
[slen
- 1] == '/'
637 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
639 "Returns the file name of the directory named DIR.\n\
640 This is the name of the file that holds the data for the directory DIR.\n\
641 This operation exists because a directory is also a file, but its name as\n\
642 a directory is different from its name as a file.\n\
643 In Unix-syntax, this function just removes the final slash.\n\
644 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
645 it returns a file name such as \"[X]Y.DIR.1\".")
647 Lisp_Object directory
;
652 CHECK_STRING (directory
, 0);
654 if (NILP (directory
))
657 /* If the file name has special constructs in it,
658 call the corresponding file handler. */
659 handler
= Ffind_file_name_handler (directory
, Qdirectory_file_name
);
661 return call2 (handler
, Qdirectory_file_name
, directory
);
664 /* 20 extra chars is insufficient for VMS, since we might perform a
665 logical name translation. an equivalence string can be up to 255
666 chars long, so grab that much extra space... - sss */
667 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20 + 255);
669 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20);
671 directory_file_name (XSTRING (directory
)->data
, buf
);
672 return build_string (buf
);
675 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
676 "Generate temporary file name (string) starting with PREFIX (a string).\n\
677 The Emacs process number forms part of the result,\n\
678 so there is no danger of generating a name being used by another process.")
683 val
= concat2 (prefix
, build_string ("XXXXXX"));
684 mktemp (XSTRING (val
)->data
);
688 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
689 "Convert FILENAME to absolute, and canonicalize it.\n\
690 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
691 (does not start with slash); if DEFAULT is nil or missing,\n\
692 the current buffer's value of default-directory is used.\n\
693 Path components that are `.' are removed, and \n\
694 path components followed by `..' are removed, along with the `..' itself;\n\
695 note that these simplifications are done without checking the resulting\n\
696 paths in the file system.\n\
697 An initial `~/' expands to your home directory.\n\
698 An initial `~USER/' expands to USER's home directory.\n\
699 See also the function `substitute-in-file-name'.")
701 Lisp_Object name
, defalt
;
705 register unsigned char *newdir
, *p
, *o
;
707 unsigned char *target
;
710 unsigned char * colon
= 0;
711 unsigned char * close
= 0;
712 unsigned char * slash
= 0;
713 unsigned char * brack
= 0;
714 int lbrack
= 0, rbrack
= 0;
717 #ifdef MSDOS /* Demacs 1.1.2 91/10/20 Manabu Higashida */
720 unsigned char *tmp
, *defdir
;
724 CHECK_STRING (name
, 0);
726 /* If the file name has special constructs in it,
727 call the corresponding file handler. */
728 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
730 return call3 (handler
, Qexpand_file_name
, name
, defalt
);
732 /* Use the buffer's default-directory if DEFALT is omitted. */
734 defalt
= current_buffer
->directory
;
735 CHECK_STRING (defalt
, 1);
737 /* Make sure DEFALT is properly expanded.
738 It would be better to do this down below where we actually use
739 defalt. Unfortunately, calling Fexpand_file_name recursively
740 could invoke GC, and the strings might be relocated. This would
741 be annoying because we have pointers into strings lying around
742 that would need adjusting, and people would add new pointers to
743 the code and forget to adjust them, resulting in intermittent bugs.
744 Putting this call here avoids all that crud.
746 The EQ test avoids infinite recursion. */
747 if (! NILP (defalt
) && !EQ (defalt
, name
)
748 /* This saves time in a common case. */
749 && XSTRING (defalt
)->data
[0] != '/')
754 defalt
= Fexpand_file_name (defalt
, Qnil
);
759 /* Filenames on VMS are always upper case. */
760 name
= Fupcase (name
);
762 #ifdef FILE_SYSTEM_CASE
763 name
= FILE_SYSTEM_CASE (name
);
766 nm
= XSTRING (name
)->data
;
769 /* First map all backslashes to slashes. */
770 dostounix_filename (nm
= strcpy (alloca (strlen (nm
) + 1), nm
));
772 /* Now strip drive name. */
774 unsigned char *colon
= rindex (nm
, ':');
780 drive
= tolower (colon
[-1]) - 'a';
784 defdir
= alloca (MAXPATHLEN
+ 1);
785 relpath
= getdefdir (drive
+ 1, defdir
);
791 /* If nm is absolute, flush ...// and detect /./ and /../.
792 If no /./ or /../ we can return right away. */
800 /* If it turns out that the filename we want to return is just a
801 suffix of FILENAME, we don't need to go through and edit
802 things; we just need to construct a new string using data
803 starting at the middle of FILENAME. If we set lose to a
804 non-zero value, that means we've discovered that we can't do
811 /* Since we know the path is absolute, we can assume that each
812 element starts with a "/". */
814 /* "//" anywhere isn't necessarily hairy; we just start afresh
815 with the second slash. */
816 if (p
[0] == '/' && p
[1] == '/'
818 /* // at start of filename is meaningful on Apollo system */
824 /* "~" is hairy as the start of any path element. */
825 if (p
[0] == '/' && p
[1] == '~')
826 nm
= p
+ 1, lose
= 1;
828 /* "." and ".." are hairy. */
833 || (p
[2] == '.' && (p
[3] == '/'
840 /* if dev:[dir]/, move nm to / */
841 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
842 nm
= (brack
? brack
+ 1 : colon
+ 1);
851 /* VMS pre V4.4,convert '-'s in filenames. */
852 if (lbrack
== rbrack
)
854 if (dots
< 2) /* this is to allow negative version numbers */
859 if (lbrack
> rbrack
&&
860 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
861 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
867 /* count open brackets, reset close bracket pointer */
868 if (p
[0] == '[' || p
[0] == '<')
870 /* count close brackets, set close bracket pointer */
871 if (p
[0] == ']' || p
[0] == '>')
873 /* detect ][ or >< */
874 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
876 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
877 nm
= p
+ 1, lose
= 1;
878 if (p
[0] == ':' && (colon
|| slash
))
879 /* if dev1:[dir]dev2:, move nm to dev2: */
885 /* if /pathname/dev:, move nm to dev: */
888 /* if node::dev:, move colon following dev */
889 else if (colon
&& colon
[-1] == ':')
891 /* if dev1:dev2:, move nm to dev2: */
892 else if (colon
&& colon
[-1] != ':')
897 if (p
[0] == ':' && !colon
)
903 if (lbrack
== rbrack
)
906 else if (p
[0] == '.')
915 return build_string (sys_translate_unix (nm
));
918 if (nm
== XSTRING (name
)->data
)
920 return build_string (nm
);
925 /* Now determine directory to start with and put it in newdir */
929 if (nm
[0] == '~') /* prefix ~ */
935 || nm
[1] == 0) /* ~ by itself */
937 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
938 newdir
= (unsigned char *) "";
940 dostounix_filename (newdir
);
944 nm
++; /* Don't leave the slash in nm. */
947 else /* ~user/filename */
949 for (p
= nm
; *p
&& (*p
!= '/'
954 o
= (unsigned char *) alloca (p
- nm
+ 1);
955 bcopy ((char *) nm
, o
, p
- nm
);
958 pw
= (struct passwd
*) getpwnam (o
+ 1);
961 newdir
= (unsigned char *) pw
-> pw_dir
;
963 nm
= p
+ 1; /* skip the terminator */
969 /* If we don't find a user of that name, leave the name
970 unchanged; don't move nm forward to p. */
983 newdir
= XSTRING (defalt
)->data
;
987 if (newdir
== 0 && relpath
)
992 /* Get rid of any slash at the end of newdir. */
993 int length
= strlen (newdir
);
994 /* Adding `length > 1 &&' makes ~ expand into / when homedir
995 is the root dir. People disagree about whether that is right.
996 Anyway, we can't take the risk of this change now. */
998 if (newdir
[1] != ':' && length
> 1)
1000 if (newdir
[length
- 1] == '/')
1002 unsigned char *temp
= (unsigned char *) alloca (length
);
1003 bcopy (newdir
, temp
, length
- 1);
1004 temp
[length
- 1] = 0;
1012 /* Now concatenate the directory and name to new space in the stack frame */
1013 tlen
+= strlen (nm
) + 1;
1015 /* Add reserved space for drive name. */
1016 target
= (unsigned char *) alloca (tlen
+ 2) + 2;
1018 target
= (unsigned char *) alloca (tlen
);
1025 if (nm
[0] == 0 || nm
[0] == '/')
1026 strcpy (target
, newdir
);
1029 file_name_as_directory (target
, newdir
);
1032 strcat (target
, nm
);
1034 if (index (target
, '/'))
1035 strcpy (target
, sys_translate_unix (target
));
1038 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1046 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1052 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1053 /* brackets are offset from each other by 2 */
1056 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1057 /* convert [foo][bar] to [bar] */
1058 while (o
[-1] != '[' && o
[-1] != '<')
1060 else if (*p
== '-' && *o
!= '.')
1063 else if (p
[0] == '-' && o
[-1] == '.' &&
1064 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1065 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1069 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1070 if (p
[1] == '.') /* foo.-.bar ==> bar*/
1072 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1074 /* else [foo.-] ==> [-] */
1080 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1081 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1091 else if (!strncmp (p
, "//", 2)
1093 /* // at start of filename is meaningful in Apollo system */
1101 else if (p
[0] == '/'
1106 /* If "/." is the entire filename, keep the "/". Otherwise,
1107 just delete the whole "/.". */
1108 if (o
== target
&& p
[2] == '\0')
1112 else if (!strncmp (p
, "/..", 3)
1113 /* `/../' is the "superroot" on certain file systems. */
1115 && (p
[3] == '/' || p
[3] == 0))
1117 while (o
!= target
&& *--o
!= '/')
1120 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1124 if (o
== target
&& *o
== '/')
1132 #endif /* not VMS */
1136 /* at last, set drive name. */
1137 if (target
[1] != ':')
1140 target
[0] = (drive
< 0 ? getdisk () : drive
) + 'a';
1145 return make_string (target
, o
- target
);
1148 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'.
1149 DEAFUN ("expand-file-name", Fexpand_file_name, Sexpand_file_name, 1, 2, 0,
1150 "Convert FILENAME to absolute, and canonicalize it.\n\
1151 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1152 (does not start with slash); if DEFAULT is nil or missing,\n\
1153 the current buffer's value of default-directory is used.\n\
1154 Filenames containing `.' or `..' as components are simplified;\n\
1155 initial `~/' expands to your home directory.\n\
1156 See also the function `substitute-in-file-name'.")
1158 Lisp_Object name, defalt;
1162 register unsigned char *newdir, *p, *o;
1164 unsigned char *target;
1168 unsigned char * colon = 0;
1169 unsigned char * close = 0;
1170 unsigned char * slash = 0;
1171 unsigned char * brack = 0;
1172 int lbrack = 0, rbrack = 0;
1176 CHECK_STRING (name
, 0);
1179 /* Filenames on VMS are always upper case. */
1180 name
= Fupcase (name
);
1183 nm
= XSTRING (name
)->data
;
1185 /* If nm is absolute, flush ...// and detect /./ and /../.
1186 If no /./ or /../ we can return right away. */
1198 if (p
[0] == '/' && p
[1] == '/'
1200 /* // at start of filename is meaningful on Apollo system */
1205 if (p
[0] == '/' && p
[1] == '~')
1206 nm
= p
+ 1, lose
= 1;
1207 if (p
[0] == '/' && p
[1] == '.'
1208 && (p
[2] == '/' || p
[2] == 0
1209 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1215 /* if dev:[dir]/, move nm to / */
1216 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1217 nm
= (brack
? brack
+ 1 : colon
+ 1);
1218 lbrack
= rbrack
= 0;
1226 /* VMS pre V4.4,convert '-'s in filenames. */
1227 if (lbrack
== rbrack
)
1229 if (dots
< 2) /* this is to allow negative version numbers */
1234 if (lbrack
> rbrack
&&
1235 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1236 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1242 /* count open brackets, reset close bracket pointer */
1243 if (p
[0] == '[' || p
[0] == '<')
1244 lbrack
++, brack
= 0;
1245 /* count close brackets, set close bracket pointer */
1246 if (p
[0] == ']' || p
[0] == '>')
1247 rbrack
++, brack
= p
;
1248 /* detect ][ or >< */
1249 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1251 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1252 nm
= p
+ 1, lose
= 1;
1253 if (p
[0] == ':' && (colon
|| slash
))
1254 /* if dev1:[dir]dev2:, move nm to dev2: */
1260 /* if /pathname/dev:, move nm to dev: */
1263 /* if node::dev:, move colon following dev */
1264 else if (colon
&& colon
[-1] == ':')
1266 /* if dev1:dev2:, move nm to dev2: */
1267 else if (colon
&& colon
[-1] != ':')
1272 if (p
[0] == ':' && !colon
)
1278 if (lbrack
== rbrack
)
1281 else if (p
[0] == '.')
1289 if (index (nm
, '/'))
1290 return build_string (sys_translate_unix (nm
));
1292 if (nm
== XSTRING (name
)->data
)
1294 return build_string (nm
);
1298 /* Now determine directory to start with and put it in NEWDIR */
1302 if (nm
[0] == '~') /* prefix ~ */
1307 || nm
[1] == 0)/* ~/filename */
1309 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1310 newdir
= (unsigned char *) "";
1313 nm
++; /* Don't leave the slash in nm. */
1316 else /* ~user/filename */
1318 /* Get past ~ to user */
1319 unsigned char *user
= nm
+ 1;
1320 /* Find end of name. */
1321 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1322 int len
= ptr
? ptr
- user
: strlen (user
);
1324 unsigned char *ptr1
= index (user
, ':');
1325 if (ptr1
!= 0 && ptr1
- user
< len
)
1328 /* Copy the user name into temp storage. */
1329 o
= (unsigned char *) alloca (len
+ 1);
1330 bcopy ((char *) user
, o
, len
);
1333 /* Look up the user name. */
1334 pw
= (struct passwd
*) getpwnam (o
+ 1);
1336 error ("\"%s\" isn't a registered user", o
+ 1);
1338 newdir
= (unsigned char *) pw
->pw_dir
;
1340 /* Discard the user name from NM. */
1347 #endif /* not VMS */
1351 defalt
= current_buffer
->directory
;
1352 CHECK_STRING (defalt
, 1);
1353 newdir
= XSTRING (defalt
)->data
;
1356 /* Now concatenate the directory and name to new space in the stack frame */
1358 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1359 target
= (unsigned char *) alloca (tlen
);
1365 if (nm
[0] == 0 || nm
[0] == '/')
1366 strcpy (target
, newdir
);
1369 file_name_as_directory (target
, newdir
);
1372 strcat (target
, nm
);
1374 if (index (target
, '/'))
1375 strcpy (target
, sys_translate_unix (target
));
1378 /* Now canonicalize by removing /. and /foo/.. if they appear */
1386 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1392 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1393 /* brackets are offset from each other by 2 */
1396 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1397 /* convert [foo][bar] to [bar] */
1398 while (o
[-1] != '[' && o
[-1] != '<')
1400 else if (*p
== '-' && *o
!= '.')
1403 else if (p
[0] == '-' && o
[-1] == '.' &&
1404 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1405 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1409 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1410 if (p
[1] == '.') /* foo.-.bar ==> bar*/
1412 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1414 /* else [foo.-] ==> [-] */
1420 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1421 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1431 else if (!strncmp (p
, "//", 2)
1433 /* // at start of filename is meaningful in Apollo system */
1441 else if (p
[0] == '/' && p
[1] == '.' &&
1442 (p
[2] == '/' || p
[2] == 0))
1444 else if (!strncmp (p
, "/..", 3)
1445 /* `/../' is the "superroot" on certain file systems. */
1447 && (p
[3] == '/' || p
[3] == 0))
1449 while (o
!= target
&& *--o
!= '/')
1452 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1456 if (o
== target
&& *o
== '/')
1464 #endif /* not VMS */
1467 return make_string (target
, o
- target
);
1471 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1472 Ssubstitute_in_file_name
, 1, 1, 0,
1473 "Substitute environment variables referred to in FILENAME.\n\
1474 `$FOO' where FOO is an environment variable name means to substitute\n\
1475 the value of that variable. The variable name should be terminated\n\
1476 with a character not a letter, digit or underscore; otherwise, enclose\n\
1477 the entire variable name in braces.\n\
1478 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1479 On VMS, `$' substitution is not done; this function does little and only\n\
1480 duplicates what `expand-file-name' does.")
1486 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1487 unsigned char *target
;
1489 int substituted
= 0;
1492 CHECK_STRING (string
, 0);
1494 nm
= XSTRING (string
)->data
;
1496 dostounix_filename (nm
= strcpy (alloca (strlen (nm
) + 1), nm
));
1497 substituted
= !strcmp (nm
, XSTRING (string
)->data
);
1499 endp
= nm
+ XSTRING (string
)->size
;
1501 /* If /~ or // appears, discard everything through first slash. */
1503 for (p
= nm
; p
!= endp
; p
++)
1507 /* // at start of file name is meaningful in Apollo system */
1508 (p
[0] == '/' && p
- 1 != nm
)
1509 #else /* not APOLLO */
1511 #endif /* not APOLLO */
1515 (p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>' ||
1526 if (p
[0] && p
[1] == ':')
1535 return build_string (nm
);
1538 /* See if any variables are substituted into the string
1539 and find the total length of their values in `total' */
1541 for (p
= nm
; p
!= endp
;)
1551 /* "$$" means a single "$" */
1560 while (p
!= endp
&& *p
!= '}') p
++;
1561 if (*p
!= '}') goto missingclose
;
1567 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1571 /* Copy out the variable name */
1572 target
= (unsigned char *) alloca (s
- o
+ 1);
1573 strncpy (target
, o
, s
- o
);
1576 strupr (target
); /* $home == $HOME etc. */
1579 /* Get variable value */
1580 o
= (unsigned char *) egetenv (target
);
1581 if (!o
) goto badvar
;
1582 total
+= strlen (o
);
1589 /* If substitution required, recopy the string and do it */
1590 /* Make space in stack frame for the new copy */
1591 xnm
= (unsigned char *) alloca (XSTRING (string
)->size
+ total
+ 1);
1594 /* Copy the rest of the name through, replacing $ constructs with values */
1611 while (p
!= endp
&& *p
!= '}') p
++;
1612 if (*p
!= '}') goto missingclose
;
1618 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1622 /* Copy out the variable name */
1623 target
= (unsigned char *) alloca (s
- o
+ 1);
1624 strncpy (target
, o
, s
- o
);
1627 strupr (target
); /* $home == $HOME etc. */
1630 /* Get variable value */
1631 o
= (unsigned char *) egetenv (target
);
1641 /* If /~ or // appears, discard everything through first slash. */
1643 for (p
= xnm
; p
!= x
; p
++)
1646 /* // at start of file name is meaningful in Apollo system */
1647 (p
[0] == '/' && p
- 1 != xnm
)
1648 #else /* not APOLLO */
1650 #endif /* not APOLLO */
1652 && p
!= nm
&& p
[-1] == '/')
1655 else if (p
[0] && p
[1] == ':')
1659 return make_string (xnm
, x
- xnm
);
1662 error ("Bad format environment-variable substitution");
1664 error ("Missing \"}\" in environment-variable substitution");
1666 error ("Substituting nonexistent environment variable \"%s\"", target
);
1669 #endif /* not VMS */
1672 /* A slightly faster and more convenient way to get
1673 (directory-file-name (expand-file-name FOO)). */
1676 expand_and_dir_to_file (filename
, defdir
)
1677 Lisp_Object filename
, defdir
;
1679 register Lisp_Object abspath
;
1681 abspath
= Fexpand_file_name (filename
, defdir
);
1684 register int c
= XSTRING (abspath
)->data
[XSTRING (abspath
)->size
- 1];
1685 if (c
== ':' || c
== ']' || c
== '>')
1686 abspath
= Fdirectory_file_name (abspath
);
1689 /* Remove final slash, if any (unless path is root).
1690 stat behaves differently depending! */
1691 if (XSTRING (abspath
)->size
> 1
1692 && XSTRING (abspath
)->data
[XSTRING (abspath
)->size
- 1] == '/')
1693 /* We cannot take shortcuts; they might be wrong for magic file names. */
1694 abspath
= Fdirectory_file_name (abspath
);
1699 barf_or_query_if_file_exists (absname
, querystring
, interactive
)
1700 Lisp_Object absname
;
1701 unsigned char *querystring
;
1704 register Lisp_Object tem
;
1705 struct gcpro gcpro1
;
1707 if (access (XSTRING (absname
)->data
, 4) >= 0)
1710 Fsignal (Qfile_already_exists
,
1711 Fcons (build_string ("File already exists"),
1712 Fcons (absname
, Qnil
)));
1714 tem
= do_yes_or_no_p (format1 ("File %s already exists; %s anyway? ",
1715 XSTRING (absname
)->data
, querystring
));
1718 Fsignal (Qfile_already_exists
,
1719 Fcons (build_string ("File already exists"),
1720 Fcons (absname
, Qnil
)));
1725 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
1726 "fCopy file: \nFCopy %s to file: \np\nP",
1727 "Copy FILE to NEWNAME. Both args must be strings.\n\
1728 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
1729 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
1730 A number as third arg means request confirmation if NEWNAME already exists.\n\
1731 This is what happens in interactive use with M-x.\n\
1732 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
1733 last-modified time as the old one. (This works on only some systems.)\n\
1734 A prefix arg makes KEEP-TIME non-nil.")
1735 (filename
, newname
, ok_if_already_exists
, keep_date
)
1736 Lisp_Object filename
, newname
, ok_if_already_exists
, keep_date
;
1739 char buf
[16 * 1024];
1741 Lisp_Object handler
;
1742 struct gcpro gcpro1
, gcpro2
;
1743 int count
= specpdl_ptr
- specpdl
;
1744 Lisp_Object args
[6];
1745 int input_file_statable_p
;
1747 GCPRO2 (filename
, newname
);
1748 CHECK_STRING (filename
, 0);
1749 CHECK_STRING (newname
, 1);
1750 filename
= Fexpand_file_name (filename
, Qnil
);
1751 newname
= Fexpand_file_name (newname
, Qnil
);
1753 /* If the input file name has special constructs in it,
1754 call the corresponding file handler. */
1755 handler
= Ffind_file_name_handler (filename
, Qcopy_file
);
1756 /* Likewise for output file name. */
1758 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
1759 if (!NILP (handler
))
1760 RETURN_UNGCPRO (call5 (handler
, Qcopy_file
, filename
, newname
,
1761 ok_if_already_exists
, keep_date
));
1763 if (NILP (ok_if_already_exists
)
1764 || XTYPE (ok_if_already_exists
) == Lisp_Int
)
1765 barf_or_query_if_file_exists (newname
, "copy to it",
1766 XTYPE (ok_if_already_exists
) == Lisp_Int
);
1768 ifd
= open (XSTRING (filename
)->data
, 0);
1770 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
1772 record_unwind_protect (close_file_unwind
, make_number (ifd
));
1774 /* We can only copy regular files and symbolic links. Other files are not
1776 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
1778 #if defined (S_ISREG) && defined (S_ISLNK)
1779 if (input_file_statable_p
)
1781 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
1783 #if defined (EISDIR)
1784 /* Get a better looking error message. */
1787 report_file_error ("Non-regular file", Fcons (filename
, Qnil
));
1790 #endif /* S_ISREG && S_ISLNK */
1793 /* Create the copy file with the same record format as the input file */
1794 ofd
= sys_creat (XSTRING (newname
)->data
, 0666, ifd
);
1797 /* System's default file type was set to binary by _fmode in emacs.c. */
1798 ofd
= creat (XSTRING (newname
)->data
, S_IREAD
| S_IWRITE
);
1799 #else /* not MSDOS */
1800 ofd
= creat (XSTRING (newname
)->data
, 0666);
1801 #endif /* not MSDOS */
1804 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
1806 record_unwind_protect (close_file_unwind
, make_number (ofd
));
1810 while ((n
= read (ifd
, buf
, sizeof buf
)) > 0)
1811 if (write (ofd
, buf
, n
) != n
)
1812 report_file_error ("I/O error", Fcons (newname
, Qnil
));
1815 /* Closing the output clobbers the file times on some systems. */
1816 if (close (ofd
) < 0)
1817 report_file_error ("I/O error", Fcons (newname
, Qnil
));
1819 if (input_file_statable_p
)
1821 if (!NILP (keep_date
))
1823 EMACS_TIME atime
, mtime
;
1824 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
1825 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
1826 EMACS_SET_UTIMES (XSTRING (newname
)->data
, atime
, mtime
);
1829 if (!egetenv ("USE_DOMAIN_ACLS"))
1831 chmod (XSTRING (newname
)->data
, st
.st_mode
& 07777);
1836 /* Discard the unwind protects. */
1837 specpdl_ptr
= specpdl
+ count
;
1843 DEFUN ("make-directory-internal", Fmake_directory_internal
,
1844 Smake_directory_internal
, 1, 1, 0,
1845 "Create a directory. One argument, a file name string.")
1847 Lisp_Object dirname
;
1850 Lisp_Object handler
;
1852 CHECK_STRING (dirname
, 0);
1853 dirname
= Fexpand_file_name (dirname
, Qnil
);
1855 handler
= Ffind_file_name_handler (dirname
, Qmake_directory_internal
);
1856 if (!NILP (handler
))
1857 return call3 (handler
, Qmake_directory_internal
, dirname
, Qnil
);
1859 dir
= XSTRING (dirname
)->data
;
1861 if (mkdir (dir
, 0777) != 0)
1862 report_file_error ("Creating directory", Flist (1, &dirname
));
1867 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
1868 "Delete a directory. One argument, a file name or directory name string.")
1870 Lisp_Object dirname
;
1873 Lisp_Object handler
;
1875 CHECK_STRING (dirname
, 0);
1876 dirname
= Fdirectory_file_name (Fexpand_file_name (dirname
, Qnil
));
1877 dir
= XSTRING (dirname
)->data
;
1879 handler
= Ffind_file_name_handler (dirname
, Qdelete_directory
);
1880 if (!NILP (handler
))
1881 return call2 (handler
, Qdelete_directory
, dirname
);
1883 if (rmdir (dir
) != 0)
1884 report_file_error ("Removing directory", Flist (1, &dirname
));
1889 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
1890 "Delete specified file. One argument, a file name string.\n\
1891 If file has multiple names, it continues to exist with the other names.")
1893 Lisp_Object filename
;
1895 Lisp_Object handler
;
1896 CHECK_STRING (filename
, 0);
1897 filename
= Fexpand_file_name (filename
, Qnil
);
1899 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
1900 if (!NILP (handler
))
1901 return call2 (handler
, Qdelete_file
, filename
);
1903 if (0 > unlink (XSTRING (filename
)->data
))
1904 report_file_error ("Removing old name", Flist (1, &filename
));
1908 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
1909 "fRename file: \nFRename %s to file: \np",
1910 "Rename FILE as NEWNAME. Both args strings.\n\
1911 If file has names other than FILE, it continues to have those names.\n\
1912 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
1913 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
1914 A number as third arg means request confirmation if NEWNAME already exists.\n\
1915 This is what happens in interactive use with M-x.")
1916 (filename
, newname
, ok_if_already_exists
)
1917 Lisp_Object filename
, newname
, ok_if_already_exists
;
1920 Lisp_Object args
[2];
1922 Lisp_Object handler
;
1923 struct gcpro gcpro1
, gcpro2
;
1925 GCPRO2 (filename
, newname
);
1926 CHECK_STRING (filename
, 0);
1927 CHECK_STRING (newname
, 1);
1928 filename
= Fexpand_file_name (filename
, Qnil
);
1929 newname
= Fexpand_file_name (newname
, Qnil
);
1931 /* If the file name has special constructs in it,
1932 call the corresponding file handler. */
1933 handler
= Ffind_file_name_handler (filename
, Qrename_file
);
1935 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
1936 if (!NILP (handler
))
1937 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
1938 filename
, newname
, ok_if_already_exists
));
1940 if (NILP (ok_if_already_exists
)
1941 || XTYPE (ok_if_already_exists
) == Lisp_Int
)
1942 barf_or_query_if_file_exists (newname
, "rename to it",
1943 XTYPE (ok_if_already_exists
) == Lisp_Int
);
1945 if (0 > rename (XSTRING (filename
)->data
, XSTRING (newname
)->data
))
1947 if (0 > link (XSTRING (filename
)->data
, XSTRING (newname
)->data
)
1948 || 0 > unlink (XSTRING (filename
)->data
))
1953 Fcopy_file (filename
, newname
,
1954 /* We have already prompted if it was an integer,
1955 so don't have copy-file prompt again. */
1956 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
1957 Fdelete_file (filename
);
1964 report_file_error ("Renaming", Flist (2, args
));
1967 report_file_error ("Renaming", Flist (2, &filename
));
1974 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
1975 "fAdd name to file: \nFName to add to %s: \np",
1976 "Give FILE additional name NEWNAME. Both args strings.\n\
1977 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
1978 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
1979 A number as third arg means request confirmation if NEWNAME already exists.\n\
1980 This is what happens in interactive use with M-x.")
1981 (filename
, newname
, ok_if_already_exists
)
1982 Lisp_Object filename
, newname
, ok_if_already_exists
;
1985 Lisp_Object args
[2];
1987 Lisp_Object handler
;
1988 struct gcpro gcpro1
, gcpro2
;
1990 GCPRO2 (filename
, newname
);
1991 CHECK_STRING (filename
, 0);
1992 CHECK_STRING (newname
, 1);
1993 filename
= Fexpand_file_name (filename
, Qnil
);
1994 newname
= Fexpand_file_name (newname
, Qnil
);
1996 /* If the file name has special constructs in it,
1997 call the corresponding file handler. */
1998 handler
= Ffind_file_name_handler (filename
, Qadd_name_to_file
);
1999 if (!NILP (handler
))
2000 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, filename
,
2001 newname
, ok_if_already_exists
));
2003 if (NILP (ok_if_already_exists
)
2004 || XTYPE (ok_if_already_exists
) == Lisp_Int
)
2005 barf_or_query_if_file_exists (newname
, "make it a new name",
2006 XTYPE (ok_if_already_exists
) == Lisp_Int
);
2007 unlink (XSTRING (newname
)->data
);
2008 if (0 > link (XSTRING (filename
)->data
, XSTRING (newname
)->data
))
2013 report_file_error ("Adding new name", Flist (2, args
));
2015 report_file_error ("Adding new name", Flist (2, &filename
));
2024 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2025 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2026 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
2027 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2028 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2029 A number as third arg means request confirmation if NEWNAME already exists.\n\
2030 This happens for interactive use with M-x.")
2031 (filename
, linkname
, ok_if_already_exists
)
2032 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2035 Lisp_Object args
[2];
2037 Lisp_Object handler
;
2038 struct gcpro gcpro1
, gcpro2
;
2040 GCPRO2 (filename
, linkname
);
2041 CHECK_STRING (filename
, 0);
2042 CHECK_STRING (linkname
, 1);
2043 /* If the link target has a ~, we must expand it to get
2044 a truly valid file name. Otherwise, do not expand;
2045 we want to permit links to relative file names. */
2046 if (XSTRING (filename
)->data
[0] == '~')
2047 filename
= Fexpand_file_name (filename
, Qnil
);
2048 linkname
= Fexpand_file_name (linkname
, Qnil
);
2050 /* If the file name has special constructs in it,
2051 call the corresponding file handler. */
2052 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2053 if (!NILP (handler
))
2054 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2055 linkname
, ok_if_already_exists
));
2057 if (NILP (ok_if_already_exists
)
2058 || XTYPE (ok_if_already_exists
) == Lisp_Int
)
2059 barf_or_query_if_file_exists (linkname
, "make it a link",
2060 XTYPE (ok_if_already_exists
) == Lisp_Int
);
2061 if (0 > symlink (XSTRING (filename
)->data
, XSTRING (linkname
)->data
))
2063 /* If we didn't complain already, silently delete existing file. */
2064 if (errno
== EEXIST
)
2066 unlink (XSTRING (linkname
)->data
);
2067 if (0 <= symlink (XSTRING (filename
)->data
, XSTRING (linkname
)->data
))
2074 report_file_error ("Making symbolic link", Flist (2, args
));
2076 report_file_error ("Making symbolic link", Flist (2, &filename
));
2082 #endif /* S_IFLNK */
2086 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2087 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2088 "Define the job-wide logical name NAME to have the value STRING.\n\
2089 If STRING is nil or a null string, the logical name NAME is deleted.")
2091 Lisp_Object varname
;
2094 CHECK_STRING (varname
, 0);
2096 delete_logical_name (XSTRING (varname
)->data
);
2099 CHECK_STRING (string
, 1);
2101 if (XSTRING (string
)->size
== 0)
2102 delete_logical_name (XSTRING (varname
)->data
);
2104 define_logical_name (XSTRING (varname
)->data
, XSTRING (string
)->data
);
2113 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2114 "Open a network connection to PATH using LOGIN as the login string.")
2116 Lisp_Object path
, login
;
2120 CHECK_STRING (path
, 0);
2121 CHECK_STRING (login
, 0);
2123 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2125 if (netresult
== -1)
2130 #endif /* HPUX_NET */
2132 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2134 "Return t if file FILENAME specifies an absolute path name.\n\
2135 On Unix, this is a name starting with a `/' or a `~'.")
2137 Lisp_Object filename
;
2141 CHECK_STRING (filename
, 0);
2142 ptr
= XSTRING (filename
)->data
;
2143 if (*ptr
== '/' || *ptr
== '~'
2145 /* ??? This criterion is probably wrong for '<'. */
2146 || index (ptr
, ':') || index (ptr
, '<')
2147 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2151 || (*ptr
!= 0 && ptr
[1] == ':' && (ptr
[2] == '/' || ptr
[2] == '\\'))
2159 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2160 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
2161 See also `file-readable-p' and `file-attributes'.")
2163 Lisp_Object filename
;
2165 Lisp_Object abspath
;
2166 Lisp_Object handler
;
2168 CHECK_STRING (filename
, 0);
2169 abspath
= Fexpand_file_name (filename
, Qnil
);
2171 /* If the file name has special constructs in it,
2172 call the corresponding file handler. */
2173 handler
= Ffind_file_name_handler (abspath
, Qfile_exists_p
);
2174 if (!NILP (handler
))
2175 return call2 (handler
, Qfile_exists_p
, abspath
);
2177 return (access (XSTRING (abspath
)->data
, 0) >= 0) ? Qt
: Qnil
;
2180 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2181 "Return t if FILENAME can be executed by you.\n\
2182 For a directory, this means you can access files in that directory.")
2184 Lisp_Object filename
;
2187 Lisp_Object abspath
;
2188 Lisp_Object handler
;
2190 CHECK_STRING (filename
, 0);
2191 abspath
= Fexpand_file_name (filename
, Qnil
);
2193 /* If the file name has special constructs in it,
2194 call the corresponding file handler. */
2195 handler
= Ffind_file_name_handler (abspath
, Qfile_executable_p
);
2196 if (!NILP (handler
))
2197 return call2 (handler
, Qfile_executable_p
, abspath
);
2199 return (access (XSTRING (abspath
)->data
, 1) >= 0) ? Qt
: Qnil
;
2202 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2203 "Return t if file FILENAME exists and you can read it.\n\
2204 See also `file-exists-p' and `file-attributes'.")
2206 Lisp_Object filename
;
2208 Lisp_Object abspath
;
2209 Lisp_Object handler
;
2211 CHECK_STRING (filename
, 0);
2212 abspath
= Fexpand_file_name (filename
, Qnil
);
2214 /* If the file name has special constructs in it,
2215 call the corresponding file handler. */
2216 handler
= Ffind_file_name_handler (abspath
, Qfile_readable_p
);
2217 if (!NILP (handler
))
2218 return call2 (handler
, Qfile_readable_p
, abspath
);
2220 return (access (XSTRING (abspath
)->data
, 4) >= 0) ? Qt
: Qnil
;
2223 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
2224 "Return non-nil if file FILENAME is the name of a symbolic link.\n\
2225 The value is the name of the file to which it is linked.\n\
2226 Otherwise returns nil.")
2228 Lisp_Object filename
;
2235 Lisp_Object handler
;
2237 CHECK_STRING (filename
, 0);
2238 filename
= Fexpand_file_name (filename
, Qnil
);
2240 /* If the file name has special constructs in it,
2241 call the corresponding file handler. */
2242 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
2243 if (!NILP (handler
))
2244 return call2 (handler
, Qfile_symlink_p
, filename
);
2249 buf
= (char *) xmalloc (bufsize
);
2250 bzero (buf
, bufsize
);
2251 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
2252 if (valsize
< bufsize
) break;
2253 /* Buffer was not long enough */
2262 val
= make_string (buf
, valsize
);
2265 #else /* not S_IFLNK */
2267 #endif /* not S_IFLNK */
2270 #ifdef SOLARIS_BROKEN_ACCESS
2271 /* In Solaris 2.1, the readonly-ness of the filesystem is not
2272 considered by the access system call. This is Sun's bug, but we
2273 still have to make Emacs work. */
2275 #include <sys/statvfs.h>
2281 struct statvfs statvfsb
;
2283 if (statvfs(path
, &statvfsb
))
2284 return 1; /* error from statvfs, be conservative and say not wrtable */
2286 /* Otherwise, fsys is ro if bit is set. */
2287 return statvfsb
.f_flag
& ST_RDONLY
;
2290 /* But on every other os, access has already done the right thing. */
2291 #define ro_fsys(path) 0
2294 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2296 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
2297 "Return t if file FILENAME can be written or created by you.")
2299 Lisp_Object filename
;
2301 Lisp_Object abspath
, dir
;
2302 Lisp_Object handler
;
2304 CHECK_STRING (filename
, 0);
2305 abspath
= Fexpand_file_name (filename
, Qnil
);
2307 /* If the file name has special constructs in it,
2308 call the corresponding file handler. */
2309 handler
= Ffind_file_name_handler (abspath
, Qfile_writable_p
);
2310 if (!NILP (handler
))
2311 return call2 (handler
, Qfile_writable_p
, abspath
);
2313 if (access (XSTRING (abspath
)->data
, 0) >= 0)
2314 return ((access (XSTRING (abspath
)->data
, 2) >= 0
2315 && ! ro_fsys ((char *) XSTRING (abspath
)->data
))
2317 dir
= Ffile_name_directory (abspath
);
2320 dir
= Fdirectory_file_name (dir
);
2324 dir
= Fdirectory_file_name (dir
);
2326 return ((access (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "", 2) >= 0
2327 && ! ro_fsys ((char *) XSTRING (dir
)->data
))
2331 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
2332 "Return t if file FILENAME is the name of a directory as a file.\n\
2333 A directory name spec may be given instead; then the value is t\n\
2334 if the directory so specified exists and really is a directory.")
2336 Lisp_Object filename
;
2338 register Lisp_Object abspath
;
2340 Lisp_Object handler
;
2342 abspath
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2344 /* If the file name has special constructs in it,
2345 call the corresponding file handler. */
2346 handler
= Ffind_file_name_handler (abspath
, Qfile_directory_p
);
2347 if (!NILP (handler
))
2348 return call2 (handler
, Qfile_directory_p
, abspath
);
2350 if (stat (XSTRING (abspath
)->data
, &st
) < 0)
2352 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
2355 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
2356 "Return t if file FILENAME is the name of a directory as a file,\n\
2357 and files in that directory can be opened by you. In order to use a\n\
2358 directory as a buffer's current directory, this predicate must return true.\n\
2359 A directory name spec may be given instead; then the value is t\n\
2360 if the directory so specified exists and really is a readable and\n\
2361 searchable directory.")
2363 Lisp_Object filename
;
2365 Lisp_Object handler
;
2367 /* If the file name has special constructs in it,
2368 call the corresponding file handler. */
2369 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
2370 if (!NILP (handler
))
2371 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
2373 if (NILP (Ffile_directory_p (filename
))
2374 || NILP (Ffile_executable_p (filename
)))
2380 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
2381 "Return mode bits of FILE, as an integer.")
2383 Lisp_Object filename
;
2385 Lisp_Object abspath
;
2387 Lisp_Object handler
;
2389 abspath
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2391 /* If the file name has special constructs in it,
2392 call the corresponding file handler. */
2393 handler
= Ffind_file_name_handler (abspath
, Qfile_modes
);
2394 if (!NILP (handler
))
2395 return call2 (handler
, Qfile_modes
, abspath
);
2397 if (stat (XSTRING (abspath
)->data
, &st
) < 0)
2403 if (S_ISREG (st
.st_mode
)
2404 && (len
= XSTRING (abspath
)->size
) >= 5
2405 && (stricmp ((suffix
= XSTRING (abspath
)->data
+ len
-4), ".com") == 0
2406 || stricmp (suffix
, ".exe") == 0
2407 || stricmp (suffix
, ".bat") == 0))
2408 st
.st_mode
|= S_IEXEC
;
2412 return make_number (st
.st_mode
& 07777);
2415 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
2416 "Set mode bits of FILE to MODE (an integer).\n\
2417 Only the 12 low bits of MODE are used.")
2419 Lisp_Object filename
, mode
;
2421 Lisp_Object abspath
;
2422 Lisp_Object handler
;
2424 abspath
= Fexpand_file_name (filename
, current_buffer
->directory
);
2425 CHECK_NUMBER (mode
, 1);
2427 /* If the file name has special constructs in it,
2428 call the corresponding file handler. */
2429 handler
= Ffind_file_name_handler (abspath
, Qset_file_modes
);
2430 if (!NILP (handler
))
2431 return call3 (handler
, Qset_file_modes
, abspath
, mode
);
2434 if (chmod (XSTRING (abspath
)->data
, XINT (mode
)) < 0)
2435 report_file_error ("Doing chmod", Fcons (abspath
, Qnil
));
2437 if (!egetenv ("USE_DOMAIN_ACLS"))
2440 struct timeval tvp
[2];
2442 /* chmod on apollo also change the file's modtime; need to save the
2443 modtime and then restore it. */
2444 if (stat (XSTRING (abspath
)->data
, &st
) < 0)
2446 report_file_error ("Doing chmod", Fcons (abspath
, Qnil
));
2450 if (chmod (XSTRING (abspath
)->data
, XINT (mode
)) < 0)
2451 report_file_error ("Doing chmod", Fcons (abspath
, Qnil
));
2453 /* reset the old accessed and modified times. */
2454 tvp
[0].tv_sec
= st
.st_atime
+ 1; /* +1 due to an Apollo roundoff bug */
2456 tvp
[1].tv_sec
= st
.st_mtime
+ 1; /* +1 due to an Apollo roundoff bug */
2459 if (utimes (XSTRING (abspath
)->data
, tvp
) < 0)
2460 report_file_error ("Doing utimes", Fcons (abspath
, Qnil
));
2467 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
2468 "Set the file permission bits for newly created files.\n\
2469 The argument MODE should be an integer; only the low 9 bits are used.\n\
2470 This setting is inherited by subprocesses.")
2474 CHECK_NUMBER (mode
, 0);
2476 umask ((~ XINT (mode
)) & 0777);
2481 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
2482 "Return the default file protection for created files.\n\
2483 The value is an integer.")
2489 realmask
= umask (0);
2492 XSET (value
, Lisp_Int
, (~ realmask
) & 0777);
2498 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
2499 "Tell Unix to finish all pending disk updates.")
2508 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
2509 "Return t if file FILE1 is newer than file FILE2.\n\
2510 If FILE1 does not exist, the answer is nil;\n\
2511 otherwise, if FILE2 does not exist, the answer is t.")
2513 Lisp_Object file1
, file2
;
2515 Lisp_Object abspath1
, abspath2
;
2518 Lisp_Object handler
;
2519 struct gcpro gcpro1
, gcpro2
;
2521 CHECK_STRING (file1
, 0);
2522 CHECK_STRING (file2
, 0);
2525 GCPRO2 (abspath1
, file2
);
2526 abspath1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
2527 abspath2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
2530 /* If the file name has special constructs in it,
2531 call the corresponding file handler. */
2532 handler
= Ffind_file_name_handler (abspath1
, Qfile_newer_than_file_p
);
2534 handler
= Ffind_file_name_handler (abspath2
, Qfile_newer_than_file_p
);
2535 if (!NILP (handler
))
2536 return call3 (handler
, Qfile_newer_than_file_p
, abspath1
, abspath2
);
2538 if (stat (XSTRING (abspath1
)->data
, &st
) < 0)
2541 mtime1
= st
.st_mtime
;
2543 if (stat (XSTRING (abspath2
)->data
, &st
) < 0)
2546 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
2550 Lisp_Object Qfind_buffer_file_type
;
2553 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
2555 "Insert contents of file FILENAME after point.\n\
2556 Returns list of absolute file name and length of data inserted.\n\
2557 If second argument VISIT is non-nil, the buffer's visited filename\n\
2558 and last save file modtime are set, and it is marked unmodified.\n\
2559 If visiting and the file does not exist, visiting is completed\n\
2560 before the error is signaled.\n\n\
2561 The optional third and fourth arguments BEG and END\n\
2562 specify what portion of the file to insert.\n\
2563 If VISIT is non-nil, BEG and END must be nil.\n\
2564 If optional fifth argument REPLACE is non-nil,\n\
2565 it means replace the current buffer contents (in the accessible portion)\n\
2566 with the file contents. This is better than simply deleting and inserting\n\
2567 the whole thing because (1) it preserves some marker positions\n\
2568 and (2) it puts less data in the undo list.")
2569 (filename
, visit
, beg
, end
, replace
)
2570 Lisp_Object filename
, visit
, beg
, end
, replace
;
2574 register int inserted
= 0;
2575 register int how_much
;
2576 int count
= specpdl_ptr
- specpdl
;
2577 struct gcpro gcpro1
, gcpro2
;
2578 Lisp_Object handler
, val
, insval
;
2585 GCPRO2 (filename
, p
);
2586 if (!NILP (current_buffer
->read_only
))
2587 Fbarf_if_buffer_read_only();
2589 CHECK_STRING (filename
, 0);
2590 filename
= Fexpand_file_name (filename
, Qnil
);
2592 /* If the file name has special constructs in it,
2593 call the corresponding file handler. */
2594 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
2595 if (!NILP (handler
))
2597 val
= call6 (handler
, Qinsert_file_contents
, filename
,
2598 visit
, beg
, end
, replace
);
2605 if (stat (XSTRING (filename
)->data
, &st
) < 0)
2607 if ((fd
= open (XSTRING (filename
)->data
, 0)) < 0
2608 || fstat (fd
, &st
) < 0)
2609 #endif /* not APOLLO */
2611 if (fd
>= 0) close (fd
);
2614 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
2621 /* This code will need to be changed in order to work on named
2622 pipes, and it's probably just not worth it. So we should at
2623 least signal an error. */
2624 if (!S_ISREG (st
.st_mode
))
2625 Fsignal (Qfile_error
,
2626 Fcons (build_string ("not a regular file"),
2627 Fcons (filename
, Qnil
)));
2631 if ((fd
= open (XSTRING (filename
)->data
, 0)) < 0)
2634 /* Replacement should preserve point as it preserves markers. */
2635 if (!NILP (replace
))
2636 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
2638 record_unwind_protect (close_file_unwind
, make_number (fd
));
2640 /* Supposedly happens on VMS. */
2642 error ("File size is negative");
2644 if (!NILP (beg
) || !NILP (end
))
2646 error ("Attempt to visit less than an entire file");
2649 CHECK_NUMBER (beg
, 0);
2654 CHECK_NUMBER (end
, 0);
2657 XSETINT (end
, st
.st_size
);
2658 if (XINT (end
) != st
.st_size
)
2659 error ("maximum buffer size exceeded");
2662 /* If requested, replace the accessible part of the buffer
2663 with the file contents. Avoid replacing text at the
2664 beginning or end of the buffer that matches the file contents;
2665 that preserves markers pointing to the unchanged parts. */
2667 /* On MSDOS, replace mode doesn't really work, except for binary files,
2668 and it's not worth supporting just for them. */
2669 if (!NILP (replace
))
2673 XFASTINT (end
) = st
.st_size
;
2674 del_range_1 (BEGV
, ZV
, 0);
2677 if (!NILP (replace
))
2679 unsigned char buffer
[1 << 14];
2680 int same_at_start
= BEGV
;
2681 int same_at_end
= ZV
;
2686 /* Count how many chars at the start of the file
2687 match the text at the beginning of the buffer. */
2692 nread
= read (fd
, buffer
, sizeof buffer
);
2694 error ("IO error reading %s: %s",
2695 XSTRING (filename
)->data
, strerror (errno
));
2696 else if (nread
== 0)
2699 while (bufpos
< nread
&& same_at_start
< ZV
2700 && FETCH_CHAR (same_at_start
) == buffer
[bufpos
])
2701 same_at_start
++, bufpos
++;
2702 /* If we found a discrepancy, stop the scan.
2703 Otherwise loop around and scan the next bufferfull. */
2704 if (bufpos
!= nread
)
2708 /* If the file matches the buffer completely,
2709 there's no need to replace anything. */
2710 if (same_at_start
- BEGV
== st
.st_size
)
2714 /* Truncate the buffer to the size of the file. */
2715 del_range_1 (same_at_start
, same_at_end
, 0);
2720 /* Count how many chars at the end of the file
2721 match the text at the end of the buffer. */
2724 int total_read
, nread
, bufpos
, curpos
, trial
;
2726 /* At what file position are we now scanning? */
2727 curpos
= st
.st_size
- (ZV
- same_at_end
);
2728 /* If the entire file matches the buffer tail, stop the scan. */
2731 /* How much can we scan in the next step? */
2732 trial
= min (curpos
, sizeof buffer
);
2733 if (lseek (fd
, curpos
- trial
, 0) < 0)
2734 report_file_error ("Setting file position",
2735 Fcons (filename
, Qnil
));
2738 while (total_read
< trial
)
2740 nread
= read (fd
, buffer
+ total_read
, trial
- total_read
);
2742 error ("IO error reading %s: %s",
2743 XSTRING (filename
)->data
, strerror (errno
));
2744 total_read
+= nread
;
2746 /* Scan this bufferfull from the end, comparing with
2747 the Emacs buffer. */
2748 bufpos
= total_read
;
2749 /* Compare with same_at_start to avoid counting some buffer text
2750 as matching both at the file's beginning and at the end. */
2751 while (bufpos
> 0 && same_at_end
> same_at_start
2752 && FETCH_CHAR (same_at_end
- 1) == buffer
[bufpos
- 1])
2753 same_at_end
--, bufpos
--;
2754 /* If we found a discrepancy, stop the scan.
2755 Otherwise loop around and scan the preceding bufferfull. */
2761 /* Don't try to reuse the same piece of text twice. */
2762 overlap
= same_at_start
- BEGV
- (same_at_end
+ st
.st_size
- ZV
);
2764 same_at_end
+= overlap
;
2766 /* Arrange to read only the nonmatching middle part of the file. */
2767 XFASTINT (beg
) = same_at_start
- BEGV
;
2768 XFASTINT (end
) = st
.st_size
- (ZV
- same_at_end
);
2770 del_range_1 (same_at_start
, same_at_end
, 0);
2771 /* Insert from the file at the proper position. */
2772 SET_PT (same_at_start
);
2776 total
= XINT (end
) - XINT (beg
);
2779 register Lisp_Object temp
;
2781 /* Make sure point-max won't overflow after this insertion. */
2782 XSET (temp
, Lisp_Int
, total
);
2783 if (total
!= XINT (temp
))
2784 error ("maximum buffer size exceeded");
2787 if (NILP (visit
) && total
> 0)
2788 prepare_to_modify_buffer (point
, point
);
2791 if (GAP_SIZE
< total
)
2792 make_gap (total
- GAP_SIZE
);
2794 if (XINT (beg
) != 0 || !NILP (replace
))
2796 if (lseek (fd
, XINT (beg
), 0) < 0)
2797 report_file_error ("Setting file position", Fcons (filename
, Qnil
));
2801 while (inserted
< total
)
2803 int try = min (total
- inserted
, 64 << 10);
2806 /* Allow quitting out of the actual I/O. */
2809 this = read (fd
, &FETCH_CHAR (point
+ inserted
- 1) + 1, try);
2826 /* Demacs 1.1.1 91/10/16 HIRANO Satoshi, MW July 1993 */
2827 /* Determine file type from name and remove LFs from CR-LFs if the file
2828 is deemed to be a text file. */
2830 struct gcpro gcpro1
;
2834 current_buffer
->buffer_file_type
2835 = call1 (Qfind_buffer_file_type
, filename
);
2837 if (NILP (current_buffer
->buffer_file_type
))
2840 = inserted
- crlf_to_lf (inserted
, &FETCH_CHAR (point
- 1) + 1);
2843 GPT
-= reduced_size
;
2844 GAP_SIZE
+= reduced_size
;
2845 inserted
-= reduced_size
;
2852 record_insert (point
, inserted
);
2854 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
2855 offset_intervals (current_buffer
, point
, inserted
);
2861 /* Discard the unwind protect for closing the file. */
2865 error ("IO error reading %s: %s",
2866 XSTRING (filename
)->data
, strerror (errno
));
2873 if (!EQ (current_buffer
->undo_list
, Qt
))
2874 current_buffer
->undo_list
= Qnil
;
2876 stat (XSTRING (filename
)->data
, &st
);
2881 current_buffer
->modtime
= st
.st_mtime
;
2882 current_buffer
->filename
= filename
;
2885 current_buffer
->save_modified
= MODIFF
;
2886 current_buffer
->auto_save_modified
= MODIFF
;
2887 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
2888 #ifdef CLASH_DETECTION
2891 if (!NILP (current_buffer
->filename
))
2892 unlock_file (current_buffer
->filename
);
2893 unlock_file (filename
);
2895 #endif /* CLASH_DETECTION */
2896 /* If visiting nonexistent file, return nil. */
2897 if (current_buffer
->modtime
== -1)
2898 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
2901 if (inserted
> 0 && NILP (visit
) && total
> 0)
2902 signal_after_change (point
, 0, inserted
);
2906 p
= Vafter_insert_file_functions
;
2909 insval
= call1 (Fcar (p
), make_number (inserted
));
2912 CHECK_NUMBER (insval
, 0);
2913 inserted
= XFASTINT (insval
);
2921 val
= Fcons (filename
,
2922 Fcons (make_number (inserted
),
2925 RETURN_UNGCPRO (unbind_to (count
, val
));
2928 static Lisp_Object
build_annotations ();
2930 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 5,
2931 "r\nFWrite region to file: ",
2932 "Write current region into specified file.\n\
2933 When called from a program, takes three arguments:\n\
2934 START, END and FILENAME. START and END are buffer positions.\n\
2935 Optional fourth argument APPEND if non-nil means\n\
2936 append to existing file contents (if any).\n\
2937 Optional fifth argument VISIT if t means\n\
2938 set the last-save-file-modtime of buffer to this file's modtime\n\
2939 and mark buffer not modified.\n\
2940 If VISIT is a string, it is a second file name;\n\
2941 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
2942 VISIT is also the file name to lock and unlock for clash detection.\n\
2943 If VISIT is neither t nor nil nor a string,\n\
2944 that means do not print the \"Wrote file\" message.\n\
2945 Kludgy feature: if START is a string, then that string is written\n\
2946 to the file, instead of any buffer contents, and END is ignored.")
2947 (start
, end
, filename
, append
, visit
)
2948 Lisp_Object start
, end
, filename
, append
, visit
;
2956 int count
= specpdl_ptr
- specpdl
;
2958 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
2960 Lisp_Object handler
;
2961 Lisp_Object visit_file
;
2962 Lisp_Object annotations
;
2963 int visiting
, quietly
;
2964 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2966 int buffer_file_type
2967 = NILP (current_buffer
->buffer_file_type
) ? O_TEXT
: O_BINARY
;
2970 if (!NILP (start
) && !STRINGP (start
))
2971 validate_region (&start
, &end
);
2973 filename
= Fexpand_file_name (filename
, Qnil
);
2974 if (STRINGP (visit
))
2975 visit_file
= Fexpand_file_name (visit
, Qnil
);
2977 visit_file
= filename
;
2979 visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
2980 quietly
= !NILP (visit
);
2984 GCPRO4 (start
, filename
, annotations
, visit_file
);
2986 /* If the file name has special constructs in it,
2987 call the corresponding file handler. */
2988 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
2989 /* If FILENAME has no handler, see if VISIT has one. */
2990 if (NILP (handler
) && XTYPE (visit
) == Lisp_String
)
2991 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
2993 if (!NILP (handler
))
2996 val
= call6 (handler
, Qwrite_region
, start
, end
,
2997 filename
, append
, visit
);
3001 current_buffer
->save_modified
= MODIFF
;
3002 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3003 current_buffer
->filename
= visit_file
;
3009 /* Special kludge to simplify auto-saving. */
3012 XFASTINT (start
) = BEG
;
3016 annotations
= build_annotations (start
, end
);
3018 #ifdef CLASH_DETECTION
3020 lock_file (visit_file
);
3021 #endif /* CLASH_DETECTION */
3023 fn
= XSTRING (filename
)->data
;
3027 desc
= open (fn
, O_WRONLY
| buffer_file_type
);
3029 desc
= open (fn
, O_WRONLY
);
3034 if (auto_saving
) /* Overwrite any previous version of autosave file */
3036 vms_truncate (fn
); /* if fn exists, truncate to zero length */
3037 desc
= open (fn
, O_RDWR
);
3039 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
3040 ? XSTRING (current_buffer
->filename
)->data
: 0,
3043 else /* Write to temporary name and rename if no errors */
3045 Lisp_Object temp_name
;
3046 temp_name
= Ffile_name_directory (filename
);
3048 if (!NILP (temp_name
))
3050 temp_name
= Fmake_temp_name (concat2 (temp_name
,
3051 build_string ("$$SAVE$$")));
3052 fname
= XSTRING (filename
)->data
;
3053 fn
= XSTRING (temp_name
)->data
;
3054 desc
= creat_copy_attrs (fname
, fn
);
3057 /* If we can't open the temporary file, try creating a new
3058 version of the original file. VMS "creat" creates a
3059 new version rather than truncating an existing file. */
3062 desc
= creat (fn
, 0666);
3063 #if 0 /* This can clobber an existing file and fail to replace it,
3064 if the user runs out of space. */
3067 /* We can't make a new version;
3068 try to truncate and rewrite existing version if any. */
3070 desc
= open (fn
, O_RDWR
);
3076 desc
= creat (fn
, 0666);
3081 O_WRONLY
| O_TRUNC
| O_CREAT
| buffer_file_type
,
3082 S_IREAD
| S_IWRITE
);
3083 #else /* not MSDOS */
3084 desc
= creat (fn
, auto_saving
? auto_save_mode_bits
: 0666);
3085 #endif /* not MSDOS */
3086 #endif /* not VMS */
3092 #ifdef CLASH_DETECTION
3094 if (!auto_saving
) unlock_file (visit_file
);
3096 #endif /* CLASH_DETECTION */
3097 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
3100 record_unwind_protect (close_file_unwind
, make_number (desc
));
3103 if (lseek (desc
, 0, 2) < 0)
3105 #ifdef CLASH_DETECTION
3106 if (!auto_saving
) unlock_file (visit_file
);
3107 #endif /* CLASH_DETECTION */
3108 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
3113 * Kludge Warning: The VMS C RTL likes to insert carriage returns
3114 * if we do writes that don't end with a carriage return. Furthermore
3115 * it cannot handle writes of more then 16K. The modified
3116 * version of "sys_write" in SYSDEP.C (see comment there) copes with
3117 * this EXCEPT for the last record (iff it doesn't end with a carriage
3118 * return). This implies that if your buffer doesn't end with a carriage
3119 * return, you get one free... tough. However it also means that if
3120 * we make two calls to sys_write (a la the following code) you can
3121 * get one at the gap as well. The easiest way to fix this (honest)
3122 * is to move the gap to the next newline (or the end of the buffer).
3127 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
3128 move_gap (find_next_newline (GPT
, 1));
3134 if (STRINGP (start
))
3136 failure
= 0 > a_write (desc
, XSTRING (start
)->data
,
3137 XSTRING (start
)->size
, 0, &annotations
);
3140 else if (XINT (start
) != XINT (end
))
3143 if (XINT (start
) < GPT
)
3145 register int end1
= XINT (end
);
3147 failure
= 0 > a_write (desc
, &FETCH_CHAR (tem
),
3148 min (GPT
, end1
) - tem
, tem
, &annotations
);
3149 nwritten
+= min (GPT
, end1
) - tem
;
3153 if (XINT (end
) > GPT
&& !failure
)
3156 tem
= max (tem
, GPT
);
3157 failure
= 0 > a_write (desc
, &FETCH_CHAR (tem
), XINT (end
) - tem
,
3159 nwritten
+= XINT (end
) - tem
;
3165 /* If file was empty, still need to write the annotations */
3166 failure
= 0 > a_write (desc
, "", 0, XINT (start
), &annotations
);
3174 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
3175 Disk full in NFS may be reported here. */
3176 /* mib says that closing the file will try to write as fast as NFS can do
3177 it, and that means the fsync here is not crucial for autosave files. */
3178 if (!auto_saving
&& fsync (desc
) < 0)
3179 failure
= 1, save_errno
= errno
;
3182 /* Spurious "file has changed on disk" warnings have been
3183 observed on Suns as well.
3184 It seems that `close' can change the modtime, under nfs.
3186 (This has supposedly been fixed in Sunos 4,
3187 but who knows about all the other machines with NFS?) */
3190 /* On VMS and APOLLO, must do the stat after the close
3191 since closing changes the modtime. */
3194 /* Recall that #if defined does not work on VMS. */
3201 /* NFS can report a write failure now. */
3202 if (close (desc
) < 0)
3203 failure
= 1, save_errno
= errno
;
3206 /* If we wrote to a temporary name and had no errors, rename to real name. */
3210 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
3218 /* Discard the unwind protect */
3219 specpdl_ptr
= specpdl
+ count
;
3221 #ifdef CLASH_DETECTION
3223 unlock_file (visit_file
);
3224 #endif /* CLASH_DETECTION */
3226 /* Do this before reporting IO error
3227 to avoid a "file has changed on disk" warning on
3228 next attempt to save. */
3230 current_buffer
->modtime
= st
.st_mtime
;
3233 error ("IO error writing %s: %s", fn
, strerror (save_errno
));
3237 current_buffer
->save_modified
= MODIFF
;
3238 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3239 current_buffer
->filename
= visit_file
;
3240 update_mode_lines
++;
3246 message ("Wrote %s", XSTRING (visit_file
)->data
);
3251 Lisp_Object
merge ();
3253 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
3254 "Return t if (car A) is numerically less than (car B).")
3258 return Flss (Fcar (a
), Fcar (b
));
3261 /* Build the complete list of annotations appropriate for writing out
3262 the text between START and END, by calling all the functions in
3263 write-region-annotate-functions and merging the lists they return. */
3266 build_annotations (start
, end
)
3267 Lisp_Object start
, end
;
3269 Lisp_Object annotations
;
3271 struct gcpro gcpro1
, gcpro2
;
3274 p
= Vwrite_region_annotate_functions
;
3275 GCPRO2 (annotations
, p
);
3278 res
= call2 (Fcar (p
), start
, end
);
3279 Flength (res
); /* Check basic validity of return value */
3280 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
3287 /* Write to descriptor DESC the LEN characters starting at ADDR,
3288 assuming they start at position POS in the buffer.
3289 Intersperse with them the annotations from *ANNOT
3290 (those which fall within the range of positions POS to POS + LEN),
3291 each at its appropriate position.
3293 Modify *ANNOT by discarding elements as we output them.
3294 The return value is negative in case of system call failure. */
3297 a_write (desc
, addr
, len
, pos
, annot
)
3299 register char *addr
;
3306 int lastpos
= pos
+ len
;
3308 while (NILP (*annot
) || CONSP (*annot
))
3310 tem
= Fcar_safe (Fcar (*annot
));
3311 if (INTEGERP (tem
) && XINT (tem
) >= pos
&& XFASTINT (tem
) <= lastpos
)
3312 nextpos
= XFASTINT (tem
);
3314 return e_write (desc
, addr
, lastpos
- pos
);
3317 if (0 > e_write (desc
, addr
, nextpos
- pos
))
3319 addr
+= nextpos
- pos
;
3322 tem
= Fcdr (Fcar (*annot
));
3325 if (0 > e_write (desc
, XSTRING (tem
)->data
, XSTRING (tem
)->size
))
3328 *annot
= Fcdr (*annot
);
3333 e_write (desc
, addr
, len
)
3335 register char *addr
;
3338 char buf
[16 * 1024];
3339 register char *p
, *end
;
3341 if (!EQ (current_buffer
->selective_display
, Qt
))
3342 return write (desc
, addr
, len
) - len
;
3346 end
= p
+ sizeof buf
;
3351 if (write (desc
, buf
, sizeof buf
) != sizeof buf
)
3360 if (write (desc
, buf
, p
- buf
) != p
- buf
)
3366 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
3367 Sverify_visited_file_modtime
, 1, 1, 0,
3368 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
3369 This means that the file has not been changed since it was visited or saved.")
3375 Lisp_Object handler
;
3377 CHECK_BUFFER (buf
, 0);
3380 if (XTYPE (b
->filename
) != Lisp_String
) return Qt
;
3381 if (b
->modtime
== 0) return Qt
;
3383 /* If the file name has special constructs in it,
3384 call the corresponding file handler. */
3385 handler
= Ffind_file_name_handler (b
->filename
,
3386 Qverify_visited_file_modtime
);
3387 if (!NILP (handler
))
3388 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
3390 if (stat (XSTRING (b
->filename
)->data
, &st
) < 0)
3392 /* If the file doesn't exist now and didn't exist before,
3393 we say that it isn't modified, provided the error is a tame one. */
3394 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
3399 if (st
.st_mtime
== b
->modtime
3400 /* If both are positive, accept them if they are off by one second. */
3401 || (st
.st_mtime
> 0 && b
->modtime
> 0
3402 && (st
.st_mtime
== b
->modtime
+ 1
3403 || st
.st_mtime
== b
->modtime
- 1)))
3408 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
3409 Sclear_visited_file_modtime
, 0, 0, 0,
3410 "Clear out records of last mod time of visited file.\n\
3411 Next attempt to save will certainly not complain of a discrepancy.")
3414 current_buffer
->modtime
= 0;
3418 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
3419 Svisited_file_modtime
, 0, 0, 0,
3420 "Return the current buffer's recorded visited file modification time.\n\
3421 The value is a list of the form (HIGH . LOW), like the time values\n\
3422 that `file-attributes' returns.")
3425 return long_to_cons (current_buffer
->modtime
);
3428 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
3429 Sset_visited_file_modtime
, 0, 1, 0,
3430 "Update buffer's recorded modification time from the visited file's time.\n\
3431 Useful if the buffer was not read from the file normally\n\
3432 or if the file itself has been changed for some known benign reason.\n\
3433 An argument specifies the modification time value to use\n\
3434 \(instead of that of the visited file), in the form of a list\n\
3435 \(HIGH . LOW) or (HIGH LOW).")
3437 Lisp_Object time_list
;
3439 if (!NILP (time_list
))
3440 current_buffer
->modtime
= cons_to_long (time_list
);
3443 register Lisp_Object filename
;
3445 Lisp_Object handler
;
3447 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
3449 /* If the file name has special constructs in it,
3450 call the corresponding file handler. */
3451 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
3452 if (!NILP (handler
))
3453 /* The handler can find the file name the same way we did. */
3454 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
3455 else if (stat (XSTRING (filename
)->data
, &st
) >= 0)
3456 current_buffer
->modtime
= st
.st_mtime
;
3465 unsigned char *name
= XSTRING (current_buffer
->name
)->data
;
3468 message ("Autosaving...error for %s", name
);
3469 Fsleep_for (make_number (1), Qnil
);
3470 message ("Autosaving...error!for %s", name
);
3471 Fsleep_for (make_number (1), Qnil
);
3472 message ("Autosaving...error for %s", name
);
3473 Fsleep_for (make_number (1), Qnil
);
3483 /* Get visited file's mode to become the auto save file's mode. */
3484 if (stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
3485 /* But make sure we can overwrite it later! */
3486 auto_save_mode_bits
= st
.st_mode
| 0600;
3488 auto_save_mode_bits
= 0666;
3491 Fwrite_region (Qnil
, Qnil
,
3492 current_buffer
->auto_save_file_name
,
3497 do_auto_save_unwind (desc
) /* used as unwind-protect function */
3500 close (XINT (desc
));
3504 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
3505 "Auto-save all buffers that need it.\n\
3506 This is all buffers that have auto-saving enabled\n\
3507 and are changed since last auto-saved.\n\
3508 Auto-saving writes the buffer into a file\n\
3509 so that your editing is not lost if the system crashes.\n\
3510 This file is not the file you visited; that changes only when you save.\n\
3511 Normally we run the normal hook `auto-save-hook' before saving.\n\n\
3512 Non-nil first argument means do not print any message if successful.\n\
3513 Non-nil second argument means save only current buffer.")
3514 (no_message
, current_only
)
3515 Lisp_Object no_message
, current_only
;
3517 struct buffer
*old
= current_buffer
, *b
;
3518 Lisp_Object tail
, buf
;
3520 char *omessage
= echo_area_glyphs
;
3521 int omessage_length
= echo_area_glyphs_length
;
3522 extern int minibuf_level
;
3523 int do_handled_files
;
3526 Lisp_Object lispstream
;
3527 int count
= specpdl_ptr
- specpdl
;
3530 /* Ordinarily don't quit within this function,
3531 but don't make it impossible to quit (in case we get hung in I/O). */
3535 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
3536 point to non-strings reached from Vbuffer_alist. */
3542 if (!NILP (Vrun_hooks
))
3543 call1 (Vrun_hooks
, intern ("auto-save-hook"));
3545 if (STRINGP (Vauto_save_list_file_name
))
3548 listdesc
= open (XSTRING (Vauto_save_list_file_name
)->data
,
3549 O_WRONLY
| O_TRUNC
| O_CREAT
| O_TEXT
,
3550 S_IREAD
| S_IWRITE
);
3551 #else /* not MSDOS */
3552 listdesc
= creat (XSTRING (Vauto_save_list_file_name
)->data
, 0666);
3553 #endif /* not MSDOS */
3558 /* Arrange to close that file whether or not we get an error. */
3560 record_unwind_protect (do_auto_save_unwind
, make_number (listdesc
));
3562 /* First, save all files which don't have handlers. If Emacs is
3563 crashing, the handlers may tweak what is causing Emacs to crash
3564 in the first place, and it would be a shame if Emacs failed to
3565 autosave perfectly ordinary files because it couldn't handle some
3567 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
3568 for (tail
= Vbuffer_alist
; XGCTYPE (tail
) == Lisp_Cons
;
3569 tail
= XCONS (tail
)->cdr
)
3571 buf
= XCONS (XCONS (tail
)->car
)->cdr
;
3574 /* Record all the buffers that have auto save mode
3575 in the special file that lists them. */
3576 if (XTYPE (b
->auto_save_file_name
) == Lisp_String
3577 && listdesc
>= 0 && do_handled_files
== 0)
3579 write (listdesc
, XSTRING (b
->auto_save_file_name
)->data
,
3580 XSTRING (b
->auto_save_file_name
)->size
);
3581 write (listdesc
, "\n", 1);
3584 if (!NILP (current_only
)
3585 && b
!= current_buffer
)
3588 /* Check for auto save enabled
3589 and file changed since last auto save
3590 and file changed since last real save. */
3591 if (XTYPE (b
->auto_save_file_name
) == Lisp_String
3592 && b
->save_modified
< BUF_MODIFF (b
)
3593 && b
->auto_save_modified
< BUF_MODIFF (b
)
3594 /* -1 means we've turned off autosaving for a while--see below. */
3595 && XINT (b
->save_length
) >= 0
3596 && (do_handled_files
3597 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
3600 EMACS_TIME before_time
, after_time
;
3602 EMACS_GET_TIME (before_time
);
3604 /* If we had a failure, don't try again for 20 minutes. */
3605 if (b
->auto_save_failure_time
>= 0
3606 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
3609 if ((XFASTINT (b
->save_length
) * 10
3610 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
3611 /* A short file is likely to change a large fraction;
3612 spare the user annoying messages. */
3613 && XFASTINT (b
->save_length
) > 5000
3614 /* These messages are frequent and annoying for `*mail*'. */
3615 && !EQ (b
->filename
, Qnil
)
3616 && NILP (no_message
))
3618 /* It has shrunk too much; turn off auto-saving here. */
3619 message ("Buffer %s has shrunk a lot; auto save turned off there",
3620 XSTRING (b
->name
)->data
);
3621 /* Turn off auto-saving until there's a real save,
3622 and prevent any more warnings. */
3623 XSET (b
->save_length
, Lisp_Int
, -1);
3624 Fsleep_for (make_number (1), Qnil
);
3627 set_buffer_internal (b
);
3628 if (!auto_saved
&& NILP (no_message
))
3629 message1 ("Auto-saving...");
3630 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
3632 b
->auto_save_modified
= BUF_MODIFF (b
);
3633 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3634 set_buffer_internal (old
);
3636 EMACS_GET_TIME (after_time
);
3638 /* If auto-save took more than 60 seconds,
3639 assume it was an NFS failure that got a timeout. */
3640 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
3641 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
3645 /* Prevent another auto save till enough input events come in. */
3646 record_auto_save ();
3648 if (auto_saved
&& NILP (no_message
))
3651 message2 (omessage
, omessage_length
);
3653 message1 ("Auto-saving...done");
3659 unbind_to (count
, Qnil
);
3663 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
3664 Sset_buffer_auto_saved
, 0, 0, 0,
3665 "Mark current buffer as auto-saved with its current text.\n\
3666 No auto-save file will be written until the buffer changes again.")
3669 current_buffer
->auto_save_modified
= MODIFF
;
3670 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3671 current_buffer
->auto_save_failure_time
= -1;
3675 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
3676 Sclear_buffer_auto_save_failure
, 0, 0, 0,
3677 "Clear any record of a recent auto-save failure in the current buffer.")
3680 current_buffer
->auto_save_failure_time
= -1;
3684 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
3686 "Return t if buffer has been auto-saved since last read in or saved.")
3689 return (current_buffer
->save_modified
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
3692 /* Reading and completing file names */
3693 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
3695 /* In the string VAL, change each $ to $$ and return the result. */
3698 double_dollars (val
)
3701 register unsigned char *old
, *new;
3705 osize
= XSTRING (val
)->size
;
3706 /* Quote "$" as "$$" to get it past substitute-in-file-name */
3707 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
3708 if (*old
++ == '$') count
++;
3711 old
= XSTRING (val
)->data
;
3712 val
= Fmake_string (make_number (osize
+ count
), make_number (0));
3713 new = XSTRING (val
)->data
;
3714 for (n
= osize
; n
> 0; n
--)
3727 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
3729 "Internal subroutine for read-file-name. Do not call this.")
3730 (string
, dir
, action
)
3731 Lisp_Object string
, dir
, action
;
3732 /* action is nil for complete, t for return list of completions,
3733 lambda for verify final value */
3735 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
3737 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3744 /* No need to protect ACTION--we only compare it with t and nil. */
3745 GCPRO4 (string
, realdir
, name
, specdir
);
3747 if (XSTRING (string
)->size
== 0)
3749 if (EQ (action
, Qlambda
))
3757 orig_string
= string
;
3758 string
= Fsubstitute_in_file_name (string
);
3759 changed
= NILP (Fstring_equal (string
, orig_string
));
3760 name
= Ffile_name_nondirectory (string
);
3761 val
= Ffile_name_directory (string
);
3763 realdir
= Fexpand_file_name (val
, realdir
);
3768 specdir
= Ffile_name_directory (string
);
3769 val
= Ffile_name_completion (name
, realdir
);
3771 if (XTYPE (val
) != Lisp_String
)
3778 if (!NILP (specdir
))
3779 val
= concat2 (specdir
, val
);
3781 return double_dollars (val
);
3784 #endif /* not VMS */
3788 if (EQ (action
, Qt
))
3789 return Ffile_name_all_completions (name
, realdir
);
3790 /* Only other case actually used is ACTION = lambda */
3792 /* Supposedly this helps commands such as `cd' that read directory names,
3793 but can someone explain how it helps them? -- RMS */
3794 if (XSTRING (name
)->size
== 0)
3797 return Ffile_exists_p (string
);
3800 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
3801 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
3802 Value is not expanded---you must call `expand-file-name' yourself.\n\
3803 Default name to DEFAULT if user enters a null string.\n\
3804 (If DEFAULT is omitted, the visited file name is used.)\n\
3805 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
3806 Non-nil and non-t means also require confirmation after completion.\n\
3807 Fifth arg INITIAL specifies text to start with.\n\
3808 DIR defaults to current buffer's directory default.")
3809 (prompt
, dir
, defalt
, mustmatch
, initial
)
3810 Lisp_Object prompt
, dir
, defalt
, mustmatch
, initial
;
3812 Lisp_Object val
, insdef
, insdef1
, tem
;
3813 struct gcpro gcpro1
, gcpro2
;
3814 register char *homedir
;
3818 dir
= current_buffer
->directory
;
3820 defalt
= current_buffer
->filename
;
3822 /* If dir starts with user's homedir, change that to ~. */
3823 homedir
= (char *) egetenv ("HOME");
3825 && XTYPE (dir
) == Lisp_String
3826 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
3827 && XSTRING (dir
)->data
[strlen (homedir
)] == '/')
3829 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
3830 XSTRING (dir
)->size
- strlen (homedir
) + 1);
3831 XSTRING (dir
)->data
[0] = '~';
3834 if (insert_default_directory
)
3837 if (!NILP (initial
))
3839 Lisp_Object args
[2], pos
;
3843 insdef
= Fconcat (2, args
);
3844 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
3845 insdef1
= Fcons (double_dollars (insdef
), pos
);
3848 insdef1
= double_dollars (insdef
);
3850 else if (!NILP (initial
))
3853 insdef1
= Fcons (double_dollars (insdef
), 0);
3856 insdef
= Qnil
, insdef1
= Qnil
;
3859 count
= specpdl_ptr
- specpdl
;
3860 specbind (intern ("completion-ignore-case"), Qt
);
3863 GCPRO2 (insdef
, defalt
);
3864 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
3865 dir
, mustmatch
, insdef1
,
3866 Qfile_name_history
);
3869 unbind_to (count
, Qnil
);
3874 error ("No file name specified");
3875 tem
= Fstring_equal (val
, insdef
);
3876 if (!NILP (tem
) && !NILP (defalt
))
3878 if (XSTRING (val
)->size
== 0 && NILP (insdef
))
3883 error ("No default file name");
3885 return Fsubstitute_in_file_name (val
);
3888 #if 0 /* Old version */
3889 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
3890 /* Don't confuse make-docfile by having two doc strings for this function.
3891 make-docfile does not pay attention to #if, for good reason! */
3893 (prompt
, dir
, defalt
, mustmatch
, initial
)
3894 Lisp_Object prompt
, dir
, defalt
, mustmatch
, initial
;
3896 Lisp_Object val
, insdef
, tem
;
3897 struct gcpro gcpro1
, gcpro2
;
3898 register char *homedir
;
3902 dir
= current_buffer
->directory
;
3904 defalt
= current_buffer
->filename
;
3906 /* If dir starts with user's homedir, change that to ~. */
3907 homedir
= (char *) egetenv ("HOME");
3909 && XTYPE (dir
) == Lisp_String
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 (!NILP (initial
))
3920 else if (insert_default_directory
)
3923 insdef
= build_string ("");
3926 count
= specpdl_ptr
- specpdl
;
3927 specbind (intern ("completion-ignore-case"), Qt
);
3930 GCPRO2 (insdef
, defalt
);
3931 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
3933 insert_default_directory
? insdef
: Qnil
,
3934 Qfile_name_history
);
3937 unbind_to (count
, Qnil
);
3942 error ("No file name specified");
3943 tem
= Fstring_equal (val
, insdef
);
3944 if (!NILP (tem
) && !NILP (defalt
))
3946 return Fsubstitute_in_file_name (val
);
3948 #endif /* Old version */
3952 Qexpand_file_name
= intern ("expand-file-name");
3953 Qdirectory_file_name
= intern ("directory-file-name");
3954 Qfile_name_directory
= intern ("file-name-directory");
3955 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
3956 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
3957 Qfile_name_as_directory
= intern ("file-name-as-directory");
3958 Qcopy_file
= intern ("copy-file");
3959 Qmake_directory_internal
= intern ("make-directory-internal");
3960 Qdelete_directory
= intern ("delete-directory");
3961 Qdelete_file
= intern ("delete-file");
3962 Qrename_file
= intern ("rename-file");
3963 Qadd_name_to_file
= intern ("add-name-to-file");
3964 Qmake_symbolic_link
= intern ("make-symbolic-link");
3965 Qfile_exists_p
= intern ("file-exists-p");
3966 Qfile_executable_p
= intern ("file-executable-p");
3967 Qfile_readable_p
= intern ("file-readable-p");
3968 Qfile_symlink_p
= intern ("file-symlink-p");
3969 Qfile_writable_p
= intern ("file-writable-p");
3970 Qfile_directory_p
= intern ("file-directory-p");
3971 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
3972 Qfile_modes
= intern ("file-modes");
3973 Qset_file_modes
= intern ("set-file-modes");
3974 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
3975 Qinsert_file_contents
= intern ("insert-file-contents");
3976 Qwrite_region
= intern ("write-region");
3977 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
3978 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
3980 staticpro (&Qexpand_file_name
);
3981 staticpro (&Qdirectory_file_name
);
3982 staticpro (&Qfile_name_directory
);
3983 staticpro (&Qfile_name_nondirectory
);
3984 staticpro (&Qunhandled_file_name_directory
);
3985 staticpro (&Qfile_name_as_directory
);
3986 staticpro (&Qcopy_file
);
3987 staticpro (&Qmake_directory
);
3988 staticpro (&Qdelete_directory
);
3989 staticpro (&Qdelete_file
);
3990 staticpro (&Qrename_file
);
3991 staticpro (&Qadd_name_to_file
);
3992 staticpro (&Qmake_symbolic_link
);
3993 staticpro (&Qfile_exists_p
);
3994 staticpro (&Qfile_executable_p
);
3995 staticpro (&Qfile_readable_p
);
3996 staticpro (&Qfile_symlink_p
);
3997 staticpro (&Qfile_writable_p
);
3998 staticpro (&Qfile_directory_p
);
3999 staticpro (&Qfile_accessible_directory_p
);
4000 staticpro (&Qfile_modes
);
4001 staticpro (&Qset_file_modes
);
4002 staticpro (&Qfile_newer_than_file_p
);
4003 staticpro (&Qinsert_file_contents
);
4004 staticpro (&Qwrite_region
);
4005 staticpro (&Qverify_visited_file_modtime
);
4007 Qfile_name_history
= intern ("file-name-history");
4008 Fset (Qfile_name_history
, Qnil
);
4009 staticpro (&Qfile_name_history
);
4011 Qfile_error
= intern ("file-error");
4012 staticpro (&Qfile_error
);
4013 Qfile_already_exists
= intern("file-already-exists");
4014 staticpro (&Qfile_already_exists
);
4017 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
4018 staticpro (&Qfind_buffer_file_type
);
4021 Qcar_less_than_car
= intern ("car-less-than-car");
4022 staticpro (&Qcar_less_than_car
);
4024 Fput (Qfile_error
, Qerror_conditions
,
4025 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
4026 Fput (Qfile_error
, Qerror_message
,
4027 build_string ("File error"));
4029 Fput (Qfile_already_exists
, Qerror_conditions
,
4030 Fcons (Qfile_already_exists
,
4031 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
4032 Fput (Qfile_already_exists
, Qerror_message
,
4033 build_string ("File already exists"));
4035 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
4036 "*Non-nil means when reading a filename start with default dir in minibuffer.");
4037 insert_default_directory
= 1;
4039 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
4040 "*Non-nil means write new files with record format `stmlf'.\n\
4041 nil means use format `var'. This variable is meaningful only on VMS.");
4042 vms_stmlf_recfm
= 0;
4044 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
4045 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
4046 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
4049 The first argument given to HANDLER is the name of the I/O primitive\n\
4050 to be handled; the remaining arguments are the arguments that were\n\
4051 passed to that primitive. For example, if you do\n\
4052 (file-exists-p FILENAME)\n\
4053 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
4054 (funcall HANDLER 'file-exists-p FILENAME)\n\
4055 The function `find-file-name-handler' checks this list for a handler\n\
4056 for its argument.");
4057 Vfile_name_handler_alist
= Qnil
;
4059 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
4060 "A list of functions to be called at the end of `insert-file-contents'.\n\
4061 Each is passed one argument, the number of bytes inserted. It should return\n\
4062 the new byte count, and leave point the same. If `insert-file-contents' is\n\
4063 intercepted by a handler from `file-name-handler-alist', that handler is\n\
4064 responsible for calling the after-insert-file-functions if appropriate.");
4065 Vafter_insert_file_functions
= Qnil
;
4067 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
4068 "A list of functions to be called at the start of `write-region'.\n\
4069 Each is passed two arguments, START and END as for `write-region'. It should\n\
4070 return a list of pairs (POSITION . STRING) of strings to be effectively\n\
4071 inserted at the specified positions of the file being written (1 means to\n\
4072 insert before the first byte written). The POSITIONs must be sorted into\n\
4073 increasing order. If there are several functions in the list, the several\n\
4074 lists are merged destructively.");
4075 Vwrite_region_annotate_functions
= Qnil
;
4077 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
4078 "A list of file name handlers that temporarily should not be used.\n\
4079 This applies only to the operation `inhibit-file-name-operation'.");
4080 Vinhibit_file_name_handlers
= Qnil
;
4082 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
4083 "The operation for which `inhibit-file-name-handlers' is applicable.");
4084 Vinhibit_file_name_operation
= Qnil
;
4086 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
4087 "File name in which we write a list of all auto save file names.");
4088 Vauto_save_list_file_name
= Qnil
;
4090 defsubr (&Sfind_file_name_handler
);
4091 defsubr (&Sfile_name_directory
);
4092 defsubr (&Sfile_name_nondirectory
);
4093 defsubr (&Sunhandled_file_name_directory
);
4094 defsubr (&Sfile_name_as_directory
);
4095 defsubr (&Sdirectory_file_name
);
4096 defsubr (&Smake_temp_name
);
4097 defsubr (&Sexpand_file_name
);
4098 defsubr (&Ssubstitute_in_file_name
);
4099 defsubr (&Scopy_file
);
4100 defsubr (&Smake_directory_internal
);
4101 defsubr (&Sdelete_directory
);
4102 defsubr (&Sdelete_file
);
4103 defsubr (&Srename_file
);
4104 defsubr (&Sadd_name_to_file
);
4106 defsubr (&Smake_symbolic_link
);
4107 #endif /* S_IFLNK */
4109 defsubr (&Sdefine_logical_name
);
4112 defsubr (&Ssysnetunam
);
4113 #endif /* HPUX_NET */
4114 defsubr (&Sfile_name_absolute_p
);
4115 defsubr (&Sfile_exists_p
);
4116 defsubr (&Sfile_executable_p
);
4117 defsubr (&Sfile_readable_p
);
4118 defsubr (&Sfile_writable_p
);
4119 defsubr (&Sfile_symlink_p
);
4120 defsubr (&Sfile_directory_p
);
4121 defsubr (&Sfile_accessible_directory_p
);
4122 defsubr (&Sfile_modes
);
4123 defsubr (&Sset_file_modes
);
4124 defsubr (&Sset_default_file_modes
);
4125 defsubr (&Sdefault_file_modes
);
4126 defsubr (&Sfile_newer_than_file_p
);
4127 defsubr (&Sinsert_file_contents
);
4128 defsubr (&Swrite_region
);
4129 defsubr (&Scar_less_than_car
);
4130 defsubr (&Sverify_visited_file_modtime
);
4131 defsubr (&Sclear_visited_file_modtime
);
4132 defsubr (&Svisited_file_modtime
);
4133 defsubr (&Sset_visited_file_modtime
);
4134 defsubr (&Sdo_auto_save
);
4135 defsubr (&Sset_buffer_auto_saved
);
4136 defsubr (&Sclear_buffer_auto_save_failure
);
4137 defsubr (&Srecent_auto_save_p
);
4139 defsubr (&Sread_file_name_internal
);
4140 defsubr (&Sread_file_name
);
4143 defsubr (&Sunix_sync
);