1 /* File IO for GNU Emacs.
2 Copyright (C) 1985,86,87,88,93,94,95,96,97,98,99,2000
3 Free Software Foundation, Inc.
5 This file is part of GNU Emacs.
7 GNU Emacs is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Emacs is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Emacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 #define _GNU_SOURCE /* for euidaccess */
26 #if defined (USG5) || defined (BSD_SYSTEM) || defined (LINUX)
31 #include <sys/types.h>
38 #if !defined (S_ISLNK) && defined (S_IFLNK)
39 # define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
42 #if !defined (S_ISFIFO) && defined (S_IFIFO)
43 # define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO)
46 #if !defined (S_ISREG) && defined (S_IFREG)
47 # define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
88 #include "intervals.h"
99 #endif /* not WINDOWSNT */
103 #include <sys/param.h>
111 #define CORRECT_DIR_SEPS(s) \
112 do { if ('/' == DIRECTORY_SEP) dostounix_filename (s); \
113 else unixtodos_filename (s); \
115 /* On Windows, drive letters must be alphabetic - on DOS, the Netware
116 redirector allows the six letters between 'Z' and 'a' as well. */
118 #define IS_DRIVE(x) ((x) >= 'A' && (x) <= 'z')
121 #define IS_DRIVE(x) isalpha (x)
123 /* Need to lower-case the drive letter, or else expanded
124 filenames will sometimes compare inequal, because
125 `expand-file-name' doesn't always down-case the drive letter. */
126 #define DRIVE_LETTER(x) (tolower (x))
147 #include "commands.h"
148 extern int use_dialog_box
;
162 #define min(a, b) ((a) < (b) ? (a) : (b))
163 #define max(a, b) ((a) > (b) ? (a) : (b))
165 /* Nonzero during writing of auto-save files */
168 /* Set by auto_save_1 to mode of original file so Fwrite_region will create
169 a new file with the same mode as the original */
170 int auto_save_mode_bits
;
172 /* Coding system for file names, or nil if none. */
173 Lisp_Object Vfile_name_coding_system
;
175 /* Coding system for file names used only when
176 Vfile_name_coding_system is nil. */
177 Lisp_Object Vdefault_file_name_coding_system
;
179 /* Alist of elements (REGEXP . HANDLER) for file names
180 whose I/O is done with a special handler. */
181 Lisp_Object Vfile_name_handler_alist
;
183 /* Format for auto-save files */
184 Lisp_Object Vauto_save_file_format
;
186 /* Lisp functions for translating file formats */
187 Lisp_Object Qformat_decode
, Qformat_annotate_function
;
189 /* Function to be called to decide a coding system of a reading file. */
190 Lisp_Object Vset_auto_coding_function
;
192 /* Functions to be called to process text properties in inserted file. */
193 Lisp_Object Vafter_insert_file_functions
;
195 /* Functions to be called to create text property annotations for file. */
196 Lisp_Object Vwrite_region_annotate_functions
;
198 /* During build_annotations, each time an annotation function is called,
199 this holds the annotations made by the previous functions. */
200 Lisp_Object Vwrite_region_annotations_so_far
;
202 /* File name in which we write a list of all our auto save files. */
203 Lisp_Object Vauto_save_list_file_name
;
205 /* Nonzero means, when reading a filename in the minibuffer,
206 start out by inserting the default directory into the minibuffer. */
207 int insert_default_directory
;
209 /* On VMS, nonzero means write new files with record format stmlf.
210 Zero means use var format. */
213 /* On NT, specifies the directory separator character, used (eg.) when
214 expanding file names. This can be bound to / or \. */
215 Lisp_Object Vdirectory_sep_char
;
217 extern Lisp_Object Vuser_login_name
;
220 extern Lisp_Object Vw32_get_true_file_attributes
;
223 extern int minibuf_level
;
225 extern int minibuffer_auto_raise
;
227 /* These variables describe handlers that have "already" had a chance
228 to handle the current operation.
230 Vinhibit_file_name_handlers is a list of file name handlers.
231 Vinhibit_file_name_operation is the operation being handled.
232 If we try to handle that operation, we ignore those handlers. */
234 static Lisp_Object Vinhibit_file_name_handlers
;
235 static Lisp_Object Vinhibit_file_name_operation
;
237 Lisp_Object Qfile_error
, Qfile_already_exists
, Qfile_date_error
;
239 Lisp_Object Qfile_name_history
;
241 Lisp_Object Qcar_less_than_car
;
243 static int a_write
P_ ((int, Lisp_Object
, int, int,
244 Lisp_Object
*, struct coding_system
*));
245 static int e_write
P_ ((int, Lisp_Object
, int, int, struct coding_system
*));
249 report_file_error (string
, data
)
253 Lisp_Object errstring
;
256 synchronize_system_messages_locale ();
257 errstring
= code_convert_string_norecord (build_string (strerror (errorno
)),
258 Vlocale_coding_system
, 0);
264 Fsignal (Qfile_already_exists
, Fcons (errstring
, data
));
267 /* System error messages are capitalized. Downcase the initial
268 unless it is followed by a slash. */
269 if (XSTRING (errstring
)->data
[1] != '/')
270 XSTRING (errstring
)->data
[0] = DOWNCASE (XSTRING (errstring
)->data
[0]);
272 Fsignal (Qfile_error
,
273 Fcons (build_string (string
), Fcons (errstring
, data
)));
278 close_file_unwind (fd
)
281 emacs_close (XFASTINT (fd
));
285 /* Restore point, having saved it as a marker. */
288 restore_point_unwind (location
)
289 Lisp_Object location
;
291 Fgoto_char (location
);
292 Fset_marker (location
, Qnil
, Qnil
);
296 Lisp_Object Qexpand_file_name
;
297 Lisp_Object Qsubstitute_in_file_name
;
298 Lisp_Object Qdirectory_file_name
;
299 Lisp_Object Qfile_name_directory
;
300 Lisp_Object Qfile_name_nondirectory
;
301 Lisp_Object Qunhandled_file_name_directory
;
302 Lisp_Object Qfile_name_as_directory
;
303 Lisp_Object Qcopy_file
;
304 Lisp_Object Qmake_directory_internal
;
305 Lisp_Object Qmake_directory
;
306 Lisp_Object Qdelete_directory
;
307 Lisp_Object Qdelete_file
;
308 Lisp_Object Qrename_file
;
309 Lisp_Object Qadd_name_to_file
;
310 Lisp_Object Qmake_symbolic_link
;
311 Lisp_Object Qfile_exists_p
;
312 Lisp_Object Qfile_executable_p
;
313 Lisp_Object Qfile_readable_p
;
314 Lisp_Object Qfile_writable_p
;
315 Lisp_Object Qfile_symlink_p
;
316 Lisp_Object Qaccess_file
;
317 Lisp_Object Qfile_directory_p
;
318 Lisp_Object Qfile_regular_p
;
319 Lisp_Object Qfile_accessible_directory_p
;
320 Lisp_Object Qfile_modes
;
321 Lisp_Object Qset_file_modes
;
322 Lisp_Object Qfile_newer_than_file_p
;
323 Lisp_Object Qinsert_file_contents
;
324 Lisp_Object Qwrite_region
;
325 Lisp_Object Qverify_visited_file_modtime
;
326 Lisp_Object Qset_visited_file_modtime
;
328 DEFUN ("find-file-name-handler", Ffind_file_name_handler
, Sfind_file_name_handler
, 2, 2, 0,
329 "Return FILENAME's handler function for OPERATION, if it has one.\n\
330 Otherwise, return nil.\n\
331 A file name is handled if one of the regular expressions in\n\
332 `file-name-handler-alist' matches it.\n\n\
333 If OPERATION equals `inhibit-file-name-operation', then we ignore\n\
334 any handlers that are members of `inhibit-file-name-handlers',\n\
335 but we still do run any other handlers. This lets handlers\n\
336 use the standard functions without calling themselves recursively.")
337 (filename
, operation
)
338 Lisp_Object filename
, operation
;
340 /* This function must not munge the match data. */
341 Lisp_Object chain
, inhibited_handlers
;
343 CHECK_STRING (filename
, 0);
345 if (EQ (operation
, Vinhibit_file_name_operation
))
346 inhibited_handlers
= Vinhibit_file_name_handlers
;
348 inhibited_handlers
= Qnil
;
350 for (chain
= Vfile_name_handler_alist
; CONSP (chain
);
351 chain
= XCDR (chain
))
359 if (STRINGP (string
) && fast_string_match (string
, filename
) >= 0)
361 Lisp_Object handler
, tem
;
363 handler
= XCDR (elt
);
364 tem
= Fmemq (handler
, inhibited_handlers
);
375 DEFUN ("file-name-directory", Ffile_name_directory
, Sfile_name_directory
,
377 "Return the directory component in file name FILENAME.\n\
378 Return nil if FILENAME does not include a directory.\n\
379 Otherwise return a directory spec.\n\
380 Given a Unix syntax file name, returns a string ending in slash;\n\
381 on VMS, perhaps instead a string ending in `:', `]' or `>'.")
383 Lisp_Object filename
;
385 register unsigned char *beg
;
386 register unsigned char *p
;
389 CHECK_STRING (filename
, 0);
391 /* If the file name has special constructs in it,
392 call the corresponding file handler. */
393 handler
= Ffind_file_name_handler (filename
, Qfile_name_directory
);
395 return call2 (handler
, Qfile_name_directory
, filename
);
397 #ifdef FILE_SYSTEM_CASE
398 filename
= FILE_SYSTEM_CASE (filename
);
400 beg
= XSTRING (filename
)->data
;
402 beg
= strcpy (alloca (strlen (beg
) + 1), beg
);
404 p
= beg
+ STRING_BYTES (XSTRING (filename
));
406 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
408 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
411 /* only recognise drive specifier at the beginning */
413 /* handle the "/:d:foo" and "/:foo" cases correctly */
414 && ((p
== beg
+ 2 && !IS_DIRECTORY_SEP (*beg
))
415 || (p
== beg
+ 4 && IS_DIRECTORY_SEP (*beg
))))
422 /* Expansion of "c:" to drive and default directory. */
425 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
426 unsigned char *res
= alloca (MAXPATHLEN
+ 1);
427 unsigned char *r
= res
;
429 if (p
== beg
+ 4 && IS_DIRECTORY_SEP (*beg
) && beg
[1] == ':')
431 strncpy (res
, beg
, 2);
436 if (getdefdir (toupper (*beg
) - 'A' + 1, r
))
438 if (!IS_DIRECTORY_SEP (res
[strlen (res
) - 1]))
441 p
= beg
+ strlen (beg
);
444 CORRECT_DIR_SEPS (beg
);
447 if (STRING_MULTIBYTE (filename
))
448 return make_string (beg
, p
- beg
);
449 return make_unibyte_string (beg
, p
- beg
);
452 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory
,
453 Sfile_name_nondirectory
, 1, 1, 0,
454 "Return file name FILENAME sans its directory.\n\
455 For example, in a Unix-syntax file name,\n\
456 this is everything after the last slash,\n\
457 or the entire name if it contains no slash.")
459 Lisp_Object filename
;
461 register unsigned char *beg
, *p
, *end
;
464 CHECK_STRING (filename
, 0);
466 /* If the file name has special constructs in it,
467 call the corresponding file handler. */
468 handler
= Ffind_file_name_handler (filename
, Qfile_name_nondirectory
);
470 return call2 (handler
, Qfile_name_nondirectory
, filename
);
472 beg
= XSTRING (filename
)->data
;
473 end
= p
= beg
+ STRING_BYTES (XSTRING (filename
));
475 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
477 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
480 /* only recognise drive specifier at beginning */
482 /* handle the "/:d:foo" case correctly */
483 && (p
== beg
+ 2 || (p
== beg
+ 4 && IS_DIRECTORY_SEP (*beg
))))
488 if (STRING_MULTIBYTE (filename
))
489 return make_string (p
, end
- p
);
490 return make_unibyte_string (p
, end
- p
);
493 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory
,
494 Sunhandled_file_name_directory
, 1, 1, 0,
495 "Return a directly usable directory name somehow associated with FILENAME.\n\
496 A `directly usable' directory name is one that may be used without the\n\
497 intervention of any file handler.\n\
498 If FILENAME is a directly usable file itself, return\n\
499 \(file-name-directory FILENAME).\n\
500 The `call-process' and `start-process' functions use this function to\n\
501 get a current directory to run processes in.")
503 Lisp_Object filename
;
507 /* If the file name has special constructs in it,
508 call the corresponding file handler. */
509 handler
= Ffind_file_name_handler (filename
, Qunhandled_file_name_directory
);
511 return call2 (handler
, Qunhandled_file_name_directory
, filename
);
513 return Ffile_name_directory (filename
);
518 file_name_as_directory (out
, in
)
521 int size
= strlen (in
) - 1;
534 /* Is it already a directory string? */
535 if (in
[size
] == ':' || in
[size
] == ']' || in
[size
] == '>')
537 /* Is it a VMS directory file name? If so, hack VMS syntax. */
538 else if (! index (in
, '/')
539 && ((size
> 3 && ! strcmp (&in
[size
- 3], ".DIR"))
540 || (size
> 3 && ! strcmp (&in
[size
- 3], ".dir"))
541 || (size
> 5 && (! strncmp (&in
[size
- 5], ".DIR", 4)
542 || ! strncmp (&in
[size
- 5], ".dir", 4))
543 && (in
[size
- 1] == '.' || in
[size
- 1] == ';')
544 && in
[size
] == '1')))
546 register char *p
, *dot
;
550 dir:x.dir --> dir:[x]
551 dir:[x]y.dir --> dir:[x.y] */
553 while (p
!= in
&& *p
!= ':' && *p
!= '>' && *p
!= ']') p
--;
556 strncpy (out
, in
, p
- in
);
575 dot
= index (p
, '.');
578 /* blindly remove any extension */
579 size
= strlen (out
) + (dot
- p
);
580 strncat (out
, p
, dot
- p
);
591 /* For Unix syntax, Append a slash if necessary */
592 if (!IS_DIRECTORY_SEP (out
[size
]))
594 out
[size
+ 1] = DIRECTORY_SEP
;
595 out
[size
+ 2] = '\0';
598 CORRECT_DIR_SEPS (out
);
604 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
605 Sfile_name_as_directory
, 1, 1, 0,
606 "Return a string representing file FILENAME interpreted as a directory.\n\
607 This operation exists because a directory is also a file, but its name as\n\
608 a directory is different from its name as a file.\n\
609 The result can be used as the value of `default-directory'\n\
610 or passed as second argument to `expand-file-name'.\n\
611 For a Unix-syntax file name, just appends a slash.\n\
612 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
619 CHECK_STRING (file
, 0);
623 /* If the file name has special constructs in it,
624 call the corresponding file handler. */
625 handler
= Ffind_file_name_handler (file
, Qfile_name_as_directory
);
627 return call2 (handler
, Qfile_name_as_directory
, file
);
629 buf
= (char *) alloca (STRING_BYTES (XSTRING (file
)) + 10);
630 return build_string (file_name_as_directory (buf
, XSTRING (file
)->data
));
634 * Convert from directory name to filename.
636 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
637 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
638 * On UNIX, it's simple: just make sure there isn't a terminating /
640 * Value is nonzero if the string output is different from the input.
644 directory_file_name (src
, dst
)
652 struct FAB fab
= cc$rms_fab
;
653 struct NAM nam
= cc$rms_nam
;
654 char esa
[NAM$C_MAXRSS
];
659 if (! index (src
, '/')
660 && (src
[slen
- 1] == ']'
661 || src
[slen
- 1] == ':'
662 || src
[slen
- 1] == '>'))
664 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
666 fab
.fab$b_fns
= slen
;
667 fab
.fab$l_nam
= &nam
;
668 fab
.fab$l_fop
= FAB$M_NAM
;
671 nam
.nam$b_ess
= sizeof esa
;
672 nam
.nam$b_nop
|= NAM$M_SYNCHK
;
674 /* We call SYS$PARSE to handle such things as [--] for us. */
675 if (SYS$
PARSE (&fab
, 0, 0) == RMS$_NORMAL
)
677 slen
= nam
.nam$b_esl
;
678 if (esa
[slen
- 1] == ';' && esa
[slen
- 2] == '.')
683 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
685 /* what about when we have logical_name:???? */
686 if (src
[slen
- 1] == ':')
687 { /* Xlate logical name and see what we get */
688 ptr
= strcpy (dst
, src
); /* upper case for getenv */
691 if ('a' <= *ptr
&& *ptr
<= 'z')
695 dst
[slen
- 1] = 0; /* remove colon */
696 if (!(src
= egetenv (dst
)))
698 /* should we jump to the beginning of this procedure?
699 Good points: allows us to use logical names that xlate
701 Bad points: can be a problem if we just translated to a device
703 For now, I'll punt and always expect VMS names, and hope for
706 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
707 { /* no recursion here! */
713 { /* not a directory spec */
718 bracket
= src
[slen
- 1];
720 /* If bracket is ']' or '>', bracket - 2 is the corresponding
722 ptr
= index (src
, bracket
- 2);
724 { /* no opening bracket */
728 if (!(rptr
= rindex (src
, '.')))
731 strncpy (dst
, src
, slen
);
735 dst
[slen
++] = bracket
;
740 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
741 then translate the device and recurse. */
742 if (dst
[slen
- 1] == ':'
743 && dst
[slen
- 2] != ':' /* skip decnet nodes */
744 && strcmp (src
+ slen
, "[000000]") == 0)
746 dst
[slen
- 1] = '\0';
747 if ((ptr
= egetenv (dst
))
748 && (rlen
= strlen (ptr
) - 1) > 0
749 && (ptr
[rlen
] == ']' || ptr
[rlen
] == '>')
750 && ptr
[rlen
- 1] == '.')
752 char * buf
= (char *) alloca (strlen (ptr
) + 1);
756 return directory_file_name (buf
, dst
);
761 strcat (dst
, "[000000]");
765 rlen
= strlen (rptr
) - 1;
766 strncat (dst
, rptr
, rlen
);
767 dst
[slen
+ rlen
] = '\0';
768 strcat (dst
, ".DIR.1");
772 /* Process as Unix format: just remove any final slash.
773 But leave "/" unchanged; do not change it to "". */
776 /* Handle // as root for apollo's. */
777 if ((slen
> 2 && dst
[slen
- 1] == '/')
778 || (slen
> 1 && dst
[0] != '/' && dst
[slen
- 1] == '/'))
782 && IS_DIRECTORY_SEP (dst
[slen
- 1])
784 && !IS_ANY_SEP (dst
[slen
- 2])
790 CORRECT_DIR_SEPS (dst
);
795 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
797 "Returns the file name of the directory named DIRECTORY.\n\
798 This is the name of the file that holds the data for the directory DIRECTORY.\n\
799 This operation exists because a directory is also a file, but its name as\n\
800 a directory is different from its name as a file.\n\
801 In Unix-syntax, this function just removes the final slash.\n\
802 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
803 it returns a file name such as \"[X]Y.DIR.1\".")
805 Lisp_Object directory
;
810 CHECK_STRING (directory
, 0);
812 if (NILP (directory
))
815 /* If the file name has special constructs in it,
816 call the corresponding file handler. */
817 handler
= Ffind_file_name_handler (directory
, Qdirectory_file_name
);
819 return call2 (handler
, Qdirectory_file_name
, directory
);
822 /* 20 extra chars is insufficient for VMS, since we might perform a
823 logical name translation. an equivalence string can be up to 255
824 chars long, so grab that much extra space... - sss */
825 buf
= (char *) alloca (STRING_BYTES (XSTRING (directory
)) + 20 + 255);
827 buf
= (char *) alloca (STRING_BYTES (XSTRING (directory
)) + 20);
829 directory_file_name (XSTRING (directory
)->data
, buf
);
830 return build_string (buf
);
833 static char make_temp_name_tbl
[64] =
835 'A','B','C','D','E','F','G','H',
836 'I','J','K','L','M','N','O','P',
837 'Q','R','S','T','U','V','W','X',
838 'Y','Z','a','b','c','d','e','f',
839 'g','h','i','j','k','l','m','n',
840 'o','p','q','r','s','t','u','v',
841 'w','x','y','z','0','1','2','3',
842 '4','5','6','7','8','9','-','_'
845 static unsigned make_temp_name_count
, make_temp_name_count_initialized_p
;
847 /* Value is a temporary file name starting with PREFIX, a string.
849 The Emacs process number forms part of the result, so there is
850 no danger of generating a name being used by another process.
851 In addition, this function makes an attempt to choose a name
852 which has no existing file. To make this work, PREFIX should be
853 an absolute file name.
855 BASE64_P non-zero means add the pid as 3 characters in base64
856 encoding. In this case, 6 characters will be added to PREFIX to
857 form the file name. Otherwise, if Emacs is running on a system
858 with long file names, add the pid as a decimal number.
860 This function signals an error if no unique file name could be
864 make_temp_name (prefix
, base64_p
)
871 unsigned char *p
, *data
;
875 CHECK_STRING (prefix
, 0);
877 /* VAL is created by adding 6 characters to PREFIX. The first
878 three are the PID of this process, in base 64, and the second
879 three are incremented if the file already exists. This ensures
880 262144 unique file names per PID per PREFIX. */
882 pid
= (int) getpid ();
886 pidbuf
[0] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
887 pidbuf
[1] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
888 pidbuf
[2] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
893 #ifdef HAVE_LONG_FILE_NAMES
894 sprintf (pidbuf
, "%d", pid
);
895 pidlen
= strlen (pidbuf
);
897 pidbuf
[0] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
898 pidbuf
[1] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
899 pidbuf
[2] = make_temp_name_tbl
[pid
& 63], pid
>>= 6;
904 len
= XSTRING (prefix
)->size
;
905 val
= make_uninit_string (len
+ 3 + pidlen
);
906 data
= XSTRING (val
)->data
;
907 bcopy(XSTRING (prefix
)->data
, data
, len
);
910 bcopy (pidbuf
, p
, pidlen
);
913 /* Here we try to minimize useless stat'ing when this function is
914 invoked many times successively with the same PREFIX. We achieve
915 this by initializing count to a random value, and incrementing it
918 We don't want make-temp-name to be called while dumping,
919 because then make_temp_name_count_initialized_p would get set
920 and then make_temp_name_count would not be set when Emacs starts. */
922 if (!make_temp_name_count_initialized_p
)
924 make_temp_name_count
= (unsigned) time (NULL
);
925 make_temp_name_count_initialized_p
= 1;
931 unsigned num
= make_temp_name_count
;
933 p
[0] = make_temp_name_tbl
[num
& 63], num
>>= 6;
934 p
[1] = make_temp_name_tbl
[num
& 63], num
>>= 6;
935 p
[2] = make_temp_name_tbl
[num
& 63], num
>>= 6;
937 /* Poor man's congruential RN generator. Replace with
938 ++make_temp_name_count for debugging. */
939 make_temp_name_count
+= 25229;
940 make_temp_name_count
%= 225307;
942 if (stat (data
, &ignored
) < 0)
944 /* We want to return only if errno is ENOENT. */
948 /* The error here is dubious, but there is little else we
949 can do. The alternatives are to return nil, which is
950 as bad as (and in many cases worse than) throwing the
951 error, or to ignore the error, which will likely result
952 in looping through 225307 stat's, which is not only
953 dog-slow, but also useless since it will fallback to
954 the errow below, anyway. */
955 report_file_error ("Cannot create temporary name for prefix",
956 Fcons (prefix
, Qnil
));
961 error ("Cannot create temporary name for prefix `%s'",
962 XSTRING (prefix
)->data
);
967 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
968 "Generate temporary file name (string) starting with PREFIX (a string).\n\
969 The Emacs process number forms part of the result,\n\
970 so there is no danger of generating a name being used by another process.\n\
972 In addition, this function makes an attempt to choose a name\n\
973 which has no existing file. To make this work,\n\
974 PREFIX should be an absolute file name.\n\
976 There is a race condition between calling `make-temp-name' and creating the\n\
977 file which opens all kinds of security holes. For that reason, you should\n\
978 probably use `make-temp-file' instead.")
982 return make_temp_name (prefix
, 0);
987 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
988 "Convert filename NAME to absolute, and canonicalize it.\n\
989 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative\n\
990 (does not start with slash); if DEFAULT-DIRECTORY is nil or missing,\n\
991 the current buffer's value of default-directory is used.\n\
992 File name components that are `.' are removed, and \n\
993 so are file name components followed by `..', along with the `..' itself;\n\
994 note that these simplifications are done without checking the resulting\n\
995 file names in the file system.\n\
996 An initial `~/' expands to your home directory.\n\
997 An initial `~USER/' expands to USER's home directory.\n\
998 See also the function `substitute-in-file-name'.")
999 (name
, default_directory
)
1000 Lisp_Object name
, default_directory
;
1004 register unsigned char *newdir
, *p
, *o
;
1006 unsigned char *target
;
1009 unsigned char * colon
= 0;
1010 unsigned char * close
= 0;
1011 unsigned char * slash
= 0;
1012 unsigned char * brack
= 0;
1013 int lbrack
= 0, rbrack
= 0;
1018 int collapse_newdir
= 1;
1022 Lisp_Object handler
;
1024 CHECK_STRING (name
, 0);
1026 /* If the file name has special constructs in it,
1027 call the corresponding file handler. */
1028 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
1029 if (!NILP (handler
))
1030 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
1032 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
1033 if (NILP (default_directory
))
1034 default_directory
= current_buffer
->directory
;
1035 if (! STRINGP (default_directory
))
1036 default_directory
= build_string ("/");
1038 if (!NILP (default_directory
))
1040 handler
= Ffind_file_name_handler (default_directory
, Qexpand_file_name
);
1041 if (!NILP (handler
))
1042 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
1045 o
= XSTRING (default_directory
)->data
;
1047 /* Make sure DEFAULT_DIRECTORY is properly expanded.
1048 It would be better to do this down below where we actually use
1049 default_directory. Unfortunately, calling Fexpand_file_name recursively
1050 could invoke GC, and the strings might be relocated. This would
1051 be annoying because we have pointers into strings lying around
1052 that would need adjusting, and people would add new pointers to
1053 the code and forget to adjust them, resulting in intermittent bugs.
1054 Putting this call here avoids all that crud.
1056 The EQ test avoids infinite recursion. */
1057 if (! NILP (default_directory
) && !EQ (default_directory
, name
)
1058 /* Save time in some common cases - as long as default_directory
1059 is not relative, it can be canonicalized with name below (if it
1060 is needed at all) without requiring it to be expanded now. */
1062 /* Detect MSDOS file names with drive specifiers. */
1063 && ! (IS_DRIVE (o
[0]) && IS_DEVICE_SEP (o
[1]) && IS_DIRECTORY_SEP (o
[2]))
1065 /* Detect Windows file names in UNC format. */
1066 && ! (IS_DIRECTORY_SEP (o
[0]) && IS_DIRECTORY_SEP (o
[1]))
1068 #else /* not DOS_NT */
1069 /* Detect Unix absolute file names (/... alone is not absolute on
1071 && ! (IS_DIRECTORY_SEP (o
[0]))
1072 #endif /* not DOS_NT */
1075 struct gcpro gcpro1
;
1078 default_directory
= Fexpand_file_name (default_directory
, Qnil
);
1083 /* Filenames on VMS are always upper case. */
1084 name
= Fupcase (name
);
1086 #ifdef FILE_SYSTEM_CASE
1087 name
= FILE_SYSTEM_CASE (name
);
1090 nm
= XSTRING (name
)->data
;
1093 /* We will force directory separators to be either all \ or /, so make
1094 a local copy to modify, even if there ends up being no change. */
1095 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
1097 /* Note if special escape prefix is present, but remove for now. */
1098 if (nm
[0] == '/' && nm
[1] == ':')
1104 /* Find and remove drive specifier if present; this makes nm absolute
1105 even if the rest of the name appears to be relative. Only look for
1106 drive specifier at the beginning. */
1107 if (IS_DRIVE (nm
[0]) && IS_DEVICE_SEP (nm
[1]))
1114 /* If we see "c://somedir", we want to strip the first slash after the
1115 colon when stripping the drive letter. Otherwise, this expands to
1117 if (drive
&& IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1119 #endif /* WINDOWSNT */
1123 /* Discard any previous drive specifier if nm is now in UNC format. */
1124 if (IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1130 /* If nm is absolute, look for /./ or /../ sequences; if none are
1131 found, we can probably return right away. We will avoid allocating
1132 a new string if name is already fully expanded. */
1134 IS_DIRECTORY_SEP (nm
[0])
1136 && drive
&& !is_escaped
1139 && (drive
|| IS_DIRECTORY_SEP (nm
[1])) && !is_escaped
1146 /* If it turns out that the filename we want to return is just a
1147 suffix of FILENAME, we don't need to go through and edit
1148 things; we just need to construct a new string using data
1149 starting at the middle of FILENAME. If we set lose to a
1150 non-zero value, that means we've discovered that we can't do
1157 /* Since we know the name is absolute, we can assume that each
1158 element starts with a "/". */
1160 /* "." and ".." are hairy. */
1161 if (IS_DIRECTORY_SEP (p
[0])
1163 && (IS_DIRECTORY_SEP (p
[2])
1165 || (p
[2] == '.' && (IS_DIRECTORY_SEP (p
[3])
1172 /* if dev:[dir]/, move nm to / */
1173 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1174 nm
= (brack
? brack
+ 1 : colon
+ 1);
1175 lbrack
= rbrack
= 0;
1183 /* VMS pre V4.4,convert '-'s in filenames. */
1184 if (lbrack
== rbrack
)
1186 if (dots
< 2) /* this is to allow negative version numbers */
1191 if (lbrack
> rbrack
&&
1192 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1193 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1199 /* count open brackets, reset close bracket pointer */
1200 if (p
[0] == '[' || p
[0] == '<')
1201 lbrack
++, brack
= 0;
1202 /* count close brackets, set close bracket pointer */
1203 if (p
[0] == ']' || p
[0] == '>')
1204 rbrack
++, brack
= p
;
1205 /* detect ][ or >< */
1206 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1208 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1209 nm
= p
+ 1, lose
= 1;
1210 if (p
[0] == ':' && (colon
|| slash
))
1211 /* if dev1:[dir]dev2:, move nm to dev2: */
1217 /* if /name/dev:, move nm to dev: */
1220 /* if node::dev:, move colon following dev */
1221 else if (colon
&& colon
[-1] == ':')
1223 /* if dev1:dev2:, move nm to dev2: */
1224 else if (colon
&& colon
[-1] != ':')
1229 if (p
[0] == ':' && !colon
)
1235 if (lbrack
== rbrack
)
1238 else if (p
[0] == '.')
1246 if (index (nm
, '/'))
1247 return build_string (sys_translate_unix (nm
));
1250 /* Make sure directories are all separated with / or \ as
1251 desired, but avoid allocation of a new string when not
1253 CORRECT_DIR_SEPS (nm
);
1255 if (IS_DIRECTORY_SEP (nm
[1]))
1257 if (strcmp (nm
, XSTRING (name
)->data
) != 0)
1258 name
= build_string (nm
);
1262 /* drive must be set, so this is okay */
1263 if (strcmp (nm
- 2, XSTRING (name
)->data
) != 0)
1265 name
= make_string (nm
- 2, p
- nm
+ 2);
1266 XSTRING (name
)->data
[0] = DRIVE_LETTER (drive
);
1267 XSTRING (name
)->data
[1] = ':';
1270 #else /* not DOS_NT */
1271 if (nm
== XSTRING (name
)->data
)
1273 return build_string (nm
);
1274 #endif /* not DOS_NT */
1278 /* At this point, nm might or might not be an absolute file name. We
1279 need to expand ~ or ~user if present, otherwise prefix nm with
1280 default_directory if nm is not absolute, and finally collapse /./
1281 and /foo/../ sequences.
1283 We set newdir to be the appropriate prefix if one is needed:
1284 - the relevant user directory if nm starts with ~ or ~user
1285 - the specified drive's working dir (DOS/NT only) if nm does not
1287 - the value of default_directory.
1289 Note that these prefixes are not guaranteed to be absolute (except
1290 for the working dir of a drive). Therefore, to ensure we always
1291 return an absolute name, if the final prefix is not absolute we
1292 append it to the current working directory. */
1296 if (nm
[0] == '~') /* prefix ~ */
1298 if (IS_DIRECTORY_SEP (nm
[1])
1302 || nm
[1] == 0) /* ~ by itself */
1304 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1305 newdir
= (unsigned char *) "";
1308 collapse_newdir
= 0;
1311 nm
++; /* Don't leave the slash in nm. */
1314 else /* ~user/filename */
1316 for (p
= nm
; *p
&& (!IS_DIRECTORY_SEP (*p
)
1321 o
= (unsigned char *) alloca (p
- nm
+ 1);
1322 bcopy ((char *) nm
, o
, p
- nm
);
1325 pw
= (struct passwd
*) getpwnam (o
+ 1);
1328 newdir
= (unsigned char *) pw
-> pw_dir
;
1330 nm
= p
+ 1; /* skip the terminator */
1334 collapse_newdir
= 0;
1339 /* If we don't find a user of that name, leave the name
1340 unchanged; don't move nm forward to p. */
1345 /* On DOS and Windows, nm is absolute if a drive name was specified;
1346 use the drive's current directory as the prefix if needed. */
1347 if (!newdir
&& drive
)
1349 /* Get default directory if needed to make nm absolute. */
1350 if (!IS_DIRECTORY_SEP (nm
[0]))
1352 newdir
= alloca (MAXPATHLEN
+ 1);
1353 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1358 /* Either nm starts with /, or drive isn't mounted. */
1359 newdir
= alloca (4);
1360 newdir
[0] = DRIVE_LETTER (drive
);
1368 /* Finally, if no prefix has been specified and nm is not absolute,
1369 then it must be expanded relative to default_directory. */
1373 /* /... alone is not absolute on DOS and Windows. */
1374 && !IS_DIRECTORY_SEP (nm
[0])
1377 && !(IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1384 newdir
= XSTRING (default_directory
)->data
;
1386 /* Note if special escape prefix is present, but remove for now. */
1387 if (newdir
[0] == '/' && newdir
[1] == ':')
1398 /* First ensure newdir is an absolute name. */
1400 /* Detect MSDOS file names with drive specifiers. */
1401 ! (IS_DRIVE (newdir
[0])
1402 && IS_DEVICE_SEP (newdir
[1]) && IS_DIRECTORY_SEP (newdir
[2]))
1404 /* Detect Windows file names in UNC format. */
1405 && ! (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1409 /* Effectively, let newdir be (expand-file-name newdir cwd).
1410 Because of the admonition against calling expand-file-name
1411 when we have pointers into lisp strings, we accomplish this
1412 indirectly by prepending newdir to nm if necessary, and using
1413 cwd (or the wd of newdir's drive) as the new newdir. */
1415 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1420 if (!IS_DIRECTORY_SEP (nm
[0]))
1422 char * tmp
= alloca (strlen (newdir
) + strlen (nm
) + 2);
1423 file_name_as_directory (tmp
, newdir
);
1427 newdir
= alloca (MAXPATHLEN
+ 1);
1430 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1437 /* Strip off drive name from prefix, if present. */
1438 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1444 /* Keep only a prefix from newdir if nm starts with slash
1445 (//server/share for UNC, nothing otherwise). */
1446 if (IS_DIRECTORY_SEP (nm
[0]) && collapse_newdir
)
1449 if (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1451 newdir
= strcpy (alloca (strlen (newdir
) + 1), newdir
);
1453 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1455 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1467 /* Get rid of any slash at the end of newdir, unless newdir is
1468 just / or // (an incomplete UNC name). */
1469 length
= strlen (newdir
);
1470 if (length
> 1 && IS_DIRECTORY_SEP (newdir
[length
- 1])
1472 && !(length
== 2 && IS_DIRECTORY_SEP (newdir
[0]))
1476 unsigned char *temp
= (unsigned char *) alloca (length
);
1477 bcopy (newdir
, temp
, length
- 1);
1478 temp
[length
- 1] = 0;
1486 /* Now concatenate the directory and name to new space in the stack frame */
1487 tlen
+= strlen (nm
) + 1;
1489 /* Reserve space for drive specifier and escape prefix, since either
1490 or both may need to be inserted. (The Microsoft x86 compiler
1491 produces incorrect code if the following two lines are combined.) */
1492 target
= (unsigned char *) alloca (tlen
+ 4);
1494 #else /* not DOS_NT */
1495 target
= (unsigned char *) alloca (tlen
);
1496 #endif /* not DOS_NT */
1502 if (nm
[0] == 0 || IS_DIRECTORY_SEP (nm
[0]))
1505 /* If newdir is effectively "C:/", then the drive letter will have
1506 been stripped and newdir will be "/". Concatenating with an
1507 absolute directory in nm produces "//", which will then be
1508 incorrectly treated as a network share. Ignore newdir in
1509 this case (keeping the drive letter). */
1510 if (!(drive
&& nm
[0] && IS_DIRECTORY_SEP (newdir
[0])
1511 && newdir
[1] == '\0'))
1513 strcpy (target
, newdir
);
1517 file_name_as_directory (target
, newdir
);
1520 strcat (target
, nm
);
1522 if (index (target
, '/'))
1523 strcpy (target
, sys_translate_unix (target
));
1526 /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */
1528 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1536 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1542 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1543 /* brackets are offset from each other by 2 */
1546 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1547 /* convert [foo][bar] to [bar] */
1548 while (o
[-1] != '[' && o
[-1] != '<')
1550 else if (*p
== '-' && *o
!= '.')
1553 else if (p
[0] == '-' && o
[-1] == '.' &&
1554 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1555 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1559 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1560 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1562 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1564 /* else [foo.-] ==> [-] */
1570 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1571 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1577 if (!IS_DIRECTORY_SEP (*p
))
1581 else if (IS_DIRECTORY_SEP (p
[0])
1583 && (IS_DIRECTORY_SEP (p
[2])
1586 /* If "/." is the entire filename, keep the "/". Otherwise,
1587 just delete the whole "/.". */
1588 if (o
== target
&& p
[2] == '\0')
1592 else if (IS_DIRECTORY_SEP (p
[0]) && p
[1] == '.' && p
[2] == '.'
1593 /* `/../' is the "superroot" on certain file systems. */
1595 && (IS_DIRECTORY_SEP (p
[3]) || p
[3] == 0))
1597 while (o
!= target
&& (--o
) && !IS_DIRECTORY_SEP (*o
))
1599 /* Keep initial / only if this is the whole name. */
1600 if (o
== target
&& IS_ANY_SEP (*o
) && p
[3] == 0)
1608 #endif /* not VMS */
1612 /* At last, set drive name. */
1614 /* Except for network file name. */
1615 if (!(IS_DIRECTORY_SEP (target
[0]) && IS_DIRECTORY_SEP (target
[1])))
1616 #endif /* WINDOWSNT */
1618 if (!drive
) abort ();
1620 target
[0] = DRIVE_LETTER (drive
);
1623 /* Reinsert the escape prefix if required. */
1630 CORRECT_DIR_SEPS (target
);
1633 return make_string (target
, o
- target
);
1637 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'. */
1638 DEAFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
1639 "Convert FILENAME to absolute, and canonicalize it.\n\
1640 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1641 (does not start with slash); if DEFAULT is nil or missing,\n\
1642 the current buffer's value of default-directory is used.\n\
1643 Filenames containing `.' or `..' as components are simplified;\n\
1644 initial `~/' expands to your home directory.\n\
1645 See also the function `substitute-in-file-name'.")
1647 Lisp_Object name
, defalt
;
1651 register unsigned char *newdir
, *p
, *o
;
1653 unsigned char *target
;
1657 unsigned char * colon
= 0;
1658 unsigned char * close
= 0;
1659 unsigned char * slash
= 0;
1660 unsigned char * brack
= 0;
1661 int lbrack
= 0, rbrack
= 0;
1665 CHECK_STRING (name
, 0);
1668 /* Filenames on VMS are always upper case. */
1669 name
= Fupcase (name
);
1672 nm
= XSTRING (name
)->data
;
1674 /* If nm is absolute, flush ...// and detect /./ and /../.
1675 If no /./ or /../ we can return right away. */
1687 if (p
[0] == '/' && p
[1] == '/'
1689 /* // at start of filename is meaningful on Apollo system. */
1694 if (p
[0] == '/' && p
[1] == '~')
1695 nm
= p
+ 1, lose
= 1;
1696 if (p
[0] == '/' && p
[1] == '.'
1697 && (p
[2] == '/' || p
[2] == 0
1698 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1704 /* if dev:[dir]/, move nm to / */
1705 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1706 nm
= (brack
? brack
+ 1 : colon
+ 1);
1707 lbrack
= rbrack
= 0;
1715 /* VMS pre V4.4,convert '-'s in filenames. */
1716 if (lbrack
== rbrack
)
1718 if (dots
< 2) /* this is to allow negative version numbers */
1723 if (lbrack
> rbrack
&&
1724 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1725 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1731 /* count open brackets, reset close bracket pointer */
1732 if (p
[0] == '[' || p
[0] == '<')
1733 lbrack
++, brack
= 0;
1734 /* count close brackets, set close bracket pointer */
1735 if (p
[0] == ']' || p
[0] == '>')
1736 rbrack
++, brack
= p
;
1737 /* detect ][ or >< */
1738 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1740 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1741 nm
= p
+ 1, lose
= 1;
1742 if (p
[0] == ':' && (colon
|| slash
))
1743 /* if dev1:[dir]dev2:, move nm to dev2: */
1749 /* If /name/dev:, move nm to dev: */
1752 /* If node::dev:, move colon following dev */
1753 else if (colon
&& colon
[-1] == ':')
1755 /* If dev1:dev2:, move nm to dev2: */
1756 else if (colon
&& colon
[-1] != ':')
1761 if (p
[0] == ':' && !colon
)
1767 if (lbrack
== rbrack
)
1770 else if (p
[0] == '.')
1778 if (index (nm
, '/'))
1779 return build_string (sys_translate_unix (nm
));
1781 if (nm
== XSTRING (name
)->data
)
1783 return build_string (nm
);
1787 /* Now determine directory to start with and put it in NEWDIR */
1791 if (nm
[0] == '~') /* prefix ~ */
1796 || nm
[1] == 0)/* ~/filename */
1798 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1799 newdir
= (unsigned char *) "";
1802 nm
++; /* Don't leave the slash in nm. */
1805 else /* ~user/filename */
1807 /* Get past ~ to user */
1808 unsigned char *user
= nm
+ 1;
1809 /* Find end of name. */
1810 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1811 int len
= ptr
? ptr
- user
: strlen (user
);
1813 unsigned char *ptr1
= index (user
, ':');
1814 if (ptr1
!= 0 && ptr1
- user
< len
)
1817 /* Copy the user name into temp storage. */
1818 o
= (unsigned char *) alloca (len
+ 1);
1819 bcopy ((char *) user
, o
, len
);
1822 /* Look up the user name. */
1823 pw
= (struct passwd
*) getpwnam (o
+ 1);
1825 error ("\"%s\" isn't a registered user", o
+ 1);
1827 newdir
= (unsigned char *) pw
->pw_dir
;
1829 /* Discard the user name from NM. */
1836 #endif /* not VMS */
1840 defalt
= current_buffer
->directory
;
1841 CHECK_STRING (defalt
, 1);
1842 newdir
= XSTRING (defalt
)->data
;
1845 /* Now concatenate the directory and name to new space in the stack frame */
1847 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1848 target
= (unsigned char *) alloca (tlen
);
1854 if (nm
[0] == 0 || nm
[0] == '/')
1855 strcpy (target
, newdir
);
1858 file_name_as_directory (target
, newdir
);
1861 strcat (target
, nm
);
1863 if (index (target
, '/'))
1864 strcpy (target
, sys_translate_unix (target
));
1867 /* Now canonicalize by removing /. and /foo/.. if they appear */
1875 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1881 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1882 /* brackets are offset from each other by 2 */
1885 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1886 /* convert [foo][bar] to [bar] */
1887 while (o
[-1] != '[' && o
[-1] != '<')
1889 else if (*p
== '-' && *o
!= '.')
1892 else if (p
[0] == '-' && o
[-1] == '.' &&
1893 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1894 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1898 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1899 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1901 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1903 /* else [foo.-] ==> [-] */
1909 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1910 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1920 else if (!strncmp (p
, "//", 2)
1922 /* // at start of filename is meaningful in Apollo system. */
1930 else if (p
[0] == '/' && p
[1] == '.' &&
1931 (p
[2] == '/' || p
[2] == 0))
1933 else if (!strncmp (p
, "/..", 3)
1934 /* `/../' is the "superroot" on certain file systems. */
1936 && (p
[3] == '/' || p
[3] == 0))
1938 while (o
!= target
&& *--o
!= '/')
1941 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1945 if (o
== target
&& *o
== '/')
1953 #endif /* not VMS */
1956 return make_string (target
, o
- target
);
1960 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1961 Ssubstitute_in_file_name
, 1, 1, 0,
1962 "Substitute environment variables referred to in FILENAME.\n\
1963 `$FOO' where FOO is an environment variable name means to substitute\n\
1964 the value of that variable. The variable name should be terminated\n\
1965 with a character not a letter, digit or underscore; otherwise, enclose\n\
1966 the entire variable name in braces.\n\
1967 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1968 On VMS, `$' substitution is not done; this function does little and only\n\
1969 duplicates what `expand-file-name' does.")
1971 Lisp_Object filename
;
1975 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1976 unsigned char *target
= NULL
;
1978 int substituted
= 0;
1980 Lisp_Object handler
;
1982 CHECK_STRING (filename
, 0);
1984 /* If the file name has special constructs in it,
1985 call the corresponding file handler. */
1986 handler
= Ffind_file_name_handler (filename
, Qsubstitute_in_file_name
);
1987 if (!NILP (handler
))
1988 return call2 (handler
, Qsubstitute_in_file_name
, filename
);
1990 nm
= XSTRING (filename
)->data
;
1992 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
1993 CORRECT_DIR_SEPS (nm
);
1994 substituted
= (strcmp (nm
, XSTRING (filename
)->data
) != 0);
1996 endp
= nm
+ STRING_BYTES (XSTRING (filename
));
1998 /* If /~ or // appears, discard everything through first slash. */
2000 for (p
= nm
; p
!= endp
; p
++)
2003 #if defined (APOLLO) || defined (WINDOWSNT)
2004 /* // at start of file name is meaningful in Apollo and
2005 WindowsNT systems. */
2006 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != nm
)
2007 #else /* not (APOLLO || WINDOWSNT) */
2008 || IS_DIRECTORY_SEP (p
[0])
2009 #endif /* not (APOLLO || WINDOWSNT) */
2014 || p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>'
2016 || IS_DIRECTORY_SEP (p
[-1])))
2022 /* see comment in expand-file-name about drive specifiers */
2023 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
2024 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
2033 return build_string (nm
);
2036 /* See if any variables are substituted into the string
2037 and find the total length of their values in `total' */
2039 for (p
= nm
; p
!= endp
;)
2049 /* "$$" means a single "$" */
2058 while (p
!= endp
&& *p
!= '}') p
++;
2059 if (*p
!= '}') goto missingclose
;
2065 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
2069 /* Copy out the variable name */
2070 target
= (unsigned char *) alloca (s
- o
+ 1);
2071 strncpy (target
, o
, s
- o
);
2074 strupr (target
); /* $home == $HOME etc. */
2077 /* Get variable value */
2078 o
= (unsigned char *) egetenv (target
);
2079 if (!o
) goto badvar
;
2080 total
+= strlen (o
);
2087 /* If substitution required, recopy the string and do it */
2088 /* Make space in stack frame for the new copy */
2089 xnm
= (unsigned char *) alloca (STRING_BYTES (XSTRING (filename
)) + total
+ 1);
2092 /* Copy the rest of the name through, replacing $ constructs with values */
2109 while (p
!= endp
&& *p
!= '}') p
++;
2110 if (*p
!= '}') goto missingclose
;
2116 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
2120 /* Copy out the variable name */
2121 target
= (unsigned char *) alloca (s
- o
+ 1);
2122 strncpy (target
, o
, s
- o
);
2125 strupr (target
); /* $home == $HOME etc. */
2128 /* Get variable value */
2129 o
= (unsigned char *) egetenv (target
);
2133 if (STRING_MULTIBYTE (filename
))
2135 /* If the original string is multibyte,
2136 convert what we substitute into multibyte. */
2139 int c
= unibyte_char_to_multibyte (*o
++);
2140 x
+= CHAR_STRING (c
, x
);
2152 /* If /~ or // appears, discard everything through first slash. */
2154 for (p
= xnm
; p
!= x
; p
++)
2156 #if defined (APOLLO) || defined (WINDOWSNT)
2157 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != xnm
)
2158 #else /* not (APOLLO || WINDOWSNT) */
2159 || IS_DIRECTORY_SEP (p
[0])
2160 #endif /* not (APOLLO || WINDOWSNT) */
2162 && p
!= xnm
&& IS_DIRECTORY_SEP (p
[-1]))
2165 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
2166 && p
> xnm
&& IS_DIRECTORY_SEP (p
[-1]))
2170 if (STRING_MULTIBYTE (filename
))
2171 return make_string (xnm
, x
- xnm
);
2172 return make_unibyte_string (xnm
, x
- xnm
);
2175 error ("Bad format environment-variable substitution");
2177 error ("Missing \"}\" in environment-variable substitution");
2179 error ("Substituting nonexistent environment variable \"%s\"", target
);
2182 #endif /* not VMS */
2186 /* A slightly faster and more convenient way to get
2187 (directory-file-name (expand-file-name FOO)). */
2190 expand_and_dir_to_file (filename
, defdir
)
2191 Lisp_Object filename
, defdir
;
2193 register Lisp_Object absname
;
2195 absname
= Fexpand_file_name (filename
, defdir
);
2198 register int c
= XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
)) - 1];
2199 if (c
== ':' || c
== ']' || c
== '>')
2200 absname
= Fdirectory_file_name (absname
);
2203 /* Remove final slash, if any (unless this is the root dir).
2204 stat behaves differently depending! */
2205 if (XSTRING (absname
)->size
> 1
2206 && IS_DIRECTORY_SEP (XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
)) - 1])
2207 && !IS_DEVICE_SEP (XSTRING (absname
)->data
[STRING_BYTES (XSTRING (absname
))-2]))
2208 /* We cannot take shortcuts; they might be wrong for magic file names. */
2209 absname
= Fdirectory_file_name (absname
);
2214 /* Signal an error if the file ABSNAME already exists.
2215 If INTERACTIVE is nonzero, ask the user whether to proceed,
2216 and bypass the error if the user says to go ahead.
2217 QUERYSTRING is a name for the action that is being considered
2220 *STATPTR is used to store the stat information if the file exists.
2221 If the file does not exist, STATPTR->st_mode is set to 0.
2222 If STATPTR is null, we don't store into it.
2224 If QUICK is nonzero, we ask for y or n, not yes or no. */
2227 barf_or_query_if_file_exists (absname
, querystring
, interactive
, statptr
, quick
)
2228 Lisp_Object absname
;
2229 unsigned char *querystring
;
2231 struct stat
*statptr
;
2234 register Lisp_Object tem
, encoded_filename
;
2235 struct stat statbuf
;
2236 struct gcpro gcpro1
;
2238 encoded_filename
= ENCODE_FILE (absname
);
2240 /* stat is a good way to tell whether the file exists,
2241 regardless of what access permissions it has. */
2242 if (stat (XSTRING (encoded_filename
)->data
, &statbuf
) >= 0)
2245 Fsignal (Qfile_already_exists
,
2246 Fcons (build_string ("File already exists"),
2247 Fcons (absname
, Qnil
)));
2249 tem
= format1 ("File %s already exists; %s anyway? ",
2250 XSTRING (absname
)->data
, querystring
);
2252 tem
= Fy_or_n_p (tem
);
2254 tem
= do_yes_or_no_p (tem
);
2257 Fsignal (Qfile_already_exists
,
2258 Fcons (build_string ("File already exists"),
2259 Fcons (absname
, Qnil
)));
2266 statptr
->st_mode
= 0;
2271 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
2272 "fCopy file: \nFCopy %s to file: \np\nP",
2273 "Copy FILE to NEWNAME. Both args must be strings.\n\
2274 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
2275 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
2276 A number as third arg means request confirmation if NEWNAME already exists.\n\
2277 This is what happens in interactive use with M-x.\n\
2278 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
2279 last-modified time as the old one. (This works on only some systems.)\n\
2280 A prefix arg makes KEEP-TIME non-nil.")
2281 (file
, newname
, ok_if_already_exists
, keep_date
)
2282 Lisp_Object file
, newname
, ok_if_already_exists
, keep_date
;
2285 char buf
[16 * 1024];
2286 struct stat st
, out_st
;
2287 Lisp_Object handler
;
2288 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2289 int count
= specpdl_ptr
- specpdl
;
2290 int input_file_statable_p
;
2291 Lisp_Object encoded_file
, encoded_newname
;
2293 encoded_file
= encoded_newname
= Qnil
;
2294 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2295 CHECK_STRING (file
, 0);
2296 CHECK_STRING (newname
, 1);
2298 file
= Fexpand_file_name (file
, Qnil
);
2299 newname
= Fexpand_file_name (newname
, Qnil
);
2301 /* If the input file name has special constructs in it,
2302 call the corresponding file handler. */
2303 handler
= Ffind_file_name_handler (file
, Qcopy_file
);
2304 /* Likewise for output file name. */
2306 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
2307 if (!NILP (handler
))
2308 RETURN_UNGCPRO (call5 (handler
, Qcopy_file
, file
, newname
,
2309 ok_if_already_exists
, keep_date
));
2311 encoded_file
= ENCODE_FILE (file
);
2312 encoded_newname
= ENCODE_FILE (newname
);
2314 if (NILP (ok_if_already_exists
)
2315 || INTEGERP (ok_if_already_exists
))
2316 barf_or_query_if_file_exists (encoded_newname
, "copy to it",
2317 INTEGERP (ok_if_already_exists
), &out_st
, 0);
2318 else if (stat (XSTRING (encoded_newname
)->data
, &out_st
) < 0)
2321 ifd
= emacs_open (XSTRING (encoded_file
)->data
, O_RDONLY
, 0);
2323 report_file_error ("Opening input file", Fcons (file
, Qnil
));
2325 record_unwind_protect (close_file_unwind
, make_number (ifd
));
2327 /* We can only copy regular files and symbolic links. Other files are not
2329 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
2331 #if !defined (DOS_NT) || __DJGPP__ > 1
2332 if (out_st
.st_mode
!= 0
2333 && st
.st_dev
== out_st
.st_dev
&& st
.st_ino
== out_st
.st_ino
)
2336 report_file_error ("Input and output files are the same",
2337 Fcons (file
, Fcons (newname
, Qnil
)));
2341 #if defined (S_ISREG) && defined (S_ISLNK)
2342 if (input_file_statable_p
)
2344 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
2346 #if defined (EISDIR)
2347 /* Get a better looking error message. */
2350 report_file_error ("Non-regular file", Fcons (file
, Qnil
));
2353 #endif /* S_ISREG && S_ISLNK */
2356 /* Create the copy file with the same record format as the input file */
2357 ofd
= sys_creat (XSTRING (encoded_newname
)->data
, 0666, ifd
);
2360 /* System's default file type was set to binary by _fmode in emacs.c. */
2361 ofd
= creat (XSTRING (encoded_newname
)->data
, S_IREAD
| S_IWRITE
);
2362 #else /* not MSDOS */
2363 ofd
= creat (XSTRING (encoded_newname
)->data
, 0666);
2364 #endif /* not MSDOS */
2367 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
2369 record_unwind_protect (close_file_unwind
, make_number (ofd
));
2373 while ((n
= emacs_read (ifd
, buf
, sizeof buf
)) > 0)
2374 if (emacs_write (ofd
, buf
, n
) != n
)
2375 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2378 /* Closing the output clobbers the file times on some systems. */
2379 if (emacs_close (ofd
) < 0)
2380 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2382 if (input_file_statable_p
)
2384 if (!NILP (keep_date
))
2386 EMACS_TIME atime
, mtime
;
2387 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
2388 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
2389 if (set_file_times (XSTRING (encoded_newname
)->data
,
2391 Fsignal (Qfile_date_error
,
2392 Fcons (build_string ("Cannot set file date"),
2393 Fcons (newname
, Qnil
)));
2396 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2398 #if defined (__DJGPP__) && __DJGPP__ > 1
2399 /* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
2400 and if it can't, it tells so. Otherwise, under MSDOS we usually
2401 get only the READ bit, which will make the copied file read-only,
2402 so it's better not to chmod at all. */
2403 if ((_djstat_flags
& _STFAIL_WRITEBIT
) == 0)
2404 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2405 #endif /* DJGPP version 2 or newer */
2411 /* Discard the unwind protects. */
2412 specpdl_ptr
= specpdl
+ count
;
2418 DEFUN ("make-directory-internal", Fmake_directory_internal
,
2419 Smake_directory_internal
, 1, 1, 0,
2420 "Create a new directory named DIRECTORY.")
2422 Lisp_Object directory
;
2425 Lisp_Object handler
;
2426 Lisp_Object encoded_dir
;
2428 CHECK_STRING (directory
, 0);
2429 directory
= Fexpand_file_name (directory
, Qnil
);
2431 handler
= Ffind_file_name_handler (directory
, Qmake_directory_internal
);
2432 if (!NILP (handler
))
2433 return call2 (handler
, Qmake_directory_internal
, directory
);
2435 encoded_dir
= ENCODE_FILE (directory
);
2437 dir
= XSTRING (encoded_dir
)->data
;
2440 if (mkdir (dir
) != 0)
2442 if (mkdir (dir
, 0777) != 0)
2444 report_file_error ("Creating directory", Flist (1, &directory
));
2449 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
2450 "Delete the directory named DIRECTORY.")
2452 Lisp_Object directory
;
2455 Lisp_Object handler
;
2456 Lisp_Object encoded_dir
;
2458 CHECK_STRING (directory
, 0);
2459 directory
= Fdirectory_file_name (Fexpand_file_name (directory
, Qnil
));
2461 handler
= Ffind_file_name_handler (directory
, Qdelete_directory
);
2462 if (!NILP (handler
))
2463 return call2 (handler
, Qdelete_directory
, directory
);
2465 encoded_dir
= ENCODE_FILE (directory
);
2467 dir
= XSTRING (encoded_dir
)->data
;
2469 if (rmdir (dir
) != 0)
2470 report_file_error ("Removing directory", Flist (1, &directory
));
2475 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
2476 "Delete file named FILENAME.\n\
2477 If file has multiple names, it continues to exist with the other names.")
2479 Lisp_Object filename
;
2481 Lisp_Object handler
;
2482 Lisp_Object encoded_file
;
2484 CHECK_STRING (filename
, 0);
2485 filename
= Fexpand_file_name (filename
, Qnil
);
2487 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
2488 if (!NILP (handler
))
2489 return call2 (handler
, Qdelete_file
, filename
);
2491 encoded_file
= ENCODE_FILE (filename
);
2493 if (0 > unlink (XSTRING (encoded_file
)->data
))
2494 report_file_error ("Removing old name", Flist (1, &filename
));
2499 internal_delete_file_1 (ignore
)
2505 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */
2508 internal_delete_file (filename
)
2509 Lisp_Object filename
;
2511 return NILP (internal_condition_case_1 (Fdelete_file
, filename
,
2512 Qt
, internal_delete_file_1
));
2515 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
2516 "fRename file: \nFRename %s to file: \np",
2517 "Rename FILE as NEWNAME. Both args strings.\n\
2518 If file has names other than FILE, it continues to have those names.\n\
2519 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2520 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2521 A number as third arg means request confirmation if NEWNAME already exists.\n\
2522 This is what happens in interactive use with M-x.")
2523 (file
, newname
, ok_if_already_exists
)
2524 Lisp_Object file
, newname
, ok_if_already_exists
;
2527 Lisp_Object args
[2];
2529 Lisp_Object handler
;
2530 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2531 Lisp_Object encoded_file
, encoded_newname
;
2533 encoded_file
= encoded_newname
= Qnil
;
2534 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2535 CHECK_STRING (file
, 0);
2536 CHECK_STRING (newname
, 1);
2537 file
= Fexpand_file_name (file
, Qnil
);
2538 newname
= Fexpand_file_name (newname
, Qnil
);
2540 /* If the file name has special constructs in it,
2541 call the corresponding file handler. */
2542 handler
= Ffind_file_name_handler (file
, Qrename_file
);
2544 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
2545 if (!NILP (handler
))
2546 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
2547 file
, newname
, ok_if_already_exists
));
2549 encoded_file
= ENCODE_FILE (file
);
2550 encoded_newname
= ENCODE_FILE (newname
);
2553 /* If the file names are identical but for the case, don't ask for
2554 confirmation: they simply want to change the letter-case of the
2556 if (NILP (Fstring_equal (Fdowncase (file
), Fdowncase (newname
))))
2558 if (NILP (ok_if_already_exists
)
2559 || INTEGERP (ok_if_already_exists
))
2560 barf_or_query_if_file_exists (encoded_newname
, "rename to it",
2561 INTEGERP (ok_if_already_exists
), 0, 0);
2563 if (0 > rename (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2565 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
)
2566 || 0 > unlink (XSTRING (encoded_file
)->data
))
2571 Fcopy_file (file
, newname
,
2572 /* We have already prompted if it was an integer,
2573 so don't have copy-file prompt again. */
2574 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
2575 Fdelete_file (file
);
2582 report_file_error ("Renaming", Flist (2, args
));
2585 report_file_error ("Renaming", Flist (2, &file
));
2592 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
2593 "fAdd name to file: \nFName to add to %s: \np",
2594 "Give FILE additional name NEWNAME. Both args strings.\n\
2595 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2596 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2597 A number as third arg means request confirmation if NEWNAME already exists.\n\
2598 This is what happens in interactive use with M-x.")
2599 (file
, newname
, ok_if_already_exists
)
2600 Lisp_Object file
, newname
, ok_if_already_exists
;
2603 Lisp_Object args
[2];
2605 Lisp_Object handler
;
2606 Lisp_Object encoded_file
, encoded_newname
;
2607 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2609 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2610 encoded_file
= encoded_newname
= Qnil
;
2611 CHECK_STRING (file
, 0);
2612 CHECK_STRING (newname
, 1);
2613 file
= Fexpand_file_name (file
, Qnil
);
2614 newname
= Fexpand_file_name (newname
, Qnil
);
2616 /* If the file name has special constructs in it,
2617 call the corresponding file handler. */
2618 handler
= Ffind_file_name_handler (file
, Qadd_name_to_file
);
2619 if (!NILP (handler
))
2620 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2621 newname
, ok_if_already_exists
));
2623 /* If the new name has special constructs in it,
2624 call the corresponding file handler. */
2625 handler
= Ffind_file_name_handler (newname
, Qadd_name_to_file
);
2626 if (!NILP (handler
))
2627 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2628 newname
, ok_if_already_exists
));
2630 encoded_file
= ENCODE_FILE (file
);
2631 encoded_newname
= ENCODE_FILE (newname
);
2633 if (NILP (ok_if_already_exists
)
2634 || INTEGERP (ok_if_already_exists
))
2635 barf_or_query_if_file_exists (encoded_newname
, "make it a new name",
2636 INTEGERP (ok_if_already_exists
), 0, 0);
2638 unlink (XSTRING (newname
)->data
);
2639 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2644 report_file_error ("Adding new name", Flist (2, args
));
2646 report_file_error ("Adding new name", Flist (2, &file
));
2655 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2656 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2657 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
2658 Signals a `file-already-exists' error if a file LINKNAME already exists\n\
2659 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2660 A number as third arg means request confirmation if LINKNAME already exists.\n\
2661 This happens for interactive use with M-x.")
2662 (filename
, linkname
, ok_if_already_exists
)
2663 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2666 Lisp_Object args
[2];
2668 Lisp_Object handler
;
2669 Lisp_Object encoded_filename
, encoded_linkname
;
2670 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2672 GCPRO4 (filename
, linkname
, encoded_filename
, encoded_linkname
);
2673 encoded_filename
= encoded_linkname
= Qnil
;
2674 CHECK_STRING (filename
, 0);
2675 CHECK_STRING (linkname
, 1);
2676 /* If the link target has a ~, we must expand it to get
2677 a truly valid file name. Otherwise, do not expand;
2678 we want to permit links to relative file names. */
2679 if (XSTRING (filename
)->data
[0] == '~')
2680 filename
= Fexpand_file_name (filename
, Qnil
);
2681 linkname
= Fexpand_file_name (linkname
, Qnil
);
2683 /* If the file name has special constructs in it,
2684 call the corresponding file handler. */
2685 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2686 if (!NILP (handler
))
2687 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2688 linkname
, ok_if_already_exists
));
2690 /* If the new link name has special constructs in it,
2691 call the corresponding file handler. */
2692 handler
= Ffind_file_name_handler (linkname
, Qmake_symbolic_link
);
2693 if (!NILP (handler
))
2694 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2695 linkname
, ok_if_already_exists
));
2697 encoded_filename
= ENCODE_FILE (filename
);
2698 encoded_linkname
= ENCODE_FILE (linkname
);
2700 if (NILP (ok_if_already_exists
)
2701 || INTEGERP (ok_if_already_exists
))
2702 barf_or_query_if_file_exists (encoded_linkname
, "make it a link",
2703 INTEGERP (ok_if_already_exists
), 0, 0);
2704 if (0 > symlink (XSTRING (encoded_filename
)->data
,
2705 XSTRING (encoded_linkname
)->data
))
2707 /* If we didn't complain already, silently delete existing file. */
2708 if (errno
== EEXIST
)
2710 unlink (XSTRING (encoded_linkname
)->data
);
2711 if (0 <= symlink (XSTRING (encoded_filename
)->data
,
2712 XSTRING (encoded_linkname
)->data
))
2722 report_file_error ("Making symbolic link", Flist (2, args
));
2724 report_file_error ("Making symbolic link", Flist (2, &filename
));
2730 #endif /* S_IFLNK */
2734 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2735 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2736 "Define the job-wide logical name NAME to have the value STRING.\n\
2737 If STRING is nil or a null string, the logical name NAME is deleted.")
2742 CHECK_STRING (name
, 0);
2744 delete_logical_name (XSTRING (name
)->data
);
2747 CHECK_STRING (string
, 1);
2749 if (XSTRING (string
)->size
== 0)
2750 delete_logical_name (XSTRING (name
)->data
);
2752 define_logical_name (XSTRING (name
)->data
, XSTRING (string
)->data
);
2761 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2762 "Open a network connection to PATH using LOGIN as the login string.")
2764 Lisp_Object path
, login
;
2768 CHECK_STRING (path
, 0);
2769 CHECK_STRING (login
, 0);
2771 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2773 if (netresult
== -1)
2778 #endif /* HPUX_NET */
2780 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2782 "Return t if file FILENAME specifies an absolute file name.\n\
2783 On Unix, this is a name starting with a `/' or a `~'.")
2785 Lisp_Object filename
;
2789 CHECK_STRING (filename
, 0);
2790 ptr
= XSTRING (filename
)->data
;
2791 if (IS_DIRECTORY_SEP (*ptr
) || *ptr
== '~'
2793 /* ??? This criterion is probably wrong for '<'. */
2794 || index (ptr
, ':') || index (ptr
, '<')
2795 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2799 || (IS_DRIVE (*ptr
) && ptr
[1] == ':' && IS_DIRECTORY_SEP (ptr
[2]))
2807 /* Return nonzero if file FILENAME exists and can be executed. */
2810 check_executable (filename
)
2814 int len
= strlen (filename
);
2817 if (stat (filename
, &st
) < 0)
2819 #if defined (WINDOWSNT) || (defined (MSDOS) && __DJGPP__ > 1)
2820 return ((st
.st_mode
& S_IEXEC
) != 0);
2822 return (S_ISREG (st
.st_mode
)
2824 && (stricmp ((suffix
= filename
+ len
-4), ".com") == 0
2825 || stricmp (suffix
, ".exe") == 0
2826 || stricmp (suffix
, ".bat") == 0)
2827 || (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2828 #endif /* not WINDOWSNT */
2829 #else /* not DOS_NT */
2830 #ifdef HAVE_EUIDACCESS
2831 return (euidaccess (filename
, 1) >= 0);
2833 /* Access isn't quite right because it uses the real uid
2834 and we really want to test with the effective uid.
2835 But Unix doesn't give us a right way to do it. */
2836 return (access (filename
, 1) >= 0);
2838 #endif /* not DOS_NT */
2841 /* Return nonzero if file FILENAME exists and can be written. */
2844 check_writable (filename
)
2849 if (stat (filename
, &st
) < 0)
2851 return (st
.st_mode
& S_IWRITE
|| (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2852 #else /* not MSDOS */
2853 #ifdef HAVE_EUIDACCESS
2854 return (euidaccess (filename
, 2) >= 0);
2856 /* Access isn't quite right because it uses the real uid
2857 and we really want to test with the effective uid.
2858 But Unix doesn't give us a right way to do it.
2859 Opening with O_WRONLY could work for an ordinary file,
2860 but would lose for directories. */
2861 return (access (filename
, 2) >= 0);
2863 #endif /* not MSDOS */
2866 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2867 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
2868 See also `file-readable-p' and `file-attributes'.")
2870 Lisp_Object filename
;
2872 Lisp_Object absname
;
2873 Lisp_Object handler
;
2874 struct stat statbuf
;
2876 CHECK_STRING (filename
, 0);
2877 absname
= Fexpand_file_name (filename
, Qnil
);
2879 /* If the file name has special constructs in it,
2880 call the corresponding file handler. */
2881 handler
= Ffind_file_name_handler (absname
, Qfile_exists_p
);
2882 if (!NILP (handler
))
2883 return call2 (handler
, Qfile_exists_p
, absname
);
2885 absname
= ENCODE_FILE (absname
);
2887 return (stat (XSTRING (absname
)->data
, &statbuf
) >= 0) ? Qt
: Qnil
;
2890 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2891 "Return t if FILENAME can be executed by you.\n\
2892 For a directory, this means you can access files in that directory.")
2894 Lisp_Object filename
;
2897 Lisp_Object absname
;
2898 Lisp_Object handler
;
2900 CHECK_STRING (filename
, 0);
2901 absname
= Fexpand_file_name (filename
, Qnil
);
2903 /* If the file name has special constructs in it,
2904 call the corresponding file handler. */
2905 handler
= Ffind_file_name_handler (absname
, Qfile_executable_p
);
2906 if (!NILP (handler
))
2907 return call2 (handler
, Qfile_executable_p
, absname
);
2909 absname
= ENCODE_FILE (absname
);
2911 return (check_executable (XSTRING (absname
)->data
) ? Qt
: Qnil
);
2914 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2915 "Return t if file FILENAME exists and you can read it.\n\
2916 See also `file-exists-p' and `file-attributes'.")
2918 Lisp_Object filename
;
2920 Lisp_Object absname
;
2921 Lisp_Object handler
;
2924 struct stat statbuf
;
2926 CHECK_STRING (filename
, 0);
2927 absname
= Fexpand_file_name (filename
, Qnil
);
2929 /* If the file name has special constructs in it,
2930 call the corresponding file handler. */
2931 handler
= Ffind_file_name_handler (absname
, Qfile_readable_p
);
2932 if (!NILP (handler
))
2933 return call2 (handler
, Qfile_readable_p
, absname
);
2935 absname
= ENCODE_FILE (absname
);
2938 /* Under MS-DOS and Windows, open does not work for directories. */
2939 if (access (XSTRING (absname
)->data
, 0) == 0)
2942 #else /* not DOS_NT */
2944 #if defined (S_ISFIFO) && defined (O_NONBLOCK)
2945 /* Opening a fifo without O_NONBLOCK can wait.
2946 We don't want to wait. But we don't want to mess wth O_NONBLOCK
2947 except in the case of a fifo, on a system which handles it. */
2948 desc
= stat (XSTRING (absname
)->data
, &statbuf
);
2951 if (S_ISFIFO (statbuf
.st_mode
))
2952 flags
|= O_NONBLOCK
;
2954 desc
= emacs_open (XSTRING (absname
)->data
, flags
, 0);
2959 #endif /* not DOS_NT */
2962 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2964 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
2965 "Return t if file FILENAME can be written or created by you.")
2967 Lisp_Object filename
;
2969 Lisp_Object absname
, dir
, encoded
;
2970 Lisp_Object handler
;
2971 struct stat statbuf
;
2973 CHECK_STRING (filename
, 0);
2974 absname
= Fexpand_file_name (filename
, Qnil
);
2976 /* If the file name has special constructs in it,
2977 call the corresponding file handler. */
2978 handler
= Ffind_file_name_handler (absname
, Qfile_writable_p
);
2979 if (!NILP (handler
))
2980 return call2 (handler
, Qfile_writable_p
, absname
);
2982 encoded
= ENCODE_FILE (absname
);
2983 if (stat (XSTRING (encoded
)->data
, &statbuf
) >= 0)
2984 return (check_writable (XSTRING (encoded
)->data
)
2987 dir
= Ffile_name_directory (absname
);
2990 dir
= Fdirectory_file_name (dir
);
2994 dir
= Fdirectory_file_name (dir
);
2997 dir
= ENCODE_FILE (dir
);
2999 /* The read-only attribute of the parent directory doesn't affect
3000 whether a file or directory can be created within it. Some day we
3001 should check ACLs though, which do affect this. */
3002 if (stat (XSTRING (dir
)->data
, &statbuf
) < 0)
3004 return (statbuf
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
3006 return (check_writable (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "")
3011 DEFUN ("access-file", Faccess_file
, Saccess_file
, 2, 2, 0,
3012 "Access file FILENAME, and get an error if that does not work.\n\
3013 The second argument STRING is used in the error message.\n\
3014 If there is no error, we return nil.")
3016 Lisp_Object filename
, string
;
3018 Lisp_Object handler
, encoded_filename
;
3021 CHECK_STRING (filename
, 0);
3022 CHECK_STRING (string
, 1);
3024 /* If the file name has special constructs in it,
3025 call the corresponding file handler. */
3026 handler
= Ffind_file_name_handler (filename
, Qaccess_file
);
3027 if (!NILP (handler
))
3028 return call3 (handler
, Qaccess_file
, filename
, string
);
3030 encoded_filename
= ENCODE_FILE (filename
);
3032 fd
= emacs_open (XSTRING (encoded_filename
)->data
, O_RDONLY
, 0);
3034 report_file_error (XSTRING (string
)->data
, Fcons (filename
, Qnil
));
3040 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
3041 "Return non-nil if file FILENAME is the name of a symbolic link.\n\
3042 The value is the name of the file to which it is linked.\n\
3043 Otherwise returns nil.")
3045 Lisp_Object filename
;
3052 Lisp_Object handler
;
3054 CHECK_STRING (filename
, 0);
3055 filename
= Fexpand_file_name (filename
, Qnil
);
3057 /* If the file name has special constructs in it,
3058 call the corresponding file handler. */
3059 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
3060 if (!NILP (handler
))
3061 return call2 (handler
, Qfile_symlink_p
, filename
);
3063 filename
= ENCODE_FILE (filename
);
3068 buf
= (char *) xmalloc (bufsize
);
3069 bzero (buf
, bufsize
);
3070 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
3071 if (valsize
< bufsize
) break;
3072 /* Buffer was not long enough */
3081 val
= make_string (buf
, valsize
);
3082 if (buf
[0] == '/' && index (buf
, ':'))
3083 val
= concat2 (build_string ("/:"), val
);
3085 val
= DECODE_FILE (val
);
3087 #else /* not S_IFLNK */
3089 #endif /* not S_IFLNK */
3092 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
3093 "Return t if FILENAME names an existing directory.\n\
3094 Symbolic links to directories count as directories.\n\
3095 See `file-symlink-p' to distinguish symlinks.")
3097 Lisp_Object filename
;
3099 register Lisp_Object absname
;
3101 Lisp_Object handler
;
3103 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
3105 /* If the file name has special constructs in it,
3106 call the corresponding file handler. */
3107 handler
= Ffind_file_name_handler (absname
, Qfile_directory_p
);
3108 if (!NILP (handler
))
3109 return call2 (handler
, Qfile_directory_p
, absname
);
3111 absname
= ENCODE_FILE (absname
);
3113 if (stat (XSTRING (absname
)->data
, &st
) < 0)
3115 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
3118 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
3119 "Return t if file FILENAME is the name of a directory as a file,\n\
3120 and files in that directory can be opened by you. In order to use a\n\
3121 directory as a buffer's current directory, this predicate must return true.\n\
3122 A directory name spec may be given instead; then the value is t\n\
3123 if the directory so specified exists and really is a readable and\n\
3124 searchable directory.")
3126 Lisp_Object filename
;
3128 Lisp_Object handler
;
3130 struct gcpro gcpro1
;
3132 /* If the file name has special constructs in it,
3133 call the corresponding file handler. */
3134 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
3135 if (!NILP (handler
))
3136 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
3138 /* It's an unlikely combination, but yes we really do need to gcpro:
3139 Suppose that file-accessible-directory-p has no handler, but
3140 file-directory-p does have a handler; this handler causes a GC which
3141 relocates the string in `filename'; and finally file-directory-p
3142 returns non-nil. Then we would end up passing a garbaged string
3143 to file-executable-p. */
3145 tem
= (NILP (Ffile_directory_p (filename
))
3146 || NILP (Ffile_executable_p (filename
)));
3148 return tem
? Qnil
: Qt
;
3151 DEFUN ("file-regular-p", Ffile_regular_p
, Sfile_regular_p
, 1, 1, 0,
3152 "Return t if file FILENAME is the name of a regular file.\n\
3153 This is the sort of file that holds an ordinary stream of data bytes.")
3155 Lisp_Object filename
;
3157 register Lisp_Object absname
;
3159 Lisp_Object handler
;
3161 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
3163 /* If the file name has special constructs in it,
3164 call the corresponding file handler. */
3165 handler
= Ffind_file_name_handler (absname
, Qfile_regular_p
);
3166 if (!NILP (handler
))
3167 return call2 (handler
, Qfile_regular_p
, absname
);
3169 absname
= ENCODE_FILE (absname
);
3174 Lisp_Object tem
= Vw32_get_true_file_attributes
;
3176 /* Tell stat to use expensive method to get accurate info. */
3177 Vw32_get_true_file_attributes
= Qt
;
3178 result
= stat (XSTRING (absname
)->data
, &st
);
3179 Vw32_get_true_file_attributes
= tem
;
3183 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
3186 if (stat (XSTRING (absname
)->data
, &st
) < 0)
3188 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
3192 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
3193 "Return mode bits of file named FILENAME, as an integer.")
3195 Lisp_Object filename
;
3197 Lisp_Object absname
;
3199 Lisp_Object handler
;
3201 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
3203 /* If the file name has special constructs in it,
3204 call the corresponding file handler. */
3205 handler
= Ffind_file_name_handler (absname
, Qfile_modes
);
3206 if (!NILP (handler
))
3207 return call2 (handler
, Qfile_modes
, absname
);
3209 absname
= ENCODE_FILE (absname
);
3211 if (stat (XSTRING (absname
)->data
, &st
) < 0)
3213 #if defined (MSDOS) && __DJGPP__ < 2
3214 if (check_executable (XSTRING (absname
)->data
))
3215 st
.st_mode
|= S_IEXEC
;
3216 #endif /* MSDOS && __DJGPP__ < 2 */
3218 return make_number (st
.st_mode
& 07777);
3221 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
3222 "Set mode bits of file named FILENAME to MODE (an integer).\n\
3223 Only the 12 low bits of MODE are used.")
3225 Lisp_Object filename
, mode
;
3227 Lisp_Object absname
, encoded_absname
;
3228 Lisp_Object handler
;
3230 absname
= Fexpand_file_name (filename
, current_buffer
->directory
);
3231 CHECK_NUMBER (mode
, 1);
3233 /* If the file name has special constructs in it,
3234 call the corresponding file handler. */
3235 handler
= Ffind_file_name_handler (absname
, Qset_file_modes
);
3236 if (!NILP (handler
))
3237 return call3 (handler
, Qset_file_modes
, absname
, mode
);
3239 encoded_absname
= ENCODE_FILE (absname
);
3241 if (chmod (XSTRING (encoded_absname
)->data
, XINT (mode
)) < 0)
3242 report_file_error ("Doing chmod", Fcons (absname
, Qnil
));
3247 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
3248 "Set the file permission bits for newly created files.\n\
3249 The argument MODE should be an integer; only the low 9 bits are used.\n\
3250 This setting is inherited by subprocesses.")
3254 CHECK_NUMBER (mode
, 0);
3256 umask ((~ XINT (mode
)) & 0777);
3261 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
3262 "Return the default file protection for created files.\n\
3263 The value is an integer.")
3269 realmask
= umask (0);
3272 XSETINT (value
, (~ realmask
) & 0777);
3282 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
3283 "Tell Unix to finish all pending disk updates.")
3292 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
3293 "Return t if file FILE1 is newer than file FILE2.\n\
3294 If FILE1 does not exist, the answer is nil;\n\
3295 otherwise, if FILE2 does not exist, the answer is t.")
3297 Lisp_Object file1
, file2
;
3299 Lisp_Object absname1
, absname2
;
3302 Lisp_Object handler
;
3303 struct gcpro gcpro1
, gcpro2
;
3305 CHECK_STRING (file1
, 0);
3306 CHECK_STRING (file2
, 0);
3309 GCPRO2 (absname1
, file2
);
3310 absname1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
3311 absname2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
3314 /* If the file name has special constructs in it,
3315 call the corresponding file handler. */
3316 handler
= Ffind_file_name_handler (absname1
, Qfile_newer_than_file_p
);
3318 handler
= Ffind_file_name_handler (absname2
, Qfile_newer_than_file_p
);
3319 if (!NILP (handler
))
3320 return call3 (handler
, Qfile_newer_than_file_p
, absname1
, absname2
);
3322 GCPRO2 (absname1
, absname2
);
3323 absname1
= ENCODE_FILE (absname1
);
3324 absname2
= ENCODE_FILE (absname2
);
3327 if (stat (XSTRING (absname1
)->data
, &st
) < 0)
3330 mtime1
= st
.st_mtime
;
3332 if (stat (XSTRING (absname2
)->data
, &st
) < 0)
3335 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
3339 Lisp_Object Qfind_buffer_file_type
;
3342 #ifndef READ_BUF_SIZE
3343 #define READ_BUF_SIZE (64 << 10)
3346 extern void adjust_markers_for_delete
P_ ((int, int, int, int));
3348 /* This function is called after Lisp functions to decide a coding
3349 system are called, or when they cause an error. Before they are
3350 called, the current buffer is set unibyte and it contains only a
3351 newly inserted text (thus the buffer was empty before the
3354 The functions may set markers, overlays, text properties, or even
3355 alter the buffer contents, change the current buffer.
3357 Here, we reset all those changes by:
3358 o set back the current buffer.
3359 o move all markers and overlays to BEG.
3360 o remove all text properties.
3361 o set back the buffer multibyteness. */
3364 decide_coding_unwind (unwind_data
)
3365 Lisp_Object unwind_data
;
3367 Lisp_Object multibyte
, undo_list
, buffer
;
3369 multibyte
= XCAR (unwind_data
);
3370 unwind_data
= XCDR (unwind_data
);
3371 undo_list
= XCAR (unwind_data
);
3372 buffer
= XCDR (unwind_data
);
3374 if (current_buffer
!= XBUFFER (buffer
))
3375 set_buffer_internal (XBUFFER (buffer
));
3376 adjust_markers_for_delete (BEG
, BEG_BYTE
, Z
, Z_BYTE
);
3377 adjust_overlays_for_delete (BEG
, Z
- BEG
);
3378 BUF_INTERVALS (current_buffer
) = 0;
3379 TEMP_SET_PT_BOTH (BEG
, BEG_BYTE
);
3381 /* Now we are safe to change the buffer's multibyteness directly. */
3382 current_buffer
->enable_multibyte_characters
= multibyte
;
3383 current_buffer
->undo_list
= undo_list
;
3388 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
3390 "Insert contents of file FILENAME after point.\n\
3391 Returns list of absolute file name and number of bytes inserted.\n\
3392 If second argument VISIT is non-nil, the buffer's visited filename\n\
3393 and last save file modtime are set, and it is marked unmodified.\n\
3394 If visiting and the file does not exist, visiting is completed\n\
3395 before the error is signaled.\n\
3396 The optional third and fourth arguments BEG and END\n\
3397 specify what portion of the file to insert.\n\
3398 These arguments count bytes in the file, not characters in the buffer.\n\
3399 If VISIT is non-nil, BEG and END must be nil.\n\
3401 If optional fifth argument REPLACE is non-nil,\n\
3402 it means replace the current buffer contents (in the accessible portion)\n\
3403 with the file contents. This is better than simply deleting and inserting\n\
3404 the whole thing because (1) it preserves some marker positions\n\
3405 and (2) it puts less data in the undo list.\n\
3406 When REPLACE is non-nil, the value is the number of characters actually read,\n\
3407 which is often less than the number of characters to be read.\n\
3409 This does code conversion according to the value of\n\
3410 `coding-system-for-read' or `file-coding-system-alist',\n\
3411 and sets the variable `last-coding-system-used' to the coding system\n\
3413 (filename
, visit
, beg
, end
, replace
)
3414 Lisp_Object filename
, visit
, beg
, end
, replace
;
3419 register int how_much
;
3420 register int unprocessed
;
3421 int count
= specpdl_ptr
- specpdl
;
3422 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3423 Lisp_Object handler
, val
, insval
, orig_filename
;
3426 int not_regular
= 0;
3427 unsigned char read_buf
[READ_BUF_SIZE
];
3428 struct coding_system coding
;
3429 unsigned char buffer
[1 << 14];
3430 int replace_handled
= 0;
3431 int set_coding_system
= 0;
3432 int coding_system_decided
= 0;
3434 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3435 error ("Cannot do file visiting in an indirect buffer");
3437 if (!NILP (current_buffer
->read_only
))
3438 Fbarf_if_buffer_read_only ();
3442 orig_filename
= Qnil
;
3444 GCPRO4 (filename
, val
, p
, orig_filename
);
3446 CHECK_STRING (filename
, 0);
3447 filename
= Fexpand_file_name (filename
, Qnil
);
3449 /* If the file name has special constructs in it,
3450 call the corresponding file handler. */
3451 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
3452 if (!NILP (handler
))
3454 val
= call6 (handler
, Qinsert_file_contents
, filename
,
3455 visit
, beg
, end
, replace
);
3456 if (CONSP (val
) && CONSP (XCDR (val
)))
3457 inserted
= XINT (XCAR (XCDR (val
)));
3461 orig_filename
= filename
;
3462 filename
= ENCODE_FILE (filename
);
3468 Lisp_Object tem
= Vw32_get_true_file_attributes
;
3470 /* Tell stat to use expensive method to get accurate info. */
3471 Vw32_get_true_file_attributes
= Qt
;
3472 total
= stat (XSTRING (filename
)->data
, &st
);
3473 Vw32_get_true_file_attributes
= tem
;
3478 if (stat (XSTRING (filename
)->data
, &st
) < 0)
3480 if ((fd
= emacs_open (XSTRING (filename
)->data
, O_RDONLY
, 0)) < 0
3481 || fstat (fd
, &st
) < 0)
3482 #endif /* not APOLLO */
3483 #endif /* WINDOWSNT */
3485 if (fd
>= 0) emacs_close (fd
);
3488 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3491 if (!NILP (Vcoding_system_for_read
))
3492 Fset (Qbuffer_file_coding_system
, Vcoding_system_for_read
);
3497 /* This code will need to be changed in order to work on named
3498 pipes, and it's probably just not worth it. So we should at
3499 least signal an error. */
3500 if (!S_ISREG (st
.st_mode
))
3507 if (! NILP (replace
) || ! NILP (beg
) || ! NILP (end
))
3508 Fsignal (Qfile_error
,
3509 Fcons (build_string ("not a regular file"),
3510 Fcons (orig_filename
, Qnil
)));
3515 if ((fd
= emacs_open (XSTRING (filename
)->data
, O_RDONLY
, 0)) < 0)
3518 /* Replacement should preserve point as it preserves markers. */
3519 if (!NILP (replace
))
3520 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
3522 record_unwind_protect (close_file_unwind
, make_number (fd
));
3524 /* Supposedly happens on VMS. */
3525 if (! not_regular
&& st
.st_size
< 0)
3526 error ("File size is negative");
3528 /* Prevent redisplay optimizations. */
3529 current_buffer
->clip_changed
= 1;
3533 if (!NILP (beg
) || !NILP (end
))
3534 error ("Attempt to visit less than an entire file");
3535 if (BEG
< Z
&& NILP (replace
))
3536 error ("Cannot do file visiting in a non-empty buffer");
3540 CHECK_NUMBER (beg
, 0);
3542 XSETFASTINT (beg
, 0);
3545 CHECK_NUMBER (end
, 0);
3550 XSETINT (end
, st
.st_size
);
3552 /* Arithmetic overflow can occur if an Emacs integer cannot
3553 represent the file size, or if the calculations below
3554 overflow. The calculations below double the file size
3555 twice, so check that it can be multiplied by 4 safely. */
3556 if (XINT (end
) != st
.st_size
3557 || ((int) st
.st_size
* 4) / 4 != st
.st_size
)
3558 error ("Maximum buffer size exceeded");
3564 /* Decide the coding system to use for reading the file now
3565 because we can't use an optimized method for handling
3566 `coding:' tag if the current buffer is not empty. */
3570 if (!NILP (Vcoding_system_for_read
))
3571 val
= Vcoding_system_for_read
;
3572 else if (! NILP (replace
))
3573 /* In REPLACE mode, we can use the same coding system
3574 that was used to visit the file. */
3575 val
= current_buffer
->buffer_file_coding_system
;
3578 /* Don't try looking inside a file for a coding system
3579 specification if it is not seekable. */
3580 if (! not_regular
&& ! NILP (Vset_auto_coding_function
))
3582 /* Find a coding system specified in the heading two
3583 lines or in the tailing several lines of the file.
3584 We assume that the 1K-byte and 3K-byte for heading
3585 and tailing respectively are sufficient for this
3589 if (st
.st_size
<= (1024 * 4))
3590 nread
= emacs_read (fd
, read_buf
, 1024 * 4);
3593 nread
= emacs_read (fd
, read_buf
, 1024);
3596 if (lseek (fd
, st
.st_size
- (1024 * 3), 0) < 0)
3597 report_file_error ("Setting file position",
3598 Fcons (orig_filename
, Qnil
));
3599 nread
+= emacs_read (fd
, read_buf
+ nread
, 1024 * 3);
3604 error ("IO error reading %s: %s",
3605 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3608 struct buffer
*prev
= current_buffer
;
3611 record_unwind_protect (Fset_buffer
, Fcurrent_buffer ());
3613 /* The call to temp_output_buffer_setup binds
3615 count1
= specpdl_ptr
- specpdl
;
3616 temp_output_buffer_setup (" *code-converting-work*");
3618 set_buffer_internal (XBUFFER (Vstandard_output
));
3619 current_buffer
->enable_multibyte_characters
= Qnil
;
3620 insert_1_both (read_buf
, nread
, nread
, 0, 0, 0);
3621 TEMP_SET_PT_BOTH (BEG
, BEG_BYTE
);
3622 val
= call2 (Vset_auto_coding_function
,
3623 filename
, make_number (nread
));
3624 set_buffer_internal (prev
);
3626 /* Remove the binding for standard-output. */
3627 unbind_to (count1
, Qnil
);
3629 /* Discard the unwind protect for recovering the
3633 /* Rewind the file for the actual read done later. */
3634 if (lseek (fd
, 0, 0) < 0)
3635 report_file_error ("Setting file position",
3636 Fcons (orig_filename
, Qnil
));
3642 /* If we have not yet decided a coding system, check
3643 file-coding-system-alist. */
3644 Lisp_Object args
[6], coding_systems
;
3646 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
;
3647 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = replace
;
3648 coding_systems
= Ffind_operation_coding_system (6, args
);
3649 if (CONSP (coding_systems
))
3650 val
= XCAR (coding_systems
);
3654 setup_coding_system (Fcheck_coding_system (val
), &coding
);
3655 /* Ensure we set Vlast_coding_system_used. */
3656 set_coding_system
= 1;
3658 if (NILP (current_buffer
->enable_multibyte_characters
)
3660 /* We must suppress all character code conversion except for
3661 end-of-line conversion. */
3662 setup_raw_text_coding_system (&coding
);
3664 coding
.src_multibyte
= 0;
3665 coding
.dst_multibyte
3666 = !NILP (current_buffer
->enable_multibyte_characters
);
3667 coding_system_decided
= 1;
3670 /* If requested, replace the accessible part of the buffer
3671 with the file contents. Avoid replacing text at the
3672 beginning or end of the buffer that matches the file contents;
3673 that preserves markers pointing to the unchanged parts.
3675 Here we implement this feature in an optimized way
3676 for the case where code conversion is NOT needed.
3677 The following if-statement handles the case of conversion
3678 in a less optimal way.
3680 If the code conversion is "automatic" then we try using this
3681 method and hope for the best.
3682 But if we discover the need for conversion, we give up on this method
3683 and let the following if-statement handle the replace job. */
3686 && !(coding
.common_flags
& CODING_REQUIRE_DECODING_MASK
))
3688 /* same_at_start and same_at_end count bytes,
3689 because file access counts bytes
3690 and BEG and END count bytes. */
3691 int same_at_start
= BEGV_BYTE
;
3692 int same_at_end
= ZV_BYTE
;
3694 /* There is still a possibility we will find the need to do code
3695 conversion. If that happens, we set this variable to 1 to
3696 give up on handling REPLACE in the optimized way. */
3697 int giveup_match_end
= 0;
3699 if (XINT (beg
) != 0)
3701 if (lseek (fd
, XINT (beg
), 0) < 0)
3702 report_file_error ("Setting file position",
3703 Fcons (orig_filename
, Qnil
));
3708 /* Count how many chars at the start of the file
3709 match the text at the beginning of the buffer. */
3714 nread
= emacs_read (fd
, buffer
, sizeof buffer
);
3716 error ("IO error reading %s: %s",
3717 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3718 else if (nread
== 0)
3721 if (coding
.type
== coding_type_undecided
)
3722 detect_coding (&coding
, buffer
, nread
);
3723 if (coding
.common_flags
& CODING_REQUIRE_DECODING_MASK
)
3724 /* We found that the file should be decoded somehow.
3725 Let's give up here. */
3727 giveup_match_end
= 1;
3731 if (coding
.eol_type
== CODING_EOL_UNDECIDED
)
3732 detect_eol (&coding
, buffer
, nread
);
3733 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3734 && coding
.eol_type
!= CODING_EOL_LF
)
3735 /* We found that the format of eol should be decoded.
3736 Let's give up here. */
3738 giveup_match_end
= 1;
3743 while (bufpos
< nread
&& same_at_start
< ZV_BYTE
3744 && FETCH_BYTE (same_at_start
) == buffer
[bufpos
])
3745 same_at_start
++, bufpos
++;
3746 /* If we found a discrepancy, stop the scan.
3747 Otherwise loop around and scan the next bufferful. */
3748 if (bufpos
!= nread
)
3752 /* If the file matches the buffer completely,
3753 there's no need to replace anything. */
3754 if (same_at_start
- BEGV_BYTE
== XINT (end
))
3758 /* Truncate the buffer to the size of the file. */
3759 del_range_1 (same_at_start
, same_at_end
, 0, 0);
3764 /* Count how many chars at the end of the file
3765 match the text at the end of the buffer. But, if we have
3766 already found that decoding is necessary, don't waste time. */
3767 while (!giveup_match_end
)
3769 int total_read
, nread
, bufpos
, curpos
, trial
;
3771 /* At what file position are we now scanning? */
3772 curpos
= XINT (end
) - (ZV_BYTE
- same_at_end
);
3773 /* If the entire file matches the buffer tail, stop the scan. */
3776 /* How much can we scan in the next step? */
3777 trial
= min (curpos
, sizeof buffer
);
3778 if (lseek (fd
, curpos
- trial
, 0) < 0)
3779 report_file_error ("Setting file position",
3780 Fcons (orig_filename
, Qnil
));
3783 while (total_read
< trial
)
3785 nread
= emacs_read (fd
, buffer
+ total_read
, trial
- total_read
);
3787 error ("IO error reading %s: %s",
3788 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3789 total_read
+= nread
;
3791 /* Scan this bufferful from the end, comparing with
3792 the Emacs buffer. */
3793 bufpos
= total_read
;
3794 /* Compare with same_at_start to avoid counting some buffer text
3795 as matching both at the file's beginning and at the end. */
3796 while (bufpos
> 0 && same_at_end
> same_at_start
3797 && FETCH_BYTE (same_at_end
- 1) == buffer
[bufpos
- 1])
3798 same_at_end
--, bufpos
--;
3800 /* If we found a discrepancy, stop the scan.
3801 Otherwise loop around and scan the preceding bufferful. */
3804 /* If this discrepancy is because of code conversion,
3805 we cannot use this method; giveup and try the other. */
3806 if (same_at_end
> same_at_start
3807 && FETCH_BYTE (same_at_end
- 1) >= 0200
3808 && ! NILP (current_buffer
->enable_multibyte_characters
)
3809 && (CODING_MAY_REQUIRE_DECODING (&coding
)))
3810 giveup_match_end
= 1;
3816 if (! giveup_match_end
)
3820 /* We win! We can handle REPLACE the optimized way. */
3822 /* Extend the start of non-matching text area to multibyte
3823 character boundary. */
3824 if (! NILP (current_buffer
->enable_multibyte_characters
))
3825 while (same_at_start
> BEGV_BYTE
3826 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start
)))
3829 /* Extend the end of non-matching text area to multibyte
3830 character boundary. */
3831 if (! NILP (current_buffer
->enable_multibyte_characters
))
3832 while (same_at_end
< ZV_BYTE
3833 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
3836 /* Don't try to reuse the same piece of text twice. */
3837 overlap
= (same_at_start
- BEGV_BYTE
3838 - (same_at_end
+ st
.st_size
- ZV
));
3840 same_at_end
+= overlap
;
3842 /* Arrange to read only the nonmatching middle part of the file. */
3843 XSETFASTINT (beg
, XINT (beg
) + (same_at_start
- BEGV_BYTE
));
3844 XSETFASTINT (end
, XINT (end
) - (ZV_BYTE
- same_at_end
));
3846 del_range_byte (same_at_start
, same_at_end
, 0);
3847 /* Insert from the file at the proper position. */
3848 temp
= BYTE_TO_CHAR (same_at_start
);
3849 SET_PT_BOTH (temp
, same_at_start
);
3851 /* If display currently starts at beginning of line,
3852 keep it that way. */
3853 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3854 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3856 replace_handled
= 1;
3860 /* If requested, replace the accessible part of the buffer
3861 with the file contents. Avoid replacing text at the
3862 beginning or end of the buffer that matches the file contents;
3863 that preserves markers pointing to the unchanged parts.
3865 Here we implement this feature for the case where code conversion
3866 is needed, in a simple way that needs a lot of memory.
3867 The preceding if-statement handles the case of no conversion
3868 in a more optimized way. */
3869 if (!NILP (replace
) && ! replace_handled
&& BEGV
< ZV
)
3871 int same_at_start
= BEGV_BYTE
;
3872 int same_at_end
= ZV_BYTE
;
3875 /* Make sure that the gap is large enough. */
3876 int bufsize
= 2 * st
.st_size
;
3877 unsigned char *conversion_buffer
= (unsigned char *) xmalloc (bufsize
);
3880 /* First read the whole file, performing code conversion into
3881 CONVERSION_BUFFER. */
3883 if (lseek (fd
, XINT (beg
), 0) < 0)
3885 xfree (conversion_buffer
);
3886 report_file_error ("Setting file position",
3887 Fcons (orig_filename
, Qnil
));
3890 total
= st
.st_size
; /* Total bytes in the file. */
3891 how_much
= 0; /* Bytes read from file so far. */
3892 inserted
= 0; /* Bytes put into CONVERSION_BUFFER so far. */
3893 unprocessed
= 0; /* Bytes not processed in previous loop. */
3895 while (how_much
< total
)
3897 /* try is reserved in some compilers (Microsoft C) */
3898 int trytry
= min (total
- how_much
, READ_BUF_SIZE
- unprocessed
);
3899 unsigned char *destination
= read_buf
+ unprocessed
;
3902 /* Allow quitting out of the actual I/O. */
3905 this = emacs_read (fd
, destination
, trytry
);
3908 if (this < 0 || this + unprocessed
== 0)
3916 if (CODING_MAY_REQUIRE_DECODING (&coding
))
3918 int require
, result
;
3920 this += unprocessed
;
3922 /* If we are using more space than estimated,
3923 make CONVERSION_BUFFER bigger. */
3924 require
= decoding_buffer_size (&coding
, this);
3925 if (inserted
+ require
+ 2 * (total
- how_much
) > bufsize
)
3927 bufsize
= inserted
+ require
+ 2 * (total
- how_much
);
3928 conversion_buffer
= (unsigned char *) xrealloc (conversion_buffer
, bufsize
);
3931 /* Convert this batch with results in CONVERSION_BUFFER. */
3932 if (how_much
>= total
) /* This is the last block. */
3933 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
3934 result
= decode_coding (&coding
, read_buf
,
3935 conversion_buffer
+ inserted
,
3936 this, bufsize
- inserted
);
3938 /* Save for next iteration whatever we didn't convert. */
3939 unprocessed
= this - coding
.consumed
;
3940 bcopy (read_buf
+ coding
.consumed
, read_buf
, unprocessed
);
3941 if (!NILP (current_buffer
->enable_multibyte_characters
))
3942 this = coding
.produced
;
3944 this = str_as_unibyte (conversion_buffer
+ inserted
,
3951 /* At this point, INSERTED is how many characters (i.e. bytes)
3952 are present in CONVERSION_BUFFER.
3953 HOW_MUCH should equal TOTAL,
3954 or should be <= 0 if we couldn't read the file. */
3958 xfree (conversion_buffer
);
3961 error ("IO error reading %s: %s",
3962 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
3963 else if (how_much
== -2)
3964 error ("maximum buffer size exceeded");
3967 /* Compare the beginning of the converted file
3968 with the buffer text. */
3971 while (bufpos
< inserted
&& same_at_start
< same_at_end
3972 && FETCH_BYTE (same_at_start
) == conversion_buffer
[bufpos
])
3973 same_at_start
++, bufpos
++;
3975 /* If the file matches the buffer completely,
3976 there's no need to replace anything. */
3978 if (bufpos
== inserted
)
3980 xfree (conversion_buffer
);
3983 /* Truncate the buffer to the size of the file. */
3984 del_range_byte (same_at_start
, same_at_end
, 0);
3989 /* Extend the start of non-matching text area to multibyte
3990 character boundary. */
3991 if (! NILP (current_buffer
->enable_multibyte_characters
))
3992 while (same_at_start
> BEGV_BYTE
3993 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_start
)))
3996 /* Scan this bufferful from the end, comparing with
3997 the Emacs buffer. */
4000 /* Compare with same_at_start to avoid counting some buffer text
4001 as matching both at the file's beginning and at the end. */
4002 while (bufpos
> 0 && same_at_end
> same_at_start
4003 && FETCH_BYTE (same_at_end
- 1) == conversion_buffer
[bufpos
- 1])
4004 same_at_end
--, bufpos
--;
4006 /* Extend the end of non-matching text area to multibyte
4007 character boundary. */
4008 if (! NILP (current_buffer
->enable_multibyte_characters
))
4009 while (same_at_end
< ZV_BYTE
4010 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
4013 /* Don't try to reuse the same piece of text twice. */
4014 overlap
= same_at_start
- BEGV_BYTE
- (same_at_end
+ inserted
- ZV_BYTE
);
4016 same_at_end
+= overlap
;
4018 /* If display currently starts at beginning of line,
4019 keep it that way. */
4020 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
4021 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
4023 /* Replace the chars that we need to replace,
4024 and update INSERTED to equal the number of bytes
4025 we are taking from the file. */
4026 inserted
-= (Z_BYTE
- same_at_end
) + (same_at_start
- BEG_BYTE
);
4028 if (same_at_end
!= same_at_start
)
4030 del_range_byte (same_at_start
, same_at_end
, 0);
4032 same_at_start
= GPT_BYTE
;
4036 temp
= BYTE_TO_CHAR (same_at_start
);
4038 /* Insert from the file at the proper position. */
4039 SET_PT_BOTH (temp
, same_at_start
);
4040 insert_1 (conversion_buffer
+ same_at_start
- BEG_BYTE
, inserted
,
4042 /* Set `inserted' to the number of inserted characters. */
4043 inserted
= PT
- temp
;
4045 xfree (conversion_buffer
);
4054 register Lisp_Object temp
;
4056 total
= XINT (end
) - XINT (beg
);
4058 /* Make sure point-max won't overflow after this insertion. */
4059 XSETINT (temp
, total
);
4060 if (total
!= XINT (temp
))
4061 error ("Maximum buffer size exceeded");
4064 /* For a special file, all we can do is guess. */
4065 total
= READ_BUF_SIZE
;
4067 if (NILP (visit
) && total
> 0)
4068 prepare_to_modify_buffer (PT
, PT
, NULL
);
4071 if (GAP_SIZE
< total
)
4072 make_gap (total
- GAP_SIZE
);
4074 if (XINT (beg
) != 0 || !NILP (replace
))
4076 if (lseek (fd
, XINT (beg
), 0) < 0)
4077 report_file_error ("Setting file position",
4078 Fcons (orig_filename
, Qnil
));
4081 /* In the following loop, HOW_MUCH contains the total bytes read so
4082 far for a regular file, and not changed for a special file. But,
4083 before exiting the loop, it is set to a negative value if I/O
4086 /* Total bytes inserted. */
4088 /* Here, we don't do code conversion in the loop. It is done by
4089 code_convert_region after all data are read into the buffer. */
4090 while (how_much
< total
)
4092 /* try is reserved in some compilers (Microsoft C) */
4093 int trytry
= min (total
- how_much
, READ_BUF_SIZE
);
4096 /* For a special file, GAP_SIZE should be checked every time. */
4097 if (not_regular
&& GAP_SIZE
< trytry
)
4098 make_gap (total
- GAP_SIZE
);
4100 /* Allow quitting out of the actual I/O. */
4103 this = emacs_read (fd
, BYTE_POS_ADDR (PT_BYTE
+ inserted
- 1) + 1,
4121 /* For a regular file, where TOTAL is the real size,
4122 count HOW_MUCH to compare with it.
4123 For a special file, where TOTAL is just a buffer size,
4124 so don't bother counting in HOW_MUCH.
4125 (INSERTED is where we count the number of characters inserted.) */
4132 /* Put an anchor to ensure multi-byte form ends at gap. */
4137 /* Discard the unwind protect for closing the file. */
4141 error ("IO error reading %s: %s",
4142 XSTRING (orig_filename
)->data
, emacs_strerror (errno
));
4146 if (! coding_system_decided
)
4148 /* The coding system is not yet decided. Decide it by an
4149 optimized method for handling `coding:' tag.
4151 Note that we can get here only if the buffer was empty
4152 before the insertion. */
4156 if (!NILP (Vcoding_system_for_read
))
4157 val
= Vcoding_system_for_read
;
4160 /* Since we are sure that the current buffer was empty
4161 before the insertion, we can toggle
4162 enable-multibyte-characters directly here without taking
4163 care of marker adjustment and byte combining problem. By
4164 this way, we can run Lisp program safely before decoding
4165 the inserted text. */
4166 Lisp_Object unwind_data
;
4167 int count
= specpdl_ptr
- specpdl
;
4169 unwind_data
= Fcons (current_buffer
->enable_multibyte_characters
,
4170 Fcons (current_buffer
->undo_list
,
4171 Fcurrent_buffer ()));
4172 current_buffer
->enable_multibyte_characters
= Qnil
;
4173 current_buffer
->undo_list
= Qt
;
4174 record_unwind_protect (decide_coding_unwind
, unwind_data
);
4176 if (inserted
> 0 && ! NILP (Vset_auto_coding_function
))
4178 val
= call2 (Vset_auto_coding_function
,
4179 filename
, make_number (inserted
));
4184 /* If the coding system is not yet decided, check
4185 file-coding-system-alist. */
4186 Lisp_Object args
[6], coding_systems
;
4188 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
;
4189 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = Qnil
;
4190 coding_systems
= Ffind_operation_coding_system (6, args
);
4191 if (CONSP (coding_systems
))
4192 val
= XCAR (coding_systems
);
4195 unbind_to (count
, Qnil
);
4196 inserted
= Z_BYTE
- BEG_BYTE
;
4199 /* The following kludgy code is to avoid some compiler bug.
4201 setup_coding_system (val, &coding);
4204 struct coding_system temp_coding
;
4205 setup_coding_system (val
, &temp_coding
);
4206 bcopy (&temp_coding
, &coding
, sizeof coding
);
4208 /* Ensure we set Vlast_coding_system_used. */
4209 set_coding_system
= 1;
4211 if (NILP (current_buffer
->enable_multibyte_characters
)
4213 /* We must suppress all character code conversion except for
4214 end-of-line conversion. */
4215 setup_raw_text_coding_system (&coding
);
4216 coding
.src_multibyte
= 0;
4217 coding
.dst_multibyte
4218 = !NILP (current_buffer
->enable_multibyte_characters
);
4222 && (coding
.type
== coding_type_no_conversion
4223 || coding
.type
== coding_type_raw_text
))
4225 /* Visiting a file with these coding system always make the buffer
4227 current_buffer
->enable_multibyte_characters
= Qnil
;
4228 coding
.dst_multibyte
= 0;
4231 if (inserted
> 0 || coding
.type
== coding_type_ccl
)
4233 if (CODING_MAY_REQUIRE_DECODING (&coding
))
4235 code_convert_region (PT
, PT_BYTE
, PT
+ inserted
, PT_BYTE
+ inserted
,
4237 inserted
= coding
.produced_char
;
4240 adjust_after_insert (PT
, PT_BYTE
, PT
+ inserted
, PT_BYTE
+ inserted
,
4245 /* Use the conversion type to determine buffer-file-type
4246 (find-buffer-file-type is now used to help determine the
4248 if ((coding
.eol_type
== CODING_EOL_UNDECIDED
4249 || coding
.eol_type
== CODING_EOL_LF
)
4250 && ! CODING_REQUIRE_DECODING (&coding
))
4251 current_buffer
->buffer_file_type
= Qt
;
4253 current_buffer
->buffer_file_type
= Qnil
;
4260 if (!EQ (current_buffer
->undo_list
, Qt
))
4261 current_buffer
->undo_list
= Qnil
;
4263 stat (XSTRING (filename
)->data
, &st
);
4268 current_buffer
->modtime
= st
.st_mtime
;
4269 current_buffer
->filename
= orig_filename
;
4272 SAVE_MODIFF
= MODIFF
;
4273 current_buffer
->auto_save_modified
= MODIFF
;
4274 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4275 #ifdef CLASH_DETECTION
4278 if (!NILP (current_buffer
->file_truename
))
4279 unlock_file (current_buffer
->file_truename
);
4280 unlock_file (filename
);
4282 #endif /* CLASH_DETECTION */
4284 Fsignal (Qfile_error
,
4285 Fcons (build_string ("not a regular file"),
4286 Fcons (orig_filename
, Qnil
)));
4289 /* Decode file format */
4292 insval
= call3 (Qformat_decode
,
4293 Qnil
, make_number (inserted
), visit
);
4294 CHECK_NUMBER (insval
, 0);
4295 inserted
= XFASTINT (insval
);
4298 if (set_coding_system
)
4299 Vlast_coding_system_used
= coding
.symbol
;
4301 /* Call after-change hooks for the inserted text, aside from the case
4302 of normal visiting (not with REPLACE), which is done in a new buffer
4303 "before" the buffer is changed. */
4304 if (inserted
> 0 && total
> 0
4305 && (NILP (visit
) || !NILP (replace
)))
4307 signal_after_change (PT
, 0, inserted
);
4308 update_compositions (PT
, PT
, CHECK_BORDER
);
4311 p
= Vafter_insert_file_functions
;
4314 insval
= call1 (Fcar (p
), make_number (inserted
));
4317 CHECK_NUMBER (insval
, 0);
4318 inserted
= XFASTINT (insval
);
4325 && current_buffer
->modtime
== -1)
4327 /* If visiting nonexistent file, return nil. */
4328 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
4331 /* ??? Retval needs to be dealt with in all cases consistently. */
4333 val
= Fcons (orig_filename
,
4334 Fcons (make_number (inserted
),
4337 RETURN_UNGCPRO (unbind_to (count
, val
));
4340 static Lisp_Object build_annotations
P_ ((Lisp_Object
, Lisp_Object
,
4343 /* If build_annotations switched buffers, switch back to BUF.
4344 Kill the temporary buffer that was selected in the meantime.
4346 Since this kill only the last temporary buffer, some buffers remain
4347 not killed if build_annotations switched buffers more than once.
4351 build_annotations_unwind (buf
)
4356 if (XBUFFER (buf
) == current_buffer
)
4358 tembuf
= Fcurrent_buffer ();
4360 Fkill_buffer (tembuf
);
4364 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 7,
4365 "r\nFWrite region to file: \ni\ni\ni\np",
4366 "Write current region into specified file.\n\
4367 When called from a program, takes three arguments:\n\
4368 START, END and FILENAME. START and END are buffer positions.\n\
4369 Optional fourth argument APPEND if non-nil means\n\
4370 append to existing file contents (if any). If it is an integer,\n\
4371 seek to that offset in the file before writing.\n\
4372 Optional fifth argument VISIT if t means\n\
4373 set the last-save-file-modtime of buffer to this file's modtime\n\
4374 and mark buffer not modified.\n\
4375 If VISIT is a string, it is a second file name;\n\
4376 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
4377 VISIT is also the file name to lock and unlock for clash detection.\n\
4378 If VISIT is neither t nor nil nor a string,\n\
4379 that means do not print the \"Wrote file\" message.\n\
4380 The optional sixth arg LOCKNAME, if non-nil, specifies the name to\n\
4381 use for locking and unlocking, overriding FILENAME and VISIT.\n\
4382 The optional seventh arg MUSTBENEW, if non-nil, insists on a check\n\
4383 for an existing file with the same name. If MUSTBENEW is `excl',\n\
4384 that means to get an error if the file already exists; never overwrite.\n\
4385 If MUSTBENEW is neither nil nor `excl', that means ask for\n\
4386 confirmation before overwriting, but do go ahead and overwrite the file\n\
4387 if the user confirms.\n\
4388 Kludgy feature: if START is a string, then that string is written\n\
4389 to the file, instead of any buffer contents, and END is ignored.\n\
4391 This does code conversion according to the value of\n\
4392 `coding-system-for-write', `buffer-file-coding-system', or\n\
4393 `file-coding-system-alist', and sets the variable\n\
4394 `last-coding-system-used' to the coding system actually used.")
4396 (start
, end
, filename
, append
, visit
, lockname
, mustbenew
)
4397 Lisp_Object start
, end
, filename
, append
, visit
, lockname
, mustbenew
;
4405 int count
= specpdl_ptr
- specpdl
;
4408 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
4410 Lisp_Object handler
;
4411 Lisp_Object visit_file
;
4412 Lisp_Object annotations
;
4413 Lisp_Object encoded_filename
;
4414 int visiting
, quietly
;
4415 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
4416 struct buffer
*given_buffer
;
4418 int buffer_file_type
= O_BINARY
;
4420 struct coding_system coding
;
4422 if (current_buffer
->base_buffer
&& ! NILP (visit
))
4423 error ("Cannot do file visiting in an indirect buffer");
4425 if (!NILP (start
) && !STRINGP (start
))
4426 validate_region (&start
, &end
);
4428 GCPRO4 (start
, filename
, visit
, lockname
);
4430 /* Decide the coding-system to encode the data with. */
4436 else if (!NILP (Vcoding_system_for_write
))
4437 val
= Vcoding_system_for_write
;
4440 /* If the variable `buffer-file-coding-system' is set locally,
4441 it means that the file was read with some kind of code
4442 conversion or the varialbe is explicitely set by users. We
4443 had better write it out with the same coding system even if
4444 `enable-multibyte-characters' is nil.
4446 If it is not set locally, we anyway have to convert EOL
4447 format if the default value of `buffer-file-coding-system'
4448 tells that it is not Unix-like (LF only) format. */
4449 int using_default_coding
= 0;
4450 int force_raw_text
= 0;
4452 val
= current_buffer
->buffer_file_coding_system
;
4454 || NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4457 if (NILP (current_buffer
->enable_multibyte_characters
))
4463 /* Check file-coding-system-alist. */
4464 Lisp_Object args
[7], coding_systems
;
4466 args
[0] = Qwrite_region
; args
[1] = start
; args
[2] = end
;
4467 args
[3] = filename
; args
[4] = append
; args
[5] = visit
;
4469 coding_systems
= Ffind_operation_coding_system (7, args
);
4470 if (CONSP (coding_systems
) && !NILP (XCDR (coding_systems
)))
4471 val
= XCDR (coding_systems
);
4475 && !NILP (current_buffer
->buffer_file_coding_system
))
4477 /* If we still have not decided a coding system, use the
4478 default value of buffer-file-coding-system. */
4479 val
= current_buffer
->buffer_file_coding_system
;
4480 using_default_coding
= 1;
4484 && !NILP (Ffboundp (Vselect_safe_coding_system_function
)))
4485 /* Confirm that VAL can surely encode the current region. */
4486 val
= call3 (Vselect_safe_coding_system_function
, start
, end
, val
);
4488 setup_coding_system (Fcheck_coding_system (val
), &coding
);
4489 if (coding
.eol_type
== CODING_EOL_UNDECIDED
4490 && !using_default_coding
)
4492 if (! EQ (default_buffer_file_coding
.symbol
,
4493 buffer_defaults
.buffer_file_coding_system
))
4494 setup_coding_system (buffer_defaults
.buffer_file_coding_system
,
4495 &default_buffer_file_coding
);
4496 if (default_buffer_file_coding
.eol_type
!= CODING_EOL_UNDECIDED
)
4498 Lisp_Object subsidiaries
;
4500 coding
.eol_type
= default_buffer_file_coding
.eol_type
;
4501 subsidiaries
= Fget (coding
.symbol
, Qeol_type
);
4502 if (VECTORP (subsidiaries
)
4503 && XVECTOR (subsidiaries
)->size
== 3)
4505 = XVECTOR (subsidiaries
)->contents
[coding
.eol_type
];
4510 setup_raw_text_coding_system (&coding
);
4511 goto done_setup_coding
;
4514 setup_coding_system (Fcheck_coding_system (val
), &coding
);
4517 if (!STRINGP (start
) && !NILP (current_buffer
->selective_display
))
4518 coding
.mode
|= CODING_MODE_SELECTIVE_DISPLAY
;
4521 Vlast_coding_system_used
= coding
.symbol
;
4523 filename
= Fexpand_file_name (filename
, Qnil
);
4525 if (! NILP (mustbenew
) && !EQ (mustbenew
, Qexcl
))
4526 barf_or_query_if_file_exists (filename
, "overwrite", 1, 0, 1);
4528 if (STRINGP (visit
))
4529 visit_file
= Fexpand_file_name (visit
, Qnil
);
4531 visit_file
= filename
;
4534 visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
4535 quietly
= !NILP (visit
);
4539 if (NILP (lockname
))
4540 lockname
= visit_file
;
4542 GCPRO5 (start
, filename
, annotations
, visit_file
, lockname
);
4544 /* If the file name has special constructs in it,
4545 call the corresponding file handler. */
4546 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
4547 /* If FILENAME has no handler, see if VISIT has one. */
4548 if (NILP (handler
) && STRINGP (visit
))
4549 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
4551 if (!NILP (handler
))
4554 val
= call6 (handler
, Qwrite_region
, start
, end
,
4555 filename
, append
, visit
);
4559 SAVE_MODIFF
= MODIFF
;
4560 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4561 current_buffer
->filename
= visit_file
;
4567 /* Special kludge to simplify auto-saving. */
4570 XSETFASTINT (start
, BEG
);
4571 XSETFASTINT (end
, Z
);
4574 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
4575 count1
= specpdl_ptr
- specpdl
;
4577 given_buffer
= current_buffer
;
4578 annotations
= build_annotations (start
, end
, coding
.pre_write_conversion
);
4579 if (current_buffer
!= given_buffer
)
4581 XSETFASTINT (start
, BEGV
);
4582 XSETFASTINT (end
, ZV
);
4585 #ifdef CLASH_DETECTION
4588 #if 0 /* This causes trouble for GNUS. */
4589 /* If we've locked this file for some other buffer,
4590 query before proceeding. */
4591 if (!visiting
&& EQ (Ffile_locked_p (lockname
), Qt
))
4592 call2 (intern ("ask-user-about-lock"), filename
, Vuser_login_name
);
4595 lock_file (lockname
);
4597 #endif /* CLASH_DETECTION */
4599 encoded_filename
= ENCODE_FILE (filename
);
4601 fn
= XSTRING (encoded_filename
)->data
;
4605 desc
= emacs_open (fn
, O_WRONLY
| buffer_file_type
, 0);
4606 #else /* not DOS_NT */
4607 desc
= emacs_open (fn
, O_WRONLY
, 0);
4608 #endif /* not DOS_NT */
4610 if (desc
< 0 && (NILP (append
) || errno
== ENOENT
))
4612 if (auto_saving
) /* Overwrite any previous version of autosave file */
4614 vms_truncate (fn
); /* if fn exists, truncate to zero length */
4615 desc
= emacs_open (fn
, O_RDWR
, 0);
4617 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
4618 ? XSTRING (current_buffer
->filename
)->data
: 0,
4621 else /* Write to temporary name and rename if no errors */
4623 Lisp_Object temp_name
;
4624 temp_name
= Ffile_name_directory (filename
);
4626 if (!NILP (temp_name
))
4628 temp_name
= Fmake_temp_name (concat2 (temp_name
,
4629 build_string ("$$SAVE$$")));
4630 fname
= XSTRING (filename
)->data
;
4631 fn
= XSTRING (temp_name
)->data
;
4632 desc
= creat_copy_attrs (fname
, fn
);
4635 /* If we can't open the temporary file, try creating a new
4636 version of the original file. VMS "creat" creates a
4637 new version rather than truncating an existing file. */
4640 desc
= creat (fn
, 0666);
4641 #if 0 /* This can clobber an existing file and fail to replace it,
4642 if the user runs out of space. */
4645 /* We can't make a new version;
4646 try to truncate and rewrite existing version if any. */
4648 desc
= emacs_open (fn
, O_RDWR
, 0);
4654 desc
= creat (fn
, 0666);
4658 desc
= emacs_open (fn
,
4659 O_WRONLY
| O_TRUNC
| O_CREAT
| buffer_file_type
4660 | (mustbenew
== Qexcl
? O_EXCL
: 0),
4661 S_IREAD
| S_IWRITE
);
4662 #else /* not DOS_NT */
4663 desc
= emacs_open (fn
, O_WRONLY
| O_TRUNC
| O_CREAT
4664 | (EQ (mustbenew
, Qexcl
) ? O_EXCL
: 0),
4665 auto_saving
? auto_save_mode_bits
: 0666);
4666 #endif /* not DOS_NT */
4667 #endif /* not VMS */
4671 #ifdef CLASH_DETECTION
4673 if (!auto_saving
) unlock_file (lockname
);
4675 #endif /* CLASH_DETECTION */
4677 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
4680 record_unwind_protect (close_file_unwind
, make_number (desc
));
4682 if (!NILP (append
) && !NILP (Ffile_regular_p (filename
)))
4686 if (NUMBERP (append
))
4687 ret
= lseek (desc
, XINT (append
), 1);
4689 ret
= lseek (desc
, 0, 2);
4692 #ifdef CLASH_DETECTION
4693 if (!auto_saving
) unlock_file (lockname
);
4694 #endif /* CLASH_DETECTION */
4696 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
4704 * Kludge Warning: The VMS C RTL likes to insert carriage returns
4705 * if we do writes that don't end with a carriage return. Furthermore
4706 * it cannot handle writes of more then 16K. The modified
4707 * version of "sys_write" in SYSDEP.C (see comment there) copes with
4708 * this EXCEPT for the last record (iff it doesn't end with a carriage
4709 * return). This implies that if your buffer doesn't end with a carriage
4710 * return, you get one free... tough. However it also means that if
4711 * we make two calls to sys_write (a la the following code) you can
4712 * get one at the gap as well. The easiest way to fix this (honest)
4713 * is to move the gap to the next newline (or the end of the buffer).
4718 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4719 move_gap (find_next_newline (GPT
, 1));
4721 /* Whether VMS or not, we must move the gap to the next of newline
4722 when we must put designation sequences at beginning of line. */
4723 if (INTEGERP (start
)
4724 && coding
.type
== coding_type_iso2022
4725 && coding
.flags
& CODING_FLAG_ISO_DESIGNATE_AT_BOL
4726 && GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4728 int opoint
= PT
, opoint_byte
= PT_BYTE
;
4729 scan_newline (PT
, PT_BYTE
, ZV
, ZV_BYTE
, 1, 0);
4730 move_gap_both (PT
, PT_BYTE
);
4731 SET_PT_BOTH (opoint
, opoint_byte
);
4738 if (STRINGP (start
))
4740 failure
= 0 > a_write (desc
, start
, 0, XSTRING (start
)->size
,
4741 &annotations
, &coding
);
4744 else if (XINT (start
) != XINT (end
))
4746 tem
= CHAR_TO_BYTE (XINT (start
));
4748 if (XINT (start
) < GPT
)
4750 failure
= 0 > a_write (desc
, Qnil
, XINT (start
),
4751 min (GPT
, XINT (end
)) - XINT (start
),
4752 &annotations
, &coding
);
4756 if (XINT (end
) > GPT
&& !failure
)
4758 tem
= max (XINT (start
), GPT
);
4759 failure
= 0 > a_write (desc
, Qnil
, tem
, XINT (end
) - tem
,
4760 &annotations
, &coding
);
4766 /* If file was empty, still need to write the annotations */
4767 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4768 failure
= 0 > a_write (desc
, Qnil
, XINT (end
), 0, &annotations
, &coding
);
4772 if (CODING_REQUIRE_FLUSHING (&coding
)
4773 && !(coding
.mode
& CODING_MODE_LAST_BLOCK
)
4776 /* We have to flush out a data. */
4777 coding
.mode
|= CODING_MODE_LAST_BLOCK
;
4778 failure
= 0 > e_write (desc
, Qnil
, 0, 0, &coding
);
4785 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
4786 Disk full in NFS may be reported here. */
4787 /* mib says that closing the file will try to write as fast as NFS can do
4788 it, and that means the fsync here is not crucial for autosave files. */
4789 if (!auto_saving
&& fsync (desc
) < 0)
4791 /* If fsync fails with EINTR, don't treat that as serious. */
4793 failure
= 1, save_errno
= errno
;
4797 /* Spurious "file has changed on disk" warnings have been
4798 observed on Suns as well.
4799 It seems that `close' can change the modtime, under nfs.
4801 (This has supposedly been fixed in Sunos 4,
4802 but who knows about all the other machines with NFS?) */
4805 /* On VMS and APOLLO, must do the stat after the close
4806 since closing changes the modtime. */
4809 /* Recall that #if defined does not work on VMS. */
4816 /* NFS can report a write failure now. */
4817 if (emacs_close (desc
) < 0)
4818 failure
= 1, save_errno
= errno
;
4821 /* If we wrote to a temporary name and had no errors, rename to real name. */
4825 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
4833 /* Discard the unwind protect for close_file_unwind. */
4834 specpdl_ptr
= specpdl
+ count1
;
4835 /* Restore the original current buffer. */
4836 visit_file
= unbind_to (count
, visit_file
);
4838 #ifdef CLASH_DETECTION
4840 unlock_file (lockname
);
4841 #endif /* CLASH_DETECTION */
4843 /* Do this before reporting IO error
4844 to avoid a "file has changed on disk" warning on
4845 next attempt to save. */
4847 current_buffer
->modtime
= st
.st_mtime
;
4850 error ("IO error writing %s: %s", XSTRING (filename
)->data
,
4851 emacs_strerror (save_errno
));
4855 SAVE_MODIFF
= MODIFF
;
4856 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4857 current_buffer
->filename
= visit_file
;
4858 update_mode_lines
++;
4864 message_with_string ("Wrote %s", visit_file
, 1);
4869 Lisp_Object
merge ();
4871 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
4872 "Return t if (car A) is numerically less than (car B).")
4876 return Flss (Fcar (a
), Fcar (b
));
4879 /* Build the complete list of annotations appropriate for writing out
4880 the text between START and END, by calling all the functions in
4881 write-region-annotate-functions and merging the lists they return.
4882 If one of these functions switches to a different buffer, we assume
4883 that buffer contains altered text. Therefore, the caller must
4884 make sure to restore the current buffer in all cases,
4885 as save-excursion would do. */
4888 build_annotations (start
, end
, pre_write_conversion
)
4889 Lisp_Object start
, end
, pre_write_conversion
;
4891 Lisp_Object annotations
;
4893 struct gcpro gcpro1
, gcpro2
;
4894 Lisp_Object original_buffer
;
4897 XSETBUFFER (original_buffer
, current_buffer
);
4900 p
= Vwrite_region_annotate_functions
;
4901 GCPRO2 (annotations
, p
);
4904 struct buffer
*given_buffer
= current_buffer
;
4905 Vwrite_region_annotations_so_far
= annotations
;
4906 res
= call2 (Fcar (p
), start
, end
);
4907 /* If the function makes a different buffer current,
4908 assume that means this buffer contains altered text to be output.
4909 Reset START and END from the buffer bounds
4910 and discard all previous annotations because they should have
4911 been dealt with by this function. */
4912 if (current_buffer
!= given_buffer
)
4914 XSETFASTINT (start
, BEGV
);
4915 XSETFASTINT (end
, ZV
);
4918 Flength (res
); /* Check basic validity of return value */
4919 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4923 /* Now do the same for annotation functions implied by the file-format */
4924 if (auto_saving
&& (!EQ (Vauto_save_file_format
, Qt
)))
4925 p
= Vauto_save_file_format
;
4927 p
= current_buffer
->file_format
;
4928 for (i
= 0; !NILP (p
); p
= Fcdr (p
), ++i
)
4930 struct buffer
*given_buffer
= current_buffer
;
4932 Vwrite_region_annotations_so_far
= annotations
;
4934 /* Value is either a list of annotations or nil if the function
4935 has written annotations to a temporary buffer, which is now
4937 res
= call5 (Qformat_annotate_function
, Fcar (p
), start
, end
,
4938 original_buffer
, make_number (i
));
4939 if (current_buffer
!= given_buffer
)
4941 XSETFASTINT (start
, BEGV
);
4942 XSETFASTINT (end
, ZV
);
4947 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4950 /* At last, do the same for the function PRE_WRITE_CONVERSION
4951 implied by the current coding-system. */
4952 if (!NILP (pre_write_conversion
))
4954 struct buffer
*given_buffer
= current_buffer
;
4955 Vwrite_region_annotations_so_far
= annotations
;
4956 res
= call2 (pre_write_conversion
, start
, end
);
4958 annotations
= (current_buffer
!= given_buffer
4960 : merge (annotations
, res
, Qcar_less_than_car
));
4967 /* Write to descriptor DESC the NCHARS chars starting at POS of STRING.
4968 If STRING is nil, POS is the character position in the current buffer.
4969 Intersperse with them the annotations from *ANNOT
4970 which fall within the range of POS to POS + NCHARS,
4971 each at its appropriate position.
4973 We modify *ANNOT by discarding elements as we use them up.
4975 The return value is negative in case of system call failure. */
4978 a_write (desc
, string
, pos
, nchars
, annot
, coding
)
4981 register int nchars
;
4984 struct coding_system
*coding
;
4988 int lastpos
= pos
+ nchars
;
4990 while (NILP (*annot
) || CONSP (*annot
))
4992 tem
= Fcar_safe (Fcar (*annot
));
4995 nextpos
= XFASTINT (tem
);
4997 /* If there are no more annotations in this range,
4998 output the rest of the range all at once. */
4999 if (! (nextpos
>= pos
&& nextpos
<= lastpos
))
5000 return e_write (desc
, string
, pos
, lastpos
, coding
);
5002 /* Output buffer text up to the next annotation's position. */
5005 if (0 > e_write (desc
, string
, pos
, nextpos
, coding
))
5009 /* Output the annotation. */
5010 tem
= Fcdr (Fcar (*annot
));
5013 if (0 > e_write (desc
, tem
, 0, XSTRING (tem
)->size
, coding
))
5016 *annot
= Fcdr (*annot
);
5021 #ifndef WRITE_BUF_SIZE
5022 #define WRITE_BUF_SIZE (16 * 1024)
5025 /* Write text in the range START and END into descriptor DESC,
5026 encoding them with coding system CODING. If STRING is nil, START
5027 and END are character positions of the current buffer, else they
5028 are indexes to the string STRING. */
5031 e_write (desc
, string
, start
, end
, coding
)
5035 struct coding_system
*coding
;
5037 register char *addr
;
5038 register int nbytes
;
5039 char buf
[WRITE_BUF_SIZE
];
5041 int require_encoding_p
;
5044 coding
->composing
= COMPOSITION_DISABLED
;
5045 if (coding
->composing
!= COMPOSITION_DISABLED
)
5046 coding_save_composition (coding
, start
, end
, string
);
5048 if (STRINGP (string
))
5050 addr
= XSTRING (string
)->data
;
5051 nbytes
= STRING_BYTES (XSTRING (string
));
5052 coding
->src_multibyte
= STRING_MULTIBYTE (string
);
5054 else if (start
< end
)
5056 /* It is assured that the gap is not in the range START and END-1. */
5057 addr
= CHAR_POS_ADDR (start
);
5058 nbytes
= CHAR_TO_BYTE (end
) - CHAR_TO_BYTE (start
);
5059 coding
->src_multibyte
5060 = !NILP (current_buffer
->enable_multibyte_characters
);
5066 coding
->src_multibyte
= 1;
5069 /* We used to have a code for handling selective display here. But,
5070 now it is handled within encode_coding. */
5075 result
= encode_coding (coding
, addr
, buf
, nbytes
, WRITE_BUF_SIZE
);
5076 if (coding
->produced
> 0)
5078 coding
->produced
-= emacs_write (desc
, buf
, coding
->produced
);
5079 if (coding
->produced
)
5085 nbytes
-= coding
->consumed
;
5086 addr
+= coding
->consumed
;
5087 if (result
== CODING_FINISH_INSUFFICIENT_SRC
5090 /* The source text ends by an incomplete multibyte form.
5091 There's no way other than write it out as is. */
5092 nbytes
-= emacs_write (desc
, addr
, nbytes
);
5101 start
+= coding
->consumed_char
;
5102 if (coding
->cmp_data
)
5103 coding_adjust_composition_offset (coding
, start
);
5106 if (coding
->cmp_data
)
5107 coding_free_composition_data (coding
);
5112 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
5113 Sverify_visited_file_modtime
, 1, 1, 0,
5114 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
5115 This means that the file has not been changed since it was visited or saved.")
5121 Lisp_Object handler
;
5122 Lisp_Object filename
;
5124 CHECK_BUFFER (buf
, 0);
5127 if (!STRINGP (b
->filename
)) return Qt
;
5128 if (b
->modtime
== 0) return Qt
;
5130 /* If the file name has special constructs in it,
5131 call the corresponding file handler. */
5132 handler
= Ffind_file_name_handler (b
->filename
,
5133 Qverify_visited_file_modtime
);
5134 if (!NILP (handler
))
5135 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
5137 filename
= ENCODE_FILE (b
->filename
);
5139 if (stat (XSTRING (filename
)->data
, &st
) < 0)
5141 /* If the file doesn't exist now and didn't exist before,
5142 we say that it isn't modified, provided the error is a tame one. */
5143 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
5148 if (st
.st_mtime
== b
->modtime
5149 /* If both are positive, accept them if they are off by one second. */
5150 || (st
.st_mtime
> 0 && b
->modtime
> 0
5151 && (st
.st_mtime
== b
->modtime
+ 1
5152 || st
.st_mtime
== b
->modtime
- 1)))
5157 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
5158 Sclear_visited_file_modtime
, 0, 0, 0,
5159 "Clear out records of last mod time of visited file.\n\
5160 Next attempt to save will certainly not complain of a discrepancy.")
5163 current_buffer
->modtime
= 0;
5167 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
5168 Svisited_file_modtime
, 0, 0, 0,
5169 "Return the current buffer's recorded visited file modification time.\n\
5170 The value is a list of the form (HIGH . LOW), like the time values\n\
5171 that `file-attributes' returns.")
5174 return long_to_cons ((unsigned long) current_buffer
->modtime
);
5177 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
5178 Sset_visited_file_modtime
, 0, 1, 0,
5179 "Update buffer's recorded modification time from the visited file's time.\n\
5180 Useful if the buffer was not read from the file normally\n\
5181 or if the file itself has been changed for some known benign reason.\n\
5182 An argument specifies the modification time value to use\n\
5183 \(instead of that of the visited file), in the form of a list\n\
5184 \(HIGH . LOW) or (HIGH LOW).")
5186 Lisp_Object time_list
;
5188 if (!NILP (time_list
))
5189 current_buffer
->modtime
= cons_to_long (time_list
);
5192 register Lisp_Object filename
;
5194 Lisp_Object handler
;
5196 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
5198 /* If the file name has special constructs in it,
5199 call the corresponding file handler. */
5200 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
5201 if (!NILP (handler
))
5202 /* The handler can find the file name the same way we did. */
5203 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
5205 filename
= ENCODE_FILE (filename
);
5207 if (stat (XSTRING (filename
)->data
, &st
) >= 0)
5208 current_buffer
->modtime
= st
.st_mtime
;
5218 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 1);
5219 Fsleep_for (make_number (1), Qnil
);
5220 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 0);
5221 Fsleep_for (make_number (1), Qnil
);
5222 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 0);
5223 Fsleep_for (make_number (1), Qnil
);
5232 /* Get visited file's mode to become the auto save file's mode. */
5233 if (! NILP (current_buffer
->filename
)
5234 && stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
5235 /* But make sure we can overwrite it later! */
5236 auto_save_mode_bits
= st
.st_mode
| 0600;
5238 auto_save_mode_bits
= 0666;
5241 Fwrite_region (Qnil
, Qnil
,
5242 current_buffer
->auto_save_file_name
,
5243 Qnil
, Qlambda
, Qnil
, Qnil
);
5247 do_auto_save_unwind (stream
) /* used as unwind-protect function */
5252 fclose ((FILE *) (XFASTINT (XCAR (stream
)) << 16
5253 | XFASTINT (XCDR (stream
))));
5258 do_auto_save_unwind_1 (value
) /* used as unwind-protect function */
5261 minibuffer_auto_raise
= XINT (value
);
5265 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
5266 "Auto-save all buffers that need it.\n\
5267 This is all buffers that have auto-saving enabled\n\
5268 and are changed since last auto-saved.\n\
5269 Auto-saving writes the buffer into a file\n\
5270 so that your editing is not lost if the system crashes.\n\
5271 This file is not the file you visited; that changes only when you save.\n\
5272 Normally we run the normal hook `auto-save-hook' before saving.\n\n\
5273 A non-nil NO-MESSAGE argument means do not print any message if successful.\n\
5274 A non-nil CURRENT-ONLY argument means save only current buffer.")
5275 (no_message
, current_only
)
5276 Lisp_Object no_message
, current_only
;
5278 struct buffer
*old
= current_buffer
, *b
;
5279 Lisp_Object tail
, buf
;
5281 int do_handled_files
;
5284 Lisp_Object lispstream
;
5285 int count
= specpdl_ptr
- specpdl
;
5286 int orig_minibuffer_auto_raise
= minibuffer_auto_raise
;
5287 int message_p
= push_message ();
5289 /* Ordinarily don't quit within this function,
5290 but don't make it impossible to quit (in case we get hung in I/O). */
5294 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
5295 point to non-strings reached from Vbuffer_alist. */
5300 if (!NILP (Vrun_hooks
))
5301 call1 (Vrun_hooks
, intern ("auto-save-hook"));
5303 if (STRINGP (Vauto_save_list_file_name
))
5305 Lisp_Object listfile
, dir
;
5307 listfile
= Fexpand_file_name (Vauto_save_list_file_name
, Qnil
);
5309 dir
= Ffile_name_directory (listfile
);
5310 if (NILP (Ffile_directory_p (dir
)))
5311 call2 (Qmake_directory
, dir
, Qt
);
5313 stream
= fopen (XSTRING (listfile
)->data
, "w");
5316 /* Arrange to close that file whether or not we get an error.
5317 Also reset auto_saving to 0. */
5318 lispstream
= Fcons (Qnil
, Qnil
);
5319 XSETFASTINT (XCAR (lispstream
), (EMACS_UINT
)stream
>> 16);
5320 XSETFASTINT (XCDR (lispstream
), (EMACS_UINT
)stream
& 0xffff);
5331 record_unwind_protect (do_auto_save_unwind
, lispstream
);
5332 record_unwind_protect (do_auto_save_unwind_1
,
5333 make_number (minibuffer_auto_raise
));
5334 minibuffer_auto_raise
= 0;
5337 /* First, save all files which don't have handlers. If Emacs is
5338 crashing, the handlers may tweak what is causing Emacs to crash
5339 in the first place, and it would be a shame if Emacs failed to
5340 autosave perfectly ordinary files because it couldn't handle some
5342 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
5343 for (tail
= Vbuffer_alist
; GC_CONSP (tail
); tail
= XCDR (tail
))
5345 buf
= XCDR (XCAR (tail
));
5348 /* Record all the buffers that have auto save mode
5349 in the special file that lists them. For each of these buffers,
5350 Record visited name (if any) and auto save name. */
5351 if (STRINGP (b
->auto_save_file_name
)
5352 && stream
!= NULL
&& do_handled_files
== 0)
5354 if (!NILP (b
->filename
))
5356 fwrite (XSTRING (b
->filename
)->data
, 1,
5357 STRING_BYTES (XSTRING (b
->filename
)), stream
);
5359 putc ('\n', stream
);
5360 fwrite (XSTRING (b
->auto_save_file_name
)->data
, 1,
5361 STRING_BYTES (XSTRING (b
->auto_save_file_name
)), stream
);
5362 putc ('\n', stream
);
5365 if (!NILP (current_only
)
5366 && b
!= current_buffer
)
5369 /* Don't auto-save indirect buffers.
5370 The base buffer takes care of it. */
5374 /* Check for auto save enabled
5375 and file changed since last auto save
5376 and file changed since last real save. */
5377 if (STRINGP (b
->auto_save_file_name
)
5378 && BUF_SAVE_MODIFF (b
) < BUF_MODIFF (b
)
5379 && b
->auto_save_modified
< BUF_MODIFF (b
)
5380 /* -1 means we've turned off autosaving for a while--see below. */
5381 && XINT (b
->save_length
) >= 0
5382 && (do_handled_files
5383 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
5386 EMACS_TIME before_time
, after_time
;
5388 EMACS_GET_TIME (before_time
);
5390 /* If we had a failure, don't try again for 20 minutes. */
5391 if (b
->auto_save_failure_time
>= 0
5392 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
5395 if ((XFASTINT (b
->save_length
) * 10
5396 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
5397 /* A short file is likely to change a large fraction;
5398 spare the user annoying messages. */
5399 && XFASTINT (b
->save_length
) > 5000
5400 /* These messages are frequent and annoying for `*mail*'. */
5401 && !EQ (b
->filename
, Qnil
)
5402 && NILP (no_message
))
5404 /* It has shrunk too much; turn off auto-saving here. */
5405 minibuffer_auto_raise
= orig_minibuffer_auto_raise
;
5406 message_with_string ("Buffer %s has shrunk a lot; auto save turned off there",
5408 minibuffer_auto_raise
= 0;
5409 /* Turn off auto-saving until there's a real save,
5410 and prevent any more warnings. */
5411 XSETINT (b
->save_length
, -1);
5412 Fsleep_for (make_number (1), Qnil
);
5415 set_buffer_internal (b
);
5416 if (!auto_saved
&& NILP (no_message
))
5417 message1 ("Auto-saving...");
5418 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
5420 b
->auto_save_modified
= BUF_MODIFF (b
);
5421 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
5422 set_buffer_internal (old
);
5424 EMACS_GET_TIME (after_time
);
5426 /* If auto-save took more than 60 seconds,
5427 assume it was an NFS failure that got a timeout. */
5428 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
5429 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
5433 /* Prevent another auto save till enough input events come in. */
5434 record_auto_save ();
5436 if (auto_saved
&& NILP (no_message
))
5440 sit_for (1, 0, 0, 0, 0);
5444 message1 ("Auto-saving...done");
5450 unbind_to (count
, Qnil
);
5454 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
5455 Sset_buffer_auto_saved
, 0, 0, 0,
5456 "Mark current buffer as auto-saved with its current text.\n\
5457 No auto-save file will be written until the buffer changes again.")
5460 current_buffer
->auto_save_modified
= MODIFF
;
5461 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
5462 current_buffer
->auto_save_failure_time
= -1;
5466 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
5467 Sclear_buffer_auto_save_failure
, 0, 0, 0,
5468 "Clear any record of a recent auto-save failure in the current buffer.")
5471 current_buffer
->auto_save_failure_time
= -1;
5475 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
5477 "Return t if buffer has been auto-saved since last read in or saved.")
5480 return (SAVE_MODIFF
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
5483 /* Reading and completing file names */
5484 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
5486 /* In the string VAL, change each $ to $$ and return the result. */
5489 double_dollars (val
)
5492 register unsigned char *old
, *new;
5496 osize
= STRING_BYTES (XSTRING (val
));
5498 /* Count the number of $ characters. */
5499 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
5500 if (*old
++ == '$') count
++;
5503 old
= XSTRING (val
)->data
;
5504 val
= make_uninit_multibyte_string (XSTRING (val
)->size
+ count
,
5506 new = XSTRING (val
)->data
;
5507 for (n
= osize
; n
> 0; n
--)
5520 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
5522 "Internal subroutine for read-file-name. Do not call this.")
5523 (string
, dir
, action
)
5524 Lisp_Object string
, dir
, action
;
5525 /* action is nil for complete, t for return list of completions,
5526 lambda for verify final value */
5528 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
5530 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
5532 CHECK_STRING (string
, 0);
5539 /* No need to protect ACTION--we only compare it with t and nil. */
5540 GCPRO5 (string
, realdir
, name
, specdir
, orig_string
);
5542 if (XSTRING (string
)->size
== 0)
5544 if (EQ (action
, Qlambda
))
5552 orig_string
= string
;
5553 string
= Fsubstitute_in_file_name (string
);
5554 changed
= NILP (Fstring_equal (string
, orig_string
));
5555 name
= Ffile_name_nondirectory (string
);
5556 val
= Ffile_name_directory (string
);
5558 realdir
= Fexpand_file_name (val
, realdir
);
5563 specdir
= Ffile_name_directory (string
);
5564 val
= Ffile_name_completion (name
, realdir
);
5569 return double_dollars (string
);
5573 if (!NILP (specdir
))
5574 val
= concat2 (specdir
, val
);
5576 return double_dollars (val
);
5579 #endif /* not VMS */
5583 if (EQ (action
, Qt
))
5584 return Ffile_name_all_completions (name
, realdir
);
5585 /* Only other case actually used is ACTION = lambda */
5587 /* Supposedly this helps commands such as `cd' that read directory names,
5588 but can someone explain how it helps them? -- RMS */
5589 if (XSTRING (name
)->size
== 0)
5592 return Ffile_exists_p (string
);
5595 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
5596 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
5597 Value is not expanded---you must call `expand-file-name' yourself.\n\
5598 Default name to DEFAULT-FILENAME if user enters a null string.\n\
5599 (If DEFAULT-FILENAME is omitted, the visited file name is used,\n\
5600 except that if INITIAL is specified, that combined with DIR is used.)\n\
5601 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
5602 Non-nil and non-t means also require confirmation after completion.\n\
5603 Fifth arg INITIAL specifies text to start with.\n\
5604 DIR defaults to current buffer's directory default.\n\
5606 If this command was invoked with the mouse, use a file dialog box if\n\
5607 `use-dialog-box' is non-nil, and the window system or X toolkit in use\n\
5608 provides a file dialog box..")
5609 (prompt
, dir
, default_filename
, mustmatch
, initial
)
5610 Lisp_Object prompt
, dir
, default_filename
, mustmatch
, initial
;
5612 Lisp_Object val
, insdef
, tem
;
5613 struct gcpro gcpro1
, gcpro2
;
5614 register char *homedir
;
5615 int replace_in_history
= 0;
5616 int add_to_history
= 0;
5620 dir
= current_buffer
->directory
;
5621 if (NILP (default_filename
))
5623 if (! NILP (initial
))
5624 default_filename
= Fexpand_file_name (initial
, dir
);
5626 default_filename
= current_buffer
->filename
;
5629 /* If dir starts with user's homedir, change that to ~. */
5630 homedir
= (char *) egetenv ("HOME");
5632 homedir
= strcpy (alloca (strlen (homedir
) + 1), homedir
);
5633 CORRECT_DIR_SEPS (homedir
);
5637 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5638 && IS_DIRECTORY_SEP (XSTRING (dir
)->data
[strlen (homedir
)]))
5640 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5641 STRING_BYTES (XSTRING (dir
)) - strlen (homedir
) + 1);
5642 XSTRING (dir
)->data
[0] = '~';
5644 /* Likewise for default_filename. */
5646 && STRINGP (default_filename
)
5647 && !strncmp (homedir
, XSTRING (default_filename
)->data
, strlen (homedir
))
5648 && IS_DIRECTORY_SEP (XSTRING (default_filename
)->data
[strlen (homedir
)]))
5651 = make_string (XSTRING (default_filename
)->data
+ strlen (homedir
) - 1,
5652 STRING_BYTES (XSTRING (default_filename
)) - strlen (homedir
) + 1);
5653 XSTRING (default_filename
)->data
[0] = '~';
5655 if (!NILP (default_filename
))
5657 CHECK_STRING (default_filename
, 3);
5658 default_filename
= double_dollars (default_filename
);
5661 if (insert_default_directory
&& STRINGP (dir
))
5664 if (!NILP (initial
))
5666 Lisp_Object args
[2], pos
;
5670 insdef
= Fconcat (2, args
);
5671 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
5672 insdef
= Fcons (double_dollars (insdef
), pos
);
5675 insdef
= double_dollars (insdef
);
5677 else if (STRINGP (initial
))
5678 insdef
= Fcons (double_dollars (initial
), make_number (0));
5682 count
= specpdl_ptr
- specpdl
;
5684 specbind (intern ("completion-ignore-case"), Qt
);
5687 specbind (intern ("minibuffer-completing-file-name"), Qt
);
5689 GCPRO2 (insdef
, default_filename
);
5691 #if defined (USE_MOTIF) || defined (HAVE_NTGUI)
5692 if ((NILP (last_nonmenu_event
) || CONSP (last_nonmenu_event
))
5696 /* If DIR contains a file name, split it. */
5698 file
= Ffile_name_nondirectory (dir
);
5699 if (XSTRING (file
)->size
&& NILP (default_filename
))
5701 default_filename
= file
;
5702 dir
= Ffile_name_directory (dir
);
5704 if (!NILP(default_filename
))
5705 default_filename
= Fexpand_file_name (default_filename
, dir
);
5706 val
= Fx_file_dialog (prompt
, dir
, default_filename
, mustmatch
);
5711 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5712 dir
, mustmatch
, insdef
,
5713 Qfile_name_history
, default_filename
, Qnil
);
5715 tem
= Fsymbol_value (Qfile_name_history
);
5716 if (CONSP (tem
) && EQ (XCAR (tem
), val
))
5717 replace_in_history
= 1;
5719 /* If Fcompleting_read returned the inserted default string itself
5720 (rather than a new string with the same contents),
5721 it has to mean that the user typed RET with the minibuffer empty.
5722 In that case, we really want to return ""
5723 so that commands such as set-visited-file-name can distinguish. */
5724 if (EQ (val
, default_filename
))
5726 /* In this case, Fcompleting_read has not added an element
5727 to the history. Maybe we should. */
5728 if (! replace_in_history
)
5731 val
= build_string ("");
5734 unbind_to (count
, Qnil
);
5737 error ("No file name specified");
5739 tem
= Fstring_equal (val
, CONSP (insdef
) ? XCAR (insdef
) : insdef
);
5741 if (!NILP (tem
) && !NILP (default_filename
))
5742 val
= default_filename
;
5743 else if (XSTRING (val
)->size
== 0 && NILP (insdef
))
5745 if (!NILP (default_filename
))
5746 val
= default_filename
;
5748 error ("No default file name");
5750 val
= Fsubstitute_in_file_name (val
);
5752 if (replace_in_history
)
5753 /* Replace what Fcompleting_read added to the history
5754 with what we will actually return. */
5755 XCAR (Fsymbol_value (Qfile_name_history
)) = double_dollars (val
);
5756 else if (add_to_history
)
5758 /* Add the value to the history--but not if it matches
5759 the last value already there. */
5760 Lisp_Object val1
= double_dollars (val
);
5761 tem
= Fsymbol_value (Qfile_name_history
);
5762 if (! CONSP (tem
) || NILP (Fequal (XCAR (tem
), val1
)))
5763 Fset (Qfile_name_history
,
5774 /* Must be set before any path manipulation is performed. */
5775 XSETFASTINT (Vdirectory_sep_char
, '/');
5782 Qexpand_file_name
= intern ("expand-file-name");
5783 Qsubstitute_in_file_name
= intern ("substitute-in-file-name");
5784 Qdirectory_file_name
= intern ("directory-file-name");
5785 Qfile_name_directory
= intern ("file-name-directory");
5786 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
5787 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
5788 Qfile_name_as_directory
= intern ("file-name-as-directory");
5789 Qcopy_file
= intern ("copy-file");
5790 Qmake_directory_internal
= intern ("make-directory-internal");
5791 Qmake_directory
= intern ("make-directory");
5792 Qdelete_directory
= intern ("delete-directory");
5793 Qdelete_file
= intern ("delete-file");
5794 Qrename_file
= intern ("rename-file");
5795 Qadd_name_to_file
= intern ("add-name-to-file");
5796 Qmake_symbolic_link
= intern ("make-symbolic-link");
5797 Qfile_exists_p
= intern ("file-exists-p");
5798 Qfile_executable_p
= intern ("file-executable-p");
5799 Qfile_readable_p
= intern ("file-readable-p");
5800 Qfile_writable_p
= intern ("file-writable-p");
5801 Qfile_symlink_p
= intern ("file-symlink-p");
5802 Qaccess_file
= intern ("access-file");
5803 Qfile_directory_p
= intern ("file-directory-p");
5804 Qfile_regular_p
= intern ("file-regular-p");
5805 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
5806 Qfile_modes
= intern ("file-modes");
5807 Qset_file_modes
= intern ("set-file-modes");
5808 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
5809 Qinsert_file_contents
= intern ("insert-file-contents");
5810 Qwrite_region
= intern ("write-region");
5811 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
5812 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
5814 staticpro (&Qexpand_file_name
);
5815 staticpro (&Qsubstitute_in_file_name
);
5816 staticpro (&Qdirectory_file_name
);
5817 staticpro (&Qfile_name_directory
);
5818 staticpro (&Qfile_name_nondirectory
);
5819 staticpro (&Qunhandled_file_name_directory
);
5820 staticpro (&Qfile_name_as_directory
);
5821 staticpro (&Qcopy_file
);
5822 staticpro (&Qmake_directory_internal
);
5823 staticpro (&Qmake_directory
);
5824 staticpro (&Qdelete_directory
);
5825 staticpro (&Qdelete_file
);
5826 staticpro (&Qrename_file
);
5827 staticpro (&Qadd_name_to_file
);
5828 staticpro (&Qmake_symbolic_link
);
5829 staticpro (&Qfile_exists_p
);
5830 staticpro (&Qfile_executable_p
);
5831 staticpro (&Qfile_readable_p
);
5832 staticpro (&Qfile_writable_p
);
5833 staticpro (&Qaccess_file
);
5834 staticpro (&Qfile_symlink_p
);
5835 staticpro (&Qfile_directory_p
);
5836 staticpro (&Qfile_regular_p
);
5837 staticpro (&Qfile_accessible_directory_p
);
5838 staticpro (&Qfile_modes
);
5839 staticpro (&Qset_file_modes
);
5840 staticpro (&Qfile_newer_than_file_p
);
5841 staticpro (&Qinsert_file_contents
);
5842 staticpro (&Qwrite_region
);
5843 staticpro (&Qverify_visited_file_modtime
);
5844 staticpro (&Qset_visited_file_modtime
);
5846 Qfile_name_history
= intern ("file-name-history");
5847 Fset (Qfile_name_history
, Qnil
);
5848 staticpro (&Qfile_name_history
);
5850 Qfile_error
= intern ("file-error");
5851 staticpro (&Qfile_error
);
5852 Qfile_already_exists
= intern ("file-already-exists");
5853 staticpro (&Qfile_already_exists
);
5854 Qfile_date_error
= intern ("file-date-error");
5855 staticpro (&Qfile_date_error
);
5856 Qexcl
= intern ("excl");
5860 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
5861 staticpro (&Qfind_buffer_file_type
);
5864 DEFVAR_LISP ("file-name-coding-system", &Vfile_name_coding_system
,
5865 "*Coding system for encoding file names.\n\
5866 If it is nil, default-file-name-coding-system (which see) is used.");
5867 Vfile_name_coding_system
= Qnil
;
5869 DEFVAR_LISP ("default-file-name-coding-system",
5870 &Vdefault_file_name_coding_system
,
5871 "Default coding system for encoding file names.\n\
5872 This variable is used only when file-name-coding-system is nil.\n\
5874 This variable is set/changed by the command set-language-environment.\n\
5875 User should not set this variable manually,\n\
5876 instead use file-name-coding-system to get a constant encoding\n\
5877 of file names regardless of the current language environment.");
5878 Vdefault_file_name_coding_system
= Qnil
;
5880 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format
,
5881 "*Format in which to write auto-save files.\n\
5882 Should be a list of symbols naming formats that are defined in `format-alist'.\n\
5883 If it is t, which is the default, auto-save files are written in the\n\
5884 same format as a regular save would use.");
5885 Vauto_save_file_format
= Qt
;
5887 Qformat_decode
= intern ("format-decode");
5888 staticpro (&Qformat_decode
);
5889 Qformat_annotate_function
= intern ("format-annotate-function");
5890 staticpro (&Qformat_annotate_function
);
5892 Qcar_less_than_car
= intern ("car-less-than-car");
5893 staticpro (&Qcar_less_than_car
);
5895 Fput (Qfile_error
, Qerror_conditions
,
5896 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
5897 Fput (Qfile_error
, Qerror_message
,
5898 build_string ("File error"));
5900 Fput (Qfile_already_exists
, Qerror_conditions
,
5901 Fcons (Qfile_already_exists
,
5902 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5903 Fput (Qfile_already_exists
, Qerror_message
,
5904 build_string ("File already exists"));
5906 Fput (Qfile_date_error
, Qerror_conditions
,
5907 Fcons (Qfile_date_error
,
5908 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5909 Fput (Qfile_date_error
, Qerror_message
,
5910 build_string ("Cannot set file date"));
5912 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
5913 "*Non-nil means when reading a filename start with default dir in minibuffer.");
5914 insert_default_directory
= 1;
5916 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
5917 "*Non-nil means write new files with record format `stmlf'.\n\
5918 nil means use format `var'. This variable is meaningful only on VMS.");
5919 vms_stmlf_recfm
= 0;
5921 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char
,
5922 "Directory separator character for built-in functions that return file names.\n\
5923 The value should be either ?/ or ?\\ (any other value is treated as ?\\).\n\
5924 This variable affects the built-in functions only on Windows,\n\
5925 on other platforms, it is initialized so that Lisp code can find out\n\
5926 what the normal separator is.");
5928 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
5929 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
5930 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
5933 The first argument given to HANDLER is the name of the I/O primitive\n\
5934 to be handled; the remaining arguments are the arguments that were\n\
5935 passed to that primitive. For example, if you do\n\
5936 (file-exists-p FILENAME)\n\
5937 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
5938 (funcall HANDLER 'file-exists-p FILENAME)\n\
5939 The function `find-file-name-handler' checks this list for a handler\n\
5940 for its argument.");
5941 Vfile_name_handler_alist
= Qnil
;
5943 DEFVAR_LISP ("set-auto-coding-function",
5944 &Vset_auto_coding_function
,
5945 "If non-nil, a function to call to decide a coding system of file.\n\
5946 Two arguments are passed to this function: the file name\n\
5947 and the length of a file contents following the point.\n\
5948 This function should return a coding system to decode the file contents.\n\
5949 It should check the file name against `auto-coding-alist'.\n\
5950 If no coding system is decided, it should check a coding system\n\
5951 specified in the heading lines with the format:\n\
5952 -*- ... coding: CODING-SYSTEM; ... -*-\n\
5953 or local variable spec of the tailing lines with `coding:' tag.");
5954 Vset_auto_coding_function
= Qnil
;
5956 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
5957 "A list of functions to be called at the end of `insert-file-contents'.\n\
5958 Each is passed one argument, the number of bytes inserted. It should return\n\
5959 the new byte count, and leave point the same. If `insert-file-contents' is\n\
5960 intercepted by a handler from `file-name-handler-alist', that handler is\n\
5961 responsible for calling the after-insert-file-functions if appropriate.");
5962 Vafter_insert_file_functions
= Qnil
;
5964 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
5965 "A list of functions to be called at the start of `write-region'.\n\
5966 Each is passed two arguments, START and END as for `write-region'.\n\
5967 These are usually two numbers but not always; see the documentation\n\
5968 for `write-region'. The function should return a list of pairs\n\
5969 of the form (POSITION . STRING), consisting of strings to be effectively\n\
5970 inserted at the specified positions of the file being written (1 means to\n\
5971 insert before the first byte written). The POSITIONs must be sorted into\n\
5972 increasing order. If there are several functions in the list, the several\n\
5973 lists are merged destructively.");
5974 Vwrite_region_annotate_functions
= Qnil
;
5976 DEFVAR_LISP ("write-region-annotations-so-far",
5977 &Vwrite_region_annotations_so_far
,
5978 "When an annotation function is called, this holds the previous annotations.\n\
5979 These are the annotations made by other annotation functions\n\
5980 that were already called. See also `write-region-annotate-functions'.");
5981 Vwrite_region_annotations_so_far
= Qnil
;
5983 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
5984 "A list of file name handlers that temporarily should not be used.\n\
5985 This applies only to the operation `inhibit-file-name-operation'.");
5986 Vinhibit_file_name_handlers
= Qnil
;
5988 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
5989 "The operation for which `inhibit-file-name-handlers' is applicable.");
5990 Vinhibit_file_name_operation
= Qnil
;
5992 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
5993 "File name in which we write a list of all auto save file names.\n\
5994 This variable is initialized automatically from `auto-save-list-file-prefix'\n\
5995 shortly after Emacs reads your `.emacs' file, if you have not yet given it\n\
5997 Vauto_save_list_file_name
= Qnil
;
5999 defsubr (&Sfind_file_name_handler
);
6000 defsubr (&Sfile_name_directory
);
6001 defsubr (&Sfile_name_nondirectory
);
6002 defsubr (&Sunhandled_file_name_directory
);
6003 defsubr (&Sfile_name_as_directory
);
6004 defsubr (&Sdirectory_file_name
);
6005 defsubr (&Smake_temp_name
);
6006 defsubr (&Sexpand_file_name
);
6007 defsubr (&Ssubstitute_in_file_name
);
6008 defsubr (&Scopy_file
);
6009 defsubr (&Smake_directory_internal
);
6010 defsubr (&Sdelete_directory
);
6011 defsubr (&Sdelete_file
);
6012 defsubr (&Srename_file
);
6013 defsubr (&Sadd_name_to_file
);
6015 defsubr (&Smake_symbolic_link
);
6016 #endif /* S_IFLNK */
6018 defsubr (&Sdefine_logical_name
);
6021 defsubr (&Ssysnetunam
);
6022 #endif /* HPUX_NET */
6023 defsubr (&Sfile_name_absolute_p
);
6024 defsubr (&Sfile_exists_p
);
6025 defsubr (&Sfile_executable_p
);
6026 defsubr (&Sfile_readable_p
);
6027 defsubr (&Sfile_writable_p
);
6028 defsubr (&Saccess_file
);
6029 defsubr (&Sfile_symlink_p
);
6030 defsubr (&Sfile_directory_p
);
6031 defsubr (&Sfile_accessible_directory_p
);
6032 defsubr (&Sfile_regular_p
);
6033 defsubr (&Sfile_modes
);
6034 defsubr (&Sset_file_modes
);
6035 defsubr (&Sset_default_file_modes
);
6036 defsubr (&Sdefault_file_modes
);
6037 defsubr (&Sfile_newer_than_file_p
);
6038 defsubr (&Sinsert_file_contents
);
6039 defsubr (&Swrite_region
);
6040 defsubr (&Scar_less_than_car
);
6041 defsubr (&Sverify_visited_file_modtime
);
6042 defsubr (&Sclear_visited_file_modtime
);
6043 defsubr (&Svisited_file_modtime
);
6044 defsubr (&Sset_visited_file_modtime
);
6045 defsubr (&Sdo_auto_save
);
6046 defsubr (&Sset_buffer_auto_saved
);
6047 defsubr (&Sclear_buffer_auto_save_failure
);
6048 defsubr (&Srecent_auto_save_p
);
6050 defsubr (&Sread_file_name_internal
);
6051 defsubr (&Sread_file_name
);
6054 defsubr (&Sunix_sync
);