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')
107 #define IS_DRIVE(x) isalpha (x)
137 #define min(a, b) ((a) < (b) ? (a) : (b))
138 #define max(a, b) ((a) > (b) ? (a) : (b))
140 /* Nonzero during writing of auto-save files */
143 /* Set by auto_save_1 to mode of original file so Fwrite_region will create
144 a new file with the same mode as the original */
145 int auto_save_mode_bits
;
147 /* Alist of elements (REGEXP . HANDLER) for file names
148 whose I/O is done with a special handler. */
149 Lisp_Object Vfile_name_handler_alist
;
151 /* Format for auto-save files */
152 Lisp_Object Vauto_save_file_format
;
154 /* Lisp functions for translating file formats */
155 Lisp_Object Qformat_decode
, Qformat_annotate_function
;
157 /* Functions to be called to process text properties in inserted file. */
158 Lisp_Object Vafter_insert_file_functions
;
160 /* Functions to be called to create text property annotations for file. */
161 Lisp_Object Vwrite_region_annotate_functions
;
163 /* During build_annotations, each time an annotation function is called,
164 this holds the annotations made by the previous functions. */
165 Lisp_Object Vwrite_region_annotations_so_far
;
167 /* File name in which we write a list of all our auto save files. */
168 Lisp_Object Vauto_save_list_file_name
;
170 /* Nonzero means, when reading a filename in the minibuffer,
171 start out by inserting the default directory into the minibuffer. */
172 int insert_default_directory
;
174 /* On VMS, nonzero means write new files with record format stmlf.
175 Zero means use var format. */
178 /* On NT, specifies the directory separator character, used (eg.) when
179 expanding file names. This can be bound to / or \. */
180 Lisp_Object Vdirectory_sep_char
;
182 /* These variables describe handlers that have "already" had a chance
183 to handle the current operation.
185 Vinhibit_file_name_handlers is a list of file name handlers.
186 Vinhibit_file_name_operation is the operation being handled.
187 If we try to handle that operation, we ignore those handlers. */
189 static Lisp_Object Vinhibit_file_name_handlers
;
190 static Lisp_Object Vinhibit_file_name_operation
;
192 Lisp_Object Qfile_error
, Qfile_already_exists
;
194 Lisp_Object Qfile_name_history
;
196 Lisp_Object Qcar_less_than_car
;
198 report_file_error (string
, data
)
202 Lisp_Object errstring
;
204 errstring
= build_string (strerror (errno
));
206 /* System error messages are capitalized. Downcase the initial
207 unless it is followed by a slash. */
208 if (XSTRING (errstring
)->data
[1] != '/')
209 XSTRING (errstring
)->data
[0] = DOWNCASE (XSTRING (errstring
)->data
[0]);
212 Fsignal (Qfile_error
,
213 Fcons (build_string (string
), Fcons (errstring
, data
)));
216 close_file_unwind (fd
)
219 close (XFASTINT (fd
));
222 /* Restore point, having saved it as a marker. */
224 restore_point_unwind (location
)
225 Lisp_Object location
;
227 SET_PT (marker_position (location
));
228 Fset_marker (location
, Qnil
, Qnil
);
231 Lisp_Object Qexpand_file_name
;
232 Lisp_Object Qsubstitute_in_file_name
;
233 Lisp_Object Qdirectory_file_name
;
234 Lisp_Object Qfile_name_directory
;
235 Lisp_Object Qfile_name_nondirectory
;
236 Lisp_Object Qunhandled_file_name_directory
;
237 Lisp_Object Qfile_name_as_directory
;
238 Lisp_Object Qcopy_file
;
239 Lisp_Object Qmake_directory_internal
;
240 Lisp_Object Qdelete_directory
;
241 Lisp_Object Qdelete_file
;
242 Lisp_Object Qrename_file
;
243 Lisp_Object Qadd_name_to_file
;
244 Lisp_Object Qmake_symbolic_link
;
245 Lisp_Object Qfile_exists_p
;
246 Lisp_Object Qfile_executable_p
;
247 Lisp_Object Qfile_readable_p
;
248 Lisp_Object Qfile_symlink_p
;
249 Lisp_Object Qfile_writable_p
;
250 Lisp_Object Qfile_directory_p
;
251 Lisp_Object Qfile_regular_p
;
252 Lisp_Object Qfile_accessible_directory_p
;
253 Lisp_Object Qfile_modes
;
254 Lisp_Object Qset_file_modes
;
255 Lisp_Object Qfile_newer_than_file_p
;
256 Lisp_Object Qinsert_file_contents
;
257 Lisp_Object Qwrite_region
;
258 Lisp_Object Qverify_visited_file_modtime
;
259 Lisp_Object Qset_visited_file_modtime
;
261 DEFUN ("find-file-name-handler", Ffind_file_name_handler
, Sfind_file_name_handler
, 2, 2, 0,
262 "Return FILENAME's handler function for OPERATION, if it has one.\n\
263 Otherwise, return nil.\n\
264 A file name is handled if one of the regular expressions in\n\
265 `file-name-handler-alist' matches it.\n\n\
266 If OPERATION equals `inhibit-file-name-operation', then we ignore\n\
267 any handlers that are members of `inhibit-file-name-handlers',\n\
268 but we still do run any other handlers. This lets handlers\n\
269 use the standard functions without calling themselves recursively.")
270 (filename
, operation
)
271 Lisp_Object filename
, operation
;
273 /* This function must not munge the match data. */
274 Lisp_Object chain
, inhibited_handlers
;
276 CHECK_STRING (filename
, 0);
278 if (EQ (operation
, Vinhibit_file_name_operation
))
279 inhibited_handlers
= Vinhibit_file_name_handlers
;
281 inhibited_handlers
= Qnil
;
283 for (chain
= Vfile_name_handler_alist
; CONSP (chain
);
284 chain
= XCONS (chain
)->cdr
)
287 elt
= XCONS (chain
)->car
;
291 string
= XCONS (elt
)->car
;
292 if (STRINGP (string
) && fast_string_match (string
, filename
) >= 0)
294 Lisp_Object handler
, tem
;
296 handler
= XCONS (elt
)->cdr
;
297 tem
= Fmemq (handler
, inhibited_handlers
);
308 DEFUN ("file-name-directory", Ffile_name_directory
, Sfile_name_directory
,
310 "Return the directory component in file name FILENAME.\n\
311 Return nil if FILENAME does not include a directory.\n\
312 Otherwise return a directory spec.\n\
313 Given a Unix syntax file name, returns a string ending in slash;\n\
314 on VMS, perhaps instead a string ending in `:', `]' or `>'.")
316 Lisp_Object filename
;
318 register unsigned char *beg
;
319 register unsigned char *p
;
322 CHECK_STRING (filename
, 0);
324 /* If the file name has special constructs in it,
325 call the corresponding file handler. */
326 handler
= Ffind_file_name_handler (filename
, Qfile_name_directory
);
328 return call2 (handler
, Qfile_name_directory
, filename
);
330 #ifdef FILE_SYSTEM_CASE
331 filename
= FILE_SYSTEM_CASE (filename
);
333 beg
= XSTRING (filename
)->data
;
335 beg
= strcpy (alloca (strlen (beg
) + 1), beg
);
337 p
= beg
+ XSTRING (filename
)->size
;
339 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
341 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
344 /* only recognise drive specifier at beginning */
345 && !(p
[-1] == ':' && p
== beg
+ 2)
352 /* Expansion of "c:" to drive and default directory. */
353 if (p
== beg
+ 2 && beg
[1] == ':')
355 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
356 unsigned char *res
= alloca (MAXPATHLEN
+ 1);
357 if (getdefdir (toupper (*beg
) - 'A' + 1, res
))
359 if (!IS_DIRECTORY_SEP (res
[strlen (res
) - 1]))
362 p
= beg
+ strlen (beg
);
365 CORRECT_DIR_SEPS (beg
);
367 return make_string (beg
, p
- beg
);
370 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory
, Sfile_name_nondirectory
,
372 "Return file name FILENAME sans its directory.\n\
373 For example, in a Unix-syntax file name,\n\
374 this is everything after the last slash,\n\
375 or the entire name if it contains no slash.")
377 Lisp_Object filename
;
379 register unsigned char *beg
, *p
, *end
;
382 CHECK_STRING (filename
, 0);
384 /* If the file name has special constructs in it,
385 call the corresponding file handler. */
386 handler
= Ffind_file_name_handler (filename
, Qfile_name_nondirectory
);
388 return call2 (handler
, Qfile_name_nondirectory
, filename
);
390 beg
= XSTRING (filename
)->data
;
391 end
= p
= beg
+ XSTRING (filename
)->size
;
393 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
395 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
398 /* only recognise drive specifier at beginning */
399 && !(p
[-1] == ':' && p
== beg
+ 2)
403 return make_string (p
, end
- p
);
406 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory
, Sunhandled_file_name_directory
, 1, 1, 0,
407 "Return a directly usable directory name somehow associated with FILENAME.\n\
408 A `directly usable' directory name is one that may be used without the\n\
409 intervention of any file handler.\n\
410 If FILENAME is a directly usable file itself, return\n\
411 (file-name-directory FILENAME).\n\
412 The `call-process' and `start-process' functions use this function to\n\
413 get a current directory to run processes in.")
415 Lisp_Object filename
;
419 /* If the file name has special constructs in it,
420 call the corresponding file handler. */
421 handler
= Ffind_file_name_handler (filename
, Qunhandled_file_name_directory
);
423 return call2 (handler
, Qunhandled_file_name_directory
, filename
);
425 return Ffile_name_directory (filename
);
430 file_name_as_directory (out
, in
)
433 int size
= strlen (in
) - 1;
438 /* Is it already a directory string? */
439 if (in
[size
] == ':' || in
[size
] == ']' || in
[size
] == '>')
441 /* Is it a VMS directory file name? If so, hack VMS syntax. */
442 else if (! index (in
, '/')
443 && ((size
> 3 && ! strcmp (&in
[size
- 3], ".DIR"))
444 || (size
> 3 && ! strcmp (&in
[size
- 3], ".dir"))
445 || (size
> 5 && (! strncmp (&in
[size
- 5], ".DIR", 4)
446 || ! strncmp (&in
[size
- 5], ".dir", 4))
447 && (in
[size
- 1] == '.' || in
[size
- 1] == ';')
448 && in
[size
] == '1')))
450 register char *p
, *dot
;
454 dir:x.dir --> dir:[x]
455 dir:[x]y.dir --> dir:[x.y] */
457 while (p
!= in
&& *p
!= ':' && *p
!= '>' && *p
!= ']') p
--;
460 strncpy (out
, in
, p
- in
);
479 dot
= index (p
, '.');
482 /* blindly remove any extension */
483 size
= strlen (out
) + (dot
- p
);
484 strncat (out
, p
, dot
- p
);
495 /* For Unix syntax, Append a slash if necessary */
496 if (!IS_DIRECTORY_SEP (out
[size
]))
498 out
[size
+ 1] = DIRECTORY_SEP
;
499 out
[size
+ 2] = '\0';
502 CORRECT_DIR_SEPS (out
);
508 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
509 Sfile_name_as_directory
, 1, 1, 0,
510 "Return a string representing file FILENAME interpreted as a directory.\n\
511 This operation exists because a directory is also a file, but its name as\n\
512 a directory is different from its name as a file.\n\
513 The result can be used as the value of `default-directory'\n\
514 or passed as second argument to `expand-file-name'.\n\
515 For a Unix-syntax file name, just appends a slash.\n\
516 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
523 CHECK_STRING (file
, 0);
527 /* If the file name has special constructs in it,
528 call the corresponding file handler. */
529 handler
= Ffind_file_name_handler (file
, Qfile_name_as_directory
);
531 return call2 (handler
, Qfile_name_as_directory
, file
);
533 buf
= (char *) alloca (XSTRING (file
)->size
+ 10);
534 return build_string (file_name_as_directory (buf
, XSTRING (file
)->data
));
538 * Convert from directory name to filename.
540 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
541 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
542 * On UNIX, it's simple: just make sure there isn't a terminating /
544 * Value is nonzero if the string output is different from the input.
547 directory_file_name (src
, dst
)
555 struct FAB fab
= cc$rms_fab
;
556 struct NAM nam
= cc$rms_nam
;
557 char esa
[NAM$C_MAXRSS
];
562 if (! index (src
, '/')
563 && (src
[slen
- 1] == ']'
564 || src
[slen
- 1] == ':'
565 || src
[slen
- 1] == '>'))
567 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
569 fab
.fab$b_fns
= slen
;
570 fab
.fab$l_nam
= &nam
;
571 fab
.fab$l_fop
= FAB$M_NAM
;
574 nam
.nam$b_ess
= sizeof esa
;
575 nam
.nam$b_nop
|= NAM$M_SYNCHK
;
577 /* We call SYS$PARSE to handle such things as [--] for us. */
578 if (SYS$
PARSE (&fab
, 0, 0) == RMS$_NORMAL
)
580 slen
= nam
.nam$b_esl
;
581 if (esa
[slen
- 1] == ';' && esa
[slen
- 2] == '.')
586 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
588 /* what about when we have logical_name:???? */
589 if (src
[slen
- 1] == ':')
590 { /* Xlate logical name and see what we get */
591 ptr
= strcpy (dst
, src
); /* upper case for getenv */
594 if ('a' <= *ptr
&& *ptr
<= 'z')
598 dst
[slen
- 1] = 0; /* remove colon */
599 if (!(src
= egetenv (dst
)))
601 /* should we jump to the beginning of this procedure?
602 Good points: allows us to use logical names that xlate
604 Bad points: can be a problem if we just translated to a device
606 For now, I'll punt and always expect VMS names, and hope for
609 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
610 { /* no recursion here! */
616 { /* not a directory spec */
621 bracket
= src
[slen
- 1];
623 /* If bracket is ']' or '>', bracket - 2 is the corresponding
625 ptr
= index (src
, bracket
- 2);
627 { /* no opening bracket */
631 if (!(rptr
= rindex (src
, '.')))
634 strncpy (dst
, src
, slen
);
638 dst
[slen
++] = bracket
;
643 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
644 then translate the device and recurse. */
645 if (dst
[slen
- 1] == ':'
646 && dst
[slen
- 2] != ':' /* skip decnet nodes */
647 && strcmp (src
+ slen
, "[000000]") == 0)
649 dst
[slen
- 1] = '\0';
650 if ((ptr
= egetenv (dst
))
651 && (rlen
= strlen (ptr
) - 1) > 0
652 && (ptr
[rlen
] == ']' || ptr
[rlen
] == '>')
653 && ptr
[rlen
- 1] == '.')
655 char * buf
= (char *) alloca (strlen (ptr
) + 1);
659 return directory_file_name (buf
, dst
);
664 strcat (dst
, "[000000]");
668 rlen
= strlen (rptr
) - 1;
669 strncat (dst
, rptr
, rlen
);
670 dst
[slen
+ rlen
] = '\0';
671 strcat (dst
, ".DIR.1");
675 /* Process as Unix format: just remove any final slash.
676 But leave "/" unchanged; do not change it to "". */
679 /* Handle // as root for apollo's. */
680 if ((slen
> 2 && dst
[slen
- 1] == '/')
681 || (slen
> 1 && dst
[0] != '/' && dst
[slen
- 1] == '/'))
685 && IS_DIRECTORY_SEP (dst
[slen
- 1])
687 && !IS_ANY_SEP (dst
[slen
- 2])
693 CORRECT_DIR_SEPS (dst
);
698 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
700 "Returns the file name of the directory named DIRECTORY.\n\
701 This is the name of the file that holds the data for the directory DIRECTORY.\n\
702 This operation exists because a directory is also a file, but its name as\n\
703 a directory is different from its name as a file.\n\
704 In Unix-syntax, this function just removes the final slash.\n\
705 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
706 it returns a file name such as \"[X]Y.DIR.1\".")
708 Lisp_Object directory
;
713 CHECK_STRING (directory
, 0);
715 if (NILP (directory
))
718 /* If the file name has special constructs in it,
719 call the corresponding file handler. */
720 handler
= Ffind_file_name_handler (directory
, Qdirectory_file_name
);
722 return call2 (handler
, Qdirectory_file_name
, directory
);
725 /* 20 extra chars is insufficient for VMS, since we might perform a
726 logical name translation. an equivalence string can be up to 255
727 chars long, so grab that much extra space... - sss */
728 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20 + 255);
730 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20);
732 directory_file_name (XSTRING (directory
)->data
, buf
);
733 return build_string (buf
);
736 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
737 "Generate temporary file name (string) starting with PREFIX (a string).\n\
738 The Emacs process number forms part of the result,\n\
739 so there is no danger of generating a name being used by another process.")
745 /* Don't use too many characters of the restricted 8+3 DOS
747 val
= concat2 (prefix
, build_string ("a.XXX"));
749 val
= concat2 (prefix
, build_string ("XXXXXX"));
751 mktemp (XSTRING (val
)->data
);
753 CORRECT_DIR_SEPS (XSTRING (val
)->data
);
758 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
759 "Convert filename NAME to absolute, and canonicalize it.\n\
760 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative\n\
761 (does not start with slash); if DEFAULT-DIRECTORY is nil or missing,\n\
762 the current buffer's value of default-directory is used.\n\
763 File name components that are `.' are removed, and \n\
764 so are file name components followed by `..', along with the `..' itself;\n\
765 note that these simplifications are done without checking the resulting\n\
766 file names in the file system.\n\
767 An initial `~/' expands to your home directory.\n\
768 An initial `~USER/' expands to USER's home directory.\n\
769 See also the function `substitute-in-file-name'.")
770 (name
, default_directory
)
771 Lisp_Object name
, default_directory
;
775 register unsigned char *newdir
, *p
, *o
;
777 unsigned char *target
;
780 unsigned char * colon
= 0;
781 unsigned char * close
= 0;
782 unsigned char * slash
= 0;
783 unsigned char * brack
= 0;
784 int lbrack
= 0, rbrack
= 0;
793 CHECK_STRING (name
, 0);
795 /* If the file name has special constructs in it,
796 call the corresponding file handler. */
797 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
799 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
801 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
802 if (NILP (default_directory
))
803 default_directory
= current_buffer
->directory
;
804 CHECK_STRING (default_directory
, 1);
806 if (!NILP (default_directory
))
808 handler
= Ffind_file_name_handler (default_directory
, Qexpand_file_name
);
810 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
813 o
= XSTRING (default_directory
)->data
;
815 /* Make sure DEFAULT_DIRECTORY is properly expanded.
816 It would be better to do this down below where we actually use
817 default_directory. Unfortunately, calling Fexpand_file_name recursively
818 could invoke GC, and the strings might be relocated. This would
819 be annoying because we have pointers into strings lying around
820 that would need adjusting, and people would add new pointers to
821 the code and forget to adjust them, resulting in intermittent bugs.
822 Putting this call here avoids all that crud.
824 The EQ test avoids infinite recursion. */
825 if (! NILP (default_directory
) && !EQ (default_directory
, name
)
826 /* Save time in some common cases - as long as default_directory
827 is not relative, it can be canonicalized with name below (if it
828 is needed at all) without requiring it to be expanded now. */
830 /* Detect MSDOS file names with drive specifiers. */
831 && ! (IS_DRIVE (o
[0]) && (IS_DEVICE_SEP (o
[1]) && IS_DIRECTORY_SEP (o
[2])))
833 /* Detect Windows file names in UNC format. */
834 && ! (IS_DIRECTORY_SEP (o
[0]) && IS_DIRECTORY_SEP (o
[1]))
836 #else /* not DOS_NT */
837 /* Detect Unix absolute file names (/... alone is not absolute on
839 && ! (IS_DIRECTORY_SEP (o
[0]))
840 #endif /* not DOS_NT */
846 default_directory
= Fexpand_file_name (default_directory
, Qnil
);
851 /* Filenames on VMS are always upper case. */
852 name
= Fupcase (name
);
854 #ifdef FILE_SYSTEM_CASE
855 name
= FILE_SYSTEM_CASE (name
);
858 nm
= XSTRING (name
)->data
;
861 /* We will force directory separators to be either all \ or /, so make
862 a local copy to modify, even if there ends up being no change. */
863 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
865 /* Find and remove drive specifier if present; this makes nm absolute
866 even if the rest of the name appears to be relative. */
868 unsigned char *colon
= rindex (nm
, ':');
871 /* Only recognize colon as part of drive specifier if there is a
872 single alphabetic character preceeding the colon (and if the
873 character before the drive letter, if present, is a directory
874 separator); this is to support the remote system syntax used by
875 ange-ftp, and the "po:username" syntax for POP mailboxes. */
879 else if (IS_DRIVE (colon
[-1])
880 && (colon
== nm
+ 1 || IS_DIRECTORY_SEP (colon
[-2])))
887 while (--colon
>= nm
)
894 /* Handle // and /~ in middle of file name
895 by discarding everything through the first / of that sequence. */
899 /* Since we are expecting the name to be absolute, we can assume
900 that each element starts with a "/". */
902 if (IS_DIRECTORY_SEP (p
[0]) && IS_DIRECTORY_SEP (p
[1])
903 #if defined (APOLLO) || defined (WINDOWSNT)
904 /* // at start of filename is meaningful on Apollo
905 and WindowsNT systems */
907 #endif /* APOLLO || WINDOWSNT */
911 if (IS_DIRECTORY_SEP (p
[0]) && p
[1] == '~')
918 /* Discard any previous drive specifier if nm is now in UNC format. */
919 if (IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
925 /* If nm is absolute, look for /./ or /../ sequences; if none are
926 found, we can probably return right away. We will avoid allocating
927 a new string if name is already fully expanded. */
929 IS_DIRECTORY_SEP (nm
[0])
934 && (drive
|| IS_DIRECTORY_SEP (nm
[1]))
941 /* If it turns out that the filename we want to return is just a
942 suffix of FILENAME, we don't need to go through and edit
943 things; we just need to construct a new string using data
944 starting at the middle of FILENAME. If we set lose to a
945 non-zero value, that means we've discovered that we can't do
952 /* Since we know the name is absolute, we can assume that each
953 element starts with a "/". */
955 /* "." and ".." are hairy. */
956 if (IS_DIRECTORY_SEP (p
[0])
958 && (IS_DIRECTORY_SEP (p
[2])
960 || (p
[2] == '.' && (IS_DIRECTORY_SEP (p
[3])
967 /* if dev:[dir]/, move nm to / */
968 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
969 nm
= (brack
? brack
+ 1 : colon
+ 1);
978 /* VMS pre V4.4,convert '-'s in filenames. */
979 if (lbrack
== rbrack
)
981 if (dots
< 2) /* this is to allow negative version numbers */
986 if (lbrack
> rbrack
&&
987 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
988 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
994 /* count open brackets, reset close bracket pointer */
995 if (p
[0] == '[' || p
[0] == '<')
997 /* count close brackets, set close bracket pointer */
998 if (p
[0] == ']' || p
[0] == '>')
1000 /* detect ][ or >< */
1001 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1003 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1004 nm
= p
+ 1, lose
= 1;
1005 if (p
[0] == ':' && (colon
|| slash
))
1006 /* if dev1:[dir]dev2:, move nm to dev2: */
1012 /* if /name/dev:, move nm to dev: */
1015 /* if node::dev:, move colon following dev */
1016 else if (colon
&& colon
[-1] == ':')
1018 /* if dev1:dev2:, move nm to dev2: */
1019 else if (colon
&& colon
[-1] != ':')
1024 if (p
[0] == ':' && !colon
)
1030 if (lbrack
== rbrack
)
1033 else if (p
[0] == '.')
1041 if (index (nm
, '/'))
1042 return build_string (sys_translate_unix (nm
));
1045 /* Make sure directories are all separated with / or \ as
1046 desired, but avoid allocation of a new string when not
1048 CORRECT_DIR_SEPS (nm
);
1050 if (IS_DIRECTORY_SEP (nm
[1]))
1052 if (strcmp (nm
, XSTRING (name
)->data
) != 0)
1053 name
= build_string (nm
);
1057 /* drive must be set, so this is okay */
1058 if (strcmp (nm
- 2, XSTRING (name
)->data
) != 0)
1060 name
= make_string (nm
- 2, p
- nm
+ 2);
1061 XSTRING (name
)->data
[0] = drive
;
1062 XSTRING (name
)->data
[1] = ':';
1065 #else /* not DOS_NT */
1066 if (nm
== XSTRING (name
)->data
)
1068 return build_string (nm
);
1069 #endif /* not DOS_NT */
1073 /* At this point, nm might or might not be an absolute file name. We
1074 need to expand ~ or ~user if present, otherwise prefix nm with
1075 default_directory if nm is not absolute, and finally collapse /./
1076 and /foo/../ sequences.
1078 We set newdir to be the appropriate prefix if one is needed:
1079 - the relevant user directory if nm starts with ~ or ~user
1080 - the specified drive's working dir (DOS/NT only) if nm does not
1082 - the value of default_directory.
1084 Note that these prefixes are not guaranteed to be absolute (except
1085 for the working dir of a drive). Therefore, to ensure we always
1086 return an absolute name, if the final prefix is not absolute we
1087 append it to the current working directory. */
1091 if (nm
[0] == '~') /* prefix ~ */
1093 if (IS_DIRECTORY_SEP (nm
[1])
1097 || nm
[1] == 0) /* ~ by itself */
1099 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1100 newdir
= (unsigned char *) "";
1103 if (IS_DIRECTORY_SEP (nm
[0]))
1104 /* Make nm look like a relative file name. */
1108 nm
++; /* Don't leave the slash in nm. */
1111 else /* ~user/filename */
1113 for (p
= nm
; *p
&& (!IS_DIRECTORY_SEP (*p
)
1118 o
= (unsigned char *) alloca (p
- nm
+ 1);
1119 bcopy ((char *) nm
, o
, p
- nm
);
1122 pw
= (struct passwd
*) getpwnam (o
+ 1);
1125 newdir
= (unsigned char *) pw
-> pw_dir
;
1127 nm
= p
+ 1; /* skip the terminator */
1131 if (IS_DIRECTORY_SEP (nm
[0]))
1132 /* Make nm look like a relative name. */
1138 /* If we don't find a user of that name, leave the name
1139 unchanged; don't move nm forward to p. */
1144 /* On DOS and Windows, nm is absolute if a drive name was specified;
1145 use the drive's current directory as the prefix if needed. */
1146 if (!newdir
&& drive
)
1148 /* Get default directory if needed to make nm absolute. */
1149 if (!IS_DIRECTORY_SEP (nm
[0]))
1151 newdir
= alloca (MAXPATHLEN
+ 1);
1152 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1157 /* Either nm starts with /, or drive isn't mounted. */
1158 newdir
= alloca (4);
1167 /* Finally, if no prefix has been specified and nm is not absolute,
1168 then it must be expanded relative to default_directory. */
1172 /* /... alone is not absolute on DOS and Windows. */
1173 !IS_DIRECTORY_SEP (nm
[0])
1176 !(IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1183 newdir
= XSTRING (default_directory
)->data
;
1189 /* First ensure newdir is an absolute name. */
1191 /* Detect MSDOS file names with drive specifiers. */
1192 ! (IS_DRIVE (newdir
[0])
1193 && IS_DEVICE_SEP (newdir
[1]) && IS_DIRECTORY_SEP (newdir
[2]))
1195 /* Detect Windows file names in UNC format. */
1196 && ! (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1200 /* Effectively, let newdir be (expand-file-name newdir cwd).
1201 Because of the admonition against calling expand-file-name
1202 when we have pointers into lisp strings, we accomplish this
1203 indirectly by prepending newdir to nm if necessary, and using
1204 cwd (or the wd of newdir's drive) as the new newdir. */
1206 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1211 if (!IS_DIRECTORY_SEP (nm
[0]))
1213 char * tmp
= alloca (strlen (newdir
) + strlen (nm
) + 2);
1214 file_name_as_directory (tmp
, newdir
);
1218 newdir
= alloca (MAXPATHLEN
+ 1);
1221 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1228 /* Strip off drive name from prefix, if present. */
1229 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1235 /* Keep only a prefix from newdir if nm starts with slash
1236 (//server/share for UNC, nothing otherwise). */
1237 if (IS_DIRECTORY_SEP (nm
[0]))
1240 if (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1242 newdir
= strcpy (alloca (strlen (newdir
) + 1), newdir
);
1244 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1246 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1258 /* Get rid of any slash at the end of newdir. */
1259 length
= strlen (newdir
);
1260 if (IS_DIRECTORY_SEP (newdir
[length
- 1]))
1262 unsigned char *temp
= (unsigned char *) alloca (length
);
1263 bcopy (newdir
, temp
, length
- 1);
1264 temp
[length
- 1] = 0;
1272 /* Now concatenate the directory and name to new space in the stack frame */
1273 tlen
+= strlen (nm
) + 1;
1275 /* Add reserved space for drive name. (The Microsoft x86 compiler
1276 produces incorrect code if the following two lines are combined.) */
1277 target
= (unsigned char *) alloca (tlen
+ 2);
1279 #else /* not DOS_NT */
1280 target
= (unsigned char *) alloca (tlen
);
1281 #endif /* not DOS_NT */
1287 if (nm
[0] == 0 || IS_DIRECTORY_SEP (nm
[0]))
1288 strcpy (target
, newdir
);
1291 file_name_as_directory (target
, newdir
);
1294 strcat (target
, nm
);
1296 if (index (target
, '/'))
1297 strcpy (target
, sys_translate_unix (target
));
1300 /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */
1302 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1310 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1316 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1317 /* brackets are offset from each other by 2 */
1320 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1321 /* convert [foo][bar] to [bar] */
1322 while (o
[-1] != '[' && o
[-1] != '<')
1324 else if (*p
== '-' && *o
!= '.')
1327 else if (p
[0] == '-' && o
[-1] == '.' &&
1328 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1329 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1333 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1334 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1336 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1338 /* else [foo.-] ==> [-] */
1344 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1345 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1351 if (!IS_DIRECTORY_SEP (*p
))
1355 else if (IS_DIRECTORY_SEP (p
[0]) && IS_DIRECTORY_SEP (p
[1])
1356 #if defined (APOLLO) || defined (WINDOWSNT)
1357 /* // at start of filename is meaningful in Apollo
1358 and WindowsNT systems */
1360 #endif /* APOLLO || WINDOWSNT */
1366 else if (IS_DIRECTORY_SEP (p
[0])
1368 && (IS_DIRECTORY_SEP (p
[2])
1371 /* If "/." is the entire filename, keep the "/". Otherwise,
1372 just delete the whole "/.". */
1373 if (o
== target
&& p
[2] == '\0')
1377 else if (IS_DIRECTORY_SEP (p
[0]) && p
[1] == '.' && p
[2] == '.'
1378 /* `/../' is the "superroot" on certain file systems. */
1380 && (IS_DIRECTORY_SEP (p
[3]) || p
[3] == 0))
1382 while (o
!= target
&& (--o
) && !IS_DIRECTORY_SEP (*o
))
1390 #endif /* not VMS */
1394 /* At last, set drive name. */
1396 /* Except for network file name. */
1397 if (!(IS_DIRECTORY_SEP (target
[0]) && IS_DIRECTORY_SEP (target
[1])))
1398 #endif /* WINDOWSNT */
1400 if (!drive
) abort ();
1405 CORRECT_DIR_SEPS (target
);
1408 return make_string (target
, o
- target
);
1412 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'. */
1413 DEAFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
1414 "Convert FILENAME to absolute, and canonicalize it.\n\
1415 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1416 (does not start with slash); if DEFAULT is nil or missing,\n\
1417 the current buffer's value of default-directory is used.\n\
1418 Filenames containing `.' or `..' as components are simplified;\n\
1419 initial `~/' expands to your home directory.\n\
1420 See also the function `substitute-in-file-name'.")
1422 Lisp_Object name
, defalt
;
1426 register unsigned char *newdir
, *p
, *o
;
1428 unsigned char *target
;
1432 unsigned char * colon
= 0;
1433 unsigned char * close
= 0;
1434 unsigned char * slash
= 0;
1435 unsigned char * brack
= 0;
1436 int lbrack
= 0, rbrack
= 0;
1440 CHECK_STRING (name
, 0);
1443 /* Filenames on VMS are always upper case. */
1444 name
= Fupcase (name
);
1447 nm
= XSTRING (name
)->data
;
1449 /* If nm is absolute, flush ...// and detect /./ and /../.
1450 If no /./ or /../ we can return right away. */
1462 if (p
[0] == '/' && p
[1] == '/'
1464 /* // at start of filename is meaningful on Apollo system */
1469 if (p
[0] == '/' && p
[1] == '~')
1470 nm
= p
+ 1, lose
= 1;
1471 if (p
[0] == '/' && p
[1] == '.'
1472 && (p
[2] == '/' || p
[2] == 0
1473 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1479 /* if dev:[dir]/, move nm to / */
1480 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1481 nm
= (brack
? brack
+ 1 : colon
+ 1);
1482 lbrack
= rbrack
= 0;
1490 /* VMS pre V4.4,convert '-'s in filenames. */
1491 if (lbrack
== rbrack
)
1493 if (dots
< 2) /* this is to allow negative version numbers */
1498 if (lbrack
> rbrack
&&
1499 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1500 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1506 /* count open brackets, reset close bracket pointer */
1507 if (p
[0] == '[' || p
[0] == '<')
1508 lbrack
++, brack
= 0;
1509 /* count close brackets, set close bracket pointer */
1510 if (p
[0] == ']' || p
[0] == '>')
1511 rbrack
++, brack
= p
;
1512 /* detect ][ or >< */
1513 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1515 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1516 nm
= p
+ 1, lose
= 1;
1517 if (p
[0] == ':' && (colon
|| slash
))
1518 /* if dev1:[dir]dev2:, move nm to dev2: */
1524 /* If /name/dev:, move nm to dev: */
1527 /* If node::dev:, move colon following dev */
1528 else if (colon
&& colon
[-1] == ':')
1530 /* If dev1:dev2:, move nm to dev2: */
1531 else if (colon
&& colon
[-1] != ':')
1536 if (p
[0] == ':' && !colon
)
1542 if (lbrack
== rbrack
)
1545 else if (p
[0] == '.')
1553 if (index (nm
, '/'))
1554 return build_string (sys_translate_unix (nm
));
1556 if (nm
== XSTRING (name
)->data
)
1558 return build_string (nm
);
1562 /* Now determine directory to start with and put it in NEWDIR */
1566 if (nm
[0] == '~') /* prefix ~ */
1571 || nm
[1] == 0)/* ~/filename */
1573 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1574 newdir
= (unsigned char *) "";
1577 nm
++; /* Don't leave the slash in nm. */
1580 else /* ~user/filename */
1582 /* Get past ~ to user */
1583 unsigned char *user
= nm
+ 1;
1584 /* Find end of name. */
1585 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1586 int len
= ptr
? ptr
- user
: strlen (user
);
1588 unsigned char *ptr1
= index (user
, ':');
1589 if (ptr1
!= 0 && ptr1
- user
< len
)
1592 /* Copy the user name into temp storage. */
1593 o
= (unsigned char *) alloca (len
+ 1);
1594 bcopy ((char *) user
, o
, len
);
1597 /* Look up the user name. */
1598 pw
= (struct passwd
*) getpwnam (o
+ 1);
1600 error ("\"%s\" isn't a registered user", o
+ 1);
1602 newdir
= (unsigned char *) pw
->pw_dir
;
1604 /* Discard the user name from NM. */
1611 #endif /* not VMS */
1615 defalt
= current_buffer
->directory
;
1616 CHECK_STRING (defalt
, 1);
1617 newdir
= XSTRING (defalt
)->data
;
1620 /* Now concatenate the directory and name to new space in the stack frame */
1622 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1623 target
= (unsigned char *) alloca (tlen
);
1629 if (nm
[0] == 0 || nm
[0] == '/')
1630 strcpy (target
, newdir
);
1633 file_name_as_directory (target
, newdir
);
1636 strcat (target
, nm
);
1638 if (index (target
, '/'))
1639 strcpy (target
, sys_translate_unix (target
));
1642 /* Now canonicalize by removing /. and /foo/.. if they appear */
1650 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1656 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1657 /* brackets are offset from each other by 2 */
1660 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1661 /* convert [foo][bar] to [bar] */
1662 while (o
[-1] != '[' && o
[-1] != '<')
1664 else if (*p
== '-' && *o
!= '.')
1667 else if (p
[0] == '-' && o
[-1] == '.' &&
1668 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1669 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1673 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1674 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1676 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1678 /* else [foo.-] ==> [-] */
1684 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1685 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1695 else if (!strncmp (p
, "//", 2)
1697 /* // at start of filename is meaningful in Apollo system */
1705 else if (p
[0] == '/' && p
[1] == '.' &&
1706 (p
[2] == '/' || p
[2] == 0))
1708 else if (!strncmp (p
, "/..", 3)
1709 /* `/../' is the "superroot" on certain file systems. */
1711 && (p
[3] == '/' || p
[3] == 0))
1713 while (o
!= target
&& *--o
!= '/')
1716 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1720 if (o
== target
&& *o
== '/')
1728 #endif /* not VMS */
1731 return make_string (target
, o
- target
);
1735 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1736 Ssubstitute_in_file_name
, 1, 1, 0,
1737 "Substitute environment variables referred to in FILENAME.\n\
1738 `$FOO' where FOO is an environment variable name means to substitute\n\
1739 the value of that variable. The variable name should be terminated\n\
1740 with a character not a letter, digit or underscore; otherwise, enclose\n\
1741 the entire variable name in braces.\n\
1742 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1743 On VMS, `$' substitution is not done; this function does little and only\n\
1744 duplicates what `expand-file-name' does.")
1746 Lisp_Object filename
;
1750 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1751 unsigned char *target
;
1753 int substituted
= 0;
1755 Lisp_Object handler
;
1757 CHECK_STRING (filename
, 0);
1759 /* If the file name has special constructs in it,
1760 call the corresponding file handler. */
1761 handler
= Ffind_file_name_handler (filename
, Qsubstitute_in_file_name
);
1762 if (!NILP (handler
))
1763 return call2 (handler
, Qsubstitute_in_file_name
, filename
);
1765 nm
= XSTRING (filename
)->data
;
1767 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
1768 CORRECT_DIR_SEPS (nm
);
1769 substituted
= (strcmp (nm
, XSTRING (filename
)->data
) != 0);
1771 endp
= nm
+ XSTRING (filename
)->size
;
1773 /* If /~ or // appears, discard everything through first slash. */
1775 for (p
= nm
; p
!= endp
; p
++)
1778 #if defined (APOLLO) || defined (WINDOWSNT)
1779 /* // at start of file name is meaningful in Apollo and
1780 WindowsNT systems */
1781 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != nm
)
1782 #else /* not (APOLLO || WINDOWSNT) */
1783 || IS_DIRECTORY_SEP (p
[0])
1784 #endif /* not (APOLLO || WINDOWSNT) */
1789 || p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>'
1791 || IS_DIRECTORY_SEP (p
[-1])))
1797 /* see comment in expand-file-name about drive specifiers */
1798 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
1799 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
1808 return build_string (nm
);
1811 /* See if any variables are substituted into the string
1812 and find the total length of their values in `total' */
1814 for (p
= nm
; p
!= endp
;)
1824 /* "$$" means a single "$" */
1833 while (p
!= endp
&& *p
!= '}') p
++;
1834 if (*p
!= '}') goto missingclose
;
1840 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1844 /* Copy out the variable name */
1845 target
= (unsigned char *) alloca (s
- o
+ 1);
1846 strncpy (target
, o
, s
- o
);
1849 strupr (target
); /* $home == $HOME etc. */
1852 /* Get variable value */
1853 o
= (unsigned char *) egetenv (target
);
1854 if (!o
) goto badvar
;
1855 total
+= strlen (o
);
1862 /* If substitution required, recopy the string and do it */
1863 /* Make space in stack frame for the new copy */
1864 xnm
= (unsigned char *) alloca (XSTRING (filename
)->size
+ total
+ 1);
1867 /* Copy the rest of the name through, replacing $ constructs with values */
1884 while (p
!= endp
&& *p
!= '}') p
++;
1885 if (*p
!= '}') goto missingclose
;
1891 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1895 /* Copy out the variable name */
1896 target
= (unsigned char *) alloca (s
- o
+ 1);
1897 strncpy (target
, o
, s
- o
);
1900 strupr (target
); /* $home == $HOME etc. */
1903 /* Get variable value */
1904 o
= (unsigned char *) egetenv (target
);
1914 /* If /~ or // appears, discard everything through first slash. */
1916 for (p
= xnm
; p
!= x
; p
++)
1918 #if defined (APOLLO) || defined (WINDOWSNT)
1919 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != xnm
)
1920 #else /* not (APOLLO || WINDOWSNT) */
1921 || IS_DIRECTORY_SEP (p
[0])
1922 #endif /* not (APOLLO || WINDOWSNT) */
1924 && p
!= nm
&& IS_DIRECTORY_SEP (p
[-1]))
1927 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
1928 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
1932 return make_string (xnm
, x
- xnm
);
1935 error ("Bad format environment-variable substitution");
1937 error ("Missing \"}\" in environment-variable substitution");
1939 error ("Substituting nonexistent environment variable \"%s\"", target
);
1942 #endif /* not VMS */
1945 /* A slightly faster and more convenient way to get
1946 (directory-file-name (expand-file-name FOO)). */
1949 expand_and_dir_to_file (filename
, defdir
)
1950 Lisp_Object filename
, defdir
;
1952 register Lisp_Object absname
;
1954 absname
= Fexpand_file_name (filename
, defdir
);
1957 register int c
= XSTRING (absname
)->data
[XSTRING (absname
)->size
- 1];
1958 if (c
== ':' || c
== ']' || c
== '>')
1959 absname
= Fdirectory_file_name (absname
);
1962 /* Remove final slash, if any (unless this is the root dir).
1963 stat behaves differently depending! */
1964 if (XSTRING (absname
)->size
> 1
1965 && IS_DIRECTORY_SEP (XSTRING (absname
)->data
[XSTRING (absname
)->size
- 1])
1966 && !IS_DEVICE_SEP (XSTRING (absname
)->data
[XSTRING (absname
)->size
-2]))
1967 /* We cannot take shortcuts; they might be wrong for magic file names. */
1968 absname
= Fdirectory_file_name (absname
);
1973 /* Signal an error if the file ABSNAME already exists.
1974 If INTERACTIVE is nonzero, ask the user whether to proceed,
1975 and bypass the error if the user says to go ahead.
1976 QUERYSTRING is a name for the action that is being considered
1978 *STATPTR is used to store the stat information if the file exists.
1979 If the file does not exist, STATPTR->st_mode is set to 0. */
1982 barf_or_query_if_file_exists (absname
, querystring
, interactive
, statptr
)
1983 Lisp_Object absname
;
1984 unsigned char *querystring
;
1986 struct stat
*statptr
;
1988 register Lisp_Object tem
;
1989 struct stat statbuf
;
1990 struct gcpro gcpro1
;
1992 /* stat is a good way to tell whether the file exists,
1993 regardless of what access permissions it has. */
1994 if (stat (XSTRING (absname
)->data
, &statbuf
) >= 0)
1997 Fsignal (Qfile_already_exists
,
1998 Fcons (build_string ("File already exists"),
1999 Fcons (absname
, Qnil
)));
2001 tem
= do_yes_or_no_p (format1 ("File %s already exists; %s anyway? ",
2002 XSTRING (absname
)->data
, querystring
));
2005 Fsignal (Qfile_already_exists
,
2006 Fcons (build_string ("File already exists"),
2007 Fcons (absname
, Qnil
)));
2014 statptr
->st_mode
= 0;
2019 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
2020 "fCopy file: \nFCopy %s to file: \np\nP",
2021 "Copy FILE to NEWNAME. Both args must be strings.\n\
2022 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
2023 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
2024 A number as third arg means request confirmation if NEWNAME already exists.\n\
2025 This is what happens in interactive use with M-x.\n\
2026 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
2027 last-modified time as the old one. (This works on only some systems.)\n\
2028 A prefix arg makes KEEP-TIME non-nil.")
2029 (file
, newname
, ok_if_already_exists
, keep_date
)
2030 Lisp_Object file
, newname
, ok_if_already_exists
, keep_date
;
2033 char buf
[16 * 1024];
2034 struct stat st
, out_st
;
2035 Lisp_Object handler
;
2036 struct gcpro gcpro1
, gcpro2
;
2037 int count
= specpdl_ptr
- specpdl
;
2038 int input_file_statable_p
;
2040 GCPRO2 (file
, newname
);
2041 CHECK_STRING (file
, 0);
2042 CHECK_STRING (newname
, 1);
2043 file
= Fexpand_file_name (file
, Qnil
);
2044 newname
= Fexpand_file_name (newname
, Qnil
);
2046 /* If the input file name has special constructs in it,
2047 call the corresponding file handler. */
2048 handler
= Ffind_file_name_handler (file
, Qcopy_file
);
2049 /* Likewise for output file name. */
2051 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
2052 if (!NILP (handler
))
2053 RETURN_UNGCPRO (call5 (handler
, Qcopy_file
, file
, newname
,
2054 ok_if_already_exists
, keep_date
));
2056 if (NILP (ok_if_already_exists
)
2057 || INTEGERP (ok_if_already_exists
))
2058 barf_or_query_if_file_exists (newname
, "copy to it",
2059 INTEGERP (ok_if_already_exists
), &out_st
);
2060 else if (stat (XSTRING (newname
)->data
, &out_st
) < 0)
2063 ifd
= open (XSTRING (file
)->data
, O_RDONLY
);
2065 report_file_error ("Opening input file", Fcons (file
, Qnil
));
2067 record_unwind_protect (close_file_unwind
, make_number (ifd
));
2069 /* We can only copy regular files and symbolic links. Other files are not
2071 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
2074 if (out_st
.st_mode
!= 0
2075 && st
.st_dev
== out_st
.st_dev
&& st
.st_ino
== out_st
.st_ino
)
2078 report_file_error ("Input and output files are the same",
2079 Fcons (file
, Fcons (newname
, Qnil
)));
2083 #if defined (S_ISREG) && defined (S_ISLNK)
2084 if (input_file_statable_p
)
2086 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
2088 #if defined (EISDIR)
2089 /* Get a better looking error message. */
2092 report_file_error ("Non-regular file", Fcons (file
, Qnil
));
2095 #endif /* S_ISREG && S_ISLNK */
2098 /* Create the copy file with the same record format as the input file */
2099 ofd
= sys_creat (XSTRING (newname
)->data
, 0666, ifd
);
2102 /* System's default file type was set to binary by _fmode in emacs.c. */
2103 ofd
= creat (XSTRING (newname
)->data
, S_IREAD
| S_IWRITE
);
2104 #else /* not MSDOS */
2105 ofd
= creat (XSTRING (newname
)->data
, 0666);
2106 #endif /* not MSDOS */
2109 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
2111 record_unwind_protect (close_file_unwind
, make_number (ofd
));
2115 while ((n
= read (ifd
, buf
, sizeof buf
)) > 0)
2116 if (write (ofd
, buf
, n
) != n
)
2117 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2120 /* Closing the output clobbers the file times on some systems. */
2121 if (close (ofd
) < 0)
2122 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2124 if (input_file_statable_p
)
2126 if (!NILP (keep_date
))
2128 EMACS_TIME atime
, mtime
;
2129 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
2130 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
2131 if (set_file_times (XSTRING (newname
)->data
, atime
, mtime
))
2132 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2135 chmod (XSTRING (newname
)->data
, st
.st_mode
& 07777);
2137 #if defined (__DJGPP__) && __DJGPP__ > 1
2138 /* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
2139 and if it can't, it tells so. Otherwise, under MSDOS we usually
2140 get only the READ bit, which will make the copied file read-only,
2141 so it's better not to chmod at all. */
2142 if ((_djstat_flags
& _STFAIL_WRITEBIT
) == 0)
2143 chmod (XSTRING (newname
)->data
, st
.st_mode
& 07777);
2144 #endif /* DJGPP version 2 or newer */
2150 /* Discard the unwind protects. */
2151 specpdl_ptr
= specpdl
+ count
;
2157 DEFUN ("make-directory-internal", Fmake_directory_internal
,
2158 Smake_directory_internal
, 1, 1, 0,
2159 "Create a new directory named DIRECTORY.")
2161 Lisp_Object directory
;
2164 Lisp_Object handler
;
2166 CHECK_STRING (directory
, 0);
2167 directory
= Fexpand_file_name (directory
, Qnil
);
2169 handler
= Ffind_file_name_handler (directory
, Qmake_directory_internal
);
2170 if (!NILP (handler
))
2171 return call2 (handler
, Qmake_directory_internal
, directory
);
2173 dir
= XSTRING (directory
)->data
;
2176 if (mkdir (dir
) != 0)
2178 if (mkdir (dir
, 0777) != 0)
2180 report_file_error ("Creating directory", Flist (1, &directory
));
2185 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
2186 "Delete the directory named DIRECTORY.")
2188 Lisp_Object directory
;
2191 Lisp_Object handler
;
2193 CHECK_STRING (directory
, 0);
2194 directory
= Fdirectory_file_name (Fexpand_file_name (directory
, Qnil
));
2195 dir
= XSTRING (directory
)->data
;
2197 handler
= Ffind_file_name_handler (directory
, Qdelete_directory
);
2198 if (!NILP (handler
))
2199 return call2 (handler
, Qdelete_directory
, directory
);
2201 if (rmdir (dir
) != 0)
2202 report_file_error ("Removing directory", Flist (1, &directory
));
2207 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
2208 "Delete file named FILENAME.\n\
2209 If file has multiple names, it continues to exist with the other names.")
2211 Lisp_Object filename
;
2213 Lisp_Object handler
;
2214 CHECK_STRING (filename
, 0);
2215 filename
= Fexpand_file_name (filename
, Qnil
);
2217 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
2218 if (!NILP (handler
))
2219 return call2 (handler
, Qdelete_file
, filename
);
2221 if (0 > unlink (XSTRING (filename
)->data
))
2222 report_file_error ("Removing old name", Flist (1, &filename
));
2227 internal_delete_file_1 (ignore
)
2233 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */
2236 internal_delete_file (filename
)
2237 Lisp_Object filename
;
2239 return NILP (internal_condition_case_1 (Fdelete_file
, filename
,
2240 Qt
, internal_delete_file_1
));
2243 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
2244 "fRename file: \nFRename %s to file: \np",
2245 "Rename FILE as NEWNAME. Both args strings.\n\
2246 If file has names other than FILE, it continues to have those names.\n\
2247 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2248 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2249 A number as third arg means request confirmation if NEWNAME already exists.\n\
2250 This is what happens in interactive use with M-x.")
2251 (file
, newname
, ok_if_already_exists
)
2252 Lisp_Object file
, newname
, ok_if_already_exists
;
2255 Lisp_Object args
[2];
2257 Lisp_Object handler
;
2258 struct gcpro gcpro1
, gcpro2
;
2260 GCPRO2 (file
, newname
);
2261 CHECK_STRING (file
, 0);
2262 CHECK_STRING (newname
, 1);
2263 file
= Fexpand_file_name (file
, Qnil
);
2264 newname
= Fexpand_file_name (newname
, Qnil
);
2266 /* If the file name has special constructs in it,
2267 call the corresponding file handler. */
2268 handler
= Ffind_file_name_handler (file
, Qrename_file
);
2270 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
2271 if (!NILP (handler
))
2272 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
2273 file
, newname
, ok_if_already_exists
));
2275 if (NILP (ok_if_already_exists
)
2276 || INTEGERP (ok_if_already_exists
))
2277 barf_or_query_if_file_exists (newname
, "rename to it",
2278 INTEGERP (ok_if_already_exists
), 0);
2280 if (0 > rename (XSTRING (file
)->data
, XSTRING (newname
)->data
))
2282 if (0 > link (XSTRING (file
)->data
, XSTRING (newname
)->data
)
2283 || 0 > unlink (XSTRING (file
)->data
))
2288 Fcopy_file (file
, newname
,
2289 /* We have already prompted if it was an integer,
2290 so don't have copy-file prompt again. */
2291 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
2292 Fdelete_file (file
);
2299 report_file_error ("Renaming", Flist (2, args
));
2302 report_file_error ("Renaming", Flist (2, &file
));
2309 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
2310 "fAdd name to file: \nFName to add to %s: \np",
2311 "Give FILE additional name NEWNAME. Both args strings.\n\
2312 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2313 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2314 A number as third arg means request confirmation if NEWNAME already exists.\n\
2315 This is what happens in interactive use with M-x.")
2316 (file
, newname
, ok_if_already_exists
)
2317 Lisp_Object file
, newname
, ok_if_already_exists
;
2320 Lisp_Object args
[2];
2322 Lisp_Object handler
;
2323 struct gcpro gcpro1
, gcpro2
;
2325 GCPRO2 (file
, newname
);
2326 CHECK_STRING (file
, 0);
2327 CHECK_STRING (newname
, 1);
2328 file
= Fexpand_file_name (file
, Qnil
);
2329 newname
= Fexpand_file_name (newname
, Qnil
);
2331 /* If the file name has special constructs in it,
2332 call the corresponding file handler. */
2333 handler
= Ffind_file_name_handler (file
, Qadd_name_to_file
);
2334 if (!NILP (handler
))
2335 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2336 newname
, ok_if_already_exists
));
2338 /* If the new name has special constructs in it,
2339 call the corresponding file handler. */
2340 handler
= Ffind_file_name_handler (newname
, Qadd_name_to_file
);
2341 if (!NILP (handler
))
2342 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2343 newname
, ok_if_already_exists
));
2345 if (NILP (ok_if_already_exists
)
2346 || INTEGERP (ok_if_already_exists
))
2347 barf_or_query_if_file_exists (newname
, "make it a new name",
2348 INTEGERP (ok_if_already_exists
), 0);
2350 /* Windows does not support this operation. */
2351 report_file_error ("Adding new name", Flist (2, &file
));
2352 #else /* not WINDOWSNT */
2354 unlink (XSTRING (newname
)->data
);
2355 if (0 > link (XSTRING (file
)->data
, XSTRING (newname
)->data
))
2360 report_file_error ("Adding new name", Flist (2, args
));
2362 report_file_error ("Adding new name", Flist (2, &file
));
2365 #endif /* not WINDOWSNT */
2372 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2373 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2374 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
2375 Signals a `file-already-exists' error if a file LINKNAME already exists\n\
2376 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2377 A number as third arg means request confirmation if LINKNAME already exists.\n\
2378 This happens for interactive use with M-x.")
2379 (filename
, linkname
, ok_if_already_exists
)
2380 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2383 Lisp_Object args
[2];
2385 Lisp_Object handler
;
2386 struct gcpro gcpro1
, gcpro2
;
2388 GCPRO2 (filename
, linkname
);
2389 CHECK_STRING (filename
, 0);
2390 CHECK_STRING (linkname
, 1);
2391 /* If the link target has a ~, we must expand it to get
2392 a truly valid file name. Otherwise, do not expand;
2393 we want to permit links to relative file names. */
2394 if (XSTRING (filename
)->data
[0] == '~')
2395 filename
= Fexpand_file_name (filename
, Qnil
);
2396 linkname
= Fexpand_file_name (linkname
, Qnil
);
2398 /* If the file name has special constructs in it,
2399 call the corresponding file handler. */
2400 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2401 if (!NILP (handler
))
2402 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2403 linkname
, ok_if_already_exists
));
2405 /* If the new link name has special constructs in it,
2406 call the corresponding file handler. */
2407 handler
= Ffind_file_name_handler (linkname
, Qmake_symbolic_link
);
2408 if (!NILP (handler
))
2409 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2410 linkname
, ok_if_already_exists
));
2412 if (NILP (ok_if_already_exists
)
2413 || INTEGERP (ok_if_already_exists
))
2414 barf_or_query_if_file_exists (linkname
, "make it a link",
2415 INTEGERP (ok_if_already_exists
), 0);
2416 if (0 > symlink (XSTRING (filename
)->data
, XSTRING (linkname
)->data
))
2418 /* If we didn't complain already, silently delete existing file. */
2419 if (errno
== EEXIST
)
2421 unlink (XSTRING (linkname
)->data
);
2422 if (0 <= symlink (XSTRING (filename
)->data
, XSTRING (linkname
)->data
))
2432 report_file_error ("Making symbolic link", Flist (2, args
));
2434 report_file_error ("Making symbolic link", Flist (2, &filename
));
2440 #endif /* S_IFLNK */
2444 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2445 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2446 "Define the job-wide logical name NAME to have the value STRING.\n\
2447 If STRING is nil or a null string, the logical name NAME is deleted.")
2452 CHECK_STRING (name
, 0);
2454 delete_logical_name (XSTRING (name
)->data
);
2457 CHECK_STRING (string
, 1);
2459 if (XSTRING (string
)->size
== 0)
2460 delete_logical_name (XSTRING (name
)->data
);
2462 define_logical_name (XSTRING (name
)->data
, XSTRING (string
)->data
);
2471 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2472 "Open a network connection to PATH using LOGIN as the login string.")
2474 Lisp_Object path
, login
;
2478 CHECK_STRING (path
, 0);
2479 CHECK_STRING (login
, 0);
2481 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2483 if (netresult
== -1)
2488 #endif /* HPUX_NET */
2490 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2492 "Return t if file FILENAME specifies an absolute file name.\n\
2493 On Unix, this is a name starting with a `/' or a `~'.")
2495 Lisp_Object filename
;
2499 CHECK_STRING (filename
, 0);
2500 ptr
= XSTRING (filename
)->data
;
2501 if (IS_DIRECTORY_SEP (*ptr
) || *ptr
== '~'
2503 /* ??? This criterion is probably wrong for '<'. */
2504 || index (ptr
, ':') || index (ptr
, '<')
2505 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2509 || (IS_DRIVE (*ptr
) && ptr
[1] == ':' && IS_DIRECTORY_SEP (ptr
[2]))
2517 /* Return nonzero if file FILENAME exists and can be executed. */
2520 check_executable (filename
)
2524 int len
= strlen (filename
);
2527 if (stat (filename
, &st
) < 0)
2530 return ((st
.st_mode
& S_IEXEC
) != 0);
2532 return (S_ISREG (st
.st_mode
)
2534 && (stricmp ((suffix
= filename
+ len
-4), ".com") == 0
2535 || stricmp (suffix
, ".exe") == 0
2536 || stricmp (suffix
, ".bat") == 0)
2537 || (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2538 #endif /* not WINDOWSNT */
2539 #else /* not DOS_NT */
2541 return (eaccess (filename
, 1) >= 0);
2543 /* Access isn't quite right because it uses the real uid
2544 and we really want to test with the effective uid.
2545 But Unix doesn't give us a right way to do it. */
2546 return (access (filename
, 1) >= 0);
2548 #endif /* not DOS_NT */
2551 /* Return nonzero if file FILENAME exists and can be written. */
2554 check_writable (filename
)
2559 if (stat (filename
, &st
) < 0)
2561 return (st
.st_mode
& S_IWRITE
|| (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2562 #else /* not MSDOS */
2564 return (eaccess (filename
, 2) >= 0);
2566 /* Access isn't quite right because it uses the real uid
2567 and we really want to test with the effective uid.
2568 But Unix doesn't give us a right way to do it.
2569 Opening with O_WRONLY could work for an ordinary file,
2570 but would lose for directories. */
2571 return (access (filename
, 2) >= 0);
2573 #endif /* not MSDOS */
2576 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2577 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
2578 See also `file-readable-p' and `file-attributes'.")
2580 Lisp_Object filename
;
2582 Lisp_Object absname
;
2583 Lisp_Object handler
;
2584 struct stat statbuf
;
2586 CHECK_STRING (filename
, 0);
2587 absname
= Fexpand_file_name (filename
, Qnil
);
2589 /* If the file name has special constructs in it,
2590 call the corresponding file handler. */
2591 handler
= Ffind_file_name_handler (absname
, Qfile_exists_p
);
2592 if (!NILP (handler
))
2593 return call2 (handler
, Qfile_exists_p
, absname
);
2595 return (stat (XSTRING (absname
)->data
, &statbuf
) >= 0) ? Qt
: Qnil
;
2598 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2599 "Return t if FILENAME can be executed by you.\n\
2600 For a directory, this means you can access files in that directory.")
2602 Lisp_Object filename
;
2605 Lisp_Object absname
;
2606 Lisp_Object handler
;
2608 CHECK_STRING (filename
, 0);
2609 absname
= Fexpand_file_name (filename
, Qnil
);
2611 /* If the file name has special constructs in it,
2612 call the corresponding file handler. */
2613 handler
= Ffind_file_name_handler (absname
, Qfile_executable_p
);
2614 if (!NILP (handler
))
2615 return call2 (handler
, Qfile_executable_p
, absname
);
2617 return (check_executable (XSTRING (absname
)->data
) ? Qt
: Qnil
);
2620 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2621 "Return t if file FILENAME exists and you can read it.\n\
2622 See also `file-exists-p' and `file-attributes'.")
2624 Lisp_Object filename
;
2626 Lisp_Object absname
;
2627 Lisp_Object handler
;
2630 CHECK_STRING (filename
, 0);
2631 absname
= Fexpand_file_name (filename
, Qnil
);
2633 /* If the file name has special constructs in it,
2634 call the corresponding file handler. */
2635 handler
= Ffind_file_name_handler (absname
, Qfile_readable_p
);
2636 if (!NILP (handler
))
2637 return call2 (handler
, Qfile_readable_p
, absname
);
2640 /* Under MS-DOS and Windows, open does not work for directories. */
2641 if (access (XSTRING (absname
)->data
, 0) == 0)
2644 #else /* not DOS_NT */
2645 desc
= open (XSTRING (absname
)->data
, O_RDONLY
);
2650 #endif /* not DOS_NT */
2653 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2655 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
2656 "Return t if file FILENAME can be written or created by you.")
2658 Lisp_Object filename
;
2660 Lisp_Object absname
, dir
;
2661 Lisp_Object handler
;
2662 struct stat statbuf
;
2664 CHECK_STRING (filename
, 0);
2665 absname
= Fexpand_file_name (filename
, Qnil
);
2667 /* If the file name has special constructs in it,
2668 call the corresponding file handler. */
2669 handler
= Ffind_file_name_handler (absname
, Qfile_writable_p
);
2670 if (!NILP (handler
))
2671 return call2 (handler
, Qfile_writable_p
, absname
);
2673 if (stat (XSTRING (absname
)->data
, &statbuf
) >= 0)
2674 return (check_writable (XSTRING (absname
)->data
)
2676 dir
= Ffile_name_directory (absname
);
2679 dir
= Fdirectory_file_name (dir
);
2683 dir
= Fdirectory_file_name (dir
);
2685 return (check_writable (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "")
2689 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
2690 "Return non-nil if file FILENAME is the name of a symbolic link.\n\
2691 The value is the name of the file to which it is linked.\n\
2692 Otherwise returns nil.")
2694 Lisp_Object filename
;
2701 Lisp_Object handler
;
2703 CHECK_STRING (filename
, 0);
2704 filename
= Fexpand_file_name (filename
, Qnil
);
2706 /* If the file name has special constructs in it,
2707 call the corresponding file handler. */
2708 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
2709 if (!NILP (handler
))
2710 return call2 (handler
, Qfile_symlink_p
, filename
);
2715 buf
= (char *) xmalloc (bufsize
);
2716 bzero (buf
, bufsize
);
2717 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
2718 if (valsize
< bufsize
) break;
2719 /* Buffer was not long enough */
2728 val
= make_string (buf
, valsize
);
2731 #else /* not S_IFLNK */
2733 #endif /* not S_IFLNK */
2736 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
2737 "Return t if file FILENAME is the name of a directory as a file.\n\
2738 A directory name spec may be given instead; then the value is t\n\
2739 if the directory so specified exists and really is a directory.")
2741 Lisp_Object filename
;
2743 register Lisp_Object absname
;
2745 Lisp_Object handler
;
2747 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2749 /* If the file name has special constructs in it,
2750 call the corresponding file handler. */
2751 handler
= Ffind_file_name_handler (absname
, Qfile_directory_p
);
2752 if (!NILP (handler
))
2753 return call2 (handler
, Qfile_directory_p
, absname
);
2755 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2757 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
2760 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
2761 "Return t if file FILENAME is the name of a directory as a file,\n\
2762 and files in that directory can be opened by you. In order to use a\n\
2763 directory as a buffer's current directory, this predicate must return true.\n\
2764 A directory name spec may be given instead; then the value is t\n\
2765 if the directory so specified exists and really is a readable and\n\
2766 searchable directory.")
2768 Lisp_Object filename
;
2770 Lisp_Object handler
;
2772 struct gcpro gcpro1
;
2774 /* If the file name has special constructs in it,
2775 call the corresponding file handler. */
2776 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
2777 if (!NILP (handler
))
2778 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
2780 /* It's an unlikely combination, but yes we really do need to gcpro:
2781 Suppose that file-accessible-directory-p has no handler, but
2782 file-directory-p does have a handler; this handler causes a GC which
2783 relocates the string in `filename'; and finally file-directory-p
2784 returns non-nil. Then we would end up passing a garbaged string
2785 to file-executable-p. */
2787 tem
= (NILP (Ffile_directory_p (filename
))
2788 || NILP (Ffile_executable_p (filename
)));
2790 return tem
? Qnil
: Qt
;
2793 DEFUN ("file-regular-p", Ffile_regular_p
, Sfile_regular_p
, 1, 1, 0,
2794 "Return t if file FILENAME is the name of a regular file.\n\
2795 This is the sort of file that holds an ordinary stream of data bytes.")
2797 Lisp_Object filename
;
2799 register Lisp_Object absname
;
2801 Lisp_Object handler
;
2803 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2805 /* If the file name has special constructs in it,
2806 call the corresponding file handler. */
2807 handler
= Ffind_file_name_handler (absname
, Qfile_regular_p
);
2808 if (!NILP (handler
))
2809 return call2 (handler
, Qfile_regular_p
, absname
);
2811 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2813 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
2816 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
2817 "Return mode bits of file named FILENAME, as an integer.")
2819 Lisp_Object filename
;
2821 Lisp_Object absname
;
2823 Lisp_Object handler
;
2825 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2827 /* If the file name has special constructs in it,
2828 call the corresponding file handler. */
2829 handler
= Ffind_file_name_handler (absname
, Qfile_modes
);
2830 if (!NILP (handler
))
2831 return call2 (handler
, Qfile_modes
, absname
);
2833 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2836 if (check_executable (XSTRING (absname
)->data
))
2837 st
.st_mode
|= S_IEXEC
;
2840 return make_number (st
.st_mode
& 07777);
2843 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
2844 "Set mode bits of file named FILENAME to MODE (an integer).\n\
2845 Only the 12 low bits of MODE are used.")
2847 Lisp_Object filename
, mode
;
2849 Lisp_Object absname
;
2850 Lisp_Object handler
;
2852 absname
= Fexpand_file_name (filename
, current_buffer
->directory
);
2853 CHECK_NUMBER (mode
, 1);
2855 /* If the file name has special constructs in it,
2856 call the corresponding file handler. */
2857 handler
= Ffind_file_name_handler (absname
, Qset_file_modes
);
2858 if (!NILP (handler
))
2859 return call3 (handler
, Qset_file_modes
, absname
, mode
);
2861 if (chmod (XSTRING (absname
)->data
, XINT (mode
)) < 0)
2862 report_file_error ("Doing chmod", Fcons (absname
, Qnil
));
2867 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
2868 "Set the file permission bits for newly created files.\n\
2869 The argument MODE should be an integer; only the low 9 bits are used.\n\
2870 This setting is inherited by subprocesses.")
2874 CHECK_NUMBER (mode
, 0);
2876 umask ((~ XINT (mode
)) & 0777);
2881 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
2882 "Return the default file protection for created files.\n\
2883 The value is an integer.")
2889 realmask
= umask (0);
2892 XSETINT (value
, (~ realmask
) & 0777);
2898 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
2899 "Tell Unix to finish all pending disk updates.")
2908 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
2909 "Return t if file FILE1 is newer than file FILE2.\n\
2910 If FILE1 does not exist, the answer is nil;\n\
2911 otherwise, if FILE2 does not exist, the answer is t.")
2913 Lisp_Object file1
, file2
;
2915 Lisp_Object absname1
, absname2
;
2918 Lisp_Object handler
;
2919 struct gcpro gcpro1
, gcpro2
;
2921 CHECK_STRING (file1
, 0);
2922 CHECK_STRING (file2
, 0);
2925 GCPRO2 (absname1
, file2
);
2926 absname1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
2927 absname2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
2930 /* If the file name has special constructs in it,
2931 call the corresponding file handler. */
2932 handler
= Ffind_file_name_handler (absname1
, Qfile_newer_than_file_p
);
2934 handler
= Ffind_file_name_handler (absname2
, Qfile_newer_than_file_p
);
2935 if (!NILP (handler
))
2936 return call3 (handler
, Qfile_newer_than_file_p
, absname1
, absname2
);
2938 if (stat (XSTRING (absname1
)->data
, &st
) < 0)
2941 mtime1
= st
.st_mtime
;
2943 if (stat (XSTRING (absname2
)->data
, &st
) < 0)
2946 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
2950 Lisp_Object Qfind_buffer_file_type
;
2953 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
2955 "Insert contents of file FILENAME after point.\n\
2956 Returns list of absolute file name and length of data inserted.\n\
2957 If second argument VISIT is non-nil, the buffer's visited filename\n\
2958 and last save file modtime are set, and it is marked unmodified.\n\
2959 If visiting and the file does not exist, visiting is completed\n\
2960 before the error is signaled.\n\n\
2961 The optional third and fourth arguments BEG and END\n\
2962 specify what portion of the file to insert.\n\
2963 If VISIT is non-nil, BEG and END must be nil.\n\
2964 If optional fifth argument REPLACE is non-nil,\n\
2965 it means replace the current buffer contents (in the accessible portion)\n\
2966 with the file contents. This is better than simply deleting and inserting\n\
2967 the whole thing because (1) it preserves some marker positions\n\
2968 and (2) it puts less data in the undo list.")
2969 (filename
, visit
, beg
, end
, replace
)
2970 Lisp_Object filename
, visit
, beg
, end
, replace
;
2974 register int inserted
= 0;
2975 register int how_much
;
2976 int count
= specpdl_ptr
- specpdl
;
2977 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2978 Lisp_Object handler
, val
, insval
;
2981 int not_regular
= 0;
2983 if (current_buffer
->base_buffer
&& ! NILP (visit
))
2984 error ("Cannot do file visiting in an indirect buffer");
2986 if (!NILP (current_buffer
->read_only
))
2987 Fbarf_if_buffer_read_only ();
2992 GCPRO3 (filename
, val
, p
);
2994 CHECK_STRING (filename
, 0);
2995 filename
= Fexpand_file_name (filename
, Qnil
);
2997 /* If the file name has special constructs in it,
2998 call the corresponding file handler. */
2999 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
3000 if (!NILP (handler
))
3002 val
= call6 (handler
, Qinsert_file_contents
, filename
,
3003 visit
, beg
, end
, replace
);
3010 if (stat (XSTRING (filename
)->data
, &st
) < 0)
3012 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0
3013 || fstat (fd
, &st
) < 0)
3014 #endif /* not APOLLO */
3016 if (fd
>= 0) close (fd
);
3019 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
3026 /* This code will need to be changed in order to work on named
3027 pipes, and it's probably just not worth it. So we should at
3028 least signal an error. */
3029 if (!S_ISREG (st
.st_mode
))
3032 Fsignal (Qfile_error
,
3033 Fcons (build_string ("not a regular file"),
3034 Fcons (filename
, Qnil
)));
3042 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0)
3045 /* Replacement should preserve point as it preserves markers. */
3046 if (!NILP (replace
))
3047 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
3049 record_unwind_protect (close_file_unwind
, make_number (fd
));
3051 /* Supposedly happens on VMS. */
3053 error ("File size is negative");
3055 if (!NILP (beg
) || !NILP (end
))
3057 error ("Attempt to visit less than an entire file");
3060 CHECK_NUMBER (beg
, 0);
3062 XSETFASTINT (beg
, 0);
3065 CHECK_NUMBER (end
, 0);
3068 XSETINT (end
, st
.st_size
);
3069 if (XINT (end
) != st
.st_size
)
3070 error ("maximum buffer size exceeded");
3073 /* If requested, replace the accessible part of the buffer
3074 with the file contents. Avoid replacing text at the
3075 beginning or end of the buffer that matches the file contents;
3076 that preserves markers pointing to the unchanged parts. */
3078 /* On MSDOS, replace mode doesn't really work, except for binary files,
3079 and it's not worth supporting just for them. */
3080 if (!NILP (replace
))
3083 XSETFASTINT (beg
, 0);
3084 XSETFASTINT (end
, st
.st_size
);
3085 del_range_1 (BEGV
, ZV
, 0);
3087 #else /* not DOS_NT */
3088 if (!NILP (replace
))
3090 unsigned char buffer
[1 << 14];
3091 int same_at_start
= BEGV
;
3092 int same_at_end
= ZV
;
3097 /* Count how many chars at the start of the file
3098 match the text at the beginning of the buffer. */
3103 nread
= read (fd
, buffer
, sizeof buffer
);
3105 error ("IO error reading %s: %s",
3106 XSTRING (filename
)->data
, strerror (errno
));
3107 else if (nread
== 0)
3110 while (bufpos
< nread
&& same_at_start
< ZV
3111 && FETCH_CHAR (same_at_start
) == buffer
[bufpos
])
3112 same_at_start
++, bufpos
++;
3113 /* If we found a discrepancy, stop the scan.
3114 Otherwise loop around and scan the next bufferful. */
3115 if (bufpos
!= nread
)
3119 /* If the file matches the buffer completely,
3120 there's no need to replace anything. */
3121 if (same_at_start
- BEGV
== st
.st_size
)
3125 /* Truncate the buffer to the size of the file. */
3126 del_range_1 (same_at_start
, same_at_end
, 0);
3131 /* Count how many chars at the end of the file
3132 match the text at the end of the buffer. */
3135 int total_read
, nread
, bufpos
, curpos
, trial
;
3137 /* At what file position are we now scanning? */
3138 curpos
= st
.st_size
- (ZV
- same_at_end
);
3139 /* If the entire file matches the buffer tail, stop the scan. */
3142 /* How much can we scan in the next step? */
3143 trial
= min (curpos
, sizeof buffer
);
3144 if (lseek (fd
, curpos
- trial
, 0) < 0)
3145 report_file_error ("Setting file position",
3146 Fcons (filename
, Qnil
));
3149 while (total_read
< trial
)
3151 nread
= read (fd
, buffer
+ total_read
, trial
- total_read
);
3153 error ("IO error reading %s: %s",
3154 XSTRING (filename
)->data
, strerror (errno
));
3155 total_read
+= nread
;
3157 /* Scan this bufferful from the end, comparing with
3158 the Emacs buffer. */
3159 bufpos
= total_read
;
3160 /* Compare with same_at_start to avoid counting some buffer text
3161 as matching both at the file's beginning and at the end. */
3162 while (bufpos
> 0 && same_at_end
> same_at_start
3163 && FETCH_CHAR (same_at_end
- 1) == buffer
[bufpos
- 1])
3164 same_at_end
--, bufpos
--;
3165 /* If we found a discrepancy, stop the scan.
3166 Otherwise loop around and scan the preceding bufferful. */
3169 /* If display current starts at beginning of line,
3170 keep it that way. */
3171 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3172 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3176 /* Don't try to reuse the same piece of text twice. */
3177 overlap
= same_at_start
- BEGV
- (same_at_end
+ st
.st_size
- ZV
);
3179 same_at_end
+= overlap
;
3181 /* Arrange to read only the nonmatching middle part of the file. */
3182 XSETFASTINT (beg
, same_at_start
- BEGV
);
3183 XSETFASTINT (end
, st
.st_size
- (ZV
- same_at_end
));
3185 del_range_1 (same_at_start
, same_at_end
, 0);
3186 /* Insert from the file at the proper position. */
3187 SET_PT (same_at_start
);
3189 #endif /* not DOS_NT */
3191 total
= XINT (end
) - XINT (beg
);
3194 register Lisp_Object temp
;
3196 /* Make sure point-max won't overflow after this insertion. */
3197 XSETINT (temp
, total
);
3198 if (total
!= XINT (temp
))
3199 error ("maximum buffer size exceeded");
3202 if (NILP (visit
) && total
> 0)
3203 prepare_to_modify_buffer (point
, point
);
3206 if (GAP_SIZE
< total
)
3207 make_gap (total
- GAP_SIZE
);
3209 if (XINT (beg
) != 0 || !NILP (replace
))
3211 if (lseek (fd
, XINT (beg
), 0) < 0)
3212 report_file_error ("Setting file position", Fcons (filename
, Qnil
));
3216 while (inserted
< total
)
3218 /* try is reserved in some compilers (Microsoft C) */
3219 int trytry
= min (total
- inserted
, 64 << 10);
3222 /* Allow quitting out of the actual I/O. */
3225 this = read (fd
, &FETCH_CHAR (point
+ inserted
- 1) + 1, trytry
);
3242 /* Demacs 1.1.1 91/10/16 HIRANO Satoshi, MW July 1993 */
3243 /* Determine file type from name and remove LFs from CR-LFs if the file
3244 is deemed to be a text file. */
3246 current_buffer
->buffer_file_type
3247 = call1 (Qfind_buffer_file_type
, filename
);
3248 if (NILP (current_buffer
->buffer_file_type
))
3251 = inserted
- crlf_to_lf (inserted
, &FETCH_CHAR (point
- 1) + 1);
3254 GPT
-= reduced_size
;
3255 GAP_SIZE
+= reduced_size
;
3256 inserted
-= reduced_size
;
3263 record_insert (point
, inserted
);
3265 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
3266 offset_intervals (current_buffer
, point
, inserted
);
3272 /* Discard the unwind protect for closing the file. */
3276 error ("IO error reading %s: %s",
3277 XSTRING (filename
)->data
, strerror (errno
));
3284 if (!EQ (current_buffer
->undo_list
, Qt
))
3285 current_buffer
->undo_list
= Qnil
;
3287 stat (XSTRING (filename
)->data
, &st
);
3292 current_buffer
->modtime
= st
.st_mtime
;
3293 current_buffer
->filename
= filename
;
3296 SAVE_MODIFF
= MODIFF
;
3297 current_buffer
->auto_save_modified
= MODIFF
;
3298 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
3299 #ifdef CLASH_DETECTION
3302 if (!NILP (current_buffer
->file_truename
))
3303 unlock_file (current_buffer
->file_truename
);
3304 unlock_file (filename
);
3306 #endif /* CLASH_DETECTION */
3308 Fsignal (Qfile_error
,
3309 Fcons (build_string ("not a regular file"),
3310 Fcons (filename
, Qnil
)));
3312 /* If visiting nonexistent file, return nil. */
3313 if (current_buffer
->modtime
== -1)
3314 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
3317 /* Decode file format */
3320 insval
= call3 (Qformat_decode
,
3321 Qnil
, make_number (inserted
), visit
);
3322 CHECK_NUMBER (insval
, 0);
3323 inserted
= XFASTINT (insval
);
3326 if (inserted
> 0 && NILP (visit
) && total
> 0)
3327 signal_after_change (point
, 0, inserted
);
3331 p
= Vafter_insert_file_functions
;
3334 insval
= call1 (Fcar (p
), make_number (inserted
));
3337 CHECK_NUMBER (insval
, 0);
3338 inserted
= XFASTINT (insval
);
3346 val
= Fcons (filename
,
3347 Fcons (make_number (inserted
),
3350 RETURN_UNGCPRO (unbind_to (count
, val
));
3353 static Lisp_Object
build_annotations ();
3355 /* If build_annotations switched buffers, switch back to BUF.
3356 Kill the temporary buffer that was selected in the meantime. */
3359 build_annotations_unwind (buf
)
3364 if (XBUFFER (buf
) == current_buffer
)
3366 tembuf
= Fcurrent_buffer ();
3368 Fkill_buffer (tembuf
);
3372 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 6,
3373 "r\nFWrite region to file: ",
3374 "Write current region into specified file.\n\
3375 When called from a program, takes three arguments:\n\
3376 START, END and FILENAME. START and END are buffer positions.\n\
3377 Optional fourth argument APPEND if non-nil means\n\
3378 append to existing file contents (if any).\n\
3379 Optional fifth argument VISIT if t means\n\
3380 set the last-save-file-modtime of buffer to this file's modtime\n\
3381 and mark buffer not modified.\n\
3382 If VISIT is a string, it is a second file name;\n\
3383 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
3384 VISIT is also the file name to lock and unlock for clash detection.\n\
3385 If VISIT is neither t nor nil nor a string,\n\
3386 that means do not print the \"Wrote file\" message.\n\
3387 The optional sixth arg LOCKNAME, if non-nil, specifies the name to\n\
3388 use for locking and unlocking, overriding FILENAME and VISIT.\n\
3389 Kludgy feature: if START is a string, then that string is written\n\
3390 to the file, instead of any buffer contents, and END is ignored.")
3391 (start
, end
, filename
, append
, visit
, lockname
)
3392 Lisp_Object start
, end
, filename
, append
, visit
, lockname
;
3400 int count
= specpdl_ptr
- specpdl
;
3403 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
3405 Lisp_Object handler
;
3406 Lisp_Object visit_file
;
3407 Lisp_Object annotations
;
3408 int visiting
, quietly
;
3409 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
3410 struct buffer
*given_buffer
;
3412 int buffer_file_type
3413 = NILP (current_buffer
->buffer_file_type
) ? O_TEXT
: O_BINARY
;
3416 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3417 error ("Cannot do file visiting in an indirect buffer");
3419 if (!NILP (start
) && !STRINGP (start
))
3420 validate_region (&start
, &end
);
3422 GCPRO3 (filename
, visit
, lockname
);
3423 filename
= Fexpand_file_name (filename
, Qnil
);
3424 if (STRINGP (visit
))
3425 visit_file
= Fexpand_file_name (visit
, Qnil
);
3427 visit_file
= filename
;
3430 visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
3431 quietly
= !NILP (visit
);
3435 if (NILP (lockname
))
3436 lockname
= visit_file
;
3438 GCPRO5 (start
, filename
, annotations
, visit_file
, lockname
);
3440 /* If the file name has special constructs in it,
3441 call the corresponding file handler. */
3442 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
3443 /* If FILENAME has no handler, see if VISIT has one. */
3444 if (NILP (handler
) && STRINGP (visit
))
3445 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
3447 if (!NILP (handler
))
3450 val
= call6 (handler
, Qwrite_region
, start
, end
,
3451 filename
, append
, visit
);
3455 SAVE_MODIFF
= MODIFF
;
3456 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
3457 current_buffer
->filename
= visit_file
;
3463 /* Special kludge to simplify auto-saving. */
3466 XSETFASTINT (start
, BEG
);
3467 XSETFASTINT (end
, Z
);
3470 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
3471 count1
= specpdl_ptr
- specpdl
;
3473 given_buffer
= current_buffer
;
3474 annotations
= build_annotations (start
, end
);
3475 if (current_buffer
!= given_buffer
)
3481 #ifdef CLASH_DETECTION
3483 lock_file (lockname
);
3484 #endif /* CLASH_DETECTION */
3486 fn
= XSTRING (filename
)->data
;
3490 desc
= open (fn
, O_WRONLY
| buffer_file_type
);
3491 #else /* not DOS_NT */
3492 desc
= open (fn
, O_WRONLY
);
3493 #endif /* not DOS_NT */
3497 if (auto_saving
) /* Overwrite any previous version of autosave file */
3499 vms_truncate (fn
); /* if fn exists, truncate to zero length */
3500 desc
= open (fn
, O_RDWR
);
3502 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
3503 ? XSTRING (current_buffer
->filename
)->data
: 0,
3506 else /* Write to temporary name and rename if no errors */
3508 Lisp_Object temp_name
;
3509 temp_name
= Ffile_name_directory (filename
);
3511 if (!NILP (temp_name
))
3513 temp_name
= Fmake_temp_name (concat2 (temp_name
,
3514 build_string ("$$SAVE$$")));
3515 fname
= XSTRING (filename
)->data
;
3516 fn
= XSTRING (temp_name
)->data
;
3517 desc
= creat_copy_attrs (fname
, fn
);
3520 /* If we can't open the temporary file, try creating a new
3521 version of the original file. VMS "creat" creates a
3522 new version rather than truncating an existing file. */
3525 desc
= creat (fn
, 0666);
3526 #if 0 /* This can clobber an existing file and fail to replace it,
3527 if the user runs out of space. */
3530 /* We can't make a new version;
3531 try to truncate and rewrite existing version if any. */
3533 desc
= open (fn
, O_RDWR
);
3539 desc
= creat (fn
, 0666);
3544 O_WRONLY
| O_TRUNC
| O_CREAT
| buffer_file_type
,
3545 S_IREAD
| S_IWRITE
);
3546 #else /* not DOS_NT */
3547 desc
= creat (fn
, auto_saving
? auto_save_mode_bits
: 0666);
3548 #endif /* not DOS_NT */
3549 #endif /* not VMS */
3555 #ifdef CLASH_DETECTION
3557 if (!auto_saving
) unlock_file (lockname
);
3559 #endif /* CLASH_DETECTION */
3560 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
3563 record_unwind_protect (close_file_unwind
, make_number (desc
));
3566 if (lseek (desc
, 0, 2) < 0)
3568 #ifdef CLASH_DETECTION
3569 if (!auto_saving
) unlock_file (lockname
);
3570 #endif /* CLASH_DETECTION */
3571 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
3576 * Kludge Warning: The VMS C RTL likes to insert carriage returns
3577 * if we do writes that don't end with a carriage return. Furthermore
3578 * it cannot handle writes of more then 16K. The modified
3579 * version of "sys_write" in SYSDEP.C (see comment there) copes with
3580 * this EXCEPT for the last record (iff it doesn't end with a carriage
3581 * return). This implies that if your buffer doesn't end with a carriage
3582 * return, you get one free... tough. However it also means that if
3583 * we make two calls to sys_write (a la the following code) you can
3584 * get one at the gap as well. The easiest way to fix this (honest)
3585 * is to move the gap to the next newline (or the end of the buffer).
3590 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
3591 move_gap (find_next_newline (GPT
, 1));
3597 if (STRINGP (start
))
3599 failure
= 0 > a_write (desc
, XSTRING (start
)->data
,
3600 XSTRING (start
)->size
, 0, &annotations
);
3603 else if (XINT (start
) != XINT (end
))
3606 if (XINT (start
) < GPT
)
3608 register int end1
= XINT (end
);
3610 failure
= 0 > a_write (desc
, &FETCH_CHAR (tem
),
3611 min (GPT
, end1
) - tem
, tem
, &annotations
);
3612 nwritten
+= min (GPT
, end1
) - tem
;
3616 if (XINT (end
) > GPT
&& !failure
)
3619 tem
= max (tem
, GPT
);
3620 failure
= 0 > a_write (desc
, &FETCH_CHAR (tem
), XINT (end
) - tem
,
3622 nwritten
+= XINT (end
) - tem
;
3628 /* If file was empty, still need to write the annotations */
3629 failure
= 0 > a_write (desc
, "", 0, XINT (start
), &annotations
);
3636 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
3637 Disk full in NFS may be reported here. */
3638 /* mib says that closing the file will try to write as fast as NFS can do
3639 it, and that means the fsync here is not crucial for autosave files. */
3640 if (!auto_saving
&& fsync (desc
) < 0)
3642 /* If fsync fails with EINTR, don't treat that as serious. */
3644 failure
= 1, save_errno
= errno
;
3648 /* Spurious "file has changed on disk" warnings have been
3649 observed on Suns as well.
3650 It seems that `close' can change the modtime, under nfs.
3652 (This has supposedly been fixed in Sunos 4,
3653 but who knows about all the other machines with NFS?) */
3656 /* On VMS and APOLLO, must do the stat after the close
3657 since closing changes the modtime. */
3660 /* Recall that #if defined does not work on VMS. */
3667 /* NFS can report a write failure now. */
3668 if (close (desc
) < 0)
3669 failure
= 1, save_errno
= errno
;
3672 /* If we wrote to a temporary name and had no errors, rename to real name. */
3676 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
3684 /* Discard the unwind protect for close_file_unwind. */
3685 specpdl_ptr
= specpdl
+ count1
;
3686 /* Restore the original current buffer. */
3687 visit_file
= unbind_to (count
, visit_file
);
3689 #ifdef CLASH_DETECTION
3691 unlock_file (lockname
);
3692 #endif /* CLASH_DETECTION */
3694 /* Do this before reporting IO error
3695 to avoid a "file has changed on disk" warning on
3696 next attempt to save. */
3698 current_buffer
->modtime
= st
.st_mtime
;
3701 error ("IO error writing %s: %s", fn
, strerror (save_errno
));
3705 SAVE_MODIFF
= MODIFF
;
3706 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
3707 current_buffer
->filename
= visit_file
;
3708 update_mode_lines
++;
3714 message ("Wrote %s", XSTRING (visit_file
)->data
);
3719 Lisp_Object
merge ();
3721 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
3722 "Return t if (car A) is numerically less than (car B).")
3726 return Flss (Fcar (a
), Fcar (b
));
3729 /* Build the complete list of annotations appropriate for writing out
3730 the text between START and END, by calling all the functions in
3731 write-region-annotate-functions and merging the lists they return.
3732 If one of these functions switches to a different buffer, we assume
3733 that buffer contains altered text. Therefore, the caller must
3734 make sure to restore the current buffer in all cases,
3735 as save-excursion would do. */
3738 build_annotations (start
, end
)
3739 Lisp_Object start
, end
;
3741 Lisp_Object annotations
;
3743 struct gcpro gcpro1
, gcpro2
;
3746 p
= Vwrite_region_annotate_functions
;
3747 GCPRO2 (annotations
, p
);
3750 struct buffer
*given_buffer
= current_buffer
;
3751 Vwrite_region_annotations_so_far
= annotations
;
3752 res
= call2 (Fcar (p
), start
, end
);
3753 /* If the function makes a different buffer current,
3754 assume that means this buffer contains altered text to be output.
3755 Reset START and END from the buffer bounds
3756 and discard all previous annotations because they should have
3757 been dealt with by this function. */
3758 if (current_buffer
!= given_buffer
)
3764 Flength (res
); /* Check basic validity of return value */
3765 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
3769 /* Now do the same for annotation functions implied by the file-format */
3770 if (auto_saving
&& (!EQ (Vauto_save_file_format
, Qt
)))
3771 p
= Vauto_save_file_format
;
3773 p
= current_buffer
->file_format
;
3776 struct buffer
*given_buffer
= current_buffer
;
3777 Vwrite_region_annotations_so_far
= annotations
;
3778 res
= call3 (Qformat_annotate_function
, Fcar (p
), start
, end
);
3779 if (current_buffer
!= given_buffer
)
3786 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
3793 /* Write to descriptor DESC the LEN characters starting at ADDR,
3794 assuming they start at position POS in the buffer.
3795 Intersperse with them the annotations from *ANNOT
3796 (those which fall within the range of positions POS to POS + LEN),
3797 each at its appropriate position.
3799 Modify *ANNOT by discarding elements as we output them.
3800 The return value is negative in case of system call failure. */
3803 a_write (desc
, addr
, len
, pos
, annot
)
3805 register char *addr
;
3812 int lastpos
= pos
+ len
;
3814 while (NILP (*annot
) || CONSP (*annot
))
3816 tem
= Fcar_safe (Fcar (*annot
));
3817 if (INTEGERP (tem
) && XINT (tem
) >= pos
&& XFASTINT (tem
) <= lastpos
)
3818 nextpos
= XFASTINT (tem
);
3820 return e_write (desc
, addr
, lastpos
- pos
);
3823 if (0 > e_write (desc
, addr
, nextpos
- pos
))
3825 addr
+= nextpos
- pos
;
3828 tem
= Fcdr (Fcar (*annot
));
3831 if (0 > e_write (desc
, XSTRING (tem
)->data
, XSTRING (tem
)->size
))
3834 *annot
= Fcdr (*annot
);
3839 e_write (desc
, addr
, len
)
3841 register char *addr
;
3844 char buf
[16 * 1024];
3845 register char *p
, *end
;
3847 if (!EQ (current_buffer
->selective_display
, Qt
))
3848 return write (desc
, addr
, len
) - len
;
3852 end
= p
+ sizeof buf
;
3857 if (write (desc
, buf
, sizeof buf
) != sizeof buf
)
3866 if (write (desc
, buf
, p
- buf
) != p
- buf
)
3872 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
3873 Sverify_visited_file_modtime
, 1, 1, 0,
3874 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
3875 This means that the file has not been changed since it was visited or saved.")
3881 Lisp_Object handler
;
3883 CHECK_BUFFER (buf
, 0);
3886 if (!STRINGP (b
->filename
)) return Qt
;
3887 if (b
->modtime
== 0) return Qt
;
3889 /* If the file name has special constructs in it,
3890 call the corresponding file handler. */
3891 handler
= Ffind_file_name_handler (b
->filename
,
3892 Qverify_visited_file_modtime
);
3893 if (!NILP (handler
))
3894 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
3896 if (stat (XSTRING (b
->filename
)->data
, &st
) < 0)
3898 /* If the file doesn't exist now and didn't exist before,
3899 we say that it isn't modified, provided the error is a tame one. */
3900 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
3905 if (st
.st_mtime
== b
->modtime
3906 /* If both are positive, accept them if they are off by one second. */
3907 || (st
.st_mtime
> 0 && b
->modtime
> 0
3908 && (st
.st_mtime
== b
->modtime
+ 1
3909 || st
.st_mtime
== b
->modtime
- 1)))
3914 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
3915 Sclear_visited_file_modtime
, 0, 0, 0,
3916 "Clear out records of last mod time of visited file.\n\
3917 Next attempt to save will certainly not complain of a discrepancy.")
3920 current_buffer
->modtime
= 0;
3924 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
3925 Svisited_file_modtime
, 0, 0, 0,
3926 "Return the current buffer's recorded visited file modification time.\n\
3927 The value is a list of the form (HIGH . LOW), like the time values\n\
3928 that `file-attributes' returns.")
3931 return long_to_cons ((unsigned long) current_buffer
->modtime
);
3934 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
3935 Sset_visited_file_modtime
, 0, 1, 0,
3936 "Update buffer's recorded modification time from the visited file's time.\n\
3937 Useful if the buffer was not read from the file normally\n\
3938 or if the file itself has been changed for some known benign reason.\n\
3939 An argument specifies the modification time value to use\n\
3940 \(instead of that of the visited file), in the form of a list\n\
3941 \(HIGH . LOW) or (HIGH LOW).")
3943 Lisp_Object time_list
;
3945 if (!NILP (time_list
))
3946 current_buffer
->modtime
= cons_to_long (time_list
);
3949 register Lisp_Object filename
;
3951 Lisp_Object handler
;
3953 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
3955 /* If the file name has special constructs in it,
3956 call the corresponding file handler. */
3957 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
3958 if (!NILP (handler
))
3959 /* The handler can find the file name the same way we did. */
3960 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
3961 else if (stat (XSTRING (filename
)->data
, &st
) >= 0)
3962 current_buffer
->modtime
= st
.st_mtime
;
3972 message ("Autosaving...error for %s", XSTRING (current_buffer
->name
)->data
);
3973 Fsleep_for (make_number (1), Qnil
);
3974 message ("Autosaving...error!for %s", XSTRING (current_buffer
->name
)->data
);
3975 Fsleep_for (make_number (1), Qnil
);
3976 message ("Autosaving...error for %s", XSTRING (current_buffer
->name
)->data
);
3977 Fsleep_for (make_number (1), Qnil
);
3987 /* Get visited file's mode to become the auto save file's mode. */
3988 if (stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
3989 /* But make sure we can overwrite it later! */
3990 auto_save_mode_bits
= st
.st_mode
| 0600;
3992 auto_save_mode_bits
= 0666;
3995 Fwrite_region (Qnil
, Qnil
,
3996 current_buffer
->auto_save_file_name
,
3997 Qnil
, Qlambda
, Qnil
);
4001 do_auto_save_unwind (desc
) /* used as unwind-protect function */
4005 if (XINT (desc
) >= 0)
4006 close (XINT (desc
));
4010 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
4011 "Auto-save all buffers that need it.\n\
4012 This is all buffers that have auto-saving enabled\n\
4013 and are changed since last auto-saved.\n\
4014 Auto-saving writes the buffer into a file\n\
4015 so that your editing is not lost if the system crashes.\n\
4016 This file is not the file you visited; that changes only when you save.\n\
4017 Normally we run the normal hook `auto-save-hook' before saving.\n\n\
4018 A non-nil NO-MESSAGE argument means do not print any message if successful.\n\
4019 A non-nil CURRENT-ONLY argument means save only current buffer.")
4020 (no_message
, current_only
)
4021 Lisp_Object no_message
, current_only
;
4023 struct buffer
*old
= current_buffer
, *b
;
4024 Lisp_Object tail
, buf
;
4026 char *omessage
= echo_area_glyphs
;
4027 int omessage_length
= echo_area_glyphs_length
;
4028 extern int minibuf_level
;
4029 int do_handled_files
;
4032 int count
= specpdl_ptr
- specpdl
;
4035 /* Ordinarily don't quit within this function,
4036 but don't make it impossible to quit (in case we get hung in I/O). */
4040 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
4041 point to non-strings reached from Vbuffer_alist. */
4046 if (!NILP (Vrun_hooks
))
4047 call1 (Vrun_hooks
, intern ("auto-save-hook"));
4049 if (STRINGP (Vauto_save_list_file_name
))
4051 Lisp_Object listfile
;
4052 listfile
= Fexpand_file_name (Vauto_save_list_file_name
, Qnil
);
4054 listdesc
= open (XSTRING (listfile
)->data
,
4055 O_WRONLY
| O_TRUNC
| O_CREAT
| O_TEXT
,
4056 S_IREAD
| S_IWRITE
);
4057 #else /* not DOS_NT */
4058 listdesc
= creat (XSTRING (listfile
)->data
, 0666);
4059 #endif /* not DOS_NT */
4064 /* Arrange to close that file whether or not we get an error.
4065 Also reset auto_saving to 0. */
4066 record_unwind_protect (do_auto_save_unwind
, make_number (listdesc
));
4070 /* First, save all files which don't have handlers. If Emacs is
4071 crashing, the handlers may tweak what is causing Emacs to crash
4072 in the first place, and it would be a shame if Emacs failed to
4073 autosave perfectly ordinary files because it couldn't handle some
4075 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
4076 for (tail
= Vbuffer_alist
; GC_CONSP (tail
); tail
= XCONS (tail
)->cdr
)
4078 buf
= XCONS (XCONS (tail
)->car
)->cdr
;
4081 /* Record all the buffers that have auto save mode
4082 in the special file that lists them. For each of these buffers,
4083 Record visited name (if any) and auto save name. */
4084 if (STRINGP (b
->auto_save_file_name
)
4085 && listdesc
>= 0 && do_handled_files
== 0)
4087 if (!NILP (b
->filename
))
4089 write (listdesc
, XSTRING (b
->filename
)->data
,
4090 XSTRING (b
->filename
)->size
);
4092 write (listdesc
, "\n", 1);
4093 write (listdesc
, XSTRING (b
->auto_save_file_name
)->data
,
4094 XSTRING (b
->auto_save_file_name
)->size
);
4095 write (listdesc
, "\n", 1);
4098 if (!NILP (current_only
)
4099 && b
!= current_buffer
)
4102 /* Don't auto-save indirect buffers.
4103 The base buffer takes care of it. */
4107 /* Check for auto save enabled
4108 and file changed since last auto save
4109 and file changed since last real save. */
4110 if (STRINGP (b
->auto_save_file_name
)
4111 && BUF_SAVE_MODIFF (b
) < BUF_MODIFF (b
)
4112 && b
->auto_save_modified
< BUF_MODIFF (b
)
4113 /* -1 means we've turned off autosaving for a while--see below. */
4114 && XINT (b
->save_length
) >= 0
4115 && (do_handled_files
4116 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
4119 EMACS_TIME before_time
, after_time
;
4121 EMACS_GET_TIME (before_time
);
4123 /* If we had a failure, don't try again for 20 minutes. */
4124 if (b
->auto_save_failure_time
>= 0
4125 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
4128 if ((XFASTINT (b
->save_length
) * 10
4129 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
4130 /* A short file is likely to change a large fraction;
4131 spare the user annoying messages. */
4132 && XFASTINT (b
->save_length
) > 5000
4133 /* These messages are frequent and annoying for `*mail*'. */
4134 && !EQ (b
->filename
, Qnil
)
4135 && NILP (no_message
))
4137 /* It has shrunk too much; turn off auto-saving here. */
4138 message ("Buffer %s has shrunk a lot; auto save turned off there",
4139 XSTRING (b
->name
)->data
);
4140 /* Turn off auto-saving until there's a real save,
4141 and prevent any more warnings. */
4142 XSETINT (b
->save_length
, -1);
4143 Fsleep_for (make_number (1), Qnil
);
4146 set_buffer_internal (b
);
4147 if (!auto_saved
&& NILP (no_message
))
4148 message1 ("Auto-saving...");
4149 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
4151 b
->auto_save_modified
= BUF_MODIFF (b
);
4152 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4153 set_buffer_internal (old
);
4155 EMACS_GET_TIME (after_time
);
4157 /* If auto-save took more than 60 seconds,
4158 assume it was an NFS failure that got a timeout. */
4159 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
4160 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
4164 /* Prevent another auto save till enough input events come in. */
4165 record_auto_save ();
4167 if (auto_saved
&& NILP (no_message
))
4171 sit_for (1, 0, 0, 0);
4172 message2 (omessage
, omessage_length
);
4175 message1 ("Auto-saving...done");
4180 unbind_to (count
, Qnil
);
4184 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
4185 Sset_buffer_auto_saved
, 0, 0, 0,
4186 "Mark current buffer as auto-saved with its current text.\n\
4187 No auto-save file will be written until the buffer changes again.")
4190 current_buffer
->auto_save_modified
= MODIFF
;
4191 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4192 current_buffer
->auto_save_failure_time
= -1;
4196 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
4197 Sclear_buffer_auto_save_failure
, 0, 0, 0,
4198 "Clear any record of a recent auto-save failure in the current buffer.")
4201 current_buffer
->auto_save_failure_time
= -1;
4205 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
4207 "Return t if buffer has been auto-saved since last read in or saved.")
4210 return (SAVE_MODIFF
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
4213 /* Reading and completing file names */
4214 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
4216 /* In the string VAL, change each $ to $$ and return the result. */
4219 double_dollars (val
)
4222 register unsigned char *old
, *new;
4226 osize
= XSTRING (val
)->size
;
4227 /* Quote "$" as "$$" to get it past substitute-in-file-name */
4228 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
4229 if (*old
++ == '$') count
++;
4232 old
= XSTRING (val
)->data
;
4233 val
= Fmake_string (make_number (osize
+ count
), make_number (0));
4234 new = XSTRING (val
)->data
;
4235 for (n
= osize
; n
> 0; n
--)
4248 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
4250 "Internal subroutine for read-file-name. Do not call this.")
4251 (string
, dir
, action
)
4252 Lisp_Object string
, dir
, action
;
4253 /* action is nil for complete, t for return list of completions,
4254 lambda for verify final value */
4256 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
4258 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
4265 /* No need to protect ACTION--we only compare it with t and nil. */
4266 GCPRO5 (string
, realdir
, name
, specdir
, orig_string
);
4268 if (XSTRING (string
)->size
== 0)
4270 if (EQ (action
, Qlambda
))
4278 orig_string
= string
;
4279 string
= Fsubstitute_in_file_name (string
);
4280 changed
= NILP (Fstring_equal (string
, orig_string
));
4281 name
= Ffile_name_nondirectory (string
);
4282 val
= Ffile_name_directory (string
);
4284 realdir
= Fexpand_file_name (val
, realdir
);
4289 specdir
= Ffile_name_directory (string
);
4290 val
= Ffile_name_completion (name
, realdir
);
4295 return double_dollars (string
);
4299 if (!NILP (specdir
))
4300 val
= concat2 (specdir
, val
);
4302 return double_dollars (val
);
4305 #endif /* not VMS */
4309 if (EQ (action
, Qt
))
4310 return Ffile_name_all_completions (name
, realdir
);
4311 /* Only other case actually used is ACTION = lambda */
4313 /* Supposedly this helps commands such as `cd' that read directory names,
4314 but can someone explain how it helps them? -- RMS */
4315 if (XSTRING (name
)->size
== 0)
4318 return Ffile_exists_p (string
);
4321 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
4322 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
4323 Value is not expanded---you must call `expand-file-name' yourself.\n\
4324 Default name to DEFAULT-FILENAME if user enters a null string.\n\
4325 (If DEFAULT-FILENAME is omitted, the visited file name is used,\n\
4326 except that if INITIAL is specified, that combined with DIR is used.)\n\
4327 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
4328 Non-nil and non-t means also require confirmation after completion.\n\
4329 Fifth arg INITIAL specifies text to start with.\n\
4330 DIR defaults to current buffer's directory default.")
4331 (prompt
, dir
, default_filename
, mustmatch
, initial
)
4332 Lisp_Object prompt
, dir
, default_filename
, mustmatch
, initial
;
4334 Lisp_Object val
, insdef
, insdef1
, tem
;
4335 struct gcpro gcpro1
, gcpro2
;
4336 register char *homedir
;
4340 dir
= current_buffer
->directory
;
4341 if (NILP (default_filename
))
4343 if (! NILP (initial
))
4344 default_filename
= Fexpand_file_name (initial
, dir
);
4346 default_filename
= current_buffer
->filename
;
4349 /* If dir starts with user's homedir, change that to ~. */
4350 homedir
= (char *) egetenv ("HOME");
4352 homedir
= strcpy (alloca (strlen (homedir
) + 1), homedir
);
4353 CORRECT_DIR_SEPS (homedir
);
4357 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
4358 && IS_DIRECTORY_SEP (XSTRING (dir
)->data
[strlen (homedir
)]))
4360 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
4361 XSTRING (dir
)->size
- strlen (homedir
) + 1);
4362 XSTRING (dir
)->data
[0] = '~';
4365 if (insert_default_directory
)
4368 if (!NILP (initial
))
4370 Lisp_Object args
[2], pos
;
4374 insdef
= Fconcat (2, args
);
4375 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
4376 insdef1
= Fcons (double_dollars (insdef
), pos
);
4379 insdef1
= double_dollars (insdef
);
4381 else if (!NILP (initial
))
4384 insdef1
= Fcons (double_dollars (insdef
), 0);
4387 insdef
= Qnil
, insdef1
= Qnil
;
4390 count
= specpdl_ptr
- specpdl
;
4391 specbind (intern ("completion-ignore-case"), Qt
);
4394 GCPRO2 (insdef
, default_filename
);
4395 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
4396 dir
, mustmatch
, insdef1
,
4397 Qfile_name_history
);
4400 unbind_to (count
, Qnil
);
4405 error ("No file name specified");
4406 tem
= Fstring_equal (val
, insdef
);
4407 if (!NILP (tem
) && !NILP (default_filename
))
4408 return default_filename
;
4409 if (XSTRING (val
)->size
== 0 && NILP (insdef
))
4411 if (!NILP (default_filename
))
4412 return default_filename
;
4414 error ("No default file name");
4416 return Fsubstitute_in_file_name (val
);
4419 #if 0 /* Old version */
4420 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
4421 /* Don't confuse make-docfile by having two doc strings for this function.
4422 make-docfile does not pay attention to #if, for good reason! */
4424 (prompt
, dir
, defalt
, mustmatch
, initial
)
4425 Lisp_Object prompt
, dir
, defalt
, mustmatch
, initial
;
4427 Lisp_Object val
, insdef
, tem
;
4428 struct gcpro gcpro1
, gcpro2
;
4429 register char *homedir
;
4433 dir
= current_buffer
->directory
;
4435 defalt
= current_buffer
->filename
;
4437 /* If dir starts with user's homedir, change that to ~. */
4438 homedir
= (char *) egetenv ("HOME");
4441 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
4442 && XSTRING (dir
)->data
[strlen (homedir
)] == '/')
4444 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
4445 XSTRING (dir
)->size
- strlen (homedir
) + 1);
4446 XSTRING (dir
)->data
[0] = '~';
4449 if (!NILP (initial
))
4451 else if (insert_default_directory
)
4454 insdef
= build_string ("");
4457 count
= specpdl_ptr
- specpdl
;
4458 specbind (intern ("completion-ignore-case"), Qt
);
4461 GCPRO2 (insdef
, defalt
);
4462 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
4464 insert_default_directory
? insdef
: Qnil
,
4465 Qfile_name_history
);
4468 unbind_to (count
, Qnil
);
4473 error ("No file name specified");
4474 tem
= Fstring_equal (val
, insdef
);
4475 if (!NILP (tem
) && !NILP (defalt
))
4477 return Fsubstitute_in_file_name (val
);
4479 #endif /* Old version */
4483 Qexpand_file_name
= intern ("expand-file-name");
4484 Qsubstitute_in_file_name
= intern ("substitute-in-file-name");
4485 Qdirectory_file_name
= intern ("directory-file-name");
4486 Qfile_name_directory
= intern ("file-name-directory");
4487 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
4488 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
4489 Qfile_name_as_directory
= intern ("file-name-as-directory");
4490 Qcopy_file
= intern ("copy-file");
4491 Qmake_directory_internal
= intern ("make-directory-internal");
4492 Qdelete_directory
= intern ("delete-directory");
4493 Qdelete_file
= intern ("delete-file");
4494 Qrename_file
= intern ("rename-file");
4495 Qadd_name_to_file
= intern ("add-name-to-file");
4496 Qmake_symbolic_link
= intern ("make-symbolic-link");
4497 Qfile_exists_p
= intern ("file-exists-p");
4498 Qfile_executable_p
= intern ("file-executable-p");
4499 Qfile_readable_p
= intern ("file-readable-p");
4500 Qfile_symlink_p
= intern ("file-symlink-p");
4501 Qfile_writable_p
= intern ("file-writable-p");
4502 Qfile_directory_p
= intern ("file-directory-p");
4503 Qfile_regular_p
= intern ("file-regular-p");
4504 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
4505 Qfile_modes
= intern ("file-modes");
4506 Qset_file_modes
= intern ("set-file-modes");
4507 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
4508 Qinsert_file_contents
= intern ("insert-file-contents");
4509 Qwrite_region
= intern ("write-region");
4510 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
4511 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
4513 staticpro (&Qexpand_file_name
);
4514 staticpro (&Qsubstitute_in_file_name
);
4515 staticpro (&Qdirectory_file_name
);
4516 staticpro (&Qfile_name_directory
);
4517 staticpro (&Qfile_name_nondirectory
);
4518 staticpro (&Qunhandled_file_name_directory
);
4519 staticpro (&Qfile_name_as_directory
);
4520 staticpro (&Qcopy_file
);
4521 staticpro (&Qmake_directory_internal
);
4522 staticpro (&Qdelete_directory
);
4523 staticpro (&Qdelete_file
);
4524 staticpro (&Qrename_file
);
4525 staticpro (&Qadd_name_to_file
);
4526 staticpro (&Qmake_symbolic_link
);
4527 staticpro (&Qfile_exists_p
);
4528 staticpro (&Qfile_executable_p
);
4529 staticpro (&Qfile_readable_p
);
4530 staticpro (&Qfile_symlink_p
);
4531 staticpro (&Qfile_writable_p
);
4532 staticpro (&Qfile_directory_p
);
4533 staticpro (&Qfile_regular_p
);
4534 staticpro (&Qfile_accessible_directory_p
);
4535 staticpro (&Qfile_modes
);
4536 staticpro (&Qset_file_modes
);
4537 staticpro (&Qfile_newer_than_file_p
);
4538 staticpro (&Qinsert_file_contents
);
4539 staticpro (&Qwrite_region
);
4540 staticpro (&Qverify_visited_file_modtime
);
4542 Qfile_name_history
= intern ("file-name-history");
4543 Fset (Qfile_name_history
, Qnil
);
4544 staticpro (&Qfile_name_history
);
4546 Qfile_error
= intern ("file-error");
4547 staticpro (&Qfile_error
);
4548 Qfile_already_exists
= intern ("file-already-exists");
4549 staticpro (&Qfile_already_exists
);
4552 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
4553 staticpro (&Qfind_buffer_file_type
);
4556 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format
,
4557 "*Format in which to write auto-save files.\n\
4558 Should be a list of symbols naming formats that are defined in `format-alist'.\n\
4559 If it is t, which is the default, auto-save files are written in the\n\
4560 same format as a regular save would use.");
4561 Vauto_save_file_format
= Qt
;
4563 Qformat_decode
= intern ("format-decode");
4564 staticpro (&Qformat_decode
);
4565 Qformat_annotate_function
= intern ("format-annotate-function");
4566 staticpro (&Qformat_annotate_function
);
4568 Qcar_less_than_car
= intern ("car-less-than-car");
4569 staticpro (&Qcar_less_than_car
);
4571 Fput (Qfile_error
, Qerror_conditions
,
4572 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
4573 Fput (Qfile_error
, Qerror_message
,
4574 build_string ("File error"));
4576 Fput (Qfile_already_exists
, Qerror_conditions
,
4577 Fcons (Qfile_already_exists
,
4578 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
4579 Fput (Qfile_already_exists
, Qerror_message
,
4580 build_string ("File already exists"));
4582 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
4583 "*Non-nil means when reading a filename start with default dir in minibuffer.");
4584 insert_default_directory
= 1;
4586 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
4587 "*Non-nil means write new files with record format `stmlf'.\n\
4588 nil means use format `var'. This variable is meaningful only on VMS.");
4589 vms_stmlf_recfm
= 0;
4591 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char
,
4592 "Directory separator character for built-in functions that return file names.\n\
4593 The value should be either ?/ or ?\\ (any other value is treated as ?\\).\n\
4594 This variable affects the built-in functions only on Windows,\n\
4595 on other platforms, it is initialized so that Lisp code can find out\n\
4596 what the normal separator is.");
4597 Vdirectory_sep_char
= '/';
4599 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
4600 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
4601 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
4604 The first argument given to HANDLER is the name of the I/O primitive\n\
4605 to be handled; the remaining arguments are the arguments that were\n\
4606 passed to that primitive. For example, if you do\n\
4607 (file-exists-p FILENAME)\n\
4608 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
4609 (funcall HANDLER 'file-exists-p FILENAME)\n\
4610 The function `find-file-name-handler' checks this list for a handler\n\
4611 for its argument.");
4612 Vfile_name_handler_alist
= Qnil
;
4614 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
4615 "A list of functions to be called at the end of `insert-file-contents'.\n\
4616 Each is passed one argument, the number of bytes inserted. It should return\n\
4617 the new byte count, and leave point the same. If `insert-file-contents' is\n\
4618 intercepted by a handler from `file-name-handler-alist', that handler is\n\
4619 responsible for calling the after-insert-file-functions if appropriate.");
4620 Vafter_insert_file_functions
= Qnil
;
4622 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
4623 "A list of functions to be called at the start of `write-region'.\n\
4624 Each is passed two arguments, START and END as for `write-region'.\n\
4625 These are usually two numbers but not always; see the documentation\n\
4626 for `write-region'. The function should return a list of pairs\n\
4627 of the form (POSITION . STRING), consisting of strings to be effectively\n\
4628 inserted at the specified positions of the file being written (1 means to\n\
4629 insert before the first byte written). The POSITIONs must be sorted into\n\
4630 increasing order. If there are several functions in the list, the several\n\
4631 lists are merged destructively.");
4632 Vwrite_region_annotate_functions
= Qnil
;
4634 DEFVAR_LISP ("write-region-annotations-so-far",
4635 &Vwrite_region_annotations_so_far
,
4636 "When an annotation function is called, this holds the previous annotations.\n\
4637 These are the annotations made by other annotation functions\n\
4638 that were already called. See also `write-region-annotate-functions'.");
4639 Vwrite_region_annotations_so_far
= Qnil
;
4641 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
4642 "A list of file name handlers that temporarily should not be used.\n\
4643 This applies only to the operation `inhibit-file-name-operation'.");
4644 Vinhibit_file_name_handlers
= Qnil
;
4646 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
4647 "The operation for which `inhibit-file-name-handlers' is applicable.");
4648 Vinhibit_file_name_operation
= Qnil
;
4650 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
4651 "File name in which we write a list of all auto save file names.\n\
4652 This variable is initialized automatically from `auto-save-list-file-prefix'\n\
4653 shortly after Emacs reads your `.emacs' file, if you have not yet given it\n\
4655 Vauto_save_list_file_name
= Qnil
;
4657 defsubr (&Sfind_file_name_handler
);
4658 defsubr (&Sfile_name_directory
);
4659 defsubr (&Sfile_name_nondirectory
);
4660 defsubr (&Sunhandled_file_name_directory
);
4661 defsubr (&Sfile_name_as_directory
);
4662 defsubr (&Sdirectory_file_name
);
4663 defsubr (&Smake_temp_name
);
4664 defsubr (&Sexpand_file_name
);
4665 defsubr (&Ssubstitute_in_file_name
);
4666 defsubr (&Scopy_file
);
4667 defsubr (&Smake_directory_internal
);
4668 defsubr (&Sdelete_directory
);
4669 defsubr (&Sdelete_file
);
4670 defsubr (&Srename_file
);
4671 defsubr (&Sadd_name_to_file
);
4673 defsubr (&Smake_symbolic_link
);
4674 #endif /* S_IFLNK */
4676 defsubr (&Sdefine_logical_name
);
4679 defsubr (&Ssysnetunam
);
4680 #endif /* HPUX_NET */
4681 defsubr (&Sfile_name_absolute_p
);
4682 defsubr (&Sfile_exists_p
);
4683 defsubr (&Sfile_executable_p
);
4684 defsubr (&Sfile_readable_p
);
4685 defsubr (&Sfile_writable_p
);
4686 defsubr (&Sfile_symlink_p
);
4687 defsubr (&Sfile_directory_p
);
4688 defsubr (&Sfile_accessible_directory_p
);
4689 defsubr (&Sfile_regular_p
);
4690 defsubr (&Sfile_modes
);
4691 defsubr (&Sset_file_modes
);
4692 defsubr (&Sset_default_file_modes
);
4693 defsubr (&Sdefault_file_modes
);
4694 defsubr (&Sfile_newer_than_file_p
);
4695 defsubr (&Sinsert_file_contents
);
4696 defsubr (&Swrite_region
);
4697 defsubr (&Scar_less_than_car
);
4698 defsubr (&Sverify_visited_file_modtime
);
4699 defsubr (&Sclear_visited_file_modtime
);
4700 defsubr (&Svisited_file_modtime
);
4701 defsubr (&Sset_visited_file_modtime
);
4702 defsubr (&Sdo_auto_save
);
4703 defsubr (&Sset_buffer_auto_saved
);
4704 defsubr (&Sclear_buffer_auto_save_failure
);
4705 defsubr (&Srecent_auto_save_p
);
4707 defsubr (&Sread_file_name_internal
);
4708 defsubr (&Sread_file_name
);
4711 defsubr (&Sunix_sync
);