cgit.sxemacs.org Git - sxemacs/blob - src/fileio.c

   1 /* File IO for SXEmacs.
   2    Copyright (C) 1985-1988, 1992-1995 Free Software Foundation, Inc.
   3    Copyright (C) 1996 Ben Wing.
   4
   5 This file is part of SXEmacs
   6
   7 SXEmacs is free software: you can redistribute it and/or modify
   8 it under the terms of the GNU General Public License as published by
   9 the Free Software Foundation, either version 3 of the License, or
  10 (at your option) any later version.
  11
  12 SXEmacs is distributed in the hope that it will be useful,
  13 but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 GNU General Public License for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with this program.  If not, see <http://www.gnu.org/licenses/>. */
  19
  20
  21 /* Synched up with: Mule 2.0, FSF 19.30. */
  22 /* More syncing: FSF Emacs 19.34.6 by Marc Paquette <marcpa@cam.org> */
  23
  24 #include <config.h>
  25 #include "lisp.h"
  26
  27 #include "buffer.h"
  28 #include "events/events.h"
  29 #include "ui/frame.h"
  30 #include "ui/insdel.h"
  31 #include "lstream.h"
  32 #include "ui/redisplay.h"
  33 #include "sysdep.h"
  34 #include "ui/window.h"          /* minibuf_level */
  35 #ifdef FILE_CODING
  36 #include "mule/file-coding.h"
  37 #endif
  38
  39 #ifdef HAVE_LIBGEN_H            /* Must come before sysfile.h */
  40 #include <libgen.h>
  41 #endif
  42 #include "sysfile.h"
  43 #include "sysproc.h"
  44 #include "syspwd.h"
  45 #include "systime.h"
  46 #include "sysdir.h"
  47
  48 #ifdef HPUX
  49 #include <netio.h>
  50 #ifdef HPUX_PRE_8_0
  51 #include <errnet.h>
  52 #endif                          /* HPUX_PRE_8_0 */
  53 #endif                          /* HPUX */
  54
  55 int lisp_to_time(Lisp_Object, time_t *);
  56 Lisp_Object time_to_lisp(time_t);
  57
  58 /* Nonzero during writing of auto-save files */
  59 static int auto_saving;
  60
  61 /* Set by auto_save_1 to mode of original file so Fwrite_region_internal
  62    will create a new file with the same mode as the original */
  63 static int auto_save_mode_bits;
  64
  65 /* Alist of elements (REGEXP . HANDLER) for file names
  66    whose I/O is done with a special handler.  */
  67 Lisp_Object Vfile_name_handler_alist;
  68
  69 /* Format for auto-save files */
  70 Lisp_Object Vauto_save_file_format;
  71
  72 /* Lisp functions for translating file formats */
  73 Lisp_Object Qformat_decode, Qformat_annotate_function;
  74
  75 /* Functions to be called to process text properties in inserted file.  */
  76 Lisp_Object Vafter_insert_file_functions;
  77
  78 /* Functions to be called to create text property annotations for file.  */
  79 Lisp_Object Vwrite_region_annotate_functions;
  80
  81 /* During build_annotations, each time an annotation function is called,
  82    this holds the annotations made by the previous functions.  */
  83 Lisp_Object Vwrite_region_annotations_so_far;
  84
  85 /* File name in which we write a list of all our auto save files.  */
  86 Lisp_Object Vauto_save_list_file_name;
  87
  88 /* Prefix used to construct Vauto_save_list_file_name. */
  89 Lisp_Object Vauto_save_list_file_prefix;
  90
  91 /* When non-nil, it prevents auto-save list file creation. */
  92 int inhibit_auto_save_session;
  93
  94 int disable_auto_save_when_buffer_shrinks;
  95
  96 Lisp_Object Vdirectory_sep_char;
  97
  98 /* These variables describe handlers that have "already" had a chance
  99    to handle the current operation.
 100
 101    Vinhibit_file_name_handlers is a list of file name handlers.
 102    Vinhibit_file_name_operation is the operation being handled.
 103    If we try to handle that operation, we ignore those handlers.  */
 104
 105 static Lisp_Object Vinhibit_file_name_handlers;
 106 static Lisp_Object Vinhibit_file_name_operation;
 107
 108 Lisp_Object Qfile_error, Qfile_already_exists;
 109
 110 Lisp_Object Qauto_save_hook;
 111 Lisp_Object Qauto_save_error;
 112 Lisp_Object Qauto_saving;
 113
 114 Lisp_Object Qcar_less_than_car;
 115
 116 Lisp_Object Qcompute_buffer_file_truename;
 117
 118 EXFUN(Frunning_temacs_p, 0);
 119
 120 /* signal a file error when errno contains a meaningful value. */
 121
 122 DOESNT_RETURN report_file_error(const char *string, Lisp_Object data)
 123 {
 124         /* #### dmoore - This uses current_buffer, better make sure no one
 125            has GC'd the current buffer.  File handlers are giving me a headache
 126            maybe I'll just always protect current_buffer around all of those
 127            calls. */
 128
 129         signal_error(Qfile_error,
 130                      Fcons(build_translated_string(string),
 131                            Fcons(lisp_strerror(errno), data)));
 132 }
 133
 134 void
 135 maybe_report_file_error(const char *string, Lisp_Object data,
 136                         Lisp_Object class, Error_behavior errb)
 137 {
 138         /* Optimization: */
 139         if (ERRB_EQ(errb, ERROR_ME_NOT))
 140                 return;
 141
 142         maybe_signal_error(Qfile_error,
 143                            Fcons(build_translated_string(string),
 144                                  Fcons(lisp_strerror(errno), data)),
 145                            class, errb);
 146 }
 147
 148 /* signal a file error when errno does not contain a meaningful value. */
 149
 150 DOESNT_RETURN signal_file_error(const char *string, Lisp_Object data)
 151 {
 152         signal_error(Qfile_error, list2(build_translated_string(string), data));
 153 }
 154
 155 void
 156 maybe_signal_file_error(const char *string, Lisp_Object data,
 157                         Lisp_Object class, Error_behavior errb)
 158 {
 159         /* Optimization: */
 160         if (ERRB_EQ(errb, ERROR_ME_NOT))
 161                 return;
 162         maybe_signal_error(Qfile_error,
 163                            list2(build_translated_string(string), data),
 164                            class, errb);
 165 }
 166
 167 DOESNT_RETURN
 168 signal_double_file_error(const char *string1, const char *string2,
 169                          Lisp_Object data)
 170 {
 171         signal_error(Qfile_error,
 172                      list3(build_translated_string(string1),
 173                            build_translated_string(string2), data));
 174 }
 175
 176 void
 177 maybe_signal_double_file_error(const char *string1, const char *string2,
 178                                Lisp_Object data, Lisp_Object class,
 179                                Error_behavior errb)
 180 {
 181         /* Optimization: */
 182         if (ERRB_EQ(errb, ERROR_ME_NOT))
 183                 return;
 184         maybe_signal_error(Qfile_error,
 185                            list3(build_translated_string(string1),
 186                                  build_translated_string(string2),
 187                                  data), class, errb);
 188 }
 189
 190 DOESNT_RETURN
 191 signal_double_file_error_2(const char *string1, const char *string2,
 192                            Lisp_Object data1, Lisp_Object data2)
 193 {
 194         signal_error(Qfile_error,
 195                      list4(build_translated_string(string1),
 196                            build_translated_string(string2), data1, data2));
 197 }
 198
 199 void
 200 maybe_signal_double_file_error_2(const char *string1, const char *string2,
 201                                  Lisp_Object data1, Lisp_Object data2,
 202                                  Lisp_Object class, Error_behavior errb)
 203 {
 204         /* Optimization: */
 205         if (ERRB_EQ(errb, ERROR_ME_NOT))
 206                 return;
 207         maybe_signal_error(Qfile_error,
 208                            list4(build_translated_string(string1),
 209                                  build_translated_string(string2),
 210                                  data1, data2), class, errb);
 211 }
 212 \f
 213 /* Just like strerror(3), except return a lisp string instead of char *.
 214    The string needs to be converted since it may be localized.
 215    Perhaps this should use strerror-coding-system instead? */
 216 Lisp_Object lisp_strerror(int errnum)
 217 {
 218         return build_ext_string(strerror(errnum), Qnative);
 219 }
 220
 221 static Lisp_Object close_file_unwind(Lisp_Object fd)
 222 {
 223         if (CONSP(fd)) {
 224                 if (INTP(XCAR(fd)))
 225                         close(XINT(XCAR(fd)));
 226
 227                 free_cons(XCONS(fd));
 228         } else
 229                 close(XINT(fd));
 230
 231         return Qnil;
 232 }
 233
 234 static Lisp_Object delete_stream_unwind(Lisp_Object stream)
 235 {
 236         Lstream_delete(XLSTREAM(stream));
 237         return Qnil;
 238 }
 239
 240 /* Restore point, having saved it as a marker.  */
 241
 242 static Lisp_Object restore_point_unwind(Lisp_Object point_marker)
 243 {
 244         BUF_SET_PT(current_buffer, marker_position(point_marker));
 245         return Fset_marker(point_marker, Qnil, Qnil);
 246 }
 247
 248 /* Versions of read() and write() that allow quitting out of the actual
 249    I/O.  We don't use immediate_quit (i.e. direct longjmp() out of the
 250    signal handler) because that's way too losing.
 251
 252    (#### Actually, longjmp()ing out of the signal handler may not be
 253    as losing as I thought.  See sys_do_signal() in sysdep.c.) */
 254
 255 ssize_t read_allowing_quit(int fildes, void *buf, size_t size)
 256 {
 257         QUIT;
 258         return sys_read_1(fildes, buf, size, 1);
 259 }
 260
 261 ssize_t write_allowing_quit(int fildes, const void *buf, size_t size)
 262 {
 263         QUIT;
 264         return sys_write_1(fildes, buf, size, 1);
 265 }
 266 \f
 267 Lisp_Object Qexpand_file_name;
 268 Lisp_Object Qfile_truename;
 269 Lisp_Object Qsubstitute_in_file_name;
 270 Lisp_Object Qdirectory_file_name;
 271 Lisp_Object Qfile_dirname;
 272 Lisp_Object Qfile_basename;
 273 Lisp_Object Qfile_name_directory;
 274 Lisp_Object Qfile_name_nondirectory;
 275 Lisp_Object Qunhandled_file_name_directory;
 276 Lisp_Object Qfile_name_as_directory;
 277 Lisp_Object Qcopy_file;
 278 Lisp_Object Qmake_directory_internal;
 279 Lisp_Object Qdelete_directory;
 280 Lisp_Object Qdelete_file;
 281 Lisp_Object Qrename_file;
 282 Lisp_Object Qadd_name_to_file;
 283 Lisp_Object Qmake_symbolic_link;
 284 Lisp_Object Qfile_exists_p;
 285 Lisp_Object Qfile_executable_p;
 286 Lisp_Object Qfile_readable_p;
 287 Lisp_Object Qfile_symlink_p;
 288 Lisp_Object Qfile_writable_p;
 289 Lisp_Object Qfile_directory_p;
 290 Lisp_Object Qfile_regular_p;
 291 Lisp_Object Qfile_accessible_directory_p;
 292 Lisp_Object Qfile_modes;
 293 Lisp_Object Qset_file_modes;
 294 Lisp_Object Qfile_newer_than_file_p;
 295 Lisp_Object Qinsert_file_contents;
 296 Lisp_Object Qwrite_region;
 297 Lisp_Object Qverify_visited_file_modtime;
 298 Lisp_Object Qset_visited_file_modtime;
 299
 300 /* If FILENAME is handled specially on account of its syntax,
 301    return its handler function.  Otherwise, return nil.  */
 302
 303 DEFUN("find-file-name-handler", Ffind_file_name_handler, 1, 2, 0,       /*
 304 Return FILENAME's handler function for OPERATION, if it has one.
 305 Otherwise, return nil.
 306 A file name is handled if one of the regular expressions in
 307 `file-name-handler-alist' matches it.
 308
 309 If OPERATION equals `inhibit-file-name-operation', then we ignore
 310 any handlers that are members of `inhibit-file-name-handlers',
 311 but we still do run any other handlers.  This lets handlers
 312 use the standard functions without calling themselves recursively.
 313
 314 Otherwise, OPERATION is the name of a funcall'able function.
 315 */
 316       (filename, operation))
 317 {
 318         /* This function does not GC */
 319         /* This function can be called during GC */
 320         /* This function must not munge the match data.  */
 321         Lisp_Object chain, inhibited_handlers;
 322
 323         CHECK_STRING(filename);
 324
 325         if (EQ(operation, Vinhibit_file_name_operation))
 326                 inhibited_handlers = Vinhibit_file_name_handlers;
 327         else
 328                 inhibited_handlers = Qnil;
 329
 330         EXTERNAL_LIST_LOOP(chain, Vfile_name_handler_alist) {
 331                 Lisp_Object elt = XCAR(chain);
 332                 if (CONSP(elt)) {
 333                         Lisp_Object string = XCAR(elt);
 334                         if (STRINGP(string)
 335                             && (fast_lisp_string_match(string, filename) >= 0)) {
 336                                 Lisp_Object handler = XCDR(elt);
 337                                 if (NILP(Fmemq(handler, inhibited_handlers)))
 338                                         return handler;
 339                         }
 340                 }
 341                 QUIT;
 342         }
 343         return Qnil;
 344 }
 345
 346 static Lisp_Object
 347 call2_check_string(Lisp_Object fn, Lisp_Object arg0, Lisp_Object arg1)
 348 {
 349         /* This function can call lisp */
 350         Lisp_Object result = call2(fn, arg0, arg1);
 351         CHECK_STRING(result);
 352         return result;
 353 }
 354
 355 static Lisp_Object
 356 call2_check_string_or_nil(Lisp_Object fn, Lisp_Object arg0, Lisp_Object arg1)
 357 {
 358         /* This function can call lisp */
 359         Lisp_Object result = call2(fn, arg0, arg1);
 360         if (!NILP(result))
 361                 CHECK_STRING(result);
 362         return result;
 363 }
 364
 365 static Lisp_Object
 366 call3_check_string(Lisp_Object fn, Lisp_Object arg0,
 367                    Lisp_Object arg1, Lisp_Object arg2)
 368 {
 369         /* This function can call lisp */
 370         Lisp_Object result = call3(fn, arg0, arg1, arg2);
 371         CHECK_STRING(result);
 372         return result;
 373 }
 374 \f
 375 DEFUN("file-name-directory", Ffile_name_directory, 1, 1, 0,     /*
 376 Return the directory component in file name FILENAME.
 377 Return nil if FILENAME does not include a directory.
 378 Otherwise return a directory spec.
 379 Given a Unix syntax file name, returns a string ending in slash.
 380 */
 381       (filename))
 382 {
 383         /* This function can GC.  GC checked 2000-07-28 ben */
 384         Bufbyte *beg;
 385         Bufbyte *p;
 386         Lisp_Object handler;
 387
 388         CHECK_STRING(filename);
 389
 390         /* If the file name has special constructs in it,
 391            call the corresponding file handler.  */
 392         handler = Ffind_file_name_handler(filename, Qfile_name_directory);
 393         if (!NILP(handler))
 394                 return call2_check_string_or_nil(handler, Qfile_name_directory,
 395                                                  filename);
 396
 397 #ifdef FILE_SYSTEM_CASE
 398         filename = FILE_SYSTEM_CASE(filename);
 399 #endif
 400         beg = XSTRING_DATA(filename);
 401         p = beg + XSTRING_LENGTH(filename);
 402
 403         while (p != beg && !IS_ANY_SEP(p[-1])
 404             )
 405                 p--;
 406
 407         if (p == beg)
 408                 return Qnil;
 409         return make_string(beg, p - beg);
 410 }
 411
 412 DEFUN("file-name-nondirectory", Ffile_name_nondirectory, 1, 1, 0,       /*
 413 Return file name FILENAME sans its directory.
 414 For example, in a Unix-syntax file name,
 415 this is everything after the last slash,
 416 or the entire name if it contains no slash.
 417 */
 418       (filename))
 419 {
 420         /* This function can GC.  GC checked 2000-07-28 ben */
 421         Bufbyte *beg, *p, *end;
 422         Lisp_Object handler;
 423
 424         CHECK_STRING(filename);
 425
 426         /* If the file name has special constructs in it,
 427            call the corresponding file handler.  */
 428         handler = Ffind_file_name_handler(filename, Qfile_name_nondirectory);
 429         if (!NILP(handler))
 430                 return call2_check_string(handler, Qfile_name_nondirectory,
 431                                           filename);
 432
 433         beg = XSTRING_DATA(filename);
 434         end = p = beg + XSTRING_LENGTH(filename);
 435
 436         while (p != beg && !IS_ANY_SEP(p[-1])
 437             )
 438                 p--;
 439
 440         return make_string(p, end - p);
 441 }
 442
 443
 444 static
 445 Bytecount file_basename_match_extension(Lisp_Object filename,
 446                                         Lisp_Object extension)
 447 {
 448         Bytecount match = -1;
 449         Bytecount len = XSTRING_LENGTH( extension );
 450         if ( len > 0 ) {
 451                 char     re[len+6],
 452                         *rep = re;
 453                 Bufbyte *ext = XSTRING_DATA(extension);
 454                 Lisp_Object regexp;
 455
 456                 memset(re,0,len+6);
 457                 if ( strncmp( (char*)ext, "\\.", 2 ) != 0 ) {
 458                         strncpy(rep, "\\.", 3);
 459                         rep += 2;
 460                 }
 461                 memcpy(rep,ext,len);
 462                 /* Note that we advance by len-1 to be positioned at
 463                    the last char of extension so that we can check it
 464                    for '$' on the if statement and advance to the
 465                    terminator if need to append...
 466                 */
 467                 rep += len-1;
 468                 if ( *rep++ != '$' )
 469                         *rep++ = '$';
 470                 *rep = '\0';
 471                 regexp = make_string( (Bufbyte*)re, strlen(re));
 472                 match = fast_lisp_string_match( regexp, filename );
 473         }
 474         return match;
 475 }
 476
 477 DEFUN("file-basename", Ffile_basename, 1, 2, 0, /*
 478 Return the basename of FILENAME sans its base directory.
 479 If EXTENSION is non-nil the extension is also removed if it matches the regexp.
 480 EXTENSION can be a list of regexps.
 481 For example, in a Unix-syntax file name,
 482 this is everything after the last slash,
 483 or the entire name if it contains no slash.
 484 It ignores trailing slash.
 485 */
 486       (filename, extension))
 487 {
 488         /* This function can GC.  GC checked 2000-07-28 ben */
 489         Bufbyte *beg, *p, *end;
 490         Lisp_Object handler;
 491         Lisp_Object rest;
 492         Lisp_Object ext;
 493         Lisp_Object res;
 494         struct gcpro gcpro1, gcpro2, gcpro3, gcpro4;
 495
 496         CHECK_STRING(filename);
 497         if ( ! NILP(extension) && ! STRINGP(extension) &&
 498              ! LISTP(extension) )
 499                 dead_wrong_type_argument(Qstringp, extension);
 500
 501         GCPRO4(handler,res,rest,ext);
 502
 503         /* If the file name has special constructs in it,
 504            call the corresponding file handler.  */
 505         handler = Ffind_file_name_handler(filename, Qfile_basename);
 506         if (!NILP(handler))
 507                 return call2_check_string(handler, Qfile_basename,
 508                                           filename);
 509
 510         beg = XSTRING_DATA(filename);
 511         end = p = beg + XSTRING_LENGTH(filename);
 512         if ( IS_ANY_SEP(p[-1]) ) {
 513           p--;
 514           end--;
 515         }
 516         while (p != beg && !IS_ANY_SEP(p[-1]))
 517