1 /* File IO for GNU Emacs.
2 Copyright (C) 1985, 1986, 1987, 1988, 1993, 1994 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
22 #include <sys/types.h>
29 #if !defined (S_ISLNK) && defined (S_IFLNK)
30 # define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
33 #if !defined (S_ISREG) && defined (S_IFREG)
34 # define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
45 #include <sys/param.h>
63 extern char *strerror ();
78 #include "intervals.h"
104 #define min(a, b) ((a) < (b) ? (a) : (b))
105 #define max(a, b) ((a) > (b) ? (a) : (b))
107 /* Nonzero during writing of auto-save files */
110 /* Set by auto_save_1 to mode of original file so Fwrite_region will create
111 a new file with the same mode as the original */
112 int auto_save_mode_bits
;
114 /* Alist of elements (REGEXP . HANDLER) for file names
115 whose I/O is done with a special handler. */
116 Lisp_Object Vfile_name_handler_alist
;
118 /* Functions to be called to process text properties in inserted file. */
119 Lisp_Object Vafter_insert_file_functions
;
121 /* Functions to be called to create text property annotations for file. */
122 Lisp_Object Vwrite_region_annotate_functions
;
124 /* Nonzero means, when reading a filename in the minibuffer,
125 start out by inserting the default directory into the minibuffer. */
126 int insert_default_directory
;
128 /* On VMS, nonzero means write new files with record format stmlf.
129 Zero means use var format. */
132 static Lisp_Object Vinhibit_file_name_handlers
;
134 Lisp_Object Qfile_error
, Qfile_already_exists
;
136 Lisp_Object Qfile_name_history
;
138 Lisp_Object Qcar_less_than_car
;
140 report_file_error (string
, data
)
144 Lisp_Object errstring
;
146 errstring
= build_string (strerror (errno
));
148 /* System error messages are capitalized. Downcase the initial
149 unless it is followed by a slash. */
150 if (XSTRING (errstring
)->data
[1] != '/')
151 XSTRING (errstring
)->data
[0] = DOWNCASE (XSTRING (errstring
)->data
[0]);
154 Fsignal (Qfile_error
,
155 Fcons (build_string (string
), Fcons (errstring
, data
)));
158 close_file_unwind (fd
)
161 close (XFASTINT (fd
));
164 /* Restore point, having saved it as a marker. */
166 restore_point_unwind (location
)
167 Lisp_Object location
;
169 SET_PT (marker_position (location
));
170 Fset_marker (location
, Qnil
, Qnil
);
173 Lisp_Object Qexpand_file_name
;
174 Lisp_Object Qdirectory_file_name
;
175 Lisp_Object Qfile_name_directory
;
176 Lisp_Object Qfile_name_nondirectory
;
177 Lisp_Object Qunhandled_file_name_directory
;
178 Lisp_Object Qfile_name_as_directory
;
179 Lisp_Object Qcopy_file
;
180 Lisp_Object Qmake_directory
;
181 Lisp_Object Qdelete_directory
;
182 Lisp_Object Qdelete_file
;
183 Lisp_Object Qrename_file
;
184 Lisp_Object Qadd_name_to_file
;
185 Lisp_Object Qmake_symbolic_link
;
186 Lisp_Object Qfile_exists_p
;
187 Lisp_Object Qfile_executable_p
;
188 Lisp_Object Qfile_readable_p
;
189 Lisp_Object Qfile_symlink_p
;
190 Lisp_Object Qfile_writable_p
;
191 Lisp_Object Qfile_directory_p
;
192 Lisp_Object Qfile_accessible_directory_p
;
193 Lisp_Object Qfile_modes
;
194 Lisp_Object Qset_file_modes
;
195 Lisp_Object Qfile_newer_than_file_p
;
196 Lisp_Object Qinsert_file_contents
;
197 Lisp_Object Qwrite_region
;
198 Lisp_Object Qverify_visited_file_modtime
;
199 Lisp_Object Qset_visited_file_modtime
;
201 DEFUN ("find-file-name-handler", Ffind_file_name_handler
, Sfind_file_name_handler
, 1, 1, 0,
202 "Return FILENAME's handler function, if its syntax is handled specially.\n\
203 Otherwise, return nil.\n\
204 A file name is handled if one of the regular expressions in\n\
205 `file-name-handler-alist' matches it.\n\n\
206 If FILENAME is a member of `inhibit-file-name-handlers',\n\
207 then its handler is not run. This is lets handlers\n\
208 use the standard functions without calling themselves recursively.")
210 Lisp_Object filename
;
212 /* This function must not munge the match data. */
215 CHECK_STRING (filename
, 0);
217 if (! NILP (Vinhibit_file_name_handlers
))
220 for (tail
= Vinhibit_file_name_handlers
; CONSP (tail
);
221 tail
= XCONS (tail
)->cdr
)
224 tem
= Fstring_equal (tail
, filename
);
230 for (chain
= Vfile_name_handler_alist
; XTYPE (chain
) == Lisp_Cons
;
231 chain
= XCONS (chain
)->cdr
)
234 elt
= XCONS (chain
)->car
;
235 if (XTYPE (elt
) == Lisp_Cons
)
238 string
= XCONS (elt
)->car
;
239 if (XTYPE (string
) == Lisp_String
240 && fast_string_match (string
, filename
) >= 0)
241 return XCONS (elt
)->cdr
;
249 DEFUN ("file-name-directory", Ffile_name_directory
, Sfile_name_directory
,
251 "Return the directory component in file name NAME.\n\
252 Return nil if NAME does not include a directory.\n\
253 Otherwise return a directory spec.\n\
254 Given a Unix syntax file name, returns a string ending in slash;\n\
255 on VMS, perhaps instead a string ending in `:', `]' or `>'.")
259 register unsigned char *beg
;
260 register unsigned char *p
;
263 CHECK_STRING (file
, 0);
265 /* If the file name has special constructs in it,
266 call the corresponding file handler. */
267 handler
= Ffind_file_name_handler (file
);
269 return call2 (handler
, Qfile_name_directory
, file
);
271 #ifdef FILE_SYSTEM_CASE
272 file
= FILE_SYSTEM_CASE (file
);
274 beg
= XSTRING (file
)->data
;
275 p
= beg
+ XSTRING (file
)->size
;
277 while (p
!= beg
&& p
[-1] != '/'
279 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
289 /* Expansion of "c:" to drive and default directory. */
290 if (p
== beg
+ 2 && beg
[1] == ':')
292 int drive
= (*beg
) - 'a';
293 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
294 unsigned char *res
= alloca (MAXPATHLEN
+ 5);
295 if (getdefdir (drive
+ 1, res
+ 2))
297 res
[0] = drive
+ 'a';
299 if (res
[strlen (res
) - 1] != '/')
302 p
= beg
+ strlen (beg
);
306 return make_string (beg
, p
- beg
);
309 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory
, Sfile_name_nondirectory
,
311 "Return file name NAME sans its directory.\n\
312 For example, in a Unix-syntax file name,\n\
313 this is everything after the last slash,\n\
314 or the entire name if it contains no slash.")
318 register unsigned char *beg
, *p
, *end
;
321 CHECK_STRING (file
, 0);
323 /* If the file name has special constructs in it,
324 call the corresponding file handler. */
325 handler
= Ffind_file_name_handler (file
);
327 return call2 (handler
, Qfile_name_nondirectory
, file
);
329 beg
= XSTRING (file
)->data
;
330 end
= p
= beg
+ XSTRING (file
)->size
;
332 while (p
!= beg
&& p
[-1] != '/'
334 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
341 return make_string (p
, end
- p
);
344 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory
, Sunhandled_file_name_directory
, 1, 1, 0,
345 "Return a directly usable directory name somehow associated with FILENAME.\n\
346 A `directly usable' directory name is one that may be used without the\n\
347 intervention of any file handler.\n\
348 If FILENAME is a directly usable file itself, return\n\
349 (file-name-directory FILENAME).\n\
350 The `call-process' and `start-process' functions use this function to\n\
351 get a current directory to run processes in.")
353 Lisp_Object filename
;
357 /* If the file name has special constructs in it,
358 call the corresponding file handler. */
359 handler
= Ffind_file_name_handler (filename
);
361 return call2 (handler
, Qunhandled_file_name_directory
, filename
);
363 return Ffile_name_directory (filename
);
368 file_name_as_directory (out
, in
)
371 int size
= strlen (in
) - 1;
376 /* Is it already a directory string? */
377 if (in
[size
] == ':' || in
[size
] == ']' || in
[size
] == '>')
379 /* Is it a VMS directory file name? If so, hack VMS syntax. */
380 else if (! index (in
, '/')
381 && ((size
> 3 && ! strcmp (&in
[size
- 3], ".DIR"))
382 || (size
> 3 && ! strcmp (&in
[size
- 3], ".dir"))
383 || (size
> 5 && (! strncmp (&in
[size
- 5], ".DIR", 4)
384 || ! strncmp (&in
[size
- 5], ".dir", 4))
385 && (in
[size
- 1] == '.' || in
[size
- 1] == ';')
386 && in
[size
] == '1')))
388 register char *p
, *dot
;
392 dir:x.dir --> dir:[x]
393 dir:[x]y.dir --> dir:[x.y] */
395 while (p
!= in
&& *p
!= ':' && *p
!= '>' && *p
!= ']') p
--;
398 strncpy (out
, in
, p
- in
);
417 dot
= index (p
, '.');
420 /* blindly remove any extension */
421 size
= strlen (out
) + (dot
- p
);
422 strncat (out
, p
, dot
- p
);
433 /* For Unix syntax, Append a slash if necessary */
435 if (out
[size
] != ':' && out
[size
] != '/')
437 if (out
[size
] != '/')
444 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
445 Sfile_name_as_directory
, 1, 1, 0,
446 "Return a string representing file FILENAME interpreted as a directory.\n\
447 This operation exists because a directory is also a file, but its name as\n\
448 a directory is different from its name as a file.\n\
449 The result can be used as the value of `default-directory'\n\
450 or passed as second argument to `expand-file-name'.\n\
451 For a Unix-syntax file name, just appends a slash.\n\
452 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
459 CHECK_STRING (file
, 0);
463 /* If the file name has special constructs in it,
464 call the corresponding file handler. */
465 handler
= Ffind_file_name_handler (file
);
467 return call2 (handler
, Qfile_name_as_directory
, file
);
469 buf
= (char *) alloca (XSTRING (file
)->size
+ 10);
470 return build_string (file_name_as_directory (buf
, XSTRING (file
)->data
));
474 * Convert from directory name to filename.
476 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
477 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
478 * On UNIX, it's simple: just make sure there is a terminating /
480 * Value is nonzero if the string output is different from the input.
483 directory_file_name (src
, dst
)
491 struct FAB fab
= cc$rms_fab
;
492 struct NAM nam
= cc$rms_nam
;
493 char esa
[NAM$C_MAXRSS
];
498 if (! index (src
, '/')
499 && (src
[slen
- 1] == ']'
500 || src
[slen
- 1] == ':'
501 || src
[slen
- 1] == '>'))
503 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
505 fab
.fab$b_fns
= slen
;
506 fab
.fab$l_nam
= &nam
;
507 fab
.fab$l_fop
= FAB$M_NAM
;
510 nam
.nam$b_ess
= sizeof esa
;
511 nam
.nam$b_nop
|= NAM$M_SYNCHK
;
513 /* We call SYS$PARSE to handle such things as [--] for us. */
514 if (SYS$
PARSE(&fab
, 0, 0) == RMS$_NORMAL
)
516 slen
= nam
.nam$b_esl
;
517 if (esa
[slen
- 1] == ';' && esa
[slen
- 2] == '.')
522 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
524 /* what about when we have logical_name:???? */
525 if (src
[slen
- 1] == ':')
526 { /* Xlate logical name and see what we get */
527 ptr
= strcpy (dst
, src
); /* upper case for getenv */
530 if ('a' <= *ptr
&& *ptr
<= 'z')
534 dst
[slen
- 1] = 0; /* remove colon */
535 if (!(src
= egetenv (dst
)))
537 /* should we jump to the beginning of this procedure?
538 Good points: allows us to use logical names that xlate
540 Bad points: can be a problem if we just translated to a device
542 For now, I'll punt and always expect VMS names, and hope for
545 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
546 { /* no recursion here! */
552 { /* not a directory spec */
557 bracket
= src
[slen
- 1];
559 /* If bracket is ']' or '>', bracket - 2 is the corresponding
561 ptr
= index (src
, bracket
- 2);
563 { /* no opening bracket */
567 if (!(rptr
= rindex (src
, '.')))
570 strncpy (dst
, src
, slen
);
574 dst
[slen
++] = bracket
;
579 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
580 then translate the device and recurse. */
581 if (dst
[slen
- 1] == ':'
582 && dst
[slen
- 2] != ':' /* skip decnet nodes */
583 && strcmp(src
+ slen
, "[000000]") == 0)
585 dst
[slen
- 1] = '\0';
586 if ((ptr
= egetenv (dst
))
587 && (rlen
= strlen (ptr
) - 1) > 0
588 && (ptr
[rlen
] == ']' || ptr
[rlen
] == '>')
589 && ptr
[rlen
- 1] == '.')
591 char * buf
= (char *) alloca (strlen (ptr
) + 1);
595 return directory_file_name (buf
, dst
);
600 strcat (dst
, "[000000]");
604 rlen
= strlen (rptr
) - 1;
605 strncat (dst
, rptr
, rlen
);
606 dst
[slen
+ rlen
] = '\0';
607 strcat (dst
, ".DIR.1");
611 /* Process as Unix format: just remove any final slash.
612 But leave "/" unchanged; do not change it to "". */
615 && dst
[slen
- 1] == '/'
617 && dst
[slen
- 2] != ':'
624 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
626 "Returns the file name of the directory named DIR.\n\
627 This is the name of the file that holds the data for the directory DIR.\n\
628 This operation exists because a directory is also a file, but its name as\n\
629 a directory is different from its name as a file.\n\
630 In Unix-syntax, this function just removes the final slash.\n\
631 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
632 it returns a file name such as \"[X]Y.DIR.1\".")
634 Lisp_Object directory
;
639 CHECK_STRING (directory
, 0);
641 if (NILP (directory
))
644 /* If the file name has special constructs in it,
645 call the corresponding file handler. */
646 handler
= Ffind_file_name_handler (directory
);
648 return call2 (handler
, Qdirectory_file_name
, directory
);
651 /* 20 extra chars is insufficient for VMS, since we might perform a
652 logical name translation. an equivalence string can be up to 255
653 chars long, so grab that much extra space... - sss */
654 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20 + 255);
656 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20);
658 directory_file_name (XSTRING (directory
)->data
, buf
);
659 return build_string (buf
);
662 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
663 "Generate temporary file name (string) starting with PREFIX (a string).\n\
664 The Emacs process number forms part of the result,\n\
665 so there is no danger of generating a name being used by another process.")
670 val
= concat2 (prefix
, build_string ("XXXXXX"));
671 mktemp (XSTRING (val
)->data
);
675 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
676 "Convert FILENAME to absolute, and canonicalize it.\n\
677 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
678 (does not start with slash); if DEFAULT is nil or missing,\n\
679 the current buffer's value of default-directory is used.\n\
680 Path components that are `.' are removed, and \n\
681 path components followed by `..' are removed, along with the `..' itself;\n\
682 note that these simplifications are done without checking the resulting\n\
683 paths in the file system.\n\
684 An initial `~/' expands to your home directory.\n\
685 An initial `~USER/' expands to USER's home directory.\n\
686 See also the function `substitute-in-file-name'.")
688 Lisp_Object name
, defalt
;
692 register unsigned char *newdir
, *p
, *o
;
694 unsigned char *target
;
697 unsigned char * colon
= 0;
698 unsigned char * close
= 0;
699 unsigned char * slash
= 0;
700 unsigned char * brack
= 0;
701 int lbrack
= 0, rbrack
= 0;
704 #ifdef MSDOS /* Demacs 1.1.2 91/10/20 Manabu Higashida */
707 unsigned char *tmp
, *defdir
;
711 CHECK_STRING (name
, 0);
713 /* If the file name has special constructs in it,
714 call the corresponding file handler. */
715 handler
= Ffind_file_name_handler (name
);
717 return call3 (handler
, Qexpand_file_name
, name
, defalt
);
719 /* Use the buffer's default-directory if DEFALT is omitted. */
721 defalt
= current_buffer
->directory
;
722 CHECK_STRING (defalt
, 1);
724 /* Make sure DEFALT is properly expanded.
725 It would be better to do this down below where we actually use
726 defalt. Unfortunately, calling Fexpand_file_name recursively
727 could invoke GC, and the strings might be relocated. This would
728 be annoying because we have pointers into strings lying around
729 that would need adjusting, and people would add new pointers to
730 the code and forget to adjust them, resulting in intermittent bugs.
731 Putting this call here avoids all that crud.
733 The EQ test avoids infinite recursion. */
734 if (! NILP (defalt
) && !EQ (defalt
, name
)
735 /* This saves time in a common case. */
736 && XSTRING (defalt
)->data
[0] != '/')
741 defalt
= Fexpand_file_name (defalt
, Qnil
);
746 /* Filenames on VMS are always upper case. */
747 name
= Fupcase (name
);
749 #ifdef FILE_SYSTEM_CASE
750 name
= FILE_SYSTEM_CASE (name
);
753 nm
= XSTRING (name
)->data
;
756 /* firstly, strip drive name. */
758 unsigned char *colon
= rindex (nm
, ':');
764 drive
= tolower (colon
[-1]) - 'a';
768 defdir
= alloca (MAXPATHLEN
+ 1);
769 relpath
= getdefdir (drive
+ 1, defdir
);
775 /* If nm is absolute, flush ...// and detect /./ and /../.
776 If no /./ or /../ we can return right away. */
784 /* If it turns out that the filename we want to return is just a
785 suffix of FILENAME, we don't need to go through and edit
786 things; we just need to construct a new string using data
787 starting at the middle of FILENAME. If we set lose to a
788 non-zero value, that means we've discovered that we can't do
795 /* Since we know the path is absolute, we can assume that each
796 element starts with a "/". */
798 /* "//" anywhere isn't necessarily hairy; we just start afresh
799 with the second slash. */
800 if (p
[0] == '/' && p
[1] == '/'
802 /* // at start of filename is meaningful on Apollo system */
808 /* "~" is hairy as the start of any path element. */
809 if (p
[0] == '/' && p
[1] == '~')
810 nm
= p
+ 1, lose
= 1;
812 /* "." and ".." are hairy. */
817 || (p
[2] == '.' && (p
[3] == '/'
824 /* if dev:[dir]/, move nm to / */
825 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
826 nm
= (brack
? brack
+ 1 : colon
+ 1);
835 /* VMS pre V4.4,convert '-'s in filenames. */
836 if (lbrack
== rbrack
)
838 if (dots
< 2) /* this is to allow negative version numbers */
843 if (lbrack
> rbrack
&&
844 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
845 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
851 /* count open brackets, reset close bracket pointer */
852 if (p
[0] == '[' || p
[0] == '<')
854 /* count close brackets, set close bracket pointer */
855 if (p
[0] == ']' || p
[0] == '>')
857 /* detect ][ or >< */
858 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
860 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
861 nm
= p
+ 1, lose
= 1;
862 if (p
[0] == ':' && (colon
|| slash
))
863 /* if dev1:[dir]dev2:, move nm to dev2: */
869 /* if /pathname/dev:, move nm to dev: */
872 /* if node::dev:, move colon following dev */
873 else if (colon
&& colon
[-1] == ':')
875 /* if dev1:dev2:, move nm to dev2: */
876 else if (colon
&& colon
[-1] != ':')
881 if (p
[0] == ':' && !colon
)
887 if (lbrack
== rbrack
)
890 else if (p
[0] == '.')
899 return build_string (sys_translate_unix (nm
));
902 if (nm
== XSTRING (name
)->data
)
904 return build_string (nm
);
909 /* Now determine directory to start with and put it in newdir */
913 if (nm
[0] == '~') /* prefix ~ */
919 || nm
[1] == 0) /* ~ by itself */
921 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
922 newdir
= (unsigned char *) "";
924 dostounix_filename (newdir
);
928 nm
++; /* Don't leave the slash in nm. */
931 else /* ~user/filename */
933 for (p
= nm
; *p
&& (*p
!= '/'
938 o
= (unsigned char *) alloca (p
- nm
+ 1);
939 bcopy ((char *) nm
, o
, p
- nm
);
942 pw
= (struct passwd
*) getpwnam (o
+ 1);
945 newdir
= (unsigned char *) pw
-> pw_dir
;
947 nm
= p
+ 1; /* skip the terminator */
953 /* If we don't find a user of that name, leave the name
954 unchanged; don't move nm forward to p. */
967 newdir
= XSTRING (defalt
)->data
;
971 if (newdir
== 0 && relpath
)
976 /* Get rid of any slash at the end of newdir. */
977 int length
= strlen (newdir
);
978 /* Adding `length > 1 &&' makes ~ expand into / when homedir
979 is the root dir. People disagree about whether that is right.
980 Anyway, we can't take the risk of this change now. */
982 if (newdir
[1] != ':' && length
> 1)
984 if (newdir
[length
- 1] == '/')
986 unsigned char *temp
= (unsigned char *) alloca (length
);
987 bcopy (newdir
, temp
, length
- 1);
988 temp
[length
- 1] = 0;
996 /* Now concatenate the directory and name to new space in the stack frame */
997 tlen
+= strlen (nm
) + 1;
999 /* Add reserved space for drive name. */
1000 target
= (unsigned char *) alloca (tlen
+ 2) + 2;
1002 target
= (unsigned char *) alloca (tlen
);
1009 if (nm
[0] == 0 || nm
[0] == '/')
1010 strcpy (target
, newdir
);
1013 file_name_as_directory (target
, newdir
);
1016 strcat (target
, nm
);
1018 if (index (target
, '/'))
1019 strcpy (target
, sys_translate_unix (target
));
1022 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1030 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1036 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1037 /* brackets are offset from each other by 2 */
1040 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1041 /* convert [foo][bar] to [bar] */
1042 while (o
[-1] != '[' && o
[-1] != '<')
1044 else if (*p
== '-' && *o
!= '.')
1047 else if (p
[0] == '-' && o
[-1] == '.' &&
1048 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1049 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1053 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1054 if (p
[1] == '.') /* foo.-.bar ==> bar*/
1056 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1058 /* else [foo.-] ==> [-] */
1064 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1065 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1075 else if (!strncmp (p
, "//", 2)
1077 /* // at start of filename is meaningful in Apollo system */
1085 else if (p
[0] == '/'
1090 /* If "/." is the entire filename, keep the "/". Otherwise,
1091 just delete the whole "/.". */
1092 if (o
== target
&& p
[2] == '\0')
1096 else if (!strncmp (p
, "/..", 3)
1097 /* `/../' is the "superroot" on certain file systems. */
1099 && (p
[3] == '/' || p
[3] == 0))
1101 while (o
!= target
&& *--o
!= '/')
1104 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1108 if (o
== target
&& *o
== '/')
1116 #endif /* not VMS */
1120 /* at last, set drive name. */
1121 if (target
[1] != ':')
1124 target
[0] = (drive
< 0 ? getdisk () : drive
) + 'a';
1129 return make_string (target
, o
- target
);
1132 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'.
1133 DEAFUN ("expand-file-name", Fexpand_file_name, Sexpand_file_name, 1, 2, 0,
1134 "Convert FILENAME to absolute, and canonicalize it.\n\
1135 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1136 (does not start with slash); if DEFAULT is nil or missing,\n\
1137 the current buffer's value of default-directory is used.\n\
1138 Filenames containing `.' or `..' as components are simplified;\n\
1139 initial `~/' expands to your home directory.\n\
1140 See also the function `substitute-in-file-name'.")
1142 Lisp_Object name, defalt;
1146 register unsigned char *newdir, *p, *o;
1148 unsigned char *target;
1152 unsigned char * colon = 0;
1153 unsigned char * close = 0;
1154 unsigned char * slash = 0;
1155 unsigned char * brack = 0;
1156 int lbrack = 0, rbrack = 0;
1160 CHECK_STRING (name
, 0);
1163 /* Filenames on VMS are always upper case. */
1164 name
= Fupcase (name
);
1167 nm
= XSTRING (name
)->data
;
1169 /* If nm is absolute, flush ...// and detect /./ and /../.
1170 If no /./ or /../ we can return right away. */
1182 if (p
[0] == '/' && p
[1] == '/'
1184 /* // at start of filename is meaningful on Apollo system */
1189 if (p
[0] == '/' && p
[1] == '~')
1190 nm
= p
+ 1, lose
= 1;
1191 if (p
[0] == '/' && p
[1] == '.'
1192 && (p
[2] == '/' || p
[2] == 0
1193 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1199 /* if dev:[dir]/, move nm to / */
1200 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1201 nm
= (brack
? brack
+ 1 : colon
+ 1);
1202 lbrack
= rbrack
= 0;
1210 /* VMS pre V4.4,convert '-'s in filenames. */
1211 if (lbrack
== rbrack
)
1213 if (dots
< 2) /* this is to allow negative version numbers */
1218 if (lbrack
> rbrack
&&
1219 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1220 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1226 /* count open brackets, reset close bracket pointer */
1227 if (p
[0] == '[' || p
[0] == '<')
1228 lbrack
++, brack
= 0;
1229 /* count close brackets, set close bracket pointer */
1230 if (p
[0] == ']' || p
[0] == '>')
1231 rbrack
++, brack
= p
;
1232 /* detect ][ or >< */
1233 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1235 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1236 nm
= p
+ 1, lose
= 1;
1237 if (p
[0] == ':' && (colon
|| slash
))
1238 /* if dev1:[dir]dev2:, move nm to dev2: */
1244 /* if /pathname/dev:, move nm to dev: */
1247 /* if node::dev:, move colon following dev */
1248 else if (colon
&& colon
[-1] == ':')
1250 /* if dev1:dev2:, move nm to dev2: */
1251 else if (colon
&& colon
[-1] != ':')
1256 if (p
[0] == ':' && !colon
)
1262 if (lbrack
== rbrack
)
1265 else if (p
[0] == '.')
1273 if (index (nm
, '/'))
1274 return build_string (sys_translate_unix (nm
));
1276 if (nm
== XSTRING (name
)->data
)
1278 return build_string (nm
);
1282 /* Now determine directory to start with and put it in NEWDIR */
1286 if (nm
[0] == '~') /* prefix ~ */
1291 || nm
[1] == 0)/* ~/filename */
1293 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1294 newdir
= (unsigned char *) "";
1297 nm
++; /* Don't leave the slash in nm. */
1300 else /* ~user/filename */
1302 /* Get past ~ to user */
1303 unsigned char *user
= nm
+ 1;
1304 /* Find end of name. */
1305 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1306 int len
= ptr
? ptr
- user
: strlen (user
);
1308 unsigned char *ptr1
= index (user
, ':');
1309 if (ptr1
!= 0 && ptr1
- user
< len
)
1312 /* Copy the user name into temp storage. */
1313 o
= (unsigned char *) alloca (len
+ 1);
1314 bcopy ((char *) user
, o
, len
);
1317 /* Look up the user name. */
1318 pw
= (struct passwd
*) getpwnam (o
+ 1);
1320 error ("\"%s\" isn't a registered user", o
+ 1);
1322 newdir
= (unsigned char *) pw
->pw_dir
;
1324 /* Discard the user name from NM. */
1331 #endif /* not VMS */
1335 defalt
= current_buffer
->directory
;
1336 CHECK_STRING (defalt
, 1);
1337 newdir
= XSTRING (defalt
)->data
;
1340 /* Now concatenate the directory and name to new space in the stack frame */
1342 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1343 target
= (unsigned char *) alloca (tlen
);
1349 if (nm
[0] == 0 || nm
[0] == '/')
1350 strcpy (target
, newdir
);
1353 file_name_as_directory (target
, newdir
);
1356 strcat (target
, nm
);
1358 if (index (target
, '/'))
1359 strcpy (target
, sys_translate_unix (target
));
1362 /* Now canonicalize by removing /. and /foo/.. if they appear */
1370 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1376 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1377 /* brackets are offset from each other by 2 */
1380 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1381 /* convert [foo][bar] to [bar] */
1382 while (o
[-1] != '[' && o
[-1] != '<')
1384 else if (*p
== '-' && *o
!= '.')
1387 else if (p
[0] == '-' && o
[-1] == '.' &&
1388 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1389 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1393 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1394 if (p
[1] == '.') /* foo.-.bar ==> bar*/
1396 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1398 /* else [foo.-] ==> [-] */
1404 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1405 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1415 else if (!strncmp (p
, "//", 2)
1417 /* // at start of filename is meaningful in Apollo system */
1425 else if (p
[0] == '/' && p
[1] == '.' &&
1426 (p
[2] == '/' || p
[2] == 0))
1428 else if (!strncmp (p
, "/..", 3)
1429 /* `/../' is the "superroot" on certain file systems. */
1431 && (p
[3] == '/' || p
[3] == 0))
1433 while (o
!= target
&& *--o
!= '/')
1436 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1440 if (o
== target
&& *o
== '/')
1448 #endif /* not VMS */
1451 return make_string (target
, o
- target
);
1455 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1456 Ssubstitute_in_file_name
, 1, 1, 0,
1457 "Substitute environment variables referred to in FILENAME.\n\
1458 `$FOO' where FOO is an environment variable name means to substitute\n\
1459 the value of that variable. The variable name should be terminated\n\
1460 with a character not a letter, digit or underscore; otherwise, enclose\n\
1461 the entire variable name in braces.\n\
1462 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1463 On VMS, `$' substitution is not done; this function does little and only\n\
1464 duplicates what `expand-file-name' does.")
1470 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1471 unsigned char *target
;
1473 int substituted
= 0;
1476 CHECK_STRING (string
, 0);
1478 nm
= XSTRING (string
)->data
;
1479 endp
= nm
+ XSTRING (string
)->size
;
1481 /* If /~ or // appears, discard everything through first slash. */
1483 for (p
= nm
; p
!= endp
; p
++)
1487 /* // at start of file name is meaningful in Apollo system */
1488 (p
[0] == '/' && p
- 1 != nm
)
1489 #else /* not APOLLO */
1491 #endif /* not APOLLO */
1495 (p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>' ||
1506 if (p
[0] && p
[1] == ':')
1515 return build_string (nm
);
1518 /* See if any variables are substituted into the string
1519 and find the total length of their values in `total' */
1521 for (p
= nm
; p
!= endp
;)
1531 /* "$$" means a single "$" */
1540 while (p
!= endp
&& *p
!= '}') p
++;
1541 if (*p
!= '}') goto missingclose
;
1547 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1551 /* Copy out the variable name */
1552 target
= (unsigned char *) alloca (s
- o
+ 1);
1553 strncpy (target
, o
, s
- o
);
1556 strupr (target
); /* $home == $HOME etc. */
1559 /* Get variable value */
1560 o
= (unsigned char *) egetenv (target
);
1561 if (!o
) goto badvar
;
1562 total
+= strlen (o
);
1569 /* If substitution required, recopy the string and do it */
1570 /* Make space in stack frame for the new copy */
1571 xnm
= (unsigned char *) alloca (XSTRING (string
)->size
+ total
+ 1);
1574 /* Copy the rest of the name through, replacing $ constructs with values */
1591 while (p
!= endp
&& *p
!= '}') p
++;
1592 if (*p
!= '}') goto missingclose
;
1598 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1602 /* Copy out the variable name */
1603 target
= (unsigned char *) alloca (s
- o
+ 1);
1604 strncpy (target
, o
, s
- o
);
1607 strupr (target
); /* $home == $HOME etc. */
1610 /* Get variable value */
1611 o
= (unsigned char *) egetenv (target
);
1621 /* If /~ or // appears, discard everything through first slash. */
1623 for (p
= xnm
; p
!= x
; p
++)
1626 /* // at start of file name is meaningful in Apollo system */
1627 (p
[0] == '/' && p
- 1 != xnm
)
1628 #else /* not APOLLO */
1630 #endif /* not APOLLO */
1632 && p
!= nm
&& p
[-1] == '/')
1635 else if (p
[0] && p
[1] == ':')
1639 return make_string (xnm
, x
- xnm
);
1642 error ("Bad format environment-variable substitution");
1644 error ("Missing \"}\" in environment-variable substitution");
1646 error ("Substituting nonexistent environment variable \"%s\"", target
);
1649 #endif /* not VMS */
1652 /* A slightly faster and more convenient way to get
1653 (directory-file-name (expand-file-name FOO)). */
1656 expand_and_dir_to_file (filename
, defdir
)
1657 Lisp_Object filename
, defdir
;
1659 register Lisp_Object abspath
;
1661 abspath
= Fexpand_file_name (filename
, defdir
);
1664 register int c
= XSTRING (abspath
)->data
[XSTRING (abspath
)->size
- 1];
1665 if (c
== ':' || c
== ']' || c
== '>')
1666 abspath
= Fdirectory_file_name (abspath
);
1669 /* Remove final slash, if any (unless path is root).
1670 stat behaves differently depending! */
1671 if (XSTRING (abspath
)->size
> 1
1672 && XSTRING (abspath
)->data
[XSTRING (abspath
)->size
- 1] == '/')
1673 /* We cannot take shortcuts; they might be wrong for magic file names. */
1674 abspath
= Fdirectory_file_name (abspath
);
1679 barf_or_query_if_file_exists (absname
, querystring
, interactive
)
1680 Lisp_Object absname
;
1681 unsigned char *querystring
;
1684 register Lisp_Object tem
;
1685 struct gcpro gcpro1
;
1687 if (access (XSTRING (absname
)->data
, 4) >= 0)
1690 Fsignal (Qfile_already_exists
,
1691 Fcons (build_string ("File already exists"),
1692 Fcons (absname
, Qnil
)));
1694 tem
= do_yes_or_no_p (format1 ("File %s already exists; %s anyway? ",
1695 XSTRING (absname
)->data
, querystring
));
1698 Fsignal (Qfile_already_exists
,
1699 Fcons (build_string ("File already exists"),
1700 Fcons (absname
, Qnil
)));
1705 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
1706 "fCopy file: \nFCopy %s to file: \np\nP",
1707 "Copy FILE to NEWNAME. Both args must be strings.\n\
1708 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
1709 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
1710 A number as third arg means request confirmation if NEWNAME already exists.\n\
1711 This is what happens in interactive use with M-x.\n\
1712 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
1713 last-modified time as the old one. (This works on only some systems.)\n\
1714 A prefix arg makes KEEP-TIME non-nil.")
1715 (filename
, newname
, ok_if_already_exists
, keep_date
)
1716 Lisp_Object filename
, newname
, ok_if_already_exists
, keep_date
;
1719 char buf
[16 * 1024];
1721 Lisp_Object handler
;
1722 struct gcpro gcpro1
, gcpro2
;
1723 int count
= specpdl_ptr
- specpdl
;
1724 Lisp_Object args
[6];
1725 int input_file_statable_p
;
1727 GCPRO2 (filename
, newname
);
1728 CHECK_STRING (filename
, 0);
1729 CHECK_STRING (newname
, 1);
1730 filename
= Fexpand_file_name (filename
, Qnil
);
1731 newname
= Fexpand_file_name (newname
, Qnil
);
1733 /* If the input file name has special constructs in it,
1734 call the corresponding file handler. */
1735 handler
= Ffind_file_name_handler (filename
);
1736 /* Likewise for output file name. */
1738 handler
= Ffind_file_name_handler (newname
);
1739 if (!NILP (handler
))
1740 RETURN_UNGCPRO (call5 (handler
, Qcopy_file
, filename
, newname
,
1741 ok_if_already_exists
, keep_date
));
1743 if (NILP (ok_if_already_exists
)
1744 || XTYPE (ok_if_already_exists
) == Lisp_Int
)
1745 barf_or_query_if_file_exists (newname
, "copy to it",
1746 XTYPE (ok_if_already_exists
) == Lisp_Int
);
1748 ifd
= open (XSTRING (filename
)->data
, 0);
1750 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
1752 record_unwind_protect (close_file_unwind
, make_number (ifd
));
1754 /* We can only copy regular files and symbolic links. Other files are not
1756 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
1758 #if defined (S_ISREG) && defined (S_ISLNK)
1759 if (input_file_statable_p
)
1761 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
1763 #if defined (EISDIR)
1764 /* Get a better looking error message. */
1767 report_file_error ("Non-regular file", Fcons (filename
, Qnil
));
1770 #endif /* S_ISREG && S_ISLNK */
1773 /* Create the copy file with the same record format as the input file */
1774 ofd
= sys_creat (XSTRING (newname
)->data
, 0666, ifd
);
1777 /* System's default file type was set to binary by _fmode in emacs.c. */
1778 ofd
= creat (XSTRING (newname
)->data
, S_IREAD
| S_IWRITE
);
1779 #else /* not MSDOS */
1780 ofd
= creat (XSTRING (newname
)->data
, 0666);
1781 #endif /* not MSDOS */
1784 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
1786 record_unwind_protect (close_file_unwind
, make_number (ofd
));
1790 while ((n
= read (ifd
, buf
, sizeof buf
)) > 0)
1791 if (write (ofd
, buf
, n
) != n
)
1792 report_file_error ("I/O error", Fcons (newname
, Qnil
));
1795 if (input_file_statable_p
)
1797 if (!NILP (keep_date
))
1799 EMACS_TIME atime
, mtime
;
1800 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
1801 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
1802 EMACS_SET_UTIMES (XSTRING (newname
)->data
, atime
, mtime
);
1805 if (!egetenv ("USE_DOMAIN_ACLS"))
1807 chmod (XSTRING (newname
)->data
, st
.st_mode
& 07777);
1810 /* Discard the unwind protects. */
1811 specpdl_ptr
= specpdl
+ count
;
1814 if (close (ofd
) < 0)
1815 report_file_error ("I/O error", Fcons (newname
, Qnil
));
1821 DEFUN ("make-directory-internal", Fmake_directory_internal
,
1822 Smake_directory_internal
, 1, 1, 0,
1823 "Create a directory. One argument, a file name string.")
1825 Lisp_Object dirname
;
1828 Lisp_Object handler
;
1830 CHECK_STRING (dirname
, 0);
1831 dirname
= Fexpand_file_name (dirname
, Qnil
);
1833 handler
= Ffind_file_name_handler (dirname
);
1834 if (!NILP (handler
))
1835 return call3 (handler
, Qmake_directory
, dirname
, Qnil
);
1837 dir
= XSTRING (dirname
)->data
;
1839 if (mkdir (dir
, 0777) != 0)
1840 report_file_error ("Creating directory", Flist (1, &dirname
));
1845 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
1846 "Delete a directory. One argument, a file name string.")
1848 Lisp_Object dirname
;
1851 Lisp_Object handler
;
1853 CHECK_STRING (dirname
, 0);
1854 dirname
= Fexpand_file_name (dirname
, Qnil
);
1855 dir
= XSTRING (dirname
)->data
;
1857 handler
= Ffind_file_name_handler (dirname
);
1858 if (!NILP (handler
))
1859 return call2 (handler
, Qdelete_directory
, dirname
);
1861 if (rmdir (dir
) != 0)
1862 report_file_error ("Removing directory", Flist (1, &dirname
));
1867 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
1868 "Delete specified file. One argument, a file name string.\n\
1869 If file has multiple names, it continues to exist with the other names.")
1871 Lisp_Object filename
;
1873 Lisp_Object handler
;
1874 CHECK_STRING (filename
, 0);
1875 filename
= Fexpand_file_name (filename
, Qnil
);
1877 handler
= Ffind_file_name_handler (filename
);
1878 if (!NILP (handler
))
1879 return call2 (handler
, Qdelete_file
, filename
);
1881 if (0 > unlink (XSTRING (filename
)->data
))
1882 report_file_error ("Removing old name", Flist (1, &filename
));
1886 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
1887 "fRename file: \nFRename %s to file: \np",
1888 "Rename FILE as NEWNAME. Both args strings.\n\
1889 If file has names other than FILE, it continues to have those names.\n\
1890 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
1891 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
1892 A number as third arg means request confirmation if NEWNAME already exists.\n\
1893 This is what happens in interactive use with M-x.")
1894 (filename
, newname
, ok_if_already_exists
)
1895 Lisp_Object filename
, newname
, ok_if_already_exists
;
1898 Lisp_Object args
[2];
1900 Lisp_Object handler
;
1901 struct gcpro gcpro1
, gcpro2
;
1903 GCPRO2 (filename
, newname
);
1904 CHECK_STRING (filename
, 0);
1905 CHECK_STRING (newname
, 1);
1906 filename
= Fexpand_file_name (filename
, Qnil
);
1907 newname
= Fexpand_file_name (newname
, Qnil
);
1909 /* If the file name has special constructs in it,
1910 call the corresponding file handler. */
1911 handler
= Ffind_file_name_handler (filename
);
1913 handler
= Ffind_file_name_handler (newname
);
1914 if (!NILP (handler
))
1915 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
1916 filename
, newname
, ok_if_already_exists
));
1918 if (NILP (ok_if_already_exists
)
1919 || XTYPE (ok_if_already_exists
) == Lisp_Int
)
1920 barf_or_query_if_file_exists (newname
, "rename to it",
1921 XTYPE (ok_if_already_exists
) == Lisp_Int
);
1923 if (0 > rename (XSTRING (filename
)->data
, XSTRING (newname
)->data
))
1925 if (0 > link (XSTRING (filename
)->data
, XSTRING (newname
)->data
)
1926 || 0 > unlink (XSTRING (filename
)->data
))
1931 Fcopy_file (filename
, newname
,
1932 /* We have already prompted if it was an integer,
1933 so don't have copy-file prompt again. */
1934 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
1935 Fdelete_file (filename
);
1942 report_file_error ("Renaming", Flist (2, args
));
1945 report_file_error ("Renaming", Flist (2, &filename
));
1952 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
1953 "fAdd name to file: \nFName to add to %s: \np",
1954 "Give FILE additional name NEWNAME. Both args strings.\n\
1955 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
1956 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
1957 A number as third arg means request confirmation if NEWNAME already exists.\n\
1958 This is what happens in interactive use with M-x.")
1959 (filename
, newname
, ok_if_already_exists
)
1960 Lisp_Object filename
, newname
, ok_if_already_exists
;
1963 Lisp_Object args
[2];
1965 Lisp_Object handler
;
1966 struct gcpro gcpro1
, gcpro2
;
1968 GCPRO2 (filename
, newname
);
1969 CHECK_STRING (filename
, 0);
1970 CHECK_STRING (newname
, 1);
1971 filename
= Fexpand_file_name (filename
, Qnil
);
1972 newname
= Fexpand_file_name (newname
, Qnil
);
1974 /* If the file name has special constructs in it,
1975 call the corresponding file handler. */
1976 handler
= Ffind_file_name_handler (filename
);
1977 if (!NILP (handler
))
1978 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, filename
,
1979 newname
, ok_if_already_exists
));
1981 if (NILP (ok_if_already_exists
)
1982 || XTYPE (ok_if_already_exists
) == Lisp_Int
)
1983 barf_or_query_if_file_exists (newname
, "make it a new name",
1984 XTYPE (ok_if_already_exists
) == Lisp_Int
);
1985 unlink (XSTRING (newname
)->data
);
1986 if (0 > link (XSTRING (filename
)->data
, XSTRING (newname
)->data
))
1991 report_file_error ("Adding new name", Flist (2, args
));
1993 report_file_error ("Adding new name", Flist (2, &filename
));
2002 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2003 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2004 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
2005 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2006 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2007 A number as third arg means request confirmation if NEWNAME already exists.\n\
2008 This happens for interactive use with M-x.")
2009 (filename
, linkname
, ok_if_already_exists
)
2010 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2013 Lisp_Object args
[2];
2015 Lisp_Object handler
;
2016 struct gcpro gcpro1
, gcpro2
;
2018 GCPRO2 (filename
, linkname
);
2019 CHECK_STRING (filename
, 0);
2020 CHECK_STRING (linkname
, 1);
2021 /* If the link target has a ~, we must expand it to get
2022 a truly valid file name. Otherwise, do not expand;
2023 we want to permit links to relative file names. */
2024 if (XSTRING (filename
)->data
[0] == '~')
2025 filename
= Fexpand_file_name (filename
, Qnil
);
2026 linkname
= Fexpand_file_name (linkname
, Qnil
);
2028 /* If the file name has special constructs in it,
2029 call the corresponding file handler. */
2030 handler
= Ffind_file_name_handler (filename
);
2031 if (!NILP (handler
))
2032 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2033 linkname
, ok_if_already_exists
));
2035 if (NILP (ok_if_already_exists
)
2036 || XTYPE (ok_if_already_exists
) == Lisp_Int
)
2037 barf_or_query_if_file_exists (linkname
, "make it a link",
2038 XTYPE (ok_if_already_exists
) == Lisp_Int
);
2039 if (0 > symlink (XSTRING (filename
)->data
, XSTRING (linkname
)->data
))
2041 /* If we didn't complain already, silently delete existing file. */
2042 if (errno
== EEXIST
)
2044 unlink (XSTRING (linkname
)->data
);
2045 if (0 <= symlink (XSTRING (filename
)->data
, XSTRING (linkname
)->data
))
2052 report_file_error ("Making symbolic link", Flist (2, args
));
2054 report_file_error ("Making symbolic link", Flist (2, &filename
));
2060 #endif /* S_IFLNK */
2064 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2065 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2066 "Define the job-wide logical name NAME to have the value STRING.\n\
2067 If STRING is nil or a null string, the logical name NAME is deleted.")
2069 Lisp_Object varname
;
2072 CHECK_STRING (varname
, 0);
2074 delete_logical_name (XSTRING (varname
)->data
);
2077 CHECK_STRING (string
, 1);
2079 if (XSTRING (string
)->size
== 0)
2080 delete_logical_name (XSTRING (varname
)->data
);
2082 define_logical_name (XSTRING (varname
)->data
, XSTRING (string
)->data
);
2091 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2092 "Open a network connection to PATH using LOGIN as the login string.")
2094 Lisp_Object path
, login
;
2098 CHECK_STRING (path
, 0);
2099 CHECK_STRING (login
, 0);
2101 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2103 if (netresult
== -1)
2108 #endif /* HPUX_NET */
2110 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2112 "Return t if file FILENAME specifies an absolute path name.\n\
2113 On Unix, this is a name starting with a `/' or a `~'.")
2115 Lisp_Object filename
;
2119 CHECK_STRING (filename
, 0);
2120 ptr
= XSTRING (filename
)->data
;
2121 if (*ptr
== '/' || *ptr
== '~'
2123 /* ??? This criterion is probably wrong for '<'. */
2124 || index (ptr
, ':') || index (ptr
, '<')
2125 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2129 || (*ptr
!= 0 && ptr
[1] == ':' && ptr
[2] == '/')
2137 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2138 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
2139 See also `file-readable-p' and `file-attributes'.")
2141 Lisp_Object filename
;
2143 Lisp_Object abspath
;
2144 Lisp_Object handler
;
2146 CHECK_STRING (filename
, 0);
2147 abspath
= Fexpand_file_name (filename
, Qnil
);
2149 /* If the file name has special constructs in it,
2150 call the corresponding file handler. */
2151 handler
= Ffind_file_name_handler (abspath
);
2152 if (!NILP (handler
))
2153 return call2 (handler
, Qfile_exists_p
, abspath
);
2155 return (access (XSTRING (abspath
)->data
, 0) >= 0) ? Qt
: Qnil
;
2158 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2159 "Return t if FILENAME can be executed by you.\n\
2160 For a directory, this means you can access files in that directory.")
2162 Lisp_Object filename
;
2165 Lisp_Object abspath
;
2166 Lisp_Object handler
;
2168 CHECK_STRING (filename
, 0);
2169 abspath
= Fexpand_file_name (filename
, Qnil
);
2171 /* If the file name has special constructs in it,
2172 call the corresponding file handler. */
2173 handler
= Ffind_file_name_handler (abspath
);
2174 if (!NILP (handler
))
2175 return call2 (handler
, Qfile_executable_p
, abspath
);
2177 return (access (XSTRING (abspath
)->data
, 1) >= 0) ? Qt
: Qnil
;
2180 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2181 "Return t if file FILENAME exists and you can read it.\n\
2182 See also `file-exists-p' and `file-attributes'.")
2184 Lisp_Object filename
;
2186 Lisp_Object abspath
;
2187 Lisp_Object handler
;
2189 CHECK_STRING (filename
, 0);
2190 abspath
= Fexpand_file_name (filename
, Qnil
);
2192 /* If the file name has special constructs in it,
2193 call the corresponding file handler. */
2194 handler
= Ffind_file_name_handler (abspath
);
2195 if (!NILP (handler
))
2196 return call2 (handler
, Qfile_readable_p
, abspath
);
2198 return (access (XSTRING (abspath
)->data
, 4) >= 0) ? Qt
: Qnil
;
2201 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
2202 "Return non-nil if file FILENAME is the name of a symbolic link.\n\
2203 The value is the name of the file to which it is linked.\n\
2204 Otherwise returns nil.")
2206 Lisp_Object filename
;
2213 Lisp_Object handler
;
2215 CHECK_STRING (filename
, 0);
2216 filename
= Fexpand_file_name (filename
, Qnil
);
2218 /* If the file name has special constructs in it,
2219 call the corresponding file handler. */
2220 handler
= Ffind_file_name_handler (filename
);
2221 if (!NILP (handler
))
2222 return call2 (handler
, Qfile_symlink_p
, filename
);
2227 buf
= (char *) xmalloc (bufsize
);
2228 bzero (buf
, bufsize
);
2229 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
2230 if (valsize
< bufsize
) break;
2231 /* Buffer was not long enough */
2240 val
= make_string (buf
, valsize
);
2243 #else /* not S_IFLNK */
2245 #endif /* not S_IFLNK */
2248 #ifdef SOLARIS_BROKEN_ACCESS
2249 /* In Solaris 2.1, the readonly-ness of the filesystem is not
2250 considered by the access system call. This is Sun's bug, but we
2251 still have to make Emacs work. */
2253 #include <sys/statvfs.h>
2259 struct statvfs statvfsb
;
2261 if (statvfs(path
, &statvfsb
))
2262 return 1; /* error from statvfs, be conservative and say not wrtable */
2264 /* Otherwise, fsys is ro if bit is set. */
2265 return statvfsb
.f_flag
& ST_RDONLY
;
2268 /* But on every other os, access has already done the right thing. */
2269 #define ro_fsys(path) 0
2272 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2274 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
2275 "Return t if file FILENAME can be written or created by you.")
2277 Lisp_Object filename
;
2279 Lisp_Object abspath
, dir
;
2280 Lisp_Object handler
;
2282 CHECK_STRING (filename
, 0);
2283 abspath
= Fexpand_file_name (filename
, Qnil
);
2285 /* If the file name has special constructs in it,
2286 call the corresponding file handler. */
2287 handler
= Ffind_file_name_handler (abspath
);
2288 if (!NILP (handler
))
2289 return call2 (handler
, Qfile_writable_p
, abspath
);
2291 if (access (XSTRING (abspath
)->data
, 0) >= 0)
2292 return ((access (XSTRING (abspath
)->data
, 2) >= 0
2293 && ! ro_fsys ((char *) XSTRING (abspath
)->data
))
2295 dir
= Ffile_name_directory (abspath
);
2298 dir
= Fdirectory_file_name (dir
);
2302 dir
= Fdirectory_file_name (dir
);
2304 return ((access (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "", 2) >= 0
2305 && ! ro_fsys ((char *) XSTRING (dir
)->data
))
2309 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
2310 "Return t if file FILENAME is the name of a directory as a file.\n\
2311 A directory name spec may be given instead; then the value is t\n\
2312 if the directory so specified exists and really is a directory.")
2314 Lisp_Object filename
;
2316 register Lisp_Object abspath
;
2318 Lisp_Object handler
;
2320 abspath
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2322 /* If the file name has special constructs in it,
2323 call the corresponding file handler. */
2324 handler
= Ffind_file_name_handler (abspath
);
2325 if (!NILP (handler
))
2326 return call2 (handler
, Qfile_directory_p
, abspath
);
2328 if (stat (XSTRING (abspath
)->data
, &st
) < 0)
2330 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
2333 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
2334 "Return t if file FILENAME is the name of a directory as a file,\n\
2335 and files in that directory can be opened by you. In order to use a\n\
2336 directory as a buffer's current directory, this predicate must return true.\n\
2337 A directory name spec may be given instead; then the value is t\n\
2338 if the directory so specified exists and really is a readable and\n\
2339 searchable directory.")
2341 Lisp_Object filename
;
2343 Lisp_Object handler
;
2345 /* If the file name has special constructs in it,
2346 call the corresponding file handler. */
2347 handler
= Ffind_file_name_handler (filename
);
2348 if (!NILP (handler
))
2349 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
2351 if (NILP (Ffile_directory_p (filename
))
2352 || NILP (Ffile_executable_p (filename
)))
2358 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
2359 "Return mode bits of FILE, as an integer.")
2361 Lisp_Object filename
;
2363 Lisp_Object abspath
;
2365 Lisp_Object handler
;
2367 abspath
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2369 /* If the file name has special constructs in it,
2370 call the corresponding file handler. */
2371 handler
= Ffind_file_name_handler (abspath
);
2372 if (!NILP (handler
))
2373 return call2 (handler
, Qfile_modes
, abspath
);
2375 if (stat (XSTRING (abspath
)->data
, &st
) < 0)
2381 if (S_ISREG (st
.st_mode
)
2382 && (len
= XSTRING (abspath
)->size
) >= 5
2383 && (stricmp ((suffix
= XSTRING (abspath
)->data
+ len
-4), ".com") == 0
2384 || stricmp (suffix
, ".exe") == 0
2385 || stricmp (suffix
, ".bat") == 0))
2386 st
.st_mode
|= S_IEXEC
;
2390 return make_number (st
.st_mode
& 07777);
2393 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
2394 "Set mode bits of FILE to MODE (an integer).\n\
2395 Only the 12 low bits of MODE are used.")
2397 Lisp_Object filename
, mode
;
2399 Lisp_Object abspath
;
2400 Lisp_Object handler
;
2402 abspath
= Fexpand_file_name (filename
, current_buffer
->directory
);
2403 CHECK_NUMBER (mode
, 1);
2405 /* If the file name has special constructs in it,
2406 call the corresponding file handler. */
2407 handler
= Ffind_file_name_handler (abspath
);
2408 if (!NILP (handler
))
2409 return call3 (handler
, Qset_file_modes
, abspath
, mode
);
2412 if (chmod (XSTRING (abspath
)->data
, XINT (mode
)) < 0)
2413 report_file_error ("Doing chmod", Fcons (abspath
, Qnil
));
2415 if (!egetenv ("USE_DOMAIN_ACLS"))
2418 struct timeval tvp
[2];
2420 /* chmod on apollo also change the file's modtime; need to save the
2421 modtime and then restore it. */
2422 if (stat (XSTRING (abspath
)->data
, &st
) < 0)
2424 report_file_error ("Doing chmod", Fcons (abspath
, Qnil
));
2428 if (chmod (XSTRING (abspath
)->data
, XINT (mode
)) < 0)
2429 report_file_error ("Doing chmod", Fcons (abspath
, Qnil
));
2431 /* reset the old accessed and modified times. */
2432 tvp
[0].tv_sec
= st
.st_atime
+ 1; /* +1 due to an Apollo roundoff bug */
2434 tvp
[1].tv_sec
= st
.st_mtime
+ 1; /* +1 due to an Apollo roundoff bug */
2437 if (utimes (XSTRING (abspath
)->data
, tvp
) < 0)
2438 report_file_error ("Doing utimes", Fcons (abspath
, Qnil
));
2445 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
2446 "Set the file permission bits for newly created files.\n\
2447 The argument MODE should be an integer; only the low 9 bits are used.\n\
2448 This setting is inherited by subprocesses.")
2452 CHECK_NUMBER (mode
, 0);
2454 umask ((~ XINT (mode
)) & 0777);
2459 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
2460 "Return the default file protection for created files.\n\
2461 The value is an integer.")
2467 realmask
= umask (0);
2470 XSET (value
, Lisp_Int
, (~ realmask
) & 0777);
2476 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
2477 "Tell Unix to finish all pending disk updates.")
2486 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
2487 "Return t if file FILE1 is newer than file FILE2.\n\
2488 If FILE1 does not exist, the answer is nil;\n\
2489 otherwise, if FILE2 does not exist, the answer is t.")
2491 Lisp_Object file1
, file2
;
2493 Lisp_Object abspath1
, abspath2
;
2496 Lisp_Object handler
;
2497 struct gcpro gcpro1
, gcpro2
;
2499 CHECK_STRING (file1
, 0);
2500 CHECK_STRING (file2
, 0);
2503 GCPRO2 (abspath1
, file2
);
2504 abspath1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
2505 abspath2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
2508 /* If the file name has special constructs in it,
2509 call the corresponding file handler. */
2510 handler
= Ffind_file_name_handler (abspath1
);
2512 handler
= Ffind_file_name_handler (abspath2
);
2513 if (!NILP (handler
))
2514 return call3 (handler
, Qfile_newer_than_file_p
, abspath1
, abspath2
);
2516 if (stat (XSTRING (abspath1
)->data
, &st
) < 0)
2519 mtime1
= st
.st_mtime
;
2521 if (stat (XSTRING (abspath2
)->data
, &st
) < 0)
2524 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
2528 Lisp_Object Qfind_buffer_file_type
;
2531 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
2533 "Insert contents of file FILENAME after point.\n\
2534 Returns list of absolute file name and length of data inserted.\n\
2535 If second argument VISIT is non-nil, the buffer's visited filename\n\
2536 and last save file modtime are set, and it is marked unmodified.\n\
2537 If visiting and the file does not exist, visiting is completed\n\
2538 before the error is signaled.\n\n\
2539 The optional third and fourth arguments BEG and END\n\
2540 specify what portion of the file to insert.\n\
2541 If VISIT is non-nil, BEG and END must be nil.\n\
2542 If optional fifth argument REPLACE is non-nil,\n\
2543 it means replace the current buffer contents (in the accessible portion)\n\
2544 with the file contents. This is better than simply deleting and inserting\n\
2545 the whole thing because (1) it preserves some marker positions\n\
2546 and (2) it puts less data in the undo list.")
2547 (filename
, visit
, beg
, end
, replace
)
2548 Lisp_Object filename
, visit
, beg
, end
, replace
;
2552 register int inserted
= 0;
2553 register int how_much
;
2554 int count
= specpdl_ptr
- specpdl
;
2555 struct gcpro gcpro1
, gcpro2
;
2556 Lisp_Object handler
, val
, insval
;
2563 GCPRO2 (filename
, p
);
2564 if (!NILP (current_buffer
->read_only
))
2565 Fbarf_if_buffer_read_only();
2567 CHECK_STRING (filename
, 0);
2568 filename
= Fexpand_file_name (filename
, Qnil
);
2570 /* If the file name has special constructs in it,
2571 call the corresponding file handler. */
2572 handler
= Ffind_file_name_handler (filename
);
2573 if (!NILP (handler
))
2575 val
= call6 (handler
, Qinsert_file_contents
, filename
,
2576 visit
, beg
, end
, replace
);
2583 if (stat (XSTRING (filename
)->data
, &st
) < 0
2584 || (fd
= open (XSTRING (filename
)->data
, 0)) < 0)
2586 if ((fd
= open (XSTRING (filename
)->data
, 0)) < 0
2587 || fstat (fd
, &st
) < 0)
2588 #endif /* not APOLLO */
2590 if (fd
>= 0) close (fd
);
2592 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
2598 /* Replacement should preserve point as it preserves markers. */
2599 if (!NILP (replace
))
2600 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
2602 record_unwind_protect (close_file_unwind
, make_number (fd
));
2605 /* This code will need to be changed in order to work on named
2606 pipes, and it's probably just not worth it. So we should at
2607 least signal an error. */
2608 if ((st
.st_mode
& S_IFMT
) == S_IFSOCK
)
2609 Fsignal (Qfile_error
,
2610 Fcons (build_string ("reading from named pipe"),
2611 Fcons (filename
, Qnil
)));
2614 /* Supposedly happens on VMS. */
2616 error ("File size is negative");
2618 if (!NILP (beg
) || !NILP (end
))
2620 error ("Attempt to visit less than an entire file");
2623 CHECK_NUMBER (beg
, 0);
2628 CHECK_NUMBER (end
, 0);
2631 XSETINT (end
, st
.st_size
);
2632 if (XINT (end
) != st
.st_size
)
2633 error ("maximum buffer size exceeded");
2636 /* If requested, replace the accessible part of the buffer
2637 with the file contents. Avoid replacing text at the
2638 beginning or end of the buffer that matches the file contents;
2639 that preserves markers pointing to the unchanged parts. */
2640 if (!NILP (replace
))
2642 char buffer
[1 << 14];
2643 int same_at_start
= BEGV
;
2644 int same_at_end
= ZV
;
2649 /* Count how many chars at the start of the file
2650 match the text at the beginning of the buffer. */
2655 nread
= read (fd
, buffer
, sizeof buffer
);
2657 error ("IO error reading %s: %s",
2658 XSTRING (filename
)->data
, strerror (errno
));
2659 else if (nread
== 0)
2662 while (bufpos
< nread
&& same_at_start
< ZV
2663 && FETCH_CHAR (same_at_start
) == buffer
[bufpos
])
2664 same_at_start
++, bufpos
++;
2665 /* If we found a discrepancy, stop the scan.
2666 Otherwise loop around and scan the next bufferfull. */
2667 if (bufpos
!= nread
)
2671 /* If the file matches the buffer completely,
2672 there's no need to replace anything. */
2673 if (same_at_start
== st
.st_size
)
2681 /* Count how many chars at the end of the file
2682 match the text at the end of the buffer. */
2685 int total_read
, nread
, bufpos
, curpos
, trial
;
2687 /* At what file position are we now scanning? */
2688 curpos
= st
.st_size
- (ZV
- same_at_end
);
2689 /* How much can we scan in the next step? */
2690 trial
= min (curpos
, sizeof buffer
);
2691 if (lseek (fd
, curpos
- trial
, 0) < 0)
2692 report_file_error ("Setting file position",
2693 Fcons (filename
, Qnil
));
2696 while (total_read
< trial
)
2698 nread
= read (fd
, buffer
+ total_read
, trial
- total_read
);
2700 error ("IO error reading %s: %s",
2701 XSTRING (filename
)->data
, strerror (errno
));
2702 total_read
+= nread
;
2704 /* Scan this bufferfull from the end, comparing with
2705 the Emacs buffer. */
2706 bufpos
= total_read
;
2707 /* Compare with same_at_start to avoid counting some buffer text
2708 as matching both at the file's beginning and at the end. */
2709 while (bufpos
> 0 && same_at_end
> same_at_start
2710 && FETCH_CHAR (same_at_end
- 1) == buffer
[bufpos
- 1])
2711 same_at_end
--, bufpos
--;
2712 /* If we found a discrepancy, stop the scan.
2713 Otherwise loop around and scan the preceding bufferfull. */
2719 /* Don't try to reuse the same piece of text twice. */
2720 overlap
= same_at_start
- BEGV
- (same_at_end
+ st
.st_size
- ZV
);
2722 same_at_end
+= overlap
;
2724 /* Arrange to read only the nonmatching middle part of the file. */
2725 XFASTINT (beg
) = same_at_start
- BEGV
;
2726 XFASTINT (end
) = st
.st_size
- (ZV
- same_at_end
);
2728 del_range_1 (same_at_start
, same_at_end
, 0);
2729 /* Insert from the file at the proper position. */
2730 SET_PT (same_at_start
);
2733 total
= XINT (end
) - XINT (beg
);
2736 register Lisp_Object temp
;
2738 /* Make sure point-max won't overflow after this insertion. */
2739 XSET (temp
, Lisp_Int
, total
);
2740 if (total
!= XINT (temp
))
2741 error ("maximum buffer size exceeded");
2744 if (NILP (visit
) && total
> 0)
2745 prepare_to_modify_buffer (point
, point
);
2748 if (GAP_SIZE
< total
)
2749 make_gap (total
- GAP_SIZE
);
2751 if (XINT (beg
) != 0 || !NILP (replace
))
2753 if (lseek (fd
, XINT (beg
), 0) < 0)
2754 report_file_error ("Setting file position", Fcons (filename
, Qnil
));
2758 while (inserted
< total
)
2760 int try = min (total
- inserted
, 64 << 10);
2763 /* Allow quitting out of the actual I/O. */
2766 this = read (fd
, &FETCH_CHAR (point
+ inserted
- 1) + 1, try);
2783 /* Demacs 1.1.1 91/10/16 HIRANO Satoshi, MW July 1993 */
2784 /* Determine file type from name and remove LFs from CR-LFs if the file
2785 is deemed to be a text file. */
2787 struct gcpro gcpro1
;
2791 code
= call1 (Qfind_buffer_file_type
, filename
);
2793 if (XTYPE (code
) == Lisp_Int
)
2794 XFASTINT (current_buffer
->buffer_file_type
) = XFASTINT (code
);
2795 if (XFASTINT (current_buffer
->buffer_file_type
) == 0)
2798 = inserted
- crlf_to_lf (inserted
, &FETCH_CHAR (point
- 1) + 1);
2801 GPT
-= reduced_size
;
2802 GAP_SIZE
+= reduced_size
;
2803 inserted
-= reduced_size
;
2810 record_insert (point
, inserted
);
2812 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
2813 offset_intervals (current_buffer
, point
, inserted
);
2819 /* Discard the unwind protect for closing the file. */
2823 error ("IO error reading %s: %s",
2824 XSTRING (filename
)->data
, strerror (errno
));
2831 if (!EQ (current_buffer
->undo_list
, Qt
))
2832 current_buffer
->undo_list
= Qnil
;
2834 stat (XSTRING (filename
)->data
, &st
);
2839 current_buffer
->modtime
= st
.st_mtime
;
2840 current_buffer
->filename
= filename
;
2843 current_buffer
->save_modified
= MODIFF
;
2844 current_buffer
->auto_save_modified
= MODIFF
;
2845 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
2846 #ifdef CLASH_DETECTION
2849 if (!NILP (current_buffer
->filename
))
2850 unlock_file (current_buffer
->filename
);
2851 unlock_file (filename
);
2853 #endif /* CLASH_DETECTION */
2854 /* If visiting nonexistent file, return nil. */
2855 if (current_buffer
->modtime
== -1)
2856 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
2859 if (inserted
> 0 && NILP (visit
) && total
> 0)
2860 signal_after_change (point
, 0, inserted
);
2864 p
= Vafter_insert_file_functions
;
2867 insval
= call1 (Fcar (p
), make_number (inserted
));
2870 CHECK_NUMBER (insval
, 0);
2871 inserted
= XFASTINT (insval
);
2879 val
= Fcons (filename
,
2880 Fcons (make_number (inserted
),
2883 RETURN_UNGCPRO (unbind_to (count
, val
));
2886 static Lisp_Object
build_annotations ();
2888 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 5,
2889 "r\nFWrite region to file: ",
2890 "Write current region into specified file.\n\
2891 When called from a program, takes three arguments:\n\
2892 START, END and FILENAME. START and END are buffer positions.\n\
2893 Optional fourth argument APPEND if non-nil means\n\
2894 append to existing file contents (if any).\n\
2895 Optional fifth argument VISIT if t means\n\
2896 set the last-save-file-modtime of buffer to this file's modtime\n\
2897 and mark buffer not modified.\n\
2898 If VISIT is a string, it is a second file name;\n\
2899 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
2900 VISIT is also the file name to lock and unlock for clash detection.\n\
2901 If VISIT is neither t nor nil nor a string,\n\
2902 that means do not print the \"Wrote file\" message.\n\
2903 Kludgy feature: if START is a string, then that string is written\n\
2904 to the file, instead of any buffer contents, and END is ignored.")
2905 (start
, end
, filename
, append
, visit
)
2906 Lisp_Object start
, end
, filename
, append
, visit
;
2914 int count
= specpdl_ptr
- specpdl
;
2916 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
2918 Lisp_Object handler
;
2919 Lisp_Object visit_file
;
2920 Lisp_Object annotations
;
2921 int visiting
, quietly
;
2922 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2924 int buffer_file_type
2925 = NILP (current_buffer
->buffer_file_type
) ? O_TEXT
: O_BINARY
;
2928 if (!NILP (start
) && !STRINGP (start
))
2929 validate_region (&start
, &end
);
2931 filename
= Fexpand_file_name (filename
, Qnil
);
2932 if (STRINGP (visit
))
2933 visit_file
= Fexpand_file_name (visit
, Qnil
);
2935 visit_file
= filename
;
2937 visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
2938 quietly
= !NILP (visit
);
2942 GCPRO4 (start
, filename
, annotations
, visit_file
);
2944 /* If the file name has special constructs in it,
2945 call the corresponding file handler. */
2946 handler
= Ffind_file_name_handler (filename
);
2947 /* If FILENAME has no handler, see if VISIT has one. */
2948 if (NILP (handler
) && XTYPE (visit
) == Lisp_String
)
2949 handler
= Ffind_file_name_handler (visit
);
2951 if (!NILP (handler
))
2954 val
= call6 (handler
, Qwrite_region
, start
, end
,
2955 filename
, append
, visit
);
2959 current_buffer
->save_modified
= MODIFF
;
2960 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
2961 current_buffer
->filename
= visit_file
;
2967 /* Special kludge to simplify auto-saving. */
2970 XFASTINT (start
) = BEG
;
2974 annotations
= build_annotations (start
, end
);
2976 #ifdef CLASH_DETECTION
2978 lock_file (visit_file
);
2979 #endif /* CLASH_DETECTION */
2981 fn
= XSTRING (filename
)->data
;
2985 desc
= open (fn
, O_WRONLY
| buffer_file_type
);
2987 desc
= open (fn
, O_WRONLY
);
2992 if (auto_saving
) /* Overwrite any previous version of autosave file */
2994 vms_truncate (fn
); /* if fn exists, truncate to zero length */
2995 desc
= open (fn
, O_RDWR
);
2997 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
2998 ? XSTRING (current_buffer
->filename
)->data
: 0,
3001 else /* Write to temporary name and rename if no errors */
3003 Lisp_Object temp_name
;
3004 temp_name
= Ffile_name_directory (filename
);
3006 if (!NILP (temp_name
))
3008 temp_name
= Fmake_temp_name (concat2 (temp_name
,
3009 build_string ("$$SAVE$$")));
3010 fname
= XSTRING (filename
)->data
;
3011 fn
= XSTRING (temp_name
)->data
;
3012 desc
= creat_copy_attrs (fname
, fn
);
3015 /* If we can't open the temporary file, try creating a new
3016 version of the original file. VMS "creat" creates a
3017 new version rather than truncating an existing file. */
3020 desc
= creat (fn
, 0666);
3021 #if 0 /* This can clobber an existing file and fail to replace it,
3022 if the user runs out of space. */
3025 /* We can't make a new version;
3026 try to truncate and rewrite existing version if any. */
3028 desc
= open (fn
, O_RDWR
);
3034 desc
= creat (fn
, 0666);
3039 O_WRONLY
| O_TRUNC
| O_CREAT
| buffer_file_type
,
3040 S_IREAD
| S_IWRITE
);
3041 #else /* not MSDOS */
3042 desc
= creat (fn
, auto_saving
? auto_save_mode_bits
: 0666);
3043 #endif /* not MSDOS */
3044 #endif /* not VMS */
3050 #ifdef CLASH_DETECTION
3052 if (!auto_saving
) unlock_file (visit_file
);
3054 #endif /* CLASH_DETECTION */
3055 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
3058 record_unwind_protect (close_file_unwind
, make_number (desc
));
3061 if (lseek (desc
, 0, 2) < 0)
3063 #ifdef CLASH_DETECTION
3064 if (!auto_saving
) unlock_file (visit_file
);
3065 #endif /* CLASH_DETECTION */
3066 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
3071 * Kludge Warning: The VMS C RTL likes to insert carriage returns
3072 * if we do writes that don't end with a carriage return. Furthermore
3073 * it cannot handle writes of more then 16K. The modified
3074 * version of "sys_write" in SYSDEP.C (see comment there) copes with
3075 * this EXCEPT for the last record (iff it doesn't end with a carriage
3076 * return). This implies that if your buffer doesn't end with a carriage
3077 * return, you get one free... tough. However it also means that if
3078 * we make two calls to sys_write (a la the following code) you can
3079 * get one at the gap as well. The easiest way to fix this (honest)
3080 * is to move the gap to the next newline (or the end of the buffer).
3085 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
3086 move_gap (find_next_newline (GPT
, 1));
3092 if (STRINGP (start
))
3094 failure
= 0 > a_write (desc
, XSTRING (start
)->data
,
3095 XSTRING (start
)->size
, 0, &annotations
);
3098 else if (XINT (start
) != XINT (end
))
3101 if (XINT (start
) < GPT
)
3103 register int end1
= XINT (end
);
3105 failure
= 0 > a_write (desc
, &FETCH_CHAR (tem
),
3106 min (GPT
, end1
) - tem
, tem
, &annotations
);
3107 nwritten
+= min (GPT
, end1
) - tem
;
3111 if (XINT (end
) > GPT
&& !failure
)
3114 tem
= max (tem
, GPT
);
3115 failure
= 0 > a_write (desc
, &FETCH_CHAR (tem
), XINT (end
) - tem
,
3117 nwritten
+= XINT (end
) - tem
;
3123 /* If file was empty, still need to write the annotations */
3124 failure
= 0 > a_write (desc
, "", 0, XINT (start
), &annotations
);
3132 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
3133 Disk full in NFS may be reported here. */
3134 /* mib says that closing the file will try to write as fast as NFS can do
3135 it, and that means the fsync here is not crucial for autosave files. */
3136 if (!auto_saving
&& fsync (desc
) < 0)
3137 failure
= 1, save_errno
= errno
;
3140 /* Spurious "file has changed on disk" warnings have been
3141 observed on Suns as well.
3142 It seems that `close' can change the modtime, under nfs.
3144 (This has supposedly been fixed in Sunos 4,
3145 but who knows about all the other machines with NFS?) */
3148 /* On VMS and APOLLO, must do the stat after the close
3149 since closing changes the modtime. */
3152 /* Recall that #if defined does not work on VMS. */
3159 /* NFS can report a write failure now. */
3160 if (close (desc
) < 0)
3161 failure
= 1, save_errno
= errno
;
3164 /* If we wrote to a temporary name and had no errors, rename to real name. */
3168 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
3176 /* Discard the unwind protect */
3177 specpdl_ptr
= specpdl
+ count
;
3179 #ifdef CLASH_DETECTION
3181 unlock_file (visit_file
);
3182 #endif /* CLASH_DETECTION */
3184 /* Do this before reporting IO error
3185 to avoid a "file has changed on disk" warning on
3186 next attempt to save. */
3188 current_buffer
->modtime
= st
.st_mtime
;
3191 error ("IO error writing %s: %s", fn
, strerror (save_errno
));
3195 current_buffer
->save_modified
= MODIFF
;
3196 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3197 current_buffer
->filename
= visit_file
;
3203 message ("Wrote %s", XSTRING (visit_file
)->data
);
3208 Lisp_Object
merge ();
3210 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
3211 "Return t if (car A) is numerically less than (car B).")
3215 return Flss (Fcar (a
), Fcar (b
));
3218 /* Build the complete list of annotations appropriate for writing out
3219 the text between START and END, by calling all the functions in
3220 write-region-annotate-functions and merging the lists they return. */
3223 build_annotations (start
, end
)
3224 Lisp_Object start
, end
;
3226 Lisp_Object annotations
;
3228 struct gcpro gcpro1
, gcpro2
;
3231 p
= Vwrite_region_annotate_functions
;
3232 GCPRO2 (annotations
, p
);
3235 res
= call2 (Fcar (p
), start
, end
);
3236 Flength (res
); /* Check basic validity of return value */
3237 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
3244 /* Write to descriptor DESC the LEN characters starting at ADDR,
3245 assuming they start at position POS in the buffer.
3246 Intersperse with them the annotations from *ANNOT
3247 (those which fall within the range of positions POS to POS + LEN),
3248 each at its appropriate position.
3250 Modify *ANNOT by discarding elements as we output them.
3251 The return value is negative in case of system call failure. */
3254 a_write (desc
, addr
, len
, pos
, annot
)
3256 register char *addr
;
3263 int lastpos
= pos
+ len
;
3267 tem
= Fcar_safe (Fcar (*annot
));
3268 if (INTEGERP (tem
) && XINT (tem
) >= pos
&& XFASTINT (tem
) <= lastpos
)
3269 nextpos
= XFASTINT (tem
);
3271 return e_write (desc
, addr
, lastpos
- pos
);
3274 if (0 > e_write (desc
, addr
, nextpos
- pos
))
3276 addr
+= nextpos
- pos
;
3279 tem
= Fcdr (Fcar (*annot
));
3282 if (0 > e_write (desc
, XSTRING (tem
)->data
, XSTRING (tem
)->size
))
3285 *annot
= Fcdr (*annot
);
3290 e_write (desc
, addr
, len
)
3292 register char *addr
;
3295 char buf
[16 * 1024];
3296 register char *p
, *end
;
3298 if (!EQ (current_buffer
->selective_display
, Qt
))
3299 return write (desc
, addr
, len
) - len
;
3303 end
= p
+ sizeof buf
;
3308 if (write (desc
, buf
, sizeof buf
) != sizeof buf
)
3317 if (write (desc
, buf
, p
- buf
) != p
- buf
)
3323 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
3324 Sverify_visited_file_modtime
, 1, 1, 0,
3325 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
3326 This means that the file has not been changed since it was visited or saved.")
3332 Lisp_Object handler
;
3334 CHECK_BUFFER (buf
, 0);
3337 if (XTYPE (b
->filename
) != Lisp_String
) return Qt
;
3338 if (b
->modtime
== 0) return Qt
;
3340 /* If the file name has special constructs in it,
3341 call the corresponding file handler. */
3342 handler
= Ffind_file_name_handler (b
->filename
);
3343 if (!NILP (handler
))
3344 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
3346 if (stat (XSTRING (b
->filename
)->data
, &st
) < 0)
3348 /* If the file doesn't exist now and didn't exist before,
3349 we say that it isn't modified, provided the error is a tame one. */
3350 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
3355 if (st
.st_mtime
== b
->modtime
3356 /* If both are positive, accept them if they are off by one second. */
3357 || (st
.st_mtime
> 0 && b
->modtime
> 0
3358 && (st
.st_mtime
== b
->modtime
+ 1
3359 || st
.st_mtime
== b
->modtime
- 1)))
3364 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
3365 Sclear_visited_file_modtime
, 0, 0, 0,
3366 "Clear out records of last mod time of visited file.\n\
3367 Next attempt to save will certainly not complain of a discrepancy.")
3370 current_buffer
->modtime
= 0;
3374 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
3375 Svisited_file_modtime
, 0, 0, 0,
3376 "Return the current buffer's recorded visited file modification time.\n\
3377 The value is a list of the form (HIGH . LOW), like the time values\n\
3378 that `file-attributes' returns.")
3381 return long_to_cons (current_buffer
->modtime
);
3384 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
3385 Sset_visited_file_modtime
, 0, 1, 0,
3386 "Update buffer's recorded modification time from the visited file's time.\n\
3387 Useful if the buffer was not read from the file normally\n\
3388 or if the file itself has been changed for some known benign reason.\n\
3389 An argument specifies the modification time value to use\n\
3390 \(instead of that of the visited file), in the form of a list\n\
3391 \(HIGH . LOW) or (HIGH LOW).")
3393 Lisp_Object time_list
;
3395 if (!NILP (time_list
))
3396 current_buffer
->modtime
= cons_to_long (time_list
);
3399 register Lisp_Object filename
;
3401 Lisp_Object handler
;
3403 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
3405 /* If the file name has special constructs in it,
3406 call the corresponding file handler. */
3407 handler
= Ffind_file_name_handler (filename
);
3408 if (!NILP (handler
))
3409 /* The handler can find the file name the same way we did. */
3410 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
3411 else if (stat (XSTRING (filename
)->data
, &st
) >= 0)
3412 current_buffer
->modtime
= st
.st_mtime
;
3421 unsigned char *name
= XSTRING (current_buffer
->name
)->data
;
3424 message ("Autosaving...error for %s", name
);
3425 Fsleep_for (make_number (1), Qnil
);
3426 message ("Autosaving...error!for %s", name
);
3427 Fsleep_for (make_number (1), Qnil
);
3428 message ("Autosaving...error for %s", name
);
3429 Fsleep_for (make_number (1), Qnil
);
3439 /* Get visited file's mode to become the auto save file's mode. */
3440 if (stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
3441 /* But make sure we can overwrite it later! */
3442 auto_save_mode_bits
= st
.st_mode
| 0600;
3444 auto_save_mode_bits
= 0666;
3447 Fwrite_region (Qnil
, Qnil
,
3448 current_buffer
->auto_save_file_name
,
3452 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
3453 "Auto-save all buffers that need it.\n\
3454 This is all buffers that have auto-saving enabled\n\
3455 and are changed since last auto-saved.\n\
3456 Auto-saving writes the buffer into a file\n\
3457 so that your editing is not lost if the system crashes.\n\
3458 This file is not the file you visited; that changes only when you save.\n\
3459 Normally we run the normal hook `auto-save-hook' before saving.\n\n\
3460 Non-nil first argument means do not print any message if successful.\n\
3461 Non-nil second argument means save only current buffer.")
3462 (no_message
, current_only
)
3463 Lisp_Object no_message
, current_only
;
3465 struct buffer
*old
= current_buffer
, *b
;
3466 Lisp_Object tail
, buf
;
3468 char *omessage
= echo_area_glyphs
;
3469 int omessage_length
= echo_area_glyphs_length
;
3470 extern int minibuf_level
;
3471 int do_handled_files
;
3474 /* Ordinarily don't quit within this function,
3475 but don't make it impossible to quit (in case we get hung in I/O). */
3479 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
3480 point to non-strings reached from Vbuffer_alist. */
3486 if (!NILP (Vrun_hooks
))
3487 call1 (Vrun_hooks
, intern ("auto-save-hook"));
3489 /* First, save all files which don't have handlers. If Emacs is
3490 crashing, the handlers may tweak what is causing Emacs to crash
3491 in the first place, and it would be a shame if Emacs failed to
3492 autosave perfectly ordinary files because it couldn't handle some
3494 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
3495 for (tail
= Vbuffer_alist
; XGCTYPE (tail
) == Lisp_Cons
;
3496 tail
= XCONS (tail
)->cdr
)
3498 buf
= XCONS (XCONS (tail
)->car
)->cdr
;
3501 if (!NILP (current_only
)
3502 && b
!= current_buffer
)
3505 /* Check for auto save enabled
3506 and file changed since last auto save
3507 and file changed since last real save. */
3508 if (XTYPE (b
->auto_save_file_name
) == Lisp_String
3509 && b
->save_modified
< BUF_MODIFF (b
)
3510 && b
->auto_save_modified
< BUF_MODIFF (b
)
3511 /* -1 means we've turned off autosaving for a while--see below. */
3512 && XINT (b
->save_length
) >= 0
3513 && (do_handled_files
3514 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
))))
3516 EMACS_TIME before_time
, after_time
;
3518 EMACS_GET_TIME (before_time
);
3520 /* If we had a failure, don't try again for 20 minutes. */
3521 if (b
->auto_save_failure_time
>= 0
3522 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
3525 if ((XFASTINT (b
->save_length
) * 10
3526 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
3527 /* A short file is likely to change a large fraction;
3528 spare the user annoying messages. */
3529 && XFASTINT (b
->save_length
) > 5000
3530 /* These messages are frequent and annoying for `*mail*'. */
3531 && !EQ (b
->filename
, Qnil
)
3532 && NILP (no_message
))
3534 /* It has shrunk too much; turn off auto-saving here. */
3535 message ("Buffer %s has shrunk a lot; auto save turned off there",
3536 XSTRING (b
->name
)->data
);
3537 /* Turn off auto-saving until there's a real save,
3538 and prevent any more warnings. */
3539 XSET (b
->save_length
, Lisp_Int
, -1);
3540 Fsleep_for (make_number (1), Qnil
);
3543 set_buffer_internal (b
);
3544 if (!auto_saved
&& NILP (no_message
))
3545 message1 ("Auto-saving...");
3546 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
3548 b
->auto_save_modified
= BUF_MODIFF (b
);
3549 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3550 set_buffer_internal (old
);
3552 EMACS_GET_TIME (after_time
);
3554 /* If auto-save took more than 60 seconds,
3555 assume it was an NFS failure that got a timeout. */
3556 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
3557 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
3561 /* Prevent another auto save till enough input events come in. */
3562 record_auto_save ();
3564 if (auto_saved
&& NILP (no_message
))
3567 message2 (omessage
, omessage_length
);
3569 message1 ("Auto-saving...done");
3578 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
3579 Sset_buffer_auto_saved
, 0, 0, 0,
3580 "Mark current buffer as auto-saved with its current text.\n\
3581 No auto-save file will be written until the buffer changes again.")
3584 current_buffer
->auto_save_modified
= MODIFF
;
3585 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3586 current_buffer
->auto_save_failure_time
= -1;
3590 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
3591 Sclear_buffer_auto_save_failure
, 0, 0, 0,
3592 "Clear any record of a recent auto-save failure in the current buffer.")
3595 current_buffer
->auto_save_failure_time
= -1;
3599 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
3601 "Return t if buffer has been auto-saved since last read in or saved.")
3604 return (current_buffer
->save_modified
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
3607 /* Reading and completing file names */
3608 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
3610 /* In the string VAL, change each $ to $$ and return the result. */
3613 double_dollars (val
)
3616 register unsigned char *old
, *new;
3620 osize
= XSTRING (val
)->size
;
3621 /* Quote "$" as "$$" to get it past substitute-in-file-name */
3622 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
3623 if (*old
++ == '$') count
++;
3626 old
= XSTRING (val
)->data
;
3627 val
= Fmake_string (make_number (osize
+ count
), make_number (0));
3628 new = XSTRING (val
)->data
;
3629 for (n
= osize
; n
> 0; n
--)
3642 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
3644 "Internal subroutine for read-file-name. Do not call this.")
3645 (string
, dir
, action
)
3646 Lisp_Object string
, dir
, action
;
3647 /* action is nil for complete, t for return list of completions,
3648 lambda for verify final value */
3650 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
3652 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3659 /* No need to protect ACTION--we only compare it with t and nil. */
3660 GCPRO4 (string
, realdir
, name
, specdir
);
3662 if (XSTRING (string
)->size
== 0)
3664 if (EQ (action
, Qlambda
))
3672 orig_string
= string
;
3673 string
= Fsubstitute_in_file_name (string
);
3674 changed
= NILP (Fstring_equal (string
, orig_string
));
3675 name
= Ffile_name_nondirectory (string
);
3676 val
= Ffile_name_directory (string
);
3678 realdir
= Fexpand_file_name (val
, realdir
);
3683 specdir
= Ffile_name_directory (string
);
3684 val
= Ffile_name_completion (name
, realdir
);
3686 if (XTYPE (val
) != Lisp_String
)
3693 if (!NILP (specdir
))
3694 val
= concat2 (specdir
, val
);
3696 return double_dollars (val
);
3699 #endif /* not VMS */
3703 if (EQ (action
, Qt
))
3704 return Ffile_name_all_completions (name
, realdir
);
3705 /* Only other case actually used is ACTION = lambda */
3707 /* Supposedly this helps commands such as `cd' that read directory names,
3708 but can someone explain how it helps them? -- RMS */
3709 if (XSTRING (name
)->size
== 0)
3712 return Ffile_exists_p (string
);
3715 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
3716 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
3717 Value is not expanded---you must call `expand-file-name' yourself.\n\
3718 Default name to DEFAULT if user enters a null string.\n\
3719 (If DEFAULT is omitted, the visited file name is used.)\n\
3720 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
3721 Non-nil and non-t means also require confirmation after completion.\n\
3722 Fifth arg INITIAL specifies text to start with.\n\
3723 DIR defaults to current buffer's directory default.")
3724 (prompt
, dir
, defalt
, mustmatch
, initial
)
3725 Lisp_Object prompt
, dir
, defalt
, mustmatch
, initial
;
3727 Lisp_Object val
, insdef
, insdef1
, tem
;
3728 struct gcpro gcpro1
, gcpro2
;
3729 register char *homedir
;
3733 dir
= current_buffer
->directory
;
3735 defalt
= current_buffer
->filename
;
3737 /* If dir starts with user's homedir, change that to ~. */
3738 homedir
= (char *) egetenv ("HOME");
3740 && XTYPE (dir
) == Lisp_String
3741 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
3742 && XSTRING (dir
)->data
[strlen (homedir
)] == '/')
3744 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
3745 XSTRING (dir
)->size
- strlen (homedir
) + 1);
3746 XSTRING (dir
)->data
[0] = '~';
3749 if (insert_default_directory
)
3752 if (!NILP (initial
))
3754 Lisp_Object args
[2], pos
;
3758 insdef
= Fconcat (2, args
);
3759 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
3760 insdef1
= Fcons (double_dollars (insdef
), pos
);
3763 insdef1
= double_dollars (insdef
);
3765 else if (!NILP (initial
))
3768 insdef1
= Fcons (double_dollars (insdef
), 0);
3771 insdef
= Qnil
, insdef1
= Qnil
;
3774 count
= specpdl_ptr
- specpdl
;
3775 specbind (intern ("completion-ignore-case"), Qt
);
3778 GCPRO2 (insdef
, defalt
);
3779 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
3780 dir
, mustmatch
, insdef1
,
3781 Qfile_name_history
);
3784 unbind_to (count
, Qnil
);
3789 error ("No file name specified");
3790 tem
= Fstring_equal (val
, insdef
);
3791 if (!NILP (tem
) && !NILP (defalt
))
3793 if (XSTRING (val
)->size
== 0 && NILP (insdef
))
3798 error ("No default file name");
3800 return Fsubstitute_in_file_name (val
);
3803 #if 0 /* Old version */
3804 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
3805 /* Don't confuse make-docfile by having two doc strings for this function.
3806 make-docfile does not pay attention to #if, for good reason! */
3808 (prompt
, dir
, defalt
, mustmatch
, initial
)
3809 Lisp_Object prompt
, dir
, defalt
, mustmatch
, initial
;
3811 Lisp_Object val
, insdef
, tem
;
3812 struct gcpro gcpro1
, gcpro2
;
3813 register char *homedir
;
3817 dir
= current_buffer
->directory
;
3819 defalt
= current_buffer
->filename
;
3821 /* If dir starts with user's homedir, change that to ~. */
3822 homedir
= (char *) egetenv ("HOME");
3824 && XTYPE (dir
) == Lisp_String
3825 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
3826 && XSTRING (dir
)->data
[strlen (homedir
)] == '/')
3828 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
3829 XSTRING (dir
)->size
- strlen (homedir
) + 1);
3830 XSTRING (dir
)->data
[0] = '~';
3833 if (!NILP (initial
))
3835 else if (insert_default_directory
)
3838 insdef
= build_string ("");
3841 count
= specpdl_ptr
- specpdl
;
3842 specbind (intern ("completion-ignore-case"), Qt
);
3845 GCPRO2 (insdef
, defalt
);
3846 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
3848 insert_default_directory
? insdef
: Qnil
,
3849 Qfile_name_history
);
3852 unbind_to (count
, Qnil
);
3857 error ("No file name specified");
3858 tem
= Fstring_equal (val
, insdef
);
3859 if (!NILP (tem
) && !NILP (defalt
))
3861 return Fsubstitute_in_file_name (val
);
3863 #endif /* Old version */
3867 Qexpand_file_name
= intern ("expand-file-name");
3868 Qdirectory_file_name
= intern ("directory-file-name");
3869 Qfile_name_directory
= intern ("file-name-directory");
3870 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
3871 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
3872 Qfile_name_as_directory
= intern ("file-name-as-directory");
3873 Qcopy_file
= intern ("copy-file");
3874 Qmake_directory
= intern ("make-directory");
3875 Qdelete_directory
= intern ("delete-directory");
3876 Qdelete_file
= intern ("delete-file");
3877 Qrename_file
= intern ("rename-file");
3878 Qadd_name_to_file
= intern ("add-name-to-file");
3879 Qmake_symbolic_link
= intern ("make-symbolic-link");
3880 Qfile_exists_p
= intern ("file-exists-p");
3881 Qfile_executable_p
= intern ("file-executable-p");
3882 Qfile_readable_p
= intern ("file-readable-p");
3883 Qfile_symlink_p
= intern ("file-symlink-p");
3884 Qfile_writable_p
= intern ("file-writable-p");
3885 Qfile_directory_p
= intern ("file-directory-p");
3886 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
3887 Qfile_modes
= intern ("file-modes");
3888 Qset_file_modes
= intern ("set-file-modes");
3889 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
3890 Qinsert_file_contents
= intern ("insert-file-contents");
3891 Qwrite_region
= intern ("write-region");
3892 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
3893 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
3895 staticpro (&Qexpand_file_name
);
3896 staticpro (&Qdirectory_file_name
);
3897 staticpro (&Qfile_name_directory
);
3898 staticpro (&Qfile_name_nondirectory
);
3899 staticpro (&Qunhandled_file_name_directory
);
3900 staticpro (&Qfile_name_as_directory
);
3901 staticpro (&Qcopy_file
);
3902 staticpro (&Qmake_directory
);
3903 staticpro (&Qdelete_directory
);
3904 staticpro (&Qdelete_file
);
3905 staticpro (&Qrename_file
);
3906 staticpro (&Qadd_name_to_file
);
3907 staticpro (&Qmake_symbolic_link
);
3908 staticpro (&Qfile_exists_p
);
3909 staticpro (&Qfile_executable_p
);
3910 staticpro (&Qfile_readable_p
);
3911 staticpro (&Qfile_symlink_p
);
3912 staticpro (&Qfile_writable_p
);
3913 staticpro (&Qfile_directory_p
);
3914 staticpro (&Qfile_accessible_directory_p
);
3915 staticpro (&Qfile_modes
);
3916 staticpro (&Qset_file_modes
);
3917 staticpro (&Qfile_newer_than_file_p
);
3918 staticpro (&Qinsert_file_contents
);
3919 staticpro (&Qwrite_region
);
3920 staticpro (&Qverify_visited_file_modtime
);
3922 Qfile_name_history
= intern ("file-name-history");
3923 Fset (Qfile_name_history
, Qnil
);
3924 staticpro (&Qfile_name_history
);
3926 Qfile_error
= intern ("file-error");
3927 staticpro (&Qfile_error
);
3928 Qfile_already_exists
= intern("file-already-exists");
3929 staticpro (&Qfile_already_exists
);
3932 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
3933 staticpro (&Qfind_buffer_file_type
);
3936 Qcar_less_than_car
= intern ("car-less-than-car");
3937 staticpro (&Qcar_less_than_car
);
3939 Fput (Qfile_error
, Qerror_conditions
,
3940 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
3941 Fput (Qfile_error
, Qerror_message
,
3942 build_string ("File error"));
3944 Fput (Qfile_already_exists
, Qerror_conditions
,
3945 Fcons (Qfile_already_exists
,
3946 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
3947 Fput (Qfile_already_exists
, Qerror_message
,
3948 build_string ("File already exists"));
3950 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
3951 "*Non-nil means when reading a filename start with default dir in minibuffer.");
3952 insert_default_directory
= 1;
3954 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
3955 "*Non-nil means write new files with record format `stmlf'.\n\
3956 nil means use format `var'. This variable is meaningful only on VMS.");
3957 vms_stmlf_recfm
= 0;
3959 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
3960 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
3961 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
3964 The first argument given to HANDLER is the name of the I/O primitive\n\
3965 to be handled; the remaining arguments are the arguments that were\n\
3966 passed to that primitive. For example, if you do\n\
3967 (file-exists-p FILENAME)\n\
3968 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
3969 (funcall HANDLER 'file-exists-p FILENAME)\n\
3970 The function `find-file-name-handler' checks this list for a handler\n\
3971 for its argument.");
3972 Vfile_name_handler_alist
= Qnil
;
3974 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
3975 "A list of functions to be called at the end of `insert-file-contents'.\n\
3976 Each is passed one argument, the number of bytes inserted. It should return\n\
3977 the new byte count, and leave point the same. If `insert-file-contents' is\n\
3978 intercepted by a handler from `file-name-handler-alist', that handler is\n\
3979 responsible for calling the after-insert-file-functions if appropriate.");
3980 Vafter_insert_file_functions
= Qnil
;
3982 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
3983 "A list of functions to be called at the start of `write-region'.\n\
3984 Each is passed two arguments, START and END as for `write-region'. It should\n\
3985 return a list of pairs (POSITION . STRING) of strings to be effectively\n\
3986 inserted at the specified positions of the file being written (1 means to\n\
3987 insert before the first byte written). The POSITIONs must be sorted into\n\
3988 increasing order. If there are several functions in the list, the several\n\
3989 lists are merged destructively.");
3990 Vwrite_region_annotate_functions
= Qnil
;
3992 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
3993 "A list of file names for which handlers should not be used.");
3994 Vinhibit_file_name_handlers
= Qnil
;
3996 defsubr (&Sfind_file_name_handler
);
3997 defsubr (&Sfile_name_directory
);
3998 defsubr (&Sfile_name_nondirectory
);
3999 defsubr (&Sunhandled_file_name_directory
);
4000 defsubr (&Sfile_name_as_directory
);
4001 defsubr (&Sdirectory_file_name
);
4002 defsubr (&Smake_temp_name
);
4003 defsubr (&Sexpand_file_name
);
4004 defsubr (&Ssubstitute_in_file_name
);
4005 defsubr (&Scopy_file
);
4006 defsubr (&Smake_directory_internal
);
4007 defsubr (&Sdelete_directory
);
4008 defsubr (&Sdelete_file
);
4009 defsubr (&Srename_file
);
4010 defsubr (&Sadd_name_to_file
);
4012 defsubr (&Smake_symbolic_link
);
4013 #endif /* S_IFLNK */
4015 defsubr (&Sdefine_logical_name
);
4018 defsubr (&Ssysnetunam
);
4019 #endif /* HPUX_NET */
4020 defsubr (&Sfile_name_absolute_p
);
4021 defsubr (&Sfile_exists_p
);
4022 defsubr (&Sfile_executable_p
);
4023 defsubr (&Sfile_readable_p
);
4024 defsubr (&Sfile_writable_p
);
4025 defsubr (&Sfile_symlink_p
);
4026 defsubr (&Sfile_directory_p
);
4027 defsubr (&Sfile_accessible_directory_p
);
4028 defsubr (&Sfile_modes
);
4029 defsubr (&Sset_file_modes
);
4030 defsubr (&Sset_default_file_modes
);
4031 defsubr (&Sdefault_file_modes
);
4032 defsubr (&Sfile_newer_than_file_p
);
4033 defsubr (&Sinsert_file_contents
);
4034 defsubr (&Swrite_region
);
4035 defsubr (&Scar_less_than_car
);
4036 defsubr (&Sverify_visited_file_modtime
);
4037 defsubr (&Sclear_visited_file_modtime
);
4038 defsubr (&Svisited_file_modtime
);
4039 defsubr (&Sset_visited_file_modtime
);
4040 defsubr (&Sdo_auto_save
);
4041 defsubr (&Sset_buffer_auto_saved
);
4042 defsubr (&Sclear_buffer_auto_save_failure
);
4043 defsubr (&Srecent_auto_save_p
);
4045 defsubr (&Sread_file_name_internal
);
4046 defsubr (&Sread_file_name
);
4049 defsubr (&Sunix_sync
);