1 /* File IO for GNU Emacs. 2 Copyright (C) 1985, 1986, 1987, 1988, 1990 Free Software Foundation, Inc. 3 4 This file is part of GNU Emacs. 5 6 GNU Emacs is free software; you can redistribute it and/or modify 7 it under the terms of the GNU General Public License as published by 8 the Free Software Foundation; either version 1, or (at your option) 9 any later version. 10 11 GNU Emacs is distributed in the hope that it will be useful, 12 but WITHOUT ANY WARRANTY; without even the implied warranty of 13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 GNU General Public License for more details. 15 16 You should have received a copy of the GNU General Public License 17 along with GNU Emacs; see the file COPYING. If not, write to 18 the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ 19 20 21 #include <sys/types.h> 22 #ifdef hpux 23 /* needed by <pwd.h> */ 24 #include <stdio.h> 25 #undef NULL 26 #endif 27 #include <sys/stat.h> 28 #include <pwd.h> 29 #include <ctype.h> 30 #include <sys/dir.h> 31 #include <errno.h> 32 33 #ifndef VMS 34 extern int errno; 35 extern char *sys_errlist[]; 36 extern int sys_nerr; 37 #endif 38 39 #define err_str(a) ((a) < sys_nerr ? sys_errlist[a] : "unknown error") 40 41 #ifdef APOLLO 42 #include <sys/time.h> 43 #endif 44 45 #ifdef NULL 46 #undef NULL 47 #endif 48 #include "config.h" 49 #include "lisp.h" 50 #include "buffer.h" 51 #include "window.h" 52 53 #ifdef VMS 54 #include <perror.h> 55 #include <file.h> 56 #include <rmsdef.h> 57 #include <fab.h> 58 #include <nam.h> 59 #endif 60 61 #ifdef HAVE_TIMEVAL 62 #ifdef HPUX 63 #include <time.h> 64 #else 65 #include <sys/time.h> 66 #endif 67 #endif 68 69 #ifdef HPUX 70 #include <netio.h> 71 #include <errnet.h> 72 #endif 73 74 #ifndef O_WRONLY 75 #define O_WRONLY 1 76 #endif 77 78 #define min(a, b) ((a) < (b) ? (a) : (b)) 79 #define max(a, b) ((a) > (b) ? (a) : (b)) 80 81 /* Nonzero during writing of auto-save files */ 82 int auto_saving; 83 84 /* Nonzero means, when reading a filename in the minibuffer, 85 start out by inserting the default directory into the minibuffer. */ 86 int insert_default_directory; 87 88 /* On VMS, nonzero means write new files with record format stmlf. 89 Zero means use var format. */ 90 int vms_stmlf_recfm; 91 92 Lisp_Object Qfile_error, Qfile_already_exists; 93 94 report_file_error (string, data) 95 char *string; 96 Lisp_Object data; 97 { 98 Lisp_Object errstring; 99 100 if (errno >= 0 && errno < sys_nerr) 101 errstring = build_string (sys_errlist[errno]); 102 else 103 errstring = build_string ("undocumented error code"); 104 105 /* System error messages are capitalized. Downcase the initial. */ 106 XSTRING (errstring)->data[0] = DOWNCASE (XSTRING (errstring)->data[0]); 107 108 while (1) 109 Fsignal (Qfile_error, 110 Fcons (build_string (string), Fcons (errstring, data))); 111 } 112 113 DEFUN ("file-name-directory", Ffile_name_directory, Sfile_name_directory, 114 1, 1, 0, 115 "Return the directory component in file name NAME.\n\ 116 Return nil if NAME does not include a directory.\n\ 117 Otherwise returns a directory spec.\n\ 118 Given a Unix syntax file name, returns a string ending in slash;\n\ 119 on VMS, perhaps instead a string ending in :, ] or >.") 120 (file) 121 Lisp_Object file; 122 { 123 register unsigned char *beg; 124 register unsigned char *p; 125 126 CHECK_STRING (file, 0); 127 128 beg = XSTRING (file)->data; 129 p = beg + XSTRING (file)->size; 130 131 while (p != beg && p[-1] != '/' 132 #ifdef VMS 133 && p[-1] != ':' && p[-1] != ']' && p[-1] != '>' 134 #endif /* VMS */ 135 ) p--; 136 137 if (p == beg) 138 return Qnil; 139 return make_string (beg, p - beg); 140 } 141 142 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory, Sfile_name_nondirectory, 143 1, 1, 0, 144 "Return file name NAME sans its directory.\n\ 145 For example, in a Unix-syntax file name,\n\ 146 this is everything after the last slash,\n\ 147 or the entire name if it contains no slash.") 148 (file) 149 Lisp_Object file; 150 { 151 register unsigned char *beg, *p, *end; 152 153 CHECK_STRING (file, 0); 154 155 beg = XSTRING (file)->data; 156 end = p = beg + XSTRING (file)->size; 157 158 while (p != beg && p[-1] != '/' 159 #ifdef VMS 160 && p[-1] != ':' && p[-1] != ']' && p[-1] != '>' 161 #endif /* VMS */ 162 ) p--; 163 164 return make_string (p, end - p); 165 } 166 167 char * 168 file_name_as_directory (out, in) 169 char *out, *in; 170 { 171 int size = strlen (in) - 1; 172 173 strcpy (out, in); 174 175 #ifdef VMS 176 /* Is it already a directory string? */ 177 if (in[size] == ':' || in[size] == ']' || in[size] == '>') 178 return out; 179 /* Is it a VMS directory file name? If so, hack VMS syntax. */ 180 else if (! index (in, '/') 181 && ((size > 3 && ! strcmp (&in[size - 3], ".DIR")) 182 || (size > 3 && ! strcmp (&in[size - 3], ".dir")) 183 || (size > 5 && (! strncmp (&in[size - 5], ".DIR", 4) 184 || ! strncmp (&in[size - 5], ".dir", 4)) 185 && (in[size - 1] == '.' || in[size - 1] == ';') 186 && in[size] == '1'))) 187 { 188 register char *p, *dot; 189 char brack; 190 191 /* x.dir -> [.x] 192 dir:x.dir --> dir:[x] 193 dir:[x]y.dir --> dir:[x.y] */ 194 p = in + size; 195 while (p != in && *p != ':' && *p != '>' && *p != ']') p--; 196 if (p != in) 197 { 198 strncpy (out, in, p - in); 199 out[p - in] = '\0'; 200 if (*p == ':') 201 { 202 brack = ']'; 203 strcat (out, ":["); 204 } 205 else 206 { 207 brack = *p; 208 strcat (out, "."); 209 } 210 p++; 211 } 212 else 213 { 214 brack = ']'; 215 strcpy (out, "[."); 216 } 217 if (dot = index (p, '.')) 218 { 219 /* blindly remove any extension */ 220 size = strlen (out) + (dot - p); 221 strncat (out, p, dot - p); 222 } 223 else 224 { 225 strcat (out, p); 226 size = strlen (out); 227 } 228 out[size++] = brack; 229 out[size] = '\0'; 230 } 231 #else /* not VMS */ 232 /* For Unix syntax, Append a slash if necessary */ 233 if (out[size] != '/') 234 strcat (out, "/"); 235 #endif /* not VMS */ 236 return out; 237 } 238 239 DEFUN ("file-name-as-directory", Ffile_name_as_directory, 240 Sfile_name_as_directory, 1, 1, 0, 241 "Return a string representing file FILENAME interpreted as a directory.\n\ 242 This string can be used as the value of default-directory\n\ 243 or passed as second argument to expand-file-name.\n\ 244 For a Unix-syntax file name, just appends a slash.\n\ 245 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.") 246 (file) 247 Lisp_Object file; 248 { 249 char *buf; 250 251 CHECK_STRING (file, 0); 252 if (NULL (file)) 253 return Qnil; 254 buf = (char *) alloca (XSTRING (file)->size + 10); 255 return build_string (file_name_as_directory (buf, XSTRING (file)->data)); 256 } 257 258 /* 259 * Convert from directory name to filename. 260 * On VMS: 261 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1 262 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1 263 * On UNIX, it's simple: just make sure there is a terminating / 264 265 * Value is nonzero if the string output is different from the input. 266 */ 267 268 directory_file_name (src, dst) 269 char *src, *dst; 270 { 271 long slen; 272 #ifdef VMS 273 long rlen; 274 char * ptr, * rptr; 275 char bracket; 276 struct FAB fab = cc$rms_fab; 277 struct NAM nam = cc$rms_nam; 278 char esa[NAM$C_MAXRSS]; 279 #endif /* VMS */ 280 281 slen = strlen (src) - 1; 282 #ifdef VMS 283 if (! index (src, '/') 284 && (src[slen] == ']' || src[slen] == ':' || src[slen] == '>')) 285 { 286 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */ 287 fab.fab$l_fna = src; 288 fab.fab$b_fns = slen + 1; 289 fab.fab$l_nam = &nam; 290 fab.fab$l_fop = FAB$M_NAM; 291 292 nam.nam$l_esa = esa; 293 nam.nam$b_ess = sizeof esa; 294 nam.nam$b_nop |= NAM$M_SYNCHK; 295 296 /* We call SYS$PARSE to handle such things as [--] for us. */ 297 if (SYS$PARSE(&fab, 0, 0) == RMS$_NORMAL) 298 { 299 slen = nam.nam$b_esl - 1; 300 if (esa[slen] == ';' && esa[slen - 1] == '.') 301 slen -= 2; 302 esa[slen + 1] = '\0'; 303 src = esa; 304 } 305 if (src[slen] != ']' && src[slen] != '>') 306 { 307 /* what about when we have logical_name:???? */ 308 if (src[slen] == ':') 309 { /* Xlate logical name and see what we get */ 310 ptr = strcpy (dst, src); /* upper case for getenv */ 311 while (*ptr) 312 { 313 if ('a' <= *ptr && *ptr <= 'z') 314 *ptr -= 040; 315 ptr++; 316 } 317 dst[slen] = 0; /* remove colon */ 318 if (!(src = egetenv (dst))) 319 return 0; 320 /* should we jump to the beginning of this procedure? 321 Good points: allows us to use logical names that xlate 322 to Unix names, 323 Bad points: can be a problem if we just translated to a device 324 name... 325 For now, I'll punt and always expect VMS names, and hope for 326 the best! */ 327 slen = strlen (src) - 1; 328 if (src[slen] != ']' && src[slen] != '>') 329 { /* no recursion here! */ 330 strcpy (dst, src); 331 return 0; 332 } 333 } 334 else 335 { /* not a directory spec */ 336 strcpy (dst, src); 337 return 0; 338 } 339 } 340 bracket = src[slen]; 341 if (!(ptr = index (src, bracket - 2))) 342 { /* no opening bracket */ 343 strcpy (dst, src); 344 return 0; 345 } 346 if (!(rptr = rindex (src, '.'))) 347 rptr = ptr; 348 slen = rptr - src; 349 strncpy (dst, src, slen); 350 dst[slen] = '\0'; 351 if (*rptr == '.') 352 { 353 dst[slen++] = bracket; 354 dst[slen] = '\0'; 355 } 356 else 357 { 358 /* If we have the top-level of a rooted directory (i.e. xx:[000000]), 359 then translate the device and recurse. */ 360 if (dst[slen - 1] == ':' 361 && dst[slen - 2] != ':' /* skip decnet nodes */ 362 && strcmp(src + slen, "[000000]") == 0) 363 { 364 dst[slen - 1] = '\0'; 365 if ((ptr = egetenv (dst)) 366 && (rlen = strlen (ptr) - 1) > 0 367 && (ptr[rlen] == ']' || ptr[rlen] == '>') 368 && ptr[rlen - 1] == '.') 369 { 370 ptr[rlen - 1] = ']'; 371 ptr[rlen] = '\0'; 372 return directory_file_name (ptr, dst); 373 } 374 else 375 dst[slen - 1] = ':'; 376 } 377 strcat (dst, "[000000]"); 378 slen += 8; 379 } 380 rptr++; 381 rlen = strlen (rptr) - 1; 382 strncat (dst, rptr, rlen); 383 dst[slen + rlen] = '\0'; 384 strcat (dst, ".DIR.1"); 385 return 1; 386 } 387 #endif /* VMS */ 388 /* Process as Unix format: just remove any final slash. 389 But leave "/" unchanged; do not change it to "". */ 390 strcpy (dst, src); 391 if (dst[slen] == '/' && slen > 1) 392 dst[slen] = 0; 393 return 1; 394 } 395 396 DEFUN ("directory-file-name", Fdirectory_file_name, Sdirectory_file_name, 397 1, 1, 0, 398 "Returns the file name of the directory named DIR.\n\ 399 This is the name of the file that holds the data for the directory DIR.\n\ 400 In Unix-syntax, this just removes the final slash.\n\ 401 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\ 402 returns a file name such as \"[X]Y.DIR.1\".") 403 (directory) 404 Lisp_Object directory; 405 { 406 char *buf; 407 408 CHECK_STRING (directory, 0); 409 410 if (NULL (directory)) 411 return Qnil; 412 #ifdef VMS 413 /* 20 extra chars is insufficient for VMS, since we might perform a 414 logical name translation. an equivalence string can be up to 255 415 chars long, so grab that much extra space... - sss */ 416 buf = (char *) alloca (XSTRING (directory)->size + 20 + 255); 417 #else 418 buf = (char *) alloca (XSTRING (directory)->size + 20); 419 #endif 420 directory_file_name (XSTRING (directory)->data, buf); 421 return build_string (buf); 422 } 423 424 DEFUN ("make-temp-name", Fmake_temp_name, Smake_temp_name, 1, 1, 0, 425 "Generate temporary name (string) starting with PREFIX (a string).") 426 (prefix) 427 Lisp_Object prefix; 428 { 429 Lisp_Object val; 430 val = concat2 (prefix, build_string ("XXXXXX")); 431 mktemp (XSTRING (val)->data); 432 return val; 433 } 434 435 DEFUN ("expand-file-name", Fexpand_file_name, Sexpand_file_name, 1, 2, 0, 436 "Convert FILENAME to absolute, and canonicalize it.\n\ 437 Second arg DEFAULT is directory to start with if FILENAME is relative\n\ 438 (does not start with slash); if DEFAULT is nil or missing,\n\ 439 the current buffer's value of default-directory is used.\n\ 440 Filenames containing . or .. as components are simplified;\n\ 441 initial ~ is expanded. See also the function substitute-in-file-name.") 442 (name, defalt) 443 Lisp_Object name, defalt; 444 { 445 unsigned char *nm; 446 447 register unsigned char *newdir, *p, *o; 448 int tlen; 449 unsigned char *target; 450 struct passwd *pw; 451 int lose; 452 #ifdef VMS 453 unsigned char * colon = 0; 454 unsigned char * close = 0; 455 unsigned char * slash = 0; 456 unsigned char * brack = 0; 457 int lbrack = 0, rbrack = 0; 458 int dots = 0; 459 #endif /* VMS */ 460 461 CHECK_STRING (name, 0); 462 463 #ifdef VMS 464 /* Filenames on VMS are always upper case. */ 465 name = Fupcase (name); 466 #endif 467 468 nm = XSTRING (name)->data; 469 470 /* If nm is absolute, flush ...// and detect /./ and /../. 471 If no /./ or /../ we can return right away. */ 472 if ( 473 nm[0] == '/' 474 #ifdef VMS 475 || index (nm, ':') 476 #endif /* VMS */ 477 ) 478 { 479 p = nm; 480 lose = 0; 481 while (*p) 482 { 483 if (p[0] == '/' && p[1] == '/' 484 #ifdef APOLLO 485 /* // at start of filename is meaningful on Apollo system */ 486 && nm != p 487 #endif /* APOLLO */ 488 ) 489 nm = p + 1; 490 if (p[0] == '/' && p[1] == '~') 491 nm = p + 1, lose = 1; 492 if (p[0] == '/' && p[1] == '.' 493 && (p[2] == '/' || p[2] == 0 494 || (p[2] == '.' && (p[3] == '/' || p[3] == 0)))) 495 lose = 1; 496 #ifdef VMS 497 if (p[0] == '\\') 498 lose = 1; 499 if (p[0] == '/') { 500 /* if dev:[dir]/, move nm to / */ 501 if (!slash && p > nm && (brack || colon)) { 502 nm = (brack ? brack + 1 : colon + 1); 503 lbrack = rbrack = 0; 504 brack = 0; 505 colon = 0; 506 } 507 slash = p; 508 } 509 if (p[0] == '-') 510 #ifndef VMS4_4 511 /* VMS pre V4.4,convert '-'s in filenames. */ 512 if (lbrack == rbrack) 513 { 514 if (dots < 2) /* this is to allow negative version numbers */ 515 p[0] = '_'; 516 } 517 else 518 #endif /* VMS4_4 */ 519 if (lbrack > rbrack && 520 ((p[-1] == '.' || p[-1] == '[' || p[-1] == '<') && 521 (p[1] == '.' || p[1] == ']' || p[1] == '>'))) 522 lose = 1; 523 #ifndef VMS4_4 524 else 525 p[0] = '_'; 526 #endif /* VMS4_4 */ 527 /* count open brackets, reset close bracket pointer */ 528 if (p[0] == '[' || p[0] == '<') 529 lbrack++, brack = 0; 530 /* count close brackets, set close bracket pointer */ 531 if (p[0] == ']' || p[0] == '>') 532 rbrack++, brack = p; 533 /* detect ][ or >< */ 534 if ((p[0] == ']' || p[0] == '>') && (p[1] == '[' || p[1] == '<')) 535 lose = 1; 536 if ((p[0] == ':' || p[0] == ']' || p[0] == '>') && p[1] == '~') 537 nm = p + 1, lose = 1; 538 if (p[0] == ':' && (colon || slash)) 539 /* if dev1:[dir]dev2:, move nm to dev2: */ 540 if (brack) 541 { 542 nm = brack + 1; 543 brack = 0; 544 } 545 /* if /pathname/dev:, move nm to dev: */ 546 else if (slash) 547 nm = slash + 1; 548 /* if node::dev:, move colon following dev */ 549 else if (colon && colon[-1] == ':') 550 colon = p; 551 /* if dev1:dev2:, move nm to dev2: */ 552 else if (colon && colon[-1] != ':') 553 { 554 nm = colon + 1; 555 colon = 0; 556 } 557 if (p[0] == ':' && !colon) 558 { 559 if (p[1] == ':') 560 p++; 561 colon = p; 562 } 563 if (lbrack == rbrack) 564 if (p[0] == ';') 565 dots = 2; 566 else if (p[0] == '.') 567 dots++; 568 #endif /* VMS */ 569 p++; 570 } 571 if (!lose) 572 { 573 #ifdef VMS 574 if (index (nm, '/')) 575 return build_string (sys_translate_unix (nm)); 576 #endif /* VMS */ 577 if (nm == XSTRING (name)->data) 578 return name; 579 return build_string (nm); 580 } 581 } 582 583 /* Now determine directory to start with and put it in NEWDIR. */ 584 585 newdir = 0; 586 587 if (nm[0] == '~') 588 { 589 if (nm[1] == '/' 590 #ifdef VMS 591 || nm[1] == ':' 592 #endif /* VMS */ 593 || nm[1] == 0) 594 { 595 /* Handle ~ on its own. */ 596 newdir = (unsigned char *) egetenv ("HOME"); 597 } 598 else 599 { 600 /* Handle ~ followed by user name. */ 601 unsigned char *user = nm + 1; 602 /* Find end of name. */ 603 unsigned char *ptr = (unsigned char *) index (user, '/'); 604 int len = ptr ? ptr - user : strlen (user); 605 #ifdef VMS 606 unsigned char *ptr1 = index (user, ':'); 607 if (ptr1 != 0 && ptr1 - user < len) 608 len = ptr1 - user; 609 #endif /* VMS */ 610 /* Copy the user name into temp storage. */ 611 o = (unsigned char *) alloca (len + 1); 612 bcopy ((char *) user, o, len); 613 o[len] = 0; 614 615 /* Look up the user name. */ 616 pw = (struct passwd *) getpwnam (o); 617 if (!pw) 618 error ("User \"%s\" is not known", o); 619 newdir = (unsigned char *) pw->pw_dir; 620 621 /* Discard the user name from NM. */ 622 nm += len; 623 } 624 625 /* Discard the ~ from NM. */ 626 nm++; 627 #ifdef VMS 628 if (*nm != 0) 629 nm++; /* Don't leave the slash in nm. */ 630 #endif /* VMS */ 631 632 if (newdir == 0) 633 newdir = (unsigned char *) ""; 634 } 635 636 if (nm[0] != '/' 637 #ifdef VMS 638 && !index (nm, ':') 639 #endif /* not VMS */ 640 && !newdir) 641 { 642 if (NULL (defalt)) 643 defalt = current_buffer->directory; 644 CHECK_STRING (defalt, 1); 645 newdir = XSTRING (defalt)->data; 646 } 647 648 /* Now concatenate the directory and name to new space in the stack frame */ 649 650 tlen = (newdir ? strlen (newdir) + 1 : 0) + strlen (nm) + 1; 651 target = (unsigned char *) alloca (tlen); 652 *target = 0; 653 654 if (newdir) 655 { 656 #ifndef VMS 657 if (nm[0] == 0 || nm[0] == '/') 658 strcpy (target, newdir); 659 else 660 #endif 661 file_name_as_directory (target, newdir); 662 } 663 664 strcat (target, nm); 665 #ifdef VMS 666 if (index (target, '/')) 667 strcpy (target, sys_translate_unix (target)); 668 #endif /* VMS */ 669 670 /* Now canonicalize by removing /. and /foo/.. if they appear */ 671 672 p = target; 673 o = target; 674 675 while (*p) 676 { 677 #ifdef VMS 678 if (*p != ']' && *p != '>' && *p != '-') 679 { 680 if (*p == '\\') 681 p++; 682 *o++ = *p++; 683 } 684 else if ((p[0] == ']' || p[0] == '>') && p[0] == p[1] + 2) 685 /* brackets are offset from each other by 2 */ 686 { 687 p += 2; 688 if (*p != '.' && *p != '-' && o[-1] != '.') 689 /* convert [foo][bar] to [bar] */ 690 while (o[-1] != '[' && o[-1] != '<') 691 o--; 692 else if (*p == '-' && *o != '.') 693 *--p = '.'; 694 } 695 else if (p[0] == '-' && o[-1] == '.' && 696 (p[1] == '.' || p[1] == ']' || p[1] == '>')) 697 /* flush .foo.- ; leave - if stopped by '[' or '<' */ 698 { 699 do 700 o--; 701 while (o[-1] != '.' && o[-1] != '[' && o[-1] != '<'); 702 if (p[1] == '.') /* foo.-.bar ==> bar*/ 703 p += 2; 704 else if (o[-1] == '.') /* '.foo.-]' ==> ']' */ 705 p++, o--; 706 /* else [foo.-] ==> [-] */ 707 } 708 else 709 { 710 #ifndef VMS4_4 711 if (*p == '-' && 712 o[-1] != '[' && o[-1] != '<' && o[-1] != '.' && 713 p[1] != ']' && p[1] != '>' && p[1] != '.') 714 *p = '_'; 715 #endif /* VMS4_4 */ 716 *o++ = *p++; 717 } 718 #else /* not VMS */ 719 if (*p != '/') 720 { 721 *o++ = *p++; 722 } 723 else if (!strncmp (p, "//", 2) 724 #ifdef APOLLO 725 /* // at start of filename is meaningful in Apollo system */ 726 && o != target 727 #endif /* APOLLO */ 728 ) 729 { 730 o = target; 731 p++; 732 } 733 else if (p[0] == '/' && p[1] == '.' && 734 (p[2] == '/' || p[2] == 0)) 735 p += 2; 736 else if (!strncmp (p, "/..", 3) 737 /* `/../' is the "superroot" on certain file systems. */ 738 && o != target 739 && (p[3] == '/' || p[3] == 0)) 740 { 741 while (o != target && *--o != '/') 742 ; 743 #ifdef APOLLO 744 if (o == target + 1 && o[-1] == '/' && o[0] == '/') 745 ++o; 746 else 747 #endif APOLLO 748 if (o == target && *o == '/') 749 ++o; 750 p += 3; 751 } 752 else 753 { 754 *o++ = *p++; 755 } 756 #endif /* not VMS */ 757 } 758 759 return make_string (target, o - target); 760 } 761 762 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name, 763 Ssubstitute_in_file_name, 1, 1, 0, 764 "Substitute environment variables referred to in STRING.\n\ 765 A $ begins a request to substitute; the env variable name is the alphanumeric\n\ 766 characters and underscores after the $, or is surrounded by braces.\n\ 767 If a ~ appears following a /, everything through that / is discarded.\n\ 768 On VMS, $ substitution is not done; this function does little and only\n\ 769 duplicates what expand-file-name does.") 770 (string) 771 Lisp_Object string; 772 { 773 unsigned char *nm; 774 775 register unsigned char *s, *p, *o, *x, *endp; 776 unsigned char *target; 777 int total = 0; 778 int substituted = 0; 779 unsigned char *xnm; 780 781 CHECK_STRING (string, 0); 782 783 nm = XSTRING (string)->data; 784 endp = nm + XSTRING (string)->size; 785 786 /* If /~ or // appears, discard everything through first slash. */ 787 788 for (p = nm; p != endp; p++) 789 { 790 if ((p[0] == '~' || 791 #ifdef APOLLO 792 /* // at start of file name is meaningful in Apollo system */ 793 (p[0] == '/' && p - 1 != nm) 794 #else /* not APOLLO */ 795 p[0] == '/' 796 #endif /* not APOLLO */ 797 ) 798 && p != nm && 799 #ifdef VMS 800 (p[-1] == ':' || p[-1] == ']' || p[-1] == '>' || 801 #endif /* VMS */ 802 p[-1] == '/') 803 #ifdef VMS 804 ) 805 #endif /* VMS */ 806 { 807 nm = p; 808 substituted = 1; 809 } 810 } 811 812 #ifdef VMS 813 return build_string (nm); 814 #else 815 816 /* See if any variables are substituted into the string 817 and find the total length of their values in `total' */ 818 819 for (p = nm; p != endp;) 820 if (*p != '$') 821 p++; 822 else 823 { 824 p++; 825 if (p == endp) 826 goto badsubst; 827 else if (*p == '$') 828 { 829 /* "$$" means a single "$" */ 830 p++; 831 total -= 1; 832 substituted = 1; 833 continue; 834 } 835 else if (*p == '{') 836 { 837 o = ++p; 838 while (p != endp && *p != '}') p++; 839 if (*p != '}') goto missingclose; 840 s = p; 841 } 842 else 843 { 844 o = p; 845 while (p != endp && (isalnum (*p) || *p == '_')) p++; 846 s = p; 847 } 848 849 /* Copy out the variable name */ 850 target = (unsigned char *) alloca (s - o + 1); 851 strncpy (target, o, s - o); 852 target[s - o] = 0; 853 854 /* Get variable value */ 855 o = (unsigned char *) egetenv (target); 856 /* The presence of this code makes vax 5.0 crash, for reasons yet unknown */ 857 #if 0 858 #ifdef USG 859 if (!o && !strcmp (target, "USER")) 860 o = egetenv ("LOGNAME"); 861 #endif /* USG */ 862 #endif /* 0 */ 863 if (!o) goto badvar; 864 total += strlen (o); 865 substituted = 1; 866 } 867 868 if (!substituted) 869 return string; 870 871 /* If substitution required, recopy the string and do it */ 872 /* Make space in stack frame for the new copy */ 873 xnm = (unsigned char *) alloca (XSTRING (string)->size + total + 1); 874 x = xnm; 875 876 /* Copy the rest of the name through, replacing $ constructs with values */ 877 for (p = nm; *p;) 878 if (*p != '$') 879 *x++ = *p++; 880 else 881 { 882 p++; 883 if (p == endp) 884 goto badsubst; 885 else if (*p == '$') 886 { 887 *x++ = *p++; 888 continue; 889 } 890 else if (*p == '{') 891 { 892 o = ++p; 893 while (p != endp && *p != '}') p++; 894 if (*p != '}') goto missingclose; 895 s = p++; 896 } 897 else 898 { 899 o = p; 900 while (p != endp && (isalnum (*p) || *p == '_')) p++; 901 s = p; 902 } 903 904 /* Copy out the variable name */ 905 target = (unsigned char *) alloca (s - o + 1); 906 strncpy (target, o, s - o); 907 target[s - o] = 0; 908 909 /* Get variable value */ 910 o = (unsigned char *) egetenv (target); 911 /* The presence of this code makes vax 5.0 crash, for reasons yet unknown */ 912 #if 0 913 #ifdef USG 914 if (!o && !strcmp (target, "USER")) 915 o = egetenv ("LOGNAME"); 916 #endif /* USG */ 917 #endif /* 0 */ 918 if (!o) 919 goto badvar; 920 921 strcpy (x, o); 922 x += strlen (o); 923 } 924 925 *x = 0; 926 927 /* If /~ or // appears, discard everything through first slash. */ 928 929 for (p = xnm; p != x; p++) 930 if ((p[0] == '~' || 931 #ifdef APOLLO 932 /* // at start of file name is meaningful in Apollo system */ 933 (p[0] == '/' && p - 1 != xnm) 934 #else /* not APOLLO */ 935 p[0] == '/' 936 #endif /* not APOLLO */ 937 ) 938 && p != nm && p[-1] == '/') 939 xnm = p; 940 941 return make_string (xnm, x - xnm); 942 943 badsubst: 944 error ("Bad format environment-variable substitution"); 945 missingclose: 946 error ("Missing \"}\" in environment-variable substitution"); 947 badvar: 948 error ("Substituting nonexistent environment variable \"%s\"", target); 949 950 /* NOTREACHED */ 951 #endif /* not VMS */ 952 } 953 954 Lisp_Object 955 expand_and_dir_to_file (filename, defdir) 956 Lisp_Object filename, defdir; 957 { 958 register Lisp_Object abspath; 959 960 abspath = Fexpand_file_name (filename, defdir); 961 #ifdef VMS 962 { 963 register int c = XSTRING (abspath)->data[XSTRING (abspath)->size - 1]; 964 if (c == ':' || c == ']' || c == '>') 965 abspath = Fdirectory_file_name (abspath); 966 } 967 #else 968 /* Remove final slash, if any (unless path is root). 969 stat behaves differently depending! */ 970 if (XSTRING (abspath)->size > 1 971 && XSTRING (abspath)->data[XSTRING (abspath)->size - 1] == '/') 972 { 973 if (EQ (abspath, filename)) 974 abspath = Fcopy_sequence (abspath); 975 XSTRING (abspath)->data[XSTRING (abspath)->size - 1] = 0; 976 } 977 #endif 978 return abspath; 979 } 980 981 barf_or_query_if_file_exists (absname, querystring, interactive) 982 Lisp_Object absname; 983 unsigned char *querystring; 984 int interactive; 985 { 986 register Lisp_Object tem; 987 struct gcpro gcpro1; 988 989 if (access (XSTRING (absname)->data, 4) >= 0) 990 { 991 if (! interactive) 992 Fsignal (Qfile_already_exists, 993 Fcons (build_string ("File already exists"), 994 Fcons (absname, Qnil))); 995 GCPRO1 (absname); 996 tem = Fyes_or_no_p (format1 ("File %s already exists; %s anyway? ", 997 XSTRING (absname)->data, querystring)); 998 UNGCPRO; 999 if (NULL (tem)) 1000 Fsignal (Qfile_already_exists, 1001 Fcons (build_string ("File already exists"), 1002 Fcons (absname, Qnil))); 1003 } 1004 return; 1005 } 1006 1007 DEFUN ("copy-file", Fcopy_file, Scopy_file, 2, 4, 1008 "fCopy file: \nFCopy %s to file: \np", 1009 "Copy FILE to NEWNAME. Both args strings.\n\ 1010 Signals a file-already-exists error if NEWNAME already exists,\n\ 1011 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\ 1012 A number as third arg means request confirmation if NEWNAME already exists.\n\ 1013 This is what happens in interactive use with M-x.\n\ 1014 Fourth arg non-nil means give the new file the same last-modified time\n\ 1015 that the old one has. (This works on only some systems.)") 1016 (filename, newname, ok_if_already_exists, keep_date) 1017 Lisp_Object filename, newname, ok_if_already_exists, keep_date; 1018 { 1019 int ifd, ofd, n; 1020 char buf[16 * 1024]; 1021 struct stat st; 1022 struct gcpro gcpro1, gcpro2; 1023 1024 GCPRO2 (filename, newname); 1025 CHECK_STRING (filename, 0); 1026 CHECK_STRING (newname, 1); 1027 filename = Fexpand_file_name (filename, Qnil); 1028 newname = Fexpand_file_name (newname, Qnil); 1029 if (NULL (ok_if_already_exists) 1030 || XTYPE (ok_if_already_exists) == Lisp_Int) 1031 barf_or_query_if_file_exists (newname, "copy to it", 1032 XTYPE (ok_if_already_exists) == Lisp_Int); 1033 1034 ifd = open (XSTRING (filename)->data, 0); 1035 if (ifd < 0) 1036 report_file_error ("Opening input file", Fcons (filename, Qnil)); 1037 1038 #ifdef VMS 1039 /* Create the copy file with the same record format as the input file */ 1040 ofd = sys_creat (XSTRING (newname)->data, 0666, ifd); 1041 #else 1042 ofd = creat (XSTRING (newname)->data, 0666); 1043 #endif /* VMS */ 1044 if (ofd < 0) 1045 { 1046 close (ifd); 1047 report_file_error ("Opening output file", Fcons (newname, Qnil)); 1048 } 1049 1050 while ((n = read (ifd, buf, sizeof buf)) > 0) 1051 if (write (ofd, buf, n) != n) 1052 { 1053 close (ifd); 1054 close (ofd); 1055 report_file_error ("I/O error", Fcons (newname, Qnil)); 1056 } 1057 1058 if (fstat (ifd, &st) >= 0) 1059 { 1060 #ifdef HAVE_TIMEVAL 1061 if (!NULL (keep_date)) 1062 { 1063 #ifdef USE_UTIME 1064 /* AIX has utimes() in compatibility package, but it dies. So use good old 1065 utime interface instead. */ 1066 struct { 1067 time_t atime; 1068 time_t mtime; 1069 } tv; 1070 tv.atime = st.st_atime; 1071 tv.mtime = st.st_mtime; 1072 utime (XSTRING (newname)->data, &tv); 1073 #else /* not USE_UTIME */ 1074 struct timeval timevals[2]; 1075 timevals[0].tv_sec = st.st_atime; 1076 timevals[1].tv_sec = st.st_mtime; 1077 timevals[0].tv_usec = timevals[1].tv_usec = 0; 1078 utimes (XSTRING (newname)->data, timevals); 1079 #endif /* not USE_UTIME */ 1080 } 1081 #endif /* HAVE_TIMEVALS */ 1082 1083 #ifdef APOLLO 1084 if (!egetenv ("USE_DOMAIN_ACLS")) 1085 #endif 1086 chmod (XSTRING (newname)->data, st.st_mode & 07777); 1087 } 1088 1089 close (ifd); 1090 if (close (ofd) < 0) 1091 report_file_error ("I/O error", Fcons (newname, Qnil)); 1092 1093 UNGCPRO; 1094 return Qnil; 1095 } 1096 1097 DEFUN ("delete-file", Fdelete_file, Sdelete_file, 1, 1, "fDelete file: ", 1098 "Delete specified file. One argument, a file name string.\n\ 1099 If file has multiple names, it continues to exist with the other names.") 1100 (filename) 1101 Lisp_Object filename; 1102 { 1103 CHECK_STRING (filename, 0); 1104 filename = Fexpand_file_name (filename, Qnil); 1105 if (0 > unlink (XSTRING (filename)->data)) 1106 report_file_error ("Removing old name", Flist (1, &filename)); 1107 return Qnil; 1108 } 1109 1110 DEFUN ("rename-file", Frename_file, Srename_file, 2, 3, 1111 "fRename file: \nFRename %s to file: \np", 1112 "Rename FILE as NEWNAME. Both args strings.\n\ 1113 If file has names other than FILE, it continues to have those names.\n\ 1114 Signals a file-already-exists error if NEWNAME already exists\n\ 1115 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\ 1116 A number as third arg means request confirmation if NEWNAME already exists.\n\ 1117 This is what happens in interactive use with M-x.") 1118 (filename, newname, ok_if_already_exists) 1119 Lisp_Object filename, newname, ok_if_already_exists; 1120 { 1121 #ifdef NO_ARG_ARRAY 1122 Lisp_Object args[2]; 1123 #endif 1124 struct gcpro gcpro1, gcpro2; 1125 1126 GCPRO2 (filename, newname); 1127 CHECK_STRING (filename, 0); 1128 CHECK_STRING (newname, 1); 1129 filename = Fexpand_file_name (filename, Qnil); 1130 newname = Fexpand_file_name (newname, Qnil); 1131 if (NULL (ok_if_already_exists) 1132 || XTYPE (ok_if_already_exists) == Lisp_Int) 1133 barf_or_query_if_file_exists (newname, "rename to it", 1134 XTYPE (ok_if_already_exists) == Lisp_Int); 1135 #ifndef BSD4_1 1136 if (0 > rename (XSTRING (filename)->data, XSTRING (newname)->data)) 1137 #else 1138 if (0 > link (XSTRING (filename)->data, XSTRING (newname)->data) 1139 || 0 > unlink (XSTRING (filename)->data)) 1140 #endif 1141 { 1142 if (errno == EXDEV) 1143 { 1144 Fcopy_file (filename, newname, ok_if_already_exists, Qt); 1145 Fdelete_file (filename); 1146 } 1147 else 1148 #ifdef NO_ARG_ARRAY 1149 { 1150 args[0] = filename; 1151 args[1] = newname; 1152 report_file_error ("Renaming", Flist (2, args)); 1153 } 1154 #else 1155 report_file_error ("Renaming", Flist (2, &filename)); 1156 #endif 1157 } 1158 UNGCPRO; 1159 return Qnil; 1160 } 1161 1162 DEFUN ("add-name-to-file", Fadd_name_to_file, Sadd_name_to_file, 2, 3, 1163 "fAdd name to file: \nFName to add to %s: \np", 1164 "Give FILE additional name NEWNAME. Both args strings.\n\ 1165 Signals a file-already-exists error if NEWNAME already exists\n\ 1166 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\ 1167 A number as third arg means request confirmation if NEWNAME already exists.\n\ 1168 This is what happens in interactive use with M-x.") 1169 (filename, newname, ok_if_already_exists) 1170 Lisp_Object filename, newname, ok_if_already_exists; 1171 { 1172 #ifdef NO_ARG_ARRAY 1173 Lisp_Object args[2]; 1174 #endif 1175 struct gcpro gcpro1, gcpro2; 1176 1177 GCPRO2 (filename, newname); 1178 CHECK_STRING (filename, 0); 1179 CHECK_STRING (newname, 1); 1180 filename = Fexpand_file_name (filename, Qnil); 1181 newname = Fexpand_file_name (newname, Qnil); 1182 if (NULL (ok_if_already_exists) 1183 || XTYPE (ok_if_already_exists) == Lisp_Int) 1184 barf_or_query_if_file_exists (newname, "make it a new name", 1185 XTYPE (ok_if_already_exists) == Lisp_Int); 1186 unlink (XSTRING (newname)->data); 1187 if (0 > link (XSTRING (filename)->data, XSTRING (newname)->data)) 1188 { 1189 #ifdef NO_ARG_ARRAY 1190 args[0] = filename; 1191 args[1] = newname; 1192 report_file_error ("Adding new name", Flist (2, args)); 1193 #else 1194 report_file_error ("Adding new name", Flist (2, &filename)); 1195 #endif 1196 } 1197 1198 UNGCPRO; 1199 return Qnil; 1200 } 1201 1202 #ifdef S_IFLNK 1203 DEFUN ("make-symbolic-link", Fmake_symbolic_link, Smake_symbolic_link, 2, 3, 1204 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np", 1205 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\ 1206 Signals a file-already-exists error if NEWNAME already exists\n\ 1207 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\ 1208 A number as third arg means request confirmation if NEWNAME already exists.\n\ 1209 This happens for interactive use with M-x.") 1210 (filename, newname, ok_if_already_exists) 1211 Lisp_Object filename, newname, ok_if_already_exists; 1212 { 1213 #ifdef NO_ARG_ARRAY 1214 Lisp_Object args[2]; 1215 #endif 1216 struct gcpro gcpro1, gcpro2; 1217 1218 GCPRO2 (filename, newname); 1219 CHECK_STRING (filename, 0); 1220 CHECK_STRING (newname, 1); 1221 filename = Fexpand_file_name (filename, Qnil); 1222 newname = Fexpand_file_name (newname, Qnil); 1223 if (NULL (ok_if_already_exists) 1224 || XTYPE (ok_if_already_exists) == Lisp_Int) 1225 barf_or_query_if_file_exists (newname, "make it a link", 1226 XTYPE (ok_if_already_exists) == Lisp_Int); 1227 if (0 > symlink (XSTRING (filename)->data, XSTRING (newname)->data)) 1228 { 1229 #ifdef NO_ARG_ARRAY 1230 args[0] = filename; 1231 args[1] = newname; 1232 report_file_error ("Making symbolic link", Flist (2, args)); 1233 #else 1234 report_file_error ("Making symbolic link", Flist (2, &filename)); 1235 #endif 1236 } 1237 UNGCPRO; 1238 return Qnil; 1239 } 1240 #endif /* S_IFLNK */ 1241 1242 #ifdef VMS 1243 1244 DEFUN ("define-logical-name", Fdefine_logical_name, Sdefine_logical_name, 1245 2, 2, 1246 "sDefine logical name: \nsDefine logical name %s as: ", 1247 "Define the job-wide logical name NAME to have the value STRING.\n\ 1248 If STRING is nil or a null string, the logical name NAME is deleted.") 1249 (varname, string) 1250 Lisp_Object varname; 1251 Lisp_Object string; 1252 { 1253 CHECK_STRING (varname, 0); 1254 if (NULL (string)) 1255 delete_logical_name (XSTRING (varname)->data); 1256 else 1257 { 1258 CHECK_STRING (string, 1); 1259 1260 if (XSTRING (string)->size == 0) 1261 delete_logical_name (XSTRING (varname)->data); 1262 else 1263 define_logical_name (XSTRING (varname)->data, XSTRING (string)->data); 1264 } 1265 1266 return string; 1267 } 1268 #endif /* VMS */ 1269 1270 #ifdef HPUX_NET 1271 1272 DEFUN ("sysnetunam", Fsysnetunam, Ssysnetunam, 2, 2, 0, 1273 "Open a network connection to PATH using LOGIN as the login string.") 1274 (path, login) 1275 Lisp_Object path, login; 1276 { 1277 int netresult; 1278 1279 CHECK_STRING (path, 0); 1280 CHECK_STRING (login, 0); 1281 1282 netresult = netunam (XSTRING (path)->data, XSTRING (login)->data); 1283 1284 if (netresult == -1) 1285 return Qnil; 1286 else 1287 return Qt; 1288 } 1289 #endif /* HPUX_NET */ 1290 1291 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p, Sfile_name_absolute_p, 1292 1, 1, 0, 1293 "Return t if file FILENAME specifies an absolute path name.") 1294 (filename) 1295 Lisp_Object filename; 1296 { 1297 unsigned char *ptr; 1298 1299 CHECK_STRING (filename, 0); 1300 ptr = XSTRING (filename)->data; 1301 if (*ptr == '/' || *ptr == '~' 1302 #ifdef VMS 1303 /* ??? This criterion is probably wrong for '<'. */ 1304 || index (ptr, ':') || index (ptr, '<') 1305 || (*ptr == '[' && (ptr[1] != '-' || (ptr[2] != '.' && ptr[2] != ']')) 1306 && ptr[1] != '.') 1307 #endif /* VMS */ 1308 ) 1309 return Qt; 1310 else 1311 return Qnil; 1312 } 1313 1314 DEFUN ("file-exists-p", Ffile_exists_p, Sfile_exists_p, 1, 1, 0, 1315 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\ 1316 See also file-readable-p and file-attributes.") 1317 (filename) 1318 Lisp_Object filename; 1319 { 1320 Lisp_Object abspath; 1321 1322 CHECK_STRING (filename, 0); 1323 abspath = Fexpand_file_name (filename, Qnil); 1324 return (access (XSTRING (abspath)->data, 0) >= 0) ? Qt : Qnil; 1325 } 1326 1327 DEFUN ("file-readable-p", Ffile_readable_p, Sfile_readable_p, 1, 1, 0, 1328 "Return t if file FILENAME exists and you can read it.\n\ 1329 See also file-exists-p and file-attributes.") 1330 (filename) 1331 Lisp_Object filename; 1332 { 1333 Lisp_Object abspath; 1334 1335 CHECK_STRING (filename, 0); 1336 abspath = Fexpand_file_name (filename, Qnil); 1337 return (access (XSTRING (abspath)->data, 4) >= 0) ? Qt : Qnil; 1338 } 1339 1340 DEFUN ("file-symlink-p", Ffile_symlink_p, Sfile_symlink_p, 1, 1, 0, 1341 "If file FILENAME is the name of a symbolic link\n\ 1342 returns the name of the file to which it is linked.\n\ 1343 Otherwise returns NIL.") 1344 (filename) 1345 Lisp_Object filename; 1346 { 1347 #ifdef S_IFLNK 1348 char *buf; 1349 int bufsize; 1350 int valsize; 1351 Lisp_Object val; 1352 1353 CHECK_STRING (filename, 0); 1354 filename = Fexpand_file_name (filename, Qnil); 1355 1356 bufsize = 100; 1357 while (1) 1358 { 1359 buf = (char *) xmalloc (bufsize); 1360 bzero (buf, bufsize); 1361 valsize = readlink (XSTRING (filename)->data, buf, bufsize); 1362 if (valsize < bufsize) break; 1363 /* Buffer was not long enough */ 1364 free (buf); 1365 bufsize *= 2; 1366 } 1367 if (valsize == -1) 1368 { 1369 free (buf); 1370 return Qnil; 1371 } 1372 val = make_string (buf, valsize); 1373 free (buf); 1374 return val; 1375 #else /* not S_IFLNK */ 1376 return Qnil; 1377 #endif /* not S_IFLNK */ 1378 } 1379 1380 /* Having this before file-symlink-p mysteriously caused it to be forgotten 1381 on the RT/PC. */ 1382 DEFUN ("file-writable-p", Ffile_writable_p, Sfile_writable_p, 1, 1, 0, 1383 "Return t if file FILENAME can be written or created by you.") 1384 (filename) 1385 Lisp_Object filename; 1386 { 1387 Lisp_Object abspath, dir; 1388 1389 CHECK_STRING (filename, 0); 1390 abspath = Fexpand_file_name (filename, Qnil); 1391 if (access (XSTRING (abspath)->data, 0) >= 0) 1392 return (access (XSTRING (abspath)->data, 2) >= 0) ? Qt : Qnil; 1393 dir = Ffile_name_directory (abspath); 1394 #ifdef VMS 1395 if (!NULL (dir)) 1396 dir = Fdirectory_file_name (dir); 1397 #endif /* VMS */ 1398 return (access (!NULL (dir) ? (char *) XSTRING (dir)->data : "", 2) >= 0 1399 ? Qt : Qnil); 1400 } 1401 1402 DEFUN ("file-directory-p", Ffile_directory_p, Sfile_directory_p, 1, 1, 0, 1403 "Return t if file FILENAME is the name of a directory as a file.\n\ 1404 A directory name spec may be given instead; then the value is t\n\ 1405 if the directory so specified exists and really is a directory.") 1406 (filename) 1407 Lisp_Object filename; 1408 { 1409 register Lisp_Object abspath; 1410 struct stat st; 1411 1412 abspath = expand_and_dir_to_file (filename, current_buffer->directory); 1413 1414 if (stat (XSTRING (abspath)->data, &st) < 0) 1415 return Qnil; 1416 return (st.st_mode & S_IFMT) == S_IFDIR ? Qt : Qnil; 1417 } 1418 1419 DEFUN ("file-modes", Ffile_modes, Sfile_modes, 1, 1, 0, 1420 "Return mode bits of FILE, as an integer.") 1421 (filename) 1422 Lisp_Object filename; 1423 { 1424 Lisp_Object abspath; 1425 struct stat st; 1426 1427 abspath = expand_and_dir_to_file (filename, current_buffer->directory); 1428 1429 if (stat (XSTRING (abspath)->data, &st) < 0) 1430 return Qnil; 1431 return make_number (st.st_mode & 07777); 1432 } 1433 1434 DEFUN ("set-file-modes", Fset_file_modes, Sset_file_modes, 2, 2, 0, 1435 "Set mode bits of FILE to MODE (an integer).\n\ 1436 Only the 12 low bits of MODE are used.") 1437 (filename, mode) 1438 Lisp_Object filename, mode; 1439 { 1440 Lisp_Object abspath; 1441 1442 abspath = Fexpand_file_name (filename, current_buffer->directory); 1443 CHECK_NUMBER (mode, 1); 1444 1445 #ifndef APOLLO 1446 if (chmod (XSTRING (abspath)->data, XINT (mode)) < 0) 1447 report_file_error ("Doing chmod", Fcons (abspath, Qnil)); 1448 #else /* APOLLO */ 1449 if (!egetenv ("USE_DOMAIN_ACLS")) 1450 { 1451 struct stat st; 1452 struct timeval tvp[2]; 1453 1454 /* chmod on apollo also change the file's modtime; need to save the 1455 modtime and then restore it. */ 1456 if (stat (XSTRING (abspath)->data, &st) < 0) 1457 { 1458 report_file_error ("Doing chmod", Fcons (abspath, Qnil)); 1459 return (Qnil); 1460 } 1461 1462 if (chmod (XSTRING (abspath)->data, XINT (mode)) < 0) 1463 report_file_error ("Doing chmod", Fcons (abspath, Qnil)); 1464 1465 /* reset the old accessed and modified times. */ 1466 tvp[0].tv_sec = st.st_atime + 1; /* +1 due to an Apollo roundoff bug */ 1467 tvp[0].tv_usec = 0; 1468 tvp[1].tv_sec = st.st_mtime + 1; /* +1 due to an Apollo roundoff bug */ 1469 tvp[1].tv_usec = 0; 1470 1471 if (utimes (XSTRING (abspath)->data, tvp) < 0) 1472 report_file_error ("Doing utimes", Fcons (abspath, Qnil)); 1473 } 1474 #endif /* APOLLO */ 1475 1476 return Qnil; 1477 } 1478 1479 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p, Sfile_newer_than_file_p, 2, 2, 0, 1480 "Return t if file FILE1 is newer than file FILE2.\n\ 1481 If FILE1 does not exist, the answer is nil;\n\ 1482 otherwise, if FILE2 does not exist, the answer is t.") 1483 (file1, file2) 1484 Lisp_Object file1, file2; 1485 { 1486 Lisp_Object abspath; 1487 struct stat st; 1488 int mtime1; 1489 1490 CHECK_STRING (file1, 0); 1491 CHECK_STRING (file2, 0); 1492 1493 abspath = expand_and_dir_to_file (file1, current_buffer->directory); 1494 1495 if (stat (XSTRING (abspath)->data, &st) < 0) 1496 return Qnil; 1497 1498 mtime1 = st.st_mtime; 1499 1500 abspath = expand_and_dir_to_file (file2, current_buffer->directory); 1501 1502 if (stat (XSTRING (abspath)->data, &st) < 0) 1503 return Qt; 1504 1505 return (mtime1 > st.st_mtime) ? Qt : Qnil; 1506 } 1507 1508 close_file_unwind (fd) 1509 Lisp_Object fd; 1510 { 1511 close (XFASTINT (fd)); 1512 } 1513 1514 DEFUN ("insert-file-contents", Finsert_file_contents, Sinsert_file_contents, 1515 1, 2, 0, 1516 "Insert contents of file FILENAME after point.\n\ 1517 Returns list of absolute pathname and length of data inserted.\n\ 1518 If second argument VISIT is non-nil, the buffer's visited filename\n\ 1519 and last save file modtime are set, and it is marked unmodified.\n\ 1520 If visiting and the file does not exist, visiting is completed\n\ 1521 before the error is signaled.") 1522 (filename, visit) 1523 Lisp_Object filename, visit; 1524 { 1525 struct stat st; 1526 register int fd; 1527 register int inserted = 0; 1528 register int i = 0; 1529 int count = specpdl_ptr - specpdl; 1530 struct gcpro gcpro1; 1531 1532 GCPRO1 (filename); 1533 if (!NULL (current_buffer->read_only)) 1534 Fbarf_if_buffer_read_only(); 1535 1536 CHECK_STRING (filename, 0); 1537 filename = Fexpand_file_name (filename, Qnil); 1538 1539 fd = -1; 1540 1541 #ifndef APOLLO 1542 if (stat (XSTRING (filename)->data, &st) < 0 1543 || (fd = open (XSTRING (filename)->data, 0)) < 0) 1544 #else 1545 if ((fd = open (XSTRING (filename)->data, 0)) < 0 1546 || fstat (fd, &st) < 0) 1547 #endif /* not APOLLO */ 1548 { 1549 if (fd >= 0) close (fd); 1550 if (NULL (visit)) 1551 report_file_error ("Opening input file", Fcons (filename, Qnil)); 1552 st.st_mtime = -1; 1553 goto notfound; 1554 } 1555 1556 record_unwind_protect (close_file_unwind, make_number (fd)); 1557 1558 /* Supposedly happens on VMS. */ 1559 if (st.st_size < 0) 1560 error ("File size is negative"); 1561 { 1562 register Lisp_Object temp; 1563 1564 /* Make sure point-max won't overflow after this insertion. */ 1565 XSET (temp, Lisp_Int, st.st_size + Z); 1566 if (st.st_size + Z != XINT (temp)) 1567 error ("maximum buffer size exceeded"); 1568 } 1569 1570 if (NULL (visit)) 1571 prepare_to_modify_buffer (); 1572 1573 move_gap (point); 1574 if (GAP_SIZE < st.st_size) 1575 make_gap ((int)st.st_size - GAP_SIZE); 1576 1577 while (1) 1578 { 1579 int try = min (st.st_size - inserted, 64 << 10); 1580 int this = read (fd, &FETCH_CHAR (point + inserted - 1) + 1, try); 1581 1582 if (this <= 0) 1583 { 1584 i = this; 1585 break; 1586 } 1587 1588 GPT += this; 1589 GAP_SIZE -= this; 1590 ZV += this; 1591 Z += this; 1592 inserted += this; 1593 } 1594 1595 if (inserted > 0) 1596 MODIFF++; 1597 record_insert (point, inserted); 1598 1599 close (fd); 1600 1601 /* Discard the unwind protect */ 1602 specpdl_ptr = specpdl + count; 1603 1604 if (i < 0) 1605 error ("IO error reading %s: %s", 1606 XSTRING (filename)->data, err_str (errno)); 1607 1608 notfound: 1609 1610 if (!NULL (visit)) 1611 { 1612 current_buffer->undo_list = Qnil; 1613 #ifdef APOLLO 1614 stat (XSTRING (filename)->data, &st); 1615 #endif 1616 current_buffer->modtime = st.st_mtime; 1617 current_buffer->save_modified = MODIFF; 1618 current_buffer->auto_save_modified = MODIFF; 1619 XFASTINT (current_buffer->save_length) = Z - BEG; 1620 #ifdef CLASH_DETECTION 1621 if (!NULL (current_buffer->filename)) 1622 unlock_file (current_buffer->filename); 1623 unlock_file (filename); 1624 #endif /* CLASH_DETECTION */ 1625 current_buffer->filename = filename; 1626 /* If visiting nonexistent file, return nil. */ 1627 if (st.st_mtime == -1) 1628 report_file_error ("Opening input file", Fcons (filename, Qnil)); 1629 } 1630 1631 UNGCPRO; 1632 return Fcons (filename, Fcons (make_number (inserted), Qnil)); 1633 } 1634 1635 DEFUN ("write-region", Fwrite_region, Swrite_region, 3, 5, 1636 "r\nFWrite region to file: ", 1637 "Write current region into specified file.\n\ 1638 When called from a program, takes three arguments:\n\ 1639 START, END and FILENAME. START and END are buffer positions.\n\ 1640 Optional fourth argument APPEND if non-nil means\n\ 1641 append to existing file contents (if any).\n\ 1642 Optional fifth argument VISIT if t means\n\ 1643 set last-save-file-modtime of buffer to this file's modtime\n\ 1644 and mark buffer not modified.\n\ 1645 If VISIT is neither t nor nil, it means do not print\n\ 1646 the \"Wrote file\" message.") 1647 (start, end, filename, append, visit) 1648 Lisp_Object start, end, filename, append, visit; 1649 { 1650 register int desc; 1651 int failure; 1652 int save_errno; 1653 unsigned char *fn; 1654 struct stat st; 1655 int tem; 1656 int count = specpdl_ptr - specpdl; 1657 #ifdef VMS 1658 unsigned char *fname = 0; /* If non-0, original filename (must rename) */ 1659 #endif /* VMS */ 1660 1661 /* Special kludge to simplify auto-saving */ 1662 if (NULL (start)) 1663 { 1664 XFASTINT (start) = BEG; 1665 XFASTINT (end) = Z; 1666 } 1667 else 1668 validate_region (&start, &end); 1669 1670 filename = Fexpand_file_name (filename, Qnil); 1671 fn = XSTRING (filename)->data; 1672 1673 #ifdef CLASH_DETECTION 1674 if (!auto_saving) 1675 lock_file (filename); 1676 #endif /* CLASH_DETECTION */ 1677 1678 desc = -1; 1679 if (!NULL (append)) 1680 desc = open (fn, O_WRONLY); 1681 1682 if (desc < 0) 1683 #ifdef VMS 1684 if (auto_saving) /* Overwrite any previous version of autosave file */ 1685 { 1686 vms_truncate (fn); /* if fn exists, truncate to zero length */ 1687 desc = open (fn, O_RDWR); 1688 if (desc < 0) 1689 desc = creat_copy_attrs (XTYPE (current_buffer->filename) == Lisp_String 1690 ? XSTRING (current_buffer->filename)->data : 0, 1691 fn); 1692 } 1693 else /* Write to temporary name and rename if no errors */ 1694 { 1695 Lisp_Object temp_name; 1696 temp_name = Ffile_name_directory (filename); 1697 1698 if (!NULL (temp_name)) 1699 { 1700 temp_name = Fmake_temp_name (concat2 (temp_name, 1701 build_string ("$$SAVE$$"))); 1702 fname = XSTRING (filename)->data; 1703 fn = XSTRING (temp_name)->data; 1704 desc = creat_copy_attrs (fname, fn); 1705 if (desc < 0) 1706 { 1707 /* If we can't open the temporary file, try creating a new 1708 version of the original file. VMS "creat" creates a 1709 new version rather than truncating an existing file. */ 1710 fn = fname; 1711 fname = 0; 1712 desc = creat (fn, 0666); 1713 if (desc < 0) 1714 { 1715 /* We can't make a new version; 1716 try to truncate and rewrite existing version if any. */ 1717 vms_truncate (fn); 1718 desc = open (fn, O_RDWR); 1719 } 1720 } 1721 } 1722 else 1723 desc = creat (fn, 0666); 1724 } 1725 #else /* not VMS */ 1726 desc = creat (fn, 0666); 1727 #endif /* not VMS */ 1728 1729 if (desc < 0) 1730 { 1731 #ifdef CLASH_DETECTION 1732 save_errno = errno; 1733 if (!auto_saving) unlock_file (filename); 1734 errno = save_errno; 1735 #endif /* CLASH_DETECTION */ 1736 report_file_error ("Opening output file", Fcons (filename, Qnil)); 1737 } 1738 1739 record_unwind_protect (close_file_unwind, make_number (desc)); 1740 1741 if (!NULL (append)) 1742 if (lseek (desc, (off_t) 0, 2) < 0) 1743 { 1744 #ifdef CLASH_DETECTION 1745 if (!auto_saving) unlock_file (filename); 1746 #endif /* CLASH_DETECTION */ 1747 report_file_error ("Lseek error", Fcons (filename, Qnil)); 1748 } 1749 1750 #ifdef VMS 1751 /* 1752 * Kludge Warning: The VMS C RTL likes to insert carriage returns 1753 * if we do writes that don't end with a carriage return. Furthermore 1754 * it cannot handle writes of more then 16K. The modified 1755 * version of "sys_write" in SYSDEP.C (see comment there) copes with 1756 * this EXCEPT for the last record (iff it doesn't end with a carriage 1757 * return). This implies that if your buffer doesn't end with a carriage 1758 * return, you get one free... tough. However it also means that if 1759 * we make two calls to sys_write (a la the following code) you can 1760 * get one at the gap as well. The easiest way to fix this (honest) 1761 * is to move the gap to the next newline (or the end of the buffer). 1762 * Thus this change. 1763 * 1764 * Yech! 1765 */ 1766 if (GPT > BEG && GPT_ADDR[-1] != '\n') 1767 move_gap (find_next_newline (GPT, 1)); 1768 #endif 1769 1770 failure = 0; 1771 if (XINT (start) != XINT (end)) 1772 { 1773 if (XINT (start) < GPT) 1774 { 1775 register int end1 = XINT (end); 1776 tem = XINT (start); 1777 failure = 0 > e_write (desc, &FETCH_CHAR (tem), 1778 min (GPT, end1) - tem); 1779 save_errno = errno; 1780 } 1781 1782 if (XINT (end) > GPT && !failure) 1783 { 1784 tem = XINT (start); 1785 tem = max (tem, GPT); 1786 failure = 0 > e_write (desc, &FETCH_CHAR (tem), XINT (end) - tem); 1787 save_errno = errno; 1788 } 1789 } 1790 1791 #ifndef USG 1792 #ifndef VMS 1793 #ifndef BSD4_1 1794 #ifndef alliant /* trinkle@cs.purdue.edu says fsync can return EBUSY 1795 on alliant, for no visible reason. */ 1796 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun). 1797 Disk full in NFS may be reported here. */ 1798 if (fsync (desc) < 0) 1799 failure = 1, save_errno = errno; 1800 #endif 1801 #endif 1802 #endif 1803 #endif 1804 1805 #if 0 1806 /* Spurious "file has changed on disk" warnings have been 1807 observed on Sun 3 as well. Maybe close changes the modtime 1808 with nfs as well. */ 1809 1810 /* On VMS and APOLLO, must do the stat after the close 1811 since closing changes the modtime. */ 1812 #ifndef VMS 1813 #ifndef APOLLO 1814 /* Recall that #if defined does not work on VMS. */ 1815 #define FOO 1816 fstat (desc, &st); 1817 #endif 1818 #endif 1819 #endif /* 0 */ 1820 1821 /* NFS can report a write failure now. */ 1822 if (close (desc) < 0) 1823 failure = 1, save_errno = errno; 1824 1825 #ifdef VMS 1826 /* If we wrote to a temporary name and had no errors, rename to real name. */ 1827 if (fname) 1828 { 1829 if (!failure) 1830 failure = (rename (fn, fname) != 0), save_errno = errno; 1831 fn = fname; 1832 } 1833 #endif /* VMS */ 1834 1835 #ifndef FOO 1836 stat (fn, &st); 1837 #endif 1838 /* Discard the unwind protect */ 1839 specpdl_ptr = specpdl + count; 1840 1841 #ifdef CLASH_DETECTION 1842 if (!auto_saving) 1843 unlock_file (filename); 1844 #endif /* CLASH_DETECTION */ 1845 1846 /* Do this before reporting IO error 1847 to avoid a "file has changed on disk" warning on 1848 next attempt to save. */ 1849 if (EQ (visit, Qt)) 1850 current_buffer->modtime = st.st_mtime; 1851 1852 if (failure) 1853 error ("IO error writing %s: %s", fn, err_str (save_errno)); 1854 1855 if (EQ (visit, Qt)) 1856 { 1857 current_buffer->save_modified = MODIFF; 1858 XFASTINT (current_buffer->save_length) = Z - BEG; 1859 current_buffer->filename = filename; 1860 } 1861 else if (!NULL (visit)) 1862 return Qnil; 1863 1864 if (!auto_saving) 1865 message ("Wrote %s", fn); 1866 1867 return Qnil; 1868 } 1869 1870 int 1871 e_write (desc, addr, len) 1872 int desc; 1873 register char *addr; 1874 register int len; 1875 { 1876 char buf[16 * 1024]; 1877 register char *p, *end; 1878 1879 if (!EQ (current_buffer->selective_display, Qt)) 1880 return write (desc, addr, len) - len; 1881 else 1882 { 1883 p = buf; 1884 end = p + sizeof buf; 1885 while (len--) 1886 { 1887 if (p == end) 1888 { 1889 if (write (desc, buf, sizeof buf) != sizeof buf) 1890 return -1; 1891 p = buf; 1892 } 1893 *p = *addr++; 1894 if (*p++ == '\015') 1895 p[-1] = '\n'; 1896 } 1897 if (p != buf) 1898 if (write (desc, buf, p - buf) != p - buf) 1899 return -1; 1900 } 1901 return 0; 1902 } 1903 1904 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime, 1905 Sverify_visited_file_modtime, 1, 1, 0, 1906 "Return t if last mod time of BUF's visited file matches what BUF records.\n\ 1907 This means that the file has not been changed since it was visited or saved.") 1908 (buf) 1909 Lisp_Object buf; 1910 { 1911 struct buffer *b; 1912 struct stat st; 1913 1914 CHECK_BUFFER (buf, 0); 1915 b = XBUFFER (buf); 1916 1917 if (XTYPE (b->filename) != Lisp_String) return Qt; 1918 if (b->modtime == 0) return Qt; 1919 1920 if (stat (XSTRING (b->filename)->data, &st) < 0) 1921 { 1922 /* If the file doesn't exist now and didn't exist before, 1923 we say that it isn't modified, provided the error is a tame one. */ 1924 if (errno == ENOENT || errno == EACCES || errno == ENOTDIR) 1925 st.st_mtime = -1; 1926 else 1927 st.st_mtime = 0; 1928 } 1929 if (st.st_mtime == b->modtime 1930 /* If both are positive, accept them if they are off by one second. */ 1931 || (st.st_mtime > 0 && b->modtime > 0 1932 && (st.st_mtime == b->modtime + 1 1933 || st.st_mtime == b->modtime - 1))) 1934 return Qt; 1935 return Qnil; 1936 } 1937 1938 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime, 1939 Sclear_visited_file_modtime, 0, 0, 0, 1940 "Clear out records of last mod time of visited file.\n\ 1941 Next attempt to save will certainly not complain of a discrepancy.") 1942 () 1943 { 1944 current_buffer->modtime = 0; 1945 return Qnil; 1946 } 1947 1948 Lisp_Object 1949 auto_save_error () 1950 { 1951 unsigned char *name = XSTRING (current_buffer->name)->data; 1952 1953 bell (); 1954 message ("Autosaving...error for %s", name); 1955 Fsleep_for (make_number (1)); 1956 message ("Autosaving...error!for %s", name); 1957 Fsleep_for (make_number (1)); 1958 message ("Autosaving...error for %s", name); 1959 Fsleep_for (make_number (1)); 1960 return Qnil; 1961 } 1962 1963 Lisp_Object 1964 auto_save_1 () 1965 { 1966 return 1967 Fwrite_region (Qnil, Qnil, 1968 current_buffer->auto_save_file_name, 1969 Qnil, Qlambda); 1970 } 1971 1972 DEFUN ("do-auto-save", Fdo_auto_save, Sdo_auto_save, 0, 1, "", 1973 "Auto-save all buffers that need it.\n\ 1974 This is all buffers that have auto-saving enabled\n\ 1975 and are changed since last auto-saved.\n\ 1976 Auto-saving writes the buffer into a file\n\ 1977 so that your editing is not lost if the system crashes.\n\ 1978 This file is not the file you visited; that changes only when you save.\n\n\ 1979 Non-nil argument means do not print any message if successful.") 1980 (nomsg) 1981 Lisp_Object nomsg; 1982 { 1983 struct buffer *old = current_buffer, *b; 1984 Lisp_Object tail, buf; 1985 int auto_saved = 0; 1986 int tried = 0; 1987 char *omessage = echo_area_contents; 1988 /* No GCPRO needed, because (when it matters) all Lisp_Object variables 1989 point to non-strings reached from Vbuffer_alist. */ 1990 1991 auto_saving = 1; 1992 if (minibuf_level) 1993 nomsg = Qt; 1994 1995 for (tail = Vbuffer_alist; XGCTYPE (tail) == Lisp_Cons; 1996 tail = XCONS (tail)->cdr) 1997 { 1998 buf = XCONS (XCONS (tail)->car)->cdr; 1999 b = XBUFFER (buf); 2000 /* Check for auto save enabled 2001 and file changed since last auto save 2002 and file changed since last real save. */ 2003 if (XTYPE (b->auto_save_file_name) == Lisp_String 2004 && b->save_modified < BUF_MODIFF (b) 2005 && b->auto_save_modified < BUF_MODIFF (b)) 2006 { 2007 /* If we at least consider a buffer for auto-saving, 2008 don't try again for a suitable time. */ 2009 tried++; 2010 if ((XFASTINT (b->save_length) * 10 2011 > (BUF_Z (b) - BUF_BEG (b)) * 13) 2012 /* A short file is likely to change a large fraction; 2013 spare the user annoying messages. */ 2014 && XFASTINT (b->save_length) > 5000 2015 /* These messages are frequent and annoying for `*mail*'. */ 2016 && !EQ (b->filename, Qnil)) 2017 { 2018 /* It has shrunk too much; don't checkpoint. */ 2019 message ("Buffer %s has shrunk a lot; not autosaving it", 2020 XSTRING (b->name)->data); 2021 Fsleep_for (make_number (1)); 2022 continue; 2023 } 2024 set_buffer_internal (b); 2025 if (!auto_saved && NULL (nomsg)) 2026 message1 ("Auto-saving..."); 2027 internal_condition_case (auto_save_1, Qt, auto_save_error); 2028 auto_saved++; 2029 b->auto_save_modified = BUF_MODIFF (b); 2030 XFASTINT (current_buffer->save_length) = Z - BEG; 2031 set_buffer_internal (old); 2032 } 2033 } 2034 2035 if (tried) 2036 record_auto_save (); 2037 2038 if (auto_saved && NULL (nomsg)) 2039 message1 (omessage ? omessage : "Auto-saving...done"); 2040 2041 auto_saving = 0; 2042 return Qnil; 2043 } 2044 2045 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved, 2046 Sset_buffer_auto_saved, 0, 0, 0, 2047 "Mark current buffer as auto-saved with its current text.\n\ 2048 No auto-save file will be written until the buffer changes again.") 2049 () 2050 { 2051 current_buffer->auto_save_modified = MODIFF; 2052 XFASTINT (current_buffer->save_length) = Z - BEG; 2053 return Qnil; 2054 } 2055 2056 DEFUN ("recent-auto-save-p", Frecent_auto_save_p, Srecent_auto_save_p, 2057 0, 0, 0, 2058 "Return t if buffer has been auto-saved since last read in or saved.") 2059 () 2060 { 2061 return (current_buffer->save_modified < current_buffer->auto_save_modified) ? Qt : Qnil; 2062 } 2063 2064 /* Reading and completing file names */ 2065 extern Lisp_Object Ffile_name_completion (), Ffile_name_all_completions (); 2066 2067 DEFUN ("read-file-name-internal", Fread_file_name_internal, Sread_file_name_internal, 2068 3, 3, 0, 2069 "Internal subroutine for read-file-name. Do not call this.") 2070 (string, dir, action) 2071 Lisp_Object string, dir, action; 2072 /* action is nil for complete, t for return list of completions, 2073 lambda for verify final value */ 2074 { 2075 Lisp_Object name, specdir, realdir, val; 2076 if (XSTRING (string)->size == 0) 2077 { 2078 name = string; 2079 realdir = dir; 2080 if (EQ (action, Qlambda)) 2081 return Qnil; 2082 } 2083 else 2084 { 2085 string = Fsubstitute_in_file_name (string); 2086 name = Ffile_name_nondirectory (string); 2087 realdir = Ffile_name_directory (string); 2088 if (NULL (realdir)) 2089 realdir = dir; 2090 else 2091 realdir = Fexpand_file_name (realdir, dir); 2092 } 2093 2094 if (NULL (action)) 2095 { 2096 specdir = Ffile_name_directory (string); 2097 val = Ffile_name_completion (name, realdir); 2098 if (XTYPE (val) != Lisp_String) 2099 return (val); 2100 2101 if (!NULL (specdir)) 2102 val = concat2 (specdir, val); 2103 #ifndef VMS 2104 { 2105 register unsigned char *old, *new; 2106 register int n; 2107 int osize, count; 2108 2109 osize = XSTRING (val)->size; 2110 /* Quote "$" as "$$" to get it past substitute-in-file-name */ 2111 for (n = osize, count = 0, old = XSTRING (val)->data; n > 0; n--) 2112 if (*old++ == '$') count++; 2113 if (count > 0) 2114 { 2115 old = XSTRING (val)->data; 2116 val = Fmake_string (make_number (osize + count), make_number (0)); 2117 new = XSTRING (val)->data; 2118 for (n = osize; n > 0; n--) 2119 if (*old != '$') 2120 *new++ = *old++; 2121 else 2122 { 2123 *new++ = '$'; 2124 *new++ = '$'; 2125 old++; 2126 } 2127 } 2128 } 2129 #endif /* Not VMS */ 2130 return (val); 2131 } 2132 2133 if (EQ (action, Qt)) 2134 return Ffile_name_all_completions (name, realdir); 2135 /* Only other case actually used is ACTION = lambda */ 2136 #ifdef VMS 2137 /* Supposedly this helps commands such as `cd' that read directory names, 2138 but can someone explain how it helps them? -- RMS */ 2139 if (XSTRING (name)->size == 0) 2140 return Qt; 2141 #endif /* VMS */ 2142 return Ffile_exists_p (string); 2143 } 2144 2145 DEFUN ("read-file-name", Fread_file_name, Sread_file_name, 1, 4, 0, 2146 "Read file name, prompting with PROMPT and completing in directory DIR.\n\ 2147 Value is not expanded! You must call expand-file-name yourself.\n\ 2148 Default name to DEFAULT if user enters a null string.\n\ 2149 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\ 2150 Non-nil and non-t means also require confirmation after completion.\n\ 2151 DIR defaults to current buffer's directory default.") 2152 (prompt, dir, defalt, mustmatch) 2153 Lisp_Object prompt, dir, defalt, mustmatch; 2154 { 2155 Lisp_Object val, insdef, tem; 2156 struct gcpro gcpro1, gcpro2; 2157 register char *homedir; 2158 int count; 2159 2160 if (NULL (dir)) 2161 dir = current_buffer->directory; 2162 if (NULL (defalt)) 2163 defalt = current_buffer->filename; 2164 2165 /* If dir starts with user's homedir, change that to ~. */ 2166 homedir = (char *) egetenv ("HOME"); 2167 if (homedir != 0 2168 && XTYPE (dir) == Lisp_String 2169 && !strncmp (homedir, XSTRING (dir)->data, strlen (homedir)) 2170 && XSTRING (dir)->data[strlen (homedir)] == '/') 2171 { 2172 dir = make_string (XSTRING (dir)->data + strlen (homedir) - 1, 2173 XSTRING (dir)->size - strlen (homedir) + 1); 2174 XSTRING (dir)->data[0] = '~'; 2175 } 2176 2177 if (insert_default_directory) 2178 insdef = dir; 2179 else 2180 insdef = build_string (""); 2181 2182 #ifdef VMS 2183 count = specpdl_ptr - specpdl; 2184 specbind (intern ("completion-ignore-case"), Qt); 2185 #endif 2186 2187 GCPRO2 (insdef, defalt); 2188 val = Fcompleting_read (prompt, intern ("read-file-name-internal"), 2189 dir, mustmatch, 2190 insert_default_directory ? insdef : Qnil); 2191 2192 #ifdef VMS 2193 unbind_to (count); 2194 #endif 2195 2196 UNGCPRO; 2197 if (NULL (val)) 2198 error ("No file name specified"); 2199 tem = Fstring_equal (val, insdef); 2200 if (!NULL (tem) && !NULL (defalt)) 2201 return defalt; 2202 return Fsubstitute_in_file_name (val); 2203 } 2204 2205 syms_of_fileio () 2206 { 2207 Qfile_error = intern ("file-error"); 2208 staticpro (&Qfile_error); 2209 Qfile_already_exists = intern("file-already-exists"); 2210 staticpro (&Qfile_already_exists); 2211 2212 Fput (Qfile_error, Qerror_conditions, 2213 Fcons (Qfile_error, Fcons (Qerror, Qnil))); 2214 Fput (Qfile_error, Qerror_message, 2215 build_string ("File error")); 2216 2217 Fput (Qfile_already_exists, Qerror_conditions, 2218 Fcons (Qfile_already_exists, 2219 Fcons (Qfile_error, Fcons (Qerror, Qnil)))); 2220 Fput (Qfile_already_exists, Qerror_message, 2221 build_string ("File already exists")); 2222 2223 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory, 2224 "*Non-nil means when reading a filename start with default dir in minibuffer."); 2225 insert_default_directory = 1; 2226 2227 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm, 2228 "*Non-nil means write new files with record format `stmlf'.\n\ 2229 nil means use format `var'. This variable is meaningful only on VMS."); 2230 vms_stmlf_recfm = 0; 2231 2232 defsubr (&Sfile_name_directory); 2233 defsubr (&Sfile_name_nondirectory); 2234 defsubr (&Sfile_name_as_directory); 2235 defsubr (&Sdirectory_file_name); 2236 defsubr (&Smake_temp_name); 2237 defsubr (&Sexpand_file_name); 2238 defsubr (&Ssubstitute_in_file_name); 2239 defsubr (&Scopy_file); 2240 defsubr (&Sdelete_file); 2241 defsubr (&Srename_file); 2242 defsubr (&Sadd_name_to_file); 2243 #ifdef S_IFLNK 2244 defsubr (&Smake_symbolic_link); 2245 #endif /* S_IFLNK */ 2246 #ifdef VMS 2247 defsubr (&Sdefine_logical_name); 2248 #endif /* VMS */ 2249 #ifdef HPUX_NET 2250 defsubr (&Ssysnetunam); 2251 #endif /* HPUX_NET */ 2252 defsubr (&Sfile_name_absolute_p); 2253 defsubr (&Sfile_exists_p); 2254 defsubr (&Sfile_readable_p); 2255 defsubr (&Sfile_writable_p); 2256 defsubr (&Sfile_symlink_p); 2257 defsubr (&Sfile_directory_p); 2258 defsubr (&Sfile_modes); 2259 defsubr (&Sset_file_modes); 2260 defsubr (&Sfile_newer_than_file_p); 2261 defsubr (&Sinsert_file_contents); 2262 defsubr (&Swrite_region); 2263 defsubr (&Sverify_visited_file_modtime); 2264 defsubr (&Sclear_visited_file_modtime); 2265 defsubr (&Sdo_auto_save); 2266 defsubr (&Sset_buffer_auto_saved); 2267 defsubr (&Srecent_auto_save_p); 2268 2269 defsubr (&Sread_file_name_internal); 2270 defsubr (&Sread_file_name); 2271 } 2272