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