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