Mercurial > hg > xemacs-beta
annotate src/fileio.c @ 4407:4ee73bbe4f8e
Always use boyer_moore in ASCII or Latin-1 buffers with ASCII search strings.
2007-12-26 Aidan Kehoe <kehoea@parhasard.net>
* casetab.c:
Extend and correct some case table documentation.
* search.c (search_buffer):
Correct a bug where only the first entry for a character in the
case equivalence table was examined in determining if the
Boyer-Moore search algorithm is appropriate.
If there are case mappings outside of the charset and row of the
characters specified in the search string, those case mappings can
be safely ignored (and Boyer-Moore search can be used) if we know
from the buffer statistics that the corresponding characters cannot
occur.
* search.c (boyer_moore):
Assert that we haven't been passed a string with varying
characters sets or rows within character sets. That's what
simple_search is for.
In the very rare event that a character in the search string has a
canonical case mapping that is not in the same character set and
row, don't try to search for the canonical character, search for
some other character that is in the the desired character set and
row. Assert that the case table isn't corrupt.
Do not search for any character case mappings that cannot possibly
occur in the buffer, given the buffer metadata about its
contents.
author | Aidan Kehoe <kehoea@parhasard.net> |
---|---|
date | Wed, 26 Dec 2007 17:30:16 +0100 |
parents | 5e526366d533 |
children | 1e04b9c8125b |
rev | line source |
---|---|
428 | 1 /* File IO for XEmacs. |
2 Copyright (C) 1985-1988, 1992-1995 Free Software Foundation, Inc. | |
2367 | 3 Copyright (C) 1996, 2001, 2002, 2003, 2004 Ben Wing. |
428 | 4 |
5 This file is part of XEmacs. | |
6 | |
7 XEmacs is free software; you can redistribute it and/or modify it | |
8 under the terms of the GNU General Public License as published by the | |
9 Free Software Foundation; either version 2, or (at your option) any | |
10 later version. | |
11 | |
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT | |
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
15 for more details. | |
16 | |
17 You should have received a copy of the GNU General Public License | |
18 along with XEmacs; see the file COPYING. If not, write to | |
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
20 Boston, MA 02111-1307, USA. */ | |
21 | |
22 /* Synched up with: Mule 2.0, FSF 19.30. */ | |
771 | 23 /* More syncing: FSF Emacs 19.34.6 by Marc Paquette <marcpa@cam.org> |
24 (Note: Sync messages from Marc Paquette may indicate | |
25 incomplete synching, so beware.) */ | |
2526 | 26 /* Some functions synched with FSF 21.0.103. */ |
771 | 27 /* Mule-ized completely except for the #if 0-code including decrypt-string |
28 and encrypt-string. --ben 7-2-00 */ | |
1333 | 29 /* #if 0-code Mule-ized, 2-22-03. --ben */ |
771 | 30 |
428 | 31 |
32 #include <config.h> | |
33 #include "lisp.h" | |
34 | |
35 #include "buffer.h" | |
800 | 36 #include "device.h" |
428 | 37 #include "events.h" |
800 | 38 #include "file-coding.h" |
428 | 39 #include "frame.h" |
40 #include "insdel.h" | |
41 #include "lstream.h" | |
2526 | 42 #include "profile.h" |
872 | 43 #include "process.h" |
428 | 44 #include "redisplay.h" |
45 #include "sysdep.h" | |
872 | 46 #include "window-impl.h" |
771 | 47 |
428 | 48 #include "sysfile.h" |
49 #include "sysproc.h" | |
50 #include "syspwd.h" | |
51 #include "systime.h" | |
52 #include "sysdir.h" | |
53 | |
54 #ifdef HPUX | |
55 #include <netio.h> | |
56 #ifdef HPUX_PRE_8_0 | |
57 #include <errnet.h> | |
58 #endif /* HPUX_PRE_8_0 */ | |
59 #endif /* HPUX */ | |
60 | |
1315 | 61 #ifdef WIN32_ANY |
657 | 62 #define WIN32_FILENAMES |
771 | 63 #include "syswindows.h" |
428 | 64 #define IS_DRIVE(x) isalpha (x) |
65 /* Need to lower-case the drive letter, or else expanded | |
66 filenames will sometimes compare inequal, because | |
67 `expand-file-name' doesn't always down-case the drive letter. */ | |
68 #define DRIVE_LETTER(x) tolower (x) | |
657 | 69 #endif /* WIN32_NATIVE || CYGWIN */ |
428 | 70 |
71 int lisp_to_time (Lisp_Object, time_t *); | |
72 Lisp_Object time_to_lisp (time_t); | |
73 | |
74 /* Nonzero during writing of auto-save files */ | |
75 static int auto_saving; | |
76 | |
77 /* Set by auto_save_1 to mode of original file so Fwrite_region_internal | |
78 will create a new file with the same mode as the original */ | |
79 static int auto_save_mode_bits; | |
80 | |
81 /* Alist of elements (REGEXP . HANDLER) for file names | |
82 whose I/O is done with a special handler. */ | |
83 Lisp_Object Vfile_name_handler_alist; | |
84 | |
85 /* Format for auto-save files */ | |
86 Lisp_Object Vauto_save_file_format; | |
87 | |
88 /* Lisp functions for translating file formats */ | |
89 Lisp_Object Qformat_decode, Qformat_annotate_function; | |
90 | |
91 /* Functions to be called to process text properties in inserted file. */ | |
92 Lisp_Object Vafter_insert_file_functions; | |
93 | |
94 /* Functions to be called to create text property annotations for file. */ | |
95 Lisp_Object Vwrite_region_annotate_functions; | |
96 | |
97 /* During build_annotations, each time an annotation function is called, | |
98 this holds the annotations made by the previous functions. */ | |
99 Lisp_Object Vwrite_region_annotations_so_far; | |
100 | |
101 /* File name in which we write a list of all our auto save files. */ | |
102 Lisp_Object Vauto_save_list_file_name; | |
103 | |
444 | 104 /* Prefix used to construct Vauto_save_list_file_name. */ |
105 Lisp_Object Vauto_save_list_file_prefix; | |
106 | |
107 /* When non-nil, it prevents auto-save list file creation. */ | |
108 int inhibit_auto_save_session; | |
109 | |
428 | 110 int disable_auto_save_when_buffer_shrinks; |
111 | |
112 Lisp_Object Vdirectory_sep_char; | |
113 | |
114 /* These variables describe handlers that have "already" had a chance | |
115 to handle the current operation. | |
116 | |
117 Vinhibit_file_name_handlers is a list of file name handlers. | |
118 Vinhibit_file_name_operation is the operation being handled. | |
119 If we try to handle that operation, we ignore those handlers. */ | |
120 | |
121 static Lisp_Object Vinhibit_file_name_handlers; | |
122 static Lisp_Object Vinhibit_file_name_operation; | |
123 | |
563 | 124 Lisp_Object Qfile_already_exists; |
4266 | 125 Lisp_Object Qexcl; |
428 | 126 |
127 Lisp_Object Qauto_save_hook; | |
128 Lisp_Object Qauto_save_error; | |
129 Lisp_Object Qauto_saving; | |
130 | |
131 Lisp_Object Qcar_less_than_car; | |
132 | |
133 Lisp_Object Qcompute_buffer_file_truename; | |
134 | |
2526 | 135 Lisp_Object QSin_expand_file_name; |
136 | |
428 | 137 EXFUN (Frunning_temacs_p, 0); |
138 | |
563 | 139 /* DATA can be anything acceptable to signal_error (). |
140 */ | |
141 | |
142 DOESNT_RETURN | |
143 report_file_type_error (Lisp_Object errtype, Lisp_Object oserrmess, | |
867 | 144 const CIbyte *string, Lisp_Object data) |
563 | 145 { |
146 struct gcpro gcpro1; | |
147 Lisp_Object errdata = build_error_data (NULL, data); | |
148 | |
149 GCPRO1 (errdata); | |
771 | 150 errdata = Fcons (build_msg_string (string), |
563 | 151 Fcons (oserrmess, errdata)); |
152 signal_error_1 (errtype, errdata); | |
801 | 153 /* UNGCPRO; not reached */ |
563 | 154 } |
155 | |
156 DOESNT_RETURN | |
157 report_error_with_errno (Lisp_Object errtype, | |
867 | 158 const CIbyte *string, Lisp_Object data) |
563 | 159 { |
160 report_file_type_error (errtype, lisp_strerror (errno), string, data); | |
161 } | |
162 | |
428 | 163 /* signal a file error when errno contains a meaningful value. */ |
164 | |
165 DOESNT_RETURN | |
867 | 166 report_file_error (const CIbyte *string, Lisp_Object data) |
428 | 167 { |
563 | 168 report_error_with_errno (Qfile_error, string, data); |
428 | 169 } |
170 | |
171 | |
172 /* Just like strerror(3), except return a lisp string instead of char *. | |
173 The string needs to be converted since it may be localized. | |
771 | 174 */ |
428 | 175 Lisp_Object |
176 lisp_strerror (int errnum) | |
177 { | |
771 | 178 Extbyte *ret = strerror (errnum); |
179 if (!ret) | |
180 { | |
867 | 181 Ibyte ffff[99]; |
771 | 182 qxesprintf (ffff, "Unknown error %d", errnum); |
183 return build_intstring (ffff); | |
184 } | |
185 return build_ext_string (ret, Qstrerror_encoding); | |
428 | 186 } |
187 | |
188 static Lisp_Object | |
189 close_file_unwind (Lisp_Object fd) | |
190 { | |
191 if (CONSP (fd)) | |
192 { | |
193 if (INTP (XCAR (fd))) | |
771 | 194 retry_close (XINT (XCAR (fd))); |
428 | 195 |
853 | 196 free_cons (fd); |
428 | 197 } |
198 else | |
771 | 199 retry_close (XINT (fd)); |
428 | 200 |
201 return Qnil; | |
202 } | |
203 | |
204 static Lisp_Object | |
205 delete_stream_unwind (Lisp_Object stream) | |
206 { | |
207 Lstream_delete (XLSTREAM (stream)); | |
208 return Qnil; | |
209 } | |
210 | |
211 /* Restore point, having saved it as a marker. */ | |
212 | |
213 static Lisp_Object | |
214 restore_point_unwind (Lisp_Object point_marker) | |
215 { | |
216 BUF_SET_PT (current_buffer, marker_position (point_marker)); | |
217 return Fset_marker (point_marker, Qnil, Qnil); | |
218 } | |
219 | |
220 | |
221 Lisp_Object Qexpand_file_name; | |
222 Lisp_Object Qfile_truename; | |
223 Lisp_Object Qsubstitute_in_file_name; | |
224 Lisp_Object Qdirectory_file_name; | |
225 Lisp_Object Qfile_name_directory; | |
226 Lisp_Object Qfile_name_nondirectory; | |
996 | 227 Lisp_Object Qfile_name_sans_extension; |
428 | 228 Lisp_Object Qunhandled_file_name_directory; |
229 Lisp_Object Qfile_name_as_directory; | |
230 Lisp_Object Qcopy_file; | |
231 Lisp_Object Qmake_directory_internal; | |
232 Lisp_Object Qdelete_directory; | |
233 Lisp_Object Qdelete_file; | |
234 Lisp_Object Qrename_file; | |
235 Lisp_Object Qadd_name_to_file; | |
236 Lisp_Object Qmake_symbolic_link; | |
844 | 237 Lisp_Object Qmake_temp_name; |
428 | 238 Lisp_Object Qfile_exists_p; |
239 Lisp_Object Qfile_executable_p; | |
240 Lisp_Object Qfile_readable_p; | |
241 Lisp_Object Qfile_symlink_p; | |
242 Lisp_Object Qfile_writable_p; | |
243 Lisp_Object Qfile_directory_p; | |
244 Lisp_Object Qfile_regular_p; | |
245 Lisp_Object Qfile_accessible_directory_p; | |
246 Lisp_Object Qfile_modes; | |
247 Lisp_Object Qset_file_modes; | |
248 Lisp_Object Qfile_newer_than_file_p; | |
249 Lisp_Object Qinsert_file_contents; | |
250 Lisp_Object Qwrite_region; | |
251 Lisp_Object Qverify_visited_file_modtime; | |
252 Lisp_Object Qset_visited_file_modtime; | |
253 | |
254 /* If FILENAME is handled specially on account of its syntax, | |
255 return its handler function. Otherwise, return nil. */ | |
256 | |
257 DEFUN ("find-file-name-handler", Ffind_file_name_handler, 1, 2, 0, /* | |
258 Return FILENAME's handler function for OPERATION, if it has one. | |
259 Otherwise, return nil. | |
260 A file name is handled if one of the regular expressions in | |
261 `file-name-handler-alist' matches it. | |
262 | |
263 If OPERATION equals `inhibit-file-name-operation', then we ignore | |
264 any handlers that are members of `inhibit-file-name-handlers', | |
265 but we still do run any other handlers. This lets handlers | |
266 use the standard functions without calling themselves recursively. | |
751 | 267 |
268 Otherwise, OPERATION is the name of a funcall'able function. | |
428 | 269 */ |
270 (filename, operation)) | |
271 { | |
272 /* This function does not GC */ | |
273 /* This function can be called during GC */ | |
274 /* This function must not munge the match data. */ | |
2367 | 275 Lisp_Object inhibited_handlers; |
428 | 276 |
277 CHECK_STRING (filename); | |
278 | |
279 if (EQ (operation, Vinhibit_file_name_operation)) | |
280 inhibited_handlers = Vinhibit_file_name_handlers; | |
281 else | |
282 inhibited_handlers = Qnil; | |
283 | |
2367 | 284 { |
285 EXTERNAL_LIST_LOOP_2 (elt, Vfile_name_handler_alist) | |
286 { | |
287 if (CONSP (elt)) | |
288 { | |
289 Lisp_Object string = XCAR (elt); | |
290 if (STRINGP (string) | |
291 && (fast_lisp_string_match (string, filename) >= 0)) | |
292 { | |
293 Lisp_Object handler = XCDR (elt); | |
294 if (NILP (Fmemq (handler, inhibited_handlers))) | |
295 return handler; | |
296 } | |
297 } | |
298 } | |
299 } | |
428 | 300 return Qnil; |
301 } | |
302 | |
303 static Lisp_Object | |
304 call2_check_string (Lisp_Object fn, Lisp_Object arg0, Lisp_Object arg1) | |
305 { | |
306 /* This function can call lisp */ | |
307 Lisp_Object result = call2 (fn, arg0, arg1); | |
308 CHECK_STRING (result); | |
309 return result; | |
310 } | |
311 | |
312 static Lisp_Object | |
313 call2_check_string_or_nil (Lisp_Object fn, Lisp_Object arg0, Lisp_Object arg1) | |
314 { | |
315 /* This function can call lisp */ | |
316 Lisp_Object result = call2 (fn, arg0, arg1); | |
317 if (!NILP (result)) | |
318 CHECK_STRING (result); | |
319 return result; | |
320 } | |
321 | |
322 static Lisp_Object | |
323 call3_check_string (Lisp_Object fn, Lisp_Object arg0, | |
324 Lisp_Object arg1, Lisp_Object arg2) | |
325 { | |
326 /* This function can call lisp */ | |
327 Lisp_Object result = call3 (fn, arg0, arg1, arg2); | |
328 CHECK_STRING (result); | |
329 return result; | |
330 } | |
331 | |
332 | |
2526 | 333 |
334 Ibyte * | |
335 find_end_of_directory_component (const Ibyte *path, Bytecount len) | |
336 { | |
337 const Ibyte *p = path + len; | |
338 | |
339 while (p != path && !IS_DIRECTORY_SEP (p[-1]) | |
340 #ifdef WIN32_FILENAMES | |
341 /* only recognise drive specifier at the beginning */ | |
342 && !(p[-1] == ':' | |
343 /* handle the "/:d:foo" and "/:foo" cases correctly */ | |
344 && ((p == path + 2 && !IS_DIRECTORY_SEP (*path)) | |
345 || (p == path + 4 && IS_DIRECTORY_SEP (*path)))) | |
346 #endif | |
347 ) p--; | |
348 | |
349 return (Ibyte *) p; | |
350 } | |
351 | |
428 | 352 DEFUN ("file-name-directory", Ffile_name_directory, 1, 1, 0, /* |
444 | 353 Return the directory component in file name FILENAME. |
354 Return nil if FILENAME does not include a directory. | |
428 | 355 Otherwise return a directory spec. |
356 Given a Unix syntax file name, returns a string ending in slash. | |
357 */ | |
444 | 358 (filename)) |
428 | 359 { |
442 | 360 /* This function can GC. GC checked 2000-07-28 ben */ |
771 | 361 /* This function synched with Emacs 21.0.103. */ |
867 | 362 Ibyte *beg; |
363 Ibyte *p; | |
428 | 364 Lisp_Object handler; |
365 | |
444 | 366 CHECK_STRING (filename); |
428 | 367 |
368 /* If the file name has special constructs in it, | |
369 call the corresponding file handler. */ | |
444 | 370 handler = Ffind_file_name_handler (filename, Qfile_name_directory); |
428 | 371 if (!NILP (handler)) |
444 | 372 return call2_check_string_or_nil (handler, Qfile_name_directory, filename); |
428 | 373 |
374 #ifdef FILE_SYSTEM_CASE | |
444 | 375 filename = FILE_SYSTEM_CASE (filename); |
428 | 376 #endif |
444 | 377 beg = XSTRING_DATA (filename); |
771 | 378 /* XEmacs: no need to alloca-copy here */ |
2526 | 379 p = find_end_of_directory_component (beg, XSTRING_LENGTH (filename)); |
428 | 380 |
381 if (p == beg) | |
382 return Qnil; | |
442 | 383 #ifdef WIN32_NATIVE |
428 | 384 /* Expansion of "c:" to drive and default directory. */ |
771 | 385 if (p[-1] == ':') |
428 | 386 { |
867 | 387 Ibyte *res; |
388 Ibyte *wd = mswindows_getdcwd (toupper (*beg) - 'A' + 1); | |
771 | 389 |
2367 | 390 res = alloca_ibytes ((wd ? qxestrlen (wd) : 0) + 10); /* go overboard */ |
1116 | 391 res[0] = '\0'; |
771 | 392 if (p == beg + 4 && IS_DIRECTORY_SEP (*beg) && beg[1] == ':') |
393 { | |
394 qxestrncpy (res, beg, 2); | |
395 beg += 2; | |
1116 | 396 res[2] = '\0'; |
771 | 397 } |
398 | |
399 if (wd) | |
428 | 400 { |
3648 | 401 int size; |
771 | 402 qxestrcat (res, wd); |
3648 | 403 size = qxestrlen (res); |
404 if (!IS_DIRECTORY_SEP (res[size - 1])) | |
405 { | |
406 res[size] = DIRECTORY_SEP; | |
407 res[size + 1] = '\0'; | |
408 } | |
428 | 409 beg = res; |
771 | 410 p = beg + qxestrlen (beg); |
428 | 411 } |
3648 | 412 else |
413 { | |
414 return Qnil; | |
415 } | |
771 | 416 if (wd) |
1726 | 417 xfree (wd, Ibyte *); |
428 | 418 } |
771 | 419 |
420 #if 0 /* No! This screws up efs, which calls file-name-directory on URL's | |
421 and expects the slashes to be left alone. This is here because of | |
422 an analogous call in FSF 21. */ | |
423 { | |
424 Bytecount len = p - beg; | |
867 | 425 Ibyte *newbeg = alloca_ibytes (len + 1); |
771 | 426 |
427 qxestrncpy (newbeg, beg, len); | |
428 newbeg[len] = '\0'; | |
429 newbeg = mswindows_canonicalize_filename (newbeg); | |
1726 | 430 return build_intstring (newbeg); |
771 | 431 } |
432 #endif | |
433 #endif /* not WIN32_NATIVE */ | |
428 | 434 return make_string (beg, p - beg); |
435 } | |
436 | |
437 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory, 1, 1, 0, /* | |
444 | 438 Return file name FILENAME sans its directory. |
428 | 439 For example, in a Unix-syntax file name, |
440 this is everything after the last slash, | |
441 or the entire name if it contains no slash. | |
442 */ | |
444 | 443 (filename)) |
428 | 444 { |
442 | 445 /* This function can GC. GC checked 2000-07-28 ben */ |
771 | 446 /* This function synched with Emacs 21.0.103. */ |
867 | 447 Ibyte *beg, *p, *end; |
428 | 448 Lisp_Object handler; |
449 | |
444 | 450 CHECK_STRING (filename); |
428 | 451 |
452 /* If the file name has special constructs in it, | |
453 call the corresponding file handler. */ | |
444 | 454 handler = Ffind_file_name_handler (filename, Qfile_name_nondirectory); |
428 | 455 if (!NILP (handler)) |
444 | 456 return call2_check_string (handler, Qfile_name_nondirectory, filename); |
457 | |
458 beg = XSTRING_DATA (filename); | |
459 end = p = beg + XSTRING_LENGTH (filename); | |
428 | 460 |
771 | 461 while (p != beg && !IS_DIRECTORY_SEP (p[-1]) |
657 | 462 #ifdef WIN32_FILENAMES |
771 | 463 /* only recognise drive specifier at beginning */ |
464 && !(p[-1] == ':' | |
465 /* handle the "/:d:foo" case correctly */ | |
466 && (p == beg + 2 || (p == beg + 4 && IS_DIRECTORY_SEP (*beg)))) | |
428 | 467 #endif |
771 | 468 ) |
469 p--; | |
428 | 470 |
471 return make_string (p, end - p); | |
472 } | |
473 | |
474 DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory, 1, 1, 0, /* | |
475 Return a directly usable directory name somehow associated with FILENAME. | |
476 A `directly usable' directory name is one that may be used without the | |
477 intervention of any file handler. | |
478 If FILENAME is a directly usable file itself, return | |
479 \(file-name-directory FILENAME). | |
480 The `call-process' and `start-process' functions use this function to | |
481 get a current directory to run processes in. | |
482 */ | |
444 | 483 (filename)) |
428 | 484 { |
442 | 485 /* This function can GC. GC checked 2000-07-28 ben */ |
428 | 486 Lisp_Object handler; |
487 | |
488 /* If the file name has special constructs in it, | |
489 call the corresponding file handler. */ | |
490 handler = Ffind_file_name_handler (filename, Qunhandled_file_name_directory); | |
491 if (!NILP (handler)) | |
492 return call2 (handler, Qunhandled_file_name_directory, | |
493 filename); | |
494 | |
495 return Ffile_name_directory (filename); | |
496 } | |
497 | |
498 | |
867 | 499 static Ibyte * |
500 file_name_as_directory (Ibyte *out, Ibyte *in) | |
428 | 501 { |
442 | 502 /* This function cannot GC */ |
771 | 503 int size = qxestrlen (in); |
428 | 504 |
505 if (size == 0) | |
506 { | |
507 out[0] = '.'; | |
508 out[1] = DIRECTORY_SEP; | |
509 out[2] = '\0'; | |
510 } | |
511 else | |
512 { | |
771 | 513 qxestrcpy (out, in); |
428 | 514 /* Append a slash if necessary */ |
515 if (!IS_ANY_SEP (out[size-1])) | |
516 { | |
517 out[size] = DIRECTORY_SEP; | |
518 out[size + 1] = '\0'; | |
519 } | |
520 } | |
521 return out; | |
522 } | |
523 | |
524 DEFUN ("file-name-as-directory", Ffile_name_as_directory, 1, 1, 0, /* | |
525 Return a string representing file FILENAME interpreted as a directory. | |
526 This operation exists because a directory is also a file, but its name as | |
527 a directory is different from its name as a file. | |
528 The result can be used as the value of `default-directory' | |
529 or passed as second argument to `expand-file-name'. | |
530 For a Unix-syntax file name, just appends a slash, | |
531 except for (file-name-as-directory \"\") => \"./\". | |
532 */ | |
444 | 533 (filename)) |
428 | 534 { |
442 | 535 /* This function can GC. GC checked 2000-07-28 ben */ |
867 | 536 Ibyte *buf; |
428 | 537 Lisp_Object handler; |
538 | |
444 | 539 CHECK_STRING (filename); |
428 | 540 |
541 /* If the file name has special constructs in it, | |
542 call the corresponding file handler. */ | |
444 | 543 handler = Ffind_file_name_handler (filename, Qfile_name_as_directory); |
428 | 544 if (!NILP (handler)) |
444 | 545 return call2_check_string (handler, Qfile_name_as_directory, filename); |
546 | |
867 | 547 buf = alloca_ibytes (XSTRING_LENGTH (filename) + 10); |
2526 | 548 file_name_as_directory (buf, XSTRING_DATA (filename)); |
549 if (qxestrcmp (buf, XSTRING_DATA (filename))) | |
550 return build_intstring (buf); | |
551 else | |
552 return filename; | |
428 | 553 } |
554 | |
555 /* | |
556 * Convert from directory name to filename. | |
557 * On UNIX, it's simple: just make sure there isn't a terminating / | |
558 * | |
559 * Value is nonzero if the string output is different from the input. | |
560 */ | |
561 | |
562 static int | |
867 | 563 directory_file_name (const Ibyte *src, Ibyte *dst) |
428 | 564 { |
442 | 565 /* This function cannot GC */ |
771 | 566 long slen = qxestrlen (src); |
428 | 567 /* Process as Unix format: just remove any final slash. |
568 But leave "/" unchanged; do not change it to "". */ | |
771 | 569 qxestrcpy (dst, src); |
428 | 570 if (slen > 1 |
571 && IS_DIRECTORY_SEP (dst[slen - 1]) | |
657 | 572 #ifdef WIN32_FILENAMES |
428 | 573 && !IS_ANY_SEP (dst[slen - 2]) |
657 | 574 #endif /* WIN32_FILENAMES */ |
428 | 575 ) |
576 dst[slen - 1] = 0; | |
577 return 1; | |
578 } | |
579 | |
580 DEFUN ("directory-file-name", Fdirectory_file_name, 1, 1, 0, /* | |
444 | 581 Return the file name of the directory named DIRECTORY. |
582 This is the name of the file that holds the data for the directory. | |
428 | 583 This operation exists because a directory is also a file, but its name as |
584 a directory is different from its name as a file. | |
585 In Unix-syntax, this function just removes the final slash. | |
586 */ | |
587 (directory)) | |
588 { | |
442 | 589 /* This function can GC. GC checked 2000-07-28 ben */ |
867 | 590 Ibyte *buf; |
428 | 591 Lisp_Object handler; |
592 | |
593 CHECK_STRING (directory); | |
594 | |
595 #if 0 /* #### WTF? */ | |
596 if (NILP (directory)) | |
597 return Qnil; | |
598 #endif | |
599 | |
600 /* If the file name has special constructs in it, | |
601 call the corresponding file handler. */ | |
602 handler = Ffind_file_name_handler (directory, Qdirectory_file_name); | |
603 if (!NILP (handler)) | |
604 return call2_check_string (handler, Qdirectory_file_name, directory); | |
2367 | 605 buf = alloca_ibytes (XSTRING_LENGTH (directory) + 20); |
771 | 606 directory_file_name (XSTRING_DATA (directory), buf); |
607 return build_intstring (buf); | |
428 | 608 } |
609 | |
610 /* Fmake_temp_name used to be a simple wrapper around mktemp(), but it | |
611 proved too broken for our purposes (it supported only 26 or 62 | |
612 unique names under some implementations). For example, this | |
613 arbitrary limit broke generation of Gnus Incoming* files. | |
614 | |
615 This implementation is better than what one usually finds in libc. | |
616 --hniksic */ | |
617 | |
442 | 618 static unsigned int temp_name_rand; |
619 | |
428 | 620 DEFUN ("make-temp-name", Fmake_temp_name, 1, 1, 0, /* |
442 | 621 Generate a temporary file name starting with PREFIX. |
428 | 622 The Emacs process number forms part of the result, so there is no |
623 danger of generating a name being used by another process. | |
624 | |
625 In addition, this function makes an attempt to choose a name that | |
626 does not specify an existing file. To make this work, PREFIX should | |
4266 | 627 be an absolute file name. |
628 | |
629 This function is analagous to mktemp(3) under POSIX, and as with it, there | |
630 exists a race condition between the test for the existence of the new file | |
631 and its creation. See `make-temp-name' for a function which avoids this | |
632 race condition by specifying the appropriate flags to `write-region'. | |
428 | 633 */ |
634 (prefix)) | |
635 { | |
442 | 636 static const char tbl[64] = |
637 { | |
428 | 638 'A','B','C','D','E','F','G','H', |
639 'I','J','K','L','M','N','O','P', | |
640 'Q','R','S','T','U','V','W','X', | |
641 'Y','Z','a','b','c','d','e','f', | |
642 'g','h','i','j','k','l','m','n', | |
643 'o','p','q','r','s','t','u','v', | |
644 'w','x','y','z','0','1','2','3', | |
442 | 645 '4','5','6','7','8','9','-','_' |
646 }; | |
428 | 647 |
648 Bytecount len; | |
867 | 649 Ibyte *p, *data; |
844 | 650 Lisp_Object handler; |
428 | 651 |
652 CHECK_STRING (prefix); | |
844 | 653 handler = Ffind_file_name_handler (prefix, Qmake_temp_name); |
654 if (!NILP (handler)) | |
655 return call2_check_string (handler, Qmake_temp_name, prefix); | |
428 | 656 |
657 /* I was tempted to apply Fexpand_file_name on PREFIX here, but it's | |
658 a bad idea because: | |
659 | |
660 1) It might change the prefix, so the resulting string might not | |
661 begin with PREFIX. This violates the principle of least | |
662 surprise. | |
663 | |
664 2) It breaks under many unforeseeable circumstances, such as with | |
665 the code that uses (make-temp-name "") instead of | |
666 (make-temp-name "./"). | |
667 | |
844 | 668 [[ 3) It might yield unexpected (to stat(2)) results in the presence |
669 of EFS and file name handlers.]] Now that we check for a handler, | |
670 that's less of a concern. --ben */ | |
428 | 671 |
672 len = XSTRING_LENGTH (prefix); | |
867 | 673 data = alloca_ibytes (len + 7); |
428 | 674 memcpy (data, XSTRING_DATA (prefix), len); |
675 p = data + len; | |
771 | 676 p[6] = '\0'; |
428 | 677 |
678 /* VAL is created by adding 6 characters to PREFIX. The first three | |
679 are the PID of this process, in base 64, and the second three are | |
442 | 680 a pseudo-random number seeded from process startup time. This |
681 ensures 262144 unique file names per PID per PREFIX per machine. */ | |
682 | |
683 { | |
771 | 684 unsigned int pid = (unsigned int) qxe_getpid (); |
442 | 685 *p++ = tbl[(pid >> 0) & 63]; |
686 *p++ = tbl[(pid >> 6) & 63]; | |
687 *p++ = tbl[(pid >> 12) & 63]; | |
688 } | |
428 | 689 |
690 /* Here we try to minimize useless stat'ing when this function is | |
691 invoked many times successively with the same PREFIX. We achieve | |
442 | 692 this by using a very pseudo-random number generator to generate |
693 file names unique to this process, with a very long cycle. */ | |
428 | 694 |
695 while (1) | |
696 { | |
697 struct stat ignored; | |
442 | 698 |
699 p[0] = tbl[(temp_name_rand >> 0) & 63]; | |
700 p[1] = tbl[(temp_name_rand >> 6) & 63]; | |
701 p[2] = tbl[(temp_name_rand >> 12) & 63]; | |
428 | 702 |
703 /* Poor man's congruential RN generator. Replace with ++count | |
704 for debugging. */ | |
442 | 705 temp_name_rand += 25229; |
706 temp_name_rand %= 225307; | |
428 | 707 |
708 QUIT; | |
709 | |
771 | 710 if (qxe_stat (data, &ignored) < 0) |
428 | 711 { |
712 /* We want to return only if errno is ENOENT. */ | |
713 if (errno == ENOENT) | |
771 | 714 return make_string (data, len + 6); |
428 | 715 |
716 /* The error here is dubious, but there is little else we | |
717 can do. The alternatives are to return nil, which is | |
718 as bad as (and in many cases worse than) throwing the | |
719 error, or to ignore the error, which will likely result | |
720 in inflooping. */ | |
721 report_file_error ("Cannot create temporary name for prefix", | |
563 | 722 prefix); |
428 | 723 return Qnil; /* not reached */ |
724 } | |
725 } | |
726 } | |
727 | |
728 | |
771 | 729 |
428 | 730 DEFUN ("expand-file-name", Fexpand_file_name, 1, 2, 0, /* |
731 Convert filename NAME to absolute, and canonicalize it. | |
732 Second arg DEFAULT-DIRECTORY is directory to start with if NAME is relative | |
733 (does not start with slash); if DEFAULT-DIRECTORY is nil or missing, | |
444 | 734 the current buffer's value of `default-directory' is used. |
428 | 735 File name components that are `.' are removed, and |
736 so are file name components followed by `..', along with the `..' itself; | |
737 note that these simplifications are done without checking the resulting | |
738 file names in the file system. | |
739 An initial `~/' expands to your home directory. | |
740 An initial `~USER/' expands to USER's home directory. | |
741 See also the function `substitute-in-file-name'. | |
742 */ | |
743 (name, default_directory)) | |
744 { | |
771 | 745 /* This function can GC. GC-checked 2000-11-18. |
746 This function synched with Emacs 21.0.103. */ | |
867 | 747 Ibyte *nm; |
748 | |
749 Ibyte *newdir, *p, *o; | |
428 | 750 int tlen; |
867 | 751 Ibyte *target; |
657 | 752 #ifdef WIN32_FILENAMES |
428 | 753 int drive = 0; |
754 int collapse_newdir = 1; | |
771 | 755 /* XEmacs note: This concerns the special '/:' syntax for preventing |
756 wildcards and such. We don't support this currently but I'm | |
757 keeping the code here in case we do. */ | |
758 int is_escaped = 0; | |
657 | 759 #endif |
760 #ifndef WIN32_NATIVE | |
428 | 761 struct passwd *pw; |
771 | 762 #endif |
428 | 763 int length; |
446 | 764 Lisp_Object handler = Qnil; |
765 struct gcpro gcpro1, gcpro2, gcpro3; | |
2526 | 766 PROFILE_DECLARE (); |
767 | |
768 PROFILE_RECORD_ENTERING_SECTION (QSin_expand_file_name); | |
442 | 769 |
770 /* both of these get set below */ | |
446 | 771 GCPRO3 (name, default_directory, handler); |
428 | 772 |
773 CHECK_STRING (name); | |
774 | |
775 /* If the file name has special constructs in it, | |
776 call the corresponding file handler. */ | |
777 handler = Ffind_file_name_handler (name, Qexpand_file_name); | |
778 if (!NILP (handler)) | |
2526 | 779 RETURN_UNGCPRO_EXIT_PROFILING (QSin_expand_file_name, |
780 call3_check_string | |
781 (handler, Qexpand_file_name, | |
782 name, default_directory)); | |
428 | 783 |
784 /* Use the buffer's default-directory if DEFAULT_DIRECTORY is omitted. */ | |
785 if (NILP (default_directory)) | |
786 default_directory = current_buffer->directory; | |
787 if (! STRINGP (default_directory)) | |
771 | 788 #ifdef WIN32_NATIVE |
789 default_directory = build_string ("C:\\"); | |
790 #else | |
428 | 791 default_directory = build_string ("/"); |
771 | 792 #endif |
428 | 793 |
794 if (!NILP (default_directory)) | |
795 { | |
796 handler = Ffind_file_name_handler (default_directory, Qexpand_file_name); | |
797 if (!NILP (handler)) | |
2526 | 798 RETURN_UNGCPRO_EXIT_PROFILING (QSin_expand_file_name, |
799 call3 (handler, Qexpand_file_name, | |
800 name, default_directory)); | |
428 | 801 } |
802 | |
803 o = XSTRING_DATA (default_directory); | |
804 | |
805 /* Make sure DEFAULT_DIRECTORY is properly expanded. | |
806 It would be better to do this down below where we actually use | |
807 default_directory. Unfortunately, calling Fexpand_file_name recursively | |
808 could invoke GC, and the strings might be relocated. This would | |
809 be annoying because we have pointers into strings lying around | |
810 that would need adjusting, and people would add new pointers to | |
811 the code and forget to adjust them, resulting in intermittent bugs. | |
812 Putting this call here avoids all that crud. | |
813 | |
814 The EQ test avoids infinite recursion. */ | |
815 if (! NILP (default_directory) && !EQ (default_directory, name) | |
816 /* Save time in some common cases - as long as default_directory | |
817 is not relative, it can be canonicalized with name below (if it | |
818 is needed at all) without requiring it to be expanded now. */ | |
657 | 819 #ifdef WIN32_FILENAMES |
442 | 820 /* Detect Windows file names with drive specifiers. */ |
428 | 821 && ! (IS_DRIVE (o[0]) && (IS_DEVICE_SEP (o[1]) && IS_DIRECTORY_SEP (o[2]))) |
822 /* Detect Windows file names in UNC format. */ | |
823 && ! (IS_DIRECTORY_SEP (o[0]) && IS_DIRECTORY_SEP (o[1])) | |
657 | 824 #endif /* not WIN32_FILENAMES */ |
825 #ifndef WIN32_NATIVE | |
428 | 826 /* Detect Unix absolute file names (/... alone is not absolute on |
442 | 827 Windows). */ |
428 | 828 && ! (IS_DIRECTORY_SEP (o[0])) |
442 | 829 #endif /* not WIN32_NATIVE */ |
428 | 830 ) |
442 | 831 |
832 default_directory = Fexpand_file_name (default_directory, Qnil); | |
428 | 833 |
834 #ifdef FILE_SYSTEM_CASE | |
835 name = FILE_SYSTEM_CASE (name); | |
836 #endif | |
837 | |
838 /* #### dmoore - this is ugly, clean this up. Looks like nm pointing | |
839 into name should be safe during all of this, though. */ | |
840 nm = XSTRING_DATA (name); | |
841 | |
657 | 842 #ifdef WIN32_FILENAMES |
428 | 843 /* We will force directory separators to be either all \ or /, so make |
844 a local copy to modify, even if there ends up being no change. */ | |
867 | 845 nm = qxestrcpy (alloca_ibytes (qxestrlen (nm) + 1), nm); |
771 | 846 |
847 /* Note if special escape prefix is present, but remove for now. */ | |
848 if (nm[0] == '/' && nm[1] == ':') | |
849 { | |
850 is_escaped = 1; | |
851 nm += 2; | |
852 } | |
428 | 853 |
854 /* Find and remove drive specifier if present; this makes nm absolute | |
855 even if the rest of the name appears to be relative. */ | |
856 { | |
867 | 857 Ibyte *colon = qxestrrchr (nm, ':'); |
428 | 858 |
859 if (colon) | |
657 | 860 { |
428 | 861 /* Only recognize colon as part of drive specifier if there is a |
862 single alphabetic character preceding the colon (and if the | |
863 character before the drive letter, if present, is a directory | |
864 separator); this is to support the remote system syntax used by | |
865 ange-ftp, and the "po:username" syntax for POP mailboxes. */ | |
866 look_again: | |
867 if (nm == colon) | |
868 nm++; | |
869 else if (IS_DRIVE (colon[-1]) | |
870 && (colon == nm + 1 || IS_DIRECTORY_SEP (colon[-2]))) | |
871 { | |
872 drive = colon[-1]; | |
873 nm = colon + 1; | |
874 } | |
875 else | |
876 { | |
877 while (--colon >= nm) | |
878 if (colon[0] == ':') | |
879 goto look_again; | |
880 } | |
657 | 881 } |
428 | 882 } |
883 | |
884 /* If we see "c://somedir", we want to strip the first slash after the | |
885 colon when stripping the drive letter. Otherwise, this expands to | |
886 "//somedir". */ | |
887 if (drive && IS_DIRECTORY_SEP (nm[0]) && IS_DIRECTORY_SEP (nm[1])) | |
888 nm++; | |
657 | 889 #endif /* WIN32_FILENAMES */ |
428 | 890 |
771 | 891 #ifdef WIN32_FILENAMES |
892 /* Discard any previous drive specifier if nm is now in UNC format. */ | |
893 if (IS_DIRECTORY_SEP (nm[0]) && IS_DIRECTORY_SEP (nm[1])) | |
894 { | |
895 drive = 0; | |
896 } | |
897 #endif | |
898 | |
428 | 899 /* If nm is absolute, look for /./ or /../ sequences; if none are |
900 found, we can probably return right away. We will avoid allocating | |
901 a new string if name is already fully expanded. */ | |
902 if ( | |
903 IS_DIRECTORY_SEP (nm[0]) | |
442 | 904 #ifdef WIN32_NATIVE |
771 | 905 && (drive || IS_DIRECTORY_SEP (nm[1])) && !is_escaped |
428 | 906 #endif |
907 ) | |
908 { | |
909 /* If it turns out that the filename we want to return is just a | |
910 suffix of FILENAME, we don't need to go through and edit | |
911 things; we just need to construct a new string using data | |
912 starting at the middle of FILENAME. If we set lose to a | |
913 non-zero value, that means we've discovered that we can't do | |
914 that cool trick. */ | |
915 int lose = 0; | |
916 | |
917 p = nm; | |
918 while (*p) | |
919 { | |
920 /* Since we know the name is absolute, we can assume that each | |
921 element starts with a "/". */ | |
922 | |
923 /* "." and ".." are hairy. */ | |
924 if (IS_DIRECTORY_SEP (p[0]) | |
925 && p[1] == '.' | |
926 && (IS_DIRECTORY_SEP (p[2]) | |
927 || p[2] == 0 | |
928 || (p[2] == '.' && (IS_DIRECTORY_SEP (p[3]) | |
929 || p[3] == 0)))) | |
930 lose = 1; | |
771 | 931 /* We want to replace multiple `/' in a row with a single |
932 slash. */ | |
933 else if (p > nm | |
934 && IS_DIRECTORY_SEP (p[0]) | |
935 && IS_DIRECTORY_SEP (p[1])) | |
936 lose = 1; | |
428 | 937 p++; |
938 } | |
939 if (!lose) | |
940 { | |
657 | 941 #ifdef WIN32_FILENAMES |
942 if (drive || IS_DIRECTORY_SEP (nm[1])) | |
428 | 943 { |
867 | 944 Ibyte *newnm; |
771 | 945 |
657 | 946 if (IS_DIRECTORY_SEP (nm[1])) |
947 { | |
771 | 948 newnm = mswindows_canonicalize_filename (nm); |
949 if (qxestrcmp (newnm, XSTRING_DATA (name)) != 0) | |
950 name = build_intstring (newnm); | |
657 | 951 } |
771 | 952 else |
657 | 953 { |
771 | 954 /* drive must be set, so this is okay */ |
955 newnm = mswindows_canonicalize_filename (nm - 2); | |
956 if (qxestrcmp (newnm, XSTRING_DATA (name)) != 0) | |
957 { | |
958 name = build_intstring (newnm); | |
959 XSTRING_DATA (name)[0] = DRIVE_LETTER (drive); | |
960 XSTRING_DATA (name)[1] = ':'; | |
961 } | |
657 | 962 } |
1726 | 963 xfree (newnm, Ibyte *); |
2526 | 964 RETURN_UNGCPRO_EXIT_PROFILING (QSin_expand_file_name, name); |
428 | 965 } |
771 | 966 #endif /* WIN32_FILENAMES */ |
657 | 967 #ifndef WIN32_NATIVE |
428 | 968 if (nm == XSTRING_DATA (name)) |
2526 | 969 RETURN_UNGCPRO_EXIT_PROFILING (QSin_expand_file_name, name); |
970 RETURN_UNGCPRO_EXIT_PROFILING (QSin_expand_file_name, | |
971 build_intstring (nm)); | |
442 | 972 #endif /* not WIN32_NATIVE */ |
428 | 973 } |
974 } | |
975 | |
976 /* At this point, nm might or might not be an absolute file name. We | |
977 need to expand ~ or ~user if present, otherwise prefix nm with | |
978 default_directory if nm is not absolute, and finally collapse /./ | |
979 and /foo/../ sequences. | |
980 | |
981 We set newdir to be the appropriate prefix if one is needed: | |
982 - the relevant user directory if nm starts with ~ or ~user | |
983 - the specified drive's working dir (DOS/NT only) if nm does not | |
984 start with / | |
985 - the value of default_directory. | |
986 | |
987 Note that these prefixes are not guaranteed to be absolute (except | |
988 for the working dir of a drive). Therefore, to ensure we always | |
989 return an absolute name, if the final prefix is not absolute we | |
990 append it to the current working directory. */ | |
991 | |
992 newdir = 0; | |
993 | |
994 if (nm[0] == '~') /* prefix ~ */ | |
995 { | |
996 if (IS_DIRECTORY_SEP (nm[1]) | |
997 || nm[1] == 0) /* ~ by itself */ | |
998 { | |
867 | 999 Ibyte *homedir = get_home_directory (); |
771 | 1000 |
1001 if (!homedir) | |
867 | 1002 newdir = (Ibyte *) ""; |
428 | 1003 else |
771 | 1004 newdir = homedir; |
428 | 1005 |
1006 nm++; | |
657 | 1007 #ifdef WIN32_FILENAMES |
428 | 1008 collapse_newdir = 0; |
1009 #endif | |
1010 } | |
1011 else /* ~user/filename */ | |
1012 { | |
1013 for (p = nm; *p && (!IS_DIRECTORY_SEP (*p)); p++) | |
1014 DO_NOTHING; | |
2367 | 1015 o = alloca_ibytes (p - nm + 1); |
771 | 1016 memcpy (o, nm, p - nm); |
428 | 1017 o [p - nm] = 0; |
1018 | |
558 | 1019 /* #### While NT is single-user (for the moment) you still |
1020 can have multiple user profiles users defined, each with | |
1021 its HOME. So maybe possibly we should think about handling | |
1022 ~user. --ben */ | |
1023 #ifndef WIN32_NATIVE | |
442 | 1024 #ifdef CYGWIN |
771 | 1025 { |
867 | 1026 Ibyte *user; |
771 | 1027 |
1028 if ((user = user_login_name (NULL)) != NULL) | |
1029 { | |
1030 /* Does the user login name match the ~name? */ | |
1031 if (qxestrcmp (user, o + 1) == 0) | |
1032 { | |
1033 newdir = get_home_directory (); | |
1034 nm = p; | |
1035 } | |
1036 } | |
1037 } | |
1038 if (!newdir) | |
428 | 1039 { |
442 | 1040 #endif /* CYGWIN */ |
428 | 1041 /* Jamie reports that getpwnam() can get wedged by SIGIO/SIGALARM |
1042 occurring in it. (It can call select()). */ | |
1043 slow_down_interrupts (); | |
771 | 1044 pw = (struct passwd *) qxe_getpwnam (o + 1); |
428 | 1045 speed_up_interrupts (); |
1046 if (pw) | |
1047 { | |
867 | 1048 newdir = (Ibyte *) pw->pw_dir; |
428 | 1049 nm = p; |
771 | 1050 /* FSF: if WIN32_NATIVE, collapse_newdir = 0; |
1051 not possible here. */ | |
428 | 1052 } |
442 | 1053 #ifdef CYGWIN |
428 | 1054 } |
1055 #endif | |
442 | 1056 #endif /* not WIN32_NATIVE */ |
428 | 1057 |
1058 /* If we don't find a user of that name, leave the name | |
1059 unchanged; don't move nm forward to p. */ | |
1060 } | |
1061 } | |
1062 | |
657 | 1063 #ifdef WIN32_FILENAMES |
428 | 1064 /* On DOS and Windows, nm is absolute if a drive name was specified; |
1065 use the drive's current directory as the prefix if needed. */ | |
1066 if (!newdir && drive) | |
1067 { | |
657 | 1068 #ifdef WIN32_NATIVE |
428 | 1069 /* Get default directory if needed to make nm absolute. */ |
1070 if (!IS_DIRECTORY_SEP (nm[0])) | |
1071 { | |
867 | 1072 Ibyte *newcwd = mswindows_getdcwd (toupper (drive) - 'A' + 1); |
771 | 1073 if (newcwd) |
1074 { | |
867 | 1075 IBYTE_STRING_TO_ALLOCA (newcwd, newdir); |
1726 | 1076 xfree (newcwd, Ibyte *); |
771 | 1077 } |
1078 else | |
428 | 1079 newdir = NULL; |
1080 } | |
657 | 1081 #endif /* WIN32_NATIVE */ |
428 | 1082 if (!newdir) |
1083 { | |
1084 /* Either nm starts with /, or drive isn't mounted. */ | |
2367 | 1085 newdir = alloca_ibytes (4); |
428 | 1086 newdir[0] = DRIVE_LETTER (drive); |
1087 newdir[1] = ':'; | |
1088 newdir[2] = '/'; | |
1089 newdir[3] = 0; | |
1090 } | |
1091 } | |
657 | 1092 #endif /* WIN32_FILENAMES */ |
428 | 1093 |
1094 /* Finally, if no prefix has been specified and nm is not absolute, | |
1095 then it must be expanded relative to default_directory. */ | |
1096 | |
1097 if (1 | |
442 | 1098 #ifndef WIN32_NATIVE |
428 | 1099 /* /... alone is not absolute on DOS and Windows. */ |
1100 && !IS_DIRECTORY_SEP (nm[0]) | |
657 | 1101 #endif |
1102 #ifdef WIN32_FILENAMES | |
428 | 1103 && !(IS_DIRECTORY_SEP (nm[0]) && IS_DIRECTORY_SEP (nm[1])) |
1104 #endif | |
1105 && !newdir) | |
1106 { | |
1107 newdir = XSTRING_DATA (default_directory); | |
771 | 1108 #ifdef WIN32_FILENAMES |
1109 /* Note if special escape prefix is present, but remove for now. */ | |
1110 if (newdir[0] == '/' && newdir[1] == ':') | |
1111 { | |
1112 is_escaped = 1; | |
1113 newdir += 2; | |
1114 } | |
1115 #endif | |
428 | 1116 } |
1117 | |
657 | 1118 #ifdef WIN32_FILENAMES |
428 | 1119 if (newdir) |
1120 { | |
1121 /* First ensure newdir is an absolute name. */ | |
1122 if ( | |
442 | 1123 /* Detect Windows file names with drive specifiers. */ |
428 | 1124 ! (IS_DRIVE (newdir[0]) |
1125 && IS_DEVICE_SEP (newdir[1]) && IS_DIRECTORY_SEP (newdir[2])) | |
1126 /* Detect Windows file names in UNC format. */ | |
1127 && ! (IS_DIRECTORY_SEP (newdir[0]) && IS_DIRECTORY_SEP (newdir[1])) | |
771 | 1128 /* XEmacs: added these two lines: Detect drive spec by itself */ |
428 | 1129 && ! (IS_DEVICE_SEP (newdir[1]) && newdir[2] == 0) |
657 | 1130 /* Detect unix format. */ |
1131 #ifndef WIN32_NATIVE | |
1132 && ! (IS_DIRECTORY_SEP (newdir[0])) | |
1133 #endif | |
428 | 1134 ) |
1135 { | |
1136 /* Effectively, let newdir be (expand-file-name newdir cwd). | |
1137 Because of the admonition against calling expand-file-name | |
1138 when we have pointers into lisp strings, we accomplish this | |
1139 indirectly by prepending newdir to nm if necessary, and using | |
1140 cwd (or the wd of newdir's drive) as the new newdir. */ | |
1141 | |
1142 if (IS_DRIVE (newdir[0]) && newdir[1] == ':') | |
1143 { | |
1144 drive = newdir[0]; | |
1145 newdir += 2; | |
1146 } | |
1147 if (!IS_DIRECTORY_SEP (nm[0])) | |
1148 { | |
2367 | 1149 Ibyte *tmp = alloca_ibytes (qxestrlen (newdir) + |
1150 qxestrlen (nm) + 2); | |
771 | 1151 file_name_as_directory (tmp, newdir); |
1152 qxestrcat (tmp, nm); | |
428 | 1153 nm = tmp; |
1154 } | |
1155 if (drive) | |
1156 { | |
657 | 1157 #ifdef WIN32_NATIVE |
867 | 1158 Ibyte *newcwd = mswindows_getdcwd (toupper (drive) - 'A' + 1); |
771 | 1159 if (newcwd) |
1160 { | |
867 | 1161 IBYTE_STRING_TO_ALLOCA (newcwd, newdir); |
1726 | 1162 xfree (newcwd, Ibyte *); |
771 | 1163 } |
1164 else | |
657 | 1165 #endif |
867 | 1166 IBYTE_STRING_TO_ALLOCA ((Ibyte *) "/", newdir); |
428 | 1167 } |
1168 else | |
867 | 1169 IBYTE_STRING_TO_ALLOCA (get_initial_directory (0, 0), newdir); |
428 | 1170 } |
1171 | |
1172 /* Strip off drive name from prefix, if present. */ | |
1173 if (IS_DRIVE (newdir[0]) && newdir[1] == ':') | |
1174 { | |
1175 drive = newdir[0]; | |
1176 newdir += 2; | |
1177 } | |
1178 | |
1179 /* Keep only a prefix from newdir if nm starts with slash | |
771 | 1180 (//server/share for UNC, nothing otherwise). */ |
657 | 1181 if (IS_DIRECTORY_SEP (nm[0]) |
1182 #ifndef WIN32_NATIVE | |
1183 && IS_DIRECTORY_SEP (nm[1]) | |
1184 #endif | |
1185 && collapse_newdir) | |
428 | 1186 { |
1187 if (IS_DIRECTORY_SEP (newdir[0]) && IS_DIRECTORY_SEP (newdir[1])) | |
1188 { | |
2367 | 1189 /* !!#### Use ei API */ |
1190 newdir = qxestrcpy (alloca_ibytes (qxestrlen (newdir) + 1), | |
1191 newdir); | |
428 | 1192 p = newdir + 2; |
1193 while (*p && !IS_DIRECTORY_SEP (*p)) p++; | |
1194 p++; | |
1195 while (*p && !IS_DIRECTORY_SEP (*p)) p++; | |
1196 *p = 0; | |
1197 } | |
1198 else | |
867 | 1199 newdir = (Ibyte *) ""; |
428 | 1200 } |
1201 } | |
657 | 1202 #endif /* WIN32_FILENAMES */ |
428 | 1203 |
1204 if (newdir) | |
1205 { | |
1206 /* Get rid of any slash at the end of newdir, unless newdir is | |
771 | 1207 just / or // (an incomplete UNC name). */ |
1208 length = qxestrlen (newdir); | |
428 | 1209 if (length > 1 && IS_DIRECTORY_SEP (newdir[length - 1]) |
657 | 1210 #ifdef WIN32_FILENAMES |
428 | 1211 && !(length == 2 && IS_DIRECTORY_SEP (newdir[0])) |
1212 #endif | |
1213 ) | |
1214 { | |
2367 | 1215 Ibyte *temp = alloca_ibytes (length); |
428 | 1216 memcpy (temp, newdir, length - 1); |
1217 temp[length - 1] = 0; | |
1218 newdir = temp; | |
1219 } | |
1220 tlen = length + 1; | |
1221 } | |
1222 else | |
1223 tlen = 0; | |
1224 | |
1225 /* Now concatenate the directory and name to new space in the stack frame */ | |
771 | 1226 tlen += qxestrlen (nm) + 1; |
657 | 1227 #ifdef WIN32_FILENAMES |
771 | 1228 /* Reserve space for drive specifier and escape prefix, since either |
1229 or both may need to be inserted. (The Microsoft x86 compiler | |
428 | 1230 produces incorrect code if the following two lines are combined.) */ |
2367 | 1231 target = alloca_ibytes (tlen + 4); |
771 | 1232 target += 4; |
657 | 1233 #else /* not WIN32_FILENAMES */ |
2367 | 1234 target = alloca_ibytes (tlen); |
657 | 1235 #endif /* not WIN32_FILENAMES */ |
428 | 1236 *target = 0; |
1237 | |
1238 if (newdir) | |
1239 { | |
1240 if (nm[0] == 0 || IS_DIRECTORY_SEP (nm[0])) | |
771 | 1241 { |
1242 #ifdef WIN32_FILENAMES | |
1243 /* If newdir is effectively "C:/", then the drive letter will have | |
1244 been stripped and newdir will be "/". Concatenating with an | |
1245 absolute directory in nm produces "//", which will then be | |
1246 incorrectly treated as a network share. Ignore newdir in | |
1247 this case (keeping the drive letter). */ | |
1248 if (!(drive && nm[0] && IS_DIRECTORY_SEP (newdir[0]) | |
1249 && newdir[1] == '\0')) | |
1250 #endif | |
1251 qxestrcpy (target, newdir); | |
1252 } | |
428 | 1253 else |
771 | 1254 file_name_as_directory (target, newdir); |
428 | 1255 } |
1256 | |
771 | 1257 qxestrcat (target, nm); |
428 | 1258 |
1259 /* ASSERT (IS_DIRECTORY_SEP (target[0])) if not VMS */ | |
1260 | |
771 | 1261 /* Now canonicalize by removing `//', `/.' and `/foo/..' if they |
1262 appear. */ | |
428 | 1263 |
1264 p = target; | |
1265 o = target; | |
1266 | |
1267 while (*p) | |
1268 { | |
1269 if (!IS_DIRECTORY_SEP (*p)) | |
1270 { | |
1271 *o++ = *p++; | |
1272 } | |
1273 else if (IS_DIRECTORY_SEP (p[0]) | |
1274 && p[1] == '.' | |
1275 && (IS_DIRECTORY_SEP (p[2]) | |
1276 || p[2] == 0)) | |
1277 { | |
1278 /* If "/." is the entire filename, keep the "/". Otherwise, | |
1279 just delete the whole "/.". */ | |
1280 if (o == target && p[2] == '\0') | |
1281 *o++ = *p; | |
1282 p += 2; | |
1283 } | |
1284 else if (IS_DIRECTORY_SEP (p[0]) && p[1] == '.' && p[2] == '.' | |
1285 /* `/../' is the "superroot" on certain file systems. */ | |
1286 && o != target | |
1287 && (IS_DIRECTORY_SEP (p[3]) || p[3] == 0)) | |
1288 { | |
1289 while (o != target && (--o) && !IS_DIRECTORY_SEP (*o)) | |
1290 ; | |
1291 /* Keep initial / only if this is the whole name. */ | |
1292 if (o == target && IS_ANY_SEP (*o) && p[3] == 0) | |
1293 ++o; | |
1294 p += 3; | |
1295 } | |
771 | 1296 else if (p > target |
1297 && IS_DIRECTORY_SEP (p[0]) && IS_DIRECTORY_SEP (p[1])) | |
1298 { | |
1299 /* Collapse multiple `/' in a row. */ | |
1300 *o++ = *p++; | |
1301 while (IS_DIRECTORY_SEP (*p)) | |
1302 ++p; | |
1303 } | |
428 | 1304 else |
1305 { | |
1306 *o++ = *p++; | |
1307 } | |
1308 } | |
1309 | |
657 | 1310 #ifdef WIN32_FILENAMES |
428 | 1311 /* At last, set drive name, except for network file name. */ |
1312 if (drive) | |
1313 { | |
1314 target -= 2; | |
1315 target[0] = DRIVE_LETTER (drive); | |
1316 target[1] = ':'; | |
1317 } | |
657 | 1318 #ifdef WIN32_NATIVE |
428 | 1319 else |
1320 { | |
1321 assert (IS_DIRECTORY_SEP (target[0]) && IS_DIRECTORY_SEP (target[1])); | |
1322 } | |
657 | 1323 #endif |
771 | 1324 /* Reinsert the escape prefix if required. */ |
1325 if (is_escaped) | |
1326 { | |
1327 target -= 2; | |
1328 target[0] = '/'; | |
1329 target[1] = ':'; | |
1330 } | |
1331 | |
1332 *o = '\0'; | |
1333 | |
1334 { | |
867 | 1335 Ibyte *newtarget = mswindows_canonicalize_filename (target); |
771 | 1336 Lisp_Object result = build_intstring (newtarget); |
1726 | 1337 xfree (newtarget, Ibyte *); |
771 | 1338 |
2526 | 1339 RETURN_UNGCPRO_EXIT_PROFILING (QSin_expand_file_name, result); |
771 | 1340 } |
1341 #else /* not WIN32_FILENAMES */ | |
2526 | 1342 RETURN_UNGCPRO_EXIT_PROFILING (QSin_expand_file_name, |
1343 make_string (target, o - target)); | |
771 | 1344 #endif /* not WIN32_FILENAMES */ |
428 | 1345 } |
1346 | |
1347 DEFUN ("file-truename", Ffile_truename, 1, 2, 0, /* | |
444 | 1348 Return the canonical name of FILENAME. |
1349 Second arg DEFAULT is directory to start with if FILENAME is relative | |
428 | 1350 (does not start with slash); if DEFAULT is nil or missing, |
444 | 1351 the current buffer's value of `default-directory' is used. |
428 | 1352 No component of the resulting pathname will be a symbolic link, as |
1353 in the realpath() function. | |
1354 */ | |
1355 (filename, default_)) | |
1356 { | |
442 | 1357 /* This function can GC. GC checked 2000-07-28 ben. */ |
428 | 1358 Lisp_Object expanded_name; |
1359 struct gcpro gcpro1; | |
1360 | |
1361 CHECK_STRING (filename); | |
1362 | |
1363 expanded_name = Fexpand_file_name (filename, default_); | |
1364 | |
1365 if (!STRINGP (expanded_name)) | |
1366 return Qnil; | |
1367 | |
1368 GCPRO1 (expanded_name); | |
442 | 1369 |
1370 { | |
1371 Lisp_Object handler = | |
1372 Ffind_file_name_handler (expanded_name, Qfile_truename); | |
1373 | |
1374 if (!NILP (handler)) | |
1375 RETURN_UNGCPRO | |
1376 (call2_check_string (handler, Qfile_truename, expanded_name)); | |
1377 } | |
428 | 1378 |
1379 { | |
2421 | 1380 Ibyte resolved_path[PATH_MAX_INTERNAL]; |
771 | 1381 Bytecount elen = XSTRING_LENGTH (expanded_name); |
867 | 1382 Ibyte *path; |
1383 Ibyte *p; | |
771 | 1384 |
1385 LISP_STRING_TO_ALLOCA (expanded_name, path); | |
988 | 1386 |
1111 | 1387 #if defined (WIN32_FILENAMES) && defined (CYGWIN) |
988 | 1388 /* When using win32 filenames in cygwin we want file-truename to |
1389 detect that c:/windows == /windows for example. */ | |
1111 | 1390 if (! (IS_DIRECTORY_SEP (path[0]) && IS_DIRECTORY_SEP (path[1]))) |
1391 { | |
1392 LOCAL_TO_WIN32_FILE_FORMAT (path, p); | |
1393 path = p; | |
1394 } | |
988 | 1395 #endif |
428 | 1396 p = path; |
442 | 1397 |
428 | 1398 /* Try doing it all at once. */ |
2526 | 1399 if (!qxe_realpath (path, resolved_path, 0)) |
428 | 1400 { |
1401 /* Didn't resolve it -- have to do it one component at a time. */ | |
1402 /* "realpath" is a typically useless, stupid un*x piece of crap. | |
1403 It claims to return a useful value in the "error" case, but since | |
1404 there is no indication provided of how far along the pathname | |
1405 the function went before erring, there is no way to use the | |
442 | 1406 partial result returned. What a piece of junk. |
1407 | |
1408 The above comment refers to historical versions of | |
1409 realpath(). The Unix98 specs state: | |
1410 | |
1411 "On successful completion, realpath() returns a | |
1412 pointer to the resolved name. Otherwise, realpath() | |
1413 returns a null pointer and sets errno to indicate the | |
1414 error, and the contents of the buffer pointed to by | |
1415 resolved_name are undefined." | |
1416 | |
771 | 1417 Since we depend on undocumented semantics of various system |
2526 | 1418 realpath()s, we just use our own version in realpath.c. |
1419 | |
1420 Note also that our own version differs in its semantics from any | |
1421 standard version, since it accepts and returns internal-format | |
1422 text, not external-format. */ | |
428 | 1423 for (;;) |
1424 { | |
867 | 1425 Ibyte *pos; |
446 | 1426 |
657 | 1427 #ifdef WIN32_FILENAMES |
446 | 1428 if (IS_DRIVE (p[0]) && IS_DEVICE_SEP (p[1]) |
1429 && IS_DIRECTORY_SEP (p[2])) | |
1430 /* don't test c: on windows */ | |
1431 p = p+2; | |
1432 else if (IS_DIRECTORY_SEP (p[0]) && IS_DIRECTORY_SEP (p[1])) | |
1433 /* start after // */ | |
1434 p = p+1; | |
1435 #endif | |
1436 for (pos = p + 1; pos < path + elen; pos++) | |
1437 if (IS_DIRECTORY_SEP (*pos)) | |
1438 { | |
1439 *(p = pos) = 0; | |
1440 break; | |
1441 } | |
1442 if (p != pos) | |
1443 p = 0; | |
428 | 1444 |
2526 | 1445 if (qxe_realpath (path, resolved_path, 0)) |
428 | 1446 { |
1447 if (p) | |
446 | 1448 *p = DIRECTORY_SEP; |
428 | 1449 else |
1450 break; | |
1451 | |
1452 } | |
1453 else if (errno == ENOENT || errno == EACCES) | |
1454 { | |
1455 /* Failed on this component. Just tack on the rest of | |
1456 the string and we are done. */ | |
771 | 1457 int rlen = qxestrlen (resolved_path); |
428 | 1458 |
1459 /* "On failure, it returns NULL, sets errno to indicate | |
1460 the error, and places in resolved_path the absolute pathname | |
1461 of the path component which could not be resolved." */ | |
442 | 1462 |
1463 if (p) | |
428 | 1464 { |
1465 int plen = elen - (p - path); | |
1466 | |
446 | 1467 if (rlen > 1 && IS_DIRECTORY_SEP (resolved_path[rlen - 1])) |
428 | 1468 rlen = rlen - 1; |
1469 | |
1470 if (plen + rlen + 1 > countof (resolved_path)) | |
1471 goto toolong; | |
1472 | |
446 | 1473 resolved_path[rlen] = DIRECTORY_SEP; |
428 | 1474 memcpy (resolved_path + rlen + 1, p + 1, plen + 1 - 1); |
1475 } | |
1476 break; | |
1477 } | |
1478 else | |
1479 goto lose; | |
1480 } | |
1481 } | |
1482 | |
1483 { | |
442 | 1484 Lisp_Object resolved_name; |
771 | 1485 int rlen = qxestrlen (resolved_path); |
826 | 1486 if (elen > 0 && IS_DIRECTORY_SEP (string_byte (expanded_name, elen - 1)) |
446 | 1487 && !(rlen > 0 && IS_DIRECTORY_SEP (resolved_path[rlen - 1]))) |
428 | 1488 { |
1489 if (rlen + 1 > countof (resolved_path)) | |
1490 goto toolong; | |
446 | 1491 resolved_path[rlen++] = DIRECTORY_SEP; |
442 | 1492 resolved_path[rlen] = '\0'; |
428 | 1493 } |
771 | 1494 resolved_name = make_string (resolved_path, rlen); |
442 | 1495 RETURN_UNGCPRO (resolved_name); |
428 | 1496 } |
1497 | |
1498 toolong: | |
1499 errno = ENAMETOOLONG; | |
1500 goto lose; | |
1501 lose: | |
563 | 1502 report_file_error ("Finding truename", expanded_name); |
428 | 1503 } |
442 | 1504 RETURN_UNGCPRO (Qnil); |
428 | 1505 } |
1506 | |
1507 | |
1508 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name, 1, 1, 0, /* | |
1509 Substitute environment variables referred to in FILENAME. | |
1510 `$FOO' where FOO is an environment variable name means to substitute | |
1511 the value of that variable. The variable name should be terminated | |
444 | 1512 with a character, not a letter, digit or underscore; otherwise, enclose |
428 | 1513 the entire variable name in braces. |
1514 If `/~' appears, all of FILENAME through that `/' is discarded. | |
1515 */ | |
444 | 1516 (filename)) |
428 | 1517 { |
442 | 1518 /* This function can GC. GC checked 2000-07-28 ben. */ |
867 | 1519 Ibyte *nm; |
1520 | |
4324
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1521 Ibyte *s, *p, *o, *x, *endp, *got; |
867 | 1522 Ibyte *target = 0; |
428 | 1523 int total = 0; |
4324
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1524 int substituted = 0, seen_braces; |
867 | 1525 Ibyte *xnm; |
428 | 1526 Lisp_Object handler; |
1527 | |
444 | 1528 CHECK_STRING (filename); |
428 | 1529 |
1530 /* If the file name has special constructs in it, | |
1531 call the corresponding file handler. */ | |
444 | 1532 handler = Ffind_file_name_handler (filename, Qsubstitute_in_file_name); |
428 | 1533 if (!NILP (handler)) |
1534 return call2_check_string_or_nil (handler, Qsubstitute_in_file_name, | |
444 | 1535 filename); |
1536 | |
1537 nm = XSTRING_DATA (filename); | |
1538 endp = nm + XSTRING_LENGTH (filename); | |
428 | 1539 |
1540 /* If /~ or // appears, discard everything through first slash. */ | |
1541 | |
1542 for (p = nm; p != endp; p++) | |
1543 { | |
1544 if ((p[0] == '~' | |
657 | 1545 #if defined (WIN32_FILENAMES) |
440 | 1546 /* // at start of file name is meaningful in WindowsNT systems */ |
428 | 1547 || (IS_DIRECTORY_SEP (p[0]) && p - 1 != nm) |
657 | 1548 #else /* not (WIN32_FILENAMES) */ |
428 | 1549 || IS_DIRECTORY_SEP (p[0]) |
657 | 1550 #endif /* not (WIN32_FILENAMES) */ |
428 | 1551 ) |
1552 && p != nm | |
1553 && (IS_DIRECTORY_SEP (p[-1]))) | |
1554 { | |
1555 nm = p; | |
1556 substituted = 1; | |
1557 } | |
657 | 1558 #ifdef WIN32_FILENAMES |
428 | 1559 /* see comment in expand-file-name about drive specifiers */ |
1560 else if (IS_DRIVE (p[0]) && p[1] == ':' | |
1561 && p > nm && IS_DIRECTORY_SEP (p[-1])) | |
1562 { | |
1563 nm = p; | |
1564 substituted = 1; | |
1565 } | |
657 | 1566 #endif /* WIN32_FILENAMES */ |
428 | 1567 } |
1568 | |
1569 /* See if any variables are substituted into the string | |
1570 and find the total length of their values in `total' */ | |
1571 | |
1572 for (p = nm; p != endp;) | |
1573 if (*p != '$') | |
1574 p++; | |
1575 else | |
1576 { | |
1577 p++; | |
1578 if (p == endp) | |
4324
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1579 { |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1580 /* No substitution, no error. */ |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1581 break; |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1582 } |
428 | 1583 else if (*p == '$') |
1584 { | |
1585 /* "$$" means a single "$" */ | |
1586 p++; | |
1587 total -= 1; | |
1588 substituted = 1; | |
1589 continue; | |
1590 } | |
1591 else if (*p == '{') | |
1592 { | |
1593 o = ++p; | |
1594 while (p != endp && *p != '}') p++; | |
4324
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1595 if (*p != '}') |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1596 { |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1597 /* No substitution, no error. Keep looking. */ |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1598 p = o; |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1599 continue; |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1600 } |
428 | 1601 s = p; |
1602 } | |
1603 else | |
1604 { | |
1605 o = p; | |
1606 while (p != endp && (isalnum (*p) || *p == '_')) p++; | |
1607 s = p; | |
1608 } | |
1609 | |
1610 /* Copy out the variable name */ | |
2367 | 1611 target = alloca_ibytes (s - o + 1); |
771 | 1612 qxestrncpy (target, o, s - o); |
428 | 1613 target[s - o] = 0; |
442 | 1614 #ifdef WIN32_NATIVE |
1204 | 1615 qxestrupr (target); /* $home == $HOME etc. */ |
442 | 1616 #endif /* WIN32_NATIVE */ |
428 | 1617 |
1618 /* Get variable value */ | |
4324
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1619 got = egetenv ((CIbyte *) target); |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1620 if (got) |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1621 { |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1622 total += qxestrlen (got); |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1623 substituted = 1; |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1624 } |
428 | 1625 } |
1626 | |
1627 if (!substituted) | |
444 | 1628 return filename; |
1629 | |
1630 /* If substitution required, recopy the filename and do it */ | |
428 | 1631 /* Make space in stack frame for the new copy */ |
2367 | 1632 xnm = alloca_ibytes (XSTRING_LENGTH (filename) + total + 1); |
428 | 1633 x = xnm; |
1634 | |
1635 /* Copy the rest of the name through, replacing $ constructs with values */ | |
1636 for (p = nm; *p;) | |
1637 if (*p != '$') | |
1638 *x++ = *p++; | |
1639 else | |
1640 { | |
1641 p++; | |
4324
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1642 seen_braces = 0; |
428 | 1643 if (p == endp) |
4324
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1644 { |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1645 *x++ = '$'; |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1646 break; |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1647 } |
428 | 1648 else if (*p == '$') |
1649 { | |
1650 *x++ = *p++; | |
1651 continue; | |
1652 } | |
1653 else if (*p == '{') | |
1654 { | |
4324
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1655 seen_braces = 1; |
428 | 1656 o = ++p; |
1657 while (p != endp && *p != '}') p++; | |
4324
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1658 if (*p != '}') |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1659 { |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1660 /* Don't syntax error, don't substitute */ |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1661 *x++ = '{'; |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1662 p = o; |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1663 continue; |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1664 } |
428 | 1665 s = p++; |
1666 } | |
1667 else | |
1668 { | |
1669 o = p; | |
1670 while (p != endp && (isalnum (*p) || *p == '_')) p++; | |
1671 s = p; | |
1672 } | |
1673 | |
1674 /* Copy out the variable name */ | |
2367 | 1675 target = alloca_ibytes (s - o + 1); |
771 | 1676 qxestrncpy (target, o, s - o); |
428 | 1677 target[s - o] = 0; |
442 | 1678 #ifdef WIN32_NATIVE |
1204 | 1679 qxestrupr (target); /* $home == $HOME etc. */ |
442 | 1680 #endif /* WIN32_NATIVE */ |
428 | 1681 |
1682 /* Get variable value */ | |
4324
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1683 got = egetenv ((CIbyte *) target); |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1684 if (got) |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1685 { |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1686 qxestrcpy (x, got); |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1687 x += qxestrlen (got); |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1688 } |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1689 else |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1690 { |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1691 *x++ = '$'; |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1692 if (seen_braces) |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1693 { |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1694 *x++ = '{'; |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1695 /* Preserve the original case. */ |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1696 qxestrncpy (x, o, s - o); |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1697 x += s - o; |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1698 *x++ = '}'; |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1699 } |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1700 else |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1701 { |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1702 /* Preserve the original case. */ |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1703 qxestrncpy (x, o, s - o); |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1704 x += s - o; |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1705 } |
5e526366d533
Don't error on unknown environment variables, #'substitute-in-file-name.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4266
diff
changeset
|
1706 } |
428 | 1707 } |
1708 | |
1709 *x = 0; | |
1710 | |
1711 /* If /~ or // appears, discard everything through first slash. */ | |
1712 | |
1713 for (p = xnm; p != x; p++) | |
1714 if ((p[0] == '~' | |
657 | 1715 #if defined (WIN32_FILENAMES) |
428 | 1716 || (IS_DIRECTORY_SEP (p[0]) && p - 1 != xnm) |
657 | 1717 #else /* not WIN32_FILENAMES */ |
428 | 1718 || IS_DIRECTORY_SEP (p[0]) |
657 | 1719 #endif /* not WIN32_FILENAMES */ |
428 | 1720 ) |
1721 /* don't do p[-1] if that would go off the beginning --jwz */ | |
1722 && p != nm && p > xnm && IS_DIRECTORY_SEP (p[-1])) | |
1723 xnm = p; | |
657 | 1724 #ifdef WIN32_FILENAMES |
428 | 1725 else if (IS_DRIVE (p[0]) && p[1] == ':' |
1726 && p > nm && IS_DIRECTORY_SEP (p[-1])) | |
1727 xnm = p; | |
1728 #endif | |
1729 | |
1730 return make_string (xnm, x - xnm); | |
1731 } | |
1732 | |
1733 /* A slightly faster and more convenient way to get | |
1734 (directory-file-name (expand-file-name FOO)). */ | |
1735 | |
1736 Lisp_Object | |
1737 expand_and_dir_to_file (Lisp_Object filename, Lisp_Object defdir) | |
1738 { | |
442 | 1739 /* This function can call Lisp. GC checked 2000-07-28 ben */ |
428 | 1740 Lisp_Object abspath; |
1741 struct gcpro gcpro1; | |
1742 | |
1743 abspath = Fexpand_file_name (filename, defdir); | |
1744 GCPRO1 (abspath); | |
1745 /* Remove final slash, if any (unless path is root). | |
1746 stat behaves differently depending! */ | |
1747 if (XSTRING_LENGTH (abspath) > 1 | |
826 | 1748 && IS_DIRECTORY_SEP (string_byte (abspath, XSTRING_LENGTH (abspath) - 1)) |
1749 && !IS_DEVICE_SEP (string_byte (abspath, XSTRING_LENGTH (abspath) - 2))) | |
428 | 1750 /* We cannot take shortcuts; they might be wrong for magic file names. */ |
1751 abspath = Fdirectory_file_name (abspath); | |
1752 UNGCPRO; | |
1753 return abspath; | |
1754 } | |
1755 | |
1756 /* Signal an error if the file ABSNAME already exists. | |
1757 If INTERACTIVE is nonzero, ask the user whether to proceed, | |
1758 and bypass the error if the user says to go ahead. | |
1759 QUERYSTRING is a name for the action that is being considered | |
1760 to alter the file. | |
1761 *STATPTR is used to store the stat information if the file exists. | |
1762 If the file does not exist, STATPTR->st_mode is set to 0. */ | |
1763 | |
1764 static void | |
1333 | 1765 barf_or_query_if_file_exists (Lisp_Object absname, const CIbyte *querystring, |
428 | 1766 int interactive, struct stat *statptr) |
1767 { | |
442 | 1768 /* This function can call Lisp. GC checked 2000-07-28 ben */ |
428 | 1769 struct stat statbuf; |
1770 | |
1771 /* stat is a good way to tell whether the file exists, | |
1772 regardless of what access permissions it has. */ | |
771 | 1773 if (qxe_stat (XSTRING_DATA (absname), &statbuf) >= 0) |
428 | 1774 { |
1775 Lisp_Object tem; | |
1776 | |
1777 if (interactive) | |
1778 { | |
1779 Lisp_Object prompt; | |
1780 struct gcpro gcpro1; | |
1781 | |
771 | 1782 prompt = |
1783 emacs_sprintf_string | |
1784 (CGETTEXT ("File %s already exists; %s anyway? "), | |
1785 XSTRING_DATA (absname), CGETTEXT (querystring)); | |
428 | 1786 |
1787 GCPRO1 (prompt); | |
1788 tem = call1 (Qyes_or_no_p, prompt); | |
1789 UNGCPRO; | |
1790 } | |
1791 else | |
1792 tem = Qnil; | |
1793 | |
1794 if (NILP (tem)) | |
1795 Fsignal (Qfile_already_exists, | |
771 | 1796 list2 (build_msg_string ("File already exists"), |
428 | 1797 absname)); |
1798 if (statptr) | |
1799 *statptr = statbuf; | |
1800 } | |
1801 else | |
1802 { | |
1803 if (statptr) | |
1804 statptr->st_mode = 0; | |
1805 } | |
1806 return; | |
1807 } | |
1808 | |
1809 DEFUN ("copy-file", Fcopy_file, 2, 4, | |
1810 "fCopy file: \nFCopy %s to file: \np\nP", /* | |
444 | 1811 Copy FILENAME to NEWNAME. Both args must be strings. |
428 | 1812 Signals a `file-already-exists' error if file NEWNAME already exists, |
1813 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil. | |
1814 A number as third arg means request confirmation if NEWNAME already exists. | |
1815 This is what happens in interactive use with M-x. | |
1816 Fourth arg KEEP-TIME non-nil means give the new file the same | |
1817 last-modified time as the old one. (This works on only some systems.) | |
1818 A prefix arg makes KEEP-TIME non-nil. | |
1819 */ | |
1820 (filename, newname, ok_if_already_exists, keep_time)) | |
1821 { | |
442 | 1822 /* This function can call Lisp. GC checked 2000-07-28 ben */ |
428 | 1823 int ifd, ofd, n; |
1824 char buf[16 * 1024]; | |
1825 struct stat st, out_st; | |
1826 Lisp_Object handler; | |
1827 int speccount = specpdl_depth (); | |
1828 struct gcpro gcpro1, gcpro2; | |
1829 /* Lisp_Object args[6]; */ | |
1830 int input_file_statable_p; | |
1831 | |
1832 GCPRO2 (filename, newname); | |
1833 CHECK_STRING (filename); | |
1834 CHECK_STRING (newname); | |
1835 filename = Fexpand_file_name (filename, Qnil); | |
1836 newname = Fexpand_file_name (newname, Qnil); | |
1837 | |
1838 /* If the input file name has special constructs in it, | |
1839 call the corresponding file handler. */ | |
1840 handler = Ffind_file_name_handler (filename, Qcopy_file); | |
1841 /* Likewise for output file name. */ | |
1842 if (NILP (handler)) | |
1843 handler = Ffind_file_name_handler (newname, Qcopy_file); | |
1844 if (!NILP (handler)) | |
1845 { | |
1846 UNGCPRO; | |
1847 return call5 (handler, Qcopy_file, filename, newname, | |
1848 ok_if_already_exists, keep_time); | |
1849 } | |
1850 | |
1851 /* When second argument is a directory, copy the file into it. | |
1852 (copy-file "foo" "bar/") == (copy-file "foo" "bar/foo") | |
1853 */ | |
1854 if (!NILP (Ffile_directory_p (newname))) | |
1855 { | |
1856 Lisp_Object args[3]; | |
1857 struct gcpro ngcpro1; | |
1858 int i = 1; | |
1859 | |
1860 args[0] = newname; | |
1861 args[1] = Qnil; args[2] = Qnil; | |
1862 NGCPRO1 (*args); | |
1863 ngcpro1.nvars = 3; | |
826 | 1864 if (!IS_DIRECTORY_SEP (string_byte (newname, |
442 | 1865 XSTRING_LENGTH (newname) - 1))) |
1866 | |
1867 args[i++] = Fchar_to_string (Vdirectory_sep_char); | |
428 | 1868 args[i++] = Ffile_name_nondirectory (filename); |
1869 newname = Fconcat (i, args); | |
1870 NUNGCPRO; | |
1871 } | |
1872 | |
1873 if (NILP (ok_if_already_exists) | |
1874 || INTP (ok_if_already_exists)) | |
1875 barf_or_query_if_file_exists (newname, "copy to it", | |
1876 INTP (ok_if_already_exists), &out_st); | |
771 | 1877 else if (qxe_stat (XSTRING_DATA (newname), &out_st) < 0) |
428 | 1878 out_st.st_mode = 0; |
1879 | |
771 | 1880 ifd = qxe_interruptible_open (XSTRING_DATA (filename), |
1881 O_RDONLY | OPEN_BINARY, 0); | |
428 | 1882 if (ifd < 0) |
563 | 1883 report_file_error ("Opening input file", filename); |
428 | 1884 |
1885 record_unwind_protect (close_file_unwind, make_int (ifd)); | |
1886 | |
1887 /* We can only copy regular files and symbolic links. Other files are not | |
1888 copyable by us. */ | |
771 | 1889 input_file_statable_p = (qxe_fstat (ifd, &st) >= 0); |
428 | 1890 |
442 | 1891 #ifndef WIN32_NATIVE |
428 | 1892 if (out_st.st_mode != 0 |
1893 && st.st_dev == out_st.st_dev && st.st_ino == out_st.st_ino) | |
1894 { | |
1895 errno = 0; | |
1896 report_file_error ("Input and output files are the same", | |
563 | 1897 list3 (Qunbound, filename, newname)); |
428 | 1898 } |
1899 #endif | |
1900 | |
1901 #if defined (S_ISREG) && defined (S_ISLNK) | |
1902 if (input_file_statable_p) | |
1903 { | |
1904 if (!(S_ISREG (st.st_mode)) | |
1905 /* XEmacs: have to allow S_ISCHR in order to copy /dev/null */ | |
1906 #ifdef S_ISCHR | |
1907 && !(S_ISCHR (st.st_mode)) | |
1908 #endif | |
1909 && !(S_ISLNK (st.st_mode))) | |
1910 { | |
1911 #if defined (EISDIR) | |
1912 /* Get a better looking error message. */ | |
1913 errno = EISDIR; | |
1914 #endif /* EISDIR */ | |
563 | 1915 report_file_error ("Non-regular file", filename); |
428 | 1916 } |
1917 } | |
1918 #endif /* S_ISREG && S_ISLNK */ | |
1919 | |
771 | 1920 ofd = qxe_open (XSTRING_DATA (newname), |
1921 O_WRONLY | O_CREAT | O_TRUNC | OPEN_BINARY, CREAT_MODE); | |
428 | 1922 if (ofd < 0) |
563 | 1923 report_file_error ("Opening output file", newname); |
428 | 1924 |
1925 { | |
1926 Lisp_Object ofd_locative = noseeum_cons (make_int (ofd), Qnil); | |
1927 | |
1928 record_unwind_protect (close_file_unwind, ofd_locative); | |
1929 | |
1930 while ((n = read_allowing_quit (ifd, buf, sizeof (buf))) > 0) | |
1931 { | |
1932 if (write_allowing_quit (ofd, buf, n) != n) | |
563 | 1933 report_file_error ("I/O error", newname); |
428 | 1934 } |
1935 | |
1936 /* Closing the output clobbers the file times on some systems. */ | |
771 | 1937 if (retry_close (ofd) < 0) |
563 | 1938 report_file_error ("I/O error", newname); |
428 | 1939 |
1940 if (input_file_statable_p) | |
1941 { | |
442 | 1942 if (!NILP (keep_time)) |
1943 { | |
1944 EMACS_TIME atime, mtime; | |
1945 EMACS_SET_SECS_USECS (atime, st.st_atime, 0); | |
1946 EMACS_SET_SECS_USECS (mtime, st.st_mtime, 0); | |
592 | 1947 if (set_file_times (newname, atime, mtime)) |
1948 report_file_error ("I/O error", list1 (newname)); | |
442 | 1949 } |
771 | 1950 qxe_chmod (XSTRING_DATA (newname), st.st_mode & 07777); |
428 | 1951 } |
1952 | |
1953 /* We'll close it by hand */ | |
1954 XCAR (ofd_locative) = Qnil; | |
1955 | |
1956 /* Close ifd */ | |
771 | 1957 unbind_to (speccount); |
428 | 1958 } |
1959 | |
1960 UNGCPRO; | |
1961 return Qnil; | |
1962 } | |
1963 | |
1964 DEFUN ("make-directory-internal", Fmake_directory_internal, 1, 1, 0, /* | |
1965 Create a directory. One argument, a file name string. | |
1966 */ | |
1967 (dirname_)) | |
1968 { | |
1969 /* This function can GC. GC checked 1997.04.06. */ | |
1970 Lisp_Object handler; | |
1971 struct gcpro gcpro1; | |
771 | 1972 DECLARE_EISTRING (dir); |
428 | 1973 |
1974 CHECK_STRING (dirname_); | |
1975 dirname_ = Fexpand_file_name (dirname_, Qnil); | |
1976 | |
1977 GCPRO1 (dirname_); | |
1978 handler = Ffind_file_name_handler (dirname_, Qmake_directory_internal); | |
1979 UNGCPRO; | |
1980 if (!NILP (handler)) | |
1981 return (call2 (handler, Qmake_directory_internal, dirname_)); | |
1982 | |
771 | 1983 eicpy_lstr (dir, dirname_); |
1984 if (eigetch_char (dir, eicharlen (dir) - 1) == '/') | |
1985 eidel (dir, eilen (dir) - 1, -1, 1, -1); | |
1986 | |
1987 if (qxe_mkdir (eidata (dir), 0777) != 0) | |
563 | 1988 report_file_error ("Creating directory", dirname_); |
428 | 1989 |
1990 return Qnil; | |
1991 } | |
1992 | |
1993 DEFUN ("delete-directory", Fdelete_directory, 1, 1, "FDelete directory: ", /* | |
1994 Delete a directory. One argument, a file name or directory name string. | |
1995 */ | |
1996 (dirname_)) | |
1997 { | |
1998 /* This function can GC. GC checked 1997.04.06. */ | |
1999 Lisp_Object handler; | |
2000 struct gcpro gcpro1; | |
2001 | |
2002 CHECK_STRING (dirname_); | |
2003 | |
2004 GCPRO1 (dirname_); | |
2005 dirname_ = Fexpand_file_name (dirname_, Qnil); | |
2006 dirname_ = Fdirectory_file_name (dirname_); | |
2007 | |
2008 handler = Ffind_file_name_handler (dirname_, Qdelete_directory); | |
2009 UNGCPRO; | |
2010 if (!NILP (handler)) | |
2011 return (call2 (handler, Qdelete_directory, dirname_)); | |
2012 | |
771 | 2013 if (qxe_rmdir (XSTRING_DATA (dirname_)) != 0) |
563 | 2014 report_file_error ("Removing directory", dirname_); |
428 | 2015 |
2016 return Qnil; | |
2017 } | |
2018 | |
2019 DEFUN ("delete-file", Fdelete_file, 1, 1, "fDelete file: ", /* | |
442 | 2020 Delete the file named FILENAME (a string). |
2021 If FILENAME has multiple names, it continues to exist with the other names. | |
428 | 2022 */ |
2023 (filename)) | |
2024 { | |
2025 /* This function can GC. GC checked 1997.04.06. */ | |
2026 Lisp_Object handler; | |
2027 struct gcpro gcpro1; | |
2028 | |
2029 CHECK_STRING (filename); | |
2030 filename = Fexpand_file_name (filename, Qnil); | |
2031 | |
2032 GCPRO1 (filename); | |
2033 handler = Ffind_file_name_handler (filename, Qdelete_file); | |
2034 UNGCPRO; | |
2035 if (!NILP (handler)) | |
2036 return call2 (handler, Qdelete_file, filename); | |
2037 | |
771 | 2038 if (0 > qxe_unlink (XSTRING_DATA (filename))) |
563 | 2039 report_file_error ("Removing old name", filename); |
428 | 2040 return Qnil; |
2041 } | |
2042 | |
2043 static Lisp_Object | |
2286 | 2044 internal_delete_file_1 (Lisp_Object UNUSED (ignore), |
2045 Lisp_Object UNUSED (ignore2)) | |
428 | 2046 { |
2047 return Qt; | |
2048 } | |
2049 | |
2050 /* Delete file FILENAME, returning 1 if successful and 0 if failed. */ | |
2051 | |
2052 int | |
2053 internal_delete_file (Lisp_Object filename) | |
2054 { | |
2055 /* This function can GC. GC checked 1997.04.06. */ | |
2056 return NILP (condition_case_1 (Qt, Fdelete_file, filename, | |
2057 internal_delete_file_1, Qnil)); | |
2058 } | |
2059 | |
2060 DEFUN ("rename-file", Frename_file, 2, 3, | |
2061 "fRename file: \nFRename %s to file: \np", /* | |
444 | 2062 Rename FILENAME as NEWNAME. Both args must be strings. |
2063 If file has names other than FILENAME, it continues to have those names. | |
428 | 2064 Signals a `file-already-exists' error if a file NEWNAME already exists |
2065 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil. | |
2066 A number as third arg means request confirmation if NEWNAME already exists. | |
2067 This is what happens in interactive use with M-x. | |
2068 */ | |
2069 (filename, newname, ok_if_already_exists)) | |
2070 { | |
2071 /* This function can GC. GC checked 1997.04.06. */ | |
2072 Lisp_Object handler; | |
2073 struct gcpro gcpro1, gcpro2; | |
2074 | |
2075 GCPRO2 (filename, newname); | |
2076 CHECK_STRING (filename); | |
2077 CHECK_STRING (newname); | |
2078 filename = Fexpand_file_name (filename, Qnil); | |
2079 newname = Fexpand_file_name (newname, Qnil); | |
2080 | |
2081 /* If the file name has special constructs in it, | |
2082 call the corresponding file handler. */ | |
2083 handler = Ffind_file_name_handler (filename, Qrename_file); | |
2084 if (NILP (handler)) | |
2085 handler = Ffind_file_name_handler (newname, Qrename_file); | |
2086 if (!NILP (handler)) | |
2087 { | |
2088 UNGCPRO; | |
2089 return call4 (handler, Qrename_file, | |
2090 filename, newname, ok_if_already_exists); | |
2091 } | |
2092 | |
2093 /* When second argument is a directory, rename the file into it. | |
2094 (rename-file "foo" "bar/") == (rename-file "foo" "bar/foo") | |
2095 */ | |
2096 if (!NILP (Ffile_directory_p (newname))) | |
2097 { | |
2098 Lisp_Object args[3]; | |
2099 struct gcpro ngcpro1; | |
2100 int i = 1; | |
2101 | |
2102 args[0] = newname; | |
2103 args[1] = Qnil; args[2] = Qnil; | |
2104 NGCPRO1 (*args); | |
2105 ngcpro1.nvars = 3; | |
826 | 2106 if (string_byte (newname, XSTRING_LENGTH (newname) - 1) != '/') |
428 | 2107 args[i++] = build_string ("/"); |
2108 args[i++] = Ffile_name_nondirectory (filename); | |
2109 newname = Fconcat (i, args); | |
2110 NUNGCPRO; | |
2111 } | |
2112 | |
2113 if (NILP (ok_if_already_exists) | |
2114 || INTP (ok_if_already_exists)) | |
2115 barf_or_query_if_file_exists (newname, "rename to it", | |
2116 INTP (ok_if_already_exists), 0); | |
2117 | |
442 | 2118 /* We have configure check for rename() and emulate using |
2119 link()/unlink() if necessary. */ | |
771 | 2120 if (0 > qxe_rename (XSTRING_DATA (filename), XSTRING_DATA (newname))) |
428 | 2121 { |
2122 if (errno == EXDEV) | |
2123 { | |
2124 Fcopy_file (filename, newname, | |
2125 /* We have already prompted if it was an integer, | |
2126 so don't have copy-file prompt again. */ | |
2127 (NILP (ok_if_already_exists) ? Qnil : Qt), | |
2128 Qt); | |
2129 Fdelete_file (filename); | |
2130 } | |
2131 else | |
2132 { | |
563 | 2133 report_file_error ("Renaming", list3 (Qunbound, filename, newname)); |
428 | 2134 } |
2135 } | |
2136 UNGCPRO; | |
2137 return Qnil; | |
2138 } | |
2139 | |
2140 DEFUN ("add-name-to-file", Fadd_name_to_file, 2, 3, | |
2141 "fAdd name to file: \nFName to add to %s: \np", /* | |
444 | 2142 Give FILENAME additional name NEWNAME. Both args must be strings. |
428 | 2143 Signals a `file-already-exists' error if a file NEWNAME already exists |
2144 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil. | |
2145 A number as third arg means request confirmation if NEWNAME already exists. | |
2146 This is what happens in interactive use with M-x. | |
2147 */ | |
2148 (filename, newname, ok_if_already_exists)) | |
2149 { | |
2150 /* This function can GC. GC checked 1997.04.06. */ | |
2151 Lisp_Object handler; | |
2152 struct gcpro gcpro1, gcpro2; | |
2153 | |
2154 GCPRO2 (filename, newname); | |
2155 CHECK_STRING (filename); | |
2156 CHECK_STRING (newname); | |
2157 filename = Fexpand_file_name (filename, Qnil); | |
2158 newname = Fexpand_file_name (newname, Qnil); | |
2159 | |
2160 /* If the file name has special constructs in it, | |
2161 call the corresponding file handler. */ | |
2162 handler = Ffind_file_name_handler (filename, Qadd_name_to_file); | |
2163 if (!NILP (handler)) | |
2164 RETURN_UNGCPRO (call4 (handler, Qadd_name_to_file, filename, | |
2165 newname, ok_if_already_exists)); | |
2166 | |
2167 /* If the new name has special constructs in it, | |
2168 call the corresponding file handler. */ | |
2169 handler = Ffind_file_name_handler (newname, Qadd_name_to_file); | |
2170 if (!NILP (handler)) | |
2171 RETURN_UNGCPRO (call4 (handler, Qadd_name_to_file, filename, | |
2172 newname, ok_if_already_exists)); | |
2173 | |
2174 if (NILP (ok_if_already_exists) | |
2175 || INTP (ok_if_already_exists)) | |
2176 barf_or_query_if_file_exists (newname, "make it a new name", | |
2177 INTP (ok_if_already_exists), 0); | |
771 | 2178 /* #### Emacs 20.6 contains an implementation of link() in w32.c. |
2179 Need to port. */ | |
2180 #ifndef HAVE_LINK | |
563 | 2181 signal_error_2 (Qunimplemented, "Adding new name", filename, newname); |
771 | 2182 #else /* HAVE_LINK */ |
2183 qxe_unlink (XSTRING_DATA (newname)); | |
2184 if (0 > qxe_link (XSTRING_DATA (filename), XSTRING_DATA (newname))) | |
428 | 2185 { |
2186 report_file_error ("Adding new name", | |
563 | 2187 list3 (Qunbound, filename, newname)); |
428 | 2188 } |
771 | 2189 #endif /* HAVE_LINK */ |
428 | 2190 |
2191 UNGCPRO; | |
2192 return Qnil; | |
2193 } | |
2194 | |
2195 DEFUN ("make-symbolic-link", Fmake_symbolic_link, 2, 3, | |
2196 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np", /* | |
2197 Make a symbolic link to FILENAME, named LINKNAME. Both args strings. | |
2198 Signals a `file-already-exists' error if a file LINKNAME already exists | |
2199 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil. | |
2200 A number as third arg means request confirmation if LINKNAME already exists. | |
2201 This happens for interactive use with M-x. | |
2202 */ | |
2203 (filename, linkname, ok_if_already_exists)) | |
2204 { | |
2205 /* This function can GC. GC checked 1997.06.04. */ | |
442 | 2206 /* XEmacs change: run handlers even if local machine doesn't have symlinks */ |
428 | 2207 Lisp_Object handler; |
2208 struct gcpro gcpro1, gcpro2; | |
2209 | |
2210 GCPRO2 (filename, linkname); | |
2211 CHECK_STRING (filename); | |
2212 CHECK_STRING (linkname); | |
2213 /* If the link target has a ~, we must expand it to get | |
2214 a truly valid file name. Otherwise, do not expand; | |
2215 we want to permit links to relative file names. */ | |
826 | 2216 if (string_byte (filename, 0) == '~') |
428 | 2217 filename = Fexpand_file_name (filename, Qnil); |
2218 linkname = Fexpand_file_name (linkname, Qnil); | |
2219 | |
2220 /* If the file name has special constructs in it, | |
2221 call the corresponding file handler. */ | |
2222 handler = Ffind_file_name_handler (filename, Qmake_symbolic_link); | |
2223 if (!NILP (handler)) | |
2224 RETURN_UNGCPRO (call4 (handler, Qmake_symbolic_link, filename, linkname, | |
2225 ok_if_already_exists)); | |
2226 | |
2227 /* If the new link name has special constructs in it, | |
2228 call the corresponding file handler. */ | |
2229 handler = Ffind_file_name_handler (linkname, Qmake_symbolic_link); | |
2230 if (!NILP (handler)) | |
2231 RETURN_UNGCPRO (call4 (handler, Qmake_symbolic_link, filename, | |
2232 linkname, ok_if_already_exists)); | |
2233 | |
771 | 2234 #ifdef HAVE_SYMLINK |
428 | 2235 if (NILP (ok_if_already_exists) |
2236 || INTP (ok_if_already_exists)) | |
2237 barf_or_query_if_file_exists (linkname, "make it a link", | |
2238 INTP (ok_if_already_exists), 0); | |
2239 | |
771 | 2240 qxe_unlink (XSTRING_DATA (linkname)); |
2241 if (0 > qxe_symlink (XSTRING_DATA (filename), | |
2242 XSTRING_DATA (linkname))) | |
428 | 2243 { |
2244 report_file_error ("Making symbolic link", | |
563 | 2245 list3 (Qunbound, filename, linkname)); |
428 | 2246 } |
771 | 2247 #endif |
442 | 2248 |
428 | 2249 UNGCPRO; |
2250 return Qnil; | |
2251 } | |
2252 | |
2253 #ifdef HPUX_NET | |
2254 | |
2255 DEFUN ("sysnetunam", Fsysnetunam, 2, 2, 0, /* | |
2256 Open a network connection to PATH using LOGIN as the login string. | |
2257 */ | |
2258 (path, login)) | |
2259 { | |
2260 int netresult; | |
1333 | 2261 const Extbyte *path_ext; |
2262 const Extbyte *login_ext; | |
428 | 2263 |
2264 CHECK_STRING (path); | |
2265 CHECK_STRING (login); | |
2266 | |
2267 /* netunam, being a strange-o system call only used once, is not | |
2268 encapsulated. */ | |
440 | 2269 |
442 | 2270 LISP_STRING_TO_EXTERNAL (path, path_ext, Qfile_name); |
2271 LISP_STRING_TO_EXTERNAL (login, login_ext, Qnative); | |
440 | 2272 |
2273 netresult = netunam (path_ext, login_ext); | |
2274 | |
2275 return netresult == -1 ? Qnil : Qt; | |
428 | 2276 } |
2277 #endif /* HPUX_NET */ | |
2278 | |
2279 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p, 1, 1, 0, /* | |
2280 Return t if file FILENAME specifies an absolute path name. | |
2281 On Unix, this is a name starting with a `/' or a `~'. | |
2282 */ | |
2283 (filename)) | |
2284 { | |
2285 /* This function does not GC */ | |
867 | 2286 Ibyte *ptr; |
428 | 2287 |
2288 CHECK_STRING (filename); | |
2289 ptr = XSTRING_DATA (filename); | |
2290 return (IS_DIRECTORY_SEP (*ptr) || *ptr == '~' | |
657 | 2291 #ifdef WIN32_FILENAMES |
428 | 2292 || (IS_DRIVE (*ptr) && ptr[1] == ':' && IS_DIRECTORY_SEP (ptr[2])) |
2293 #endif | |
2294 ) ? Qt : Qnil; | |
2295 } | |
2296 | |
2297 /* Return nonzero if file FILENAME exists and can be executed. */ | |
2298 | |
2299 static int | |
771 | 2300 check_executable (Lisp_Object filename) |
428 | 2301 { |
442 | 2302 #ifdef WIN32_NATIVE |
428 | 2303 struct stat st; |
771 | 2304 if (qxe_stat (XSTRING_DATA (filename), &st) < 0) |
428 | 2305 return 0; |
2306 return ((st.st_mode & S_IEXEC) != 0); | |
442 | 2307 #else /* not WIN32_NATIVE */ |
428 | 2308 #ifdef HAVE_EACCESS |
771 | 2309 return qxe_eaccess (XSTRING_DATA (filename), X_OK) >= 0; |
428 | 2310 #else |
2311 /* Access isn't quite right because it uses the real uid | |
2312 and we really want to test with the effective uid. | |
2313 But Unix doesn't give us a right way to do it. */ | |
771 | 2314 return qxe_access (XSTRING_DATA (filename), X_OK) >= 0; |
428 | 2315 #endif /* HAVE_EACCESS */ |
442 | 2316 #endif /* not WIN32_NATIVE */ |
428 | 2317 } |
2318 | |
2319 /* Return nonzero if file FILENAME exists and can be written. */ | |
2320 | |
2321 static int | |
867 | 2322 check_writable (const Ibyte *filename) |
428 | 2323 { |
3728 | 2324 #if defined(WIN32_NATIVE) || defined(CYGWIN) |
2325 #ifdef CYGWIN | |
2326 char filename_buffer[PATH_MAX]; | |
2327 #endif | |
2328 // Since this has to work for a directory, we can't just call 'CreateFile' | |
2329 PSECURITY_DESCRIPTOR pDesc; /* Must be freed with LocalFree */ | |
2330 /* these need not be freed, they point into pDesc */ | |
2331 PSID psidOwner; | |
2332 PSID psidGroup; | |
2333 PACL pDacl; | |
2334 PACL pSacl; | |
2335 /* end of insides of descriptor */ | |
2336 DWORD error; | |
2337 DWORD attributes; | |
2338 HANDLE tokenHandle; | |
2339 GENERIC_MAPPING genericMapping; | |
2340 DWORD accessMask; | |
2341 PRIVILEGE_SET PrivilegeSet; | |
2342 DWORD dwPrivSetSize = sizeof( PRIVILEGE_SET ); | |
2343 BOOL fAccessGranted = FALSE; | |
3781 | 2344 DWORD dwAccessAllowed; |
2345 Extbyte *fnameext; | |
3728 | 2346 |
2347 #ifdef CYGWIN | |
2348 cygwin_conv_to_full_win32_path(filename, filename_buffer); | |
2349 filename = (Ibyte*)filename_buffer; | |
2350 #endif | |
2351 | |
2352 C_STRING_TO_TSTR(filename, fnameext); | |
3781 | 2353 |
2354 // First check for a normal file with the old-style readonly bit | |
2355 attributes = qxeGetFileAttributes(fnameext); | |
2356 if (FILE_ATTRIBUTE_READONLY == (attributes & (FILE_ATTRIBUTE_DIRECTORY|FILE_ATTRIBUTE_READONLY))) | |
2357 return 0; | |
2358 | |
3728 | 2359 /* Win32 prototype lacks const. */ |
2360 error = qxeGetNamedSecurityInfo(fnameext, SE_FILE_OBJECT, | |
3781 | 2361 DACL_SECURITY_INFORMATION|GROUP_SECURITY_INFORMATION|OWNER_SECURITY_INFORMATION, |
2362 &psidOwner, &psidGroup, &pDacl, &pSacl, &pDesc); | |
3728 | 2363 if(error != ERROR_SUCCESS) { // FAT? |
3781 | 2364 attributes = qxeGetFileAttributes(fnameext); |
3728 | 2365 return (attributes & FILE_ATTRIBUTE_DIRECTORY) || (0 == (attributes & FILE_ATTRIBUTE_READONLY)); |
2366 } | |
2367 | |
2368 genericMapping.GenericRead = FILE_GENERIC_READ; | |
2369 genericMapping.GenericWrite = FILE_GENERIC_WRITE; | |
2370 genericMapping.GenericExecute = FILE_GENERIC_EXECUTE; | |
2371 genericMapping.GenericAll = FILE_ALL_ACCESS; | |
2372 | |
2373 if(!ImpersonateSelf(SecurityDelegation)) { | |
2374 return 0; | |
2375 } | |
2376 if(!OpenThreadToken(GetCurrentThread(), TOKEN_ALL_ACCESS, TRUE, &tokenHandle)) { | |
2377 return 0; | |
2378 } | |
2379 | |
2380 accessMask = GENERIC_WRITE; | |
2381 MapGenericMask(&accessMask, &genericMapping); | |
2382 | |
2383 if(!AccessCheck(pDesc, tokenHandle, accessMask, &genericMapping, | |
2384 &PrivilegeSet, // receives privileges used in check | |
2385 &dwPrivSetSize, // size of PrivilegeSet buffer | |
2386 &dwAccessAllowed, // receives mask of allowed access rights | |
2387 &fAccessGranted)) | |
2388 { | |
2389 CloseHandle(tokenHandle); | |
2390 RevertToSelf(); | |
2391 LocalFree(pDesc); | |
2392 return 0; | |
2393 } | |
2394 CloseHandle(tokenHandle); | |
2395 RevertToSelf(); | |
2396 LocalFree(pDesc); | |
2397 return fAccessGranted == TRUE; | |
2398 #else | |
428 | 2399 #ifdef HAVE_EACCESS |
771 | 2400 return (qxe_eaccess (filename, W_OK) >= 0); |
428 | 2401 #else |
2402 /* Access isn't quite right because it uses the real uid | |
2403 and we really want to test with the effective uid. | |
2404 But Unix doesn't give us a right way to do it. | |
2405 Opening with O_WRONLY could work for an ordinary file, | |
2406 but would lose for directories. */ | |
771 | 2407 return (qxe_access (filename, W_OK) >= 0); |
428 | 2408 #endif |
3728 | 2409 #endif |
428 | 2410 } |
2411 | |
2412 DEFUN ("file-exists-p", Ffile_exists_p, 1, 1, 0, /* | |
2413 Return t if file FILENAME exists. (This does not mean you can read it.) | |
2414 See also `file-readable-p' and `file-attributes'. | |
2415 */ | |
2416 (filename)) | |
2417 { | |
442 | 2418 /* This function can call lisp; GC checked 2000-07-11 ben */ |
428 | 2419 Lisp_Object abspath; |
2420 Lisp_Object handler; | |
2421 struct stat statbuf; | |
2422 struct gcpro gcpro1; | |
2423 | |
2424 CHECK_STRING (filename); | |
2425 abspath = Fexpand_file_name (filename, Qnil); | |
2426 | |
2427 /* If the file name has special constructs in it, | |
2428 call the corresponding file handler. */ | |
2429 GCPRO1 (abspath); | |
2430 handler = Ffind_file_name_handler (abspath, Qfile_exists_p); | |
2431 UNGCPRO; | |
2432 if (!NILP (handler)) | |
2433 return call2 (handler, Qfile_exists_p, abspath); | |
2434 | |
771 | 2435 return qxe_stat (XSTRING_DATA (abspath), &statbuf) >= 0 ? Qt : Qnil; |
428 | 2436 } |
2437 | |
2438 DEFUN ("file-executable-p", Ffile_executable_p, 1, 1, 0, /* | |
2439 Return t if FILENAME can be executed by you. | |
2440 For a directory, this means you can access files in that directory. | |
2441 */ | |
2442 (filename)) | |
2443 | |
2444 { | |
442 | 2445 /* This function can GC. GC checked 07-11-2000 ben. */ |
428 | 2446 Lisp_Object abspath; |
2447 Lisp_Object handler; | |
2448 struct gcpro gcpro1; | |
2449 | |
2450 CHECK_STRING (filename); | |
2451 abspath = Fexpand_file_name (filename, Qnil); | |
2452 | |
2453 /* If the file name has special constructs in it, | |
2454 call the corresponding file handler. */ | |
2455 GCPRO1 (abspath); | |
2456 handler = Ffind_file_name_handler (abspath, Qfile_executable_p); | |
2457 UNGCPRO; | |
2458 if (!NILP (handler)) | |
2459 return call2 (handler, Qfile_executable_p, abspath); | |
2460 | |
771 | 2461 return check_executable (abspath) ? Qt : Qnil; |
428 | 2462 } |
2463 | |
2464 DEFUN ("file-readable-p", Ffile_readable_p, 1, 1, 0, /* | |
2465 Return t if file FILENAME exists and you can read it. | |
2466 See also `file-exists-p' and `file-attributes'. | |
2467 */ | |
2468 (filename)) | |
2469 { | |
2470 /* This function can GC */ | |
2471 Lisp_Object abspath = Qnil; | |
2472 Lisp_Object handler; | |
2473 struct gcpro gcpro1; | |
2474 GCPRO1 (abspath); | |
2475 | |
2476 CHECK_STRING (filename); | |
2477 abspath = Fexpand_file_name (filename, Qnil); | |
2478 | |
2479 /* If the file name has special constructs in it, | |
2480 call the corresponding file handler. */ | |
2481 handler = Ffind_file_name_handler (abspath, Qfile_readable_p); | |
2482 if (!NILP (handler)) | |
2483 RETURN_UNGCPRO (call2 (handler, Qfile_readable_p, abspath)); | |
2484 | |
2526 | 2485 #if defined (WIN32_FILENAMES) |
428 | 2486 /* Under MS-DOS and Windows, open does not work for directories. */ |
2487 UNGCPRO; | |
771 | 2488 if (qxe_access (XSTRING_DATA (abspath), 0) == 0) |
428 | 2489 return Qt; |
2490 else | |
2491 return Qnil; | |
657 | 2492 #else /* not WIN32_FILENAMES */ |
428 | 2493 { |
771 | 2494 int desc = qxe_interruptible_open (XSTRING_DATA (abspath), |
2495 O_RDONLY | OPEN_BINARY, 0); | |
428 | 2496 UNGCPRO; |
2497 if (desc < 0) | |
2498 return Qnil; | |
771 | 2499 retry_close (desc); |
428 | 2500 return Qt; |
2501 } | |
657 | 2502 #endif /* not WIN32_FILENAMES */ |
428 | 2503 } |
2504 | |
2505 /* Having this before file-symlink-p mysteriously caused it to be forgotten | |
2506 on the RT/PC. */ | |
2507 DEFUN ("file-writable-p", Ffile_writable_p, 1, 1, 0, /* | |
2508 Return t if file FILENAME can be written or created by you. | |
2509 */ | |
2510 (filename)) | |
2511 { | |
2512 /* This function can GC. GC checked 1997.04.10. */ | |
2513 Lisp_Object abspath, dir; | |
2514 Lisp_Object handler; | |
2515 struct stat statbuf; | |
2516 struct gcpro gcpro1; | |
2517 | |
2518 CHECK_STRING (filename); | |
2519 abspath = Fexpand_file_name (filename, Qnil); | |
2520 | |
2521 /* If the file name has special constructs in it, | |
2522 call the corresponding file handler. */ | |
2523 GCPRO1 (abspath); | |
2524 handler = Ffind_file_name_handler (abspath, Qfile_writable_p); | |
2525 UNGCPRO; | |
2526 if (!NILP (handler)) | |
2527 return call2 (handler, Qfile_writable_p, abspath); | |
2528 | |
771 | 2529 if (qxe_stat (XSTRING_DATA (abspath), &statbuf) >= 0) |
2530 return (check_writable (XSTRING_DATA (abspath)) | |
428 | 2531 ? Qt : Qnil); |
2532 | |
2533 | |
2534 GCPRO1 (abspath); | |
2535 dir = Ffile_name_directory (abspath); | |
2536 UNGCPRO; | |
867 | 2537 return (check_writable (!NILP (dir) ? XSTRING_DATA (dir) : (Ibyte *) "") |
428 | 2538 ? Qt : Qnil); |
2539 } | |
2540 | |
2541 DEFUN ("file-symlink-p", Ffile_symlink_p, 1, 1, 0, /* | |
2542 Return non-nil if file FILENAME is the name of a symbolic link. | |
2543 The value is the name of the file to which it is linked. | |
2544 Otherwise returns nil. | |
2545 */ | |
2546 (filename)) | |
2547 { | |
2548 /* This function can GC. GC checked 1997.04.10. */ | |
442 | 2549 /* XEmacs change: run handlers even if local machine doesn't have symlinks */ |
771 | 2550 #ifdef HAVE_READLINK |
867 | 2551 Ibyte *buf; |
428 | 2552 int bufsize; |
2553 int valsize; | |
2554 Lisp_Object val; | |
442 | 2555 #endif |
428 | 2556 Lisp_Object handler; |
2557 struct gcpro gcpro1; | |
2558 | |
2559 CHECK_STRING (filename); | |
2560 filename = Fexpand_file_name (filename, Qnil); | |
2561 | |
2562 /* If the file name has special constructs in it, | |
2563 call the corresponding file handler. */ | |
2564 GCPRO1 (filename); | |
2565 handler = Ffind_file_name_handler (filename, Qfile_symlink_p); | |
2566 UNGCPRO; | |
2567 if (!NILP (handler)) | |
2568 return call2 (handler, Qfile_symlink_p, filename); | |
2569 | |
771 | 2570 #ifdef HAVE_READLINK |
428 | 2571 bufsize = 100; |
2572 while (1) | |
2573 { | |
867 | 2574 buf = xnew_array_and_zero (Ibyte, bufsize); |
771 | 2575 valsize = qxe_readlink (XSTRING_DATA (filename), |
2576 buf, bufsize); | |
428 | 2577 if (valsize < bufsize) break; |
2578 /* Buffer was not long enough */ | |
1726 | 2579 xfree (buf, Ibyte *); |
428 | 2580 bufsize *= 2; |
2581 } | |
2582 if (valsize == -1) | |
2583 { | |
1726 | 2584 xfree (buf, Ibyte *); |
428 | 2585 return Qnil; |
2586 } | |
771 | 2587 val = make_string (buf, valsize); |
1726 | 2588 xfree (buf, Ibyte *); |
428 | 2589 return val; |
2526 | 2590 #elif defined (WIN32_NATIVE) |
2591 if (mswindows_shortcuts_are_symlinks) | |
2592 { | |
2593 /* We want to resolve the directory component and leave the rest | |
2594 alone. */ | |
2595 Ibyte *path = XSTRING_DATA (filename); | |
2596 Ibyte *dirend = | |
2597 find_end_of_directory_component (path, XSTRING_LENGTH (filename)); | |
2598 Ibyte *fname; | |
2599 DECLARE_EISTRING (dir); | |
2600 | |
2601 if (dirend != path) | |
2602 { | |
2603 Ibyte *resdir; | |
2604 DECLARE_EISTRING (resname); | |
2605 | |
2606 eicpy_raw (dir, path, dirend - path); | |
2607 PATHNAME_RESOLVE_LINKS (eidata (dir), resdir); | |
2608 eicpy_rawz (resname, resdir); | |
2609 eicat_rawz (resname, dirend); | |
2610 path = eidata (resname); | |
2611 } | |
2612 | |
2613 fname = mswindows_read_link (path); | |
2614 if (!fname) | |
2615 return Qnil; | |
2616 { | |
2617 Lisp_Object val = build_intstring (fname); | |
2618 xfree (fname, Ibyte *); | |
2619 return val; | |
2620 } | |
2621 } | |
428 | 2622 return Qnil; |
2526 | 2623 #else |
2624 return Qnil; | |
2625 #endif | |
428 | 2626 } |
2627 | |
2628 DEFUN ("file-directory-p", Ffile_directory_p, 1, 1, 0, /* | |
2629 Return t if file FILENAME is the name of a directory as a file. | |
2630 A directory name spec may be given instead; then the value is t | |
2631 if the directory so specified exists and really is a directory. | |
2632 */ | |
2633 (filename)) | |
2634 { | |
2635 /* This function can GC. GC checked 1997.04.10. */ | |
2636 Lisp_Object abspath; | |
2637 struct stat st; | |
2638 Lisp_Object handler; | |
2639 struct gcpro gcpro1; | |
2640 | |
2641 GCPRO1 (current_buffer->directory); | |
2642 abspath = expand_and_dir_to_file (filename, | |
2643 current_buffer->directory); | |
2644 UNGCPRO; | |
2645 | |
2646 /* If the file name has special constructs in it, | |
2647 call the corresponding file handler. */ | |
2648 GCPRO1 (abspath); | |
2649 handler = Ffind_file_name_handler (abspath, Qfile_directory_p); | |
2650 UNGCPRO; | |
2651 if (!NILP (handler)) | |
2652 return call2 (handler, Qfile_directory_p, abspath); | |
2653 | |
771 | 2654 if (qxe_stat (XSTRING_DATA (abspath), &st) < 0) |
428 | 2655 return Qnil; |
2656 return (st.st_mode & S_IFMT) == S_IFDIR ? Qt : Qnil; | |
2657 } | |
2658 | |
2659 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p, 1, 1, 0, /* | |
2660 Return t if file FILENAME is the name of a directory as a file, | |
2661 and files in that directory can be opened by you. In order to use a | |
2662 directory as a buffer's current directory, this predicate must return true. | |
2663 A directory name spec may be given instead; then the value is t | |
2664 if the directory so specified exists and really is a readable and | |
2665 searchable directory. | |
2666 */ | |
2667 (filename)) | |
2668 { | |
2669 /* This function can GC. GC checked 1997.04.10. */ | |
2670 Lisp_Object handler; | |
2671 | |
2672 /* If the file name has special constructs in it, | |
2673 call the corresponding file handler. */ | |
2674 handler = Ffind_file_name_handler (filename, Qfile_accessible_directory_p); | |
2675 if (!NILP (handler)) | |
2676 return call2 (handler, Qfile_accessible_directory_p, | |
2677 filename); | |
2678 | |
2526 | 2679 #if !defined (WIN32_NATIVE) |
428 | 2680 if (NILP (Ffile_directory_p (filename))) |
2681 return (Qnil); | |
2682 else | |
2683 return Ffile_executable_p (filename); | |
2684 #else | |
2685 { | |
2686 int tem; | |
2687 struct gcpro gcpro1; | |
2688 /* It's an unlikely combination, but yes we really do need to gcpro: | |
2689 Suppose that file-accessible-directory-p has no handler, but | |
2690 file-directory-p does have a handler; this handler causes a GC which | |
2691 relocates the string in `filename'; and finally file-directory-p | |
2692 returns non-nil. Then we would end up passing a garbaged string | |
2693 to file-executable-p. */ | |
2694 GCPRO1 (filename); | |
2695 tem = (NILP (Ffile_directory_p (filename)) | |
2696 || NILP (Ffile_executable_p (filename))); | |
2697 UNGCPRO; | |
2698 return tem ? Qnil : Qt; | |
2699 } | |
442 | 2700 #endif /* !defined(WIN32_NATIVE) */ |
428 | 2701 } |
2702 | |
2703 DEFUN ("file-regular-p", Ffile_regular_p, 1, 1, 0, /* | |
2704 Return t if file FILENAME is the name of a regular file. | |
2705 This is the sort of file that holds an ordinary stream of data bytes. | |
2706 */ | |
2707 (filename)) | |
2708 { | |
2709 /* This function can GC. GC checked 1997.04.10. */ | |
2710 Lisp_Object abspath; | |
2711 struct stat st; | |
2712 Lisp_Object handler; | |
2713 struct gcpro gcpro1; | |
2714 | |
2715 GCPRO1 (current_buffer->directory); | |
2716 abspath = expand_and_dir_to_file (filename, current_buffer->directory); | |
2717 UNGCPRO; | |
2718 | |
2719 /* If the file name has special constructs in it, | |
2720 call the corresponding file handler. */ | |
2721 GCPRO1 (abspath); | |
2722 handler = Ffind_file_name_handler (abspath, Qfile_regular_p); | |
2723 UNGCPRO; | |
2724 if (!NILP (handler)) | |
2725 return call2 (handler, Qfile_regular_p, abspath); | |
2726 | |
771 | 2727 if (qxe_stat (XSTRING_DATA (abspath), &st) < 0) |
428 | 2728 return Qnil; |
2729 return (st.st_mode & S_IFMT) == S_IFREG ? Qt : Qnil; | |
2730 } | |
2731 | |
2732 DEFUN ("file-modes", Ffile_modes, 1, 1, 0, /* | |
444 | 2733 Return mode bits of file named FILENAME, as an integer. |
428 | 2734 */ |
2735 (filename)) | |
2736 { | |
2737 /* This function can GC. GC checked 1997.04.10. */ | |
2738 Lisp_Object abspath; | |
2739 struct stat st; | |
2740 Lisp_Object handler; | |
2741 struct gcpro gcpro1; | |
2742 | |
2743 GCPRO1 (current_buffer->directory); | |
2744 abspath = expand_and_dir_to_file (filename, | |
2745 current_buffer->directory); | |
2746 UNGCPRO; | |
2747 | |
2748 /* If the file name has special constructs in it, | |
2749 call the corresponding file handler. */ | |
2750 GCPRO1 (abspath); | |
2751 handler = Ffind_file_name_handler (abspath, Qfile_modes); | |
2752 UNGCPRO; | |
2753 if (!NILP (handler)) | |
2754 return call2 (handler, Qfile_modes, abspath); | |
2755 | |
771 | 2756 if (qxe_stat (XSTRING_DATA (abspath), &st) < 0) |
428 | 2757 return Qnil; |
2758 /* Syncing with FSF 19.34.6 note: not in FSF, #if 0'ed out here. */ | |
2759 #if 0 | |
442 | 2760 #ifdef WIN32_NATIVE |
771 | 2761 if (check_executable (abspath)) |
428 | 2762 st.st_mode |= S_IEXEC; |
442 | 2763 #endif /* WIN32_NATIVE */ |
428 | 2764 #endif /* 0 */ |
2765 | |
2766 return make_int (st.st_mode & 07777); | |
2767 } | |
2768 | |
2769 DEFUN ("set-file-modes", Fset_file_modes, 2, 2, 0, /* | |
444 | 2770 Set mode bits of file named FILENAME to MODE (an integer). |
428 | 2771 Only the 12 low bits of MODE are used. |
2772 */ | |
2773 (filename, mode)) | |
2774 { | |
2775 /* This function can GC. GC checked 1997.04.10. */ | |
2776 Lisp_Object abspath; | |
2777 Lisp_Object handler; | |
2778 struct gcpro gcpro1; | |
2779 | |
2780 GCPRO1 (current_buffer->directory); | |
2781 abspath = Fexpand_file_name (filename, current_buffer->directory); | |
2782 UNGCPRO; | |
2783 | |
2784 CHECK_INT (mode); | |
2785 | |
2786 /* If the file name has special constructs in it, | |
2787 call the corresponding file handler. */ | |
2788 GCPRO1 (abspath); | |
2789 handler = Ffind_file_name_handler (abspath, Qset_file_modes); | |
2790 UNGCPRO; | |
2791 if (!NILP (handler)) | |
2792 return call3 (handler, Qset_file_modes, abspath, mode); | |
2793 | |
771 | 2794 if (qxe_chmod (XSTRING_DATA (abspath), XINT (mode)) < 0) |
563 | 2795 report_file_error ("Doing chmod", abspath); |
428 | 2796 |
2797 return Qnil; | |
2798 } | |
2799 | |
2800 DEFUN ("set-default-file-modes", Fset_default_file_modes, 1, 1, 0, /* | |
2801 Set the file permission bits for newly created files. | |
444 | 2802 The argument MODE should be an integer; if a bit in MODE is 1, |
2803 subsequently created files will not have the permission corresponding | |
2804 to that bit enabled. Only the low 9 bits are used. | |
428 | 2805 This setting is inherited by subprocesses. |
2806 */ | |
2807 (mode)) | |
2808 { | |
2809 CHECK_INT (mode); | |
2810 | |
2811 umask ((~ XINT (mode)) & 0777); | |
2812 | |
2813 return Qnil; | |
2814 } | |
2815 | |
2816 DEFUN ("default-file-modes", Fdefault_file_modes, 0, 0, 0, /* | |
2817 Return the default file protection for created files. | |
2818 The umask value determines which permissions are enabled in newly | |
2819 created files. If a permission's bit in the umask is 1, subsequently | |
2820 created files will not have that permission enabled. | |
2821 */ | |
2822 ()) | |
2823 { | |
2824 int mode; | |
2825 | |
2826 mode = umask (0); | |
2827 umask (mode); | |
2828 | |
2829 return make_int ((~ mode) & 0777); | |
2830 } | |
2831 | |
2832 DEFUN ("unix-sync", Funix_sync, 0, 0, "", /* | |
2833 Tell Unix to finish all pending disk updates. | |
2834 */ | |
2835 ()) | |
2836 { | |
442 | 2837 #ifndef WIN32_NATIVE |
428 | 2838 sync (); |
2839 #endif | |
2840 return Qnil; | |
2841 } | |
2842 | |
2843 | |
2844 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p, 2, 2, 0, /* | |
2845 Return t if file FILE1 is newer than file FILE2. | |
2846 If FILE1 does not exist, the answer is nil; | |
2847 otherwise, if FILE2 does not exist, the answer is t. | |
2848 */ | |
2849 (file1, file2)) | |
2850 { | |
2851 /* This function can GC. GC checked 1997.04.10. */ | |
2852 Lisp_Object abspath1, abspath2; | |
2853 struct stat st; | |
2854 int mtime1; | |
2855 Lisp_Object handler; | |
2856 struct gcpro gcpro1, gcpro2, gcpro3; | |
2857 | |
2858 CHECK_STRING (file1); | |
2859 CHECK_STRING (file2); | |
2860 | |
2861 abspath1 = Qnil; | |
2862 abspath2 = Qnil; | |
2863 | |
2864 GCPRO3 (abspath1, abspath2, current_buffer->directory); | |
2865 abspath1 = expand_and_dir_to_file (file1, current_buffer->directory); | |
2866 abspath2 = expand_and_dir_to_file (file2, current_buffer->directory); | |
2867 | |
2868 /* If the file name has special constructs in it, | |
2869 call the corresponding file handler. */ | |
2870 handler = Ffind_file_name_handler (abspath1, Qfile_newer_than_file_p); | |
2871 if (NILP (handler)) | |
2872 handler = Ffind_file_name_handler (abspath2, Qfile_newer_than_file_p); | |
2873 UNGCPRO; | |
2874 if (!NILP (handler)) | |
2875 return call3 (handler, Qfile_newer_than_file_p, abspath1, | |
2876 abspath2); | |
2877 | |
771 | 2878 if (qxe_stat (XSTRING_DATA (abspath1), &st) < 0) |
428 | 2879 return Qnil; |
2880 | |
2881 mtime1 = st.st_mtime; | |
2882 | |
771 | 2883 if (qxe_stat (XSTRING_DATA (abspath2), &st) < 0) |
428 | 2884 return Qt; |
2885 | |
2886 return (mtime1 > st.st_mtime) ? Qt : Qnil; | |
2887 } | |
2888 | |
2889 | |
2890 /* Stack sizes > 2**16 is a good way to elicit compiler bugs */ | |
2891 /* #define READ_BUF_SIZE (2 << 16) */ | |
2892 #define READ_BUF_SIZE (1 << 15) | |
2893 | |
2894 DEFUN ("insert-file-contents-internal", Finsert_file_contents_internal, | |
2895 1, 7, 0, /* | |
2896 Insert contents of file FILENAME after point; no coding-system frobbing. | |
2897 This function is identical to `insert-file-contents' except for the | |
771 | 2898 handling of the CODESYS and USED-CODESYS arguments. |
2899 | |
2900 The file is decoded according to CODESYS; if omitted, no conversion | |
2901 happens. If USED-CODESYS is non-nil, it should be a symbol, and the actual | |
2902 coding system that was used for the decoding is stored into it. It will in | |
2903 general be different from CODESYS if CODESYS specifies automatic encoding | |
2904 detection or end-of-line detection. | |
428 | 2905 |
444 | 2906 Currently START and END refer to byte positions (as opposed to character |
771 | 2907 positions), even in Mule and under MS Windows. (Fixing this, particularly |
2908 under Mule, is very difficult.) | |
428 | 2909 */ |
444 | 2910 (filename, visit, start, end, replace, codesys, used_codesys)) |
428 | 2911 { |
2912 /* This function can call lisp */ | |
2913 struct stat st; | |
2914 int fd; | |
2915 int saverrno = 0; | |
2916 Charcount inserted = 0; | |
2917 int speccount; | |
3841 | 2918 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4; |
3814 | 2919 Lisp_Object val; |
428 | 2920 int total; |
867 | 2921 Ibyte read_buf[READ_BUF_SIZE]; |
428 | 2922 int mc_count; |
2923 struct buffer *buf = current_buffer; | |
2924 Lisp_Object curbuf; | |
2925 int not_regular = 0; | |
771 | 2926 int do_speedy_insert = |
2927 coding_system_is_binary (Fget_coding_system (codesys)); | |
428 | 2928 |
2929 if (buf->base_buffer && ! NILP (visit)) | |
563 | 2930 invalid_operation ("Cannot do file visiting in an indirect buffer", Qunbound); |
428 | 2931 |
2932 /* No need to call Fbarf_if_buffer_read_only() here. | |
2933 That's called in begin_multiple_change() or wherever. */ | |
2934 | |
2935 val = Qnil; | |
2936 | |
2937 /* #### dmoore - should probably check in various places to see if | |
2938 curbuf was killed and if so signal an error? */ | |
2939 | |
793 | 2940 curbuf = wrap_buffer (buf); |
428 | 2941 |
3814 | 2942 GCPRO4 (filename, val, visit, curbuf); |
428 | 2943 |
2944 mc_count = (NILP (replace)) ? | |
2945 begin_multiple_change (buf, BUF_PT (buf), BUF_PT (buf)) : | |
2946 begin_multiple_change (buf, BUF_BEG (buf), BUF_Z (buf)); | |
2947 | |
2948 speccount = specpdl_depth (); /* begin_multiple_change also adds | |
2949 an unwind_protect */ | |
2950 | |
2951 filename = Fexpand_file_name (filename, Qnil); | |
2952 | |
2953 if (!NILP (used_codesys)) | |
2954 CHECK_SYMBOL (used_codesys); | |
2955 | |
444 | 2956 if ( (!NILP (start) || !NILP (end)) && !NILP (visit) ) |
563 | 2957 invalid_operation ("Attempt to visit less than an entire file", Qunbound); |
428 | 2958 |
2959 fd = -1; | |
2960 | |
771 | 2961 if (qxe_stat (XSTRING_DATA (filename), &st) < 0) |
428 | 2962 { |
2963 badopen: | |
2964 if (NILP (visit)) | |
563 | 2965 report_file_error ("Opening input file", filename); |
428 | 2966 st.st_mtime = -1; |
2967 goto notfound; | |
2968 } | |
2969 | |
2970 #ifdef S_IFREG | |
2971 /* Signal an error if we are accessing a non-regular file, with | |
444 | 2972 REPLACE, START or END being non-nil. */ |
428 | 2973 if (!S_ISREG (st.st_mode)) |
2974 { | |
2975 not_regular = 1; | |
2976 | |
2977 if (!NILP (visit)) | |
2978 goto notfound; | |
2979 | |
444 | 2980 if (!NILP (replace) || !NILP (start) || !NILP (end)) |
428 | 2981 { |
2982 end_multiple_change (buf, mc_count); | |
2983 | |
444 | 2984 RETURN_UNGCPRO |
2985 (Fsignal (Qfile_error, | |
771 | 2986 list2 (build_msg_string("not a regular file"), |
444 | 2987 filename))); |
428 | 2988 } |
2989 } | |
2990 #endif /* S_IFREG */ | |
2991 | |
444 | 2992 if (!NILP (start)) |
2993 CHECK_INT (start); | |
428 | 2994 else |
444 | 2995 start = Qzero; |
428 | 2996 |
2997 if (!NILP (end)) | |
2998 CHECK_INT (end); | |
2999 | |
3000 if (fd < 0) | |
3001 { | |
771 | 3002 if ((fd = qxe_interruptible_open (XSTRING_DATA (filename), |
3003 O_RDONLY | OPEN_BINARY, 0)) < 0) | |
428 | 3004 goto badopen; |
3005 } | |
3006 | |
3007 /* Replacement should preserve point as it preserves markers. */ | |
3008 if (!NILP (replace)) | |
3009 record_unwind_protect (restore_point_unwind, Fpoint_marker (Qnil, Qnil)); | |
3010 | |
3011 record_unwind_protect (close_file_unwind, make_int (fd)); | |
3012 | |
3013 /* Supposedly happens on VMS. */ | |
3014 if (st.st_size < 0) | |
563 | 3015 signal_error (Qfile_error, "File size is negative", Qunbound); |
428 | 3016 |
3017 if (NILP (end)) | |
3018 { | |
3019 if (!not_regular) | |
3020 { | |
3021 end = make_int (st.st_size); | |
3022 if (XINT (end) != st.st_size) | |
563 | 3023 out_of_memory ("Maximum buffer size exceeded", Qunbound); |
428 | 3024 } |
3025 } | |
3026 | |
3027 /* If requested, replace the accessible part of the buffer | |
3028 with the file contents. Avoid replacing text at the | |
3029 beginning or end of the buffer that matches the file contents; | |
771 | 3030 that preserves markers pointing to the unchanged parts. */ |
3031 /* The replace-mode code is currently implemented by comparing the | |
3032 file on disk with the contents in the buffer, character by character. | |
3033 That works only if the characters on disk are exactly what will go into | |
3034 the buffer -- i.e. `binary' conversion. | |
3035 | |
3036 FSF tries to implement this in all situations, even the non-binary | |
3037 conversion, by (in that case) loading the whole converted file into a | |
3038 separate memory area, then doing the comparison. I really don't see | |
3039 the point of this, and it will fail spectacularly if the file is many | |
3040 megabytes in size. To try to get around this, we could certainly read | |
3041 from the beginning and decode as necessary before comparing, but doing | |
3042 the same at the end gets very difficult because of the possibility of | |
3043 modal coding systems -- trying to decode data from any point forward | |
3044 without decoding previous data might always give you different results | |
3045 from starting at the beginning. We could try further tricks like | |
3046 keeping track of which coding systems are non-modal and providing some | |
3047 extra method for such coding systems to be given a chunk of data that | |
3048 came from a specified location in a specified file and ask the coding | |
3049 systems to return a "sync point" from which the data can be read | |
3050 forward and have results guaranteed to be the same as reading from the | |
3051 beginning to that point, but I really don't think it's worth it. If | |
3052 we implemented the FSF "brute-force" method, we would have to put a | |
3053 reasonable maximum file size on the files. Is any of this worth it? | |
3054 --ben | |
3055 | |
3638 | 3056 |
3057 It's probably not worth it, and despite what you might take from the | |
3058 above, we don't do it currently; that is, for non-"binary" coding | |
3059 systems, we don't try to implement replace-mode at all. See the | |
3060 do_speedy_insert variable above. The upside of this is that our API | |
3061 is consistent and not buggy. -- Aidan Kehoe, Fri Oct 27 21:02:30 CEST | |
3062 2006 | |
771 | 3063 */ |
3064 | |
428 | 3065 if (!NILP (replace)) |
3066 { | |
771 | 3067 if (!do_speedy_insert) |
3068 buffer_delete_range (buf, BUF_BEG (buf), BUF_Z (buf), | |
3069 !NILP (visit) ? INSDEL_NO_LOCKING : 0); | |
3070 else | |
428 | 3071 { |
771 | 3072 char buffer[1 << 14]; |
3073 Charbpos same_at_start = BUF_BEGV (buf); | |
3074 Charbpos same_at_end = BUF_ZV (buf); | |
3075 int overlap; | |
3076 | |
3077 /* Count how many chars at the start of the file | |
3078 match the text at the beginning of the buffer. */ | |
3079 while (1) | |
3080 { | |
3081 int nread; | |
3082 Charbpos charbpos; | |
3083 nread = read_allowing_quit (fd, buffer, sizeof (buffer)); | |
3084 if (nread < 0) | |
3085 report_file_error ("Reading", filename); | |
3086 else if (nread == 0) | |
3087 break; | |
3088 charbpos = 0; | |
3089 while (charbpos < nread && same_at_start < BUF_ZV (buf) | |
814 | 3090 && BUF_FETCH_CHAR (buf, same_at_start) == |
3091 buffer[charbpos]) | |
771 | 3092 same_at_start++, charbpos++; |
3093 /* If we found a discrepancy, stop the scan. | |
3094 Otherwise loop around and scan the next bufferful. */ | |
3095 if (charbpos != nread) | |
3096 break; | |
3097 } | |
3098 /* If the file matches the buffer completely, | |
3099 there's no need to replace anything. */ | |
3100 if (same_at_start - BUF_BEGV (buf) == st.st_size) | |
3101 { | |
3102 retry_close (fd); | |
3103 unbind_to (speccount); | |
3104 /* Truncate the buffer to the size of the file. */ | |
3105 buffer_delete_range (buf, same_at_start, same_at_end, | |
3106 !NILP (visit) ? INSDEL_NO_LOCKING : 0); | |
3107 goto handled; | |
3108 } | |
3109 /* Count how many chars at the end of the file | |
3110 match the text at the end of the buffer. */ | |
3111 while (1) | |
3112 { | |
3113 int total_read, nread; | |
814 | 3114 Charcount charbpos, curpos, trial; |
771 | 3115 |
3116 /* At what file position are we now scanning? */ | |
3117 curpos = st.st_size - (BUF_ZV (buf) - same_at_end); | |
3118 /* If the entire file matches the buffer tail, stop the scan. */ | |
3119 if (curpos == 0) | |
3120 break; | |
3121 /* How much can we scan in the next step? */ | |
3122 trial = min (curpos, (Charbpos) sizeof (buffer)); | |
3123 if (lseek (fd, curpos - trial, 0) < 0) | |
3124 report_file_error ("Setting file position", filename); | |
3125 | |
3126 total_read = 0; | |
3127 while (total_read < trial) | |
3128 { | |
3129 nread = read_allowing_quit (fd, buffer + total_read, | |
3130 trial - total_read); | |
3131 if (nread <= 0) | |
3132 report_file_error ("IO error reading file", filename); | |
3133 total_read += nread; | |
3134 } | |
3135 /* Scan this bufferful from the end, comparing with | |
3136 the Emacs buffer. */ | |
3137 charbpos = total_read; | |
3138 /* Compare with same_at_start to avoid counting some buffer text | |
3139 as matching both at the file's beginning and at the end. */ | |
3140 while (charbpos > 0 && same_at_end > same_at_start | |
3141 && BUF_FETCH_CHAR (buf, same_at_end - 1) == | |
3142 buffer[charbpos - 1]) | |
3143 same_at_end--, charbpos--; | |
3144 /* If we found a discrepancy, stop the scan. | |
3145 Otherwise loop around and scan the preceding bufferful. */ | |
3146 if (charbpos != 0) | |
3147 break; | |
3148 /* If display current starts at beginning of line, | |
3149 keep it that way. */ | |
3150 if (XBUFFER (XWINDOW (Fselected_window (Qnil))->buffer) == buf) | |
3151 XWINDOW (Fselected_window (Qnil))->start_at_line_beg = | |
3152 !NILP (Fbolp (wrap_buffer (buf))); | |
3153 } | |
3154 | |
3155 /* Don't try to reuse the same piece of text twice. */ | |
3156 overlap = same_at_start - BUF_BEGV (buf) - | |
3157 (same_at_end + st.st_size - BUF_ZV (buf)); | |
3158 if (overlap > 0) | |
3159 same_at_end += overlap; | |
3160 | |
3161 /* Arrange to read only the nonmatching middle part of the file. */ | |
3162 start = make_int (same_at_start - BUF_BEGV (buf)); | |
3163 end = make_int (st.st_size - (BUF_ZV (buf) - same_at_end)); | |
3164 | |
428 | 3165 buffer_delete_range (buf, same_at_start, same_at_end, |
3166 !NILP (visit) ? INSDEL_NO_LOCKING : 0); | |
771 | 3167 /* Insert from the file at the proper position. */ |
3168 BUF_SET_PT (buf, same_at_start); | |
428 | 3169 } |
3170 } | |
3171 | |
3172 if (!not_regular) | |
3173 { | |
444 | 3174 total = XINT (end) - XINT (start); |
428 | 3175 |
3176 /* Make sure point-max won't overflow after this insertion. */ | |
3177 if (total != XINT (make_int (total))) | |
563 | 3178 out_of_memory ("Maximum buffer size exceeded", Qunbound); |
428 | 3179 } |
3180 else | |
3181 /* For a special file, all we can do is guess. The value of -1 | |
3182 will make the stream functions read as much as possible. */ | |
3183 total = -1; | |
3184 | |
444 | 3185 if (XINT (start) != 0 |
428 | 3186 /* why was this here? asked jwz. The reason is that the replace-mode |
3187 connivings above will normally put the file pointer other than | |
3188 where it should be. */ | |
771 | 3189 || (!NILP (replace) && do_speedy_insert)) |
428 | 3190 { |
444 | 3191 if (lseek (fd, XINT (start), 0) < 0) |
563 | 3192 report_file_error ("Setting file position", filename); |
428 | 3193 } |
3194 | |
3195 { | |
665 | 3196 Charbpos cur_point = BUF_PT (buf); |
428 | 3197 struct gcpro ngcpro1; |
3198 Lisp_Object stream = make_filedesc_input_stream (fd, 0, total, | |
3199 LSTR_ALLOW_QUIT); | |
3200 | |
3201 NGCPRO1 (stream); | |
3202 Lstream_set_buffering (XLSTREAM (stream), LSTREAM_BLOCKN_BUFFERED, 65536); | |
771 | 3203 stream = make_coding_input_stream |
3204 (XLSTREAM (stream), get_coding_system_for_text_file (codesys, 1), | |
800 | 3205 CODING_DECODE, 0); |
428 | 3206 Lstream_set_buffering (XLSTREAM (stream), LSTREAM_BLOCKN_BUFFERED, 65536); |
3207 | |
3208 record_unwind_protect (delete_stream_unwind, stream); | |
3209 | |
3210 /* No need to limit the amount of stuff we attempt to read. (It would | |
3211 be incorrect, anyway, when Mule is enabled.) Instead, the limiting | |
3212 occurs inside of the filedesc stream. */ | |
3213 while (1) | |
3214 { | |
665 | 3215 Bytecount this_len; |
428 | 3216 Charcount cc_inserted; |
3217 | |
3218 QUIT; | |
3219 this_len = Lstream_read (XLSTREAM (stream), read_buf, | |
3220 sizeof (read_buf)); | |
3221 | |
3222 if (this_len <= 0) | |
3223 { | |
3224 if (this_len < 0) | |
3225 saverrno = errno; | |
3226 break; | |
3227 } | |
3228 | |
3229 cc_inserted = buffer_insert_raw_string_1 (buf, cur_point, read_buf, | |
3230 this_len, | |
3231 !NILP (visit) | |
3232 ? INSDEL_NO_LOCKING : 0); | |
3233 inserted += cc_inserted; | |
3234 cur_point += cc_inserted; | |
3235 } | |
3236 if (!NILP (used_codesys)) | |
3237 { | |
3238 Fset (used_codesys, | |
771 | 3239 XCODING_SYSTEM_NAME |
3240 (coding_stream_detected_coding_system (XLSTREAM (stream)))); | |
428 | 3241 } |
3242 NUNGCPRO; | |
3243 } | |
3244 | |
3245 /* Close the file/stream */ | |
771 | 3246 unbind_to (speccount); |
428 | 3247 |
3248 if (saverrno != 0) | |
3249 { | |
563 | 3250 errno = saverrno; |
3251 report_file_error ("Reading", filename); | |
428 | 3252 } |
3253 | |
3254 notfound: | |
3255 handled: | |
3256 | |
3257 end_multiple_change (buf, mc_count); | |
3258 | |
3259 if (!NILP (visit)) | |
3260 { | |
3261 if (!EQ (buf->undo_list, Qt)) | |
3262 buf->undo_list = Qnil; | |
3814 | 3263 buf->modtime = st.st_mtime; |
3264 buf->filename = filename; | |
3265 /* XEmacs addition: */ | |
3266 /* This function used to be in C, ostensibly so that | |
3267 it could be called here. But that's just silly. | |
3268 There's no reason C code can't call out to Lisp | |
3269 code, and it's a lot cleaner this way. */ | |
3270 /* Note: compute-buffer-file-truename is called for | |
3271 side-effect! Its return value is intentionally | |
3272 ignored. */ | |
3273 if (!NILP (Ffboundp (Qcompute_buffer_file_truename))) | |
3274 call1 (Qcompute_buffer_file_truename, wrap_buffer (buf)); | |
428 | 3275 BUF_SAVE_MODIFF (buf) = BUF_MODIFF (buf); |
3276 buf->auto_save_modified = BUF_MODIFF (buf); | |
3277 buf->saved_size = make_int (BUF_SIZE (buf)); | |
3278 #ifdef CLASH_DETECTION | |
3814 | 3279 if (!NILP (buf->file_truename)) |
3280 unlock_file (buf->file_truename); | |
3281 unlock_file (filename); | |
428 | 3282 #endif /* CLASH_DETECTION */ |
3283 if (not_regular) | |
3284 RETURN_UNGCPRO (Fsignal (Qfile_error, | |
771 | 3285 list2 (build_msg_string ("not a regular file"), |
428 | 3286 filename))); |
3287 | |
3288 /* If visiting nonexistent file, return nil. */ | |
3289 if (buf->modtime == -1) | |
3290 report_file_error ("Opening input file", | |
563 | 3291 filename); |
428 | 3292 } |
3293 | |
3294 /* Decode file format */ | |
3295 if (inserted > 0) | |
3296 { | |
3297 Lisp_Object insval = call3 (Qformat_decode, | |
3298 Qnil, make_int (inserted), visit); | |
3299 CHECK_INT (insval); | |
3300 inserted = XINT (insval); | |
3301 } | |
3302 | |
3303 if (inserted > 0) | |
3304 { | |
2367 | 3305 GC_EXTERNAL_LIST_LOOP_2 (p, Vafter_insert_file_functions) |
428 | 3306 { |
2367 | 3307 Lisp_Object insval = call1 (p, make_int (inserted)); |
428 | 3308 if (!NILP (insval)) |
3309 { | |
3310 CHECK_NATNUM (insval); | |
3311 inserted = XINT (insval); | |
3312 } | |
3313 } | |
2367 | 3314 END_GC_EXTERNAL_LIST_LOOP (p); |
428 | 3315 } |
3316 | |
3317 UNGCPRO; | |
3318 | |
3319 if (!NILP (val)) | |
3320 return (val); | |
3321 else | |
3322 return (list2 (filename, make_int (inserted))); | |
3323 } | |
3324 | |
3325 | |
3326 static int a_write (Lisp_Object outstream, Lisp_Object instream, int pos, | |
3327 Lisp_Object *annot); | |
3328 static Lisp_Object build_annotations (Lisp_Object start, Lisp_Object end); | |
3329 | |
3330 /* If build_annotations switched buffers, switch back to BUF. | |
3331 Kill the temporary buffer that was selected in the meantime. */ | |
3332 | |
3333 static Lisp_Object | |
3334 build_annotations_unwind (Lisp_Object buf) | |
3335 { | |
3336 Lisp_Object tembuf; | |
3337 | |
3338 if (XBUFFER (buf) == current_buffer) | |
3339 return Qnil; | |
3340 tembuf = Fcurrent_buffer (); | |
3341 Fset_buffer (buf); | |
3342 Fkill_buffer (tembuf); | |
3343 return Qnil; | |
3344 } | |
3345 | |
4266 | 3346 DEFUN ("write-region-internal", Fwrite_region_internal, 3, 8, |
428 | 3347 "r\nFWrite region to file: ", /* |
3348 Write current region into specified file; no coding-system frobbing. | |
4266 | 3349 |
3350 This function is almost identical to `write-region'; see that function for | |
3351 documentation of the START, END, FILENAME, APPEND, VISIT, and LOCKNAME | |
3352 arguments. CODESYS specifies the encoding to be used for the file; if it is | |
3353 nil, no code conversion occurs. (With `write-region' the coding system is | |
3354 determined automatically if not specified.) | |
3355 | |
3356 MUSTBENEW specifies that a check for an existing file of the same name | |
3357 should be made. If it is 'excl, XEmacs will error on detecting such a file | |
3358 and never write it. If it is some other non-nil value, the user will be | |
3359 prompted to confirm the overwriting of an existing file. If it is nil, | |
3360 existing files are silently overwritten when file system permissions allow | |
3361 this. | |
764 | 3362 |
3363 As a special kludge to support auto-saving, when START is nil START and | |
3364 END are set to the beginning and end, respectively, of the buffer, | |
3365 regardless of any restrictions. Don't use this feature. It is documented | |
3366 here because write-region handler writers need to be aware of it. | |
4266 | 3367 |
428 | 3368 */ |
4266 | 3369 (start, end, filename, append, visit, lockname, codesys, |
3370 mustbenew)) | |
428 | 3371 { |
442 | 3372 /* This function can call lisp. GC checked 2000-07-28 ben */ |
428 | 3373 int desc; |
3374 int failure; | |
3375 int save_errno = 0; | |
3376 struct stat st; | |
442 | 3377 Lisp_Object fn = Qnil; |
428 | 3378 int speccount = specpdl_depth (); |
3379 int visiting_other = STRINGP (visit); | |
3380 int visiting = (EQ (visit, Qt) || visiting_other); | |
3381 int quietly = (!visiting && !NILP (visit)); | |
3382 Lisp_Object visit_file = Qnil; | |
3383 Lisp_Object annotations = Qnil; | |
3384 struct buffer *given_buffer; | |
665 | 3385 Charbpos start1, end1; |
442 | 3386 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; |
3387 struct gcpro ngcpro1, ngcpro2; | |
793 | 3388 Lisp_Object curbuf = wrap_buffer (current_buffer); |
3389 | |
442 | 3390 |
3391 /* start, end, visit, and append are never modified in this fun | |
3392 so we don't protect them. */ | |
3393 GCPRO5 (visit_file, filename, codesys, lockname, annotations); | |
3394 NGCPRO2 (curbuf, fn); | |
3395 | |
3396 /* [[ dmoore - if Fexpand_file_name or handlers kill the buffer, | |
428 | 3397 we should signal an error rather than blissfully continuing |
3398 along. ARGH, this function is going to lose lose lose. We need | |
3399 to protect the current_buffer from being destroyed, but the | |
442 | 3400 multiple return points make this a pain in the butt. ]] we do |
3401 protect curbuf now. --ben */ | |
428 | 3402 |
771 | 3403 codesys = get_coding_system_for_text_file (codesys, 0); |
428 | 3404 |
3405 if (current_buffer->base_buffer && ! NILP (visit)) | |
442 | 3406 invalid_operation ("Cannot do file visiting in an indirect buffer", |
3407 curbuf); | |
428 | 3408 |
3409 if (!NILP (start) && !STRINGP (start)) | |
3410 get_buffer_range_char (current_buffer, start, end, &start1, &end1, 0); | |
3411 | |
3412 { | |
3413 Lisp_Object handler; | |
3414 | |
4266 | 3415 if (!NILP (mustbenew) && !EQ (mustbenew, Qexcl)) |
3416 barf_or_query_if_file_exists (filename, "overwrite", 1, NULL); | |
3417 | |
428 | 3418 if (visiting_other) |
3419 visit_file = Fexpand_file_name (visit, Qnil); | |
3420 else | |
3421 visit_file = filename; | |
3422 filename = Fexpand_file_name (filename, Qnil); | |
3423 | |
3424 if (NILP (lockname)) | |
3425 lockname = visit_file; | |
3426 | |
442 | 3427 /* We used to UNGCPRO here. BAD! visit_file is used below after |
3428 more Lisp calling. */ | |
428 | 3429 /* If the file name has special constructs in it, |
3430 call the corresponding file handler. */ | |
3431 handler = Ffind_file_name_handler (filename, Qwrite_region); | |
3432 /* If FILENAME has no handler, see if VISIT has one. */ | |
3433 if (NILP (handler) && STRINGP (visit)) | |
3434 handler = Ffind_file_name_handler (visit, Qwrite_region); | |
3435 | |
3436 if (!NILP (handler)) | |
3437 { | |
3438 Lisp_Object val = call8 (handler, Qwrite_region, start, end, | |
3439 filename, append, visit, lockname, codesys); | |
3440 if (visiting) | |
3441 { | |
3442 BUF_SAVE_MODIFF (current_buffer) = BUF_MODIFF (current_buffer); | |
3443 current_buffer->saved_size = make_int (BUF_SIZE (current_buffer)); | |
3444 current_buffer->filename = visit_file; | |
3445 MARK_MODELINE_CHANGED; | |
3446 } | |
442 | 3447 NUNGCPRO; |
3448 UNGCPRO; | |
428 | 3449 return val; |
3450 } | |
3451 } | |
3452 | |
3453 #ifdef CLASH_DETECTION | |
3454 if (!auto_saving) | |
442 | 3455 lock_file (lockname); |
428 | 3456 #endif /* CLASH_DETECTION */ |
3457 | |
3458 /* Special kludge to simplify auto-saving. */ | |
3459 if (NILP (start)) | |
3460 { | |
3461 start1 = BUF_BEG (current_buffer); | |
3462 end1 = BUF_Z (current_buffer); | |
3463 } | |
3464 | |
3465 record_unwind_protect (build_annotations_unwind, Fcurrent_buffer ()); | |
3466 | |
3467 given_buffer = current_buffer; | |
3468 annotations = build_annotations (start, end); | |
3469 if (current_buffer != given_buffer) | |
3470 { | |
3471 start1 = BUF_BEGV (current_buffer); | |
3472 end1 = BUF_ZV (current_buffer); | |
3473 } | |
3474 | |
3475 fn = filename; | |
3476 desc = -1; | |
3477 if (!NILP (append)) | |
3478 { | |
4266 | 3479 desc = qxe_open (XSTRING_DATA (fn), O_WRONLY | OPEN_BINARY |
3480 | (EQ (mustbenew, Qexcl) ? O_EXCL : 0), 0); | |
428 | 3481 } |
3482 if (desc < 0) | |
3483 { | |
771 | 3484 desc = qxe_open (XSTRING_DATA (fn), |
4266 | 3485 O_WRONLY | (EQ (mustbenew, Qexcl) ? O_EXCL : O_TRUNC) |
3486 | O_CREAT | OPEN_BINARY, | |
771 | 3487 auto_saving ? auto_save_mode_bits : CREAT_MODE); |
428 | 3488 } |
3489 | |
3490 if (desc < 0) | |
3491 { | |
3492 #ifdef CLASH_DETECTION | |
3493 save_errno = errno; | |
3494 if (!auto_saving) unlock_file (lockname); | |
3495 errno = save_errno; | |
3496 #endif /* CLASH_DETECTION */ | |
563 | 3497 report_file_error ("Opening output file", filename); |
428 | 3498 } |
3499 | |
3500 { | |
3501 Lisp_Object desc_locative = Fcons (make_int (desc), Qnil); | |
3502 Lisp_Object instream = Qnil, outstream = Qnil; | |
442 | 3503 struct gcpro nngcpro1, nngcpro2; |
3504 NNGCPRO2 (instream, outstream); | |
428 | 3505 |
3506 record_unwind_protect (close_file_unwind, desc_locative); | |
3507 | |
3508 if (!NILP (append)) | |
3509 { | |
3510 if (lseek (desc, 0, 2) < 0) | |
3511 { | |
3512 #ifdef CLASH_DETECTION | |
3513 if (!auto_saving) unlock_file (lockname); | |
3514 #endif /* CLASH_DETECTION */ | |
3515 report_file_error ("Lseek error", | |
563 | 3516 filename); |
428 | 3517 } |
3518 } | |
3519 | |
3520 failure = 0; | |
3521 | |
3522 /* Note: I tried increasing the buffering size, along with | |
3523 various other tricks, but nothing seemed to make much of | |
3524 a difference in the time it took to save a large file. | |
3525 (Actually that's not true. With a local disk, changing | |
3526 the buffer size doesn't seem to make much difference. | |
3527 With an NFS-mounted disk, it could make a lot of difference | |
3528 because you're affecting the number of network requests | |
3529 that need to be made, and there could be a large latency | |
3530 for each request. So I've increased the buffer size | |
3531 to 64K.) */ | |
3532 outstream = make_filedesc_output_stream (desc, 0, -1, 0); | |
3533 Lstream_set_buffering (XLSTREAM (outstream), | |
3534 LSTREAM_BLOCKN_BUFFERED, 65536); | |
3535 outstream = | |
800 | 3536 make_coding_output_stream (XLSTREAM (outstream), codesys, |
3537 CODING_ENCODE, 0); | |
428 | 3538 Lstream_set_buffering (XLSTREAM (outstream), |
3539 LSTREAM_BLOCKN_BUFFERED, 65536); | |
3540 if (STRINGP (start)) | |
3541 { | |
3542 instream = make_lisp_string_input_stream (start, 0, -1); | |
3543 start1 = 0; | |
3544 } | |
3545 else | |
3546 instream = make_lisp_buffer_input_stream (current_buffer, start1, end1, | |
3547 LSTR_SELECTIVE | | |
3548 LSTR_IGNORE_ACCESSIBLE); | |
3549 failure = (0 > (a_write (outstream, instream, start1, | |
3550 &annotations))); | |
3551 save_errno = errno; | |
3552 /* Note that this doesn't close the desc since we created the | |
3553 stream without the LSTR_CLOSING flag, but it does | |
3554 flush out any buffered data. */ | |
3555 if (Lstream_close (XLSTREAM (outstream)) < 0) | |
3556 { | |
3557 failure = 1; | |
3558 save_errno = errno; | |
3559 } | |
3560 Lstream_close (XLSTREAM (instream)); | |
3561 | |
3562 #ifdef HAVE_FSYNC | |
3563 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun). | |
3564 Disk full in NFS may be reported here. */ | |
3565 /* mib says that closing the file will try to write as fast as NFS can do | |
3566 it, and that means the fsync here is not crucial for autosave files. */ | |
3567 if (!auto_saving && fsync (desc) < 0 | |
3568 /* If fsync fails with EINTR, don't treat that as serious. */ | |
3569 && errno != EINTR) | |
3570 { | |
3571 failure = 1; | |
3572 save_errno = errno; | |
3573 } | |
3574 #endif /* HAVE_FSYNC */ | |
3575 | |
440 | 3576 /* Spurious "file has changed on disk" warnings used to be seen on |
3577 systems where close() can change the modtime. This is known to | |
3578 happen on various NFS file systems, on Windows, and on Linux. | |
3579 Rather than handling this on a per-system basis, we | |
771 | 3580 unconditionally do the qxe_stat() after the retry_close(). */ |
428 | 3581 |
3582 /* NFS can report a write failure now. */ | |
771 | 3583 if (retry_close (desc) < 0) |
428 | 3584 { |
3585 failure = 1; | |
3586 save_errno = errno; | |
3587 } | |
3588 | |
3589 /* Discard the close unwind-protect. Execute the one for | |
3590 build_annotations (switches back to the original current buffer | |
3591 as necessary). */ | |
3592 XCAR (desc_locative) = Qnil; | |
771 | 3593 unbind_to (speccount); |
442 | 3594 |
3595 NNUNGCPRO; | |
428 | 3596 } |
3597 | |
771 | 3598 qxe_stat (XSTRING_DATA (fn), &st); |
428 | 3599 |
3600 #ifdef CLASH_DETECTION | |
3601 if (!auto_saving) | |
3602 unlock_file (lockname); | |
3603 #endif /* CLASH_DETECTION */ | |
3604 | |
3605 /* Do this before reporting IO error | |
3606 to avoid a "file has changed on disk" warning on | |
3607 next attempt to save. */ | |
3608 if (visiting) | |
3609 current_buffer->modtime = st.st_mtime; | |
3610 | |
3611 if (failure) | |
442 | 3612 { |
3613 errno = save_errno; | |
563 | 3614 report_file_error ("Writing file", fn); |
442 | 3615 } |
428 | 3616 |
3617 if (visiting) | |
3618 { | |
3619 BUF_SAVE_MODIFF (current_buffer) = BUF_MODIFF (current_buffer); | |
3620 current_buffer->saved_size = make_int (BUF_SIZE (current_buffer)); | |
3621 current_buffer->filename = visit_file; | |
3622 MARK_MODELINE_CHANGED; | |
3623 } | |
3624 else if (quietly) | |
3625 { | |
442 | 3626 NUNGCPRO; |
3627 UNGCPRO; | |
428 | 3628 return Qnil; |
3629 } | |
3630 | |
3631 if (!auto_saving) | |
3632 { | |
3633 if (visiting_other) | |
3634 message ("Wrote %s", XSTRING_DATA (visit_file)); | |
3635 else | |
3636 { | |
446 | 3637 Lisp_Object fsp = Qnil; |
442 | 3638 struct gcpro nngcpro1; |
3639 | |
3640 NNGCPRO1 (fsp); | |
428 | 3641 fsp = Ffile_symlink_p (fn); |
3642 if (NILP (fsp)) | |
3643 message ("Wrote %s", XSTRING_DATA (fn)); | |
3644 else | |
3645 message ("Wrote %s (symlink to %s)", | |
3646 XSTRING_DATA (fn), XSTRING_DATA (fsp)); | |
442 | 3647 NNUNGCPRO; |
428 | 3648 } |
3649 } | |
442 | 3650 NUNGCPRO; |
3651 UNGCPRO; | |
428 | 3652 return Qnil; |
3653 } | |
3654 | |
3655 /* #### This is such a load of shit!!!! There is no way we should define | |
3656 something so stupid as a subr, just sort the fucking list more | |
3657 intelligently. */ | |
3658 DEFUN ("car-less-than-car", Fcar_less_than_car, 2, 2, 0, /* | |
3659 Return t if (car A) is numerically less than (car B). | |
3660 */ | |
3661 (a, b)) | |
3662 { | |
3663 Lisp_Object objs[2]; | |
3664 objs[0] = Fcar (a); | |
3665 objs[1] = Fcar (b); | |
3666 return Flss (2, objs); | |
3667 } | |
3668 | |
3669 /* Heh heh heh, let's define this too, just to aggravate the person who | |
3670 wrote the above comment. */ | |
3671 DEFUN ("cdr-less-than-cdr", Fcdr_less_than_cdr, 2, 2, 0, /* | |
3672 Return t if (cdr A) is numerically less than (cdr B). | |
3673 */ | |
3674 (a, b)) | |
3675 { | |
3676 Lisp_Object objs[2]; | |
3677 objs[0] = Fcdr (a); | |
3678 objs[1] = Fcdr (b); | |
3679 return Flss (2, objs); | |
3680 } | |
3681 | |
3682 /* Build the complete list of annotations appropriate for writing out | |
3683 the text between START and END, by calling all the functions in | |
3684 write-region-annotate-functions and merging the lists they return. | |
3685 If one of these functions switches to a different buffer, we assume | |
3686 that buffer contains altered text. Therefore, the caller must | |
3687 make sure to restore the current buffer in all cases, | |
3688 as save-excursion would do. */ | |
3689 | |
3690 static Lisp_Object | |
3691 build_annotations (Lisp_Object start, Lisp_Object end) | |
3692 { | |
3693 /* This function can GC */ | |
3694 Lisp_Object annotations; | |
3695 Lisp_Object p, res; | |
3696 struct gcpro gcpro1, gcpro2; | |
793 | 3697 Lisp_Object original_buffer = wrap_buffer (current_buffer); |
3698 | |
428 | 3699 |
3700 annotations = Qnil; | |
3701 p = Vwrite_region_annotate_functions; | |
3702 GCPRO2 (annotations, p); | |
3703 while (!NILP (p)) | |
3704 { | |
3705 struct buffer *given_buffer = current_buffer; | |
3706 Vwrite_region_annotations_so_far = annotations; | |
3707 res = call2 (Fcar (p), start, end); | |
3708 /* If the function makes a different buffer current, | |
3709 assume that means this buffer contains altered text to be output. | |
3710 Reset START and END from the buffer bounds | |
3711 and discard all previous annotations because they should have | |
3712 been dealt with by this function. */ | |
3713 if (current_buffer != given_buffer) | |
3714 { | |
3715 start = make_int (BUF_BEGV (current_buffer)); | |
3716 end = make_int (BUF_ZV (current_buffer)); | |
3717 annotations = Qnil; | |
3718 } | |
3719 Flength (res); /* Check basic validity of return value */ | |
3720 annotations = merge (annotations, res, Qcar_less_than_car); | |
3721 p = Fcdr (p); | |
3722 } | |
3723 | |
3724 /* Now do the same for annotation functions implied by the file-format */ | |
3725 if (auto_saving && (!EQ (Vauto_save_file_format, Qt))) | |
3726 p = Vauto_save_file_format; | |
3727 else | |
3728 p = current_buffer->file_format; | |
3729 while (!NILP (p)) | |
3730 { | |
3731 struct buffer *given_buffer = current_buffer; | |
3732 Vwrite_region_annotations_so_far = annotations; | |
3733 res = call4 (Qformat_annotate_function, Fcar (p), start, end, | |
3734 original_buffer); | |
3735 if (current_buffer != given_buffer) | |
3736 { | |
3737 start = make_int (BUF_BEGV (current_buffer)); | |
3738 end = make_int (BUF_ZV (current_buffer)); | |
3739 annotations = Qnil; | |
3740 } | |
3741 Flength (res); | |
3742 annotations = merge (annotations, res, Qcar_less_than_car); | |
3743 p = Fcdr (p); | |
3744 } | |
3745 UNGCPRO; | |
3746 return annotations; | |
3747 } | |
3748 | |
3749 /* Write to stream OUTSTREAM the characters from INSTREAM (it is read until | |
3750 EOF is encountered), assuming they start at position POS in the buffer | |
3751 of string that STREAM refers to. Intersperse with them the annotations | |
3752 from *ANNOT that fall into the range of positions we are reading from, | |
3753 each at its appropriate position. | |
3754 | |
3755 Modify *ANNOT by discarding elements as we output them. | |
3756 The return value is negative in case of system call failure. */ | |
3757 | |
3758 /* 4K should probably be fine. We just need to reduce the number of | |
3759 function calls to reasonable level. The Lstream stuff itself will | |
3760 batch to 64K to reduce the number of system calls. */ | |
3761 | |
3762 #define A_WRITE_BATCH_SIZE 4096 | |
3763 | |
3764 static int | |
3765 a_write (Lisp_Object outstream, Lisp_Object instream, int pos, | |
3766 Lisp_Object *annot) | |
3767 { | |
3768 Lisp_Object tem; | |
3769 int nextpos; | |
3770 unsigned char largebuf[A_WRITE_BATCH_SIZE]; | |
3771 Lstream *instr = XLSTREAM (instream); | |
3772 Lstream *outstr = XLSTREAM (outstream); | |
3773 | |
3774 while (LISTP (*annot)) | |
3775 { | |
3776 tem = Fcar_safe (Fcar (*annot)); | |
3777 if (INTP (tem)) | |
3778 nextpos = XINT (tem); | |
3779 else | |
3780 nextpos = INT_MAX; | |
3781 #ifdef MULE | |
3782 /* If there are annotations left and we have Mule, then we | |
867 | 3783 have to do the I/O one ichar at a time so we can |
428 | 3784 determine when to insert the annotation. */ |
3785 if (!NILP (*annot)) | |
3786 { | |
867 | 3787 Ichar ch; |
3788 while (pos != nextpos && (ch = Lstream_get_ichar (instr)) != EOF) | |
428 | 3789 { |
867 | 3790 if (Lstream_put_ichar (outstr, ch) < 0) |
428 | 3791 return -1; |
3792 pos++; | |
3793 } | |
3794 } | |
3795 else | |
3796 #endif /* MULE */ | |
3797 { | |
3798 while (pos != nextpos) | |
3799 { | |
3800 /* Otherwise there is no point to that. Just go in batches. */ | |
3801 int chunk = min (nextpos - pos, A_WRITE_BATCH_SIZE); | |
3802 | |
3803 chunk = Lstream_read (instr, largebuf, chunk); | |
3804 if (chunk < 0) | |
3805 return -1; | |
3806 if (chunk == 0) /* EOF */ | |
3807 break; | |
771 | 3808 if (Lstream_write (outstr, largebuf, chunk) < 0) |
428 | 3809 return -1; |
3810 pos += chunk; | |
3811 } | |
3812 } | |
3813 if (pos == nextpos) | |
3814 { | |
3815 tem = Fcdr (Fcar (*annot)); | |
3816 if (STRINGP (tem)) | |
3817 { | |
3818 if (Lstream_write (outstr, XSTRING_DATA (tem), | |
3819 XSTRING_LENGTH (tem)) < 0) | |
3820 return -1; | |
3821 } | |
3822 *annot = Fcdr (*annot); | |
3823 } | |
3824 else | |
3825 return 0; | |
3826 } | |
3827 return -1; | |
3828 } | |
3829 | |
3830 | |
3831 | |
3832 #if 0 | |
3833 #include <des_crypt.h> | |
3834 | |
3835 #define CRYPT_BLOCK_SIZE 8 /* bytes */ | |
3836 #define CRYPT_KEY_SIZE 8 /* bytes */ | |
3837 | |
3838 DEFUN ("encrypt-string", Fencrypt_string, 2, 2, 0, /* | |
3839 Encrypt STRING using KEY. | |
3840 */ | |
3841 (string, key)) | |
3842 { | |
2367 | 3843 /* !!#### Needs work */ |
1333 | 3844 Extbyte *encrypted_string, *raw_key; |
3845 Extbyte *string_ext, *key_ext; | |
3846 Bytecount string_size_ext, key_size_ext, rounded_size, extra, key_size; | |
3847 | |
428 | 3848 CHECK_STRING (string); |
3849 CHECK_STRING (key); | |
3850 | |
1333 | 3851 LISP_STRING_TO_SIZED_EXTERNAL (string, string_ext, string_size_ext, Qbinary); |
3852 LISP_STRING_TO_SIZED_EXTERNAL (key, key_ext, key_size_ext, Qbinary); | |
3853 | |
3854 extra = string_size_ext % CRYPT_BLOCK_SIZE; | |
3855 rounded_size = string_size_ext + extra; | |
851 | 3856 encrypted_string = ALLOCA (rounded_size + 1); |
1333 | 3857 memcpy (encrypted_string, string_ext, string_size_ext); |
428 | 3858 memset (encrypted_string + rounded_size - extra, 0, extra + 1); |
3859 | |
1333 | 3860 key_size = min (CRYPT_KEY_SIZE, key_size_ext); |
428 | 3861 |
851 | 3862 raw_key = ALLOCA (CRYPT_KEY_SIZE + 1); |
1333 | 3863 memcpy (raw_key, key_ext, key_size); |
428 | 3864 memset (raw_key + key_size, 0, (CRYPT_KEY_SIZE + 1) - key_size); |
3865 | |
3866 ecb_crypt (raw_key, encrypted_string, rounded_size, | |
3867 DES_ENCRYPT | DES_SW); | |
1333 | 3868 return make_ext_string (encrypted_string, rounded_size, Qbinary); |
428 | 3869 } |
3870 | |
3871 DEFUN ("decrypt-string", Fdecrypt_string, 2, 2, 0, /* | |
3872 Decrypt STRING using KEY. | |
3873 */ | |
3874 (string, key)) | |
3875 { | |
1333 | 3876 Extbyte *decrypted_string, *raw_key; |
3877 Extbyte *string_ext, *key_ext; | |
3878 Bytecount string_size_ext, key_size_ext, string_size, key_size; | |
428 | 3879 |
3880 CHECK_STRING (string); | |
3881 CHECK_STRING (key); | |
3882 | |
1333 | 3883 LISP_STRING_TO_SIZED_EXTERNAL (string, string_ext, string_size_ext, Qbinary); |
3884 LISP_STRING_TO_SIZED_EXTERNAL (key, key_ext, key_size_ext, Qbinary); | |
3885 | |
3886 string_size = string_size_ext + 1; | |
851 | 3887 decrypted_string = ALLOCA (string_size); |
1333 | 3888 memcpy (decrypted_string, string_ext, string_size); |
428 | 3889 decrypted_string[string_size - 1] = '\0'; |
3890 | |
1333 | 3891 key_size = min (CRYPT_KEY_SIZE, key_size_ext); |
428 | 3892 |
851 | 3893 raw_key = ALLOCA (CRYPT_KEY_SIZE + 1); |
1333 | 3894 memcpy (raw_key, key_ext, key_size); |
428 | 3895 memset (raw_key + key_size, 0, (CRYPT_KEY_SIZE + 1) - key_size); |
3896 | |
3897 | |
3898 ecb_crypt (raw_key, decrypted_string, string_size, D | DES_SW); | |
1333 | 3899 return make_ext_string (decrypted_string, string_size - 1, Qbinary); |
428 | 3900 } |
3901 #endif /* 0 */ | |
3902 | |
3903 | |
3904 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime, 1, 1, 0, /* | |
444 | 3905 Return t if last mod time of BUFFER's visited file matches what BUFFER records. |
428 | 3906 This means that the file has not been changed since it was visited or saved. |
3907 */ | |
444 | 3908 (buffer)) |
428 | 3909 { |
442 | 3910 /* This function can call lisp; GC checked 2000-07-11 ben */ |
428 | 3911 struct buffer *b; |
3912 struct stat st; | |
3913 Lisp_Object handler; | |
3914 | |
444 | 3915 CHECK_BUFFER (buffer); |
3916 b = XBUFFER (buffer); | |
428 | 3917 |
3918 if (!STRINGP (b->filename)) return Qt; | |
3919 if (b->modtime == 0) return Qt; | |
3920 | |
3921 /* If the file name has special constructs in it, | |
3922 call the corresponding file handler. */ | |
3923 handler = Ffind_file_name_handler (b->filename, | |
3924 Qverify_visited_file_modtime); | |
3925 if (!NILP (handler)) | |
444 | 3926 return call2 (handler, Qverify_visited_file_modtime, buffer); |
428 | 3927 |
771 | 3928 if (qxe_stat (XSTRING_DATA (b->filename), &st) < 0) |
428 | 3929 { |
3930 /* If the file doesn't exist now and didn't exist before, | |
3931 we say that it isn't modified, provided the error is a tame one. */ | |
3932 if (errno == ENOENT || errno == EACCES || errno == ENOTDIR) | |
3933 st.st_mtime = -1; | |
3934 else | |
3935 st.st_mtime = 0; | |
3936 } | |
3937 if (st.st_mtime == b->modtime | |
3938 /* If both are positive, accept them if they are off by one second. */ | |
3939 || (st.st_mtime > 0 && b->modtime > 0 | |
3940 && (st.st_mtime == b->modtime + 1 | |
3941 || st.st_mtime == b->modtime - 1))) | |
3942 return Qt; | |
3943 return Qnil; | |
3944 } | |
3945 | |
3946 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime, 0, 0, 0, /* | |
3947 Clear out records of last mod time of visited file. | |
3948 Next attempt to save will certainly not complain of a discrepancy. | |
3949 */ | |
3950 ()) | |
3951 { | |
3952 current_buffer->modtime = 0; | |
3953 return Qnil; | |
3954 } | |
3955 | |
3956 DEFUN ("visited-file-modtime", Fvisited_file_modtime, 0, 0, 0, /* | |
3957 Return the current buffer's recorded visited file modification time. | |
3958 The value is a list of the form (HIGH . LOW), like the time values | |
3959 that `file-attributes' returns. | |
3960 */ | |
3961 ()) | |
3962 { | |
3963 return time_to_lisp ((time_t) current_buffer->modtime); | |
3964 } | |
3965 | |
3966 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime, 0, 1, 0, /* | |
3967 Update buffer's recorded modification time from the visited file's time. | |
3968 Useful if the buffer was not read from the file normally | |
3969 or if the file itself has been changed for some known benign reason. | |
3970 An argument specifies the modification time value to use | |
3971 \(instead of that of the visited file), in the form of a list | |
3972 \(HIGH . LOW) or (HIGH LOW). | |
3973 */ | |
3974 (time_list)) | |
3975 { | |
3976 /* This function can call lisp */ | |
3977 if (!NILP (time_list)) | |
3978 { | |
3979 time_t the_time; | |
3980 lisp_to_time (time_list, &the_time); | |
3981 current_buffer->modtime = (int) the_time; | |
3982 } | |
3983 else | |
3984 { | |
446 | 3985 Lisp_Object filename = Qnil; |
428 | 3986 struct stat st; |
3987 Lisp_Object handler; | |
3988 struct gcpro gcpro1, gcpro2, gcpro3; | |
3989 | |
3990 GCPRO3 (filename, time_list, current_buffer->filename); | |
3991 filename = Fexpand_file_name (current_buffer->filename, Qnil); | |
3992 | |
3993 /* If the file name has special constructs in it, | |
3994 call the corresponding file handler. */ | |
3995 handler = Ffind_file_name_handler (filename, Qset_visited_file_modtime); | |
3996 UNGCPRO; | |
3997 if (!NILP (handler)) | |
3998 /* The handler can find the file name the same way we did. */ | |
3999 return call2 (handler, Qset_visited_file_modtime, Qnil); | |
771 | 4000 else if (qxe_stat (XSTRING_DATA (filename), &st) >= 0) |
428 | 4001 current_buffer->modtime = st.st_mtime; |
4002 } | |
4003 | |
4004 return Qnil; | |
4005 } | |
4006 | |
4007 static Lisp_Object | |
2286 | 4008 auto_save_error (Lisp_Object UNUSED (condition_object), |
4009 Lisp_Object UNUSED (ignored)) | |
428 | 4010 { |
4011 /* This function can call lisp */ | |
4012 if (gc_in_progress) | |
4013 return Qnil; | |
4014 /* Don't try printing an error message after everything is gone! */ | |
4015 if (preparing_for_armageddon) | |
4016 return Qnil; | |
4017 clear_echo_area (selected_frame (), Qauto_saving, 1); | |
4018 Fding (Qt, Qauto_save_error, Qnil); | |
4019 message ("Auto-saving...error for %s", XSTRING_DATA (current_buffer->name)); | |
4020 Fsleep_for (make_int (1)); | |
4021 message ("Auto-saving...error!for %s", XSTRING_DATA (current_buffer->name)); | |
4022 Fsleep_for (make_int (1)); | |
4023 message ("Auto-saving...error for %s", XSTRING_DATA (current_buffer->name)); | |
4024 Fsleep_for (make_int (1)); | |
4025 return Qnil; | |
4026 } | |
4027 | |
4028 static Lisp_Object | |
2286 | 4029 auto_save_1 (Lisp_Object UNUSED (ignored)) |
428 | 4030 { |
4031 /* This function can call lisp */ | |
4032 /* #### I think caller is protecting current_buffer? */ | |
4033 struct stat st; | |
4034 Lisp_Object fn = current_buffer->filename; | |
4035 Lisp_Object a = current_buffer->auto_save_file_name; | |
4036 | |
4037 if (!STRINGP (a)) | |
4038 return (Qnil); | |
4039 | |
4040 /* Get visited file's mode to become the auto save file's mode. */ | |
4041 if (STRINGP (fn) && | |
771 | 4042 qxe_stat (XSTRING_DATA (fn), &st) >= 0) |
428 | 4043 /* But make sure we can overwrite it later! */ |
4044 auto_save_mode_bits = st.st_mode | 0600; | |
4045 else | |
4046 /* default mode for auto-save files of buffers with no file is | |
4047 readable by owner only. This may annoy some small number of | |
4048 people, but the alternative removes all privacy from email. */ | |
4049 auto_save_mode_bits = 0600; | |
4050 | |
4051 return | |
4052 Fwrite_region_internal (Qnil, Qnil, a, Qnil, Qlambda, Qnil, | |
771 | 4053 #if 1 /* #### Kyle wants it changed to not use escape-quoted. Think |
4054 carefully about how this works. */ | |
4266 | 4055 Qescape_quoted, |
771 | 4056 #else |
4266 | 4057 current_buffer->buffer_file_coding_system, |
428 | 4058 #endif |
4266 | 4059 Qnil); |
428 | 4060 } |
4061 | |
4062 static Lisp_Object | |
2286 | 4063 auto_save_expand_name_error (Lisp_Object condition_object, |
4064 Lisp_Object UNUSED (ignored)) | |
428 | 4065 { |
771 | 4066 warn_when_safe_lispobj |
793 | 4067 (Qfile, Qerror, |
771 | 4068 Fcons (build_msg_string ("Invalid auto-save list-file"), |
4069 Fcons (Vauto_save_list_file_name, | |
4070 condition_object))); | |
428 | 4071 return Qnil; |
4072 } | |
4073 | |
4074 static Lisp_Object | |
4075 auto_save_expand_name (Lisp_Object name) | |
4076 { | |
4077 struct gcpro gcpro1; | |
4078 | |
4079 /* note that caller did NOT gc protect name, so we do it. */ | |
771 | 4080 /* [[dmoore - this might not be necessary, if condition_case_1 |
4081 protects it. but I don't think it does.]] indeed it doesn't. --ben */ | |
428 | 4082 GCPRO1 (name); |
4083 RETURN_UNGCPRO (Fexpand_file_name (name, Qnil)); | |
4084 } | |
4085 | |
4086 | |
4087 static Lisp_Object | |
4088 do_auto_save_unwind (Lisp_Object fd) | |
4089 { | |
771 | 4090 retry_close (XINT (fd)); |
428 | 4091 return (fd); |
4092 } | |
4093 | |
4094 /* Fdo_auto_save() checks whether a GC is in progress when it is called, | |
4095 and if so, tries to avoid touching lisp objects. | |
4096 | |
4097 The only time that Fdo_auto_save() is called while GC is in progress | |
2500 | 4098 is if we're going down, as a result of an ABORT() or a kill signal. |
428 | 4099 It's fairly important that we generate autosave files in that case! |
4100 */ | |
4101 | |
4102 DEFUN ("do-auto-save", Fdo_auto_save, 0, 2, "", /* | |
4103 Auto-save all buffers that need it. | |
4104 This is all buffers that have auto-saving enabled | |
4105 and are changed since last auto-saved. | |
4106 Auto-saving writes the buffer into a file | |
4107 so that your editing is not lost if the system crashes. | |
4108 This file is not the file you visited; that changes only when you save. | |
4109 Normally we run the normal hook `auto-save-hook' before saving. | |
4110 | |
4111 Non-nil first argument means do not print any message if successful. | |
4112 Non-nil second argument means save only current buffer. | |
4113 */ | |
4114 (no_message, current_only)) | |
4115 { | |
4116 /* This function can call lisp */ | |
4117 struct buffer *b; | |
4118 Lisp_Object tail, buf; | |
4119 int auto_saved = 0; | |
4120 int do_handled_files; | |
4121 Lisp_Object oquit = Qnil; | |
4122 Lisp_Object listfile = Qnil; | |
4123 Lisp_Object old; | |
4124 int listdesc = -1; | |
4125 int speccount = specpdl_depth (); | |
4126 struct gcpro gcpro1, gcpro2, gcpro3; | |
4127 | |
793 | 4128 old = wrap_buffer (current_buffer); |
428 | 4129 GCPRO3 (oquit, listfile, old); |
4130 check_quit (); /* make Vquit_flag accurate */ | |
4131 /* Ordinarily don't quit within this function, | |
4132 but don't make it impossible to quit (in case we get hung in I/O). */ | |
4133 oquit = Vquit_flag; | |
4134 Vquit_flag = Qnil; | |
4135 | |
4136 /* No further GCPRO needed, because (when it matters) all Lisp_Object | |
4137 variables point to non-strings reached from Vbuffer_alist. */ | |
4138 | |
4139 if (minibuf_level != 0 || preparing_for_armageddon) | |
4140 no_message = Qt; | |
4141 | |
4142 run_hook (Qauto_save_hook); | |
4143 | |
4144 if (STRINGP (Vauto_save_list_file_name)) | |
4145 listfile = condition_case_1 (Qt, | |
4146 auto_save_expand_name, | |
4147 Vauto_save_list_file_name, | |
4148 auto_save_expand_name_error, Qnil); | |
4149 | |
853 | 4150 internal_bind_int (&auto_saving, 1); |
428 | 4151 |
4152 /* First, save all files which don't have handlers. If Emacs is | |
4153 crashing, the handlers may tweak what is causing Emacs to crash | |
4154 in the first place, and it would be a shame if Emacs failed to | |
4155 autosave perfectly ordinary files because it couldn't handle some | |
4156 ange-ftp'd file. */ | |
4157 for (do_handled_files = 0; do_handled_files < 2; do_handled_files++) | |
4158 { | |
4159 for (tail = Vbuffer_alist; | |
4160 CONSP (tail); | |
4161 tail = XCDR (tail)) | |
4162 { | |
4163 buf = XCDR (XCAR (tail)); | |
4164 b = XBUFFER (buf); | |
4165 | |
4166 if (!NILP (current_only) | |
4167 && b != current_buffer) | |
4168 continue; | |
4169 | |
4170 /* Don't auto-save indirect buffers. | |
4171 The base buffer takes care of it. */ | |
4172 if (b->base_buffer) | |
4173 continue; | |
4174 | |
4175 /* Check for auto save enabled | |
4176 and file changed since last auto save | |
4177 and file changed since last real save. */ | |
4178 if (STRINGP (b->auto_save_file_name) | |
4179 && BUF_SAVE_MODIFF (b) < BUF_MODIFF (b) | |
4180 && b->auto_save_modified < BUF_MODIFF (b) | |
4181 /* -1 means we've turned off autosaving for a while--see below. */ | |
4182 && XINT (b->saved_size) >= 0 | |
4183 && (do_handled_files | |
4184 || NILP (Ffind_file_name_handler (b->auto_save_file_name, | |
4185 Qwrite_region)))) | |
4186 { | |
4187 EMACS_TIME before_time, after_time; | |
4188 | |
4189 EMACS_GET_TIME (before_time); | |
4190 /* If we had a failure, don't try again for 20 minutes. */ | |
4191 if (!preparing_for_armageddon | |
4192 && b->auto_save_failure_time >= 0 | |
4193 && (EMACS_SECS (before_time) - b->auto_save_failure_time < | |
4194 1200)) | |
4195 continue; | |
4196 | |
4197 if (!preparing_for_armageddon && | |
4198 (XINT (b->saved_size) * 10 | |
4199 > (BUF_Z (b) - BUF_BEG (b)) * 13) | |
4200 /* A short file is likely to change a large fraction; | |
4201 spare the user annoying messages. */ | |
4202 && XINT (b->saved_size) > 5000 | |
4203 /* These messages are frequent and annoying for `*mail*'. */ | |
4204 && !NILP (b->filename) | |
4205 && NILP (no_message) | |
4206 && disable_auto_save_when_buffer_shrinks) | |
4207 { | |
4208 /* It has shrunk too much; turn off auto-saving here. | |
4209 Unless we're about to crash, in which case auto-save it | |
4210 anyway. | |
4211 */ | |
4212 message | |
4213 ("Buffer %s has shrunk a lot; auto save turned off there", | |
4214 XSTRING_DATA (b->name)); | |
4215 /* Turn off auto-saving until there's a real save, | |
4216 and prevent any more warnings. */ | |
4217 b->saved_size = make_int (-1); | |
4218 if (!gc_in_progress) | |
4219 Fsleep_for (make_int (1)); | |
4220 continue; | |
4221 } | |
4222 set_buffer_internal (b); | |
4223 if (!auto_saved && NILP (no_message)) | |
4224 { | |
1333 | 4225 static const Ibyte *msg = (const Ibyte *) "Auto-saving..."; |
428 | 4226 echo_area_message (selected_frame (), msg, Qnil, |
1333 | 4227 0, qxestrlen (msg), |
428 | 4228 Qauto_saving); |
4229 } | |
4230 | |
4231 /* Open the auto-save list file, if necessary. | |
4232 We only do this now so that the file only exists | |
4233 if we actually auto-saved any files. */ | |
444 | 4234 if (!auto_saved && !inhibit_auto_save_session |
4235 && !NILP (Vauto_save_list_file_prefix) | |
4236 && STRINGP (listfile) && listdesc < 0) | |
428 | 4237 { |
771 | 4238 listdesc = |
4239 qxe_open (XSTRING_DATA (listfile), | |
4240 O_WRONLY | O_TRUNC | O_CREAT | OPEN_BINARY, | |
4241 CREAT_MODE); | |
428 | 4242 |
4243 /* Arrange to close that file whether or not we get | |
4244 an error. */ | |
4245 if (listdesc >= 0) | |
4246 record_unwind_protect (do_auto_save_unwind, | |
4247 make_int (listdesc)); | |
4248 } | |
4249 | |
4250 /* Record all the buffers that we are auto-saving in | |
4251 the special file that lists them. For each of | |
4252 these buffers, record visited name (if any) and | |
4253 auto save name. */ | |
4254 if (listdesc >= 0) | |
4255 { | |
442 | 4256 const Extbyte *auto_save_file_name_ext; |
665 | 4257 Bytecount auto_save_file_name_ext_len; |
428 | 4258 |
440 | 4259 TO_EXTERNAL_FORMAT (LISP_STRING, b->auto_save_file_name, |
4260 ALLOCA, (auto_save_file_name_ext, | |
4261 auto_save_file_name_ext_len), | |
771 | 4262 Qescape_quoted); |
428 | 4263 if (!NILP (b->filename)) |
4264 { | |
442 | 4265 const Extbyte *filename_ext; |
665 | 4266 Bytecount filename_ext_len; |
428 | 4267 |
440 | 4268 TO_EXTERNAL_FORMAT (LISP_STRING, b->filename, |
4269 ALLOCA, (filename_ext, | |
4270 filename_ext_len), | |
771 | 4271 Qescape_quoted); |
4272 retry_write (listdesc, filename_ext, filename_ext_len); | |
428 | 4273 } |
771 | 4274 retry_write (listdesc, "\n", 1); |
4275 retry_write (listdesc, auto_save_file_name_ext, | |
428 | 4276 auto_save_file_name_ext_len); |
771 | 4277 retry_write (listdesc, "\n", 1); |
428 | 4278 } |
4279 | |
4280 /* dmoore - In a bad scenario we've set b=XBUFFER(buf) | |
4281 based on values in Vbuffer_alist. auto_save_1 may | |
4282 cause lisp handlers to run. Those handlers may kill | |
4283 the buffer and then GC. Since the buffer is killed, | |
4284 it's no longer in Vbuffer_alist so it might get reaped | |
4285 by the GC. We also need to protect tail. */ | |
4286 /* #### There is probably a lot of other code which has | |
4287 pointers into buffers which may get blown away by | |
4288 handlers. */ | |
4289 { | |
4290 struct gcpro ngcpro1, ngcpro2; | |
4291 NGCPRO2 (buf, tail); | |
4292 condition_case_1 (Qt, | |
4293 auto_save_1, Qnil, | |
4294 auto_save_error, Qnil); | |
4295 NUNGCPRO; | |
4296 } | |
4297 /* Handler killed our saved current-buffer! Pick any. */ | |
4298 if (!BUFFER_LIVE_P (XBUFFER (old))) | |
793 | 4299 old = wrap_buffer (current_buffer); |
428 | 4300 |
4301 set_buffer_internal (XBUFFER (old)); | |
4302 auto_saved++; | |
4303 | |
4304 /* Handler killed their own buffer! */ | |
4305 if (!BUFFER_LIVE_P(b)) | |
4306 continue; | |
4307 | |
4308 b->auto_save_modified = BUF_MODIFF (b); | |
4309 b->saved_size = make_int (BUF_SIZE (b)); | |
4310 EMACS_GET_TIME (after_time); | |
4311 /* If auto-save took more than 60 seconds, | |
4312 assume it was an NFS failure that got a timeout. */ | |
4313 if (EMACS_SECS (after_time) - EMACS_SECS (before_time) > 60) | |
4314 b->auto_save_failure_time = EMACS_SECS (after_time); | |
4315 } | |
4316 } | |
4317 } | |
4318 | |
4319 /* Prevent another auto save till enough input events come in. */ | |
4320 if (auto_saved) | |
4321 record_auto_save (); | |
4322 | |
4323 /* If we didn't save anything into the listfile, remove the old | |
4324 one because nothing needed to be auto-saved. Do this afterwards | |
4325 rather than before in case we get a crash attempting to autosave | |
4326 (in that case we'd still want the old one around). */ | |
4327 if (listdesc < 0 && !auto_saved && STRINGP (listfile)) | |
771 | 4328 qxe_unlink (XSTRING_DATA (listfile)); |
428 | 4329 |
4330 /* Show "...done" only if the echo area would otherwise be empty. */ | |
4331 if (auto_saved && NILP (no_message) | |
4332 && NILP (clear_echo_area (selected_frame (), Qauto_saving, 0))) | |
4333 { | |
1333 | 4334 static const Ibyte *msg = (const Ibyte *)"Auto-saving...done"; |
428 | 4335 echo_area_message (selected_frame (), msg, Qnil, 0, |
1333 | 4336 qxestrlen (msg), Qauto_saving); |
428 | 4337 } |
4338 | |
4339 Vquit_flag = oquit; | |
4340 | |
771 | 4341 RETURN_UNGCPRO (unbind_to (speccount)); |
428 | 4342 } |
4343 | |
4344 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved, 0, 0, 0, /* | |
4345 Mark current buffer as auto-saved with its current text. | |
4346 No auto-save file will be written until the buffer changes again. | |
4347 */ | |
4348 ()) | |
4349 { | |
4350 current_buffer->auto_save_modified = BUF_MODIFF (current_buffer); | |
4351 current_buffer->saved_size = make_int (BUF_SIZE (current_buffer)); | |
4352 current_buffer->auto_save_failure_time = -1; | |
4353 return Qnil; | |
4354 } | |
4355 | |
4356 DEFUN ("clear-buffer-auto-save-failure", Fclear_buffer_auto_save_failure, 0, 0, 0, /* | |
4357 Clear any record of a recent auto-save failure in the current buffer. | |
4358 */ | |
4359 ()) | |
4360 { | |
4361 current_buffer->auto_save_failure_time = -1; | |
4362 return Qnil; | |
4363 } | |
4364 | |
4365 DEFUN ("recent-auto-save-p", Frecent_auto_save_p, 0, 0, 0, /* | |
4366 Return t if buffer has been auto-saved since last read in or saved. | |
4367 */ | |
4368 ()) | |
4369 { | |
4370 return (BUF_SAVE_MODIFF (current_buffer) < | |
4371 current_buffer->auto_save_modified) ? Qt : Qnil; | |
4372 } | |
4373 | |
4374 | |
4375 /************************************************************************/ | |
4376 /* initialization */ | |
4377 /************************************************************************/ | |
4378 | |
4379 void | |
4380 syms_of_fileio (void) | |
4381 { | |
563 | 4382 DEFSYMBOL (Qexpand_file_name); |
4383 DEFSYMBOL (Qfile_truename); | |
4384 DEFSYMBOL (Qsubstitute_in_file_name); | |
4385 DEFSYMBOL (Qdirectory_file_name); | |
4386 DEFSYMBOL (Qfile_name_directory); | |
4387 DEFSYMBOL (Qfile_name_nondirectory); | |
996 | 4388 DEFSYMBOL (Qfile_name_sans_extension); |
563 | 4389 DEFSYMBOL (Qunhandled_file_name_directory); |
4390 DEFSYMBOL (Qfile_name_as_directory); | |
4391 DEFSYMBOL (Qcopy_file); | |
4392 DEFSYMBOL (Qmake_directory_internal); | |
4393 DEFSYMBOL (Qdelete_directory); | |
4394 DEFSYMBOL (Qdelete_file); | |
4395 DEFSYMBOL (Qrename_file); | |
4396 DEFSYMBOL (Qadd_name_to_file); | |
4397 DEFSYMBOL (Qmake_symbolic_link); | |
844 | 4398 DEFSYMBOL (Qmake_temp_name); |
563 | 4399 DEFSYMBOL (Qfile_exists_p); |
4400 DEFSYMBOL (Qfile_executable_p); | |
4401 DEFSYMBOL (Qfile_readable_p); | |
4402 DEFSYMBOL (Qfile_symlink_p); | |
4403 DEFSYMBOL (Qfile_writable_p); | |
4404 DEFSYMBOL (Qfile_directory_p); | |
4405 DEFSYMBOL (Qfile_regular_p); | |
4406 DEFSYMBOL (Qfile_accessible_directory_p); | |
4407 DEFSYMBOL (Qfile_modes); | |
4408 DEFSYMBOL (Qset_file_modes); | |
4409 DEFSYMBOL (Qfile_newer_than_file_p); | |
4410 DEFSYMBOL (Qinsert_file_contents); | |
4411 DEFSYMBOL (Qwrite_region); | |
4412 DEFSYMBOL (Qverify_visited_file_modtime); | |
4413 DEFSYMBOL (Qset_visited_file_modtime); | |
4414 DEFSYMBOL (Qcar_less_than_car); /* Vomitous! */ | |
4266 | 4415 DEFSYMBOL (Qexcl); |
563 | 4416 |
4417 DEFSYMBOL (Qauto_save_hook); | |
4418 DEFSYMBOL (Qauto_save_error); | |
4419 DEFSYMBOL (Qauto_saving); | |
4420 | |
4421 DEFSYMBOL (Qformat_decode); | |
4422 DEFSYMBOL (Qformat_annotate_function); | |
4423 | |
4424 DEFSYMBOL (Qcompute_buffer_file_truename); | |
4425 | |
442 | 4426 DEFERROR_STANDARD (Qfile_already_exists, Qfile_error); |
428 | 4427 |
4428 DEFSUBR (Ffind_file_name_handler); | |
4429 | |
4430 DEFSUBR (Ffile_name_directory); | |
4431 DEFSUBR (Ffile_name_nondirectory); | |
4432 DEFSUBR (Funhandled_file_name_directory); | |
4433 DEFSUBR (Ffile_name_as_directory); | |
4434 DEFSUBR (Fdirectory_file_name); | |
4435 DEFSUBR (Fmake_temp_name); | |
4436 DEFSUBR (Fexpand_file_name); | |
4437 DEFSUBR (Ffile_truename); | |
4438 DEFSUBR (Fsubstitute_in_file_name); | |
4439 DEFSUBR (Fcopy_file); | |
4440 DEFSUBR (Fmake_directory_internal); | |
4441 DEFSUBR (Fdelete_directory); | |
4442 DEFSUBR (Fdelete_file); | |
4443 DEFSUBR (Frename_file); | |
4444 DEFSUBR (Fadd_name_to_file); | |
4445 DEFSUBR (Fmake_symbolic_link); | |
4446 #ifdef HPUX_NET | |
4447 DEFSUBR (Fsysnetunam); | |
4448 #endif /* HPUX_NET */ | |
4449 DEFSUBR (Ffile_name_absolute_p); | |
4450 DEFSUBR (Ffile_exists_p); | |
4451 DEFSUBR (Ffile_executable_p); | |
4452 DEFSUBR (Ffile_readable_p); | |
4453 DEFSUBR (Ffile_writable_p); | |
4454 DEFSUBR (Ffile_symlink_p); | |
4455 DEFSUBR (Ffile_directory_p); | |
4456 DEFSUBR (Ffile_accessible_directory_p); | |
4457 DEFSUBR (Ffile_regular_p); | |
4458 DEFSUBR (Ffile_modes); | |
4459 DEFSUBR (Fset_file_modes); | |
4460 DEFSUBR (Fset_default_file_modes); | |
4461 DEFSUBR (Fdefault_file_modes); | |
4462 DEFSUBR (Funix_sync); | |
4463 DEFSUBR (Ffile_newer_than_file_p); | |
4464 DEFSUBR (Finsert_file_contents_internal); | |
4465 DEFSUBR (Fwrite_region_internal); | |
4466 DEFSUBR (Fcar_less_than_car); /* Vomitous! */ | |
4467 DEFSUBR (Fcdr_less_than_cdr); /* Yeah oh yeah bucko .... */ | |
4468 #if 0 | |
4469 DEFSUBR (Fencrypt_string); | |
4470 DEFSUBR (Fdecrypt_string); | |
4471 #endif | |
4472 DEFSUBR (Fverify_visited_file_modtime); | |
4473 DEFSUBR (Fclear_visited_file_modtime); | |
4474 DEFSUBR (Fvisited_file_modtime); | |
4475 DEFSUBR (Fset_visited_file_modtime); | |
4476 | |
4477 DEFSUBR (Fdo_auto_save); | |
4478 DEFSUBR (Fset_buffer_auto_saved); | |
4479 DEFSUBR (Fclear_buffer_auto_save_failure); | |
4480 DEFSUBR (Frecent_auto_save_p); | |
4481 } | |
4482 | |
4483 void | |
4484 vars_of_fileio (void) | |
4485 { | |
2526 | 4486 QSin_expand_file_name = |
4487 build_msg_string ("(in expand-file-name)"); | |
4488 staticpro (&QSin_expand_file_name); | |
4489 | |
428 | 4490 DEFVAR_LISP ("auto-save-file-format", &Vauto_save_file_format /* |
4491 *Format in which to write auto-save files. | |
4492 Should be a list of symbols naming formats that are defined in `format-alist'. | |
4493 If it is t, which is the default, auto-save files are written in the | |
4494 same format as a regular save would use. | |
4495 */ ); | |
4496 Vauto_save_file_format = Qt; | |
4497 | |
4498 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist /* | |
4499 *Alist of elements (REGEXP . HANDLER) for file names handled specially. | |
4500 If a file name matches REGEXP, then all I/O on that file is done by calling | |
4501 HANDLER. | |
4502 | |
4503 The first argument given to HANDLER is the name of the I/O primitive | |
4504 to be handled; the remaining arguments are the arguments that were | |
4505 passed to that primitive. For example, if you do | |
4506 (file-exists-p FILENAME) | |
4507 and FILENAME is handled by HANDLER, then HANDLER is called like this: | |
4508 (funcall HANDLER 'file-exists-p FILENAME) | |
4509 The function `find-file-name-handler' checks this list for a handler | |
4510 for its argument. | |
4511 */ ); | |
4512 Vfile_name_handler_alist = Qnil; | |
4513 | |
4514 DEFVAR_LISP ("after-insert-file-functions", &Vafter_insert_file_functions /* | |
4515 A list of functions to be called at the end of `insert-file-contents'. | |
4516 Each is passed one argument, the number of bytes inserted. It should return | |
4517 the new byte count, and leave point the same. If `insert-file-contents' is | |
4518 intercepted by a handler from `file-name-handler-alist', that handler is | |
4519 responsible for calling the after-insert-file-functions if appropriate. | |
4520 */ ); | |
4521 Vafter_insert_file_functions = Qnil; | |
4522 | |
4523 DEFVAR_LISP ("write-region-annotate-functions", | |
4524 &Vwrite_region_annotate_functions /* | |
4525 A list of functions to be called at the start of `write-region'. | |
4526 Each is passed two arguments, START and END, as for `write-region'. | |
4527 It should return a list of pairs (POSITION . STRING) of strings to be | |
4528 effectively inserted at the specified positions of the file being written | |
4529 \(1 means to insert before the first byte written). The POSITIONs must be | |
4530 sorted into increasing order. If there are several functions in the list, | |
4531 the several lists are merged destructively. | |
4532 */ ); | |
4533 Vwrite_region_annotate_functions = Qnil; | |
4534 | |
4535 DEFVAR_LISP ("write-region-annotations-so-far", | |
4536 &Vwrite_region_annotations_so_far /* | |
4537 When an annotation function is called, this holds the previous annotations. | |
4538 These are the annotations made by other annotation functions | |
4539 that were already called. See also `write-region-annotate-functions'. | |
4540 */ ); | |
4541 Vwrite_region_annotations_so_far = Qnil; | |
4542 | |
4543 DEFVAR_LISP ("inhibit-file-name-handlers", &Vinhibit_file_name_handlers /* | |
4544 A list of file name handlers that temporarily should not be used. | |
4545 This applies only to the operation `inhibit-file-name-operation'. | |
4546 */ ); | |
4547 Vinhibit_file_name_handlers = Qnil; | |
4548 | |
4549 DEFVAR_LISP ("inhibit-file-name-operation", &Vinhibit_file_name_operation /* | |
4550 The operation for which `inhibit-file-name-handlers' is applicable. | |
4551 */ ); | |
4552 Vinhibit_file_name_operation = Qnil; | |
4553 | |
4554 DEFVAR_LISP ("auto-save-list-file-name", &Vauto_save_list_file_name /* | |
4555 File name in which we write a list of all auto save file names. | |
4556 */ ); | |
4557 Vauto_save_list_file_name = Qnil; | |
4558 | |
444 | 4559 DEFVAR_LISP ("auto-save-list-file-prefix", &Vauto_save_list_file_prefix /* |
4560 Prefix for generating auto-save-list-file-name. | |
4561 Emacs's pid and the system name will be appended to | |
4562 this prefix to create a unique file name. | |
4563 */ ); | |
4564 Vauto_save_list_file_prefix = build_string ("~/.saves-"); | |
4565 | |
4566 DEFVAR_BOOL ("inhibit-auto-save-session", &inhibit_auto_save_session /* | |
4567 When non-nil, inhibit auto save list file creation. | |
4568 */ ); | |
4569 inhibit_auto_save_session = 0; | |
4570 | |
428 | 4571 DEFVAR_BOOL ("disable-auto-save-when-buffer-shrinks", |
4572 &disable_auto_save_when_buffer_shrinks /* | |
4573 If non-nil, auto-saving is disabled when a buffer shrinks too much. | |
4574 This is to prevent you from losing your edits if you accidentally | |
4575 delete a large chunk of the buffer and don't notice it until too late. | |
4576 Saving the buffer normally turns auto-save back on. | |
4577 */ ); | |
4578 disable_auto_save_when_buffer_shrinks = 1; | |
4579 | |
4580 DEFVAR_LISP ("directory-sep-char", &Vdirectory_sep_char /* | |
4581 Directory separator character for built-in functions that return file names. | |
4582 The value should be either ?/ or ?\\ (any other value is treated as ?\\). | |
4583 This variable affects the built-in functions only on Windows, | |
4584 on other platforms, it is initialized so that Lisp code can find out | |
4585 what the normal separator is. | |
4586 */ ); | |
771 | 4587 Vdirectory_sep_char = make_char (DEFAULT_DIRECTORY_SEP); |
428 | 4588 } |
442 | 4589 |
4590 void | |
4591 reinit_vars_of_fileio (void) | |
4592 { | |
4593 /* We want temp_name_rand to be initialized to a value likely to be | |
4594 unique to the process, not to the executable. The danger is that | |
4595 two different XEmacs processes using the same binary on different | |
4596 machines creating temp files in the same directory will be | |
4597 unlucky enough to have the same pid. If we randomize using | |
4598 process startup time, then in practice they will be unlikely to | |
4599 collide. We use the microseconds field so that scripts that start | |
4600 simultaneous XEmacs processes on multiple machines will have less | |
4601 chance of collision. */ | |
4602 { | |
4603 EMACS_TIME thyme; | |
4604 | |
4605 EMACS_GET_TIME (thyme); | |
4606 temp_name_rand = (unsigned int) (EMACS_SECS (thyme) ^ EMACS_USECS (thyme)); | |
4607 } | |
4608 } |