*** empty log message ***
[emacs.git] / src / fileio.c
blobea7f8c6250f4bfcb712c01585fbe19f40b1245c0
1 /* File IO for GNU Emacs.
2 Copyright (C) 1985, 1986, 1987, 1988 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
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.
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.
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. */
21 #include <sys/types.h>
22 #include <sys/stat.h>
24 #ifdef VMS
25 #include "vms-pwd.h"
26 #else
27 #include <pwd.h>
28 #endif
30 #include <ctype.h>
32 #ifdef VMS
33 #include "dir.h"
34 #include <perror.h>
35 #include <stddef.h>
36 #include <string.h>
37 #else
38 #include <sys/dir.h>
39 #endif
41 #include <errno.h>
43 #ifndef vax11c
44 extern int errno;
45 extern char *sys_errlist[];
46 extern int sys_nerr;
47 #endif
49 #define err_str(a) ((a) < sys_nerr ? sys_errlist[a] : "unknown error")
51 #ifdef APOLLO
52 #include <sys/time.h>
53 #endif
55 #include "config.h"
56 #include "lisp.h"
57 #include "buffer.h"
58 #include "window.h"
60 #ifdef VMS
61 #include <file.h>
62 #include <rmsdef.h>
63 #include <fab.h>
64 #include <nam.h>
65 #endif
67 #include "systime.h"
69 #ifdef HPUX
70 #include <netio.h>
71 #ifndef HPUX8
72 #include <errnet.h>
73 #endif
74 #endif
76 #ifndef O_WRONLY
77 #define O_WRONLY 1
78 #endif
80 #define min(a, b) ((a) < (b) ? (a) : (b))
81 #define max(a, b) ((a) > (b) ? (a) : (b))
83 /* Nonzero during writing of auto-save files */
84 int auto_saving;
86 /* Set by auto_save_1 to mode of original file so Fwrite_region will create
87 a new file with the same mode as the original */
88 int auto_save_mode_bits;
90 /* Nonzero means, when reading a filename in the minibuffer,
91 start out by inserting the default directory into the minibuffer. */
92 int insert_default_directory;
94 /* On VMS, nonzero means write new files with record format stmlf.
95 Zero means use var format. */
96 int vms_stmlf_recfm;
98 Lisp_Object Qfile_error, Qfile_already_exists;
100 report_file_error (string, data)
101 char *string;
102 Lisp_Object data;
104 Lisp_Object errstring;
106 if (errno >= 0 && errno < sys_nerr)
107 errstring = build_string (sys_errlist[errno]);
108 else
109 errstring = build_string ("undocumented error code");
111 /* System error messages are capitalized. Downcase the initial
112 unless it is followed by a slash. */
113 if (XSTRING (errstring)->data[1] != '/')
114 XSTRING (errstring)->data[0] = DOWNCASE (XSTRING (errstring)->data[0]);
116 while (1)
117 Fsignal (Qfile_error,
118 Fcons (build_string (string), Fcons (errstring, data)));
121 close_file_unwind (fd)
122 Lisp_Object fd;
124 close (XFASTINT (fd));
127 DEFUN ("file-name-directory", Ffile_name_directory, Sfile_name_directory,
128 1, 1, 0,
129 "Return the directory component in file name NAME.\n\
130 Return nil if NAME does not include a directory.\n\
131 Otherwise return a directory spec.\n\
132 Given a Unix syntax file name, returns a string ending in slash;\n\
133 on VMS, perhaps instead a string ending in `:', `]' or `>'.")
134 (file)
135 Lisp_Object file;
137 register unsigned char *beg;
138 register unsigned char *p;
140 CHECK_STRING (file, 0);
142 beg = XSTRING (file)->data;
143 p = beg + XSTRING (file)->size;
145 while (p != beg && p[-1] != '/'
146 #ifdef VMS
147 && p[-1] != ':' && p[-1] != ']' && p[-1] != '>'
148 #endif /* VMS */
149 ) p--;
151 if (p == beg)
152 return Qnil;
153 return make_string (beg, p - beg);
156 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory, Sfile_name_nondirectory,
157 1, 1, 0,
158 "Return file name NAME sans its directory.\n\
159 For example, in a Unix-syntax file name,\n\
160 this is everything after the last slash,\n\
161 or the entire name if it contains no slash.")
162 (file)
163 Lisp_Object file;
165 register unsigned char *beg, *p, *end;
167 CHECK_STRING (file, 0);
169 beg = XSTRING (file)->data;
170 end = p = beg + XSTRING (file)->size;
172 while (p != beg && p[-1] != '/'
173 #ifdef VMS
174 && p[-1] != ':' && p[-1] != ']' && p[-1] != '>'
175 #endif /* VMS */
176 ) p--;
178 return make_string (p, end - p);
181 char *
182 file_name_as_directory (out, in)
183 char *out, *in;
185 int size = strlen (in) - 1;
187 strcpy (out, in);
189 #ifdef VMS
190 /* Is it already a directory string? */
191 if (in[size] == ':' || in[size] == ']' || in[size] == '>')
192 return out;
193 /* Is it a VMS directory file name? If so, hack VMS syntax. */
194 else if (! index (in, '/')
195 && ((size > 3 && ! strcmp (&in[size - 3], ".DIR"))
196 || (size > 3 && ! strcmp (&in[size - 3], ".dir"))
197 || (size > 5 && (! strncmp (&in[size - 5], ".DIR", 4)
198 || ! strncmp (&in[size - 5], ".dir", 4))
199 && (in[size - 1] == '.' || in[size - 1] == ';')
200 && in[size] == '1')))
202 register char *p, *dot;
203 char brack;
205 /* x.dir -> [.x]
206 dir:x.dir --> dir:[x]
207 dir:[x]y.dir --> dir:[x.y] */
208 p = in + size;
209 while (p != in && *p != ':' && *p != '>' && *p != ']') p--;
210 if (p != in)
212 strncpy (out, in, p - in);
213 out[p - in] = '\0';
214 if (*p == ':')
216 brack = ']';
217 strcat (out, ":[");
219 else
221 brack = *p;
222 strcat (out, ".");
224 p++;
226 else
228 brack = ']';
229 strcpy (out, "[.");
231 dot = index (p, '.');
232 if (dot)
234 /* blindly remove any extension */
235 size = strlen (out) + (dot - p);
236 strncat (out, p, dot - p);
238 else
240 strcat (out, p);
241 size = strlen (out);
243 out[size++] = brack;
244 out[size] = '\0';
246 #else /* not VMS */
247 /* For Unix syntax, Append a slash if necessary */
248 if (out[size] != '/')
249 strcat (out, "/");
250 #endif /* not VMS */
251 return out;
254 DEFUN ("file-name-as-directory", Ffile_name_as_directory,
255 Sfile_name_as_directory, 1, 1, 0,
256 "Return a string representing file FILENAME interpreted as a directory.\n\
257 This operation exists because a directory is also a file, but its name as\n\
258 a directory is different from its name as a file.\n\
259 The result can be used as the value of `default-directory'\n\
260 or passed as second argument to `expand-file-name'.\n\
261 For a Unix-syntax file name, just appends a slash.\n\
262 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
263 (file)
264 Lisp_Object file;
266 char *buf;
268 CHECK_STRING (file, 0);
269 if (NILP (file))
270 return Qnil;
271 buf = (char *) alloca (XSTRING (file)->size + 10);
272 return build_string (file_name_as_directory (buf, XSTRING (file)->data));
276 * Convert from directory name to filename.
277 * On VMS:
278 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
279 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
280 * On UNIX, it's simple: just make sure there is a terminating /
282 * Value is nonzero if the string output is different from the input.
285 directory_file_name (src, dst)
286 char *src, *dst;
288 long slen;
289 #ifdef VMS
290 long rlen;
291 char * ptr, * rptr;
292 char bracket;
293 struct FAB fab = cc$rms_fab;
294 struct NAM nam = cc$rms_nam;
295 char esa[NAM$C_MAXRSS];
296 #endif /* VMS */
298 slen = strlen (src);
299 #ifdef VMS
300 if (! index (src, '/')
301 && (src[slen - 1] == ']'
302 || src[slen - 1] == ':'
303 || src[slen - 1] == '>'))
305 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
306 fab.fab$l_fna = src;
307 fab.fab$b_fns = slen;
308 fab.fab$l_nam = &nam;
309 fab.fab$l_fop = FAB$M_NAM;
311 nam.nam$l_esa = esa;
312 nam.nam$b_ess = sizeof esa;
313 nam.nam$b_nop |= NAM$M_SYNCHK;
315 /* We call SYS$PARSE to handle such things as [--] for us. */
316 if (SYS$PARSE(&fab, 0, 0) == RMS$_NORMAL)
318 slen = nam.nam$b_esl;
319 if (esa[slen - 1] == ';' && esa[slen - 2] == '.')
320 slen -= 2;
321 esa[slen] = '\0';
322 src = esa;
324 if (src[slen - 1] != ']' && src[slen - 1] != '>')
326 /* what about when we have logical_name:???? */
327 if (src[slen - 1] == ':')
328 { /* Xlate logical name and see what we get */
329 ptr = strcpy (dst, src); /* upper case for getenv */
330 while (*ptr)
332 if ('a' <= *ptr && *ptr <= 'z')
333 *ptr -= 040;
334 ptr++;
336 dst[slen - 1] = 0; /* remove colon */
337 if (!(src = egetenv (dst)))
338 return 0;
339 /* should we jump to the beginning of this procedure?
340 Good points: allows us to use logical names that xlate
341 to Unix names,
342 Bad points: can be a problem if we just translated to a device
343 name...
344 For now, I'll punt and always expect VMS names, and hope for
345 the best! */
346 slen = strlen (src);
347 if (src[slen - 1] != ']' && src[slen - 1] != '>')
348 { /* no recursion here! */
349 strcpy (dst, src);
350 return 0;
353 else
354 { /* not a directory spec */
355 strcpy (dst, src);
356 return 0;
359 bracket = src[slen - 1];
361 /* If bracket is ']' or '>', bracket - 2 is the corresponding
362 opening bracket. */
363 ptr = index (src, bracket - 2);
364 if (ptr == 0)
365 { /* no opening bracket */
366 strcpy (dst, src);
367 return 0;
369 if (!(rptr = rindex (src, '.')))
370 rptr = ptr;
371 slen = rptr - src;
372 strncpy (dst, src, slen);
373 dst[slen] = '\0';
374 if (*rptr == '.')
376 dst[slen++] = bracket;
377 dst[slen] = '\0';
379 else
381 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
382 then translate the device and recurse. */
383 if (dst[slen - 1] == ':'
384 && dst[slen - 2] != ':' /* skip decnet nodes */
385 && strcmp(src + slen, "[000000]") == 0)
387 dst[slen - 1] = '\0';
388 if ((ptr = egetenv (dst))
389 && (rlen = strlen (ptr) - 1) > 0
390 && (ptr[rlen] == ']' || ptr[rlen] == '>')
391 && ptr[rlen - 1] == '.')
393 ptr[rlen - 1] = ']';
394 ptr[rlen] = '\0';
395 return directory_file_name (ptr, dst);
397 else
398 dst[slen - 1] = ':';
400 strcat (dst, "[000000]");
401 slen += 8;
403 rptr++;
404 rlen = strlen (rptr) - 1;
405 strncat (dst, rptr, rlen);
406 dst[slen + rlen] = '\0';
407 strcat (dst, ".DIR.1");
408 return 1;
410 #endif /* VMS */
411 /* Process as Unix format: just remove any final slash.
412 But leave "/" unchanged; do not change it to "". */
413 strcpy (dst, src);
414 if (dst[slen - 1] == '/' && slen > 1)
415 dst[slen - 1] = 0;
416 return 1;
419 DEFUN ("directory-file-name", Fdirectory_file_name, Sdirectory_file_name,
420 1, 1, 0,
421 "Returns the file name of the directory named DIR.\n\
422 This is the name of the file that holds the data for the directory DIR.\n\
423 This operation exists because a directory is also a file, but its name as\n\
424 a directory is different from its name as a file.\n\
425 In Unix-syntax, this function just removes the final slash.\n\
426 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
427 it returns a file name such as \"[X]Y.DIR.1\".")
428 (directory)
429 Lisp_Object directory;
431 char *buf;
433 CHECK_STRING (directory, 0);
435 if (NILP (directory))
436 return Qnil;
437 #ifdef VMS
438 /* 20 extra chars is insufficient for VMS, since we might perform a
439 logical name translation. an equivalence string can be up to 255
440 chars long, so grab that much extra space... - sss */
441 buf = (char *) alloca (XSTRING (directory)->size + 20 + 255);
442 #else
443 buf = (char *) alloca (XSTRING (directory)->size + 20);
444 #endif
445 directory_file_name (XSTRING (directory)->data, buf);
446 return build_string (buf);
449 DEFUN ("make-temp-name", Fmake_temp_name, Smake_temp_name, 1, 1, 0,
450 "Generate temporary file name (string) starting with PREFIX (a string).\n\
451 The Emacs process number forms part of the result,\n\
452 so there is no danger of generating a name being used by another process.")
453 (prefix)
454 Lisp_Object prefix;
456 Lisp_Object val;
457 val = concat2 (prefix, build_string ("XXXXXX"));
458 mktemp (XSTRING (val)->data);
459 return val;
462 DEFUN ("expand-file-name", Fexpand_file_name, Sexpand_file_name, 1, 2, 0,
463 "Convert FILENAME to absolute, and canonicalize it.\n\
464 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
465 (does not start with slash); if DEFAULT is nil or missing,\n\
466 the current buffer's value of default-directory is used.\n\
467 Path components that are `.' are removed, and \n\
468 path components followed by `..' are removed, along with the `..' itself;\n\
469 note that these simplifications are done without checking the resulting\n\
470 paths in the file system.\n\
471 An initial `~/' expands to your home directory.\n\
472 An initial `~USER/' expands to USER's home directory.\n\
473 See also the function `substitute-in-file-name'.")
474 (name, defalt)
475 Lisp_Object name, defalt;
477 unsigned char *nm;
479 register unsigned char *newdir, *p, *o;
480 int tlen;
481 unsigned char *target;
482 struct passwd *pw;
483 int lose;
484 #ifdef VMS
485 unsigned char * colon = 0;
486 unsigned char * close = 0;
487 unsigned char * slash = 0;
488 unsigned char * brack = 0;
489 int lbrack = 0, rbrack = 0;
490 int dots = 0;
491 #endif /* VMS */
493 CHECK_STRING (name, 0);
495 #ifdef VMS
496 /* Filenames on VMS are always upper case. */
497 name = Fupcase (name);
498 #endif
500 nm = XSTRING (name)->data;
502 /* If nm is absolute, flush ...// and detect /./ and /../.
503 If no /./ or /../ we can return right away. */
504 if (
505 nm[0] == '/'
506 #ifdef VMS
507 || index (nm, ':')
508 #endif /* VMS */
511 p = nm;
512 lose = 0;
513 while (*p)
515 if (p[0] == '/' && p[1] == '/'
516 #ifdef APOLLO
517 /* // at start of filename is meaningful on Apollo system */
518 && nm != p
519 #endif /* APOLLO */
521 nm = p + 1;
522 if (p[0] == '/' && p[1] == '~')
523 nm = p + 1, lose = 1;
524 if (p[0] == '/' && p[1] == '.'
525 && (p[2] == '/' || p[2] == 0
526 || (p[2] == '.' && (p[3] == '/' || p[3] == 0))))
527 lose = 1;
528 #ifdef VMS
529 if (p[0] == '\\')
530 lose = 1;
531 if (p[0] == '/') {
532 /* if dev:[dir]/, move nm to / */
533 if (!slash && p > nm && (brack || colon)) {
534 nm = (brack ? brack + 1 : colon + 1);
535 lbrack = rbrack = 0;
536 brack = 0;
537 colon = 0;
539 slash = p;
541 if (p[0] == '-')
542 #ifndef VMS4_4
543 /* VMS pre V4.4,convert '-'s in filenames. */
544 if (lbrack == rbrack)
546 if (dots < 2) /* this is to allow negative version numbers */
547 p[0] = '_';
549 else
550 #endif /* VMS4_4 */
551 if (lbrack > rbrack &&
552 ((p[-1] == '.' || p[-1] == '[' || p[-1] == '<') &&
553 (p[1] == '.' || p[1] == ']' || p[1] == '>')))
554 lose = 1;
555 #ifndef VMS4_4
556 else
557 p[0] = '_';
558 #endif /* VMS4_4 */
559 /* count open brackets, reset close bracket pointer */
560 if (p[0] == '[' || p[0] == '<')
561 lbrack++, brack = 0;
562 /* count close brackets, set close bracket pointer */
563 if (p[0] == ']' || p[0] == '>')
564 rbrack++, brack = p;
565 /* detect ][ or >< */
566 if ((p[0] == ']' || p[0] == '>') && (p[1] == '[' || p[1] == '<'))
567 lose = 1;
568 if ((p[0] == ':' || p[0] == ']' || p[0] == '>') && p[1] == '~')
569 nm = p + 1, lose = 1;
570 if (p[0] == ':' && (colon || slash))
571 /* if dev1:[dir]dev2:, move nm to dev2: */
572 if (brack)
574 nm = brack + 1;
575 brack = 0;
577 /* if /pathname/dev:, move nm to dev: */
578 else if (slash)
579 nm = slash + 1;
580 /* if node::dev:, move colon following dev */
581 else if (colon && colon[-1] == ':')
582 colon = p;
583 /* if dev1:dev2:, move nm to dev2: */
584 else if (colon && colon[-1] != ':')
586 nm = colon + 1;
587 colon = 0;
589 if (p[0] == ':' && !colon)
591 if (p[1] == ':')
592 p++;
593 colon = p;
595 if (lbrack == rbrack)
596 if (p[0] == ';')
597 dots = 2;
598 else if (p[0] == '.')
599 dots++;
600 #endif /* VMS */
601 p++;
603 if (!lose)
605 #ifdef VMS
606 if (index (nm, '/'))
607 return build_string (sys_translate_unix (nm));
608 #endif /* VMS */
609 if (nm == XSTRING (name)->data)
610 return name;
611 return build_string (nm);
615 /* Now determine directory to start with and put it in newdir */
617 newdir = 0;
619 if (nm[0] == '~') /* prefix ~ */
620 if (nm[1] == '/'
621 #ifdef VMS
622 || nm[1] == ':'
623 #endif /* VMS */
624 || nm[1] == 0)/* ~/filename */
626 if (!(newdir = (unsigned char *) egetenv ("HOME")))
627 newdir = (unsigned char *) "";
628 nm++;
629 #ifdef VMS
630 nm++; /* Don't leave the slash in nm. */
631 #endif /* VMS */
633 else /* ~user/filename */
635 for (p = nm; *p && (*p != '/'
636 #ifdef VMS
637 && *p != ':'
638 #endif /* VMS */
639 ); p++);
640 o = (unsigned char *) alloca (p - nm + 1);
641 bcopy ((char *) nm, o, p - nm);
642 o [p - nm] = 0;
644 pw = (struct passwd *) getpwnam (o + 1);
645 if (!pw)
646 error ("\"%s\" isn't a registered user", o + 1);
648 #ifdef VMS
649 nm = p + 1; /* skip the terminator */
650 #else
651 nm = p;
652 #endif /* VMS */
653 newdir = (unsigned char *) pw -> pw_dir;
656 if (nm[0] != '/'
657 #ifdef VMS
658 && !index (nm, ':')
659 #endif /* not VMS */
660 && !newdir)
662 if (NILP (defalt))
663 defalt = current_buffer->directory;
664 CHECK_STRING (defalt, 1);
665 newdir = XSTRING (defalt)->data;
668 if (newdir != 0)
670 /* Get rid of any slash at the end of newdir. */
671 int length = strlen (newdir);
672 if (newdir[length - 1] == '/')
674 unsigned char *temp = (unsigned char *) alloca (length);
675 bcopy (newdir, temp, length - 1);
676 temp[length - 1] = 0;
677 newdir = temp;
679 tlen = length + 1;
681 else
682 tlen = 0;
684 /* Now concatenate the directory and name to new space in the stack frame */
685 tlen += strlen (nm) + 1;
686 target = (unsigned char *) alloca (tlen);
687 *target = 0;
689 if (newdir)
691 #ifndef VMS
692 if (nm[0] == 0 || nm[0] == '/')
693 strcpy (target, newdir);
694 else
695 #endif
696 file_name_as_directory (target, newdir);
699 strcat (target, nm);
700 #ifdef VMS
701 if (index (target, '/'))
702 strcpy (target, sys_translate_unix (target));
703 #endif /* VMS */
705 /* Now canonicalize by removing /. and /foo/.. if they appear */
707 p = target;
708 o = target;
710 while (*p)
712 #ifdef VMS
713 if (*p != ']' && *p != '>' && *p != '-')
715 if (*p == '\\')
716 p++;
717 *o++ = *p++;
719 else if ((p[0] == ']' || p[0] == '>') && p[0] == p[1] + 2)
720 /* brackets are offset from each other by 2 */
722 p += 2;
723 if (*p != '.' && *p != '-' && o[-1] != '.')
724 /* convert [foo][bar] to [bar] */
725 while (o[-1] != '[' && o[-1] != '<')
726 o--;
727 else if (*p == '-' && *o != '.')
728 *--p = '.';
730 else if (p[0] == '-' && o[-1] == '.' &&
731 (p[1] == '.' || p[1] == ']' || p[1] == '>'))
732 /* flush .foo.- ; leave - if stopped by '[' or '<' */
735 o--;
736 while (o[-1] != '.' && o[-1] != '[' && o[-1] != '<');
737 if (p[1] == '.') /* foo.-.bar ==> bar*/
738 p += 2;
739 else if (o[-1] == '.') /* '.foo.-]' ==> ']' */
740 p++, o--;
741 /* else [foo.-] ==> [-] */
743 else
745 #ifndef VMS4_4
746 if (*p == '-' &&
747 o[-1] != '[' && o[-1] != '<' && o[-1] != '.' &&
748 p[1] != ']' && p[1] != '>' && p[1] != '.')
749 *p = '_';
750 #endif /* VMS4_4 */
751 *o++ = *p++;
753 #else /* not VMS */
754 if (*p != '/')
756 *o++ = *p++;
758 else if (!strncmp (p, "//", 2)
759 #ifdef APOLLO
760 /* // at start of filename is meaningful in Apollo system */
761 && o != target
762 #endif /* APOLLO */
765 o = target;
766 p++;
768 else if (p[0] == '/' && p[1] == '.' &&
769 (p[2] == '/' || p[2] == 0))
770 p += 2;
771 else if (!strncmp (p, "/..", 3)
772 /* `/../' is the "superroot" on certain file systems. */
773 && o != target
774 && (p[3] == '/' || p[3] == 0))
776 while (o != target && *--o != '/')
778 #ifdef APOLLO
779 if (o == target + 1 && o[-1] == '/' && o[0] == '/')
780 ++o;
781 else
782 #endif /* APOLLO */
783 if (o == target && *o == '/')
784 ++o;
785 p += 3;
787 else
789 *o++ = *p++;
791 #endif /* not VMS */
794 return make_string (target, o - target);
796 #if 0
797 DEFUN ("expand-file-name", Fexpand_file_name, Sexpand_file_name, 1, 2, 0,
798 "Convert FILENAME to absolute, and canonicalize it.\n\
799 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
800 (does not start with slash); if DEFAULT is nil or missing,\n\
801 the current buffer's value of default-directory is used.\n\
802 Filenames containing `.' or `..' as components are simplified;\n\
803 initial `~/' expands to your home directory.\n\
804 See also the function `substitute-in-file-name'.")
805 (name, defalt)
806 Lisp_Object name, defalt;
808 unsigned char *nm;
810 register unsigned char *newdir, *p, *o;
811 int tlen;
812 unsigned char *target;
813 struct passwd *pw;
814 int lose;
815 #ifdef VMS
816 unsigned char * colon = 0;
817 unsigned char * close = 0;
818 unsigned char * slash = 0;
819 unsigned char * brack = 0;
820 int lbrack = 0, rbrack = 0;
821 int dots = 0;
822 #endif /* VMS */
824 CHECK_STRING (name, 0);
826 #ifdef VMS
827 /* Filenames on VMS are always upper case. */
828 name = Fupcase (name);
829 #endif
831 nm = XSTRING (name)->data;
833 /* If nm is absolute, flush ...// and detect /./ and /../.
834 If no /./ or /../ we can return right away. */
835 if (
836 nm[0] == '/'
837 #ifdef VMS
838 || index (nm, ':')
839 #endif /* VMS */
842 p = nm;
843 lose = 0;
844 while (*p)
846 if (p[0] == '/' && p[1] == '/'
847 #ifdef APOLLO
848 /* // at start of filename is meaningful on Apollo system */
849 && nm != p
850 #endif /* APOLLO */
852 nm = p + 1;
853 if (p[0] == '/' && p[1] == '~')
854 nm = p + 1, lose = 1;
855 if (p[0] == '/' && p[1] == '.'
856 && (p[2] == '/' || p[2] == 0
857 || (p[2] == '.' && (p[3] == '/' || p[3] == 0))))
858 lose = 1;
859 #ifdef VMS
860 if (p[0] == '\\')
861 lose = 1;
862 if (p[0] == '/') {
863 /* if dev:[dir]/, move nm to / */
864 if (!slash && p > nm && (brack || colon)) {
865 nm = (brack ? brack + 1 : colon + 1);
866 lbrack = rbrack = 0;
867 brack = 0;
868 colon = 0;
870 slash = p;
872 if (p[0] == '-')
873 #ifndef VMS4_4
874 /* VMS pre V4.4,convert '-'s in filenames. */
875 if (lbrack == rbrack)
877 if (dots < 2) /* this is to allow negative version numbers */
878 p[0] = '_';
880 else
881 #endif /* VMS4_4 */
882 if (lbrack > rbrack &&
883 ((p[-1] == '.' || p[-1] == '[' || p[-1] == '<') &&
884 (p[1] == '.' || p[1] == ']' || p[1] == '>')))
885 lose = 1;
886 #ifndef VMS4_4
887 else
888 p[0] = '_';
889 #endif /* VMS4_4 */
890 /* count open brackets, reset close bracket pointer */
891 if (p[0] == '[' || p[0] == '<')
892 lbrack++, brack = 0;
893 /* count close brackets, set close bracket pointer */
894 if (p[0] == ']' || p[0] == '>')
895 rbrack++, brack = p;
896 /* detect ][ or >< */
897 if ((p[0] == ']' || p[0] == '>') && (p[1] == '[' || p[1] == '<'))
898 lose = 1;
899 if ((p[0] == ':' || p[0] == ']' || p[0] == '>') && p[1] == '~')
900 nm = p + 1, lose = 1;
901 if (p[0] == ':' && (colon || slash))
902 /* if dev1:[dir]dev2:, move nm to dev2: */
903 if (brack)
905 nm = brack + 1;
906 brack = 0;
908 /* if /pathname/dev:, move nm to dev: */
909 else if (slash)
910 nm = slash + 1;
911 /* if node::dev:, move colon following dev */
912 else if (colon && colon[-1] == ':')
913 colon = p;
914 /* if dev1:dev2:, move nm to dev2: */
915 else if (colon && colon[-1] != ':')
917 nm = colon + 1;
918 colon = 0;
920 if (p[0] == ':' && !colon)
922 if (p[1] == ':')
923 p++;
924 colon = p;
926 if (lbrack == rbrack)
927 if (p[0] == ';')
928 dots = 2;
929 else if (p[0] == '.')
930 dots++;
931 #endif /* VMS */
932 p++;
934 if (!lose)
936 #ifdef VMS
937 if (index (nm, '/'))
938 return build_string (sys_translate_unix (nm));
939 #endif /* VMS */
940 if (nm == XSTRING (name)->data)
941 return name;
942 return build_string (nm);
946 /* Now determine directory to start with and put it in NEWDIR */
948 newdir = 0;
950 if (nm[0] == '~') /* prefix ~ */
951 if (nm[1] == '/'
952 #ifdef VMS
953 || nm[1] == ':'
954 #endif /* VMS */
955 || nm[1] == 0)/* ~/filename */
957 if (!(newdir = (unsigned char *) egetenv ("HOME")))
958 newdir = (unsigned char *) "";
959 nm++;
960 #ifdef VMS
961 nm++; /* Don't leave the slash in nm. */
962 #endif /* VMS */
964 else /* ~user/filename */
966 /* Get past ~ to user */
967 unsigned char *user = nm + 1;
968 /* Find end of name. */
969 unsigned char *ptr = (unsigned char *) index (user, '/');
970 int len = ptr ? ptr - user : strlen (user);
971 #ifdef VMS
972 unsigned char *ptr1 = index (user, ':');
973 if (ptr1 != 0 && ptr1 - user < len)
974 len = ptr1 - user;
975 #endif /* VMS */
976 /* Copy the user name into temp storage. */
977 o = (unsigned char *) alloca (len + 1);
978 bcopy ((char *) user, o, len);
979 o[len] = 0;
981 /* Look up the user name. */
982 pw = (struct passwd *) getpwnam (o + 1);
983 if (!pw)
984 error ("\"%s\" isn't a registered user", o + 1);
986 newdir = (unsigned char *) pw->pw_dir;
988 /* Discard the user name from NM. */
989 nm += len;
992 if (nm[0] != '/'
993 #ifdef VMS
994 && !index (nm, ':')
995 #endif /* not VMS */
996 && !newdir)
998 if (NILP (defalt))
999 defalt = current_buffer->directory;
1000 CHECK_STRING (defalt, 1);
1001 newdir = XSTRING (defalt)->data;
1004 /* Now concatenate the directory and name to new space in the stack frame */
1006 tlen = (newdir ? strlen (newdir) + 1 : 0) + strlen (nm) + 1;
1007 target = (unsigned char *) alloca (tlen);
1008 *target = 0;
1010 if (newdir)
1012 #ifndef VMS
1013 if (nm[0] == 0 || nm[0] == '/')
1014 strcpy (target, newdir);
1015 else
1016 #endif
1017 file_name_as_directory (target, newdir);
1020 strcat (target, nm);
1021 #ifdef VMS
1022 if (index (target, '/'))
1023 strcpy (target, sys_translate_unix (target));
1024 #endif /* VMS */
1026 /* Now canonicalize by removing /. and /foo/.. if they appear */
1028 p = target;
1029 o = target;
1031 while (*p)
1033 #ifdef VMS
1034 if (*p != ']' && *p != '>' && *p != '-')
1036 if (*p == '\\')
1037 p++;
1038 *o++ = *p++;
1040 else if ((p[0] == ']' || p[0] == '>') && p[0] == p[1] + 2)
1041 /* brackets are offset from each other by 2 */
1043 p += 2;
1044 if (*p != '.' && *p != '-' && o[-1] != '.')
1045 /* convert [foo][bar] to [bar] */
1046 while (o[-1] != '[' && o[-1] != '<')
1047 o--;
1048 else if (*p == '-' && *o != '.')
1049 *--p = '.';
1051 else if (p[0] == '-' && o[-1] == '.' &&
1052 (p[1] == '.' || p[1] == ']' || p[1] == '>'))
1053 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1056 o--;
1057 while (o[-1] != '.' && o[-1] != '[' && o[-1] != '<');
1058 if (p[1] == '.') /* foo.-.bar ==> bar*/
1059 p += 2;
1060 else if (o[-1] == '.') /* '.foo.-]' ==> ']' */
1061 p++, o--;
1062 /* else [foo.-] ==> [-] */
1064 else
1066 #ifndef VMS4_4
1067 if (*p == '-' &&
1068 o[-1] != '[' && o[-1] != '<' && o[-1] != '.' &&
1069 p[1] != ']' && p[1] != '>' && p[1] != '.')
1070 *p = '_';
1071 #endif /* VMS4_4 */
1072 *o++ = *p++;
1074 #else /* not VMS */
1075 if (*p != '/')
1077 *o++ = *p++;
1079 else if (!strncmp (p, "//", 2)
1080 #ifdef APOLLO
1081 /* // at start of filename is meaningful in Apollo system */
1082 && o != target
1083 #endif /* APOLLO */
1086 o = target;
1087 p++;
1089 else if (p[0] == '/' && p[1] == '.' &&
1090 (p[2] == '/' || p[2] == 0))
1091 p += 2;
1092 else if (!strncmp (p, "/..", 3)
1093 /* `/../' is the "superroot" on certain file systems. */
1094 && o != target
1095 && (p[3] == '/' || p[3] == 0))
1097 while (o != target && *--o != '/')
1099 #ifdef APOLLO
1100 if (o == target + 1 && o[-1] == '/' && o[0] == '/')
1101 ++o;
1102 else
1103 #endif /* APOLLO */
1104 if (o == target && *o == '/')
1105 ++o;
1106 p += 3;
1108 else
1110 *o++ = *p++;
1112 #endif /* not VMS */
1115 return make_string (target, o - target);
1117 #endif
1119 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name,
1120 Ssubstitute_in_file_name, 1, 1, 0,
1121 "Substitute environment variables referred to in FILENAME.\n\
1122 `$FOO' where FOO is an environment variable name means to substitute\n\
1123 the value of that variable. The variable name should be terminated\n\
1124 with a character not a letter, digit or underscore; otherwise, enclose\n\
1125 the entire variable name in braces.\n\
1126 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1127 On VMS, `$' substitution is not done; this function does little and only\n\
1128 duplicates what `expand-file-name' does.")
1129 (string)
1130 Lisp_Object string;
1132 unsigned char *nm;
1134 register unsigned char *s, *p, *o, *x, *endp;
1135 unsigned char *target;
1136 int total = 0;
1137 int substituted = 0;
1138 unsigned char *xnm;
1140 CHECK_STRING (string, 0);
1142 nm = XSTRING (string)->data;
1143 endp = nm + XSTRING (string)->size;
1145 /* If /~ or // appears, discard everything through first slash. */
1147 for (p = nm; p != endp; p++)
1149 if ((p[0] == '~' ||
1150 #ifdef APOLLO
1151 /* // at start of file name is meaningful in Apollo system */
1152 (p[0] == '/' && p - 1 != nm)
1153 #else /* not APOLLO */
1154 p[0] == '/'
1155 #endif /* not APOLLO */
1157 && p != nm &&
1158 #ifdef VMS
1159 (p[-1] == ':' || p[-1] == ']' || p[-1] == '>' ||
1160 #endif /* VMS */
1161 p[-1] == '/')
1162 #ifdef VMS
1164 #endif /* VMS */
1166 nm = p;
1167 substituted = 1;
1171 #ifdef VMS
1172 return build_string (nm);
1173 #else
1175 /* See if any variables are substituted into the string
1176 and find the total length of their values in `total' */
1178 for (p = nm; p != endp;)
1179 if (*p != '$')
1180 p++;
1181 else
1183 p++;
1184 if (p == endp)
1185 goto badsubst;
1186 else if (*p == '$')
1188 /* "$$" means a single "$" */
1189 p++;
1190 total -= 1;
1191 substituted = 1;
1192 continue;
1194 else if (*p == '{')
1196 o = ++p;
1197 while (p != endp && *p != '}') p++;
1198 if (*p != '}') goto missingclose;
1199 s = p;
1201 else
1203 o = p;
1204 while (p != endp && (isalnum (*p) || *p == '_')) p++;
1205 s = p;
1208 /* Copy out the variable name */
1209 target = (unsigned char *) alloca (s - o + 1);
1210 strncpy (target, o, s - o);
1211 target[s - o] = 0;
1213 /* Get variable value */
1214 o = (unsigned char *) egetenv (target);
1215 /* The presence of this code makes vax 5.0 crash, for reasons yet unknown */
1216 #if 0
1217 #ifdef USG
1218 if (!o && !strcmp (target, "USER"))
1219 o = egetenv ("LOGNAME");
1220 #endif /* USG */
1221 #endif /* 0 */
1222 if (!o) goto badvar;
1223 total += strlen (o);
1224 substituted = 1;
1227 if (!substituted)
1228 return string;
1230 /* If substitution required, recopy the string and do it */
1231 /* Make space in stack frame for the new copy */
1232 xnm = (unsigned char *) alloca (XSTRING (string)->size + total + 1);
1233 x = xnm;
1235 /* Copy the rest of the name through, replacing $ constructs with values */
1236 for (p = nm; *p;)
1237 if (*p != '$')
1238 *x++ = *p++;
1239 else
1241 p++;
1242 if (p == endp)
1243 goto badsubst;
1244 else if (*p == '$')
1246 *x++ = *p++;
1247 continue;
1249 else if (*p == '{')
1251 o = ++p;
1252 while (p != endp && *p != '}') p++;
1253 if (*p != '}') goto missingclose;
1254 s = p++;
1256 else
1258 o = p;
1259 while (p != endp && (isalnum (*p) || *p == '_')) p++;
1260 s = p;
1263 /* Copy out the variable name */
1264 target = (unsigned char *) alloca (s - o + 1);
1265 strncpy (target, o, s - o);
1266 target[s - o] = 0;
1268 /* Get variable value */
1269 o = (unsigned char *) egetenv (target);
1270 /* The presence of this code makes vax 5.0 crash, for reasons yet unknown */
1271 #if 0
1272 #ifdef USG
1273 if (!o && !strcmp (target, "USER"))
1274 o = egetenv ("LOGNAME");
1275 #endif /* USG */
1276 #endif /* 0 */
1277 if (!o)
1278 goto badvar;
1280 strcpy (x, o);
1281 x += strlen (o);
1284 *x = 0;
1286 /* If /~ or // appears, discard everything through first slash. */
1288 for (p = xnm; p != x; p++)
1289 if ((p[0] == '~' ||
1290 #ifdef APOLLO
1291 /* // at start of file name is meaningful in Apollo system */
1292 (p[0] == '/' && p - 1 != xnm)
1293 #else /* not APOLLO */
1294 p[0] == '/'
1295 #endif /* not APOLLO */
1297 && p != nm && p[-1] == '/')
1298 xnm = p;
1300 return make_string (xnm, x - xnm);
1302 badsubst:
1303 error ("Bad format environment-variable substitution");
1304 missingclose:
1305 error ("Missing \"}\" in environment-variable substitution");
1306 badvar:
1307 error ("Substituting nonexistent environment variable \"%s\"", target);
1309 /* NOTREACHED */
1310 #endif /* not VMS */
1313 Lisp_Object
1314 expand_and_dir_to_file (filename, defdir)
1315 Lisp_Object filename, defdir;
1317 register Lisp_Object abspath;
1319 abspath = Fexpand_file_name (filename, defdir);
1320 #ifdef VMS
1322 register int c = XSTRING (abspath)->data[XSTRING (abspath)->size - 1];
1323 if (c == ':' || c == ']' || c == '>')
1324 abspath = Fdirectory_file_name (abspath);
1326 #else
1327 /* Remove final slash, if any (unless path is root).
1328 stat behaves differently depending! */
1329 if (XSTRING (abspath)->size > 1
1330 && XSTRING (abspath)->data[XSTRING (abspath)->size - 1] == '/')
1332 if (EQ (abspath, filename))
1333 abspath = Fcopy_sequence (abspath);
1334 XSTRING (abspath)->data[XSTRING (abspath)->size - 1] = 0;
1336 #endif
1337 return abspath;
1340 barf_or_query_if_file_exists (absname, querystring, interactive)
1341 Lisp_Object absname;
1342 unsigned char *querystring;
1343 int interactive;
1345 register Lisp_Object tem;
1346 struct gcpro gcpro1;
1348 if (access (XSTRING (absname)->data, 4) >= 0)
1350 if (! interactive)
1351 Fsignal (Qfile_already_exists,
1352 Fcons (build_string ("File already exists"),
1353 Fcons (absname, Qnil)));
1354 GCPRO1 (absname);
1355 tem = do_yes_or_no_p (format1 ("File %s already exists; %s anyway? ",
1356 XSTRING (absname)->data, querystring));
1357 UNGCPRO;
1358 if (NILP (tem))
1359 Fsignal (Qfile_already_exists,
1360 Fcons (build_string ("File already exists"),
1361 Fcons (absname, Qnil)));
1363 return;
1366 DEFUN ("copy-file", Fcopy_file, Scopy_file, 2, 4,
1367 "fCopy file: \nFCopy %s to file: \np\nP",
1368 "Copy FILE to NEWNAME. Both args must be strings.\n\
1369 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
1370 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
1371 A number as third arg means request confirmation if NEWNAME already exists.\n\
1372 This is what happens in interactive use with M-x.\n\
1373 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
1374 last-modified time as the old one. (This works on only some systems.)\n\
1375 A prefix arg makes KEEP-TIME non-nil.")
1376 (filename, newname, ok_if_already_exists, keep_date)
1377 Lisp_Object filename, newname, ok_if_already_exists, keep_date;
1379 int ifd, ofd, n;
1380 char buf[16 * 1024];
1381 struct stat st;
1382 struct gcpro gcpro1, gcpro2;
1383 int count = specpdl_ptr - specpdl;
1385 GCPRO2 (filename, newname);
1386 CHECK_STRING (filename, 0);
1387 CHECK_STRING (newname, 1);
1388 filename = Fexpand_file_name (filename, Qnil);
1389 newname = Fexpand_file_name (newname, Qnil);
1390 if (NILP (ok_if_already_exists)
1391 || XTYPE (ok_if_already_exists) == Lisp_Int)
1392 barf_or_query_if_file_exists (newname, "copy to it",
1393 XTYPE (ok_if_already_exists) == Lisp_Int);
1395 ifd = open (XSTRING (filename)->data, 0);
1396 if (ifd < 0)
1397 report_file_error ("Opening input file", Fcons (filename, Qnil));
1399 record_unwind_protect (close_file_unwind, make_number (ifd));
1401 #ifdef VMS
1402 /* Create the copy file with the same record format as the input file */
1403 ofd = sys_creat (XSTRING (newname)->data, 0666, ifd);
1404 #else
1405 ofd = creat (XSTRING (newname)->data, 0666);
1406 #endif /* VMS */
1407 if (ofd < 0)
1408 report_file_error ("Opening output file", Fcons (newname, Qnil));
1410 record_unwind_protect (close_file_unwind, make_number (ofd));
1412 immediate_quit = 1;
1413 QUIT;
1414 while ((n = read (ifd, buf, sizeof buf)) > 0)
1415 if (write (ofd, buf, n) != n)
1416 report_file_error ("I/O error", Fcons (newname, Qnil));
1417 immediate_quit = 0;
1419 if (fstat (ifd, &st) >= 0)
1421 if (!NILP (keep_date))
1423 EMACS_TIME atime, mtime;
1424 EMACS_SET_SECS_USECS (atime, st.st_atime, 0);
1425 EMACS_SET_SECS_USECS (mtime, st.st_mtime, 0);
1426 EMACS_SET_UTIMES (XSTRING (newname)->data, atime, mtime);
1428 #ifdef APOLLO
1429 if (!egetenv ("USE_DOMAIN_ACLS"))
1430 #endif
1431 chmod (XSTRING (newname)->data, st.st_mode & 07777);
1434 /* Discard the unwind protects. */
1435 specpdl_ptr = specpdl + count;
1437 close (ifd);
1438 if (close (ofd) < 0)
1439 report_file_error ("I/O error", Fcons (newname, Qnil));
1441 UNGCPRO;
1442 return Qnil;
1445 DEFUN ("make-directory", Fmake_directory, Smake_directory, 1, 1, "FMake directory: ",
1446 "Create a directory. One argument, a file name string.")
1447 (dirname)
1448 Lisp_Object dirname;
1450 unsigned char *dir;
1452 CHECK_STRING (dirname, 0);
1453 dirname = Fexpand_file_name (dirname, Qnil);
1454 dir = XSTRING (dirname)->data;
1456 if (mkdir (dir, 0777) != 0)
1457 report_file_error ("Creating directory", Flist (1, &dirname));
1459 return Qnil;
1462 DEFUN ("remove-directory", Fremove_directory, Sremove_directory, 1, 1, "FRemove directory: ",
1463 "Remove a directory. One argument, a file name string.")
1464 (dirname)
1465 Lisp_Object dirname;
1467 unsigned char *dir;
1469 CHECK_STRING (dirname, 0);
1470 dirname = Fexpand_file_name (dirname, Qnil);
1471 dir = XSTRING (dirname)->data;
1473 if (rmdir (dir) != 0)
1474 report_file_error ("Removing directory", Flist (1, &dirname));
1476 return Qnil;
1479 DEFUN ("delete-file", Fdelete_file, Sdelete_file, 1, 1, "fDelete file: ",
1480 "Delete specified file. One argument, a file name string.\n\
1481 If file has multiple names, it continues to exist with the other names.")
1482 (filename)
1483 Lisp_Object filename;
1485 CHECK_STRING (filename, 0);
1486 filename = Fexpand_file_name (filename, Qnil);
1487 if (0 > unlink (XSTRING (filename)->data))
1488 report_file_error ("Removing old name", Flist (1, &filename));
1489 return Qnil;
1492 DEFUN ("rename-file", Frename_file, Srename_file, 2, 3,
1493 "fRename file: \nFRename %s to file: \np",
1494 "Rename FILE as NEWNAME. Both args strings.\n\
1495 If file has names other than FILE, it continues to have those names.\n\
1496 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
1497 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
1498 A number as third arg means request confirmation if NEWNAME already exists.\n\
1499 This is what happens in interactive use with M-x.")
1500 (filename, newname, ok_if_already_exists)
1501 Lisp_Object filename, newname, ok_if_already_exists;
1503 #ifdef NO_ARG_ARRAY
1504 Lisp_Object args[2];
1505 #endif
1506 struct gcpro gcpro1, gcpro2;
1508 GCPRO2 (filename, newname);
1509 CHECK_STRING (filename, 0);
1510 CHECK_STRING (newname, 1);
1511 filename = Fexpand_file_name (filename, Qnil);
1512 newname = Fexpand_file_name (newname, Qnil);
1513 if (NILP (ok_if_already_exists)
1514 || XTYPE (ok_if_already_exists) == Lisp_Int)
1515 barf_or_query_if_file_exists (newname, "rename to it",
1516 XTYPE (ok_if_already_exists) == Lisp_Int);
1517 #ifndef BSD4_1
1518 if (0 > rename (XSTRING (filename)->data, XSTRING (newname)->data))
1519 #else
1520 if (0 > link (XSTRING (filename)->data, XSTRING (newname)->data)
1521 || 0 > unlink (XSTRING (filename)->data))
1522 #endif
1524 if (errno == EXDEV)
1526 Fcopy_file (filename, newname, ok_if_already_exists, Qt);
1527 Fdelete_file (filename);
1529 else
1530 #ifdef NO_ARG_ARRAY
1532 args[0] = filename;
1533 args[1] = newname;
1534 report_file_error ("Renaming", Flist (2, args));
1536 #else
1537 report_file_error ("Renaming", Flist (2, &filename));
1538 #endif
1540 UNGCPRO;
1541 return Qnil;
1544 DEFUN ("add-name-to-file", Fadd_name_to_file, Sadd_name_to_file, 2, 3,
1545 "fAdd name to file: \nFName to add to %s: \np",
1546 "Give FILE additional name NEWNAME. Both args strings.\n\
1547 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
1548 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
1549 A number as third arg means request confirmation if NEWNAME already exists.\n\
1550 This is what happens in interactive use with M-x.")
1551 (filename, newname, ok_if_already_exists)
1552 Lisp_Object filename, newname, ok_if_already_exists;
1554 #ifdef NO_ARG_ARRAY
1555 Lisp_Object args[2];
1556 #endif
1557 struct gcpro gcpro1, gcpro2;
1559 GCPRO2 (filename, newname);
1560 CHECK_STRING (filename, 0);
1561 CHECK_STRING (newname, 1);
1562 filename = Fexpand_file_name (filename, Qnil);
1563 newname = Fexpand_file_name (newname, Qnil);
1564 if (NILP (ok_if_already_exists)
1565 || XTYPE (ok_if_already_exists) == Lisp_Int)
1566 barf_or_query_if_file_exists (newname, "make it a new name",
1567 XTYPE (ok_if_already_exists) == Lisp_Int);
1568 unlink (XSTRING (newname)->data);
1569 if (0 > link (XSTRING (filename)->data, XSTRING (newname)->data))
1571 #ifdef NO_ARG_ARRAY
1572 args[0] = filename;
1573 args[1] = newname;
1574 report_file_error ("Adding new name", Flist (2, args));
1575 #else
1576 report_file_error ("Adding new name", Flist (2, &filename));
1577 #endif
1580 UNGCPRO;
1581 return Qnil;
1584 #ifdef S_IFLNK
1585 DEFUN ("make-symbolic-link", Fmake_symbolic_link, Smake_symbolic_link, 2, 3,
1586 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
1587 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
1588 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
1589 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
1590 A number as third arg means request confirmation if NEWNAME already exists.\n\
1591 This happens for interactive use with M-x.")
1592 (filename, newname, ok_if_already_exists)
1593 Lisp_Object filename, newname, ok_if_already_exists;
1595 #ifdef NO_ARG_ARRAY
1596 Lisp_Object args[2];
1597 #endif
1598 struct gcpro gcpro1, gcpro2;
1600 GCPRO2 (filename, newname);
1601 CHECK_STRING (filename, 0);
1602 CHECK_STRING (newname, 1);
1603 #if 0 /* This made it impossible to make a link to a relative name. */
1604 filename = Fexpand_file_name (filename, Qnil);
1605 #endif
1606 newname = Fexpand_file_name (newname, Qnil);
1607 if (NILP (ok_if_already_exists)
1608 || XTYPE (ok_if_already_exists) == Lisp_Int)
1609 barf_or_query_if_file_exists (newname, "make it a link",
1610 XTYPE (ok_if_already_exists) == Lisp_Int);
1611 if (0 > symlink (XSTRING (filename)->data, XSTRING (newname)->data))
1613 /* If we didn't complain already, silently delete existing file. */
1614 if (errno == EEXIST)
1616 unlink (XSTRING (filename)->data);
1617 if (0 <= symlink (XSTRING (filename)->data, XSTRING (newname)->data))
1618 return Qnil;
1621 #ifdef NO_ARG_ARRAY
1622 args[0] = filename;
1623 args[1] = newname;
1624 report_file_error ("Making symbolic link", Flist (2, args));
1625 #else
1626 report_file_error ("Making symbolic link", Flist (2, &filename));
1627 #endif
1629 UNGCPRO;
1630 return Qnil;
1632 #endif /* S_IFLNK */
1634 #ifdef VMS
1636 DEFUN ("define-logical-name", Fdefine_logical_name, Sdefine_logical_name,
1637 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
1638 "Define the job-wide logical name NAME to have the value STRING.\n\
1639 If STRING is nil or a null string, the logical name NAME is deleted.")
1640 (varname, string)
1641 Lisp_Object varname;
1642 Lisp_Object string;
1644 CHECK_STRING (varname, 0);
1645 if (NILP (string))
1646 delete_logical_name (XSTRING (varname)->data);
1647 else
1649 CHECK_STRING (string, 1);
1651 if (XSTRING (string)->size == 0)
1652 delete_logical_name (XSTRING (varname)->data);
1653 else
1654 define_logical_name (XSTRING (varname)->data, XSTRING (string)->data);
1657 return string;
1659 #endif /* VMS */
1661 #ifdef HPUX_NET
1663 DEFUN ("sysnetunam", Fsysnetunam, Ssysnetunam, 2, 2, 0,
1664 "Open a network connection to PATH using LOGIN as the login string.")
1665 (path, login)
1666 Lisp_Object path, login;
1668 int netresult;
1670 CHECK_STRING (path, 0);
1671 CHECK_STRING (login, 0);
1673 netresult = netunam (XSTRING (path)->data, XSTRING (login)->data);
1675 if (netresult == -1)
1676 return Qnil;
1677 else
1678 return Qt;
1680 #endif /* HPUX_NET */
1682 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p, Sfile_name_absolute_p,
1683 1, 1, 0,
1684 "Return t if file FILENAME specifies an absolute path name.\n\
1685 On Unix, this is a name starting with a `/' or a `~'.")
1686 (filename)
1687 Lisp_Object filename;
1689 unsigned char *ptr;
1691 CHECK_STRING (filename, 0);
1692 ptr = XSTRING (filename)->data;
1693 if (*ptr == '/' || *ptr == '~'
1694 #ifdef VMS
1695 /* ??? This criterion is probably wrong for '<'. */
1696 || index (ptr, ':') || index (ptr, '<')
1697 || (*ptr == '[' && (ptr[1] != '-' || (ptr[2] != '.' && ptr[2] != ']'))
1698 && ptr[1] != '.')
1699 #endif /* VMS */
1701 return Qt;
1702 else
1703 return Qnil;
1706 DEFUN ("file-exists-p", Ffile_exists_p, Sfile_exists_p, 1, 1, 0,
1707 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
1708 See also `file-readable-p' and `file-attributes'.")
1709 (filename)
1710 Lisp_Object filename;
1712 Lisp_Object abspath;
1714 CHECK_STRING (filename, 0);
1715 abspath = Fexpand_file_name (filename, Qnil);
1716 return (access (XSTRING (abspath)->data, 0) >= 0) ? Qt : Qnil;
1719 DEFUN ("file-executable-p", Ffile_executable_p, Sfile_executable_p, 1, 1, 0,
1720 "Return t if FILENAME can be executed by you.\n\
1721 For directories this means you can change to that directory.")
1722 (filename)
1723 Lisp_Object filename;
1726 Lisp_Object abspath;
1728 CHECK_STRING (filename, 0);
1729 abspath = Fexpand_file_name (filename, Qnil);
1730 return (access (XSTRING (abspath)->data, 1) >= 0) ? Qt : Qnil;
1733 DEFUN ("file-readable-p", Ffile_readable_p, Sfile_readable_p, 1, 1, 0,
1734 "Return t if file FILENAME exists and you can read it.\n\
1735 See also `file-exists-p' and `file-attributes'.")
1736 (filename)
1737 Lisp_Object filename;
1739 Lisp_Object abspath;
1741 CHECK_STRING (filename, 0);
1742 abspath = Fexpand_file_name (filename, Qnil);
1743 return (access (XSTRING (abspath)->data, 4) >= 0) ? Qt : Qnil;
1746 DEFUN ("file-symlink-p", Ffile_symlink_p, Sfile_symlink_p, 1, 1, 0,
1747 "If file FILENAME is the name of a symbolic link\n\
1748 returns the name of the file to which it is linked.\n\
1749 Otherwise returns NIL.")
1750 (filename)
1751 Lisp_Object filename;
1753 #ifdef S_IFLNK
1754 char *buf;
1755 int bufsize;
1756 int valsize;
1757 Lisp_Object val;
1759 CHECK_STRING (filename, 0);
1760 filename = Fexpand_file_name (filename, Qnil);
1762 bufsize = 100;
1763 while (1)
1765 buf = (char *) xmalloc (bufsize);
1766 bzero (buf, bufsize);
1767 valsize = readlink (XSTRING (filename)->data, buf, bufsize);
1768 if (valsize < bufsize) break;
1769 /* Buffer was not long enough */
1770 free (buf);
1771 bufsize *= 2;
1773 if (valsize == -1)
1775 free (buf);
1776 return Qnil;
1778 val = make_string (buf, valsize);
1779 free (buf);
1780 return val;
1781 #else /* not S_IFLNK */
1782 return Qnil;
1783 #endif /* not S_IFLNK */
1786 /* Having this before file-symlink-p mysteriously caused it to be forgotten
1787 on the RT/PC. */
1788 DEFUN ("file-writable-p", Ffile_writable_p, Sfile_writable_p, 1, 1, 0,
1789 "Return t if file FILENAME can be written or created by you.")
1790 (filename)
1791 Lisp_Object filename;
1793 Lisp_Object abspath, dir;
1795 CHECK_STRING (filename, 0);
1796 abspath = Fexpand_file_name (filename, Qnil);
1797 if (access (XSTRING (abspath)->data, 0) >= 0)
1798 return (access (XSTRING (abspath)->data, 2) >= 0) ? Qt : Qnil;
1799 dir = Ffile_name_directory (abspath);
1800 #ifdef VMS
1801 if (!NILP (dir))
1802 dir = Fdirectory_file_name (dir);
1803 #endif /* VMS */
1804 return (access (!NILP (dir) ? (char *) XSTRING (dir)->data : "", 2) >= 0
1805 ? Qt : Qnil);
1808 DEFUN ("file-directory-p", Ffile_directory_p, Sfile_directory_p, 1, 1, 0,
1809 "Return t if file FILENAME is the name of a directory as a file.\n\
1810 A directory name spec may be given instead; then the value is t\n\
1811 if the directory so specified exists and really is a directory.")
1812 (filename)
1813 Lisp_Object filename;
1815 register Lisp_Object abspath;
1816 struct stat st;
1818 abspath = expand_and_dir_to_file (filename, current_buffer->directory);
1820 if (stat (XSTRING (abspath)->data, &st) < 0)
1821 return Qnil;
1822 return (st.st_mode & S_IFMT) == S_IFDIR ? Qt : Qnil;
1825 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p, Sfile_accessible_directory_p, 1, 1, 0,
1826 "Return t if file FILENAME is the name of a directory as a file,\n\
1827 and files in that directory can be opened by you. In order to use a\n\
1828 directory as a buffer's current directory, this predicate must return true.\n\
1829 A directory name spec may be given instead; then the value is t\n\
1830 if the directory so specified exists and really is a readable and\n\
1831 searchable directory.")
1832 (filename)
1833 Lisp_Object filename;
1835 if (NILP (Ffile_directory_p (filename))
1836 || NILP (Ffile_executable_p (filename)))
1837 return Qnil;
1838 else
1839 return Qt;
1842 DEFUN ("file-modes", Ffile_modes, Sfile_modes, 1, 1, 0,
1843 "Return mode bits of FILE, as an integer.")
1844 (filename)
1845 Lisp_Object filename;
1847 Lisp_Object abspath;
1848 struct stat st;
1850 abspath = expand_and_dir_to_file (filename, current_buffer->directory);
1852 if (stat (XSTRING (abspath)->data, &st) < 0)
1853 return Qnil;
1854 return make_number (st.st_mode & 07777);
1857 DEFUN ("set-file-modes", Fset_file_modes, Sset_file_modes, 2, 2, 0,
1858 "Set mode bits of FILE to MODE (an integer).\n\
1859 Only the 12 low bits of MODE are used.")
1860 (filename, mode)
1861 Lisp_Object filename, mode;
1863 Lisp_Object abspath;
1865 abspath = Fexpand_file_name (filename, current_buffer->directory);
1866 CHECK_NUMBER (mode, 1);
1868 #ifndef APOLLO
1869 if (chmod (XSTRING (abspath)->data, XINT (mode)) < 0)
1870 report_file_error ("Doing chmod", Fcons (abspath, Qnil));
1871 #else /* APOLLO */
1872 if (!egetenv ("USE_DOMAIN_ACLS"))
1874 struct stat st;
1875 struct timeval tvp[2];
1877 /* chmod on apollo also change the file's modtime; need to save the
1878 modtime and then restore it. */
1879 if (stat (XSTRING (abspath)->data, &st) < 0)
1881 report_file_error ("Doing chmod", Fcons (abspath, Qnil));
1882 return (Qnil);
1885 if (chmod (XSTRING (abspath)->data, XINT (mode)) < 0)
1886 report_file_error ("Doing chmod", Fcons (abspath, Qnil));
1888 /* reset the old accessed and modified times. */
1889 tvp[0].tv_sec = st.st_atime + 1; /* +1 due to an Apollo roundoff bug */
1890 tvp[0].tv_usec = 0;
1891 tvp[1].tv_sec = st.st_mtime + 1; /* +1 due to an Apollo roundoff bug */
1892 tvp[1].tv_usec = 0;
1894 if (utimes (XSTRING (abspath)->data, tvp) < 0)
1895 report_file_error ("Doing utimes", Fcons (abspath, Qnil));
1897 #endif /* APOLLO */
1899 return Qnil;
1902 DEFUN ("set-umask", Fset_umask, Sset_umask, 1, 1, 0,
1903 "Select which permission bits to disable in newly created files.\n\
1904 MASK should be an integer; if a permission's bit in MASK is 1,\n\
1905 subsequently created files will not have that permission enabled.\n\
1906 Only the low 9 bits are used.\n\
1907 This setting is inherited by subprocesses.")
1908 (mask)
1909 Lisp_Object mask;
1911 CHECK_NUMBER (mask, 0);
1913 umask (XINT (mask) & 0777);
1915 return Qnil;
1918 DEFUN ("umask", Fumask, Sumask, 0, 0, 0,
1919 "Return the current umask value.\n\
1920 The umask value determines which permissions are enabled in newly\n\
1921 created files. If a permission's bit in the umask is 1, subsequently\n\
1922 created files will not have that permission enabled.")
1925 Lisp_Object mask;
1927 XSET (mask, Lisp_Int, umask (0));
1928 umask (XINT (mask));
1930 return mask;
1933 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p, Sfile_newer_than_file_p, 2, 2, 0,
1934 "Return t if file FILE1 is newer than file FILE2.\n\
1935 If FILE1 does not exist, the answer is nil;\n\
1936 otherwise, if FILE2 does not exist, the answer is t.")
1937 (file1, file2)
1938 Lisp_Object file1, file2;
1940 Lisp_Object abspath;
1941 struct stat st;
1942 int mtime1;
1944 CHECK_STRING (file1, 0);
1945 CHECK_STRING (file2, 0);
1947 abspath = expand_and_dir_to_file (file1, current_buffer->directory);
1949 if (stat (XSTRING (abspath)->data, &st) < 0)
1950 return Qnil;
1952 mtime1 = st.st_mtime;
1954 abspath = expand_and_dir_to_file (file2, current_buffer->directory);
1956 if (stat (XSTRING (abspath)->data, &st) < 0)
1957 return Qt;
1959 return (mtime1 > st.st_mtime) ? Qt : Qnil;
1962 DEFUN ("insert-file-contents", Finsert_file_contents, Sinsert_file_contents,
1963 1, 2, 0,
1964 "Insert contents of file FILENAME after point.\n\
1965 Returns list of absolute pathname and length of data inserted.\n\
1966 If second argument VISIT is non-nil, the buffer's visited filename\n\
1967 and last save file modtime are set, and it is marked unmodified.\n\
1968 If visiting and the file does not exist, visiting is completed\n\
1969 before the error is signaled.")
1970 (filename, visit)
1971 Lisp_Object filename, visit;
1973 struct stat st;
1974 register int fd;
1975 register int inserted = 0;
1976 register int how_much;
1977 int count = specpdl_ptr - specpdl;
1978 struct gcpro gcpro1;
1980 GCPRO1 (filename);
1981 if (!NILP (current_buffer->read_only))
1982 Fbarf_if_buffer_read_only();
1984 CHECK_STRING (filename, 0);
1985 filename = Fexpand_file_name (filename, Qnil);
1987 fd = -1;
1989 #ifndef APOLLO
1990 if (stat (XSTRING (filename)->data, &st) < 0
1991 || (fd = open (XSTRING (filename)->data, 0)) < 0)
1992 #else
1993 if ((fd = open (XSTRING (filename)->data, 0)) < 0
1994 || fstat (fd, &st) < 0)
1995 #endif /* not APOLLO */
1997 if (fd >= 0) close (fd);
1998 if (NILP (visit))
1999 report_file_error ("Opening input file", Fcons (filename, Qnil));
2000 st.st_mtime = -1;
2001 how_much = 0;
2002 goto notfound;
2005 record_unwind_protect (close_file_unwind, make_number (fd));
2007 /* Supposedly happens on VMS. */
2008 if (st.st_size < 0)
2009 error ("File size is negative");
2011 register Lisp_Object temp;
2013 /* Make sure point-max won't overflow after this insertion. */
2014 XSET (temp, Lisp_Int, st.st_size + Z);
2015 if (st.st_size + Z != XINT (temp))
2016 error ("maximum buffer size exceeded");
2019 if (NILP (visit))
2020 prepare_to_modify_buffer (point, point);
2022 move_gap (point);
2023 if (GAP_SIZE < st.st_size)
2024 make_gap (st.st_size - GAP_SIZE);
2026 while (1)
2028 int try = min (st.st_size - inserted, 64 << 10);
2029 int this;
2031 /* Allow quitting out of the actual I/O. */
2032 immediate_quit = 1;
2033 QUIT;
2034 this = read (fd, &FETCH_CHAR (point + inserted - 1) + 1, try);
2035 immediate_quit = 0;
2037 if (this <= 0)
2039 how_much = this;
2040 break;
2043 GPT += this;
2044 GAP_SIZE -= this;
2045 ZV += this;
2046 Z += this;
2047 inserted += this;
2050 if (inserted > 0)
2051 MODIFF++;
2052 record_insert (point, inserted);
2054 close (fd);
2056 /* Discard the unwind protect */
2057 specpdl_ptr = specpdl + count;
2059 if (how_much < 0)
2060 error ("IO error reading %s: %s",
2061 XSTRING (filename)->data, err_str (errno));
2063 notfound:
2065 if (!NILP (visit))
2067 current_buffer->undo_list = Qnil;
2068 #ifdef APOLLO
2069 stat (XSTRING (filename)->data, &st);
2070 #endif
2071 current_buffer->modtime = st.st_mtime;
2072 current_buffer->save_modified = MODIFF;
2073 current_buffer->auto_save_modified = MODIFF;
2074 XFASTINT (current_buffer->save_length) = Z - BEG;
2075 #ifdef CLASH_DETECTION
2076 if (!NILP (current_buffer->filename))
2077 unlock_file (current_buffer->filename);
2078 unlock_file (filename);
2079 #endif /* CLASH_DETECTION */
2080 current_buffer->filename = filename;
2081 /* If visiting nonexistent file, return nil. */
2082 if (st.st_mtime == -1)
2083 report_file_error ("Opening input file", Fcons (filename, Qnil));
2086 signal_after_change (point, 0, inserted);
2088 RETURN_UNGCPRO (Fcons (filename,
2089 Fcons (make_number (inserted),
2090 Qnil)));
2093 DEFUN ("write-region", Fwrite_region, Swrite_region, 3, 5,
2094 "r\nFWrite region to file: ",
2095 "Write current region into specified file.\n\
2096 When called from a program, takes three arguments:\n\
2097 START, END and FILENAME. START and END are buffer positions.\n\
2098 Optional fourth argument APPEND if non-nil means\n\
2099 append to existing file contents (if any).\n\
2100 Optional fifth argument VISIT if t means\n\
2101 set the last-save-file-modtime of buffer to this file's modtime\n\
2102 and mark buffer not modified.\n\
2103 If VISIT is neither t nor nil, it means do not print\n\
2104 the \"Wrote file\" message.\n\
2105 Kludgy feature: if START is a string, then that string is written\n\
2106 to the file, instead of any buffer contents, and END is ignored.")
2107 (start, end, filename, append, visit)
2108 Lisp_Object start, end, filename, append, visit;
2110 register int desc;
2111 int failure;
2112 int save_errno;
2113 unsigned char *fn;
2114 struct stat st;
2115 int tem;
2116 int count = specpdl_ptr - specpdl;
2117 #ifdef VMS
2118 unsigned char *fname = 0; /* If non-0, original filename (must rename) */
2119 #endif /* VMS */
2121 /* Special kludge to simplify auto-saving */
2122 if (NILP (start))
2124 XFASTINT (start) = BEG;
2125 XFASTINT (end) = Z;
2127 else if (XTYPE (start) != Lisp_String)
2128 validate_region (&start, &end);
2130 filename = Fexpand_file_name (filename, Qnil);
2131 fn = XSTRING (filename)->data;
2133 #ifdef CLASH_DETECTION
2134 if (!auto_saving)
2135 lock_file (filename);
2136 #endif /* CLASH_DETECTION */
2138 desc = -1;
2139 if (!NILP (append))
2140 desc = open (fn, O_WRONLY);
2142 if (desc < 0)
2143 #ifdef VMS
2144 if (auto_saving) /* Overwrite any previous version of autosave file */
2146 vms_truncate (fn); /* if fn exists, truncate to zero length */
2147 desc = open (fn, O_RDWR);
2148 if (desc < 0)
2149 desc = creat_copy_attrs (XTYPE (current_buffer->filename) == Lisp_String
2150 ? XSTRING (current_buffer->filename)->data : 0,
2151 fn);
2153 else /* Write to temporary name and rename if no errors */
2155 Lisp_Object temp_name;
2156 temp_name = Ffile_name_directory (filename);
2158 if (!NILP (temp_name))
2160 temp_name = Fmake_temp_name (concat2 (temp_name,
2161 build_string ("$$SAVE$$")));
2162 fname = XSTRING (filename)->data;
2163 fn = XSTRING (temp_name)->data;
2164 desc = creat_copy_attrs (fname, fn);
2165 if (desc < 0)
2167 /* If we can't open the temporary file, try creating a new
2168 version of the original file. VMS "creat" creates a
2169 new version rather than truncating an existing file. */
2170 fn = fname;
2171 fname = 0;
2172 desc = creat (fn, 0666);
2173 #if 0 /* This can clobber an existing file and fail to replace it,
2174 if the user runs out of space. */
2175 if (desc < 0)
2177 /* We can't make a new version;
2178 try to truncate and rewrite existing version if any. */
2179 vms_truncate (fn);
2180 desc = open (fn, O_RDWR);
2182 #endif
2185 else
2186 desc = creat (fn, 0666);
2188 #else /* not VMS */
2189 desc = creat (fn, auto_saving ? auto_save_mode_bits : 0666);
2190 #endif /* not VMS */
2192 if (desc < 0)
2194 #ifdef CLASH_DETECTION
2195 save_errno = errno;
2196 if (!auto_saving) unlock_file (filename);
2197 errno = save_errno;
2198 #endif /* CLASH_DETECTION */
2199 report_file_error ("Opening output file", Fcons (filename, Qnil));
2202 record_unwind_protect (close_file_unwind, make_number (desc));
2204 if (!NILP (append))
2205 if (lseek (desc, 0, 2) < 0)
2207 #ifdef CLASH_DETECTION
2208 if (!auto_saving) unlock_file (filename);
2209 #endif /* CLASH_DETECTION */
2210 report_file_error ("Lseek error", Fcons (filename, Qnil));
2213 #ifdef VMS
2215 * Kludge Warning: The VMS C RTL likes to insert carriage returns
2216 * if we do writes that don't end with a carriage return. Furthermore
2217 * it cannot handle writes of more then 16K. The modified
2218 * version of "sys_write" in SYSDEP.C (see comment there) copes with
2219 * this EXCEPT for the last record (iff it doesn't end with a carriage
2220 * return). This implies that if your buffer doesn't end with a carriage
2221 * return, you get one free... tough. However it also means that if
2222 * we make two calls to sys_write (a la the following code) you can
2223 * get one at the gap as well. The easiest way to fix this (honest)
2224 * is to move the gap to the next newline (or the end of the buffer).
2225 * Thus this change.
2227 * Yech!
2229 if (GPT > BEG && GPT_ADDR[-1] != '\n')
2230 move_gap (find_next_newline (GPT, 1));
2231 #endif
2233 failure = 0;
2234 immediate_quit = 1;
2236 if (XTYPE (start) == Lisp_String)
2238 failure = 0 > e_write (desc, XSTRING (start)->data,
2239 XSTRING (start)->size);
2240 save_errno = errno;
2242 else if (XINT (start) != XINT (end))
2244 if (XINT (start) < GPT)
2246 register int end1 = XINT (end);
2247 tem = XINT (start);
2248 failure = 0 > e_write (desc, &FETCH_CHAR (tem),
2249 min (GPT, end1) - tem);
2250 save_errno = errno;
2253 if (XINT (end) > GPT && !failure)
2255 tem = XINT (start);
2256 tem = max (tem, GPT);
2257 failure = 0 > e_write (desc, &FETCH_CHAR (tem), XINT (end) - tem);
2258 save_errno = errno;
2262 immediate_quit = 0;
2264 #ifndef USG
2265 #ifndef VMS
2266 #ifndef BSD4_1
2267 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
2268 Disk full in NFS may be reported here. */
2269 if (fsync (desc) < 0)
2270 failure = 1, save_errno = errno;
2271 #endif
2272 #endif
2273 #endif
2275 /* Spurious "file has changed on disk" warnings have been
2276 observed on Suns as well.
2277 It seems that `close' can change the modtime, under nfs.
2279 (This has supposedly been fixed in Sunos 4,
2280 but who knows about all the other machines with NFS?) */
2281 #if 0
2283 /* On VMS and APOLLO, must do the stat after the close
2284 since closing changes the modtime. */
2285 #ifndef VMS
2286 #ifndef APOLLO
2287 /* Recall that #if defined does not work on VMS. */
2288 #define FOO
2289 fstat (desc, &st);
2290 #endif
2291 #endif
2292 #endif
2294 /* NFS can report a write failure now. */
2295 if (close (desc) < 0)
2296 failure = 1, save_errno = errno;
2298 #ifdef VMS
2299 /* If we wrote to a temporary name and had no errors, rename to real name. */
2300 if (fname)
2302 if (!failure)
2303 failure = (rename (fn, fname) != 0), save_errno = errno;
2304 fn = fname;
2306 #endif /* VMS */
2308 #ifndef FOO
2309 stat (fn, &st);
2310 #endif
2311 /* Discard the unwind protect */
2312 specpdl_ptr = specpdl + count;
2314 #ifdef CLASH_DETECTION
2315 if (!auto_saving)
2316 unlock_file (filename);
2317 #endif /* CLASH_DETECTION */
2319 /* Do this before reporting IO error
2320 to avoid a "file has changed on disk" warning on
2321 next attempt to save. */
2322 if (EQ (visit, Qt))
2323 current_buffer->modtime = st.st_mtime;
2325 if (failure)
2326 error ("IO error writing %s: %s", fn, err_str (save_errno));
2328 if (EQ (visit, Qt))
2330 current_buffer->save_modified = MODIFF;
2331 XFASTINT (current_buffer->save_length) = Z - BEG;
2332 current_buffer->filename = filename;
2334 else if (!NILP (visit))
2335 return Qnil;
2337 if (!auto_saving)
2338 message ("Wrote %s", fn);
2340 return Qnil;
2344 e_write (desc, addr, len)
2345 int desc;
2346 register char *addr;
2347 register int len;
2349 char buf[16 * 1024];
2350 register char *p, *end;
2352 if (!EQ (current_buffer->selective_display, Qt))
2353 return write (desc, addr, len) - len;
2354 else
2356 p = buf;
2357 end = p + sizeof buf;
2358 while (len--)
2360 if (p == end)
2362 if (write (desc, buf, sizeof buf) != sizeof buf)
2363 return -1;
2364 p = buf;
2366 *p = *addr++;
2367 if (*p++ == '\015')
2368 p[-1] = '\n';
2370 if (p != buf)
2371 if (write (desc, buf, p - buf) != p - buf)
2372 return -1;
2374 return 0;
2377 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime,
2378 Sverify_visited_file_modtime, 1, 1, 0,
2379 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
2380 This means that the file has not been changed since it was visited or saved.")
2381 (buf)
2382 Lisp_Object buf;
2384 struct buffer *b;
2385 struct stat st;
2387 CHECK_BUFFER (buf, 0);
2388 b = XBUFFER (buf);
2390 if (XTYPE (b->filename) != Lisp_String) return Qt;
2391 if (b->modtime == 0) return Qt;
2393 if (stat (XSTRING (b->filename)->data, &st) < 0)
2395 /* If the file doesn't exist now and didn't exist before,
2396 we say that it isn't modified, provided the error is a tame one. */
2397 if (errno == ENOENT || errno == EACCES || errno == ENOTDIR)
2398 st.st_mtime = -1;
2399 else
2400 st.st_mtime = 0;
2402 if (st.st_mtime == b->modtime
2403 /* If both are positive, accept them if they are off by one second. */
2404 || (st.st_mtime > 0 && b->modtime > 0
2405 && (st.st_mtime == b->modtime + 1
2406 || st.st_mtime == b->modtime - 1)))
2407 return Qt;
2408 return Qnil;
2411 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime,
2412 Sclear_visited_file_modtime, 0, 0, 0,
2413 "Clear out records of last mod time of visited file.\n\
2414 Next attempt to save will certainly not complain of a discrepancy.")
2417 current_buffer->modtime = 0;
2418 return Qnil;
2421 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime,
2422 Sset_visited_file_modtime, 0, 0, 0,
2423 "Update buffer's recorded modification time from the visited file's time.\n\
2424 Useful if the buffer was not read from the file normally\n\
2425 or if the file itself has been changed for some known benign reason.")
2428 register Lisp_Object filename;
2429 struct stat st;
2431 filename = Fexpand_file_name (current_buffer->filename, Qnil);
2433 if (stat (XSTRING (filename)->data, &st) >= 0)
2434 current_buffer->modtime = st.st_mtime;
2436 return Qnil;
2439 Lisp_Object
2440 auto_save_error ()
2442 unsigned char *name = XSTRING (current_buffer->name)->data;
2444 ring_bell ();
2445 message ("Autosaving...error for %s", name);
2446 Fsleep_for (make_number (1));
2447 message ("Autosaving...error!for %s", name);
2448 Fsleep_for (make_number (1));
2449 message ("Autosaving...error for %s", name);
2450 Fsleep_for (make_number (1));
2451 return Qnil;
2454 Lisp_Object
2455 auto_save_1 ()
2457 unsigned char *fn;
2458 struct stat st;
2460 /* Get visited file's mode to become the auto save file's mode. */
2461 if (stat (XSTRING (current_buffer->filename)->data, &st) >= 0)
2462 /* But make sure we can overwrite it later! */
2463 auto_save_mode_bits = st.st_mode | 0600;
2464 else
2465 auto_save_mode_bits = 0666;
2467 return
2468 Fwrite_region (Qnil, Qnil,
2469 current_buffer->auto_save_file_name,
2470 Qnil, Qlambda);
2473 DEFUN ("do-auto-save", Fdo_auto_save, Sdo_auto_save, 0, 2, "",
2474 "Auto-save all buffers that need it.\n\
2475 This is all buffers that have auto-saving enabled\n\
2476 and are changed since last auto-saved.\n\
2477 Auto-saving writes the buffer into a file\n\
2478 so that your editing is not lost if the system crashes.\n\
2479 This file is not the file you visited; that changes only when you save.\n\n\
2480 Non-nil first argument means do not print any message if successful.\n\
2481 Non-nil second argumet means save only current buffer.")
2482 (nomsg)
2483 Lisp_Object nomsg;
2485 struct buffer *old = current_buffer, *b;
2486 Lisp_Object tail, buf;
2487 int auto_saved = 0;
2488 char *omessage = echo_area_glyphs;
2489 extern minibuf_level;
2491 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
2492 point to non-strings reached from Vbuffer_alist. */
2494 auto_saving = 1;
2495 if (minibuf_level)
2496 nomsg = Qt;
2498 /* Vrun_hooks is nil before emacs is dumped, and inc-vers.el will
2499 eventually call do-auto-save, so don't err here in that case. */
2500 if (!NILP (Vrun_hooks))
2501 call1 (Vrun_hooks, intern ("auto-save-hook"));
2503 for (tail = Vbuffer_alist; XGCTYPE (tail) == Lisp_Cons;
2504 tail = XCONS (tail)->cdr)
2506 buf = XCONS (XCONS (tail)->car)->cdr;
2507 b = XBUFFER (buf);
2508 /* Check for auto save enabled
2509 and file changed since last auto save
2510 and file changed since last real save. */
2511 if (XTYPE (b->auto_save_file_name) == Lisp_String
2512 && b->save_modified < BUF_MODIFF (b)
2513 && b->auto_save_modified < BUF_MODIFF (b))
2515 if ((XFASTINT (b->save_length) * 10
2516 > (BUF_Z (b) - BUF_BEG (b)) * 13)
2517 /* A short file is likely to change a large fraction;
2518 spare the user annoying messages. */
2519 && XFASTINT (b->save_length) > 5000
2520 /* These messages are frequent and annoying for `*mail*'. */
2521 && !EQ (b->filename, Qnil))
2523 /* It has shrunk too much; turn off auto-saving here. */
2524 message ("Buffer %s has shrunk a lot; auto save turned off there",
2525 XSTRING (b->name)->data);
2526 /* User can reenable saving with M-x auto-save. */
2527 b->auto_save_file_name = Qnil;
2528 /* Prevent warning from repeating if user does so. */
2529 XFASTINT (b->save_length) = 0;
2530 Fsleep_for (make_number (1));
2531 continue;
2533 set_buffer_internal (b);
2534 if (!auto_saved && NILP (nomsg))
2535 message1 ("Auto-saving...");
2536 internal_condition_case (auto_save_1, Qt, auto_save_error);
2537 auto_saved++;
2538 b->auto_save_modified = BUF_MODIFF (b);
2539 XFASTINT (current_buffer->save_length) = Z - BEG;
2540 set_buffer_internal (old);
2544 if (auto_saved)
2545 record_auto_save ();
2547 if (auto_saved && NILP (nomsg))
2548 message1 (omessage ? omessage : "Auto-saving...done");
2550 auto_saving = 0;
2551 return Qnil;
2554 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved,
2555 Sset_buffer_auto_saved, 0, 0, 0,
2556 "Mark current buffer as auto-saved with its current text.\n\
2557 No auto-save file will be written until the buffer changes again.")
2560 current_buffer->auto_save_modified = MODIFF;
2561 XFASTINT (current_buffer->save_length) = Z - BEG;
2562 return Qnil;
2565 DEFUN ("recent-auto-save-p", Frecent_auto_save_p, Srecent_auto_save_p,
2566 0, 0, 0,
2567 "Return t if buffer has been auto-saved since last read in or saved.")
2570 return (current_buffer->save_modified < current_buffer->auto_save_modified) ? Qt : Qnil;
2573 /* Reading and completing file names */
2574 extern Lisp_Object Ffile_name_completion (), Ffile_name_all_completions ();
2576 DEFUN ("read-file-name-internal", Fread_file_name_internal, Sread_file_name_internal,
2577 3, 3, 0,
2578 "Internal subroutine for read-file-name. Do not call this.")
2579 (string, dir, action)
2580 Lisp_Object string, dir, action;
2581 /* action is nil for complete, t for return list of completions,
2582 lambda for verify final value */
2584 Lisp_Object name, specdir, realdir, val, orig_string;
2586 if (XSTRING (string)->size == 0)
2588 orig_string = Qnil;
2589 name = string;
2590 realdir = dir;
2591 if (EQ (action, Qlambda))
2592 return Qnil;
2594 else
2596 orig_string = string;
2597 string = Fsubstitute_in_file_name (string);
2598 name = Ffile_name_nondirectory (string);
2599 realdir = Ffile_name_directory (string);
2600 if (NILP (realdir))
2601 realdir = dir;
2602 else
2603 realdir = Fexpand_file_name (realdir, dir);
2606 if (NILP (action))
2608 specdir = Ffile_name_directory (string);
2609 val = Ffile_name_completion (name, realdir);
2610 if (XTYPE (val) != Lisp_String)
2612 if (NILP (Fstring_equal (string, orig_string)))
2613 return string;
2614 return (val);
2617 if (!NILP (specdir))
2618 val = concat2 (specdir, val);
2619 #ifndef VMS
2621 register unsigned char *old, *new;
2622 register int n;
2623 int osize, count;
2625 osize = XSTRING (val)->size;
2626 /* Quote "$" as "$$" to get it past substitute-in-file-name */
2627 for (n = osize, count = 0, old = XSTRING (val)->data; n > 0; n--)
2628 if (*old++ == '$') count++;
2629 if (count > 0)
2631 old = XSTRING (val)->data;
2632 val = Fmake_string (make_number (osize + count), make_number (0));
2633 new = XSTRING (val)->data;
2634 for (n = osize; n > 0; n--)
2635 if (*old != '$')
2636 *new++ = *old++;
2637 else
2639 *new++ = '$';
2640 *new++ = '$';
2641 old++;
2645 #endif /* Not VMS */
2646 return (val);
2649 if (EQ (action, Qt))
2650 return Ffile_name_all_completions (name, realdir);
2651 /* Only other case actually used is ACTION = lambda */
2652 #ifdef VMS
2653 /* Supposedly this helps commands such as `cd' that read directory names,
2654 but can someone explain how it helps them? -- RMS */
2655 if (XSTRING (name)->size == 0)
2656 return Qt;
2657 #endif /* VMS */
2658 return Ffile_exists_p (string);
2661 DEFUN ("read-file-name", Fread_file_name, Sread_file_name, 1, 5, 0,
2662 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
2663 Value is not expanded---you must call `expand-file-name' yourself.\n\
2664 Default name to DEFAULT if user enters a null string.\n\
2665 (If DEFAULT is omitted, the visited file name is used.)\n\
2666 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
2667 Non-nil and non-t means also require confirmation after completion.\n\
2668 Fifth arg INITIAL specifies text to start with.\n\
2669 DIR defaults to current buffer's directory default.")
2670 (prompt, dir, defalt, mustmatch, initial)
2671 Lisp_Object prompt, dir, defalt, mustmatch, initial;
2673 Lisp_Object val, insdef, tem, backup_n;
2674 struct gcpro gcpro1, gcpro2;
2675 register char *homedir;
2676 int count;
2678 if (NILP (dir))
2679 dir = current_buffer->directory;
2680 if (NILP (defalt))
2681 defalt = current_buffer->filename;
2683 /* If dir starts with user's homedir, change that to ~. */
2684 homedir = (char *) egetenv ("HOME");
2685 if (homedir != 0
2686 && XTYPE (dir) == Lisp_String
2687 && !strncmp (homedir, XSTRING (dir)->data, strlen (homedir))
2688 && XSTRING (dir)->data[strlen (homedir)] == '/')
2690 dir = make_string (XSTRING (dir)->data + strlen (homedir) - 1,
2691 XSTRING (dir)->size - strlen (homedir) + 1);
2692 XSTRING (dir)->data[0] = '~';
2695 if (insert_default_directory)
2697 insdef = dir;
2698 if (!NILP (initial))
2700 Lisp_Object args[2];
2702 args[0] = insdef;
2703 args[1] = initial;
2704 insdef = Fconcat (2, args);
2705 backup_n = make_number (- (XSTRING (initial)->size));
2707 else
2708 backup_n = Qnil;
2710 else
2712 insdef = build_string ("");
2713 backup_n = Qnil;
2716 #ifdef VMS
2717 count = specpdl_ptr - specpdl;
2718 specbind (intern ("completion-ignore-case"), Qt);
2719 #endif
2721 GCPRO2 (insdef, defalt);
2722 val = Fcompleting_read (prompt, intern ("read-file-name-internal"),
2723 dir, mustmatch,
2724 insert_default_directory ? insdef : Qnil, backup_n);
2726 #ifdef VMS
2727 unbind_to (count, Qnil);
2728 #endif
2730 UNGCPRO;
2731 if (NILP (val))
2732 error ("No file name specified");
2733 tem = Fstring_equal (val, insdef);
2734 if (!NILP (tem) && !NILP (defalt))
2735 return defalt;
2736 return Fsubstitute_in_file_name (val);
2739 #if 0 /* Old version */
2740 DEFUN ("read-file-name", Fread_file_name, Sread_file_name, 1, 5, 0,
2741 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
2742 Value is not expanded---you must call `expand-file-name' yourself.\n\
2743 Default name to DEFAULT if user enters a null string.\n\
2744 (If DEFAULT is omitted, the visited file name is used.)\n\
2745 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
2746 Non-nil and non-t means also require confirmation after completion.\n\
2747 Fifth arg INITIAL specifies text to start with.\n\
2748 DIR defaults to current buffer's directory default.")
2749 (prompt, dir, defalt, mustmatch, initial)
2750 Lisp_Object prompt, dir, defalt, mustmatch, initial;
2752 Lisp_Object val, insdef, tem;
2753 struct gcpro gcpro1, gcpro2;
2754 register char *homedir;
2755 int count;
2757 if (NILP (dir))
2758 dir = current_buffer->directory;
2759 if (NILP (defalt))
2760 defalt = current_buffer->filename;
2762 /* If dir starts with user's homedir, change that to ~. */
2763 homedir = (char *) egetenv ("HOME");
2764 if (homedir != 0
2765 && XTYPE (dir) == Lisp_String
2766 && !strncmp (homedir, XSTRING (dir)->data, strlen (homedir))
2767 && XSTRING (dir)->data[strlen (homedir)] == '/')
2769 dir = make_string (XSTRING (dir)->data + strlen (homedir) - 1,
2770 XSTRING (dir)->size - strlen (homedir) + 1);
2771 XSTRING (dir)->data[0] = '~';
2774 if (!NILP (initial))
2775 insdef = initial;
2776 else if (insert_default_directory)
2777 insdef = dir;
2778 else
2779 insdef = build_string ("");
2781 #ifdef VMS
2782 count = specpdl_ptr - specpdl;
2783 specbind (intern ("completion-ignore-case"), Qt);
2784 #endif
2786 GCPRO2 (insdef, defalt);
2787 val = Fcompleting_read (prompt, intern ("read-file-name-internal"),
2788 dir, mustmatch,
2789 insert_default_directory ? insdef : Qnil, Qnil);
2791 #ifdef VMS
2792 unbind_to (count, Qnil);
2793 #endif
2795 UNGCPRO;
2796 if (NILP (val))
2797 error ("No file name specified");
2798 tem = Fstring_equal (val, insdef);
2799 if (!NILP (tem) && !NILP (defalt))
2800 return defalt;
2801 return Fsubstitute_in_file_name (val);
2803 #endif /* Old version */
2805 syms_of_fileio ()
2807 Qfile_error = intern ("file-error");
2808 staticpro (&Qfile_error);
2809 Qfile_already_exists = intern("file-already-exists");
2810 staticpro (&Qfile_already_exists);
2812 Fput (Qfile_error, Qerror_conditions,
2813 Fcons (Qfile_error, Fcons (Qerror, Qnil)));
2814 Fput (Qfile_error, Qerror_message,
2815 build_string ("File error"));
2817 Fput (Qfile_already_exists, Qerror_conditions,
2818 Fcons (Qfile_already_exists,
2819 Fcons (Qfile_error, Fcons (Qerror, Qnil))));
2820 Fput (Qfile_already_exists, Qerror_message,
2821 build_string ("File already exists"));
2823 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory,
2824 "*Non-nil means when reading a filename start with default dir in minibuffer.");
2825 insert_default_directory = 1;
2827 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm,
2828 "*Non-nil means write new files with record format `stmlf'.\n\
2829 nil means use format `var'. This variable is meaningful only on VMS.");
2830 vms_stmlf_recfm = 0;
2832 defsubr (&Sfile_name_directory);
2833 defsubr (&Sfile_name_nondirectory);
2834 defsubr (&Sfile_name_as_directory);
2835 defsubr (&Sdirectory_file_name);
2836 defsubr (&Smake_temp_name);
2837 defsubr (&Sexpand_file_name);
2838 defsubr (&Ssubstitute_in_file_name);
2839 defsubr (&Scopy_file);
2840 defsubr (&Smake_directory);
2841 defsubr (&Sremove_directory);
2842 defsubr (&Sdelete_file);
2843 defsubr (&Srename_file);
2844 defsubr (&Sadd_name_to_file);
2845 #ifdef S_IFLNK
2846 defsubr (&Smake_symbolic_link);
2847 #endif /* S_IFLNK */
2848 #ifdef VMS
2849 defsubr (&Sdefine_logical_name);
2850 #endif /* VMS */
2851 #ifdef HPUX_NET
2852 defsubr (&Ssysnetunam);
2853 #endif /* HPUX_NET */
2854 defsubr (&Sfile_name_absolute_p);
2855 defsubr (&Sfile_exists_p);
2856 defsubr (&Sfile_executable_p);
2857 defsubr (&Sfile_readable_p);
2858 defsubr (&Sfile_writable_p);
2859 defsubr (&Sfile_symlink_p);
2860 defsubr (&Sfile_directory_p);
2861 defsubr (&Sfile_accessible_directory_p);
2862 defsubr (&Sfile_modes);
2863 defsubr (&Sset_file_modes);
2864 defsubr (&Sset_umask);
2865 defsubr (&Sumask);
2866 defsubr (&Sfile_newer_than_file_p);
2867 defsubr (&Sinsert_file_contents);
2868 defsubr (&Swrite_region);
2869 defsubr (&Sverify_visited_file_modtime);
2870 defsubr (&Sclear_visited_file_modtime);
2871 defsubr (&Sset_visited_file_modtime);
2872 defsubr (&Sdo_auto_save);
2873 defsubr (&Sset_buffer_auto_saved);
2874 defsubr (&Srecent_auto_save_p);
2876 defsubr (&Sread_file_name_internal);
2877 defsubr (&Sread_file_name);