1 /* File IO for GNU Emacs.
2 Copyright (C) 1985,86,87,88,93,94,95,96,1997 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
6 GNU Emacs is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs; see the file COPYING. If not, write to
18 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
23 #if defined (USG5) || defined (BSD_SYSTEM) || defined (LINUX)
28 #include <sys/types.h>
35 #if !defined (S_ISLNK) && defined (S_IFLNK)
36 # define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
39 #if !defined (S_ISFIFO) && defined (S_IFIFO)
40 # define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO)
43 #if !defined (S_ISREG) && defined (S_IFREG)
44 # define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
55 #include <sys/param.h>
77 extern char *strerror ();
94 #include "intervals.h"
105 #endif /* not WINDOWSNT */
108 #define CORRECT_DIR_SEPS(s) \
109 do { if ('/' == DIRECTORY_SEP) dostounix_filename (s); \
110 else unixtodos_filename (s); \
112 /* On Windows, drive letters must be alphabetic - on DOS, the Netware
113 redirector allows the six letters between 'Z' and 'a' as well. */
115 #define IS_DRIVE(x) ((x) >= 'A' && (x) <= 'z')
118 #define IS_DRIVE(x) isalpha (x)
120 /* Need to lower-case the drive letter, or else expanded
121 filenames will sometimes compare inequal, because
122 `expand-file-name' doesn't always down-case the drive letter. */
123 #define DRIVE_LETTER(x) (tolower (x))
152 #define min(a, b) ((a) < (b) ? (a) : (b))
153 #define max(a, b) ((a) > (b) ? (a) : (b))
155 /* Encode the file name NAME using the specified coding system
156 for file names, if any. */
157 #define ENCODE_FILE(name) \
158 (! NILP (Vfile_name_coding_system) \
159 && XFASTINT (Vfile_name_coding_system) != 0 \
160 ? Fencode_coding_string (name, Vfile_name_coding_system, Qt) \
163 /* Nonzero during writing of auto-save files */
166 /* Set by auto_save_1 to mode of original file so Fwrite_region will create
167 a new file with the same mode as the original */
168 int auto_save_mode_bits
;
170 /* Coding system for file names, or nil if none. */
171 Lisp_Object Vfile_name_coding_system
;
173 /* Alist of elements (REGEXP . HANDLER) for file names
174 whose I/O is done with a special handler. */
175 Lisp_Object Vfile_name_handler_alist
;
177 /* Format for auto-save files */
178 Lisp_Object Vauto_save_file_format
;
180 /* Lisp functions for translating file formats */
181 Lisp_Object Qformat_decode
, Qformat_annotate_function
;
183 /* Function to be called to decide a coding system of a reading file. */
184 Lisp_Object Vset_auto_coding_function
;
186 /* Functions to be called to process text properties in inserted file. */
187 Lisp_Object Vafter_insert_file_functions
;
189 /* Functions to be called to create text property annotations for file. */
190 Lisp_Object Vwrite_region_annotate_functions
;
192 /* During build_annotations, each time an annotation function is called,
193 this holds the annotations made by the previous functions. */
194 Lisp_Object Vwrite_region_annotations_so_far
;
196 /* File name in which we write a list of all our auto save files. */
197 Lisp_Object Vauto_save_list_file_name
;
199 /* Nonzero means, when reading a filename in the minibuffer,
200 start out by inserting the default directory into the minibuffer. */
201 int insert_default_directory
;
203 /* On VMS, nonzero means write new files with record format stmlf.
204 Zero means use var format. */
207 /* On NT, specifies the directory separator character, used (eg.) when
208 expanding file names. This can be bound to / or \. */
209 Lisp_Object Vdirectory_sep_char
;
211 extern Lisp_Object Vuser_login_name
;
213 extern int minibuf_level
;
215 extern int minibuffer_auto_raise
;
217 /* These variables describe handlers that have "already" had a chance
218 to handle the current operation.
220 Vinhibit_file_name_handlers is a list of file name handlers.
221 Vinhibit_file_name_operation is the operation being handled.
222 If we try to handle that operation, we ignore those handlers. */
224 static Lisp_Object Vinhibit_file_name_handlers
;
225 static Lisp_Object Vinhibit_file_name_operation
;
227 Lisp_Object Qfile_error
, Qfile_already_exists
, Qfile_date_error
;
229 Lisp_Object Qfile_name_history
;
231 Lisp_Object Qcar_less_than_car
;
233 static int a_write
P_ ((int, char *, int, int,
234 Lisp_Object
*, struct coding_system
*));
235 static int e_write
P_ ((int, char *, int, struct coding_system
*));
238 report_file_error (string
, data
)
242 Lisp_Object errstring
;
244 errstring
= build_string (strerror (errno
));
246 /* System error messages are capitalized. Downcase the initial
247 unless it is followed by a slash. */
248 if (XSTRING (errstring
)->data
[1] != '/')
249 XSTRING (errstring
)->data
[0] = DOWNCASE (XSTRING (errstring
)->data
[0]);
252 Fsignal (Qfile_error
,
253 Fcons (build_string (string
), Fcons (errstring
, data
)));
257 close_file_unwind (fd
)
260 close (XFASTINT (fd
));
264 /* Restore point, having saved it as a marker. */
267 restore_point_unwind (location
)
268 Lisp_Object location
;
270 Fgoto_char (location
);
271 Fset_marker (location
, Qnil
, Qnil
);
275 Lisp_Object Qexpand_file_name
;
276 Lisp_Object Qsubstitute_in_file_name
;
277 Lisp_Object Qdirectory_file_name
;
278 Lisp_Object Qfile_name_directory
;
279 Lisp_Object Qfile_name_nondirectory
;
280 Lisp_Object Qunhandled_file_name_directory
;
281 Lisp_Object Qfile_name_as_directory
;
282 Lisp_Object Qcopy_file
;
283 Lisp_Object Qmake_directory_internal
;
284 Lisp_Object Qdelete_directory
;
285 Lisp_Object Qdelete_file
;
286 Lisp_Object Qrename_file
;
287 Lisp_Object Qadd_name_to_file
;
288 Lisp_Object Qmake_symbolic_link
;
289 Lisp_Object Qfile_exists_p
;
290 Lisp_Object Qfile_executable_p
;
291 Lisp_Object Qfile_readable_p
;
292 Lisp_Object Qfile_writable_p
;
293 Lisp_Object Qfile_symlink_p
;
294 Lisp_Object Qaccess_file
;
295 Lisp_Object Qfile_directory_p
;
296 Lisp_Object Qfile_regular_p
;
297 Lisp_Object Qfile_accessible_directory_p
;
298 Lisp_Object Qfile_modes
;
299 Lisp_Object Qset_file_modes
;
300 Lisp_Object Qfile_newer_than_file_p
;
301 Lisp_Object Qinsert_file_contents
;
302 Lisp_Object Qwrite_region
;
303 Lisp_Object Qverify_visited_file_modtime
;
304 Lisp_Object Qset_visited_file_modtime
;
306 DEFUN ("find-file-name-handler", Ffind_file_name_handler
, Sfind_file_name_handler
, 2, 2, 0,
307 "Return FILENAME's handler function for OPERATION, if it has one.\n\
308 Otherwise, return nil.\n\
309 A file name is handled if one of the regular expressions in\n\
310 `file-name-handler-alist' matches it.\n\n\
311 If OPERATION equals `inhibit-file-name-operation', then we ignore\n\
312 any handlers that are members of `inhibit-file-name-handlers',\n\
313 but we still do run any other handlers. This lets handlers\n\
314 use the standard functions without calling themselves recursively.")
315 (filename
, operation
)
316 Lisp_Object filename
, operation
;
318 /* This function must not munge the match data. */
319 Lisp_Object chain
, inhibited_handlers
;
321 CHECK_STRING (filename
, 0);
323 if (EQ (operation
, Vinhibit_file_name_operation
))
324 inhibited_handlers
= Vinhibit_file_name_handlers
;
326 inhibited_handlers
= Qnil
;
328 for (chain
= Vfile_name_handler_alist
; CONSP (chain
);
329 chain
= XCONS (chain
)->cdr
)
332 elt
= XCONS (chain
)->car
;
336 string
= XCONS (elt
)->car
;
337 if (STRINGP (string
) && fast_string_match (string
, filename
) >= 0)
339 Lisp_Object handler
, tem
;
341 handler
= XCONS (elt
)->cdr
;
342 tem
= Fmemq (handler
, inhibited_handlers
);
353 DEFUN ("file-name-directory", Ffile_name_directory
, Sfile_name_directory
,
355 "Return the directory component in file name FILENAME.\n\
356 Return nil if FILENAME does not include a directory.\n\
357 Otherwise return a directory spec.\n\
358 Given a Unix syntax file name, returns a string ending in slash;\n\
359 on VMS, perhaps instead a string ending in `:', `]' or `>'.")
361 Lisp_Object filename
;
363 register unsigned char *beg
;
364 register unsigned char *p
;
367 CHECK_STRING (filename
, 0);
369 /* If the file name has special constructs in it,
370 call the corresponding file handler. */
371 handler
= Ffind_file_name_handler (filename
, Qfile_name_directory
);
373 return call2 (handler
, Qfile_name_directory
, filename
);
375 #ifdef FILE_SYSTEM_CASE
376 filename
= FILE_SYSTEM_CASE (filename
);
378 beg
= XSTRING (filename
)->data
;
380 beg
= strcpy (alloca (strlen (beg
) + 1), beg
);
382 p
= beg
+ XSTRING (filename
)->size
;
384 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
386 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
389 /* only recognise drive specifier at beginning */
390 && !(p
[-1] == ':' && p
== beg
+ 2)
397 /* Expansion of "c:" to drive and default directory. */
398 if (p
== beg
+ 2 && beg
[1] == ':')
400 /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir. */
401 unsigned char *res
= alloca (MAXPATHLEN
+ 1);
402 if (getdefdir (toupper (*beg
) - 'A' + 1, res
))
404 if (!IS_DIRECTORY_SEP (res
[strlen (res
) - 1]))
407 p
= beg
+ strlen (beg
);
410 CORRECT_DIR_SEPS (beg
);
413 if (STRING_MULTIBYTE (filename
))
414 return make_string (beg
, p
- beg
);
415 return make_unibyte_string (beg
, p
- beg
);
418 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory
,
419 Sfile_name_nondirectory
, 1, 1, 0,
420 "Return file name FILENAME sans its directory.\n\
421 For example, in a Unix-syntax file name,\n\
422 this is everything after the last slash,\n\
423 or the entire name if it contains no slash.")
425 Lisp_Object filename
;
427 register unsigned char *beg
, *p
, *end
;
430 CHECK_STRING (filename
, 0);
432 /* If the file name has special constructs in it,
433 call the corresponding file handler. */
434 handler
= Ffind_file_name_handler (filename
, Qfile_name_nondirectory
);
436 return call2 (handler
, Qfile_name_nondirectory
, filename
);
438 beg
= XSTRING (filename
)->data
;
439 end
= p
= beg
+ XSTRING (filename
)->size
;
441 while (p
!= beg
&& !IS_DIRECTORY_SEP (p
[-1])
443 && p
[-1] != ':' && p
[-1] != ']' && p
[-1] != '>'
446 /* only recognise drive specifier at beginning */
447 && !(p
[-1] == ':' && p
== beg
+ 2)
452 if (STRING_MULTIBYTE (filename
))
453 return make_string (p
, end
- p
);
454 return make_unibyte_string (p
, end
- p
);
457 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory
,
458 Sunhandled_file_name_directory
, 1, 1, 0,
459 "Return a directly usable directory name somehow associated with FILENAME.\n\
460 A `directly usable' directory name is one that may be used without the\n\
461 intervention of any file handler.\n\
462 If FILENAME is a directly usable file itself, return\n\
463 \(file-name-directory FILENAME).\n\
464 The `call-process' and `start-process' functions use this function to\n\
465 get a current directory to run processes in.")
467 Lisp_Object filename
;
471 /* If the file name has special constructs in it,
472 call the corresponding file handler. */
473 handler
= Ffind_file_name_handler (filename
, Qunhandled_file_name_directory
);
475 return call2 (handler
, Qunhandled_file_name_directory
, filename
);
477 return Ffile_name_directory (filename
);
482 file_name_as_directory (out
, in
)
485 int size
= strlen (in
) - 1;
490 /* Is it already a directory string? */
491 if (in
[size
] == ':' || in
[size
] == ']' || in
[size
] == '>')
493 /* Is it a VMS directory file name? If so, hack VMS syntax. */
494 else if (! index (in
, '/')
495 && ((size
> 3 && ! strcmp (&in
[size
- 3], ".DIR"))
496 || (size
> 3 && ! strcmp (&in
[size
- 3], ".dir"))
497 || (size
> 5 && (! strncmp (&in
[size
- 5], ".DIR", 4)
498 || ! strncmp (&in
[size
- 5], ".dir", 4))
499 && (in
[size
- 1] == '.' || in
[size
- 1] == ';')
500 && in
[size
] == '1')))
502 register char *p
, *dot
;
506 dir:x.dir --> dir:[x]
507 dir:[x]y.dir --> dir:[x.y] */
509 while (p
!= in
&& *p
!= ':' && *p
!= '>' && *p
!= ']') p
--;
512 strncpy (out
, in
, p
- in
);
531 dot
= index (p
, '.');
534 /* blindly remove any extension */
535 size
= strlen (out
) + (dot
- p
);
536 strncat (out
, p
, dot
- p
);
547 /* For Unix syntax, Append a slash if necessary */
548 if (!IS_DIRECTORY_SEP (out
[size
]))
550 out
[size
+ 1] = DIRECTORY_SEP
;
551 out
[size
+ 2] = '\0';
554 CORRECT_DIR_SEPS (out
);
560 DEFUN ("file-name-as-directory", Ffile_name_as_directory
,
561 Sfile_name_as_directory
, 1, 1, 0,
562 "Return a string representing file FILENAME interpreted as a directory.\n\
563 This operation exists because a directory is also a file, but its name as\n\
564 a directory is different from its name as a file.\n\
565 The result can be used as the value of `default-directory'\n\
566 or passed as second argument to `expand-file-name'.\n\
567 For a Unix-syntax file name, just appends a slash.\n\
568 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
575 CHECK_STRING (file
, 0);
579 /* If the file name has special constructs in it,
580 call the corresponding file handler. */
581 handler
= Ffind_file_name_handler (file
, Qfile_name_as_directory
);
583 return call2 (handler
, Qfile_name_as_directory
, file
);
585 buf
= (char *) alloca (XSTRING (file
)->size
+ 10);
586 return build_string (file_name_as_directory (buf
, XSTRING (file
)->data
));
590 * Convert from directory name to filename.
592 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
593 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
594 * On UNIX, it's simple: just make sure there isn't a terminating /
596 * Value is nonzero if the string output is different from the input.
599 directory_file_name (src
, dst
)
607 struct FAB fab
= cc$rms_fab
;
608 struct NAM nam
= cc$rms_nam
;
609 char esa
[NAM$C_MAXRSS
];
614 if (! index (src
, '/')
615 && (src
[slen
- 1] == ']'
616 || src
[slen
- 1] == ':'
617 || src
[slen
- 1] == '>'))
619 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
621 fab
.fab$b_fns
= slen
;
622 fab
.fab$l_nam
= &nam
;
623 fab
.fab$l_fop
= FAB$M_NAM
;
626 nam
.nam$b_ess
= sizeof esa
;
627 nam
.nam$b_nop
|= NAM$M_SYNCHK
;
629 /* We call SYS$PARSE to handle such things as [--] for us. */
630 if (SYS$
PARSE (&fab
, 0, 0) == RMS$_NORMAL
)
632 slen
= nam
.nam$b_esl
;
633 if (esa
[slen
- 1] == ';' && esa
[slen
- 2] == '.')
638 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
640 /* what about when we have logical_name:???? */
641 if (src
[slen
- 1] == ':')
642 { /* Xlate logical name and see what we get */
643 ptr
= strcpy (dst
, src
); /* upper case for getenv */
646 if ('a' <= *ptr
&& *ptr
<= 'z')
650 dst
[slen
- 1] = 0; /* remove colon */
651 if (!(src
= egetenv (dst
)))
653 /* should we jump to the beginning of this procedure?
654 Good points: allows us to use logical names that xlate
656 Bad points: can be a problem if we just translated to a device
658 For now, I'll punt and always expect VMS names, and hope for
661 if (src
[slen
- 1] != ']' && src
[slen
- 1] != '>')
662 { /* no recursion here! */
668 { /* not a directory spec */
673 bracket
= src
[slen
- 1];
675 /* If bracket is ']' or '>', bracket - 2 is the corresponding
677 ptr
= index (src
, bracket
- 2);
679 { /* no opening bracket */
683 if (!(rptr
= rindex (src
, '.')))
686 strncpy (dst
, src
, slen
);
690 dst
[slen
++] = bracket
;
695 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
696 then translate the device and recurse. */
697 if (dst
[slen
- 1] == ':'
698 && dst
[slen
- 2] != ':' /* skip decnet nodes */
699 && strcmp (src
+ slen
, "[000000]") == 0)
701 dst
[slen
- 1] = '\0';
702 if ((ptr
= egetenv (dst
))
703 && (rlen
= strlen (ptr
) - 1) > 0
704 && (ptr
[rlen
] == ']' || ptr
[rlen
] == '>')
705 && ptr
[rlen
- 1] == '.')
707 char * buf
= (char *) alloca (strlen (ptr
) + 1);
711 return directory_file_name (buf
, dst
);
716 strcat (dst
, "[000000]");
720 rlen
= strlen (rptr
) - 1;
721 strncat (dst
, rptr
, rlen
);
722 dst
[slen
+ rlen
] = '\0';
723 strcat (dst
, ".DIR.1");
727 /* Process as Unix format: just remove any final slash.
728 But leave "/" unchanged; do not change it to "". */
731 /* Handle // as root for apollo's. */
732 if ((slen
> 2 && dst
[slen
- 1] == '/')
733 || (slen
> 1 && dst
[0] != '/' && dst
[slen
- 1] == '/'))
737 && IS_DIRECTORY_SEP (dst
[slen
- 1])
739 && !IS_ANY_SEP (dst
[slen
- 2])
745 CORRECT_DIR_SEPS (dst
);
750 DEFUN ("directory-file-name", Fdirectory_file_name
, Sdirectory_file_name
,
752 "Returns the file name of the directory named DIRECTORY.\n\
753 This is the name of the file that holds the data for the directory DIRECTORY.\n\
754 This operation exists because a directory is also a file, but its name as\n\
755 a directory is different from its name as a file.\n\
756 In Unix-syntax, this function just removes the final slash.\n\
757 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
758 it returns a file name such as \"[X]Y.DIR.1\".")
760 Lisp_Object directory
;
765 CHECK_STRING (directory
, 0);
767 if (NILP (directory
))
770 /* If the file name has special constructs in it,
771 call the corresponding file handler. */
772 handler
= Ffind_file_name_handler (directory
, Qdirectory_file_name
);
774 return call2 (handler
, Qdirectory_file_name
, directory
);
777 /* 20 extra chars is insufficient for VMS, since we might perform a
778 logical name translation. an equivalence string can be up to 255
779 chars long, so grab that much extra space... - sss */
780 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20 + 255);
782 buf
= (char *) alloca (XSTRING (directory
)->size
+ 20);
784 directory_file_name (XSTRING (directory
)->data
, buf
);
785 return build_string (buf
);
788 DEFUN ("make-temp-name", Fmake_temp_name
, Smake_temp_name
, 1, 1, 0,
789 "Generate temporary file name (string) starting with PREFIX (a string).\n\
790 The Emacs process number forms part of the result,\n\
791 so there is no danger of generating a name being used by another process.\n\
792 In addition, this function makes an attempt to choose a name\n\
793 which has no existing file.")
799 /* Don't use too many characters of the restricted 8+3 DOS
801 val
= concat2 (prefix
, build_string ("a.XXX"));
803 val
= concat2 (prefix
, build_string ("XXXXXX"));
805 mktemp (XSTRING (val
)->data
);
807 CORRECT_DIR_SEPS (XSTRING (val
)->data
);
812 DEFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
813 "Convert filename NAME to absolute, and canonicalize it.\n\
814 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative\n\
815 (does not start with slash); if DEFAULT-DIRECTORY is nil or missing,\n\
816 the current buffer's value of default-directory is used.\n\
817 File name components that are `.' are removed, and \n\
818 so are file name components followed by `..', along with the `..' itself;\n\
819 note that these simplifications are done without checking the resulting\n\
820 file names in the file system.\n\
821 An initial `~/' expands to your home directory.\n\
822 An initial `~USER/' expands to USER's home directory.\n\
823 See also the function `substitute-in-file-name'.")
824 (name
, default_directory
)
825 Lisp_Object name
, default_directory
;
829 register unsigned char *newdir
, *p
, *o
;
831 unsigned char *target
;
834 unsigned char * colon
= 0;
835 unsigned char * close
= 0;
836 unsigned char * slash
= 0;
837 unsigned char * brack
= 0;
838 int lbrack
= 0, rbrack
= 0;
843 int collapse_newdir
= 1;
848 CHECK_STRING (name
, 0);
850 /* If the file name has special constructs in it,
851 call the corresponding file handler. */
852 handler
= Ffind_file_name_handler (name
, Qexpand_file_name
);
854 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
856 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */
857 if (NILP (default_directory
))
858 default_directory
= current_buffer
->directory
;
859 if (! STRINGP (default_directory
))
860 default_directory
= build_string ("/");
862 if (!NILP (default_directory
))
864 handler
= Ffind_file_name_handler (default_directory
, Qexpand_file_name
);
866 return call3 (handler
, Qexpand_file_name
, name
, default_directory
);
869 o
= XSTRING (default_directory
)->data
;
871 /* Make sure DEFAULT_DIRECTORY is properly expanded.
872 It would be better to do this down below where we actually use
873 default_directory. Unfortunately, calling Fexpand_file_name recursively
874 could invoke GC, and the strings might be relocated. This would
875 be annoying because we have pointers into strings lying around
876 that would need adjusting, and people would add new pointers to
877 the code and forget to adjust them, resulting in intermittent bugs.
878 Putting this call here avoids all that crud.
880 The EQ test avoids infinite recursion. */
881 if (! NILP (default_directory
) && !EQ (default_directory
, name
)
882 /* Save time in some common cases - as long as default_directory
883 is not relative, it can be canonicalized with name below (if it
884 is needed at all) without requiring it to be expanded now. */
886 /* Detect MSDOS file names with drive specifiers. */
887 && ! (IS_DRIVE (o
[0]) && (IS_DEVICE_SEP (o
[1]) && IS_DIRECTORY_SEP (o
[2])))
889 /* Detect Windows file names in UNC format. */
890 && ! (IS_DIRECTORY_SEP (o
[0]) && IS_DIRECTORY_SEP (o
[1]))
892 #else /* not DOS_NT */
893 /* Detect Unix absolute file names (/... alone is not absolute on
895 && ! (IS_DIRECTORY_SEP (o
[0]))
896 #endif /* not DOS_NT */
902 default_directory
= Fexpand_file_name (default_directory
, Qnil
);
907 /* Filenames on VMS are always upper case. */
908 name
= Fupcase (name
);
910 #ifdef FILE_SYSTEM_CASE
911 name
= FILE_SYSTEM_CASE (name
);
914 nm
= XSTRING (name
)->data
;
917 /* We will force directory separators to be either all \ or /, so make
918 a local copy to modify, even if there ends up being no change. */
919 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
921 /* Find and remove drive specifier if present; this makes nm absolute
922 even if the rest of the name appears to be relative. */
924 unsigned char *colon
= rindex (nm
, ':');
927 /* Only recognize colon as part of drive specifier if there is a
928 single alphabetic character preceeding the colon (and if the
929 character before the drive letter, if present, is a directory
930 separator); this is to support the remote system syntax used by
931 ange-ftp, and the "po:username" syntax for POP mailboxes. */
935 else if (IS_DRIVE (colon
[-1])
936 && (colon
== nm
+ 1 || IS_DIRECTORY_SEP (colon
[-2])))
943 while (--colon
>= nm
)
950 /* If we see "c://somedir", we want to strip the first slash after the
951 colon when stripping the drive letter. Otherwise, this expands to
953 if (drive
&& IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
955 #endif /* WINDOWSNT */
959 /* Discard any previous drive specifier if nm is now in UNC format. */
960 if (IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
966 /* If nm is absolute, look for /./ or /../ sequences; if none are
967 found, we can probably return right away. We will avoid allocating
968 a new string if name is already fully expanded. */
970 IS_DIRECTORY_SEP (nm
[0])
975 && (drive
|| IS_DIRECTORY_SEP (nm
[1]))
982 /* If it turns out that the filename we want to return is just a
983 suffix of FILENAME, we don't need to go through and edit
984 things; we just need to construct a new string using data
985 starting at the middle of FILENAME. If we set lose to a
986 non-zero value, that means we've discovered that we can't do
993 /* Since we know the name is absolute, we can assume that each
994 element starts with a "/". */
996 /* "." and ".." are hairy. */
997 if (IS_DIRECTORY_SEP (p
[0])
999 && (IS_DIRECTORY_SEP (p
[2])
1001 || (p
[2] == '.' && (IS_DIRECTORY_SEP (p
[3])
1008 /* if dev:[dir]/, move nm to / */
1009 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1010 nm
= (brack
? brack
+ 1 : colon
+ 1);
1011 lbrack
= rbrack
= 0;
1019 /* VMS pre V4.4,convert '-'s in filenames. */
1020 if (lbrack
== rbrack
)
1022 if (dots
< 2) /* this is to allow negative version numbers */
1027 if (lbrack
> rbrack
&&
1028 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1029 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1035 /* count open brackets, reset close bracket pointer */
1036 if (p
[0] == '[' || p
[0] == '<')
1037 lbrack
++, brack
= 0;
1038 /* count close brackets, set close bracket pointer */
1039 if (p
[0] == ']' || p
[0] == '>')
1040 rbrack
++, brack
= p
;
1041 /* detect ][ or >< */
1042 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1044 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1045 nm
= p
+ 1, lose
= 1;
1046 if (p
[0] == ':' && (colon
|| slash
))
1047 /* if dev1:[dir]dev2:, move nm to dev2: */
1053 /* if /name/dev:, move nm to dev: */
1056 /* if node::dev:, move colon following dev */
1057 else if (colon
&& colon
[-1] == ':')
1059 /* if dev1:dev2:, move nm to dev2: */
1060 else if (colon
&& colon
[-1] != ':')
1065 if (p
[0] == ':' && !colon
)
1071 if (lbrack
== rbrack
)
1074 else if (p
[0] == '.')
1082 if (index (nm
, '/'))
1083 return build_string (sys_translate_unix (nm
));
1086 /* Make sure directories are all separated with / or \ as
1087 desired, but avoid allocation of a new string when not
1089 CORRECT_DIR_SEPS (nm
);
1091 if (IS_DIRECTORY_SEP (nm
[1]))
1093 if (strcmp (nm
, XSTRING (name
)->data
) != 0)
1094 name
= build_string (nm
);
1098 /* drive must be set, so this is okay */
1099 if (strcmp (nm
- 2, XSTRING (name
)->data
) != 0)
1101 name
= make_string (nm
- 2, p
- nm
+ 2);
1102 XSTRING (name
)->data
[0] = DRIVE_LETTER (drive
);
1103 XSTRING (name
)->data
[1] = ':';
1106 #else /* not DOS_NT */
1107 if (nm
== XSTRING (name
)->data
)
1109 return build_string (nm
);
1110 #endif /* not DOS_NT */
1114 /* At this point, nm might or might not be an absolute file name. We
1115 need to expand ~ or ~user if present, otherwise prefix nm with
1116 default_directory if nm is not absolute, and finally collapse /./
1117 and /foo/../ sequences.
1119 We set newdir to be the appropriate prefix if one is needed:
1120 - the relevant user directory if nm starts with ~ or ~user
1121 - the specified drive's working dir (DOS/NT only) if nm does not
1123 - the value of default_directory.
1125 Note that these prefixes are not guaranteed to be absolute (except
1126 for the working dir of a drive). Therefore, to ensure we always
1127 return an absolute name, if the final prefix is not absolute we
1128 append it to the current working directory. */
1132 if (nm
[0] == '~') /* prefix ~ */
1134 if (IS_DIRECTORY_SEP (nm
[1])
1138 || nm
[1] == 0) /* ~ by itself */
1140 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1141 newdir
= (unsigned char *) "";
1144 collapse_newdir
= 0;
1147 nm
++; /* Don't leave the slash in nm. */
1150 else /* ~user/filename */
1152 for (p
= nm
; *p
&& (!IS_DIRECTORY_SEP (*p
)
1157 o
= (unsigned char *) alloca (p
- nm
+ 1);
1158 bcopy ((char *) nm
, o
, p
- nm
);
1161 pw
= (struct passwd
*) getpwnam (o
+ 1);
1164 newdir
= (unsigned char *) pw
-> pw_dir
;
1166 nm
= p
+ 1; /* skip the terminator */
1170 collapse_newdir
= 0;
1175 /* If we don't find a user of that name, leave the name
1176 unchanged; don't move nm forward to p. */
1181 /* On DOS and Windows, nm is absolute if a drive name was specified;
1182 use the drive's current directory as the prefix if needed. */
1183 if (!newdir
&& drive
)
1185 /* Get default directory if needed to make nm absolute. */
1186 if (!IS_DIRECTORY_SEP (nm
[0]))
1188 newdir
= alloca (MAXPATHLEN
+ 1);
1189 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1194 /* Either nm starts with /, or drive isn't mounted. */
1195 newdir
= alloca (4);
1196 newdir
[0] = DRIVE_LETTER (drive
);
1204 /* Finally, if no prefix has been specified and nm is not absolute,
1205 then it must be expanded relative to default_directory. */
1209 /* /... alone is not absolute on DOS and Windows. */
1210 && !IS_DIRECTORY_SEP (nm
[0])
1213 && !(IS_DIRECTORY_SEP (nm
[0]) && IS_DIRECTORY_SEP (nm
[1]))
1220 newdir
= XSTRING (default_directory
)->data
;
1226 /* First ensure newdir is an absolute name. */
1228 /* Detect MSDOS file names with drive specifiers. */
1229 ! (IS_DRIVE (newdir
[0])
1230 && IS_DEVICE_SEP (newdir
[1]) && IS_DIRECTORY_SEP (newdir
[2]))
1232 /* Detect Windows file names in UNC format. */
1233 && ! (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1237 /* Effectively, let newdir be (expand-file-name newdir cwd).
1238 Because of the admonition against calling expand-file-name
1239 when we have pointers into lisp strings, we accomplish this
1240 indirectly by prepending newdir to nm if necessary, and using
1241 cwd (or the wd of newdir's drive) as the new newdir. */
1243 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1248 if (!IS_DIRECTORY_SEP (nm
[0]))
1250 char * tmp
= alloca (strlen (newdir
) + strlen (nm
) + 2);
1251 file_name_as_directory (tmp
, newdir
);
1255 newdir
= alloca (MAXPATHLEN
+ 1);
1258 if (!getdefdir (toupper (drive
) - 'A' + 1, newdir
))
1265 /* Strip off drive name from prefix, if present. */
1266 if (IS_DRIVE (newdir
[0]) && newdir
[1] == ':')
1272 /* Keep only a prefix from newdir if nm starts with slash
1273 (//server/share for UNC, nothing otherwise). */
1274 if (IS_DIRECTORY_SEP (nm
[0]) && collapse_newdir
)
1277 if (IS_DIRECTORY_SEP (newdir
[0]) && IS_DIRECTORY_SEP (newdir
[1]))
1279 newdir
= strcpy (alloca (strlen (newdir
) + 1), newdir
);
1281 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1283 while (*p
&& !IS_DIRECTORY_SEP (*p
)) p
++;
1295 /* Get rid of any slash at the end of newdir, unless newdir is
1296 just // (an incomplete UNC name). */
1297 length
= strlen (newdir
);
1298 if (length
> 0 && IS_DIRECTORY_SEP (newdir
[length
- 1])
1300 && !(length
== 2 && IS_DIRECTORY_SEP (newdir
[0]))
1304 unsigned char *temp
= (unsigned char *) alloca (length
);
1305 bcopy (newdir
, temp
, length
- 1);
1306 temp
[length
- 1] = 0;
1314 /* Now concatenate the directory and name to new space in the stack frame */
1315 tlen
+= strlen (nm
) + 1;
1317 /* Add reserved space for drive name. (The Microsoft x86 compiler
1318 produces incorrect code if the following two lines are combined.) */
1319 target
= (unsigned char *) alloca (tlen
+ 2);
1321 #else /* not DOS_NT */
1322 target
= (unsigned char *) alloca (tlen
);
1323 #endif /* not DOS_NT */
1329 if (nm
[0] == 0 || IS_DIRECTORY_SEP (nm
[0]))
1330 strcpy (target
, newdir
);
1333 file_name_as_directory (target
, newdir
);
1336 strcat (target
, nm
);
1338 if (index (target
, '/'))
1339 strcpy (target
, sys_translate_unix (target
));
1342 /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */
1344 /* Now canonicalize by removing /. and /foo/.. if they appear. */
1352 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1358 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1359 /* brackets are offset from each other by 2 */
1362 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1363 /* convert [foo][bar] to [bar] */
1364 while (o
[-1] != '[' && o
[-1] != '<')
1366 else if (*p
== '-' && *o
!= '.')
1369 else if (p
[0] == '-' && o
[-1] == '.' &&
1370 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1371 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1375 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1376 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1378 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1380 /* else [foo.-] ==> [-] */
1386 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1387 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1393 if (!IS_DIRECTORY_SEP (*p
))
1397 else if (IS_DIRECTORY_SEP (p
[0])
1399 && (IS_DIRECTORY_SEP (p
[2])
1402 /* If "/." is the entire filename, keep the "/". Otherwise,
1403 just delete the whole "/.". */
1404 if (o
== target
&& p
[2] == '\0')
1408 else if (IS_DIRECTORY_SEP (p
[0]) && p
[1] == '.' && p
[2] == '.'
1409 /* `/../' is the "superroot" on certain file systems. */
1411 && (IS_DIRECTORY_SEP (p
[3]) || p
[3] == 0))
1413 while (o
!= target
&& (--o
) && !IS_DIRECTORY_SEP (*o
))
1415 /* Keep initial / only if this is the whole name. */
1416 if (o
== target
&& IS_ANY_SEP (*o
) && p
[3] == 0)
1424 #endif /* not VMS */
1428 /* At last, set drive name. */
1430 /* Except for network file name. */
1431 if (!(IS_DIRECTORY_SEP (target
[0]) && IS_DIRECTORY_SEP (target
[1])))
1432 #endif /* WINDOWSNT */
1434 if (!drive
) abort ();
1436 target
[0] = DRIVE_LETTER (drive
);
1439 CORRECT_DIR_SEPS (target
);
1442 return make_string (target
, o
- target
);
1446 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'. */
1447 DEAFUN ("expand-file-name", Fexpand_file_name
, Sexpand_file_name
, 1, 2, 0,
1448 "Convert FILENAME to absolute, and canonicalize it.\n\
1449 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
1450 (does not start with slash); if DEFAULT is nil or missing,\n\
1451 the current buffer's value of default-directory is used.\n\
1452 Filenames containing `.' or `..' as components are simplified;\n\
1453 initial `~/' expands to your home directory.\n\
1454 See also the function `substitute-in-file-name'.")
1456 Lisp_Object name
, defalt
;
1460 register unsigned char *newdir
, *p
, *o
;
1462 unsigned char *target
;
1466 unsigned char * colon
= 0;
1467 unsigned char * close
= 0;
1468 unsigned char * slash
= 0;
1469 unsigned char * brack
= 0;
1470 int lbrack
= 0, rbrack
= 0;
1474 CHECK_STRING (name
, 0);
1477 /* Filenames on VMS are always upper case. */
1478 name
= Fupcase (name
);
1481 nm
= XSTRING (name
)->data
;
1483 /* If nm is absolute, flush ...// and detect /./ and /../.
1484 If no /./ or /../ we can return right away. */
1496 if (p
[0] == '/' && p
[1] == '/'
1498 /* // at start of filename is meaningful on Apollo system. */
1503 if (p
[0] == '/' && p
[1] == '~')
1504 nm
= p
+ 1, lose
= 1;
1505 if (p
[0] == '/' && p
[1] == '.'
1506 && (p
[2] == '/' || p
[2] == 0
1507 || (p
[2] == '.' && (p
[3] == '/' || p
[3] == 0))))
1513 /* if dev:[dir]/, move nm to / */
1514 if (!slash
&& p
> nm
&& (brack
|| colon
)) {
1515 nm
= (brack
? brack
+ 1 : colon
+ 1);
1516 lbrack
= rbrack
= 0;
1524 /* VMS pre V4.4,convert '-'s in filenames. */
1525 if (lbrack
== rbrack
)
1527 if (dots
< 2) /* this is to allow negative version numbers */
1532 if (lbrack
> rbrack
&&
1533 ((p
[-1] == '.' || p
[-1] == '[' || p
[-1] == '<') &&
1534 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>')))
1540 /* count open brackets, reset close bracket pointer */
1541 if (p
[0] == '[' || p
[0] == '<')
1542 lbrack
++, brack
= 0;
1543 /* count close brackets, set close bracket pointer */
1544 if (p
[0] == ']' || p
[0] == '>')
1545 rbrack
++, brack
= p
;
1546 /* detect ][ or >< */
1547 if ((p
[0] == ']' || p
[0] == '>') && (p
[1] == '[' || p
[1] == '<'))
1549 if ((p
[0] == ':' || p
[0] == ']' || p
[0] == '>') && p
[1] == '~')
1550 nm
= p
+ 1, lose
= 1;
1551 if (p
[0] == ':' && (colon
|| slash
))
1552 /* if dev1:[dir]dev2:, move nm to dev2: */
1558 /* If /name/dev:, move nm to dev: */
1561 /* If node::dev:, move colon following dev */
1562 else if (colon
&& colon
[-1] == ':')
1564 /* If dev1:dev2:, move nm to dev2: */
1565 else if (colon
&& colon
[-1] != ':')
1570 if (p
[0] == ':' && !colon
)
1576 if (lbrack
== rbrack
)
1579 else if (p
[0] == '.')
1587 if (index (nm
, '/'))
1588 return build_string (sys_translate_unix (nm
));
1590 if (nm
== XSTRING (name
)->data
)
1592 return build_string (nm
);
1596 /* Now determine directory to start with and put it in NEWDIR */
1600 if (nm
[0] == '~') /* prefix ~ */
1605 || nm
[1] == 0)/* ~/filename */
1607 if (!(newdir
= (unsigned char *) egetenv ("HOME")))
1608 newdir
= (unsigned char *) "";
1611 nm
++; /* Don't leave the slash in nm. */
1614 else /* ~user/filename */
1616 /* Get past ~ to user */
1617 unsigned char *user
= nm
+ 1;
1618 /* Find end of name. */
1619 unsigned char *ptr
= (unsigned char *) index (user
, '/');
1620 int len
= ptr
? ptr
- user
: strlen (user
);
1622 unsigned char *ptr1
= index (user
, ':');
1623 if (ptr1
!= 0 && ptr1
- user
< len
)
1626 /* Copy the user name into temp storage. */
1627 o
= (unsigned char *) alloca (len
+ 1);
1628 bcopy ((char *) user
, o
, len
);
1631 /* Look up the user name. */
1632 pw
= (struct passwd
*) getpwnam (o
+ 1);
1634 error ("\"%s\" isn't a registered user", o
+ 1);
1636 newdir
= (unsigned char *) pw
->pw_dir
;
1638 /* Discard the user name from NM. */
1645 #endif /* not VMS */
1649 defalt
= current_buffer
->directory
;
1650 CHECK_STRING (defalt
, 1);
1651 newdir
= XSTRING (defalt
)->data
;
1654 /* Now concatenate the directory and name to new space in the stack frame */
1656 tlen
= (newdir
? strlen (newdir
) + 1 : 0) + strlen (nm
) + 1;
1657 target
= (unsigned char *) alloca (tlen
);
1663 if (nm
[0] == 0 || nm
[0] == '/')
1664 strcpy (target
, newdir
);
1667 file_name_as_directory (target
, newdir
);
1670 strcat (target
, nm
);
1672 if (index (target
, '/'))
1673 strcpy (target
, sys_translate_unix (target
));
1676 /* Now canonicalize by removing /. and /foo/.. if they appear */
1684 if (*p
!= ']' && *p
!= '>' && *p
!= '-')
1690 else if ((p
[0] == ']' || p
[0] == '>') && p
[0] == p
[1] + 2)
1691 /* brackets are offset from each other by 2 */
1694 if (*p
!= '.' && *p
!= '-' && o
[-1] != '.')
1695 /* convert [foo][bar] to [bar] */
1696 while (o
[-1] != '[' && o
[-1] != '<')
1698 else if (*p
== '-' && *o
!= '.')
1701 else if (p
[0] == '-' && o
[-1] == '.' &&
1702 (p
[1] == '.' || p
[1] == ']' || p
[1] == '>'))
1703 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1707 while (o
[-1] != '.' && o
[-1] != '[' && o
[-1] != '<');
1708 if (p
[1] == '.') /* foo.-.bar ==> bar. */
1710 else if (o
[-1] == '.') /* '.foo.-]' ==> ']' */
1712 /* else [foo.-] ==> [-] */
1718 o
[-1] != '[' && o
[-1] != '<' && o
[-1] != '.' &&
1719 p
[1] != ']' && p
[1] != '>' && p
[1] != '.')
1729 else if (!strncmp (p
, "//", 2)
1731 /* // at start of filename is meaningful in Apollo system. */
1739 else if (p
[0] == '/' && p
[1] == '.' &&
1740 (p
[2] == '/' || p
[2] == 0))
1742 else if (!strncmp (p
, "/..", 3)
1743 /* `/../' is the "superroot" on certain file systems. */
1745 && (p
[3] == '/' || p
[3] == 0))
1747 while (o
!= target
&& *--o
!= '/')
1750 if (o
== target
+ 1 && o
[-1] == '/' && o
[0] == '/')
1754 if (o
== target
&& *o
== '/')
1762 #endif /* not VMS */
1765 return make_string (target
, o
- target
);
1769 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name
,
1770 Ssubstitute_in_file_name
, 1, 1, 0,
1771 "Substitute environment variables referred to in FILENAME.\n\
1772 `$FOO' where FOO is an environment variable name means to substitute\n\
1773 the value of that variable. The variable name should be terminated\n\
1774 with a character not a letter, digit or underscore; otherwise, enclose\n\
1775 the entire variable name in braces.\n\
1776 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1777 On VMS, `$' substitution is not done; this function does little and only\n\
1778 duplicates what `expand-file-name' does.")
1780 Lisp_Object filename
;
1784 register unsigned char *s
, *p
, *o
, *x
, *endp
;
1785 unsigned char *target
;
1787 int substituted
= 0;
1789 Lisp_Object handler
;
1791 CHECK_STRING (filename
, 0);
1793 /* If the file name has special constructs in it,
1794 call the corresponding file handler. */
1795 handler
= Ffind_file_name_handler (filename
, Qsubstitute_in_file_name
);
1796 if (!NILP (handler
))
1797 return call2 (handler
, Qsubstitute_in_file_name
, filename
);
1799 nm
= XSTRING (filename
)->data
;
1801 nm
= strcpy (alloca (strlen (nm
) + 1), nm
);
1802 CORRECT_DIR_SEPS (nm
);
1803 substituted
= (strcmp (nm
, XSTRING (filename
)->data
) != 0);
1805 endp
= nm
+ XSTRING (filename
)->size
;
1807 /* If /~ or // appears, discard everything through first slash. */
1809 for (p
= nm
; p
!= endp
; p
++)
1812 #if defined (APOLLO) || defined (WINDOWSNT)
1813 /* // at start of file name is meaningful in Apollo and
1814 WindowsNT systems. */
1815 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != nm
)
1816 #else /* not (APOLLO || WINDOWSNT) */
1817 || IS_DIRECTORY_SEP (p
[0])
1818 #endif /* not (APOLLO || WINDOWSNT) */
1823 || p
[-1] == ':' || p
[-1] == ']' || p
[-1] == '>'
1825 || IS_DIRECTORY_SEP (p
[-1])))
1831 /* see comment in expand-file-name about drive specifiers */
1832 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
1833 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
1842 return build_string (nm
);
1845 /* See if any variables are substituted into the string
1846 and find the total length of their values in `total' */
1848 for (p
= nm
; p
!= endp
;)
1858 /* "$$" means a single "$" */
1867 while (p
!= endp
&& *p
!= '}') p
++;
1868 if (*p
!= '}') goto missingclose
;
1874 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1878 /* Copy out the variable name */
1879 target
= (unsigned char *) alloca (s
- o
+ 1);
1880 strncpy (target
, o
, s
- o
);
1883 strupr (target
); /* $home == $HOME etc. */
1886 /* Get variable value */
1887 o
= (unsigned char *) egetenv (target
);
1888 if (!o
) goto badvar
;
1889 total
+= strlen (o
);
1896 /* If substitution required, recopy the string and do it */
1897 /* Make space in stack frame for the new copy */
1898 xnm
= (unsigned char *) alloca (XSTRING (filename
)->size
+ total
+ 1);
1901 /* Copy the rest of the name through, replacing $ constructs with values */
1918 while (p
!= endp
&& *p
!= '}') p
++;
1919 if (*p
!= '}') goto missingclose
;
1925 while (p
!= endp
&& (isalnum (*p
) || *p
== '_')) p
++;
1929 /* Copy out the variable name */
1930 target
= (unsigned char *) alloca (s
- o
+ 1);
1931 strncpy (target
, o
, s
- o
);
1934 strupr (target
); /* $home == $HOME etc. */
1937 /* Get variable value */
1938 o
= (unsigned char *) egetenv (target
);
1942 if (STRING_MULTIBYTE (filename
))
1944 /* If the original string is multibyte,
1945 convert what we substitute into multibyte. */
1946 unsigned char workbuf
[4], *str
;
1948 extern int nonascii_insert_offset
;
1955 c
+= nonascii_insert_offset
;
1956 len
= CHAR_STRING (c
, workbuf
, str
);
1957 bcopy (str
, x
, len
);
1973 /* If /~ or // appears, discard everything through first slash. */
1975 for (p
= xnm
; p
!= x
; p
++)
1977 #if defined (APOLLO) || defined (WINDOWSNT)
1978 || (IS_DIRECTORY_SEP (p
[0]) && p
- 1 != xnm
)
1979 #else /* not (APOLLO || WINDOWSNT) */
1980 || IS_DIRECTORY_SEP (p
[0])
1981 #endif /* not (APOLLO || WINDOWSNT) */
1983 && p
!= xnm
&& IS_DIRECTORY_SEP (p
[-1]))
1986 else if (IS_DRIVE (p
[0]) && p
[1] == ':'
1987 && p
> nm
&& IS_DIRECTORY_SEP (p
[-1]))
1991 if (STRING_MULTIBYTE (filename
))
1992 return make_string (xnm
, x
- xnm
);
1993 return make_unibyte_string (xnm
, x
- xnm
);
1996 error ("Bad format environment-variable substitution");
1998 error ("Missing \"}\" in environment-variable substitution");
2000 error ("Substituting nonexistent environment variable \"%s\"", target
);
2003 #endif /* not VMS */
2006 /* A slightly faster and more convenient way to get
2007 (directory-file-name (expand-file-name FOO)). */
2010 expand_and_dir_to_file (filename
, defdir
)
2011 Lisp_Object filename
, defdir
;
2013 register Lisp_Object absname
;
2015 absname
= Fexpand_file_name (filename
, defdir
);
2018 register int c
= XSTRING (absname
)->data
[XSTRING (absname
)->size
- 1];
2019 if (c
== ':' || c
== ']' || c
== '>')
2020 absname
= Fdirectory_file_name (absname
);
2023 /* Remove final slash, if any (unless this is the root dir).
2024 stat behaves differently depending! */
2025 if (XSTRING (absname
)->size
> 1
2026 && IS_DIRECTORY_SEP (XSTRING (absname
)->data
[XSTRING (absname
)->size
- 1])
2027 && !IS_DEVICE_SEP (XSTRING (absname
)->data
[XSTRING (absname
)->size
-2]))
2028 /* We cannot take shortcuts; they might be wrong for magic file names. */
2029 absname
= Fdirectory_file_name (absname
);
2034 /* Signal an error if the file ABSNAME already exists.
2035 If INTERACTIVE is nonzero, ask the user whether to proceed,
2036 and bypass the error if the user says to go ahead.
2037 QUERYSTRING is a name for the action that is being considered
2039 *STATPTR is used to store the stat information if the file exists.
2040 If the file does not exist, STATPTR->st_mode is set to 0. */
2043 barf_or_query_if_file_exists (absname
, querystring
, interactive
, statptr
)
2044 Lisp_Object absname
;
2045 unsigned char *querystring
;
2047 struct stat
*statptr
;
2049 register Lisp_Object tem
;
2050 struct stat statbuf
;
2051 struct gcpro gcpro1
;
2053 /* stat is a good way to tell whether the file exists,
2054 regardless of what access permissions it has. */
2055 if (stat (XSTRING (absname
)->data
, &statbuf
) >= 0)
2058 Fsignal (Qfile_already_exists
,
2059 Fcons (build_string ("File already exists"),
2060 Fcons (absname
, Qnil
)));
2062 tem
= do_yes_or_no_p (format1 ("File %s already exists; %s anyway? ",
2063 XSTRING (absname
)->data
, querystring
));
2066 Fsignal (Qfile_already_exists
,
2067 Fcons (build_string ("File already exists"),
2068 Fcons (absname
, Qnil
)));
2075 statptr
->st_mode
= 0;
2080 DEFUN ("copy-file", Fcopy_file
, Scopy_file
, 2, 4,
2081 "fCopy file: \nFCopy %s to file: \np\nP",
2082 "Copy FILE to NEWNAME. Both args must be strings.\n\
2083 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
2084 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
2085 A number as third arg means request confirmation if NEWNAME already exists.\n\
2086 This is what happens in interactive use with M-x.\n\
2087 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
2088 last-modified time as the old one. (This works on only some systems.)\n\
2089 A prefix arg makes KEEP-TIME non-nil.")
2090 (file
, newname
, ok_if_already_exists
, keep_date
)
2091 Lisp_Object file
, newname
, ok_if_already_exists
, keep_date
;
2094 char buf
[16 * 1024];
2095 struct stat st
, out_st
;
2096 Lisp_Object handler
;
2097 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2098 int count
= specpdl_ptr
- specpdl
;
2099 int input_file_statable_p
;
2100 Lisp_Object encoded_file
, encoded_newname
;
2102 encoded_file
= encoded_newname
= Qnil
;
2103 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2104 CHECK_STRING (file
, 0);
2105 CHECK_STRING (newname
, 1);
2107 file
= Fexpand_file_name (file
, Qnil
);
2108 newname
= Fexpand_file_name (newname
, Qnil
);
2110 /* If the input file name has special constructs in it,
2111 call the corresponding file handler. */
2112 handler
= Ffind_file_name_handler (file
, Qcopy_file
);
2113 /* Likewise for output file name. */
2115 handler
= Ffind_file_name_handler (newname
, Qcopy_file
);
2116 if (!NILP (handler
))
2117 RETURN_UNGCPRO (call5 (handler
, Qcopy_file
, file
, newname
,
2118 ok_if_already_exists
, keep_date
));
2120 encoded_file
= ENCODE_FILE (file
);
2121 encoded_newname
= ENCODE_FILE (newname
);
2123 if (NILP (ok_if_already_exists
)
2124 || INTEGERP (ok_if_already_exists
))
2125 barf_or_query_if_file_exists (encoded_newname
, "copy to it",
2126 INTEGERP (ok_if_already_exists
), &out_st
);
2127 else if (stat (XSTRING (encoded_newname
)->data
, &out_st
) < 0)
2130 ifd
= open (XSTRING (encoded_file
)->data
, O_RDONLY
);
2132 report_file_error ("Opening input file", Fcons (file
, Qnil
));
2134 record_unwind_protect (close_file_unwind
, make_number (ifd
));
2136 /* We can only copy regular files and symbolic links. Other files are not
2138 input_file_statable_p
= (fstat (ifd
, &st
) >= 0);
2140 #if !defined (MSDOS) || __DJGPP__ > 1
2141 if (out_st
.st_mode
!= 0
2142 && st
.st_dev
== out_st
.st_dev
&& st
.st_ino
== out_st
.st_ino
)
2145 report_file_error ("Input and output files are the same",
2146 Fcons (file
, Fcons (newname
, Qnil
)));
2150 #if defined (S_ISREG) && defined (S_ISLNK)
2151 if (input_file_statable_p
)
2153 if (!(S_ISREG (st
.st_mode
)) && !(S_ISLNK (st
.st_mode
)))
2155 #if defined (EISDIR)
2156 /* Get a better looking error message. */
2159 report_file_error ("Non-regular file", Fcons (file
, Qnil
));
2162 #endif /* S_ISREG && S_ISLNK */
2165 /* Create the copy file with the same record format as the input file */
2166 ofd
= sys_creat (XSTRING (encoded_newname
)->data
, 0666, ifd
);
2169 /* System's default file type was set to binary by _fmode in emacs.c. */
2170 ofd
= creat (XSTRING (encoded_newname
)->data
, S_IREAD
| S_IWRITE
);
2171 #else /* not MSDOS */
2172 ofd
= creat (XSTRING (encoded_newname
)->data
, 0666);
2173 #endif /* not MSDOS */
2176 report_file_error ("Opening output file", Fcons (newname
, Qnil
));
2178 record_unwind_protect (close_file_unwind
, make_number (ofd
));
2182 while ((n
= read (ifd
, buf
, sizeof buf
)) > 0)
2183 if (write (ofd
, buf
, n
) != n
)
2184 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2187 /* Closing the output clobbers the file times on some systems. */
2188 if (close (ofd
) < 0)
2189 report_file_error ("I/O error", Fcons (newname
, Qnil
));
2191 if (input_file_statable_p
)
2193 if (!NILP (keep_date
))
2195 EMACS_TIME atime
, mtime
;
2196 EMACS_SET_SECS_USECS (atime
, st
.st_atime
, 0);
2197 EMACS_SET_SECS_USECS (mtime
, st
.st_mtime
, 0);
2198 if (set_file_times (XSTRING (encoded_newname
)->data
,
2200 Fsignal (Qfile_date_error
,
2201 Fcons (build_string ("Cannot set file date"),
2202 Fcons (newname
, Qnil
)));
2205 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2207 #if defined (__DJGPP__) && __DJGPP__ > 1
2208 /* In DJGPP v2.0 and later, fstat usually returns true file mode bits,
2209 and if it can't, it tells so. Otherwise, under MSDOS we usually
2210 get only the READ bit, which will make the copied file read-only,
2211 so it's better not to chmod at all. */
2212 if ((_djstat_flags
& _STFAIL_WRITEBIT
) == 0)
2213 chmod (XSTRING (encoded_newname
)->data
, st
.st_mode
& 07777);
2214 #endif /* DJGPP version 2 or newer */
2220 /* Discard the unwind protects. */
2221 specpdl_ptr
= specpdl
+ count
;
2227 DEFUN ("make-directory-internal", Fmake_directory_internal
,
2228 Smake_directory_internal
, 1, 1, 0,
2229 "Create a new directory named DIRECTORY.")
2231 Lisp_Object directory
;
2234 Lisp_Object handler
;
2235 Lisp_Object encoded_dir
;
2237 CHECK_STRING (directory
, 0);
2238 directory
= Fexpand_file_name (directory
, Qnil
);
2240 handler
= Ffind_file_name_handler (directory
, Qmake_directory_internal
);
2241 if (!NILP (handler
))
2242 return call2 (handler
, Qmake_directory_internal
, directory
);
2244 encoded_dir
= ENCODE_FILE (directory
);
2246 dir
= XSTRING (encoded_dir
)->data
;
2249 if (mkdir (dir
) != 0)
2251 if (mkdir (dir
, 0777) != 0)
2253 report_file_error ("Creating directory", Flist (1, &directory
));
2258 DEFUN ("delete-directory", Fdelete_directory
, Sdelete_directory
, 1, 1, "FDelete directory: ",
2259 "Delete the directory named DIRECTORY.")
2261 Lisp_Object directory
;
2264 Lisp_Object handler
;
2265 Lisp_Object encoded_dir
;
2267 CHECK_STRING (directory
, 0);
2268 directory
= Fdirectory_file_name (Fexpand_file_name (directory
, Qnil
));
2270 handler
= Ffind_file_name_handler (directory
, Qdelete_directory
);
2271 if (!NILP (handler
))
2272 return call2 (handler
, Qdelete_directory
, directory
);
2274 encoded_dir
= ENCODE_FILE (directory
);
2276 dir
= XSTRING (encoded_dir
)->data
;
2278 if (rmdir (dir
) != 0)
2279 report_file_error ("Removing directory", Flist (1, &directory
));
2284 DEFUN ("delete-file", Fdelete_file
, Sdelete_file
, 1, 1, "fDelete file: ",
2285 "Delete file named FILENAME.\n\
2286 If file has multiple names, it continues to exist with the other names.")
2288 Lisp_Object filename
;
2290 Lisp_Object handler
;
2291 Lisp_Object encoded_file
;
2293 CHECK_STRING (filename
, 0);
2294 filename
= Fexpand_file_name (filename
, Qnil
);
2296 handler
= Ffind_file_name_handler (filename
, Qdelete_file
);
2297 if (!NILP (handler
))
2298 return call2 (handler
, Qdelete_file
, filename
);
2300 encoded_file
= ENCODE_FILE (filename
);
2302 if (0 > unlink (XSTRING (encoded_file
)->data
))
2303 report_file_error ("Removing old name", Flist (1, &filename
));
2308 internal_delete_file_1 (ignore
)
2314 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */
2317 internal_delete_file (filename
)
2318 Lisp_Object filename
;
2320 return NILP (internal_condition_case_1 (Fdelete_file
, filename
,
2321 Qt
, internal_delete_file_1
));
2324 DEFUN ("rename-file", Frename_file
, Srename_file
, 2, 3,
2325 "fRename file: \nFRename %s to file: \np",
2326 "Rename FILE as NEWNAME. Both args strings.\n\
2327 If file has names other than FILE, it continues to have those names.\n\
2328 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2329 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2330 A number as third arg means request confirmation if NEWNAME already exists.\n\
2331 This is what happens in interactive use with M-x.")
2332 (file
, newname
, ok_if_already_exists
)
2333 Lisp_Object file
, newname
, ok_if_already_exists
;
2336 Lisp_Object args
[2];
2338 Lisp_Object handler
;
2339 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2340 Lisp_Object encoded_file
, encoded_newname
;
2342 encoded_file
= encoded_newname
= Qnil
;
2343 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2344 CHECK_STRING (file
, 0);
2345 CHECK_STRING (newname
, 1);
2346 file
= Fexpand_file_name (file
, Qnil
);
2347 newname
= Fexpand_file_name (newname
, Qnil
);
2349 /* If the file name has special constructs in it,
2350 call the corresponding file handler. */
2351 handler
= Ffind_file_name_handler (file
, Qrename_file
);
2353 handler
= Ffind_file_name_handler (newname
, Qrename_file
);
2354 if (!NILP (handler
))
2355 RETURN_UNGCPRO (call4 (handler
, Qrename_file
,
2356 file
, newname
, ok_if_already_exists
));
2358 encoded_file
= ENCODE_FILE (file
);
2359 encoded_newname
= ENCODE_FILE (newname
);
2361 if (NILP (ok_if_already_exists
)
2362 || INTEGERP (ok_if_already_exists
))
2363 barf_or_query_if_file_exists (encoded_newname
, "rename to it",
2364 INTEGERP (ok_if_already_exists
), 0);
2366 if (0 > rename (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2368 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
)
2369 || 0 > unlink (XSTRING (encoded_file
)->data
))
2374 Fcopy_file (file
, newname
,
2375 /* We have already prompted if it was an integer,
2376 so don't have copy-file prompt again. */
2377 NILP (ok_if_already_exists
) ? Qnil
: Qt
, Qt
);
2378 Fdelete_file (file
);
2385 report_file_error ("Renaming", Flist (2, args
));
2388 report_file_error ("Renaming", Flist (2, &file
));
2395 DEFUN ("add-name-to-file", Fadd_name_to_file
, Sadd_name_to_file
, 2, 3,
2396 "fAdd name to file: \nFName to add to %s: \np",
2397 "Give FILE additional name NEWNAME. Both args strings.\n\
2398 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
2399 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2400 A number as third arg means request confirmation if NEWNAME already exists.\n\
2401 This is what happens in interactive use with M-x.")
2402 (file
, newname
, ok_if_already_exists
)
2403 Lisp_Object file
, newname
, ok_if_already_exists
;
2406 Lisp_Object args
[2];
2408 Lisp_Object handler
;
2409 Lisp_Object encoded_file
, encoded_newname
;
2410 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2412 GCPRO4 (file
, newname
, encoded_file
, encoded_newname
);
2413 encoded_file
= encoded_newname
= Qnil
;
2414 CHECK_STRING (file
, 0);
2415 CHECK_STRING (newname
, 1);
2416 file
= Fexpand_file_name (file
, Qnil
);
2417 newname
= Fexpand_file_name (newname
, Qnil
);
2419 /* If the file name has special constructs in it,
2420 call the corresponding file handler. */
2421 handler
= Ffind_file_name_handler (file
, Qadd_name_to_file
);
2422 if (!NILP (handler
))
2423 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2424 newname
, ok_if_already_exists
));
2426 /* If the new name has special constructs in it,
2427 call the corresponding file handler. */
2428 handler
= Ffind_file_name_handler (newname
, Qadd_name_to_file
);
2429 if (!NILP (handler
))
2430 RETURN_UNGCPRO (call4 (handler
, Qadd_name_to_file
, file
,
2431 newname
, ok_if_already_exists
));
2433 encoded_file
= ENCODE_FILE (file
);
2434 encoded_newname
= ENCODE_FILE (newname
);
2436 if (NILP (ok_if_already_exists
)
2437 || INTEGERP (ok_if_already_exists
))
2438 barf_or_query_if_file_exists (encoded_newname
, "make it a new name",
2439 INTEGERP (ok_if_already_exists
), 0);
2441 unlink (XSTRING (newname
)->data
);
2442 if (0 > link (XSTRING (encoded_file
)->data
, XSTRING (encoded_newname
)->data
))
2447 report_file_error ("Adding new name", Flist (2, args
));
2449 report_file_error ("Adding new name", Flist (2, &file
));
2458 DEFUN ("make-symbolic-link", Fmake_symbolic_link
, Smake_symbolic_link
, 2, 3,
2459 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
2460 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
2461 Signals a `file-already-exists' error if a file LINKNAME already exists\n\
2462 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
2463 A number as third arg means request confirmation if LINKNAME already exists.\n\
2464 This happens for interactive use with M-x.")
2465 (filename
, linkname
, ok_if_already_exists
)
2466 Lisp_Object filename
, linkname
, ok_if_already_exists
;
2469 Lisp_Object args
[2];
2471 Lisp_Object handler
;
2472 Lisp_Object encoded_filename
, encoded_linkname
;
2473 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
2475 GCPRO4 (filename
, linkname
, encoded_filename
, encoded_linkname
);
2476 encoded_filename
= encoded_linkname
= Qnil
;
2477 CHECK_STRING (filename
, 0);
2478 CHECK_STRING (linkname
, 1);
2479 /* If the link target has a ~, we must expand it to get
2480 a truly valid file name. Otherwise, do not expand;
2481 we want to permit links to relative file names. */
2482 if (XSTRING (filename
)->data
[0] == '~')
2483 filename
= Fexpand_file_name (filename
, Qnil
);
2484 linkname
= Fexpand_file_name (linkname
, Qnil
);
2486 /* If the file name has special constructs in it,
2487 call the corresponding file handler. */
2488 handler
= Ffind_file_name_handler (filename
, Qmake_symbolic_link
);
2489 if (!NILP (handler
))
2490 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2491 linkname
, ok_if_already_exists
));
2493 /* If the new link name has special constructs in it,
2494 call the corresponding file handler. */
2495 handler
= Ffind_file_name_handler (linkname
, Qmake_symbolic_link
);
2496 if (!NILP (handler
))
2497 RETURN_UNGCPRO (call4 (handler
, Qmake_symbolic_link
, filename
,
2498 linkname
, ok_if_already_exists
));
2500 encoded_filename
= ENCODE_FILE (filename
);
2501 encoded_linkname
= ENCODE_FILE (linkname
);
2503 if (NILP (ok_if_already_exists
)
2504 || INTEGERP (ok_if_already_exists
))
2505 barf_or_query_if_file_exists (encoded_linkname
, "make it a link",
2506 INTEGERP (ok_if_already_exists
), 0);
2507 if (0 > symlink (XSTRING (encoded_filename
)->data
,
2508 XSTRING (encoded_linkname
)->data
))
2510 /* If we didn't complain already, silently delete existing file. */
2511 if (errno
== EEXIST
)
2513 unlink (XSTRING (encoded_linkname
)->data
);
2514 if (0 <= symlink (XSTRING (encoded_filename
)->data
,
2515 XSTRING (encoded_linkname
)->data
))
2525 report_file_error ("Making symbolic link", Flist (2, args
));
2527 report_file_error ("Making symbolic link", Flist (2, &filename
));
2533 #endif /* S_IFLNK */
2537 DEFUN ("define-logical-name", Fdefine_logical_name
, Sdefine_logical_name
,
2538 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
2539 "Define the job-wide logical name NAME to have the value STRING.\n\
2540 If STRING is nil or a null string, the logical name NAME is deleted.")
2545 CHECK_STRING (name
, 0);
2547 delete_logical_name (XSTRING (name
)->data
);
2550 CHECK_STRING (string
, 1);
2552 if (XSTRING (string
)->size
== 0)
2553 delete_logical_name (XSTRING (name
)->data
);
2555 define_logical_name (XSTRING (name
)->data
, XSTRING (string
)->data
);
2564 DEFUN ("sysnetunam", Fsysnetunam
, Ssysnetunam
, 2, 2, 0,
2565 "Open a network connection to PATH using LOGIN as the login string.")
2567 Lisp_Object path
, login
;
2571 CHECK_STRING (path
, 0);
2572 CHECK_STRING (login
, 0);
2574 netresult
= netunam (XSTRING (path
)->data
, XSTRING (login
)->data
);
2576 if (netresult
== -1)
2581 #endif /* HPUX_NET */
2583 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p
, Sfile_name_absolute_p
,
2585 "Return t if file FILENAME specifies an absolute file name.\n\
2586 On Unix, this is a name starting with a `/' or a `~'.")
2588 Lisp_Object filename
;
2592 CHECK_STRING (filename
, 0);
2593 ptr
= XSTRING (filename
)->data
;
2594 if (IS_DIRECTORY_SEP (*ptr
) || *ptr
== '~'
2596 /* ??? This criterion is probably wrong for '<'. */
2597 || index (ptr
, ':') || index (ptr
, '<')
2598 || (*ptr
== '[' && (ptr
[1] != '-' || (ptr
[2] != '.' && ptr
[2] != ']'))
2602 || (IS_DRIVE (*ptr
) && ptr
[1] == ':' && IS_DIRECTORY_SEP (ptr
[2]))
2610 /* Return nonzero if file FILENAME exists and can be executed. */
2613 check_executable (filename
)
2617 int len
= strlen (filename
);
2620 if (stat (filename
, &st
) < 0)
2622 #if defined (WINDOWSNT) || (defined (MSDOS) && __DJGPP__ > 1)
2623 return ((st
.st_mode
& S_IEXEC
) != 0);
2625 return (S_ISREG (st
.st_mode
)
2627 && (stricmp ((suffix
= filename
+ len
-4), ".com") == 0
2628 || stricmp (suffix
, ".exe") == 0
2629 || stricmp (suffix
, ".bat") == 0)
2630 || (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2631 #endif /* not WINDOWSNT */
2632 #else /* not DOS_NT */
2633 #ifdef HAVE_EUIDACCESS
2634 return (euidaccess (filename
, 1) >= 0);
2636 /* Access isn't quite right because it uses the real uid
2637 and we really want to test with the effective uid.
2638 But Unix doesn't give us a right way to do it. */
2639 return (access (filename
, 1) >= 0);
2641 #endif /* not DOS_NT */
2644 /* Return nonzero if file FILENAME exists and can be written. */
2647 check_writable (filename
)
2652 if (stat (filename
, &st
) < 0)
2654 return (st
.st_mode
& S_IWRITE
|| (st
.st_mode
& S_IFMT
) == S_IFDIR
);
2655 #else /* not MSDOS */
2656 #ifdef HAVE_EUIDACCESS
2657 return (euidaccess (filename
, 2) >= 0);
2659 /* Access isn't quite right because it uses the real uid
2660 and we really want to test with the effective uid.
2661 But Unix doesn't give us a right way to do it.
2662 Opening with O_WRONLY could work for an ordinary file,
2663 but would lose for directories. */
2664 return (access (filename
, 2) >= 0);
2666 #endif /* not MSDOS */
2669 DEFUN ("file-exists-p", Ffile_exists_p
, Sfile_exists_p
, 1, 1, 0,
2670 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
2671 See also `file-readable-p' and `file-attributes'.")
2673 Lisp_Object filename
;
2675 Lisp_Object absname
;
2676 Lisp_Object handler
;
2677 struct stat statbuf
;
2679 CHECK_STRING (filename
, 0);
2680 absname
= Fexpand_file_name (filename
, Qnil
);
2682 /* If the file name has special constructs in it,
2683 call the corresponding file handler. */
2684 handler
= Ffind_file_name_handler (absname
, Qfile_exists_p
);
2685 if (!NILP (handler
))
2686 return call2 (handler
, Qfile_exists_p
, absname
);
2688 absname
= ENCODE_FILE (absname
);
2690 return (stat (XSTRING (absname
)->data
, &statbuf
) >= 0) ? Qt
: Qnil
;
2693 DEFUN ("file-executable-p", Ffile_executable_p
, Sfile_executable_p
, 1, 1, 0,
2694 "Return t if FILENAME can be executed by you.\n\
2695 For a directory, this means you can access files in that directory.")
2697 Lisp_Object filename
;
2700 Lisp_Object absname
;
2701 Lisp_Object handler
;
2703 CHECK_STRING (filename
, 0);
2704 absname
= Fexpand_file_name (filename
, Qnil
);
2706 /* If the file name has special constructs in it,
2707 call the corresponding file handler. */
2708 handler
= Ffind_file_name_handler (absname
, Qfile_executable_p
);
2709 if (!NILP (handler
))
2710 return call2 (handler
, Qfile_executable_p
, absname
);
2712 absname
= ENCODE_FILE (absname
);
2714 return (check_executable (XSTRING (absname
)->data
) ? Qt
: Qnil
);
2717 DEFUN ("file-readable-p", Ffile_readable_p
, Sfile_readable_p
, 1, 1, 0,
2718 "Return t if file FILENAME exists and you can read it.\n\
2719 See also `file-exists-p' and `file-attributes'.")
2721 Lisp_Object filename
;
2723 Lisp_Object absname
;
2724 Lisp_Object handler
;
2727 struct stat statbuf
;
2729 CHECK_STRING (filename
, 0);
2730 absname
= Fexpand_file_name (filename
, Qnil
);
2732 /* If the file name has special constructs in it,
2733 call the corresponding file handler. */
2734 handler
= Ffind_file_name_handler (absname
, Qfile_readable_p
);
2735 if (!NILP (handler
))
2736 return call2 (handler
, Qfile_readable_p
, absname
);
2738 absname
= ENCODE_FILE (absname
);
2741 /* Under MS-DOS and Windows, open does not work for directories. */
2742 if (access (XSTRING (absname
)->data
, 0) == 0)
2745 #else /* not DOS_NT */
2747 #if defined (S_ISFIFO) && defined (O_NONBLOCK)
2748 /* Opening a fifo without O_NONBLOCK can wait.
2749 We don't want to wait. But we don't want to mess wth O_NONBLOCK
2750 except in the case of a fifo, on a system which handles it. */
2751 desc
= stat (XSTRING (absname
)->data
, &statbuf
);
2754 if (S_ISFIFO (statbuf
.st_mode
))
2755 flags
|= O_NONBLOCK
;
2757 desc
= open (XSTRING (absname
)->data
, flags
);
2762 #endif /* not DOS_NT */
2765 /* Having this before file-symlink-p mysteriously caused it to be forgotten
2767 DEFUN ("file-writable-p", Ffile_writable_p
, Sfile_writable_p
, 1, 1, 0,
2768 "Return t if file FILENAME can be written or created by you.")
2770 Lisp_Object filename
;
2772 Lisp_Object absname
, dir
, encoded
;
2773 Lisp_Object handler
;
2774 struct stat statbuf
;
2776 CHECK_STRING (filename
, 0);
2777 absname
= Fexpand_file_name (filename
, Qnil
);
2779 /* If the file name has special constructs in it,
2780 call the corresponding file handler. */
2781 handler
= Ffind_file_name_handler (absname
, Qfile_writable_p
);
2782 if (!NILP (handler
))
2783 return call2 (handler
, Qfile_writable_p
, absname
);
2785 encoded
= ENCODE_FILE (absname
);
2786 if (stat (XSTRING (encoded
)->data
, &statbuf
) >= 0)
2787 return (check_writable (XSTRING (encoded
)->data
)
2790 dir
= Ffile_name_directory (absname
);
2793 dir
= Fdirectory_file_name (dir
);
2797 dir
= Fdirectory_file_name (dir
);
2800 dir
= ENCODE_FILE (dir
);
2801 return (check_writable (!NILP (dir
) ? (char *) XSTRING (dir
)->data
: "")
2805 DEFUN ("access-file", Faccess_file
, Saccess_file
, 2, 2, 0,
2806 "Access file FILENAME, and get an error if that does not work.\n\
2807 The second argument STRING is used in the error message.\n\
2808 If there is no error, we return nil.")
2810 Lisp_Object filename
, string
;
2812 Lisp_Object handler
, encoded_filename
;
2815 CHECK_STRING (filename
, 0);
2817 /* If the file name has special constructs in it,
2818 call the corresponding file handler. */
2819 handler
= Ffind_file_name_handler (filename
, Qaccess_file
);
2820 if (!NILP (handler
))
2821 return call3 (handler
, Qaccess_file
, filename
, string
);
2823 encoded_filename
= ENCODE_FILE (filename
);
2825 fd
= open (XSTRING (encoded_filename
)->data
, O_RDONLY
);
2827 report_file_error (XSTRING (string
)->data
, Fcons (filename
, Qnil
));
2833 DEFUN ("file-symlink-p", Ffile_symlink_p
, Sfile_symlink_p
, 1, 1, 0,
2834 "Return non-nil if file FILENAME is the name of a symbolic link.\n\
2835 The value is the name of the file to which it is linked.\n\
2836 Otherwise returns nil.")
2838 Lisp_Object filename
;
2845 Lisp_Object handler
;
2847 CHECK_STRING (filename
, 0);
2848 filename
= Fexpand_file_name (filename
, Qnil
);
2850 /* If the file name has special constructs in it,
2851 call the corresponding file handler. */
2852 handler
= Ffind_file_name_handler (filename
, Qfile_symlink_p
);
2853 if (!NILP (handler
))
2854 return call2 (handler
, Qfile_symlink_p
, filename
);
2856 filename
= ENCODE_FILE (filename
);
2861 buf
= (char *) xmalloc (bufsize
);
2862 bzero (buf
, bufsize
);
2863 valsize
= readlink (XSTRING (filename
)->data
, buf
, bufsize
);
2864 if (valsize
< bufsize
) break;
2865 /* Buffer was not long enough */
2874 val
= make_string (buf
, valsize
);
2876 return Fdecode_coding_string (val
, Vfile_name_coding_system
, Qt
);
2877 #else /* not S_IFLNK */
2879 #endif /* not S_IFLNK */
2882 DEFUN ("file-directory-p", Ffile_directory_p
, Sfile_directory_p
, 1, 1, 0,
2883 "Return t if FILENAME names an existing directory.")
2885 Lisp_Object filename
;
2887 register Lisp_Object absname
;
2889 Lisp_Object handler
;
2891 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2893 /* If the file name has special constructs in it,
2894 call the corresponding file handler. */
2895 handler
= Ffind_file_name_handler (absname
, Qfile_directory_p
);
2896 if (!NILP (handler
))
2897 return call2 (handler
, Qfile_directory_p
, absname
);
2899 absname
= ENCODE_FILE (absname
);
2901 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2903 return (st
.st_mode
& S_IFMT
) == S_IFDIR
? Qt
: Qnil
;
2906 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p
, Sfile_accessible_directory_p
, 1, 1, 0,
2907 "Return t if file FILENAME is the name of a directory as a file,\n\
2908 and files in that directory can be opened by you. In order to use a\n\
2909 directory as a buffer's current directory, this predicate must return true.\n\
2910 A directory name spec may be given instead; then the value is t\n\
2911 if the directory so specified exists and really is a readable and\n\
2912 searchable directory.")
2914 Lisp_Object filename
;
2916 Lisp_Object handler
;
2918 struct gcpro gcpro1
;
2920 /* If the file name has special constructs in it,
2921 call the corresponding file handler. */
2922 handler
= Ffind_file_name_handler (filename
, Qfile_accessible_directory_p
);
2923 if (!NILP (handler
))
2924 return call2 (handler
, Qfile_accessible_directory_p
, filename
);
2926 /* It's an unlikely combination, but yes we really do need to gcpro:
2927 Suppose that file-accessible-directory-p has no handler, but
2928 file-directory-p does have a handler; this handler causes a GC which
2929 relocates the string in `filename'; and finally file-directory-p
2930 returns non-nil. Then we would end up passing a garbaged string
2931 to file-executable-p. */
2933 tem
= (NILP (Ffile_directory_p (filename
))
2934 || NILP (Ffile_executable_p (filename
)));
2936 return tem
? Qnil
: Qt
;
2939 DEFUN ("file-regular-p", Ffile_regular_p
, Sfile_regular_p
, 1, 1, 0,
2940 "Return t if file FILENAME is the name of a regular file.\n\
2941 This is the sort of file that holds an ordinary stream of data bytes.")
2943 Lisp_Object filename
;
2945 register Lisp_Object absname
;
2947 Lisp_Object handler
;
2949 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2951 /* If the file name has special constructs in it,
2952 call the corresponding file handler. */
2953 handler
= Ffind_file_name_handler (absname
, Qfile_regular_p
);
2954 if (!NILP (handler
))
2955 return call2 (handler
, Qfile_regular_p
, absname
);
2957 absname
= ENCODE_FILE (absname
);
2959 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2961 return (st
.st_mode
& S_IFMT
) == S_IFREG
? Qt
: Qnil
;
2964 DEFUN ("file-modes", Ffile_modes
, Sfile_modes
, 1, 1, 0,
2965 "Return mode bits of file named FILENAME, as an integer.")
2967 Lisp_Object filename
;
2969 Lisp_Object absname
;
2971 Lisp_Object handler
;
2973 absname
= expand_and_dir_to_file (filename
, current_buffer
->directory
);
2975 /* If the file name has special constructs in it,
2976 call the corresponding file handler. */
2977 handler
= Ffind_file_name_handler (absname
, Qfile_modes
);
2978 if (!NILP (handler
))
2979 return call2 (handler
, Qfile_modes
, absname
);
2981 absname
= ENCODE_FILE (absname
);
2983 if (stat (XSTRING (absname
)->data
, &st
) < 0)
2985 #if defined (MSDOS) && __DJGPP__ < 2
2986 if (check_executable (XSTRING (absname
)->data
))
2987 st
.st_mode
|= S_IEXEC
;
2988 #endif /* MSDOS && __DJGPP__ < 2 */
2990 return make_number (st
.st_mode
& 07777);
2993 DEFUN ("set-file-modes", Fset_file_modes
, Sset_file_modes
, 2, 2, 0,
2994 "Set mode bits of file named FILENAME to MODE (an integer).\n\
2995 Only the 12 low bits of MODE are used.")
2997 Lisp_Object filename
, mode
;
2999 Lisp_Object absname
, encoded_absname
;
3000 Lisp_Object handler
;
3002 absname
= Fexpand_file_name (filename
, current_buffer
->directory
);
3003 CHECK_NUMBER (mode
, 1);
3005 /* If the file name has special constructs in it,
3006 call the corresponding file handler. */
3007 handler
= Ffind_file_name_handler (absname
, Qset_file_modes
);
3008 if (!NILP (handler
))
3009 return call3 (handler
, Qset_file_modes
, absname
, mode
);
3011 encoded_absname
= ENCODE_FILE (absname
);
3013 if (chmod (XSTRING (encoded_absname
)->data
, XINT (mode
)) < 0)
3014 report_file_error ("Doing chmod", Fcons (absname
, Qnil
));
3019 DEFUN ("set-default-file-modes", Fset_default_file_modes
, Sset_default_file_modes
, 1, 1, 0,
3020 "Set the file permission bits for newly created files.\n\
3021 The argument MODE should be an integer; only the low 9 bits are used.\n\
3022 This setting is inherited by subprocesses.")
3026 CHECK_NUMBER (mode
, 0);
3028 umask ((~ XINT (mode
)) & 0777);
3033 DEFUN ("default-file-modes", Fdefault_file_modes
, Sdefault_file_modes
, 0, 0, 0,
3034 "Return the default file protection for created files.\n\
3035 The value is an integer.")
3041 realmask
= umask (0);
3044 XSETINT (value
, (~ realmask
) & 0777);
3050 DEFUN ("unix-sync", Funix_sync
, Sunix_sync
, 0, 0, "",
3051 "Tell Unix to finish all pending disk updates.")
3060 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p
, Sfile_newer_than_file_p
, 2, 2, 0,
3061 "Return t if file FILE1 is newer than file FILE2.\n\
3062 If FILE1 does not exist, the answer is nil;\n\
3063 otherwise, if FILE2 does not exist, the answer is t.")
3065 Lisp_Object file1
, file2
;
3067 Lisp_Object absname1
, absname2
;
3070 Lisp_Object handler
;
3071 struct gcpro gcpro1
, gcpro2
;
3073 CHECK_STRING (file1
, 0);
3074 CHECK_STRING (file2
, 0);
3077 GCPRO2 (absname1
, file2
);
3078 absname1
= expand_and_dir_to_file (file1
, current_buffer
->directory
);
3079 absname2
= expand_and_dir_to_file (file2
, current_buffer
->directory
);
3082 /* If the file name has special constructs in it,
3083 call the corresponding file handler. */
3084 handler
= Ffind_file_name_handler (absname1
, Qfile_newer_than_file_p
);
3086 handler
= Ffind_file_name_handler (absname2
, Qfile_newer_than_file_p
);
3087 if (!NILP (handler
))
3088 return call3 (handler
, Qfile_newer_than_file_p
, absname1
, absname2
);
3090 GCPRO2 (absname1
, absname2
);
3091 absname1
= ENCODE_FILE (absname1
);
3092 absname2
= ENCODE_FILE (absname2
);
3095 if (stat (XSTRING (absname1
)->data
, &st
) < 0)
3098 mtime1
= st
.st_mtime
;
3100 if (stat (XSTRING (absname2
)->data
, &st
) < 0)
3103 return (mtime1
> st
.st_mtime
) ? Qt
: Qnil
;
3107 Lisp_Object Qfind_buffer_file_type
;
3110 #ifndef READ_BUF_SIZE
3111 #define READ_BUF_SIZE (64 << 10)
3114 DEFUN ("insert-file-contents", Finsert_file_contents
, Sinsert_file_contents
,
3116 "Insert contents of file FILENAME after point.\n\
3117 Returns list of absolute file name and number of bytes inserted.\n\
3118 If second argument VISIT is non-nil, the buffer's visited filename\n\
3119 and last save file modtime are set, and it is marked unmodified.\n\
3120 If visiting and the file does not exist, visiting is completed\n\
3121 before the error is signaled.\n\
3122 The optional third and fourth arguments BEG and END\n\
3123 specify what portion of the file to insert.\n\
3124 These arguments count bytes in the file, not characters in the buffer.\n\
3125 If VISIT is non-nil, BEG and END must be nil.\n\
3127 If optional fifth argument REPLACE is non-nil,\n\
3128 it means replace the current buffer contents (in the accessible portion)\n\
3129 with the file contents. This is better than simply deleting and inserting\n\
3130 the whole thing because (1) it preserves some marker positions\n\
3131 and (2) it puts less data in the undo list.\n\
3132 When REPLACE is non-nil, the value is the number of characters actually read,\n\
3133 which is often less than the number of characters to be read.\n\
3134 This does code conversion according to the value of\n\
3135 `coding-system-for-read' or `file-coding-system-alist',\n\
3136 and sets the variable `last-coding-system-used' to the coding system\n\
3138 (filename
, visit
, beg
, end
, replace
)
3139 Lisp_Object filename
, visit
, beg
, end
, replace
;
3144 int inserted_chars
= 0;
3145 register int how_much
;
3146 register int unprocessed
;
3147 int count
= specpdl_ptr
- specpdl
;
3148 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
;
3149 Lisp_Object handler
, val
, insval
, orig_filename
;
3152 int not_regular
= 0;
3153 char read_buf
[READ_BUF_SIZE
];
3154 struct coding_system coding
;
3155 unsigned char buffer
[1 << 14];
3156 int replace_handled
= 0;
3157 int set_coding_system
= 0;
3159 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3160 error ("Cannot do file visiting in an indirect buffer");
3162 if (!NILP (current_buffer
->read_only
))
3163 Fbarf_if_buffer_read_only ();
3167 orig_filename
= Qnil
;
3169 GCPRO4 (filename
, val
, p
, orig_filename
);
3171 CHECK_STRING (filename
, 0);
3172 filename
= Fexpand_file_name (filename
, Qnil
);
3174 /* If the file name has special constructs in it,
3175 call the corresponding file handler. */
3176 handler
= Ffind_file_name_handler (filename
, Qinsert_file_contents
);
3177 if (!NILP (handler
))
3179 val
= call6 (handler
, Qinsert_file_contents
, filename
,
3180 visit
, beg
, end
, replace
);
3184 orig_filename
= filename
;
3185 filename
= ENCODE_FILE (filename
);
3190 if (stat (XSTRING (filename
)->data
, &st
) < 0)
3192 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0
3193 || fstat (fd
, &st
) < 0)
3194 #endif /* not APOLLO */
3196 if (fd
>= 0) close (fd
);
3199 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3202 if (!NILP (Vcoding_system_for_read
))
3203 current_buffer
->buffer_file_coding_system
= Vcoding_system_for_read
;
3208 /* This code will need to be changed in order to work on named
3209 pipes, and it's probably just not worth it. So we should at
3210 least signal an error. */
3211 if (!S_ISREG (st
.st_mode
))
3218 if (! NILP (replace
) || ! NILP (beg
) || ! NILP (end
))
3219 Fsignal (Qfile_error
,
3220 Fcons (build_string ("not a regular file"),
3221 Fcons (orig_filename
, Qnil
)));
3226 if ((fd
= open (XSTRING (filename
)->data
, O_RDONLY
)) < 0)
3229 /* Replacement should preserve point as it preserves markers. */
3230 if (!NILP (replace
))
3231 record_unwind_protect (restore_point_unwind
, Fpoint_marker ());
3233 record_unwind_protect (close_file_unwind
, make_number (fd
));
3235 /* Supposedly happens on VMS. */
3236 if (! not_regular
&& st
.st_size
< 0)
3237 error ("File size is negative");
3239 if (!NILP (beg
) || !NILP (end
))
3241 error ("Attempt to visit less than an entire file");
3244 CHECK_NUMBER (beg
, 0);
3246 XSETFASTINT (beg
, 0);
3249 CHECK_NUMBER (end
, 0);
3254 XSETINT (end
, st
.st_size
);
3255 if (XINT (end
) != st
.st_size
)
3256 error ("Maximum buffer size exceeded");
3260 /* Decide the coding-system of the file. */
3262 Lisp_Object val
= Qnil
;
3264 if (!NILP (Vcoding_system_for_read
))
3265 val
= Vcoding_system_for_read
;
3266 else if (NILP (current_buffer
->enable_multibyte_characters
))
3270 if (! NILP (Vset_auto_coding_function
))
3272 /* Find a coding system specified in the heading two lines
3273 or in the tailing several lines of the file. We assume
3274 that the 1K-byte and 3K-byte for heading and tailing
3275 respectively are sufficient fot this purpose. */
3276 int how_many
, nread
;
3278 if (st
.st_size
<= (1024 * 4))
3279 nread
= read (fd
, read_buf
, 1024 * 4);
3282 nread
= read (fd
, read_buf
, 1024);
3285 if (lseek (fd
, st
.st_size
- (1024 * 3), 0) < 0)
3286 report_file_error ("Setting file position",
3287 Fcons (orig_filename
, Qnil
));
3288 nread
+= read (fd
, read_buf
+ nread
, 1024 * 3);
3293 error ("IO error reading %s: %s",
3294 XSTRING (orig_filename
)->data
, strerror (errno
));
3298 /* Always make this a unibyte string
3299 because we have not yet decoded it. */
3300 tem
= make_unibyte_string (read_buf
, nread
);
3301 val
= call1 (Vset_auto_coding_function
, tem
);
3302 /* Rewind the file for the actual read done later. */
3303 if (lseek (fd
, 0, 0) < 0)
3304 report_file_error ("Setting file position",
3305 Fcons (orig_filename
, Qnil
));
3310 Lisp_Object args
[6], coding_systems
;
3312 args
[0] = Qinsert_file_contents
, args
[1] = orig_filename
,
3313 args
[2] = visit
, args
[3] = beg
, args
[4] = end
, args
[5] = replace
;
3314 coding_systems
= Ffind_operation_coding_system (6, args
);
3315 if (CONSP (coding_systems
)) val
= XCONS (coding_systems
)->car
;
3318 setup_coding_system (Fcheck_coding_system (val
), &coding
);
3321 /* If requested, replace the accessible part of the buffer
3322 with the file contents. Avoid replacing text at the
3323 beginning or end of the buffer that matches the file contents;
3324 that preserves markers pointing to the unchanged parts.
3326 Here we implement this feature in an optimized way
3327 for the case where code conversion is NOT needed.
3328 The following if-statement handles the case of conversion
3329 in a less optimal way.
3331 If the code conversion is "automatic" then we try using this
3332 method and hope for the best.
3333 But if we discover the need for conversion, we give up on this method
3334 and let the following if-statement handle the replace job. */
3336 && ! CODING_REQUIRE_DECODING (&coding
))
3338 /* same_at_start and same_at_end count bytes,
3339 because file access counts bytes
3340 and BEG and END count bytes. */
3341 int same_at_start
= BEGV_BYTE
;
3342 int same_at_end
= ZV_BYTE
;
3344 /* There is still a possibility we will find the need to do code
3345 conversion. If that happens, we set this variable to 1 to
3346 give up on handling REPLACE in the optimized way. */
3347 int giveup_match_end
= 0;
3349 if (XINT (beg
) != 0)
3351 if (lseek (fd
, XINT (beg
), 0) < 0)
3352 report_file_error ("Setting file position",
3353 Fcons (orig_filename
, Qnil
));
3358 /* Count how many chars at the start of the file
3359 match the text at the beginning of the buffer. */
3364 nread
= read (fd
, buffer
, sizeof buffer
);
3366 error ("IO error reading %s: %s",
3367 XSTRING (orig_filename
)->data
, strerror (errno
));
3368 else if (nread
== 0)
3371 if (coding
.type
== coding_type_undecided
)
3372 detect_coding (&coding
, buffer
, nread
);
3373 if (CODING_REQUIRE_DECODING (&coding
))
3374 /* We found that the file should be decoded somehow.
3375 Let's give up here. */
3377 giveup_match_end
= 1;
3381 if (coding
.eol_type
== CODING_EOL_UNDECIDED
)
3382 detect_eol (&coding
, buffer
, nread
);
3383 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3384 && coding
.eol_type
!= CODING_EOL_LF
)
3385 /* We found that the format of eol should be decoded.
3386 Let's give up here. */
3388 giveup_match_end
= 1;
3393 while (bufpos
< nread
&& same_at_start
< ZV_BYTE
3394 && FETCH_BYTE (same_at_start
) == buffer
[bufpos
])
3395 same_at_start
++, bufpos
++;
3396 /* If we found a discrepancy, stop the scan.
3397 Otherwise loop around and scan the next bufferful. */
3398 if (bufpos
!= nread
)
3402 /* If the file matches the buffer completely,
3403 there's no need to replace anything. */
3404 if (same_at_start
- BEGV_BYTE
== XINT (end
))
3408 /* Truncate the buffer to the size of the file. */
3409 del_range_1 (same_at_start
, same_at_end
, 0);
3414 /* Count how many chars at the end of the file
3415 match the text at the end of the buffer. But, if we have
3416 already found that decoding is necessary, don't waste time. */
3417 while (!giveup_match_end
)
3419 int total_read
, nread
, bufpos
, curpos
, trial
;
3421 /* At what file position are we now scanning? */
3422 curpos
= XINT (end
) - (ZV_BYTE
- same_at_end
);
3423 /* If the entire file matches the buffer tail, stop the scan. */
3426 /* How much can we scan in the next step? */
3427 trial
= min (curpos
, sizeof buffer
);
3428 if (lseek (fd
, curpos
- trial
, 0) < 0)
3429 report_file_error ("Setting file position",
3430 Fcons (orig_filename
, Qnil
));
3433 while (total_read
< trial
)
3435 nread
= read (fd
, buffer
+ total_read
, trial
- total_read
);
3437 error ("IO error reading %s: %s",
3438 XSTRING (orig_filename
)->data
, strerror (errno
));
3439 total_read
+= nread
;
3441 /* Scan this bufferful from the end, comparing with
3442 the Emacs buffer. */
3443 bufpos
= total_read
;
3444 /* Compare with same_at_start to avoid counting some buffer text
3445 as matching both at the file's beginning and at the end. */
3446 while (bufpos
> 0 && same_at_end
> same_at_start
3447 && FETCH_BYTE (same_at_end
- 1) == buffer
[bufpos
- 1])
3448 same_at_end
--, bufpos
--;
3450 /* If we found a discrepancy, stop the scan.
3451 Otherwise loop around and scan the preceding bufferful. */
3454 /* If this discrepancy is because of code conversion,
3455 we cannot use this method; giveup and try the other. */
3456 if (same_at_end
> same_at_start
3457 && FETCH_BYTE (same_at_end
- 1) >= 0200
3458 && ! NILP (current_buffer
->enable_multibyte_characters
)
3459 && (CODING_REQUIRE_DECODING (&coding
)
3460 || CODING_REQUIRE_DETECTION (&coding
)))
3461 giveup_match_end
= 1;
3467 if (! giveup_match_end
)
3471 /* We win! We can handle REPLACE the optimized way. */
3473 /* Extends the end of non-matching text area to multibyte
3474 character boundary. */
3475 if (! NILP (current_buffer
->enable_multibyte_characters
))
3476 while (same_at_end
< ZV_BYTE
3477 && ! CHAR_HEAD_P (FETCH_BYTE (same_at_end
)))
3480 /* Don't try to reuse the same piece of text twice. */
3481 overlap
= (same_at_start
- BEGV_BYTE
3482 - (same_at_end
+ st
.st_size
- ZV
));
3484 same_at_end
+= overlap
;
3486 /* Arrange to read only the nonmatching middle part of the file. */
3487 XSETFASTINT (beg
, XINT (beg
) + (same_at_start
- BEGV_BYTE
));
3488 XSETFASTINT (end
, XINT (end
) - (ZV_BYTE
- same_at_end
));
3490 del_range_byte (same_at_start
, same_at_end
, 0);
3491 /* Insert from the file at the proper position. */
3492 temp
= BYTE_TO_CHAR (same_at_start
);
3493 SET_PT_BOTH (temp
, same_at_start
);
3495 /* If display currently starts at beginning of line,
3496 keep it that way. */
3497 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3498 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3500 replace_handled
= 1;
3504 /* If requested, replace the accessible part of the buffer
3505 with the file contents. Avoid replacing text at the
3506 beginning or end of the buffer that matches the file contents;
3507 that preserves markers pointing to the unchanged parts.
3509 Here we implement this feature for the case where code conversion
3510 is needed, in a simple way that needs a lot of memory.
3511 The preceding if-statement handles the case of no conversion
3512 in a more optimized way. */
3513 if (!NILP (replace
) && ! replace_handled
)
3515 int same_at_start
= BEGV_BYTE
;
3516 int same_at_end
= ZV_BYTE
;
3519 /* Make sure that the gap is large enough. */
3520 int bufsize
= 2 * st
.st_size
;
3521 unsigned char *conversion_buffer
= (unsigned char *) xmalloc (bufsize
);
3524 /* First read the whole file, performing code conversion into
3525 CONVERSION_BUFFER. */
3527 if (lseek (fd
, XINT (beg
), 0) < 0)
3529 free (conversion_buffer
);
3530 report_file_error ("Setting file position",
3531 Fcons (orig_filename
, Qnil
));
3534 total
= st
.st_size
; /* Total bytes in the file. */
3535 how_much
= 0; /* Bytes read from file so far. */
3536 inserted
= 0; /* Bytes put into CONVERSION_BUFFER so far. */
3537 unprocessed
= 0; /* Bytes not processed in previous loop. */
3539 while (how_much
< total
)
3541 /* try is reserved in some compilers (Microsoft C) */
3542 int trytry
= min (total
- how_much
, READ_BUF_SIZE
- unprocessed
);
3543 char *destination
= read_buf
+ unprocessed
;
3546 /* Allow quitting out of the actual I/O. */
3549 this = read (fd
, destination
, trytry
);
3552 if (this < 0 || this + unprocessed
== 0)
3560 if (CODING_REQUIRE_DECODING (&coding
)
3561 || CODING_REQUIRE_DETECTION (&coding
))
3563 int require
, produced
, consumed
;
3565 this += unprocessed
;
3567 /* If we are using more space than estimated,
3568 make CONVERSION_BUFFER bigger. */
3569 require
= decoding_buffer_size (&coding
, this);
3570 if (inserted
+ require
+ 2 * (total
- how_much
) > bufsize
)
3572 bufsize
= inserted
+ require
+ 2 * (total
- how_much
);
3573 conversion_buffer
= (unsigned char *) xrealloc (conversion_buffer
, bufsize
);
3576 /* Convert this batch with results in CONVERSION_BUFFER. */
3577 if (how_much
>= total
) /* This is the last block. */
3578 coding
.last_block
= 1;
3579 produced
= decode_coding (&coding
, read_buf
,
3580 conversion_buffer
+ inserted
,
3581 this, bufsize
- inserted
,
3584 /* Save for next iteration whatever we didn't convert. */
3585 unprocessed
= this - consumed
;
3586 bcopy (read_buf
+ consumed
, read_buf
, unprocessed
);
3593 /* At this point, INSERTED is how many characters
3594 are present in CONVERSION_BUFFER.
3595 HOW_MUCH should equal TOTAL,
3596 or should be <= 0 if we couldn't read the file. */
3600 free (conversion_buffer
);
3603 error ("IO error reading %s: %s",
3604 XSTRING (orig_filename
)->data
, strerror (errno
));
3605 else if (how_much
== -2)
3606 error ("maximum buffer size exceeded");
3609 /* Compare the beginning of the converted file
3610 with the buffer text. */
3613 while (bufpos
< inserted
&& same_at_start
< same_at_end
3614 && FETCH_BYTE (same_at_start
) == conversion_buffer
[bufpos
])
3615 same_at_start
++, bufpos
++;
3617 /* If the file matches the buffer completely,
3618 there's no need to replace anything. */
3620 if (bufpos
== inserted
)
3622 free (conversion_buffer
);
3625 /* Truncate the buffer to the size of the file. */
3626 del_range_1 (same_at_start
, same_at_end
, 0);
3630 /* Scan this bufferful from the end, comparing with
3631 the Emacs buffer. */
3634 /* Compare with same_at_start to avoid counting some buffer text
3635 as matching both at the file's beginning and at the end. */
3636 while (bufpos
> 0 && same_at_end
> same_at_start
3637 && FETCH_BYTE (same_at_end
- 1) == conversion_buffer
[bufpos
- 1])
3638 same_at_end
--, bufpos
--;
3640 /* Don't try to reuse the same piece of text twice. */
3641 overlap
= same_at_start
- BEGV_BYTE
- (same_at_end
+ inserted
- ZV_BYTE
);
3643 same_at_end
+= overlap
;
3645 /* If display currently starts at beginning of line,
3646 keep it that way. */
3647 if (XBUFFER (XWINDOW (selected_window
)->buffer
) == current_buffer
)
3648 XWINDOW (selected_window
)->start_at_line_beg
= Fbolp ();
3650 /* Replace the chars that we need to replace,
3651 and update INSERTED to equal the number of bytes
3652 we are taking from the file. */
3653 inserted
-= (Z_BYTE
- same_at_end
) + (same_at_start
- BEG_BYTE
);
3654 del_range_byte (same_at_start
, same_at_end
, 0);
3655 SET_PT_BOTH (GPT
, GPT_BYTE
);
3657 insert_1 (conversion_buffer
+ same_at_start
- BEG_BYTE
, inserted
,
3660 free (conversion_buffer
);
3669 register Lisp_Object temp
;
3671 total
= XINT (end
) - XINT (beg
);
3673 /* Make sure point-max won't overflow after this insertion. */
3674 XSETINT (temp
, total
);
3675 if (total
!= XINT (temp
))
3676 error ("Maximum buffer size exceeded");
3679 /* For a special file, all we can do is guess. */
3680 total
= READ_BUF_SIZE
;
3682 if (NILP (visit
) && total
> 0)
3683 prepare_to_modify_buffer (PT
, PT
, NULL
);
3686 if (GAP_SIZE
< total
)
3687 make_gap (total
- GAP_SIZE
);
3689 if (XINT (beg
) != 0 || !NILP (replace
))
3691 if (lseek (fd
, XINT (beg
), 0) < 0)
3692 report_file_error ("Setting file position",
3693 Fcons (orig_filename
, Qnil
));
3696 /* In the following loop, HOW_MUCH contains the total bytes read so
3697 far. Before exiting the loop, it is set to -1 if I/O error
3698 occurs, set to -2 if the maximum buffer size is exceeded. */
3700 /* Total bytes inserted. */
3702 /* Bytes not processed in the previous loop because short gap size. */
3704 while (how_much
< total
)
3706 /* try is reserved in some compilers (Microsoft C) */
3707 int trytry
= min (total
- how_much
, READ_BUF_SIZE
- unprocessed
);
3708 char *destination
= (! (CODING_REQUIRE_DECODING (&coding
)
3709 || CODING_REQUIRE_DETECTION (&coding
))
3710 ? (char *) (BYTE_POS_ADDR (PT_BYTE
+ inserted
- 1) + 1)
3711 : read_buf
+ unprocessed
);
3712 int this, this_chars
;
3714 /* Allow quitting out of the actual I/O. */
3717 this = read (fd
, destination
, trytry
);
3720 if (this < 0 || this + unprocessed
== 0)
3726 /* For a regular file, where TOTAL is the real size,
3727 count HOW_MUCH to compare with it.
3728 For a special file, where TOTAL is just a buffer size,
3729 so don't bother counting in HOW_MUCH.
3730 (INSERTED is where we count the number of characters inserted.) */
3735 if (CODING_REQUIRE_DECODING (&coding
)
3736 || CODING_REQUIRE_DETECTION (&coding
))
3738 int require
, produced
, consumed
;
3740 this += unprocessed
;
3741 /* Make sure that the gap is large enough. */
3742 require
= decoding_buffer_size (&coding
, this);
3743 if (GAP_SIZE
< require
)
3744 make_gap (require
- GAP_SIZE
);
3748 if (how_much
>= total
) /* This is the last block. */
3749 coding
.last_block
= 1;
3753 /* If we encounter EOF, say it is the last block. (The
3754 data this will apply to is the UNPROCESSED characters
3755 carried over from the last batch.) */
3757 coding
.last_block
= 1;
3760 produced
= decode_coding (&coding
, read_buf
,
3761 BYTE_POS_ADDR (PT_BYTE
+ inserted
- 1) + 1,
3762 this, GAP_SIZE
, &consumed
);
3767 XSET (temp
, Lisp_Int
, Z_BYTE
+ produced
);
3768 if (Z_BYTE
+ produced
!= XINT (temp
))
3774 unprocessed
= this - consumed
;
3775 bcopy (read_buf
+ consumed
, read_buf
, unprocessed
);
3777 this_chars
= chars_in_text (BYTE_POS_ADDR (PT_BYTE
+ inserted
- 1) + 1,
3790 /* Put an anchor to ensure multi-byte form ends at gap. */
3793 inserted_chars
+= this_chars
;
3797 /* Use the conversion type to determine buffer-file-type
3798 (find-buffer-file-type is now used to help determine the
3800 if (coding
.eol_type
!= CODING_EOL_UNDECIDED
3801 && coding
.eol_type
!= CODING_EOL_LF
)
3802 current_buffer
->buffer_file_type
= Qnil
;
3804 current_buffer
->buffer_file_type
= Qt
;
3809 record_insert (PT
, inserted_chars
);
3811 /* Only defined if Emacs is compiled with USE_TEXT_PROPERTIES */
3812 offset_intervals (current_buffer
, PT
, inserted_chars
);
3818 /* Discard the unwind protect for closing the file. */
3822 error ("IO error reading %s: %s",
3823 XSTRING (orig_filename
)->data
, strerror (errno
));
3824 else if (how_much
== -2)
3825 error ("maximum buffer size exceeded");
3827 set_coding_system
= 1;
3834 if (!EQ (current_buffer
->undo_list
, Qt
))
3835 current_buffer
->undo_list
= Qnil
;
3837 stat (XSTRING (filename
)->data
, &st
);
3842 current_buffer
->modtime
= st
.st_mtime
;
3843 current_buffer
->filename
= orig_filename
;
3846 SAVE_MODIFF
= MODIFF
;
3847 current_buffer
->auto_save_modified
= MODIFF
;
3848 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
3849 #ifdef CLASH_DETECTION
3852 if (!NILP (current_buffer
->file_truename
))
3853 unlock_file (current_buffer
->file_truename
);
3854 unlock_file (filename
);
3856 #endif /* CLASH_DETECTION */
3858 Fsignal (Qfile_error
,
3859 Fcons (build_string ("not a regular file"),
3860 Fcons (orig_filename
, Qnil
)));
3862 /* If visiting nonexistent file, return nil. */
3863 if (current_buffer
->modtime
== -1)
3864 report_file_error ("Opening input file", Fcons (orig_filename
, Qnil
));
3867 /* Decode file format */
3868 if (inserted_chars
> 0)
3870 insval
= call3 (Qformat_decode
,
3871 Qnil
, make_number (inserted_chars
), visit
);
3872 CHECK_NUMBER (insval
, 0);
3873 inserted_chars
= XFASTINT (insval
);
3876 /* Call after-change hooks for the inserted text, aside from the case
3877 of normal visiting (not with REPLACE), which is done in a new buffer
3878 "before" the buffer is changed. */
3879 if (inserted_chars
> 0 && total
> 0
3880 && (NILP (visit
) || !NILP (replace
)))
3881 signal_after_change (PT
, 0, inserted_chars
);
3883 if (set_coding_system
)
3884 Vlast_coding_system_used
= coding
.symbol
;
3888 p
= Vafter_insert_file_functions
;
3889 if (!NILP (coding
.post_read_conversion
))
3890 p
= Fcons (coding
.post_read_conversion
, p
);
3894 insval
= call1 (Fcar (p
), make_number (inserted_chars
));
3897 CHECK_NUMBER (insval
, 0);
3898 inserted_chars
= XFASTINT (insval
);
3905 /* ??? Retval needs to be dealt with in all cases consistently. */
3907 val
= Fcons (orig_filename
,
3908 Fcons (make_number (inserted
),
3911 RETURN_UNGCPRO (unbind_to (count
, val
));
3914 static Lisp_Object build_annotations
P_ ((Lisp_Object
, Lisp_Object
,
3917 /* If build_annotations switched buffers, switch back to BUF.
3918 Kill the temporary buffer that was selected in the meantime.
3920 Since this kill only the last temporary buffer, some buffers remain
3921 not killed if build_annotations switched buffers more than once.
3925 build_annotations_unwind (buf
)
3930 if (XBUFFER (buf
) == current_buffer
)
3932 tembuf
= Fcurrent_buffer ();
3934 Fkill_buffer (tembuf
);
3938 DEFUN ("write-region", Fwrite_region
, Swrite_region
, 3, 6,
3939 "r\nFWrite region to file: ",
3940 "Write current region into specified file.\n\
3941 When called from a program, takes three arguments:\n\
3942 START, END and FILENAME. START and END are buffer positions.\n\
3943 Optional fourth argument APPEND if non-nil means\n\
3944 append to existing file contents (if any).\n\
3945 Optional fifth argument VISIT if t means\n\
3946 set the last-save-file-modtime of buffer to this file's modtime\n\
3947 and mark buffer not modified.\n\
3948 If VISIT is a string, it is a second file name;\n\
3949 the output goes to FILENAME, but the buffer is marked as visiting VISIT.\n\
3950 VISIT is also the file name to lock and unlock for clash detection.\n\
3951 If VISIT is neither t nor nil nor a string,\n\
3952 that means do not print the \"Wrote file\" message.\n\
3953 The optional sixth arg LOCKNAME, if non-nil, specifies the name to\n\
3954 use for locking and unlocking, overriding FILENAME and VISIT.\n\
3955 Kludgy feature: if START is a string, then that string is written\n\
3956 to the file, instead of any buffer contents, and END is ignored.")
3957 (start
, end
, filename
, append
, visit
, lockname
)
3958 Lisp_Object start
, end
, filename
, append
, visit
, lockname
;
3966 int count
= specpdl_ptr
- specpdl
;
3969 unsigned char *fname
= 0; /* If non-0, original filename (must rename) */
3971 Lisp_Object handler
;
3972 Lisp_Object visit_file
;
3973 Lisp_Object annotations
;
3974 Lisp_Object encoded_filename
;
3975 int visiting
, quietly
;
3976 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
3977 struct buffer
*given_buffer
;
3979 int buffer_file_type
= O_BINARY
;
3981 struct coding_system coding
;
3983 if (current_buffer
->base_buffer
&& ! NILP (visit
))
3984 error ("Cannot do file visiting in an indirect buffer");
3986 if (!NILP (start
) && !STRINGP (start
))
3987 validate_region (&start
, &end
);
3989 GCPRO4 (start
, filename
, visit
, lockname
);
3991 /* Decide the coding-system to encode the data with. */
3997 else if (!NILP (Vcoding_system_for_write
))
3998 val
= Vcoding_system_for_write
;
3999 else if (NILP (current_buffer
->enable_multibyte_characters
))
4001 /* If the variable `buffer-file-coding-system' is set locally,
4002 it means that the file was read with some kind of code
4003 conversion or the varialbe is explicitely set by users. We
4004 had better write it out with the same coding system even if
4005 `enable-multibyte-characters' is nil.
4007 If is is not set locally, we anyway have to convert EOL
4008 format if the default value of `buffer-file-coding-system'
4009 tells that it is not Unix-like (LF only) format. */
4010 val
= current_buffer
->buffer_file_coding_system
;
4011 if (NILP (Flocal_variable_p (Qbuffer_file_coding_system
, Qnil
)))
4013 struct coding_system coding_temp
;
4015 setup_coding_system (Fcheck_coding_system (val
), &coding_temp
);
4016 if (coding_temp
.eol_type
== CODING_EOL_CRLF
4017 || coding_temp
.eol_type
== CODING_EOL_CR
)
4019 setup_coding_system (Qemacs_mule
, &coding
);
4020 coding
.eol_type
= coding_temp
.eol_type
;
4021 goto done_setup_coding
;
4028 Lisp_Object args
[7], coding_systems
;
4030 args
[0] = Qwrite_region
, args
[1] = start
, args
[2] = end
,
4031 args
[3] = filename
, args
[4] = append
, args
[5] = visit
,
4033 coding_systems
= Ffind_operation_coding_system (7, args
);
4034 val
= (CONSP (coding_systems
) && !NILP (XCONS (coding_systems
)->cdr
)
4035 ? XCONS (coding_systems
)->cdr
4036 : current_buffer
->buffer_file_coding_system
);
4038 setup_coding_system (Fcheck_coding_system (val
), &coding
);
4041 if (!STRINGP (start
) && !NILP (current_buffer
->selective_display
))
4042 coding
.selective
= 1;
4045 Vlast_coding_system_used
= coding
.symbol
;
4047 filename
= Fexpand_file_name (filename
, Qnil
);
4048 if (STRINGP (visit
))
4049 visit_file
= Fexpand_file_name (visit
, Qnil
);
4051 visit_file
= filename
;
4054 visiting
= (EQ (visit
, Qt
) || STRINGP (visit
));
4055 quietly
= !NILP (visit
);
4059 if (NILP (lockname
))
4060 lockname
= visit_file
;
4062 GCPRO5 (start
, filename
, annotations
, visit_file
, lockname
);
4064 /* If the file name has special constructs in it,
4065 call the corresponding file handler. */
4066 handler
= Ffind_file_name_handler (filename
, Qwrite_region
);
4067 /* If FILENAME has no handler, see if VISIT has one. */
4068 if (NILP (handler
) && STRINGP (visit
))
4069 handler
= Ffind_file_name_handler (visit
, Qwrite_region
);
4071 if (!NILP (handler
))
4074 val
= call6 (handler
, Qwrite_region
, start
, end
,
4075 filename
, append
, visit
);
4079 SAVE_MODIFF
= MODIFF
;
4080 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4081 current_buffer
->filename
= visit_file
;
4087 /* Special kludge to simplify auto-saving. */
4090 XSETFASTINT (start
, BEG
);
4091 XSETFASTINT (end
, Z
);
4094 record_unwind_protect (build_annotations_unwind
, Fcurrent_buffer ());
4095 count1
= specpdl_ptr
- specpdl
;
4097 given_buffer
= current_buffer
;
4098 annotations
= build_annotations (start
, end
, coding
.pre_write_conversion
);
4099 if (current_buffer
!= given_buffer
)
4101 XSETFASTINT (start
, BEGV
);
4102 XSETFASTINT (end
, ZV
);
4105 #ifdef CLASH_DETECTION
4108 #if 0 /* This causes trouble for GNUS. */
4109 /* If we've locked this file for some other buffer,
4110 query before proceeding. */
4111 if (!visiting
&& EQ (Ffile_locked_p (lockname
), Qt
))
4112 call2 (intern ("ask-user-about-lock"), filename
, Vuser_login_name
);
4115 lock_file (lockname
);
4117 #endif /* CLASH_DETECTION */
4119 encoded_filename
= ENCODE_FILE (filename
);
4121 fn
= XSTRING (encoded_filename
)->data
;
4125 desc
= open (fn
, O_WRONLY
| buffer_file_type
);
4126 #else /* not DOS_NT */
4127 desc
= open (fn
, O_WRONLY
);
4128 #endif /* not DOS_NT */
4130 if (desc
< 0 && (NILP (append
) || errno
== ENOENT
))
4132 if (auto_saving
) /* Overwrite any previous version of autosave file */
4134 vms_truncate (fn
); /* if fn exists, truncate to zero length */
4135 desc
= open (fn
, O_RDWR
);
4137 desc
= creat_copy_attrs (STRINGP (current_buffer
->filename
)
4138 ? XSTRING (current_buffer
->filename
)->data
: 0,
4141 else /* Write to temporary name and rename if no errors */
4143 Lisp_Object temp_name
;
4144 temp_name
= Ffile_name_directory (filename
);
4146 if (!NILP (temp_name
))
4148 temp_name
= Fmake_temp_name (concat2 (temp_name
,
4149 build_string ("$$SAVE$$")));
4150 fname
= XSTRING (filename
)->data
;
4151 fn
= XSTRING (temp_name
)->data
;
4152 desc
= creat_copy_attrs (fname
, fn
);
4155 /* If we can't open the temporary file, try creating a new
4156 version of the original file. VMS "creat" creates a
4157 new version rather than truncating an existing file. */
4160 desc
= creat (fn
, 0666);
4161 #if 0 /* This can clobber an existing file and fail to replace it,
4162 if the user runs out of space. */
4165 /* We can't make a new version;
4166 try to truncate and rewrite existing version if any. */
4168 desc
= open (fn
, O_RDWR
);
4174 desc
= creat (fn
, 0666);
4179 O_WRONLY
| O_TRUNC
| O_CREAT
| buffer_file_type
,
4180 S_IREAD
| S_IWRITE
);
4181 #else /* not DOS_NT */
4182 desc
= creat (fn
, auto_saving
? auto_save_mode_bits
: 0666);
4183 #endif /* not DOS_NT */
4184 #endif /* not VMS */
4190 #ifdef CLASH_DETECTION
4192 if (!auto_saving
) unlock_file (lockname
);
4194 #endif /* CLASH_DETECTION */
4195 report_file_error ("Opening output file", Fcons (filename
, Qnil
));
4198 record_unwind_protect (close_file_unwind
, make_number (desc
));
4201 if (lseek (desc
, 0, 2) < 0)
4203 #ifdef CLASH_DETECTION
4204 if (!auto_saving
) unlock_file (lockname
);
4205 #endif /* CLASH_DETECTION */
4206 report_file_error ("Lseek error", Fcons (filename
, Qnil
));
4211 * Kludge Warning: The VMS C RTL likes to insert carriage returns
4212 * if we do writes that don't end with a carriage return. Furthermore
4213 * it cannot handle writes of more then 16K. The modified
4214 * version of "sys_write" in SYSDEP.C (see comment there) copes with
4215 * this EXCEPT for the last record (iff it doesn't end with a carriage
4216 * return). This implies that if your buffer doesn't end with a carriage
4217 * return, you get one free... tough. However it also means that if
4218 * we make two calls to sys_write (a la the following code) you can
4219 * get one at the gap as well. The easiest way to fix this (honest)
4220 * is to move the gap to the next newline (or the end of the buffer).
4225 if (GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4226 move_gap (find_next_newline (GPT
, 1));
4228 /* Whether VMS or not, we must move the gap to the next of newline
4229 when we must put designation sequences at beginning of line. */
4230 if (INTEGERP (start
)
4231 && coding
.type
== coding_type_iso2022
4232 && coding
.flags
& CODING_FLAG_ISO_DESIGNATE_AT_BOL
4233 && GPT
> BEG
&& GPT_ADDR
[-1] != '\n')
4235 int opoint
= PT
, opoint_byte
= PT_BYTE
;
4236 scan_newline (PT
, PT_BYTE
, ZV
, ZV_BYTE
, 1, 0);
4237 move_gap_both (PT
, PT_BYTE
);
4238 SET_PT_BOTH (opoint
, opoint_byte
);
4245 if (STRINGP (start
))
4247 failure
= 0 > a_write (desc
, XSTRING (start
)->data
,
4248 XSTRING (start
)->size
, 0, &annotations
, &coding
);
4251 else if (XINT (start
) != XINT (end
))
4253 register int end1
= CHAR_TO_BYTE (XINT (end
));
4255 tem
= CHAR_TO_BYTE (XINT (start
));
4257 if (XINT (start
) < GPT
)
4259 failure
= 0 > a_write (desc
, BYTE_POS_ADDR (tem
),
4260 min (GPT_BYTE
, end1
) - tem
, tem
, &annotations
,
4265 if (XINT (end
) > GPT
&& !failure
)
4267 tem
= max (tem
, GPT_BYTE
);
4268 failure
= 0 > a_write (desc
, BYTE_POS_ADDR (tem
), end1
- tem
,
4269 tem
, &annotations
, &coding
);
4275 /* If file was empty, still need to write the annotations */
4276 coding
.last_block
= 1;
4277 failure
= 0 > a_write (desc
, "", 0, XINT (start
), &annotations
, &coding
);
4281 if (CODING_REQUIRE_FLUSHING (&coding
) && !coding
.last_block
)
4283 /* We have to flush out a data. */
4284 coding
.last_block
= 1;
4285 failure
= 0 > e_write (desc
, "", 0, &coding
);
4292 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
4293 Disk full in NFS may be reported here. */
4294 /* mib says that closing the file will try to write as fast as NFS can do
4295 it, and that means the fsync here is not crucial for autosave files. */
4296 if (!auto_saving
&& fsync (desc
) < 0)
4298 /* If fsync fails with EINTR, don't treat that as serious. */
4300 failure
= 1, save_errno
= errno
;
4304 /* Spurious "file has changed on disk" warnings have been
4305 observed on Suns as well.
4306 It seems that `close' can change the modtime, under nfs.
4308 (This has supposedly been fixed in Sunos 4,
4309 but who knows about all the other machines with NFS?) */
4312 /* On VMS and APOLLO, must do the stat after the close
4313 since closing changes the modtime. */
4316 /* Recall that #if defined does not work on VMS. */
4323 /* NFS can report a write failure now. */
4324 if (close (desc
) < 0)
4325 failure
= 1, save_errno
= errno
;
4328 /* If we wrote to a temporary name and had no errors, rename to real name. */
4332 failure
= (rename (fn
, fname
) != 0), save_errno
= errno
;
4340 /* Discard the unwind protect for close_file_unwind. */
4341 specpdl_ptr
= specpdl
+ count1
;
4342 /* Restore the original current buffer. */
4343 visit_file
= unbind_to (count
, visit_file
);
4345 #ifdef CLASH_DETECTION
4347 unlock_file (lockname
);
4348 #endif /* CLASH_DETECTION */
4350 /* Do this before reporting IO error
4351 to avoid a "file has changed on disk" warning on
4352 next attempt to save. */
4354 current_buffer
->modtime
= st
.st_mtime
;
4357 error ("IO error writing %s: %s", XSTRING (filename
)->data
,
4358 strerror (save_errno
));
4362 SAVE_MODIFF
= MODIFF
;
4363 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4364 current_buffer
->filename
= visit_file
;
4365 update_mode_lines
++;
4371 message_with_string ("Wrote %s", visit_file
, 1);
4376 Lisp_Object
merge ();
4378 DEFUN ("car-less-than-car", Fcar_less_than_car
, Scar_less_than_car
, 2, 2, 0,
4379 "Return t if (car A) is numerically less than (car B).")
4383 return Flss (Fcar (a
), Fcar (b
));
4386 /* Build the complete list of annotations appropriate for writing out
4387 the text between START and END, by calling all the functions in
4388 write-region-annotate-functions and merging the lists they return.
4389 If one of these functions switches to a different buffer, we assume
4390 that buffer contains altered text. Therefore, the caller must
4391 make sure to restore the current buffer in all cases,
4392 as save-excursion would do. */
4395 build_annotations (start
, end
, pre_write_conversion
)
4396 Lisp_Object start
, end
, pre_write_conversion
;
4398 Lisp_Object annotations
;
4400 struct gcpro gcpro1
, gcpro2
;
4401 Lisp_Object original_buffer
;
4403 XSETBUFFER (original_buffer
, current_buffer
);
4406 p
= Vwrite_region_annotate_functions
;
4407 GCPRO2 (annotations
, p
);
4410 struct buffer
*given_buffer
= current_buffer
;
4411 Vwrite_region_annotations_so_far
= annotations
;
4412 res
= call2 (Fcar (p
), start
, end
);
4413 /* If the function makes a different buffer current,
4414 assume that means this buffer contains altered text to be output.
4415 Reset START and END from the buffer bounds
4416 and discard all previous annotations because they should have
4417 been dealt with by this function. */
4418 if (current_buffer
!= given_buffer
)
4420 XSETFASTINT (start
, BEGV
);
4421 XSETFASTINT (end
, ZV
);
4424 Flength (res
); /* Check basic validity of return value */
4425 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4429 /* Now do the same for annotation functions implied by the file-format */
4430 if (auto_saving
&& (!EQ (Vauto_save_file_format
, Qt
)))
4431 p
= Vauto_save_file_format
;
4433 p
= current_buffer
->file_format
;
4436 struct buffer
*given_buffer
= current_buffer
;
4437 Vwrite_region_annotations_so_far
= annotations
;
4438 res
= call4 (Qformat_annotate_function
, Fcar (p
), start
, end
,
4440 if (current_buffer
!= given_buffer
)
4442 XSETFASTINT (start
, BEGV
);
4443 XSETFASTINT (end
, ZV
);
4447 annotations
= merge (annotations
, res
, Qcar_less_than_car
);
4451 /* At last, do the same for the function PRE_WRITE_CONVERSION
4452 implied by the current coding-system. */
4453 if (!NILP (pre_write_conversion
))
4455 struct buffer
*given_buffer
= current_buffer
;
4456 Vwrite_region_annotations_so_far
= annotations
;
4457 res
= call2 (pre_write_conversion
, start
, end
);
4459 annotations
= (current_buffer
!= given_buffer
4461 : merge (annotations
, res
, Qcar_less_than_car
));
4468 /* Write to descriptor DESC the NBYTES bytes starting at ADDR,
4469 assuming they start at byte position BYTEPOS in the buffer.
4470 Intersperse with them the annotations from *ANNOT
4471 which fall within the range of byte positions BYTEPOS to BYTEPOS + NBYTES,
4472 each at its appropriate position.
4474 We modify *ANNOT by discarding elements as we use them up.
4476 The return value is negative in case of system call failure. */
4479 a_write (desc
, addr
, nbytes
, bytepos
, annot
, coding
)
4481 register char *addr
;
4482 register int nbytes
;
4485 struct coding_system
*coding
;
4489 int lastpos
= bytepos
+ nbytes
;
4491 while (NILP (*annot
) || CONSP (*annot
))
4493 tem
= Fcar_safe (Fcar (*annot
));
4496 nextpos
= CHAR_TO_BYTE (XFASTINT (tem
));
4498 /* If there are no more annotations in this range,
4499 output the rest of the range all at once. */
4500 if (! (nextpos
>= bytepos
&& nextpos
<= lastpos
))
4501 return e_write (desc
, addr
, lastpos
- bytepos
, coding
);
4503 /* Output buffer text up to the next annotation's position. */
4504 if (nextpos
> bytepos
)
4506 if (0 > e_write (desc
, addr
, nextpos
- bytepos
, coding
))
4508 addr
+= nextpos
- bytepos
;
4511 /* Output the annotation. */
4512 tem
= Fcdr (Fcar (*annot
));
4515 if (0 > e_write (desc
, XSTRING (tem
)->data
, XSTRING (tem
)->size
,
4519 *annot
= Fcdr (*annot
);
4523 #ifndef WRITE_BUF_SIZE
4524 #define WRITE_BUF_SIZE (16 * 1024)
4527 /* Write NBYTES bytes starting at ADDR into descriptor DESC,
4528 encoding them with coding system CODING. */
4531 e_write (desc
, addr
, nbytes
, coding
)
4533 register char *addr
;
4534 register int nbytes
;
4535 struct coding_system
*coding
;
4537 char buf
[WRITE_BUF_SIZE
];
4538 int produced
, consumed
;
4540 /* We used to have a code for handling selective display here. But,
4541 now it is handled within encode_coding. */
4544 produced
= encode_coding (coding
, addr
, buf
, nbytes
, WRITE_BUF_SIZE
,
4546 nbytes
-= consumed
, addr
+= consumed
;
4549 produced
-= write (desc
, buf
, produced
);
4550 if (produced
) return -1;
4558 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime
,
4559 Sverify_visited_file_modtime
, 1, 1, 0,
4560 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
4561 This means that the file has not been changed since it was visited or saved.")
4567 Lisp_Object handler
;
4568 Lisp_Object filename
;
4570 CHECK_BUFFER (buf
, 0);
4573 if (!STRINGP (b
->filename
)) return Qt
;
4574 if (b
->modtime
== 0) return Qt
;
4576 /* If the file name has special constructs in it,
4577 call the corresponding file handler. */
4578 handler
= Ffind_file_name_handler (b
->filename
,
4579 Qverify_visited_file_modtime
);
4580 if (!NILP (handler
))
4581 return call2 (handler
, Qverify_visited_file_modtime
, buf
);
4583 filename
= ENCODE_FILE (b
->filename
);
4585 if (stat (XSTRING (filename
)->data
, &st
) < 0)
4587 /* If the file doesn't exist now and didn't exist before,
4588 we say that it isn't modified, provided the error is a tame one. */
4589 if (errno
== ENOENT
|| errno
== EACCES
|| errno
== ENOTDIR
)
4594 if (st
.st_mtime
== b
->modtime
4595 /* If both are positive, accept them if they are off by one second. */
4596 || (st
.st_mtime
> 0 && b
->modtime
> 0
4597 && (st
.st_mtime
== b
->modtime
+ 1
4598 || st
.st_mtime
== b
->modtime
- 1)))
4603 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime
,
4604 Sclear_visited_file_modtime
, 0, 0, 0,
4605 "Clear out records of last mod time of visited file.\n\
4606 Next attempt to save will certainly not complain of a discrepancy.")
4609 current_buffer
->modtime
= 0;
4613 DEFUN ("visited-file-modtime", Fvisited_file_modtime
,
4614 Svisited_file_modtime
, 0, 0, 0,
4615 "Return the current buffer's recorded visited file modification time.\n\
4616 The value is a list of the form (HIGH . LOW), like the time values\n\
4617 that `file-attributes' returns.")
4620 return long_to_cons ((unsigned long) current_buffer
->modtime
);
4623 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime
,
4624 Sset_visited_file_modtime
, 0, 1, 0,
4625 "Update buffer's recorded modification time from the visited file's time.\n\
4626 Useful if the buffer was not read from the file normally\n\
4627 or if the file itself has been changed for some known benign reason.\n\
4628 An argument specifies the modification time value to use\n\
4629 \(instead of that of the visited file), in the form of a list\n\
4630 \(HIGH . LOW) or (HIGH LOW).")
4632 Lisp_Object time_list
;
4634 if (!NILP (time_list
))
4635 current_buffer
->modtime
= cons_to_long (time_list
);
4638 register Lisp_Object filename
;
4640 Lisp_Object handler
;
4642 filename
= Fexpand_file_name (current_buffer
->filename
, Qnil
);
4644 /* If the file name has special constructs in it,
4645 call the corresponding file handler. */
4646 handler
= Ffind_file_name_handler (filename
, Qset_visited_file_modtime
);
4647 if (!NILP (handler
))
4648 /* The handler can find the file name the same way we did. */
4649 return call2 (handler
, Qset_visited_file_modtime
, Qnil
);
4651 filename
= ENCODE_FILE (filename
);
4653 if (stat (XSTRING (filename
)->data
, &st
) >= 0)
4654 current_buffer
->modtime
= st
.st_mtime
;
4664 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 1);
4665 Fsleep_for (make_number (1), Qnil
);
4666 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 0);
4667 Fsleep_for (make_number (1), Qnil
);
4668 message_with_string ("Autosaving...error for %s", current_buffer
->name
, 0);
4669 Fsleep_for (make_number (1), Qnil
);
4679 /* Get visited file's mode to become the auto save file's mode. */
4680 if (stat (XSTRING (current_buffer
->filename
)->data
, &st
) >= 0)
4681 /* But make sure we can overwrite it later! */
4682 auto_save_mode_bits
= st
.st_mode
| 0600;
4684 auto_save_mode_bits
= 0666;
4687 Fwrite_region (Qnil
, Qnil
,
4688 current_buffer
->auto_save_file_name
,
4689 Qnil
, Qlambda
, Qnil
);
4693 do_auto_save_unwind (stream
) /* used as unwind-protect function */
4698 fclose ((FILE *) (XFASTINT (XCONS (stream
)->car
) << 16
4699 | XFASTINT (XCONS (stream
)->cdr
)));
4704 do_auto_save_unwind_1 (value
) /* used as unwind-protect function */
4707 minibuffer_auto_raise
= XINT (value
);
4711 DEFUN ("do-auto-save", Fdo_auto_save
, Sdo_auto_save
, 0, 2, "",
4712 "Auto-save all buffers that need it.\n\
4713 This is all buffers that have auto-saving enabled\n\
4714 and are changed since last auto-saved.\n\
4715 Auto-saving writes the buffer into a file\n\
4716 so that your editing is not lost if the system crashes.\n\
4717 This file is not the file you visited; that changes only when you save.\n\
4718 Normally we run the normal hook `auto-save-hook' before saving.\n\n\
4719 A non-nil NO-MESSAGE argument means do not print any message if successful.\n\
4720 A non-nil CURRENT-ONLY argument means save only current buffer.")
4721 (no_message
, current_only
)
4722 Lisp_Object no_message
, current_only
;
4724 struct buffer
*old
= current_buffer
, *b
;
4725 Lisp_Object tail
, buf
;
4727 char *omessage
= echo_area_glyphs
;
4728 int omessage_length
= echo_area_glyphs_length
;
4729 int oldmultibyte
= message_enable_multibyte
;
4730 int do_handled_files
;
4733 Lisp_Object lispstream
;
4734 int count
= specpdl_ptr
- specpdl
;
4736 int orig_minibuffer_auto_raise
= minibuffer_auto_raise
;
4738 /* Ordinarily don't quit within this function,
4739 but don't make it impossible to quit (in case we get hung in I/O). */
4743 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
4744 point to non-strings reached from Vbuffer_alist. */
4749 if (!NILP (Vrun_hooks
))
4750 call1 (Vrun_hooks
, intern ("auto-save-hook"));
4752 if (STRINGP (Vauto_save_list_file_name
))
4754 Lisp_Object listfile
;
4755 listfile
= Fexpand_file_name (Vauto_save_list_file_name
, Qnil
);
4756 stream
= fopen (XSTRING (listfile
)->data
, "w");
4759 /* Arrange to close that file whether or not we get an error.
4760 Also reset auto_saving to 0. */
4761 lispstream
= Fcons (Qnil
, Qnil
);
4762 XSETFASTINT (XCONS (lispstream
)->car
, (EMACS_UINT
)stream
>> 16);
4763 XSETFASTINT (XCONS (lispstream
)->cdr
, (EMACS_UINT
)stream
& 0xffff);
4774 record_unwind_protect (do_auto_save_unwind
, lispstream
);
4775 record_unwind_protect (do_auto_save_unwind_1
,
4776 make_number (minibuffer_auto_raise
));
4777 minibuffer_auto_raise
= 0;
4780 /* First, save all files which don't have handlers. If Emacs is
4781 crashing, the handlers may tweak what is causing Emacs to crash
4782 in the first place, and it would be a shame if Emacs failed to
4783 autosave perfectly ordinary files because it couldn't handle some
4785 for (do_handled_files
= 0; do_handled_files
< 2; do_handled_files
++)
4786 for (tail
= Vbuffer_alist
; GC_CONSP (tail
); tail
= XCONS (tail
)->cdr
)
4788 buf
= XCONS (XCONS (tail
)->car
)->cdr
;
4791 /* Record all the buffers that have auto save mode
4792 in the special file that lists them. For each of these buffers,
4793 Record visited name (if any) and auto save name. */
4794 if (STRINGP (b
->auto_save_file_name
)
4795 && stream
!= NULL
&& do_handled_files
== 0)
4797 if (!NILP (b
->filename
))
4799 fwrite (XSTRING (b
->filename
)->data
, 1,
4800 XSTRING (b
->filename
)->size
, stream
);
4802 putc ('\n', stream
);
4803 fwrite (XSTRING (b
->auto_save_file_name
)->data
, 1,
4804 XSTRING (b
->auto_save_file_name
)->size
, stream
);
4805 putc ('\n', stream
);
4808 if (!NILP (current_only
)
4809 && b
!= current_buffer
)
4812 /* Don't auto-save indirect buffers.
4813 The base buffer takes care of it. */
4817 /* Check for auto save enabled
4818 and file changed since last auto save
4819 and file changed since last real save. */
4820 if (STRINGP (b
->auto_save_file_name
)
4821 && BUF_SAVE_MODIFF (b
) < BUF_MODIFF (b
)
4822 && b
->auto_save_modified
< BUF_MODIFF (b
)
4823 /* -1 means we've turned off autosaving for a while--see below. */
4824 && XINT (b
->save_length
) >= 0
4825 && (do_handled_files
4826 || NILP (Ffind_file_name_handler (b
->auto_save_file_name
,
4829 EMACS_TIME before_time
, after_time
;
4831 EMACS_GET_TIME (before_time
);
4833 /* If we had a failure, don't try again for 20 minutes. */
4834 if (b
->auto_save_failure_time
>= 0
4835 && EMACS_SECS (before_time
) - b
->auto_save_failure_time
< 1200)
4838 if ((XFASTINT (b
->save_length
) * 10
4839 > (BUF_Z (b
) - BUF_BEG (b
)) * 13)
4840 /* A short file is likely to change a large fraction;
4841 spare the user annoying messages. */
4842 && XFASTINT (b
->save_length
) > 5000
4843 /* These messages are frequent and annoying for `*mail*'. */
4844 && !EQ (b
->filename
, Qnil
)
4845 && NILP (no_message
))
4847 /* It has shrunk too much; turn off auto-saving here. */
4848 minibuffer_auto_raise
= orig_minibuffer_auto_raise
;
4849 message_with_string ("Buffer %s has shrunk a lot; auto save turned off there",
4851 minibuffer_auto_raise
= 0;
4852 /* Turn off auto-saving until there's a real save,
4853 and prevent any more warnings. */
4854 XSETINT (b
->save_length
, -1);
4855 Fsleep_for (make_number (1), Qnil
);
4858 set_buffer_internal (b
);
4859 if (!auto_saved
&& NILP (no_message
))
4860 message1 ("Auto-saving...");
4861 internal_condition_case (auto_save_1
, Qt
, auto_save_error
);
4863 b
->auto_save_modified
= BUF_MODIFF (b
);
4864 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4865 set_buffer_internal (old
);
4867 EMACS_GET_TIME (after_time
);
4869 /* If auto-save took more than 60 seconds,
4870 assume it was an NFS failure that got a timeout. */
4871 if (EMACS_SECS (after_time
) - EMACS_SECS (before_time
) > 60)
4872 b
->auto_save_failure_time
= EMACS_SECS (after_time
);
4876 /* Prevent another auto save till enough input events come in. */
4877 record_auto_save ();
4879 if (auto_saved
&& NILP (no_message
))
4883 sit_for (1, 0, 0, 0, 0);
4884 message2 (omessage
, omessage_length
, oldmultibyte
);
4887 message1 ("Auto-saving...done");
4892 unbind_to (count
, Qnil
);
4896 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved
,
4897 Sset_buffer_auto_saved
, 0, 0, 0,
4898 "Mark current buffer as auto-saved with its current text.\n\
4899 No auto-save file will be written until the buffer changes again.")
4902 current_buffer
->auto_save_modified
= MODIFF
;
4903 XSETFASTINT (current_buffer
->save_length
, Z
- BEG
);
4904 current_buffer
->auto_save_failure_time
= -1;
4908 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure
,
4909 Sclear_buffer_auto_save_failure
, 0, 0, 0,
4910 "Clear any record of a recent auto-save failure in the current buffer.")
4913 current_buffer
->auto_save_failure_time
= -1;
4917 DEFUN ("recent-auto-save-p", Frecent_auto_save_p
, Srecent_auto_save_p
,
4919 "Return t if buffer has been auto-saved since last read in or saved.")
4922 return (SAVE_MODIFF
< current_buffer
->auto_save_modified
) ? Qt
: Qnil
;
4925 /* Reading and completing file names */
4926 extern Lisp_Object
Ffile_name_completion (), Ffile_name_all_completions ();
4928 /* In the string VAL, change each $ to $$ and return the result. */
4931 double_dollars (val
)
4934 register unsigned char *old
, *new;
4938 osize
= XSTRING (val
)->size_byte
;
4940 /* Count the number of $ characters. */
4941 for (n
= osize
, count
= 0, old
= XSTRING (val
)->data
; n
> 0; n
--)
4942 if (*old
++ == '$') count
++;
4945 old
= XSTRING (val
)->data
;
4946 val
= make_uninit_multibyte_string (XSTRING (val
)->size
+ count
,
4948 new = XSTRING (val
)->data
;
4949 for (n
= osize
; n
> 0; n
--)
4962 DEFUN ("read-file-name-internal", Fread_file_name_internal
, Sread_file_name_internal
,
4964 "Internal subroutine for read-file-name. Do not call this.")
4965 (string
, dir
, action
)
4966 Lisp_Object string
, dir
, action
;
4967 /* action is nil for complete, t for return list of completions,
4968 lambda for verify final value */
4970 Lisp_Object name
, specdir
, realdir
, val
, orig_string
;
4972 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
;
4974 CHECK_STRING (string
, 0);
4981 /* No need to protect ACTION--we only compare it with t and nil. */
4982 GCPRO5 (string
, realdir
, name
, specdir
, orig_string
);
4984 if (XSTRING (string
)->size
== 0)
4986 if (EQ (action
, Qlambda
))
4994 orig_string
= string
;
4995 string
= Fsubstitute_in_file_name (string
);
4996 changed
= NILP (Fstring_equal (string
, orig_string
));
4997 name
= Ffile_name_nondirectory (string
);
4998 val
= Ffile_name_directory (string
);
5000 realdir
= Fexpand_file_name (val
, realdir
);
5005 specdir
= Ffile_name_directory (string
);
5006 val
= Ffile_name_completion (name
, realdir
);
5011 return double_dollars (string
);
5015 if (!NILP (specdir
))
5016 val
= concat2 (specdir
, val
);
5018 return double_dollars (val
);
5021 #endif /* not VMS */
5025 if (EQ (action
, Qt
))
5026 return Ffile_name_all_completions (name
, realdir
);
5027 /* Only other case actually used is ACTION = lambda */
5029 /* Supposedly this helps commands such as `cd' that read directory names,
5030 but can someone explain how it helps them? -- RMS */
5031 if (XSTRING (name
)->size
== 0)
5034 return Ffile_exists_p (string
);
5037 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
5038 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
5039 Value is not expanded---you must call `expand-file-name' yourself.\n\
5040 Default name to DEFAULT-FILENAME if user enters a null string.\n\
5041 (If DEFAULT-FILENAME is omitted, the visited file name is used,\n\
5042 except that if INITIAL is specified, that combined with DIR is used.)\n\
5043 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
5044 Non-nil and non-t means also require confirmation after completion.\n\
5045 Fifth arg INITIAL specifies text to start with.\n\
5046 DIR defaults to current buffer's directory default.")
5047 (prompt
, dir
, default_filename
, mustmatch
, initial
)
5048 Lisp_Object prompt
, dir
, default_filename
, mustmatch
, initial
;
5050 Lisp_Object val
, insdef
, insdef1
, tem
;
5051 struct gcpro gcpro1
, gcpro2
;
5052 register char *homedir
;
5056 dir
= current_buffer
->directory
;
5057 if (NILP (default_filename
))
5059 if (! NILP (initial
))
5060 default_filename
= Fexpand_file_name (initial
, dir
);
5062 default_filename
= current_buffer
->filename
;
5065 /* If dir starts with user's homedir, change that to ~. */
5066 homedir
= (char *) egetenv ("HOME");
5068 homedir
= strcpy (alloca (strlen (homedir
) + 1), homedir
);
5069 CORRECT_DIR_SEPS (homedir
);
5073 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5074 && IS_DIRECTORY_SEP (XSTRING (dir
)->data
[strlen (homedir
)]))
5076 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5077 XSTRING (dir
)->size
- strlen (homedir
) + 1);
5078 XSTRING (dir
)->data
[0] = '~';
5081 if (insert_default_directory
&& STRINGP (dir
))
5084 if (!NILP (initial
))
5086 Lisp_Object args
[2], pos
;
5090 insdef
= Fconcat (2, args
);
5091 pos
= make_number (XSTRING (double_dollars (dir
))->size
);
5092 insdef1
= Fcons (double_dollars (insdef
), pos
);
5095 insdef1
= double_dollars (insdef
);
5097 else if (STRINGP (initial
))
5100 insdef1
= Fcons (double_dollars (insdef
), make_number (0));
5103 insdef
= Qnil
, insdef1
= Qnil
;
5106 count
= specpdl_ptr
- specpdl
;
5107 specbind (intern ("completion-ignore-case"), Qt
);
5110 GCPRO2 (insdef
, default_filename
);
5111 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5112 dir
, mustmatch
, insdef1
,
5113 Qfile_name_history
, default_filename
, Qnil
);
5114 /* If Fcompleting_read returned the default string itself
5115 (rather than a new string with the same contents),
5116 it has to mean that the user typed RET with the minibuffer empty.
5117 In that case, we really want to return ""
5118 so that commands such as set-visited-file-name can distinguish. */
5119 if (EQ (val
, default_filename
))
5120 val
= build_string ("");
5123 unbind_to (count
, Qnil
);
5128 error ("No file name specified");
5129 tem
= Fstring_equal (val
, insdef
);
5130 if (!NILP (tem
) && !NILP (default_filename
))
5131 return default_filename
;
5132 if (XSTRING (val
)->size
== 0 && NILP (insdef
))
5134 if (!NILP (default_filename
))
5135 return default_filename
;
5137 error ("No default file name");
5139 return Fsubstitute_in_file_name (val
);
5142 #if 0 /* Old version */
5143 DEFUN ("read-file-name", Fread_file_name
, Sread_file_name
, 1, 5, 0,
5144 /* Don't confuse make-docfile by having two doc strings for this function.
5145 make-docfile does not pay attention to #if, for good reason! */
5147 (prompt
, dir
, defalt
, mustmatch
, initial
)
5148 Lisp_Object prompt
, dir
, defalt
, mustmatch
, initial
;
5150 Lisp_Object val
, insdef
, tem
;
5151 struct gcpro gcpro1
, gcpro2
;
5152 register char *homedir
;
5156 dir
= current_buffer
->directory
;
5158 defalt
= current_buffer
->filename
;
5160 /* If dir starts with user's homedir, change that to ~. */
5161 homedir
= (char *) egetenv ("HOME");
5164 && !strncmp (homedir
, XSTRING (dir
)->data
, strlen (homedir
))
5165 && XSTRING (dir
)->data
[strlen (homedir
)] == '/')
5167 dir
= make_string (XSTRING (dir
)->data
+ strlen (homedir
) - 1,
5168 XSTRING (dir
)->size
- strlen (homedir
) + 1);
5169 XSTRING (dir
)->data
[0] = '~';
5172 if (!NILP (initial
))
5174 else if (insert_default_directory
)
5177 insdef
= build_string ("");
5180 count
= specpdl_ptr
- specpdl
;
5181 specbind (intern ("completion-ignore-case"), Qt
);
5184 GCPRO2 (insdef
, defalt
);
5185 val
= Fcompleting_read (prompt
, intern ("read-file-name-internal"),
5187 insert_default_directory
? insdef
: Qnil
,
5188 Qfile_name_history
, Qnil
, Qnil
);
5191 unbind_to (count
, Qnil
);
5196 error ("No file name specified");
5197 tem
= Fstring_equal (val
, insdef
);
5198 if (!NILP (tem
) && !NILP (defalt
))
5200 return Fsubstitute_in_file_name (val
);
5202 #endif /* Old version */
5206 Qexpand_file_name
= intern ("expand-file-name");
5207 Qsubstitute_in_file_name
= intern ("substitute-in-file-name");
5208 Qdirectory_file_name
= intern ("directory-file-name");
5209 Qfile_name_directory
= intern ("file-name-directory");
5210 Qfile_name_nondirectory
= intern ("file-name-nondirectory");
5211 Qunhandled_file_name_directory
= intern ("unhandled-file-name-directory");
5212 Qfile_name_as_directory
= intern ("file-name-as-directory");
5213 Qcopy_file
= intern ("copy-file");
5214 Qmake_directory_internal
= intern ("make-directory-internal");
5215 Qdelete_directory
= intern ("delete-directory");
5216 Qdelete_file
= intern ("delete-file");
5217 Qrename_file
= intern ("rename-file");
5218 Qadd_name_to_file
= intern ("add-name-to-file");
5219 Qmake_symbolic_link
= intern ("make-symbolic-link");
5220 Qfile_exists_p
= intern ("file-exists-p");
5221 Qfile_executable_p
= intern ("file-executable-p");
5222 Qfile_readable_p
= intern ("file-readable-p");
5223 Qfile_writable_p
= intern ("file-writable-p");
5224 Qfile_symlink_p
= intern ("file-symlink-p");
5225 Qaccess_file
= intern ("access-file");
5226 Qfile_directory_p
= intern ("file-directory-p");
5227 Qfile_regular_p
= intern ("file-regular-p");
5228 Qfile_accessible_directory_p
= intern ("file-accessible-directory-p");
5229 Qfile_modes
= intern ("file-modes");
5230 Qset_file_modes
= intern ("set-file-modes");
5231 Qfile_newer_than_file_p
= intern ("file-newer-than-file-p");
5232 Qinsert_file_contents
= intern ("insert-file-contents");
5233 Qwrite_region
= intern ("write-region");
5234 Qverify_visited_file_modtime
= intern ("verify-visited-file-modtime");
5235 Qset_visited_file_modtime
= intern ("set-visited-file-modtime");
5237 staticpro (&Qexpand_file_name
);
5238 staticpro (&Qsubstitute_in_file_name
);
5239 staticpro (&Qdirectory_file_name
);
5240 staticpro (&Qfile_name_directory
);
5241 staticpro (&Qfile_name_nondirectory
);
5242 staticpro (&Qunhandled_file_name_directory
);
5243 staticpro (&Qfile_name_as_directory
);
5244 staticpro (&Qcopy_file
);
5245 staticpro (&Qmake_directory_internal
);
5246 staticpro (&Qdelete_directory
);
5247 staticpro (&Qdelete_file
);
5248 staticpro (&Qrename_file
);
5249 staticpro (&Qadd_name_to_file
);
5250 staticpro (&Qmake_symbolic_link
);
5251 staticpro (&Qfile_exists_p
);
5252 staticpro (&Qfile_executable_p
);
5253 staticpro (&Qfile_readable_p
);
5254 staticpro (&Qfile_writable_p
);
5255 staticpro (&Qaccess_file
);
5256 staticpro (&Qfile_symlink_p
);
5257 staticpro (&Qfile_directory_p
);
5258 staticpro (&Qfile_regular_p
);
5259 staticpro (&Qfile_accessible_directory_p
);
5260 staticpro (&Qfile_modes
);
5261 staticpro (&Qset_file_modes
);
5262 staticpro (&Qfile_newer_than_file_p
);
5263 staticpro (&Qinsert_file_contents
);
5264 staticpro (&Qwrite_region
);
5265 staticpro (&Qverify_visited_file_modtime
);
5266 staticpro (&Qset_visited_file_modtime
);
5268 Qfile_name_history
= intern ("file-name-history");
5269 Fset (Qfile_name_history
, Qnil
);
5270 staticpro (&Qfile_name_history
);
5272 Qfile_error
= intern ("file-error");
5273 staticpro (&Qfile_error
);
5274 Qfile_already_exists
= intern ("file-already-exists");
5275 staticpro (&Qfile_already_exists
);
5276 Qfile_date_error
= intern ("file-date-error");
5277 staticpro (&Qfile_date_error
);
5280 Qfind_buffer_file_type
= intern ("find-buffer-file-type");
5281 staticpro (&Qfind_buffer_file_type
);
5284 DEFVAR_LISP ("file-name-coding-system", &Vfile_name_coding_system
,
5285 "*Coding system for encoding file names.");
5286 Vfile_name_coding_system
= Qnil
;
5288 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format
,
5289 "*Format in which to write auto-save files.\n\
5290 Should be a list of symbols naming formats that are defined in `format-alist'.\n\
5291 If it is t, which is the default, auto-save files are written in the\n\
5292 same format as a regular save would use.");
5293 Vauto_save_file_format
= Qt
;
5295 Qformat_decode
= intern ("format-decode");
5296 staticpro (&Qformat_decode
);
5297 Qformat_annotate_function
= intern ("format-annotate-function");
5298 staticpro (&Qformat_annotate_function
);
5300 Qcar_less_than_car
= intern ("car-less-than-car");
5301 staticpro (&Qcar_less_than_car
);
5303 Fput (Qfile_error
, Qerror_conditions
,
5304 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
)));
5305 Fput (Qfile_error
, Qerror_message
,
5306 build_string ("File error"));
5308 Fput (Qfile_already_exists
, Qerror_conditions
,
5309 Fcons (Qfile_already_exists
,
5310 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5311 Fput (Qfile_already_exists
, Qerror_message
,
5312 build_string ("File already exists"));
5314 Fput (Qfile_date_error
, Qerror_conditions
,
5315 Fcons (Qfile_date_error
,
5316 Fcons (Qfile_error
, Fcons (Qerror
, Qnil
))));
5317 Fput (Qfile_date_error
, Qerror_message
,
5318 build_string ("Cannot set file date"));
5320 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory
,
5321 "*Non-nil means when reading a filename start with default dir in minibuffer.");
5322 insert_default_directory
= 1;
5324 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm
,
5325 "*Non-nil means write new files with record format `stmlf'.\n\
5326 nil means use format `var'. This variable is meaningful only on VMS.");
5327 vms_stmlf_recfm
= 0;
5329 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char
,
5330 "Directory separator character for built-in functions that return file names.\n\
5331 The value should be either ?/ or ?\\ (any other value is treated as ?\\).\n\
5332 This variable affects the built-in functions only on Windows,\n\
5333 on other platforms, it is initialized so that Lisp code can find out\n\
5334 what the normal separator is.");
5335 XSETFASTINT (Vdirectory_sep_char
, '/');
5337 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist
,
5338 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
5339 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
5342 The first argument given to HANDLER is the name of the I/O primitive\n\
5343 to be handled; the remaining arguments are the arguments that were\n\
5344 passed to that primitive. For example, if you do\n\
5345 (file-exists-p FILENAME)\n\
5346 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
5347 (funcall HANDLER 'file-exists-p FILENAME)\n\
5348 The function `find-file-name-handler' checks this list for a handler\n\
5349 for its argument.");
5350 Vfile_name_handler_alist
= Qnil
;
5352 DEFVAR_LISP ("set-auto-coding-function",
5353 &Vset_auto_coding_function
,
5354 "If non-nil, a function to call to decide a coding system of file.\n\
5355 One argument is passed to this function: the string of concatination\n\
5356 or the heading 1K-byte and the tailing 3K-byte of a file to be read.\n\
5357 This function should return a coding system to decode the file contents\n\
5358 specified in the heading lines with the format:\n\
5359 -*- ... coding: CODING-SYSTEM; ... -*-\n\
5360 or local variable spec of the tailing lines with `coding:' tag.");
5361 Vset_auto_coding_function
= Qnil
;
5363 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions
,
5364 "A list of functions to be called at the end of `insert-file-contents'.\n\
5365 Each is passed one argument, the number of bytes inserted. It should return\n\
5366 the new byte count, and leave point the same. If `insert-file-contents' is\n\
5367 intercepted by a handler from `file-name-handler-alist', that handler is\n\
5368 responsible for calling the after-insert-file-functions if appropriate.");
5369 Vafter_insert_file_functions
= Qnil
;
5371 DEFVAR_LISP ("write-region-annotate-functions", &Vwrite_region_annotate_functions
,
5372 "A list of functions to be called at the start of `write-region'.\n\
5373 Each is passed two arguments, START and END as for `write-region'.\n\
5374 These are usually two numbers but not always; see the documentation\n\
5375 for `write-region'. The function should return a list of pairs\n\
5376 of the form (POSITION . STRING), consisting of strings to be effectively\n\
5377 inserted at the specified positions of the file being written (1 means to\n\
5378 insert before the first byte written). The POSITIONs must be sorted into\n\
5379 increasing order. If there are several functions in the list, the several\n\
5380 lists are merged destructively.");
5381 Vwrite_region_annotate_functions
= Qnil
;
5383 DEFVAR_LISP ("write-region-annotations-so-far",
5384 &Vwrite_region_annotations_so_far
,
5385 "When an annotation function is called, this holds the previous annotations.\n\
5386 These are the annotations made by other annotation functions\n\
5387 that were already called. See also `write-region-annotate-functions'.");
5388 Vwrite_region_annotations_so_far
= Qnil
;
5390 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers
,
5391 "A list of file name handlers that temporarily should not be used.\n\
5392 This applies only to the operation `inhibit-file-name-operation'.");
5393 Vinhibit_file_name_handlers
= Qnil
;
5395 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation
,
5396 "The operation for which `inhibit-file-name-handlers' is applicable.");
5397 Vinhibit_file_name_operation
= Qnil
;
5399 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name
,
5400 "File name in which we write a list of all auto save file names.\n\
5401 This variable is initialized automatically from `auto-save-list-file-prefix'\n\
5402 shortly after Emacs reads your `.emacs' file, if you have not yet given it\n\
5404 Vauto_save_list_file_name
= Qnil
;
5406 defsubr (&Sfind_file_name_handler
);
5407 defsubr (&Sfile_name_directory
);
5408 defsubr (&Sfile_name_nondirectory
);
5409 defsubr (&Sunhandled_file_name_directory
);
5410 defsubr (&Sfile_name_as_directory
);
5411 defsubr (&Sdirectory_file_name
);
5412 defsubr (&Smake_temp_name
);
5413 defsubr (&Sexpand_file_name
);
5414 defsubr (&Ssubstitute_in_file_name
);
5415 defsubr (&Scopy_file
);
5416 defsubr (&Smake_directory_internal
);
5417 defsubr (&Sdelete_directory
);
5418 defsubr (&Sdelete_file
);
5419 defsubr (&Srename_file
);
5420 defsubr (&Sadd_name_to_file
);
5422 defsubr (&Smake_symbolic_link
);
5423 #endif /* S_IFLNK */
5425 defsubr (&Sdefine_logical_name
);
5428 defsubr (&Ssysnetunam
);
5429 #endif /* HPUX_NET */
5430 defsubr (&Sfile_name_absolute_p
);
5431 defsubr (&Sfile_exists_p
);
5432 defsubr (&Sfile_executable_p
);
5433 defsubr (&Sfile_readable_p
);
5434 defsubr (&Sfile_writable_p
);
5435 defsubr (&Saccess_file
);
5436 defsubr (&Sfile_symlink_p
);
5437 defsubr (&Sfile_directory_p
);
5438 defsubr (&Sfile_accessible_directory_p
);
5439 defsubr (&Sfile_regular_p
);
5440 defsubr (&Sfile_modes
);
5441 defsubr (&Sset_file_modes
);
5442 defsubr (&Sset_default_file_modes
);
5443 defsubr (&Sdefault_file_modes
);
5444 defsubr (&Sfile_newer_than_file_p
);
5445 defsubr (&Sinsert_file_contents
);
5446 defsubr (&Swrite_region
);
5447 defsubr (&Scar_less_than_car
);
5448 defsubr (&Sverify_visited_file_modtime
);
5449 defsubr (&Sclear_visited_file_modtime
);
5450 defsubr (&Svisited_file_modtime
);
5451 defsubr (&Sset_visited_file_modtime
);
5452 defsubr (&Sdo_auto_save
);
5453 defsubr (&Sset_buffer_auto_saved
);
5454 defsubr (&Sclear_buffer_auto_save_failure
);
5455 defsubr (&Srecent_auto_save_p
);
5457 defsubr (&Sread_file_name_internal
);
5458 defsubr (&Sread_file_name
);
5461 defsubr (&Sunix_sync
);