1 /* File IO for GNU Emacs.
2 Copyright (C) 1985,86,87,88,93,94,95,96,97,1998 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 #if defined (USG5) || defined (BSD_SYSTEM) || defined (LINUX)
28 #include <sys/types.h>
35 #if !defined (S_ISLNK) && defined (S_IFLNK)
36 # define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
39 #if !defined (S_ISFIFO) && defined (S_IFIFO)
40 # define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO)
43 #if !defined (S_ISREG) && defined (S_IFREG)
44 # define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
55 #include <sys/param.h>
77 extern char *strerror ();
94 #include "intervals.h"
105 #endif /* not WINDOWSNT */
108 #define CORRECT_DIR_SEPS(s) \
109 do { if ('/' == DIRECTORY_SEP) dostounix_filename (s); \
110 else unixtodos_filename (s); \
112 /* On Windows, drive letters must be alphabetic - on DOS, the Netware
113 redirector allows the six letters between 'Z' and 'a' as well. */
115 #define IS_DRIVE(x) ((x) >= 'A' && (x) <= 'z')
118 #define IS_DRIVE(x) isalpha (x)
120 /* Need to lower-case the drive letter, or else expanded
121 filenames will sometimes compare inequal, because
122 `expand-file-name' doesn't always down-case the drive letter. */
123 #define DRIVE_LETTER(x) (tolower (x))
152 #define min(a, b) ((a) < (b) ? (a) : (b))
153 #define max(a, b) ((a) > (b) ? (a) : (b))
155 /* Encode the file name NAME using the specified coding system
156 for file names, if any. */
157 #define ENCODE_FILE(name) \
158 (! NILP (Vfile_name_coding_system) \
159 && XFASTINT (Vfile_name_coding_system) != 0 \
160 ? Fencode_coding_string (name, Vfile_name_coding_system, Qt) \
163 /* Nonzero during writing of auto-save files */
166 /* Set by auto_save_1 to mode of original file so Fwrite_region will create
167 a new file with the same mode as the original */
168 int auto_save_mode_bits
;
170 /* Coding system for file names, or nil if none. */
171 Lisp_Object Vfile_name_coding_system
;
173 /* Alist of elements (REGEXP . HANDLER) for file names
174 whose I/O is done with a special handler. */
175 Lisp_Object Vfile_name_handler_alist
;
177 /* Format for auto-save files */
178 Lisp_Object Vauto_save_file_format
;
180 /* Lisp functions for translating file formats */
181 Lisp_Object Qformat_decode
, Qformat_annotate_function
;
183 /* Function to be called to decide a coding system of a reading file. */
184 Lisp_Object Vset_auto_coding_function
;
186 /* Functions to be called to process text properties in inserted file. */
187 Lisp_Object Vafter_insert_file_functions
;
189 /* Functions to be called to create text property annotations for file. */
190 Lisp_Object Vwrite_region_annotate_functions
;
192 /* During build_annotations, each time an annotation function is called,
193 this holds the annotations made by the previous functions. */
194 Lisp_Object Vwrite_region_annotations_so_far
;
196 /* File name in which we write a list of all our auto save files. */
197 Lisp_Object Vauto_save_list_file_name
;
199 /* Nonzero means, when reading a filename in the minibuffer,
200 start out by inserting the default directory into the minibuffer. */
201 int insert_default_directory
;
203 /* On VMS, nonzero means write new files with record format stmlf.
204 Zero means use var format. */
207 /* On NT, specifies the directory separator character, used (eg.) when
208 expanding file names. This can be bound to / or \. */
209 Lisp_Object Vdirectory_sep_char
;
211 extern Lisp_Object Vuser_login_name
;
213 extern int minibuf_level
;
215 extern int minibuffer_auto_raise
;
217 /* These variables describe handlers that have "already" had a chance
218 to handle the current operation.
220 Vinhibit_file_name_handlers is a list of file name handlers.
221 Vinhibit_file_name_operation is the operation being handled.
222 If we try to handle that operation, we ignore those handlers. */
224 static Lisp_Object Vinhibit_file_name_handlers
;
225 static Lisp_Object Vinhibit_file_name_operation
;
227 Lisp_Object Qfile_error
, Qfile_already_exists
, Qfile_date_error
;
229 Lisp_Object Qfile_name_history
;
231 Lisp_Object Qcar_less_than_car
;
233 static int a_write
P_ ((int, char *, int, int,
234 Lisp_Object
*, struct coding_system
*));
235 static int e_write
P_ ((int, char *, int, struct coding_system
*));
238 report_file_error (string
, data
)
242 Lisp_Object errstring
;
244 errstring
= build_string (strerror (errno
));
246 /* System error messages are capitalized. Downcase the initial
247 unless it is followed by a slash. */
248 if (XSTRING (errstring
)->data
[1] != '/')
249 XSTRING (errstring
)->data
[0] = DOWNCASE (XSTRING (errstring
)->data
[0]);
252 Fsignal (Qfile_error
,
253 Fcons (build_string (string
), Fcons (errstring
, data
)));
257 close_file_unwind (fd
)
260 close (XFASTINT (fd
));
264 /* Restore point, having saved it as a marker. */
267 restore_point_unwind (location
)
268 Lisp_Object location
;
270 Fgoto_char (location
);
271 Fset_marker (location
, Qnil
, Qnil
);
275 Lisp_Object Qexpand_file_name
;
276 Lisp_Object Qsubstitute_in_file_name
;
277 Lisp_Object Qdirectory_file_name
;
278 Lisp_Object Qfile_name_directory
;
279 Lisp_Object Qfile_name_nondirectory
;
280 Lisp_Object Qunhandled_file_name_directory
;
281 Lisp_Object Qfile_name_as_directory
;
282 Lisp_Object Qcopy_file
;
283 Lisp_Object Qmake_directory_internal
;
284 Lisp_Object Qdelete_directory
;
285 Lisp_Object Qdelete_file
;
286 Lisp_Object Qrename_file
;
287 Lisp_Object Qadd_name_to_file
;
288 Lisp_Object Qmake_symbolic_link
;
289 Lisp_Object Qfile_exists_p
;
290 Lisp_Object Qfile_executable_p
;
291 Lisp_Object Qfile_readable_p
;
292 Lisp_Object Qfile_writable_p
;
293 Lisp_Object Qfile_symlink_p
;
294 Lisp_Object Qaccess_file
;
295 Lisp_Object Qfile_directory_p
;
296 Lisp_Object Qfile_regular_p
;
297 Lisp_Object Qfile_accessible_directory_p
;
298 Lisp_Object Qfile_modes
;
299 Lisp_Object Qset_file_modes
;
300 Lisp_Object Qfile_newer_than_file_p
;
301 Lisp_Object Qinsert_file_contents
;
302 Lisp_Object Qwrite_region
;
303 Lisp_Object Qverify_visited_file_modtime
;
304 Lisp_Object Qset_visited_file_modtime
;
306 DEFUN ("find-file-name-handler", Ffind_file_name_handler
, Sfind_file_name_handler
, 2, 2, 0,
307 "Return FILENAME's handler function for OPERATION, if it has one.\n\
308 Otherwise, return nil.\n\
309 A file name is handled if one of the regular expressions in\n\
310 `file-name-handler-alist' matches it.\n\n\
311 If OPERATION equals `inhibit-file-name-operation', then we ignore\n\
312 any handlers that are members of `inhibit-file-name-handlers',\n\
313 but we still do run any other handlers. This lets handlers\n\
314 use the standard functions without calling themselves recursively.")
315 (filename
, operation
)
316 Lisp_Object filename
, operation
;
318 /* This function must not munge the match data. */
319 Lisp_Object chain
, inhibited_handlers
;
321 CHECK_STRING (filename
, 0);
323 if (EQ (operation
, Vinhibit_file_name_operation
))
324 inhibited_handlers
= Vinhibit_file_name_handlers
;
326 inhibited_handlers
= Qnil
;
328 for (chain
= Vfile_name_handler_alist
; CONSP (chain
);
329 chain
= XCONS (chain
)->cdr
)
332 elt
= XCONS (chain
)->car
;
336 string
= XCONS (elt
)->car
;
337 if (STRINGP (string
) && fast_string_match (string
, filename
) >= 0)
339 Lisp_Object handler
, tem
;
341 handler
= XCONS (elt
)->cdr
;
342 tem
= Fmemq (handler
, inhibited_handlers
);
353 DEFUN ("file-name-directory", Ffile_name_directory
, Sfile_name_directory
,
355 "Return the directory component in file name FILENAME.\n\
356 Return nil if FILENAME does not include a directory.\n\
357 Otherwise return a directory spec.\n\
358 Given a Unix syntax file name, returns a string ending in slash;\n\
359 on VMS, perhaps instead a string ending in `:', `]' or `>'.")
361 Lisp_Object filename
;
363 register unsigned char *beg
;
364 register unsigned char *p
;
367 CHECK_STRING (filename
, 0);
369 /* If the file name has special constructs in it,
370 call the corresponding file handler. */
371 handler
= Ffind_file_name_handler (filename
, Qfile_name_directory
);
373 return call2 (handler
, Qfile_name_directory
, filename
);
375 #ifdef FILE_SYSTEM_CASE
376 filename
= FILE_SYSTEM_CASE (filename
);
378 beg
= XSTRING (filename
)->data
;
380 beg
= strcpy (alloca (strlen (beg
) + 1), beg
);
382 p
= beg
+ XSTRING (filename
)->size
;
384 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
386 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
389 /* only recognise drive specifier at beginning */
390 && !(p
[-1] == ':' && p
== beg
+ 2)
397 /* Expansion of "c:" to drive and default directory. */
398 if (p
== beg
+ 2 && beg
[1] == ':')
400 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
401 unsigned char *res
= alloca (MAXPATHLEN
+ 1);
402 if (getdefdir (toupper (*beg
) - 'A' + 1, res
))
404 if (!IS_DIRECTORY_SEP (res
[strlen (res
) - 1]))
407 p
= beg
+ strlen (beg
);
410 CORRECT_DIR_SEPS (beg
);
413 if (STRING_MULTIBYTE (filename
))
414 return make_string (beg
, p
- beg
);
415 return make_unibyte_string (beg
, p
- beg
);
418 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory
,
419 Sfile_name_nondirectory
, 1, 1, 0,
420 "Return file name FILENAME sans its directory.\n\
421 For example, in a Unix-syntax file name,\n\
422 this is everything after the last slash,\n\
423 or the entire name if it contains no slash.")
425 Lisp_Object filename
;
427 register unsigned char *beg
, *p
, *end
;
430 CHECK_STRING (filename
, 0);
432 /* If the file name has special constructs in it,
433 call the corresponding file handler. */
434 handler
= Ffind_file_name_handler (filename
, Qfile_name_nondirectory
);
436 return call2 (handler
, Qfile_name_nondirectory
, filename
);
438 beg
= XSTRING (filename
)->data
;
439 end
= p
= beg
+ XSTRING (filename
)->size
;
441 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
443 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
446 /* only recognise drive specifier at beginning */
447 && !(p
[-1] == ':' && p
== beg
+ 2)
452 if (STRING_MULTIBYTE (filename
))
453 return make_string (p
, end
- p
);
454 return make_unibyte_string (p
, end
- p
);
457 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory
,
458 Sunhandled_file_name_directory
, 1, 1, 0,
459 "Return a directly usable directory name somehow associated with FILENAME.\n\
460 A `directly usable' directory name is one that may be used without the\n\
461 intervention of any file handler.\n\
462 If FILENAME is a directly usable file itself, return\n\
463 \(file-name-directory FILENAME).\n\
464 The `call-process' and `start-process' functions use this function to\n\
465 get a current directory to run processes in.")
467 Lisp_Object filename
;
471 /* If the file name has special constructs in it,
472 call the corresponding file handler. */
473 handler
= Ffind_file_name_handler (filename
, Qunhandled_file_name_directory
);
475 return call2 (handler
, Qunhandled_file_name_directory
, filename
);
477 return Ffile_name_directory (filename
);
482 file_name_as_directory (out
, in
)
485 int size
= strlen (in
) - 1;
488 error ("Empty file name");
493 /* Is it already a directory string? */
494 if (in
[size
] == ':' || in
[size
] == ']' || in
[size
] == '>')
496 /* Is it a VMS directory file name? If so, hack VMS syntax. */
497 else if (! index (in
, '/')
498 && ((size
> 3 && ! strcmp (&in
[size
- 3], ".DIR"))
499 || (size
> 3 && ! strcmp (&in
[size
- 3], ".dir"))
500 || (size
> 5 && (! strncmp (&in
[size
- 5], ".DIR", 4)
501 || ! strncmp (&in
[size
- 5], ".dir", 4))
502 && (in
[size
- 1] == '.' || in
[size
- 1] == ';')
503 && in
[size
] == '1')))
505 register char *p
, *dot
;
509 dir:x.dir --> dir:[x]
510 dir:[x]y.dir --> dir:[x.y] */
512 while (p
!= in
&& *p
!= ':' && *p
!= '>' && *p
!= ']') p
--;
515 strncpy (out
, in
, p
- in
);
534 dot
= index (p
, '.');
537 /* blindly remove any extension */
538 size
= strlen (out
) + (dot
- p
);
539 strncat (out
, p
, dot
- p
);
550 /* For Unix syntax, Append a slash if necessary */
551 if (!IS_DIRECTORY_SEP (out
[size
]))
553 out
[size
+ 1] = DIRECTORY_SEP
;
554 out
[size
+ 2] = '\0';
557 CORRECT_DIR_SEPS (out
);
563 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
564 Sfile_name_as_directory
, 1, 1, 0,
565 "Return a string representing file FILENAME interpreted as a directory.\n\
566 This operation exists because a directory is also a file, but its name as\n\
567 a directory is different from its name as a file.\n\
568 The result can be used as the value of `default-directory'\n\
569 or passed as second argument to `expand-file-name'.\n\
570 For a Unix-syntax file name, just appends a slash.\n\
571 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
578 CHECK_STRING (file
, 0);
582 /* If the file name has special constructs in it,
583 call the corresponding file handler. */
584 handler
= Ffind_file_name_handler (file
, Qfile_name_as_directory
);
586 return call2 (handler
, Qfile_name_as_directory
, file
);
588 buf
= (char *) alloca (XSTRING (file
)->size
+ 10);
589 return build_string (file_name_as_directory (buf
, XSTRING (file
)->data
));
593 * Convert from directory name to filename.
595 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
596 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
597 * On UNIX, it's simple: just make sure there isn't a terminating /
599 * Value is nonzero if the string output is different from the input.
602 directory_file_name (src
, dst
)
610 struct FAB fab
= cc$rms_fab
;
611 struct NAM nam
= cc$rms_nam
;
612 char esa
[NAM$C_MAXRSS
];
617 if (! index (src
, '/')
618 && (src
[slen
- 1] == ']'
619 || src
[slen
- 1] == ':'
620 || src
[slen
- 1] == '>'))
622 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
624 fab
.fab$b_fns
= slen
;
625 fab
.fab$l_nam
= &nam
;
626 fab
.fab$l_fop
= FAB$M_NAM
;
629 nam
.nam$b_ess
= sizeof esa
;
630 nam
.nam$b_nop
|= NAM$M_SYNCHK
;
632 /* We call SYS$PARSE to handle such things as [--] for us. */
633 if (SYS$
PARSE (&fab
, 0, 0) == RMS$_NORMAL
)
635 slen
= nam
.nam$b_esl
;
636 if (esa
[slen
- 1] == ';' && esa
[slen
- 2] == '.')
641 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
643 /* what about when we have logical_name:???? */
644 if (src
[slen
- 1] == ':')
645 { /* Xlate logical name and see what we get */
646 ptr
= strcpy (dst
, src
); /* upper case for getenv */
649 if ('a' <= *ptr
&& *ptr
<= 'z')
653 dst
[slen
- 1] = 0; /* remove colon */
654 if (!(src
= egetenv (dst
)))
656 /* should we jump to the beginning of this procedure?
657 Good points: allows us to use logical names that xlate
659 Bad points: can be a problem if we just translated to a device
661 For now, I'll punt and always expect VMS names, and hope for
664 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
665 { /* no recursion here! */
671 { /* not a directory spec */
676 bracket
= src
[slen
- 1];
678 /* If bracket is ']' or '>', bracket - 2 is the corresponding
680 ptr
= index (src
, bracket
- 2);
682 { /* no opening bracket */
686 if (!(rptr
= rindex (src
, '.')))
689 strncpy (dst
, src
, slen
);
693 dst
[slen
++] = bracket
;
698 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
699 then translate the device and recurse. */
700 if (dst
[slen
- 1] == ':'
701 && dst
[slen
- 2] != ':' /* skip decnet nodes */
702 && strcmp (src
+ slen
, "[000000]") == 0)
704 dst
[slen
- 1] = '\0';
705 if ((ptr
= egetenv (dst
))
706 && (rlen
= strlen (ptr
) - 1) > 0
707 && (ptr
[rlen
] == ']' || ptr
[rlen
] == '>')
708 && ptr
[rlen
- 1] == '.')
710 char * buf
= (char *) alloca (strlen (ptr
) + 1);
714 return directory_file_name (buf
, dst
);
719 strcat (dst
, "[000000]");
723 rlen
= strlen (rptr
) - 1;
724 strncat (dst
, rptr
, rlen
);
725 dst
[slen
+ rlen
] = '\0';
726 strcat (dst
, ".DIR.1");
730 /* Process as Unix format: just remove any final slash.
731 But leave "/" unchanged; do not change it to "". */
734 /* Handle // as root for apollo's. */
735 if ((slen
> 2 && dst
[slen
- 1] == '/')
736 || (slen
> 1 && dst
[0] != '/' && dst
[slen
- 1] == '/'))
740 && IS_DIRECTORY_SEP (dst
[slen
- 1])
742 && !IS_ANY_SEP (dst
[slen
- 2])
748 CORRECT_DIR_SEPS (dst
);
753 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
755 "Returns the file name of the directory named DIRECTORY.\n\
756 This is the name of the file that holds the data for the directory DIRECTORY.\n\
757 This operation exists because a directory is also a file, but its name as\n\
758 a directory is different from its name as a file.\n\
759 In Unix-syntax, this function just removes the final slash.\n\
760 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
761 it returns a file name such as \"[X]Y.DIR.1\".")
763 Lisp_Object directory
;
768 CHECK_STRING (directory
, 0);
770 if (NILP (directory
))
773 /* If the file name has special constructs in it,
774 call the corresponding file handler. */
775 handler
= Ffind_file_name_handler (directory
, Qdirectory_file_name
);
777 return call2 (handler
, Qdirectory_file_name
, directory
);
780 /* 20 extra chars is insufficient for VMS, since we might perform a
781 logical name translation. an equivalence string can be up to 255
782 chars long, so grab that much extra space... - sss */
783 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20 + 255);
785 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20);
787 directory_file_name (XSTRING (directory
)->data
, buf
);
788 return build_string (buf
);
791 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
792 "Generate temporary file name (string) starting with PREFIX (a string).\n\
793 The Emacs process number forms part of the result,\n\
794 so there is no danger of generating a name being used by another process.\n\
795 In addition, this function makes an attempt to choose a name\n\
796 which has no existing file.")
802 /* Don't use too many characters of the restricted 8+3 DOS
804 val
= concat2 (prefix
, build_string ("a.XXX"));
806 val
= concat2 (prefix
, build_string ("XXXXXX"));
808 mktemp (XSTRING (val
)->data
);
810 CORRECT_DIR_SEPS (XSTRING (val
)->data
);
815 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
816 "Convert filename NAME to absolute, and canonicalize it.\n\
817 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative\n\
818 (does not start with slash); if DEFAULT-DIRECTORY is nil or missing,\n\
819 the current buffer's value of default-directory is used.\n\
820 File name components that are `.' are removed, and \n\
821 so are file name components followed by `..', along with the `..' itself;\n\
822 note that these simplifications are done without checking the resulting\n\
823 file names in the file system.\n\
824 An initial `~/' expands to your home directory.\n\
825 An initial `~USER/' expands to USER's home directory.\n\
826 See also the function `substitute-in-file-name'.")
827 (name
, default_directory
)
828 Lisp_Object name
, default_directory
;
832 register unsigned char *newdir
, *p
, *o
;
834 unsigned char *target
;
837 unsigned char * colon
= 0;
838 unsigned char * close
= 0;
839 unsigned char * slash
= 0;
840 unsigned char * brack
= 0;
841 int lbrack
= 0, rbrack
= 0;
846 int collapse_newdir
= 1;
851 CHECK_STRING (name
, 0);
853 /* If the file name has special constructs in it,
854 call the corresponding file handler. */
855 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
857 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
859 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
860 if (NILP (default_directory
))
861 default_directory
= current_buffer
->directory
;
862 if (! STRINGP (default_directory
))
863 default_directory
= build_string ("/");
865 if (!NILP (default_directory
))
867 handler
= Ffind_file_name_handler (default_directory
, Qexpand_file_name
);
869 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
872 o
= XSTRING (default_directory
)->data
;
874 /* Make sure DEFAULT_DIRECTORY is properly expanded.
875 It would be better to do this down below where we actually use
876 default_directory. Unfortunately, calling Fexpand_file_name recursively
877 could invoke GC, and the strings might be relocated. This would
878 be annoying because we have pointers into strings lying around
879 that would need adjusting, and people would add new pointers to
880 the code and forget to adjust them, resulting in intermittent bugs.
881 Putting this call here avoids all that crud.
883 The EQ test avoids infinite recursion. */
884 if (! NILP (default_directory
) && !EQ (default_directory
, name
)
885 /* Save time in some common cases - as long as default_directory
886 is not relative, it can be canonicalized with name below (if it
887 is needed at all) without requiring it to be expanded now. */
889 /* Detect MSDOS file names with drive specifiers. */
890 && ! (IS_DRIVE (o
[0]) && (IS_DEVICE_SEP (o
[1]) && IS_DIRECTORY_SEP (o
[2])))
892 /* Detect Windows file names in UNC format. */
893 && ! (IS_DIRECTORY_SEP (o
[0]) && IS_DIRECTORY_SEP (o
[1]))
895 #else /* not DOS_NT */
896 /* Detect Unix absolute file names (/... alone is not absolute on
898 && ! (IS_DIRECTORY_SEP (o
[0]))
899 #endif /* not DOS_NT */
905 default_directory
= Fexpand_file_name (default_directory
, Qnil
);
910 /* Filenames on VMS are always upper case. */
911 name
= Fupcase (name
);
913 #ifdef FILE_SYSTEM_CASE
914 name
= FILE_SYSTEM_CASE (name
);
917 nm
= XSTRING (name
)->data
;
920 /* We will force directory separators to be either all \ or /, so make
921 a local copy to modify, even if there ends up being no change. */
922 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
924 /* Find and remove drive specifier if present; this makes nm absolute
925 even if the rest of the name appears to be relative. */
927 unsigned char *colon
= rindex (nm
, ':');
930 /* Only recognize colon as part of drive specifier if there is a
931 single alphabetic character preceeding the colon (and if the
932 character before the drive letter, if present, is a directory
933 separator); this is to support the remote system syntax used by
934 ange-ftp, and the "po:username" syntax for POP mailboxes. */
938 else if (IS_DRIVE (colon
[-1])
939 && (colon
== nm
+ 1 || IS_DIRECTORY_SEP (colon
[-2])))
946 while (--colon
>= nm
)
953 /* If we see "c://somedir", we want to strip the first slash after the
954 colon when stripping the drive letter. Otherwise, this expands to
956 if (drive
&& IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
958 #endif /* WINDOWSNT */
962 /* Discard any previous drive specifier if nm is now in UNC format. */
963 if (IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
969 /* If nm is absolute, look for /./ or /../ sequences; if none are
970 found, we can probably return right away. We will avoid allocating
971 a new string if name is already fully expanded. */
973 IS_DIRECTORY_SEP (nm
[0])
978 && (drive
|| IS_DIRECTORY_SEP (nm
[1]))
985 /* If it turns out that the filename we want to return is just a
986 suffix of FILENAME, we don't need to go through and edit
987 things; we just need to construct a new string using data
988 starting at the middle of FILENAME. If we set lose to a
989 non-zero value, that means we've discovered that we can't do
996 /* Since we know the name is absolute, we can assume that each
997 element starts with a "/". */
999 /* "." and ".." are hairy. */
1000 if (IS_DIRECTORY_SEP (p
[0])
1002 && (IS_DIRECTORY_SEP (p
[2])
1004 || (p
[2] == '.' && (IS_DIRECTORY_SEP (p
[3])
1011 /* if dev:[dir]/, move nm to / */
1012 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1013 nm
= (brack
? brack
+ 1 : colon
+ 1);
1014 lbrack
= rbrack
= 0;
1022 /* VMS pre V4.4,convert '-'s in filenames. */
1023 if (lbrack
== rbrack
)
1025 if (dots
< 2) /* this is to allow negative version numbers */
1030 if (lbrack
> rbrack
&&
1031 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1032 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1038 /* count open brackets, reset close bracket pointer */
1039 if (p
[0] == '[' || p
[0] == '<')
1040 lbrack
++, brack
= 0;
1041 /* count close brackets, set close bracket pointer */
1042 if (p
[0] == ']' || p
[0] == '>')
1043 rbrack
++, brack
= p
;
1044 /* detect ][ or >< */
1045 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1047 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1048 nm
= p
+ 1, lose
= 1;
1049 if (p
[0] == ':' && (colon
|| slash
))
1050 /* if dev1:[dir]dev2:, move nm to dev2: */
1056 /* if /name/dev:, move nm to dev: */
1059 /* if node::dev:, move colon following dev */
1060 else if (colon
&& colon
[-1] == ':')
1062 /* if dev1:dev2:, move nm to dev2: */
1063 else if (colon
&& colon
[-1] != ':')
1068 if (p
[0] == ':' && !colon
)
1074 if (lbrack
== rbrack
)
1077 else if (p
[0] == '.')
1085 if (index (nm
, '/'))
1086 return build_string (sys_translate_unix (nm
));
1089 /* Make sure directories are all separated with / or \ as
1090 desired, but avoid allocation of a new string when not
1092 CORRECT_DIR_SEPS (nm
);
1094 if (IS_DIRECTORY_SEP (nm
[1]))
1096 if (strcmp (nm
, XSTRING (name
)->data
) != 0)
1097 name
= build_string (nm
);
1101 /* drive must be set, so this is okay */
1102 if (strcmp (nm
- 2, XSTRING (name
)->data
) != 0)
1104 name
= make_string (nm
- 2, p
- nm
+ 2);
1105 XSTRING (name
)->data
[0] = DRIVE_LETTER (drive
);
1106 XSTRING (name
)->data
[1] = ':';
1109 #else /* not DOS_NT */
1110 if (nm
== XSTRING (name
)->data
)
1112 return build_string (nm
);
1113 #endif /* not DOS_NT */
1117 /* At this point, nm might or might not be an absolute file name. We
1118 need to expand ~ or ~user if present, otherwise prefix nm with
1119 default_directory if nm is not absolute, and finally collapse /./
1120 and /foo/../ sequences.
1122 We set newdir to be the appropriate prefix if one is needed:
1123 - the relevant user directory if nm starts with ~ or ~user
1124 - the specified drive's working dir (DOS/NT only) if nm does not
1126 - the value of default_directory.
1128 Note that these prefixes are not guaranteed to be absolute (except
1129 for the working dir of a drive). Therefore, to ensure we always
1130 return an absolute name, if the final prefix is not absolute we
1131 append it to the current working directory. */
1135 if (nm
[0] == '~') /* prefix ~ */
1137 if (IS_DIRECTORY_SEP (nm
[1])
1141 || nm
[1] == 0) /* ~ by itself */
1143 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1144 newdir
= (unsigned char *) "";
1147 collapse_newdir
= 0;
1150 nm
++; /* Don't leave the slash in nm. */
1153 else /* ~user/filename */
1155 for (p
= nm
; *p
&& (!IS_DIRECTORY_SEP (*p
)
1160 o
= (unsigned char *) alloca (p
- nm
+ 1);
1161 bcopy ((char *) nm
, o
, p
- nm
);
1164 pw
= (struct passwd
*) getpwnam (o
+ 1);
1167 newdir
= (unsigned char *) pw
-> pw_dir
;
1169 nm
= p
+ 1; /* skip the terminator */
1173 collapse_newdir
= 0;
1178 /* If we don't find a user of that name, leave the name
1179 unchanged; don't move nm forward to p. */
1184 /* On DOS and Windows, nm is absolute if a drive name was specified;
1185 use the drive's current directory as the prefix if needed. */
1186 if (!newdir
&& drive
)
1188 /* Get default directory if needed to make nm absolute. */
1189 if (!IS_DIRECTORY_SEP (nm
[0]))
1191 newdir
= alloca (MAXPATHLEN
+ 1);
1192 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1197 /* Either nm starts with /, or drive isn't mounted. */
1198 newdir
= alloca (4);
1199 newdir
[0] = DRIVE_LETTER (drive
);
1207 /* Finally, if no prefix has been specified and nm is not absolute,
1208 then it must be expanded relative to default_directory. */
1212 /* /... alone is not absolute on DOS and Windows. */
1213 && !IS_DIRECTORY_SEP (nm
[0])
1216 && !(IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1223 newdir
= XSTRING (default_directory
)->data
;
1229 /* First ensure newdir is an absolute name. */
1231 /* Detect MSDOS file names with drive specifiers. */
1232 ! (IS_DRIVE (newdir
[0])
1233 && IS_DEVICE_SEP (newdir
[1]) && IS_DIRECTORY_SEP (newdir
[2]))
1235 /* Detect Windows file names in UNC format. */
1236 && ! (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1240 /* Effectively, let newdir be (expand-file-name newdir cwd).
1241 Because of the admonition against calling expand-file-name
1242 when we have pointers into lisp strings, we accomplish this
1243 indirectly by prepending newdir to nm if necessary, and using
1244 cwd (or the wd of newdir's drive) as the new newdir. */
1246 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1251 if (!IS_DIRECTORY_SEP (nm
[0]))
1253 char * tmp
= alloca (strlen (newdir
) + strlen (nm
) + 2);
1254 file_name_as_directory (tmp
, newdir
);
1258 newdir
= alloca (MAXPATHLEN
+ 1);
1261 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1268 /* Strip off drive name from prefix, if present. */
1269 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1275 /* Keep only a prefix from newdir if nm starts with slash
1276 (//server/share for UNC, nothing otherwise). */
1277 if (IS_DIRECTORY_SEP (nm
[0]) && collapse_newdir
)
1280 if (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1282 newdir
= strcpy (alloca (strlen (newdir
) + 1), newdir
);
1284 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1286 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1298 /* Get rid of any slash at the end of newdir, unless newdir is
1299 just // (an incomplete UNC name). */
1300 length
= strlen (newdir
);
1301 if (length
> 0 && IS_DIRECTORY_SEP (newdir
[length
- 1])
1303 && !(length
== 2 && IS_DIRECTORY_SEP (newdir
[0]))
1307 unsigned char *temp
= (unsigned char *) alloca (length
);
1308 bcopy (newdir
, temp
, length
- 1);
1309 temp
[length
- 1] = 0;
1317 /* Now concatenate the directory and name to new space in the stack frame */
1318 tlen
+= strlen (nm
) + 1;
1320 /* Add reserved space for drive name. (The Microsoft x86 compiler
1321 produces incorrect code if the following two lines are combined.) */
1322 target
= (unsigned char *) alloca (tlen
+ 2);
1324 #else /* not DOS_NT */
1325 target
= (unsigned char *) alloca (tlen
);
1326 #endif /* not DOS_NT */
1332 if (nm
[0] == 0 || IS_DIRECTORY_SEP (nm
[0]))
1333 strcpy (target
, newdir
);
1336 file_name_as_directory (target
, newdir
);
1339 strcat (target
, nm
);
1341 if (index (target
, '/'))
1342 strcpy (target
, sys_translate_unix (target
));
1345 /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */
1347 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1355 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1361 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1362 /* brackets are offset from each other by 2 */
1365 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1366 /* convert [foo][bar] to [bar] */
1367 while (o
[-1] != '[' && o
[-1] != '<')
1369 else if (*p
== '-' && *o
!= '.')
1372 else if (p
[0] == '-' && o
[-1] == '.' &&
1373 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1374 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1378 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1379 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1381 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1383 /* else [foo.-] ==> [-] */
1389 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1390 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1396 if (!IS_DIRECTORY_SEP (*p
))
1400 else if (IS_DIRECTORY_SEP (p
[0])
1402 && (IS_DIRECTORY_SEP (p
[2])
1405 /* If "/." is the entire filename, keep the "/". Otherwise,
1406 just delete the whole "/.". */
1407 if (o
== target
&& p
[2] == '\0')
1411 else if (IS_DIRECTORY_SEP (p
[0]) && p
[1] == '.' && p
[2] == '.'
1412 /* `/../' is the "superroot" on certain file systems. */
1414 && (IS_DIRECTORY_SEP (p
[3]) || p
[3] == 0))
1416 while (o
!= target
&& (--o
) && !IS_DIRECTORY_SEP (*o
))
1418 /* Keep initial / only if this is the whole name. */
1419 if (o
== target
&& IS_ANY_SEP (*o
) && p
[3] == 0)
1427 #endif /* not VMS */
1431 /* At last, set drive name. */
1433 /* Except for network file name. */
1434 if (!(IS_DIRECTORY_SEP (target
[0]) && IS_DIRECTORY_SEP (target
[1])))
1435 #endif /* WINDOWSNT */
1437 if (!drive
) abort ();
1439 target
[0] = DRIVE_LETTER (drive
);
1442 CORRECT_DIR_SEPS (target
);
1445 return make_string (target
, o
- target
);
1449 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'. */
1450 DEAFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
1451 "Convert FILENAME to absolute, and canonicalize it.\n\
1452 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1453 (does not start with slash); if DEFAULT is nil or missing,\n\
1454 the current buffer's value of default-directory is used.\n\
1455 Filenames containing `.' or `..' as components are simplified;\n\
1456 initial `~/' expands to your home directory.\n\
1457 See also the function `substitute-in-file-name'.")
1459 Lisp_Object name
, defalt
;
1463 register unsigned char *newdir
, *p
, *o
;
1465 unsigned char *target
;
1469 unsigned char * colon
= 0;
1470 unsigned char * close
= 0;
1471 unsigned char * slash
= 0;
1472 unsigned char * brack
= 0;
1473 int lbrack
= 0, rbrack
= 0;
1477 CHECK_STRING (name
, 0);
1480 /* Filenames on VMS are always upper case. */
1481 name
= Fupcase (name
);
1484 nm
= XSTRING (name
)->data
;
1486 /* If nm is absolute, flush ...// and detect /./ and /../.
1487 If no /./ or /../ we can return right away. */
1499 if (p
[0] == '/' && p
[1] == '/'
1501 /* // at start of filename is meaningful on Apollo system. */
1506 if (p
[0] == '/' && p
[1] == '~')
1507 nm
= p
+ 1, lose
= 1;
1508 if (p
[0] == '/' && p
[1] == '.'
1509 && (p
[2] == '/' || p
[2] == 0
1510 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1516 /* if dev:[dir]/, move nm to / */
1517 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1518 nm
= (brack
? brack
+ 1 : colon
+ 1);
1519 lbrack
= rbrack
= 0;
1527 /* VMS pre V4.4,convert '-'s in filenames. */
1528 if (lbrack
== rbrack
)
1530 if (dots
< 2) /* this is to allow negative version numbers */
1535 if (lbrack
> rbrack
&&
1536 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1537 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1543 /* count open brackets, reset close bracket pointer */
1544 if (p
[0] == '[' || p
[0] == '<')
1545 lbrack
++, brack
= 0;
1546 /* count close brackets, set close bracket pointer */
1547 if (p
[0] == ']' || p
[0] == '>')
1548 rbrack
++, brack
= p
;
1549 /* detect ][ or >< */
1550 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1552 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1553 nm
= p
+ 1, lose
= 1;
1554 if (p
[0] == ':' && (colon
|| slash
))
1555 /* if dev1:[dir]dev2:, move nm to dev2: */
1561 /* If /name/dev:, move nm to dev: */
1564 /* If node::dev:, move colon following dev */
1565 else if (colon
&& colon
[-1] == ':')
1567 /* If dev1:dev2:, move nm to dev2: */
1568 else if (colon
&& colon
[-1] != ':')
1573 if (p
[0] == ':' && !colon
)
1579 if (lbrack
== rbrack
)
1582 else if (p
[0] == '.')
1590 if (index (nm
, '/'))
1591 return build_string (sys_translate_unix (nm
));
1593 if (nm
== XSTRING (name
)->data
)
1595 return build_string (nm
);
1599 /* Now determine directory to start with and put it in NEWDIR */
1603 if (nm
[0] == '~') /* prefix ~ */
1608 || nm
[1] == 0)/* ~/filename */
1610 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1611 newdir
= (unsigned char *) "";
1614 nm
++; /* Don't leave the slash in nm. */
1617 else /* ~user/filename */
1619 /* Get past ~ to user */
1620 unsigned char *user
= nm
+ 1;
1621 /* Find end of name. */
1622 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1623 int len
= ptr
? ptr
- user
: strlen (user
);
1625 unsigned char *ptr1
= index (user
, ':');
1626 if (ptr1
!= 0 && ptr1
- user
< len
)
1629 /* Copy the user name into temp storage. */
1630 o
= (unsigned char *) alloca (len
+ 1);
1631 bcopy ((char *) user
, o
, len
);
1634 /* Look up the user name. */
1635 pw
= (struct passwd
*) getpwnam (o
+ 1);
1637 error ("\"%s\" isn't a registered user", o
+ 1);
1639 newdir
= (unsigned char *) pw
->pw_dir
;
1641 /* Discard the user name from NM. */
1648 #endif /* not VMS */
1652 defalt
= current_buffer
->directory
;
1653 CHECK_STRING (defalt
, 1);
1654 newdir
= XSTRING (defalt
)->data
;
1657 /* Now concatenate the directory and name to new space in the stack frame */
1659 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1660 target
= (unsigned char *) alloca (tlen
);
1666 if (nm
[0] == 0 || nm
[0] == '/')
1667 strcpy (target
, newdir
);
1670 file_name_as_directory (target
, newdir
);
1673 strcat (target
, nm
);
1675 if (index (target
, '/'))
1676 strcpy (target
, sys_translate_unix (target
));
1679 /* Now canonicalize by removing /. and /foo/.. if they appear */
1687 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1693 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1694 /* brackets are offset from each other by 2 */
1697 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1698 /* convert [foo][bar] to [bar] */
1699 while (o
[-1] != '[' && o
[-1] != '<')
1701 else if (*p
== '-' && *o
!= '.')
1704 else if (p
[0] == '-' && o
[-1] == '.' &&
1705 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1706 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1710 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1711 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1713 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1715 /* else [foo.-] ==> [-] */
1721 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1722 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1732 else if (!strncmp (p
, "//", 2)
1734 /* // at start of filename is meaningful in Apollo system. */
1742 else if (p
[0] == '/' && p
[1] == '.' &&
1743 (p
[2] == '/' || p
[2] == 0))
1745 else if (!strncmp (p
, "/..", 3)
1746 /* `/../' is the "superroot" on certain file systems. */
1748 && (p
[3] == '/' || p
[3] == 0))
1750 while (o
!= target
&& *--o
!= '/')
1753 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1757 if (o
== target
&& *o
== '/')
1765 #endif /* not VMS */
1768 return make_string (target
, o
- target
);
1772 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1773 Ssubstitute_in_file_name
, 1, 1, 0,
1774 "Substitute environment variables referred to in FILENAME.\n\
1775 `$FOO' where FOO is an environment variable name means to substitute\n\
1776 the value of that variable. The variable name should be terminated\n\
1777 with a character not a letter, digit or underscore; otherwise, enclose\n\
1778 the entire variable name in braces.\n\
1779 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1780 On VMS, `$' substitution is not done; this function does little and only\n\
1781 duplicates what `expand-file-name' does.")
1783 Lisp_Object filename
;
1787 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1788 unsigned char *target
;
1790 int substituted
= 0;
1792 Lisp_Object handler
;
1794 CHECK_STRING (filename
, 0);
1796 /* If the file name has special constructs in it,
1797 call the corresponding file handler. */
1798 handler
= Ffind_file_name_handler (filename
, Qsubstitute_in_file_name
);
1799 if (!NILP (handler
))
1800 return call2 (handler
, Qsubstitute_in_file_name
, filename
);
1802 nm
= XSTRING (filename
)->data
;
1804 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
1805 CORRECT_DIR_SEPS (nm
);
1806 substituted
= (strcmp (nm
, XSTRING (filename
)->data
) != 0);
1808 endp
= nm
+ XSTRING (filename
)->size
;
1810 /* If /~ or // appears, discard everything through first slash. */
1812 for (p
= nm
; p
!= endp
; p
++)
1815 #if defined (APOLLO) || defined (WINDOWSNT)
1816 /* // at start of file name is meaningful in Apollo and
1817 WindowsNT systems. */
1818 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != nm
)
1819 #else /* not (APOLLO || WINDOWSNT) */
1820 || IS_DIRECTORY_SEP (p
[0])
1821 #endif /* not (APOLLO || WINDOWSNT) */
1826 || p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>'
1828 || IS_DIRECTORY_SEP (p
[-1])))
1834 /* see comment in expand-file-name about drive specifiers */
1835 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
1836 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
1845 return build_string (nm
);
1848 /* See if any variables are substituted into the string
1849 and find the total length of their values in `total' */
1851 for (p
= nm
; p
!= endp
;)
1861 /* "$$" means a single "$" */
1870 while (p
!= endp
&& *p
!= '}') p
++;
1871 if (*p
!= '}') goto missingclose
;
1877 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1881 /* Copy out the variable name */
1882 target
= (unsigned char *) alloca (s
- o
+ 1);
1883 strncpy (target
, o
, s
- o
);
1886 strupr (target
); /* $home == $HOME etc. */
1889 /* Get variable value */
1890 o
= (unsigned char *) egetenv (target
);
1891 if (!o
) goto badvar
;
1892 total
+= strlen (o
);
1899 /* If substitution required, recopy the string and do it */
1900 /* Make space in stack frame for the new copy */
1901 xnm
= (unsigned char *) alloca (XSTRING (filename
)->size
+ total
+ 1);
1904 /* Copy the rest of the name through, replacing $ constructs with values */
1921 while (p
!= endp
&& *p
!= '}') p
++;
1922 if (*p
!= '}') goto missingclose
;
1928 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1932 /* Copy out the variable name */
1933 target
= (unsigned char *) alloca (s
- o
+ 1);
1934 strncpy (target
, o
, s
- o
);
1937 strupr (target
); /* $home == $HOME etc. */
1940 /* Get variable value */
1941 o
= (unsigned char *) egetenv (target
);
1945 if (STRING_MULTIBYTE (filename
))
1947 /* If the original string is multibyte,
1948 convert what we substitute into multibyte. */
1949 unsigned char workbuf
[4], *str
;
1955 c
= unibyte_char_to_multibyte (c
);
1956 if (! SINGLE_BYTE_CHAR_P (c
))
1958 len
= CHAR_STRING (c
, workbuf
, str
);
1959 bcopy (str
, x
, len
);
1975 /* If /~ or // appears, discard everything through first slash. */
1977 for (p
= xnm
; p
!= x
; p
++)
1979 #if defined (APOLLO) || defined (WINDOWSNT)
1980 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != xnm
)
1981 #else /* not (APOLLO || WINDOWSNT) */
1982 || IS_DIRECTORY_SEP (p
[0])
1983 #endif /* not (APOLLO || WINDOWSNT) */
1985 && p
!= xnm
&& IS_DIRECTORY_SEP (p
[-1]))
1988 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
1989 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
1993 if (STRING_MULTIBYTE (filename
))
1994 return make_string (xnm
, x
- xnm
);
1995 return make_unibyte_string (xnm
, x
- xnm
);
1998 error ("Bad format environment-variable substitution");
2000 error ("Missing \"}\" in environment-variable substitution");
2002 error ("Substituting nonexistent environment variable \"%s\"", target
);
2005 #endif /* not VMS */
2008 /* A slightly faster and more convenient way to get
2009 (directory-file-name (expand-file-name FOO)). */
2012 expand_and_dir_to_file (filename
, defdir
)
2013 Lisp_Object filename
, defdir
;
2015 register Lisp_Object absname
;
2017 absname
= Fexpand_file_name (filename
, defdir
);
2020 register int c
= XSTRING (absname
)->data
[XSTRING (absname
)->size
- 1];
2021 if (c
== ':' || c
== ']' || c
== '>')
2022 absname
= Fdirectory_file_name (absname
);
2025 /* Remove final slash, if any (unless this is the root dir).
2026 stat behaves differently depending! */
2027 if (XSTRING (absname
)->size
> 1
2028 && IS_DIRECTORY_SEP (XSTRING (absname
)->data
[XSTRING (absname
)->size
- 1])
2029 && !IS_DEVICE_SEP (XSTRING (absname
)->data
[XSTRING (absname
)->size
-2]))
2030 /* We cannot take shortcuts; they might be wrong for magic file names. */
2031 absname
= Fdirectory_file_name (absname
);
2036 /* Signal an error if the file ABSNAME already exists.
2037 If INTERACTIVE is nonzero, ask the user whether to proceed,
2038 and bypass the error if the user says to go ahead.
2039 QUERYSTRING is a name for the action that is being considered
2041 *STATPTR is used to store the stat information if the file exists.
2042 If the file does not exist, STATPTR->st_mode is set to 0. */
2045 barf_or_query_if_file_exists (absname
, querystring
, interactive
, statptr
)
2046 Lisp_Object absname
;
2047 unsigned char *querystring
;
2049 struct stat
*statptr
;
2051 register Lisp_Object tem
;
2052 struct stat statbuf
;
2053 struct gcpro gcpro1
;
2055 /* stat is a good way to tell whether the file exists,
2056 regardless of what access permissions it has. */
2057 if (stat (XSTRING (absname
)->data
, &statbuf
) >= 0)
2060 Fsignal (Qfile_already_exists
,
2061 Fcons (build_string ("File already exists"),
2062 Fcons (absname
, Qnil
)));
2064 tem
= do_yes_or_no_p (format1 ("File %s already exists; %s anyway? ",
2065 XSTRING (absname
)->data
, querystring
));
2068 Fsignal (Qfile_already_exists
,
2069 Fcons (build_string ("File already exists"),
2070 Fcons (absname
, Qnil
)));
2077 statptr
->st_mode
= 0;
2082 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
2083 "fCopy file: \nFCopy %s to file: \np\nP",
2084 "Copy FILE to NEWNAME. Both args must be strings.\n\
2085 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
2086 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
2087 A number as third arg means request confirmation if NEWNAME already exists.\n\
2088 This is what happens in interactive use with M-x.\n\
2089 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
2090 last-modified time as the old one. (This works on only some systems.)\n\
2091 A prefix arg makes KEEP-TIME non-nil.")
2092 (file
, newname
, ok_if_already_exists
, keep_date
)
2093 Lisp_Object file
, newname
, ok_if_already_exists
, keep_date
;
2096 char buf
[16 * 1024];
2097 struct stat st
, out_st
;
2098 Lisp_Object handler
;
2099 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2100 int count
= specpdl_ptr
- specpdl
;
2101 int input_file_statable_p
;
2102 Lisp_Object encoded_file
, encoded_newname
;
2104 encoded_file
= encoded_newname
= Qnil
;
2105 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2106 CHECK_STRING (file
, 0);
2107 CHECK_STRING (newname
, 1);
2109 file
= Fexpand_file_name (file
, Qnil
);
2110 newname
= Fexpand_file_name (newname
, Qnil
);
2112 /* If the input file name has special constructs in it,
2113 call the corresponding file handler. */
2114 handler
= Ffind_file_name_handler (file
, Qcopy_file
);
2115 /* Likewise for output file name. */
2117 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
2118 if (!NILP (handler
))
2119 RETURN_UNGCPRO (call5 (handler
, Qcopy_file
, file
, newname
,
2120 ok_if_already_exists
, keep_date
));
2122 encoded_file
= ENCODE_FILE (file
);
2123 encoded_newname
= ENCODE_FILE (newname
);
2125 if (NILP (ok_if_already_exists
)
2126 || INTEGERP (ok_if_already_exists
))
2127 barf_or_query_if_file_exists (encoded_newname
, "copy to it",
2128 INTEGERP (ok_if_already_exists
), &out_st
);
2129 else if (stat (XSTRING (encoded_newname
)->data
, &out_st
) < 0)
2132 ifd
= open (XSTRING (encoded_file
)->data
, O_RDONLY
);
2134 report_file_error ("Opening input file", Fcons (file
, Qnil
));
2136 record_unwind_protect (close_file_unwind
, make_number (ifd
));
2138 /* We can only copy regular files and symbolic links. Other files are not
2140 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
2142 #if !defined (MSDOS) || __DJGPP__ > 1
2143 if (out_st
.st_mode
!= 0
2144 && st
.st_dev
== out_st
.st_dev
&& st
.st_ino
== out_st
.st_ino
)
2147 report_file_error ("Input and output files are the same",
2148 Fcons (file
, Fcons (newname
, Qnil
)));
2152 #if defined (S_ISREG) && defined (S_ISLNK)
2153 if (input_file_statable_p
)
2155 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
2157 #if defined (EISDIR)
2158 /* Get a better looking error message. */
2161 report_file_error ("Non-regular file", Fcons (file
, Qnil
));
2164 #endif /* S_ISREG && S_ISLNK */
2167 /* Create the copy file with the same record format as the input file */
2168 ofd
= sys_creat (XSTRING (encoded_newname
)->data
, 0666, ifd
);
2171 /* System's default file type was set to binary by _fmode in emacs.c. */
2172 ofd
= creat (XSTRING (encoded_newname
)->data
, S_IREAD
| S_IWRITE
);
2173 #else /* not MSDOS */
2174 ofd
= creat (XSTRING (encoded_newname
)->data
, 0666);
2175 #endif /* not MSDOS */
2178 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
2180 record_unwind_protect (close_file_unwind
, make_number (ofd
));
2184 while ((n
= read (ifd
, buf
, sizeof buf
)) > 0)
2185 if (write (ofd
, buf
, n
) != n
)
2186 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2189 /* Closing the output clobbers the file times on some systems. */
2190 if (close (ofd
) < 0)
2191 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2193 if (input_file_statable_p
)
2195 if (!NILP (keep_date
))
2197 EMACS_TIME atime
, mtime
;
2198 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
2199 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
2200 if (set_file_times (XSTRING (encoded_newname
)->data
,
2202 Fsignal (Qfile_date_error
,
2203 Fcons (build_string ("Cannot set file date"),
2204 Fcons (newname
, Qnil
)));
2207 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2209 #if defined (__DJGPP__) && __DJGPP__ > 1
2210 /* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
2211 and if it can't, it tells so. Otherwise, under MSDOS we usually
2212 get only the READ bit, which will make the copied file read-only,
2213 so it's better not to chmod at all. */
2214 if ((_djstat_flags
& _STFAIL_WRITEBIT
) == 0)
2215 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2216 #endif /* DJGPP version 2 or newer */
2222 /* Discard the unwind protects. */
2223 specpdl_ptr
= specpdl
+ count
;
2229 DEFUN ("make-directory-internal", Fmake_directory_internal
,
2230 Smake_directory_internal
, 1, 1, 0,
2231 "Create a new directory named DIRECTORY.")
2233 Lisp_Object directory
;
2236 Lisp_Object handler
;
2237 Lisp_Object encoded_dir
;
2239 CHECK_STRING (directory
, 0);
2240 directory
= Fexpand_file_name (directory
, Qnil
);
2242 handler
= Ffind_file_name_handler (directory
, Qmake_directory_internal
);
2243 if (!NILP (handler
))
2244 return call2 (handler
, Qmake_directory_internal
, directory
);
2246 encoded_dir
= ENCODE_FILE (directory
);
2248 dir
= XSTRING (encoded_dir
)->data
;
2251 if (mkdir (dir
) != 0)
2253 if (mkdir (dir
, 0777) != 0)
2255 report_file_error ("Creating directory", Flist (1, &directory
));
2260 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
2261 "Delete the directory named DIRECTORY.")
2263 Lisp_Object directory
;
2266 Lisp_Object handler
;
2267 Lisp_Object encoded_dir
;
2269 CHECK_STRING (directory
, 0);
2270 directory
= Fdirectory_file_name (Fexpand_file_name (directory
, Qnil
));
2272 handler
= Ffind_file_name_handler (directory
, Qdelete_directory
);
2273 if (!NILP (handler
))
2274 return call2 (handler
, Qdelete_directory
, directory
);
2276 encoded_dir
= ENCODE_FILE (directory
);
2278 dir
= XSTRING (encoded_dir
)->data
;
2280 if (rmdir (dir
) != 0)
2281 report_file_error ("Removing directory", Flist (1, &directory
));
2286 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
2287 "Delete file named FILENAME.\n\
2288 If file has multiple names, it continues to exist with the other names.")
2290 Lisp_Object filename
;
2292 Lisp_Object handler
;
2293 Lisp_Object encoded_file
;
2295 CHECK_STRING (filename
, 0);
2296 filename
= Fexpand_file_name (filename
, Qnil
);
2298 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
2299 if (!NILP (handler
))
2300 return call2 (handler
, Qdelete_file
, filename
);
2302 encoded_file
= ENCODE_FILE (filename
);
2304 if (0 > unlink (XSTRING (encoded_file
)->data
))
2305 report_file_error ("Removing old name", Flist (1, &filename
));
2310 internal_delete_file_1 (ignore
)
2316 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */
2319 internal_delete_file (filename
)
2320 Lisp_Object filename
;
2322 return NILP (internal_condition_case_1 (Fdelete_file
, filename
,
2323 Qt
, internal_delete_file_1
));
2326 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
2327 "fRename file: \nFRename %s to file: \np",
2328 "Rename FILE as NEWNAME. Both args strings.\n\
2329 If file has names other than FILE, it continues to have those names.\n\
2330 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2331 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2332 A number as third arg means request confirmation if NEWNAME already exists.\n\
2333 This is what happens in interactive use with M-x.")
2334 (file
, newname
, ok_if_already_exists
)
2335 Lisp_Object file
, newname
, ok_if_already_exists
;
2338 Lisp_Object args
[2];
2340 Lisp_Object handler
;
2341 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2342 Lisp_Object encoded_file
, encoded_newname
;
2344 encoded_file
= encoded_newname
= Qnil
;
2345 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2346 CHECK_STRING (file
, 0);
2347 CHECK_STRING (newname
, 1);
2348 file
= Fexpand_file_name (file
, Qnil
);
2349 newname
= Fexpand_file_name (newname
, Qnil
);
2351 /* If the file name has special constructs in it,
2352 call the corresponding file handler. */
2353 handler
= Ffind_file_name_handler (file
, Qrename_file
);
2355 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
2356 if (!NILP (handler
))
2357 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
2358 file
, newname
, ok_if_already_exists
));
2360 encoded_file
= ENCODE_FILE (file
);
2361 encoded_newname
= ENCODE_FILE (newname
);
2363 if (NILP (ok_if_already_exists
)
2364 || INTEGERP (ok_if_already_exists
))
2365 barf_or_query_if_file_exists (encoded_newname
, "rename to it",
2366 INTEGERP (ok_if_already_exists
), 0);
2368 if (0 > rename (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2370 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
)
2371 || 0 > unlink (XSTRING (encoded_file
)->data
))
2376 Fcopy_file (file
, newname
,
2377 /* We have already prompted if it was an integer,
2378 so don't have copy-file prompt again. */
2379 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
2380 Fdelete_file (file
);
2387 report_file_error ("Renaming", Flist (2, args
));
2390 report_file_error ("Renaming", Flist (2, &file
));
2397 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
2398 "fAdd name to file: \nFName to add to %s: \np",
2399 "Give FILE additional name NEWNAME. Both args strings.\n\
2400 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2401 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2402 A number as third arg means request confirmation if NEWNAME already exists.\n\
2403 This is what happens in interactive use with M-x.")
2404 (file
, newname
, ok_if_already_exists
)
2405 Lisp_Object file
, newname
, ok_if_already_exists
;
2408 Lisp_Object args
[2];
2410 Lisp_Object handler
;
2411 Lisp_Object encoded_file
, encoded_newname
;
2412 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2414 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2415 encoded_file
= encoded_newname
= Qnil
;
2416 CHECK_STRING (file
, 0);
2417 CHECK_STRING (newname
, 1);
2418 file
= Fexpand_file_name (file
, Qnil
);
2419 newname
= Fexpand_file_name (newname
, Qnil
);
2421 /* If the file name has special constructs in it,
2422 call the corresponding file handler. */
2423 handler
= Ffind_file_name_handler (file
, Qadd_name_to_file
);
2424 if (!NILP (handler
))
2425 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2426 newname
, ok_if_already_exists
));
2428 /* If the new name has special constructs in it,
2429 call the corresponding file handler. */
2430 handler
= Ffind_file_name_handler (newname
, Qadd_name_to_file
);
2431 if (!NILP (handler
))
2432 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2433 newname
, ok_if_already_exists
));
2435 encoded_file
= ENCODE_FILE (file
);
2436 encoded_newname
= ENCODE_FILE (newname
);
2438 if (NILP (ok_if_already_exists
)
2439 || INTEGERP (ok_if_already_exists
))
2440 barf_or_query_if_file_exists (encoded_newname
, "make it a new name",
2441 INTEGERP (ok_if_already_exists
), 0);
2443 unlink (XSTRING (newname
)->data
);
2444 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2449 report_file_error ("Adding new name", Flist (2, args
));
2451 report_file_error ("Adding new name", Flist (2, &file
));
2460 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2461 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2462 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
2463 Signals a `file-already-exists' error if a file LINKNAME already exists\n\
2464 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2465 A number as third arg means request confirmation if LINKNAME already exists.\n\
2466 This happens for interactive use with M-x.")
2467 (filename
, linkname
, ok_if_already_exists
)
2468 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2471 Lisp_Object args
[2];
2473 Lisp_Object handler
;
2474 Lisp_Object encoded_filename
, encoded_linkname
;
2475 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2477 GCPRO4 (filename
, linkname
, encoded_filename
, encoded_linkname
);
2478 encoded_filename
= encoded_linkname
= Qnil
;
2479 CHECK_STRING (filename
, 0);
2480 CHECK_STRING (linkname
, 1);
2481 /* If the link target has a ~, we must expand it to get
2482 a truly valid file name. Otherwise, do not expand;
2483 we want to permit links to relative file names. */
2484 if (XSTRING (filename
)->data
[0] == '~')
2485 filename
= Fexpand_file_name (filename
, Qnil
);
2486 linkname
= Fexpand_file_name (linkname
, Qnil
);
2488 /* If the file name has special constructs in it,
2489 call the corresponding file handler. */
2490 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2491 if (!NILP (handler
))
2492 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2493 linkname
, ok_if_already_exists
));
2495 /* If the new link name has special constructs in it,
2496 call the corresponding file handler. */
2497 handler
= Ffind_file_name_handler (linkname
, Qmake_symbolic_link
);
2498 if (!NILP (handler
))
2499 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2500 linkname
, ok_if_already_exists
));
2502 encoded_filename
= ENCODE_FILE (filename
);
2503 encoded_linkname
= ENCODE_FILE (linkname
);
2505 if (NILP (ok_if_already_exists
)
2506 || INTEGERP (ok_if_already_exists
))
2507 barf_or_query_if_file_exists (encoded_linkname
, "make it a link",
2508 INTEGERP (ok_if_already_exists
), 0);
2509 if (0 > symlink (XSTRING (encoded_filename
)->data
,
2510 XSTRING (encoded_linkname
)->data
))
2512 /* If we didn't complain already, silently delete existing file. */
2513 if (errno
== EEXIST
)
2515 unlink (XSTRING (encoded_linkname
)->data
);
2516 if (0 <= symlink (XSTRING (encoded_filename
)->data
,
2517 XSTRING (encoded_linkname
)->data
))
2527 report_file_error ("Making symbolic link", Flist (2, args
));
2529 report_file_error ("Making symbolic link", Flist (2, &filename
));
2535 #endif /* S_IFLNK */
2539 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2540 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2541 "Define the job-wide logical name NAME to have the value STRING.\n\
2542 If STRING is nil or a null string, the logical name NAME is deleted.")
2547 CHECK_STRING (name
, 0);
2549 delete_logical_name (XSTRING (name
)->data
);
2552 CHECK_STRING (string
, 1);
2554 if (XSTRING (string
)->size
== 0)
2555 delete_logical_name (XSTRING (name
)->data
);
2557 define_logical_name (XSTRING (name
)->data
, XSTRING (string
)->data
);
2566 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2567 "Open a network connection to PATH using LOGIN as the login string.")
2569 Lisp_Object path
, login
;
2573 CHECK_STRING (path
, 0);
2574 CHECK_STRING (login
, 0);
2576 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2578 if (netresult
== -1)
2583 #endif /* HPUX_NET */
2585 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2587 "Return t if file FILENAME specifies an absolute file name.\n\
2588 On Unix, this is a name starting with a `/' or a `~'.")
2590 Lisp_Object filename
;
2594 CHECK_STRING (filename
, 0);
2595 ptr
= XSTRING (filename
)->data
;
2596 if (IS_DIRECTORY_SEP (*ptr
) || *ptr
== '~'
2598 /* ??? This criterion is probably wrong for '<'. */
2599 || index (ptr
, ':') || index (ptr
, '<')
2600 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2604 || (IS_DRIVE (*ptr
) && ptr
[1] == ':' && IS_DIRECTORY_SEP (ptr
[2]))
2612 /* Return nonzero if file FILENAME exists and can be executed. */
2615 check_executable (filename
)
2619 int len
= strlen (filename
);
2622 if (stat (filename
, &st
) < 0)
2624 #if defined (WINDOWSNT) || (defined (MSDOS) && __DJGPP__ > 1)
2625 return ((st
.st_mode
& S_IEXEC
) != 0);
2627 return (S_ISREG (st
.st_mode
)
2629 && (stricmp ((suffix
= filename
+ len
-4), ".com") == 0
2630 || stricmp (suffix
, ".exe") == 0
2631 || stricmp (suffix
, ".bat") == 0)
2632 || (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2633 #endif /* not WINDOWSNT */
2634 #else /* not DOS_NT */
2635 #ifdef HAVE_EUIDACCESS
2636 return (euidaccess (filename
, 1) >= 0);
2638 /* Access isn't quite right because it uses the real uid
2639 and we really want to test with the effective uid.
2640 But Unix doesn't give us a right way to do it. */
2641 return (access (filename
, 1) >= 0);
2643 #endif /* not DOS_NT */
2646 /* Return nonzero if file FILENAME exists and can be written. */
2649 check_writable (filename
)
2654 if (stat (filename
, &st
) < 0)
2656 return (st
.st_mode
& S_IWRITE
|| (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2657 #else /* not MSDOS */
2658 #ifdef HAVE_EUIDACCESS
2659 return (euidaccess (filename
, 2) >= 0);
2661 /* Access isn't quite right because it uses the real uid
2662 and we really want to test with the effective uid.
2663 But Unix doesn't give us a right way to do it.
2664 Opening with O_WRONLY could work for an ordinary file,
2665 but would lose for directories. */
2666 return (access (filename
, 2) >= 0);
2668 #endif /* not MSDOS */
2671 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2672 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
2673 See also `file-readable-p' and `file-attributes'.")
2675 Lisp_Object filename
;
2677 Lisp_Object absname
;
2678 Lisp_Object handler
;
2679 struct stat statbuf
;
2681 CHECK_STRING (filename
, 0);
2682 absname
= Fexpand_file_name (filename
, Qnil
);
2684 /* If the file name has special constructs in it,
2685 call the corresponding file handler. */
2686 handler
= Ffind_file_name_handler (absname
, Qfile_exists_p
);
2687 if (!NILP (handler
))
2688 return call2 (handler
, Qfile_exists_p
, absname
);
2690 absname
= ENCODE_FILE (absname
);
2692 return (stat (XSTRING (absname
)->data
, &statbuf
) >= 0) ? Qt
: Qnil
;
2695 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2696 "Return t if FILENAME can be executed by you.\n\
2697 For a directory, this means you can access files in that directory.")
2699 Lisp_Object filename
;
2702 Lisp_Object absname
;
2703 Lisp_Object handler
;
2705 CHECK_STRING (filename
, 0);
2706 absname
= Fexpand_file_name (filename
, Qnil
);
2708 /* If the file name has special constructs in it,
2709 call the corresponding file handler. */
2710 handler
= Ffind_file_name_handler (absname
, Qfile_executable_p
);
2711 if (!NILP (handler
))
2712 return call2 (handler
, Qfile_executable_p
, absname
);
2714 absname
= ENCODE_FILE (absname
);
2716 return (check_executable (XSTRING (absname
)->data
) ? Qt
: Qnil
);
2719 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2720 "Return t if file FILENAME exists and you can read it.\n\
2721 See also `file-exists-p' and `file-attributes'.")
2723 Lisp_Object filename
;
2725 Lisp_Object absname
;
2726 Lisp_Object handler
;
2729 struct stat statbuf
;
2731 CHECK_STRING (filename
, 0);
2732 absname
= Fexpand_file_name (filename
, Qnil
);
2734 /* If the file name has special constructs in it,
2735 call the corresponding file handler. */
2736 handler
= Ffind_file_name_handler (absname
, Qfile_readable_p
);
2737 if (!NILP (handler
))
2738 return call2 (handler
, Qfile_readable_p
, absname
);
2740 absname
= ENCODE_FILE (absname
);
2743 /* Under MS-DOS and Windows, open does not work for directories. */
2744 if (access (XSTRING (absname
)->data
, 0) == 0)
2747 #else /* not DOS_NT */
2749 #if defined (S_ISFIFO) && defined (O_NONBLOCK)
2750 /* Opening a fifo without O_NONBLOCK can wait.
2751 We don't want to wait. But we don't want to mess wth O_NONBLOCK
2752 except in the case of a fifo, on a system which handles it. */
2753 desc
= stat (XSTRING (absname
)->data
, &statbuf
);
2756 if (S_ISFIFO (statbuf
.st_mode
))
2757 flags
|= O_NONBLOCK
;
2759 desc
= open (XSTRING (absname
)->data
, flags
);
2764 #endif /* not DOS_NT */
2767 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2769 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
2770 "Return t if file FILENAME can be written or created by you.")
2772 Lisp_Object filename
;
2774 Lisp_Object absname
, dir
, encoded
;
2775 Lisp_Object handler
;
2776 struct stat statbuf
;
2778 CHECK_STRING (filename
, 0);
2779 absname
= Fexpand_file_name (filename
, Qnil
);
2781 /* If the file name has special constructs in it,
2782 call the corresponding file handler. */
2783 handler
= Ffind_file_name_handler (absname
, Qfile_writable_p
);
2784 if (!NILP (handler
))
2785 return call2 (handler
, Qfile_writable_p
, absname
);
2787 encoded
= ENCODE_FILE (absname
);
2788 if (stat (XSTRING (encoded
)->data
, &statbuf
) >= 0)
2789 return (check_writable (XSTRING (encoded
)->data
)
2792 dir
= Ffile_name_directory (absname
);
2795 dir
= Fdirectory_file_name (dir
);
2799 dir
= Fdirectory_file_name (dir
);
2802 dir
= ENCODE_FILE (dir
);
2803 return (check_writable (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "")
2807 DEFUN ("access-file", Faccess_file
, Saccess_file
, 2, 2, 0,
2808 "Access file FILENAME, and get an error if that does not work.\n\
2809 The second argument STRING is used in the error message.\n\
2810 If there is no error, we return nil.")
2812 Lisp_Object filename
, string
;
2814 Lisp_Object handler
, encoded_filename
;
2817 CHECK_STRING (filename
, 0);
2819 /* If the file name has special constructs in it,
2820 call the corresponding file handler. */
2821 handler
= Ffind_file_name_handler (filename
, Qaccess_file
);
2822 if (!NILP (handler
))
2823 return call3 (handler
, Qaccess_file
, filename
, string
);
2825 encoded_filename
= ENCODE_FILE (filename
);
2827 fd
= open (XSTRING (encoded_filename
)->data
, O_RDONLY
);
2829 report_file_error (XSTRING (string
)->data
, Fcons (filename
, Qnil
));
2835 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
2836 "Return non-nil if file FILENAME is the name of a symbolic link.\n\
2837 The value is the name of the file to which it is linked.\n\
2838 Otherwise returns nil.")
2840 Lisp_Object filename
;
2847 Lisp_Object handler
;
2849 CHECK_STRING (filename
, 0);
2850 filename
= Fexpand_file_name (filename
, Qnil
);
2852 /* If the file name has special constructs in it,
2853 call the corresponding file handler. */
2854 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
2855 if (!NILP (handler
))
2856 return call2 (handler
, Qfile_symlink_p
, filename
);
2858 filename
= ENCODE_FILE (filename
);
2863 buf
= (char *) xmalloc (bufsize
);
2864 bzero (buf
, bufsize
);
2865 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
2866 if (valsize
< bufsize
) break;
2867 /* Buffer was not long enough */
2876 val
= make_string (buf
, valsize
);
2878 return Fdecode_coding_string (val
, Vfile_name_coding_system
, Qt
);
2879 #else /* not S_IFLNK */
2881 #endif /* not S_IFLNK */
2884 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
2885 "Return t if FILENAME names an existing directory.")
2887 Lisp_Object filename
;
2889 register Lisp_Object absname
;
2891 Lisp_Object handler
;
2893 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2895 /* If the file name has special constructs in it,
2896 call the corresponding file handler. */
2897 handler
= Ffind_file_name_handler (absname
, Qfile_directory_p
);
2898 if (!NILP (handler
))
2899 return call2 (handler
, Qfile_directory_p
, absname
);
2901 absname
= ENCODE_FILE (absname
);
2903 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2905 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
2908 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
2909 "Return t if file FILENAME is the name of a directory as a file,\n\
2910 and files in that directory can be opened by you. In order to use a\n\
2911 directory as a buffer's current directory, this predicate must return true.\n\
2912 A directory name spec may be given instead; then the value is t\n\
2913 if the directory so specified exists and really is a readable and\n\
2914 searchable directory.")
2916 Lisp_Object filename
;
2918 Lisp_Object handler
;
2920 struct gcpro gcpro1
;
2922 /* If the file name has special constructs in it,
2923 call the corresponding file handler. */
2924 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
2925 if (!NILP (handler
))
2926 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
2928 /* It's an unlikely combination, but yes we really do need to gcpro:
2929 Suppose that file-accessible-directory-p has no handler, but
2930 file-directory-p does have a handler; this handler causes a GC which
2931 relocates the string in `filename'; and finally file-directory-p
2932 returns non-nil. Then we would end up passing a garbaged string
2933 to file-executable-p. */
2935 tem
= (NILP (Ffile_directory_p (filename
))
2936 || NILP (Ffile_executable_p (filename
)));
2938 return tem
? Qnil
: Qt
;
2941 DEFUN ("file-regular-p", Ffile_regular_p
, Sfile_regular_p
, 1, 1, 0,
2942 "Return t if file FILENAME is the name of a regular file.\n\
2943 This is the sort of file that holds an ordinary stream of data bytes.")
2945 Lisp_Object filename
;
2947 register Lisp_Object absname
;
2949 Lisp_Object handler
;
2951 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2953 /* If the file name has special constructs in it,
2954 call the corresponding file handler. */
2955 handler
= Ffind_file_name_handler (absname
, Qfile_regular_p
);
2956 if (!NILP (handler
))
2957 return call2 (handler
, Qfile_regular_p
, absname
);
2959 absname
= ENCODE_FILE (absname
);
2961 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2963 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
2966 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
2967 "Return mode bits of file named FILENAME, as an integer.")
2969 Lisp_Object filename
;
2971 Lisp_Object absname
;
2973 Lisp_Object handler
;
2975 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2977 /* If the file name has special constructs in it,
2978 call the corresponding file handler. */
2979 handler
= Ffind_file_name_handler (absname
, Qfile_modes
);
2980 if (!NILP (handler
))
2981 return call2 (handler
, Qfile_modes
, absname
);
2983 absname
= ENCODE_FILE (absname
);
2985 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2987 #if defined (MSDOS) && __DJGPP__ < 2
2988 if (check_executable (XSTRING (absname
)->data
))
2989 st
.st_mode
|= S_IEXEC
;
2990 #endif /* MSDOS && __DJGPP__ < 2 */
2992 return make_number (st
.st_mode
& 07777);
2995 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
2996 "Set mode bits of file named FILENAME to MODE (an integer).\n\
2997 Only the 12 low bits of MODE are used.")
2999 Lisp_Object filename
, mode
;
3001 Lisp_Object absname
, encoded_absname
;
3002 Lisp_Object handler
;
3004 absname
= Fexpand_file_name (filename
, current_buffer
->directory
);
3005 CHECK_NUMBER (mode
, 1);
3007 /* If the file name has special constructs in it,
3008 call the corresponding file handler. */
3009 handler
= Ffind_file_name_handler (absname
, Qset_file_modes
);
3010 if (!NILP (handler
))
3011 return call3 (handler
, Qset_file_modes
, absname
, mode
);
3013 encoded_absname
= ENCODE_FILE (absname
);
3015 if (chmod (XSTRING (encoded_absname
)->data
, XINT (mode
)) < 0)
3016 report_file_error ("Doing chmod", Fcons (absname
, Qnil
));
3021 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
3022 "Set the file permission bits for newly created files.\n\
3023 The argument MODE should be an integer; only the low 9 bits are used.\n\
3024 This setting is inherited by subprocesses.")
3028 CHECK_NUMBER (mode
, 0);
3030 umask ((~ XINT (mode
)) & 0777);
3035 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
3036 "Return the default file protection for created files.\n\
3037 The value is an integer.")
3043 realmask
= umask (0);
3046 XSETINT (value
, (~ realmask
) & 0777);
3052 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
3053 "Tell Unix to finish all pending disk updates.")
3062 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
3063 "Return t if file FILE1 is newer than file FILE2.\n\
3064 If FILE1 does not exist, the answer is nil;\n\
3065 otherwise, if FILE2 does not exist, the answer is t.")
3067 Lisp_Object file1
, file2
;
3069 Lisp_Object absname1
, absname2
;
3072 Lisp_Object handler
;
3073 struct gcpro gcpro1
, gcpro2
;
3075 CHECK_STRING (file1
, 0);
3076 CHECK_STRING (file2
, 0);
3079 GCPRO2 (absname1
, file2
);
3080 absname1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
3081 absname2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
3084 /* If the file name has special constructs in it,
3085 call the corresponding file handler. */
3086 handler
= Ffind_file_name_handler (absname1
, Qfile_newer_than_file_p
);
3088 handler
= Ffind_file_name_handler (absname2
, Qfile_newer_than_file_p
);
3089 if (!NILP (handler
))
3090 return call3 (handler
, Qfile_newer_than_file_p
, absname1
, absname2
);
3092 GCPRO2 (absname1
, absname2
);
3093 absname1
= ENCODE_FILE (absname1
);
3094 absname2
= ENCODE_FILE (absname2
);
3097 if (stat (XSTRING (absname1
)->data
, &st
) < 0)
3100 mtime1
= st
.st_mtime
;
3102 if (stat (XSTRING (absname2
)->data
, &st
) < 0)
3105 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
3109 Lisp_Object Qfind_buffer_file_type
;
3112 #ifndef READ_BUF_SIZE
3113 #define READ_BUF_SIZE (64 << 10)
3116 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
3118 "Insert contents of file FILENAME after point.\n\
3119 Returns list of absolute file name and number of bytes inserted.\n\
3120 If second argument VISIT is non-nil, the buffer's visited filename\n\
3121 and last save file modtime are set, and it is marked unmodified.\n\
3122 If visiting and the file does not exist, visiting is completed\n\
3123 before the error is signaled.\n\
3124 The optional third and fourth arguments BEG and END\n\
3125 specify what portion of the file to insert.\n\
3126 These arguments count bytes in the file, not characters in the buffer.\n\
3127 If VISIT is non-nil, BEG and END must be nil.\n\
3129 If optional fifth argument REPLACE is non-nil,\n\
3130 it means replace the current buffer contents (in the accessible portion)\n\
3131 with the file contents. This is better than simply deleting and inserting\n\
3132 the whole thing because (1) it preserves some marker positions\n\
3133 and (2) it puts less data in the undo list.\n\
3134 When REPLACE is non-nil, the value is the number of characters actually read,\n\
3135 which is often less than the number of characters to be read.\n\
3136 This does code conversion according to the value of\n\
3137 `coding-system-for-read' or `file-coding-system-alist',\n\
3138 and sets the variable `last-coding-system-used' to the coding system\n\
3140 (filename
, visit
, beg
, end
, replace
)
3141 Lisp_Object filename
, visit
, beg
, end
, replace
;
3146 register int how_much
;
3147 register int unprocessed
;
3148 int count
= specpdl_ptr
- specpdl
;
3149 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3150 Lisp_Object handler
, val
, insval
, orig_filename
;
3153 int not_regular
= 0;
3154 char read_buf
[READ_BUF_SIZE
];
3155 struct coding_system coding
;
3156 unsigned char buffer
[1 << 14];
3157 int replace_handled
= 0;
3158 int set_coding_system
= 0;
3160 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3161 error ("Cannot do file visiting in an indirect buffer");
3163 if (!NILP (current_buffer
->read_only
))
3164 Fbarf_if_buffer_read_only ();
3168 orig_filename
= Qnil
;
3170 GCPRO4 (filename
, val
, p
, orig_filename
);
3172 CHECK_STRING (filename
, 0);
3173 filename
= Fexpand_file_name (filename
, Qnil
);
3175 /* If the file name has special constructs in it,
3176 call the corresponding file handler. */
3177 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
3178 if (!NILP (handler
))
3180 val
= call6 (handler
, Qinsert_file_contents
, filename
,
3181 visit
, beg
, end
, replace
);
3185 orig_filename
= filename
;
3186 filename
= ENCODE_FILE (filename
);
3191 if (stat (XSTRING (filename
)->data
, &st
) < 0)
3193 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0
3194 || fstat (fd
, &st
) < 0)
3195 #endif /* not APOLLO */
3197 if (fd
>= 0) close (fd
);
3200 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3203 if (!NILP (Vcoding_system_for_read
))
3204 current_buffer
->buffer_file_coding_system
= Vcoding_system_for_read
;
3209 /* This code will need to be changed in order to work on named
3210 pipes, and it's probably just not worth it. So we should at
3211 least signal an error. */
3212 if (!S_ISREG (st
.st_mode
))
3219 if (! NILP (replace
) || ! NILP (beg
) || ! NILP (end
))
3220 Fsignal (Qfile_error
,
3221 Fcons (build_string ("not a regular file"),
3222 Fcons (orig_filename
, Qnil
)));
3227 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0)
3230 /* Replacement should preserve point as it preserves markers. */
3231 if (!NILP (replace
))
3232 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
3234 record_unwind_protect (close_file_unwind
, make_number (fd
));
3236 /* Supposedly happens on VMS. */
3237 if (! not_regular
&& st
.st_size
< 0)
3238 error ("File size is negative");
3240 if (!NILP (beg
) || !NILP (end
))
3242 error ("Attempt to visit less than an entire file");
3245 CHECK_NUMBER (beg
, 0);
3247 XSETFASTINT (beg
, 0);
3250 CHECK_NUMBER (end
, 0);
3255 XSETINT (end
, st
.st_size
);
3256 if (XINT (end
) != st
.st_size
)
3257 error ("Maximum buffer size exceeded");
3261 /* Decide the coding-system of the file. */
3263 Lisp_Object val
= Qnil
;
3265 if (!NILP (Vcoding_system_for_read
))
3266 val
= Vcoding_system_for_read
;
3269 if (! NILP (Vset_auto_coding_function
))
3271 /* Find a coding system specified in the heading two lines
3272 or in the tailing several lines of the file. We assume
3273 that the 1K-byte and 3K-byte for heading and tailing
3274 respectively are sufficient fot this purpose. */
3275 int how_many
, nread
;
3277 if (st
.st_size
<= (1024 * 4))
3278 nread
= read (fd
, read_buf
, 1024 * 4);
3281 nread
= read (fd
, read_buf
, 1024);
3284 if (lseek (fd
, st
.st_size
- (1024 * 3), 0) < 0)
3285 report_file_error ("Setting file position",
3286 Fcons (orig_filename
, Qnil
));
3287 nread
+= read (fd
, read_buf
+ nread
, 1024 * 3);
3292 error ("IO error reading %s: %s",
3293 XSTRING (orig_filename
)->data
, strerror (errno
));
3297 /* Always make this a unibyte string
3298 because we have not yet decoded it. */
3299 tem
= make_unibyte_string (read_buf
, nread
);
3300 val
= call1 (Vset_auto_coding_function
, tem
);
3301 /* Rewind the file for the actual read done later. */
3302 if (lseek (fd
, 0, 0) < 0)
3303 report_file_error ("Setting file position",
3304 Fcons (orig_filename
, Qnil
));
3309 Lisp_Object args
[6], coding_systems
;
3311 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
,
3312 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = replace
;
3313 coding_systems
= Ffind_operation_coding_system (6, args
);
3314 if (CONSP (coding_systems
)) val
= XCONS (coding_systems
)->car
;
3318 if (NILP (Vcoding_system_for_read
)
3319 && NILP (current_buffer
->enable_multibyte_characters
))
3321 /* We must suppress all text conversion except for end-of-line
3323 struct coding_system coding_temp
;
3325 setup_coding_system (Fcheck_coding_system (val
), &coding_temp
);
3326 setup_coding_system (Qraw_text
, &coding
);
3327 coding
.eol_type
= coding_temp
.eol_type
;
3330 setup_coding_system (Fcheck_coding_system (val
), &coding
);
3333 /* If requested, replace the accessible part of the buffer
3334 with the file contents. Avoid replacing text at the
3335 beginning or end of the buffer that matches the file contents;
3336 that preserves markers pointing to the unchanged parts.
3338 Here we implement this feature in an optimized way
3339 for the case where code conversion is NOT needed.
3340 The following if-statement handles the case of conversion
3341 in a less optimal way.
3343 If the code conversion is "automatic" then we try using this
3344 method and hope for the best.
3345 But if we discover the need for conversion, we give up on this method
3346 and let the following if-statement handle the replace job. */
3348 && ! CODING_REQUIRE_DECODING (&coding
))
3350 /* same_at_start and same_at_end count bytes,
3351 because file access counts bytes
3352 and BEG and END count bytes. */
3353 int same_at_start
= BEGV_BYTE
;
3354 int same_at_end
= ZV_BYTE
;
3356 /* There is still a possibility we will find the need to do code
3357 conversion. If that happens, we set this variable to 1 to
3358 give up on handling REPLACE in the optimized way. */
3359 int giveup_match_end
= 0;
3361 if (XINT (beg
) != 0)
3363 if (lseek (fd
, XINT (beg
), 0) < 0)
3364 report_file_error ("Setting file position",
3365 Fcons (orig_filename
, Qnil
));
3370 /* Count how many chars at the start of the file
3371 match the text at the beginning of the buffer. */
3376 nread
= read (fd
, buffer
, sizeof buffer
);
3378 error ("IO error reading %s: %s",
3379 XSTRING (orig_filename
)->data
, strerror (errno
));
3380 else if (nread
== 0)
3383 if (coding
.type
== coding_type_undecided
)
3384 detect_coding (&coding
, buffer
, nread
);
3385 if (CODING_REQUIRE_DECODING (&coding
))
3386 /* We found that the file should be decoded somehow.
3387 Let's give up here. */
3389 giveup_match_end
= 1;
3393 if (coding
.eol_type
== CODING_EOL_UNDECIDED
)
3394 detect_eol (&coding
, buffer
, nread
);
3395 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3396 && coding
.eol_type
!= CODING_EOL_LF
)
3397 /* We found that the format of eol should be decoded.
3398 Let's give up here. */
3400 giveup_match_end
= 1;
3405 while (bufpos
< nread
&& same_at_start
< ZV_BYTE
3406 && FETCH_BYTE (same_at_start
) == buffer
[bufpos
])
3407 same_at_start
++, bufpos
++;
3408 /* If we found a discrepancy, stop the scan.
3409 Otherwise loop around and scan the next bufferful. */
3410 if (bufpos
!= nread
)
3414 /* If the file matches the buffer completely,
3415 there's no need to replace anything. */
3416 if (same_at_start
- BEGV_BYTE
== XINT (end
))
3420 /* Truncate the buffer to the size of the file. */
3421 del_range_1 (same_at_start
, same_at_end
, 0);
3426 /* Count how many chars at the end of the file
3427 match the text at the end of the buffer. But, if we have
3428 already found that decoding is necessary, don't waste time. */
3429 while (!giveup_match_end
)
3431 int total_read
, nread
, bufpos
, curpos
, trial
;
3433 /* At what file position are we now scanning? */
3434 curpos
= XINT (end
) - (ZV_BYTE
- same_at_end
);
3435 /* If the entire file matches the buffer tail, stop the scan. */
3438 /* How much can we scan in the next step? */
3439 trial
= min (curpos
, sizeof buffer
);
3440 if (lseek (fd
, curpos
- trial
, 0) < 0)
3441 report_file_error ("Setting file position",
3442 Fcons (orig_filename
, Qnil
));
3445 while (total_read
< trial
)
3447 nread
= read (fd
, buffer
+ total_read
, trial
- total_read
);
3449 error ("IO error reading %s: %s",
3450 XSTRING (orig_filename
)->data
, strerror (errno
));
3451 total_read
+= nread
;
3453 /* Scan this bufferful from the end, comparing with
3454 the Emacs buffer. */
3455 bufpos
= total_read
;
3456 /* Compare with same_at_start to avoid counting some buffer text
3457 as matching both at the file's beginning and at the end. */
3458 while (bufpos
> 0 && same_at_end
> same_at_start
3459 && FETCH_BYTE (same_at_end
- 1) == buffer
[bufpos
- 1])
3460 same_at_end
--, bufpos
--;
3462 /* If we found a discrepancy, stop the scan.
3463 Otherwise loop around and scan the preceding bufferful. */
3466 /* If this discrepancy is because of code conversion,
3467 we cannot use this method; giveup and try the other. */
3468 if (same_at_end
> same_at_start
3469 && FETCH_BYTE (same_at_end
- 1) >= 0200
3470 && ! NILP (current_buffer
->enable_multibyte_characters
)
3471 && (CODING_MAY_REQUIRE_DECODING (&coding
)))
3472 giveup_match_end
= 1;
3478 if (! giveup_match_end
)
3482 /* We win! We can handle REPLACE the optimized way. */
3484 /* Extends the end of non-matching text area to multibyte
3485 character boundary. */
3486 if (! NILP (current_buffer
->enable_multibyte_characters
))
3487 while (same_at_end
< ZV_BYTE
3488 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
3491 /* Don't try to reuse the same piece of text twice. */
3492 overlap
= (same_at_start
- BEGV_BYTE
3493 - (same_at_end
+ st
.st_size
- ZV
));
3495 same_at_end
+= overlap
;
3497 /* Arrange to read only the nonmatching middle part of the file. */
3498 XSETFASTINT (beg
, XINT (beg
) + (same_at_start
- BEGV_BYTE
));
3499 XSETFASTINT (end
, XINT (end
) - (ZV_BYTE
- same_at_end
));
3501 del_range_byte (same_at_start
, same_at_end
, 0);
3502 /* Insert from the file at the proper position. */
3503 temp
= BYTE_TO_CHAR (same_at_start
);
3504 SET_PT_BOTH (temp
, same_at_start
);
3506 /* If display currently starts at beginning of line,
3507 keep it that way. */
3508 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3509 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3511 replace_handled
= 1;
3515 /* If requested, replace the accessible part of the buffer
3516 with the file contents. Avoid replacing text at the
3517 beginning or end of the buffer that matches the file contents;
3518 that preserves markers pointing to the unchanged parts.
3520 Here we implement this feature for the case where code conversion
3521 is needed, in a simple way that needs a lot of memory.
3522 The preceding if-statement handles the case of no conversion
3523 in a more optimized way. */
3524 if (!NILP (replace
) && ! replace_handled
)
3526 int same_at_start
= BEGV_BYTE
;
3527 int same_at_end
= ZV_BYTE
;
3530 /* Make sure that the gap is large enough. */
3531 int bufsize
= 2 * st
.st_size
;
3532 unsigned char *conversion_buffer
= (unsigned char *) xmalloc (bufsize
);
3535 /* First read the whole file, performing code conversion into
3536 CONVERSION_BUFFER. */
3538 if (lseek (fd
, XINT (beg
), 0) < 0)
3540 free (conversion_buffer
);
3541 report_file_error ("Setting file position",
3542 Fcons (orig_filename
, Qnil
));
3545 total
= st
.st_size
; /* Total bytes in the file. */
3546 how_much
= 0; /* Bytes read from file so far. */
3547 inserted
= 0; /* Bytes put into CONVERSION_BUFFER so far. */
3548 unprocessed
= 0; /* Bytes not processed in previous loop. */
3550 while (how_much
< total
)
3552 /* try is reserved in some compilers (Microsoft C) */
3553 int trytry
= min (total
- how_much
, READ_BUF_SIZE
- unprocessed
);
3554 char *destination
= read_buf
+ unprocessed
;
3557 /* Allow quitting out of the actual I/O. */
3560 this = read (fd
, destination
, trytry
);
3563 if (this < 0 || this + unprocessed
== 0)
3571 if (CODING_MAY_REQUIRE_DECODING (&coding
))
3573 int require
, result
;
3575 this += unprocessed
;
3577 /* If we are using more space than estimated,
3578 make CONVERSION_BUFFER bigger. */
3579 require
= decoding_buffer_size (&coding
, this);
3580 if (inserted
+ require
+ 2 * (total
- how_much
) > bufsize
)
3582 bufsize
= inserted
+ require
+ 2 * (total
- how_much
);
3583 conversion_buffer
= (unsigned char *) xrealloc (conversion_buffer
, bufsize
);
3586 /* Convert this batch with results in CONVERSION_BUFFER. */
3587 if (how_much
>= total
) /* This is the last block. */
3588 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
3589 result
= decode_coding (&coding
, read_buf
,
3590 conversion_buffer
+ inserted
,
3591 this, bufsize
- inserted
);
3593 /* Save for next iteration whatever we didn't convert. */
3594 unprocessed
= this - coding
.consumed
;
3595 bcopy (read_buf
+ coding
.consumed
, read_buf
, unprocessed
);
3596 this = coding
.produced
;
3602 /* At this point, INSERTED is how many characters (i.e. bytes)
3603 are present in CONVERSION_BUFFER.
3604 HOW_MUCH should equal TOTAL,
3605 or should be <= 0 if we couldn't read the file. */
3609 free (conversion_buffer
);
3612 error ("IO error reading %s: %s",
3613 XSTRING (orig_filename
)->data
, strerror (errno
));
3614 else if (how_much
== -2)
3615 error ("maximum buffer size exceeded");
3618 /* Compare the beginning of the converted file
3619 with the buffer text. */
3622 while (bufpos
< inserted
&& same_at_start
< same_at_end
3623 && FETCH_BYTE (same_at_start
) == conversion_buffer
[bufpos
])
3624 same_at_start
++, bufpos
++;
3626 /* If the file matches the buffer completely,
3627 there's no need to replace anything. */
3629 if (bufpos
== inserted
)
3631 free (conversion_buffer
);
3634 /* Truncate the buffer to the size of the file. */
3635 del_range_1 (same_at_start
, same_at_end
, 0);
3639 /* Scan this bufferful from the end, comparing with
3640 the Emacs buffer. */
3643 /* Compare with same_at_start to avoid counting some buffer text
3644 as matching both at the file's beginning and at the end. */
3645 while (bufpos
> 0 && same_at_end
> same_at_start
3646 && FETCH_BYTE (same_at_end
- 1) == conversion_buffer
[bufpos
- 1])
3647 same_at_end
--, bufpos
--;
3649 /* Don't try to reuse the same piece of text twice. */
3650 overlap
= same_at_start
- BEGV_BYTE
- (same_at_end
+ inserted
- ZV_BYTE
);
3652 same_at_end
+= overlap
;
3654 /* If display currently starts at beginning of line,
3655 keep it that way. */
3656 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3657 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3659 /* Replace the chars that we need to replace,
3660 and update INSERTED to equal the number of bytes
3661 we are taking from the file. */
3662 inserted
-= (Z_BYTE
- same_at_end
) + (same_at_start
- BEG_BYTE
);
3663 del_range_byte (same_at_start
, same_at_end
, 0);
3664 SET_PT_BOTH (GPT
, GPT_BYTE
);
3666 insert_1 (conversion_buffer
+ same_at_start
- BEG_BYTE
, inserted
,
3669 free (conversion_buffer
);
3678 register Lisp_Object temp
;
3680 total
= XINT (end
) - XINT (beg
);
3682 /* Make sure point-max won't overflow after this insertion. */
3683 XSETINT (temp
, total
);
3684 if (total
!= XINT (temp
))
3685 error ("Maximum buffer size exceeded");
3688 /* For a special file, all we can do is guess. */
3689 total
= READ_BUF_SIZE
;
3691 if (NILP (visit
) && total
> 0)
3692 prepare_to_modify_buffer (PT
, PT
, NULL
);
3695 if (GAP_SIZE
< total
)
3696 make_gap (total
- GAP_SIZE
);
3698 if (XINT (beg
) != 0 || !NILP (replace
))
3700 if (lseek (fd
, XINT (beg
), 0) < 0)
3701 report_file_error ("Setting file position",
3702 Fcons (orig_filename
, Qnil
));
3705 /* In the following loop, HOW_MUCH contains the total bytes read so
3706 far for a regular file, and not changed for a special file. But,
3707 before exiting the loop, it is set to a negative value if I/O
3710 /* Total bytes inserted. */
3712 /* Here, we don't do code conversion in the loop. It is done by
3713 code_convert_region after all data are read into the buffer. */
3714 while (how_much
< total
)
3716 /* try is reserved in some compilers (Microsoft C) */
3717 int trytry
= min (total
- how_much
, READ_BUF_SIZE
);
3720 /* For a special file, GAP_SIZE should be checked every time. */
3721 if (not_regular
&& GAP_SIZE
< trytry
)
3722 make_gap (total
- GAP_SIZE
);
3724 /* Allow quitting out of the actual I/O. */
3727 this = read (fd
, BYTE_POS_ADDR (PT
+ inserted
- 1) + 1, trytry
);
3744 /* For a regular file, where TOTAL is the real size,
3745 count HOW_MUCH to compare with it.
3746 For a special file, where TOTAL is just a buffer size,
3747 so don't bother counting in HOW_MUCH.
3748 (INSERTED is where we count the number of characters inserted.) */
3755 /* Put an anchor to ensure multi-byte form ends at gap. */
3760 /* Discard the unwind protect for closing the file. */
3764 error ("IO error reading %s: %s",
3765 XSTRING (orig_filename
)->data
, strerror (errno
));
3769 if (CODING_MAY_REQUIRE_DECODING (&coding
))
3770 inserted
= code_convert_region (PT
, PT
+ inserted
, &coding
, 0, 0);
3773 /* Use the conversion type to determine buffer-file-type
3774 (find-buffer-file-type is now used to help determine the
3776 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3777 && coding
.eol_type
!= CODING_EOL_LF
)
3778 current_buffer
->buffer_file_type
= Qnil
;
3780 current_buffer
->buffer_file_type
= Qt
;
3783 record_insert (PT
, inserted
);
3785 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
3786 offset_intervals (current_buffer
, PT
, inserted
);
3789 if (! NILP (coding
.post_read_conversion
))
3793 val
= call1 (coding
.post_read_conversion
, make_number (inserted
));
3796 CHECK_NUMBER (val
, 0);
3797 inserted
= XFASTINT (val
);
3802 set_coding_system
= 1;
3809 if (!EQ (current_buffer
->undo_list
, Qt
))
3810 current_buffer
->undo_list
= Qnil
;
3812 stat (XSTRING (filename
)->data
, &st
);
3817 current_buffer
->modtime
= st
.st_mtime
;
3818 current_buffer
->filename
= orig_filename
;
3821 SAVE_MODIFF
= MODIFF
;
3822 current_buffer
->auto_save_modified
= MODIFF
;
3823 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
3824 #ifdef CLASH_DETECTION
3827 if (!NILP (current_buffer
->file_truename
))
3828 unlock_file (current_buffer
->file_truename
);
3829 unlock_file (filename
);
3831 #endif /* CLASH_DETECTION */
3833 Fsignal (Qfile_error
,
3834 Fcons (build_string ("not a regular file"),
3835 Fcons (orig_filename
, Qnil
)));
3837 /* If visiting nonexistent file, return nil. */
3838 if (current_buffer
->modtime
== -1)
3839 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3842 /* Decode file format */
3845 insval
= call3 (Qformat_decode
,
3846 Qnil
, make_number (inserted
), visit
);
3847 CHECK_NUMBER (insval
, 0);
3848 inserted
= XFASTINT (insval
);
3851 /* Call after-change hooks for the inserted text, aside from the case
3852 of normal visiting (not with REPLACE), which is done in a new buffer
3853 "before" the buffer is changed. */
3854 if (inserted
> 0 && total
> 0
3855 && (NILP (visit
) || !NILP (replace
)))
3856 signal_after_change (PT
, 0, inserted
);
3858 if (set_coding_system
)
3859 Vlast_coding_system_used
= coding
.symbol
;
3863 p
= Vafter_insert_file_functions
;
3866 insval
= call1 (Fcar (p
), make_number (inserted
));
3869 CHECK_NUMBER (insval
, 0);
3870 inserted
= XFASTINT (insval
);
3877 /* ??? Retval needs to be dealt with in all cases consistently. */
3879 val
= Fcons (orig_filename
,
3880 Fcons (make_number (inserted
),
3883 RETURN_UNGCPRO (unbind_to (count
, val
));
3886 static Lisp_Object build_annotations
P_ ((Lisp_Object
, Lisp_Object
,
3889 /* If build_annotations switched buffers, switch back to BUF.
3890 Kill the temporary buffer that was selected in the meantime.
3892 Since this kill only the last temporary buffer, some buffers remain
3893 not killed if build_annotations switched buffers more than once.
3897 build_annotations_unwind (buf
)
3902 if (XBUFFER (buf
) == current_buffer
)
3904 tembuf
= Fcurrent_buffer ();
3906 Fkill_buffer (tembuf
);
3910 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 6,
3911 "r\nFWrite region to file: ",
3912 "Write current region into specified file.\n\
3913 When called from a program, takes three arguments:\n\
3914 START, END and FILENAME. START and END are buffer positions.\n\
3915 Optional fourth argument APPEND if non-nil means\n\
3916 append to existing file contents (if any).\n\
3917 Optional fifth argument VISIT if t means\n\
3918 set the last-save-file-modtime of buffer to this file's modtime\n\
3919 and mark buffer not modified.\n\
3920 If VISIT is a string, it is a second file name;\n\
3921 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
3922 VISIT is also the file name to lock and unlock for clash detection.\n\
3923 If VISIT is neither t nor nil nor a string,\n\
3924 that means do not print the \"Wrote file\" message.\n\
3925 The optional sixth arg LOCKNAME, if non-nil, specifies the name to\n\
3926 use for locking and unlocking, overriding FILENAME and VISIT.\n\
3927 Kludgy feature: if START is a string, then that string is written\n\
3928 to the file, instead of any buffer contents, and END is ignored.")
3929 (start
, end
, filename
, append
, visit
, lockname
)
3930 Lisp_Object start
, end
, filename
, append
, visit
, lockname
;
3938 int count
= specpdl_ptr
- specpdl
;
3941 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
3943 Lisp_Object handler
;
3944 Lisp_Object visit_file
;
3945 Lisp_Object annotations
;
3946 Lisp_Object encoded_filename
;
3947 int visiting
, quietly
;
3948 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
3949 struct buffer
*given_buffer
;
3951 int buffer_file_type
= O_BINARY
;
3953 struct coding_system coding
;
3955 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3956 error ("Cannot do file visiting in an indirect buffer");
3958 if (!NILP (start
) && !STRINGP (start
))
3959 validate_region (&start
, &end
);
3961 GCPRO4 (start
, filename
, visit
, lockname
);
3963 /* Decide the coding-system to encode the data with. */
3969 else if (!NILP (Vcoding_system_for_write
))
3970 val
= Vcoding_system_for_write
;
3971 else if (NILP (current_buffer
->enable_multibyte_characters
))
3973 /* If the variable `buffer-file-coding-system' is set locally,
3974 it means that the file was read with some kind of code
3975 conversion or the varialbe is explicitely set by users. We
3976 had better write it out with the same coding system even if
3977 `enable-multibyte-characters' is nil.
3979 If it is not set locally, we anyway have to convert EOL
3980 format if the default value of `buffer-file-coding-system'
3981 tells that it is not Unix-like (LF only) format. */
3982 val
= current_buffer
->buffer_file_coding_system
;
3983 if (NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
3985 struct coding_system coding_temp
;
3987 setup_coding_system (Fcheck_coding_system (val
), &coding_temp
);
3988 if (coding_temp
.eol_type
== CODING_EOL_CRLF
3989 || coding_temp
.eol_type
== CODING_EOL_CR
)
3991 setup_coding_system (Qraw_text
, &coding
);
3992 coding
.eol_type
= coding_temp
.eol_type
;
3993 goto done_setup_coding
;
4000 Lisp_Object args
[7], coding_systems
;
4002 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4003 args
[3] = filename
; args
[4] = append
; args
[5] = visit
;
4005 coding_systems
= Ffind_operation_coding_system (7, args
);
4006 val
= (CONSP (coding_systems
) && !NILP (XCONS (coding_systems
)->cdr
)
4007 ? XCONS (coding_systems
)->cdr
4008 : current_buffer
->buffer_file_coding_system
);
4009 /* Confirm that VAL can surely encode the current region. */
4010 if (Ffboundp (Vselect_safe_coding_system_function
))
4011 val
= call3 (Vselect_safe_coding_system_function
, start
, end
, val
);
4013 setup_coding_system (Fcheck_coding_system (val
), &coding
);
4016 if (!STRINGP (start
) && !NILP (current_buffer
->selective_display
))
4017 coding
.mode
|= CODING_MODE_SELECTIVE_DISPLAY
;
4020 Vlast_coding_system_used
= coding
.symbol
;
4022 filename
= Fexpand_file_name (filename
, Qnil
);
4023 if (STRINGP (visit
))
4024 visit_file
= Fexpand_file_name (visit
, Qnil
);
4026 visit_file
= filename
;
4029 visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
4030 quietly
= !NILP (visit
);
4034 if (NILP (lockname
))
4035 lockname
= visit_file
;
4037 GCPRO5 (start
, filename
, annotations
, visit_file
, lockname
);
4039 /* If the file name has special constructs in it,
4040 call the corresponding file handler. */
4041 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
4042 /* If FILENAME has no handler, see if VISIT has one. */
4043 if (NILP (handler
) && STRINGP (visit
))
4044 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
4046 if (!NILP (handler
))
4049 val
= call6 (handler
, Qwrite_region
, start
, end
,
4050 filename
, append
, visit
);
4054 SAVE_MODIFF
= MODIFF
;
4055 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4056 current_buffer
->filename
= visit_file
;
4062 /* Special kludge to simplify auto-saving. */
4065 XSETFASTINT (start
, BEG
);
4066 XSETFASTINT (end
, Z
);
4069 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
4070 count1
= specpdl_ptr
- specpdl
;
4072 given_buffer
= current_buffer
;
4073 annotations
= build_annotations (start
, end
, coding
.pre_write_conversion
);
4074 if (current_buffer
!= given_buffer
)
4076 XSETFASTINT (start
, BEGV
);
4077 XSETFASTINT (end
, ZV
);
4080 #ifdef CLASH_DETECTION
4083 #if 0 /* This causes trouble for GNUS. */
4084 /* If we've locked this file for some other buffer,
4085 query before proceeding. */
4086 if (!visiting
&& EQ (Ffile_locked_p (lockname
), Qt
))
4087 call2 (intern ("ask-user-about-lock"), filename
, Vuser_login_name
);
4090 lock_file (lockname
);
4092 #endif /* CLASH_DETECTION */
4094 encoded_filename
= ENCODE_FILE (filename
);
4096 fn
= XSTRING (encoded_filename
)->data
;
4100 desc
= open (fn
, O_WRONLY
| buffer_file_type
);
4101 #else /* not DOS_NT */
4102 desc
= open (fn
, O_WRONLY
);
4103 #endif /* not DOS_NT */
4105 if (desc
< 0 && (NILP (append
) || errno
== ENOENT
))
4107 if (auto_saving
) /* Overwrite any previous version of autosave file */
4109 vms_truncate (fn
); /* if fn exists, truncate to zero length */
4110 desc
= open (fn
, O_RDWR
);
4112 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
4113 ? XSTRING (current_buffer
->filename
)->data
: 0,
4116 else /* Write to temporary name and rename if no errors */
4118 Lisp_Object temp_name
;
4119 temp_name
= Ffile_name_directory (filename
);
4121 if (!NILP (temp_name
))
4123 temp_name
= Fmake_temp_name (concat2 (temp_name
,
4124 build_string ("$$SAVE$$")));
4125 fname
= XSTRING (filename
)->data
;
4126 fn
= XSTRING (temp_name
)->data
;
4127 desc
= creat_copy_attrs (fname
, fn
);
4130 /* If we can't open the temporary file, try creating a new
4131 version of the original file. VMS "creat" creates a
4132 new version rather than truncating an existing file. */
4135 desc
= creat (fn
, 0666);
4136 #if 0 /* This can clobber an existing file and fail to replace it,
4137 if the user runs out of space. */
4140 /* We can't make a new version;
4141 try to truncate and rewrite existing version if any. */
4143 desc
= open (fn
, O_RDWR
);
4149 desc
= creat (fn
, 0666);
4154 O_WRONLY
| O_TRUNC
| O_CREAT
| buffer_file_type
,
4155 S_IREAD
| S_IWRITE
);
4156 #else /* not DOS_NT */
4157 desc
= creat (fn
, auto_saving
? auto_save_mode_bits
: 0666);
4158 #endif /* not DOS_NT */
4159 #endif /* not VMS */
4165 #ifdef CLASH_DETECTION
4167 if (!auto_saving
) unlock_file (lockname
);
4169 #endif /* CLASH_DETECTION */
4170 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
4173 record_unwind_protect (close_file_unwind
, make_number (desc
));
4176 if (lseek (desc
, 0, 2) < 0)
4178 #ifdef CLASH_DETECTION
4179 if (!auto_saving
) unlock_file (lockname
);
4180 #endif /* CLASH_DETECTION */
4181 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
4186 * Kludge Warning: The VMS C RTL likes to insert carriage returns
4187 * if we do writes that don't end with a carriage return. Furthermore
4188 * it cannot handle writes of more then 16K. The modified
4189 * version of "sys_write" in SYSDEP.C (see comment there) copes with
4190 * this EXCEPT for the last record (iff it doesn't end with a carriage
4191 * return). This implies that if your buffer doesn't end with a carriage
4192 * return, you get one free... tough. However it also means that if
4193 * we make two calls to sys_write (a la the following code) you can
4194 * get one at the gap as well. The easiest way to fix this (honest)
4195 * is to move the gap to the next newline (or the end of the buffer).
4200 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4201 move_gap (find_next_newline (GPT
, 1));
4203 /* Whether VMS or not, we must move the gap to the next of newline
4204 when we must put designation sequences at beginning of line. */
4205 if (INTEGERP (start
)
4206 && coding
.type
== coding_type_iso2022
4207 && coding
.flags
& CODING_FLAG_ISO_DESIGNATE_AT_BOL
4208 && GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4210 int opoint
= PT
, opoint_byte
= PT_BYTE
;
4211 scan_newline (PT
, PT_BYTE
, ZV
, ZV_BYTE
, 1, 0);
4212 move_gap_both (PT
, PT_BYTE
);
4213 SET_PT_BOTH (opoint
, opoint_byte
);
4220 if (STRINGP (start
))
4222 failure
= 0 > a_write (desc
, XSTRING (start
)->data
,
4223 XSTRING (start
)->size
, 0, &annotations
, &coding
);
4226 else if (XINT (start
) != XINT (end
))
4228 register int end1
= CHAR_TO_BYTE (XINT (end
));
4230 tem
= CHAR_TO_BYTE (XINT (start
));
4232 if (XINT (start
) < GPT
)
4234 failure
= 0 > a_write (desc
, BYTE_POS_ADDR (tem
),
4235 min (GPT_BYTE
, end1
) - tem
, tem
, &annotations
,
4240 if (XINT (end
) > GPT
&& !failure
)
4242 tem
= max (tem
, GPT_BYTE
);
4243 failure
= 0 > a_write (desc
, BYTE_POS_ADDR (tem
), end1
- tem
,
4244 tem
, &annotations
, &coding
);
4250 /* If file was empty, still need to write the annotations */
4251 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4252 failure
= 0 > a_write (desc
, "", 0, XINT (start
), &annotations
, &coding
);
4256 if (CODING_REQUIRE_FLUSHING (&coding
)
4257 && !(coding
.mode
& CODING_MODE_LAST_BLOCK
)
4260 /* We have to flush out a data. */
4261 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4262 failure
= 0 > e_write (desc
, "", 0, &coding
);
4269 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
4270 Disk full in NFS may be reported here. */
4271 /* mib says that closing the file will try to write as fast as NFS can do
4272 it, and that means the fsync here is not crucial for autosave files. */
4273 if (!auto_saving
&& fsync (desc
) < 0)
4275 /* If fsync fails with EINTR, don't treat that as serious. */
4277 failure
= 1, save_errno
= errno
;
4281 /* Spurious "file has changed on disk" warnings have been
4282 observed on Suns as well.
4283 It seems that `close' can change the modtime, under nfs.
4285 (This has supposedly been fixed in Sunos 4,
4286 but who knows about all the other machines with NFS?) */
4289 /* On VMS and APOLLO, must do the stat after the close
4290 since closing changes the modtime. */
4293 /* Recall that #if defined does not work on VMS. */
4300 /* NFS can report a write failure now. */
4301 if (close (desc
) < 0)
4302 failure
= 1, save_errno
= errno
;
4305 /* If we wrote to a temporary name and had no errors, rename to real name. */
4309 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
4317 /* Discard the unwind protect for close_file_unwind. */
4318 specpdl_ptr
= specpdl
+ count1
;
4319 /* Restore the original current buffer. */
4320 visit_file
= unbind_to (count
, visit_file
);
4322 #ifdef CLASH_DETECTION
4324 unlock_file (lockname
);
4325 #endif /* CLASH_DETECTION */
4327 /* Do this before reporting IO error
4328 to avoid a "file has changed on disk" warning on
4329 next attempt to save. */
4331 current_buffer
->modtime
= st
.st_mtime
;
4334 error ("IO error writing %s: %s", XSTRING (filename
)->data
,
4335 strerror (save_errno
));
4339 SAVE_MODIFF
= MODIFF
;
4340 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4341 current_buffer
->filename
= visit_file
;
4342 update_mode_lines
++;
4348 message_with_string ("Wrote %s", visit_file
, 1);
4353 Lisp_Object
merge ();
4355 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
4356 "Return t if (car A) is numerically less than (car B).")
4360 return Flss (Fcar (a
), Fcar (b
));
4363 /* Build the complete list of annotations appropriate for writing out
4364 the text between START and END, by calling all the functions in
4365 write-region-annotate-functions and merging the lists they return.
4366 If one of these functions switches to a different buffer, we assume
4367 that buffer contains altered text. Therefore, the caller must
4368 make sure to restore the current buffer in all cases,
4369 as save-excursion would do. */
4372 build_annotations (start
, end
, pre_write_conversion
)
4373 Lisp_Object start
, end
, pre_write_conversion
;
4375 Lisp_Object annotations
;
4377 struct gcpro gcpro1
, gcpro2
;
4378 Lisp_Object original_buffer
;
4380 XSETBUFFER (original_buffer
, current_buffer
);
4383 p
= Vwrite_region_annotate_functions
;
4384 GCPRO2 (annotations
, p
);
4387 struct buffer
*given_buffer
= current_buffer
;
4388 Vwrite_region_annotations_so_far
= annotations
;
4389 res
= call2 (Fcar (p
), start
, end
);
4390 /* If the function makes a different buffer current,
4391 assume that means this buffer contains altered text to be output.
4392 Reset START and END from the buffer bounds
4393 and discard all previous annotations because they should have
4394 been dealt with by this function. */
4395 if (current_buffer
!= given_buffer
)
4397 XSETFASTINT (start
, BEGV
);
4398 XSETFASTINT (end
, ZV
);
4401 Flength (res
); /* Check basic validity of return value */
4402 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4406 /* Now do the same for annotation functions implied by the file-format */
4407 if (auto_saving
&& (!EQ (Vauto_save_file_format
, Qt
)))
4408 p
= Vauto_save_file_format
;
4410 p
= current_buffer
->file_format
;
4413 struct buffer
*given_buffer
= current_buffer
;
4414 Vwrite_region_annotations_so_far
= annotations
;
4415 res
= call4 (Qformat_annotate_function
, Fcar (p
), start
, end
,
4417 if (current_buffer
!= given_buffer
)
4419 XSETFASTINT (start
, BEGV
);
4420 XSETFASTINT (end
, ZV
);
4424 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4428 /* At last, do the same for the function PRE_WRITE_CONVERSION
4429 implied by the current coding-system. */
4430 if (!NILP (pre_write_conversion
))
4432 struct buffer
*given_buffer
= current_buffer
;
4433 Vwrite_region_annotations_so_far
= annotations
;
4434 res
= call2 (pre_write_conversion
, start
, end
);
4436 annotations
= (current_buffer
!= given_buffer
4438 : merge (annotations
, res
, Qcar_less_than_car
));
4445 /* Write to descriptor DESC the NBYTES bytes starting at ADDR,
4446 assuming they start at byte position BYTEPOS in the buffer.
4447 Intersperse with them the annotations from *ANNOT
4448 which fall within the range of byte positions BYTEPOS to BYTEPOS + NBYTES,
4449 each at its appropriate position.
4451 We modify *ANNOT by discarding elements as we use them up.
4453 The return value is negative in case of system call failure. */
4456 a_write (desc
, addr
, nbytes
, bytepos
, annot
, coding
)
4458 register char *addr
;
4459 register int nbytes
;
4462 struct coding_system
*coding
;
4466 int lastpos
= bytepos
+ nbytes
;
4468 while (NILP (*annot
) || CONSP (*annot
))
4470 tem
= Fcar_safe (Fcar (*annot
));
4473 nextpos
= CHAR_TO_BYTE (XFASTINT (tem
));
4475 /* If there are no more annotations in this range,
4476 output the rest of the range all at once. */
4477 if (! (nextpos
>= bytepos
&& nextpos
<= lastpos
))
4478 return e_write (desc
, addr
, lastpos
- bytepos
, coding
);
4480 /* Output buffer text up to the next annotation's position. */
4481 if (nextpos
> bytepos
)
4483 if (0 > e_write (desc
, addr
, nextpos
- bytepos
, coding
))
4485 addr
+= nextpos
- bytepos
;
4488 /* Output the annotation. */
4489 tem
= Fcdr (Fcar (*annot
));
4492 if (0 > e_write (desc
, XSTRING (tem
)->data
, XSTRING (tem
)->size
,
4496 *annot
= Fcdr (*annot
);
4500 #ifndef WRITE_BUF_SIZE
4501 #define WRITE_BUF_SIZE (16 * 1024)
4504 /* Write NBYTES bytes starting at ADDR into descriptor DESC,
4505 encoding them with coding system CODING. */
4508 e_write (desc
, addr
, nbytes
, coding
)
4510 register char *addr
;
4511 register int nbytes
;
4512 struct coding_system
*coding
;
4514 char buf
[WRITE_BUF_SIZE
];
4516 /* We used to have a code for handling selective display here. But,
4517 now it is handled within encode_coding. */
4520 encode_coding (coding
, addr
, buf
, nbytes
, WRITE_BUF_SIZE
);
4521 nbytes
-= coding
->consumed
, addr
+= coding
->consumed
;
4522 if (coding
->produced
> 0)
4524 coding
->produced
-= write (desc
, buf
, coding
->produced
);
4525 if (coding
->produced
) return -1;
4533 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
4534 Sverify_visited_file_modtime
, 1, 1, 0,
4535 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
4536 This means that the file has not been changed since it was visited or saved.")
4542 Lisp_Object handler
;
4543 Lisp_Object filename
;
4545 CHECK_BUFFER (buf
, 0);
4548 if (!STRINGP (b
->filename
)) return Qt
;
4549 if (b
->modtime
== 0) return Qt
;
4551 /* If the file name has special constructs in it,
4552 call the corresponding file handler. */
4553 handler
= Ffind_file_name_handler (b
->filename
,
4554 Qverify_visited_file_modtime
);
4555 if (!NILP (handler
))
4556 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
4558 filename
= ENCODE_FILE (b
->filename
);
4560 if (stat (XSTRING (filename
)->data
, &st
) < 0)
4562 /* If the file doesn't exist now and didn't exist before,
4563 we say that it isn't modified, provided the error is a tame one. */
4564 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
4569 if (st
.st_mtime
== b
->modtime
4570 /* If both are positive, accept them if they are off by one second. */
4571 || (st
.st_mtime
> 0 && b
->modtime
> 0
4572 && (st
.st_mtime
== b
->modtime
+ 1
4573 || st
.st_mtime
== b
->modtime
- 1)))
4578 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
4579 Sclear_visited_file_modtime
, 0, 0, 0,
4580 "Clear out records of last mod time of visited file.\n\
4581 Next attempt to save will certainly not complain of a discrepancy.")
4584 current_buffer
->modtime
= 0;
4588 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
4589 Svisited_file_modtime
, 0, 0, 0,
4590 "Return the current buffer's recorded visited file modification time.\n\
4591 The value is a list of the form (HIGH . LOW), like the time values\n\
4592 that `file-attributes' returns.")
4595 return long_to_cons ((unsigned long) current_buffer
->modtime
);
4598 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
4599 Sset_visited_file_modtime
, 0, 1, 0,
4600 "Update buffer's recorded modification time from the visited file's time.\n\
4601 Useful if the buffer was not read from the file normally\n\
4602 or if the file itself has been changed for some known benign reason.\n\
4603 An argument specifies the modification time value to use\n\
4604 \(instead of that of the visited file), in the form of a list\n\
4605 \(HIGH . LOW) or (HIGH LOW).")
4607 Lisp_Object time_list
;
4609 if (!NILP (time_list
))
4610 current_buffer
->modtime
= cons_to_long (time_list
);
4613 register Lisp_Object filename
;
4615 Lisp_Object handler
;
4617 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
4619 /* If the file name has special constructs in it,
4620 call the corresponding file handler. */
4621 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
4622 if (!NILP (handler
))
4623 /* The handler can find the file name the same way we did. */
4624 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
4626 filename
= ENCODE_FILE (filename
);
4628 if (stat (XSTRING (filename
)->data
, &st
) >= 0)
4629 current_buffer
->modtime
= st
.st_mtime
;
4639 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 1);
4640 Fsleep_for (make_number (1), Qnil
);
4641 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 0);
4642 Fsleep_for (make_number (1), Qnil
);
4643 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 0);
4644 Fsleep_for (make_number (1), Qnil
);
4654 /* Get visited file's mode to become the auto save file's mode. */
4655 if (stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
4656 /* But make sure we can overwrite it later! */
4657 auto_save_mode_bits
= st
.st_mode
| 0600;
4659 auto_save_mode_bits
= 0666;
4662 Fwrite_region (Qnil
, Qnil
,
4663 current_buffer
->auto_save_file_name
,
4664 Qnil
, Qlambda
, Qnil
);
4668 do_auto_save_unwind (stream
) /* used as unwind-protect function */
4673 fclose ((FILE *) (XFASTINT (XCONS (stream
)->car
) << 16
4674 | XFASTINT (XCONS (stream
)->cdr
)));
4679 do_auto_save_unwind_1 (value
) /* used as unwind-protect function */
4682 minibuffer_auto_raise
= XINT (value
);
4686 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
4687 "Auto-save all buffers that need it.\n\
4688 This is all buffers that have auto-saving enabled\n\
4689 and are changed since last auto-saved.\n\
4690 Auto-saving writes the buffer into a file\n\
4691 so that your editing is not lost if the system crashes.\n\
4692 This file is not the file you visited; that changes only when you save.\n\
4693 Normally we run the normal hook `auto-save-hook' before saving.\n\n\
4694 A non-nil NO-MESSAGE argument means do not print any message if successful.\n\
4695 A non-nil CURRENT-ONLY argument means save only current buffer.")
4696 (no_message
, current_only
)
4697 Lisp_Object no_message
, current_only
;
4699 struct buffer
*old
= current_buffer
, *b
;
4700 Lisp_Object tail
, buf
;
4702 char *omessage
= echo_area_glyphs
;
4703 int omessage_length
= echo_area_glyphs_length
;
4704 int oldmultibyte
= message_enable_multibyte
;
4705 int do_handled_files
;
4708 Lisp_Object lispstream
;
4709 int count
= specpdl_ptr
- specpdl
;
4711 int orig_minibuffer_auto_raise
= minibuffer_auto_raise
;
4713 /* Ordinarily don't quit within this function,
4714 but don't make it impossible to quit (in case we get hung in I/O). */
4718 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
4719 point to non-strings reached from Vbuffer_alist. */
4724 if (!NILP (Vrun_hooks
))
4725 call1 (Vrun_hooks
, intern ("auto-save-hook"));
4727 if (STRINGP (Vauto_save_list_file_name
))
4729 Lisp_Object listfile
;
4730 listfile
= Fexpand_file_name (Vauto_save_list_file_name
, Qnil
);
4731 stream
= fopen (XSTRING (listfile
)->data
, "w");
4734 /* Arrange to close that file whether or not we get an error.
4735 Also reset auto_saving to 0. */
4736 lispstream
= Fcons (Qnil
, Qnil
);
4737 XSETFASTINT (XCONS (lispstream
)->car
, (EMACS_UINT
)stream
>> 16);
4738 XSETFASTINT (XCONS (lispstream
)->cdr
, (EMACS_UINT
)stream
& 0xffff);
4749 record_unwind_protect (do_auto_save_unwind
, lispstream
);
4750 record_unwind_protect (do_auto_save_unwind_1
,
4751 make_number (minibuffer_auto_raise
));
4752 minibuffer_auto_raise
= 0;
4755 /* First, save all files which don't have handlers. If Emacs is
4756 crashing, the handlers may tweak what is causing Emacs to crash
4757 in the first place, and it would be a shame if Emacs failed to
4758 autosave perfectly ordinary files because it couldn't handle some
4760 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
4761 for (tail
= Vbuffer_alist
; GC_CONSP (tail
); tail
= XCONS (tail
)->cdr
)
4763 buf
= XCONS (XCONS (tail
)->car
)->cdr
;
4766 /* Record all the buffers that have auto save mode
4767 in the special file that lists them. For each of these buffers,
4768 Record visited name (if any) and auto save name. */
4769 if (STRINGP (b
->auto_save_file_name
)
4770 && stream
!= NULL
&& do_handled_files
== 0)
4772 if (!NILP (b
->filename
))
4774 fwrite (XSTRING (b
->filename
)->data
, 1,
4775 XSTRING (b
->filename
)->size
, stream
);
4777 putc ('\n', stream
);
4778 fwrite (XSTRING (b
->auto_save_file_name
)->data
, 1,
4779 XSTRING (b
->auto_save_file_name
)->size
, stream
);
4780 putc ('\n', stream
);
4783 if (!NILP (current_only
)
4784 && b
!= current_buffer
)
4787 /* Don't auto-save indirect buffers.
4788 The base buffer takes care of it. */
4792 /* Check for auto save enabled
4793 and file changed since last auto save
4794 and file changed since last real save. */
4795 if (STRINGP (b
->auto_save_file_name
)
4796 && BUF_SAVE_MODIFF (b
) < BUF_MODIFF (b
)
4797 && b
->auto_save_modified
< BUF_MODIFF (b
)
4798 /* -1 means we've turned off autosaving for a while--see below. */
4799 && XINT (b
->save_length
) >= 0
4800 && (do_handled_files
4801 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
4804 EMACS_TIME before_time
, after_time
;
4806 EMACS_GET_TIME (before_time
);
4808 /* If we had a failure, don't try again for 20 minutes. */
4809 if (b
->auto_save_failure_time
>= 0
4810 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
4813 if ((XFASTINT (b
->save_length
) * 10
4814 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
4815 /* A short file is likely to change a large fraction;
4816 spare the user annoying messages. */
4817 && XFASTINT (b
->save_length
) > 5000
4818 /* These messages are frequent and annoying for `*mail*'. */
4819 && !EQ (b
->filename
, Qnil
)
4820 && NILP (no_message
))
4822 /* It has shrunk too much; turn off auto-saving here. */
4823 minibuffer_auto_raise
= orig_minibuffer_auto_raise
;
4824 message_with_string ("Buffer %s has shrunk a lot; auto save turned off there",
4826 minibuffer_auto_raise
= 0;
4827 /* Turn off auto-saving until there's a real save,
4828 and prevent any more warnings. */
4829 XSETINT (b
->save_length
, -1);
4830 Fsleep_for (make_number (1), Qnil
);
4833 set_buffer_internal (b
);
4834 if (!auto_saved
&& NILP (no_message
))
4835 message1 ("Auto-saving...");
4836 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
4838 b
->auto_save_modified
= BUF_MODIFF (b
);
4839 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4840 set_buffer_internal (old
);
4842 EMACS_GET_TIME (after_time
);
4844 /* If auto-save took more than 60 seconds,
4845 assume it was an NFS failure that got a timeout. */
4846 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
4847 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
4851 /* Prevent another auto save till enough input events come in. */
4852 record_auto_save ();
4854 if (auto_saved
&& NILP (no_message
))
4858 sit_for (1, 0, 0, 0, 0);
4859 message2 (omessage
, omessage_length
, oldmultibyte
);
4862 message1 ("Auto-saving...done");
4867 unbind_to (count
, Qnil
);
4871 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
4872 Sset_buffer_auto_saved
, 0, 0, 0,
4873 "Mark current buffer as auto-saved with its current text.\n\
4874 No auto-save file will be written until the buffer changes again.")
4877 current_buffer
->auto_save_modified
= MODIFF
;
4878 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4879 current_buffer
->auto_save_failure_time
= -1;
4883 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
4884 Sclear_buffer_auto_save_failure
, 0, 0, 0,
4885 "Clear any record of a recent auto-save failure in the current buffer.")
4888 current_buffer
->auto_save_failure_time
= -1;
4892 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
4894 "Return t if buffer has been auto-saved since last read in or saved.")
4897 return (SAVE_MODIFF
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
4900 /* Reading and completing file names */
4901 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
4903 /* In the string VAL, change each $ to $$ and return the result. */
4906 double_dollars (val
)
4909 register unsigned char *old
, *new;
4913 osize
= XSTRING (val
)->size_byte
;
4915 /* Count the number of $ characters. */
4916 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
4917 if (*old
++ == '$') count
++;
4920 old
= XSTRING (val
)->data
;
4921 val
= make_uninit_multibyte_string (XSTRING (val
)->size
+ count
,
4923 new = XSTRING (val
)->data
;
4924 for (n
= osize
; n
> 0; n
--)
4937 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
4939 "Internal subroutine for read-file-name. Do not call this.")
4940 (string
, dir
, action
)
4941 Lisp_Object string
, dir
, action
;
4942 /* action is nil for complete, t for return list of completions,
4943 lambda for verify final value */
4945 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
4947 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
4949 CHECK_STRING (string
, 0);
4956 /* No need to protect ACTION--we only compare it with t and nil. */
4957 GCPRO5 (string
, realdir
, name
, specdir
, orig_string
);
4959 if (XSTRING (string
)->size
== 0)
4961 if (EQ (action
, Qlambda
))
4969 orig_string
= string
;
4970 string
= Fsubstitute_in_file_name (string
);
4971 changed
= NILP (Fstring_equal (string
, orig_string
));
4972 name
= Ffile_name_nondirectory (string
);
4973 val
= Ffile_name_directory (string
);
4975 realdir
= Fexpand_file_name (val
, realdir
);
4980 specdir
= Ffile_name_directory (string
);
4981 val
= Ffile_name_completion (name
, realdir
);
4986 return double_dollars (string
);
4990 if (!NILP (specdir
))
4991 val
= concat2 (specdir
, val
);
4993 return double_dollars (val
);
4996 #endif /* not VMS */
5000 if (EQ (action
, Qt
))
5001 return Ffile_name_all_completions (name
, realdir
);
5002 /* Only other case actually used is ACTION = lambda */
5004 /* Supposedly this helps commands such as `cd' that read directory names,
5005 but can someone explain how it helps them? -- RMS */
5006 if (XSTRING (name
)->size
== 0)
5009 return Ffile_exists_p (string
);
5012 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
5013 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
5014 Value is not expanded---you must call `expand-file-name' yourself.\n\
5015 Default name to DEFAULT-FILENAME if user enters a null string.\n\
5016 (If DEFAULT-FILENAME is omitted, the visited file name is used,\n\
5017 except that if INITIAL is specified, that combined with DIR is used.)\n\
5018 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
5019 Non-nil and non-t means also require confirmation after completion.\n\
5020 Fifth arg INITIAL specifies text to start with.\n\
5021 DIR defaults to current buffer's directory default.")
5022 (prompt
, dir
, default_filename
, mustmatch
, initial
)
5023 Lisp_Object prompt
, dir
, default_filename
, mustmatch
, initial
;
5025 Lisp_Object val
, insdef
, insdef1
, tem
;
5026 struct gcpro gcpro1
, gcpro2
;
5027 register char *homedir
;
5031 dir
= current_buffer
->directory
;
5032 if (NILP (default_filename
))
5034 if (! NILP (initial
))
5035 default_filename
= Fexpand_file_name (initial
, dir
);
5037 default_filename
= current_buffer
->filename
;
5040 /* If dir starts with user's homedir, change that to ~. */
5041 homedir
= (char *) egetenv ("HOME");
5043 homedir
= strcpy (alloca (strlen (homedir
) + 1), homedir
);
5044 CORRECT_DIR_SEPS (homedir
);
5048 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5049 && IS_DIRECTORY_SEP (XSTRING (dir
)->data
[strlen (homedir
)]))
5051 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5052 XSTRING (dir
)->size
- strlen (homedir
) + 1);
5053 XSTRING (dir
)->data
[0] = '~';
5056 if (insert_default_directory
&& STRINGP (dir
))
5059 if (!NILP (initial
))
5061 Lisp_Object args
[2], pos
;
5065 insdef
= Fconcat (2, args
);
5066 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
5067 insdef1
= Fcons (double_dollars (insdef
), pos
);
5070 insdef1
= double_dollars (insdef
);
5072 else if (STRINGP (initial
))
5075 insdef1
= Fcons (double_dollars (insdef
), make_number (0));
5078 insdef
= Qnil
, insdef1
= Qnil
;
5081 count
= specpdl_ptr
- specpdl
;
5082 specbind (intern ("completion-ignore-case"), Qt
);
5085 GCPRO2 (insdef
, default_filename
);
5086 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5087 dir
, mustmatch
, insdef1
,
5088 Qfile_name_history
, default_filename
, Qnil
);
5089 /* If Fcompleting_read returned the default string itself
5090 (rather than a new string with the same contents),
5091 it has to mean that the user typed RET with the minibuffer empty.
5092 In that case, we really want to return ""
5093 so that commands such as set-visited-file-name can distinguish. */
5094 if (EQ (val
, default_filename
))
5095 val
= build_string ("");
5098 unbind_to (count
, Qnil
);
5103 error ("No file name specified");
5104 tem
= Fstring_equal (val
, insdef
);
5105 if (!NILP (tem
) && !NILP (default_filename
))
5106 return default_filename
;
5107 if (XSTRING (val
)->size
== 0 && NILP (insdef
))
5109 if (!NILP (default_filename
))
5110 return default_filename
;
5112 error ("No default file name");
5114 return Fsubstitute_in_file_name (val
);
5117 #if 0 /* Old version */
5118 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
5119 /* Don't confuse make-docfile by having two doc strings for this function.
5120 make-docfile does not pay attention to #if, for good reason! */
5122 (prompt
, dir
, defalt
, mustmatch
, initial
)
5123 Lisp_Object prompt
, dir
, defalt
, mustmatch
, initial
;
5125 Lisp_Object val
, insdef
, tem
;
5126 struct gcpro gcpro1
, gcpro2
;
5127 register char *homedir
;
5131 dir
= current_buffer
->directory
;
5133 defalt
= current_buffer
->filename
;
5135 /* If dir starts with user's homedir, change that to ~. */
5136 homedir
= (char *) egetenv ("HOME");
5139 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5140 && XSTRING (dir
)->data
[strlen (homedir
)] == '/')
5142 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5143 XSTRING (dir
)->size
- strlen (homedir
) + 1);
5144 XSTRING (dir
)->data
[0] = '~';
5147 if (!NILP (initial
))
5149 else if (insert_default_directory
)
5152 insdef
= build_string ("");
5155 count
= specpdl_ptr
- specpdl
;
5156 specbind (intern ("completion-ignore-case"), Qt
);
5159 GCPRO2 (insdef
, defalt
);
5160 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5162 insert_default_directory
? insdef
: Qnil
,
5163 Qfile_name_history
, Qnil
, Qnil
);
5166 unbind_to (count
, Qnil
);
5171 error ("No file name specified");
5172 tem
= Fstring_equal (val
, insdef
);
5173 if (!NILP (tem
) && !NILP (defalt
))
5175 return Fsubstitute_in_file_name (val
);
5177 #endif /* Old version */
5181 Qexpand_file_name
= intern ("expand-file-name");
5182 Qsubstitute_in_file_name
= intern ("substitute-in-file-name");
5183 Qdirectory_file_name
= intern ("directory-file-name");
5184 Qfile_name_directory
= intern ("file-name-directory");
5185 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
5186 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
5187 Qfile_name_as_directory
= intern ("file-name-as-directory");
5188 Qcopy_file
= intern ("copy-file");
5189 Qmake_directory_internal
= intern ("make-directory-internal");
5190 Qdelete_directory
= intern ("delete-directory");
5191 Qdelete_file
= intern ("delete-file");
5192 Qrename_file
= intern ("rename-file");
5193 Qadd_name_to_file
= intern ("add-name-to-file");
5194 Qmake_symbolic_link
= intern ("make-symbolic-link");
5195 Qfile_exists_p
= intern ("file-exists-p");
5196 Qfile_executable_p
= intern ("file-executable-p");
5197 Qfile_readable_p
= intern ("file-readable-p");
5198 Qfile_writable_p
= intern ("file-writable-p");
5199 Qfile_symlink_p
= intern ("file-symlink-p");
5200 Qaccess_file
= intern ("access-file");
5201 Qfile_directory_p
= intern ("file-directory-p");
5202 Qfile_regular_p
= intern ("file-regular-p");
5203 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
5204 Qfile_modes
= intern ("file-modes");
5205 Qset_file_modes
= intern ("set-file-modes");
5206 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
5207 Qinsert_file_contents
= intern ("insert-file-contents");
5208 Qwrite_region
= intern ("write-region");
5209 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
5210 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
5212 staticpro (&Qexpand_file_name
);
5213 staticpro (&Qsubstitute_in_file_name
);
5214 staticpro (&Qdirectory_file_name
);
5215 staticpro (&Qfile_name_directory
);
5216 staticpro (&Qfile_name_nondirectory
);
5217 staticpro (&Qunhandled_file_name_directory
);
5218 staticpro (&Qfile_name_as_directory
);
5219 staticpro (&Qcopy_file
);
5220 staticpro (&Qmake_directory_internal
);
5221 staticpro (&Qdelete_directory
);
5222 staticpro (&Qdelete_file
);
5223 staticpro (&Qrename_file
);
5224 staticpro (&Qadd_name_to_file
);
5225 staticpro (&Qmake_symbolic_link
);
5226 staticpro (&Qfile_exists_p
);
5227 staticpro (&Qfile_executable_p
);
5228 staticpro (&Qfile_readable_p
);
5229 staticpro (&Qfile_writable_p
);
5230 staticpro (&Qaccess_file
);
5231 staticpro (&Qfile_symlink_p
);
5232 staticpro (&Qfile_directory_p
);
5233 staticpro (&Qfile_regular_p
);
5234 staticpro (&Qfile_accessible_directory_p
);
5235 staticpro (&Qfile_modes
);
5236 staticpro (&Qset_file_modes
);
5237 staticpro (&Qfile_newer_than_file_p
);
5238 staticpro (&Qinsert_file_contents
);
5239 staticpro (&Qwrite_region
);
5240 staticpro (&Qverify_visited_file_modtime
);
5241 staticpro (&Qset_visited_file_modtime
);
5243 Qfile_name_history
= intern ("file-name-history");
5244 Fset (Qfile_name_history
, Qnil
);
5245 staticpro (&Qfile_name_history
);
5247 Qfile_error
= intern ("file-error");
5248 staticpro (&Qfile_error
);
5249 Qfile_already_exists
= intern ("file-already-exists");
5250 staticpro (&Qfile_already_exists
);
5251 Qfile_date_error
= intern ("file-date-error");
5252 staticpro (&Qfile_date_error
);
5255 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
5256 staticpro (&Qfind_buffer_file_type
);
5259 DEFVAR_LISP ("file-name-coding-system", &Vfile_name_coding_system
,
5260 "*Coding system for encoding file names.");
5261 Vfile_name_coding_system
= Qnil
;
5263 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format
,
5264 "*Format in which to write auto-save files.\n\
5265 Should be a list of symbols naming formats that are defined in `format-alist'.\n\
5266 If it is t, which is the default, auto-save files are written in the\n\
5267 same format as a regular save would use.");
5268 Vauto_save_file_format
= Qt
;
5270 Qformat_decode
= intern ("format-decode");
5271 staticpro (&Qformat_decode
);
5272 Qformat_annotate_function
= intern ("format-annotate-function");
5273 staticpro (&Qformat_annotate_function
);
5275 Qcar_less_than_car
= intern ("car-less-than-car");
5276 staticpro (&Qcar_less_than_car
);
5278 Fput (Qfile_error
, Qerror_conditions
,
5279 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
5280 Fput (Qfile_error
, Qerror_message
,
5281 build_string ("File error"));
5283 Fput (Qfile_already_exists
, Qerror_conditions
,
5284 Fcons (Qfile_already_exists
,
5285 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5286 Fput (Qfile_already_exists
, Qerror_message
,
5287 build_string ("File already exists"));
5289 Fput (Qfile_date_error
, Qerror_conditions
,
5290 Fcons (Qfile_date_error
,
5291 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5292 Fput (Qfile_date_error
, Qerror_message
,
5293 build_string ("Cannot set file date"));
5295 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
5296 "*Non-nil means when reading a filename start with default dir in minibuffer.");
5297 insert_default_directory
= 1;
5299 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
5300 "*Non-nil means write new files with record format `stmlf'.\n\
5301 nil means use format `var'. This variable is meaningful only on VMS.");
5302 vms_stmlf_recfm
= 0;
5304 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char
,
5305 "Directory separator character for built-in functions that return file names.\n\
5306 The value should be either ?/ or ?\\ (any other value is treated as ?\\).\n\
5307 This variable affects the built-in functions only on Windows,\n\
5308 on other platforms, it is initialized so that Lisp code can find out\n\
5309 what the normal separator is.");
5310 XSETFASTINT (Vdirectory_sep_char
, '/');
5312 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
5313 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
5314 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
5317 The first argument given to HANDLER is the name of the I/O primitive\n\
5318 to be handled; the remaining arguments are the arguments that were\n\
5319 passed to that primitive. For example, if you do\n\
5320 (file-exists-p FILENAME)\n\
5321 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
5322 (funcall HANDLER 'file-exists-p FILENAME)\n\
5323 The function `find-file-name-handler' checks this list for a handler\n\
5324 for its argument.");
5325 Vfile_name_handler_alist
= Qnil
;
5327 DEFVAR_LISP ("set-auto-coding-function",
5328 &Vset_auto_coding_function
,
5329 "If non-nil, a function to call to decide a coding system of file.\n\
5330 One argument is passed to this function: the string of concatination\n\
5331 or the heading 1K-byte and the tailing 3K-byte of a file to be read.\n\
5332 This function should return a coding system to decode the file contents\n\
5333 specified in the heading lines with the format:\n\
5334 -*- ... coding: CODING-SYSTEM; ... -*-\n\
5335 or local variable spec of the tailing lines with `coding:' tag.");
5336 Vset_auto_coding_function
= Qnil
;
5338 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
5339 "A list of functions to be called at the end of `insert-file-contents'.\n\
5340 Each is passed one argument, the number of bytes inserted. It should return\n\
5341 the new byte count, and leave point the same. If `insert-file-contents' is\n\
5342 intercepted by a handler from `file-name-handler-alist', that handler is\n\
5343 responsible for calling the after-insert-file-functions if appropriate.");
5344 Vafter_insert_file_functions
= Qnil
;
5346 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
5347 "A list of functions to be called at the start of `write-region'.\n\
5348 Each is passed two arguments, START and END as for `write-region'.\n\
5349 These are usually two numbers but not always; see the documentation\n\
5350 for `write-region'. The function should return a list of pairs\n\
5351 of the form (POSITION . STRING), consisting of strings to be effectively\n\
5352 inserted at the specified positions of the file being written (1 means to\n\
5353 insert before the first byte written). The POSITIONs must be sorted into\n\
5354 increasing order. If there are several functions in the list, the several\n\
5355 lists are merged destructively.");
5356 Vwrite_region_annotate_functions
= Qnil
;
5358 DEFVAR_LISP ("write-region-annotations-so-far",
5359 &Vwrite_region_annotations_so_far
,
5360 "When an annotation function is called, this holds the previous annotations.\n\
5361 These are the annotations made by other annotation functions\n\
5362 that were already called. See also `write-region-annotate-functions'.");
5363 Vwrite_region_annotations_so_far
= Qnil
;
5365 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
5366 "A list of file name handlers that temporarily should not be used.\n\
5367 This applies only to the operation `inhibit-file-name-operation'.");
5368 Vinhibit_file_name_handlers
= Qnil
;
5370 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
5371 "The operation for which `inhibit-file-name-handlers' is applicable.");
5372 Vinhibit_file_name_operation
= Qnil
;
5374 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
5375 "File name in which we write a list of all auto save file names.\n\
5376 This variable is initialized automatically from `auto-save-list-file-prefix'\n\
5377 shortly after Emacs reads your `.emacs' file, if you have not yet given it\n\
5379 Vauto_save_list_file_name
= Qnil
;
5381 defsubr (&Sfind_file_name_handler
);
5382 defsubr (&Sfile_name_directory
);
5383 defsubr (&Sfile_name_nondirectory
);
5384 defsubr (&Sunhandled_file_name_directory
);
5385 defsubr (&Sfile_name_as_directory
);
5386 defsubr (&Sdirectory_file_name
);
5387 defsubr (&Smake_temp_name
);
5388 defsubr (&Sexpand_file_name
);
5389 defsubr (&Ssubstitute_in_file_name
);
5390 defsubr (&Scopy_file
);
5391 defsubr (&Smake_directory_internal
);
5392 defsubr (&Sdelete_directory
);
5393 defsubr (&Sdelete_file
);
5394 defsubr (&Srename_file
);
5395 defsubr (&Sadd_name_to_file
);
5397 defsubr (&Smake_symbolic_link
);
5398 #endif /* S_IFLNK */
5400 defsubr (&Sdefine_logical_name
);
5403 defsubr (&Ssysnetunam
);
5404 #endif /* HPUX_NET */
5405 defsubr (&Sfile_name_absolute_p
);
5406 defsubr (&Sfile_exists_p
);
5407 defsubr (&Sfile_executable_p
);
5408 defsubr (&Sfile_readable_p
);
5409 defsubr (&Sfile_writable_p
);
5410 defsubr (&Saccess_file
);
5411 defsubr (&Sfile_symlink_p
);
5412 defsubr (&Sfile_directory_p
);
5413 defsubr (&Sfile_accessible_directory_p
);
5414 defsubr (&Sfile_regular_p
);
5415 defsubr (&Sfile_modes
);
5416 defsubr (&Sset_file_modes
);
5417 defsubr (&Sset_default_file_modes
);
5418 defsubr (&Sdefault_file_modes
);
5419 defsubr (&Sfile_newer_than_file_p
);
5420 defsubr (&Sinsert_file_contents
);
5421 defsubr (&Swrite_region
);
5422 defsubr (&Scar_less_than_car
);
5423 defsubr (&Sverify_visited_file_modtime
);
5424 defsubr (&Sclear_visited_file_modtime
);
5425 defsubr (&Svisited_file_modtime
);
5426 defsubr (&Sset_visited_file_modtime
);
5427 defsubr (&Sdo_auto_save
);
5428 defsubr (&Sset_buffer_auto_saved
);
5429 defsubr (&Sclear_buffer_auto_save_failure
);
5430 defsubr (&Srecent_auto_save_p
);
5432 defsubr (&Sread_file_name_internal
);
5433 defsubr (&Sread_file_name
);
5436 defsubr (&Sunix_sync
);