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