1: /* File IO for GNU Emacs.
    2:    Copyright (C) 1985, 1986, 1987, 1988, 1993, 1994, 1995, 1996,
    3:                  1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
    4:                  2005, 2006, 2007 Free Software Foundation, Inc.
    5: 
    6: This file is part of GNU Emacs.
    7: 
    8: GNU Emacs is free software; you can redistribute it and/or modify
    9: it under the terms of the GNU General Public License as published by
   10: the Free Software Foundation; either version 2, or (at your option)
   11: any later version.
   12: 
   13: GNU Emacs is distributed in the hope that it will be useful,
   14: but WITHOUT ANY WARRANTY; without even the implied warranty of
   15: MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   16: GNU General Public License for more details.
   17: 
   18: You should have received a copy of the GNU General Public License
   19: along with GNU Emacs; see the file COPYING.  If not, write to
   20: the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
   21: Boston, MA 02110-1301, USA.  */
   22: 
   23: #include <config.h>
   24: 
   25: #ifdef HAVE_FCNTL_H
   26: #include <fcntl.h>
   27: #endif
   28: 
   29: #include <stdio.h>
   30: #include <sys/types.h>
   31: #include <sys/stat.h>
   32: 
   33: #ifdef HAVE_UNISTD_H
   34: #include <unistd.h>
   35: #endif
   36: 
   37: #if !defined (S_ISLNK) && defined (S_IFLNK)
   38: #  define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
   39: #endif
   40: 
   41: #if !defined (S_ISFIFO) && defined (S_IFIFO)
   42: #  define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO)
   43: #endif
   44: 
   45: #if !defined (S_ISREG) && defined (S_IFREG)
   46: #  define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
   47: #endif
   48: 
   49: #ifdef HAVE_PWD_H
   50: #include <pwd.h>
   51: #endif
   52: 
   53: #include <ctype.h>
   54: 
   55: #ifdef VMS
   56: #include "vmsdir.h"
   57: #include <perror.h>
   58: #include <stddef.h>
   59: #include <string.h>
   60: #endif
   61: 
   62: #include <errno.h>
   63: 
   64: #ifndef vax11c
   65: #ifndef USE_CRT_DLL
   66: extern int errno;
   67: #endif
   68: #endif
   69: 
   70: #ifdef APOLLO
   71: #include <sys/time.h>
   72: #endif
   73: 
   74: #include "lisp.h"
   75: #include "intervals.h"
   76: #include "buffer.h"
   77: #include "charset.h"
   78: #include "coding.h"
   79: #include "window.h"
   80: #include "blockinput.h"
   81: 
   82: #ifdef WINDOWSNT
   83: #define NOMINMAX 1
   84: #include <windows.h>
   85: #include <stdlib.h>
   86: #include <fcntl.h>
   87: #endif /* not WINDOWSNT */
   88: 
   89: #ifdef MSDOS
   90: #include "msdos.h"
   91: #include <sys/param.h>
   92: #if __DJGPP__ >= 2
   93: #include <fcntl.h>
   94: #include <string.h>
   95: #endif
   96: #endif
   97: 
   98: #ifdef DOS_NT
   99: #define CORRECT_DIR_SEPS(s) \
  100:   do { if ('/' == DIRECTORY_SEP) dostounix_filename (s); \
  101:        else unixtodos_filename (s); \
  102:   } while (0)
  103: /* On Windows, drive letters must be alphabetic - on DOS, the Netware
  104:    redirector allows the six letters between 'Z' and 'a' as well. */
  105: #ifdef MSDOS
  106: #define IS_DRIVE(x) ((x) >= 'A' && (x) <= 'z')
  107: #endif
  108: #ifdef WINDOWSNT
  109: #define IS_DRIVE(x) isalpha (x)
  110: #endif
  111: /* Need to lower-case the drive letter, or else expanded
  112:    filenames will sometimes compare inequal, because
  113:    `expand-file-name' doesn't always down-case the drive letter.  */
  114: #define DRIVE_LETTER(x) (tolower (x))
  115: #endif
  116: 
  117: #ifdef VMS
  118: #include <file.h>
  119: #include <rmsdef.h>
  120: #include <fab.h>
  121: #include <nam.h>
  122: #endif
  123: 
  124: #include "systime.h"
  125: 
  126: #ifdef HPUX
  127: #include <netio.h>
  128: #ifndef HPUX8
  129: #ifndef HPUX9
  130: #include <errnet.h>
  131: #endif
  132: #endif
  133: #endif
  134: 
  135: #include "commands.h"
  136: extern int use_dialog_box;
  137: extern int use_file_dialog;
  138: 
  139: #ifndef O_WRONLY
  140: #define O_WRONLY 1
  141: #endif
  142: 
  143: #ifndef O_RDONLY
  144: #define O_RDONLY 0
  145: #endif
  146: 
  147: #ifndef S_ISLNK
  148: #  define lstat stat
  149: #endif
  150: 
  151: #ifndef FILE_SYSTEM_CASE
  152: #define FILE_SYSTEM_CASE(filename)  (filename)
  153: #endif
  154: 
  155: /* Nonzero during writing of auto-save files */
  156: int auto_saving;
  157: 
  158: /* Set by auto_save_1 to mode of original file so Fwrite_region will create
  159:    a new file with the same mode as the original */
  160: int auto_save_mode_bits;
  161: 
  162: /* The symbol bound to coding-system-for-read when
  163:    insert-file-contents is called for recovering a file.  This is not
  164:    an actual coding system name, but just an indicator to tell
  165:    insert-file-contents to use `emacs-mule' with a special flag for
  166:    auto saving and recovering a file.  */
  167: Lisp_Object Qauto_save_coding;
  168: 
  169: /* Coding system for file names, or nil if none.  */
  170: Lisp_Object Vfile_name_coding_system;
  171: 
  172: /* Coding system for file names used only when
  173:    Vfile_name_coding_system is nil.  */
  174: Lisp_Object Vdefault_file_name_coding_system;
  175: 
  176: /* Alist of elements (REGEXP . HANDLER) for file names
  177:    whose I/O is done with a special handler.  */
  178: Lisp_Object Vfile_name_handler_alist;
  179: 
  180: /* Property name of a file name handler,
  181:    which gives a list of operations it handles..  */
  182: Lisp_Object Qoperations;
  183: 
  184: /* Lisp functions for translating file formats */
  185: Lisp_Object Qformat_decode, Qformat_annotate_function;
  186: 
  187: /* Function to be called to decide a coding system of a reading file.  */
  188: Lisp_Object Vset_auto_coding_function;
  189: 
  190: /* Functions to be called to process text properties in inserted file.  */
  191: Lisp_Object Vafter_insert_file_functions;
  192: 
  193: /* Lisp function for setting buffer-file-coding-system and the
  194:    multibyteness of the current buffer after inserting a file.  */
  195: Lisp_Object Qafter_insert_file_set_coding;
  196: 
  197: /* Functions to be called to create text property annotations for file.  */
  198: Lisp_Object Vwrite_region_annotate_functions;
  199: Lisp_Object Qwrite_region_annotate_functions;
  200: 
  201: /* During build_annotations, each time an annotation function is called,
  202:    this holds the annotations made by the previous functions.  */
  203: Lisp_Object Vwrite_region_annotations_so_far;
  204: 
  205: /* File name in which we write a list of all our auto save files.  */
  206: Lisp_Object Vauto_save_list_file_name;
  207: 
  208: /* Function to call to read a file name.  */
  209: Lisp_Object Vread_file_name_function;
  210: 
  211: /* Current predicate used by read_file_name_internal.  */
  212: Lisp_Object Vread_file_name_predicate;
  213: 
  214: /* Nonzero means completion ignores case when reading file name.  */
  215: int read_file_name_completion_ignore_case;
  216: 
  217: /* Nonzero means, when reading a filename in the minibuffer,
  218:  start out by inserting the default directory into the minibuffer. */
  219: int insert_default_directory;
  220: 
  221: /* On VMS, nonzero means write new files with record format stmlf.
  222:    Zero means use var format.  */
  223: int vms_stmlf_recfm;
  224: 
  225: /* On NT, specifies the directory separator character, used (eg.) when
  226:    expanding file names.  This can be bound to / or \. */
  227: Lisp_Object Vdirectory_sep_char;
  228: 
  229: #ifdef HAVE_FSYNC
  230: /* Nonzero means skip the call to fsync in Fwrite-region.  */
  231: int write_region_inhibit_fsync;
  232: #endif
  233: 
  234: extern Lisp_Object Vuser_login_name;
  235: 
  236: #ifdef WINDOWSNT
  237: extern Lisp_Object Vw32_get_true_file_attributes;
  238: #endif
  239: 
  240: extern int minibuf_level;
  241: 
  242: extern int minibuffer_auto_raise;
  243: 
  244: extern int history_delete_duplicates;
  245: 
  246: /* These variables describe handlers that have "already" had a chance
  247:    to handle the current operation.
  248: 
  249:    Vinhibit_file_name_handlers is a list of file name handlers.
  250:    Vinhibit_file_name_operation is the operation being handled.
  251:    If we try to handle that operation, we ignore those handlers.  */
  252: 
  253: static Lisp_Object Vinhibit_file_name_handlers;
  254: static Lisp_Object Vinhibit_file_name_operation;
  255: 
  256: Lisp_Object Qfile_error, Qfile_already_exists, Qfile_date_error;
  257: Lisp_Object Qexcl;
  258: Lisp_Object Qfile_name_history;
  259: 
  260: Lisp_Object Qcar_less_than_car;
  261: 
  262: static int a_write P_ ((int, Lisp_Object, int, int,
  263:                         Lisp_Object *, struct coding_system *));
  264: static int e_write P_ ((int, Lisp_Object, int, int, struct coding_system *));
  265: 
  266: ^L
  267: void
  268: report_file_error (string, data)
  269:      const char *string;
  270:      Lisp_Object data;
  271: {
  272:   Lisp_Object errstring;
  273:   int errorno = errno;
  274: 
  275:   synchronize_system_messages_locale ();
  276:   errstring = code_convert_string_norecord (build_string (strerror (errorno)),
  277:                                             Vlocale_coding_system, 0);
  278: 
  279:   while (1)
  280:     switch (errorno)
  281:       {
  282:       case EEXIST:
  283:         xsignal (Qfile_already_exists, Fcons (errstring, data));
  284:         break;
  285:       default:
  286:         /* System error messages are capitalized.  Downcase the initial
  287:            unless it is followed by a slash.  */
  288:         if (SREF (errstring, 1) != '/')
  289:           SSET (errstring, 0, DOWNCASE (SREF (errstring, 0)));
  290: 
  291:         xsignal (Qfile_error,
  292:                  Fcons (build_string (string), Fcons (errstring, data)));
  293:       }
  294: }
  295: 
  296: Lisp_Object
  297: close_file_unwind (fd)
  298:      Lisp_Object fd;
  299: {
  300:   emacs_close (XFASTINT (fd));
  301:   return Qnil;
  302: }
  303: 
  304: /* Restore point, having saved it as a marker.  */
  305: 
  306: static Lisp_Object
  307: restore_point_unwind (location)
  308:      Lisp_Object location;
  309: {
  310:   Fgoto_char (location);
  311:   Fset_marker (location, Qnil, Qnil);
  312:   return Qnil;
  313: }
  314: ^L
  315: Lisp_Object Qexpand_file_name;
  316: Lisp_Object Qsubstitute_in_file_name;
  317: Lisp_Object Qdirectory_file_name;
  318: Lisp_Object Qfile_name_directory;
  319: Lisp_Object Qfile_name_nondirectory;
  320: Lisp_Object Qunhandled_file_name_directory;
  321: Lisp_Object Qfile_name_as_directory;
  322: Lisp_Object Qcopy_file;
  323: Lisp_Object Qmake_directory_internal;
  324: Lisp_Object Qmake_directory;
  325: Lisp_Object Qdelete_directory;
  326: Lisp_Object Qdelete_file;
  327: Lisp_Object Qrename_file;
  328: Lisp_Object Qadd_name_to_file;
  329: Lisp_Object Qmake_symbolic_link;
  330: Lisp_Object Qfile_exists_p;
  331: Lisp_Object Qfile_executable_p;
  332: Lisp_Object Qfile_readable_p;
  333: Lisp_Object Qfile_writable_p;
  334: Lisp_Object Qfile_symlink_p;
  335: Lisp_Object Qaccess_file;
  336: Lisp_Object Qfile_directory_p;
  337: Lisp_Object Qfile_regular_p;
  338: Lisp_Object Qfile_accessible_directory_p;
  339: Lisp_Object Qfile_modes;
  340: Lisp_Object Qset_file_modes;
  341: Lisp_Object Qset_file_times;
  342: Lisp_Object Qfile_newer_than_file_p;
  343: Lisp_Object Qinsert_file_contents;
  344: Lisp_Object Qwrite_region;
  345: Lisp_Object Qverify_visited_file_modtime;
  346: Lisp_Object Qset_visited_file_modtime;
  347: 
  348: DEFUN ("find-file-name-handler", Ffind_file_name_handler, Sfind_file_name_handler, 2, 2, 0,
  349:        doc: /* Return FILENAME's handler function for OPERATION, if it has one.
  350: Otherwise, return nil.
  351: A file name is handled if one of the regular expressions in
  352: `file-name-handler-alist' matches it.
  353: 
  354: If OPERATION equals `inhibit-file-name-operation', then we ignore
  355: any handlers that are members of `inhibit-file-name-handlers',
  356: but we still do run any other handlers.  This lets handlers
  357: use the standard functions without calling themselves recursively.  */)
  358:      (filename, operation)
  359:      Lisp_Object filename, operation;
  360: {
  361:   /* This function must not munge the match data.  */
  362:   Lisp_Object chain, inhibited_handlers, result;
  363:   int pos = -1;
  364: 
  365:   result = Qnil;
  366:   CHECK_STRING (filename);
  367: 
  368:   if (EQ (operation, Vinhibit_file_name_operation))
  369:     inhibited_handlers = Vinhibit_file_name_handlers;
  370:   else
  371:     inhibited_handlers = Qnil;
  372: 
  373:   for (chain = Vfile_name_handler_alist; CONSP (chain);
  374:        chain = XCDR (chain))
  375:     {
  376:       Lisp_Object elt;
  377:       elt = XCAR (chain);
  378:       if (CONSP (elt))
  379:         {
  380:           Lisp_Object string = XCAR (elt);
  381:           int match_pos;
  382:           Lisp_Object handler = XCDR (elt);
  383:           Lisp_Object operations = Qnil;
  384: 
  385:           if (SYMBOLP (handler))
  386:             operations = Fget (handler, Qoperations);
  387: 
  388:           if (STRINGP (string)
  389:               && (match_pos = fast_string_match (string, filename)) > pos
  390:               && (NILP (operations) || ! NILP (Fmemq (operation, operations))))
  391:             {
  392:               Lisp_Object tem;
  393: 
  394:               handler = XCDR (elt);
  395:               tem = Fmemq (handler, inhibited_handlers);
  396:               if (NILP (tem))
  397:                 {
  398:                   result = handler;
  399:                   pos = match_pos;
  400:                 }
  401:             }
  402:         }
  403: 
  404:       QUIT;
  405:     }
  406:   return result;
  407: }
  408: ^L
  409: DEFUN ("file-name-directory", Ffile_name_directory, Sfile_name_directory,
  410:        1, 1, 0,
  411:        doc: /* Return the directory component in file name FILENAME.
  412: Return nil if FILENAME does not include a directory.
  413: Otherwise return a directory spec.
  414: Given a Unix syntax file name, returns a string ending in slash;
  415: on VMS, perhaps instead a string ending in `:', `]' or `>'.  */)
  416:      (filename)
  417:      Lisp_Object filename;
  418: {
  419: #ifndef DOS_NT
  420:   register const unsigned char *beg;
  421: #else
  422:   register unsigned char *beg;
  423: #endif
  424:   register const unsigned char *p;
  425:   Lisp_Object handler;
  426: 
  427:   CHECK_STRING (filename);
  428: 
  429:   /* If the file name has special constructs in it,
  430:      call the corresponding file handler.  */
  431:   handler = Ffind_file_name_handler (filename, Qfile_name_directory);
  432:   if (!NILP (handler))
  433:     return call2 (handler, Qfile_name_directory, filename);
  434: 
  435:   filename = FILE_SYSTEM_CASE (filename);
  436:   beg = SDATA (filename);
  437: #ifdef DOS_NT
  438:   beg = strcpy (alloca (strlen (beg) + 1), beg);
  439: #endif
  440:   p = beg + SBYTES (filename);
  441: 
  442:   while (p != beg && !IS_DIRECTORY_SEP (p[-1])
  443: #ifdef VMS
  444:          && p[-1] != ':' && p[-1] != ']' && p[-1] != '>'
  445: #endif /* VMS */
  446: #ifdef DOS_NT
  447:          /* only recognise drive specifier at the beginning */
  448:          && !(p[-1] == ':'
  449:               /* handle the "/:d:foo" and "/:foo" cases correctly  */
  450:               && ((p == beg + 2 && !IS_DIRECTORY_SEP (*beg))
  451:                   || (p == beg + 4 && IS_DIRECTORY_SEP (*beg))))
  452: #endif
  453:          ) p--;
  454: 
  455:   if (p == beg)
  456:     return Qnil;
  457: #ifdef DOS_NT
  458:   /* Expansion of "c:" to drive and default directory.  */
  459:   if (p[-1] == ':')
  460:     {
  461:       /* MAXPATHLEN+1 is guaranteed to be enough space for getdefdir.  */
  462:       unsigned char *res = alloca (MAXPATHLEN + 1);
  463:       unsigned char *r = res;
  464: 
  465:       if (p == beg + 4 && IS_DIRECTORY_SEP (*beg) && beg[1] == ':')
  466:         {
  467:           strncpy (res, beg, 2);
  468:           beg += 2;
  469:           r += 2;
  470:         }
  471: 
  472:       if (getdefdir (toupper (*beg) - 'A' + 1, r))
  473:         {
  474:           if (!IS_DIRECTORY_SEP (res[strlen (res) - 1]))
  475:             strcat (res, "/");
  476:           beg = res;
  477:           p = beg + strlen (beg);
  478:         }
  479:     }
  480:   CORRECT_DIR_SEPS (beg);
  481: #endif /* DOS_NT */
  482: 
  483:   return make_specified_string (beg, -1, p - beg, STRING_MULTIBYTE (filename));
  484: }
  485: 
  486: DEFUN ("file-name-nondirectory", Ffile_name_nondirectory,
  487:        Sfile_name_nondirectory, 1, 1, 0,
  488:        doc: /* Return file name FILENAME sans its directory.
  489: For example, in a Unix-syntax file name,
  490: this is everything after the last slash,
  491: or the entire name if it contains no slash.  */)
  492:      (filename)
  493:      Lisp_Object filename;
  494: {
  495:   register const unsigned char *beg, *p, *end;
  496:   Lisp_Object handler;
  497: 
  498:   CHECK_STRING (filename);
  499: 
  500:   /* If the file name has special constructs in it,
  501:      call the corresponding file handler.  */
  502:   handler = Ffind_file_name_handler (filename, Qfile_name_nondirectory);
  503:   if (!NILP (handler))
  504:     return call2 (handler, Qfile_name_nondirectory, filename);
  505: 
  506:   beg = SDATA (filename);
  507:   end = p = beg + SBYTES (filename);
  508: 
  509:   while (p != beg && !IS_DIRECTORY_SEP (p[-1])
  510: #ifdef VMS
  511:          && p[-1] != ':' && p[-1] != ']' && p[-1] != '>'
  512: #endif /* VMS */
  513: #ifdef DOS_NT
  514:          /* only recognise drive specifier at beginning */
  515:          && !(p[-1] == ':'
  516:               /* handle the "/:d:foo" case correctly  */
  517:               && (p == beg + 2 || (p == beg + 4 && IS_DIRECTORY_SEP (*beg))))
  518: #endif
  519:          )
  520:     p--;
  521: 
  522:   return make_specified_string (p, -1, end - p, STRING_MULTIBYTE (filename));
  523: }
  524: 
  525: DEFUN ("unhandled-file-name-directory", Funhandled_file_name_directory,
  526:        Sunhandled_file_name_directory, 1, 1, 0,
  527:        doc: /* Return a directly usable directory name somehow associated with FILENAME.
  528: A `directly usable' directory name is one that may be used without the
  529: intervention of any file handler.
  530: If FILENAME is a directly usable file itself, return
  531: \(file-name-directory FILENAME).
  532: The `call-process' and `start-process' functions use this function to
  533: get a current directory to run processes in.  */)
  534:      (filename)
  535:      Lisp_Object filename;
  536: {
  537:   Lisp_Object handler;
  538: 
  539:   /* If the file name has special constructs in it,
  540:      call the corresponding file handler.  */
  541:   handler = Ffind_file_name_handler (filename, Qunhandled_file_name_directory);
  542:   if (!NILP (handler))
  543:     return call2 (handler, Qunhandled_file_name_directory, filename);
  544: 
  545:   return Ffile_name_directory (filename);
  546: }
  547: 
  548: ^L
  549: char *
  550: file_name_as_directory (out, in)
  551:      char *out, *in;
  552: {
  553:   int size = strlen (in) - 1;
  554: 
  555:   strcpy (out, in);
  556: 
  557:   if (size < 0)
  558:     {
  559:       out[0] = '.';
  560:       out[1] = '/';
  561:       out[2] = 0;
  562:       return out;
  563:     }
  564: 
  565: #ifdef VMS
  566:   /* Is it already a directory string? */
  567:   if (in[size] == ':' || in[size] == ']' || in[size] == '>')
  568:     return out;
  569:   /* Is it a VMS directory file name?  If so, hack VMS syntax.  */
  570:   else if (! index (in, '/')
  571:            && ((size > 3 && ! strcmp (&in[size - 3], ".DIR"))
  572:                || (size > 3 && ! strcmp (&in[size - 3], ".dir"))
  573:                || (size > 5 && (! strncmp (&in[size - 5], ".DIR", 4)
  574:                                 || ! strncmp (&in[size - 5], ".dir", 4))
  575:                    && (in[size - 1] == '.' || in[size - 1] == ';')
  576:                    && in[size] == '1')))
  577:     {
  578:       register char *p, *dot;
  579:       char brack;
  580: 
  581:       /* x