1 /* File IO for GNU Emacs.
2 Copyright (C) 1985,86,87,88,93,94,95,96 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, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
23 #include <sys/types.h>
30 #if !defined (S_ISLNK) && defined (S_IFLNK)
31 # define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
34 #if !defined (S_ISREG) && defined (S_IFREG)
35 # define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
46 #include <sys/param.h>
68 extern char *strerror ();
85 #include "intervals.h"
94 #endif /* not WINDOWSNT */
97 #define CORRECT_DIR_SEPS(s) \
98 do { if ('/' == DIRECTORY_SEP) dostounix_filename (s); \
99 else unixtodos_filename (s); \
101 /* On Windows, drive letters must be alphabetic - on DOS, the Netware
102 redirector allows the six letters between 'Z' and 'a' as well. */
104 #define IS_DRIVE(x) ((x) >= 'A' && (x) <= 'z')
105 /* Need to lower-case the drive letter, or else expanded
106 filenames will sometimes compare inequal, because
107 `expand-file-name' doesn't always down-case the drive letter. */
108 #define DRIVE_LETTER(x) (tolower (x))
111 #define IS_DRIVE(x) isalpha (x)
112 extern Lisp_Object Vwin32_downcase_file_names
;
113 #define DRIVE_LETTER(x) (NILP (Vwin32_downcase_file_names) ? (x) : tolower (x))
143 #define min(a, b) ((a) < (b) ? (a) : (b))
144 #define max(a, b) ((a) > (b) ? (a) : (b))
146 /* Nonzero during writing of auto-save files */
149 /* Set by auto_save_1 to mode of original file so Fwrite_region will create
150 a new file with the same mode as the original */
151 int auto_save_mode_bits
;
153 /* Alist of elements (REGEXP . HANDLER) for file names
154 whose I/O is done with a special handler. */
155 Lisp_Object Vfile_name_handler_alist
;
157 /* Format for auto-save files */
158 Lisp_Object Vauto_save_file_format
;
160 /* Lisp functions for translating file formats */
161 Lisp_Object Qformat_decode
, Qformat_annotate_function
;
163 /* Functions to be called to process text properties in inserted file. */
164 Lisp_Object Vafter_insert_file_functions
;
166 /* Functions to be called to create text property annotations for file. */
167 Lisp_Object Vwrite_region_annotate_functions
;
169 /* During build_annotations, each time an annotation function is called,
170 this holds the annotations made by the previous functions. */
171 Lisp_Object Vwrite_region_annotations_so_far
;
173 /* File name in which we write a list of all our auto save files. */
174 Lisp_Object Vauto_save_list_file_name
;
176 /* Nonzero means, when reading a filename in the minibuffer,
177 start out by inserting the default directory into the minibuffer. */
178 int insert_default_directory
;
180 /* On VMS, nonzero means write new files with record format stmlf.
181 Zero means use var format. */
184 /* On NT, specifies the directory separator character, used (eg.) when
185 expanding file names. This can be bound to / or \. */
186 Lisp_Object Vdirectory_sep_char
;
188 /* These variables describe handlers that have "already" had a chance
189 to handle the current operation.
191 Vinhibit_file_name_handlers is a list of file name handlers.
192 Vinhibit_file_name_operation is the operation being handled.
193 If we try to handle that operation, we ignore those handlers. */
195 static Lisp_Object Vinhibit_file_name_handlers
;
196 static Lisp_Object Vinhibit_file_name_operation
;
198 Lisp_Object Qfile_error
, Qfile_already_exists
;
200 Lisp_Object Qfile_name_history
;
202 Lisp_Object Qcar_less_than_car
;
204 report_file_error (string
, data
)
208 Lisp_Object errstring
;
210 errstring
= build_string (strerror (errno
));
212 /* System error messages are capitalized. Downcase the initial
213 unless it is followed by a slash. */
214 if (XSTRING (errstring
)->data
[1] != '/')
215 XSTRING (errstring
)->data
[0] = DOWNCASE (XSTRING (errstring
)->data
[0]);
218 Fsignal (Qfile_error
,
219 Fcons (build_string (string
), Fcons (errstring
, data
)));
222 close_file_unwind (fd
)
225 close (XFASTINT (fd
));
228 /* Restore point, having saved it as a marker. */
230 restore_point_unwind (location
)
231 Lisp_Object location
;
233 SET_PT (marker_position (location
));
234 Fset_marker (location
, Qnil
, Qnil
);
237 Lisp_Object Qexpand_file_name
;
238 Lisp_Object Qsubstitute_in_file_name
;
239 Lisp_Object Qdirectory_file_name
;
240 Lisp_Object Qfile_name_directory
;
241 Lisp_Object Qfile_name_nondirectory
;
242 Lisp_Object Qunhandled_file_name_directory
;
243 Lisp_Object Qfile_name_as_directory
;
244 Lisp_Object Qcopy_file
;
245 Lisp_Object Qmake_directory_internal
;
246 Lisp_Object Qdelete_directory
;
247 Lisp_Object Qdelete_file
;
248 Lisp_Object Qrename_file
;
249 Lisp_Object Qadd_name_to_file
;
250 Lisp_Object Qmake_symbolic_link
;
251 Lisp_Object Qfile_exists_p
;
252 Lisp_Object Qfile_executable_p
;
253 Lisp_Object Qfile_readable_p
;
254 Lisp_Object Qfile_symlink_p
;
255 Lisp_Object Qfile_writable_p
;
256 Lisp_Object Qfile_directory_p
;
257 Lisp_Object Qfile_regular_p
;
258 Lisp_Object Qfile_accessible_directory_p
;
259 Lisp_Object Qfile_modes
;
260 Lisp_Object Qset_file_modes
;
261 Lisp_Object Qfile_newer_than_file_p
;
262 Lisp_Object Qinsert_file_contents
;
263 Lisp_Object Qwrite_region
;
264 Lisp_Object Qverify_visited_file_modtime
;
265 Lisp_Object Qset_visited_file_modtime
;
267 DEFUN ("find-file-name-handler", Ffind_file_name_handler
, Sfind_file_name_handler
, 2, 2, 0,
268 "Return FILENAME's handler function for OPERATION, if it has one.\n\
269 Otherwise, return nil.\n\
270 A file name is handled if one of the regular expressions in\n\
271 `file-name-handler-alist' matches it.\n\n\
272 If OPERATION equals `inhibit-file-name-operation', then we ignore\n\
273 any handlers that are members of `inhibit-file-name-handlers',\n\
274 but we still do run any other handlers. This lets handlers\n\
275 use the standard functions without calling themselves recursively.")
276 (filename
, operation
)
277 Lisp_Object filename
, operation
;
279 /* This function must not munge the match data. */
280 Lisp_Object chain
, inhibited_handlers
;
282 CHECK_STRING (filename
, 0);
284 if (EQ (operation
, Vinhibit_file_name_operation
))
285 inhibited_handlers
= Vinhibit_file_name_handlers
;
287 inhibited_handlers
= Qnil
;
289 for (chain
= Vfile_name_handler_alist
; CONSP (chain
);
290 chain
= XCONS (chain
)->cdr
)
293 elt
= XCONS (chain
)->car
;
297 string
= XCONS (elt
)->car
;
298 if (STRINGP (string
) && fast_string_match (string
, filename
) >= 0)
300 Lisp_Object handler
, tem
;
302 handler
= XCONS (elt
)->cdr
;
303 tem
= Fmemq (handler
, inhibited_handlers
);
314 DEFUN ("file-name-directory", Ffile_name_directory
, Sfile_name_directory
,
316 "Return the directory component in file name FILENAME.\n\
317 Return nil if FILENAME does not include a directory.\n\
318 Otherwise return a directory spec.\n\
319 Given a Unix syntax file name, returns a string ending in slash;\n\
320 on VMS, perhaps instead a string ending in `:', `]' or `>'.")
322 Lisp_Object filename
;
324 register unsigned char *beg
;
325 register unsigned char *p
;
328 CHECK_STRING (filename
, 0);
330 /* If the file name has special constructs in it,
331 call the corresponding file handler. */
332 handler
= Ffind_file_name_handler (filename
, Qfile_name_directory
);
334 return call2 (handler
, Qfile_name_directory
, filename
);
336 #ifdef FILE_SYSTEM_CASE
337 filename
= FILE_SYSTEM_CASE (filename
);
339 beg
= XSTRING (filename
)->data
;
341 beg
= strcpy (alloca (strlen (beg
) + 1), beg
);
343 p
= beg
+ XSTRING (filename
)->size
;
345 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
347 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
350 /* only recognise drive specifier at beginning */
351 && !(p
[-1] == ':' && p
== beg
+ 2)
358 /* Expansion of "c:" to drive and default directory. */
359 if (p
== beg
+ 2 && beg
[1] == ':')
361 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
362 unsigned char *res
= alloca (MAXPATHLEN
+ 1);
363 if (getdefdir (toupper (*beg
) - 'A' + 1, res
))
365 if (!IS_DIRECTORY_SEP (res
[strlen (res
) - 1]))
368 p
= beg
+ strlen (beg
);
371 CORRECT_DIR_SEPS (beg
);
373 return make_string (beg
, p
- beg
);
376 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory
, Sfile_name_nondirectory
,
378 "Return file name FILENAME sans its directory.\n\
379 For example, in a Unix-syntax file name,\n\
380 this is everything after the last slash,\n\
381 or the entire name if it contains no slash.")
383 Lisp_Object filename
;
385 register unsigned char *beg
, *p
, *end
;
388 CHECK_STRING (filename
, 0);
390 /* If the file name has special constructs in it,
391 call the corresponding file handler. */
392 handler
= Ffind_file_name_handler (filename
, Qfile_name_nondirectory
);
394 return call2 (handler
, Qfile_name_nondirectory
, filename
);
396 beg
= XSTRING (filename
)->data
;
397 end
= p
= beg
+ XSTRING (filename
)->size
;
399 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
401 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
404 /* only recognise drive specifier at beginning */
405 && !(p
[-1] == ':' && p
== beg
+ 2)
409 return make_string (p
, end
- p
);
412 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory
, Sunhandled_file_name_directory
, 1, 1, 0,
413 "Return a directly usable directory name somehow associated with FILENAME.\n\
414 A `directly usable' directory name is one that may be used without the\n\
415 intervention of any file handler.\n\
416 If FILENAME is a directly usable file itself, return\n\
417 (file-name-directory FILENAME).\n\
418 The `call-process' and `start-process' functions use this function to\n\
419 get a current directory to run processes in.")
421 Lisp_Object filename
;
425 /* If the file name has special constructs in it,
426 call the corresponding file handler. */
427 handler
= Ffind_file_name_handler (filename
, Qunhandled_file_name_directory
);
429 return call2 (handler
, Qunhandled_file_name_directory
, filename
);
431 return Ffile_name_directory (filename
);
436 file_name_as_directory (out
, in
)
439 int size
= strlen (in
) - 1;
444 /* Is it already a directory string? */
445 if (in
[size
] == ':' || in
[size
] == ']' || in
[size
] == '>')
447 /* Is it a VMS directory file name? If so, hack VMS syntax. */
448 else if (! index (in
, '/')
449 && ((size
> 3 && ! strcmp (&in
[size
- 3], ".DIR"))
450 || (size
> 3 && ! strcmp (&in
[size
- 3], ".dir"))
451 || (size
> 5 && (! strncmp (&in
[size
- 5], ".DIR", 4)
452 || ! strncmp (&in
[size
- 5], ".dir", 4))
453 && (in
[size
- 1] == '.' || in
[size
- 1] == ';')
454 && in
[size
] == '1')))
456 register char *p
, *dot
;
460 dir:x.dir --> dir:[x]
461 dir:[x]y.dir --> dir:[x.y] */
463 while (p
!= in
&& *p
!= ':' && *p
!= '>' && *p
!= ']') p
--;
466 strncpy (out
, in
, p
- in
);
485 dot
= index (p
, '.');
488 /* blindly remove any extension */
489 size
= strlen (out
) + (dot
- p
);
490 strncat (out
, p
, dot
- p
);
501 /* For Unix syntax, Append a slash if necessary */
502 if (!IS_DIRECTORY_SEP (out
[size
]))
504 out
[size
+ 1] = DIRECTORY_SEP
;
505 out
[size
+ 2] = '\0';
508 CORRECT_DIR_SEPS (out
);
514 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
515 Sfile_name_as_directory
, 1, 1, 0,
516 "Return a string representing file FILENAME interpreted as a directory.\n\
517 This operation exists because a directory is also a file, but its name as\n\
518 a directory is different from its name as a file.\n\
519 The result can be used as the value of `default-directory'\n\
520 or passed as second argument to `expand-file-name'.\n\
521 For a Unix-syntax file name, just appends a slash.\n\
522 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
529 CHECK_STRING (file
, 0);
533 /* If the file name has special constructs in it,
534 call the corresponding file handler. */
535 handler
= Ffind_file_name_handler (file
, Qfile_name_as_directory
);
537 return call2 (handler
, Qfile_name_as_directory
, file
);
539 buf
= (char *) alloca (XSTRING (file
)->size
+ 10);
540 return build_string (file_name_as_directory (buf
, XSTRING (file
)->data
));
544 * Convert from directory name to filename.
546 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
547 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
548 * On UNIX, it's simple: just make sure there isn't a terminating /
550 * Value is nonzero if the string output is different from the input.
553 directory_file_name (src
, dst
)
561 struct FAB fab
= cc$rms_fab
;
562 struct NAM nam
= cc$rms_nam
;
563 char esa
[NAM$C_MAXRSS
];
568 if (! index (src
, '/')
569 && (src
[slen
- 1] == ']'
570 || src
[slen
- 1] == ':'
571 || src
[slen
- 1] == '>'))
573 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
575 fab
.fab$b_fns
= slen
;
576 fab
.fab$l_nam
= &nam
;
577 fab
.fab$l_fop
= FAB$M_NAM
;
580 nam
.nam$b_ess
= sizeof esa
;
581 nam
.nam$b_nop
|= NAM$M_SYNCHK
;
583 /* We call SYS$PARSE to handle such things as [--] for us. */
584 if (SYS$
PARSE (&fab
, 0, 0) == RMS$_NORMAL
)
586 slen
= nam
.nam$b_esl
;
587 if (esa
[slen
- 1] == ';' && esa
[slen
- 2] == '.')
592 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
594 /* what about when we have logical_name:???? */
595 if (src
[slen
- 1] == ':')
596 { /* Xlate logical name and see what we get */
597 ptr
= strcpy (dst
, src
); /* upper case for getenv */
600 if ('a' <= *ptr
&& *ptr
<= 'z')
604 dst
[slen
- 1] = 0; /* remove colon */
605 if (!(src
= egetenv (dst
)))
607 /* should we jump to the beginning of this procedure?
608 Good points: allows us to use logical names that xlate
610 Bad points: can be a problem if we just translated to a device
612 For now, I'll punt and always expect VMS names, and hope for
615 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
616 { /* no recursion here! */
622 { /* not a directory spec */
627 bracket
= src
[slen
- 1];
629 /* If bracket is ']' or '>', bracket - 2 is the corresponding
631 ptr
= index (src
, bracket
- 2);
633 { /* no opening bracket */
637 if (!(rptr
= rindex (src
, '.')))
640 strncpy (dst
, src
, slen
);
644 dst
[slen
++] = bracket
;
649 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
650 then translate the device and recurse. */
651 if (dst
[slen
- 1] == ':'
652 && dst
[slen
- 2] != ':' /* skip decnet nodes */
653 && strcmp (src
+ slen
, "[000000]") == 0)
655 dst
[slen
- 1] = '\0';
656 if ((ptr
= egetenv (dst
))
657 && (rlen
= strlen (ptr
) - 1) > 0
658 && (ptr
[rlen
] == ']' || ptr
[rlen
] == '>')
659 && ptr
[rlen
- 1] == '.')
661 char * buf
= (char *) alloca (strlen (ptr
) + 1);
665 return directory_file_name (buf
, dst
);
670 strcat (dst
, "[000000]");
674 rlen
= strlen (rptr
) - 1;
675 strncat (dst
, rptr
, rlen
);
676 dst
[slen
+ rlen
] = '\0';
677 strcat (dst
, ".DIR.1");
681 /* Process as Unix format: just remove any final slash.
682 But leave "/" unchanged; do not change it to "". */
685 /* Handle // as root for apollo's. */
686 if ((slen
> 2 && dst
[slen
- 1] == '/')
687 || (slen
> 1 && dst
[0] != '/' && dst
[slen
- 1] == '/'))
691 && IS_DIRECTORY_SEP (dst
[slen
- 1])
693 && !IS_ANY_SEP (dst
[slen
- 2])
699 CORRECT_DIR_SEPS (dst
);
704 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
706 "Returns the file name of the directory named DIRECTORY.\n\
707 This is the name of the file that holds the data for the directory DIRECTORY.\n\
708 This operation exists because a directory is also a file, but its name as\n\
709 a directory is different from its name as a file.\n\
710 In Unix-syntax, this function just removes the final slash.\n\
711 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
712 it returns a file name such as \"[X]Y.DIR.1\".")
714 Lisp_Object directory
;
719 CHECK_STRING (directory
, 0);
721 if (NILP (directory
))
724 /* If the file name has special constructs in it,
725 call the corresponding file handler. */
726 handler
= Ffind_file_name_handler (directory
, Qdirectory_file_name
);
728 return call2 (handler
, Qdirectory_file_name
, directory
);
731 /* 20 extra chars is insufficient for VMS, since we might perform a
732 logical name translation. an equivalence string can be up to 255
733 chars long, so grab that much extra space... - sss */
734 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20 + 255);
736 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20);
738 directory_file_name (XSTRING (directory
)->data
, buf
);
739 return build_string (buf
);
742 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
743 "Generate temporary file name (string) starting with PREFIX (a string).\n\
744 The Emacs process number forms part of the result,\n\
745 so there is no danger of generating a name being used by another process.")
751 /* Don't use too many characters of the restricted 8+3 DOS
753 val
= concat2 (prefix
, build_string ("a.XXX"));
755 val
= concat2 (prefix
, build_string ("XXXXXX"));
757 mktemp (XSTRING (val
)->data
);
759 CORRECT_DIR_SEPS (XSTRING (val
)->data
);
764 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
765 "Convert filename NAME to absolute, and canonicalize it.\n\
766 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative\n\
767 (does not start with slash); if DEFAULT-DIRECTORY is nil or missing,\n\
768 the current buffer's value of default-directory is used.\n\
769 File name components that are `.' are removed, and \n\
770 so are file name components followed by `..', along with the `..' itself;\n\
771 note that these simplifications are done without checking the resulting\n\
772 file names in the file system.\n\
773 An initial `~/' expands to your home directory.\n\
774 An initial `~USER/' expands to USER's home directory.\n\
775 See also the function `substitute-in-file-name'.")
776 (name
, default_directory
)
777 Lisp_Object name
, default_directory
;
781 register unsigned char *newdir
, *p
, *o
;
783 unsigned char *target
;
786 unsigned char * colon
= 0;
787 unsigned char * close
= 0;
788 unsigned char * slash
= 0;
789 unsigned char * brack
= 0;
790 int lbrack
= 0, rbrack
= 0;
795 int collapse_newdir
= 1;
800 CHECK_STRING (name
, 0);
802 /* If the file name has special constructs in it,
803 call the corresponding file handler. */
804 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
806 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
808 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
809 if (NILP (default_directory
))
810 default_directory
= current_buffer
->directory
;
811 CHECK_STRING (default_directory
, 1);
813 if (!NILP (default_directory
))
815 handler
= Ffind_file_name_handler (default_directory
, Qexpand_file_name
);
817 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
820 o
= XSTRING (default_directory
)->data
;
822 /* Make sure DEFAULT_DIRECTORY is properly expanded.
823 It would be better to do this down below where we actually use
824 default_directory. Unfortunately, calling Fexpand_file_name recursively
825 could invoke GC, and the strings might be relocated. This would
826 be annoying because we have pointers into strings lying around
827 that would need adjusting, and people would add new pointers to
828 the code and forget to adjust them, resulting in intermittent bugs.
829 Putting this call here avoids all that crud.
831 The EQ test avoids infinite recursion. */
832 if (! NILP (default_directory
) && !EQ (default_directory
, name
)
833 /* Save time in some common cases - as long as default_directory
834 is not relative, it can be canonicalized with name below (if it
835 is needed at all) without requiring it to be expanded now. */
837 /* Detect MSDOS file names with drive specifiers. */
838 && ! (IS_DRIVE (o
[0]) && (IS_DEVICE_SEP (o
[1]) && IS_DIRECTORY_SEP (o
[2])))
840 /* Detect Windows file names in UNC format. */
841 && ! (IS_DIRECTORY_SEP (o
[0]) && IS_DIRECTORY_SEP (o
[1]))
843 #else /* not DOS_NT */
844 /* Detect Unix absolute file names (/... alone is not absolute on
846 && ! (IS_DIRECTORY_SEP (o
[0]))
847 #endif /* not DOS_NT */
853 default_directory
= Fexpand_file_name (default_directory
, Qnil
);
858 /* Filenames on VMS are always upper case. */
859 name
= Fupcase (name
);
861 #ifdef FILE_SYSTEM_CASE
862 name
= FILE_SYSTEM_CASE (name
);
865 nm
= XSTRING (name
)->data
;
868 /* We will force directory separators to be either all \ or /, so make
869 a local copy to modify, even if there ends up being no change. */
870 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
872 /* Find and remove drive specifier if present; this makes nm absolute
873 even if the rest of the name appears to be relative. */
875 unsigned char *colon
= rindex (nm
, ':');
878 /* Only recognize colon as part of drive specifier if there is a
879 single alphabetic character preceeding the colon (and if the
880 character before the drive letter, if present, is a directory
881 separator); this is to support the remote system syntax used by
882 ange-ftp, and the "po:username" syntax for POP mailboxes. */
886 else if (IS_DRIVE (colon
[-1])
887 && (colon
== nm
+ 1 || IS_DIRECTORY_SEP (colon
[-2])))
894 while (--colon
>= nm
)
901 /* Handle // and /~ in middle of file name
902 by discarding everything through the first / of that sequence. */
906 /* Since we are expecting the name to be absolute, we can assume
907 that each element starts with a "/". */
909 if (IS_DIRECTORY_SEP (p
[0]) && IS_DIRECTORY_SEP (p
[1])
910 #if defined (APOLLO) || defined (WINDOWSNT)
911 /* // at start of filename is meaningful on Apollo
912 and WindowsNT systems */
914 #endif /* APOLLO || WINDOWSNT */
918 if (IS_DIRECTORY_SEP (p
[0]) && p
[1] == '~')
925 /* Discard any previous drive specifier if nm is now in UNC format. */
926 if (IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
932 /* If nm is absolute, look for /./ or /../ sequences; if none are
933 found, we can probably return right away. We will avoid allocating
934 a new string if name is already fully expanded. */
936 IS_DIRECTORY_SEP (nm
[0])
941 && (drive
|| IS_DIRECTORY_SEP (nm
[1]))
948 /* If it turns out that the filename we want to return is just a
949 suffix of FILENAME, we don't need to go through and edit
950 things; we just need to construct a new string using data
951 starting at the middle of FILENAME. If we set lose to a
952 non-zero value, that means we've discovered that we can't do
959 /* Since we know the name is absolute, we can assume that each
960 element starts with a "/". */
962 /* "." and ".." are hairy. */
963 if (IS_DIRECTORY_SEP (p
[0])
965 && (IS_DIRECTORY_SEP (p
[2])
967 || (p
[2] == '.' && (IS_DIRECTORY_SEP (p
[3])
974 /* if dev:[dir]/, move nm to / */
975 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
976 nm
= (brack
? brack
+ 1 : colon
+ 1);
985 /* VMS pre V4.4,convert '-'s in filenames. */
986 if (lbrack
== rbrack
)
988 if (dots
< 2) /* this is to allow negative version numbers */
993 if (lbrack
> rbrack
&&
994 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
995 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1001 /* count open brackets, reset close bracket pointer */
1002 if (p
[0] == '[' || p
[0] == '<')
1003 lbrack
++, brack
= 0;
1004 /* count close brackets, set close bracket pointer */
1005 if (p
[0] == ']' || p
[0] == '>')
1006 rbrack
++, brack
= p
;
1007 /* detect ][ or >< */
1008 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1010 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1011 nm
= p
+ 1, lose
= 1;
1012 if (p
[0] == ':' && (colon
|| slash
))
1013 /* if dev1:[dir]dev2:, move nm to dev2: */
1019 /* if /name/dev:, move nm to dev: */
1022 /* if node::dev:, move colon following dev */
1023 else if (colon
&& colon
[-1] == ':')
1025 /* if dev1:dev2:, move nm to dev2: */
1026 else if (colon
&& colon
[-1] != ':')
1031 if (p
[0] == ':' && !colon
)
1037 if (lbrack
== rbrack
)
1040 else if (p
[0] == '.')
1048 if (index (nm
, '/'))
1049 return build_string (sys_translate_unix (nm
));
1052 /* Make sure directories are all separated with / or \ as
1053 desired, but avoid allocation of a new string when not
1055 CORRECT_DIR_SEPS (nm
);
1057 if (IS_DIRECTORY_SEP (nm
[1]))
1059 if (strcmp (nm
, XSTRING (name
)->data
) != 0)
1060 name
= build_string (nm
);
1064 /* drive must be set, so this is okay */
1065 if (strcmp (nm
- 2, XSTRING (name
)->data
) != 0)
1067 name
= make_string (nm
- 2, p
- nm
+ 2);
1068 XSTRING (name
)->data
[0] = DRIVE_LETTER (drive
);
1069 XSTRING (name
)->data
[1] = ':';
1072 #else /* not DOS_NT */
1073 if (nm
== XSTRING (name
)->data
)
1075 return build_string (nm
);
1076 #endif /* not DOS_NT */
1080 /* At this point, nm might or might not be an absolute file name. We
1081 need to expand ~ or ~user if present, otherwise prefix nm with
1082 default_directory if nm is not absolute, and finally collapse /./
1083 and /foo/../ sequences.
1085 We set newdir to be the appropriate prefix if one is needed:
1086 - the relevant user directory if nm starts with ~ or ~user
1087 - the specified drive's working dir (DOS/NT only) if nm does not
1089 - the value of default_directory.
1091 Note that these prefixes are not guaranteed to be absolute (except
1092 for the working dir of a drive). Therefore, to ensure we always
1093 return an absolute name, if the final prefix is not absolute we
1094 append it to the current working directory. */
1098 if (nm
[0] == '~') /* prefix ~ */
1100 if (IS_DIRECTORY_SEP (nm
[1])
1104 || nm
[1] == 0) /* ~ by itself */
1106 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1107 newdir
= (unsigned char *) "";
1110 collapse_newdir
= 0;
1113 nm
++; /* Don't leave the slash in nm. */
1116 else /* ~user/filename */
1118 for (p
= nm
; *p
&& (!IS_DIRECTORY_SEP (*p
)
1123 o
= (unsigned char *) alloca (p
- nm
+ 1);
1124 bcopy ((char *) nm
, o
, p
- nm
);
1127 pw
= (struct passwd
*) getpwnam (o
+ 1);
1130 newdir
= (unsigned char *) pw
-> pw_dir
;
1132 nm
= p
+ 1; /* skip the terminator */
1136 collapse_newdir
= 0;
1141 /* If we don't find a user of that name, leave the name
1142 unchanged; don't move nm forward to p. */
1147 /* On DOS and Windows, nm is absolute if a drive name was specified;
1148 use the drive's current directory as the prefix if needed. */
1149 if (!newdir
&& drive
)
1151 /* Get default directory if needed to make nm absolute. */
1152 if (!IS_DIRECTORY_SEP (nm
[0]))
1154 newdir
= alloca (MAXPATHLEN
+ 1);
1155 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1160 /* Either nm starts with /, or drive isn't mounted. */
1161 newdir
= alloca (4);
1162 newdir
[0] = DRIVE_LETTER (drive
);
1170 /* Finally, if no prefix has been specified and nm is not absolute,
1171 then it must be expanded relative to default_directory. */
1175 /* /... alone is not absolute on DOS and Windows. */
1176 && !IS_DIRECTORY_SEP (nm
[0])
1179 && !(IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1186 newdir
= XSTRING (default_directory
)->data
;
1192 /* First ensure newdir is an absolute name. */
1194 /* Detect MSDOS file names with drive specifiers. */
1195 ! (IS_DRIVE (newdir
[0])
1196 && IS_DEVICE_SEP (newdir
[1]) && IS_DIRECTORY_SEP (newdir
[2]))
1198 /* Detect Windows file names in UNC format. */
1199 && ! (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1203 /* Effectively, let newdir be (expand-file-name newdir cwd).
1204 Because of the admonition against calling expand-file-name
1205 when we have pointers into lisp strings, we accomplish this
1206 indirectly by prepending newdir to nm if necessary, and using
1207 cwd (or the wd of newdir's drive) as the new newdir. */
1209 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1214 if (!IS_DIRECTORY_SEP (nm
[0]))
1216 char * tmp
= alloca (strlen (newdir
) + strlen (nm
) + 2);
1217 file_name_as_directory (tmp
, newdir
);
1221 newdir
= alloca (MAXPATHLEN
+ 1);
1224 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1231 /* Strip off drive name from prefix, if present. */
1232 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1238 /* Keep only a prefix from newdir if nm starts with slash
1239 (//server/share for UNC, nothing otherwise). */
1240 if (IS_DIRECTORY_SEP (nm
[0]) && collapse_newdir
)
1243 if (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1245 newdir
= strcpy (alloca (strlen (newdir
) + 1), newdir
);
1247 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1249 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1261 /* Get rid of any slash at the end of newdir, unless newdir is
1262 just // (an incomplete UNC name). */
1263 length
= strlen (newdir
);
1264 if (IS_DIRECTORY_SEP (newdir
[length
- 1])
1266 && !(length
== 2 && IS_DIRECTORY_SEP (newdir
[0]))
1270 unsigned char *temp
= (unsigned char *) alloca (length
);
1271 bcopy (newdir
, temp
, length
- 1);
1272 temp
[length
- 1] = 0;
1280 /* Now concatenate the directory and name to new space in the stack frame */
1281 tlen
+= strlen (nm
) + 1;
1283 /* Add reserved space for drive name. (The Microsoft x86 compiler
1284 produces incorrect code if the following two lines are combined.) */
1285 target
= (unsigned char *) alloca (tlen
+ 2);
1287 #else /* not DOS_NT */
1288 target
= (unsigned char *) alloca (tlen
);
1289 #endif /* not DOS_NT */
1295 if (nm
[0] == 0 || IS_DIRECTORY_SEP (nm
[0]))
1296 strcpy (target
, newdir
);
1299 file_name_as_directory (target
, newdir
);
1302 strcat (target
, nm
);
1304 if (index (target
, '/'))
1305 strcpy (target
, sys_translate_unix (target
));
1308 /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */
1310 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1318 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1324 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1325 /* brackets are offset from each other by 2 */
1328 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1329 /* convert [foo][bar] to [bar] */
1330 while (o
[-1] != '[' && o
[-1] != '<')
1332 else if (*p
== '-' && *o
!= '.')
1335 else if (p
[0] == '-' && o
[-1] == '.' &&
1336 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1337 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1341 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1342 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1344 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1346 /* else [foo.-] ==> [-] */
1352 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1353 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1359 if (!IS_DIRECTORY_SEP (*p
))
1363 else if (IS_DIRECTORY_SEP (p
[0]) && IS_DIRECTORY_SEP (p
[1])
1364 #if defined (APOLLO) || defined (WINDOWSNT)
1365 /* // at start of filename is meaningful in Apollo
1366 and WindowsNT systems */
1368 #endif /* APOLLO || WINDOWSNT */
1374 else if (IS_DIRECTORY_SEP (p
[0])
1376 && (IS_DIRECTORY_SEP (p
[2])
1379 /* If "/." is the entire filename, keep the "/". Otherwise,
1380 just delete the whole "/.". */
1381 if (o
== target
&& p
[2] == '\0')
1385 else if (IS_DIRECTORY_SEP (p
[0]) && p
[1] == '.' && p
[2] == '.'
1386 /* `/../' is the "superroot" on certain file systems. */
1388 && (IS_DIRECTORY_SEP (p
[3]) || p
[3] == 0))
1390 while (o
!= target
&& (--o
) && !IS_DIRECTORY_SEP (*o
))
1392 if (o
== target
&& IS_ANY_SEP (*o
))
1400 #endif /* not VMS */
1404 /* At last, set drive name. */
1406 /* Except for network file name. */
1407 if (!(IS_DIRECTORY_SEP (target
[0]) && IS_DIRECTORY_SEP (target
[1])))
1408 #endif /* WINDOWSNT */
1410 if (!drive
) abort ();
1412 target
[0] = DRIVE_LETTER (drive
);
1415 CORRECT_DIR_SEPS (target
);
1418 return make_string (target
, o
- target
);
1422 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'. */
1423 DEAFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
1424 "Convert FILENAME to absolute, and canonicalize it.\n\
1425 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1426 (does not start with slash); if DEFAULT is nil or missing,\n\
1427 the current buffer's value of default-directory is used.\n\
1428 Filenames containing `.' or `..' as components are simplified;\n\
1429 initial `~/' expands to your home directory.\n\
1430 See also the function `substitute-in-file-name'.")
1432 Lisp_Object name
, defalt
;
1436 register unsigned char *newdir
, *p
, *o
;
1438 unsigned char *target
;
1442 unsigned char * colon
= 0;
1443 unsigned char * close
= 0;
1444 unsigned char * slash
= 0;
1445 unsigned char * brack
= 0;
1446 int lbrack
= 0, rbrack
= 0;
1450 CHECK_STRING (name
, 0);
1453 /* Filenames on VMS are always upper case. */
1454 name
= Fupcase (name
);
1457 nm
= XSTRING (name
)->data
;
1459 /* If nm is absolute, flush ...// and detect /./ and /../.
1460 If no /./ or /../ we can return right away. */
1472 if (p
[0] == '/' && p
[1] == '/'
1474 /* // at start of filename is meaningful on Apollo system */
1479 if (p
[0] == '/' && p
[1] == '~')
1480 nm
= p
+ 1, lose
= 1;
1481 if (p
[0] == '/' && p
[1] == '.'
1482 && (p
[2] == '/' || p
[2] == 0
1483 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1489 /* if dev:[dir]/, move nm to / */
1490 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1491 nm
= (brack
? brack
+ 1 : colon
+ 1);
1492 lbrack
= rbrack
= 0;
1500 /* VMS pre V4.4,convert '-'s in filenames. */
1501 if (lbrack
== rbrack
)
1503 if (dots
< 2) /* this is to allow negative version numbers */
1508 if (lbrack
> rbrack
&&
1509 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1510 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1516 /* count open brackets, reset close bracket pointer */
1517 if (p
[0] == '[' || p
[0] == '<')
1518 lbrack
++, brack
= 0;
1519 /* count close brackets, set close bracket pointer */
1520 if (p
[0] == ']' || p
[0] == '>')
1521 rbrack
++, brack
= p
;
1522 /* detect ][ or >< */
1523 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1525 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1526 nm
= p
+ 1, lose
= 1;
1527 if (p
[0] == ':' && (colon
|| slash
))
1528 /* if dev1:[dir]dev2:, move nm to dev2: */
1534 /* If /name/dev:, move nm to dev: */
1537 /* If node::dev:, move colon following dev */
1538 else if (colon
&& colon
[-1] == ':')
1540 /* If dev1:dev2:, move nm to dev2: */
1541 else if (colon
&& colon
[-1] != ':')
1546 if (p
[0] == ':' && !colon
)
1552 if (lbrack
== rbrack
)
1555 else if (p
[0] == '.')
1563 if (index (nm
, '/'))
1564 return build_string (sys_translate_unix (nm
));
1566 if (nm
== XSTRING (name
)->data
)
1568 return build_string (nm
);
1572 /* Now determine directory to start with and put it in NEWDIR */
1576 if (nm
[0] == '~') /* prefix ~ */
1581 || nm
[1] == 0)/* ~/filename */
1583 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1584 newdir
= (unsigned char *) "";
1587 nm
++; /* Don't leave the slash in nm. */
1590 else /* ~user/filename */
1592 /* Get past ~ to user */
1593 unsigned char *user
= nm
+ 1;
1594 /* Find end of name. */
1595 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1596 int len
= ptr
? ptr
- user
: strlen (user
);
1598 unsigned char *ptr1
= index (user
, ':');
1599 if (ptr1
!= 0 && ptr1
- user
< len
)
1602 /* Copy the user name into temp storage. */
1603 o
= (unsigned char *) alloca (len
+ 1);
1604 bcopy ((char *) user
, o
, len
);
1607 /* Look up the user name. */
1608 pw
= (struct passwd
*) getpwnam (o
+ 1);
1610 error ("\"%s\" isn't a registered user", o
+ 1);
1612 newdir
= (unsigned char *) pw
->pw_dir
;
1614 /* Discard the user name from NM. */
1621 #endif /* not VMS */
1625 defalt
= current_buffer
->directory
;
1626 CHECK_STRING (defalt
, 1);
1627 newdir
= XSTRING (defalt
)->data
;
1630 /* Now concatenate the directory and name to new space in the stack frame */
1632 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1633 target
= (unsigned char *) alloca (tlen
);
1639 if (nm
[0] == 0 || nm
[0] == '/')
1640 strcpy (target
, newdir
);
1643 file_name_as_directory (target
, newdir
);
1646 strcat (target
, nm
);
1648 if (index (target
, '/'))
1649 strcpy (target
, sys_translate_unix (target
));
1652 /* Now canonicalize by removing /. and /foo/.. if they appear */
1660 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1666 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1667 /* brackets are offset from each other by 2 */
1670 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1671 /* convert [foo][bar] to [bar] */
1672 while (o
[-1] != '[' && o
[-1] != '<')
1674 else if (*p
== '-' && *o
!= '.')
1677 else if (p
[0] == '-' && o
[-1] == '.' &&
1678 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1679 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1683 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1684 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1686 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1688 /* else [foo.-] ==> [-] */
1694 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1695 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1705 else if (!strncmp (p
, "//", 2)
1707 /* // at start of filename is meaningful in Apollo system */
1715 else if (p
[0] == '/' && p
[1] == '.' &&
1716 (p
[2] == '/' || p
[2] == 0))
1718 else if (!strncmp (p
, "/..", 3)
1719 /* `/../' is the "superroot" on certain file systems. */
1721 && (p
[3] == '/' || p
[3] == 0))
1723 while (o
!= target
&& *--o
!= '/')
1726 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1730 if (o
== target
&& *o
== '/')
1738 #endif /* not VMS */
1741 return make_string (target
, o
- target
);
1745 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1746 Ssubstitute_in_file_name
, 1, 1, 0,
1747 "Substitute environment variables referred to in FILENAME.\n\
1748 `$FOO' where FOO is an environment variable name means to substitute\n\
1749 the value of that variable. The variable name should be terminated\n\
1750 with a character not a letter, digit or underscore; otherwise, enclose\n\
1751 the entire variable name in braces.\n\
1752 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1753 On VMS, `$' substitution is not done; this function does little and only\n\
1754 duplicates what `expand-file-name' does.")
1756 Lisp_Object filename
;
1760 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1761 unsigned char *target
;
1763 int substituted
= 0;
1765 Lisp_Object handler
;
1767 CHECK_STRING (filename
, 0);
1769 /* If the file name has special constructs in it,
1770 call the corresponding file handler. */
1771 handler
= Ffind_file_name_handler (filename
, Qsubstitute_in_file_name
);
1772 if (!NILP (handler
))
1773 return call2 (handler
, Qsubstitute_in_file_name
, filename
);
1775 nm
= XSTRING (filename
)->data
;
1777 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
1778 CORRECT_DIR_SEPS (nm
);
1779 substituted
= (strcmp (nm
, XSTRING (filename
)->data
) != 0);
1781 endp
= nm
+ XSTRING (filename
)->size
;
1783 /* If /~ or // appears, discard everything through first slash. */
1785 for (p
= nm
; p
!= endp
; p
++)
1788 #if defined (APOLLO) || defined (WINDOWSNT)
1789 /* // at start of file name is meaningful in Apollo and
1790 WindowsNT systems */
1791 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != nm
)
1792 #else /* not (APOLLO || WINDOWSNT) */
1793 || IS_DIRECTORY_SEP (p
[0])
1794 #endif /* not (APOLLO || WINDOWSNT) */
1799 || p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>'
1801 || IS_DIRECTORY_SEP (p
[-1])))
1807 /* see comment in expand-file-name about drive specifiers */
1808 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
1809 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
1818 return build_string (nm
);
1821 /* See if any variables are substituted into the string
1822 and find the total length of their values in `total' */
1824 for (p
= nm
; p
!= endp
;)
1834 /* "$$" means a single "$" */
1843 while (p
!= endp
&& *p
!= '}') p
++;
1844 if (*p
!= '}') goto missingclose
;
1850 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1854 /* Copy out the variable name */
1855 target
= (unsigned char *) alloca (s
- o
+ 1);
1856 strncpy (target
, o
, s
- o
);
1859 strupr (target
); /* $home == $HOME etc. */
1862 /* Get variable value */
1863 o
= (unsigned char *) egetenv (target
);
1864 if (!o
) goto badvar
;
1865 total
+= strlen (o
);
1872 /* If substitution required, recopy the string and do it */
1873 /* Make space in stack frame for the new copy */
1874 xnm
= (unsigned char *) alloca (XSTRING (filename
)->size
+ total
+ 1);
1877 /* Copy the rest of the name through, replacing $ constructs with values */
1894 while (p
!= endp
&& *p
!= '}') p
++;
1895 if (*p
!= '}') goto missingclose
;
1901 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1905 /* Copy out the variable name */
1906 target
= (unsigned char *) alloca (s
- o
+ 1);
1907 strncpy (target
, o
, s
- o
);
1910 strupr (target
); /* $home == $HOME etc. */
1913 /* Get variable value */
1914 o
= (unsigned char *) egetenv (target
);
1924 /* If /~ or // appears, discard everything through first slash. */
1926 for (p
= xnm
; p
!= x
; p
++)
1928 #if defined (APOLLO) || defined (WINDOWSNT)
1929 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != xnm
)
1930 #else /* not (APOLLO || WINDOWSNT) */
1931 || IS_DIRECTORY_SEP (p
[0])
1932 #endif /* not (APOLLO || WINDOWSNT) */
1934 && p
!= nm
&& IS_DIRECTORY_SEP (p
[-1]))
1937 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
1938 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
1942 return make_string (xnm
, x
- xnm
);
1945 error ("Bad format environment-variable substitution");
1947 error ("Missing \"}\" in environment-variable substitution");
1949 error ("Substituting nonexistent environment variable \"%s\"", target
);
1952 #endif /* not VMS */
1955 /* A slightly faster and more convenient way to get
1956 (directory-file-name (expand-file-name FOO)). */
1959 expand_and_dir_to_file (filename
, defdir
)
1960 Lisp_Object filename
, defdir
;
1962 register Lisp_Object absname
;
1964 absname
= Fexpand_file_name (filename
, defdir
);
1967 register int c
= XSTRING (absname
)->data
[XSTRING (absname
)->size
- 1];
1968 if (c
== ':' || c
== ']' || c
== '>')
1969 absname
= Fdirectory_file_name (absname
);
1972 /* Remove final slash, if any (unless this is the root dir).
1973 stat behaves differently depending! */
1974 if (XSTRING (absname
)->size
> 1
1975 && IS_DIRECTORY_SEP (XSTRING (absname
)->data
[XSTRING (absname
)->size
- 1])
1976 && !IS_DEVICE_SEP (XSTRING (absname
)->data
[XSTRING (absname
)->size
-2]))
1977 /* We cannot take shortcuts; they might be wrong for magic file names. */
1978 absname
= Fdirectory_file_name (absname
);
1983 /* Signal an error if the file ABSNAME already exists.
1984 If INTERACTIVE is nonzero, ask the user whether to proceed,
1985 and bypass the error if the user says to go ahead.
1986 QUERYSTRING is a name for the action that is being considered
1988 *STATPTR is used to store the stat information if the file exists.
1989 If the file does not exist, STATPTR->st_mode is set to 0. */
1992 barf_or_query_if_file_exists (absname
, querystring
, interactive
, statptr
)
1993 Lisp_Object absname
;
1994 unsigned char *querystring
;
1996 struct stat
*statptr
;
1998 register Lisp_Object tem
;
1999 struct stat statbuf
;
2000 struct gcpro gcpro1
;
2002 /* stat is a good way to tell whether the file exists,
2003 regardless of what access permissions it has. */
2004 if (stat (XSTRING (absname
)->data
, &statbuf
) >= 0)
2007 Fsignal (Qfile_already_exists
,
2008 Fcons (build_string ("File already exists"),
2009 Fcons (absname
, Qnil
)));
2011 tem
= do_yes_or_no_p (format1 ("File %s already exists; %s anyway? ",
2012 XSTRING (absname
)->data
, querystring
));
2015 Fsignal (Qfile_already_exists
,
2016 Fcons (build_string ("File already exists"),
2017 Fcons (absname
, Qnil
)));
2024 statptr
->st_mode
= 0;
2029 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
2030 "fCopy file: \nFCopy %s to file: \np\nP",
2031 "Copy FILE to NEWNAME. Both args must be strings.\n\
2032 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
2033 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
2034 A number as third arg means request confirmation if NEWNAME already exists.\n\
2035 This is what happens in interactive use with M-x.\n\
2036 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
2037 last-modified time as the old one. (This works on only some systems.)\n\
2038 A prefix arg makes KEEP-TIME non-nil.")
2039 (file
, newname
, ok_if_already_exists
, keep_date
)
2040 Lisp_Object file
, newname
, ok_if_already_exists
, keep_date
;
2043 char buf
[16 * 1024];
2044 struct stat st
, out_st
;
2045 Lisp_Object handler
;
2046 struct gcpro gcpro1
, gcpro2
;
2047 int count
= specpdl_ptr
- specpdl
;
2048 int input_file_statable_p
;
2050 GCPRO2 (file
, newname
);
2051 CHECK_STRING (file
, 0);
2052 CHECK_STRING (newname
, 1);
2053 file
= Fexpand_file_name (file
, Qnil
);
2054 newname
= Fexpand_file_name (newname
, Qnil
);
2056 /* If the input file name has special constructs in it,
2057 call the corresponding file handler. */
2058 handler
= Ffind_file_name_handler (file
, Qcopy_file
);
2059 /* Likewise for output file name. */
2061 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
2062 if (!NILP (handler
))
2063 RETURN_UNGCPRO (call5 (handler
, Qcopy_file
, file
, newname
,
2064 ok_if_already_exists
, keep_date
));
2066 if (NILP (ok_if_already_exists
)
2067 || INTEGERP (ok_if_already_exists
))
2068 barf_or_query_if_file_exists (newname
, "copy to it",
2069 INTEGERP (ok_if_already_exists
), &out_st
);
2070 else if (stat (XSTRING (newname
)->data
, &out_st
) < 0)
2073 ifd
= open (XSTRING (file
)->data
, O_RDONLY
);
2075 report_file_error ("Opening input file", Fcons (file
, Qnil
));
2077 record_unwind_protect (close_file_unwind
, make_number (ifd
));
2079 /* We can only copy regular files and symbolic links. Other files are not
2081 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
2084 if (out_st
.st_mode
!= 0
2085 && st
.st_dev
== out_st
.st_dev
&& st
.st_ino
== out_st
.st_ino
)
2088 report_file_error ("Input and output files are the same",
2089 Fcons (file
, Fcons (newname
, Qnil
)));
2093 #if defined (S_ISREG) && defined (S_ISLNK)
2094 if (input_file_statable_p
)
2096 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
2098 #if defined (EISDIR)
2099 /* Get a better looking error message. */
2102 report_file_error ("Non-regular file", Fcons (file
, Qnil
));
2105 #endif /* S_ISREG && S_ISLNK */
2108 /* Create the copy file with the same record format as the input file */
2109 ofd
= sys_creat (XSTRING (newname
)->data
, 0666, ifd
);
2112 /* System's default file type was set to binary by _fmode in emacs.c. */
2113 ofd
= creat (XSTRING (newname
)->data
, S_IREAD
| S_IWRITE
);
2114 #else /* not MSDOS */
2115 ofd
= creat (XSTRING (newname
)->data
, 0666);
2116 #endif /* not MSDOS */
2119 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
2121 record_unwind_protect (close_file_unwind
, make_number (ofd
));
2125 while ((n
= read (ifd
, buf
, sizeof buf
)) > 0)
2126 if (write (ofd
, buf
, n
) != n
)
2127 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2130 /* Closing the output clobbers the file times on some systems. */
2131 if (close (ofd
) < 0)
2132 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2134 if (input_file_statable_p
)
2136 if (!NILP (keep_date
))
2138 EMACS_TIME atime
, mtime
;
2139 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
2140 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
2141 if (set_file_times (XSTRING (newname
)->data
, atime
, mtime
))
2142 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2145 chmod (XSTRING (newname
)->data
, st
.st_mode
& 07777);
2147 #if defined (__DJGPP__) && __DJGPP__ > 1
2148 /* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
2149 and if it can't, it tells so. Otherwise, under MSDOS we usually
2150 get only the READ bit, which will make the copied file read-only,
2151 so it's better not to chmod at all. */
2152 if ((_djstat_flags
& _STFAIL_WRITEBIT
) == 0)
2153 chmod (XSTRING (newname
)->data
, st
.st_mode
& 07777);
2154 #endif /* DJGPP version 2 or newer */
2160 /* Discard the unwind protects. */
2161 specpdl_ptr
= specpdl
+ count
;
2167 DEFUN ("make-directory-internal", Fmake_directory_internal
,
2168 Smake_directory_internal
, 1, 1, 0,
2169 "Create a new directory named DIRECTORY.")
2171 Lisp_Object directory
;
2174 Lisp_Object handler
;
2176 CHECK_STRING (directory
, 0);
2177 directory
= Fexpand_file_name (directory
, Qnil
);
2179 handler
= Ffind_file_name_handler (directory
, Qmake_directory_internal
);
2180 if (!NILP (handler
))
2181 return call2 (handler
, Qmake_directory_internal
, directory
);
2183 dir
= XSTRING (directory
)->data
;
2186 if (mkdir (dir
) != 0)
2188 if (mkdir (dir
, 0777) != 0)
2190 report_file_error ("Creating directory", Flist (1, &directory
));
2195 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
2196 "Delete the directory named DIRECTORY.")
2198 Lisp_Object directory
;
2201 Lisp_Object handler
;
2203 CHECK_STRING (directory
, 0);
2204 directory
= Fdirectory_file_name (Fexpand_file_name (directory
, Qnil
));
2205 dir
= XSTRING (directory
)->data
;
2207 handler
= Ffind_file_name_handler (directory
, Qdelete_directory
);
2208 if (!NILP (handler
))
2209 return call2 (handler
, Qdelete_directory
, directory
);
2211 if (rmdir (dir
) != 0)
2212 report_file_error ("Removing directory", Flist (1, &directory
));
2217 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
2218 "Delete file named FILENAME.\n\
2219 If file has multiple names, it continues to exist with the other names.")
2221 Lisp_Object filename
;
2223 Lisp_Object handler
;
2224 CHECK_STRING (filename
, 0);
2225 filename
= Fexpand_file_name (filename
, Qnil
);
2227 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
2228 if (!NILP (handler
))
2229 return call2 (handler
, Qdelete_file
, filename
);
2231 if (0 > unlink (XSTRING (filename
)->data
))
2232 report_file_error ("Removing old name", Flist (1, &filename
));
2237 internal_delete_file_1 (ignore
)
2243 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */
2246 internal_delete_file (filename
)
2247 Lisp_Object filename
;
2249 return NILP (internal_condition_case_1 (Fdelete_file
, filename
,
2250 Qt
, internal_delete_file_1
));
2253 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
2254 "fRename file: \nFRename %s to file: \np",
2255 "Rename FILE as NEWNAME. Both args strings.\n\
2256 If file has names other than FILE, it continues to have those names.\n\
2257 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2258 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2259 A number as third arg means request confirmation if NEWNAME already exists.\n\
2260 This is what happens in interactive use with M-x.")
2261 (file
, newname
, ok_if_already_exists
)
2262 Lisp_Object file
, newname
, ok_if_already_exists
;
2265 Lisp_Object args
[2];
2267 Lisp_Object handler
;
2268 struct gcpro gcpro1
, gcpro2
;
2270 GCPRO2 (file
, newname
);
2271 CHECK_STRING (file
, 0);
2272 CHECK_STRING (newname
, 1);
2273 file
= Fexpand_file_name (file
, Qnil
);
2274 newname
= Fexpand_file_name (newname
, Qnil
);
2276 /* If the file name has special constructs in it,
2277 call the corresponding file handler. */
2278 handler
= Ffind_file_name_handler (file
, Qrename_file
);
2280 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
2281 if (!NILP (handler
))
2282 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
2283 file
, newname
, ok_if_already_exists
));
2285 if (NILP (ok_if_already_exists
)
2286 || INTEGERP (ok_if_already_exists
))
2287 barf_or_query_if_file_exists (newname
, "rename to it",
2288 INTEGERP (ok_if_already_exists
), 0);
2290 if (0 > rename (XSTRING (file
)->data
, XSTRING (newname
)->data
))
2292 if (0 > link (XSTRING (file
)->data
, XSTRING (newname
)->data
)
2293 || 0 > unlink (XSTRING (file
)->data
))
2298 Fcopy_file (file
, newname
,
2299 /* We have already prompted if it was an integer,
2300 so don't have copy-file prompt again. */
2301 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
2302 Fdelete_file (file
);
2309 report_file_error ("Renaming", Flist (2, args
));
2312 report_file_error ("Renaming", Flist (2, &file
));
2319 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
2320 "fAdd name to file: \nFName to add to %s: \np",
2321 "Give FILE additional name NEWNAME. Both args strings.\n\
2322 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2323 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2324 A number as third arg means request confirmation if NEWNAME already exists.\n\
2325 This is what happens in interactive use with M-x.")
2326 (file
, newname
, ok_if_already_exists
)
2327 Lisp_Object file
, newname
, ok_if_already_exists
;
2330 Lisp_Object args
[2];
2332 Lisp_Object handler
;
2333 struct gcpro gcpro1
, gcpro2
;
2335 GCPRO2 (file
, newname
);
2336 CHECK_STRING (file
, 0);
2337 CHECK_STRING (newname
, 1);
2338 file
= Fexpand_file_name (file
, Qnil
);
2339 newname
= Fexpand_file_name (newname
, Qnil
);
2341 /* If the file name has special constructs in it,
2342 call the corresponding file handler. */
2343 handler
= Ffind_file_name_handler (file
, Qadd_name_to_file
);
2344 if (!NILP (handler
))
2345 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2346 newname
, ok_if_already_exists
));
2348 /* If the new name has special constructs in it,
2349 call the corresponding file handler. */
2350 handler
= Ffind_file_name_handler (newname
, Qadd_name_to_file
);
2351 if (!NILP (handler
))
2352 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2353 newname
, ok_if_already_exists
));
2355 if (NILP (ok_if_already_exists
)
2356 || INTEGERP (ok_if_already_exists
))
2357 barf_or_query_if_file_exists (newname
, "make it a new name",
2358 INTEGERP (ok_if_already_exists
), 0);
2360 /* Windows does not support this operation. */
2361 report_file_error ("Adding new name", Flist (2, &file
));
2362 #else /* not WINDOWSNT */
2364 unlink (XSTRING (newname
)->data
);
2365 if (0 > link (XSTRING (file
)->data
, XSTRING (newname
)->data
))
2370 report_file_error ("Adding new name", Flist (2, args
));
2372 report_file_error ("Adding new name", Flist (2, &file
));
2375 #endif /* not WINDOWSNT */
2382 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2383 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2384 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
2385 Signals a `file-already-exists' error if a file LINKNAME already exists\n\
2386 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2387 A number as third arg means request confirmation if LINKNAME already exists.\n\
2388 This happens for interactive use with M-x.")
2389 (filename
, linkname
, ok_if_already_exists
)
2390 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2393 Lisp_Object args
[2];
2395 Lisp_Object handler
;
2396 struct gcpro gcpro1
, gcpro2
;
2398 GCPRO2 (filename
, linkname
);
2399 CHECK_STRING (filename
, 0);
2400 CHECK_STRING (linkname
, 1);
2401 /* If the link target has a ~, we must expand it to get
2402 a truly valid file name. Otherwise, do not expand;
2403 we want to permit links to relative file names. */
2404 if (XSTRING (filename
)->data
[0] == '~')
2405 filename
= Fexpand_file_name (filename
, Qnil
);
2406 linkname
= Fexpand_file_name (linkname
, Qnil
);
2408 /* If the file name has special constructs in it,
2409 call the corresponding file handler. */
2410 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2411 if (!NILP (handler
))
2412 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2413 linkname
, ok_if_already_exists
));
2415 /* If the new link name has special constructs in it,
2416 call the corresponding file handler. */
2417 handler
= Ffind_file_name_handler (linkname
, Qmake_symbolic_link
);
2418 if (!NILP (handler
))
2419 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2420 linkname
, ok_if_already_exists
));
2422 if (NILP (ok_if_already_exists
)
2423 || INTEGERP (ok_if_already_exists
))
2424 barf_or_query_if_file_exists (linkname
, "make it a link",
2425 INTEGERP (ok_if_already_exists
), 0);
2426 if (0 > symlink (XSTRING (filename
)->data
, XSTRING (linkname
)->data
))
2428 /* If we didn't complain already, silently delete existing file. */
2429 if (errno
== EEXIST
)
2431 unlink (XSTRING (linkname
)->data
);
2432 if (0 <= symlink (XSTRING (filename
)->data
, XSTRING (linkname
)->data
))
2442 report_file_error ("Making symbolic link", Flist (2, args
));
2444 report_file_error ("Making symbolic link", Flist (2, &filename
));
2450 #endif /* S_IFLNK */
2454 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2455 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2456 "Define the job-wide logical name NAME to have the value STRING.\n\
2457 If STRING is nil or a null string, the logical name NAME is deleted.")
2462 CHECK_STRING (name
, 0);
2464 delete_logical_name (XSTRING (name
)->data
);
2467 CHECK_STRING (string
, 1);
2469 if (XSTRING (string
)->size
== 0)
2470 delete_logical_name (XSTRING (name
)->data
);
2472 define_logical_name (XSTRING (name
)->data
, XSTRING (string
)->data
);
2481 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2482 "Open a network connection to PATH using LOGIN as the login string.")
2484 Lisp_Object path
, login
;
2488 CHECK_STRING (path
, 0);
2489 CHECK_STRING (login
, 0);
2491 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2493 if (netresult
== -1)
2498 #endif /* HPUX_NET */
2500 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2502 "Return t if file FILENAME specifies an absolute file name.\n\
2503 On Unix, this is a name starting with a `/' or a `~'.")
2505 Lisp_Object filename
;
2509 CHECK_STRING (filename
, 0);
2510 ptr
= XSTRING (filename
)->data
;
2511 if (IS_DIRECTORY_SEP (*ptr
) || *ptr
== '~'
2513 /* ??? This criterion is probably wrong for '<'. */
2514 || index (ptr
, ':') || index (ptr
, '<')
2515 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2519 || (IS_DRIVE (*ptr
) && ptr
[1] == ':' && IS_DIRECTORY_SEP (ptr
[2]))
2527 /* Return nonzero if file FILENAME exists and can be executed. */
2530 check_executable (filename
)
2534 int len
= strlen (filename
);
2537 if (stat (filename
, &st
) < 0)
2540 return ((st
.st_mode
& S_IEXEC
) != 0);
2542 return (S_ISREG (st
.st_mode
)
2544 && (stricmp ((suffix
= filename
+ len
-4), ".com") == 0
2545 || stricmp (suffix
, ".exe") == 0
2546 || stricmp (suffix
, ".bat") == 0)
2547 || (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2548 #endif /* not WINDOWSNT */
2549 #else /* not DOS_NT */
2550 #ifdef HAVE_EUIDACCESS
2551 return (euidaccess (filename
, 1) >= 0);
2553 /* Access isn't quite right because it uses the real uid
2554 and we really want to test with the effective uid.
2555 But Unix doesn't give us a right way to do it. */
2556 return (access (filename
, 1) >= 0);
2558 #endif /* not DOS_NT */
2561 /* Return nonzero if file FILENAME exists and can be written. */
2564 check_writable (filename
)
2569 if (stat (filename
, &st
) < 0)
2571 return (st
.st_mode
& S_IWRITE
|| (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2572 #else /* not MSDOS */
2574 return (eaccess (filename
, 2) >= 0);
2576 /* Access isn't quite right because it uses the real uid
2577 and we really want to test with the effective uid.
2578 But Unix doesn't give us a right way to do it.
2579 Opening with O_WRONLY could work for an ordinary file,
2580 but would lose for directories. */
2581 return (access (filename
, 2) >= 0);
2583 #endif /* not MSDOS */
2586 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2587 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
2588 See also `file-readable-p' and `file-attributes'.")
2590 Lisp_Object filename
;
2592 Lisp_Object absname
;
2593 Lisp_Object handler
;
2594 struct stat statbuf
;
2596 CHECK_STRING (filename
, 0);
2597 absname
= Fexpand_file_name (filename
, Qnil
);
2599 /* If the file name has special constructs in it,
2600 call the corresponding file handler. */
2601 handler
= Ffind_file_name_handler (absname
, Qfile_exists_p
);
2602 if (!NILP (handler
))
2603 return call2 (handler
, Qfile_exists_p
, absname
);
2605 return (stat (XSTRING (absname
)->data
, &statbuf
) >= 0) ? Qt
: Qnil
;
2608 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2609 "Return t if FILENAME can be executed by you.\n\
2610 For a directory, this means you can access files in that directory.")
2612 Lisp_Object filename
;
2615 Lisp_Object absname
;
2616 Lisp_Object handler
;
2618 CHECK_STRING (filename
, 0);
2619 absname
= Fexpand_file_name (filename
, Qnil
);
2621 /* If the file name has special constructs in it,
2622 call the corresponding file handler. */
2623 handler
= Ffind_file_name_handler (absname
, Qfile_executable_p
);
2624 if (!NILP (handler
))
2625 return call2 (handler
, Qfile_executable_p
, absname
);
2627 return (check_executable (XSTRING (absname
)->data
) ? Qt
: Qnil
);
2630 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2631 "Return t if file FILENAME exists and you can read it.\n\
2632 See also `file-exists-p' and `file-attributes'.")
2634 Lisp_Object filename
;
2636 Lisp_Object absname
;
2637 Lisp_Object handler
;
2640 CHECK_STRING (filename
, 0);
2641 absname
= Fexpand_file_name (filename
, Qnil
);
2643 /* If the file name has special constructs in it,
2644 call the corresponding file handler. */
2645 handler
= Ffind_file_name_handler (absname
, Qfile_readable_p
);
2646 if (!NILP (handler
))
2647 return call2 (handler
, Qfile_readable_p
, absname
);
2650 /* Under MS-DOS and Windows, open does not work for directories. */
2651 if (access (XSTRING (absname
)->data
, 0) == 0)
2654 #else /* not DOS_NT */
2655 desc
= open (XSTRING (absname
)->data
, O_RDONLY
);
2660 #endif /* not DOS_NT */
2663 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2665 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
2666 "Return t if file FILENAME can be written or created by you.")
2668 Lisp_Object filename
;
2670 Lisp_Object absname
, dir
;
2671 Lisp_Object handler
;
2672 struct stat statbuf
;
2674 CHECK_STRING (filename
, 0);
2675 absname
= Fexpand_file_name (filename
, Qnil
);
2677 /* If the file name has special constructs in it,
2678 call the corresponding file handler. */
2679 handler
= Ffind_file_name_handler (absname
, Qfile_writable_p
);
2680 if (!NILP (handler
))
2681 return call2 (handler
, Qfile_writable_p
, absname
);
2683 if (stat (XSTRING (absname
)->data
, &statbuf
) >= 0)
2684 return (check_writable (XSTRING (absname
)->data
)
2686 dir
= Ffile_name_directory (absname
);
2689 dir
= Fdirectory_file_name (dir
);
2693 dir
= Fdirectory_file_name (dir
);
2695 return (check_writable (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "")
2699 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
2700 "Return non-nil if file FILENAME is the name of a symbolic link.\n\
2701 The value is the name of the file to which it is linked.\n\
2702 Otherwise returns nil.")
2704 Lisp_Object filename
;
2711 Lisp_Object handler
;
2713 CHECK_STRING (filename
, 0);
2714 filename
= Fexpand_file_name (filename
, Qnil
);
2716 /* If the file name has special constructs in it,
2717 call the corresponding file handler. */
2718 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
2719 if (!NILP (handler
))
2720 return call2 (handler
, Qfile_symlink_p
, filename
);
2725 buf
= (char *) xmalloc (bufsize
);
2726 bzero (buf
, bufsize
);
2727 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
2728 if (valsize
< bufsize
) break;
2729 /* Buffer was not long enough */
2738 val
= make_string (buf
, valsize
);
2741 #else /* not S_IFLNK */
2743 #endif /* not S_IFLNK */
2746 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
2747 "Return t if file FILENAME is the name of a directory as a file.\n\
2748 A directory name spec may be given instead; then the value is t\n\
2749 if the directory so specified exists and really is a directory.")
2751 Lisp_Object filename
;
2753 register Lisp_Object absname
;
2755 Lisp_Object handler
;
2757 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2759 /* If the file name has special constructs in it,
2760 call the corresponding file handler. */
2761 handler
= Ffind_file_name_handler (absname
, Qfile_directory_p
);
2762 if (!NILP (handler
))
2763 return call2 (handler
, Qfile_directory_p
, absname
);
2765 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2767 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
2770 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
2771 "Return t if file FILENAME is the name of a directory as a file,\n\
2772 and files in that directory can be opened by you. In order to use a\n\
2773 directory as a buffer's current directory, this predicate must return true.\n\
2774 A directory name spec may be given instead; then the value is t\n\
2775 if the directory so specified exists and really is a readable and\n\
2776 searchable directory.")
2778 Lisp_Object filename
;
2780 Lisp_Object handler
;
2782 struct gcpro gcpro1
;
2784 /* If the file name has special constructs in it,
2785 call the corresponding file handler. */
2786 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
2787 if (!NILP (handler
))
2788 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
2790 /* It's an unlikely combination, but yes we really do need to gcpro:
2791 Suppose that file-accessible-directory-p has no handler, but
2792 file-directory-p does have a handler; this handler causes a GC which
2793 relocates the string in `filename'; and finally file-directory-p
2794 returns non-nil. Then we would end up passing a garbaged string
2795 to file-executable-p. */
2797 tem
= (NILP (Ffile_directory_p (filename
))
2798 || NILP (Ffile_executable_p (filename
)));
2800 return tem
? Qnil
: Qt
;
2803 DEFUN ("file-regular-p", Ffile_regular_p
, Sfile_regular_p
, 1, 1, 0,
2804 "Return t if file FILENAME is the name of a regular file.\n\
2805 This is the sort of file that holds an ordinary stream of data bytes.")
2807 Lisp_Object filename
;
2809 register Lisp_Object absname
;
2811 Lisp_Object handler
;
2813 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2815 /* If the file name has special constructs in it,
2816 call the corresponding file handler. */
2817 handler
= Ffind_file_name_handler (absname
, Qfile_regular_p
);
2818 if (!NILP (handler
))
2819 return call2 (handler
, Qfile_regular_p
, absname
);
2821 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2823 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
2826 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
2827 "Return mode bits of file named FILENAME, as an integer.")
2829 Lisp_Object filename
;
2831 Lisp_Object absname
;
2833 Lisp_Object handler
;
2835 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2837 /* If the file name has special constructs in it,
2838 call the corresponding file handler. */
2839 handler
= Ffind_file_name_handler (absname
, Qfile_modes
);
2840 if (!NILP (handler
))
2841 return call2 (handler
, Qfile_modes
, absname
);
2843 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2846 if (check_executable (XSTRING (absname
)->data
))
2847 st
.st_mode
|= S_IEXEC
;
2850 return make_number (st
.st_mode
& 07777);
2853 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
2854 "Set mode bits of file named FILENAME to MODE (an integer).\n\
2855 Only the 12 low bits of MODE are used.")
2857 Lisp_Object filename
, mode
;
2859 Lisp_Object absname
;
2860 Lisp_Object handler
;
2862 absname
= Fexpand_file_name (filename
, current_buffer
->directory
);
2863 CHECK_NUMBER (mode
, 1);
2865 /* If the file name has special constructs in it,
2866 call the corresponding file handler. */
2867 handler
= Ffind_file_name_handler (absname
, Qset_file_modes
);
2868 if (!NILP (handler
))
2869 return call3 (handler
, Qset_file_modes
, absname
, mode
);
2871 if (chmod (XSTRING (absname
)->data
, XINT (mode
)) < 0)
2872 report_file_error ("Doing chmod", Fcons (absname
, Qnil
));
2877 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
2878 "Set the file permission bits for newly created files.\n\
2879 The argument MODE should be an integer; only the low 9 bits are used.\n\
2880 This setting is inherited by subprocesses.")
2884 CHECK_NUMBER (mode
, 0);
2886 umask ((~ XINT (mode
)) & 0777);
2891 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
2892 "Return the default file protection for created files.\n\
2893 The value is an integer.")
2899 realmask
= umask (0);
2902 XSETINT (value
, (~ realmask
) & 0777);
2908 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
2909 "Tell Unix to finish all pending disk updates.")
2918 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
2919 "Return t if file FILE1 is newer than file FILE2.\n\
2920 If FILE1 does not exist, the answer is nil;\n\
2921 otherwise, if FILE2 does not exist, the answer is t.")
2923 Lisp_Object file1
, file2
;
2925 Lisp_Object absname1
, absname2
;
2928 Lisp_Object handler
;
2929 struct gcpro gcpro1
, gcpro2
;
2931 CHECK_STRING (file1
, 0);
2932 CHECK_STRING (file2
, 0);
2935 GCPRO2 (absname1
, file2
);
2936 absname1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
2937 absname2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
2940 /* If the file name has special constructs in it,
2941 call the corresponding file handler. */
2942 handler
= Ffind_file_name_handler (absname1
, Qfile_newer_than_file_p
);
2944 handler
= Ffind_file_name_handler (absname2
, Qfile_newer_than_file_p
);
2945 if (!NILP (handler
))
2946 return call3 (handler
, Qfile_newer_than_file_p
, absname1
, absname2
);
2948 if (stat (XSTRING (absname1
)->data
, &st
) < 0)
2951 mtime1
= st
.st_mtime
;
2953 if (stat (XSTRING (absname2
)->data
, &st
) < 0)
2956 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
2960 Lisp_Object Qfind_buffer_file_type
;
2963 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
2965 "Insert contents of file FILENAME after point.\n\
2966 Returns list of absolute file name and length of data inserted.\n\
2967 If second argument VISIT is non-nil, the buffer's visited filename\n\
2968 and last save file modtime are set, and it is marked unmodified.\n\
2969 If visiting and the file does not exist, visiting is completed\n\
2970 before the error is signaled.\n\n\
2971 The optional third and fourth arguments BEG and END\n\
2972 specify what portion of the file to insert.\n\
2973 If VISIT is non-nil, BEG and END must be nil.\n\
2974 If optional fifth argument REPLACE is non-nil,\n\
2975 it means replace the current buffer contents (in the accessible portion)\n\
2976 with the file contents. This is better than simply deleting and inserting\n\
2977 the whole thing because (1) it preserves some marker positions\n\
2978 and (2) it puts less data in the undo list.")
2979 (filename
, visit
, beg
, end
, replace
)
2980 Lisp_Object filename
, visit
, beg
, end
, replace
;
2984 register int inserted
= 0;
2985 register int how_much
;
2986 int count
= specpdl_ptr
- specpdl
;
2987 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2988 Lisp_Object handler
, val
, insval
;
2991 int not_regular
= 0;
2993 if (current_buffer
->base_buffer
&& ! NILP (visit
))
2994 error ("Cannot do file visiting in an indirect buffer");
2996 if (!NILP (current_buffer
->read_only
))
2997 Fbarf_if_buffer_read_only ();
3002 GCPRO3 (filename
, val
, p
);
3004 CHECK_STRING (filename
, 0);
3005 filename
= Fexpand_file_name (filename
, Qnil
);
3007 /* If the file name has special constructs in it,
3008 call the corresponding file handler. */
3009 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
3010 if (!NILP (handler
))
3012 val
= call6 (handler
, Qinsert_file_contents
, filename
,
3013 visit
, beg
, end
, replace
);
3020 if (stat (XSTRING (filename
)->data
, &st
) < 0)
3022 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0
3023 || fstat (fd
, &st
) < 0)
3024 #endif /* not APOLLO */
3026 if (fd
>= 0) close (fd
);
3029 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
3036 /* This code will need to be changed in order to work on named
3037 pipes, and it's probably just not worth it. So we should at
3038 least signal an error. */
3039 if (!S_ISREG (st
.st_mode
))
3042 Fsignal (Qfile_error
,
3043 Fcons (build_string ("not a regular file"),
3044 Fcons (filename
, Qnil
)));
3052 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0)
3055 /* Replacement should preserve point as it preserves markers. */
3056 if (!NILP (replace
))
3057 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
3059 record_unwind_protect (close_file_unwind
, make_number (fd
));
3061 /* Supposedly happens on VMS. */
3063 error ("File size is negative");
3065 if (!NILP (beg
) || !NILP (end
))
3067 error ("Attempt to visit less than an entire file");
3070 CHECK_NUMBER (beg
, 0);
3072 XSETFASTINT (beg
, 0);
3075 CHECK_NUMBER (end
, 0);
3078 XSETINT (end
, st
.st_size
);
3079 if (XINT (end
) != st
.st_size
)
3080 error ("maximum buffer size exceeded");
3083 /* If requested, replace the accessible part of the buffer
3084 with the file contents. Avoid replacing text at the
3085 beginning or end of the buffer that matches the file contents;
3086 that preserves markers pointing to the unchanged parts. */
3088 /* On MSDOS, replace mode doesn't really work, except for binary files,
3089 and it's not worth supporting just for them. */
3090 if (!NILP (replace
))
3093 XSETFASTINT (beg
, 0);
3094 XSETFASTINT (end
, st
.st_size
);
3095 del_range_1 (BEGV
, ZV
, 0);
3097 #else /* not DOS_NT */
3098 if (!NILP (replace
))
3100 unsigned char buffer
[1 << 14];
3101 int same_at_start
= BEGV
;
3102 int same_at_end
= ZV
;
3107 /* Count how many chars at the start of the file
3108 match the text at the beginning of the buffer. */
3113 nread
= read (fd
, buffer
, sizeof buffer
);
3115 error ("IO error reading %s: %s",
3116 XSTRING (filename
)->data
, strerror (errno
));
3117 else if (nread
== 0)
3120 while (bufpos
< nread
&& same_at_start
< ZV
3121 && FETCH_CHAR (same_at_start
) == buffer
[bufpos
])
3122 same_at_start
++, bufpos
++;
3123 /* If we found a discrepancy, stop the scan.
3124 Otherwise loop around and scan the next bufferful. */
3125 if (bufpos
!= nread
)
3129 /* If the file matches the buffer completely,
3130 there's no need to replace anything. */
3131 if (same_at_start
- BEGV
== st
.st_size
)
3135 /* Truncate the buffer to the size of the file. */
3136 del_range_1 (same_at_start
, same_at_end
, 0);
3141 /* Count how many chars at the end of the file
3142 match the text at the end of the buffer. */
3145 int total_read
, nread
, bufpos
, curpos
, trial
;
3147 /* At what file position are we now scanning? */
3148 curpos
= st
.st_size
- (ZV
- same_at_end
);
3149 /* If the entire file matches the buffer tail, stop the scan. */
3152 /* How much can we scan in the next step? */
3153 trial
= min (curpos
, sizeof buffer
);
3154 if (lseek (fd
, curpos
- trial
, 0) < 0)
3155 report_file_error ("Setting file position",
3156 Fcons (filename
, Qnil
));
3159 while (total_read
< trial
)
3161 nread
= read (fd
, buffer
+ total_read
, trial
- total_read
);
3163 error ("IO error reading %s: %s",
3164 XSTRING (filename
)->data
, strerror (errno
));
3165 total_read
+= nread
;
3167 /* Scan this bufferful from the end, comparing with
3168 the Emacs buffer. */
3169 bufpos
= total_read
;
3170 /* Compare with same_at_start to avoid counting some buffer text
3171 as matching both at the file's beginning and at the end. */
3172 while (bufpos
> 0 && same_at_end
> same_at_start
3173 && FETCH_CHAR (same_at_end
- 1) == buffer
[bufpos
- 1])
3174 same_at_end
--, bufpos
--;
3175 /* If we found a discrepancy, stop the scan.
3176 Otherwise loop around and scan the preceding bufferful. */
3179 /* If display current starts at beginning of line,
3180 keep it that way. */
3181 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3182 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3186 /* Don't try to reuse the same piece of text twice. */
3187 overlap
= same_at_start
- BEGV
- (same_at_end
+ st
.st_size
- ZV
);
3189 same_at_end
+= overlap
;
3191 /* Arrange to read only the nonmatching middle part of the file. */
3192 XSETFASTINT (beg
, same_at_start
- BEGV
);
3193 XSETFASTINT (end
, st
.st_size
- (ZV
- same_at_end
));
3195 del_range_1 (same_at_start
, same_at_end
, 0);
3196 /* Insert from the file at the proper position. */
3197 SET_PT (same_at_start
);
3199 #endif /* not DOS_NT */
3201 total
= XINT (end
) - XINT (beg
);
3204 register Lisp_Object temp
;
3206 /* Make sure point-max won't overflow after this insertion. */
3207 XSETINT (temp
, total
);
3208 if (total
!= XINT (temp
))
3209 error ("maximum buffer size exceeded");
3212 if (NILP (visit
) && total
> 0)
3213 prepare_to_modify_buffer (point
, point
);
3216 if (GAP_SIZE
< total
)
3217 make_gap (total
- GAP_SIZE
);
3219 if (XINT (beg
) != 0 || !NILP (replace
))
3221 if (lseek (fd
, XINT (beg
), 0) < 0)
3222 report_file_error ("Setting file position", Fcons (filename
, Qnil
));
3226 while (inserted
< total
)
3228 /* try is reserved in some compilers (Microsoft C) */
3229 int trytry
= min (total
- inserted
, 64 << 10);
3232 /* Allow quitting out of the actual I/O. */
3235 this = read (fd
, &FETCH_CHAR (point
+ inserted
- 1) + 1, trytry
);
3252 /* Demacs 1.1.1 91/10/16 HIRANO Satoshi, MW July 1993 */
3253 /* Determine file type from name and remove LFs from CR-LFs if the file
3254 is deemed to be a text file. */
3256 current_buffer
->buffer_file_type
3257 = call1 (Qfind_buffer_file_type
, filename
);
3258 if (NILP (current_buffer
->buffer_file_type
))
3261 = inserted
- crlf_to_lf (inserted
, &FETCH_CHAR (point
- 1) + 1);
3264 GPT
-= reduced_size
;
3265 GAP_SIZE
+= reduced_size
;
3266 inserted
-= reduced_size
;
3273 record_insert (point
, inserted
);
3275 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
3276 offset_intervals (current_buffer
, point
, inserted
);
3282 /* Discard the unwind protect for closing the file. */
3286 error ("IO error reading %s: %s",
3287 XSTRING (filename
)->data
, strerror (errno
));
3294 if (!EQ (current_buffer
->undo_list
, Qt
))
3295 current_buffer
->undo_list
= Qnil
;
3297 stat (XSTRING (filename
)->data
, &st
);
3302 current_buffer
->modtime
= st
.st_mtime
;
3303 current_buffer
->filename
= filename
;
3306 SAVE_MODIFF
= MODIFF
;
3307 current_buffer
->auto_save_modified
= MODIFF
;
3308 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
3309 #ifdef CLASH_DETECTION
3312 if (!NILP (current_buffer
->file_truename
))
3313 unlock_file (current_buffer
->file_truename
);
3314 unlock_file (filename
);
3316 #endif /* CLASH_DETECTION */
3318 Fsignal (Qfile_error
,
3319 Fcons (build_string ("not a regular file"),
3320 Fcons (filename
, Qnil
)));
3322 /* If visiting nonexistent file, return nil. */
3323 if (current_buffer
->modtime
== -1)
3324 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
3327 /* Decode file format */
3330 insval
= call3 (Qformat_decode
,
3331 Qnil
, make_number (inserted
), visit
);
3332 CHECK_NUMBER (insval
, 0);
3333 inserted
= XFASTINT (insval
);
3336 if (inserted
> 0 && NILP (visit
) && total
> 0)
3337 signal_after_change (point
, 0, inserted
);
3341 p
= Vafter_insert_file_functions
;
3344 insval
= call1 (Fcar (p
), make_number (inserted
));
3347 CHECK_NUMBER (insval
, 0);
3348 inserted
= XFASTINT (insval
);
3356 val
= Fcons (filename
,
3357 Fcons (make_number (inserted
),
3360 RETURN_UNGCPRO (unbind_to (count
, val
));
3363 static Lisp_Object
build_annotations ();
3365 /* If build_annotations switched buffers, switch back to BUF.
3366 Kill the temporary buffer that was selected in the meantime. */
3369 build_annotations_unwind (buf
)
3374 if (XBUFFER (buf
) == current_buffer
)
3376 tembuf
= Fcurrent_buffer ();
3378 Fkill_buffer (tembuf
);
3382 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 6,
3383 "r\nFWrite region to file: ",
3384 "Write current region into specified file.\n\
3385 When called from a program, takes three arguments:\n\
3386 START, END and FILENAME. START and END are buffer positions.\n\
3387 Optional fourth argument APPEND if non-nil means\n\
3388 append to existing file contents (if any).\n\
3389 Optional fifth argument VISIT if t means\n\
3390 set the last-save-file-modtime of buffer to this file's modtime\n\
3391 and mark buffer not modified.\n\
3392 If VISIT is a string, it is a second file name;\n\
3393 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
3394 VISIT is also the file name to lock and unlock for clash detection.\n\
3395 If VISIT is neither t nor nil nor a string,\n\
3396 that means do not print the \"Wrote file\" message.\n\
3397 The optional sixth arg LOCKNAME, if non-nil, specifies the name to\n\
3398 use for locking and unlocking, overriding FILENAME and VISIT.\n\
3399 Kludgy feature: if START is a string, then that string is written\n\
3400 to the file, instead of any buffer contents, and END is ignored.")
3401 (start
, end
, filename
, append
, visit
, lockname
)
3402 Lisp_Object start
, end
, filename
, append
, visit
, lockname
;
3410 int count
= specpdl_ptr
- specpdl
;
3413 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
3415 Lisp_Object handler
;
3416 Lisp_Object visit_file
;
3417 Lisp_Object annotations
;
3418 int visiting
, quietly
;
3419 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
3420 struct buffer
*given_buffer
;
3422 int buffer_file_type
3423 = NILP (current_buffer
->buffer_file_type
) ? O_TEXT
: O_BINARY
;
3426 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3427 error ("Cannot do file visiting in an indirect buffer");
3429 if (!NILP (start
) && !STRINGP (start
))
3430 validate_region (&start
, &end
);
3432 GCPRO3 (filename
, visit
, lockname
);
3433 filename
= Fexpand_file_name (filename
, Qnil
);
3434 if (STRINGP (visit
))
3435 visit_file
= Fexpand_file_name (visit
, Qnil
);
3437 visit_file
= filename
;
3440 visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
3441 quietly
= !NILP (visit
);
3445 if (NILP (lockname
))
3446 lockname
= visit_file
;
3448 GCPRO5 (start
, filename
, annotations
, visit_file
, lockname
);
3450 /* If the file name has special constructs in it,
3451 call the corresponding file handler. */
3452 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
3453 /* If FILENAME has no handler, see if VISIT has one. */
3454 if (NILP (handler
) && STRINGP (visit
))
3455 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
3457 if (!NILP (handler
))
3460 val
= call6 (handler
, Qwrite_region
, start
, end
,
3461 filename
, append
, visit
);
3465 SAVE_MODIFF
= MODIFF
;
3466 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
3467 current_buffer
->filename
= visit_file
;
3473 /* Special kludge to simplify auto-saving. */
3476 XSETFASTINT (start
, BEG
);
3477 XSETFASTINT (end
, Z
);
3480 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
3481 count1
= specpdl_ptr
- specpdl
;
3483 given_buffer
= current_buffer
;
3484 annotations
= build_annotations (start
, end
);
3485 if (current_buffer
!= given_buffer
)
3491 #ifdef CLASH_DETECTION
3493 lock_file (lockname
);
3494 #endif /* CLASH_DETECTION */
3496 fn
= XSTRING (filename
)->data
;
3500 desc
= open (fn
, O_WRONLY
| buffer_file_type
);
3501 #else /* not DOS_NT */
3502 desc
= open (fn
, O_WRONLY
);
3503 #endif /* not DOS_NT */
3507 if (auto_saving
) /* Overwrite any previous version of autosave file */
3509 vms_truncate (fn
); /* if fn exists, truncate to zero length */
3510 desc
= open (fn
, O_RDWR
);
3512 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
3513 ? XSTRING (current_buffer
->filename
)->data
: 0,
3516 else /* Write to temporary name and rename if no errors */
3518 Lisp_Object temp_name
;
3519 temp_name
= Ffile_name_directory (filename
);
3521 if (!NILP (temp_name
))
3523 temp_name
= Fmake_temp_name (concat2 (temp_name
,
3524 build_string ("$$SAVE$$")));
3525 fname
= XSTRING (filename
)->data
;
3526 fn
= XSTRING (temp_name
)->data
;
3527 desc
= creat_copy_attrs (fname
, fn
);
3530 /* If we can't open the temporary file, try creating a new
3531 version of the original file. VMS "creat" creates a
3532 new version rather than truncating an existing file. */
3535 desc
= creat (fn
, 0666);
3536 #if 0 /* This can clobber an existing file and fail to replace it,
3537 if the user runs out of space. */
3540 /* We can't make a new version;
3541 try to truncate and rewrite existing version if any. */
3543 desc
= open (fn
, O_RDWR
);
3549 desc
= creat (fn
, 0666);
3554 O_WRONLY
| O_TRUNC
| O_CREAT
| buffer_file_type
,
3555 S_IREAD
| S_IWRITE
);
3556 #else /* not DOS_NT */
3557 desc
= creat (fn
, auto_saving
? auto_save_mode_bits
: 0666);
3558 #endif /* not DOS_NT */
3559 #endif /* not VMS */
3565 #ifdef CLASH_DETECTION
3567 if (!auto_saving
) unlock_file (lockname
);
3569 #endif /* CLASH_DETECTION */
3570 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
3573 record_unwind_protect (close_file_unwind
, make_number (desc
));
3576 if (lseek (desc
, 0, 2) < 0)
3578 #ifdef CLASH_DETECTION
3579 if (!auto_saving
) unlock_file (lockname
);
3580 #endif /* CLASH_DETECTION */
3581 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
3586 * Kludge Warning: The VMS C RTL likes to insert carriage returns
3587 * if we do writes that don't end with a carriage return. Furthermore
3588 * it cannot handle writes of more then 16K. The modified
3589 * version of "sys_write" in SYSDEP.C (see comment there) copes with
3590 * this EXCEPT for the last record (iff it doesn't end with a carriage
3591 * return). This implies that if your buffer doesn't end with a carriage
3592 * return, you get one free... tough. However it also means that if
3593 * we make two calls to sys_write (a la the following code) you can
3594 * get one at the gap as well. The easiest way to fix this (honest)
3595 * is to move the gap to the next newline (or the end of the buffer).
3600 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
3601 move_gap (find_next_newline (GPT
, 1));
3607 if (STRINGP (start
))
3609 failure
= 0 > a_write (desc
, XSTRING (start
)->data
,
3610 XSTRING (start
)->size
, 0, &annotations
);
3613 else if (XINT (start
) != XINT (end
))
3616 if (XINT (start
) < GPT
)
3618 register int end1
= XINT (end
);
3620 failure
= 0 > a_write (desc
, &FETCH_CHAR (tem
),
3621 min (GPT
, end1
) - tem
, tem
, &annotations
);
3622 nwritten
+= min (GPT
, end1
) - tem
;
3626 if (XINT (end
) > GPT
&& !failure
)
3629 tem
= max (tem
, GPT
);
3630 failure
= 0 > a_write (desc
, &FETCH_CHAR (tem
), XINT (end
) - tem
,
3632 nwritten
+= XINT (end
) - tem
;
3638 /* If file was empty, still need to write the annotations */
3639 failure
= 0 > a_write (desc
, "", 0, XINT (start
), &annotations
);
3646 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
3647 Disk full in NFS may be reported here. */
3648 /* mib says that closing the file will try to write as fast as NFS can do
3649 it, and that means the fsync here is not crucial for autosave files. */
3650 if (!auto_saving
&& fsync (desc
) < 0)
3652 /* If fsync fails with EINTR, don't treat that as serious. */
3654 failure
= 1, save_errno
= errno
;
3658 /* Spurious "file has changed on disk" warnings have been
3659 observed on Suns as well.
3660 It seems that `close' can change the modtime, under nfs.
3662 (This has supposedly been fixed in Sunos 4,
3663 but who knows about all the other machines with NFS?) */
3666 /* On VMS and APOLLO, must do the stat after the close
3667 since closing changes the modtime. */
3670 /* Recall that #if defined does not work on VMS. */
3677 /* NFS can report a write failure now. */
3678 if (close (desc
) < 0)
3679 failure
= 1, save_errno
= errno
;
3682 /* If we wrote to a temporary name and had no errors, rename to real name. */
3686 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
3694 /* Discard the unwind protect for close_file_unwind. */
3695 specpdl_ptr
= specpdl
+ count1
;
3696 /* Restore the original current buffer. */
3697 visit_file
= unbind_to (count
, visit_file
);
3699 #ifdef CLASH_DETECTION
3701 unlock_file (lockname
);
3702 #endif /* CLASH_DETECTION */
3704 /* Do this before reporting IO error
3705 to avoid a "file has changed on disk" warning on
3706 next attempt to save. */
3708 current_buffer
->modtime
= st
.st_mtime
;
3711 error ("IO error writing %s: %s", fn
, strerror (save_errno
));
3715 SAVE_MODIFF
= MODIFF
;
3716 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
3717 current_buffer
->filename
= visit_file
;
3718 update_mode_lines
++;
3724 message ("Wrote %s", XSTRING (visit_file
)->data
);
3729 Lisp_Object
merge ();
3731 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
3732 "Return t if (car A) is numerically less than (car B).")
3736 return Flss (Fcar (a
), Fcar (b
));
3739 /* Build the complete list of annotations appropriate for writing out
3740 the text between START and END, by calling all the functions in
3741 write-region-annotate-functions and merging the lists they return.
3742 If one of these functions switches to a different buffer, we assume
3743 that buffer contains altered text. Therefore, the caller must
3744 make sure to restore the current buffer in all cases,
3745 as save-excursion would do. */
3748 build_annotations (start
, end
)
3749 Lisp_Object start
, end
;
3751 Lisp_Object annotations
;
3753 struct gcpro gcpro1
, gcpro2
;
3756 p
= Vwrite_region_annotate_functions
;
3757 GCPRO2 (annotations
, p
);
3760 struct buffer
*given_buffer
= current_buffer
;
3761 Vwrite_region_annotations_so_far
= annotations
;
3762 res
= call2 (Fcar (p
), start
, end
);
3763 /* If the function makes a different buffer current,
3764 assume that means this buffer contains altered text to be output.
3765 Reset START and END from the buffer bounds
3766 and discard all previous annotations because they should have
3767 been dealt with by this function. */
3768 if (current_buffer
!= given_buffer
)
3774 Flength (res
); /* Check basic validity of return value */
3775 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
3779 /* Now do the same for annotation functions implied by the file-format */
3780 if (auto_saving
&& (!EQ (Vauto_save_file_format
, Qt
)))
3781 p
= Vauto_save_file_format
;
3783 p
= current_buffer
->file_format
;
3786 struct buffer
*given_buffer
= current_buffer
;
3787 Vwrite_region_annotations_so_far
= annotations
;
3788 res
= call3 (Qformat_annotate_function
, Fcar (p
), start
, end
);
3789 if (current_buffer
!= given_buffer
)
3796 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
3803 /* Write to descriptor DESC the LEN characters starting at ADDR,
3804 assuming they start at position POS in the buffer.
3805 Intersperse with them the annotations from *ANNOT
3806 (those which fall within the range of positions POS to POS + LEN),
3807 each at its appropriate position.
3809 Modify *ANNOT by discarding elements as we output them.
3810 The return value is negative in case of system call failure. */
3813 a_write (desc
, addr
, len
, pos
, annot
)
3815 register char *addr
;
3822 int lastpos
= pos
+ len
;
3824 while (NILP (*annot
) || CONSP (*annot
))
3826 tem
= Fcar_safe (Fcar (*annot
));
3827 if (INTEGERP (tem
) && XINT (tem
) >= pos
&& XFASTINT (tem
) <= lastpos
)
3828 nextpos
= XFASTINT (tem
);
3830 return e_write (desc
, addr
, lastpos
- pos
);
3833 if (0 > e_write (desc
, addr
, nextpos
- pos
))
3835 addr
+= nextpos
- pos
;
3838 tem
= Fcdr (Fcar (*annot
));
3841 if (0 > e_write (desc
, XSTRING (tem
)->data
, XSTRING (tem
)->size
))
3844 *annot
= Fcdr (*annot
);
3849 e_write (desc
, addr
, len
)
3851 register char *addr
;
3854 char buf
[16 * 1024];
3855 register char *p
, *end
;
3857 if (!EQ (current_buffer
->selective_display
, Qt
))
3858 return write (desc
, addr
, len
) - len
;
3862 end
= p
+ sizeof buf
;
3867 if (write (desc
, buf
, sizeof buf
) != sizeof buf
)
3876 if (write (desc
, buf
, p
- buf
) != p
- buf
)
3882 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
3883 Sverify_visited_file_modtime
, 1, 1, 0,
3884 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
3885 This means that the file has not been changed since it was visited or saved.")
3891 Lisp_Object handler
;
3893 CHECK_BUFFER (buf
, 0);
3896 if (!STRINGP (b
->filename
)) return Qt
;
3897 if (b
->modtime
== 0) return Qt
;
3899 /* If the file name has special constructs in it,
3900 call the corresponding file handler. */
3901 handler
= Ffind_file_name_handler (b
->filename
,
3902 Qverify_visited_file_modtime
);
3903 if (!NILP (handler
))
3904 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
3906 if (stat (XSTRING (b
->filename
)->data
, &st
) < 0)
3908 /* If the file doesn't exist now and didn't exist before,
3909 we say that it isn't modified, provided the error is a tame one. */
3910 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
3915 if (st
.st_mtime
== b
->modtime
3916 /* If both are positive, accept them if they are off by one second. */
3917 || (st
.st_mtime
> 0 && b
->modtime
> 0
3918 && (st
.st_mtime
== b
->modtime
+ 1
3919 || st
.st_mtime
== b
->modtime
- 1)))
3924 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
3925 Sclear_visited_file_modtime
, 0, 0, 0,
3926 "Clear out records of last mod time of visited file.\n\
3927 Next attempt to save will certainly not complain of a discrepancy.")
3930 current_buffer
->modtime
= 0;
3934 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
3935 Svisited_file_modtime
, 0, 0, 0,
3936 "Return the current buffer's recorded visited file modification time.\n\
3937 The value is a list of the form (HIGH . LOW), like the time values\n\
3938 that `file-attributes' returns.")
3941 return long_to_cons ((unsigned long) current_buffer
->modtime
);
3944 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
3945 Sset_visited_file_modtime
, 0, 1, 0,
3946 "Update buffer's recorded modification time from the visited file's time.\n\
3947 Useful if the buffer was not read from the file normally\n\
3948 or if the file itself has been changed for some known benign reason.\n\
3949 An argument specifies the modification time value to use\n\
3950 \(instead of that of the visited file), in the form of a list\n\
3951 \(HIGH . LOW) or (HIGH LOW).")
3953 Lisp_Object time_list
;
3955 if (!NILP (time_list
))
3956 current_buffer
->modtime
= cons_to_long (time_list
);
3959 register Lisp_Object filename
;
3961 Lisp_Object handler
;
3963 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
3965 /* If the file name has special constructs in it,
3966 call the corresponding file handler. */
3967 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
3968 if (!NILP (handler
))
3969 /* The handler can find the file name the same way we did. */
3970 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
3971 else if (stat (XSTRING (filename
)->data
, &st
) >= 0)
3972 current_buffer
->modtime
= st
.st_mtime
;
3982 message ("Autosaving...error for %s", XSTRING (current_buffer
->name
)->data
);
3983 Fsleep_for (make_number (1), Qnil
);
3984 message ("Autosaving...error!for %s", XSTRING (current_buffer
->name
)->data
);
3985 Fsleep_for (make_number (1), Qnil
);
3986 message ("Autosaving...error for %s", XSTRING (current_buffer
->name
)->data
);
3987 Fsleep_for (make_number (1), Qnil
);
3997 /* Get visited file's mode to become the auto save file's mode. */
3998 if (stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
3999 /* But make sure we can overwrite it later! */
4000 auto_save_mode_bits
= st
.st_mode
| 0600;
4002 auto_save_mode_bits
= 0666;
4005 Fwrite_region (Qnil
, Qnil
,
4006 current_buffer
->auto_save_file_name
,
4007 Qnil
, Qlambda
, Qnil
);
4011 do_auto_save_unwind (desc
) /* used as unwind-protect function */
4015 if (XINT (desc
) >= 0)
4016 close (XINT (desc
));
4020 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
4021 "Auto-save all buffers that need it.\n\
4022 This is all buffers that have auto-saving enabled\n\
4023 and are changed since last auto-saved.\n\
4024 Auto-saving writes the buffer into a file\n\
4025 so that your editing is not lost if the system crashes.\n\
4026 This file is not the file you visited; that changes only when you save.\n\
4027 Normally we run the normal hook `auto-save-hook' before saving.\n\n\
4028 A non-nil NO-MESSAGE argument means do not print any message if successful.\n\
4029 A non-nil CURRENT-ONLY argument means save only current buffer.")
4030 (no_message
, current_only
)
4031 Lisp_Object no_message
, current_only
;
4033 struct buffer
*old
= current_buffer
, *b
;
4034 Lisp_Object tail
, buf
;
4036 char *omessage
= echo_area_glyphs
;
4037 int omessage_length
= echo_area_glyphs_length
;
4038 extern int minibuf_level
;
4039 int do_handled_files
;
4042 int count
= specpdl_ptr
- specpdl
;
4045 /* Ordinarily don't quit within this function,
4046 but don't make it impossible to quit (in case we get hung in I/O). */
4050 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
4051 point to non-strings reached from Vbuffer_alist. */
4056 if (!NILP (Vrun_hooks
))
4057 call1 (Vrun_hooks
, intern ("auto-save-hook"));
4059 if (STRINGP (Vauto_save_list_file_name
))
4061 Lisp_Object listfile
;
4062 listfile
= Fexpand_file_name (Vauto_save_list_file_name
, Qnil
);
4064 listdesc
= open (XSTRING (listfile
)->data
,
4065 O_WRONLY
| O_TRUNC
| O_CREAT
| O_TEXT
,
4066 S_IREAD
| S_IWRITE
);
4067 #else /* not DOS_NT */
4068 listdesc
= creat (XSTRING (listfile
)->data
, 0666);
4069 #endif /* not DOS_NT */
4074 /* Arrange to close that file whether or not we get an error.
4075 Also reset auto_saving to 0. */
4076 record_unwind_protect (do_auto_save_unwind
, make_number (listdesc
));
4080 /* First, save all files which don't have handlers. If Emacs is
4081 crashing, the handlers may tweak what is causing Emacs to crash
4082 in the first place, and it would be a shame if Emacs failed to
4083 autosave perfectly ordinary files because it couldn't handle some
4085 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
4086 for (tail
= Vbuffer_alist
; GC_CONSP (tail
); tail
= XCONS (tail
)->cdr
)
4088 buf
= XCONS (XCONS (tail
)->car
)->cdr
;
4091 /* Record all the buffers that have auto save mode
4092 in the special file that lists them. For each of these buffers,
4093 Record visited name (if any) and auto save name. */
4094 if (STRINGP (b
->auto_save_file_name
)
4095 && listdesc
>= 0 && do_handled_files
== 0)
4097 if (!NILP (b
->filename
))
4099 write (listdesc
, XSTRING (b
->filename
)->data
,
4100 XSTRING (b
->filename
)->size
);
4102 write (listdesc
, "\n", 1);
4103 write (listdesc
, XSTRING (b
->auto_save_file_name
)->data
,
4104 XSTRING (b
->auto_save_file_name
)->size
);
4105 write (listdesc
, "\n", 1);
4108 if (!NILP (current_only
)
4109 && b
!= current_buffer
)
4112 /* Don't auto-save indirect buffers.
4113 The base buffer takes care of it. */
4117 /* Check for auto save enabled
4118 and file changed since last auto save
4119 and file changed since last real save. */
4120 if (STRINGP (b
->auto_save_file_name
)
4121 && BUF_SAVE_MODIFF (b
) < BUF_MODIFF (b
)
4122 && b
->auto_save_modified
< BUF_MODIFF (b
)
4123 /* -1 means we've turned off autosaving for a while--see below. */
4124 && XINT (b
->save_length
) >= 0
4125 && (do_handled_files
4126 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
4129 EMACS_TIME before_time
, after_time
;
4131 EMACS_GET_TIME (before_time
);
4133 /* If we had a failure, don't try again for 20 minutes. */
4134 if (b
->auto_save_failure_time
>= 0
4135 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
4138 if ((XFASTINT (b
->save_length
) * 10
4139 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
4140 /* A short file is likely to change a large fraction;
4141 spare the user annoying messages. */
4142 && XFASTINT (b
->save_length
) > 5000
4143 /* These messages are frequent and annoying for `*mail*'. */
4144 && !EQ (b
->filename
, Qnil
)
4145 && NILP (no_message
))
4147 /* It has shrunk too much; turn off auto-saving here. */
4148 message ("Buffer %s has shrunk a lot; auto save turned off there",
4149 XSTRING (b
->name
)->data
);
4150 /* Turn off auto-saving until there's a real save,
4151 and prevent any more warnings. */
4152 XSETINT (b
->save_length
, -1);
4153 Fsleep_for (make_number (1), Qnil
);
4156 set_buffer_internal (b
);
4157 if (!auto_saved
&& NILP (no_message
))
4158 message1 ("Auto-saving...");
4159 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
4161 b
->auto_save_modified
= BUF_MODIFF (b
);
4162 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4163 set_buffer_internal (old
);
4165 EMACS_GET_TIME (after_time
);
4167 /* If auto-save took more than 60 seconds,
4168 assume it was an NFS failure that got a timeout. */
4169 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
4170 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
4174 /* Prevent another auto save till enough input events come in. */
4175 record_auto_save ();
4177 if (auto_saved
&& NILP (no_message
))
4181 sit_for (1, 0, 0, 0);
4182 message2 (omessage
, omessage_length
);
4185 message1 ("Auto-saving...done");
4190 unbind_to (count
, Qnil
);
4194 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
4195 Sset_buffer_auto_saved
, 0, 0, 0,
4196 "Mark current buffer as auto-saved with its current text.\n\
4197 No auto-save file will be written until the buffer changes again.")
4200 current_buffer
->auto_save_modified
= MODIFF
;
4201 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4202 current_buffer
->auto_save_failure_time
= -1;
4206 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
4207 Sclear_buffer_auto_save_failure
, 0, 0, 0,
4208 "Clear any record of a recent auto-save failure in the current buffer.")
4211 current_buffer
->auto_save_failure_time
= -1;
4215 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
4217 "Return t if buffer has been auto-saved since last read in or saved.")
4220 return (SAVE_MODIFF
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
4223 /* Reading and completing file names */
4224 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
4226 /* In the string VAL, change each $ to $$ and return the result. */
4229 double_dollars (val
)
4232 register unsigned char *old
, *new;
4236 osize
= XSTRING (val
)->size
;
4237 /* Quote "$" as "$$" to get it past substitute-in-file-name */
4238 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
4239 if (*old
++ == '$') count
++;
4242 old
= XSTRING (val
)->data
;
4243 val
= Fmake_string (make_number (osize
+ count
), make_number (0));
4244 new = XSTRING (val
)->data
;
4245 for (n
= osize
; n
> 0; n
--)
4258 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
4260 "Internal subroutine for read-file-name. Do not call this.")
4261 (string
, dir
, action
)
4262 Lisp_Object string
, dir
, action
;
4263 /* action is nil for complete, t for return list of completions,
4264 lambda for verify final value */
4266 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
4268 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
4275 /* No need to protect ACTION--we only compare it with t and nil. */
4276 GCPRO5 (string
, realdir
, name
, specdir
, orig_string
);
4278 if (XSTRING (string
)->size
== 0)
4280 if (EQ (action
, Qlambda
))
4288 orig_string
= string
;
4289 string
= Fsubstitute_in_file_name (string
);
4290 changed
= NILP (Fstring_equal (string
, orig_string
));
4291 name
= Ffile_name_nondirectory (string
);
4292 val
= Ffile_name_directory (string
);
4294 realdir
= Fexpand_file_name (val
, realdir
);
4299 specdir
= Ffile_name_directory (string
);
4300 val
= Ffile_name_completion (name
, realdir
);
4305 return double_dollars (string
);
4309 if (!NILP (specdir
))
4310 val
= concat2 (specdir
, val
);
4312 return double_dollars (val
);
4315 #endif /* not VMS */
4319 if (EQ (action
, Qt
))
4320 return Ffile_name_all_completions (name
, realdir
);
4321 /* Only other case actually used is ACTION = lambda */
4323 /* Supposedly this helps commands such as `cd' that read directory names,
4324 but can someone explain how it helps them? -- RMS */
4325 if (XSTRING (name
)->size
== 0)
4328 return Ffile_exists_p (string
);
4331 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
4332 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
4333 Value is not expanded---you must call `expand-file-name' yourself.\n\
4334 Default name to DEFAULT-FILENAME if user enters a null string.\n\
4335 (If DEFAULT-FILENAME is omitted, the visited file name is used,\n\
4336 except that if INITIAL is specified, that combined with DIR is used.)\n\
4337 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
4338 Non-nil and non-t means also require confirmation after completion.\n\
4339 Fifth arg INITIAL specifies text to start with.\n\
4340 DIR defaults to current buffer's directory default.")
4341 (prompt
, dir
, default_filename
, mustmatch
, initial
)
4342 Lisp_Object prompt
, dir
, default_filename
, mustmatch
, initial
;
4344 Lisp_Object val
, insdef
, insdef1
, tem
;
4345 struct gcpro gcpro1
, gcpro2
;
4346 register char *homedir
;
4350 dir
= current_buffer
->directory
;
4351 if (NILP (default_filename
))
4353 if (! NILP (initial
))
4354 default_filename
= Fexpand_file_name (initial
, dir
);
4356 default_filename
= current_buffer
->filename
;
4359 /* If dir starts with user's homedir, change that to ~. */
4360 homedir
= (char *) egetenv ("HOME");
4362 homedir
= strcpy (alloca (strlen (homedir
) + 1), homedir
);
4363 CORRECT_DIR_SEPS (homedir
);
4367 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
4368 && IS_DIRECTORY_SEP (XSTRING (dir
)->data
[strlen (homedir
)]))
4370 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
4371 XSTRING (dir
)->size
- strlen (homedir
) + 1);
4372 XSTRING (dir
)->data
[0] = '~';
4375 if (insert_default_directory
)
4378 if (!NILP (initial
))
4380 Lisp_Object args
[2], pos
;
4384 insdef
= Fconcat (2, args
);
4385 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
4386 insdef1
= Fcons (double_dollars (insdef
), pos
);
4389 insdef1
= double_dollars (insdef
);
4391 else if (!NILP (initial
))
4394 insdef1
= Fcons (double_dollars (insdef
), 0);
4397 insdef
= Qnil
, insdef1
= Qnil
;
4400 count
= specpdl_ptr
- specpdl
;
4401 specbind (intern ("completion-ignore-case"), Qt
);
4404 GCPRO2 (insdef
, default_filename
);
4405 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
4406 dir
, mustmatch
, insdef1
,
4407 Qfile_name_history
);
4410 unbind_to (count
, Qnil
);
4415 error ("No file name specified");
4416 tem
= Fstring_equal (val
, insdef
);
4417 if (!NILP (tem
) && !NILP (default_filename
))
4418 return default_filename
;
4419 if (XSTRING (val
)->size
== 0 && NILP (insdef
))
4421 if (!NILP (default_filename
))
4422 return default_filename
;
4424 error ("No default file name");
4426 return Fsubstitute_in_file_name (val
);
4429 #if 0 /* Old version */
4430 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
4431 /* Don't confuse make-docfile by having two doc strings for this function.
4432 make-docfile does not pay attention to #if, for good reason! */
4434 (prompt
, dir
, defalt
, mustmatch
, initial
)
4435 Lisp_Object prompt
, dir
, defalt
, mustmatch
, initial
;
4437 Lisp_Object val
, insdef
, tem
;
4438 struct gcpro gcpro1
, gcpro2
;
4439 register char *homedir
;
4443 dir
= current_buffer
->directory
;
4445 defalt
= current_buffer
->filename
;
4447 /* If dir starts with user's homedir, change that to ~. */
4448 homedir
= (char *) egetenv ("HOME");
4451 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
4452 && XSTRING (dir
)->data
[strlen (homedir
)] == '/')
4454 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
4455 XSTRING (dir
)->size
- strlen (homedir
) + 1);
4456 XSTRING (dir
)->data
[0] = '~';
4459 if (!NILP (initial
))
4461 else if (insert_default_directory
)
4464 insdef
= build_string ("");
4467 count
= specpdl_ptr
- specpdl
;
4468 specbind (intern ("completion-ignore-case"), Qt
);
4471 GCPRO2 (insdef
, defalt
);
4472 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
4474 insert_default_directory
? insdef
: Qnil
,
4475 Qfile_name_history
);
4478 unbind_to (count
, Qnil
);
4483 error ("No file name specified");
4484 tem
= Fstring_equal (val
, insdef
);
4485 if (!NILP (tem
) && !NILP (defalt
))
4487 return Fsubstitute_in_file_name (val
);
4489 #endif /* Old version */
4493 Qexpand_file_name
= intern ("expand-file-name");
4494 Qsubstitute_in_file_name
= intern ("substitute-in-file-name");
4495 Qdirectory_file_name
= intern ("directory-file-name");
4496 Qfile_name_directory
= intern ("file-name-directory");
4497 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
4498 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
4499 Qfile_name_as_directory
= intern ("file-name-as-directory");
4500 Qcopy_file
= intern ("copy-file");
4501 Qmake_directory_internal
= intern ("make-directory-internal");
4502 Qdelete_directory
= intern ("delete-directory");
4503 Qdelete_file
= intern ("delete-file");
4504 Qrename_file
= intern ("rename-file");
4505 Qadd_name_to_file
= intern ("add-name-to-file");
4506 Qmake_symbolic_link
= intern ("make-symbolic-link");
4507 Qfile_exists_p
= intern ("file-exists-p");
4508 Qfile_executable_p
= intern ("file-executable-p");
4509 Qfile_readable_p
= intern ("file-readable-p");
4510 Qfile_symlink_p
= intern ("file-symlink-p");
4511 Qfile_writable_p
= intern ("file-writable-p");
4512 Qfile_directory_p
= intern ("file-directory-p");
4513 Qfile_regular_p
= intern ("file-regular-p");
4514 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
4515 Qfile_modes
= intern ("file-modes");
4516 Qset_file_modes
= intern ("set-file-modes");
4517 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
4518 Qinsert_file_contents
= intern ("insert-file-contents");
4519 Qwrite_region
= intern ("write-region");
4520 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
4521 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
4523 staticpro (&Qexpand_file_name
);
4524 staticpro (&Qsubstitute_in_file_name
);
4525 staticpro (&Qdirectory_file_name
);
4526 staticpro (&Qfile_name_directory
);
4527 staticpro (&Qfile_name_nondirectory
);
4528 staticpro (&Qunhandled_file_name_directory
);
4529 staticpro (&Qfile_name_as_directory
);
4530 staticpro (&Qcopy_file
);
4531 staticpro (&Qmake_directory_internal
);
4532 staticpro (&Qdelete_directory
);
4533 staticpro (&Qdelete_file
);
4534 staticpro (&Qrename_file
);
4535 staticpro (&Qadd_name_to_file
);
4536 staticpro (&Qmake_symbolic_link
);
4537 staticpro (&Qfile_exists_p
);
4538 staticpro (&Qfile_executable_p
);
4539 staticpro (&Qfile_readable_p
);
4540 staticpro (&Qfile_symlink_p
);
4541 staticpro (&Qfile_writable_p
);
4542 staticpro (&Qfile_directory_p
);
4543 staticpro (&Qfile_regular_p
);
4544 staticpro (&Qfile_accessible_directory_p
);
4545 staticpro (&Qfile_modes
);
4546 staticpro (&Qset_file_modes
);
4547 staticpro (&Qfile_newer_than_file_p
);
4548 staticpro (&Qinsert_file_contents
);
4549 staticpro (&Qwrite_region
);
4550 staticpro (&Qverify_visited_file_modtime
);
4552 Qfile_name_history
= intern ("file-name-history");
4553 Fset (Qfile_name_history
, Qnil
);
4554 staticpro (&Qfile_name_history
);
4556 Qfile_error
= intern ("file-error");
4557 staticpro (&Qfile_error
);
4558 Qfile_already_exists
= intern ("file-already-exists");
4559 staticpro (&Qfile_already_exists
);
4562 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
4563 staticpro (&Qfind_buffer_file_type
);
4566 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format
,
4567 "*Format in which to write auto-save files.\n\
4568 Should be a list of symbols naming formats that are defined in `format-alist'.\n\
4569 If it is t, which is the default, auto-save files are written in the\n\
4570 same format as a regular save would use.");
4571 Vauto_save_file_format
= Qt
;
4573 Qformat_decode
= intern ("format-decode");
4574 staticpro (&Qformat_decode
);
4575 Qformat_annotate_function
= intern ("format-annotate-function");
4576 staticpro (&Qformat_annotate_function
);
4578 Qcar_less_than_car
= intern ("car-less-than-car");
4579 staticpro (&Qcar_less_than_car
);
4581 Fput (Qfile_error
, Qerror_conditions
,
4582 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
4583 Fput (Qfile_error
, Qerror_message
,
4584 build_string ("File error"));
4586 Fput (Qfile_already_exists
, Qerror_conditions
,
4587 Fcons (Qfile_already_exists
,
4588 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
4589 Fput (Qfile_already_exists
, Qerror_message
,
4590 build_string ("File already exists"));
4592 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
4593 "*Non-nil means when reading a filename start with default dir in minibuffer.");
4594 insert_default_directory
= 1;
4596 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
4597 "*Non-nil means write new files with record format `stmlf'.\n\
4598 nil means use format `var'. This variable is meaningful only on VMS.");
4599 vms_stmlf_recfm
= 0;
4601 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char
,
4602 "Directory separator character for built-in functions that return file names.\n\
4603 The value should be either ?/ or ?\\ (any other value is treated as ?\\).\n\
4604 This variable affects the built-in functions only on Windows,\n\
4605 on other platforms, it is initialized so that Lisp code can find out\n\
4606 what the normal separator is.");
4607 Vdirectory_sep_char
= '/';
4609 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
4610 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
4611 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
4614 The first argument given to HANDLER is the name of the I/O primitive\n\
4615 to be handled; the remaining arguments are the arguments that were\n\
4616 passed to that primitive. For example, if you do\n\
4617 (file-exists-p FILENAME)\n\
4618 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
4619 (funcall HANDLER 'file-exists-p FILENAME)\n\
4620 The function `find-file-name-handler' checks this list for a handler\n\
4621 for its argument.");
4622 Vfile_name_handler_alist
= Qnil
;
4624 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
4625 "A list of functions to be called at the end of `insert-file-contents'.\n\
4626 Each is passed one argument, the number of bytes inserted. It should return\n\
4627 the new byte count, and leave point the same. If `insert-file-contents' is\n\
4628 intercepted by a handler from `file-name-handler-alist', that handler is\n\
4629 responsible for calling the after-insert-file-functions if appropriate.");
4630 Vafter_insert_file_functions
= Qnil
;
4632 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
4633 "A list of functions to be called at the start of `write-region'.\n\
4634 Each is passed two arguments, START and END as for `write-region'.\n\
4635 These are usually two numbers but not always; see the documentation\n\
4636 for `write-region'. The function should return a list of pairs\n\
4637 of the form (POSITION . STRING), consisting of strings to be effectively\n\
4638 inserted at the specified positions of the file being written (1 means to\n\
4639 insert before the first byte written). The POSITIONs must be sorted into\n\
4640 increasing order. If there are several functions in the list, the several\n\
4641 lists are merged destructively.");
4642 Vwrite_region_annotate_functions
= Qnil
;
4644 DEFVAR_LISP ("write-region-annotations-so-far",
4645 &Vwrite_region_annotations_so_far
,
4646 "When an annotation function is called, this holds the previous annotations.\n\
4647 These are the annotations made by other annotation functions\n\
4648 that were already called. See also `write-region-annotate-functions'.");
4649 Vwrite_region_annotations_so_far
= Qnil
;
4651 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
4652 "A list of file name handlers that temporarily should not be used.\n\
4653 This applies only to the operation `inhibit-file-name-operation'.");
4654 Vinhibit_file_name_handlers
= Qnil
;
4656 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
4657 "The operation for which `inhibit-file-name-handlers' is applicable.");
4658 Vinhibit_file_name_operation
= Qnil
;
4660 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
4661 "File name in which we write a list of all auto save file names.\n\
4662 This variable is initialized automatically from `auto-save-list-file-prefix'\n\
4663 shortly after Emacs reads your `.emacs' file, if you have not yet given it\n\
4665 Vauto_save_list_file_name
= Qnil
;
4667 defsubr (&Sfind_file_name_handler
);
4668 defsubr (&Sfile_name_directory
);
4669 defsubr (&Sfile_name_nondirectory
);
4670 defsubr (&Sunhandled_file_name_directory
);
4671 defsubr (&Sfile_name_as_directory
);
4672 defsubr (&Sdirectory_file_name
);
4673 defsubr (&Smake_temp_name
);
4674 defsubr (&Sexpand_file_name
);
4675 defsubr (&Ssubstitute_in_file_name
);
4676 defsubr (&Scopy_file
);
4677 defsubr (&Smake_directory_internal
);
4678 defsubr (&Sdelete_directory
);
4679 defsubr (&Sdelete_file
);
4680 defsubr (&Srename_file
);
4681 defsubr (&Sadd_name_to_file
);
4683 defsubr (&Smake_symbolic_link
);
4684 #endif /* S_IFLNK */
4686 defsubr (&Sdefine_logical_name
);
4689 defsubr (&Ssysnetunam
);
4690 #endif /* HPUX_NET */
4691 defsubr (&Sfile_name_absolute_p
);
4692 defsubr (&Sfile_exists_p
);
4693 defsubr (&Sfile_executable_p
);
4694 defsubr (&Sfile_readable_p
);
4695 defsubr (&Sfile_writable_p
);
4696 defsubr (&Sfile_symlink_p
);
4697 defsubr (&Sfile_directory_p
);
4698 defsubr (&Sfile_accessible_directory_p
);
4699 defsubr (&Sfile_regular_p
);
4700 defsubr (&Sfile_modes
);
4701 defsubr (&Sset_file_modes
);
4702 defsubr (&Sset_default_file_modes
);
4703 defsubr (&Sdefault_file_modes
);
4704 defsubr (&Sfile_newer_than_file_p
);
4705 defsubr (&Sinsert_file_contents
);
4706 defsubr (&Swrite_region
);
4707 defsubr (&Scar_less_than_car
);
4708 defsubr (&Sverify_visited_file_modtime
);
4709 defsubr (&Sclear_visited_file_modtime
);
4710 defsubr (&Svisited_file_modtime
);
4711 defsubr (&Sset_visited_file_modtime
);
4712 defsubr (&Sdo_auto_save
);
4713 defsubr (&Sset_buffer_auto_saved
);
4714 defsubr (&Sclear_buffer_auto_save_failure
);
4715 defsubr (&Srecent_auto_save_p
);
4717 defsubr (&Sread_file_name_internal
);
4718 defsubr (&Sread_file_name
);
4721 defsubr (&Sunix_sync
);