1 /* File IO for GNU Emacs.
2 Copyright (C) 1985, 1986, 1987, 1988, 1993, 1994 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
22 #include <sys/types.h>
29 #if !defined (S_ISLNK) && defined (S_IFLNK)
30 # define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
33 #if !defined (S_ISREG) && defined (S_IFREG)
34 # define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
45 #include <sys/param.h>
63 extern char *strerror ();
78 #include "intervals.h"
108 #define min(a, b) ((a) < (b) ? (a) : (b))
109 #define max(a, b) ((a) > (b) ? (a) : (b))
111 /* Nonzero during writing of auto-save files */
114 /* Set by auto_save_1 to mode of original file so Fwrite_region will create
115 a new file with the same mode as the original */
116 int auto_save_mode_bits
;
118 /* Alist of elements (REGEXP . HANDLER) for file names
119 whose I/O is done with a special handler. */
120 Lisp_Object Vfile_name_handler_alist
;
122 /* Functions to be called to process text properties in inserted file. */
123 Lisp_Object Vafter_insert_file_functions
;
125 /* Functions to be called to create text property annotations for file. */
126 Lisp_Object Vwrite_region_annotate_functions
;
128 /* During build_annotations, each time an annotation function is called,
129 this holds the annotations made by the previous functions. */
130 Lisp_Object Vwrite_region_annotations_so_far
;
132 /* File name in which we write a list of all our auto save files. */
133 Lisp_Object Vauto_save_list_file_name
;
135 /* Nonzero means, when reading a filename in the minibuffer,
136 start out by inserting the default directory into the minibuffer. */
137 int insert_default_directory
;
139 /* On VMS, nonzero means write new files with record format stmlf.
140 Zero means use var format. */
143 /* These variables describe handlers that have "already" had a chance
144 to handle the current operation.
146 Vinhibit_file_name_handlers is a list of file name handlers.
147 Vinhibit_file_name_operation is the operation being handled.
148 If we try to handle that operation, we ignore those handlers. */
150 static Lisp_Object Vinhibit_file_name_handlers
;
151 static Lisp_Object Vinhibit_file_name_operation
;
153 Lisp_Object Qfile_error
, Qfile_already_exists
;
155 Lisp_Object Qfile_name_history
;
157 Lisp_Object Qcar_less_than_car
;
159 report_file_error (string
, data
)
163 Lisp_Object errstring
;
165 errstring
= build_string (strerror (errno
));
167 /* System error messages are capitalized. Downcase the initial
168 unless it is followed by a slash. */
169 if (XSTRING (errstring
)->data
[1] != '/')
170 XSTRING (errstring
)->data
[0] = DOWNCASE (XSTRING (errstring
)->data
[0]);
173 Fsignal (Qfile_error
,
174 Fcons (build_string (string
), Fcons (errstring
, data
)));
177 close_file_unwind (fd
)
180 close (XFASTINT (fd
));
183 /* Restore point, having saved it as a marker. */
185 restore_point_unwind (location
)
186 Lisp_Object location
;
188 SET_PT (marker_position (location
));
189 Fset_marker (location
, Qnil
, Qnil
);
192 Lisp_Object Qexpand_file_name
;
193 Lisp_Object Qdirectory_file_name
;
194 Lisp_Object Qfile_name_directory
;
195 Lisp_Object Qfile_name_nondirectory
;
196 Lisp_Object Qunhandled_file_name_directory
;
197 Lisp_Object Qfile_name_as_directory
;
198 Lisp_Object Qcopy_file
;
199 Lisp_Object Qmake_directory_internal
;
200 Lisp_Object Qdelete_directory
;
201 Lisp_Object Qdelete_file
;
202 Lisp_Object Qrename_file
;
203 Lisp_Object Qadd_name_to_file
;
204 Lisp_Object Qmake_symbolic_link
;
205 Lisp_Object Qfile_exists_p
;
206 Lisp_Object Qfile_executable_p
;
207 Lisp_Object Qfile_readable_p
;
208 Lisp_Object Qfile_symlink_p
;
209 Lisp_Object Qfile_writable_p
;
210 Lisp_Object Qfile_directory_p
;
211 Lisp_Object Qfile_accessible_directory_p
;
212 Lisp_Object Qfile_modes
;
213 Lisp_Object Qset_file_modes
;
214 Lisp_Object Qfile_newer_than_file_p
;
215 Lisp_Object Qinsert_file_contents
;
216 Lisp_Object Qwrite_region
;
217 Lisp_Object Qverify_visited_file_modtime
;
218 Lisp_Object Qset_visited_file_modtime
;
220 DEFUN ("find-file-name-handler", Ffind_file_name_handler
, Sfind_file_name_handler
, 2, 2, 0,
221 "Return FILENAME's handler function for OPERATION, if it has one.\n\
222 Otherwise, return nil.\n\
223 A file name is handled if one of the regular expressions in\n\
224 `file-name-handler-alist' matches it.\n\n\
225 If OPERATION equals `inhibit-file-name-operation', then we ignore\n\
226 any handlers that are members of `inhibit-file-name-handlers',\n\
227 but we still do run any other handlers. This lets handlers\n\
228 use the standard functions without calling themselves recursively.")
229 (filename
, operation
)
230 Lisp_Object filename
, operation
;
232 /* This function must not munge the match data. */
233 Lisp_Object chain
, inhibited_handlers
;
235 CHECK_STRING (filename
, 0);
237 if (EQ (operation
, Vinhibit_file_name_operation
))
238 inhibited_handlers
= Vinhibit_file_name_handlers
;
240 inhibited_handlers
= Qnil
;
242 for (chain
= Vfile_name_handler_alist
; XTYPE (chain
) == Lisp_Cons
;
243 chain
= XCONS (chain
)->cdr
)
246 elt
= XCONS (chain
)->car
;
247 if (XTYPE (elt
) == Lisp_Cons
)
250 string
= XCONS (elt
)->car
;
251 if (XTYPE (string
) == Lisp_String
252 && fast_string_match (string
, filename
) >= 0)
254 Lisp_Object handler
, tem
;
256 handler
= XCONS (elt
)->cdr
;
257 tem
= Fmemq (handler
, inhibited_handlers
);
268 DEFUN ("file-name-directory", Ffile_name_directory
, Sfile_name_directory
,
270 "Return the directory component in file name NAME.\n\
271 Return nil if NAME does not include a directory.\n\
272 Otherwise return a directory spec.\n\
273 Given a Unix syntax file name, returns a string ending in slash;\n\
274 on VMS, perhaps instead a string ending in `:', `]' or `>'.")
278 register unsigned char *beg
;
279 register unsigned char *p
;
282 CHECK_STRING (file
, 0);
284 /* If the file name has special constructs in it,
285 call the corresponding file handler. */
286 handler
= Ffind_file_name_handler (file
, Qfile_name_directory
);
288 return call2 (handler
, Qfile_name_directory
, file
);
290 #ifdef FILE_SYSTEM_CASE
291 file
= FILE_SYSTEM_CASE (file
);
293 beg
= XSTRING (file
)->data
;
294 p
= beg
+ XSTRING (file
)->size
;
296 while (p
!= beg
&& p
[-1] != '/'
298 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
301 && p
[-1] != ':' && p
[-1] != '\\'
308 /* Expansion of "c:" to drive and default directory. */
309 if (p
== beg
+ 2 && beg
[1] == ':')
311 int drive
= (*beg
) - 'a';
312 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
313 unsigned char *res
= alloca (MAXPATHLEN
+ 5);
314 if (getdefdir (drive
+ 1, res
+ 2))
316 res
[0] = drive
+ 'a';
318 if (res
[strlen (res
) - 1] != '/')
321 p
= beg
+ strlen (beg
);
325 return make_string (beg
, p
- beg
);
328 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory
, Sfile_name_nondirectory
,
330 "Return file name NAME sans its directory.\n\
331 For example, in a Unix-syntax file name,\n\
332 this is everything after the last slash,\n\
333 or the entire name if it contains no slash.")
337 register unsigned char *beg
, *p
, *end
;
340 CHECK_STRING (file
, 0);
342 /* If the file name has special constructs in it,
343 call the corresponding file handler. */
344 handler
= Ffind_file_name_handler (file
, Qfile_name_nondirectory
);
346 return call2 (handler
, Qfile_name_nondirectory
, file
);
348 beg
= XSTRING (file
)->data
;
349 end
= p
= beg
+ XSTRING (file
)->size
;
351 while (p
!= beg
&& p
[-1] != '/'
353 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
356 && p
[-1] != ':' && p
[-1] != '\\'
360 return make_string (p
, end
- p
);
363 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory
, Sunhandled_file_name_directory
, 1, 1, 0,
364 "Return a directly usable directory name somehow associated with FILENAME.\n\
365 A `directly usable' directory name is one that may be used without the\n\
366 intervention of any file handler.\n\
367 If FILENAME is a directly usable file itself, return\n\
368 (file-name-directory FILENAME).\n\
369 The `call-process' and `start-process' functions use this function to\n\
370 get a current directory to run processes in.")
372 Lisp_Object filename
;
376 /* If the file name has special constructs in it,
377 call the corresponding file handler. */
378 handler
= Ffind_file_name_handler (filename
, Qunhandled_file_name_directory
);
380 return call2 (handler
, Qunhandled_file_name_directory
, filename
);
382 return Ffile_name_directory (filename
);
387 file_name_as_directory (out
, in
)
390 int size
= strlen (in
) - 1;
395 /* Is it already a directory string? */
396 if (in
[size
] == ':' || in
[size
] == ']' || in
[size
] == '>')
398 /* Is it a VMS directory file name? If so, hack VMS syntax. */
399 else if (! index (in
, '/')
400 && ((size
> 3 && ! strcmp (&in
[size
- 3], ".DIR"))
401 || (size
> 3 && ! strcmp (&in
[size
- 3], ".dir"))
402 || (size
> 5 && (! strncmp (&in
[size
- 5], ".DIR", 4)
403 || ! strncmp (&in
[size
- 5], ".dir", 4))
404 && (in
[size
- 1] == '.' || in
[size
- 1] == ';')
405 && in
[size
] == '1')))
407 register char *p
, *dot
;
411 dir:x.dir --> dir:[x]
412 dir:[x]y.dir --> dir:[x.y] */
414 while (p
!= in
&& *p
!= ':' && *p
!= '>' && *p
!= ']') p
--;
417 strncpy (out
, in
, p
- in
);
436 dot
= index (p
, '.');
439 /* blindly remove any extension */
440 size
= strlen (out
) + (dot
- p
);
441 strncat (out
, p
, dot
- p
);
452 /* For Unix syntax, Append a slash if necessary */
454 if (out
[size
] != ':' && out
[size
] != '/' && out
[size
] != '\\')
456 if (out
[size
] != '/')
463 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
464 Sfile_name_as_directory
, 1, 1, 0,
465 "Return a string representing file FILENAME interpreted as a directory.\n\
466 This operation exists because a directory is also a file, but its name as\n\
467 a directory is different from its name as a file.\n\
468 The result can be used as the value of `default-directory'\n\
469 or passed as second argument to `expand-file-name'.\n\
470 For a Unix-syntax file name, just appends a slash.\n\
471 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
478 CHECK_STRING (file
, 0);
482 /* If the file name has special constructs in it,
483 call the corresponding file handler. */
484 handler
= Ffind_file_name_handler (file
, Qfile_name_as_directory
);
486 return call2 (handler
, Qfile_name_as_directory
, file
);
488 buf
= (char *) alloca (XSTRING (file
)->size
+ 10);
489 return build_string (file_name_as_directory (buf
, XSTRING (file
)->data
));
493 * Convert from directory name to filename.
495 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
496 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
497 * On UNIX, it's simple: just make sure there is a terminating /
499 * Value is nonzero if the string output is different from the input.
502 directory_file_name (src
, dst
)
510 struct FAB fab
= cc$rms_fab
;
511 struct NAM nam
= cc$rms_nam
;
512 char esa
[NAM$C_MAXRSS
];
517 if (! index (src
, '/')
518 && (src
[slen
- 1] == ']'
519 || src
[slen
- 1] == ':'
520 || src
[slen
- 1] == '>'))
522 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
524 fab
.fab$b_fns
= slen
;
525 fab
.fab$l_nam
= &nam
;
526 fab
.fab$l_fop
= FAB$M_NAM
;
529 nam
.nam$b_ess
= sizeof esa
;
530 nam
.nam$b_nop
|= NAM$M_SYNCHK
;
532 /* We call SYS$PARSE to handle such things as [--] for us. */
533 if (SYS$
PARSE(&fab
, 0, 0) == RMS$_NORMAL
)
535 slen
= nam
.nam$b_esl
;
536 if (esa
[slen
- 1] == ';' && esa
[slen
- 2] == '.')
541 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
543 /* what about when we have logical_name:???? */
544 if (src
[slen
- 1] == ':')
545 { /* Xlate logical name and see what we get */
546 ptr
= strcpy (dst
, src
); /* upper case for getenv */
549 if ('a' <= *ptr
&& *ptr
<= 'z')
553 dst
[slen
- 1] = 0; /* remove colon */
554 if (!(src
= egetenv (dst
)))
556 /* should we jump to the beginning of this procedure?
557 Good points: allows us to use logical names that xlate
559 Bad points: can be a problem if we just translated to a device
561 For now, I'll punt and always expect VMS names, and hope for
564 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
565 { /* no recursion here! */
571 { /* not a directory spec */
576 bracket
= src
[slen
- 1];
578 /* If bracket is ']' or '>', bracket - 2 is the corresponding
580 ptr
= index (src
, bracket
- 2);
582 { /* no opening bracket */
586 if (!(rptr
= rindex (src
, '.')))
589 strncpy (dst
, src
, slen
);
593 dst
[slen
++] = bracket
;
598 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
599 then translate the device and recurse. */
600 if (dst
[slen
- 1] == ':'
601 && dst
[slen
- 2] != ':' /* skip decnet nodes */
602 && strcmp(src
+ slen
, "[000000]") == 0)
604 dst
[slen
- 1] = '\0';
605 if ((ptr
= egetenv (dst
))
606 && (rlen
= strlen (ptr
) - 1) > 0
607 && (ptr
[rlen
] == ']' || ptr
[rlen
] == '>')
608 && ptr
[rlen
- 1] == '.')
610 char * buf
= (char *) alloca (strlen (ptr
) + 1);
614 return directory_file_name (buf
, dst
);
619 strcat (dst
, "[000000]");
623 rlen
= strlen (rptr
) - 1;
624 strncat (dst
, rptr
, rlen
);
625 dst
[slen
+ rlen
] = '\0';
626 strcat (dst
, ".DIR.1");
630 /* Process as Unix format: just remove any final slash.
631 But leave "/" unchanged; do not change it to "". */
635 && (dst
[slen
- 1] == '/' || dst
[slen
- 1] == '/')
636 && dst
[slen
- 2] != ':'
638 && dst
[slen
- 1] == '/'
645 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
647 "Returns the file name of the directory named DIR.\n\
648 This is the name of the file that holds the data for the directory DIR.\n\
649 This operation exists because a directory is also a file, but its name as\n\
650 a directory is different from its name as a file.\n\
651 In Unix-syntax, this function just removes the final slash.\n\
652 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
653 it returns a file name such as \"[X]Y.DIR.1\".")
655 Lisp_Object directory
;
660 CHECK_STRING (directory
, 0);
662 if (NILP (directory
))
665 /* If the file name has special constructs in it,
666 call the corresponding file handler. */
667 handler
= Ffind_file_name_handler (directory
, Qdirectory_file_name
);
669 return call2 (handler
, Qdirectory_file_name
, directory
);
672 /* 20 extra chars is insufficient for VMS, since we might perform a
673 logical name translation. an equivalence string can be up to 255
674 chars long, so grab that much extra space... - sss */
675 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20 + 255);
677 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20);
679 directory_file_name (XSTRING (directory
)->data
, buf
);
680 return build_string (buf
);
683 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
684 "Generate temporary file name (string) starting with PREFIX (a string).\n\
685 The Emacs process number forms part of the result,\n\
686 so there is no danger of generating a name being used by another process.")
691 val
= concat2 (prefix
, build_string ("XXXXXX"));
692 mktemp (XSTRING (val
)->data
);
696 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
697 "Convert FILENAME to absolute, and canonicalize it.\n\
698 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
699 (does not start with slash); if DEFAULT is nil or missing,\n\
700 the current buffer's value of default-directory is used.\n\
701 Path components that are `.' are removed, and \n\
702 path components followed by `..' are removed, along with the `..' itself;\n\
703 note that these simplifications are done without checking the resulting\n\
704 paths in the file system.\n\
705 An initial `~/' expands to your home directory.\n\
706 An initial `~USER/' expands to USER's home directory.\n\
707 See also the function `substitute-in-file-name'.")
709 Lisp_Object name
, defalt
;
713 register unsigned char *newdir
, *p
, *o
;
715 unsigned char *target
;
718 unsigned char * colon
= 0;
719 unsigned char * close
= 0;
720 unsigned char * slash
= 0;
721 unsigned char * brack
= 0;
722 int lbrack
= 0, rbrack
= 0;
725 #ifdef MSDOS /* Demacs 1.1.2 91/10/20 Manabu Higashida */
728 unsigned char *tmp
, *defdir
;
732 CHECK_STRING (name
, 0);
734 /* If the file name has special constructs in it,
735 call the corresponding file handler. */
736 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
738 return call3 (handler
, Qexpand_file_name
, name
, defalt
);
740 /* Use the buffer's default-directory if DEFALT is omitted. */
742 defalt
= current_buffer
->directory
;
743 CHECK_STRING (defalt
, 1);
745 /* Make sure DEFALT is properly expanded.
746 It would be better to do this down below where we actually use
747 defalt. Unfortunately, calling Fexpand_file_name recursively
748 could invoke GC, and the strings might be relocated. This would
749 be annoying because we have pointers into strings lying around
750 that would need adjusting, and people would add new pointers to
751 the code and forget to adjust them, resulting in intermittent bugs.
752 Putting this call here avoids all that crud.
754 The EQ test avoids infinite recursion. */
755 if (! NILP (defalt
) && !EQ (defalt
, name
)
756 /* This saves time in a common case. */
757 && XSTRING (defalt
)->data
[0] != '/')
762 defalt
= Fexpand_file_name (defalt
, Qnil
);
767 /* Filenames on VMS are always upper case. */
768 name
= Fupcase (name
);
770 #ifdef FILE_SYSTEM_CASE
771 name
= FILE_SYSTEM_CASE (name
);
774 nm
= XSTRING (name
)->data
;
777 /* First map all backslashes to slashes. */
778 dostounix_filename (nm
= strcpy (alloca (strlen (nm
) + 1), nm
));
780 /* Now strip drive name. */
782 unsigned char *colon
= rindex (nm
, ':');
788 drive
= tolower (colon
[-1]) - 'a';
792 defdir
= alloca (MAXPATHLEN
+ 1);
793 relpath
= getdefdir (drive
+ 1, defdir
);
799 /* If nm is absolute, flush ...// and detect /./ and /../.
800 If no /./ or /../ we can return right away. */
808 /* If it turns out that the filename we want to return is just a
809 suffix of FILENAME, we don't need to go through and edit
810 things; we just need to construct a new string using data
811 starting at the middle of FILENAME. If we set lose to a
812 non-zero value, that means we've discovered that we can't do
819 /* Since we know the path is absolute, we can assume that each
820 element starts with a "/". */
822 /* "//" anywhere isn't necessarily hairy; we just start afresh
823 with the second slash. */
824 if (p
[0] == '/' && p
[1] == '/'
826 /* // at start of filename is meaningful on Apollo system */
832 /* "~" is hairy as the start of any path element. */
833 if (p
[0] == '/' && p
[1] == '~')
834 nm
= p
+ 1, lose
= 1;
836 /* "." and ".." are hairy. */
841 || (p
[2] == '.' && (p
[3] == '/'
848 /* if dev:[dir]/, move nm to / */
849 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
850 nm
= (brack
? brack
+ 1 : colon
+ 1);
859 /* VMS pre V4.4,convert '-'s in filenames. */
860 if (lbrack
== rbrack
)
862 if (dots
< 2) /* this is to allow negative version numbers */
867 if (lbrack
> rbrack
&&
868 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
869 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
875 /* count open brackets, reset close bracket pointer */
876 if (p
[0] == '[' || p
[0] == '<')
878 /* count close brackets, set close bracket pointer */
879 if (p
[0] == ']' || p
[0] == '>')
881 /* detect ][ or >< */
882 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
884 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
885 nm
= p
+ 1, lose
= 1;
886 if (p
[0] == ':' && (colon
|| slash
))
887 /* if dev1:[dir]dev2:, move nm to dev2: */
893 /* if /pathname/dev:, move nm to dev: */
896 /* if node::dev:, move colon following dev */
897 else if (colon
&& colon
[-1] == ':')
899 /* if dev1:dev2:, move nm to dev2: */
900 else if (colon
&& colon
[-1] != ':')
905 if (p
[0] == ':' && !colon
)
911 if (lbrack
== rbrack
)
914 else if (p
[0] == '.')
923 return build_string (sys_translate_unix (nm
));
926 if (nm
== XSTRING (name
)->data
)
928 return build_string (nm
);
933 /* Now determine directory to start with and put it in newdir */
937 if (nm
[0] == '~') /* prefix ~ */
943 || nm
[1] == 0) /* ~ by itself */
945 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
946 newdir
= (unsigned char *) "";
948 dostounix_filename (newdir
);
952 nm
++; /* Don't leave the slash in nm. */
955 else /* ~user/filename */
957 for (p
= nm
; *p
&& (*p
!= '/'
962 o
= (unsigned char *) alloca (p
- nm
+ 1);
963 bcopy ((char *) nm
, o
, p
- nm
);
966 pw
= (struct passwd
*) getpwnam (o
+ 1);
969 newdir
= (unsigned char *) pw
-> pw_dir
;
971 nm
= p
+ 1; /* skip the terminator */
977 /* If we don't find a user of that name, leave the name
978 unchanged; don't move nm forward to p. */
991 newdir
= XSTRING (defalt
)->data
;
995 if (newdir
== 0 && relpath
)
1000 /* Get rid of any slash at the end of newdir. */
1001 int length
= strlen (newdir
);
1002 /* Adding `length > 1 &&' makes ~ expand into / when homedir
1003 is the root dir. People disagree about whether that is right.
1004 Anyway, we can't take the risk of this change now. */
1006 if (newdir
[1] != ':' && length
> 1)
1008 if (newdir
[length
- 1] == '/')
1010 unsigned char *temp
= (unsigned char *) alloca (length
);
1011 bcopy (newdir
, temp
, length
- 1);
1012 temp
[length
- 1] = 0;
1020 /* Now concatenate the directory and name to new space in the stack frame */
1021 tlen
+= strlen (nm
) + 1;
1023 /* Add reserved space for drive name. */
1024 target
= (unsigned char *) alloca (tlen
+ 2) + 2;
1026 target
= (unsigned char *) alloca (tlen
);
1033 if (nm
[0] == 0 || nm
[0] == '/')
1034 strcpy (target
, newdir
);
1037 file_name_as_directory (target
, newdir
);
1040 strcat (target
, nm
);
1042 if (index (target
, '/'))
1043 strcpy (target
, sys_translate_unix (target
));
1046 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1054 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1060 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1061 /* brackets are offset from each other by 2 */
1064 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1065 /* convert [foo][bar] to [bar] */
1066 while (o
[-1] != '[' && o
[-1] != '<')
1068 else if (*p
== '-' && *o
!= '.')
1071 else if (p
[0] == '-' && o
[-1] == '.' &&
1072 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1073 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1077 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1078 if (p
[1] == '.') /* foo.-.bar ==> bar*/
1080 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1082 /* else [foo.-] ==> [-] */
1088 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1089 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1099 else if (!strncmp (p
, "//", 2)
1101 /* // at start of filename is meaningful in Apollo system */
1109 else if (p
[0] == '/'
1114 /* If "/." is the entire filename, keep the "/". Otherwise,
1115 just delete the whole "/.". */
1116 if (o
== target
&& p
[2] == '\0')
1120 else if (!strncmp (p
, "/..", 3)
1121 /* `/../' is the "superroot" on certain file systems. */
1123 && (p
[3] == '/' || p
[3] == 0))
1125 while (o
!= target
&& *--o
!= '/')
1128 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1132 if (o
== target
&& *o
== '/')
1140 #endif /* not VMS */
1144 /* at last, set drive name. */
1145 if (target
[1] != ':')
1148 target
[0] = (drive
< 0 ? getdisk () : drive
) + 'a';
1153 return make_string (target
, o
- target
);
1156 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'.
1157 DEAFUN ("expand-file-name", Fexpand_file_name, Sexpand_file_name, 1, 2, 0,
1158 "Convert FILENAME to absolute, and canonicalize it.\n\
1159 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1160 (does not start with slash); if DEFAULT is nil or missing,\n\
1161 the current buffer's value of default-directory is used.\n\
1162 Filenames containing `.' or `..' as components are simplified;\n\
1163 initial `~/' expands to your home directory.\n\
1164 See also the function `substitute-in-file-name'.")
1166 Lisp_Object name, defalt;
1170 register unsigned char *newdir, *p, *o;
1172 unsigned char *target;
1176 unsigned char * colon = 0;
1177 unsigned char * close = 0;
1178 unsigned char * slash = 0;
1179 unsigned char * brack = 0;
1180 int lbrack = 0, rbrack = 0;
1184 CHECK_STRING (name
, 0);
1187 /* Filenames on VMS are always upper case. */
1188 name
= Fupcase (name
);
1191 nm
= XSTRING (name
)->data
;
1193 /* If nm is absolute, flush ...// and detect /./ and /../.
1194 If no /./ or /../ we can return right away. */
1206 if (p
[0] == '/' && p
[1] == '/'
1208 /* // at start of filename is meaningful on Apollo system */
1213 if (p
[0] == '/' && p
[1] == '~')
1214 nm
= p
+ 1, lose
= 1;
1215 if (p
[0] == '/' && p
[1] == '.'
1216 && (p
[2] == '/' || p
[2] == 0
1217 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1223 /* if dev:[dir]/, move nm to / */
1224 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1225 nm
= (brack
? brack
+ 1 : colon
+ 1);
1226 lbrack
= rbrack
= 0;
1234 /* VMS pre V4.4,convert '-'s in filenames. */
1235 if (lbrack
== rbrack
)
1237 if (dots
< 2) /* this is to allow negative version numbers */
1242 if (lbrack
> rbrack
&&
1243 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1244 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1250 /* count open brackets, reset close bracket pointer */
1251 if (p
[0] == '[' || p
[0] == '<')
1252 lbrack
++, brack
= 0;
1253 /* count close brackets, set close bracket pointer */
1254 if (p
[0] == ']' || p
[0] == '>')
1255 rbrack
++, brack
= p
;
1256 /* detect ][ or >< */
1257 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1259 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1260 nm
= p
+ 1, lose
= 1;
1261 if (p
[0] == ':' && (colon
|| slash
))
1262 /* if dev1:[dir]dev2:, move nm to dev2: */
1268 /* if /pathname/dev:, move nm to dev: */
1271 /* if node::dev:, move colon following dev */
1272 else if (colon
&& colon
[-1] == ':')
1274 /* if dev1:dev2:, move nm to dev2: */
1275 else if (colon
&& colon
[-1] != ':')
1280 if (p
[0] == ':' && !colon
)
1286 if (lbrack
== rbrack
)
1289 else if (p
[0] == '.')
1297 if (index (nm
, '/'))
1298 return build_string (sys_translate_unix (nm
));
1300 if (nm
== XSTRING (name
)->data
)
1302 return build_string (nm
);
1306 /* Now determine directory to start with and put it in NEWDIR */
1310 if (nm
[0] == '~') /* prefix ~ */
1315 || nm
[1] == 0)/* ~/filename */
1317 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1318 newdir
= (unsigned char *) "";
1321 nm
++; /* Don't leave the slash in nm. */
1324 else /* ~user/filename */
1326 /* Get past ~ to user */
1327 unsigned char *user
= nm
+ 1;
1328 /* Find end of name. */
1329 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1330 int len
= ptr
? ptr
- user
: strlen (user
);
1332 unsigned char *ptr1
= index (user
, ':');
1333 if (ptr1
!= 0 && ptr1
- user
< len
)
1336 /* Copy the user name into temp storage. */
1337 o
= (unsigned char *) alloca (len
+ 1);
1338 bcopy ((char *) user
, o
, len
);
1341 /* Look up the user name. */
1342 pw
= (struct passwd
*) getpwnam (o
+ 1);
1344 error ("\"%s\" isn't a registered user", o
+ 1);
1346 newdir
= (unsigned char *) pw
->pw_dir
;
1348 /* Discard the user name from NM. */
1355 #endif /* not VMS */
1359 defalt
= current_buffer
->directory
;
1360 CHECK_STRING (defalt
, 1);
1361 newdir
= XSTRING (defalt
)->data
;
1364 /* Now concatenate the directory and name to new space in the stack frame */
1366 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1367 target
= (unsigned char *) alloca (tlen
);
1373 if (nm
[0] == 0 || nm
[0] == '/')
1374 strcpy (target
, newdir
);
1377 file_name_as_directory (target
, newdir
);
1380 strcat (target
, nm
);
1382 if (index (target
, '/'))
1383 strcpy (target
, sys_translate_unix (target
));
1386 /* Now canonicalize by removing /. and /foo/.. if they appear */
1394 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1400 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1401 /* brackets are offset from each other by 2 */
1404 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1405 /* convert [foo][bar] to [bar] */
1406 while (o
[-1] != '[' && o
[-1] != '<')
1408 else if (*p
== '-' && *o
!= '.')
1411 else if (p
[0] == '-' && o
[-1] == '.' &&
1412 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1413 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1417 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1418 if (p
[1] == '.') /* foo.-.bar ==> bar*/
1420 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1422 /* else [foo.-] ==> [-] */
1428 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1429 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1439 else if (!strncmp (p
, "//", 2)
1441 /* // at start of filename is meaningful in Apollo system */
1449 else if (p
[0] == '/' && p
[1] == '.' &&
1450 (p
[2] == '/' || p
[2] == 0))
1452 else if (!strncmp (p
, "/..", 3)
1453 /* `/../' is the "superroot" on certain file systems. */
1455 && (p
[3] == '/' || p
[3] == 0))
1457 while (o
!= target
&& *--o
!= '/')
1460 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1464 if (o
== target
&& *o
== '/')
1472 #endif /* not VMS */
1475 return make_string (target
, o
- target
);
1479 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1480 Ssubstitute_in_file_name
, 1, 1, 0,
1481 "Substitute environment variables referred to in FILENAME.\n\
1482 `$FOO' where FOO is an environment variable name means to substitute\n\
1483 the value of that variable. The variable name should be terminated\n\
1484 with a character not a letter, digit or underscore; otherwise, enclose\n\
1485 the entire variable name in braces.\n\
1486 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1487 On VMS, `$' substitution is not done; this function does little and only\n\
1488 duplicates what `expand-file-name' does.")
1494 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1495 unsigned char *target
;
1497 int substituted
= 0;
1500 CHECK_STRING (string
, 0);
1502 nm
= XSTRING (string
)->data
;
1504 dostounix_filename (nm
= strcpy (alloca (strlen (nm
) + 1), nm
));
1505 substituted
= !strcmp (nm
, XSTRING (string
)->data
);
1507 endp
= nm
+ XSTRING (string
)->size
;
1509 /* If /~ or // appears, discard everything through first slash. */
1511 for (p
= nm
; p
!= endp
; p
++)
1515 /* // at start of file name is meaningful in Apollo system */
1516 (p
[0] == '/' && p
- 1 != nm
)
1517 #else /* not APOLLO */
1519 #endif /* not APOLLO */
1523 (p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>' ||
1534 if (p
[0] && p
[1] == ':')
1543 return build_string (nm
);
1546 /* See if any variables are substituted into the string
1547 and find the total length of their values in `total' */
1549 for (p
= nm
; p
!= endp
;)
1559 /* "$$" means a single "$" */
1568 while (p
!= endp
&& *p
!= '}') p
++;
1569 if (*p
!= '}') goto missingclose
;
1575 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1579 /* Copy out the variable name */
1580 target
= (unsigned char *) alloca (s
- o
+ 1);
1581 strncpy (target
, o
, s
- o
);
1584 strupr (target
); /* $home == $HOME etc. */
1587 /* Get variable value */
1588 o
= (unsigned char *) egetenv (target
);
1589 if (!o
) goto badvar
;
1590 total
+= strlen (o
);
1597 /* If substitution required, recopy the string and do it */
1598 /* Make space in stack frame for the new copy */
1599 xnm
= (unsigned char *) alloca (XSTRING (string
)->size
+ total
+ 1);
1602 /* Copy the rest of the name through, replacing $ constructs with values */
1619 while (p
!= endp
&& *p
!= '}') p
++;
1620 if (*p
!= '}') goto missingclose
;
1626 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1630 /* Copy out the variable name */
1631 target
= (unsigned char *) alloca (s
- o
+ 1);
1632 strncpy (target
, o
, s
- o
);
1635 strupr (target
); /* $home == $HOME etc. */
1638 /* Get variable value */
1639 o
= (unsigned char *) egetenv (target
);
1649 /* If /~ or // appears, discard everything through first slash. */
1651 for (p
= xnm
; p
!= x
; p
++)
1654 /* // at start of file name is meaningful in Apollo system */
1655 (p
[0] == '/' && p
- 1 != xnm
)
1656 #else /* not APOLLO */
1658 #endif /* not APOLLO */
1660 && p
!= nm
&& p
[-1] == '/')
1663 else if (p
[0] && p
[1] == ':')
1667 return make_string (xnm
, x
- xnm
);
1670 error ("Bad format environment-variable substitution");
1672 error ("Missing \"}\" in environment-variable substitution");
1674 error ("Substituting nonexistent environment variable \"%s\"", target
);
1677 #endif /* not VMS */
1680 /* A slightly faster and more convenient way to get
1681 (directory-file-name (expand-file-name FOO)). */
1684 expand_and_dir_to_file (filename
, defdir
)
1685 Lisp_Object filename
, defdir
;
1687 register Lisp_Object abspath
;
1689 abspath
= Fexpand_file_name (filename
, defdir
);
1692 register int c
= XSTRING (abspath
)->data
[XSTRING (abspath
)->size
- 1];
1693 if (c
== ':' || c
== ']' || c
== '>')
1694 abspath
= Fdirectory_file_name (abspath
);
1697 /* Remove final slash, if any (unless path is root).
1698 stat behaves differently depending! */
1699 if (XSTRING (abspath
)->size
> 1
1700 && XSTRING (abspath
)->data
[XSTRING (abspath
)->size
- 1] == '/')
1701 /* We cannot take shortcuts; they might be wrong for magic file names. */
1702 abspath
= Fdirectory_file_name (abspath
);
1707 barf_or_query_if_file_exists (absname
, querystring
, interactive
)
1708 Lisp_Object absname
;
1709 unsigned char *querystring
;
1712 register Lisp_Object tem
;
1713 struct stat statbuf
;
1714 struct gcpro gcpro1
;
1716 /* stat is a good way to tell whether the file exists,
1717 regardless of what access permissions it has. */
1718 if (stat (XSTRING (absname
)->data
, &statbuf
) >= 0)
1721 Fsignal (Qfile_already_exists
,
1722 Fcons (build_string ("File already exists"),
1723 Fcons (absname
, Qnil
)));
1725 tem
= do_yes_or_no_p (format1 ("File %s already exists; %s anyway? ",
1726 XSTRING (absname
)->data
, querystring
));
1729 Fsignal (Qfile_already_exists
,
1730 Fcons (build_string ("File already exists"),
1731 Fcons (absname
, Qnil
)));
1736 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
1737 "fCopy file: \nFCopy %s to file: \np\nP",
1738 "Copy FILE to NEWNAME. Both args must be strings.\n\
1739 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
1740 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
1741 A number as third arg means request confirmation if NEWNAME already exists.\n\
1742 This is what happens in interactive use with M-x.\n\
1743 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
1744 last-modified time as the old one. (This works on only some systems.)\n\
1745 A prefix arg makes KEEP-TIME non-nil.")
1746 (filename
, newname
, ok_if_already_exists
, keep_date
)
1747 Lisp_Object filename
, newname
, ok_if_already_exists
, keep_date
;
1750 char buf
[16 * 1024];
1752 Lisp_Object handler
;
1753 struct gcpro gcpro1
, gcpro2
;
1754 int count
= specpdl_ptr
- specpdl
;
1755 int input_file_statable_p
;
1757 GCPRO2 (filename
, newname
);
1758 CHECK_STRING (filename
, 0);
1759 CHECK_STRING (newname
, 1);
1760 filename
= Fexpand_file_name (filename
, Qnil
);
1761 newname
= Fexpand_file_name (newname
, Qnil
);
1763 /* If the input file name has special constructs in it,
1764 call the corresponding file handler. */
1765 handler
= Ffind_file_name_handler (filename
, Qcopy_file
);
1766 /* Likewise for output file name. */
1768 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
1769 if (!NILP (handler
))
1770 RETURN_UNGCPRO (call5 (handler
, Qcopy_file
, filename
, newname
,
1771 ok_if_already_exists
, keep_date
));
1773 if (NILP (ok_if_already_exists
)
1774 || XTYPE (ok_if_already_exists
) == Lisp_Int
)
1775 barf_or_query_if_file_exists (newname
, "copy to it",
1776 XTYPE (ok_if_already_exists
) == Lisp_Int
);
1778 ifd
= open (XSTRING (filename
)->data
, O_RDONLY
);
1780 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
1782 record_unwind_protect (close_file_unwind
, make_number (ifd
));
1784 /* We can only copy regular files and symbolic links. Other files are not
1786 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
1788 #if defined (S_ISREG) && defined (S_ISLNK)
1789 if (input_file_statable_p
)
1791 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
1793 #if defined (EISDIR)
1794 /* Get a better looking error message. */
1797 report_file_error ("Non-regular file", Fcons (filename
, Qnil
));
1800 #endif /* S_ISREG && S_ISLNK */
1803 /* Create the copy file with the same record format as the input file */
1804 ofd
= sys_creat (XSTRING (newname
)->data
, 0666, ifd
);
1807 /* System's default file type was set to binary by _fmode in emacs.c. */
1808 ofd
= creat (XSTRING (newname
)->data
, S_IREAD
| S_IWRITE
);
1809 #else /* not MSDOS */
1810 ofd
= creat (XSTRING (newname
)->data
, 0666);
1811 #endif /* not MSDOS */
1814 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
1816 record_unwind_protect (close_file_unwind
, make_number (ofd
));
1820 while ((n
= read (ifd
, buf
, sizeof buf
)) > 0)
1821 if (write (ofd
, buf
, n
) != n
)
1822 report_file_error ("I/O error", Fcons (newname
, Qnil
));
1825 /* Closing the output clobbers the file times on some systems. */
1826 if (close (ofd
) < 0)
1827 report_file_error ("I/O error", Fcons (newname
, Qnil
));
1829 if (input_file_statable_p
)
1831 if (!NILP (keep_date
))
1833 EMACS_TIME atime
, mtime
;
1834 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
1835 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
1836 EMACS_SET_UTIMES (XSTRING (newname
)->data
, atime
, mtime
);
1839 if (!egetenv ("USE_DOMAIN_ACLS"))
1841 chmod (XSTRING (newname
)->data
, st
.st_mode
& 07777);
1846 /* Discard the unwind protects. */
1847 specpdl_ptr
= specpdl
+ count
;
1853 DEFUN ("make-directory-internal", Fmake_directory_internal
,
1854 Smake_directory_internal
, 1, 1, 0,
1855 "Create a directory. One argument, a file name string.")
1857 Lisp_Object dirname
;
1860 Lisp_Object handler
;
1862 CHECK_STRING (dirname
, 0);
1863 dirname
= Fexpand_file_name (dirname
, Qnil
);
1865 handler
= Ffind_file_name_handler (dirname
, Qmake_directory_internal
);
1866 if (!NILP (handler
))
1867 return call2 (handler
, Qmake_directory_internal
, dirname
);
1869 dir
= XSTRING (dirname
)->data
;
1871 if (mkdir (dir
, 0777) != 0)
1872 report_file_error ("Creating directory", Flist (1, &dirname
));
1877 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
1878 "Delete a directory. One argument, a file name or directory name string.")
1880 Lisp_Object dirname
;
1883 Lisp_Object handler
;
1885 CHECK_STRING (dirname
, 0);
1886 dirname
= Fdirectory_file_name (Fexpand_file_name (dirname
, Qnil
));
1887 dir
= XSTRING (dirname
)->data
;
1889 handler
= Ffind_file_name_handler (dirname
, Qdelete_directory
);
1890 if (!NILP (handler
))
1891 return call2 (handler
, Qdelete_directory
, dirname
);
1893 if (rmdir (dir
) != 0)
1894 report_file_error ("Removing directory", Flist (1, &dirname
));
1899 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
1900 "Delete specified file. One argument, a file name string.\n\
1901 If file has multiple names, it continues to exist with the other names.")
1903 Lisp_Object filename
;
1905 Lisp_Object handler
;
1906 CHECK_STRING (filename
, 0);
1907 filename
= Fexpand_file_name (filename
, Qnil
);
1909 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
1910 if (!NILP (handler
))
1911 return call2 (handler
, Qdelete_file
, filename
);
1913 if (0 > unlink (XSTRING (filename
)->data
))
1914 report_file_error ("Removing old name", Flist (1, &filename
));
1918 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
1919 "fRename file: \nFRename %s to file: \np",
1920 "Rename FILE as NEWNAME. Both args strings.\n\
1921 If file has names other than FILE, it continues to have those names.\n\
1922 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
1923 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
1924 A number as third arg means request confirmation if NEWNAME already exists.\n\
1925 This is what happens in interactive use with M-x.")
1926 (filename
, newname
, ok_if_already_exists
)
1927 Lisp_Object filename
, newname
, ok_if_already_exists
;
1930 Lisp_Object args
[2];
1932 Lisp_Object handler
;
1933 struct gcpro gcpro1
, gcpro2
;
1935 GCPRO2 (filename
, newname
);
1936 CHECK_STRING (filename
, 0);
1937 CHECK_STRING (newname
, 1);
1938 filename
= Fexpand_file_name (filename
, Qnil
);
1939 newname
= Fexpand_file_name (newname
, Qnil
);
1941 /* If the file name has special constructs in it,
1942 call the corresponding file handler. */
1943 handler
= Ffind_file_name_handler (filename
, Qrename_file
);
1945 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
1946 if (!NILP (handler
))
1947 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
1948 filename
, newname
, ok_if_already_exists
));
1950 if (NILP (ok_if_already_exists
)
1951 || XTYPE (ok_if_already_exists
) == Lisp_Int
)
1952 barf_or_query_if_file_exists (newname
, "rename to it",
1953 XTYPE (ok_if_already_exists
) == Lisp_Int
);
1955 if (0 > rename (XSTRING (filename
)->data
, XSTRING (newname
)->data
))
1957 if (0 > link (XSTRING (filename
)->data
, XSTRING (newname
)->data
)
1958 || 0 > unlink (XSTRING (filename
)->data
))
1963 Fcopy_file (filename
, newname
,
1964 /* We have already prompted if it was an integer,
1965 so don't have copy-file prompt again. */
1966 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
1967 Fdelete_file (filename
);
1974 report_file_error ("Renaming", Flist (2, args
));
1977 report_file_error ("Renaming", Flist (2, &filename
));
1984 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
1985 "fAdd name to file: \nFName to add to %s: \np",
1986 "Give FILE additional name NEWNAME. Both args strings.\n\
1987 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
1988 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
1989 A number as third arg means request confirmation if NEWNAME already exists.\n\
1990 This is what happens in interactive use with M-x.")
1991 (filename
, newname
, ok_if_already_exists
)
1992 Lisp_Object filename
, newname
, ok_if_already_exists
;
1995 Lisp_Object args
[2];
1997 Lisp_Object handler
;
1998 struct gcpro gcpro1
, gcpro2
;
2000 GCPRO2 (filename
, newname
);
2001 CHECK_STRING (filename
, 0);
2002 CHECK_STRING (newname
, 1);
2003 filename
= Fexpand_file_name (filename
, Qnil
);
2004 newname
= Fexpand_file_name (newname
, Qnil
);
2006 /* If the file name has special constructs in it,
2007 call the corresponding file handler. */
2008 handler
= Ffind_file_name_handler (filename
, Qadd_name_to_file
);
2009 if (!NILP (handler
))
2010 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, filename
,
2011 newname
, ok_if_already_exists
));
2013 if (NILP (ok_if_already_exists
)
2014 || XTYPE (ok_if_already_exists
) == Lisp_Int
)
2015 barf_or_query_if_file_exists (newname
, "make it a new name",
2016 XTYPE (ok_if_already_exists
) == Lisp_Int
);
2017 unlink (XSTRING (newname
)->data
);
2018 if (0 > link (XSTRING (filename
)->data
, XSTRING (newname
)->data
))
2023 report_file_error ("Adding new name", Flist (2, args
));
2025 report_file_error ("Adding new name", Flist (2, &filename
));
2034 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2035 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2036 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
2037 Signals a `file-already-exists' error if a file LINKNAME already exists\n\
2038 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2039 A number as third arg means request confirmation if LINKNAME already exists.\n\
2040 This happens for interactive use with M-x.")
2041 (filename
, linkname
, ok_if_already_exists
)
2042 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2045 Lisp_Object args
[2];
2047 Lisp_Object handler
;
2048 struct gcpro gcpro1
, gcpro2
;
2050 GCPRO2 (filename
, linkname
);
2051 CHECK_STRING (filename
, 0);
2052 CHECK_STRING (linkname
, 1);
2053 /* If the link target has a ~, we must expand it to get
2054 a truly valid file name. Otherwise, do not expand;
2055 we want to permit links to relative file names. */
2056 if (XSTRING (filename
)->data
[0] == '~')
2057 filename
= Fexpand_file_name (filename
, Qnil
);
2058 linkname
= Fexpand_file_name (linkname
, Qnil
);
2060 /* If the file name has special constructs in it,
2061 call the corresponding file handler. */
2062 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2063 if (!NILP (handler
))
2064 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2065 linkname
, ok_if_already_exists
));
2067 if (NILP (ok_if_already_exists
)
2068 || XTYPE (ok_if_already_exists
) == Lisp_Int
)
2069 barf_or_query_if_file_exists (linkname
, "make it a link",
2070 XTYPE (ok_if_already_exists
) == Lisp_Int
);
2071 if (0 > symlink (XSTRING (filename
)->data
, XSTRING (linkname
)->data
))
2073 /* If we didn't complain already, silently delete existing file. */
2074 if (errno
== EEXIST
)
2076 unlink (XSTRING (linkname
)->data
);
2077 if (0 <= symlink (XSTRING (filename
)->data
, XSTRING (linkname
)->data
))
2087 report_file_error ("Making symbolic link", Flist (2, args
));
2089 report_file_error ("Making symbolic link", Flist (2, &filename
));
2095 #endif /* S_IFLNK */
2099 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2100 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2101 "Define the job-wide logical name NAME to have the value STRING.\n\
2102 If STRING is nil or a null string, the logical name NAME is deleted.")
2104 Lisp_Object varname
;
2107 CHECK_STRING (varname
, 0);
2109 delete_logical_name (XSTRING (varname
)->data
);
2112 CHECK_STRING (string
, 1);
2114 if (XSTRING (string
)->size
== 0)
2115 delete_logical_name (XSTRING (varname
)->data
);
2117 define_logical_name (XSTRING (varname
)->data
, XSTRING (string
)->data
);
2126 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2127 "Open a network connection to PATH using LOGIN as the login string.")
2129 Lisp_Object path
, login
;
2133 CHECK_STRING (path
, 0);
2134 CHECK_STRING (login
, 0);
2136 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2138 if (netresult
== -1)
2143 #endif /* HPUX_NET */
2145 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2147 "Return t if file FILENAME specifies an absolute path name.\n\
2148 On Unix, this is a name starting with a `/' or a `~'.")
2150 Lisp_Object filename
;
2154 CHECK_STRING (filename
, 0);
2155 ptr
= XSTRING (filename
)->data
;
2156 if (*ptr
== '/' || *ptr
== '~'
2158 /* ??? This criterion is probably wrong for '<'. */
2159 || index (ptr
, ':') || index (ptr
, '<')
2160 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2164 || (*ptr
!= 0 && ptr
[1] == ':' && (ptr
[2] == '/' || ptr
[2] == '\\'))
2172 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2173 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
2174 See also `file-readable-p' and `file-attributes'.")
2176 Lisp_Object filename
;
2178 Lisp_Object abspath
;
2179 Lisp_Object handler
;
2180 struct stat statbuf
;
2182 CHECK_STRING (filename
, 0);
2183 abspath
= Fexpand_file_name (filename
, Qnil
);
2185 /* If the file name has special constructs in it,
2186 call the corresponding file handler. */
2187 handler
= Ffind_file_name_handler (abspath
, Qfile_exists_p
);
2188 if (!NILP (handler
))
2189 return call2 (handler
, Qfile_exists_p
, abspath
);
2191 return (stat (XSTRING (abspath
)->data
, &statbuf
) >= 0) ? Qt
: Qnil
;
2194 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2195 "Return t if FILENAME can be executed by you.\n\
2196 For a directory, this means you can access files in that directory.")
2198 Lisp_Object filename
;
2201 Lisp_Object abspath
;
2202 Lisp_Object handler
;
2204 CHECK_STRING (filename
, 0);
2205 abspath
= Fexpand_file_name (filename
, Qnil
);
2207 /* If the file name has special constructs in it,
2208 call the corresponding file handler. */
2209 handler
= Ffind_file_name_handler (abspath
, Qfile_executable_p
);
2210 if (!NILP (handler
))
2211 return call2 (handler
, Qfile_executable_p
, abspath
);
2213 return (access (XSTRING (abspath
)->data
, 1) >= 0) ? Qt
: Qnil
;
2216 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2217 "Return t if file FILENAME exists and you can read it.\n\
2218 See also `file-exists-p' and `file-attributes'.")
2220 Lisp_Object filename
;
2222 Lisp_Object abspath
;
2223 Lisp_Object handler
;
2226 CHECK_STRING (filename
, 0);
2227 abspath
= Fexpand_file_name (filename
, Qnil
);
2229 /* If the file name has special constructs in it,
2230 call the corresponding file handler. */
2231 handler
= Ffind_file_name_handler (abspath
, Qfile_readable_p
);
2232 if (!NILP (handler
))
2233 return call2 (handler
, Qfile_readable_p
, abspath
);
2235 desc
= open (XSTRING (abspath
)->data
, O_RDONLY
);
2242 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
2243 "Return non-nil if file FILENAME is the name of a symbolic link.\n\
2244 The value is the name of the file to which it is linked.\n\
2245 Otherwise returns nil.")
2247 Lisp_Object filename
;
2254 Lisp_Object handler
;
2256 CHECK_STRING (filename
, 0);
2257 filename
= Fexpand_file_name (filename
, Qnil
);
2259 /* If the file name has special constructs in it,
2260 call the corresponding file handler. */
2261 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
2262 if (!NILP (handler
))
2263 return call2 (handler
, Qfile_symlink_p
, filename
);
2268 buf
= (char *) xmalloc (bufsize
);
2269 bzero (buf
, bufsize
);
2270 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
2271 if (valsize
< bufsize
) break;
2272 /* Buffer was not long enough */
2281 val
= make_string (buf
, valsize
);
2284 #else /* not S_IFLNK */
2286 #endif /* not S_IFLNK */
2289 #ifdef SOLARIS_BROKEN_ACCESS
2290 /* In Solaris 2.1, the readonly-ness of the filesystem is not
2291 considered by the access system call. This is Sun's bug, but we
2292 still have to make Emacs work. */
2294 #include <sys/statvfs.h>
2300 struct statvfs statvfsb
;
2302 if (statvfs(path
, &statvfsb
))
2303 return 1; /* error from statvfs, be conservative and say not wrtable */
2305 /* Otherwise, fsys is ro if bit is set. */
2306 return statvfsb
.f_flag
& ST_RDONLY
;
2309 /* But on every other os, access has already done the right thing. */
2310 #define ro_fsys(path) 0
2313 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2315 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
2316 "Return t if file FILENAME can be written or created by you.")
2318 Lisp_Object filename
;
2320 Lisp_Object abspath
, dir
;
2321 Lisp_Object handler
;
2323 CHECK_STRING (filename
, 0);
2324 abspath
= Fexpand_file_name (filename
, Qnil
);
2326 /* If the file name has special constructs in it,
2327 call the corresponding file handler. */
2328 handler
= Ffind_file_name_handler (abspath
, Qfile_writable_p
);
2329 if (!NILP (handler
))
2330 return call2 (handler
, Qfile_writable_p
, abspath
);
2332 if (access (XSTRING (abspath
)->data
, 0) >= 0)
2333 return ((access (XSTRING (abspath
)->data
, 2) >= 0
2334 && ! ro_fsys ((char *) XSTRING (abspath
)->data
))
2336 dir
= Ffile_name_directory (abspath
);
2339 dir
= Fdirectory_file_name (dir
);
2343 dir
= Fdirectory_file_name (dir
);
2345 return ((access (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "", 2) >= 0
2346 && ! ro_fsys ((char *) XSTRING (dir
)->data
))
2350 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
2351 "Return t if file FILENAME is the name of a directory as a file.\n\
2352 A directory name spec may be given instead; then the value is t\n\
2353 if the directory so specified exists and really is a directory.")
2355 Lisp_Object filename
;
2357 register Lisp_Object abspath
;
2359 Lisp_Object handler
;
2361 abspath
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2363 /* If the file name has special constructs in it,
2364 call the corresponding file handler. */
2365 handler
= Ffind_file_name_handler (abspath
, Qfile_directory_p
);
2366 if (!NILP (handler
))
2367 return call2 (handler
, Qfile_directory_p
, abspath
);
2369 if (stat (XSTRING (abspath
)->data
, &st
) < 0)
2371 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
2374 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
2375 "Return t if file FILENAME is the name of a directory as a file,\n\
2376 and files in that directory can be opened by you. In order to use a\n\
2377 directory as a buffer's current directory, this predicate must return true.\n\
2378 A directory name spec may be given instead; then the value is t\n\
2379 if the directory so specified exists and really is a readable and\n\
2380 searchable directory.")
2382 Lisp_Object filename
;
2384 Lisp_Object handler
;
2386 struct gcpro gcpro1
;
2388 /* If the file name has special constructs in it,
2389 call the corresponding file handler. */
2390 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
2391 if (!NILP (handler
))
2392 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
2394 /* It's an unlikely combination, but yes we really do need to gcpro:
2395 Suppose that file-accessible-directory-p has no handler, but
2396 file-directory-p does have a handler; this handler causes a GC which
2397 relocates the string in `filename'; and finally file-directory-p
2398 returns non-nil. Then we would end up passing a garbaged string
2399 to file-executable-p. */
2401 tem
= (NILP (Ffile_directory_p (filename
))
2402 || NILP (Ffile_executable_p (filename
)));
2404 return tem
? Qnil
: Qt
;
2407 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
2408 "Return mode bits of FILE, as an integer.")
2410 Lisp_Object filename
;
2412 Lisp_Object abspath
;
2414 Lisp_Object handler
;
2416 abspath
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2418 /* If the file name has special constructs in it,
2419 call the corresponding file handler. */
2420 handler
= Ffind_file_name_handler (abspath
, Qfile_modes
);
2421 if (!NILP (handler
))
2422 return call2 (handler
, Qfile_modes
, abspath
);
2424 if (stat (XSTRING (abspath
)->data
, &st
) < 0)
2430 if (S_ISREG (st
.st_mode
)
2431 && (len
= XSTRING (abspath
)->size
) >= 5
2432 && (stricmp ((suffix
= XSTRING (abspath
)->data
+ len
-4), ".com") == 0
2433 || stricmp (suffix
, ".exe") == 0
2434 || stricmp (suffix
, ".bat") == 0))
2435 st
.st_mode
|= S_IEXEC
;
2439 return make_number (st
.st_mode
& 07777);
2442 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
2443 "Set mode bits of FILE to MODE (an integer).\n\
2444 Only the 12 low bits of MODE are used.")
2446 Lisp_Object filename
, mode
;
2448 Lisp_Object abspath
;
2449 Lisp_Object handler
;
2451 abspath
= Fexpand_file_name (filename
, current_buffer
->directory
);
2452 CHECK_NUMBER (mode
, 1);
2454 /* If the file name has special constructs in it,
2455 call the corresponding file handler. */
2456 handler
= Ffind_file_name_handler (abspath
, Qset_file_modes
);
2457 if (!NILP (handler
))
2458 return call3 (handler
, Qset_file_modes
, abspath
, mode
);
2461 if (chmod (XSTRING (abspath
)->data
, XINT (mode
)) < 0)
2462 report_file_error ("Doing chmod", Fcons (abspath
, Qnil
));
2464 if (!egetenv ("USE_DOMAIN_ACLS"))
2467 struct timeval tvp
[2];
2469 /* chmod on apollo also change the file's modtime; need to save the
2470 modtime and then restore it. */
2471 if (stat (XSTRING (abspath
)->data
, &st
) < 0)
2473 report_file_error ("Doing chmod", Fcons (abspath
, Qnil
));
2477 if (chmod (XSTRING (abspath
)->data
, XINT (mode
)) < 0)
2478 report_file_error ("Doing chmod", Fcons (abspath
, Qnil
));
2480 /* reset the old accessed and modified times. */
2481 tvp
[0].tv_sec
= st
.st_atime
+ 1; /* +1 due to an Apollo roundoff bug */
2483 tvp
[1].tv_sec
= st
.st_mtime
+ 1; /* +1 due to an Apollo roundoff bug */
2486 if (utimes (XSTRING (abspath
)->data
, tvp
) < 0)
2487 report_file_error ("Doing utimes", Fcons (abspath
, Qnil
));
2494 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
2495 "Set the file permission bits for newly created files.\n\
2496 The argument MODE should be an integer; only the low 9 bits are used.\n\
2497 This setting is inherited by subprocesses.")
2501 CHECK_NUMBER (mode
, 0);
2503 umask ((~ XINT (mode
)) & 0777);
2508 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
2509 "Return the default file protection for created files.\n\
2510 The value is an integer.")
2516 realmask
= umask (0);
2519 XSET (value
, Lisp_Int
, (~ realmask
) & 0777);
2525 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
2526 "Tell Unix to finish all pending disk updates.")
2535 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
2536 "Return t if file FILE1 is newer than file FILE2.\n\
2537 If FILE1 does not exist, the answer is nil;\n\
2538 otherwise, if FILE2 does not exist, the answer is t.")
2540 Lisp_Object file1
, file2
;
2542 Lisp_Object abspath1
, abspath2
;
2545 Lisp_Object handler
;
2546 struct gcpro gcpro1
, gcpro2
;
2548 CHECK_STRING (file1
, 0);
2549 CHECK_STRING (file2
, 0);
2552 GCPRO2 (abspath1
, file2
);
2553 abspath1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
2554 abspath2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
2557 /* If the file name has special constructs in it,
2558 call the corresponding file handler. */
2559 handler
= Ffind_file_name_handler (abspath1
, Qfile_newer_than_file_p
);
2561 handler
= Ffind_file_name_handler (abspath2
, Qfile_newer_than_file_p
);
2562 if (!NILP (handler
))
2563 return call3 (handler
, Qfile_newer_than_file_p
, abspath1
, abspath2
);
2565 if (stat (XSTRING (abspath1
)->data
, &st
) < 0)
2568 mtime1
= st
.st_mtime
;
2570 if (stat (XSTRING (abspath2
)->data
, &st
) < 0)
2573 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
2577 Lisp_Object Qfind_buffer_file_type
;
2580 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
2582 "Insert contents of file FILENAME after point.\n\
2583 Returns list of absolute file name and length of data inserted.\n\
2584 If second argument VISIT is non-nil, the buffer's visited filename\n\
2585 and last save file modtime are set, and it is marked unmodified.\n\
2586 If visiting and the file does not exist, visiting is completed\n\
2587 before the error is signaled.\n\n\
2588 The optional third and fourth arguments BEG and END\n\
2589 specify what portion of the file to insert.\n\
2590 If VISIT is non-nil, BEG and END must be nil.\n\
2591 If optional fifth argument REPLACE is non-nil,\n\
2592 it means replace the current buffer contents (in the accessible portion)\n\
2593 with the file contents. This is better than simply deleting and inserting\n\
2594 the whole thing because (1) it preserves some marker positions\n\
2595 and (2) it puts less data in the undo list.")
2596 (filename
, visit
, beg
, end
, replace
)
2597 Lisp_Object filename
, visit
, beg
, end
, replace
;
2601 register int inserted
= 0;
2602 register int how_much
;
2603 int count
= specpdl_ptr
- specpdl
;
2604 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2605 Lisp_Object handler
, val
, insval
;
2612 GCPRO3 (filename
, val
, p
);
2613 if (!NILP (current_buffer
->read_only
))
2614 Fbarf_if_buffer_read_only();
2616 CHECK_STRING (filename
, 0);
2617 filename
= Fexpand_file_name (filename
, Qnil
);
2619 /* If the file name has special constructs in it,
2620 call the corresponding file handler. */
2621 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
2622 if (!NILP (handler
))
2624 val
= call6 (handler
, Qinsert_file_contents
, filename
,
2625 visit
, beg
, end
, replace
);
2632 if (stat (XSTRING (filename
)->data
, &st
) < 0)
2634 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0
2635 || fstat (fd
, &st
) < 0)
2636 #endif /* not APOLLO */
2638 if (fd
>= 0) close (fd
);
2641 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
2648 /* This code will need to be changed in order to work on named
2649 pipes, and it's probably just not worth it. So we should at
2650 least signal an error. */
2651 if (!S_ISREG (st
.st_mode
))
2652 Fsignal (Qfile_error
,
2653 Fcons (build_string ("not a regular file"),
2654 Fcons (filename
, Qnil
)));
2658 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0)
2661 /* Replacement should preserve point as it preserves markers. */
2662 if (!NILP (replace
))
2663 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
2665 record_unwind_protect (close_file_unwind
, make_number (fd
));
2667 /* Supposedly happens on VMS. */
2669 error ("File size is negative");
2671 if (!NILP (beg
) || !NILP (end
))
2673 error ("Attempt to visit less than an entire file");
2676 CHECK_NUMBER (beg
, 0);
2681 CHECK_NUMBER (end
, 0);
2684 XSETINT (end
, st
.st_size
);
2685 if (XINT (end
) != st
.st_size
)
2686 error ("maximum buffer size exceeded");
2689 /* If requested, replace the accessible part of the buffer
2690 with the file contents. Avoid replacing text at the
2691 beginning or end of the buffer that matches the file contents;
2692 that preserves markers pointing to the unchanged parts. */
2694 /* On MSDOS, replace mode doesn't really work, except for binary files,
2695 and it's not worth supporting just for them. */
2696 if (!NILP (replace
))
2700 XFASTINT (end
) = st
.st_size
;
2701 del_range_1 (BEGV
, ZV
, 0);
2704 if (!NILP (replace
))
2706 unsigned char buffer
[1 << 14];
2707 int same_at_start
= BEGV
;
2708 int same_at_end
= ZV
;
2713 /* Count how many chars at the start of the file
2714 match the text at the beginning of the buffer. */
2719 nread
= read (fd
, buffer
, sizeof buffer
);
2721 error ("IO error reading %s: %s",
2722 XSTRING (filename
)->data
, strerror (errno
));
2723 else if (nread
== 0)
2726 while (bufpos
< nread
&& same_at_start
< ZV
2727 && FETCH_CHAR (same_at_start
) == buffer
[bufpos
])
2728 same_at_start
++, bufpos
++;
2729 /* If we found a discrepancy, stop the scan.
2730 Otherwise loop around and scan the next bufferfull. */
2731 if (bufpos
!= nread
)
2735 /* If the file matches the buffer completely,
2736 there's no need to replace anything. */
2737 if (same_at_start
- BEGV
== st
.st_size
)
2741 /* Truncate the buffer to the size of the file. */
2742 del_range_1 (same_at_start
, same_at_end
, 0);
2747 /* Count how many chars at the end of the file
2748 match the text at the end of the buffer. */
2751 int total_read
, nread
, bufpos
, curpos
, trial
;
2753 /* At what file position are we now scanning? */
2754 curpos
= st
.st_size
- (ZV
- same_at_end
);
2755 /* If the entire file matches the buffer tail, stop the scan. */
2758 /* How much can we scan in the next step? */
2759 trial
= min (curpos
, sizeof buffer
);
2760 if (lseek (fd
, curpos
- trial
, 0) < 0)
2761 report_file_error ("Setting file position",
2762 Fcons (filename
, Qnil
));
2765 while (total_read
< trial
)
2767 nread
= read (fd
, buffer
+ total_read
, trial
- total_read
);
2769 error ("IO error reading %s: %s",
2770 XSTRING (filename
)->data
, strerror (errno
));
2771 total_read
+= nread
;
2773 /* Scan this bufferfull from the end, comparing with
2774 the Emacs buffer. */
2775 bufpos
= total_read
;
2776 /* Compare with same_at_start to avoid counting some buffer text
2777 as matching both at the file's beginning and at the end. */
2778 while (bufpos
> 0 && same_at_end
> same_at_start
2779 && FETCH_CHAR (same_at_end
- 1) == buffer
[bufpos
- 1])
2780 same_at_end
--, bufpos
--;
2781 /* If we found a discrepancy, stop the scan.
2782 Otherwise loop around and scan the preceding bufferfull. */
2788 /* Don't try to reuse the same piece of text twice. */
2789 overlap
= same_at_start
- BEGV
- (same_at_end
+ st
.st_size
- ZV
);
2791 same_at_end
+= overlap
;
2793 /* Arrange to read only the nonmatching middle part of the file. */
2794 XFASTINT (beg
) = same_at_start
- BEGV
;
2795 XFASTINT (end
) = st
.st_size
- (ZV
- same_at_end
);
2797 del_range_1 (same_at_start
, same_at_end
, 0);
2798 /* Insert from the file at the proper position. */
2799 SET_PT (same_at_start
);
2803 total
= XINT (end
) - XINT (beg
);
2806 register Lisp_Object temp
;
2808 /* Make sure point-max won't overflow after this insertion. */
2809 XSET (temp
, Lisp_Int
, total
);
2810 if (total
!= XINT (temp
))
2811 error ("maximum buffer size exceeded");
2814 if (NILP (visit
) && total
> 0)
2815 prepare_to_modify_buffer (point
, point
);
2818 if (GAP_SIZE
< total
)
2819 make_gap (total
- GAP_SIZE
);
2821 if (XINT (beg
) != 0 || !NILP (replace
))
2823 if (lseek (fd
, XINT (beg
), 0) < 0)
2824 report_file_error ("Setting file position", Fcons (filename
, Qnil
));
2828 while (inserted
< total
)
2830 int try = min (total
- inserted
, 64 << 10);
2833 /* Allow quitting out of the actual I/O. */
2836 this = read (fd
, &FETCH_CHAR (point
+ inserted
- 1) + 1, try);
2853 /* Demacs 1.1.1 91/10/16 HIRANO Satoshi, MW July 1993 */
2854 /* Determine file type from name and remove LFs from CR-LFs if the file
2855 is deemed to be a text file. */
2857 struct gcpro gcpro1
;
2861 current_buffer
->buffer_file_type
2862 = call1 (Qfind_buffer_file_type
, filename
);
2864 if (NILP (current_buffer
->buffer_file_type
))
2867 = inserted
- crlf_to_lf (inserted
, &FETCH_CHAR (point
- 1) + 1);
2870 GPT
-= reduced_size
;
2871 GAP_SIZE
+= reduced_size
;
2872 inserted
-= reduced_size
;
2879 record_insert (point
, inserted
);
2881 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
2882 offset_intervals (current_buffer
, point
, inserted
);
2888 /* Discard the unwind protect for closing the file. */
2892 error ("IO error reading %s: %s",
2893 XSTRING (filename
)->data
, strerror (errno
));
2900 if (!EQ (current_buffer
->undo_list
, Qt
))
2901 current_buffer
->undo_list
= Qnil
;
2903 stat (XSTRING (filename
)->data
, &st
);
2908 current_buffer
->modtime
= st
.st_mtime
;
2909 current_buffer
->filename
= filename
;
2912 current_buffer
->save_modified
= MODIFF
;
2913 current_buffer
->auto_save_modified
= MODIFF
;
2914 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
2915 #ifdef CLASH_DETECTION
2918 if (!NILP (current_buffer
->filename
))
2919 unlock_file (current_buffer
->filename
);
2920 unlock_file (filename
);
2922 #endif /* CLASH_DETECTION */
2923 /* If visiting nonexistent file, return nil. */
2924 if (current_buffer
->modtime
== -1)
2925 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
2928 if (inserted
> 0 && NILP (visit
) && total
> 0)
2929 signal_after_change (point
, 0, inserted
);
2933 p
= Vafter_insert_file_functions
;
2936 insval
= call1 (Fcar (p
), make_number (inserted
));
2939 CHECK_NUMBER (insval
, 0);
2940 inserted
= XFASTINT (insval
);
2948 val
= Fcons (filename
,
2949 Fcons (make_number (inserted
),
2952 RETURN_UNGCPRO (unbind_to (count
, val
));
2955 static Lisp_Object
build_annotations ();
2957 /* If build_annotations switched buffers, switch back to BUF.
2958 Kill the temporary buffer that was selected in the meantime. */
2961 build_annotations_unwind (buf
)
2966 if (XBUFFER (buf
) == current_buffer
)
2968 tembuf
= Fcurrent_buffer ();
2970 Fkill_buffer (tembuf
);
2974 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 5,
2975 "r\nFWrite region to file: ",
2976 "Write current region into specified file.\n\
2977 When called from a program, takes three arguments:\n\
2978 START, END and FILENAME. START and END are buffer positions.\n\
2979 Optional fourth argument APPEND if non-nil means\n\
2980 append to existing file contents (if any).\n\
2981 Optional fifth argument VISIT if t means\n\
2982 set the last-save-file-modtime of buffer to this file's modtime\n\
2983 and mark buffer not modified.\n\
2984 If VISIT is a string, it is a second file name;\n\
2985 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
2986 VISIT is also the file name to lock and unlock for clash detection.\n\
2987 If VISIT is neither t nor nil nor a string,\n\
2988 that means do not print the \"Wrote file\" message.\n\
2989 Kludgy feature: if START is a string, then that string is written\n\
2990 to the file, instead of any buffer contents, and END is ignored.")
2991 (start
, end
, filename
, append
, visit
)
2992 Lisp_Object start
, end
, filename
, append
, visit
;
3000 int count
= specpdl_ptr
- specpdl
;
3003 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
3005 Lisp_Object handler
;
3006 Lisp_Object visit_file
;
3007 Lisp_Object annotations
;
3008 int visiting
, quietly
;
3009 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3010 struct buffer
*given_buffer
;
3012 int buffer_file_type
3013 = NILP (current_buffer
->buffer_file_type
) ? O_TEXT
: O_BINARY
;
3016 if (!NILP (start
) && !STRINGP (start
))
3017 validate_region (&start
, &end
);
3019 GCPRO2 (filename
, visit
);
3020 filename
= Fexpand_file_name (filename
, Qnil
);
3021 if (STRINGP (visit
))
3022 visit_file
= Fexpand_file_name (visit
, Qnil
);
3024 visit_file
= filename
;
3027 visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
3028 quietly
= !NILP (visit
);
3032 GCPRO4 (start
, filename
, annotations
, visit_file
);
3034 /* If the file name has special constructs in it,
3035 call the corresponding file handler. */
3036 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
3037 /* If FILENAME has no handler, see if VISIT has one. */
3038 if (NILP (handler
) && XTYPE (visit
) == Lisp_String
)
3039 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
3041 if (!NILP (handler
))
3044 val
= call6 (handler
, Qwrite_region
, start
, end
,
3045 filename
, append
, visit
);
3049 current_buffer
->save_modified
= MODIFF
;
3050 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3051 current_buffer
->filename
= visit_file
;
3057 /* Special kludge to simplify auto-saving. */
3060 XFASTINT (start
) = BEG
;
3064 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
3065 count1
= specpdl_ptr
- specpdl
;
3067 given_buffer
= current_buffer
;
3068 annotations
= build_annotations (start
, end
);
3069 if (current_buffer
!= given_buffer
)
3075 #ifdef CLASH_DETECTION
3077 lock_file (visit_file
);
3078 #endif /* CLASH_DETECTION */
3080 fn
= XSTRING (filename
)->data
;
3084 desc
= open (fn
, O_WRONLY
| buffer_file_type
);
3086 desc
= open (fn
, O_WRONLY
);
3091 if (auto_saving
) /* Overwrite any previous version of autosave file */
3093 vms_truncate (fn
); /* if fn exists, truncate to zero length */
3094 desc
= open (fn
, O_RDWR
);
3096 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
3097 ? XSTRING (current_buffer
->filename
)->data
: 0,
3100 else /* Write to temporary name and rename if no errors */
3102 Lisp_Object temp_name
;
3103 temp_name
= Ffile_name_directory (filename
);
3105 if (!NILP (temp_name
))
3107 temp_name
= Fmake_temp_name (concat2 (temp_name
,
3108 build_string ("$$SAVE$$")));
3109 fname
= XSTRING (filename
)->data
;
3110 fn
= XSTRING (temp_name
)->data
;
3111 desc
= creat_copy_attrs (fname
, fn
);
3114 /* If we can't open the temporary file, try creating a new
3115 version of the original file. VMS "creat" creates a
3116 new version rather than truncating an existing file. */
3119 desc
= creat (fn
, 0666);
3120 #if 0 /* This can clobber an existing file and fail to replace it,
3121 if the user runs out of space. */
3124 /* We can't make a new version;
3125 try to truncate and rewrite existing version if any. */
3127 desc
= open (fn
, O_RDWR
);
3133 desc
= creat (fn
, 0666);
3138 O_WRONLY
| O_TRUNC
| O_CREAT
| buffer_file_type
,
3139 S_IREAD
| S_IWRITE
);
3140 #else /* not MSDOS */
3141 desc
= creat (fn
, auto_saving
? auto_save_mode_bits
: 0666);
3142 #endif /* not MSDOS */
3143 #endif /* not VMS */
3149 #ifdef CLASH_DETECTION
3151 if (!auto_saving
) unlock_file (visit_file
);
3153 #endif /* CLASH_DETECTION */
3154 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
3157 record_unwind_protect (close_file_unwind
, make_number (desc
));
3160 if (lseek (desc
, 0, 2) < 0)
3162 #ifdef CLASH_DETECTION
3163 if (!auto_saving
) unlock_file (visit_file
);
3164 #endif /* CLASH_DETECTION */
3165 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
3170 * Kludge Warning: The VMS C RTL likes to insert carriage returns
3171 * if we do writes that don't end with a carriage return. Furthermore
3172 * it cannot handle writes of more then 16K. The modified
3173 * version of "sys_write" in SYSDEP.C (see comment there) copes with
3174 * this EXCEPT for the last record (iff it doesn't end with a carriage
3175 * return). This implies that if your buffer doesn't end with a carriage
3176 * return, you get one free... tough. However it also means that if
3177 * we make two calls to sys_write (a la the following code) you can
3178 * get one at the gap as well. The easiest way to fix this (honest)
3179 * is to move the gap to the next newline (or the end of the buffer).
3184 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
3185 move_gap (find_next_newline (GPT
, 1));
3191 if (STRINGP (start
))
3193 failure
= 0 > a_write (desc
, XSTRING (start
)->data
,
3194 XSTRING (start
)->size
, 0, &annotations
);
3197 else if (XINT (start
) != XINT (end
))
3200 if (XINT (start
) < GPT
)
3202 register int end1
= XINT (end
);
3204 failure
= 0 > a_write (desc
, &FETCH_CHAR (tem
),
3205 min (GPT
, end1
) - tem
, tem
, &annotations
);
3206 nwritten
+= min (GPT
, end1
) - tem
;
3210 if (XINT (end
) > GPT
&& !failure
)
3213 tem
= max (tem
, GPT
);
3214 failure
= 0 > a_write (desc
, &FETCH_CHAR (tem
), XINT (end
) - tem
,
3216 nwritten
+= XINT (end
) - tem
;
3222 /* If file was empty, still need to write the annotations */
3223 failure
= 0 > a_write (desc
, "", 0, XINT (start
), &annotations
);
3231 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
3232 Disk full in NFS may be reported here. */
3233 /* mib says that closing the file will try to write as fast as NFS can do
3234 it, and that means the fsync here is not crucial for autosave files. */
3235 if (!auto_saving
&& fsync (desc
) < 0)
3236 failure
= 1, save_errno
= errno
;
3239 /* Spurious "file has changed on disk" warnings have been
3240 observed on Suns as well.
3241 It seems that `close' can change the modtime, under nfs.
3243 (This has supposedly been fixed in Sunos 4,
3244 but who knows about all the other machines with NFS?) */
3247 /* On VMS and APOLLO, must do the stat after the close
3248 since closing changes the modtime. */
3251 /* Recall that #if defined does not work on VMS. */
3258 /* NFS can report a write failure now. */
3259 if (close (desc
) < 0)
3260 failure
= 1, save_errno
= errno
;
3263 /* If we wrote to a temporary name and had no errors, rename to real name. */
3267 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
3275 /* Discard the unwind protect for close_file_unwind. */
3276 specpdl_ptr
= specpdl
+ count1
;
3277 /* Restore the original current buffer. */
3278 visit_file
= unbind_to (count
, visit_file
);
3280 #ifdef CLASH_DETECTION
3282 unlock_file (visit_file
);
3283 #endif /* CLASH_DETECTION */
3285 /* Do this before reporting IO error
3286 to avoid a "file has changed on disk" warning on
3287 next attempt to save. */
3289 current_buffer
->modtime
= st
.st_mtime
;
3292 error ("IO error writing %s: %s", fn
, strerror (save_errno
));
3296 current_buffer
->save_modified
= MODIFF
;
3297 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3298 current_buffer
->filename
= visit_file
;
3299 update_mode_lines
++;
3305 message ("Wrote %s", XSTRING (visit_file
)->data
);
3310 Lisp_Object
merge ();
3312 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
3313 "Return t if (car A) is numerically less than (car B).")
3317 return Flss (Fcar (a
), Fcar (b
));
3320 /* Build the complete list of annotations appropriate for writing out
3321 the text between START and END, by calling all the functions in
3322 write-region-annotate-functions and merging the lists they return.
3323 If one of these functions switches to a different buffer, we assume
3324 that buffer contains altered text. Therefore, the caller must
3325 make sure to restore the current buffer in all cases,
3326 as save-excursion would do. */
3329 build_annotations (start
, end
)
3330 Lisp_Object start
, end
;
3332 Lisp_Object annotations
;
3334 struct gcpro gcpro1
, gcpro2
;
3337 p
= Vwrite_region_annotate_functions
;
3338 GCPRO2 (annotations
, p
);
3341 struct buffer
*given_buffer
= current_buffer
;
3342 Vwrite_region_annotations_so_far
= annotations
;
3343 res
= call2 (Fcar (p
), start
, end
);
3344 /* If the function makes a different buffer current,
3345 assume that means this buffer contains altered text to be output.
3346 Reset START and END from the buffer bounds
3347 and discard all previous annotations because they should have
3348 been dealt with by this function. */
3349 if (current_buffer
!= given_buffer
)
3355 Flength (res
); /* Check basic validity of return value */
3356 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
3363 /* Write to descriptor DESC the LEN characters starting at ADDR,
3364 assuming they start at position POS in the buffer.
3365 Intersperse with them the annotations from *ANNOT
3366 (those which fall within the range of positions POS to POS + LEN),
3367 each at its appropriate position.
3369 Modify *ANNOT by discarding elements as we output them.
3370 The return value is negative in case of system call failure. */
3373 a_write (desc
, addr
, len
, pos
, annot
)
3375 register char *addr
;
3382 int lastpos
= pos
+ len
;
3384 while (NILP (*annot
) || CONSP (*annot
))
3386 tem
= Fcar_safe (Fcar (*annot
));
3387 if (INTEGERP (tem
) && XINT (tem
) >= pos
&& XFASTINT (tem
) <= lastpos
)
3388 nextpos
= XFASTINT (tem
);
3390 return e_write (desc
, addr
, lastpos
- pos
);
3393 if (0 > e_write (desc
, addr
, nextpos
- pos
))
3395 addr
+= nextpos
- pos
;
3398 tem
= Fcdr (Fcar (*annot
));
3401 if (0 > e_write (desc
, XSTRING (tem
)->data
, XSTRING (tem
)->size
))
3404 *annot
= Fcdr (*annot
);
3409 e_write (desc
, addr
, len
)
3411 register char *addr
;
3414 char buf
[16 * 1024];
3415 register char *p
, *end
;
3417 if (!EQ (current_buffer
->selective_display
, Qt
))
3418 return write (desc
, addr
, len
) - len
;
3422 end
= p
+ sizeof buf
;
3427 if (write (desc
, buf
, sizeof buf
) != sizeof buf
)
3436 if (write (desc
, buf
, p
- buf
) != p
- buf
)
3442 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
3443 Sverify_visited_file_modtime
, 1, 1, 0,
3444 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
3445 This means that the file has not been changed since it was visited or saved.")
3451 Lisp_Object handler
;
3453 CHECK_BUFFER (buf
, 0);
3456 if (XTYPE (b
->filename
) != Lisp_String
) return Qt
;
3457 if (b
->modtime
== 0) return Qt
;
3459 /* If the file name has special constructs in it,
3460 call the corresponding file handler. */
3461 handler
= Ffind_file_name_handler (b
->filename
,
3462 Qverify_visited_file_modtime
);
3463 if (!NILP (handler
))
3464 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
3466 if (stat (XSTRING (b
->filename
)->data
, &st
) < 0)
3468 /* If the file doesn't exist now and didn't exist before,
3469 we say that it isn't modified, provided the error is a tame one. */
3470 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
3475 if (st
.st_mtime
== b
->modtime
3476 /* If both are positive, accept them if they are off by one second. */
3477 || (st
.st_mtime
> 0 && b
->modtime
> 0
3478 && (st
.st_mtime
== b
->modtime
+ 1
3479 || st
.st_mtime
== b
->modtime
- 1)))
3484 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
3485 Sclear_visited_file_modtime
, 0, 0, 0,
3486 "Clear out records of last mod time of visited file.\n\
3487 Next attempt to save will certainly not complain of a discrepancy.")
3490 current_buffer
->modtime
= 0;
3494 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
3495 Svisited_file_modtime
, 0, 0, 0,
3496 "Return the current buffer's recorded visited file modification time.\n\
3497 The value is a list of the form (HIGH . LOW), like the time values\n\
3498 that `file-attributes' returns.")
3501 return long_to_cons (current_buffer
->modtime
);
3504 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
3505 Sset_visited_file_modtime
, 0, 1, 0,
3506 "Update buffer's recorded modification time from the visited file's time.\n\
3507 Useful if the buffer was not read from the file normally\n\
3508 or if the file itself has been changed for some known benign reason.\n\
3509 An argument specifies the modification time value to use\n\
3510 \(instead of that of the visited file), in the form of a list\n\
3511 \(HIGH . LOW) or (HIGH LOW).")
3513 Lisp_Object time_list
;
3515 if (!NILP (time_list
))
3516 current_buffer
->modtime
= cons_to_long (time_list
);
3519 register Lisp_Object filename
;
3521 Lisp_Object handler
;
3523 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
3525 /* If the file name has special constructs in it,
3526 call the corresponding file handler. */
3527 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
3528 if (!NILP (handler
))
3529 /* The handler can find the file name the same way we did. */
3530 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
3531 else if (stat (XSTRING (filename
)->data
, &st
) >= 0)
3532 current_buffer
->modtime
= st
.st_mtime
;
3542 message ("Autosaving...error for %s", XSTRING (current_buffer
->name
)->data
);
3543 Fsleep_for (make_number (1), Qnil
);
3544 message ("Autosaving...error!for %s", XSTRING (current_buffer
->name
)->data
);
3545 Fsleep_for (make_number (1), Qnil
);
3546 message ("Autosaving...error for %s", XSTRING (current_buffer
->name
)->data
);
3547 Fsleep_for (make_number (1), Qnil
);
3557 /* Get visited file's mode to become the auto save file's mode. */
3558 if (stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
3559 /* But make sure we can overwrite it later! */
3560 auto_save_mode_bits
= st
.st_mode
| 0600;
3562 auto_save_mode_bits
= 0666;
3565 Fwrite_region (Qnil
, Qnil
,
3566 current_buffer
->auto_save_file_name
,
3571 do_auto_save_unwind (desc
) /* used as unwind-protect function */
3574 close (XINT (desc
));
3578 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
3579 "Auto-save all buffers that need it.\n\
3580 This is all buffers that have auto-saving enabled\n\
3581 and are changed since last auto-saved.\n\
3582 Auto-saving writes the buffer into a file\n\
3583 so that your editing is not lost if the system crashes.\n\
3584 This file is not the file you visited; that changes only when you save.\n\
3585 Normally we run the normal hook `auto-save-hook' before saving.\n\n\
3586 Non-nil first argument means do not print any message if successful.\n\
3587 Non-nil second argument means save only current buffer.")
3588 (no_message
, current_only
)
3589 Lisp_Object no_message
, current_only
;
3591 struct buffer
*old
= current_buffer
, *b
;
3592 Lisp_Object tail
, buf
;
3594 char *omessage
= echo_area_glyphs
;
3595 int omessage_length
= echo_area_glyphs_length
;
3596 extern int minibuf_level
;
3597 int do_handled_files
;
3600 int count
= specpdl_ptr
- specpdl
;
3603 /* Ordinarily don't quit within this function,
3604 but don't make it impossible to quit (in case we get hung in I/O). */
3608 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
3609 point to non-strings reached from Vbuffer_alist. */
3615 if (!NILP (Vrun_hooks
))
3616 call1 (Vrun_hooks
, intern ("auto-save-hook"));
3618 if (STRINGP (Vauto_save_list_file_name
))
3621 listdesc
= open (XSTRING (Vauto_save_list_file_name
)->data
,
3622 O_WRONLY
| O_TRUNC
| O_CREAT
| O_TEXT
,
3623 S_IREAD
| S_IWRITE
);
3624 #else /* not MSDOS */
3625 listdesc
= creat (XSTRING (Vauto_save_list_file_name
)->data
, 0666);
3626 #endif /* not MSDOS */
3631 /* Arrange to close that file whether or not we get an error. */
3633 record_unwind_protect (do_auto_save_unwind
, make_number (listdesc
));
3635 /* First, save all files which don't have handlers. If Emacs is
3636 crashing, the handlers may tweak what is causing Emacs to crash
3637 in the first place, and it would be a shame if Emacs failed to
3638 autosave perfectly ordinary files because it couldn't handle some
3640 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
3641 for (tail
= Vbuffer_alist
; XGCTYPE (tail
) == Lisp_Cons
;
3642 tail
= XCONS (tail
)->cdr
)
3644 buf
= XCONS (XCONS (tail
)->car
)->cdr
;
3647 /* Record all the buffers that have auto save mode
3648 in the special file that lists them. */
3649 if (XTYPE (b
->auto_save_file_name
) == Lisp_String
3650 && listdesc
>= 0 && do_handled_files
== 0)
3652 write (listdesc
, XSTRING (b
->auto_save_file_name
)->data
,
3653 XSTRING (b
->auto_save_file_name
)->size
);
3654 write (listdesc
, "\n", 1);
3657 if (!NILP (current_only
)
3658 && b
!= current_buffer
)
3661 /* Check for auto save enabled
3662 and file changed since last auto save
3663 and file changed since last real save. */
3664 if (XTYPE (b
->auto_save_file_name
) == Lisp_String
3665 && b
->save_modified
< BUF_MODIFF (b
)
3666 && b
->auto_save_modified
< BUF_MODIFF (b
)
3667 /* -1 means we've turned off autosaving for a while--see below. */
3668 && XINT (b
->save_length
) >= 0
3669 && (do_handled_files
3670 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
3673 EMACS_TIME before_time
, after_time
;
3675 EMACS_GET_TIME (before_time
);
3677 /* If we had a failure, don't try again for 20 minutes. */
3678 if (b
->auto_save_failure_time
>= 0
3679 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
3682 if ((XFASTINT (b
->save_length
) * 10
3683 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
3684 /* A short file is likely to change a large fraction;
3685 spare the user annoying messages. */
3686 && XFASTINT (b
->save_length
) > 5000
3687 /* These messages are frequent and annoying for `*mail*'. */
3688 && !EQ (b
->filename
, Qnil
)
3689 && NILP (no_message
))
3691 /* It has shrunk too much; turn off auto-saving here. */
3692 message ("Buffer %s has shrunk a lot; auto save turned off there",
3693 XSTRING (b
->name
)->data
);
3694 /* Turn off auto-saving until there's a real save,
3695 and prevent any more warnings. */
3696 XSET (b
->save_length
, Lisp_Int
, -1);
3697 Fsleep_for (make_number (1), Qnil
);
3700 set_buffer_internal (b
);
3701 if (!auto_saved
&& NILP (no_message
))
3702 message1 ("Auto-saving...");
3703 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
3705 b
->auto_save_modified
= BUF_MODIFF (b
);
3706 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3707 set_buffer_internal (old
);
3709 EMACS_GET_TIME (after_time
);
3711 /* If auto-save took more than 60 seconds,
3712 assume it was an NFS failure that got a timeout. */
3713 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
3714 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
3718 /* Prevent another auto save till enough input events come in. */
3719 record_auto_save ();
3721 if (auto_saved
&& NILP (no_message
))
3724 message2 (omessage
, omessage_length
);
3726 message1 ("Auto-saving...done");
3732 unbind_to (count
, Qnil
);
3736 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
3737 Sset_buffer_auto_saved
, 0, 0, 0,
3738 "Mark current buffer as auto-saved with its current text.\n\
3739 No auto-save file will be written until the buffer changes again.")
3742 current_buffer
->auto_save_modified
= MODIFF
;
3743 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3744 current_buffer
->auto_save_failure_time
= -1;
3748 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
3749 Sclear_buffer_auto_save_failure
, 0, 0, 0,
3750 "Clear any record of a recent auto-save failure in the current buffer.")
3753 current_buffer
->auto_save_failure_time
= -1;
3757 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
3759 "Return t if buffer has been auto-saved since last read in or saved.")
3762 return (current_buffer
->save_modified
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
3765 /* Reading and completing file names */
3766 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
3768 /* In the string VAL, change each $ to $$ and return the result. */
3771 double_dollars (val
)
3774 register unsigned char *old
, *new;
3778 osize
= XSTRING (val
)->size
;
3779 /* Quote "$" as "$$" to get it past substitute-in-file-name */
3780 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
3781 if (*old
++ == '$') count
++;
3784 old
= XSTRING (val
)->data
;
3785 val
= Fmake_string (make_number (osize
+ count
), make_number (0));
3786 new = XSTRING (val
)->data
;
3787 for (n
= osize
; n
> 0; n
--)
3800 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
3802 "Internal subroutine for read-file-name. Do not call this.")
3803 (string
, dir
, action
)
3804 Lisp_Object string
, dir
, action
;
3805 /* action is nil for complete, t for return list of completions,
3806 lambda for verify final value */
3808 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
3810 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3817 /* No need to protect ACTION--we only compare it with t and nil. */
3818 GCPRO4 (string
, realdir
, name
, specdir
);
3820 if (XSTRING (string
)->size
== 0)
3822 if (EQ (action
, Qlambda
))
3830 orig_string
= string
;
3831 string
= Fsubstitute_in_file_name (string
);
3832 changed
= NILP (Fstring_equal (string
, orig_string
));
3833 name
= Ffile_name_nondirectory (string
);
3834 val
= Ffile_name_directory (string
);
3836 realdir
= Fexpand_file_name (val
, realdir
);
3841 specdir
= Ffile_name_directory (string
);
3842 val
= Ffile_name_completion (name
, realdir
);
3844 if (XTYPE (val
) != Lisp_String
)
3847 return double_dollars (string
);
3851 if (!NILP (specdir
))
3852 val
= concat2 (specdir
, val
);
3854 return double_dollars (val
);
3857 #endif /* not VMS */
3861 if (EQ (action
, Qt
))
3862 return Ffile_name_all_completions (name
, realdir
);
3863 /* Only other case actually used is ACTION = lambda */
3865 /* Supposedly this helps commands such as `cd' that read directory names,
3866 but can someone explain how it helps them? -- RMS */
3867 if (XSTRING (name
)->size
== 0)
3870 return Ffile_exists_p (string
);
3873 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
3874 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
3875 Value is not expanded---you must call `expand-file-name' yourself.\n\
3876 Default name to DEFAULT if user enters a null string.\n\
3877 (If DEFAULT is omitted, the visited file name is used.)\n\
3878 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
3879 Non-nil and non-t means also require confirmation after completion.\n\
3880 Fifth arg INITIAL specifies text to start with.\n\
3881 DIR defaults to current buffer's directory default.")
3882 (prompt
, dir
, defalt
, mustmatch
, initial
)
3883 Lisp_Object prompt
, dir
, defalt
, mustmatch
, initial
;
3885 Lisp_Object val
, insdef
, insdef1
, tem
;
3886 struct gcpro gcpro1
, gcpro2
;
3887 register char *homedir
;
3891 dir
= current_buffer
->directory
;
3893 defalt
= current_buffer
->filename
;
3895 /* If dir starts with user's homedir, change that to ~. */
3896 homedir
= (char *) egetenv ("HOME");
3898 && XTYPE (dir
) == Lisp_String
3899 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
3900 && XSTRING (dir
)->data
[strlen (homedir
)] == '/')
3902 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
3903 XSTRING (dir
)->size
- strlen (homedir
) + 1);
3904 XSTRING (dir
)->data
[0] = '~';
3907 if (insert_default_directory
)
3910 if (!NILP (initial
))
3912 Lisp_Object args
[2], pos
;
3916 insdef
= Fconcat (2, args
);
3917 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
3918 insdef1
= Fcons (double_dollars (insdef
), pos
);
3921 insdef1
= double_dollars (insdef
);
3923 else if (!NILP (initial
))
3926 insdef1
= Fcons (double_dollars (insdef
), 0);
3929 insdef
= Qnil
, insdef1
= Qnil
;
3932 count
= specpdl_ptr
- specpdl
;
3933 specbind (intern ("completion-ignore-case"), Qt
);
3936 GCPRO2 (insdef
, defalt
);
3937 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
3938 dir
, mustmatch
, insdef1
,
3939 Qfile_name_history
);
3942 unbind_to (count
, Qnil
);
3947 error ("No file name specified");
3948 tem
= Fstring_equal (val
, insdef
);
3949 if (!NILP (tem
) && !NILP (defalt
))
3951 if (XSTRING (val
)->size
== 0 && NILP (insdef
))
3956 error ("No default file name");
3958 return Fsubstitute_in_file_name (val
);
3961 #if 0 /* Old version */
3962 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
3963 /* Don't confuse make-docfile by having two doc strings for this function.
3964 make-docfile does not pay attention to #if, for good reason! */
3966 (prompt
, dir
, defalt
, mustmatch
, initial
)
3967 Lisp_Object prompt
, dir
, defalt
, mustmatch
, initial
;
3969 Lisp_Object val
, insdef
, tem
;
3970 struct gcpro gcpro1
, gcpro2
;
3971 register char *homedir
;
3975 dir
= current_buffer
->directory
;
3977 defalt
= current_buffer
->filename
;
3979 /* If dir starts with user's homedir, change that to ~. */
3980 homedir
= (char *) egetenv ("HOME");
3982 && XTYPE (dir
) == Lisp_String
3983 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
3984 && XSTRING (dir
)->data
[strlen (homedir
)] == '/')
3986 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
3987 XSTRING (dir
)->size
- strlen (homedir
) + 1);
3988 XSTRING (dir
)->data
[0] = '~';
3991 if (!NILP (initial
))
3993 else if (insert_default_directory
)
3996 insdef
= build_string ("");
3999 count
= specpdl_ptr
- specpdl
;
4000 specbind (intern ("completion-ignore-case"), Qt
);
4003 GCPRO2 (insdef
, defalt
);
4004 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
4006 insert_default_directory
? insdef
: Qnil
,
4007 Qfile_name_history
);
4010 unbind_to (count
, Qnil
);
4015 error ("No file name specified");
4016 tem
= Fstring_equal (val
, insdef
);
4017 if (!NILP (tem
) && !NILP (defalt
))
4019 return Fsubstitute_in_file_name (val
);
4021 #endif /* Old version */
4025 Qexpand_file_name
= intern ("expand-file-name");
4026 Qdirectory_file_name
= intern ("directory-file-name");
4027 Qfile_name_directory
= intern ("file-name-directory");
4028 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
4029 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
4030 Qfile_name_as_directory
= intern ("file-name-as-directory");
4031 Qcopy_file
= intern ("copy-file");
4032 Qmake_directory_internal
= intern ("make-directory-internal");
4033 Qdelete_directory
= intern ("delete-directory");
4034 Qdelete_file
= intern ("delete-file");
4035 Qrename_file
= intern ("rename-file");
4036 Qadd_name_to_file
= intern ("add-name-to-file");
4037 Qmake_symbolic_link
= intern ("make-symbolic-link");
4038 Qfile_exists_p
= intern ("file-exists-p");
4039 Qfile_executable_p
= intern ("file-executable-p");
4040 Qfile_readable_p
= intern ("file-readable-p");
4041 Qfile_symlink_p
= intern ("file-symlink-p");
4042 Qfile_writable_p
= intern ("file-writable-p");
4043 Qfile_directory_p
= intern ("file-directory-p");
4044 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
4045 Qfile_modes
= intern ("file-modes");
4046 Qset_file_modes
= intern ("set-file-modes");
4047 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
4048 Qinsert_file_contents
= intern ("insert-file-contents");
4049 Qwrite_region
= intern ("write-region");
4050 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
4051 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
4053 staticpro (&Qexpand_file_name
);
4054 staticpro (&Qdirectory_file_name
);
4055 staticpro (&Qfile_name_directory
);
4056 staticpro (&Qfile_name_nondirectory
);
4057 staticpro (&Qunhandled_file_name_directory
);
4058 staticpro (&Qfile_name_as_directory
);
4059 staticpro (&Qcopy_file
);
4060 staticpro (&Qmake_directory_internal
);
4061 staticpro (&Qdelete_directory
);
4062 staticpro (&Qdelete_file
);
4063 staticpro (&Qrename_file
);
4064 staticpro (&Qadd_name_to_file
);
4065 staticpro (&Qmake_symbolic_link
);
4066 staticpro (&Qfile_exists_p
);
4067 staticpro (&Qfile_executable_p
);
4068 staticpro (&Qfile_readable_p
);
4069 staticpro (&Qfile_symlink_p
);
4070 staticpro (&Qfile_writable_p
);
4071 staticpro (&Qfile_directory_p
);
4072 staticpro (&Qfile_accessible_directory_p
);
4073 staticpro (&Qfile_modes
);
4074 staticpro (&Qset_file_modes
);
4075 staticpro (&Qfile_newer_than_file_p
);
4076 staticpro (&Qinsert_file_contents
);
4077 staticpro (&Qwrite_region
);
4078 staticpro (&Qverify_visited_file_modtime
);
4080 Qfile_name_history
= intern ("file-name-history");
4081 Fset (Qfile_name_history
, Qnil
);
4082 staticpro (&Qfile_name_history
);
4084 Qfile_error
= intern ("file-error");
4085 staticpro (&Qfile_error
);
4086 Qfile_already_exists
= intern("file-already-exists");
4087 staticpro (&Qfile_already_exists
);
4090 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
4091 staticpro (&Qfind_buffer_file_type
);
4094 Qcar_less_than_car
= intern ("car-less-than-car");
4095 staticpro (&Qcar_less_than_car
);
4097 Fput (Qfile_error
, Qerror_conditions
,
4098 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
4099 Fput (Qfile_error
, Qerror_message
,
4100 build_string ("File error"));
4102 Fput (Qfile_already_exists
, Qerror_conditions
,
4103 Fcons (Qfile_already_exists
,
4104 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
4105 Fput (Qfile_already_exists
, Qerror_message
,
4106 build_string ("File already exists"));
4108 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
4109 "*Non-nil means when reading a filename start with default dir in minibuffer.");
4110 insert_default_directory
= 1;
4112 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
4113 "*Non-nil means write new files with record format `stmlf'.\n\
4114 nil means use format `var'. This variable is meaningful only on VMS.");
4115 vms_stmlf_recfm
= 0;
4117 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
4118 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
4119 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
4122 The first argument given to HANDLER is the name of the I/O primitive\n\
4123 to be handled; the remaining arguments are the arguments that were\n\
4124 passed to that primitive. For example, if you do\n\
4125 (file-exists-p FILENAME)\n\
4126 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
4127 (funcall HANDLER 'file-exists-p FILENAME)\n\
4128 The function `find-file-name-handler' checks this list for a handler\n\
4129 for its argument.");
4130 Vfile_name_handler_alist
= Qnil
;
4132 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
4133 "A list of functions to be called at the end of `insert-file-contents'.\n\
4134 Each is passed one argument, the number of bytes inserted. It should return\n\
4135 the new byte count, and leave point the same. If `insert-file-contents' is\n\
4136 intercepted by a handler from `file-name-handler-alist', that handler is\n\
4137 responsible for calling the after-insert-file-functions if appropriate.");
4138 Vafter_insert_file_functions
= Qnil
;
4140 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
4141 "A list of functions to be called at the start of `write-region'.\n\
4142 Each is passed two arguments, START and END as for `write-region'. It should\n\
4143 return a list of pairs (POSITION . STRING) of strings to be effectively\n\
4144 inserted at the specified positions of the file being written (1 means to\n\
4145 insert before the first byte written). The POSITIONs must be sorted into\n\
4146 increasing order. If there are several functions in the list, the several\n\
4147 lists are merged destructively.");
4148 Vwrite_region_annotate_functions
= Qnil
;
4150 DEFVAR_LISP ("write-region-annotations-so-far",
4151 &Vwrite_region_annotations_so_far
,
4152 "When an annotation function is called, this holds the previous annotations.\n\
4153 These are the annotations made by other annotation functions\n\
4154 that were already called. See also `write-region-annotate-functions'.");
4155 Vwrite_region_annotations_so_far
= Qnil
;
4157 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
4158 "A list of file name handlers that temporarily should not be used.\n\
4159 This applies only to the operation `inhibit-file-name-operation'.");
4160 Vinhibit_file_name_handlers
= Qnil
;
4162 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
4163 "The operation for which `inhibit-file-name-handlers' is applicable.");
4164 Vinhibit_file_name_operation
= Qnil
;
4166 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
4167 "File name in which we write a list of all auto save file names.");
4168 Vauto_save_list_file_name
= Qnil
;
4170 defsubr (&Sfind_file_name_handler
);
4171 defsubr (&Sfile_name_directory
);
4172 defsubr (&Sfile_name_nondirectory
);
4173 defsubr (&Sunhandled_file_name_directory
);
4174 defsubr (&Sfile_name_as_directory
);
4175 defsubr (&Sdirectory_file_name
);
4176 defsubr (&Smake_temp_name
);
4177 defsubr (&Sexpand_file_name
);
4178 defsubr (&Ssubstitute_in_file_name
);
4179 defsubr (&Scopy_file
);
4180 defsubr (&Smake_directory_internal
);
4181 defsubr (&Sdelete_directory
);
4182 defsubr (&Sdelete_file
);
4183 defsubr (&Srename_file
);
4184 defsubr (&Sadd_name_to_file
);
4186 defsubr (&Smake_symbolic_link
);
4187 #endif /* S_IFLNK */
4189 defsubr (&Sdefine_logical_name
);
4192 defsubr (&Ssysnetunam
);
4193 #endif /* HPUX_NET */
4194 defsubr (&Sfile_name_absolute_p
);
4195 defsubr (&Sfile_exists_p
);
4196 defsubr (&Sfile_executable_p
);
4197 defsubr (&Sfile_readable_p
);
4198 defsubr (&Sfile_writable_p
);
4199 defsubr (&Sfile_symlink_p
);
4200 defsubr (&Sfile_directory_p
);
4201 defsubr (&Sfile_accessible_directory_p
);
4202 defsubr (&Sfile_modes
);
4203 defsubr (&Sset_file_modes
);
4204 defsubr (&Sset_default_file_modes
);
4205 defsubr (&Sdefault_file_modes
);
4206 defsubr (&Sfile_newer_than_file_p
);
4207 defsubr (&Sinsert_file_contents
);
4208 defsubr (&Swrite_region
);
4209 defsubr (&Scar_less_than_car
);
4210 defsubr (&Sverify_visited_file_modtime
);
4211 defsubr (&Sclear_visited_file_modtime
);
4212 defsubr (&Svisited_file_modtime
);
4213 defsubr (&Sset_visited_file_modtime
);
4214 defsubr (&Sdo_auto_save
);
4215 defsubr (&Sset_buffer_auto_saved
);
4216 defsubr (&Sclear_buffer_auto_save_failure
);
4217 defsubr (&Srecent_auto_save_p
);
4219 defsubr (&Sread_file_name_internal
);
4220 defsubr (&Sread_file_name
);
4223 defsubr (&Sunix_sync
);