4.3BSD - /usr/src/new/emacs/src/fileio.c

   1: /* File IO for GNU Emacs.
   2:    Copyright (C) 1985 Richard M. Stallman.
   3: 
   4: This file is part of GNU Emacs.
   5: 
   6: GNU Emacs is distributed in the hope that it will be useful,
   7: but WITHOUT ANY WARRANTY.  No author or distributor
   8: accepts responsibility to anyone for the consequences of using it
   9: or for whether it serves any particular purpose or works at all,
  10: unless he says so in writing.  Refer to the GNU Emacs General Public
  11: License for full details.
  12: 
  13: Everyone is granted permission to copy, modify and redistribute
  14: GNU Emacs, but only under the conditions described in the
  15: GNU Emacs General Public License.   A copy of this license is
  16: supposed to have been given to you along with GNU Emacs so you
  17: can know your rights and responsibilities.  It should be in a
  18: file named COPYING.  Among other things, the copyright notice
  19: and this notice must be preserved on all copies.  */
  20: 
  21: 
  22: #include <sys/types.h>
  23: #include <sys/stat.h>
  24: #include <pwd.h>
  25: #include <ctype.h>
  26: #include <sys/dir.h>
  27: #include <errno.h>
  28: #undef NULL
  29: #include "config.h"
  30: #include "lisp.h"
  31: #include "buffer.h"
  32: #include "window.h"
  33: 
  34: #define min(a, b) ((a) < (b) ? (a) : (b))
  35: #define max(a, b) ((a) > (b) ? (a) : (b))
  36: 
  37: /* Nonzero during writing of auto-save files */
  38: int auto_saving;
  39: 
  40: /* Nonzero means, when reading a filename in the minibuffer,
  41:  start out by inserting the default directory into the minibuffer. */
  42: int insert_default_directory;
  43: 
  44: Lisp_Object Qfile_error, Qfile_already_exists;
  45: 
  46: report_file_error (string, data)
  47:      char *string;
  48:      Lisp_Object data;
  49: {
  50:   Lisp_Object errstring;
  51:   extern char *sys_errlist[];
  52:   extern int errno;
  53:   extern int sys_nerr;
  54: 
  55:   if (errno < sys_nerr)
  56:     errstring = build_string (sys_errlist[errno]);
  57:   else
  58:     errstring = build_string ("undocumented error code");
  59: 
  60:   /* System error messages are capitalized.  Downcase the initial. */
  61:   if (XSTRING (errstring)->data[0] >= 'A' &&
  62:       XSTRING (errstring)->data[0] <= 'Z')
  63:     XSTRING (errstring)->data[0] += 040;
  64: 
  65:   while (1)
  66:     Fsignal (Qfile_error,
  67:          Fcons (build_string (string), Fcons (errstring, data)));
  68: }
  69: 
  70: DEFUN ("file-name-directory", Ffile_name_directory, Sfile_name_directory,
  71:   1, 1, 0,
  72:   "Return the directory component in file name NAME.\n\
  73: Return nil if NAME does not include a directory.\n\
  74: Otherwise return a string ending in a slash.")
  75:   (file)
  76:      Lisp_Object file;
  77: {
  78:   register unsigned char *beg;
  79:   register unsigned char *p;
  80: 
  81:   CHECK_STRING (file, 0);
  82: 
  83:   beg = XSTRING (file)->data;
  84:   p = beg + XSTRING (file)->size;
  85: 
  86:   while (p != beg && p[-1] != '/') p--;
  87: 
  88:   if (p == beg)
  89:     return Qnil;
  90:   return make_string (beg, p - beg);
  91: }
  92: 
  93: DEFUN ("file-name-nondirectory", Ffile_name_nondirectory, Sfile_name_nondirectory,
  94:   1, 1, 0,
  95:   "Return file name NAME sans its directory.\n\
  96: This is everything after the last slash in NAME, if NAME contains a slash.")
  97:   (file)
  98:      Lisp_Object file;
  99: {
 100:   register unsigned char *beg, *p, *end;
 101: 
 102:   CHECK_STRING (file, 0);
 103: 
 104:   beg = XSTRING (file)->data;
 105:   end = p = beg + XSTRING (file)->size;
 106: 
 107:   while (p != beg && p[-1] != '/') p--;
 108: 
 109:   return make_string (p, end - p);
 110: }
 111: 
 112: DEFUN ("make-temp-name", Fmake_temp_name, Smake_temp_name, 1, 1, 0,
 113:   "Generate temporary name (string) starting with PREFIX (a string).")
 114:   (prefix)
 115:      Lisp_Object prefix;
 116: {
 117:   Lisp_Object val;
 118:   val = concat2 (prefix, build_string ("XXXXXX"));
 119:   mktemp (XSTRING (val)->data);
 120:   return val;
 121: }
 122: 
 123: DEFUN ("expand-file-name", Fexpand_file_name, Sexpand_file_name, 1, 2, 0,
 124:   "Convert FILENAME to absolute, and canonicalize it.\n\
 125: Second arg DEFAULT is directory to start with if FILENAME is relative\n\
 126:  (does not start with slash); if DEFAULT is nil or missing,\n\
 127: the current buffer's value of default-directory is used.\n\
 128: Filenames containing . or .. as components are simplified;\n\
 129: initial ~ is expanded.  See also the function  substitute-in-file-name.")
 130:      (name, defalt)
 131:      Lisp_Object name, defalt;
 132: {
 133:   unsigned char *nm;
 134: 
 135:   register unsigned char *newdir, *p, *o;
 136:   int tlen;
 137:   unsigned char *target;
 138:   struct passwd *pw;
 139:   int lose;
 140: 
 141:   CHECK_STRING (name, 0);
 142: 
 143:   nm = XSTRING (name)->data;
 144: 
 145:   /* If nm is absolute, flush ...// and detect /./ and /../.
 146:      If no /./ or /../ we can return right away. */
 147:   if (nm[0] == '/')
 148:     {
 149:       p = nm;
 150:       lose = 0;
 151:       while (*p)
 152:     {
 153:       if (p[0] == '/' && p[1] == '/'
 154: #ifdef APOLLO
 155:           /* // at start of filename is meaningful on Apollo system */
 156:           && nm != p
 157: #endif /* APOLLO */
 158:           )
 159:         nm = p + 1;
 160:       if (p[0] == '/' && p[1] == '~')
 161:         nm = p + 1, lose = 1;
 162:       if (p[0] == '/' && p[1] == '.'
 163:           && (p[2] == '/' || p[2] == 0
 164:           || (p[2] == '.' && (p[3] == '/' || p[3] == 0))))
 165:         lose = 1;
 166:       p++;
 167:     }
 168:       if (!lose)
 169:     {
 170:       if (nm == XSTRING (name)->data)
 171:         return name;
 172:       return build_string (nm);
 173:     }
 174:     }
 175: 
 176:   /* Now determine directory to start with and put it in newdir */
 177: 
 178:   newdir = 0;
 179: 
 180:   if (nm[0] == '~')     /* prefix ~ */
 181:     if (nm[1] == '/' || nm[1] == 0)/* ~/filename */
 182:       {
 183:     if (!(newdir = (unsigned char *) getenv ("HOME")))
 184:       newdir = (unsigned char *) "";
 185:     nm++;
 186:       }
 187:     else            /* ~user/filename */
 188:       {
 189:     for (p = nm; *p && *p != '/'; p++);
 190:     o = (unsigned char *) alloca (p - nm + 1);
 191:     bcopy ((char *) nm, o, p - nm);
 192:     o [p - nm] = 0;
 193: 
 194:     pw = (struct passwd *) getpwnam (o + 1);
 195:     if (!pw)
 196:       error ("\"%s\" isn't a registered user", o + 1);
 197: 
 198:     nm = p;
 199:     newdir = (unsigned char *) pw -> pw_dir;
 200:       }
 201: 
 202:   if (nm[0] != '/' && !newdir)
 203:     {
 204:       if (NULL (defalt))
 205:     defalt = bf_cur->directory;
 206:       CHECK_STRING (defalt, 1);
 207:       newdir = XSTRING (defalt)->data;
 208:     }
 209: 
 210:   /* Now concatenate the directory and name to new space in thestack frame */
 211: 
 212:   tlen = (newdir ? strlen (newdir) + 1 : 0) + strlen (nm) + 1;
 213:   target = (unsigned char *) alloca (tlen);
 214:   *target = 0;
 215: 
 216:   if (newdir)
 217:     {
 218:       strcpy (target, newdir);
 219: 
 220:       /* Make sure there is a slash to separate directory from following */
 221:       if (target[strlen (target) - 1] != '/' && nm[0] != '/' && nm[0])
 222:     strcat (target, "/");
 223:     }
 224: 
 225:   strcat (target, nm);
 226: 
 227:   /* Now canonicalize by removing /. and /foo/.. if they appear */
 228: 
 229:   p = target;
 230:   o = target;
 231: 
 232:   while (*p)
 233:     {
 234:       if (*p != '/')
 235:     {
 236:       *o++ = *p++;
 237:     }
 238:       else if (!strncmp (p, "//", 2)
 239: #ifdef APOLLO
 240:            /* // at start of filename is meaningful in Apollo system */
 241:            && o != target
 242: #endif /* APOLLO */
 243:            )
 244:     {
 245:       o = target;
 246:       p++;
 247:     }
 248:       else if (p[0] == '/' && p[1] == '.' &&
 249:            (p[2] == '/' || p[2] == 0))
 250:     p += 2;
 251:       else if (!strncmp (p, "/..", 3)
 252:            && (p[3] == '/' || p[3] == 0))
 253:     {
 254:       while (o != target && *--o != '/');
 255:       p += 3;
 256:     }
 257:       else
 258:     {
 259:       *o++ = *p++;
 260:     }
 261:     }
 262: 
 263:   return make_string (target, o - target);
 264: }
 265: 
 266: DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name,
 267:   Ssubstitute_in_file_name, 1, 1, 0,
 268:   "Substitute environment variables referred to in STRING.\n\
 269: A $ begins a request to substitute; the env variable name is\n\
 270: the alphanumeric characters after the $, or else is surrounded by braces.\n\
 271: If a ~ appears following a /, everything through that / is discarded.")
 272:   (string)
 273:      Lisp_Object string;
 274: {
 275:   unsigned char *nm;
 276: 
 277:   register unsigned char *s, *p, *o, *x, *endp;
 278:   unsigned char *target;
 279:   int total = 0;
 280:   unsigned char *xnm;
 281: 
 282:   CHECK_STRING (string, 0);
 283: 
 284:   nm = XSTRING (string)->data;
 285:   endp = nm + XSTRING (string)->size;
 286: 
 287:   /* If /~ or // appears, discard everything through first slash. */
 288: 
 289:   for (p = nm; p != endp; p++)
 290:     {
 291:       if ((p[0] == '~' ||
 292: #ifdef APOLLO
 293:        /* // at start of file name is meaningful in Apollo system */
 294:        (p[0] == '/' && p - 1 != nm)
 295: #else /* not APOLLO */
 296:        p[0] == '/'
 297: #endif /* not APOLLO */
 298:        )
 299:       && p != nm && p[-1] == '/')
 300:     {
 301:       nm = p;
 302:       total = 1;
 303:     }
 304:     }
 305: 
 306:   /* See if any variables are substituted into the string
 307:      and find the total length of their values in `total' */
 308: 
 309:   for (p = nm; p != endp;)
 310:     if (*p == '$')
 311:       {
 312:     p++;
 313:     if (p == endp) goto badsubst;
 314:     if (*p == '{')
 315:       {
 316:         o = ++p;
 317:         while (p != endp && *p != '}') p++;
 318:         if (*p != '}') goto missingclose;
 319:         s = p;
 320:       }
 321:     else
 322:       {
 323:         o = p;
 324:         while (p != endp && isalnum(*p)) p++;
 325:         s = p;
 326:       }
 327: 
 328:     /* Copy out the variable name */
 329:     target = (unsigned char *) alloca (s - o + 1);
 330:     strncpy (target, o, s - o);
 331:     target[s - o] = 0;
 332: 
 333:     /* Get variable value */
 334:     o = (unsigned char *) getenv (target);
 335: /* The presence of this code makes vax 5.0 crash, for reasons yet unknown */
 336: #if 0
 337: #ifdef USG
 338:     if (!o && !strcmp (target, "USER"))
 339:       o = (unsigned char *) getenv ("LOGNAME");
 340: #endif /* USG */
 341: #endif /* 0 */
 342:     if (!o)
 343:       goto badvar;
 344:     total += strlen (o);
 345:       }
 346:     else p++;
 347: 
 348:   if (!total)
 349:     return string;
 350: 
 351:   /* If substitution required, recopy the string and do it */
 352:   /* Make space in stack frame for the new copy */
 353:   xnm = (unsigned char *) alloca (XSTRING (string)->size + total + 1);
 354:   x = xnm;
 355: 
 356:   /* Copy the rest of the name through, replacing $ constructs with values */
 357:   for (p = nm; *p;)
 358:     if (*p == '$')
 359:       {
 360:     p++;
 361:     if (p == endp) goto badsubst;
 362:     if (*p == '{')
 363:       {
 364:         o = ++p;
 365:         while (p != endp && *p != '}') p++;
 366:         if (*p != '}') goto missingclose;
 367:         s = p++;
 368:       }
 369:     else
 370:       {
 371:         o = p;
 372:         while (p != endp && isalnum(*p)) p++;
 373:         s = p;
 374:       }
 375: 
 376:     /* Copy out the variable name */
 377:     target = (unsigned char *) alloca (s - o + 1);
 378:     strncpy (target, o, s - o);
 379:     target[s - o] = 0;
 380: 
 381:     /* Get variable value */
 382:     o = (unsigned char *) getenv (target);
 383: /* The presence of this code makes vax 5.0 crash, for reasons yet unknown */
 384: #if 0
 385: #ifdef USG
 386:     if (!o && !strcmp (target, "USER"))
 387:       o = (unsigned char *) getenv ("LOGNAME");
 388: #endif /* USG */
 389: #endif /* 0 */
 390:     if (!o)
 391:       goto badvar;
 392: 
 393:     strcpy (x, o);
 394:     x += strlen (o);
 395:       }
 396:   else
 397:     *x++ = *p++;
 398: 
 399:   *x = 0;
 400: 
 401:   /* If /~ or // appears, discard everything through first slash. */
 402: 
 403:   for (p = xnm; p != x; p++)
 404:     if ((p[0] == '~' ||
 405: #ifdef APOLLO
 406:      /* // at start of file name is meaningful in Apollo system */
 407:      (p[0] == '/' && p - 1 != xnm)
 408: #else /* not APOLLO */
 409:      p[0] == '/'
 410: #endif /* not APOLLO */
 411:      )
 412:     && p != nm && p[-1] == '/')
 413:       xnm = p;
 414: 
 415:   return make_string (xnm, x - xnm);
 416: 
 417:  badsubst:
 418:   error ("Bad format environment-variable substitution");
 419:  missingclose:
 420:   error ("Missing \"}\" in environment-variable substitution");
 421:  badvar:
 422:   error ("Substituting nonexistent environment variable %s", target);
 423: 
 424:   /* NOTREACHED */
 425: }
 426: 
 427: barf_or_query_if_file_exists (absname, querystring)
 428:      Lisp_Object absname;
 429:      unsigned char *querystring;
 430: {
 431:   Lisp_Object tem;
 432:   if (access (XSTRING (absname)->data, 4) >= 0)
 433:     if (!(Finteractive_p ()) ||
 434:     (tem = Fyes_or_no_p
 435:              (format1 ("File %s already exists; %s anyway? ",
 436:                XSTRING (absname)->data, querystring)),
 437:      NULL (tem)))
 438:       Fsignal (Qfile_already_exists, Fcons (absname, Qnil));
 439:   return;
 440: }
 441: 
 442: DEFUN ("copy-file", Fcopy_file, Scopy_file, 2, 3,
 443:   "fCopy file: \nFCopy %s to file: ",
 444:   "Copy FILE to NEWNAME.  Both args strings.\n\
 445: Signals a  file-already-exists  error if NEWNAME already exists,\n\
 446: unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.")
 447:   (filename, newname, ok_if_already_exists)
 448:      Lisp_Object filename, newname, ok_if_already_exists;
 449: {
 450:   int ifd, ofd, n;
 451:   char buf[2048];
 452:   struct stat st;
 453: 
 454:   CHECK_STRING (filename, 0);
 455:   CHECK_STRING (newname, 1);
 456:   filename = Fexpand_file_name (filename, Qnil);
 457:   newname = Fexpand_file_name (newname, Qnil);
 458:   if (NULL (ok_if_already_exists))
 459:       barf_or_query_if_file_exists (newname, "copy to it");
 460: 
 461:   ifd = open (XSTRING (filename)->data, 0);
 462:   if (ifd < 0)
 463:     report_file_error ("Opening input file", Fcons (filename, Qnil));
 464: 
 465:   ofd = creat (XSTRING (newname)->data, 0666);
 466:   if (ofd < 0)
 467:     {
 468:       close (ifd);
 469:       report_file_error ("Opening output file", Fcons (newname, Qnil));
 470:     }
 471: 
 472:   while ((n = read (ifd, buf, sizeof buf)) > 0)
 473:     write (ofd, buf, n);
 474: 
 475:   if (fstat (ifd, &st) >= 0)
 476: #if defined (BSD) && !defined (BSD4_1)
 477:     fchmod (ofd, st.st_mode & 07777);
 478: #else
 479:     chmod (XSTRING (newname)->data, st.st_mode & 07777);
 480: #endif
 481: 
 482:   close (ifd);
 483:   close (ofd);
 484:   return Qnil;
 485: }
 486: 
 487: DEFUN ("delete-file", Fdelete_file, Sdelete_file, 1, 1, "fDelete file: ",
 488:   "Delete specified file.  One argument, a file name string.\n\
 489: If file has multiple names, it continues to exist with the other names.")
 490:   (filename)
 491:      Lisp_Object filename;
 492: {
 493:   CHECK_STRING (filename, 0);
 494:   filename = Fexpand_file_name (filename, Qnil);
 495:   if (0 > unlink (XSTRING (filename)->data))
 496:     report_file_error ("Removing old name", Flist (1, &filename));
 497:   return Qnil;
 498: }
 499: 
 500: DEFUN ("rename-file", Frename_file, Srename_file, 2, 3,
 501:   "fRename file: \nFRename %s to file: ",
 502:   "Rename FILE as NEWNAME.  Both args strings.\n\
 503: If file has names other than FILE, it continues to have those names.\n\
 504: Signals a  file-already-exists  error if NEWNAME already exists\n\
 505: unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.")
 506:   (filename, newname, ok_if_already_exists)
 507:      Lisp_Object filename, newname, ok_if_already_exists;
 508: {
 509:   extern int errno;
 510: #ifdef NO_ARG_ARRAY
 511:   Lisp_Object args[2];
 512: #endif
 513: 
 514:   CHECK_STRING (filename, 0);
 515:   CHECK_STRING (newname, 1);
 516:   filename = Fexpand_file_name (filename, Qnil);
 517:   newname = Fexpand_file_name (newname, Qnil);
 518:   if (NULL (ok_if_already_exists))
 519:     barf_or_query_if_file_exists (newname, "rename to it");
 520: #ifndef BSD4_1
 521:   if (0 > rename (XSTRING (filename)->data, XSTRING (newname)->data))
 522: #else
 523:   if (0 > link (XSTRING (filename)->data, XSTRING (newname)->data)
 524:       || 0 > unlink (XSTRING (filename)->data))
 525: #endif
 526:     {
 527:       if (errno == EXDEV)
 528:     {
 529:       Fcopy_file (filename, newname, ok_if_already_exists);
 530:       Fdelete_file (filename);
 531:     }
 532:       else
 533: #ifdef NO_ARG_ARRAY
 534:     {
 535:       args[0] = filename;
 536:       args[1] = newname;
 537:       report_file_error ("Renaming", Flist (2, args));
 538:     }
 539: #else
 540:     report_file_error ("Renaming", Flist (2, &filename));
 541: #endif
 542:     }
 543:   return Qnil;
 544: }
 545: 
 546: DEFUN ("add-name-to-file", Fadd_name_to_file, Sadd_name_to_file, 2, 3,
 547:   "fAdd name to file: \nFName to add to %s: ",
 548:   "Give FILE additional name NEWNAME.  Both args strings.\n\
 549: Signals a  file-already-exists  error if NEWNAME already exists\n\
 550: unlesss optional third argument OK-IF-ALREADY-EXISTS is non-nil.")
 551:   (filename, newname, ok_if_already_exists)
 552:      Lisp_Object filename, newname, ok_if_already_exists;
 553: {
 554: #ifdef NO_ARG_ARRAY
 555:   Lisp_Object args[2];
 556: #endif
 557: 
 558:   CHECK_STRING (filename, 0);
 559:   CHECK_STRING (newname, 1);
 560:   filename = Fexpand_file_name (filename, Qnil);
 561:   newname = Fexpand_file_name (newname, Qnil);
 562:   if (NULL (ok_if_already_exists))
 563:     barf_or_query_if_file_exists (newname, "make it a new name");
 564:   unlink (XSTRING (newname)->data);
 565:   if (0 > link (XSTRING (filename)->data, XSTRING (newname)->data))
 566:     {
 567: #ifdef NO_ARG_ARRAY
 568:       args[0] = filename;
 569:       args[1] = newname;
 570:       report_file_error ("Adding new name", Flist (2, args));
 571: #else
 572:       report_file_error ("Adding new name", Flist (2, &filename));
 573: #endif
 574:     }
 575: 
 576:   return Qnil;
 577: }
 578: 
 579: #ifdef S_IFLNK
 580: DEFUN ("make-symbolic-link", Fmake_symbolic_link, Smake_symbolic_link, 2, 3,
 581:   "FMake symbolic link to file: \nFMake symbolic link to file %s: ",
 582:   "Make a symbolic link to FILENAME, named LINKNAME.  Both args strings.\n\
 583: Signals a  file-already-exists  error if NEWNAME already exists\n\
 584: unlesss optional third argument OK-IF-ALREADY-EXISTS is non-nil.")
 585: 
 586:   (filename, newname, ok_if_already_exists)
 587:      Lisp_Object filename, newname, ok_if_already_exists;
 588: {
 589: #ifdef NO_ARG_ARRAY
 590:   Lisp_Object args[2];
 591: #endif
 592: 
 593:   CHECK_STRING (filename, 0);
 594:   CHECK_STRING (newname, 1);
 595:   filename = Fexpand_file_name (filename, Qnil);
 596:   newname = Fexpand_file_name (newname, Qnil);
 597:   if (NULL (ok_if_already_exists))
 598:     barf_or_query_if_file_exists (newname, "make it a link");
 599:   if (0 > symlink (XSTRING (filename)->data, XSTRING (newname)->data))
 600:     {
 601: #ifdef NO_ARG_ARRAY
 602:       args[0] = filename;
 603:       args[1] = newname;
 604:       report_file_error ("Making symbolic link", Flist (2, args));
 605: #else
 606:       report_file_error ("Making symbolic link", Flist (2, &filename));
 607: #endif
 608:     }
 609:   return Qnil;
 610: }
 611: #endif /* S_IFLNK */
 612: 
 613: DEFUN ("file-exists-p", Ffile_exists_p, Sfile_exists_p, 1, 1, 0,
 614:   "Return t if file FILENAME exists and you can read it.\n\
 615: Use file-attributes to check for existence not caring about readability.")
 616:   (filename)
 617:      Lisp_Object filename;
 618: {
 619:   Lisp_Object abspath;
 620: 
 621:   CHECK_STRING (filename, 0);
 622:   abspath = Fexpand_file_name (filename, Qnil);
 623:   return (access (XSTRING (abspath)->data, 4) >= 0) ? Qt : Qnil;
 624: }
 625: 
 626: DEFUN ("file-writable-p", Ffile_writable_p, Sfile_writable_p, 1, 1, 0,
 627:   "Return t if file FILENAME can be written or created by you.")
 628:   (filename)
 629:      Lisp_Object filename;
 630: {
 631:   Lisp_Object abspath, dir;
 632: 
 633:   CHECK_STRING (filename, 0);
 634:   abspath = Fexpand_file_name (filename, Qnil);
 635:   if (access (XSTRING (abspath)->data, 0) >= 0)
 636:     return (access (XSTRING (abspath)->data, 2) >= 0) ? Qt : Qnil;
 637:   dir = Ffile_name_directory (abspath);
 638:   return (access (!NULL (dir) ? (char *) XSTRING (dir)->data : "", 2) >= 0
 639:       ? Qt : Qnil);
 640: }
 641: 
 642: DEFUN ("file-symlink-p", Ffile_symlink_p, Sfile_symlink_p, 1, 1, 0,
 643:   "If file FILENAME is the name of a symbolic link\n\
 644: returns the name of the file to which it is linked.\n\
 645: Otherwise returns NIL.")
 646:   (filename)
 647:      Lisp_Object filename;
 648: {
 649: #ifdef S_IFLNK
 650:   char *buf;
 651:   int bufsize;
 652:   int valsize;
 653:   Lisp_Object val;
 654: 
 655:   CHECK_STRING (filename, 0);
 656: 
 657:   bufsize = 100;
 658:   while (1)
 659:     {
 660:       buf = (char *) xmalloc (bufsize);
 661:       bzero (buf, bufsize);
 662:       valsize = readlink (XSTRING (filename)->data, buf, bufsize);
 663:       if (valsize < bufsize) break;
 664:       /* Buffer was not long enough */
 665:       free (buf);
 666:       bufsize *= 2;
 667:     }
 668:   if (valsize == -1)
 669:     {
 670:       free (buf);
 671:       return Qnil;
 672:     }
 673:   val = make_string (buf, valsize);
 674:   free (buf);
 675:   return val;
 676: #else /* not S_IFLNK */
 677:   return Qnil;
 678: #endif /* not S_IFLNK */
 679: }
 680: 
 681: DEFUN ("file-directory-p", Ffile_directory_p, Sfile_directory_p, 1, 1, 0,
 682:   "Return t if file FILENAME is the name of a directory.")
 683:   (filename)
 684:      Lisp_Object filename;
 685: {
 686:   register Lisp_Object abspath;
 687:   struct stat st;
 688: 
 689:   abspath = Fexpand_file_name (filename, bf_cur->directory);
 690:   /* Remove final slash, if any (unless path is root).
 691:      stat behaves differently depending!  */
 692:   if (XSTRING (abspath)->size > 1
 693:       && XSTRING (abspath)->data[XSTRING (abspath)->size - 1] == '/')
 694:     {
 695:       if (EQ (abspath, filename))
 696:     abspath = Fcopy_sequence (abspath);
 697:       XSTRING (abspath)->data[XSTRING (abspath)->size - 1] = 0;
 698:     }
 699: 
 700:   if (stat (XSTRING (abspath)->data, &st) < 0)
 701:     return Qnil;
 702:   return (st.st_mode & S_IFMT) == S_IFDIR ? Qt : Qnil;
 703: }
 704: 
 705: DEFUN ("file-modes", Ffile_modes, Sfile_modes, 1, 1, 0,
 706:   "Return mode bits of FILE, as an integer.")
 707:   (filename)
 708:      Lisp_Object filename;
 709: {
 710:   Lisp_Object abspath;
 711:   struct stat st;
 712: 
 713:   abspath = Fexpand_file_name (filename, bf_cur->directory);
 714: 
 715:   /* Remove final slash, if any (unless path is the root).
 716:      stat behaves differently depending!  */
 717:   if (XSTRING (abspath)->size > 1
 718:       && XSTRING (abspath)->data[XSTRING (abspath)->size - 1] == '/')
 719:     {
 720:       if (EQ (abspath, filename))
 721:     abspath = Fcopy_sequence (abspath);
 722:       XSTRING (abspath)->data[XSTRING (abspath)->size - 1] = 0;
 723:     }
 724: 
 725:   if (stat (XSTRING (abspath)->data, &st) < 0)
 726:     return Qnil;
 727:   return make_number (st.st_mode & 07777);
 728: }
 729: 
 730: DEFUN ("set-file-modes", Fset_file_modes, Sset_file_modes, 2, 2, 0,
 731:   "Set mode bits of FILE to MODE (an integer).\n\
 732: Only the 12 low bits of MODE are used.")
 733:   (filename, mode)
 734:      Lisp_Object filename, mode;
 735: {
 736:   Lisp_Object abspath;
 737: 
 738:   abspath = Fexpand_file_name (filename, bf_cur->directory);
 739:   CHECK_NUMBER (mode, 1);
 740:   if (chmod (XSTRING (abspath)->data, XINT (mode)) < 0)
 741:     report_file_error ("Doing chmod", Fcons (abspath, Qnil));
 742:   return Qnil;
 743: }
 744: 
 745: close_file_unwind (fd)
 746:      Lisp_Object fd;
 747: {
 748:   close (XFASTINT (fd));
 749: }
 750: 
 751: DEFUN ("insert-file-contents", Finsert_file_contents, Sinsert_file_contents,
 752:   1, 2, 0,
 753:   "Insert contents of file FILENAME after point.\n\
 754: Returns list of absolute pathname and length of data inserted.\n\
 755: If second argument VISIT is non-nil, the buffer's\n\
 756: visited filename and last save file modtime are set,\n\
 757: and it is marked unmodified.")
 758:   (filename, visit)
 759:      Lisp_Object filename, visit;
 760: {
 761:   struct stat st;
 762:   register int fd;
 763:   register int n, i;
 764:   int count = specpdl_ptr - specpdl;
 765: 
 766:   if (!NULL (bf_cur->read_only))
 767:     Fbarf_if_buffer_read_only();
 768: 
 769:   CHECK_STRING (filename, 0);
 770:   filename = Fexpand_file_name (filename, Qnil);
 771: 
 772:   if (stat (XSTRING (filename)->data, &st) < 0
 773:     || (fd = open (XSTRING (filename)->data, 0)) < 0)
 774:     report_file_error ("Opening input file", Fcons (filename, Qnil));
 775: 
 776:   record_unwind_protect (close_file_unwind, make_number (fd));
 777: 
 778:   if (NULL (visit))
 779:     prepare_to_modify_buffer ();
 780: 
 781:   RecordInsert (point, st.st_size);
 782:   bf_modified++;
 783: 
 784:   GapTo (point);
 785:   if (bf_gap < st.st_size)
 786:     make_gap (st.st_size);
 787: 
 788:   n = 0;
 789:   while ((i = read (fd, bf_p1 + bf_s1 + 1, st.st_size - n)) > 0)
 790:     {
 791:       bf_s1 += i;
 792:       bf_gap -= i;
 793:       bf_p2 -= i;
 794:       n += i;
 795:     }
 796: 
 797:   if (!NULL (visit))
 798:     DoneIsDone ();
 799: 
 800:   close (fd);
 801:   /* Discard the unwind protect */
 802:   specpdl_ptr = specpdl + count;
 803: 
 804:   if (i < 0)
 805:     error ("IO error reading %s", XSTRING (filename)->data);
 806: 
 807:   if (!NULL (visit))
 808:     {
 809:       bf_cur->modtime = st.st_mtime;
 810:       bf_cur->save_modified = bf_modified;
 811:       bf_cur->auto_save_modified = bf_modified;
 812:       XFASTINT (bf_cur->save_length) = NumCharacters;
 813: #ifdef CLASH_DETECTION
 814:       if (!NULL (bf_cur->filename))
 815:     unlock_file (bf_cur->filename);
 816:       unlock_file (filename);
 817: #endif /* CLASH_DETECTION */
 818:       bf_cur->filename = filename;
 819:     }
 820: 
 821:   return Fcons (filename, Fcons (make_number (st.st_size), Qnil));
 822: }
 823: 
 824: DEFUN ("write-region", Fwrite_region, Swrite_region, 3, 5,
 825:   "r\nFWrite region to file: ",
 826:   "Write current region into specified file.\n\
 827: When called from a program, takes three arguments:\n\
 828: START, END and FILENAME.  START and END are buffer positions.\n\
 829: Optional fourth argument APPEND if non-nil means\n\
 830:   append to existing file contents (if any).\n\
 831: Optional fifth argument VISIT if t means\n\
 832:   set last-save-file-modtime of buffer to this file's modtime\n\
 833:   and mark buffer not modified.\n\
 834: If VISIT is neither t nor nil, it means do not print\n\
 835:   the \"Wrote file\" message.")
 836:   (start, end, filename, append, visit)
 837:      Lisp_Object start, end, filename, append, visit;
 838: {
 839:   register int fd;
 840:   int failure = 0;
 841:   unsigned char *fn;
 842:   struct stat st;
 843:   int tem;
 844:   int count = specpdl_ptr - specpdl;
 845: 
 846:   /* Special kludge to simplify auto-saving */
 847:   if (NULL (start))
 848:     {
 849:       XFASTINT (start) = 1;
 850:       XFASTINT (end) = 1 + bf_s1 + bf_s2;
 851:     }
 852:   else
 853:     validate_region (&start, &end);
 854: 
 855:   filename = Fexpand_file_name (filename, Qnil);
 856:   fn = XSTRING (filename)->data;
 857: 
 858: #ifdef CLASH_DETECTION
 859:   if (!auto_saving)
 860:     lock_file (filename);
 861: #endif /* CLASH_DETECTION */
 862: 
 863:   fd = -1;
 864:   if (!NULL (append))
 865:     fd = open (fn, 1);
 866: 
 867:   if (fd < 0)
 868:     fd = creat (fn, 0666);
 869: 
 870:   if (fd < 0)
 871:     {
 872: #ifdef CLASH_DETECTION
 873:       if (!auto_saving) unlock_file (filename);
 874: #endif /* CLASH_DETECTION */
 875:       report_file_error ("Opening output file", Fcons (filename, Qnil));
 876:     }
 877: 
 878:   record_unwind_protect (close_file_unwind, make_number (fd));
 879: 
 880:   if (!NULL (append))
 881:     if (lseek (fd, 0, 2) < 0)
 882:       {
 883: #ifdef CLASH_DETECTION
 884:     if (!auto_saving) unlock_file (filename);
 885: #endif /* CLASH_DETECTION */
 886:     report_file_error ("Lseek error", Fcons (filename, Qnil));
 887:       }
 888: 
 889:   failure = 0;
 890:   if (XINT (start) != XINT (end))
 891:     {
 892:       if (XINT (start) - 1 < bf_s1)
 893:     failure = 0 > e_write (fd, &CharAt (XINT (start)),
 894:                    min (bf_s1 + 1, XINT (end)) - XINT (start));
 895: 
 896:       if (XINT (end) - 1 > bf_s1 && !failure)
 897:     {
 898:       tem = max (XINT (start), bf_s1 + 1);
 899:       failure = 0 > e_write (fd, &CharAt (tem), XINT (end) - tem);
 900:     }
 901:     }
 902: 
 903:   fstat (fd, &st);
 904:   close (fd);
 905:   /* Discard the unwind protect */
 906:   specpdl_ptr = specpdl + count;
 907: 
 908: #ifdef CLASH_DETECTION
 909:   if (!auto_saving)
 910:     unlock_file (filename);
 911: #endif /* CLASH_DETECTION */
 912: 
 913:   if (failure)
 914:     error ("IO error writing %s", fn);
 915: 
 916:   if (EQ (visit, Qt))
 917:     {
 918:       bf_cur->modtime = st.st_mtime;
 919:       bf_cur->save_modified = bf_modified;
 920:       XFASTINT (bf_cur->save_length) = NumCharacters;
 921:       bf_cur->filename = filename;
 922:     }
 923:   else if (!NULL (visit))
 924:     return Qnil;
 925: 
 926:   if (!auto_saving)
 927:     message ("Wrote %s", fn);
 928: 
 929:   return Qnil;
 930: }
 931: 
 932: int
 933: e_write (fd, addr, len)
 934:      int fd;
 935:      register char *addr;
 936:      register int len;
 937: {
 938:   char buf[1024];
 939:   register char *p, *end;
 940: 
 941:   if (!EQ (bf_cur->selective_display, Qt))
 942:     return write (fd, addr, len) - len;
 943:   else
 944:     {
 945:       p = buf;
 946:       end = p + sizeof buf;
 947:       while (len--)
 948:     {
 949:       if (p == end)
 950:         {
 951:           if (write (fd, buf, sizeof buf) != sizeof buf)
 952:         return -1;
 953:           p = buf;
 954:         }
 955:       *p = *addr++;
 956:       if (*p++ == '\015')
 957:         p[-1] = '\n';
 958:     }
 959:       if (p != buf)
 960:     if (write (fd, buf, p - buf) != p - buf)
 961:       return -1;
 962:     }
 963:   return 0;
 964: }
 965: 
 966: DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime,
 967:   Sverify_visited_file_modtime, 1, 1, 0,
 968:   "Return t if last mod time of BUF's visited file matches what BUF records.\n\
 969: This means that the file has not been changed since it was visited or saved.")
 970:   (buf)
 971:      Lisp_Object buf;
 972: {
 973:   struct buffer *b = XBUFFER (buf);
 974:   struct stat st;
 975: 
 976:   CHECK_BUFFER (buf, 0);
 977: 
 978:   if (XTYPE (b->filename) != Lisp_String) return Qt;
 979:   if (!b->modtime) return Qt;
 980:   if (stat (XSTRING (b->filename)->data, &st) < 0)
 981:     return Qnil;
 982:   if (st.st_mtime != b->modtime)
 983:     return Qnil;
 984:   return Qt;
 985: }
 986: 
 987: DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime,
 988:   Sclear_visited_file_modtime, 0, 0, 0,
 989:   "Clear out records of last mod time of visited file.\n\
 990: Next attempt to save will certainly not complain of a discrepancy.")
 991:   ()
 992: {
 993:   bf_cur->modtime = 0;
 994:   return Qnil;
 995: }
 996: 
 997: Lisp_Object
 998: auto_save_error ()
 999: {
1000:   return Qnil;
1001: }
1002: 
1003: Lisp_Object
1004: auto_save_1 ()
1005: {
1006:   return
1007:     Fwrite_region (Qnil, Qnil,
1008:            bf_cur->auto_save_file_name,
1009:            Qnil, Qlambda);
1010: }
1011: 
1012: DEFUN ("do-auto-save", Fdo_auto_save, Sdo_auto_save, 0, 1, "",
1013:   "Auto-save all buffers that need it.\n\
1014: This is all buffers that have auto-saving enabled\n\
1015: and are changed since last auto-saved.\n\
1016: Auto-saving writes the buffer into a file\n\
1017: so that your editing is not lost if the system crashes.\n\
1018: This file is not the file you visited; that changes only when you save.\n\n\
1019: Non-nil argument means do not print any message.")
1020:   (nomsg)
1021:      Lisp_Object nomsg;
1022: {
1023:   struct buffer *old = bf_cur, *b;
1024:   Lisp_Object tail, buf;
1025:   int auto_saved = 0;
1026:   char *omessage = minibuf_message;
1027:   extern MinibufDepth;
1028: 
1029:   auto_saving = 1;
1030:   if (MinibufDepth)
1031:     nomsg = Qt;
1032: 
1033:   bf_cur->text = bf_text;
1034: 
1035:   for (tail = Vbuffer_alist; XGCTYPE (tail) == Lisp_Cons;
1036:        tail = XCONS (tail)->cdr)
1037:     {
1038:       buf = XCONS (XCONS (tail)->car)->cdr;
1039:       b = XBUFFER (buf);
1040:       /* Check for auto save enabled
1041: 	 and file changed since last auto save
1042: 	 and file changed since last real save.  */
1043:       if (XTYPE (b->auto_save_file_name) == Lisp_String
1044:       && b->save_modified < b->text.modified
1045:       && b->auto_save_modified < b->text.modified)
1046:     {
1047:       if (XFASTINT (b->save_length) * 10
1048:           > (b->text.size1 + b->text.size2) * 13)
1049:         {
1050:           /* It has shrunk too much; don't chckpoint. */
1051:         /*** Should report this to user somehow ***/
1052:           continue;
1053:         }
1054:       SetBfp (b);
1055:       if (!auto_saved && NULL (nomsg))
1056:         message1 ("Auto-saving...");
1057:       internal_condition_case (auto_save_1, Qt, auto_save_error);
1058:       auto_saved++;
1059:       b->auto_save_modified = b->text.modified;
1060:       XFASTINT (bf_cur->save_length) = NumCharacters;
1061:       SetBfp (old);
1062:     }
1063:     }
1064: 
1065:   if (auto_saved && NULL (nomsg))
1066:     message1 (omessage ? omessage : "Auto-saving...done");
1067: 
1068:   auto_saving = 0;
1069:   return Qnil;
1070: }
1071: 
1072: DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved,
1073:   Sset_buffer_auto_saved, 0, 0, 0,
1074:   "Mark current buffer as auto-saved with its current text.\n\
1075: No auto-save file will be written until the buffer changes again.")
1076:   ()
1077: {
1078:   bf_cur->auto_save_modified = bf_modified;
1079:   return Qnil;
1080: }
1081: 
1082: DEFUN ("recent-auto-save-p", Frecent_auto_save_p, Srecent_auto_save_p,
1083:   0, 0, 0,
1084:   "Return t if buffer has been auto-saved since last read in or saved.")
1085:   ()
1086: {
1087:   return (bf_cur->save_modified < bf_cur->auto_save_modified) ? Qt : Qnil;
1088: }
1089: 
1090: /* Reading and completing file names */
1091: extern Lisp_Object Ffile_name_completion (), Ffile_name_all_completions ();
1092: 
1093: DEFUN ("read-file-name-internal", Fread_file_name_internal, Sread_file_name_internal,
1094:   3, 3, 0,
1095:   "Internal subroutine for read-file-name.  Do not call this.")
1096:   (string, dir, action)
1097:      Lisp_Object string, dir, action;
1098:   /* action is nil for complete, t for return list of completions,
1099:      lambda for verify final value */
1100: {
1101:   Lisp_Object name, specdir, realdir, val;
1102:   if (XSTRING (string)->size == 0)
1103:     {
1104:       name = string;
1105:       realdir = dir;
1106:       if (EQ (action, Qlambda))
1107:     return Qnil;
1108:     }
1109:   else
1110:     {
1111:       string = Fsubstitute_in_file_name (string);
1112:       name = Ffile_name_nondirectory (string);
1113:       realdir = Ffile_name_directory (string);
1114:       if (NULL (realdir))
1115:     realdir = dir;
1116:       else
1117:     realdir = Fexpand_file_name (realdir, dir);
1118:     }
1119: 
1120:   if (NULL (action))
1121:     {
1122:       specdir = Ffile_name_directory (string);
1123:       val = Ffile_name_completion (name, realdir);
1124:       if (XTYPE (val) == Lisp_String && !NULL (specdir))
1125:     return concat2 (specdir, val);
1126:       return val;
1127:     }
1128:   if (EQ (action, Qt))
1129:     return Ffile_name_all_completions (name, realdir);
1130:   /* Only other case actually used is ACTION = lambda */
1131:   return Ffile_exists_p (string);
1132: }
1133: 
1134: DEFUN ("read-file-name", Fread_file_name, Sread_file_name, 1, 4, 0,
1135:   "Read file name, prompting with PROMPT and completing in directory DIR.\n\
1136: Value is not expanded!  You must call expand-file-name yourself.\n\
1137: Default name to DEFAULT if user enters a null string.\n\
1138: Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
1139:  Non-nil and non-t means also require confirmation after completion.\n\
1140: DIR defaults to current buffer's directory default.")
1141:   (prompt, dir, defalt, mustmatch)
1142:      Lisp_Object prompt, dir, defalt, mustmatch;
1143: {
1144:   Lisp_Object val, insdef, tem;
1145:   struct gcpro gcpro1, gcpro2;
1146:   register char *homedir;
1147: 
1148:   if (NULL (dir))
1149:     dir = bf_cur->directory;
1150:   if (NULL (defalt))
1151:     defalt = bf_cur->filename;
1152: 
1153:   /* If dir starts with user's homedir, change that to ~. */
1154:   homedir = (char *) getenv ("HOME");
1155:   if (XTYPE (dir) == Lisp_String
1156:       && !strncmp (homedir, XSTRING (dir)->data, strlen (homedir))
1157:       && XSTRING (dir)->data[strlen (homedir)] == '/')
1158:     {
1159:       dir = make_string (XSTRING (dir)->data + strlen (homedir) - 1,
1160:              XSTRING (dir)->size - strlen (homedir) + 1);
1161:       XSTRING (dir)->data[0] = '~';
1162:     }
1163: 
1164:   if (insert_default_directory)
1165:     insdef = dir;
1166:   else
1167:     insdef = build_string ("");
1168: 
1169:   GCPRO2 (insdef, defalt);
1170:   val = Fcompleting_read (prompt, intern ("read-file-name-internal"),
1171:               dir, mustmatch,
1172:               insert_default_directory ? insdef : Qnil);
1173:   UNGCPRO;
1174:   if (NULL (val))
1175:     error ("No file name specified");
1176:   tem = Fstring_equal (val, insdef);
1177:   if (!NULL (tem) && !NULL (defalt))
1178:     return defalt;
1179:   return Fsubstitute_in_file_name (val);
1180: }
1181: 
1182: syms_of_fileio ()
1183: {
1184:   Qfile_error = intern ("file-error");
1185:   staticpro (&Qfile_error);
1186:   Qfile_already_exists = intern("file-already-exists");
1187:   staticpro (&Qfile_already_exists);
1188: 
1189:   Fput (Qfile_error, Qerror_conditions,
1190:     Fcons (Qfile_error, Fcons (Qerror, Qnil)));
1191:   Fput (Qfile_error, Qerror_message,
1192:     build_string ("File error"));
1193: 
1194:   Fput (Qfile_already_exists, Qerror_conditions,
1195:     Fcons (Qfile_already_exists,
1196:            Fcons (Qfile_error, Fcons (Qerror, Qnil))));
1197:   Fput (Qfile_already_exists, Qerror_message,
1198:     build_string ("File already exists"));
1199: 
1200:   DefBoolVar ("insert-default-directory", &insert_default_directory,
1201:     "*Non-nil means when reading a filename start with default dir in minibuffer.");
1202:   insert_default_directory = 1;
1203: 
1204:   defsubr (&Sfile_name_directory);
1205:   defsubr (&Sfile_name_nondirectory);
1206:   defsubr (&Smake_temp_name);
1207:   defsubr (&Sexpand_file_name);
1208:   defsubr (&Ssubstitute_in_file_name);
1209:   defsubr (&Scopy_file);
1210:   defsubr (&Sdelete_file);
1211:   defsubr (&Srename_file);
1212:   defsubr (&Sadd_name_to_file);
1213: #ifdef S_IFLNK
1214:   defsubr (&Smake_symbolic_link);
1215: #endif /* S_IFLNK */
1216:   defsubr (&Sfile_exists_p);
1217:   defalias (&Sfile_exists_p, "file-readable-p");
1218:   defsubr (&Sfile_writable_p);
1219:   defsubr (&Sfile_symlink_p);
1220:   defsubr (&Sfile_directory_p);
1221:   defsubr (&Sfile_modes);
1222:   defsubr (&Sset_file_modes);
1223:   defsubr (&Sinsert_file_contents);
1224:   defsubr (&Swrite_region);
1225:   defsubr (&Sverify_visited_file_modtime);
1226:   defsubr (&Sclear_visited_file_modtime);
1227:   defsubr (&Sdo_auto_save);
1228:   defsubr (&Sset_buffer_auto_saved);
1229:   defsubr (&Srecent_auto_save_p);
1230: 
1231:   defsubr (&Sread_file_name_internal);
1232:   defsubr (&Sread_file_name);
1233: }

Defined functions

Defined variables

Defined macros