1 /* File IO for GNU Emacs.
2 Copyright (C) 1985, 86, 87, 88, 93, 94, 95 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>
64 extern char *strerror ();
81 #include "intervals.h"
90 #endif /* not WINDOWSNT */
118 #define min(a, b) ((a) < (b) ? (a) : (b))
119 #define max(a, b) ((a) > (b) ? (a) : (b))
121 /* Nonzero during writing of auto-save files */
124 /* Set by auto_save_1 to mode of original file so Fwrite_region will create
125 a new file with the same mode as the original */
126 int auto_save_mode_bits
;
128 /* Alist of elements (REGEXP . HANDLER) for file names
129 whose I/O is done with a special handler. */
130 Lisp_Object Vfile_name_handler_alist
;
132 /* Format for auto-save files */
133 Lisp_Object Vauto_save_file_format
;
135 /* Lisp functions for translating file formats */
136 Lisp_Object Qformat_decode
, Qformat_annotate_function
;
138 /* Functions to be called to process text properties in inserted file. */
139 Lisp_Object Vafter_insert_file_functions
;
141 /* Functions to be called to create text property annotations for file. */
142 Lisp_Object Vwrite_region_annotate_functions
;
144 /* During build_annotations, each time an annotation function is called,
145 this holds the annotations made by the previous functions. */
146 Lisp_Object Vwrite_region_annotations_so_far
;
148 /* File name in which we write a list of all our auto save files. */
149 Lisp_Object Vauto_save_list_file_name
;
151 /* Nonzero means, when reading a filename in the minibuffer,
152 start out by inserting the default directory into the minibuffer. */
153 int insert_default_directory
;
155 /* On VMS, nonzero means write new files with record format stmlf.
156 Zero means use var format. */
159 /* These variables describe handlers that have "already" had a chance
160 to handle the current operation.
162 Vinhibit_file_name_handlers is a list of file name handlers.
163 Vinhibit_file_name_operation is the operation being handled.
164 If we try to handle that operation, we ignore those handlers. */
166 static Lisp_Object Vinhibit_file_name_handlers
;
167 static Lisp_Object Vinhibit_file_name_operation
;
169 Lisp_Object Qfile_error
, Qfile_already_exists
;
171 Lisp_Object Qfile_name_history
;
173 Lisp_Object Qcar_less_than_car
;
175 report_file_error (string
, data
)
179 Lisp_Object errstring
;
181 errstring
= build_string (strerror (errno
));
183 /* System error messages are capitalized. Downcase the initial
184 unless it is followed by a slash. */
185 if (XSTRING (errstring
)->data
[1] != '/')
186 XSTRING (errstring
)->data
[0] = DOWNCASE (XSTRING (errstring
)->data
[0]);
189 Fsignal (Qfile_error
,
190 Fcons (build_string (string
), Fcons (errstring
, data
)));
193 close_file_unwind (fd
)
196 close (XFASTINT (fd
));
199 /* Restore point, having saved it as a marker. */
201 restore_point_unwind (location
)
202 Lisp_Object location
;
204 SET_PT (marker_position (location
));
205 Fset_marker (location
, Qnil
, Qnil
);
208 Lisp_Object Qexpand_file_name
;
209 Lisp_Object Qsubstitute_in_file_name
;
210 Lisp_Object Qdirectory_file_name
;
211 Lisp_Object Qfile_name_directory
;
212 Lisp_Object Qfile_name_nondirectory
;
213 Lisp_Object Qunhandled_file_name_directory
;
214 Lisp_Object Qfile_name_as_directory
;
215 Lisp_Object Qcopy_file
;
216 Lisp_Object Qmake_directory_internal
;
217 Lisp_Object Qdelete_directory
;
218 Lisp_Object Qdelete_file
;
219 Lisp_Object Qrename_file
;
220 Lisp_Object Qadd_name_to_file
;
221 Lisp_Object Qmake_symbolic_link
;
222 Lisp_Object Qfile_exists_p
;
223 Lisp_Object Qfile_executable_p
;
224 Lisp_Object Qfile_readable_p
;
225 Lisp_Object Qfile_symlink_p
;
226 Lisp_Object Qfile_writable_p
;
227 Lisp_Object Qfile_directory_p
;
228 Lisp_Object Qfile_regular_p
;
229 Lisp_Object Qfile_accessible_directory_p
;
230 Lisp_Object Qfile_modes
;
231 Lisp_Object Qset_file_modes
;
232 Lisp_Object Qfile_newer_than_file_p
;
233 Lisp_Object Qinsert_file_contents
;
234 Lisp_Object Qwrite_region
;
235 Lisp_Object Qverify_visited_file_modtime
;
236 Lisp_Object Qset_visited_file_modtime
;
238 DEFUN ("find-file-name-handler", Ffind_file_name_handler
, Sfind_file_name_handler
, 2, 2, 0,
239 "Return FILENAME's handler function for OPERATION, if it has one.\n\
240 Otherwise, return nil.\n\
241 A file name is handled if one of the regular expressions in\n\
242 `file-name-handler-alist' matches it.\n\n\
243 If OPERATION equals `inhibit-file-name-operation', then we ignore\n\
244 any handlers that are members of `inhibit-file-name-handlers',\n\
245 but we still do run any other handlers. This lets handlers\n\
246 use the standard functions without calling themselves recursively.")
247 (filename
, operation
)
248 Lisp_Object filename
, operation
;
250 /* This function must not munge the match data. */
251 Lisp_Object chain
, inhibited_handlers
;
253 CHECK_STRING (filename
, 0);
255 if (EQ (operation
, Vinhibit_file_name_operation
))
256 inhibited_handlers
= Vinhibit_file_name_handlers
;
258 inhibited_handlers
= Qnil
;
260 for (chain
= Vfile_name_handler_alist
; CONSP (chain
);
261 chain
= XCONS (chain
)->cdr
)
264 elt
= XCONS (chain
)->car
;
268 string
= XCONS (elt
)->car
;
269 if (STRINGP (string
) && fast_string_match (string
, filename
) >= 0)
271 Lisp_Object handler
, tem
;
273 handler
= XCONS (elt
)->cdr
;
274 tem
= Fmemq (handler
, inhibited_handlers
);
285 DEFUN ("file-name-directory", Ffile_name_directory
, Sfile_name_directory
,
287 "Return the directory component in file name FILENAME.\n\
288 Return nil if FILENAME does not include a directory.\n\
289 Otherwise return a directory spec.\n\
290 Given a Unix syntax file name, returns a string ending in slash;\n\
291 on VMS, perhaps instead a string ending in `:', `]' or `>'.")
293 Lisp_Object filename
;
295 register unsigned char *beg
;
296 register unsigned char *p
;
299 CHECK_STRING (filename
, 0);
301 /* If the file name has special constructs in it,
302 call the corresponding file handler. */
303 handler
= Ffind_file_name_handler (filename
, Qfile_name_directory
);
305 return call2 (handler
, Qfile_name_directory
, filename
);
307 #ifdef FILE_SYSTEM_CASE
308 filename
= FILE_SYSTEM_CASE (filename
);
310 beg
= XSTRING (filename
)->data
;
311 p
= beg
+ XSTRING (filename
)->size
;
313 while (p
!= beg
&& !IS_ANY_SEP (p
[-1])
315 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
322 /* Expansion of "c:" to drive and default directory. */
323 /* (NT does the right thing.) */
324 if (p
== beg
+ 2 && beg
[1] == ':')
326 int drive
= (*beg
) - 'a';
327 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
328 unsigned char *res
= alloca (MAXPATHLEN
+ 5);
332 /* The NT version places the drive letter at the beginning already. */
333 #else /* not WINDOWSNT */
334 /* On MSDOG we must put the drive letter in by hand. */
336 #endif /* not WINDOWSNT */
337 if (getdefdir (drive
+ 1, res
))
340 res
[0] = drive
+ 'a';
343 if (IS_DIRECTORY_SEP (res
[strlen (res
) - 1]))
346 p
= beg
+ strlen (beg
);
350 return make_string (beg
, p
- beg
);
353 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory
, Sfile_name_nondirectory
,
355 "Return file name FILENAME sans its directory.\n\
356 For example, in a Unix-syntax file name,\n\
357 this is everything after the last slash,\n\
358 or the entire name if it contains no slash.")
360 Lisp_Object filename
;
362 register unsigned char *beg
, *p
, *end
;
365 CHECK_STRING (filename
, 0);
367 /* If the file name has special constructs in it,
368 call the corresponding file handler. */
369 handler
= Ffind_file_name_handler (filename
, Qfile_name_nondirectory
);
371 return call2 (handler
, Qfile_name_nondirectory
, filename
);
373 beg
= XSTRING (filename
)->data
;
374 end
= p
= beg
+ XSTRING (filename
)->size
;
376 while (p
!= beg
&& !IS_ANY_SEP (p
[-1])
378 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
382 return make_string (p
, end
- p
);
385 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory
, Sunhandled_file_name_directory
, 1, 1, 0,
386 "Return a directly usable directory name somehow associated with FILENAME.\n\
387 A `directly usable' directory name is one that may be used without the\n\
388 intervention of any file handler.\n\
389 If FILENAME is a directly usable file itself, return\n\
390 (file-name-directory FILENAME).\n\
391 The `call-process' and `start-process' functions use this function to\n\
392 get a current directory to run processes in.")
394 Lisp_Object filename
;
398 /* If the file name has special constructs in it,
399 call the corresponding file handler. */
400 handler
= Ffind_file_name_handler (filename
, Qunhandled_file_name_directory
);
402 return call2 (handler
, Qunhandled_file_name_directory
, filename
);
404 return Ffile_name_directory (filename
);
409 file_name_as_directory (out
, in
)
412 int size
= strlen (in
) - 1;
417 /* Is it already a directory string? */
418 if (in
[size
] == ':' || in
[size
] == ']' || in
[size
] == '>')
420 /* Is it a VMS directory file name? If so, hack VMS syntax. */
421 else if (! index (in
, '/')
422 && ((size
> 3 && ! strcmp (&in
[size
- 3], ".DIR"))
423 || (size
> 3 && ! strcmp (&in
[size
- 3], ".dir"))
424 || (size
> 5 && (! strncmp (&in
[size
- 5], ".DIR", 4)
425 || ! strncmp (&in
[size
- 5], ".dir", 4))
426 && (in
[size
- 1] == '.' || in
[size
- 1] == ';')
427 && in
[size
] == '1')))
429 register char *p
, *dot
;
433 dir:x.dir --> dir:[x]
434 dir:[x]y.dir --> dir:[x.y] */
436 while (p
!= in
&& *p
!= ':' && *p
!= '>' && *p
!= ']') p
--;
439 strncpy (out
, in
, p
- in
);
458 dot
= index (p
, '.');
461 /* blindly remove any extension */
462 size
= strlen (out
) + (dot
- p
);
463 strncat (out
, p
, dot
- p
);
474 /* For Unix syntax, Append a slash if necessary */
475 if (!IS_ANY_SEP (out
[size
]))
477 out
[size
+ 1] = DIRECTORY_SEP
;
478 out
[size
+ 2] = '\0';
484 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
485 Sfile_name_as_directory
, 1, 1, 0,
486 "Return a string representing file FILENAME interpreted as a directory.\n\
487 This operation exists because a directory is also a file, but its name as\n\
488 a directory is different from its name as a file.\n\
489 The result can be used as the value of `default-directory'\n\
490 or passed as second argument to `expand-file-name'.\n\
491 For a Unix-syntax file name, just appends a slash.\n\
492 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
499 CHECK_STRING (file
, 0);
503 /* If the file name has special constructs in it,
504 call the corresponding file handler. */
505 handler
= Ffind_file_name_handler (file
, Qfile_name_as_directory
);
507 return call2 (handler
, Qfile_name_as_directory
, file
);
509 buf
= (char *) alloca (XSTRING (file
)->size
+ 10);
510 return build_string (file_name_as_directory (buf
, XSTRING (file
)->data
));
514 * Convert from directory name to filename.
516 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
517 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
518 * On UNIX, it's simple: just make sure there is a terminating /
520 * Value is nonzero if the string output is different from the input.
523 directory_file_name (src
, dst
)
531 struct FAB fab
= cc$rms_fab
;
532 struct NAM nam
= cc$rms_nam
;
533 char esa
[NAM$C_MAXRSS
];
538 if (! index (src
, '/')
539 && (src
[slen
- 1] == ']'
540 || src
[slen
- 1] == ':'
541 || src
[slen
- 1] == '>'))
543 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
545 fab
.fab$b_fns
= slen
;
546 fab
.fab$l_nam
= &nam
;
547 fab
.fab$l_fop
= FAB$M_NAM
;
550 nam
.nam$b_ess
= sizeof esa
;
551 nam
.nam$b_nop
|= NAM$M_SYNCHK
;
553 /* We call SYS$PARSE to handle such things as [--] for us. */
554 if (SYS$
PARSE(&fab
, 0, 0) == RMS$_NORMAL
)
556 slen
= nam
.nam$b_esl
;
557 if (esa
[slen
- 1] == ';' && esa
[slen
- 2] == '.')
562 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
564 /* what about when we have logical_name:???? */
565 if (src
[slen
- 1] == ':')
566 { /* Xlate logical name and see what we get */
567 ptr
= strcpy (dst
, src
); /* upper case for getenv */
570 if ('a' <= *ptr
&& *ptr
<= 'z')
574 dst
[slen
- 1] = 0; /* remove colon */
575 if (!(src
= egetenv (dst
)))
577 /* should we jump to the beginning of this procedure?
578 Good points: allows us to use logical names that xlate
580 Bad points: can be a problem if we just translated to a device
582 For now, I'll punt and always expect VMS names, and hope for
585 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
586 { /* no recursion here! */
592 { /* not a directory spec */
597 bracket
= src
[slen
- 1];
599 /* If bracket is ']' or '>', bracket - 2 is the corresponding
601 ptr
= index (src
, bracket
- 2);
603 { /* no opening bracket */
607 if (!(rptr
= rindex (src
, '.')))
610 strncpy (dst
, src
, slen
);
614 dst
[slen
++] = bracket
;
619 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
620 then translate the device and recurse. */
621 if (dst
[slen
- 1] == ':'
622 && dst
[slen
- 2] != ':' /* skip decnet nodes */
623 && strcmp(src
+ slen
, "[000000]") == 0)
625 dst
[slen
- 1] = '\0';
626 if ((ptr
= egetenv (dst
))
627 && (rlen
= strlen (ptr
) - 1) > 0
628 && (ptr
[rlen
] == ']' || ptr
[rlen
] == '>')
629 && ptr
[rlen
- 1] == '.')
631 char * buf
= (char *) alloca (strlen (ptr
) + 1);
635 return directory_file_name (buf
, dst
);
640 strcat (dst
, "[000000]");
644 rlen
= strlen (rptr
) - 1;
645 strncat (dst
, rptr
, rlen
);
646 dst
[slen
+ rlen
] = '\0';
647 strcat (dst
, ".DIR.1");
651 /* Process as Unix format: just remove any final slash.
652 But leave "/" unchanged; do not change it to "". */
655 /* Handle // as root for apollo's. */
656 if ((slen
> 2 && dst
[slen
- 1] == '/')
657 || (slen
> 1 && dst
[0] != '/' && dst
[slen
- 1] == '/'))
661 && IS_DIRECTORY_SEP (dst
[slen
- 1])
663 && !IS_ANY_SEP (dst
[slen
- 2])
671 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
673 "Returns the file name of the directory named DIRECTORY.\n\
674 This is the name of the file that holds the data for the directory DIRECTORY.\n\
675 This operation exists because a directory is also a file, but its name as\n\
676 a directory is different from its name as a file.\n\
677 In Unix-syntax, this function just removes the final slash.\n\
678 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
679 it returns a file name such as \"[X]Y.DIR.1\".")
681 Lisp_Object directory
;
686 CHECK_STRING (directory
, 0);
688 if (NILP (directory
))
691 /* If the file name has special constructs in it,
692 call the corresponding file handler. */
693 handler
= Ffind_file_name_handler (directory
, Qdirectory_file_name
);
695 return call2 (handler
, Qdirectory_file_name
, directory
);
698 /* 20 extra chars is insufficient for VMS, since we might perform a
699 logical name translation. an equivalence string can be up to 255
700 chars long, so grab that much extra space... - sss */
701 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20 + 255);
703 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20);
705 directory_file_name (XSTRING (directory
)->data
, buf
);
706 return build_string (buf
);
709 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
710 "Generate temporary file name (string) starting with PREFIX (a string).\n\
711 The Emacs process number forms part of the result,\n\
712 so there is no danger of generating a name being used by another process.")
718 /* Don't use too many characters of the restricted 8+3 DOS
720 val
= concat2 (prefix
, build_string ("a.XXX"));
722 val
= concat2 (prefix
, build_string ("XXXXXX"));
724 mktemp (XSTRING (val
)->data
);
728 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
729 "Convert filename NAME to absolute, and canonicalize it.\n\
730 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative\n\
731 (does not start with slash); if DEFAULT-DIRECTORY is nil or missing,\n\
732 the current buffer's value of default-directory is used.\n\
733 Path components that are `.' are removed, and \n\
734 path components followed by `..' are removed, along with the `..' itself;\n\
735 note that these simplifications are done without checking the resulting\n\
736 paths in the file system.\n\
737 An initial `~/' expands to your home directory.\n\
738 An initial `~USER/' expands to USER's home directory.\n\
739 See also the function `substitute-in-file-name'.")
740 (name
, default_directory
)
741 Lisp_Object name
, default_directory
;
745 register unsigned char *newdir
, *p
, *o
;
747 unsigned char *target
;
750 unsigned char * colon
= 0;
751 unsigned char * close
= 0;
752 unsigned char * slash
= 0;
753 unsigned char * brack
= 0;
754 int lbrack
= 0, rbrack
= 0;
758 /* Demacs 1.1.2 91/10/20 Manabu Higashida */
761 unsigned char *tmp
, *defdir
;
765 CHECK_STRING (name
, 0);
767 /* If the file name has special constructs in it,
768 call the corresponding file handler. */
769 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
771 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
773 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
774 if (NILP (default_directory
))
775 default_directory
= current_buffer
->directory
;
776 CHECK_STRING (default_directory
, 1);
778 if (!NILP (default_directory
))
780 handler
= Ffind_file_name_handler (default_directory
, Qexpand_file_name
);
782 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
785 o
= XSTRING (default_directory
)->data
;
787 /* Make sure DEFAULT_DIRECTORY is properly expanded.
788 It would be better to do this down below where we actually use
789 default_directory. Unfortunately, calling Fexpand_file_name recursively
790 could invoke GC, and the strings might be relocated. This would
791 be annoying because we have pointers into strings lying around
792 that would need adjusting, and people would add new pointers to
793 the code and forget to adjust them, resulting in intermittent bugs.
794 Putting this call here avoids all that crud.
796 The EQ test avoids infinite recursion. */
797 if (! NILP (default_directory
) && !EQ (default_directory
, name
)
798 /* Save time in some common cases. */
800 /* Detect MSDOS file names with device names. */
801 && ! (XSTRING (default_directory
)->size
>= 3
802 && IS_DEVICE_SEP (o
[1]) && IS_DIRECTORY_SEP (o
[2]))
804 /* Detect Unix absolute file names. */
805 && ! (XSTRING (default_directory
)->size
>= 2
806 && IS_DIRECTORY_SEP (o
[0])))
811 default_directory
= Fexpand_file_name (default_directory
, Qnil
);
816 /* Filenames on VMS are always upper case. */
817 name
= Fupcase (name
);
819 #ifdef FILE_SYSTEM_CASE
820 name
= FILE_SYSTEM_CASE (name
);
823 nm
= XSTRING (name
)->data
;
826 /* First map all backslashes to slashes. */
827 dostounix_filename (nm
= strcpy (alloca (strlen (nm
) + 1), nm
));
831 /* Now strip drive name. */
833 unsigned char *colon
= rindex (nm
, ':');
841 if (!IS_DIRECTORY_SEP (*nm
))
843 defdir
= alloca (MAXPATHLEN
+ 1);
844 relpath
= getdefdir (tolower (drive
) - 'a' + 1, defdir
);
850 /* Handle // and /~ in middle of file name
851 by discarding everything through the first / of that sequence. */
855 /* Since we know the path is absolute, we can assume that each
856 element starts with a "/". */
858 /* "//" anywhere isn't necessarily hairy; we just start afresh
859 with the second slash. */
860 if (IS_DIRECTORY_SEP (p
[0]) && IS_DIRECTORY_SEP (p
[1])
861 #if defined (APOLLO) || defined (WINDOWSNT)
862 /* // at start of filename is meaningful on Apollo
863 and WindowsNT systems */
865 #endif /* APOLLO || WINDOWSNT */
869 /* "~" is hairy as the start of any path element. */
870 if (IS_DIRECTORY_SEP (p
[0]) && p
[1] == '~')
876 /* If nm is absolute, flush ...// and detect /./ and /../.
877 If no /./ or /../ we can return right away. */
879 IS_DIRECTORY_SEP (nm
[0])
885 /* If it turns out that the filename we want to return is just a
886 suffix of FILENAME, we don't need to go through and edit
887 things; we just need to construct a new string using data
888 starting at the middle of FILENAME. If we set lose to a
889 non-zero value, that means we've discovered that we can't do
896 /* Since we know the path is absolute, we can assume that each
897 element starts with a "/". */
899 /* "." and ".." are hairy. */
900 if (IS_DIRECTORY_SEP (p
[0])
902 && (IS_DIRECTORY_SEP (p
[2])
904 || (p
[2] == '.' && (IS_DIRECTORY_SEP (p
[3])
911 /* if dev:[dir]/, move nm to / */
912 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
913 nm
= (brack
? brack
+ 1 : colon
+ 1);
922 /* VMS pre V4.4,convert '-'s in filenames. */
923 if (lbrack
== rbrack
)
925 if (dots
< 2) /* this is to allow negative version numbers */
930 if (lbrack
> rbrack
&&
931 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
932 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
938 /* count open brackets, reset close bracket pointer */
939 if (p
[0] == '[' || p
[0] == '<')
941 /* count close brackets, set close bracket pointer */
942 if (p
[0] == ']' || p
[0] == '>')
944 /* detect ][ or >< */
945 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
947 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
948 nm
= p
+ 1, lose
= 1;
949 if (p
[0] == ':' && (colon
|| slash
))
950 /* if dev1:[dir]dev2:, move nm to dev2: */
956 /* if /pathname/dev:, move nm to dev: */
959 /* if node::dev:, move colon following dev */
960 else if (colon
&& colon
[-1] == ':')
962 /* if dev1:dev2:, move nm to dev2: */
963 else if (colon
&& colon
[-1] != ':')
968 if (p
[0] == ':' && !colon
)
974 if (lbrack
== rbrack
)
977 else if (p
[0] == '.')
986 return build_string (sys_translate_unix (nm
));
989 if (nm
== XSTRING (name
)->data
)
991 return build_string (nm
);
992 #endif /* not DOS_NT */
996 /* Now determine directory to start with and put it in newdir */
1000 if (nm
[0] == '~') /* prefix ~ */
1002 if (IS_DIRECTORY_SEP (nm
[1])
1006 || nm
[1] == 0) /* ~ by itself */
1008 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1009 newdir
= (unsigned char *) "";
1011 /* Problem when expanding "~\" if HOME is not on current drive.
1012 Ulrich Leodolter, Wed Jan 11 10:20:35 1995 */
1013 if (newdir
[1] == ':')
1015 dostounix_filename (newdir
);
1019 nm
++; /* Don't leave the slash in nm. */
1022 else /* ~user/filename */
1024 for (p
= nm
; *p
&& (!IS_DIRECTORY_SEP (*p
)
1029 o
= (unsigned char *) alloca (p
- nm
+ 1);
1030 bcopy ((char *) nm
, o
, p
- nm
);
1034 newdir
= (unsigned char *) egetenv ("HOME");
1035 dostounix_filename (newdir
);
1036 #else /* not WINDOWSNT */
1037 pw
= (struct passwd
*) getpwnam (o
+ 1);
1040 newdir
= (unsigned char *) pw
-> pw_dir
;
1042 nm
= p
+ 1; /* skip the terminator */
1047 #endif /* not WINDOWSNT */
1049 /* If we don't find a user of that name, leave the name
1050 unchanged; don't move nm forward to p. */
1054 if (!IS_ANY_SEP (nm
[0])
1057 #endif /* not VMS */
1063 newdir
= XSTRING (default_directory
)->data
;
1067 if (newdir
== 0 && relpath
)
1072 /* Get rid of any slash at the end of newdir. */
1073 int length
= strlen (newdir
);
1074 /* Adding `length > 1 &&' makes ~ expand into / when homedir
1075 is the root dir. People disagree about whether that is right.
1076 Anyway, we can't take the risk of this change now. */
1078 if (newdir
[1] != ':' && length
> 1)
1080 if (IS_DIRECTORY_SEP (newdir
[length
- 1]))
1082 unsigned char *temp
= (unsigned char *) alloca (length
);
1083 bcopy (newdir
, temp
, length
- 1);
1084 temp
[length
- 1] = 0;
1092 /* Now concatenate the directory and name to new space in the stack frame */
1093 tlen
+= strlen (nm
) + 1;
1095 /* Add reserved space for drive name. (The Microsoft x86 compiler
1096 produces incorrect code if the following two lines are combined.) */
1097 target
= (unsigned char *) alloca (tlen
+ 2);
1099 #else /* not DOS_NT */
1100 target
= (unsigned char *) alloca (tlen
);
1101 #endif /* not DOS_NT */
1107 if (nm
[0] == 0 || IS_DIRECTORY_SEP (nm
[0]))
1108 strcpy (target
, newdir
);
1111 file_name_as_directory (target
, newdir
);
1114 strcat (target
, nm
);
1116 if (index (target
, '/'))
1117 strcpy (target
, sys_translate_unix (target
));
1120 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1128 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1134 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1135 /* brackets are offset from each other by 2 */
1138 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1139 /* convert [foo][bar] to [bar] */
1140 while (o
[-1] != '[' && o
[-1] != '<')
1142 else if (*p
== '-' && *o
!= '.')
1145 else if (p
[0] == '-' && o
[-1] == '.' &&
1146 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1147 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1151 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1152 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1154 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1156 /* else [foo.-] ==> [-] */
1162 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1163 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1169 if (!IS_DIRECTORY_SEP (*p
))
1173 else if (IS_DIRECTORY_SEP (p
[0]) && IS_DIRECTORY_SEP (p
[1])
1174 #if defined (APOLLO) || defined (WINDOWSNT)
1175 /* // at start of filename is meaningful in Apollo
1176 and WindowsNT systems */
1184 else if (IS_DIRECTORY_SEP (p
[0])
1186 && (IS_DIRECTORY_SEP (p
[2])
1189 /* If "/." is the entire filename, keep the "/". Otherwise,
1190 just delete the whole "/.". */
1191 if (o
== target
&& p
[2] == '\0')
1195 else if (IS_DIRECTORY_SEP (p
[0]) && p
[1] == '.' && p
[2] == '.'
1196 /* `/../' is the "superroot" on certain file systems. */
1198 && (IS_DIRECTORY_SEP (p
[3]) || p
[3] == 0))
1200 while (o
!= target
&& (--o
) && !IS_DIRECTORY_SEP (*o
))
1202 #if defined (APOLLO) || defined (WINDOWSNT)
1204 && IS_DIRECTORY_SEP (o
[-1]) && IS_DIRECTORY_SEP (o
[0]))
1207 #endif /* APOLLO || WINDOWSNT */
1208 if (o
== target
&& IS_ANY_SEP (*o
))
1216 #endif /* not VMS */
1220 /* at last, set drive name. */
1221 if (target
[1] != ':'
1223 /* Allow network paths that look like "\\foo" */
1224 && !(IS_DIRECTORY_SEP (target
[0]) && IS_DIRECTORY_SEP (target
[1]))
1225 #endif /* WINDOWSNT */
1229 target
[0] = (drive
< 0 ? getdisk () + 'A' : drive
);
1234 return make_string (target
, o
- target
);
1238 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'. */
1239 DEAFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
1240 "Convert FILENAME to absolute, and canonicalize it.\n\
1241 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1242 (does not start with slash); if DEFAULT is nil or missing,\n\
1243 the current buffer's value of default-directory is used.\n\
1244 Filenames containing `.' or `..' as components are simplified;\n\
1245 initial `~/' expands to your home directory.\n\
1246 See also the function `substitute-in-file-name'.")
1248 Lisp_Object name
, defalt
;
1252 register unsigned char *newdir
, *p
, *o
;
1254 unsigned char *target
;
1258 unsigned char * colon
= 0;
1259 unsigned char * close
= 0;
1260 unsigned char * slash
= 0;
1261 unsigned char * brack
= 0;
1262 int lbrack
= 0, rbrack
= 0;
1266 CHECK_STRING (name
, 0);
1269 /* Filenames on VMS are always upper case. */
1270 name
= Fupcase (name
);
1273 nm
= XSTRING (name
)->data
;
1275 /* If nm is absolute, flush ...// and detect /./ and /../.
1276 If no /./ or /../ we can return right away. */
1288 if (p
[0] == '/' && p
[1] == '/'
1290 /* // at start of filename is meaningful on Apollo system */
1295 if (p
[0] == '/' && p
[1] == '~')
1296 nm
= p
+ 1, lose
= 1;
1297 if (p
[0] == '/' && p
[1] == '.'
1298 && (p
[2] == '/' || p
[2] == 0
1299 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1305 /* if dev:[dir]/, move nm to / */
1306 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1307 nm
= (brack
? brack
+ 1 : colon
+ 1);
1308 lbrack
= rbrack
= 0;
1316 /* VMS pre V4.4,convert '-'s in filenames. */
1317 if (lbrack
== rbrack
)
1319 if (dots
< 2) /* this is to allow negative version numbers */
1324 if (lbrack
> rbrack
&&
1325 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1326 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1332 /* count open brackets, reset close bracket pointer */
1333 if (p
[0] == '[' || p
[0] == '<')
1334 lbrack
++, brack
= 0;
1335 /* count close brackets, set close bracket pointer */
1336 if (p
[0] == ']' || p
[0] == '>')
1337 rbrack
++, brack
= p
;
1338 /* detect ][ or >< */
1339 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1341 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1342 nm
= p
+ 1, lose
= 1;
1343 if (p
[0] == ':' && (colon
|| slash
))
1344 /* if dev1:[dir]dev2:, move nm to dev2: */
1350 /* if /pathname/dev:, move nm to dev: */
1353 /* if node::dev:, move colon following dev */
1354 else if (colon
&& colon
[-1] == ':')
1356 /* if dev1:dev2:, move nm to dev2: */
1357 else if (colon
&& colon
[-1] != ':')
1362 if (p
[0] == ':' && !colon
)
1368 if (lbrack
== rbrack
)
1371 else if (p
[0] == '.')
1379 if (index (nm
, '/'))
1380 return build_string (sys_translate_unix (nm
));
1382 if (nm
== XSTRING (name
)->data
)
1384 return build_string (nm
);
1388 /* Now determine directory to start with and put it in NEWDIR */
1392 if (nm
[0] == '~') /* prefix ~ */
1397 || nm
[1] == 0)/* ~/filename */
1399 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1400 newdir
= (unsigned char *) "";
1403 nm
++; /* Don't leave the slash in nm. */
1406 else /* ~user/filename */
1408 /* Get past ~ to user */
1409 unsigned char *user
= nm
+ 1;
1410 /* Find end of name. */
1411 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1412 int len
= ptr
? ptr
- user
: strlen (user
);
1414 unsigned char *ptr1
= index (user
, ':');
1415 if (ptr1
!= 0 && ptr1
- user
< len
)
1418 /* Copy the user name into temp storage. */
1419 o
= (unsigned char *) alloca (len
+ 1);
1420 bcopy ((char *) user
, o
, len
);
1423 /* Look up the user name. */
1424 pw
= (struct passwd
*) getpwnam (o
+ 1);
1426 error ("\"%s\" isn't a registered user", o
+ 1);
1428 newdir
= (unsigned char *) pw
->pw_dir
;
1430 /* Discard the user name from NM. */
1437 #endif /* not VMS */
1441 defalt
= current_buffer
->directory
;
1442 CHECK_STRING (defalt
, 1);
1443 newdir
= XSTRING (defalt
)->data
;
1446 /* Now concatenate the directory and name to new space in the stack frame */
1448 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1449 target
= (unsigned char *) alloca (tlen
);
1455 if (nm
[0] == 0 || nm
[0] == '/')
1456 strcpy (target
, newdir
);
1459 file_name_as_directory (target
, newdir
);
1462 strcat (target
, nm
);
1464 if (index (target
, '/'))
1465 strcpy (target
, sys_translate_unix (target
));
1468 /* Now canonicalize by removing /. and /foo/.. if they appear */
1476 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1482 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1483 /* brackets are offset from each other by 2 */
1486 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1487 /* convert [foo][bar] to [bar] */
1488 while (o
[-1] != '[' && o
[-1] != '<')
1490 else if (*p
== '-' && *o
!= '.')
1493 else if (p
[0] == '-' && o
[-1] == '.' &&
1494 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1495 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1499 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1500 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1502 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1504 /* else [foo.-] ==> [-] */
1510 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1511 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1521 else if (!strncmp (p
, "//", 2)
1523 /* // at start of filename is meaningful in Apollo system */
1531 else if (p
[0] == '/' && p
[1] == '.' &&
1532 (p
[2] == '/' || p
[2] == 0))
1534 else if (!strncmp (p
, "/..", 3)
1535 /* `/../' is the "superroot" on certain file systems. */
1537 && (p
[3] == '/' || p
[3] == 0))
1539 while (o
!= target
&& *--o
!= '/')
1542 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1546 if (o
== target
&& *o
== '/')
1554 #endif /* not VMS */
1557 return make_string (target
, o
- target
);
1561 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1562 Ssubstitute_in_file_name
, 1, 1, 0,
1563 "Substitute environment variables referred to in FILENAME.\n\
1564 `$FOO' where FOO is an environment variable name means to substitute\n\
1565 the value of that variable. The variable name should be terminated\n\
1566 with a character not a letter, digit or underscore; otherwise, enclose\n\
1567 the entire variable name in braces.\n\
1568 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1569 On VMS, `$' substitution is not done; this function does little and only\n\
1570 duplicates what `expand-file-name' does.")
1572 Lisp_Object filename
;
1576 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1577 unsigned char *target
;
1579 int substituted
= 0;
1581 Lisp_Object handler
;
1583 CHECK_STRING (filename
, 0);
1585 /* If the file name has special constructs in it,
1586 call the corresponding file handler. */
1587 handler
= Ffind_file_name_handler (filename
, Qsubstitute_in_file_name
);
1588 if (!NILP (handler
))
1589 return call2 (handler
, Qsubstitute_in_file_name
, filename
);
1591 nm
= XSTRING (filename
)->data
;
1593 dostounix_filename (nm
= strcpy (alloca (strlen (nm
) + 1), nm
));
1594 substituted
= !strcmp (nm
, XSTRING (filename
)->data
);
1596 endp
= nm
+ XSTRING (filename
)->size
;
1598 /* If /~ or // appears, discard everything through first slash. */
1600 for (p
= nm
; p
!= endp
; p
++)
1604 /* // at start of file name is meaningful in Apollo system */
1605 (p
[0] == '/' && p
- 1 != nm
)
1606 #else /* not APOLLO */
1608 (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != nm
)
1609 #else /* not WINDOWSNT */
1611 #endif /* not WINDOWSNT */
1612 #endif /* not APOLLO */
1617 || p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>'
1619 || IS_DIRECTORY_SEP (p
[-1])))
1625 if (p
[0] && p
[1] == ':')
1634 return build_string (nm
);
1637 /* See if any variables are substituted into the string
1638 and find the total length of their values in `total' */
1640 for (p
= nm
; p
!= endp
;)
1650 /* "$$" means a single "$" */
1659 while (p
!= endp
&& *p
!= '}') p
++;
1660 if (*p
!= '}') goto missingclose
;
1666 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1670 /* Copy out the variable name */
1671 target
= (unsigned char *) alloca (s
- o
+ 1);
1672 strncpy (target
, o
, s
- o
);
1675 strupr (target
); /* $home == $HOME etc. */
1678 /* Get variable value */
1679 o
= (unsigned char *) egetenv (target
);
1680 if (!o
) goto badvar
;
1681 total
+= strlen (o
);
1688 /* If substitution required, recopy the string and do it */
1689 /* Make space in stack frame for the new copy */
1690 xnm
= (unsigned char *) alloca (XSTRING (filename
)->size
+ total
+ 1);
1693 /* Copy the rest of the name through, replacing $ constructs with values */
1710 while (p
!= endp
&& *p
!= '}') p
++;
1711 if (*p
!= '}') goto missingclose
;
1717 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1721 /* Copy out the variable name */
1722 target
= (unsigned char *) alloca (s
- o
+ 1);
1723 strncpy (target
, o
, s
- o
);
1726 strupr (target
); /* $home == $HOME etc. */
1729 /* Get variable value */
1730 o
= (unsigned char *) egetenv (target
);
1740 /* If /~ or // appears, discard everything through first slash. */
1742 for (p
= xnm
; p
!= x
; p
++)
1745 /* // at start of file name is meaningful in Apollo system */
1746 || (p
[0] == '/' && p
- 1 != xnm
)
1747 #else /* not APOLLO */
1749 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != xnm
)
1750 #else /* not WINDOWSNT */
1752 #endif /* not WINDOWSNT */
1753 #endif /* not APOLLO */
1755 && p
!= nm
&& IS_DIRECTORY_SEP (p
[-1]))
1758 else if (p
[0] && p
[1] == ':')
1762 return make_string (xnm
, x
- xnm
);
1765 error ("Bad format environment-variable substitution");
1767 error ("Missing \"}\" in environment-variable substitution");
1769 error ("Substituting nonexistent environment variable \"%s\"", target
);
1772 #endif /* not VMS */
1775 /* A slightly faster and more convenient way to get
1776 (directory-file-name (expand-file-name FOO)). */
1779 expand_and_dir_to_file (filename
, defdir
)
1780 Lisp_Object filename
, defdir
;
1782 register Lisp_Object abspath
;
1784 abspath
= Fexpand_file_name (filename
, defdir
);
1787 register int c
= XSTRING (abspath
)->data
[XSTRING (abspath
)->size
- 1];
1788 if (c
== ':' || c
== ']' || c
== '>')
1789 abspath
= Fdirectory_file_name (abspath
);
1792 /* Remove final slash, if any (unless path is root).
1793 stat behaves differently depending! */
1794 if (XSTRING (abspath
)->size
> 1
1795 && IS_DIRECTORY_SEP (XSTRING (abspath
)->data
[XSTRING (abspath
)->size
- 1])
1796 && !IS_DEVICE_SEP (XSTRING (abspath
)->data
[XSTRING (abspath
)->size
-2]))
1797 /* We cannot take shortcuts; they might be wrong for magic file names. */
1798 abspath
= Fdirectory_file_name (abspath
);
1803 /* Signal an error if the file ABSNAME already exists.
1804 If INTERACTIVE is nonzero, ask the user whether to proceed,
1805 and bypass the error if the user says to go ahead.
1806 QUERYSTRING is a name for the action that is being considered
1808 *STATPTR is used to store the stat information if the file exists.
1809 If the file does not exist, STATPTR->st_mode is set to 0. */
1812 barf_or_query_if_file_exists (absname
, querystring
, interactive
, statptr
)
1813 Lisp_Object absname
;
1814 unsigned char *querystring
;
1816 struct stat
*statptr
;
1818 register Lisp_Object tem
;
1819 struct stat statbuf
;
1820 struct gcpro gcpro1
;
1822 /* stat is a good way to tell whether the file exists,
1823 regardless of what access permissions it has. */
1824 if (stat (XSTRING (absname
)->data
, &statbuf
) >= 0)
1827 Fsignal (Qfile_already_exists
,
1828 Fcons (build_string ("File already exists"),
1829 Fcons (absname
, Qnil
)));
1831 tem
= do_yes_or_no_p (format1 ("File %s already exists; %s anyway? ",
1832 XSTRING (absname
)->data
, querystring
));
1835 Fsignal (Qfile_already_exists
,
1836 Fcons (build_string ("File already exists"),
1837 Fcons (absname
, Qnil
)));
1844 statptr
->st_mode
= 0;
1849 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
1850 "fCopy file: \nFCopy %s to file: \np\nP",
1851 "Copy FILE to NEWNAME. Both args must be strings.\n\
1852 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
1853 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
1854 A number as third arg means request confirmation if NEWNAME already exists.\n\
1855 This is what happens in interactive use with M-x.\n\
1856 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
1857 last-modified time as the old one. (This works on only some systems.)\n\
1858 A prefix arg makes KEEP-TIME non-nil.")
1859 (file
, newname
, ok_if_already_exists
, keep_date
)
1860 Lisp_Object file
, newname
, ok_if_already_exists
, keep_date
;
1863 char buf
[16 * 1024];
1864 struct stat st
, out_st
;
1865 Lisp_Object handler
;
1866 struct gcpro gcpro1
, gcpro2
;
1867 int count
= specpdl_ptr
- specpdl
;
1868 int input_file_statable_p
;
1870 GCPRO2 (file
, newname
);
1871 CHECK_STRING (file
, 0);
1872 CHECK_STRING (newname
, 1);
1873 file
= Fexpand_file_name (file
, Qnil
);
1874 newname
= Fexpand_file_name (newname
, Qnil
);
1876 /* If the input file name has special constructs in it,
1877 call the corresponding file handler. */
1878 handler
= Ffind_file_name_handler (file
, Qcopy_file
);
1879 /* Likewise for output file name. */
1881 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
1882 if (!NILP (handler
))
1883 RETURN_UNGCPRO (call5 (handler
, Qcopy_file
, file
, newname
,
1884 ok_if_already_exists
, keep_date
));
1886 if (NILP (ok_if_already_exists
)
1887 || INTEGERP (ok_if_already_exists
))
1888 barf_or_query_if_file_exists (newname
, "copy to it",
1889 INTEGERP (ok_if_already_exists
), &out_st
);
1890 else if (stat (XSTRING (newname
)->data
, &out_st
) < 0)
1893 ifd
= open (XSTRING (file
)->data
, O_RDONLY
);
1895 report_file_error ("Opening input file", Fcons (file
, Qnil
));
1897 record_unwind_protect (close_file_unwind
, make_number (ifd
));
1899 /* We can only copy regular files and symbolic links. Other files are not
1901 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
1904 if (out_st
.st_mode
!= 0
1905 && st
.st_dev
== out_st
.st_dev
&& st
.st_ino
== out_st
.st_ino
)
1908 report_file_error ("Input and output files are the same",
1909 Fcons (file
, Fcons (newname
, Qnil
)));
1913 #if defined (S_ISREG) && defined (S_ISLNK)
1914 if (input_file_statable_p
)
1916 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
1918 #if defined (EISDIR)
1919 /* Get a better looking error message. */
1922 report_file_error ("Non-regular file", Fcons (file
, Qnil
));
1925 #endif /* S_ISREG && S_ISLNK */
1928 /* Create the copy file with the same record format as the input file */
1929 ofd
= sys_creat (XSTRING (newname
)->data
, 0666, ifd
);
1932 /* System's default file type was set to binary by _fmode in emacs.c. */
1933 ofd
= creat (XSTRING (newname
)->data
, S_IREAD
| S_IWRITE
);
1934 #else /* not MSDOS */
1935 ofd
= creat (XSTRING (newname
)->data
, 0666);
1936 #endif /* not MSDOS */
1939 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
1941 record_unwind_protect (close_file_unwind
, make_number (ofd
));
1945 while ((n
= read (ifd
, buf
, sizeof buf
)) > 0)
1946 if (write (ofd
, buf
, n
) != n
)
1947 report_file_error ("I/O error", Fcons (newname
, Qnil
));
1950 /* Closing the output clobbers the file times on some systems. */
1951 if (close (ofd
) < 0)
1952 report_file_error ("I/O error", Fcons (newname
, Qnil
));
1954 if (input_file_statable_p
)
1956 if (!NILP (keep_date
))
1958 EMACS_TIME atime
, mtime
;
1959 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
1960 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
1961 if (set_file_times (XSTRING (newname
)->data
, atime
, mtime
))
1962 report_file_error ("I/O error", Fcons (newname
, Qnil
));
1965 chmod (XSTRING (newname
)->data
, st
.st_mode
& 07777);
1967 #if defined (__DJGPP__) && __DJGPP__ > 1
1968 /* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
1969 and if it can't, it tells so. Otherwise, under MSDOS we usually
1970 get only the READ bit, which will make the copied file read-only,
1971 so it's better not to chmod at all. */
1972 if ((_djstat_flags
& _STFAIL_WRITEBIT
) == 0)
1973 chmod (XSTRING (newname
)->data
, st
.st_mode
& 07777);
1974 #endif /* DJGPP version 2 or newer */
1980 /* Discard the unwind protects. */
1981 specpdl_ptr
= specpdl
+ count
;
1987 DEFUN ("make-directory-internal", Fmake_directory_internal
,
1988 Smake_directory_internal
, 1, 1, 0,
1989 "Create a new directory named DIRECTORY.")
1991 Lisp_Object directory
;
1994 Lisp_Object handler
;
1996 CHECK_STRING (directory
, 0);
1997 directory
= Fexpand_file_name (directory
, Qnil
);
1999 handler
= Ffind_file_name_handler (directory
, Qmake_directory_internal
);
2000 if (!NILP (handler
))
2001 return call2 (handler
, Qmake_directory_internal
, directory
);
2003 dir
= XSTRING (directory
)->data
;
2006 if (mkdir (dir
) != 0)
2008 if (mkdir (dir
, 0777) != 0)
2010 report_file_error ("Creating directory", Flist (1, &directory
));
2015 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
2016 "Delete the directory named DIRECTORY.")
2018 Lisp_Object directory
;
2021 Lisp_Object handler
;
2023 CHECK_STRING (directory
, 0);
2024 directory
= Fdirectory_file_name (Fexpand_file_name (directory
, Qnil
));
2025 dir
= XSTRING (directory
)->data
;
2027 handler
= Ffind_file_name_handler (directory
, Qdelete_directory
);
2028 if (!NILP (handler
))
2029 return call2 (handler
, Qdelete_directory
, directory
);
2031 if (rmdir (dir
) != 0)
2032 report_file_error ("Removing directory", Flist (1, &directory
));
2037 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
2038 "Delete file named FILENAME.\n\
2039 If file has multiple names, it continues to exist with the other names.")
2041 Lisp_Object filename
;
2043 Lisp_Object handler
;
2044 CHECK_STRING (filename
, 0);
2045 filename
= Fexpand_file_name (filename
, Qnil
);
2047 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
2048 if (!NILP (handler
))
2049 return call2 (handler
, Qdelete_file
, filename
);
2051 if (0 > unlink (XSTRING (filename
)->data
))
2052 report_file_error ("Removing old name", Flist (1, &filename
));
2057 internal_delete_file_1 (ignore
)
2063 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */
2066 internal_delete_file (filename
)
2067 Lisp_Object filename
;
2069 return NILP (internal_condition_case_1 (Fdelete_file
, filename
,
2070 Qt
, internal_delete_file_1
));
2073 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
2074 "fRename file: \nFRename %s to file: \np",
2075 "Rename FILE as NEWNAME. Both args strings.\n\
2076 If file has names other than FILE, it continues to have those names.\n\
2077 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2078 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2079 A number as third arg means request confirmation if NEWNAME already exists.\n\
2080 This is what happens in interactive use with M-x.")
2081 (file
, newname
, ok_if_already_exists
)
2082 Lisp_Object file
, newname
, ok_if_already_exists
;
2085 Lisp_Object args
[2];
2087 Lisp_Object handler
;
2088 struct gcpro gcpro1
, gcpro2
;
2090 GCPRO2 (file
, newname
);
2091 CHECK_STRING (file
, 0);
2092 CHECK_STRING (newname
, 1);
2093 file
= Fexpand_file_name (file
, Qnil
);
2094 newname
= Fexpand_file_name (newname
, Qnil
);
2096 /* If the file name has special constructs in it,
2097 call the corresponding file handler. */
2098 handler
= Ffind_file_name_handler (file
, Qrename_file
);
2100 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
2101 if (!NILP (handler
))
2102 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
2103 file
, newname
, ok_if_already_exists
));
2105 if (NILP (ok_if_already_exists
)
2106 || INTEGERP (ok_if_already_exists
))
2107 barf_or_query_if_file_exists (newname
, "rename to it",
2108 INTEGERP (ok_if_already_exists
), 0);
2110 if (0 > rename (XSTRING (file
)->data
, XSTRING (newname
)->data
))
2113 if (!MoveFile (XSTRING (file
)->data
, XSTRING (newname
)->data
))
2114 #else /* not WINDOWSNT */
2115 if (0 > link (XSTRING (file
)->data
, XSTRING (newname
)->data
)
2116 || 0 > unlink (XSTRING (file
)->data
))
2117 #endif /* not WINDOWSNT */
2121 /* Why two? And why doesn't MS document what MoveFile will return? */
2122 if (GetLastError () == ERROR_FILE_EXISTS
2123 || GetLastError () == ERROR_ALREADY_EXISTS
)
2124 #else /* not WINDOWSNT */
2126 #endif /* not WINDOWSNT */
2128 Fcopy_file (file
, newname
,
2129 /* We have already prompted if it was an integer,
2130 so don't have copy-file prompt again. */
2131 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
2132 Fdelete_file (file
);
2139 report_file_error ("Renaming", Flist (2, args
));
2142 report_file_error ("Renaming", Flist (2, &file
));
2149 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
2150 "fAdd name to file: \nFName to add to %s: \np",
2151 "Give FILE additional name NEWNAME. Both args strings.\n\
2152 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2153 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2154 A number as third arg means request confirmation if NEWNAME already exists.\n\
2155 This is what happens in interactive use with M-x.")
2156 (file
, newname
, ok_if_already_exists
)
2157 Lisp_Object file
, newname
, ok_if_already_exists
;
2160 Lisp_Object args
[2];
2162 Lisp_Object handler
;
2163 struct gcpro gcpro1
, gcpro2
;
2165 GCPRO2 (file
, newname
);
2166 CHECK_STRING (file
, 0);
2167 CHECK_STRING (newname
, 1);
2168 file
= Fexpand_file_name (file
, Qnil
);
2169 newname
= Fexpand_file_name (newname
, Qnil
);
2171 /* If the file name has special constructs in it,
2172 call the corresponding file handler. */
2173 handler
= Ffind_file_name_handler (file
, Qadd_name_to_file
);
2174 if (!NILP (handler
))
2175 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2176 newname
, ok_if_already_exists
));
2178 /* If the new name has special constructs in it,
2179 call the corresponding file handler. */
2180 handler
= Ffind_file_name_handler (newname
, Qadd_name_to_file
);
2181 if (!NILP (handler
))
2182 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2183 newname
, ok_if_already_exists
));
2185 if (NILP (ok_if_already_exists
)
2186 || INTEGERP (ok_if_already_exists
))
2187 barf_or_query_if_file_exists (newname
, "make it a new name",
2188 INTEGERP (ok_if_already_exists
), 0);
2190 /* Windows does not support this operation. */
2191 report_file_error ("Adding new name", Flist (2, &file
));
2192 #else /* not WINDOWSNT */
2194 unlink (XSTRING (newname
)->data
);
2195 if (0 > link (XSTRING (file
)->data
, XSTRING (newname
)->data
))
2200 report_file_error ("Adding new name", Flist (2, args
));
2202 report_file_error ("Adding new name", Flist (2, &file
));
2205 #endif /* not WINDOWSNT */
2212 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2213 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2214 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
2215 Signals a `file-already-exists' error if a file LINKNAME already exists\n\
2216 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2217 A number as third arg means request confirmation if LINKNAME already exists.\n\
2218 This happens for interactive use with M-x.")
2219 (filename
, linkname
, ok_if_already_exists
)
2220 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2223 Lisp_Object args
[2];
2225 Lisp_Object handler
;
2226 struct gcpro gcpro1
, gcpro2
;
2228 GCPRO2 (filename
, linkname
);
2229 CHECK_STRING (filename
, 0);
2230 CHECK_STRING (linkname
, 1);
2231 /* If the link target has a ~, we must expand it to get
2232 a truly valid file name. Otherwise, do not expand;
2233 we want to permit links to relative file names. */
2234 if (XSTRING (filename
)->data
[0] == '~')
2235 filename
= Fexpand_file_name (filename
, Qnil
);
2236 linkname
= Fexpand_file_name (linkname
, Qnil
);
2238 /* If the file name has special constructs in it,
2239 call the corresponding file handler. */
2240 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2241 if (!NILP (handler
))
2242 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2243 linkname
, ok_if_already_exists
));
2245 /* If the new link name has special constructs in it,
2246 call the corresponding file handler. */
2247 handler
= Ffind_file_name_handler (linkname
, Qmake_symbolic_link
);
2248 if (!NILP (handler
))
2249 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2250 linkname
, ok_if_already_exists
));
2252 if (NILP (ok_if_already_exists
)
2253 || INTEGERP (ok_if_already_exists
))
2254 barf_or_query_if_file_exists (linkname
, "make it a link",
2255 INTEGERP (ok_if_already_exists
), 0);
2256 if (0 > symlink (XSTRING (filename
)->data
, XSTRING (linkname
)->data
))
2258 /* If we didn't complain already, silently delete existing file. */
2259 if (errno
== EEXIST
)
2261 unlink (XSTRING (linkname
)->data
);
2262 if (0 <= symlink (XSTRING (filename
)->data
, XSTRING (linkname
)->data
))
2272 report_file_error ("Making symbolic link", Flist (2, args
));
2274 report_file_error ("Making symbolic link", Flist (2, &filename
));
2280 #endif /* S_IFLNK */
2284 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2285 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2286 "Define the job-wide logical name NAME to have the value STRING.\n\
2287 If STRING is nil or a null string, the logical name NAME is deleted.")
2292 CHECK_STRING (name
, 0);
2294 delete_logical_name (XSTRING (name
)->data
);
2297 CHECK_STRING (string
, 1);
2299 if (XSTRING (string
)->size
== 0)
2300 delete_logical_name (XSTRING (name
)->data
);
2302 define_logical_name (XSTRING (name
)->data
, XSTRING (string
)->data
);
2311 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2312 "Open a network connection to PATH using LOGIN as the login string.")
2314 Lisp_Object path
, login
;
2318 CHECK_STRING (path
, 0);
2319 CHECK_STRING (login
, 0);
2321 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2323 if (netresult
== -1)
2328 #endif /* HPUX_NET */
2330 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2332 "Return t if file FILENAME specifies an absolute path name.\n\
2333 On Unix, this is a name starting with a `/' or a `~'.")
2335 Lisp_Object filename
;
2339 CHECK_STRING (filename
, 0);
2340 ptr
= XSTRING (filename
)->data
;
2341 if (IS_DIRECTORY_SEP (*ptr
) || *ptr
== '~'
2343 /* ??? This criterion is probably wrong for '<'. */
2344 || index (ptr
, ':') || index (ptr
, '<')
2345 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2349 || (*ptr
!= 0 && ptr
[1] == ':' && (ptr
[2] == '/' || ptr
[2] == '\\'))
2357 /* Return nonzero if file FILENAME exists and can be executed. */
2360 check_executable (filename
)
2364 int len
= strlen (filename
);
2367 if (stat (filename
, &st
) < 0)
2369 return (S_ISREG (st
.st_mode
)
2371 && (stricmp ((suffix
= filename
+ len
-4), ".com") == 0
2372 || stricmp (suffix
, ".exe") == 0
2373 || stricmp (suffix
, ".bat") == 0)
2374 || (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2375 #else /* not DOS_NT */
2377 return (eaccess (filename
, 1) >= 0);
2379 /* Access isn't quite right because it uses the real uid
2380 and we really want to test with the effective uid.
2381 But Unix doesn't give us a right way to do it. */
2382 return (access (filename
, 1) >= 0);
2384 #endif /* not DOS_NT */
2387 /* Return nonzero if file FILENAME exists and can be written. */
2390 check_writable (filename
)
2395 if (stat (filename
, &st
) < 0)
2397 return (st
.st_mode
& S_IWRITE
|| (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2398 #else /* not MSDOS */
2400 return (eaccess (filename
, 2) >= 0);
2402 /* Access isn't quite right because it uses the real uid
2403 and we really want to test with the effective uid.
2404 But Unix doesn't give us a right way to do it.
2405 Opening with O_WRONLY could work for an ordinary file,
2406 but would lose for directories. */
2407 return (access (filename
, 2) >= 0);
2409 #endif /* not MSDOS */
2412 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2413 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
2414 See also `file-readable-p' and `file-attributes'.")
2416 Lisp_Object filename
;
2418 Lisp_Object abspath
;
2419 Lisp_Object handler
;
2420 struct stat statbuf
;
2422 CHECK_STRING (filename
, 0);
2423 abspath
= Fexpand_file_name (filename
, Qnil
);
2425 /* If the file name has special constructs in it,
2426 call the corresponding file handler. */
2427 handler
= Ffind_file_name_handler (abspath
, Qfile_exists_p
);
2428 if (!NILP (handler
))
2429 return call2 (handler
, Qfile_exists_p
, abspath
);
2431 return (stat (XSTRING (abspath
)->data
, &statbuf
) >= 0) ? Qt
: Qnil
;
2434 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2435 "Return t if FILENAME can be executed by you.\n\
2436 For a directory, this means you can access files in that directory.")
2438 Lisp_Object filename
;
2441 Lisp_Object abspath
;
2442 Lisp_Object handler
;
2444 CHECK_STRING (filename
, 0);
2445 abspath
= Fexpand_file_name (filename
, Qnil
);
2447 /* If the file name has special constructs in it,
2448 call the corresponding file handler. */
2449 handler
= Ffind_file_name_handler (abspath
, Qfile_executable_p
);
2450 if (!NILP (handler
))
2451 return call2 (handler
, Qfile_executable_p
, abspath
);
2453 return (check_executable (XSTRING (abspath
)->data
) ? Qt
: Qnil
);
2456 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2457 "Return t if file FILENAME exists and you can read it.\n\
2458 See also `file-exists-p' and `file-attributes'.")
2460 Lisp_Object filename
;
2462 Lisp_Object abspath
;
2463 Lisp_Object handler
;
2466 CHECK_STRING (filename
, 0);
2467 abspath
= Fexpand_file_name (filename
, Qnil
);
2469 /* If the file name has special constructs in it,
2470 call the corresponding file handler. */
2471 handler
= Ffind_file_name_handler (abspath
, Qfile_readable_p
);
2472 if (!NILP (handler
))
2473 return call2 (handler
, Qfile_readable_p
, abspath
);
2476 /* Under MS-DOS, open does not work't right, because it doesn't work for
2477 directories (MS-DOS won't let you open a directory). */
2478 if (access (XSTRING (abspath
)->data
, 0) == 0)
2481 #else /* not MSDOS */
2482 desc
= open (XSTRING (abspath
)->data
, O_RDONLY
);
2487 #endif /* not MSDOS */
2490 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2492 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
2493 "Return t if file FILENAME can be written or created by you.")
2495 Lisp_Object filename
;
2497 Lisp_Object abspath
, dir
;
2498 Lisp_Object handler
;
2499 struct stat statbuf
;
2501 CHECK_STRING (filename
, 0);
2502 abspath
= Fexpand_file_name (filename
, Qnil
);
2504 /* If the file name has special constructs in it,
2505 call the corresponding file handler. */
2506 handler
= Ffind_file_name_handler (abspath
, Qfile_writable_p
);
2507 if (!NILP (handler
))
2508 return call2 (handler
, Qfile_writable_p
, abspath
);
2510 if (stat (XSTRING (abspath
)->data
, &statbuf
) >= 0)
2511 return (check_writable (XSTRING (abspath
)->data
)
2513 dir
= Ffile_name_directory (abspath
);
2516 dir
= Fdirectory_file_name (dir
);
2520 dir
= Fdirectory_file_name (dir
);
2522 return (check_writable (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "")
2526 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
2527 "Return non-nil if file FILENAME is the name of a symbolic link.\n\
2528 The value is the name of the file to which it is linked.\n\
2529 Otherwise returns nil.")
2531 Lisp_Object filename
;
2538 Lisp_Object handler
;
2540 CHECK_STRING (filename
, 0);
2541 filename
= Fexpand_file_name (filename
, Qnil
);
2543 /* If the file name has special constructs in it,
2544 call the corresponding file handler. */
2545 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
2546 if (!NILP (handler
))
2547 return call2 (handler
, Qfile_symlink_p
, filename
);
2552 buf
= (char *) xmalloc (bufsize
);
2553 bzero (buf
, bufsize
);
2554 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
2555 if (valsize
< bufsize
) break;
2556 /* Buffer was not long enough */
2565 val
= make_string (buf
, valsize
);
2568 #else /* not S_IFLNK */
2570 #endif /* not S_IFLNK */
2573 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
2574 "Return t if file FILENAME is the name of a directory as a file.\n\
2575 A directory name spec may be given instead; then the value is t\n\
2576 if the directory so specified exists and really is a directory.")
2578 Lisp_Object filename
;
2580 register Lisp_Object abspath
;
2582 Lisp_Object handler
;
2584 abspath
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2586 /* If the file name has special constructs in it,
2587 call the corresponding file handler. */
2588 handler
= Ffind_file_name_handler (abspath
, Qfile_directory_p
);
2589 if (!NILP (handler
))
2590 return call2 (handler
, Qfile_directory_p
, abspath
);
2592 if (stat (XSTRING (abspath
)->data
, &st
) < 0)
2594 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
2597 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
2598 "Return t if file FILENAME is the name of a directory as a file,\n\
2599 and files in that directory can be opened by you. In order to use a\n\
2600 directory as a buffer's current directory, this predicate must return true.\n\
2601 A directory name spec may be given instead; then the value is t\n\
2602 if the directory so specified exists and really is a readable and\n\
2603 searchable directory.")
2605 Lisp_Object filename
;
2607 Lisp_Object handler
;
2609 struct gcpro gcpro1
;
2611 /* If the file name has special constructs in it,
2612 call the corresponding file handler. */
2613 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
2614 if (!NILP (handler
))
2615 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
2617 /* It's an unlikely combination, but yes we really do need to gcpro:
2618 Suppose that file-accessible-directory-p has no handler, but
2619 file-directory-p does have a handler; this handler causes a GC which
2620 relocates the string in `filename'; and finally file-directory-p
2621 returns non-nil. Then we would end up passing a garbaged string
2622 to file-executable-p. */
2624 tem
= (NILP (Ffile_directory_p (filename
))
2625 || NILP (Ffile_executable_p (filename
)));
2627 return tem
? Qnil
: Qt
;
2630 DEFUN ("file-regular-p", Ffile_regular_p
, Sfile_regular_p
, 1, 1, 0,
2631 "Return t if file FILENAME is the name of a regular file.\n\
2632 This is the sort of file that holds an ordinary stream of data bytes.")
2634 Lisp_Object filename
;
2636 register Lisp_Object abspath
;
2638 Lisp_Object handler
;
2640 abspath
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2642 /* If the file name has special constructs in it,
2643 call the corresponding file handler. */
2644 handler
= Ffind_file_name_handler (abspath
, Qfile_regular_p
);
2645 if (!NILP (handler
))
2646 return call2 (handler
, Qfile_regular_p
, abspath
);
2648 if (stat (XSTRING (abspath
)->data
, &st
) < 0)
2650 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
2653 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
2654 "Return mode bits of file named FILENAME, as an integer.")
2656 Lisp_Object filename
;
2658 Lisp_Object abspath
;
2660 Lisp_Object handler
;
2662 abspath
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2664 /* If the file name has special constructs in it,
2665 call the corresponding file handler. */
2666 handler
= Ffind_file_name_handler (abspath
, Qfile_modes
);
2667 if (!NILP (handler
))
2668 return call2 (handler
, Qfile_modes
, abspath
);
2670 if (stat (XSTRING (abspath
)->data
, &st
) < 0)
2673 if (check_executable (XSTRING (abspath
)->data
))
2674 st
.st_mode
|= S_IEXEC
;
2677 return make_number (st
.st_mode
& 07777);
2680 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
2681 "Set mode bits of file named FILENAME to MODE (an integer).\n\
2682 Only the 12 low bits of MODE are used.")
2684 Lisp_Object filename
, mode
;
2686 Lisp_Object abspath
;
2687 Lisp_Object handler
;
2689 abspath
= Fexpand_file_name (filename
, current_buffer
->directory
);
2690 CHECK_NUMBER (mode
, 1);
2692 /* If the file name has special constructs in it,
2693 call the corresponding file handler. */
2694 handler
= Ffind_file_name_handler (abspath
, Qset_file_modes
);
2695 if (!NILP (handler
))
2696 return call3 (handler
, Qset_file_modes
, abspath
, mode
);
2698 if (chmod (XSTRING (abspath
)->data
, XINT (mode
)) < 0)
2699 report_file_error ("Doing chmod", Fcons (abspath
, Qnil
));
2704 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
2705 "Set the file permission bits for newly created files.\n\
2706 The argument MODE should be an integer; only the low 9 bits are used.\n\
2707 This setting is inherited by subprocesses.")
2711 CHECK_NUMBER (mode
, 0);
2713 umask ((~ XINT (mode
)) & 0777);
2718 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
2719 "Return the default file protection for created files.\n\
2720 The value is an integer.")
2726 realmask
= umask (0);
2729 XSETINT (value
, (~ realmask
) & 0777);
2735 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
2736 "Tell Unix to finish all pending disk updates.")
2745 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
2746 "Return t if file FILE1 is newer than file FILE2.\n\
2747 If FILE1 does not exist, the answer is nil;\n\
2748 otherwise, if FILE2 does not exist, the answer is t.")
2750 Lisp_Object file1
, file2
;
2752 Lisp_Object abspath1
, abspath2
;
2755 Lisp_Object handler
;
2756 struct gcpro gcpro1
, gcpro2
;
2758 CHECK_STRING (file1
, 0);
2759 CHECK_STRING (file2
, 0);
2762 GCPRO2 (abspath1
, file2
);
2763 abspath1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
2764 abspath2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
2767 /* If the file name has special constructs in it,
2768 call the corresponding file handler. */
2769 handler
= Ffind_file_name_handler (abspath1
, Qfile_newer_than_file_p
);
2771 handler
= Ffind_file_name_handler (abspath2
, Qfile_newer_than_file_p
);
2772 if (!NILP (handler
))
2773 return call3 (handler
, Qfile_newer_than_file_p
, abspath1
, abspath2
);
2775 if (stat (XSTRING (abspath1
)->data
, &st
) < 0)
2778 mtime1
= st
.st_mtime
;
2780 if (stat (XSTRING (abspath2
)->data
, &st
) < 0)
2783 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
2787 Lisp_Object Qfind_buffer_file_type
;
2790 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
2792 "Insert contents of file FILENAME after point.\n\
2793 Returns list of absolute file name and length of data inserted.\n\
2794 If second argument VISIT is non-nil, the buffer's visited filename\n\
2795 and last save file modtime are set, and it is marked unmodified.\n\
2796 If visiting and the file does not exist, visiting is completed\n\
2797 before the error is signaled.\n\n\
2798 The optional third and fourth arguments BEG and END\n\
2799 specify what portion of the file to insert.\n\
2800 If VISIT is non-nil, BEG and END must be nil.\n\
2801 If optional fifth argument REPLACE is non-nil,\n\
2802 it means replace the current buffer contents (in the accessible portion)\n\
2803 with the file contents. This is better than simply deleting and inserting\n\
2804 the whole thing because (1) it preserves some marker positions\n\
2805 and (2) it puts less data in the undo list.")
2806 (filename
, visit
, beg
, end
, replace
)
2807 Lisp_Object filename
, visit
, beg
, end
, replace
;
2811 register int inserted
= 0;
2812 register int how_much
;
2813 int count
= specpdl_ptr
- specpdl
;
2814 struct gcpro gcpro1
, gcpro2
, gcpro3
;
2815 Lisp_Object handler
, val
, insval
;
2818 int not_regular
= 0;
2820 if (current_buffer
->base_buffer
&& ! NILP (visit
))
2821 error ("Cannot do file visiting in an indirect buffer");
2823 if (!NILP (current_buffer
->read_only
))
2824 Fbarf_if_buffer_read_only ();
2829 GCPRO3 (filename
, val
, p
);
2831 CHECK_STRING (filename
, 0);
2832 filename
= Fexpand_file_name (filename
, Qnil
);
2834 /* If the file name has special constructs in it,
2835 call the corresponding file handler. */
2836 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
2837 if (!NILP (handler
))
2839 val
= call6 (handler
, Qinsert_file_contents
, filename
,
2840 visit
, beg
, end
, replace
);
2847 if (stat (XSTRING (filename
)->data
, &st
) < 0)
2849 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0
2850 || fstat (fd
, &st
) < 0)
2851 #endif /* not APOLLO */
2853 if (fd
>= 0) close (fd
);
2856 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
2863 /* This code will need to be changed in order to work on named
2864 pipes, and it's probably just not worth it. So we should at
2865 least signal an error. */
2866 if (!S_ISREG (st
.st_mode
))
2869 Fsignal (Qfile_error
,
2870 Fcons (build_string ("not a regular file"),
2871 Fcons (filename
, Qnil
)));
2879 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0)
2882 /* Replacement should preserve point as it preserves markers. */
2883 if (!NILP (replace
))
2884 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
2886 record_unwind_protect (close_file_unwind
, make_number (fd
));
2888 /* Supposedly happens on VMS. */
2890 error ("File size is negative");
2892 if (!NILP (beg
) || !NILP (end
))
2894 error ("Attempt to visit less than an entire file");
2897 CHECK_NUMBER (beg
, 0);
2899 XSETFASTINT (beg
, 0);
2902 CHECK_NUMBER (end
, 0);
2905 XSETINT (end
, st
.st_size
);
2906 if (XINT (end
) != st
.st_size
)
2907 error ("maximum buffer size exceeded");
2910 /* If requested, replace the accessible part of the buffer
2911 with the file contents. Avoid replacing text at the
2912 beginning or end of the buffer that matches the file contents;
2913 that preserves markers pointing to the unchanged parts. */
2915 /* On MSDOS, replace mode doesn't really work, except for binary files,
2916 and it's not worth supporting just for them. */
2917 if (!NILP (replace
))
2920 XSETFASTINT (beg
, 0);
2921 XSETFASTINT (end
, st
.st_size
);
2922 del_range_1 (BEGV
, ZV
, 0);
2924 #else /* not DOS_NT */
2925 if (!NILP (replace
))
2927 unsigned char buffer
[1 << 14];
2928 int same_at_start
= BEGV
;
2929 int same_at_end
= ZV
;
2934 /* Count how many chars at the start of the file
2935 match the text at the beginning of the buffer. */
2940 nread
= read (fd
, buffer
, sizeof buffer
);
2942 error ("IO error reading %s: %s",
2943 XSTRING (filename
)->data
, strerror (errno
));
2944 else if (nread
== 0)
2947 while (bufpos
< nread
&& same_at_start
< ZV
2948 && FETCH_CHAR (same_at_start
) == buffer
[bufpos
])
2949 same_at_start
++, bufpos
++;
2950 /* If we found a discrepancy, stop the scan.
2951 Otherwise loop around and scan the next bufferful. */
2952 if (bufpos
!= nread
)
2956 /* If the file matches the buffer completely,
2957 there's no need to replace anything. */
2958 if (same_at_start
- BEGV
== st
.st_size
)
2962 /* Truncate the buffer to the size of the file. */
2963 del_range_1 (same_at_start
, same_at_end
, 0);
2968 /* Count how many chars at the end of the file
2969 match the text at the end of the buffer. */
2972 int total_read
, nread
, bufpos
, curpos
, trial
;
2974 /* At what file position are we now scanning? */
2975 curpos
= st
.st_size
- (ZV
- same_at_end
);
2976 /* If the entire file matches the buffer tail, stop the scan. */
2979 /* How much can we scan in the next step? */
2980 trial
= min (curpos
, sizeof buffer
);
2981 if (lseek (fd
, curpos
- trial
, 0) < 0)
2982 report_file_error ("Setting file position",
2983 Fcons (filename
, Qnil
));
2986 while (total_read
< trial
)
2988 nread
= read (fd
, buffer
+ total_read
, trial
- total_read
);
2990 error ("IO error reading %s: %s",
2991 XSTRING (filename
)->data
, strerror (errno
));
2992 total_read
+= nread
;
2994 /* Scan this bufferful from the end, comparing with
2995 the Emacs buffer. */
2996 bufpos
= total_read
;
2997 /* Compare with same_at_start to avoid counting some buffer text
2998 as matching both at the file's beginning and at the end. */
2999 while (bufpos
> 0 && same_at_end
> same_at_start
3000 && FETCH_CHAR (same_at_end
- 1) == buffer
[bufpos
- 1])
3001 same_at_end
--, bufpos
--;
3002 /* If we found a discrepancy, stop the scan.
3003 Otherwise loop around and scan the preceding bufferful. */
3006 /* If display current starts at beginning of line,
3007 keep it that way. */
3008 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3009 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3013 /* Don't try to reuse the same piece of text twice. */
3014 overlap
= same_at_start
- BEGV
- (same_at_end
+ st
.st_size
- ZV
);
3016 same_at_end
+= overlap
;
3018 /* Arrange to read only the nonmatching middle part of the file. */
3019 XSETFASTINT (beg
, same_at_start
- BEGV
);
3020 XSETFASTINT (end
, st
.st_size
- (ZV
- same_at_end
));
3022 del_range_1 (same_at_start
, same_at_end
, 0);
3023 /* Insert from the file at the proper position. */
3024 SET_PT (same_at_start
);
3026 #endif /* not DOS_NT */
3028 total
= XINT (end
) - XINT (beg
);
3031 register Lisp_Object temp
;
3033 /* Make sure point-max won't overflow after this insertion. */
3034 XSETINT (temp
, total
);
3035 if (total
!= XINT (temp
))
3036 error ("maximum buffer size exceeded");
3039 if (NILP (visit
) && total
> 0)
3040 prepare_to_modify_buffer (point
, point
);
3043 if (GAP_SIZE
< total
)
3044 make_gap (total
- GAP_SIZE
);
3046 if (XINT (beg
) != 0 || !NILP (replace
))
3048 if (lseek (fd
, XINT (beg
), 0) < 0)
3049 report_file_error ("Setting file position", Fcons (filename
, Qnil
));
3053 while (inserted
< total
)
3055 /* try is reserved in some compilers (Microsoft C) */
3056 int trytry
= min (total
- inserted
, 64 << 10);
3059 /* Allow quitting out of the actual I/O. */
3062 this = read (fd
, &FETCH_CHAR (point
+ inserted
- 1) + 1, trytry
);
3079 /* Demacs 1.1.1 91/10/16 HIRANO Satoshi, MW July 1993 */
3080 /* Determine file type from name and remove LFs from CR-LFs if the file
3081 is deemed to be a text file. */
3083 current_buffer
->buffer_file_type
3084 = call1 (Qfind_buffer_file_type
, filename
);
3085 if (NILP (current_buffer
->buffer_file_type
))
3088 = inserted
- crlf_to_lf (inserted
, &FETCH_CHAR (point
- 1) + 1);
3091 GPT
-= reduced_size
;
3092 GAP_SIZE
+= reduced_size
;
3093 inserted
-= reduced_size
;
3100 record_insert (point
, inserted
);
3102 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
3103 offset_intervals (current_buffer
, point
, inserted
);
3109 /* Discard the unwind protect for closing the file. */
3113 error ("IO error reading %s: %s",
3114 XSTRING (filename
)->data
, strerror (errno
));
3121 if (!EQ (current_buffer
->undo_list
, Qt
))
3122 current_buffer
->undo_list
= Qnil
;
3124 stat (XSTRING (filename
)->data
, &st
);
3129 current_buffer
->modtime
= st
.st_mtime
;
3130 current_buffer
->filename
= filename
;
3133 SAVE_MODIFF
= MODIFF
;
3134 current_buffer
->auto_save_modified
= MODIFF
;
3135 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
3136 #ifdef CLASH_DETECTION
3139 if (!NILP (current_buffer
->file_truename
))
3140 unlock_file (current_buffer
->file_truename
);
3141 unlock_file (filename
);
3143 #endif /* CLASH_DETECTION */
3145 Fsignal (Qfile_error
,
3146 Fcons (build_string ("not a regular file"),
3147 Fcons (filename
, Qnil
)));
3149 /* If visiting nonexistent file, return nil. */
3150 if (current_buffer
->modtime
== -1)
3151 report_file_error ("Opening input file", Fcons (filename
, Qnil
));
3154 /* Decode file format */
3157 insval
= call3 (Qformat_decode
,
3158 Qnil
, make_number (inserted
), visit
);
3159 CHECK_NUMBER (insval
, 0);
3160 inserted
= XFASTINT (insval
);
3163 if (inserted
> 0 && NILP (visit
) && total
> 0)
3164 signal_after_change (point
, 0, inserted
);
3168 p
= Vafter_insert_file_functions
;
3171 insval
= call1 (Fcar (p
), make_number (inserted
));
3174 CHECK_NUMBER (insval
, 0);
3175 inserted
= XFASTINT (insval
);
3183 val
= Fcons (filename
,
3184 Fcons (make_number (inserted
),
3187 RETURN_UNGCPRO (unbind_to (count
, val
));
3190 static Lisp_Object
build_annotations ();
3192 /* If build_annotations switched buffers, switch back to BUF.
3193 Kill the temporary buffer that was selected in the meantime. */
3196 build_annotations_unwind (buf
)
3201 if (XBUFFER (buf
) == current_buffer
)
3203 tembuf
= Fcurrent_buffer ();
3205 Fkill_buffer (tembuf
);
3209 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 6,
3210 "r\nFWrite region to file: ",
3211 "Write current region into specified file.\n\
3212 When called from a program, takes three arguments:\n\
3213 START, END and FILENAME. START and END are buffer positions.\n\
3214 Optional fourth argument APPEND if non-nil means\n\
3215 append to existing file contents (if any).\n\
3216 Optional fifth argument VISIT if t means\n\
3217 set the last-save-file-modtime of buffer to this file's modtime\n\
3218 and mark buffer not modified.\n\
3219 If VISIT is a string, it is a second file name;\n\
3220 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
3221 VISIT is also the file name to lock and unlock for clash detection.\n\
3222 If VISIT is neither t nor nil nor a string,\n\
3223 that means do not print the \"Wrote file\" message.\n\
3224 The optional sixth arg LOCKNAME, if non-nil, specifies the name to\n\
3225 use for locking and unlocking, overriding FILENAME and VISIT.\n\
3226 Kludgy feature: if START is a string, then that string is written\n\
3227 to the file, instead of any buffer contents, and END is ignored.")
3228 (start
, end
, filename
, append
, visit
, lockname
)
3229 Lisp_Object start
, end
, filename
, append
, visit
, lockname
;
3237 int count
= specpdl_ptr
- specpdl
;
3240 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
3242 Lisp_Object handler
;
3243 Lisp_Object visit_file
;
3244 Lisp_Object annotations
;
3245 int visiting
, quietly
;
3246 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
3247 struct buffer
*given_buffer
;
3249 int buffer_file_type
3250 = NILP (current_buffer
->buffer_file_type
) ? O_TEXT
: O_BINARY
;
3253 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3254 error ("Cannot do file visiting in an indirect buffer");
3256 if (!NILP (start
) && !STRINGP (start
))
3257 validate_region (&start
, &end
);
3259 GCPRO3 (filename
, visit
, lockname
);
3260 filename
= Fexpand_file_name (filename
, Qnil
);
3261 if (STRINGP (visit
))
3262 visit_file
= Fexpand_file_name (visit
, Qnil
);
3264 visit_file
= filename
;
3267 visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
3268 quietly
= !NILP (visit
);
3272 if (NILP (lockname
))
3273 lockname
= visit_file
;
3275 GCPRO5 (start
, filename
, annotations
, visit_file
, lockname
);
3277 /* If the file name has special constructs in it,
3278 call the corresponding file handler. */
3279 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
3280 /* If FILENAME has no handler, see if VISIT has one. */
3281 if (NILP (handler
) && STRINGP (visit
))
3282 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
3284 if (!NILP (handler
))
3287 val
= call6 (handler
, Qwrite_region
, start
, end
,
3288 filename
, append
, visit
);
3292 SAVE_MODIFF
= MODIFF
;
3293 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
3294 current_buffer
->filename
= visit_file
;
3300 /* Special kludge to simplify auto-saving. */
3303 XSETFASTINT (start
, BEG
);
3304 XSETFASTINT (end
, Z
);
3307 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
3308 count1
= specpdl_ptr
- specpdl
;
3310 given_buffer
= current_buffer
;
3311 annotations
= build_annotations (start
, end
);
3312 if (current_buffer
!= given_buffer
)
3318 #ifdef CLASH_DETECTION
3320 lock_file (lockname
);
3321 #endif /* CLASH_DETECTION */
3323 fn
= XSTRING (filename
)->data
;
3327 desc
= open (fn
, O_WRONLY
| buffer_file_type
);
3328 #else /* not DOS_NT */
3329 desc
= open (fn
, O_WRONLY
);
3330 #endif /* not DOS_NT */
3334 if (auto_saving
) /* Overwrite any previous version of autosave file */
3336 vms_truncate (fn
); /* if fn exists, truncate to zero length */
3337 desc
= open (fn
, O_RDWR
);
3339 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
3340 ? XSTRING (current_buffer
->filename
)->data
: 0,
3343 else /* Write to temporary name and rename if no errors */
3345 Lisp_Object temp_name
;
3346 temp_name
= Ffile_name_directory (filename
);
3348 if (!NILP (temp_name
))
3350 temp_name
= Fmake_temp_name (concat2 (temp_name
,
3351 build_string ("$$SAVE$$")));
3352 fname
= XSTRING (filename
)->data
;
3353 fn
= XSTRING (temp_name
)->data
;
3354 desc
= creat_copy_attrs (fname
, fn
);
3357 /* If we can't open the temporary file, try creating a new
3358 version of the original file. VMS "creat" creates a
3359 new version rather than truncating an existing file. */
3362 desc
= creat (fn
, 0666);
3363 #if 0 /* This can clobber an existing file and fail to replace it,
3364 if the user runs out of space. */
3367 /* We can't make a new version;
3368 try to truncate and rewrite existing version if any. */
3370 desc
= open (fn
, O_RDWR
);
3376 desc
= creat (fn
, 0666);
3381 O_WRONLY
| O_TRUNC
| O_CREAT
| buffer_file_type
,
3382 S_IREAD
| S_IWRITE
);
3383 #else /* not DOS_NT */
3384 desc
= creat (fn
, auto_saving
? auto_save_mode_bits
: 0666);
3385 #endif /* not DOS_NT */
3386 #endif /* not VMS */
3392 #ifdef CLASH_DETECTION
3394 if (!auto_saving
) unlock_file (lockname
);
3396 #endif /* CLASH_DETECTION */
3397 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
3400 record_unwind_protect (close_file_unwind
, make_number (desc
));
3403 if (lseek (desc
, 0, 2) < 0)
3405 #ifdef CLASH_DETECTION
3406 if (!auto_saving
) unlock_file (lockname
);
3407 #endif /* CLASH_DETECTION */
3408 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
3413 * Kludge Warning: The VMS C RTL likes to insert carriage returns
3414 * if we do writes that don't end with a carriage return. Furthermore
3415 * it cannot handle writes of more then 16K. The modified
3416 * version of "sys_write" in SYSDEP.C (see comment there) copes with
3417 * this EXCEPT for the last record (iff it doesn't end with a carriage
3418 * return). This implies that if your buffer doesn't end with a carriage
3419 * return, you get one free... tough. However it also means that if
3420 * we make two calls to sys_write (a la the following code) you can
3421 * get one at the gap as well. The easiest way to fix this (honest)
3422 * is to move the gap to the next newline (or the end of the buffer).
3427 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
3428 move_gap (find_next_newline (GPT
, 1));
3434 if (STRINGP (start
))
3436 failure
= 0 > a_write (desc
, XSTRING (start
)->data
,
3437 XSTRING (start
)->size
, 0, &annotations
);
3440 else if (XINT (start
) != XINT (end
))
3443 if (XINT (start
) < GPT
)
3445 register int end1
= XINT (end
);
3447 failure
= 0 > a_write (desc
, &FETCH_CHAR (tem
),
3448 min (GPT
, end1
) - tem
, tem
, &annotations
);
3449 nwritten
+= min (GPT
, end1
) - tem
;
3453 if (XINT (end
) > GPT
&& !failure
)
3456 tem
= max (tem
, GPT
);
3457 failure
= 0 > a_write (desc
, &FETCH_CHAR (tem
), XINT (end
) - tem
,
3459 nwritten
+= XINT (end
) - tem
;
3465 /* If file was empty, still need to write the annotations */
3466 failure
= 0 > a_write (desc
, "", 0, XINT (start
), &annotations
);
3473 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
3474 Disk full in NFS may be reported here. */
3475 /* mib says that closing the file will try to write as fast as NFS can do
3476 it, and that means the fsync here is not crucial for autosave files. */
3477 if (!auto_saving
&& fsync (desc
) < 0)
3479 /* If fsync fails with EINTR, don't treat that as serious. */
3481 failure
= 1, save_errno
= errno
;
3485 /* Spurious "file has changed on disk" warnings have been
3486 observed on Suns as well.
3487 It seems that `close' can change the modtime, under nfs.
3489 (This has supposedly been fixed in Sunos 4,
3490 but who knows about all the other machines with NFS?) */
3493 /* On VMS and APOLLO, must do the stat after the close
3494 since closing changes the modtime. */
3497 /* Recall that #if defined does not work on VMS. */
3504 /* NFS can report a write failure now. */
3505 if (close (desc
) < 0)
3506 failure
= 1, save_errno
= errno
;
3509 /* If we wrote to a temporary name and had no errors, rename to real name. */
3513 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
3521 /* Discard the unwind protect for close_file_unwind. */
3522 specpdl_ptr
= specpdl
+ count1
;
3523 /* Restore the original current buffer. */
3524 visit_file
= unbind_to (count
, visit_file
);
3526 #ifdef CLASH_DETECTION
3528 unlock_file (lockname
);
3529 #endif /* CLASH_DETECTION */
3531 /* Do this before reporting IO error
3532 to avoid a "file has changed on disk" warning on
3533 next attempt to save. */
3535 current_buffer
->modtime
= st
.st_mtime
;
3538 error ("IO error writing %s: %s", fn
, strerror (save_errno
));
3542 SAVE_MODIFF
= MODIFF
;
3543 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
3544 current_buffer
->filename
= visit_file
;
3545 update_mode_lines
++;
3551 message ("Wrote %s", XSTRING (visit_file
)->data
);
3556 Lisp_Object
merge ();
3558 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
3559 "Return t if (car A) is numerically less than (car B).")
3563 return Flss (Fcar (a
), Fcar (b
));
3566 /* Build the complete list of annotations appropriate for writing out
3567 the text between START and END, by calling all the functions in
3568 write-region-annotate-functions and merging the lists they return.
3569 If one of these functions switches to a different buffer, we assume
3570 that buffer contains altered text. Therefore, the caller must
3571 make sure to restore the current buffer in all cases,
3572 as save-excursion would do. */
3575 build_annotations (start
, end
)
3576 Lisp_Object start
, end
;
3578 Lisp_Object annotations
;
3580 struct gcpro gcpro1
, gcpro2
;
3583 p
= Vwrite_region_annotate_functions
;
3584 GCPRO2 (annotations
, p
);
3587 struct buffer
*given_buffer
= current_buffer
;
3588 Vwrite_region_annotations_so_far
= annotations
;
3589 res
= call2 (Fcar (p
), start
, end
);
3590 /* If the function makes a different buffer current,
3591 assume that means this buffer contains altered text to be output.
3592 Reset START and END from the buffer bounds
3593 and discard all previous annotations because they should have
3594 been dealt with by this function. */
3595 if (current_buffer
!= given_buffer
)
3601 Flength (res
); /* Check basic validity of return value */
3602 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
3606 /* Now do the same for annotation functions implied by the file-format */
3607 if (auto_saving
&& (!EQ (Vauto_save_file_format
, Qt
)))
3608 p
= Vauto_save_file_format
;
3610 p
= current_buffer
->file_format
;
3613 struct buffer
*given_buffer
= current_buffer
;
3614 Vwrite_region_annotations_so_far
= annotations
;
3615 res
= call3 (Qformat_annotate_function
, Fcar (p
), start
, end
);
3616 if (current_buffer
!= given_buffer
)
3623 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
3630 /* Write to descriptor DESC the LEN characters starting at ADDR,
3631 assuming they start at position POS in the buffer.
3632 Intersperse with them the annotations from *ANNOT
3633 (those which fall within the range of positions POS to POS + LEN),
3634 each at its appropriate position.
3636 Modify *ANNOT by discarding elements as we output them.
3637 The return value is negative in case of system call failure. */
3640 a_write (desc
, addr
, len
, pos
, annot
)
3642 register char *addr
;
3649 int lastpos
= pos
+ len
;
3651 while (NILP (*annot
) || CONSP (*annot
))
3653 tem
= Fcar_safe (Fcar (*annot
));
3654 if (INTEGERP (tem
) && XINT (tem
) >= pos
&& XFASTINT (tem
) <= lastpos
)
3655 nextpos
= XFASTINT (tem
);
3657 return e_write (desc
, addr
, lastpos
- pos
);
3660 if (0 > e_write (desc
, addr
, nextpos
- pos
))
3662 addr
+= nextpos
- pos
;
3665 tem
= Fcdr (Fcar (*annot
));
3668 if (0 > e_write (desc
, XSTRING (tem
)->data
, XSTRING (tem
)->size
))
3671 *annot
= Fcdr (*annot
);
3676 e_write (desc
, addr
, len
)
3678 register char *addr
;
3681 char buf
[16 * 1024];
3682 register char *p
, *end
;
3684 if (!EQ (current_buffer
->selective_display
, Qt
))
3685 return write (desc
, addr
, len
) - len
;
3689 end
= p
+ sizeof buf
;
3694 if (write (desc
, buf
, sizeof buf
) != sizeof buf
)
3703 if (write (desc
, buf
, p
- buf
) != p
- buf
)
3709 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
3710 Sverify_visited_file_modtime
, 1, 1, 0,
3711 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
3712 This means that the file has not been changed since it was visited or saved.")
3718 Lisp_Object handler
;
3720 CHECK_BUFFER (buf
, 0);
3723 if (!STRINGP (b
->filename
)) return Qt
;
3724 if (b
->modtime
== 0) return Qt
;
3726 /* If the file name has special constructs in it,
3727 call the corresponding file handler. */
3728 handler
= Ffind_file_name_handler (b
->filename
,
3729 Qverify_visited_file_modtime
);
3730 if (!NILP (handler
))
3731 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
3733 if (stat (XSTRING (b
->filename
)->data
, &st
) < 0)
3735 /* If the file doesn't exist now and didn't exist before,
3736 we say that it isn't modified, provided the error is a tame one. */
3737 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
3742 if (st
.st_mtime
== b
->modtime
3743 /* If both are positive, accept them if they are off by one second. */
3744 || (st
.st_mtime
> 0 && b
->modtime
> 0
3745 && (st
.st_mtime
== b
->modtime
+ 1
3746 || st
.st_mtime
== b
->modtime
- 1)))
3751 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
3752 Sclear_visited_file_modtime
, 0, 0, 0,
3753 "Clear out records of last mod time of visited file.\n\
3754 Next attempt to save will certainly not complain of a discrepancy.")
3757 current_buffer
->modtime
= 0;
3761 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
3762 Svisited_file_modtime
, 0, 0, 0,
3763 "Return the current buffer's recorded visited file modification time.\n\
3764 The value is a list of the form (HIGH . LOW), like the time values\n\
3765 that `file-attributes' returns.")
3768 return long_to_cons ((unsigned long) current_buffer
->modtime
);
3771 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
3772 Sset_visited_file_modtime
, 0, 1, 0,
3773 "Update buffer's recorded modification time from the visited file's time.\n\
3774 Useful if the buffer was not read from the file normally\n\
3775 or if the file itself has been changed for some known benign reason.\n\
3776 An argument specifies the modification time value to use\n\
3777 \(instead of that of the visited file), in the form of a list\n\
3778 \(HIGH . LOW) or (HIGH LOW).")
3780 Lisp_Object time_list
;
3782 if (!NILP (time_list
))
3783 current_buffer
->modtime
= cons_to_long (time_list
);
3786 register Lisp_Object filename
;
3788 Lisp_Object handler
;
3790 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
3792 /* If the file name has special constructs in it,
3793 call the corresponding file handler. */
3794 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
3795 if (!NILP (handler
))
3796 /* The handler can find the file name the same way we did. */
3797 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
3798 else if (stat (XSTRING (filename
)->data
, &st
) >= 0)
3799 current_buffer
->modtime
= st
.st_mtime
;
3809 message ("Autosaving...error for %s", XSTRING (current_buffer
->name
)->data
);
3810 Fsleep_for (make_number (1), Qnil
);
3811 message ("Autosaving...error!for %s", XSTRING (current_buffer
->name
)->data
);
3812 Fsleep_for (make_number (1), Qnil
);
3813 message ("Autosaving...error for %s", XSTRING (current_buffer
->name
)->data
);
3814 Fsleep_for (make_number (1), Qnil
);
3824 /* Get visited file's mode to become the auto save file's mode. */
3825 if (stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
3826 /* But make sure we can overwrite it later! */
3827 auto_save_mode_bits
= st
.st_mode
| 0600;
3829 auto_save_mode_bits
= 0666;
3832 Fwrite_region (Qnil
, Qnil
,
3833 current_buffer
->auto_save_file_name
,
3834 Qnil
, Qlambda
, Qnil
);
3838 do_auto_save_unwind (desc
) /* used as unwind-protect function */
3842 if (XINT (desc
) >= 0)
3843 close (XINT (desc
));
3847 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
3848 "Auto-save all buffers that need it.\n\
3849 This is all buffers that have auto-saving enabled\n\
3850 and are changed since last auto-saved.\n\
3851 Auto-saving writes the buffer into a file\n\
3852 so that your editing is not lost if the system crashes.\n\
3853 This file is not the file you visited; that changes only when you save.\n\
3854 Normally we run the normal hook `auto-save-hook' before saving.\n\n\
3855 A non-nil NO-MESSAGE argument means do not print any message if successful.\n\
3856 A non-nil CURRENT-ONLY argument means save only current buffer.")
3857 (no_message
, current_only
)
3858 Lisp_Object no_message
, current_only
;
3860 struct buffer
*old
= current_buffer
, *b
;
3861 Lisp_Object tail
, buf
;
3863 char *omessage
= echo_area_glyphs
;
3864 int omessage_length
= echo_area_glyphs_length
;
3865 extern int minibuf_level
;
3866 int do_handled_files
;
3869 int count
= specpdl_ptr
- specpdl
;
3872 /* Ordinarily don't quit within this function,
3873 but don't make it impossible to quit (in case we get hung in I/O). */
3877 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
3878 point to non-strings reached from Vbuffer_alist. */
3883 if (!NILP (Vrun_hooks
))
3884 call1 (Vrun_hooks
, intern ("auto-save-hook"));
3886 if (STRINGP (Vauto_save_list_file_name
))
3888 Lisp_Object listfile
;
3889 listfile
= Fexpand_file_name (Vauto_save_list_file_name
, Qnil
);
3891 listdesc
= open (XSTRING (listfile
)->data
,
3892 O_WRONLY
| O_TRUNC
| O_CREAT
| O_TEXT
,
3893 S_IREAD
| S_IWRITE
);
3894 #else /* not DOS_NT */
3895 listdesc
= creat (XSTRING (listfile
)->data
, 0666);
3896 #endif /* not DOS_NT */
3901 /* Arrange to close that file whether or not we get an error.
3902 Also reset auto_saving to 0. */
3903 record_unwind_protect (do_auto_save_unwind
, make_number (listdesc
));
3907 /* First, save all files which don't have handlers. If Emacs is
3908 crashing, the handlers may tweak what is causing Emacs to crash
3909 in the first place, and it would be a shame if Emacs failed to
3910 autosave perfectly ordinary files because it couldn't handle some
3912 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
3913 for (tail
= Vbuffer_alist
; GC_CONSP (tail
); tail
= XCONS (tail
)->cdr
)
3915 buf
= XCONS (XCONS (tail
)->car
)->cdr
;
3918 /* Record all the buffers that have auto save mode
3919 in the special file that lists them. For each of these buffers,
3920 Record visited name (if any) and auto save name. */
3921 if (STRINGP (b
->auto_save_file_name
)
3922 && listdesc
>= 0 && do_handled_files
== 0)
3924 if (!NILP (b
->filename
))
3926 write (listdesc
, XSTRING (b
->filename
)->data
,
3927 XSTRING (b
->filename
)->size
);
3929 write (listdesc
, "\n", 1);
3930 write (listdesc
, XSTRING (b
->auto_save_file_name
)->data
,
3931 XSTRING (b
->auto_save_file_name
)->size
);
3932 write (listdesc
, "\n", 1);
3935 if (!NILP (current_only
)
3936 && b
!= current_buffer
)
3939 /* Don't auto-save indirect buffers.
3940 The base buffer takes care of it. */
3944 /* Check for auto save enabled
3945 and file changed since last auto save
3946 and file changed since last real save. */
3947 if (STRINGP (b
->auto_save_file_name
)
3948 && BUF_SAVE_MODIFF (b
) < BUF_MODIFF (b
)
3949 && b
->auto_save_modified
< BUF_MODIFF (b
)
3950 /* -1 means we've turned off autosaving for a while--see below. */
3951 && XINT (b
->save_length
) >= 0
3952 && (do_handled_files
3953 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
3956 EMACS_TIME before_time
, after_time
;
3958 EMACS_GET_TIME (before_time
);
3960 /* If we had a failure, don't try again for 20 minutes. */
3961 if (b
->auto_save_failure_time
>= 0
3962 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
3965 if ((XFASTINT (b
->save_length
) * 10
3966 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
3967 /* A short file is likely to change a large fraction;
3968 spare the user annoying messages. */
3969 && XFASTINT (b
->save_length
) > 5000
3970 /* These messages are frequent and annoying for `*mail*'. */
3971 && !EQ (b
->filename
, Qnil
)
3972 && NILP (no_message
))
3974 /* It has shrunk too much; turn off auto-saving here. */
3975 message ("Buffer %s has shrunk a lot; auto save turned off there",
3976 XSTRING (b
->name
)->data
);
3977 /* Turn off auto-saving until there's a real save,
3978 and prevent any more warnings. */
3979 XSETINT (b
->save_length
, -1);
3980 Fsleep_for (make_number (1), Qnil
);
3983 set_buffer_internal (b
);
3984 if (!auto_saved
&& NILP (no_message
))
3985 message1 ("Auto-saving...");
3986 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
3988 b
->auto_save_modified
= BUF_MODIFF (b
);
3989 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
3990 set_buffer_internal (old
);
3992 EMACS_GET_TIME (after_time
);
3994 /* If auto-save took more than 60 seconds,
3995 assume it was an NFS failure that got a timeout. */
3996 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
3997 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
4001 /* Prevent another auto save till enough input events come in. */
4002 record_auto_save ();
4004 if (auto_saved
&& NILP (no_message
))
4008 sit_for (1, 0, 0, 0);
4009 message2 (omessage
, omessage_length
);
4012 message1 ("Auto-saving...done");
4017 unbind_to (count
, Qnil
);
4021 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
4022 Sset_buffer_auto_saved
, 0, 0, 0,
4023 "Mark current buffer as auto-saved with its current text.\n\
4024 No auto-save file will be written until the buffer changes again.")
4027 current_buffer
->auto_save_modified
= MODIFF
;
4028 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4029 current_buffer
->auto_save_failure_time
= -1;
4033 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
4034 Sclear_buffer_auto_save_failure
, 0, 0, 0,
4035 "Clear any record of a recent auto-save failure in the current buffer.")
4038 current_buffer
->auto_save_failure_time
= -1;
4042 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
4044 "Return t if buffer has been auto-saved since last read in or saved.")
4047 return (SAVE_MODIFF
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
4050 /* Reading and completing file names */
4051 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
4053 /* In the string VAL, change each $ to $$ and return the result. */
4056 double_dollars (val
)
4059 register unsigned char *old
, *new;
4063 osize
= XSTRING (val
)->size
;
4064 /* Quote "$" as "$$" to get it past substitute-in-file-name */
4065 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
4066 if (*old
++ == '$') count
++;
4069 old
= XSTRING (val
)->data
;
4070 val
= Fmake_string (make_number (osize
+ count
), make_number (0));
4071 new = XSTRING (val
)->data
;
4072 for (n
= osize
; n
> 0; n
--)
4085 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
4087 "Internal subroutine for read-file-name. Do not call this.")
4088 (string
, dir
, action
)
4089 Lisp_Object string
, dir
, action
;
4090 /* action is nil for complete, t for return list of completions,
4091 lambda for verify final value */
4093 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
4095 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
4102 /* No need to protect ACTION--we only compare it with t and nil. */
4103 GCPRO5 (string
, realdir
, name
, specdir
, orig_string
);
4105 if (XSTRING (string
)->size
== 0)
4107 if (EQ (action
, Qlambda
))
4115 orig_string
= string
;
4116 string
= Fsubstitute_in_file_name (string
);
4117 changed
= NILP (Fstring_equal (string
, orig_string
));
4118 name
= Ffile_name_nondirectory (string
);
4119 val
= Ffile_name_directory (string
);
4121 realdir
= Fexpand_file_name (val
, realdir
);
4126 specdir
= Ffile_name_directory (string
);
4127 val
= Ffile_name_completion (name
, realdir
);
4132 return double_dollars (string
);
4136 if (!NILP (specdir
))
4137 val
= concat2 (specdir
, val
);
4139 return double_dollars (val
);
4142 #endif /* not VMS */
4146 if (EQ (action
, Qt
))
4147 return Ffile_name_all_completions (name
, realdir
);
4148 /* Only other case actually used is ACTION = lambda */
4150 /* Supposedly this helps commands such as `cd' that read directory names,
4151 but can someone explain how it helps them? -- RMS */
4152 if (XSTRING (name
)->size
== 0)
4155 return Ffile_exists_p (string
);
4158 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
4159 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
4160 Value is not expanded---you must call `expand-file-name' yourself.\n\
4161 Default name to DEFAULT-FILENAME if user enters a null string.\n\
4162 (If DEFAULT-FILENAME is omitted, the visited file name is used,\n\
4163 except that if INITIAL is specified, that combined with DIR is used.)\n\
4164 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
4165 Non-nil and non-t means also require confirmation after completion.\n\
4166 Fifth arg INITIAL specifies text to start with.\n\
4167 DIR defaults to current buffer's directory default.")
4168 (prompt
, dir
, default_filename
, mustmatch
, initial
)
4169 Lisp_Object prompt
, dir
, default_filename
, mustmatch
, initial
;
4171 Lisp_Object val
, insdef
, insdef1
, tem
;
4172 struct gcpro gcpro1
, gcpro2
;
4173 register char *homedir
;
4177 dir
= current_buffer
->directory
;
4178 if (NILP (default_filename
))
4180 if (! NILP (initial
))
4181 default_filename
= Fexpand_file_name (initial
, dir
);
4183 default_filename
= current_buffer
->filename
;
4186 /* If dir starts with user's homedir, change that to ~. */
4187 homedir
= (char *) egetenv ("HOME");
4190 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
4191 && IS_DIRECTORY_SEP (XSTRING (dir
)->data
[strlen (homedir
)]))
4193 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
4194 XSTRING (dir
)->size
- strlen (homedir
) + 1);
4195 XSTRING (dir
)->data
[0] = '~';
4198 if (insert_default_directory
)
4201 if (!NILP (initial
))
4203 Lisp_Object args
[2], pos
;
4207 insdef
= Fconcat (2, args
);
4208 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
4209 insdef1
= Fcons (double_dollars (insdef
), pos
);
4212 insdef1
= double_dollars (insdef
);
4214 else if (!NILP (initial
))
4217 insdef1
= Fcons (double_dollars (insdef
), 0);
4220 insdef
= Qnil
, insdef1
= Qnil
;
4223 count
= specpdl_ptr
- specpdl
;
4224 specbind (intern ("completion-ignore-case"), Qt
);
4227 GCPRO2 (insdef
, default_filename
);
4228 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
4229 dir
, mustmatch
, insdef1
,
4230 Qfile_name_history
);
4233 unbind_to (count
, Qnil
);
4238 error ("No file name specified");
4239 tem
= Fstring_equal (val
, insdef
);
4240 if (!NILP (tem
) && !NILP (default_filename
))
4241 return default_filename
;
4242 if (XSTRING (val
)->size
== 0 && NILP (insdef
))
4244 if (!NILP (default_filename
))
4245 return default_filename
;
4247 error ("No default file name");
4249 return Fsubstitute_in_file_name (val
);
4252 #if 0 /* Old version */
4253 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
4254 /* Don't confuse make-docfile by having two doc strings for this function.
4255 make-docfile does not pay attention to #if, for good reason! */
4257 (prompt
, dir
, defalt
, mustmatch
, initial
)
4258 Lisp_Object prompt
, dir
, defalt
, mustmatch
, initial
;
4260 Lisp_Object val
, insdef
, tem
;
4261 struct gcpro gcpro1
, gcpro2
;
4262 register char *homedir
;
4266 dir
= current_buffer
->directory
;
4268 defalt
= current_buffer
->filename
;
4270 /* If dir starts with user's homedir, change that to ~. */
4271 homedir
= (char *) egetenv ("HOME");
4274 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
4275 && XSTRING (dir
)->data
[strlen (homedir
)] == '/')
4277 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
4278 XSTRING (dir
)->size
- strlen (homedir
) + 1);
4279 XSTRING (dir
)->data
[0] = '~';
4282 if (!NILP (initial
))
4284 else if (insert_default_directory
)
4287 insdef
= build_string ("");
4290 count
= specpdl_ptr
- specpdl
;
4291 specbind (intern ("completion-ignore-case"), Qt
);
4294 GCPRO2 (insdef
, defalt
);
4295 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
4297 insert_default_directory
? insdef
: Qnil
,
4298 Qfile_name_history
);
4301 unbind_to (count
, Qnil
);
4306 error ("No file name specified");
4307 tem
= Fstring_equal (val
, insdef
);
4308 if (!NILP (tem
) && !NILP (defalt
))
4310 return Fsubstitute_in_file_name (val
);
4312 #endif /* Old version */
4316 Qexpand_file_name
= intern ("expand-file-name");
4317 Qsubstitute_in_file_name
= intern ("substitute-in-file-name");
4318 Qdirectory_file_name
= intern ("directory-file-name");
4319 Qfile_name_directory
= intern ("file-name-directory");
4320 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
4321 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
4322 Qfile_name_as_directory
= intern ("file-name-as-directory");
4323 Qcopy_file
= intern ("copy-file");
4324 Qmake_directory_internal
= intern ("make-directory-internal");
4325 Qdelete_directory
= intern ("delete-directory");
4326 Qdelete_file
= intern ("delete-file");
4327 Qrename_file
= intern ("rename-file");
4328 Qadd_name_to_file
= intern ("add-name-to-file");
4329 Qmake_symbolic_link
= intern ("make-symbolic-link");
4330 Qfile_exists_p
= intern ("file-exists-p");
4331 Qfile_executable_p
= intern ("file-executable-p");
4332 Qfile_readable_p
= intern ("file-readable-p");
4333 Qfile_symlink_p
= intern ("file-symlink-p");
4334 Qfile_writable_p
= intern ("file-writable-p");
4335 Qfile_directory_p
= intern ("file-directory-p");
4336 Qfile_regular_p
= intern ("file-regular-p");
4337 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
4338 Qfile_modes
= intern ("file-modes");
4339 Qset_file_modes
= intern ("set-file-modes");
4340 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
4341 Qinsert_file_contents
= intern ("insert-file-contents");
4342 Qwrite_region
= intern ("write-region");
4343 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
4344 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
4346 staticpro (&Qexpand_file_name
);
4347 staticpro (&Qsubstitute_in_file_name
);
4348 staticpro (&Qdirectory_file_name
);
4349 staticpro (&Qfile_name_directory
);
4350 staticpro (&Qfile_name_nondirectory
);
4351 staticpro (&Qunhandled_file_name_directory
);
4352 staticpro (&Qfile_name_as_directory
);
4353 staticpro (&Qcopy_file
);
4354 staticpro (&Qmake_directory_internal
);
4355 staticpro (&Qdelete_directory
);
4356 staticpro (&Qdelete_file
);
4357 staticpro (&Qrename_file
);
4358 staticpro (&Qadd_name_to_file
);
4359 staticpro (&Qmake_symbolic_link
);
4360 staticpro (&Qfile_exists_p
);
4361 staticpro (&Qfile_executable_p
);
4362 staticpro (&Qfile_readable_p
);
4363 staticpro (&Qfile_symlink_p
);
4364 staticpro (&Qfile_writable_p
);
4365 staticpro (&Qfile_directory_p
);
4366 staticpro (&Qfile_regular_p
);
4367 staticpro (&Qfile_accessible_directory_p
);
4368 staticpro (&Qfile_modes
);
4369 staticpro (&Qset_file_modes
);
4370 staticpro (&Qfile_newer_than_file_p
);
4371 staticpro (&Qinsert_file_contents
);
4372 staticpro (&Qwrite_region
);
4373 staticpro (&Qverify_visited_file_modtime
);
4375 Qfile_name_history
= intern ("file-name-history");
4376 Fset (Qfile_name_history
, Qnil
);
4377 staticpro (&Qfile_name_history
);
4379 Qfile_error
= intern ("file-error");
4380 staticpro (&Qfile_error
);
4381 Qfile_already_exists
= intern("file-already-exists");
4382 staticpro (&Qfile_already_exists
);
4385 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
4386 staticpro (&Qfind_buffer_file_type
);
4389 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format
,
4390 "*Format in which to write auto-save files.\n\
4391 Should be a list of symbols naming formats that are defined in `format-alist'.\n\
4392 If it is t, which is the default, auto-save files are written in the\n\
4393 same format as a regular save would use.");
4394 Vauto_save_file_format
= Qt
;
4396 Qformat_decode
= intern ("format-decode");
4397 staticpro (&Qformat_decode
);
4398 Qformat_annotate_function
= intern ("format-annotate-function");
4399 staticpro (&Qformat_annotate_function
);
4401 Qcar_less_than_car
= intern ("car-less-than-car");
4402 staticpro (&Qcar_less_than_car
);
4404 Fput (Qfile_error
, Qerror_conditions
,
4405 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
4406 Fput (Qfile_error
, Qerror_message
,
4407 build_string ("File error"));
4409 Fput (Qfile_already_exists
, Qerror_conditions
,
4410 Fcons (Qfile_already_exists
,
4411 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
4412 Fput (Qfile_already_exists
, Qerror_message
,
4413 build_string ("File already exists"));
4415 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
4416 "*Non-nil means when reading a filename start with default dir in minibuffer.");
4417 insert_default_directory
= 1;
4419 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
4420 "*Non-nil means write new files with record format `stmlf'.\n\
4421 nil means use format `var'. This variable is meaningful only on VMS.");
4422 vms_stmlf_recfm
= 0;
4424 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
4425 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
4426 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
4429 The first argument given to HANDLER is the name of the I/O primitive\n\
4430 to be handled; the remaining arguments are the arguments that were\n\
4431 passed to that primitive. For example, if you do\n\
4432 (file-exists-p FILENAME)\n\
4433 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
4434 (funcall HANDLER 'file-exists-p FILENAME)\n\
4435 The function `find-file-name-handler' checks this list for a handler\n\
4436 for its argument.");
4437 Vfile_name_handler_alist
= Qnil
;
4439 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
4440 "A list of functions to be called at the end of `insert-file-contents'.\n\
4441 Each is passed one argument, the number of bytes inserted. It should return\n\
4442 the new byte count, and leave point the same. If `insert-file-contents' is\n\
4443 intercepted by a handler from `file-name-handler-alist', that handler is\n\
4444 responsible for calling the after-insert-file-functions if appropriate.");
4445 Vafter_insert_file_functions
= Qnil
;
4447 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
4448 "A list of functions to be called at the start of `write-region'.\n\
4449 Each is passed two arguments, START and END as for `write-region'. It should\n\
4450 return a list of pairs (POSITION . STRING) of strings to be effectively\n\
4451 inserted at the specified positions of the file being written (1 means to\n\
4452 insert before the first byte written). The POSITIONs must be sorted into\n\
4453 increasing order. If there are several functions in the list, the several\n\
4454 lists are merged destructively.");
4455 Vwrite_region_annotate_functions
= Qnil
;
4457 DEFVAR_LISP ("write-region-annotations-so-far",
4458 &Vwrite_region_annotations_so_far
,
4459 "When an annotation function is called, this holds the previous annotations.\n\
4460 These are the annotations made by other annotation functions\n\
4461 that were already called. See also `write-region-annotate-functions'.");
4462 Vwrite_region_annotations_so_far
= Qnil
;
4464 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
4465 "A list of file name handlers that temporarily should not be used.\n\
4466 This applies only to the operation `inhibit-file-name-operation'.");
4467 Vinhibit_file_name_handlers
= Qnil
;
4469 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
4470 "The operation for which `inhibit-file-name-handlers' is applicable.");
4471 Vinhibit_file_name_operation
= Qnil
;
4473 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
4474 "File name in which we write a list of all auto save file names.\n\
4475 This variable is initialized automatically from `auto-save-list-file-prefix'\n\
4476 shortly after Emacs reads your `.emacs' file, if you have not yet given it\n\
4478 Vauto_save_list_file_name
= Qnil
;
4480 defsubr (&Sfind_file_name_handler
);
4481 defsubr (&Sfile_name_directory
);
4482 defsubr (&Sfile_name_nondirectory
);
4483 defsubr (&Sunhandled_file_name_directory
);
4484 defsubr (&Sfile_name_as_directory
);
4485 defsubr (&Sdirectory_file_name
);
4486 defsubr (&Smake_temp_name
);
4487 defsubr (&Sexpand_file_name
);
4488 defsubr (&Ssubstitute_in_file_name
);
4489 defsubr (&Scopy_file
);
4490 defsubr (&Smake_directory_internal
);
4491 defsubr (&Sdelete_directory
);
4492 defsubr (&Sdelete_file
);
4493 defsubr (&Srename_file
);
4494 defsubr (&Sadd_name_to_file
);
4496 defsubr (&Smake_symbolic_link
);
4497 #endif /* S_IFLNK */
4499 defsubr (&Sdefine_logical_name
);
4502 defsubr (&Ssysnetunam
);
4503 #endif /* HPUX_NET */
4504 defsubr (&Sfile_name_absolute_p
);
4505 defsubr (&Sfile_exists_p
);
4506 defsubr (&Sfile_executable_p
);
4507 defsubr (&Sfile_readable_p
);
4508 defsubr (&Sfile_writable_p
);
4509 defsubr (&Sfile_symlink_p
);
4510 defsubr (&Sfile_directory_p
);
4511 defsubr (&Sfile_accessible_directory_p
);
4512 defsubr (&Sfile_regular_p
);
4513 defsubr (&Sfile_modes
);
4514 defsubr (&Sset_file_modes
);
4515 defsubr (&Sset_default_file_modes
);
4516 defsubr (&Sdefault_file_modes
);
4517 defsubr (&Sfile_newer_than_file_p
);
4518 defsubr (&Sinsert_file_contents
);
4519 defsubr (&Swrite_region
);
4520 defsubr (&Scar_less_than_car
);
4521 defsubr (&Sverify_visited_file_modtime
);
4522 defsubr (&Sclear_visited_file_modtime
);
4523 defsubr (&Svisited_file_modtime
);
4524 defsubr (&Sset_visited_file_modtime
);
4525 defsubr (&Sdo_auto_save
);
4526 defsubr (&Sset_buffer_auto_saved
);
4527 defsubr (&Sclear_buffer_auto_save_failure
);
4528 defsubr (&Srecent_auto_save_p
);
4530 defsubr (&Sread_file_name_internal
);
4531 defsubr (&Sread_file_name
);
4534 defsubr (&Sunix_sync
);