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>
25 #if !defined (S_ISLNK) && defined (S_IFLNK)
26 # define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
29 #if !defined (S_ISREG) && defined (S_IFREG)
30 # define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
41 #include <sys/param.h>
59 extern char *strerror ();
74 #include "intervals.h"
100 #define min(a, b) ((a) < (b) ? (a) : (b))
101 #define max(a, b) ((a) > (b) ? (a) : (b))
103 /* Nonzero during writing of auto-save files */
106 /* Set by auto_save_1 to mode of original file so Fwrite_region will create
107 a new file with the same mode as the original */
108 int auto_save_mode_bits
;
110 /* Alist of elements (REGEXP . HANDLER) for file names
111 whose I/O is done with a special handler. */
112 Lisp_Object Vfile_name_handler_alist
;
114 /* Functions to be called to process text properties in inserted file. */
115 Lisp_Object Vafter_insert_file_functions
;
117 /* Functions to be called to create text property annotations for file. */
118 Lisp_Object Vwrite_region_annotate_functions
;
120 /* Nonzero means, when reading a filename in the minibuffer,
121 start out by inserting the default directory into the minibuffer. */
122 int insert_default_directory
;
124 /* On VMS, nonzero means write new files with record format stmlf.
125 Zero means use var format. */
128 Lisp_Object Qfile_error
, Qfile_already_exists
;
130 Lisp_Object Qfile_name_history
;
132 Lisp_Object Qcar_less_than_car
;
134 report_file_error (string
, data
)
138 Lisp_Object errstring
;
140 errstring
= build_string (strerror (errno
));
142 /* System error messages are capitalized. Downcase the initial
143 unless it is followed by a slash. */
144 if (XSTRING (errstring
)->data
[1] != '/')
145 XSTRING (errstring
)->data
[0] = DOWNCASE (XSTRING (errstring
)->data
[0]);
148 Fsignal (Qfile_error
,
149 Fcons (build_string (string
), Fcons (errstring
, data
)));
152 close_file_unwind (fd
)
155 close (XFASTINT (fd
));
158 Lisp_Object Qexpand_file_name
;
159 Lisp_Object Qdirectory_file_name
;
160 Lisp_Object Qfile_name_directory
;
161 Lisp_Object Qfile_name_nondirectory
;
162 Lisp_Object Qunhandled_file_name_directory
;
163 Lisp_Object Qfile_name_as_directory
;
164 Lisp_Object Qcopy_file
;
165 Lisp_Object Qmake_directory
;
166 Lisp_Object Qdelete_directory
;
167 Lisp_Object Qdelete_file
;
168 Lisp_Object Qrename_file
;
169 Lisp_Object Qadd_name_to_file
;
170 Lisp_Object Qmake_symbolic_link
;
171 Lisp_Object Qfile_exists_p
;
172 Lisp_Object Qfile_executable_p
;
173 Lisp_Object Qfile_readable_p
;
174 Lisp_Object Qfile_symlink_p
;
175 Lisp_Object Qfile_writable_p
;
176 Lisp_Object Qfile_directory_p
;
177 Lisp_Object Qfile_accessible_directory_p
;
178 Lisp_Object Qfile_modes
;
179 Lisp_Object Qset_file_modes
;
180 Lisp_Object Qfile_newer_than_file_p
;
181 Lisp_Object Qinsert_file_contents
;
182 Lisp_Object Qwrite_region
;
183 Lisp_Object Qverify_visited_file_modtime
;
184 Lisp_Object Qset_visited_file_modtime
;
186 DEFUN ("find-file-name-handler", Ffind_file_name_handler
, Sfind_file_name_handler
, 1, 1, 0,
187 "Return FILENAME's handler function, if its syntax is handled specially.\n\
188 Otherwise, return nil.\n\
189 A file name is handled if one of the regular expressions in\n\
190 `file-name-handler-alist' matches it.")
192 Lisp_Object filename
;
194 /* This function must not munge the match data. */
197 CHECK_STRING (filename
, 0);
199 for (chain
= Vfile_name_handler_alist
; XTYPE (chain
) == Lisp_Cons
;
200 chain
= XCONS (chain
)->cdr
)
203 elt
= XCONS (chain
)->car
;
204 if (XTYPE (elt
) == Lisp_Cons
)
207 string
= XCONS (elt
)->car
;
208 if (XTYPE (string
) == Lisp_String
209 && fast_string_match (string
, filename
) >= 0)
210 return XCONS (elt
)->cdr
;
218 DEFUN ("file-name-directory", Ffile_name_directory
, Sfile_name_directory
,
220 "Return the directory component in file name NAME.\n\
221 Return nil if NAME does not include a directory.\n\
222 Otherwise return a directory spec.\n\
223 Given a Unix syntax file name, returns a string ending in slash;\n\
224 on VMS, perhaps instead a string ending in `:', `]' or `>'.")
228 register unsigned char *beg
;
229 register unsigned char *p
;
232 CHECK_STRING (file
, 0);
234 /* If the file name has special constructs in it,
235 call the corresponding file handler. */
236 handler
= Ffind_file_name_handler (file
);
238 return call2 (handler
, Qfile_name_directory
, file
);
240 #ifdef FILE_SYSTEM_CASE
241 file
= FILE_SYSTEM_CASE (file
);
243 beg
= XSTRING (file
)->data
;
244 p
= beg
+ XSTRING (file
)->size
;
246 while (p
!= beg
&& p
[-1] != '/'
248 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
258 /* Expansion of "c:" to drive and default directory. */
259 if (p
== beg
+ 2 && beg
[1] == ':')
261 int drive
= (*beg
) - 'a';
262 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
263 unsigned char *res
= alloca (MAXPATHLEN
+ 5);
264 if (getdefdir (drive
+ 1, res
+ 2))
266 res
[0] = drive
+ 'a';
268 if (res
[strlen (res
) - 1] != '/')
271 p
= beg
+ strlen (beg
);
275 return make_string (beg
, p
- beg
);
278 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory
, Sfile_name_nondirectory
,
280 "Return file name NAME sans its directory.\n\
281 For example, in a Unix-syntax file name,\n\
282 this is everything after the last slash,\n\
283 or the entire name if it contains no slash.")
287 register unsigned char *beg
, *p
, *end
;
290 CHECK_STRING (file
, 0);
292 /* If the file name has special constructs in it,
293 call the corresponding file handler. */
294 handler
= Ffind_file_name_handler (file
);
296 return call2 (handler
, Qfile_name_nondirectory
, file
);
298 beg
= XSTRING (file
)->data
;
299 end
= p
= beg
+ XSTRING (file
)->size
;
301 while (p
!= beg
&& p
[-1] != '/'
303 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
310 return make_string (p
, end
- p
);
313 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory
, Sunhandled_file_name_directory
, 1, 1, 0,
314 "Return a directly usable directory name somehow associated with FILENAME.\n\
315 A `directly usable' directory name is one that may be used without the\n\
316 intervention of any file handler.\n\
317 If FILENAME is a directly usable file itself, return\n\
318 (file-name-directory FILENAME).\n\
319 The `call-process' and `start-process' functions use this function to\n\
320 get a current directory to run processes in.")
322 Lisp_Object filename
;
326 /* If the file name has special constructs in it,
327 call the corresponding file handler. */
328 handler
= Ffind_file_name_handler (filename
);
330 return call2 (handler
, Qunhandled_file_name_directory
, filename
);
332 return Ffile_name_directory (filename
);
337 file_name_as_directory (out
, in
)
340 int size
= strlen (in
) - 1;
345 /* Is it already a directory string? */
346 if (in
[size
] == ':' || in
[size
] == ']' || in
[size
] == '>')
348 /* Is it a VMS directory file name? If so, hack VMS syntax. */
349 else if (! index (in
, '/')
350 && ((size
> 3 && ! strcmp (&in
[size
- 3], ".DIR"))
351 || (size
> 3 && ! strcmp (&in
[size
- 3], ".dir"))
352 || (size
> 5 && (! strncmp (&in
[size
- 5], ".DIR", 4)
353 || ! strncmp (&in
[size
- 5], ".dir", 4))
354 && (in
[size
- 1] == '.' || in
[size
- 1] == ';')
355 && in
[size
] == '1')))
357 register char *p
, *dot
;
361 dir:x.dir --> dir:[x]
362 dir:[x]y.dir --> dir:[x.y] */
364 while (p
!= in
&& *p
!= ':' && *p
!= '>' && *p
!= ']') p
--;
367 strncpy (out
, in
, p
- in
);
386 dot
= index (p
, '.');
389 /* blindly remove any extension */
390 size
= strlen (out
) + (dot
- p
);
391 strncat (out
, p
, dot
- p
);
402 /* For Unix syntax, Append a slash if necessary */
404 if (out
[size
] != ':' && out
[size
] != '/')
406 if (out
[size
] != '/')
413 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
414 Sfile_name_as_directory
, 1, 1, 0,
415 "Return a string representing file FILENAME interpreted as a directory.\n\
416 This operation exists because a directory is also a file, but its name as\n\
417 a directory is different from its name as a file.\n\
418 The result can be used as the value of `default-directory'\n\
419 or passed as second argument to `expand-file-name'.\n\
420 For a Unix-syntax file name, just appends a slash.\n\
421 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
428 CHECK_STRING (file
, 0);
432 /* If the file name has special constructs in it,
433 call the corresponding file handler. */
434 handler
= Ffind_file_name_handler (file
);
436 return call2 (handler
, Qfile_name_as_directory
, file
);
438 buf
= (char *) alloca (XSTRING (file
)->size
+ 10);
439 return build_string (file_name_as_directory (buf
, XSTRING (file
)->data
));
443 * Convert from directory name to filename.
445 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
446 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
447 * On UNIX, it's simple: just make sure there is a terminating /
449 * Value is nonzero if the string output is different from the input.
452 directory_file_name (src
, dst
)
460 struct FAB fab
= cc$rms_fab
;
461 struct NAM nam
= cc$rms_nam
;
462 char esa
[NAM$C_MAXRSS
];
467 if (! index (src
, '/')
468 && (src
[slen
- 1] == ']'
469 || src
[slen
- 1] == ':'
470 || src
[slen
- 1] == '>'))
472 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
474 fab
.fab$b_fns
= slen
;
475 fab
.fab$l_nam
= &nam
;
476 fab
.fab$l_fop
= FAB$M_NAM
;
479 nam
.nam$b_ess
= sizeof esa
;
480 nam
.nam$b_nop
|= NAM$M_SYNCHK
;
482 /* We call SYS$PARSE to handle such things as [--] for us. */
483 if (SYS$
PARSE(&fab
, 0, 0) == RMS$_NORMAL
)
485 slen
= nam
.nam$b_esl
;
486 if (esa
[slen
- 1] == ';' && esa
[slen
- 2] == '.')
491 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
493 /* what about when we have logical_name:???? */
494 if (src
[slen
- 1] == ':')
495 { /* Xlate logical name and see what we get */
496 ptr
= strcpy (dst
, src
); /* upper case for getenv */
499 if ('a' <= *ptr
&& *ptr
<= 'z')
503 dst
[slen
- 1] = 0; /* remove colon */
504 if (!(src
= egetenv (dst
)))
506 /* should we jump to the beginning of this procedure?
507 Good points: allows us to use logical names that xlate
509 Bad points: can be a problem if we just translated to a device
511 For now, I'll punt and always expect VMS names, and hope for
514 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
515 { /* no recursion here! */
521 { /* not a directory spec */
526 bracket
= src
[slen
- 1];
528 /* If bracket is ']' or '>', bracket - 2 is the corresponding
530 ptr
= index (src
, bracket
- 2);
532 { /* no opening bracket */
536 if (!(rptr
= rindex (src
, '.')))
539 strncpy (dst
, src
, slen
);
543 dst
[slen
++] = bracket
;
548 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
549 then translate the device and recurse. */
550 if (dst
[slen
- 1] == ':'
551 && dst
[slen
- 2] != ':' /* skip decnet nodes */
552 && strcmp(src
+ slen
, "[000000]") == 0)
554 dst
[slen
- 1] = '\0';
555 if ((ptr
= egetenv (dst
))
556 && (rlen
= strlen (ptr
) - 1) > 0
557 && (ptr
[rlen
] == ']' || ptr
[rlen
] == '>')
558 && ptr
[rlen
- 1] == '.')
560 char * buf
= (char *) alloca (strlen (ptr
) + 1);
564 return directory_file_name (buf
, dst
);
569 strcat (dst
, "[000000]");
573 rlen
= strlen (rptr
) - 1;
574 strncat (dst
, rptr
, rlen
);
575 dst
[slen
+ rlen
] = '\0';
576 strcat (dst
, ".DIR.1");
580 /* Process as Unix format: just remove any final slash.
581 But leave "/" unchanged; do not change it to "". */
584 && dst
[slen
- 1] == '/'
586 && dst
[slen
- 2] != ':'
593 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
595 "Returns the file name of the directory named DIR.\n\
596 This is the name of the file that holds the data for the directory DIR.\n\
597 This operation exists because a directory is also a file, but its name as\n\
598 a directory is different from its name as a file.\n\
599 In Unix-syntax, this function just removes the final slash.\n\
600 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
601 it returns a file name such as \"[X]Y.DIR.1\".")
603 Lisp_Object directory
;
608 CHECK_STRING (directory
, 0);
610 if (NILP (directory
))
613 /* If the file name has special constructs in it,
614 call the corresponding file handler. */
615 handler
= Ffind_file_name_handler (directory
);
617 return call2 (handler
, Qdirectory_file_name
, directory
);
620 /* 20 extra chars is insufficient for VMS, since we might perform a
621 logical name translation. an equivalence string can be up to 255
622 chars long, so grab that much extra space... - sss */
623 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20 + 255);
625 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20);
627 directory_file_name (XSTRING (directory
)->data
, buf
);
628 return build_string (buf
);
631 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
632 "Generate temporary file name (string) starting with PREFIX (a string).\n\
633 The Emacs process number forms part of the result,\n\
634 so there is no danger of generating a name being used by another process.")
639 val
= concat2 (prefix
, build_string ("XXXXXX"));
640 mktemp (XSTRING (val
)->data
);
644 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
645 "Convert FILENAME to absolute, and canonicalize it.\n\
646 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
647 (does not start with slash); if DEFAULT is nil or missing,\n\
648 the current buffer's value of default-directory is used.\n\
649 Path components that are `.' are removed, and \n\
650 path components followed by `..' are removed, along with the `..' itself;\n\
651 note that these simplifications are done without checking the resulting\n\
652 paths in the file system.\n\
653 An initial `~/' expands to your home directory.\n\
654 An initial `~USER/' expands to USER's home directory.\n\
655 See also the function `substitute-in-file-name'.")
657 Lisp_Object name
, defalt
;
661 register unsigned char *newdir
, *p
, *o
;
663 unsigned char *target
;
666 unsigned char * colon
= 0;
667 unsigned char * close
= 0;
668 unsigned char * slash
= 0;
669 unsigned char * brack
= 0;
670 int lbrack
= 0, rbrack
= 0;
673 #ifdef MSDOS /* Demacs 1.1.2 91/10/20 Manabu Higashida */
676 unsigned char *tmp
, *defdir
;
680 CHECK_STRING (name
, 0);
682 /* If the file name has special constructs in it,
683 call the corresponding file handler. */
684 handler
= Ffind_file_name_handler (name
);
686 return call3 (handler
, Qexpand_file_name
, name
, defalt
);
688 /* Use the buffer's default-directory if DEFALT is omitted. */
690 defalt
= current_buffer
->directory
;
691 CHECK_STRING (defalt
, 1);
693 /* Make sure DEFALT is properly expanded.
694 It would be better to do this down below where we actually use
695 defalt. Unfortunately, calling Fexpand_file_name recursively
696 could invoke GC, and the strings might be relocated. This would
697 be annoying because we have pointers into strings lying around
698 that would need adjusting, and people would add new pointers to
699 the code and forget to adjust them, resulting in intermittent bugs.
700 Putting this call here avoids all that crud.
702 The EQ test avoids infinite recursion. */
703 if (! NILP (defalt
) && !EQ (defalt
, name
)
704 /* This saves time in a common case. */
705 && XSTRING (defalt
)->data
[0] != '/')
710 defalt
= Fexpand_file_name (defalt
, Qnil
);
715 /* Filenames on VMS are always upper case. */
716 name
= Fupcase (name
);
718 #ifdef FILE_SYSTEM_CASE
719 name
= FILE_SYSTEM_CASE (name
);
722 nm
= XSTRING (name
)->data
;
725 /* firstly, strip drive name. */
727 unsigned char *colon
= rindex (nm
, ':');
733 drive
= tolower (colon
[-1]) - 'a';
737 defdir
= alloca (MAXPATHLEN
+ 1);
738 relpath
= getdefdir (drive
+ 1, defdir
);
744 /* If nm is absolute, flush ...// and detect /./ and /../.
745 If no /./ or /../ we can return right away. */
753 /* If it turns out that the filename we want to return is just a
754 suffix of FILENAME, we don't need to go through and edit
755 things; we just need to construct a new string using data
756 starting at the middle of FILENAME. If we set lose to a
757 non-zero value, that means we've discovered that we can't do
764 /* Since we know the path is absolute, we can assume that each
765 element starts with a "/". */
767 /* "//" anywhere isn't necessarily hairy; we just start afresh
768 with the second slash. */
769 if (p
[0] == '/' && p
[1] == '/'
771 /* // at start of filename is meaningful on Apollo system */
777 /* "~" is hairy as the start of any path element. */
778 if (p
[0] == '/' && p
[1] == '~')
779 nm
= p
+ 1, lose
= 1;
781 /* "." and ".." are hairy. */
786 || (p
[2] == '.' && (p
[3] == '/'
793 /* if dev:[dir]/, move nm to / */
794 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
795 nm
= (brack
? brack
+ 1 : colon
+ 1);
804 /* VMS pre V4.4,convert '-'s in filenames. */
805 if (lbrack
== rbrack
)
807 if (dots
< 2) /* this is to allow negative version numbers */
812 if (lbrack
> rbrack
&&
813 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
814 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
820 /* count open brackets, reset close bracket pointer */
821 if (p
[0] == '[' || p
[0] == '<')
823 /* count close brackets, set close bracket pointer */
824 if (p
[0] == ']' || p
[0] == '>')
826 /* detect ][ or >< */
827 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
829 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
830 nm
= p
+ 1, lose
= 1;
831 if (p
[0] == ':' && (colon
|| slash
))
832 /* if dev1:[dir]dev2:, move nm to dev2: */
838 /* if /pathname/dev:, move nm to dev: */
841 /* if node::dev:, move colon following dev */
842 else if (colon
&& colon
[-1] == ':')
844 /* if dev1:dev2:, move nm to dev2: */
845 else if (colon
&& colon
[-1] != ':')
850 if (p
[0] == ':' && !colon
)
856 if (lbrack
== rbrack
)
859 else if (p
[0] == '.')
868 return build_string (sys_translate_unix (nm
));
871 if (nm
== XSTRING (name
)->data
)
873 return build_string (nm
);
878 /* Now determine directory to start with and put it in newdir */
882 if (nm
[0] == '~') /* prefix ~ */
888 || nm
[1] == 0) /* ~ by itself */
890 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
891 newdir
= (unsigned char *) "";
893 dostounix_filename (newdir
);
897 nm
++; /* Don't leave the slash in nm. */
900 else /* ~user/filename */
902 for (p
= nm
; *p
&& (*p
!= '/'
907 o
= (unsigned char *) alloca (p
- nm
+ 1);
908 bcopy ((char *) nm
, o
, p
- nm
);
911 pw
= (struct passwd
*) getpwnam (o
+ 1);
914 newdir
= (unsigned char *) pw
-> pw_dir
;
916 nm
= p
+ 1; /* skip the terminator */
922 /* If we don't find a user of that name, leave the name
923 unchanged; don't move nm forward to p. */
936 newdir
= XSTRING (defalt
)->data
;
940 if (newdir
== 0 && relpath
)
945 /* Get rid of any slash at the end of newdir. */
946 int length
= strlen (newdir
);
947 /* Adding `length > 1 &&' makes ~ expand into / when homedir
948 is the root dir. People disagree about whether that is right.
949 Anyway, we can't take the risk of this change now. */
951 if (newdir
[1] != ':' && length
> 1)
953 if (newdir
[length
- 1] == '/')
955 unsigned char *temp
= (unsigned char *) alloca (length
);
956 bcopy (newdir
, temp
, length
- 1);
957 temp
[length
- 1] = 0;
965 /* Now concatenate the directory and name to new space in the stack frame */
966 tlen
+= strlen (nm
) + 1;
968 /* Add reserved space for drive name. */
969 target
= (unsigned char *) alloca (tlen
+ 2) + 2;
971 target
= (unsigned char *) alloca (tlen
);
978 if (nm
[0] == 0 || nm
[0] == '/')
979 strcpy (target
, newdir
);
982 file_name_as_directory (target
, newdir
);
987 if (index (target
, '/'))
988 strcpy (target
, sys_translate_unix (target
));
991 /* Now canonicalize by removing /. and /foo/.. if they appear. */
999 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1005 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1006 /* brackets are offset from each other by 2 */
1009 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1010 /* convert [foo][bar] to [bar] */
1011 while (o
[-1] != '[' && o
[-1] != '<')
1013 else if (*p
== '-' && *o
!= '.')
1016 else if (p
[0] == '-' && o
[-1] == '.' &&
1017 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1018 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1022 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1023 if (p
[1] == '.') /* foo.-.bar ==> bar*/
1025 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1027 /* else [foo.-] ==> [-] */
1033 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1034 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1044 else if (!strncmp (p
, "//", 2)
1046 /* // at start of filename is meaningful in Apollo system */
1054 else if (p
[0] == '/'
1059 /* If "/." is the entire filename, keep the "/". Otherwise,
1060 just delete the whole "/.". */
1061 if (o
== target
&& p
[2] == '\0')
1065 else if (!strncmp (p
, "/..", 3)
1066 /* `/../' is the "superroot" on certain file systems. */
1068 && (p
[3] == '/' || p
[3] == 0))
1070 while (o
!= target
&& *--o
!= '/')
1073 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1077 if (o
== target
&& *o
== '/')
1085 #endif /* not VMS */
1089 /* at last, set drive name. */
1090 if (target
[1] != ':')
1093 target
[0] = (drive
< 0 ? getdisk () : drive
) + 'a';
1098 return make_string (target
, o
- target
);
1101 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'.
1102 DEAFUN ("expand-file-name", Fexpand_file_name, Sexpand_file_name, 1, 2, 0,
1103 "Convert FILENAME to absolute, and canonicalize it.\n\
1104 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1105 (does not start with slash); if DEFAULT is nil or missing,\n\
1106 the current buffer's value of default-directory is used.\n\
1107 Filenames containing `.' or `..' as components are simplified;\n\
1108 initial `~/' expands to your home directory.\n\
1109 See also the function `substitute-in-file-name'.")
1111 Lisp_Object name, defalt;
1115 register unsigned char *newdir, *p, *o;
1117 unsigned char *target;
1121 unsigned char * colon = 0;
1122 unsigned char * close = 0;
1123 unsigned char * slash = 0;
1124 unsigned char * brack = 0;
1125 int lbrack = 0, rbrack = 0;
1129 CHECK_STRING (name
, 0);
1132 /* Filenames on VMS are always upper case. */
1133 name
= Fupcase (name
);
1136 nm
= XSTRING (name
)->data
;
1138 /* If nm is absolute, flush ...// and detect /./ and /../.
1139 If no /./ or /../ we can return right away. */
1151 if (p
[0] == '/' && p
[1] == '/'
1153 /* // at start of filename is meaningful on Apollo system */
1158 if (p
[0] == '/' && p
[1] == '~')
1159 nm
= p
+ 1, lose
= 1;
1160 if (p
[0] == '/' && p
[1] == '.'
1161 && (p
[2] == '/' || p
[2] == 0
1162 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1168 /* if dev:[dir]/, move nm to / */
1169 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1170 nm
= (brack
? brack
+ 1 : colon
+ 1);
1171 lbrack
= rbrack
= 0;
1179 /* VMS pre V4.4,convert '-'s in filenames. */
1180 if (lbrack
== rbrack
)
1182 if (dots
< 2) /* this is to allow negative version numbers */
1187 if (lbrack
> rbrack
&&
1188 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1189 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1195 /* count open brackets, reset close bracket pointer */
1196 if (p
[0] == '[' || p
[0] == '<')
1197 lbrack
++, brack
= 0;
1198 /* count close brackets, set close bracket pointer */
1199 if (p
[0] == ']' || p
[0] == '>')
1200 rbrack
++, brack
= p
;
1201 /* detect ][ or >< */
1202 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1204 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1205 nm
= p
+ 1, lose
= 1;
1206 if (p
[0] == ':' && (colon
|| slash
))
1207 /* if dev1:[dir]dev2:, move nm to dev2: */
1213 /* if /pathname/dev:, move nm to dev: */
1216 /* if node::dev:, move colon following dev */
1217 else if (colon
&& colon
[-1] == ':')
1219 /* if dev1:dev2:, move nm to dev2: */
1220 else if (colon
&& colon
[-1] != ':')
1225 if (p
[0] == ':' && !colon
)
1231 if (lbrack
== rbrack
)
1234 else if (p
[0] == '.')
1242 if (index (nm
, '/'))
1243 return build_string (sys_translate_unix (nm
));
1245 if (nm
== XSTRING (name
)->data
)
1247 return build_string (nm
);
1251 /* Now determine directory to start with and put it in NEWDIR */
1255 if (nm
[0] == '~') /* prefix ~ */
1260 || nm
[1] == 0)/* ~/filename */
1262 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1263 newdir
= (unsigned char *) "";
1266 nm
++; /* Don't leave the slash in nm. */
1269 else /* ~user/filename */
1271 /* Get past ~ to user */
1272 unsigned char *user
= nm
+ 1;
1273 /* Find end of name. */
1274 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1275 int len
= ptr
? ptr
- user
: strlen (user
);
1277 unsigned char *ptr1
= index (user
, ':');
1278 if (ptr1
!= 0 && ptr1
- user
< len
)
1281 /* Copy the user name into temp storage. */
1282 o
= (unsigned char *) alloca (len
+ 1);
1283 bcopy ((char *) user
, o
, len
);
1286 /* Look up the user name. */
1287 pw
= (struct passwd
*) getpwnam (o
+ 1);
1289 error ("\"%s\" isn't a registered user", o
+ 1);
1291 newdir
= (unsigned char *) pw
->pw_dir
;
1293 /* Discard the user name from NM. */
1300 #endif /* not VMS */
1304 defalt
= current_buffer
->directory
;
1305 CHECK_STRING (defalt
, 1);
1306 newdir
= XSTRING (defalt
)->data
;
1309 /* Now concatenate the directory and name to new space in the stack frame */
1311 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1312 target
= (unsigned char *) alloca (tlen
);
1318 if (nm
[0] == 0 || nm
[0] == '/')
1319 strcpy (target
, newdir
);
1322 file_name_as_directory (target
, newdir
);
1325 strcat (target
, nm
);
1327 if (index (target
, '/'))
1328 strcpy (target
, sys_translate_unix (target
));
1331 /* Now canonicalize by removing /. and /foo/.. if they appear */
1339 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1345 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1346 /* brackets are offset from each other by 2 */
1349 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1350 /* convert [foo][bar] to [bar] */
1351 while (o
[-1] != '[' && o
[-1] != '<')
1353 else if (*p
== '-' && *o
!= '.')
1356 else if (p
[0] == '-' && o
[-1] == '.' &&
1357 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1358 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1362 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1363 if (p
[1] == '.') /* foo.-.bar ==> bar*/
1365 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1367 /* else [foo.-] ==> [-] */
1373 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1374 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1384 else if (!strncmp (p
, "//", 2)
1386 /* // at start of filename is meaningful in Apollo system */
1394 else if (p
[0] == '/' && p
[1] == '.' &&
1395 (p
[2] == '/' || p
[2] == 0))
1397 else if (!strncmp (p
, "/..", 3)
1398 /* `/../' is the "superroot" on certain file systems. */
1400 && (p
[3] == '/' || p
[3] == 0))
1402 while (o
!= target
&& *--o
!= '/')
1405 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1409 if (o
== target
&& *o
== '/')
1417 #endif /* not VMS */
1420 return make_string (target
, o
- target
);
1424 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1425 Ssubstitute_in_file_name
, 1, 1, 0,
1426 "Substitute environment variables referred to in FILENAME.\n\
1427 `$FOO' where FOO is an environment variable name means to substitute\n\
1428 the value of that variable. The variable name should be terminated\n\
1429 with a character not a letter, digit or underscore; otherwise, enclose\n\
1430 the entire variable name in braces.\n\
1431 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1432 On VMS, `$' substitution is not done; this function does little and only\n\
1433 duplicates what `expand-file-name' does.")
1439 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1440 unsigned char *target
;
1442 int substituted
= 0;
1445 CHECK_STRING (string
, 0);
1447 nm
= XSTRING (string
)->data
;
1448 endp
= nm
+ XSTRING (string
)->size
;
1450 /* If /~ or // appears, discard everything through first slash. */
1452 for (p
= nm
; p
!= endp
; p
++)
1456 /* // at start of file name is meaningful in Apollo system */
1457 (p
[0] == '/' && p
- 1 != nm
)
1458 #else /* not APOLLO */
1460 #endif /* not APOLLO */
1464 (p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>' ||
1475 if (p
[0] && p
[1] == ':')
1484 return build_string (nm
);
1487 /* See if any variables are substituted into the string
1488 and find the total length of their values in `total' */
1490 for (p
= nm
; p
!= endp
;)
1500 /* "$$" means a single "$" */
1509 while (p
!= endp
&& *p
!= '}') p
++;
1510 if (*p
!= '}') goto missingclose
;
1516 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1520 /* Copy out the variable name */
1521 target
= (unsigned char *) alloca (s
- o
+ 1);
1522 strncpy (target
, o
, s
- o
);
1525 strupr (target
); /* $home == $HOME etc. */
1528 /* Get variable value */
1529 o
= (unsigned char *) egetenv (target
);
1530 if (!o
) goto badvar
;
1531 total
+= strlen (o
);
1538 /* If substitution required, recopy the string and do it */
1539 /* Make space in stack frame for the new copy */
1540 xnm
= (unsigned char *) alloca (XSTRING (string
)->size
+ total
+ 1);
1543 /* Copy the rest of the name through, replacing $ constructs with values */
1560 while (p
!= endp
&& *p
!= '}') p
++;
1561 if (*p
!= '}') goto missingclose
;
1567 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1571 /* Copy out the variable name */
1572 target
= (unsigned char *) alloca (s
- o
+ 1);
1573 strncpy (target
, o
, s
- o
);
1576 strupr (target
); /* $home == $HOME etc. */
1579 /* Get variable value */
1580 o
= (unsigned char *) egetenv (target
);
1590 /* If /~ or // appears, discard everything through first slash. */
1592 for (p
= xnm
; p
!= x
; p
++)
1595 /* // at start of file name is meaningful in Apollo system */
1596 (p
[0] == '/' && p
- 1 != xnm
)
1597 #else /* not APOLLO */
1599 #endif /* not APOLLO */
1601 && p
!= nm
&& p
[-1] == '/')
1604 else if (p
[0] && p
[1] == ':')
1608 return make_string (xnm
, x
- xnm
);
1611 error ("Bad format environment-variable substitution");
1613 error ("Missing \"}\" in environment-variable substitution");
1615 error ("Substituting nonexistent environment variable \"%s\"", target
);
1618 #endif /* not VMS */
1621 /* A slightly faster and more convenient way to get
1622 (directory-file-name (expand-file-name FOO)). */
1625 expand_and_dir_to_file (filename
, defdir
)
1626 Lisp_Object filename
, defdir
;
1628 register Lisp_Object abspath
;
1630 abspath
= Fexpand_file_name (filename
, defdir
);
1633 register int c
= XSTRING (abspath
)->data
[XSTRING (abspath
)->size
- 1];
1634 if (c
== ':' || c
== ']' || c
== '>')
1635 abspath
= Fdirectory_file_name (abspath
);
1638 /* Remove final slash, if any (unless path is root).
1639 stat behaves differently depending! */
1640 if (XSTRING (abspath
)->size
> 1
1641 && XSTRING (abspath
)->data
[XSTRING (abspath
)->size
- 1] == '/')
1642 /* We cannot take shortcuts; they might be wrong for magic file names. */
1643 abspath
= Fdirectory_file_name (abspath
);
1648 barf_or_query_if_file_exists (absname
, querystring
, interactive
)
1649 Lisp_Object absname
;
1650 unsigned char *querystring
;
1653 register Lisp_Object tem
;
1654 struct gcpro gcpro1
;
1656 if (access (XSTRING (absname
)->data
, 4) >= 0)
1659 Fsignal (Qfile_already_exists
,
1660 Fcons (build_string ("File already exists"),
1661 Fcons (absname
, Qnil
)));
1663 tem
= do_yes_or_no_p (format1 ("File %s already exists; %s anyway? ",
1664 XSTRING (absname
)->data
, querystring
));
1667 Fsignal (Qfile_already_exists
,
1668 Fcons (build_string ("File already exists"),
1669 Fcons (absname
, Qnil
)));
1674 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
1675 "fCopy file: \nFCopy %s to file: \np\nP",
1676 "Copy FILE to NEWNAME. Both args must be strings.\n\
1677 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
1678 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
1679 A number as third arg means request confirmation if NEWNAME already exists.\n\
1680 This is what happens in interactive use with M-x.\n\
1681 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
1682 last-modified time as the old one. (This works on only some systems.)\n\
1683 A prefix arg makes KEEP-TIME non-nil.")
1684 (filename
, newname
, ok_if_already_exists
, keep_date
)
1685 Lisp_Object filename
, newname
, ok_if_already_exists
, keep_date
;
1688 char buf
[16 * 1024];
1690 Lisp_Object handler
;
1691 struct gcpro gcpro1
, gcpro2
;
1692 int count
= specpdl_ptr
- specpdl
;
1693 Lisp_Object args
[6];
1694 int input_file_statable_p
;
1696 GCPRO2 (filename
, newname
);
1697 CHECK_STRING (filename
, 0);
1698 CHECK_STRING (newname
, 1);
1699 filename
= Fexpand_file_name (filename
, Qnil
);
1700 newname
= Fexpand_file_name (newname
, Qnil
);
1702 /* If the input file name has special constructs in it,
1703 call the corresponding file handler. */
1704 handler
= Ffind_file_name_handler (filename
);
1705 /* Likewise for output file name. */
1707 handler
= Ffind_file_name_handler (newname
);
1708 if (!NILP (handler
))
1709 return call5 (handler
, Qcopy_file
, filename
, newname
,
1710 ok_if_already_exists
, keep_date
);
1712 if (NILP (ok_if_already_exists
)
1713 || XTYPE (ok_if_already_exists
) == Lisp_Int
)
1714 barf_or_query_if_file_exists (newname
, "copy to it",
1715 XTYPE (ok_if_already_exists
) == Lisp_Int
);
1717 ifd
= open (XSTRING (filename
)->data
, 0);
1719 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
1721 record_unwind_protect (close_file_unwind
, make_number (ifd
));
1723 /* We can only copy regular files and symbolic links. Other files are not
1725 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
1727 #if defined (S_ISREG) && defined (S_ISLNK)
1728 if (input_file_statable_p
)
1730 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
1732 #if defined (EISDIR)
1733 /* Get a better looking error message. */
1736 report_file_error ("Non-regular file", Fcons (filename
, Qnil
));
1739 #endif /* S_ISREG && S_ISLNK */
1742 /* Create the copy file with the same record format as the input file */
1743 ofd
= sys_creat (XSTRING (newname
)->data
, 0666, ifd
);
1746 /* System's default file type was set to binary by _fmode in emacs.c. */
1747 ofd
= creat (XSTRING (newname
)->data
, S_IREAD
| S_IWRITE
);
1748 #else /* not MSDOS */
1749 ofd
= creat (XSTRING (newname
)->data
, 0666);
1750 #endif /* not MSDOS */
1753 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
1755 record_unwind_protect (close_file_unwind
, make_number (ofd
));
1759 while ((n
= read (ifd
, buf
, sizeof buf
)) > 0)
1760 if (write (ofd
, buf
, n
) != n
)
1761 report_file_error ("I/O error", Fcons (newname
, Qnil
));
1764 if (input_file_statable_p
)
1766 if (!NILP (keep_date
))
1768 EMACS_TIME atime
, mtime
;
1769 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
1770 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
1771 EMACS_SET_UTIMES (XSTRING (newname
)->data
, atime
, mtime
);
1774 if (!egetenv ("USE_DOMAIN_ACLS"))
1776 chmod (XSTRING (newname
)->data
, st
.st_mode
& 07777);
1779 /* Discard the unwind protects. */
1780 specpdl_ptr
= specpdl
+ count
;
1783 if (close (ofd
) < 0)
1784 report_file_error ("I/O error", Fcons (newname
, Qnil
));
1790 DEFUN ("make-directory-internal", Fmake_directory_internal
,
1791 Smake_directory_internal
, 1, 1, 0,
1792 "Create a directory. One argument, a file name string.")
1794 Lisp_Object dirname
;
1797 Lisp_Object handler
;
1799 CHECK_STRING (dirname
, 0);
1800 dirname
= Fexpand_file_name (dirname
, Qnil
);
1802 handler
= Ffind_file_name_handler (dirname
);
1803 if (!NILP (handler
))
1804 return call3 (handler
, Qmake_directory
, dirname
, Qnil
);
1806 dir
= XSTRING (dirname
)->data
;
1808 if (mkdir (dir
, 0777) != 0)
1809 report_file_error ("Creating directory", Flist (1, &dirname
));
1814 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
1815 "Delete a directory. One argument, a file name string.")
1817 Lisp_Object dirname
;
1820 Lisp_Object handler
;
1822 CHECK_STRING (dirname
, 0);
1823 dirname
= Fexpand_file_name (dirname
, Qnil
);
1824 dir
= XSTRING (dirname
)->data
;
1826 handler
= Ffind_file_name_handler (dirname
);
1827 if (!NILP (handler
))
1828 return call2 (handler
, Qdelete_directory
, dirname
);
1830 if (rmdir (dir
) != 0)
1831 report_file_error ("Removing directory", Flist (1, &dirname
));
1836 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
1837 "Delete specified file. One argument, a file name string.\n\
1838 If file has multiple names, it continues to exist with the other names.")
1840 Lisp_Object filename
;
1842 Lisp_Object handler
;
1843 CHECK_STRING (filename
, 0);
1844 filename
= Fexpand_file_name (filename
, Qnil
);
1846 handler
= Ffind_file_name_handler (filename
);
1847 if (!NILP (handler
))
1848 return call2 (handler
, Qdelete_file
, filename
);
1850 if (0 > unlink (XSTRING (filename
)->data
))
1851 report_file_error ("Removing old name", Flist (1, &filename
));
1855 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
1856 "fRename file: \nFRename %s to file: \np",
1857 "Rename FILE as NEWNAME. Both args strings.\n\
1858 If file has names other than FILE, it continues to have those names.\n\
1859 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
1860 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
1861 A number as third arg means request confirmation if NEWNAME already exists.\n\
1862 This is what happens in interactive use with M-x.")
1863 (filename
, newname
, ok_if_already_exists
)
1864 Lisp_Object filename
, newname
, ok_if_already_exists
;
1867 Lisp_Object args
[2];
1869 Lisp_Object handler
;
1870 struct gcpro gcpro1
, gcpro2
;
1872 GCPRO2 (filename
, newname
);
1873 CHECK_STRING (filename
, 0);
1874 CHECK_STRING (newname
, 1);
1875 filename
= Fexpand_file_name (filename
, Qnil
);
1876 newname
= Fexpand_file_name (newname
, Qnil
);
1878 /* If the file name has special constructs in it,
1879 call the corresponding file handler. */
1880 handler
= Ffind_file_name_handler (filename
);
1882 handler
= Ffind_file_name_handler (newname
);
1883 if (!NILP (handler
))
1884 return call4 (handler
, Qrename_file
,
1885 filename
, newname
, ok_if_already_exists
);
1887 if (NILP (ok_if_already_exists
)
1888 || XTYPE (ok_if_already_exists
) == Lisp_Int
)
1889 barf_or_query_if_file_exists (newname
, "rename to it",
1890 XTYPE (ok_if_already_exists
) == Lisp_Int
);
1892 if (0 > rename (XSTRING (filename
)->data
, XSTRING (newname
)->data
))
1894 if (0 > link (XSTRING (filename
)->data
, XSTRING (newname
)->data
)
1895 || 0 > unlink (XSTRING (filename
)->data
))
1900 Fcopy_file (filename
, newname
,
1901 /* We have already prompted if it was an integer,
1902 so don't have copy-file prompt again. */
1903 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
1904 Fdelete_file (filename
);
1911 report_file_error ("Renaming", Flist (2, args
));
1914 report_file_error ("Renaming", Flist (2, &filename
));
1921 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
1922 "fAdd name to file: \nFName to add to %s: \np",
1923 "Give FILE additional name NEWNAME. Both args strings.\n\
1924 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
1925 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
1926 A number as third arg means request confirmation if NEWNAME already exists.\n\
1927 This is what happens in interactive use with M-x.")
1928 (filename
, newname
, ok_if_already_exists
)
1929 Lisp_Object filename
, newname
, ok_if_already_exists
;
1932 Lisp_Object args
[2];
1934 Lisp_Object handler
;
1935 struct gcpro gcpro1
, gcpro2
;
1937 GCPRO2 (filename
, newname
);
1938 CHECK_STRING (filename
, 0);
1939 CHECK_STRING (newname
, 1);
1940 filename
= Fexpand_file_name (filename
, Qnil
);
1941 newname
= Fexpand_file_name (newname
, Qnil
);
1943 /* If the file name has special constructs in it,
1944 call the corresponding file handler. */
1945 handler
= Ffind_file_name_handler (filename
);
1946 if (!NILP (handler
))
1947 return call4 (handler
, Qadd_name_to_file
, filename
, newname
,
1948 ok_if_already_exists
);
1950 if (NILP (ok_if_already_exists
)
1951 || XTYPE (ok_if_already_exists
) == Lisp_Int
)
1952 barf_or_query_if_file_exists (newname
, "make it a new name",
1953 XTYPE (ok_if_already_exists
) == Lisp_Int
);
1954 unlink (XSTRING (newname
)->data
);
1955 if (0 > link (XSTRING (filename
)->data
, XSTRING (newname
)->data
))
1960 report_file_error ("Adding new name", Flist (2, args
));
1962 report_file_error ("Adding new name", Flist (2, &filename
));
1971 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
1972 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
1973 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
1974 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
1975 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
1976 A number as third arg means request confirmation if NEWNAME already exists.\n\
1977 This happens for interactive use with M-x.")
1978 (filename
, linkname
, ok_if_already_exists
)
1979 Lisp_Object filename
, linkname
, ok_if_already_exists
;
1982 Lisp_Object args
[2];
1984 Lisp_Object handler
;
1985 struct gcpro gcpro1
, gcpro2
;
1987 GCPRO2 (filename
, linkname
);
1988 CHECK_STRING (filename
, 0);
1989 CHECK_STRING (linkname
, 1);
1990 /* If the link target has a ~, we must expand it to get
1991 a truly valid file name. Otherwise, do not expand;
1992 we want to permit links to relative file names. */
1993 if (XSTRING (filename
)->data
[0] == '~')
1994 filename
= Fexpand_file_name (filename
, Qnil
);
1995 linkname
= Fexpand_file_name (linkname
, Qnil
);
1997 /* If the file name has special constructs in it,
1998 call the corresponding file handler. */
1999 handler
= Ffind_file_name_handler (filename
);
2000 if (!NILP (handler
))
2001 return call4 (handler
, Qmake_symbolic_link
, filename
, linkname
,
2002 ok_if_already_exists
);
2004 if (NILP (ok_if_already_exists
)
2005 || XTYPE (ok_if_already_exists
) == Lisp_Int
)
2006 barf_or_query_if_file_exists (linkname
, "make it a link",
2007 XTYPE (ok_if_already_exists
) == Lisp_Int
);
2008 if (0 > symlink (XSTRING (filename
)->data
, XSTRING (linkname
)->data
))
2010 /* If we didn't complain already, silently delete existing file. */
2011 if (errno
== EEXIST
)
2013 unlink (XSTRING (linkname
)->data
);
2014 if (0 <= symlink (XSTRING (filename
)->data
, XSTRING (linkname
)->data
))
2021 report_file_error ("Making symbolic link", Flist (2, args
));
2023 report_file_error ("Making symbolic link", Flist (2, &filename
));
2029 #endif /* S_IFLNK */
2033 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2034 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2035 "Define the job-wide logical name NAME to have the value STRING.\n\
2036 If STRING is nil or a null string, the logical name NAME is deleted.")
2038 Lisp_Object varname
;
2041 CHECK_STRING (varname
, 0);
2043 delete_logical_name (XSTRING (varname
)->data
);
2046 CHECK_STRING (string
, 1);
2048 if (XSTRING (string
)->size
== 0)
2049 delete_logical_name (XSTRING (varname
)->data
);
2051 define_logical_name (XSTRING (varname
)->data
, XSTRING (string
)->data
);
2060 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2061 "Open a network connection to PATH using LOGIN as the login string.")
2063 Lisp_Object path
, login
;
2067 CHECK_STRING (path
, 0);
2068 CHECK_STRING (login
, 0);
2070 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2072 if (netresult
== -1)
2077 #endif /* HPUX_NET */
2079 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2081 "Return t if file FILENAME specifies an absolute path name.\n\
2082 On Unix, this is a name starting with a `/' or a `~'.")
2084 Lisp_Object filename
;
2088 CHECK_STRING (filename
, 0);
2089 ptr
= XSTRING (filename
)->data
;
2090 if (*ptr
== '/' || *ptr
== '~'
2092 /* ??? This criterion is probably wrong for '<'. */
2093 || index (ptr
, ':') || index (ptr
, '<')
2094 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2098 || (*ptr
!= 0 && ptr
[1] == ':' && ptr
[2] == '/')
2106 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2107 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
2108 See also `file-readable-p' and `file-attributes'.")
2110 Lisp_Object filename
;
2112 Lisp_Object abspath
;
2113 Lisp_Object handler
;
2115 CHECK_STRING (filename
, 0);
2116 abspath
= Fexpand_file_name (filename
, Qnil
);
2118 /* If the file name has special constructs in it,
2119 call the corresponding file handler. */
2120 handler
= Ffind_file_name_handler (abspath
);
2121 if (!NILP (handler
))
2122 return call2 (handler
, Qfile_exists_p
, abspath
);
2124 return (access (XSTRING (abspath
)->data
, 0) >= 0) ? Qt
: Qnil
;
2127 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2128 "Return t if FILENAME can be executed by you.\n\
2129 For a directory, this means you can access files in that directory.")
2131 Lisp_Object filename
;
2134 Lisp_Object abspath
;
2135 Lisp_Object handler
;
2137 CHECK_STRING (filename
, 0);
2138 abspath
= Fexpand_file_name (filename
, Qnil
);
2140 /* If the file name has special constructs in it,
2141 call the corresponding file handler. */
2142 handler
= Ffind_file_name_handler (abspath
);
2143 if (!NILP (handler
))
2144 return call2 (handler
, Qfile_executable_p
, abspath
);
2146 return (access (XSTRING (abspath
)->data
, 1) >= 0) ? Qt
: Qnil
;
2149 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2150 "Return t if file FILENAME exists and you can read it.\n\
2151 See also `file-exists-p' and `file-attributes'.")
2153 Lisp_Object filename
;
2155 Lisp_Object abspath
;
2156 Lisp_Object handler
;
2158 CHECK_STRING (filename
, 0);
2159 abspath
= Fexpand_file_name (filename
, Qnil
);
2161 /* If the file name has special constructs in it,
2162 call the corresponding file handler. */
2163 handler
= Ffind_file_name_handler (abspath
);
2164 if (!NILP (handler
))
2165 return call2 (handler
, Qfile_readable_p
, abspath
);
2167 return (access (XSTRING (abspath
)->data
, 4) >= 0) ? Qt
: Qnil
;
2170 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
2171 "Return non-nil if file FILENAME is the name of a symbolic link.\n\
2172 The value is the name of the file to which it is linked.\n\
2173 Otherwise returns nil.")
2175 Lisp_Object filename
;
2182 Lisp_Object handler
;
2184 CHECK_STRING (filename
, 0);
2185 filename
= Fexpand_file_name (filename
, Qnil
);
2187 /* If the file name has special constructs in it,
2188 call the corresponding file handler. */
2189 handler
= Ffind_file_name_handler (filename
);
2190 if (!NILP (handler
))
2191 return call2 (handler
, Qfile_symlink_p
, filename
);
2196 buf
= (char *) xmalloc (bufsize
);
2197 bzero (buf
, bufsize
);
2198 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
2199 if (valsize
< bufsize
) break;
2200 /* Buffer was not long enough */
2209 val
= make_string (buf
, valsize
);
2212 #else /* not S_IFLNK */
2214 #endif /* not S_IFLNK */
2217 #ifdef SOLARIS_BROKEN_ACCESS
2218 /* In Solaris 2.1, the readonly-ness of the filesystem is not
2219 considered by the access system call. This is Sun's bug, but we
2220 still have to make Emacs work. */
2222 #include <sys/statvfs.h>
2228 struct statvfs statvfsb
;
2230 if (statvfs(path
, &statvfsb
))
2231 return 1; /* error from statvfs, be conservative and say not wrtable */
2233 /* Otherwise, fsys is ro if bit is set. */
2234 return statvfsb
.f_flag
& ST_RDONLY
;
2237 /* But on every other os, access has already done the right thing. */
2238 #define ro_fsys(path) 0
2241 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2243 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
2244 "Return t if file FILENAME can be written or created by you.")
2246 Lisp_Object filename
;
2248 Lisp_Object abspath
, dir
;
2249 Lisp_Object handler
;
2251 CHECK_STRING (filename
, 0);
2252 abspath
= Fexpand_file_name (filename
, Qnil
);
2254 /* If the file name has special constructs in it,
2255 call the corresponding file handler. */
2256 handler
= Ffind_file_name_handler (abspath
);
2257 if (!NILP (handler
))
2258 return call2 (handler
, Qfile_writable_p
, abspath
);
2260 if (access (XSTRING (abspath
)->data
, 0) >= 0)
2261 return ((access (XSTRING (abspath
)->data
, 2) >= 0
2262 && ! ro_fsys ((char *) XSTRING (abspath
)->data
))
2264 dir
= Ffile_name_directory (abspath
);
2267 dir
= Fdirectory_file_name (dir
);
2271 dir
= Fdirectory_file_name (dir
);
2273 return ((access (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "", 2) >= 0
2274 && ! ro_fsys ((char *) XSTRING (dir
)->data
))
2278 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
2279 "Return t if file FILENAME is the name of a directory as a file.\n\
2280 A directory name spec may be given instead; then the value is t\n\
2281 if the directory so specified exists and really is a directory.")
2283 Lisp_Object filename
;
2285 register Lisp_Object abspath
;
2287 Lisp_Object handler
;
2289 abspath
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2291 /* If the file name has special constructs in it,
2292 call the corresponding file handler. */
2293 handler
= Ffind_file_name_handler (abspath
);
2294 if (!NILP (handler
))
2295 return call2 (handler
, Qfile_directory_p
, abspath
);
2297 if (stat (XSTRING (abspath
)->data
, &st
) < 0)
2299 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
2302 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
2303 "Return t if file FILENAME is the name of a directory as a file,\n\
2304 and files in that directory can be opened by you. In order to use a\n\
2305 directory as a buffer's current directory, this predicate must return true.\n\
2306 A directory name spec may be given instead; then the value is t\n\
2307 if the directory so specified exists and really is a readable and\n\
2308 searchable directory.")
2310 Lisp_Object filename
;
2312 Lisp_Object handler
;
2314 /* If the file name has special constructs in it,
2315 call the corresponding file handler. */
2316 handler
= Ffind_file_name_handler (filename
);
2317 if (!NILP (handler
))
2318 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
2320 if (NILP (Ffile_directory_p (filename
))
2321 || NILP (Ffile_executable_p (filename
)))
2327 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
2328 "Return mode bits of FILE, as an integer.")
2330 Lisp_Object filename
;
2332 Lisp_Object abspath
;
2334 Lisp_Object handler
;
2336 abspath
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2338 /* If the file name has special constructs in it,
2339 call the corresponding file handler. */
2340 handler
= Ffind_file_name_handler (abspath
);
2341 if (!NILP (handler
))
2342 return call2 (handler
, Qfile_modes
, abspath
);
2344 if (stat (XSTRING (abspath
)->data
, &st
) < 0)
2346 return make_number (st
.st_mode
& 07777);
2349 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
2350 "Set mode bits of FILE to MODE (an integer).\n\
2351 Only the 12 low bits of MODE are used.")
2353 Lisp_Object filename
, mode
;
2355 Lisp_Object abspath
;
2356 Lisp_Object handler
;
2358 abspath
= Fexpand_file_name (filename
, current_buffer
->directory
);
2359 CHECK_NUMBER (mode
, 1);
2361 /* If the file name has special constructs in it,
2362 call the corresponding file handler. */
2363 handler
= Ffind_file_name_handler (abspath
);
2364 if (!NILP (handler
))
2365 return call3 (handler
, Qset_file_modes
, abspath
, mode
);
2368 if (chmod (XSTRING (abspath
)->data
, XINT (mode
)) < 0)
2369 report_file_error ("Doing chmod", Fcons (abspath
, Qnil
));
2371 if (!egetenv ("USE_DOMAIN_ACLS"))
2374 struct timeval tvp
[2];
2376 /* chmod on apollo also change the file's modtime; need to save the
2377 modtime and then restore it. */
2378 if (stat (XSTRING (abspath
)->data
, &st
) < 0)
2380 report_file_error ("Doing chmod", Fcons (abspath
, Qnil
));
2384 if (chmod (XSTRING (abspath
)->data
, XINT (mode
)) < 0)
2385 report_file_error ("Doing chmod", Fcons (abspath
, Qnil
));
2387 /* reset the old accessed and modified times. */
2388 tvp
[0].tv_sec
= st
.st_atime
+ 1; /* +1 due to an Apollo roundoff bug */
2390 tvp
[1].tv_sec
= st
.st_mtime
+ 1; /* +1 due to an Apollo roundoff bug */
2393 if (utimes (XSTRING (abspath
)->data
, tvp
) < 0)
2394 report_file_error ("Doing utimes", Fcons (abspath
, Qnil
));
2401 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
2402 "Set the file permission bits for newly created files.\n\
2403 The argument MODE should be an integer; only the low 9 bits are used.\n\
2404 This setting is inherited by subprocesses.")
2408 CHECK_NUMBER (mode
, 0);
2410 umask ((~ XINT (mode
)) & 0777);
2415 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
2416 "Return the default file protection for created files.\n\
2417 The value is an integer.")
2423 realmask
= umask (0);
2426 XSET (value
, Lisp_Int
, (~ realmask
) & 0777);
2432 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
2433 "Tell Unix to finish all pending disk updates.")
2442 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
2443 "Return t if file FILE1 is newer than file FILE2.\n\
2444 If FILE1 does not exist, the answer is nil;\n\
2445 otherwise, if FILE2 does not exist, the answer is t.")
2447 Lisp_Object file1
, file2
;
2449 Lisp_Object abspath1
, abspath2
;
2452 Lisp_Object handler
;
2453 struct gcpro gcpro1
, gcpro2
;
2455 CHECK_STRING (file1
, 0);
2456 CHECK_STRING (file2
, 0);
2459 GCPRO2 (abspath1
, file2
);
2460 abspath1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
2461 abspath2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
2464 /* If the file name has special constructs in it,
2465 call the corresponding file handler. */
2466 handler
= Ffind_file_name_handler (abspath1
);
2468 handler
= Ffind_file_name_handler (abspath2
);
2469 if (!NILP (handler
))
2470 return call3 (handler
, Qfile_newer_than_file_p
, abspath1
, abspath2
);
2472 if (stat (XSTRING (abspath1
)->data
, &st
) < 0)
2475 mtime1
= st
.st_mtime
;
2477 if (stat (XSTRING (abspath2
)->data
, &st
) < 0)
2480 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
2484 Lisp_Object Qfind_buffer_file_type
;
2487 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
2489 "Insert contents of file FILENAME after point.\n\
2490 Returns list of absolute file name and length of data inserted.\n\
2491 If second argument VISIT is non-nil, the buffer's visited filename\n\
2492 and last save file modtime are set, and it is marked unmodified.\n\
2493 If visiting and the file does not exist, visiting is completed\n\
2494 before the error is signaled.\n\n\
2495 The optional third and fourth arguments BEG and END\n\
2496 specify what portion of the file to insert.\n\
2497 If VISIT is non-nil, BEG and END must be nil.\n\
2498 If optional fifth argument REPLACE is non-nil,\n\
2499 it means replace the current buffer contents (in the accessible portion)\n\
2500 with the file contents. This is better than simply deleting and inserting\n\
2501 the whole thing because (1) it preserves some marker positions\n\
2502 and (2) it puts less data in the undo list.")
2503 (filename
, visit
, beg
, end
, replace
)
2504 Lisp_Object filename
, visit
, beg
, end
, replace
;
2508 register int inserted
= 0;
2509 register int how_much
;
2510 int count
= specpdl_ptr
- specpdl
;
2511 struct gcpro gcpro1
, gcpro2
;
2512 Lisp_Object handler
, val
, insval
;
2519 GCPRO2 (filename
, p
);
2520 if (!NILP (current_buffer
->read_only
))
2521 Fbarf_if_buffer_read_only();
2523 CHECK_STRING (filename
, 0);
2524 filename
= Fexpand_file_name (filename
, Qnil
);
2526 /* If the file name has special constructs in it,
2527 call the corresponding file handler. */
2528 handler
= Ffind_file_name_handler (filename
);
2529 if (!NILP (handler
))
2531 val
= call6 (handler
, Qinsert_file_contents
, filename
,
2532 visit
, beg
, end
, replace
);
2539 if (stat (XSTRING (filename
)->data
, &st
) < 0
2540 || (fd
= open (XSTRING (filename
)->data
, 0)) < 0)
2542 if ((fd
= open (XSTRING (filename
)->data
, 0)) < 0
2543 || fstat (fd
, &st
) < 0)
2544 #endif /* not APOLLO */
2546 if (fd
>= 0) close (fd
);
2548 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
2554 record_unwind_protect (close_file_unwind
, make_number (fd
));
2557 /* This code will need to be changed in order to work on named
2558 pipes, and it's probably just not worth it. So we should at
2559 least signal an error. */
2560 if ((st
.st_mode
& S_IFMT
) == S_IFSOCK
)
2561 Fsignal (Qfile_error
,
2562 Fcons (build_string ("reading from named pipe"),
2563 Fcons (filename
, Qnil
)));
2566 /* Supposedly happens on VMS. */
2568 error ("File size is negative");
2570 if (!NILP (beg
) || !NILP (end
))
2572 error ("Attempt to visit less than an entire file");
2575 CHECK_NUMBER (beg
, 0);
2580 CHECK_NUMBER (end
, 0);
2583 XSETINT (end
, st
.st_size
);
2584 if (XINT (end
) != st
.st_size
)
2585 error ("maximum buffer size exceeded");
2588 /* If requested, replace the accessible part of the buffer
2589 with the file contents. Avoid replacing text at the
2590 beginning or end of the buffer that matches the file contents;
2591 that preserves markers pointing to the unchanged parts. */
2592 if (!NILP (replace
))
2594 char buffer
[1 << 14];
2595 int same_at_start
= BEGV
;
2596 int same_at_end
= ZV
;
2599 /* Count how many chars at the start of the file
2600 match the text at the beginning of the buffer. */
2605 nread
= read (fd
, buffer
, sizeof buffer
);
2607 error ("IO error reading %s: %s",
2608 XSTRING (filename
)->data
, strerror (errno
));
2609 else if (nread
== 0)
2612 while (bufpos
< nread
&& same_at_start
< ZV
2613 && FETCH_CHAR (same_at_start
) == buffer
[bufpos
])
2614 same_at_start
++, bufpos
++;
2615 /* If we found a discrepancy, stop the scan.
2616 Otherwise loop around and scan the next bufferfull. */
2617 if (bufpos
!= nread
)
2621 /* If the file matches the buffer completely,
2622 there's no need to replace anything. */
2623 if (same_at_start
== ZV
)
2630 /* Count how many chars at the end of the file
2631 match the text at the end of the buffer. */
2634 int total_read
, nread
, bufpos
, curpos
, trial
;
2636 /* At what file position are we now scanning? */
2637 curpos
= st
.st_size
- (ZV
- same_at_end
);
2638 /* How much can we scan in the next step? */
2639 trial
= min (curpos
, sizeof buffer
);
2640 if (lseek (fd
, curpos
- trial
, 0) < 0)
2641 report_file_error ("Setting file position",
2642 Fcons (filename
, Qnil
));
2645 while (total_read
< trial
)
2647 nread
= read (fd
, buffer
+ total_read
, trial
- total_read
);
2649 error ("IO error reading %s: %s",
2650 XSTRING (filename
)->data
, strerror (errno
));
2651 total_read
+= nread
;
2653 /* Scan this bufferfull from the end, comparing with
2654 the Emacs buffer. */
2655 bufpos
= total_read
;
2656 /* Compare with same_at_start to avoid counting some buffer text
2657 as matching both at the file's beginning and at the end. */
2658 while (bufpos
> 0 && same_at_end
> same_at_start
2659 && FETCH_CHAR (same_at_end
- 1) == buffer
[bufpos
- 1])
2660 same_at_end
--, bufpos
--;
2661 /* If we found a discrepancy, stop the scan.
2662 Otherwise loop around and scan the preceding bufferfull. */
2667 /* Arrange to read only the nonmatching middle part of the file. */
2668 XFASTINT (beg
) = same_at_start
- BEGV
;
2669 XFASTINT (end
) = st
.st_size
- (ZV
- same_at_end
);
2670 /* Delete the nonmatching middle part of the buffer. */
2671 Fdelete_region (make_number (same_at_start
), make_number (same_at_end
));
2674 total
= XINT (end
) - XINT (beg
);
2677 register Lisp_Object temp
;
2679 /* Make sure point-max won't overflow after this insertion. */
2680 XSET (temp
, Lisp_Int
, total
);
2681 if (total
!= XINT (temp
))
2682 error ("maximum buffer size exceeded");
2685 if (NILP (visit
) && total
> 0)
2686 prepare_to_modify_buffer (point
, point
);
2689 if (GAP_SIZE
< total
)
2690 make_gap (total
- GAP_SIZE
);
2692 if (XINT (beg
) != 0)
2694 if (lseek (fd
, XINT (beg
), 0) < 0)
2695 report_file_error ("Setting file position", Fcons (filename
, Qnil
));
2700 int try = min (total
- inserted
, 64 << 10);
2703 /* Allow quitting out of the actual I/O. */
2706 this = read (fd
, &FETCH_CHAR (point
+ inserted
- 1) + 1, try);
2723 /* Demacs 1.1.1 91/10/16 HIRANO Satoshi, MW July 1993 */
2724 /* Determine file type from name and remove LFs from CR-LFs if the file
2725 is deemed to be a text file. */
2727 struct gcpro gcpro1
;
2728 Lisp_Object code
= Qnil
;
2730 code
= call1 (Qfind_buffer_file_type
, filename
);
2732 if (XTYPE (code
) == Lisp_Int
)
2733 XFASTINT (current_buffer
->buffer_file_type
) = XFASTINT (code
);
2734 if (XFASTINT (current_buffer
->buffer_file_type
) == 0)
2737 inserted
- crlf_to_lf (inserted
, &FETCH_CHAR (point
- 1) + 1);
2740 GPT
-= reduced_size
;
2741 GAP_SIZE
+= reduced_size
;
2742 inserted
-= reduced_size
;
2749 record_insert (point
, inserted
);
2751 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
2752 offset_intervals (current_buffer
, point
, inserted
);
2758 /* Discard the unwind protect */
2759 specpdl_ptr
= specpdl
+ count
;
2762 error ("IO error reading %s: %s",
2763 XSTRING (filename
)->data
, strerror (errno
));
2770 current_buffer
->undo_list
= Qnil
;
2772 stat (XSTRING (filename
)->data
, &st
);
2777 current_buffer
->modtime
= st
.st_mtime
;
2778 current_buffer
->filename
= filename
;
2781 current_buffer
->save_modified
= MODIFF
;
2782 current_buffer
->auto_save_modified
= MODIFF
;
2783 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
2784 #ifdef CLASH_DETECTION
2787 if (!NILP (current_buffer
->filename
))
2788 unlock_file (current_buffer
->filename
);
2789 unlock_file (filename
);
2791 #endif /* CLASH_DETECTION */
2792 /* If visiting nonexistent file, return nil. */
2793 if (current_buffer
->modtime
== -1)
2794 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
2797 if (inserted
> 0 && NILP (visit
) && total
> 0)
2798 signal_after_change (point
, 0, inserted
);
2802 p
= Vafter_insert_file_functions
;
2805 insval
= call1 (Fcar (p
), make_number (inserted
));
2808 CHECK_NUMBER (insval
, 0);
2809 inserted
= XFASTINT (insval
);
2817 RETURN_UNGCPRO (val
);
2818 RETURN_UNGCPRO (Fcons (filename
,
2819 Fcons (make_number (inserted
),
2823 static Lisp_Object
build_annotations ();
2825 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 5,
2826 "r\nFWrite region to file: ",
2827 "Write current region into specified file.\n\
2828 When called from a program, takes three arguments:\n\
2829 START, END and FILENAME. START and END are buffer positions.\n\
2830 Optional fourth argument APPEND if non-nil means\n\
2831 append to existing file contents (if any).\n\
2832 Optional fifth argument VISIT if t means\n\
2833 set the last-save-file-modtime of buffer to this file's modtime\n\
2834 and mark buffer not modified.\n\
2835 If VISIT is a string, it is a second file name;\n\
2836 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
2837 VISIT is also the file name to lock and unlock for clash detection.\n\
2838 If VISIT is neither t nor nil nor a string,\n\
2839 that means do not print the \"Wrote file\" message.\n\
2840 Kludgy feature: if START is a string, then that string is written\n\
2841 to the file, instead of any buffer contents, and END is ignored.")
2842 (start
, end
, filename
, append
, visit
)
2843 Lisp_Object start
, end
, filename
, append
, visit
;
2851 int count
= specpdl_ptr
- specpdl
;
2853 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
2855 Lisp_Object handler
;
2856 Lisp_Object visit_file
;
2857 Lisp_Object annotations
;
2858 int visiting
, quietly
;
2859 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2861 int buffer_file_type
2862 = NILP (current_buffer
->buffer_file_type
) ? O_TEXT
: O_BINARY
;
2865 if (!NILP (start
) && !STRINGP (start
))
2866 validate_region (&start
, &end
);
2868 filename
= Fexpand_file_name (filename
, Qnil
);
2869 if (STRINGP (visit
))
2870 visit_file
= Fexpand_file_name (visit
, Qnil
);
2872 visit_file
= filename
;
2874 visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
2875 quietly
= !NILP (visit
);
2879 GCPRO4 (start
, filename
, annotations
, visit_file
);
2881 /* If the file name has special constructs in it,
2882 call the corresponding file handler. */
2883 handler
= Ffind_file_name_handler (filename
);
2884 /* If FILENAME has no handler, see if VISIT has one. */
2885 if (NILP (handler
) && XTYPE (visit
) == Lisp_String
)
2886 handler
= Ffind_file_name_handler (visit
);
2888 if (!NILP (handler
))
2891 val
= call6 (handler
, Qwrite_region
, start
, end
,
2892 filename
, append
, visit
);
2896 current_buffer
->save_modified
= MODIFF
;
2897 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
2898 current_buffer
->filename
= visit_file
;
2904 /* Special kludge to simplify auto-saving. */
2907 XFASTINT (start
) = BEG
;
2911 annotations
= build_annotations (start
, end
);
2913 #ifdef CLASH_DETECTION
2915 lock_file (visit_file
);
2916 #endif /* CLASH_DETECTION */
2918 fn
= XSTRING (filename
)->data
;
2922 desc
= open (fn
, O_WRONLY
| buffer_file_type
);
2924 desc
= open (fn
, O_WRONLY
);
2929 if (auto_saving
) /* Overwrite any previous version of autosave file */
2931 vms_truncate (fn
); /* if fn exists, truncate to zero length */
2932 desc
= open (fn
, O_RDWR
);
2934 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
2935 ? XSTRING (current_buffer
->filename
)->data
: 0,
2938 else /* Write to temporary name and rename if no errors */
2940 Lisp_Object temp_name
;
2941 temp_name
= Ffile_name_directory (filename
);
2943 if (!NILP (temp_name
))
2945 temp_name
= Fmake_temp_name (concat2 (temp_name
,
2946 build_string ("$$SAVE$$")));
2947 fname
= XSTRING (filename
)->data
;
2948 fn
= XSTRING (temp_name
)->data
;
2949 desc
= creat_copy_attrs (fname
, fn
);
2952 /* If we can't open the temporary file, try creating a new
2953 version of the original file. VMS "creat" creates a
2954 new version rather than truncating an existing file. */
2957 desc
= creat (fn
, 0666);
2958 #if 0 /* This can clobber an existing file and fail to replace it,
2959 if the user runs out of space. */
2962 /* We can't make a new version;
2963 try to truncate and rewrite existing version if any. */
2965 desc
= open (fn
, O_RDWR
);
2971 desc
= creat (fn
, 0666);
2976 O_WRONLY
| O_TRUNC
| O_CREAT
| buffer_file_type
,
2977 S_IREAD
| S_IWRITE
);
2978 #else /* not MSDOS */
2979 desc
= creat (fn
, auto_saving
? auto_save_mode_bits
: 0666);
2980 #endif /* not MSDOS */
2981 #endif /* not VMS */
2987 #ifdef CLASH_DETECTION
2989 if (!auto_saving
) unlock_file (visit_file
);
2991 #endif /* CLASH_DETECTION */
2992 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
2995 record_unwind_protect (close_file_unwind
, make_number (desc
));
2998 if (lseek (desc
, 0, 2) < 0)
3000 #ifdef CLASH_DETECTION
3001 if (!auto_saving
) unlock_file (visit_file
);
3002 #endif /* CLASH_DETECTION */
3003 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
3008 * Kludge Warning: The VMS C RTL likes to insert carriage returns
3009 * if we do writes that don't end with a carriage return. Furthermore
3010 * it cannot handle writes of more then 16K. The modified
3011 * version of "sys_write" in SYSDEP.C (see comment there) copes with
3012 * this EXCEPT for the last record (iff it doesn't end with a carriage
3013 * return). This implies that if your buffer doesn't end with a carriage
3014 * return, you get one free... tough. However it also means that if
3015 * we make two calls to sys_write (a la the following code) you can
3016 * get one at the gap as well. The easiest way to fix this (honest)
3017 * is to move the gap to the next newline (or the end of the buffer).
3022 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
3023 move_gap (find_next_newline (GPT
, 1));
3029 if (STRINGP (start
))
3031 failure
= 0 > a_write (desc
, XSTRING (start
)->data
,
3032 XSTRING (start
)->size
, 0, &annotations
);
3035 else if (XINT (start
) != XINT (end
))
3038 if (XINT (start
) < GPT
)
3040 register int end1
= XINT (end
);
3042 failure
= 0 > a_write (desc
, &FETCH_CHAR (tem
),
3043 min (GPT
, end1
) - tem
, tem
, &annotations
);
3044 nwritten
+= min (GPT
, end1
) - tem
;
3048 if (XINT (end
) > GPT
&& !failure
)
3051 tem
= max (tem
, GPT
);
3052 failure
= 0 > a_write (desc
, &FETCH_CHAR (tem
), XINT (end
) - tem
,
3054 nwritten
+= XINT (end
) - tem
;
3060 /* If file was empty, still need to write the annotations */
3061 failure
= 0 > a_write (desc
, "", 0, XINT (start
), &annotations
);
3069 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
3070 Disk full in NFS may be reported here. */
3071 /* mib says that closing the file will try to write as fast as NFS can do
3072 it, and that means the fsync here is not crucial for autosave files. */
3073 if (!auto_saving
&& fsync (desc
) < 0)
3074 failure
= 1, save_errno
= errno
;
3077 /* Spurious "file has changed on disk" warnings have been
3078 observed on Suns as well.
3079 It seems that `close' can change the modtime, under nfs.
3081 (This has supposedly been fixed in Sunos 4,
3082 but who knows about all the other machines with NFS?) */
3085 /* On VMS and APOLLO, must do the stat after the close
3086 since closing changes the modtime. */
3089 /* Recall that #if defined does not work on VMS. */
3096 /* NFS can report a write failure now. */
3097 if (close (desc
) < 0)
3098 failure
= 1, save_errno
= errno
;
3101 /* If we wrote to a temporary name and had no errors, rename to real name. */
3105 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
3113 /* Discard the unwind protect */
3114 specpdl_ptr
= specpdl
+ count
;
3116 #ifdef CLASH_DETECTION
3118 unlock_file (visit_file
);
3119 #endif /* CLASH_DETECTION */
3121 /* Do this before reporting IO error
3122 to avoid a "file has changed on disk" warning on
3123 next attempt to save. */
3125 current_buffer
->modtime
= st
.st_mtime
;
3128 error ("IO error writing %s: %s", fn
, strerror (save_errno
));
3132 current_buffer
->save_modified
= MODIFF
;
3133 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3134 current_buffer
->filename
= visit_file
;
3140 message ("Wrote %s", XSTRING (visit_file
)->data
);
3145 Lisp_Object
merge ();
3147 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
3148 "Return t if (car A) is numerically less than (car B).")
3152 return Flss (Fcar (a
), Fcar (b
));
3155 /* Build the complete list of annotations appropriate for writing out
3156 the text between START and END, by calling all the functions in
3157 write-region-annotate-functions and merging the lists they return. */
3160 build_annotations (start
, end
)
3161 Lisp_Object start
, end
;
3163 Lisp_Object annotations
;
3165 struct gcpro gcpro1
, gcpro2
;
3168 p
= Vwrite_region_annotate_functions
;
3169 GCPRO2 (annotations
, p
);
3172 res
= call2 (Fcar (p
), start
, end
);
3173 Flength (res
); /* Check basic validity of return value */
3174 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
3181 /* Write to descriptor DESC the LEN characters starting at ADDR,
3182 assuming they start at position POS in the buffer.
3183 Intersperse with them the annotations from *ANNOT
3184 (those which fall within the range of positions POS to POS + LEN),
3185 each at its appropriate position.
3187 Modify *ANNOT by discarding elements as we output them.
3188 The return value is negative in case of system call failure. */
3191 a_write (desc
, addr
, len
, pos
, annot
)
3193 register char *addr
;
3200 int lastpos
= pos
+ len
;
3204 tem
= Fcar_safe (Fcar (*annot
));
3205 if (INTEGERP (tem
) && XINT (tem
) >= pos
&& XFASTINT (tem
) <= lastpos
)
3206 nextpos
= XFASTINT (tem
);
3208 return e_write (desc
, addr
, lastpos
- pos
);
3211 if (0 > e_write (desc
, addr
, nextpos
- pos
))
3213 addr
+= nextpos
- pos
;
3216 tem
= Fcdr (Fcar (*annot
));
3219 if (0 > e_write (desc
, XSTRING (tem
)->data
, XSTRING (tem
)->size
))
3222 *annot
= Fcdr (*annot
);
3227 e_write (desc
, addr
, len
)
3229 register char *addr
;
3232 char buf
[16 * 1024];
3233 register char *p
, *end
;
3235 if (!EQ (current_buffer
->selective_display
, Qt
))
3236 return write (desc
, addr
, len
) - len
;
3240 end
= p
+ sizeof buf
;
3245 if (write (desc
, buf
, sizeof buf
) != sizeof buf
)
3254 if (write (desc
, buf
, p
- buf
) != p
- buf
)
3260 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
3261 Sverify_visited_file_modtime
, 1, 1, 0,
3262 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
3263 This means that the file has not been changed since it was visited or saved.")
3269 Lisp_Object handler
;
3271 CHECK_BUFFER (buf
, 0);
3274 if (XTYPE (b
->filename
) != Lisp_String
) return Qt
;
3275 if (b
->modtime
== 0) return Qt
;
3277 /* If the file name has special constructs in it,
3278 call the corresponding file handler. */
3279 handler
= Ffind_file_name_handler (b
->filename
);
3280 if (!NILP (handler
))
3281 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
3283 if (stat (XSTRING (b
->filename
)->data
, &st
) < 0)
3285 /* If the file doesn't exist now and didn't exist before,
3286 we say that it isn't modified, provided the error is a tame one. */
3287 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
3292 if (st
.st_mtime
== b
->modtime
3293 /* If both are positive, accept them if they are off by one second. */
3294 || (st
.st_mtime
> 0 && b
->modtime
> 0
3295 && (st
.st_mtime
== b
->modtime
+ 1
3296 || st
.st_mtime
== b
->modtime
- 1)))
3301 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
3302 Sclear_visited_file_modtime
, 0, 0, 0,
3303 "Clear out records of last mod time of visited file.\n\
3304 Next attempt to save will certainly not complain of a discrepancy.")
3307 current_buffer
->modtime
= 0;
3311 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
3312 Svisited_file_modtime
, 0, 0, 0,
3313 "Return the current buffer's recorded visited file modification time.\n\
3314 The value is a list of the form (HIGH . LOW), like the time values\n\
3315 that `file-attributes' returns.")
3318 return long_to_cons (current_buffer
->modtime
);
3321 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
3322 Sset_visited_file_modtime
, 0, 1, 0,
3323 "Update buffer's recorded modification time from the visited file's time.\n\
3324 Useful if the buffer was not read from the file normally\n\
3325 or if the file itself has been changed for some known benign reason.\n\
3326 An argument specifies the modification time value to use\n\
3327 \(instead of that of the visited file), in the form of a list\n\
3328 \(HIGH . LOW) or (HIGH LOW).")
3330 Lisp_Object time_list
;
3332 if (!NILP (time_list
))
3333 current_buffer
->modtime
= cons_to_long (time_list
);
3336 register Lisp_Object filename
;
3338 Lisp_Object handler
;
3340 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
3342 /* If the file name has special constructs in it,
3343 call the corresponding file handler. */
3344 handler
= Ffind_file_name_handler (filename
);
3345 if (!NILP (handler
))
3346 /* The handler can find the file name the same way we did. */
3347 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
3348 else if (stat (XSTRING (filename
)->data
, &st
) >= 0)
3349 current_buffer
->modtime
= st
.st_mtime
;
3358 unsigned char *name
= XSTRING (current_buffer
->name
)->data
;
3361 message ("Autosaving...error for %s", name
);
3362 Fsleep_for (make_number (1), Qnil
);
3363 message ("Autosaving...error!for %s", name
);
3364 Fsleep_for (make_number (1), Qnil
);
3365 message ("Autosaving...error for %s", name
);
3366 Fsleep_for (make_number (1), Qnil
);
3376 /* Get visited file's mode to become the auto save file's mode. */
3377 if (stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
3378 /* But make sure we can overwrite it later! */
3379 auto_save_mode_bits
= st
.st_mode
| 0600;
3381 auto_save_mode_bits
= 0666;
3384 Fwrite_region (Qnil
, Qnil
,
3385 current_buffer
->auto_save_file_name
,
3389 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
3390 "Auto-save all buffers that need it.\n\
3391 This is all buffers that have auto-saving enabled\n\
3392 and are changed since last auto-saved.\n\
3393 Auto-saving writes the buffer into a file\n\
3394 so that your editing is not lost if the system crashes.\n\
3395 This file is not the file you visited; that changes only when you save.\n\n\
3396 Non-nil first argument means do not print any message if successful.\n\
3397 Non-nil second argument means save only current buffer.")
3398 (no_message
, current_only
)
3399 Lisp_Object no_message
, current_only
;
3401 struct buffer
*old
= current_buffer
, *b
;
3402 Lisp_Object tail
, buf
;
3404 char *omessage
= echo_area_glyphs
;
3405 int omessage_length
= echo_area_glyphs_length
;
3406 extern int minibuf_level
;
3407 int do_handled_files
;
3410 /* Ordinarily don't quit within this function,
3411 but don't make it impossible to quit (in case we get hung in I/O). */
3415 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
3416 point to non-strings reached from Vbuffer_alist. */
3422 /* Vrun_hooks is nil before emacs is dumped, and inc-vers.el will
3423 eventually call do-auto-save, so don't err here in that case. */
3424 if (!NILP (Vrun_hooks
))
3425 call1 (Vrun_hooks
, intern ("auto-save-hook"));
3427 /* First, save all files which don't have handlers. If Emacs is
3428 crashing, the handlers may tweak what is causing Emacs to crash
3429 in the first place, and it would be a shame if Emacs failed to
3430 autosave perfectly ordinary files because it couldn't handle some
3432 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
3433 for (tail
= Vbuffer_alist
; XGCTYPE (tail
) == Lisp_Cons
;
3434 tail
= XCONS (tail
)->cdr
)
3436 buf
= XCONS (XCONS (tail
)->car
)->cdr
;
3439 if (!NILP (current_only
)
3440 && b
!= current_buffer
)
3443 /* Check for auto save enabled
3444 and file changed since last auto save
3445 and file changed since last real save. */
3446 if (XTYPE (b
->auto_save_file_name
) == Lisp_String
3447 && b
->save_modified
< BUF_MODIFF (b
)
3448 && b
->auto_save_modified
< BUF_MODIFF (b
)
3449 && (do_handled_files
3450 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
))))
3452 EMACS_TIME before_time
, after_time
;
3454 EMACS_GET_TIME (before_time
);
3456 /* If we had a failure, don't try again for 20 minutes. */
3457 if (b
->auto_save_failure_time
>= 0
3458 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
3461 if ((XFASTINT (b
->save_length
) * 10
3462 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
3463 /* A short file is likely to change a large fraction;
3464 spare the user annoying messages. */
3465 && XFASTINT (b
->save_length
) > 5000
3466 /* These messages are frequent and annoying for `*mail*'. */
3467 && !EQ (b
->filename
, Qnil
)
3468 && NILP (no_message
))
3470 /* It has shrunk too much; turn off auto-saving here. */
3471 message ("Buffer %s has shrunk a lot; auto save turned off there",
3472 XSTRING (b
->name
)->data
);
3473 /* User can reenable saving with M-x auto-save. */
3474 b
->auto_save_file_name
= Qnil
;
3475 /* Prevent warning from repeating if user does so. */
3476 XFASTINT (b
->save_length
) = 0;
3477 Fsleep_for (make_number (1), Qnil
);
3480 set_buffer_internal (b
);
3481 if (!auto_saved
&& NILP (no_message
))
3482 message1 ("Auto-saving...");
3483 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
3485 b
->auto_save_modified
= BUF_MODIFF (b
);
3486 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3487 set_buffer_internal (old
);
3489 EMACS_GET_TIME (after_time
);
3491 /* If auto-save took more than 60 seconds,
3492 assume it was an NFS failure that got a timeout. */
3493 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
3494 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
3498 /* Prevent another auto save till enough input events come in. */
3499 record_auto_save ();
3501 if (auto_saved
&& NILP (no_message
))
3504 message2 (omessage
, omessage_length
);
3506 message1 ("Auto-saving...done");
3515 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
3516 Sset_buffer_auto_saved
, 0, 0, 0,
3517 "Mark current buffer as auto-saved with its current text.\n\
3518 No auto-save file will be written until the buffer changes again.")
3521 current_buffer
->auto_save_modified
= MODIFF
;
3522 XFASTINT (current_buffer
->save_length
) = Z
- BEG
;
3523 current_buffer
->auto_save_failure_time
= -1;
3527 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
3528 Sclear_buffer_auto_save_failure
, 0, 0, 0,
3529 "Clear any record of a recent auto-save failure in the current buffer.")
3532 current_buffer
->auto_save_failure_time
= -1;
3536 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
3538 "Return t if buffer has been auto-saved since last read in or saved.")
3541 return (current_buffer
->save_modified
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
3544 /* Reading and completing file names */
3545 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
3547 /* In the string VAL, change each $ to $$ and return the result. */
3550 double_dollars (val
)
3553 register unsigned char *old
, *new;
3557 osize
= XSTRING (val
)->size
;
3558 /* Quote "$" as "$$" to get it past substitute-in-file-name */
3559 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
3560 if (*old
++ == '$') count
++;
3563 old
= XSTRING (val
)->data
;
3564 val
= Fmake_string (make_number (osize
+ count
), make_number (0));
3565 new = XSTRING (val
)->data
;
3566 for (n
= osize
; n
> 0; n
--)
3579 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
3581 "Internal subroutine for read-file-name. Do not call this.")
3582 (string
, dir
, action
)
3583 Lisp_Object string
, dir
, action
;
3584 /* action is nil for complete, t for return list of completions,
3585 lambda for verify final value */
3587 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
3589 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3596 /* No need to protect ACTION--we only compare it with t and nil. */
3597 GCPRO4 (string
, realdir
, name
, specdir
);
3599 if (XSTRING (string
)->size
== 0)
3601 if (EQ (action
, Qlambda
))
3609 orig_string
= string
;
3610 string
= Fsubstitute_in_file_name (string
);
3611 changed
= NILP (Fstring_equal (string
, orig_string
));
3612 name
= Ffile_name_nondirectory (string
);
3613 val
= Ffile_name_directory (string
);
3615 realdir
= Fexpand_file_name (val
, realdir
);
3620 specdir
= Ffile_name_directory (string
);
3621 val
= Ffile_name_completion (name
, realdir
);
3623 if (XTYPE (val
) != Lisp_String
)
3630 if (!NILP (specdir
))
3631 val
= concat2 (specdir
, val
);
3633 return double_dollars (val
);
3636 #endif /* not VMS */
3640 if (EQ (action
, Qt
))
3641 return Ffile_name_all_completions (name
, realdir
);
3642 /* Only other case actually used is ACTION = lambda */
3644 /* Supposedly this helps commands such as `cd' that read directory names,
3645 but can someone explain how it helps them? -- RMS */
3646 if (XSTRING (name
)->size
== 0)
3649 return Ffile_exists_p (string
);
3652 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
3653 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
3654 Value is not expanded---you must call `expand-file-name' yourself.\n\
3655 Default name to DEFAULT if user enters a null string.\n\
3656 (If DEFAULT is omitted, the visited file name is used.)\n\
3657 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
3658 Non-nil and non-t means also require confirmation after completion.\n\
3659 Fifth arg INITIAL specifies text to start with.\n\
3660 DIR defaults to current buffer's directory default.")
3661 (prompt
, dir
, defalt
, mustmatch
, initial
)
3662 Lisp_Object prompt
, dir
, defalt
, mustmatch
, initial
;
3664 Lisp_Object val
, insdef
, insdef1
, tem
;
3665 struct gcpro gcpro1
, gcpro2
;
3666 register char *homedir
;
3670 dir
= current_buffer
->directory
;
3672 defalt
= current_buffer
->filename
;
3674 /* If dir starts with user's homedir, change that to ~. */
3675 homedir
= (char *) egetenv ("HOME");
3677 && XTYPE (dir
) == Lisp_String
3678 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
3679 && XSTRING (dir
)->data
[strlen (homedir
)] == '/')
3681 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
3682 XSTRING (dir
)->size
- strlen (homedir
) + 1);
3683 XSTRING (dir
)->data
[0] = '~';
3686 if (insert_default_directory
)
3690 if (!NILP (initial
))
3692 Lisp_Object args
[2], pos
;
3696 insdef
= Fconcat (2, args
);
3697 pos
= make_number (XSTRING (dir
)->size
);
3698 insdef1
= Fcons (double_dollars (insdef
), pos
);
3701 insdef1
= double_dollars (insdef
);
3704 insdef
= Qnil
, insdef1
= Qnil
;
3707 count
= specpdl_ptr
- specpdl
;
3708 specbind (intern ("completion-ignore-case"), Qt
);
3711 GCPRO2 (insdef
, defalt
);
3712 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
3713 dir
, mustmatch
, insdef1
,
3714 Qfile_name_history
);
3717 unbind_to (count
, Qnil
);
3722 error ("No file name specified");
3723 tem
= Fstring_equal (val
, insdef
);
3724 if (!NILP (tem
) && !NILP (defalt
))
3726 if (XSTRING (val
)->size
== 0 && NILP (insdef
))
3731 error ("No default file name");
3733 return Fsubstitute_in_file_name (val
);
3736 #if 0 /* Old version */
3737 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
3738 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
3739 Value is not expanded---you must call `expand-file-name' yourself.\n\
3740 Default name to DEFAULT if user enters a null string.\n\
3741 (If DEFAULT is omitted, the visited file name is used.)\n\
3742 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
3743 Non-nil and non-t means also require confirmation after completion.\n\
3744 Fifth arg INITIAL specifies text to start with.\n\
3745 DIR defaults to current buffer's directory default.")
3746 (prompt
, dir
, defalt
, mustmatch
, initial
)
3747 Lisp_Object prompt
, dir
, defalt
, mustmatch
, initial
;
3749 Lisp_Object val
, insdef
, tem
;
3750 struct gcpro gcpro1
, gcpro2
;
3751 register char *homedir
;
3755 dir
= current_buffer
->directory
;
3757 defalt
= current_buffer
->filename
;
3759 /* If dir starts with user's homedir, change that to ~. */
3760 homedir
= (char *) egetenv ("HOME");
3762 && XTYPE (dir
) == Lisp_String
3763 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
3764 && XSTRING (dir
)->data
[strlen (homedir
)] == '/')
3766 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
3767 XSTRING (dir
)->size
- strlen (homedir
) + 1);
3768 XSTRING (dir
)->data
[0] = '~';
3771 if (!NILP (initial
))
3773 else if (insert_default_directory
)
3776 insdef
= build_string ("");
3779 count
= specpdl_ptr
- specpdl
;
3780 specbind (intern ("completion-ignore-case"), Qt
);
3783 GCPRO2 (insdef
, defalt
);
3784 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
3786 insert_default_directory
? insdef
: Qnil
,
3787 Qfile_name_history
);
3790 unbind_to (count
, Qnil
);
3795 error ("No file name specified");
3796 tem
= Fstring_equal (val
, insdef
);
3797 if (!NILP (tem
) && !NILP (defalt
))
3799 return Fsubstitute_in_file_name (val
);
3801 #endif /* Old version */
3805 Qexpand_file_name
= intern ("expand-file-name");
3806 Qdirectory_file_name
= intern ("directory-file-name");
3807 Qfile_name_directory
= intern ("file-name-directory");
3808 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
3809 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
3810 Qfile_name_as_directory
= intern ("file-name-as-directory");
3811 Qcopy_file
= intern ("copy-file");
3812 Qmake_directory
= intern ("make-directory");
3813 Qdelete_directory
= intern ("delete-directory");
3814 Qdelete_file
= intern ("delete-file");
3815 Qrename_file
= intern ("rename-file");
3816 Qadd_name_to_file
= intern ("add-name-to-file");
3817 Qmake_symbolic_link
= intern ("make-symbolic-link");
3818 Qfile_exists_p
= intern ("file-exists-p");
3819 Qfile_executable_p
= intern ("file-executable-p");
3820 Qfile_readable_p
= intern ("file-readable-p");
3821 Qfile_symlink_p
= intern ("file-symlink-p");
3822 Qfile_writable_p
= intern ("file-writable-p");
3823 Qfile_directory_p
= intern ("file-directory-p");
3824 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
3825 Qfile_modes
= intern ("file-modes");
3826 Qset_file_modes
= intern ("set-file-modes");
3827 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
3828 Qinsert_file_contents
= intern ("insert-file-contents");
3829 Qwrite_region
= intern ("write-region");
3830 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
3831 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
3833 staticpro (&Qexpand_file_name
);
3834 staticpro (&Qdirectory_file_name
);
3835 staticpro (&Qfile_name_directory
);
3836 staticpro (&Qfile_name_nondirectory
);
3837 staticpro (&Qunhandled_file_name_directory
);
3838 staticpro (&Qfile_name_as_directory
);
3839 staticpro (&Qcopy_file
);
3840 staticpro (&Qmake_directory
);
3841 staticpro (&Qdelete_directory
);
3842 staticpro (&Qdelete_file
);
3843 staticpro (&Qrename_file
);
3844 staticpro (&Qadd_name_to_file
);
3845 staticpro (&Qmake_symbolic_link
);
3846 staticpro (&Qfile_exists_p
);
3847 staticpro (&Qfile_executable_p
);
3848 staticpro (&Qfile_readable_p
);
3849 staticpro (&Qfile_symlink_p
);
3850 staticpro (&Qfile_writable_p
);
3851 staticpro (&Qfile_directory_p
);
3852 staticpro (&Qfile_accessible_directory_p
);
3853 staticpro (&Qfile_modes
);
3854 staticpro (&Qset_file_modes
);
3855 staticpro (&Qfile_newer_than_file_p
);
3856 staticpro (&Qinsert_file_contents
);
3857 staticpro (&Qwrite_region
);
3858 staticpro (&Qverify_visited_file_modtime
);
3860 Qfile_name_history
= intern ("file-name-history");
3861 Fset (Qfile_name_history
, Qnil
);
3862 staticpro (&Qfile_name_history
);
3864 Qfile_error
= intern ("file-error");
3865 staticpro (&Qfile_error
);
3866 Qfile_already_exists
= intern("file-already-exists");
3867 staticpro (&Qfile_already_exists
);
3870 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
3871 staticpro (&Qfind_buffer_file_type
);
3874 Qcar_less_than_car
= intern ("car-less-than-car");
3875 staticpro (&Qcar_less_than_car
);
3877 Fput (Qfile_error
, Qerror_conditions
,
3878 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
3879 Fput (Qfile_error
, Qerror_message
,
3880 build_string ("File error"));
3882 Fput (Qfile_already_exists
, Qerror_conditions
,
3883 Fcons (Qfile_already_exists
,
3884 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
3885 Fput (Qfile_already_exists
, Qerror_message
,
3886 build_string ("File already exists"));
3888 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
3889 "*Non-nil means when reading a filename start with default dir in minibuffer.");
3890 insert_default_directory
= 1;
3892 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
3893 "*Non-nil means write new files with record format `stmlf'.\n\
3894 nil means use format `var'. This variable is meaningful only on VMS.");
3895 vms_stmlf_recfm
= 0;
3897 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
3898 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
3899 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
3902 The first argument given to HANDLER is the name of the I/O primitive\n\
3903 to be handled; the remaining arguments are the arguments that were\n\
3904 passed to that primitive. For example, if you do\n\
3905 (file-exists-p FILENAME)\n\
3906 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
3907 (funcall HANDLER 'file-exists-p FILENAME)\n\
3908 The function `find-file-name-handler' checks this list for a handler\n\
3909 for its argument.");
3910 Vfile_name_handler_alist
= Qnil
;
3912 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
3913 "A list of functions to be called at the end of `insert-file-contents'.\n\
3914 Each is passed one argument, the number of bytes inserted. It should return\n\
3915 the new byte count, and leave point the same. If `insert-file-contents' is\n\
3916 intercepted by a handler from `file-name-handler-alist', that handler is\n\
3917 responsible for calling the after-insert-file-functions if appropriate.");
3918 Vafter_insert_file_functions
= Qnil
;
3920 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
3921 "A list of functions to be called at the start of `write-region'.\n\
3922 Each is passed two arguments, START and END as for `write-region'. It should\n\
3923 return a list of pairs (POSITION . STRING) of strings to be effectively\n\
3924 inserted at the specified positions of the file being written (1 means to\n\
3925 insert before the first byte written). The POSITIONs must be sorted into\n\
3926 increasing order. If there are several functions in the list, the several\n\
3927 lists are merged destructively.");
3928 Vwrite_region_annotate_functions
= Qnil
;
3930 defsubr (&Sfind_file_name_handler
);
3931 defsubr (&Sfile_name_directory
);
3932 defsubr (&Sfile_name_nondirectory
);
3933 defsubr (&Sunhandled_file_name_directory
);
3934 defsubr (&Sfile_name_as_directory
);
3935 defsubr (&Sdirectory_file_name
);
3936 defsubr (&Smake_temp_name
);
3937 defsubr (&Sexpand_file_name
);
3938 defsubr (&Ssubstitute_in_file_name
);
3939 defsubr (&Scopy_file
);
3940 defsubr (&Smake_directory_internal
);
3941 defsubr (&Sdelete_directory
);
3942 defsubr (&Sdelete_file
);
3943 defsubr (&Srename_file
);
3944 defsubr (&Sadd_name_to_file
);
3946 defsubr (&Smake_symbolic_link
);
3947 #endif /* S_IFLNK */
3949 defsubr (&Sdefine_logical_name
);
3952 defsubr (&Ssysnetunam
);
3953 #endif /* HPUX_NET */
3954 defsubr (&Sfile_name_absolute_p
);
3955 defsubr (&Sfile_exists_p
);
3956 defsubr (&Sfile_executable_p
);
3957 defsubr (&Sfile_readable_p
);
3958 defsubr (&Sfile_writable_p
);
3959 defsubr (&Sfile_symlink_p
);
3960 defsubr (&Sfile_directory_p
);
3961 defsubr (&Sfile_accessible_directory_p
);
3962 defsubr (&Sfile_modes
);
3963 defsubr (&Sset_file_modes
);
3964 defsubr (&Sset_default_file_modes
);
3965 defsubr (&Sdefault_file_modes
);
3966 defsubr (&Sfile_newer_than_file_p
);
3967 defsubr (&Sinsert_file_contents
);
3968 defsubr (&Swrite_region
);
3969 defsubr (&Scar_less_than_car
);
3970 defsubr (&Sverify_visited_file_modtime
);
3971 defsubr (&Sclear_visited_file_modtime
);
3972 defsubr (&Svisited_file_modtime
);
3973 defsubr (&Sset_visited_file_modtime
);
3974 defsubr (&Sdo_auto_save
);
3975 defsubr (&Sset_buffer_auto_saved
);
3976 defsubr (&Sclear_buffer_auto_save_failure
);
3977 defsubr (&Srecent_auto_save_p
);
3979 defsubr (&Sread_file_name_internal
);
3980 defsubr (&Sread_file_name
);
3983 defsubr (&Sunix_sync
);