entered into RCS
[bpt/emacs.git] / src / fileio.c
1 /* File IO for GNU Emacs.
2 Copyright (C) 1985, 1986, 1987, 1988, 1992 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 2, 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 #include "config.h"
21
22 #include <sys/types.h>
23 #include <sys/stat.h>
24
25 #ifdef VMS
26 #include "vms-pwd.h"
27 #else
28 #include <pwd.h>
29 #endif
30
31 #include <ctype.h>
32
33 #ifdef VMS
34 #include "dir.h"
35 #include <perror.h>
36 #include <stddef.h>
37 #include <string.h>
38 #else
39 #include <sys/dir.h>
40 #endif
41
42 #include <errno.h>
43
44 #ifndef vax11c
45 extern int errno;
46 extern char *sys_errlist[];
47 extern int sys_nerr;
48 #endif
49
50 #define err_str(a) ((a) < sys_nerr ? sys_errlist[a] : "unknown error")
51
52 #ifdef APOLLO
53 #include <sys/time.h>
54 #endif
55
56 #include "lisp.h"
57 #include "buffer.h"
58 #include "window.h"
59
60 #ifdef VMS
61 #include <file.h>
62 #include <rmsdef.h>
63 #include <fab.h>
64 #include <nam.h>
65 #endif
66
67 #include "systime.h"
68
69 #ifdef HPUX
70 #include <netio.h>
71 #ifndef HPUX8
72 #include <errnet.h>
73 #endif
74 #endif
75
76 #ifndef O_WRONLY
77 #define O_WRONLY 1
78 #endif
79
80 #define min(a, b) ((a) < (b) ? (a) : (b))
81 #define max(a, b) ((a) > (b) ? (a) : (b))
82
83 /* Nonzero during writing of auto-save files */
84 int auto_saving;
85
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;
89
90 /* Alist of elements (REGEXP . HANDLER) for file names
91 whose I/O is done with a special handler. */
92 Lisp_Object Vfile_name_handler_alist;
93
94 /* Nonzero means, when reading a filename in the minibuffer,
95 start out by inserting the default directory into the minibuffer. */
96 int insert_default_directory;
97
98 /* On VMS, nonzero means write new files with record format stmlf.
99 Zero means use var format. */
100 int vms_stmlf_recfm;
101
102 Lisp_Object Qfile_error, Qfile_already_exists;
103
104 Lisp_Object Qfile_name_history;
105
106 report_file_error (string, data)
107 char *string;
108 Lisp_Object data;
109 {
110 Lisp_Object errstring;
111
112 if (errno >= 0 && errno < sys_nerr)
113 errstring = build_string (sys_errlist[errno]);
114 else
115 errstring = build_string ("undocumented error code");
116
117 /* System error messages are capitalized. Downcase the initial
118 unless it is followed by a slash. */
119 if (XSTRING (errstring)->data[1] != '/')
120 XSTRING (errstring)->data[0] = DOWNCASE (XSTRING (errstring)->data[0]);
121
122 while (1)
123 Fsignal (Qfile_error,
124 Fcons (build_string (string), Fcons (errstring, data)));
125 }
126
127 close_file_unwind (fd)
128 Lisp_Object fd;
129 {
130 close (XFASTINT (fd));
131 }
132 \f
133 Lisp_Object Qcopy_file;
134 Lisp_Object Qmake_directory;
135 Lisp_Object Qdelete_directory;
136 Lisp_Object Qdelete_file;
137 Lisp_Object Qrename_file;
138 Lisp_Object Qadd_name_to_file;
139 Lisp_Object Qmake_symbolic_link;
140 Lisp_Object Qfile_exists_p;
141 Lisp_Object Qfile_executable_p;
142 Lisp_Object Qfile_readable_p;
143 Lisp_Object Qfile_symlink_p;
144 Lisp_Object Qfile_writable_p;
145 Lisp_Object Qfile_directory_p;
146 Lisp_Object Qfile_accessible_directory_p;
147 Lisp_Object Qfile_modes;
148 Lisp_Object Qset_file_modes;
149 Lisp_Object Qfile_newer_than_file_p;
150 Lisp_Object Qinsert_file_contents;
151 Lisp_Object Qwrite_region;
152 Lisp_Object Qverify_visited_file_modtime;
153
154 /* If FILENAME is handled specially on account of its syntax,
155 return its handler function. Otherwise, return nil. */
156
157 Lisp_Object
158 find_file_handler (filename)
159 Lisp_Object filename;
160 {
161 Lisp_Object chain;
162 for (chain = Vfile_name_handler_alist; XTYPE (chain) == Lisp_Cons;
163 chain = XCONS (chain)->cdr)
164 {
165 Lisp_Object elt;
166 elt = XCONS (chain)->car;
167 if (XTYPE (elt) == Lisp_Cons)
168 {
169 Lisp_Object string;
170 string = XCONS (elt)->car;
171 if (XTYPE (string) == Lisp_String
172 && fast_string_match (string, filename))
173 return XCONS (elt)->cdr;
174 }
175 }
176 return Qnil;
177 }
178 \f
179 DEFUN ("file-name-directory", Ffile_name_directory, Sfile_name_directory,
180 1, 1, 0,
181 "Return the directory component in file name NAME.\n\
182 Return nil if NAME does not include a directory.\n\
183 Otherwise return a directory spec.\n\
184 Given a Unix syntax file name, returns a string ending in slash;\n\
185 on VMS, perhaps instead a string ending in `:', `]' or `>'.")
186 (file)
187 Lisp_Object file;
188 {
189 register unsigned char *beg;
190 register unsigned char *p;
191
192 CHECK_STRING (file, 0);
193
194 beg = XSTRING (file)->data;
195 p = beg + XSTRING (file)->size;
196
197 while (p != beg && p[-1] != '/'
198 #ifdef VMS
199 && p[-1] != ':' && p[-1] != ']' && p[-1] != '>'
200 #endif /* VMS */
201 ) p--;
202
203 if (p == beg)
204 return Qnil;
205 return make_string (beg, p - beg);
206 }
207
208 DEFUN ("file-name-nondirectory", Ffile_name_nondirectory, Sfile_name_nondirectory,
209 1, 1, 0,
210 "Return file name NAME sans its directory.\n\
211 For example, in a Unix-syntax file name,\n\
212 this is everything after the last slash,\n\
213 or the entire name if it contains no slash.")
214 (file)
215 Lisp_Object file;
216 {
217 register unsigned char *beg, *p, *end;
218
219 CHECK_STRING (file, 0);
220
221 beg = XSTRING (file)->data;
222 end = p = beg + XSTRING (file)->size;
223
224 while (p != beg && p[-1] != '/'
225 #ifdef VMS
226 && p[-1] != ':' && p[-1] != ']' && p[-1] != '>'
227 #endif /* VMS */
228 ) p--;
229
230 return make_string (p, end - p);
231 }
232 \f
233 char *
234 file_name_as_directory (out, in)
235 char *out, *in;
236 {
237 int size = strlen (in) - 1;
238
239 strcpy (out, in);
240
241 #ifdef VMS
242 /* Is it already a directory string? */
243 if (in[size] == ':' || in[size] == ']' || in[size] == '>')
244 return out;
245 /* Is it a VMS directory file name? If so, hack VMS syntax. */
246 else if (! index (in, '/')
247 && ((size > 3 && ! strcmp (&in[size - 3], ".DIR"))
248 || (size > 3 && ! strcmp (&in[size - 3], ".dir"))
249 || (size > 5 && (! strncmp (&in[size - 5], ".DIR", 4)
250 || ! strncmp (&in[size - 5], ".dir", 4))
251 && (in[size - 1] == '.' || in[size - 1] == ';')
252 && in[size] == '1')))
253 {
254 register char *p, *dot;
255 char brack;
256
257 /* x.dir -> [.x]
258 dir:x.dir --> dir:[x]
259 dir:[x]y.dir --> dir:[x.y] */
260 p = in + size;
261 while (p != in && *p != ':' && *p != '>' && *p != ']') p--;
262 if (p != in)
263 {
264 strncpy (out, in, p - in);
265 out[p - in] = '\0';
266 if (*p == ':')
267 {
268 brack = ']';
269 strcat (out, ":[");
270 }
271 else
272 {
273 brack = *p;
274 strcat (out, ".");
275 }
276 p++;
277 }
278 else
279 {
280 brack = ']';
281 strcpy (out, "[.");
282 }
283 dot = index (p, '.');
284 if (dot)
285 {
286 /* blindly remove any extension */
287 size = strlen (out) + (dot - p);
288 strncat (out, p, dot - p);
289 }
290 else
291 {
292 strcat (out, p);
293 size = strlen (out);
294 }
295 out[size++] = brack;
296 out[size] = '\0';
297 }
298 #else /* not VMS */
299 /* For Unix syntax, Append a slash if necessary */
300 if (out[size] != '/')
301 strcat (out, "/");
302 #endif /* not VMS */
303 return out;
304 }
305
306 DEFUN ("file-name-as-directory", Ffile_name_as_directory,
307 Sfile_name_as_directory, 1, 1, 0,
308 "Return a string representing file FILENAME interpreted as a directory.\n\
309 This operation exists because a directory is also a file, but its name as\n\
310 a directory is different from its name as a file.\n\
311 The result can be used as the value of `default-directory'\n\
312 or passed as second argument to `expand-file-name'.\n\
313 For a Unix-syntax file name, just appends a slash.\n\
314 On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
315 (file)
316 Lisp_Object file;
317 {
318 char *buf;
319
320 CHECK_STRING (file, 0);
321 if (NILP (file))
322 return Qnil;
323 buf = (char *) alloca (XSTRING (file)->size + 10);
324 return build_string (file_name_as_directory (buf, XSTRING (file)->data));
325 }
326 \f
327 /*
328 * Convert from directory name to filename.
329 * On VMS:
330 * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
331 * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
332 * On UNIX, it's simple: just make sure there is a terminating /
333
334 * Value is nonzero if the string output is different from the input.
335 */
336
337 directory_file_name (src, dst)
338 char *src, *dst;
339 {
340 long slen;
341 #ifdef VMS
342 long rlen;
343 char * ptr, * rptr;
344 char bracket;
345 struct FAB fab = cc$rms_fab;
346 struct NAM nam = cc$rms_nam;
347 char esa[NAM$C_MAXRSS];
348 #endif /* VMS */
349
350 slen = strlen (src);
351 #ifdef VMS
352 if (! index (src, '/')
353 && (src[slen - 1] == ']'
354 || src[slen - 1] == ':'
355 || src[slen - 1] == '>'))
356 {
357 /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
358 fab.fab$l_fna = src;
359 fab.fab$b_fns = slen;
360 fab.fab$l_nam = &nam;
361 fab.fab$l_fop = FAB$M_NAM;
362
363 nam.nam$l_esa = esa;
364 nam.nam$b_ess = sizeof esa;
365 nam.nam$b_nop |= NAM$M_SYNCHK;
366
367 /* We call SYS$PARSE to handle such things as [--] for us. */
368 if (SYS$PARSE(&fab, 0, 0) == RMS$_NORMAL)
369 {
370 slen = nam.nam$b_esl;
371 if (esa[slen - 1] == ';' && esa[slen - 2] == '.')
372 slen -= 2;
373 esa[slen] = '\0';
374 src = esa;
375 }
376 if (src[slen - 1] != ']' && src[slen - 1] != '>')
377 {
378 /* what about when we have logical_name:???? */
379 if (src[slen - 1] == ':')
380 { /* Xlate logical name and see what we get */
381 ptr = strcpy (dst, src); /* upper case for getenv */
382 while (*ptr)
383 {
384 if ('a' <= *ptr && *ptr <= 'z')
385 *ptr -= 040;
386 ptr++;
387 }
388 dst[slen - 1] = 0; /* remove colon */
389 if (!(src = egetenv (dst)))
390 return 0;
391 /* should we jump to the beginning of this procedure?
392 Good points: allows us to use logical names that xlate
393 to Unix names,
394 Bad points: can be a problem if we just translated to a device
395 name...
396 For now, I'll punt and always expect VMS names, and hope for
397 the best! */
398 slen = strlen (src);
399 if (src[slen - 1] != ']' && src[slen - 1] != '>')
400 { /* no recursion here! */
401 strcpy (dst, src);
402 return 0;
403 }
404 }
405 else
406 { /* not a directory spec */
407 strcpy (dst, src);
408 return 0;
409 }
410 }
411 bracket = src[slen - 1];
412
413 /* If bracket is ']' or '>', bracket - 2 is the corresponding
414 opening bracket. */
415 ptr = index (src, bracket - 2);
416 if (ptr == 0)
417 { /* no opening bracket */
418 strcpy (dst, src);
419 return 0;
420 }
421 if (!(rptr = rindex (src, '.')))
422 rptr = ptr;
423 slen = rptr - src;
424 strncpy (dst, src, slen);
425 dst[slen] = '\0';
426 if (*rptr == '.')
427 {
428 dst[slen++] = bracket;
429 dst[slen] = '\0';
430 }
431 else
432 {
433 /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
434 then translate the device and recurse. */
435 if (dst[slen - 1] == ':'
436 && dst[slen - 2] != ':' /* skip decnet nodes */
437 && strcmp(src + slen, "[000000]") == 0)
438 {
439 dst[slen - 1] = '\0';
440 if ((ptr = egetenv (dst))
441 && (rlen = strlen (ptr) - 1) > 0
442 && (ptr[rlen] == ']' || ptr[rlen] == '>')
443 && ptr[rlen - 1] == '.')
444 {
445 ptr[rlen - 1] = ']';
446 ptr[rlen] = '\0';
447 return directory_file_name (ptr, dst);
448 }
449 else
450 dst[slen - 1] = ':';
451 }
452 strcat (dst, "[000000]");
453 slen += 8;
454 }
455 rptr++;
456 rlen = strlen (rptr) - 1;
457 strncat (dst, rptr, rlen);
458 dst[slen + rlen] = '\0';
459 strcat (dst, ".DIR.1");
460 return 1;
461 }
462 #endif /* VMS */
463 /* Process as Unix format: just remove any final slash.
464 But leave "/" unchanged; do not change it to "". */
465 strcpy (dst, src);
466 if (slen > 1 && dst[slen - 1] == '/')
467 dst[slen - 1] = 0;
468 return 1;
469 }
470
471 DEFUN ("directory-file-name", Fdirectory_file_name, Sdirectory_file_name,
472 1, 1, 0,
473 "Returns the file name of the directory named DIR.\n\
474 This is the name of the file that holds the data for the directory DIR.\n\
475 This operation exists because a directory is also a file, but its name as\n\
476 a directory is different from its name as a file.\n\
477 In Unix-syntax, this function just removes the final slash.\n\
478 On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
479 it returns a file name such as \"[X]Y.DIR.1\".")
480 (directory)
481 Lisp_Object directory;
482 {
483 char *buf;
484
485 CHECK_STRING (directory, 0);
486
487 if (NILP (directory))
488 return Qnil;
489 #ifdef VMS
490 /* 20 extra chars is insufficient for VMS, since we might perform a
491 logical name translation. an equivalence string can be up to 255
492 chars long, so grab that much extra space... - sss */
493 buf = (char *) alloca (XSTRING (directory)->size + 20 + 255);
494 #else
495 buf = (char *) alloca (XSTRING (directory)->size + 20);
496 #endif
497 directory_file_name (XSTRING (directory)->data, buf);
498 return build_string (buf);
499 }
500
501 DEFUN ("make-temp-name", Fmake_temp_name, Smake_temp_name, 1, 1, 0,
502 "Generate temporary file name (string) starting with PREFIX (a string).\n\
503 The Emacs process number forms part of the result,\n\
504 so there is no danger of generating a name being used by another process.")
505 (prefix)
506 Lisp_Object prefix;
507 {
508 Lisp_Object val;
509 val = concat2 (prefix, build_string ("XXXXXX"));
510 mktemp (XSTRING (val)->data);
511 return val;
512 }
513 \f
514 DEFUN ("expand-file-name", Fexpand_file_name, Sexpand_file_name, 1, 2, 0,
515 "Convert FILENAME to absolute, and canonicalize it.\n\
516 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
517 (does not start with slash); if DEFAULT is nil or missing,\n\
518 the current buffer's value of default-directory is used.\n\
519 Path components that are `.' are removed, and \n\
520 path components followed by `..' are removed, along with the `..' itself;\n\
521 note that these simplifications are done without checking the resulting\n\
522 paths in the file system.\n\
523 An initial `~/' expands to your home directory.\n\
524 An initial `~USER/' expands to USER's home directory.\n\
525 See also the function `substitute-in-file-name'.")
526 (name, defalt)
527 Lisp_Object name, defalt;
528 {
529 unsigned char *nm;
530
531 register unsigned char *newdir, *p, *o;
532 int tlen;
533 unsigned char *target;
534 struct passwd *pw;
535 int lose;
536 #ifdef VMS
537 unsigned char * colon = 0;
538 unsigned char * close = 0;
539 unsigned char * slash = 0;
540 unsigned char * brack = 0;
541 int lbrack = 0, rbrack = 0;
542 int dots = 0;
543 #endif /* VMS */
544
545 CHECK_STRING (name, 0);
546
547 #ifdef VMS
548 /* Filenames on VMS are always upper case. */
549 name = Fupcase (name);
550 #endif
551
552 nm = XSTRING (name)->data;
553
554 /* If nm is absolute, flush ...// and detect /./ and /../.
555 If no /./ or /../ we can return right away. */
556 if (
557 nm[0] == '/'
558 #ifdef VMS
559 || index (nm, ':')
560 #endif /* VMS */
561 )
562 {
563 p = nm;
564 lose = 0;
565 while (*p)
566 {
567 if (p[0] == '/' && p[1] == '/'
568 #ifdef APOLLO
569 /* // at start of filename is meaningful on Apollo system */
570 && nm != p
571 #endif /* APOLLO */
572 )
573 nm = p + 1;
574 if (p[0] == '/' && p[1] == '~')
575 nm = p + 1, lose = 1;
576 if (p[0] == '/' && p[1] == '.'
577 && (p[2] == '/' || p[2] == 0
578 || (p[2] == '.' && (p[3] == '/' || p[3] == 0))))
579 lose = 1;
580 #ifdef VMS
581 if (p[0] == '\\')
582 lose = 1;
583 if (p[0] == '/') {
584 /* if dev:[dir]/, move nm to / */
585 if (!slash && p > nm && (brack || colon)) {
586 nm = (brack ? brack + 1 : colon + 1);
587 lbrack = rbrack = 0;
588 brack = 0;
589 colon = 0;
590 }
591 slash = p;
592 }
593 if (p[0] == '-')
594 #ifndef VMS4_4
595 /* VMS pre V4.4,convert '-'s in filenames. */
596 if (lbrack == rbrack)
597 {
598 if (dots < 2) /* this is to allow negative version numbers */
599 p[0] = '_';
600 }
601 else
602 #endif /* VMS4_4 */
603 if (lbrack > rbrack &&
604 ((p[-1] == '.' || p[-1] == '[' || p[-1] == '<') &&
605 (p[1] == '.' || p[1] == ']' || p[1] == '>')))
606 lose = 1;
607 #ifndef VMS4_4
608 else
609 p[0] = '_';
610 #endif /* VMS4_4 */
611 /* count open brackets, reset close bracket pointer */
612 if (p[0] == '[' || p[0] == '<')
613 lbrack++, brack = 0;
614 /* count close brackets, set close bracket pointer */
615 if (p[0] == ']' || p[0] == '>')
616 rbrack++, brack = p;
617 /* detect ][ or >< */
618 if ((p[0] == ']' || p[0] == '>') && (p[1] == '[' || p[1] == '<'))
619 lose = 1;
620 if ((p[0] == ':' || p[0] == ']' || p[0] == '>') && p[1] == '~')
621 nm = p + 1, lose = 1;
622 if (p[0] == ':' && (colon || slash))
623 /* if dev1:[dir]dev2:, move nm to dev2: */
624 if (brack)
625 {
626 nm = brack + 1;
627 brack = 0;
628 }
629 /* if /pathname/dev:, move nm to dev: */
630 else if (slash)
631 nm = slash + 1;
632 /* if node::dev:, move colon following dev */
633 else if (colon && colon[-1] == ':')
634 colon = p;
635 /* if dev1:dev2:, move nm to dev2: */
636 else if (colon && colon[-1] != ':')
637 {
638 nm = colon + 1;
639 colon = 0;
640 }
641 if (p[0] == ':' && !colon)
642 {
643 if (p[1] == ':')
644 p++;
645 colon = p;
646 }
647 if (lbrack == rbrack)
648 if (p[0] == ';')
649 dots = 2;
650 else if (p[0] == '.')
651 dots++;
652 #endif /* VMS */
653 p++;
654 }
655 if (!lose)
656 {
657 #ifdef VMS
658 if (index (nm, '/'))
659 return build_string (sys_translate_unix (nm));
660 #endif /* VMS */
661 if (nm == XSTRING (name)->data)
662 return name;
663 return build_string (nm);
664 }
665 }
666
667 /* Now determine directory to start with and put it in newdir */
668
669 newdir = 0;
670
671 if (nm[0] == '~') /* prefix ~ */
672 if (nm[1] == '/'
673 #ifdef VMS
674 || nm[1] == ':'
675 #endif /* VMS */
676 || nm[1] == 0)/* ~ by itself */
677 {
678 if (!(newdir = (unsigned char *) egetenv ("HOME")))
679 newdir = (unsigned char *) "";
680 nm++;
681 #ifdef VMS
682 nm++; /* Don't leave the slash in nm. */
683 #endif /* VMS */
684 }
685 else /* ~user/filename */
686 {
687 for (p = nm; *p && (*p != '/'
688 #ifdef VMS
689 && *p != ':'
690 #endif /* VMS */
691 ); p++);
692 o = (unsigned char *) alloca (p - nm + 1);
693 bcopy ((char *) nm, o, p - nm);
694 o [p - nm] = 0;
695
696 pw = (struct passwd *) getpwnam (o + 1);
697 if (pw)
698 {
699 newdir = (unsigned char *) pw -> pw_dir;
700 #ifdef VMS
701 nm = p + 1; /* skip the terminator */
702 #else
703 nm = p;
704 #endif /* VMS */
705 }
706
707 /* If we don't find a user of that name, leave the name
708 unchanged; don't move nm forward to p. */
709 }
710
711 if (nm[0] != '/'
712 #ifdef VMS
713 && !index (nm, ':')
714 #endif /* not VMS */
715 && !newdir)
716 {
717 if (NILP (defalt))
718 defalt = current_buffer->directory;
719 CHECK_STRING (defalt, 1);
720 newdir = XSTRING (defalt)->data;
721 }
722
723 if (newdir != 0)
724 {
725 /* Get rid of any slash at the end of newdir. */
726 int length = strlen (newdir);
727 if (newdir[length - 1] == '/')
728 {
729 unsigned char *temp = (unsigned char *) alloca (length);
730 bcopy (newdir, temp, length - 1);
731 temp[length - 1] = 0;
732 newdir = temp;
733 }
734 tlen = length + 1;
735 }
736 else
737 tlen = 0;
738
739 /* Now concatenate the directory and name to new space in the stack frame */
740 tlen += strlen (nm) + 1;
741 target = (unsigned char *) alloca (tlen);
742 *target = 0;
743
744 if (newdir)
745 {
746 #ifndef VMS
747 if (nm[0] == 0 || nm[0] == '/')
748 strcpy (target, newdir);
749 else
750 #endif
751 file_name_as_directory (target, newdir);
752 }
753
754 strcat (target, nm);
755 #ifdef VMS
756 if (index (target, '/'))
757 strcpy (target, sys_translate_unix (target));
758 #endif /* VMS */
759
760 /* Now canonicalize by removing /. and /foo/.. if they appear */
761
762 p = target;
763 o = target;
764
765 while (*p)
766 {
767 #ifdef VMS
768 if (*p != ']' && *p != '>' && *p != '-')
769 {
770 if (*p == '\\')
771 p++;
772 *o++ = *p++;
773 }
774 else if ((p[0] == ']' || p[0] == '>') && p[0] == p[1] + 2)
775 /* brackets are offset from each other by 2 */
776 {
777 p += 2;
778 if (*p != '.' && *p != '-' && o[-1] != '.')
779 /* convert [foo][bar] to [bar] */
780 while (o[-1] != '[' && o[-1] != '<')
781 o--;
782 else if (*p == '-' && *o != '.')
783 *--p = '.';
784 }
785 else if (p[0] == '-' && o[-1] == '.' &&
786 (p[1] == '.' || p[1] == ']' || p[1] == '>'))
787 /* flush .foo.- ; leave - if stopped by '[' or '<' */
788 {
789 do
790 o--;
791 while (o[-1] != '.' && o[-1] != '[' && o[-1] != '<');
792 if (p[1] == '.') /* foo.-.bar ==> bar*/
793 p += 2;
794 else if (o[-1] == '.') /* '.foo.-]' ==> ']' */
795 p++, o--;
796 /* else [foo.-] ==> [-] */
797 }
798 else
799 {
800 #ifndef VMS4_4
801 if (*p == '-' &&
802 o[-1] != '[' && o[-1] != '<' && o[-1] != '.' &&
803 p[1] != ']' && p[1] != '>' && p[1] != '.')
804 *p = '_';
805 #endif /* VMS4_4 */
806 *o++ = *p++;
807 }
808 #else /* not VMS */
809 if (*p != '/')
810 {
811 *o++ = *p++;
812 }
813 else if (!strncmp (p, "//", 2)
814 #ifdef APOLLO
815 /* // at start of filename is meaningful in Apollo system */
816 && o != target
817 #endif /* APOLLO */
818 )
819 {
820 o = target;
821 p++;
822 }
823 else if (p[0] == '/' && p[1] == '.' &&
824 (p[2] == '/' || p[2] == 0))
825 p += 2;
826 else if (!strncmp (p, "/..", 3)
827 /* `/../' is the "superroot" on certain file systems. */
828 && o != target
829 && (p[3] == '/' || p[3] == 0))
830 {
831 while (o != target && *--o != '/')
832 ;
833 #ifdef APOLLO
834 if (o == target + 1 && o[-1] == '/' && o[0] == '/')
835 ++o;
836 else
837 #endif /* APOLLO */
838 if (o == target && *o == '/')
839 ++o;
840 p += 3;
841 }
842 else
843 {
844 *o++ = *p++;
845 }
846 #endif /* not VMS */
847 }
848
849 return make_string (target, o - target);
850 }
851 #if 0
852 /* Changed this DEFUN to a DEAFUN, so as not to confuse `make-docfile'.
853 DEAFUN ("expand-file-name", Fexpand_file_name, Sexpand_file_name, 1, 2, 0,
854 "Convert FILENAME to absolute, and canonicalize it.\n\
855 Second arg DEFAULT is directory to start with if FILENAME is relative\n\
856 (does not start with slash); if DEFAULT is nil or missing,\n\
857 the current buffer's value of default-directory is used.\n\
858 Filenames containing `.' or `..' as components are simplified;\n\
859 initial `~/' expands to your home directory.\n\
860 See also the function `substitute-in-file-name'.")
861 (name, defalt)
862 Lisp_Object name, defalt;
863 {
864 unsigned char *nm;
865
866 register unsigned char *newdir, *p, *o;
867 int tlen;
868 unsigned char *target;
869 struct passwd *pw;
870 int lose;
871 #ifdef VMS
872 unsigned char * colon = 0;
873 unsigned char * close = 0;
874 unsigned char * slash = 0;
875 unsigned char * brack = 0;
876 int lbrack = 0, rbrack = 0;
877 int dots = 0;
878 #endif /* VMS */
879
880 CHECK_STRING (name, 0);
881
882 #ifdef VMS
883 /* Filenames on VMS are always upper case. */
884 name = Fupcase (name);
885 #endif
886
887 nm = XSTRING (name)->data;
888
889 /* If nm is absolute, flush ...// and detect /./ and /../.
890 If no /./ or /../ we can return right away. */
891 if (
892 nm[0] == '/'
893 #ifdef VMS
894 || index (nm, ':')
895 #endif /* VMS */
896 )
897 {
898 p = nm;
899 lose = 0;
900 while (*p)
901 {
902 if (p[0] == '/' && p[1] == '/'
903 #ifdef APOLLO
904 /* // at start of filename is meaningful on Apollo system */
905 && nm != p
906 #endif /* APOLLO */
907 )
908 nm = p + 1;
909 if (p[0] == '/' && p[1] == '~')
910 nm = p + 1, lose = 1;
911 if (p[0] == '/' && p[1] == '.'
912 && (p[2] == '/' || p[2] == 0
913 || (p[2] == '.' && (p[3] == '/' || p[3] == 0))))
914 lose = 1;
915 #ifdef VMS
916 if (p[0] == '\\')
917 lose = 1;
918 if (p[0] == '/') {
919 /* if dev:[dir]/, move nm to / */
920 if (!slash && p > nm && (brack || colon)) {
921 nm = (brack ? brack + 1 : colon + 1);
922 lbrack = rbrack = 0;
923 brack = 0;
924 colon = 0;
925 }
926 slash = p;
927 }
928 if (p[0] == '-')
929 #ifndef VMS4_4
930 /* VMS pre V4.4,convert '-'s in filenames. */
931 if (lbrack == rbrack)
932 {
933 if (dots < 2) /* this is to allow negative version numbers */
934 p[0] = '_';
935 }
936 else
937 #endif /* VMS4_4 */
938 if (lbrack > rbrack &&
939 ((p[-1] == '.' || p[-1] == '[' || p[-1] == '<') &&
940 (p[1] == '.' || p[1] == ']' || p[1] == '>')))
941 lose = 1;
942 #ifndef VMS4_4
943 else
944 p[0] = '_';
945 #endif /* VMS4_4 */
946 /* count open brackets, reset close bracket pointer */
947 if (p[0] == '[' || p[0] == '<')
948 lbrack++, brack = 0;
949 /* count close brackets, set close bracket pointer */
950 if (p[0] == ']' || p[0] == '>')
951 rbrack++, brack = p;
952 /* detect ][ or >< */
953 if ((p[0] == ']' || p[0] == '>') && (p[1] == '[' || p[1] == '<'))
954 lose = 1;
955 if ((p[0] == ':' || p[0] == ']' || p[0] == '>') && p[1] == '~')
956 nm = p + 1, lose = 1;
957 if (p[0] == ':' && (colon || slash))
958 /* if dev1:[dir]dev2:, move nm to dev2: */
959 if (brack)
960 {
961 nm = brack + 1;
962 brack = 0;
963 }
964 /* if /pathname/dev:, move nm to dev: */
965 else if (slash)
966 nm = slash + 1;
967 /* if node::dev:, move colon following dev */
968 else if (colon && colon[-1] == ':')
969 colon = p;
970 /* if dev1:dev2:, move nm to dev2: */
971 else if (colon && colon[-1] != ':')
972 {
973 nm = colon + 1;
974 colon = 0;
975 }
976 if (p[0] == ':' && !colon)
977 {
978 if (p[1] == ':')
979 p++;
980 colon = p;
981 }
982 if (lbrack == rbrack)
983 if (p[0] == ';')
984 dots = 2;
985 else if (p[0] == '.')
986 dots++;
987 #endif /* VMS */
988 p++;
989 }
990 if (!lose)
991 {
992 #ifdef VMS
993 if (index (nm, '/'))
994 return build_string (sys_translate_unix (nm));
995 #endif /* VMS */
996 if (nm == XSTRING (name)->data)
997 return name;
998 return build_string (nm);
999 }
1000 }
1001
1002 /* Now determine directory to start with and put it in NEWDIR */
1003
1004 newdir = 0;
1005
1006 if (nm[0] == '~') /* prefix ~ */
1007 if (nm[1] == '/'
1008 #ifdef VMS
1009 || nm[1] == ':'
1010 #endif /* VMS */
1011 || nm[1] == 0)/* ~/filename */
1012 {
1013 if (!(newdir = (unsigned char *) egetenv ("HOME")))
1014 newdir = (unsigned char *) "";
1015 nm++;
1016 #ifdef VMS
1017 nm++; /* Don't leave the slash in nm. */
1018 #endif /* VMS */
1019 }
1020 else /* ~user/filename */
1021 {
1022 /* Get past ~ to user */
1023 unsigned char *user = nm + 1;
1024 /* Find end of name. */
1025 unsigned char *ptr = (unsigned char *) index (user, '/');
1026 int len = ptr ? ptr - user : strlen (user);
1027 #ifdef VMS
1028 unsigned char *ptr1 = index (user, ':');
1029 if (ptr1 != 0 && ptr1 - user < len)
1030 len = ptr1 - user;
1031 #endif /* VMS */
1032 /* Copy the user name into temp storage. */
1033 o = (unsigned char *) alloca (len + 1);
1034 bcopy ((char *) user, o, len);
1035 o[len] = 0;
1036
1037 /* Look up the user name. */
1038 pw = (struct passwd *) getpwnam (o + 1);
1039 if (!pw)
1040 error ("\"%s\" isn't a registered user", o + 1);
1041
1042 newdir = (unsigned char *) pw->pw_dir;
1043
1044 /* Discard the user name from NM. */
1045 nm += len;
1046 }
1047
1048 if (nm[0] != '/'
1049 #ifdef VMS
1050 && !index (nm, ':')
1051 #endif /* not VMS */
1052 && !newdir)
1053 {
1054 if (NILP (defalt))
1055 defalt = current_buffer->directory;
1056 CHECK_STRING (defalt, 1);
1057 newdir = XSTRING (defalt)->data;
1058 }
1059
1060 /* Now concatenate the directory and name to new space in the stack frame */
1061
1062 tlen = (newdir ? strlen (newdir) + 1 : 0) + strlen (nm) + 1;
1063 target = (unsigned char *) alloca (tlen);
1064 *target = 0;
1065
1066 if (newdir)
1067 {
1068 #ifndef VMS
1069 if (nm[0] == 0 || nm[0] == '/')
1070 strcpy (target, newdir);
1071 else
1072 #endif
1073 file_name_as_directory (target, newdir);
1074 }
1075
1076 strcat (target, nm);
1077 #ifdef VMS
1078 if (index (target, '/'))
1079 strcpy (target, sys_translate_unix (target));
1080 #endif /* VMS */
1081
1082 /* Now canonicalize by removing /. and /foo/.. if they appear */
1083
1084 p = target;
1085 o = target;
1086
1087 while (*p)
1088 {
1089 #ifdef VMS
1090 if (*p != ']' && *p != '>' && *p != '-')
1091 {
1092 if (*p == '\\')
1093 p++;
1094 *o++ = *p++;
1095 }
1096 else if ((p[0] == ']' || p[0] == '>') && p[0] == p[1] + 2)
1097 /* brackets are offset from each other by 2 */
1098 {
1099 p += 2;
1100 if (*p != '.' && *p != '-' && o[-1] != '.')
1101 /* convert [foo][bar] to [bar] */
1102 while (o[-1] != '[' && o[-1] != '<')
1103 o--;
1104 else if (*p == '-' && *o != '.')
1105 *--p = '.';
1106 }
1107 else if (p[0] == '-' && o[-1] == '.' &&
1108 (p[1] == '.' || p[1] == ']' || p[1] == '>'))
1109 /* flush .foo.- ; leave - if stopped by '[' or '<' */
1110 {
1111 do
1112 o--;
1113 while (o[-1] != '.' && o[-1] != '[' && o[-1] != '<');
1114 if (p[1] == '.') /* foo.-.bar ==> bar*/
1115 p += 2;
1116 else if (o[-1] == '.') /* '.foo.-]' ==> ']' */
1117 p++, o--;
1118 /* else [foo.-] ==> [-] */
1119 }
1120 else
1121 {
1122 #ifndef VMS4_4
1123 if (*p == '-' &&
1124 o[-1] != '[' && o[-1] != '<' && o[-1] != '.' &&
1125 p[1] != ']' && p[1] != '>' && p[1] != '.')
1126 *p = '_';
1127 #endif /* VMS4_4 */
1128 *o++ = *p++;
1129 }
1130 #else /* not VMS */
1131 if (*p != '/')
1132 {
1133 *o++ = *p++;
1134 }
1135 else if (!strncmp (p, "//", 2)
1136 #ifdef APOLLO
1137 /* // at start of filename is meaningful in Apollo system */
1138 && o != target
1139 #endif /* APOLLO */
1140 )
1141 {
1142 o = target;
1143 p++;
1144 }
1145 else if (p[0] == '/' && p[1] == '.' &&
1146 (p[2] == '/' || p[2] == 0))
1147 p += 2;
1148 else if (!strncmp (p, "/..", 3)
1149 /* `/../' is the "superroot" on certain file systems. */
1150 && o != target
1151 && (p[3] == '/' || p[3] == 0))
1152 {
1153 while (o != target && *--o != '/')
1154 ;
1155 #ifdef APOLLO
1156 if (o == target + 1 && o[-1] == '/' && o[0] == '/')
1157 ++o;
1158 else
1159 #endif /* APOLLO */
1160 if (o == target && *o == '/')
1161 ++o;
1162 p += 3;
1163 }
1164 else
1165 {
1166 *o++ = *p++;
1167 }
1168 #endif /* not VMS */
1169 }
1170
1171 return make_string (target, o - target);
1172 }
1173 #endif
1174 \f
1175 DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name,
1176 Ssubstitute_in_file_name, 1, 1, 0,
1177 "Substitute environment variables referred to in FILENAME.\n\
1178 `$FOO' where FOO is an environment variable name means to substitute\n\
1179 the value of that variable. The variable name should be terminated\n\
1180 with a character not a letter, digit or underscore; otherwise, enclose\n\
1181 the entire variable name in braces.\n\
1182 If `/~' appears, all of FILENAME through that `/' is discarded.\n\n\
1183 On VMS, `$' substitution is not done; this function does little and only\n\
1184 duplicates what `expand-file-name' does.")
1185 (string)
1186 Lisp_Object string;
1187 {
1188 unsigned char *nm;
1189
1190 register unsigned char *s, *p, *o, *x, *endp;
1191 unsigned char *target;
1192 int total = 0;
1193 int substituted = 0;
1194 unsigned char *xnm;
1195
1196 CHECK_STRING (string, 0);
1197
1198 nm = XSTRING (string)->data;
1199 endp = nm + XSTRING (string)->size;
1200
1201 /* If /~ or // appears, discard everything through first slash. */
1202
1203 for (p = nm; p != endp; p++)
1204 {
1205 if ((p[0] == '~' ||
1206 #ifdef APOLLO
1207 /* // at start of file name is meaningful in Apollo system */
1208 (p[0] == '/' && p - 1 != nm)
1209 #else /* not APOLLO */
1210 p[0] == '/'
1211 #endif /* not APOLLO */
1212 )
1213 && p != nm &&
1214 #ifdef VMS
1215 (p[-1] == ':' || p[-1] == ']' || p[-1] == '>' ||
1216 #endif /* VMS */
1217 p[-1] == '/')
1218 #ifdef VMS
1219 )
1220 #endif /* VMS */
1221 {
1222 nm = p;
1223 substituted = 1;
1224 }
1225 }
1226
1227 #ifdef VMS
1228 return build_string (nm);
1229 #else
1230
1231 /* See if any variables are substituted into the string
1232 and find the total length of their values in `total' */
1233
1234 for (p = nm; p != endp;)
1235 if (*p != '$')
1236 p++;
1237 else
1238 {
1239 p++;
1240 if (p == endp)
1241 goto badsubst;
1242 else if (*p == '$')
1243 {
1244 /* "$$" means a single "$" */
1245 p++;
1246 total -= 1;
1247 substituted = 1;
1248 continue;
1249 }
1250 else if (*p == '{')
1251 {
1252 o = ++p;
1253 while (p != endp && *p != '}') p++;
1254 if (*p != '}') goto missingclose;
1255 s = p;
1256 }
1257 else
1258 {
1259 o = p;
1260 while (p != endp && (isalnum (*p) || *p == '_')) p++;
1261 s = p;
1262 }
1263
1264 /* Copy out the variable name */
1265 target = (unsigned char *) alloca (s - o + 1);
1266 strncpy (target, o, s - o);
1267 target[s - o] = 0;
1268
1269 /* Get variable value */
1270 o = (unsigned char *) egetenv (target);
1271 /* The presence of this code makes vax 5.0 crash, for reasons yet unknown */
1272 #if 0
1273 #ifdef USG
1274 if (!o && !strcmp (target, "USER"))
1275 o = egetenv ("LOGNAME");
1276 #endif /* USG */
1277 #endif /* 0 */
1278 if (!o) goto badvar;
1279 total += strlen (o);
1280 substituted = 1;
1281 }
1282
1283 if (!substituted)
1284 return string;
1285
1286 /* If substitution required, recopy the string and do it */
1287 /* Make space in stack frame for the new copy */
1288 xnm = (unsigned char *) alloca (XSTRING (string)->size + total + 1);
1289 x = xnm;
1290
1291 /* Copy the rest of the name through, replacing $ constructs with values */
1292 for (p = nm; *p;)
1293 if (*p != '$')
1294 *x++ = *p++;
1295 else
1296 {
1297 p++;
1298 if (p == endp)
1299 goto badsubst;
1300 else if (*p == '$')
1301 {
1302 *x++ = *p++;
1303 continue;
1304 }
1305 else if (*p == '{')
1306 {
1307 o = ++p;
1308 while (p != endp && *p != '}') p++;
1309 if (*p != '}') goto missingclose;
1310 s = p++;
1311 }
1312 else
1313 {
1314 o = p;
1315 while (p != endp && (isalnum (*p) || *p == '_')) p++;
1316 s = p;
1317 }
1318
1319 /* Copy out the variable name */
1320 target = (unsigned char *) alloca (s - o + 1);
1321 strncpy (target, o, s - o);
1322 target[s - o] = 0;
1323
1324 /* Get variable value */
1325 o = (unsigned char *) egetenv (target);
1326 /* The presence of this code makes vax 5.0 crash, for reasons yet unknown */
1327 #if 0
1328 #ifdef USG
1329 if (!o && !strcmp (target, "USER"))
1330 o = egetenv ("LOGNAME");
1331 #endif /* USG */
1332 #endif /* 0 */
1333 if (!o)
1334 goto badvar;
1335
1336 strcpy (x, o);
1337 x += strlen (o);
1338 }
1339
1340 *x = 0;
1341
1342 /* If /~ or // appears, discard everything through first slash. */
1343
1344 for (p = xnm; p != x; p++)
1345 if ((p[0] == '~' ||
1346 #ifdef APOLLO
1347 /* // at start of file name is meaningful in Apollo system */
1348 (p[0] == '/' && p - 1 != xnm)
1349 #else /* not APOLLO */
1350 p[0] == '/'
1351 #endif /* not APOLLO */
1352 )
1353 && p != nm && p[-1] == '/')
1354 xnm = p;
1355
1356 return make_string (xnm, x - xnm);
1357
1358 badsubst:
1359 error ("Bad format environment-variable substitution");
1360 missingclose:
1361 error ("Missing \"}\" in environment-variable substitution");
1362 badvar:
1363 error ("Substituting nonexistent environment variable \"%s\"", target);
1364
1365 /* NOTREACHED */
1366 #endif /* not VMS */
1367 }
1368 \f
1369 /* A slightly faster and more convenient way to get
1370 (directory-file-name (expand-file-name FOO)). The return value may
1371 have had its last character zapped with a '\0' character, meaning
1372 that it is acceptable to system calls, but not to other lisp
1373 functions. Callers should make sure that the return value doesn't
1374 escape. */
1375
1376 Lisp_Object
1377 expand_and_dir_to_file (filename, defdir)
1378 Lisp_Object filename, defdir;
1379 {
1380 register Lisp_Object abspath;
1381
1382 abspath = Fexpand_file_name (filename, defdir);
1383 #ifdef VMS
1384 {
1385 register int c = XSTRING (abspath)->data[XSTRING (abspath)->size - 1];
1386 if (c == ':' || c == ']' || c == '>')
1387 abspath = Fdirectory_file_name (abspath);
1388 }
1389 #else
1390 /* Remove final slash, if any (unless path is root).
1391 stat behaves differently depending! */
1392 if (XSTRING (abspath)->size > 1
1393 && XSTRING (abspath)->data[XSTRING (abspath)->size - 1] == '/')
1394 {
1395 if (EQ (abspath, filename))
1396 abspath = Fcopy_sequence (abspath);
1397 XSTRING (abspath)->data[XSTRING (abspath)->size - 1] = 0;
1398 }
1399 #endif
1400 return abspath;
1401 }
1402 \f
1403 barf_or_query_if_file_exists (absname, querystring, interactive)
1404 Lisp_Object absname;
1405 unsigned char *querystring;
1406 int interactive;
1407 {
1408 register Lisp_Object tem;
1409 struct gcpro gcpro1;
1410
1411 if (access (XSTRING (absname)->data, 4) >= 0)
1412 {
1413 if (! interactive)
1414 Fsignal (Qfile_already_exists,
1415 Fcons (build_string ("File already exists"),
1416 Fcons (absname, Qnil)));
1417 GCPRO1 (absname);
1418 tem = do_yes_or_no_p (format1 ("File %s already exists; %s anyway? ",
1419 XSTRING (absname)->data, querystring));
1420 UNGCPRO;
1421 if (NILP (tem))
1422 Fsignal (Qfile_already_exists,
1423 Fcons (build_string ("File already exists"),
1424 Fcons (absname, Qnil)));
1425 }
1426 return;
1427 }
1428
1429 DEFUN ("copy-file", Fcopy_file, Scopy_file, 2, 4,
1430 "fCopy file: \nFCopy %s to file: \np\nP",
1431 "Copy FILE to NEWNAME. Both args must be strings.\n\
1432 Signals a `file-already-exists' error if file NEWNAME already exists,\n\
1433 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
1434 A number as third arg means request confirmation if NEWNAME already exists.\n\
1435 This is what happens in interactive use with M-x.\n\
1436 Fourth arg KEEP-TIME non-nil means give the new file the same\n\
1437 last-modified time as the old one. (This works on only some systems.)\n\
1438 A prefix arg makes KEEP-TIME non-nil.")
1439 (filename, newname, ok_if_already_exists, keep_date)
1440 Lisp_Object filename, newname, ok_if_already_exists, keep_date;
1441 {
1442 int ifd, ofd, n;
1443 char buf[16 * 1024];
1444 struct stat st;
1445 Lisp_Object handler;
1446 struct gcpro gcpro1, gcpro2;
1447 int count = specpdl_ptr - specpdl;
1448
1449 GCPRO2 (filename, newname);
1450 CHECK_STRING (filename, 0);
1451 CHECK_STRING (newname, 1);
1452 filename = Fexpand_file_name (filename, Qnil);
1453 newname = Fexpand_file_name (newname, Qnil);
1454
1455 /* If the file name has special constructs in it,
1456 call the corresponding file handler. */
1457 handler = find_file_handler (filename);
1458 if (!NILP (handler))
1459 return call3 (handler, Qcopy_file, filename, newname);
1460
1461 if (NILP (ok_if_already_exists)
1462 || XTYPE (ok_if_already_exists) == Lisp_Int)
1463 barf_or_query_if_file_exists (newname, "copy to it",
1464 XTYPE (ok_if_already_exists) == Lisp_Int);
1465
1466 ifd = open (XSTRING (filename)->data, 0);
1467 if (ifd < 0)
1468 report_file_error ("Opening input file", Fcons (filename, Qnil));
1469
1470 record_unwind_protect (close_file_unwind, make_number (ifd));
1471
1472 #ifdef VMS
1473 /* Create the copy file with the same record format as the input file */
1474 ofd = sys_creat (XSTRING (newname)->data, 0666, ifd);
1475 #else
1476 ofd = creat (XSTRING (newname)->data, 0666);
1477 #endif /* VMS */
1478 if (ofd < 0)
1479 report_file_error ("Opening output file", Fcons (newname, Qnil));
1480
1481 record_unwind_protect (close_file_unwind, make_number (ofd));
1482
1483 immediate_quit = 1;
1484 QUIT;
1485 while ((n = read (ifd, buf, sizeof buf)) > 0)
1486 if (write (ofd, buf, n) != n)
1487 report_file_error ("I/O error", Fcons (newname, Qnil));
1488 immediate_quit = 0;
1489
1490 if (fstat (ifd, &st) >= 0)
1491 {
1492 if (!NILP (keep_date))
1493 {
1494 EMACS_TIME atime, mtime;
1495 EMACS_SET_SECS_USECS (atime, st.st_atime, 0);
1496 EMACS_SET_SECS_USECS (mtime, st.st_mtime, 0);
1497 EMACS_SET_UTIMES (XSTRING (newname)->data, atime, mtime);
1498 }
1499 #ifdef APOLLO
1500 if (!egetenv ("USE_DOMAIN_ACLS"))
1501 #endif
1502 chmod (XSTRING (newname)->data, st.st_mode & 07777);
1503 }
1504
1505 /* Discard the unwind protects. */
1506 specpdl_ptr = specpdl + count;
1507
1508 close (ifd);
1509 if (close (ofd) < 0)
1510 report_file_error ("I/O error", Fcons (newname, Qnil));
1511
1512 UNGCPRO;
1513 return Qnil;
1514 }
1515
1516 DEFUN ("make-directory", Fmake_directory, Smake_directory, 1, 1, "FMake directory: ",
1517 "Create a directory. One argument, a file name string.")
1518 (dirname)
1519 Lisp_Object dirname;
1520 {
1521 unsigned char *dir;
1522 Lisp_Object handler;
1523
1524 CHECK_STRING (dirname, 0);
1525 dirname = Fexpand_file_name (dirname, Qnil);
1526
1527 handler = find_file_handler (dirname);
1528 if (!NILP (handler))
1529 return call2 (handler, Qmake_directory, dirname);
1530
1531 dir = XSTRING (dirname)->data;
1532
1533 if (mkdir (dir, 0777) != 0)
1534 report_file_error ("Creating directory", Flist (1, &dirname));
1535
1536 return Qnil;
1537 }
1538
1539 DEFUN ("delete-directory", Fdelete_directory, Sdelete_directory, 1, 1, "FDelete directory: ",
1540 "Delete a directory. One argument, a file name string.")
1541 (dirname)
1542 Lisp_Object dirname;
1543 {
1544 unsigned char *dir;
1545 Lisp_Object handler;
1546
1547 CHECK_STRING (dirname, 0);
1548 dirname = Fexpand_file_name (dirname, Qnil);
1549 dir = XSTRING (dirname)->data;
1550
1551 handler = find_file_handler (dirname);
1552 if (!NILP (handler))
1553 return call2 (handler, Qdelete_directory, dirname);
1554
1555 if (rmdir (dir) != 0)
1556 report_file_error ("Removing directory", Flist (1, &dirname));
1557
1558 return Qnil;
1559 }
1560
1561 DEFUN ("delete-file", Fdelete_file, Sdelete_file, 1, 1, "fDelete file: ",
1562 "Delete specified file. One argument, a file name string.\n\
1563 If file has multiple names, it continues to exist with the other names.")
1564 (filename)
1565 Lisp_Object filename;
1566 {
1567 Lisp_Object handler;
1568 CHECK_STRING (filename, 0);
1569 filename = Fexpand_file_name (filename, Qnil);
1570
1571 handler = find_file_handler (filename);
1572 if (!NILP (handler))
1573 return call2 (handler, Qdelete_file, filename);
1574
1575 if (0 > unlink (XSTRING (filename)->data))
1576 report_file_error ("Removing old name", Flist (1, &filename));
1577 return Qnil;
1578 }
1579
1580 DEFUN ("rename-file", Frename_file, Srename_file, 2, 3,
1581 "fRename file: \nFRename %s to file: \np",
1582 "Rename FILE as NEWNAME. Both args strings.\n\
1583 If file has names other than FILE, it continues to have those names.\n\
1584 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
1585 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
1586 A number as third arg means request confirmation if NEWNAME already exists.\n\
1587 This is what happens in interactive use with M-x.")
1588 (filename, newname, ok_if_already_exists)
1589 Lisp_Object filename, newname, ok_if_already_exists;
1590 {
1591 #ifdef NO_ARG_ARRAY
1592 Lisp_Object args[2];
1593 #endif
1594 Lisp_Object handler;
1595 struct gcpro gcpro1, gcpro2;
1596
1597 GCPRO2 (filename, newname);
1598 CHECK_STRING (filename, 0);
1599 CHECK_STRING (newname, 1);
1600 filename = Fexpand_file_name (filename, Qnil);
1601 newname = Fexpand_file_name (newname, Qnil);
1602
1603 /* If the file name has special constructs in it,
1604 call the corresponding file handler. */
1605 handler = find_file_handler (filename);
1606 if (!NILP (handler))
1607 return call3 (handler, Qrename_file, filename, newname);
1608
1609 if (NILP (ok_if_already_exists)
1610 || XTYPE (ok_if_already_exists) == Lisp_Int)
1611 barf_or_query_if_file_exists (newname, "rename to it",
1612 XTYPE (ok_if_already_exists) == Lisp_Int);
1613 #ifndef BSD4_1
1614 if (0 > rename (XSTRING (filename)->data, XSTRING (newname)->data))
1615 #else
1616 if (0 > link (XSTRING (filename)->data, XSTRING (newname)->data)
1617 || 0 > unlink (XSTRING (filename)->data))
1618 #endif
1619 {
1620 if (errno == EXDEV)
1621 {
1622 Fcopy_file (filename, newname, ok_if_already_exists, Qt);
1623 Fdelete_file (filename);
1624 }
1625 else
1626 #ifdef NO_ARG_ARRAY
1627 {
1628 args[0] = filename;
1629 args[1] = newname;
1630 report_file_error ("Renaming", Flist (2, args));
1631 }
1632 #else
1633 report_file_error ("Renaming", Flist (2, &filename));
1634 #endif
1635 }
1636 UNGCPRO;
1637 return Qnil;
1638 }
1639
1640 DEFUN ("add-name-to-file", Fadd_name_to_file, Sadd_name_to_file, 2, 3,
1641 "fAdd name to file: \nFName to add to %s: \np",
1642 "Give FILE additional name NEWNAME. Both args strings.\n\
1643 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
1644 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
1645 A number as third arg means request confirmation if NEWNAME already exists.\n\
1646 This is what happens in interactive use with M-x.")
1647 (filename, newname, ok_if_already_exists)
1648 Lisp_Object filename, newname, ok_if_already_exists;
1649 {
1650 #ifdef NO_ARG_ARRAY
1651 Lisp_Object args[2];
1652 #endif
1653 Lisp_Object handler;
1654 struct gcpro gcpro1, gcpro2;
1655
1656 GCPRO2 (filename, newname);
1657 CHECK_STRING (filename, 0);
1658 CHECK_STRING (newname, 1);
1659 filename = Fexpand_file_name (filename, Qnil);
1660 newname = Fexpand_file_name (newname, Qnil);
1661
1662 /* If the file name has special constructs in it,
1663 call the corresponding file handler. */
1664 handler = find_file_handler (filename);
1665 if (!NILP (handler))
1666 return call3 (handler, Qadd_name_to_file, filename, newname);
1667
1668 if (NILP (ok_if_already_exists)
1669 || XTYPE (ok_if_already_exists) == Lisp_Int)
1670 barf_or_query_if_file_exists (newname, "make it a new name",
1671 XTYPE (ok_if_already_exists) == Lisp_Int);
1672 unlink (XSTRING (newname)->data);
1673 if (0 > link (XSTRING (filename)->data, XSTRING (newname)->data))
1674 {
1675 #ifdef NO_ARG_ARRAY
1676 args[0] = filename;
1677 args[1] = newname;
1678 report_file_error ("Adding new name", Flist (2, args));
1679 #else
1680 report_file_error ("Adding new name", Flist (2, &filename));
1681 #endif
1682 }
1683
1684 UNGCPRO;
1685 return Qnil;
1686 }
1687
1688 #ifdef S_IFLNK
1689 DEFUN ("make-symbolic-link", Fmake_symbolic_link, Smake_symbolic_link, 2, 3,
1690 "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
1691 "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
1692 Signals a `file-already-exists' error if a file NEWNAME already exists\n\
1693 unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
1694 A number as third arg means request confirmation if NEWNAME already exists.\n\
1695 This happens for interactive use with M-x.")
1696 (filename, linkname, ok_if_already_exists)
1697 Lisp_Object filename, linkname, ok_if_already_exists;
1698 {
1699 #ifdef NO_ARG_ARRAY
1700 Lisp_Object args[2];
1701 #endif
1702 Lisp_Object handler;
1703 struct gcpro gcpro1, gcpro2;
1704
1705 GCPRO2 (filename, linkname);
1706 CHECK_STRING (filename, 0);
1707 CHECK_STRING (linkname, 1);
1708 #if 0 /* This made it impossible to make a link to a relative name. */
1709 filename = Fexpand_file_name (filename, Qnil);
1710 #endif
1711 linkname = Fexpand_file_name (linkname, Qnil);
1712
1713 /* If the file name has special constructs in it,
1714 call the corresponding file handler. */
1715 handler = find_file_handler (filename);
1716 if (!NILP (handler))
1717 return call3 (handler, Qmake_symbolic_link, filename, linkname);
1718
1719 if (NILP (ok_if_already_exists)
1720 || XTYPE (ok_if_already_exists) == Lisp_Int)
1721 barf_or_query_if_file_exists (linkname, "make it a link",
1722 XTYPE (ok_if_already_exists) == Lisp_Int);
1723 if (0 > symlink (XSTRING (filename)->data, XSTRING (linkname)->data))
1724 {
1725 /* If we didn't complain already, silently delete existing file. */
1726 if (errno == EEXIST)
1727 {
1728 unlink (XSTRING (filename)->data);
1729 if (0 <= symlink (XSTRING (filename)->data, XSTRING (linkname)->data))
1730 return Qnil;
1731 }
1732
1733 #ifdef NO_ARG_ARRAY
1734 args[0] = filename;
1735 args[1] = linkname;
1736 report_file_error ("Making symbolic link", Flist (2, args));
1737 #else
1738 report_file_error ("Making symbolic link", Flist (2, &filename));
1739 #endif
1740 }
1741 UNGCPRO;
1742 return Qnil;
1743 }
1744 #endif /* S_IFLNK */
1745
1746 #ifdef VMS
1747
1748 DEFUN ("define-logical-name", Fdefine_logical_name, Sdefine_logical_name,
1749 2, 2, "sDefine logical name: \nsDefine logical name %s as: ",
1750 "Define the job-wide logical name NAME to have the value STRING.\n\
1751 If STRING is nil or a null string, the logical name NAME is deleted.")
1752 (varname, string)
1753 Lisp_Object varname;
1754 Lisp_Object string;
1755 {
1756 CHECK_STRING (varname, 0);
1757 if (NILP (string))
1758 delete_logical_name (XSTRING (varname)->data);
1759 else
1760 {
1761 CHECK_STRING (string, 1);
1762
1763 if (XSTRING (string)->size == 0)
1764 delete_logical_name (XSTRING (varname)->data);
1765 else
1766 define_logical_name (XSTRING (varname)->data, XSTRING (string)->data);
1767 }
1768
1769 return string;
1770 }
1771 #endif /* VMS */
1772
1773 #ifdef HPUX_NET
1774
1775 DEFUN ("sysnetunam", Fsysnetunam, Ssysnetunam, 2, 2, 0,
1776 "Open a network connection to PATH using LOGIN as the login string.")
1777 (path, login)
1778 Lisp_Object path, login;
1779 {
1780 int netresult;
1781
1782 CHECK_STRING (path, 0);
1783 CHECK_STRING (login, 0);
1784
1785 netresult = netunam (XSTRING (path)->data, XSTRING (login)->data);
1786
1787 if (netresult == -1)
1788 return Qnil;
1789 else
1790 return Qt;
1791 }
1792 #endif /* HPUX_NET */
1793 \f
1794 DEFUN ("file-name-absolute-p", Ffile_name_absolute_p, Sfile_name_absolute_p,
1795 1, 1, 0,
1796 "Return t if file FILENAME specifies an absolute path name.\n\
1797 On Unix, this is a name starting with a `/' or a `~'.")
1798 (filename)
1799 Lisp_Object filename;
1800 {
1801 unsigned char *ptr;
1802
1803 CHECK_STRING (filename, 0);
1804 ptr = XSTRING (filename)->data;
1805 if (*ptr == '/' || *ptr == '~'
1806 #ifdef VMS
1807 /* ??? This criterion is probably wrong for '<'. */
1808 || index (ptr, ':') || index (ptr, '<')
1809 || (*ptr == '[' && (ptr[1] != '-' || (ptr[2] != '.' && ptr[2] != ']'))
1810 && ptr[1] != '.')
1811 #endif /* VMS */
1812 )
1813 return Qt;
1814 else
1815 return Qnil;
1816 }
1817
1818 DEFUN ("file-exists-p", Ffile_exists_p, Sfile_exists_p, 1, 1, 0,
1819 "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
1820 See also `file-readable-p' and `file-attributes'.")
1821 (filename)
1822 Lisp_Object filename;
1823 {
1824 Lisp_Object abspath;
1825 Lisp_Object handler;
1826
1827 CHECK_STRING (filename, 0);
1828 abspath = Fexpand_file_name (filename, Qnil);
1829
1830 /* If the file name has special constructs in it,
1831 call the corresponding file handler. */
1832 handler = find_file_handler (filename);
1833 if (!NILP (handler))
1834 return call2 (handler, Qfile_exists_p, filename);
1835
1836 return (access (XSTRING (abspath)->data, 0) >= 0) ? Qt : Qnil;
1837 }
1838
1839 DEFUN ("file-executable-p", Ffile_executable_p, Sfile_executable_p, 1, 1, 0,
1840 "Return t if FILENAME can be executed by you.\n\
1841 For directories this means you can change to that directory.")
1842 (filename)
1843 Lisp_Object filename;
1844
1845 {
1846 Lisp_Object abspath;
1847 Lisp_Object handler;
1848
1849 CHECK_STRING (filename, 0);
1850 abspath = Fexpand_file_name (filename, Qnil);
1851
1852 /* If the file name has special constructs in it,
1853 call the corresponding file handler. */
1854 handler = find_file_handler (filename);
1855 if (!NILP (handler))
1856 return call2 (handler, Qfile_executable_p, filename);
1857
1858 return (access (XSTRING (abspath)->data, 1) >= 0) ? Qt : Qnil;
1859 }
1860
1861 DEFUN ("file-readable-p", Ffile_readable_p, Sfile_readable_p, 1, 1, 0,
1862 "Return t if file FILENAME exists and you can read it.\n\
1863 See also `file-exists-p' and `file-attributes'.")
1864 (filename)
1865 Lisp_Object filename;
1866 {
1867 Lisp_Object abspath;
1868 Lisp_Object handler;
1869
1870 CHECK_STRING (filename, 0);
1871 abspath = Fexpand_file_name (filename, Qnil);
1872
1873 /* If the file name has special constructs in it,
1874 call the corresponding file handler. */
1875 handler = find_file_handler (filename);
1876 if (!NILP (handler))
1877 return call2 (handler, Qfile_readable_p, filename);
1878
1879 return (access (XSTRING (abspath)->data, 4) >= 0) ? Qt : Qnil;
1880 }
1881
1882 DEFUN ("file-symlink-p", Ffile_symlink_p, Sfile_symlink_p, 1, 1, 0,
1883 "If file FILENAME is the name of a symbolic link\n\
1884 returns the name of the file to which it is linked.\n\
1885 Otherwise returns NIL.")
1886 (filename)
1887 Lisp_Object filename;
1888 {
1889 #ifdef S_IFLNK
1890 char *buf;
1891 int bufsize;
1892 int valsize;
1893 Lisp_Object val;
1894 Lisp_Object handler;
1895
1896 CHECK_STRING (filename, 0);
1897 filename = Fexpand_file_name (filename, Qnil);
1898
1899 /* If the file name has special constructs in it,
1900 call the corresponding file handler. */
1901 handler = find_file_handler (filename);
1902 if (!NILP (handler))
1903 return call2 (handler, Qfile_symlink_p, filename);
1904
1905 bufsize = 100;
1906 while (1)
1907 {
1908 buf = (char *) xmalloc (bufsize);
1909 bzero (buf, bufsize);
1910 valsize = readlink (XSTRING (filename)->data, buf, bufsize);
1911 if (valsize < bufsize) break;
1912 /* Buffer was not long enough */
1913 free (buf);
1914 bufsize *= 2;
1915 }
1916 if (valsize == -1)
1917 {
1918 free (buf);
1919 return Qnil;
1920 }
1921 val = make_string (buf, valsize);
1922 free (buf);
1923 return val;
1924 #else /* not S_IFLNK */
1925 return Qnil;
1926 #endif /* not S_IFLNK */
1927 }
1928
1929 /* Having this before file-symlink-p mysteriously caused it to be forgotten
1930 on the RT/PC. */
1931 DEFUN ("file-writable-p", Ffile_writable_p, Sfile_writable_p, 1, 1, 0,
1932 "Return t if file FILENAME can be written or created by you.")
1933 (filename)
1934 Lisp_Object filename;
1935 {
1936 Lisp_Object abspath, dir;
1937 Lisp_Object handler;
1938
1939 CHECK_STRING (filename, 0);
1940 abspath = Fexpand_file_name (filename, Qnil);
1941
1942 /* If the file name has special constructs in it,
1943 call the corresponding file handler. */
1944 handler = find_file_handler (filename);
1945 if (!NILP (handler))
1946 return call2 (handler, Qfile_writable_p, filename);
1947
1948 if (access (XSTRING (abspath)->data, 0) >= 0)
1949 return (access (XSTRING (abspath)->data, 2) >= 0) ? Qt : Qnil;
1950 dir = Ffile_name_directory (abspath);
1951 #ifdef VMS
1952 if (!NILP (dir))
1953 dir = Fdirectory_file_name (dir);
1954 #endif /* VMS */
1955 return (access (!NILP (dir) ? (char *) XSTRING (dir)->data : "", 2) >= 0
1956 ? Qt : Qnil);
1957 }
1958
1959 DEFUN ("file-directory-p", Ffile_directory_p, Sfile_directory_p, 1, 1, 0,
1960 "Return t if file FILENAME is the name of a directory as a file.\n\
1961 A directory name spec may be given instead; then the value is t\n\
1962 if the directory so specified exists and really is a directory.")
1963 (filename)
1964 Lisp_Object filename;
1965 {
1966 register Lisp_Object abspath;
1967 struct stat st;
1968 Lisp_Object handler;
1969
1970 abspath = expand_and_dir_to_file (filename, current_buffer->directory);
1971
1972 /* If the file name has special constructs in it,
1973 call the corresponding file handler. */
1974 handler = find_file_handler (filename);
1975 if (!NILP (handler))
1976 return call2 (handler, Qfile_directory_p, filename);
1977
1978 if (stat (XSTRING (abspath)->data, &st) < 0)
1979 return Qnil;
1980 return (st.st_mode & S_IFMT) == S_IFDIR ? Qt : Qnil;
1981 }
1982
1983 DEFUN ("file-accessible-directory-p", Ffile_accessible_directory_p, Sfile_accessible_directory_p, 1, 1, 0,
1984 "Return t if file FILENAME is the name of a directory as a file,\n\
1985 and files in that directory can be opened by you. In order to use a\n\
1986 directory as a buffer's current directory, this predicate must return true.\n\
1987 A directory name spec may be given instead; then the value is t\n\
1988 if the directory so specified exists and really is a readable and\n\
1989 searchable directory.")
1990 (filename)
1991 Lisp_Object filename;
1992 {
1993 Lisp_Object handler;
1994
1995 /* If the file name has special constructs in it,
1996 call the corresponding file handler. */
1997 handler = find_file_handler (filename);
1998 if (!NILP (handler))
1999 return call2 (handler, Qfile_accessible_directory_p, filename);
2000
2001 if (NILP (Ffile_directory_p (filename))
2002 || NILP (Ffile_executable_p (filename)))
2003 return Qnil;
2004 else
2005 return Qt;
2006 }
2007
2008 DEFUN ("file-modes", Ffile_modes, Sfile_modes, 1, 1, 0,
2009 "Return mode bits of FILE, as an integer.")
2010 (filename)
2011 Lisp_Object filename;
2012 {
2013 Lisp_Object abspath;
2014 struct stat st;
2015 Lisp_Object handler;
2016
2017 abspath = expand_and_dir_to_file (filename, current_buffer->directory);
2018
2019 /* If the file name has special constructs in it,
2020 call the corresponding file handler. */
2021 handler = find_file_handler (filename);
2022 if (!NILP (handler))
2023 return call2 (handler, Qfile_modes, filename);
2024
2025 if (stat (XSTRING (abspath)->data, &st) < 0)
2026 return Qnil;
2027 return make_number (st.st_mode & 07777);
2028 }
2029
2030 DEFUN ("set-file-modes", Fset_file_modes, Sset_file_modes, 2, 2, 0,
2031 "Set mode bits of FILE to MODE (an integer).\n\
2032 Only the 12 low bits of MODE are used.")
2033 (filename, mode)
2034 Lisp_Object filename, mode;
2035 {
2036 Lisp_Object abspath;
2037 Lisp_Object handler;
2038
2039 abspath = Fexpand_file_name (filename, current_buffer->directory);
2040 CHECK_NUMBER (mode, 1);
2041
2042 /* If the file name has special constructs in it,
2043 call the corresponding file handler. */
2044 handler = find_file_handler (filename);
2045 if (!NILP (handler))
2046 return call3 (handler, Qset_file_modes, filename, mode);
2047
2048 #ifndef APOLLO
2049 if (chmod (XSTRING (abspath)->data, XINT (mode)) < 0)
2050 report_file_error ("Doing chmod", Fcons (abspath, Qnil));
2051 #else /* APOLLO */
2052 if (!egetenv ("USE_DOMAIN_ACLS"))
2053 {
2054 struct stat st;
2055 struct timeval tvp[2];
2056
2057 /* chmod on apollo also change the file's modtime; need to save the
2058 modtime and then restore it. */
2059 if (stat (XSTRING (abspath)->data, &st) < 0)
2060 {
2061 report_file_error ("Doing chmod", Fcons (abspath, Qnil));
2062 return (Qnil);
2063 }
2064
2065 if (chmod (XSTRING (abspath)->data, XINT (mode)) < 0)
2066 report_file_error ("Doing chmod", Fcons (abspath, Qnil));
2067
2068 /* reset the old accessed and modified times. */
2069 tvp[0].tv_sec = st.st_atime + 1; /* +1 due to an Apollo roundoff bug */
2070 tvp[0].tv_usec = 0;
2071 tvp[1].tv_sec = st.st_mtime + 1; /* +1 due to an Apollo roundoff bug */
2072 tvp[1].tv_usec = 0;
2073
2074 if (utimes (XSTRING (abspath)->data, tvp) < 0)
2075 report_file_error ("Doing utimes", Fcons (abspath, Qnil));
2076 }
2077 #endif /* APOLLO */
2078
2079 return Qnil;
2080 }
2081
2082 DEFUN ("set-umask", Fset_umask, Sset_umask, 1, 1, 0,
2083 "Select which permission bits to disable in newly created files.\n\
2084 MASK should be an integer; if a permission's bit in MASK is 1,\n\
2085 subsequently created files will not have that permission enabled.\n\
2086 Only the low 9 bits are used.\n\
2087 This setting is inherited by subprocesses.")
2088 (mask)
2089 Lisp_Object mask;
2090 {
2091 CHECK_NUMBER (mask, 0);
2092
2093 umask (XINT (mask) & 0777);
2094
2095 return Qnil;
2096 }
2097
2098 DEFUN ("umask", Fumask, Sumask, 0, 0, 0,
2099 "Return the current umask value.\n\
2100 The umask value determines which permissions are enabled in newly\n\
2101 created files. If a permission's bit in the umask is 1, subsequently\n\
2102 created files will not have that permission enabled.")
2103 ()
2104 {
2105 Lisp_Object mask;
2106
2107 XSET (mask, Lisp_Int, umask (0));
2108 umask (XINT (mask));
2109
2110 return mask;
2111 }
2112
2113 #ifdef unix
2114
2115 DEFUN ("unix-sync", Funix_sync, Sunix_sync, 0, 0, "",
2116 "Tell Unix to finish all pending disk updates.")
2117 ()
2118 {
2119 sync ();
2120 return Qnil;
2121 }
2122
2123 #endif /* unix */
2124
2125 DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p, Sfile_newer_than_file_p, 2, 2, 0,
2126 "Return t if file FILE1 is newer than file FILE2.\n\
2127 If FILE1 does not exist, the answer is nil;\n\
2128 otherwise, if FILE2 does not exist, the answer is t.")
2129 (file1, file2)
2130 Lisp_Object file1, file2;
2131 {
2132 Lisp_Object abspath1, abspath2;
2133 struct stat st;
2134 int mtime1;
2135 Lisp_Object handler;
2136
2137 CHECK_STRING (file1, 0);
2138 CHECK_STRING (file2, 0);
2139
2140 abspath1 = expand_and_dir_to_file (file1, current_buffer->directory);
2141 abspath2 = expand_and_dir_to_file (file2, current_buffer->directory);
2142
2143 /* If the file name has special constructs in it,
2144 call the corresponding file handler. */
2145 handler = find_file_handler (abspath1);
2146 if (!NILP (handler))
2147 return call3 (handler, Qfile_newer_than_file_p, abspath1, abspath2);
2148
2149 if (stat (XSTRING (abspath1)->data, &st) < 0)
2150 return Qnil;
2151
2152 mtime1 = st.st_mtime;
2153
2154 if (stat (XSTRING (abspath2)->data, &st) < 0)
2155 return Qt;
2156
2157 return (mtime1 > st.st_mtime) ? Qt : Qnil;
2158 }
2159 \f
2160 DEFUN ("insert-file-contents", Finsert_file_contents, Sinsert_file_contents,
2161 1, 2, 0,
2162 "Insert contents of file FILENAME after point.\n\
2163 Returns list of absolute pathname and length of data inserted.\n\
2164 If second argument VISIT is non-nil, the buffer's visited filename\n\
2165 and last save file modtime are set, and it is marked unmodified.\n\
2166 If visiting and the file does not exist, visiting is completed\n\
2167 before the error is signaled.")
2168 (filename, visit)
2169 Lisp_Object filename, visit;
2170 {
2171 struct stat st;
2172 register int fd;
2173 register int inserted = 0;
2174 register int how_much;
2175 int count = specpdl_ptr - specpdl;
2176 struct gcpro gcpro1;
2177 Lisp_Object handler, val;
2178
2179 val = Qnil;
2180
2181 GCPRO1 (filename);
2182 if (!NILP (current_buffer->read_only))
2183 Fbarf_if_buffer_read_only();
2184
2185 CHECK_STRING (filename, 0);
2186 filename = Fexpand_file_name (filename, Qnil);
2187
2188 /* If the file name has special constructs in it,
2189 call the corresponding file handler. */
2190 handler = find_file_handler (filename);
2191 if (!NILP (handler))
2192 {
2193 val = call3 (handler, Qinsert_file_contents, filename, visit);
2194 st.st_mtime = 0;
2195 goto handled;
2196 }
2197
2198 fd = -1;
2199
2200 #ifndef APOLLO
2201 if (stat (XSTRING (filename)->data, &st) < 0
2202 || (fd = open (XSTRING (filename)->data, 0)) < 0)
2203 #else
2204 if ((fd = open (XSTRING (filename)->data, 0)) < 0
2205 || fstat (fd, &st) < 0)
2206 #endif /* not APOLLO */
2207 {
2208 if (fd >= 0) close (fd);
2209 if (NILP (visit))
2210 report_file_error ("Opening input file", Fcons (filename, Qnil));
2211 st.st_mtime = -1;
2212 how_much = 0;
2213 goto notfound;
2214 }
2215
2216 record_unwind_protect (close_file_unwind, make_number (fd));
2217
2218 #ifdef S_IFSOCK
2219 /* This code will need to be changed in order to work on named
2220 pipes, and it's probably just not worth it. So we should at
2221 least signal an error. */
2222 if ((st.st_mode & S_IFMT) == S_IFSOCK)
2223 Fsignal (Qfile_error,
2224 Fcons (build_string ("reading from named pipe"),
2225 Fcons (filename, Qnil)));
2226 #endif
2227
2228 /* Supposedly happens on VMS. */
2229 if (st.st_size < 0)
2230 error ("File size is negative");
2231
2232 {
2233 register Lisp_Object temp;
2234
2235 /* Make sure point-max won't overflow after this insertion. */
2236 XSET (temp, Lisp_Int, st.st_size + Z);
2237 if (st.st_size + Z != XINT (temp))
2238 error ("maximum buffer size exceeded");
2239 }
2240
2241 if (NILP (visit))
2242 prepare_to_modify_buffer (point, point);
2243
2244 move_gap (point);
2245 if (GAP_SIZE < st.st_size)
2246 make_gap (st.st_size - GAP_SIZE);
2247
2248 while (1)
2249 {
2250 int try = min (st.st_size - inserted, 64 << 10);
2251 int this;
2252
2253 /* Allow quitting out of the actual I/O. */
2254 immediate_quit = 1;
2255 QUIT;
2256 this = read (fd, &FETCH_CHAR (point + inserted - 1) + 1, try);
2257 immediate_quit = 0;
2258
2259 if (this <= 0)
2260 {
2261 how_much = this;
2262 break;
2263 }
2264
2265 GPT += this;
2266 GAP_SIZE -= this;
2267 ZV += this;
2268 Z += this;
2269 inserted += this;
2270 }
2271
2272 if (inserted > 0)
2273 MODIFF++;
2274 record_insert (point, inserted);
2275
2276 close (fd);
2277
2278 /* Discard the unwind protect */
2279 specpdl_ptr = specpdl + count;
2280
2281 if (how_much < 0)
2282 error ("IO error reading %s: %s",
2283 XSTRING (filename)->data, err_str (errno));
2284
2285 notfound:
2286 handled:
2287
2288 if (!NILP (visit))
2289 {
2290 current_buffer->undo_list = Qnil;
2291 #ifdef APOLLO
2292 stat (XSTRING (filename)->data, &st);
2293 #endif
2294 current_buffer->modtime = st.st_mtime;
2295 current_buffer->save_modified = MODIFF;
2296 current_buffer->auto_save_modified = MODIFF;
2297 XFASTINT (current_buffer->save_length) = Z - BEG;
2298 #ifdef CLASH_DETECTION
2299 if (NILP (handler))
2300 {
2301 if (!NILP (current_buffer->filename))
2302 unlock_file (current_buffer->filename);
2303 unlock_file (filename);
2304 }
2305 #endif /* CLASH_DETECTION */
2306 current_buffer->filename = filename;
2307 /* If visiting nonexistent file, return nil. */
2308 if (current_buffer->modtime == -1)
2309 report_file_error ("Opening input file", Fcons (filename, Qnil));
2310 }
2311
2312 signal_after_change (point, 0, inserted);
2313
2314 if (!NILP (val))
2315 RETURN_UNGCPRO (val);
2316 RETURN_UNGCPRO (Fcons (filename,
2317 Fcons (make_number (inserted),
2318 Qnil)));
2319 }
2320
2321 DEFUN ("write-region", Fwrite_region, Swrite_region, 3, 5,
2322 "r\nFWrite region to file: ",
2323 "Write current region into specified file.\n\
2324 When called from a program, takes three arguments:\n\
2325 START, END and FILENAME. START and END are buffer positions.\n\
2326 Optional fourth argument APPEND if non-nil means\n\
2327 append to existing file contents (if any).\n\
2328 Optional fifth argument VISIT if t means\n\
2329 set the last-save-file-modtime of buffer to this file's modtime\n\
2330 and mark buffer not modified.\n\
2331 If VISIT is neither t nor nil, it means do not print\n\
2332 the \"Wrote file\" message.\n\
2333 Kludgy feature: if START is a string, then that string is written\n\
2334 to the file, instead of any buffer contents, and END is ignored.")
2335 (start, end, filename, append, visit)
2336 Lisp_Object start, end, filename, append, visit;
2337 {
2338 register int desc;
2339 int failure;
2340 int save_errno;
2341 unsigned char *fn;
2342 struct stat st;
2343 int tem;
2344 int count = specpdl_ptr - specpdl;
2345 #ifdef VMS
2346 unsigned char *fname = 0; /* If non-0, original filename (must rename) */
2347 #endif /* VMS */
2348 Lisp_Object handler;
2349
2350 /* Special kludge to simplify auto-saving */
2351 if (NILP (start))
2352 {
2353 XFASTINT (start) = BEG;
2354 XFASTINT (end) = Z;
2355 }
2356 else if (XTYPE (start) != Lisp_String)
2357 validate_region (&start, &end);
2358
2359 filename = Fexpand_file_name (filename, Qnil);
2360 fn = XSTRING (filename)->data;
2361
2362 /* If the file name has special constructs in it,
2363 call the corresponding file handler. */
2364 handler = find_file_handler (filename);
2365
2366 if (!NILP (handler))
2367 {
2368 Lisp_Object args[7];
2369 Lisp_Object val;
2370 args[0] = handler;
2371 args[1] = Qwrite_region;
2372 args[2] = start;
2373 args[3] = end;
2374 args[4] = filename;
2375 args[5] = append;
2376 args[6] = visit;
2377 val = Ffuncall (7, args);
2378
2379 /* Do this before reporting IO error
2380 to avoid a "file has changed on disk" warning on
2381 next attempt to save. */
2382 if (EQ (visit, Qt))
2383 {
2384 current_buffer->modtime = 0;
2385 current_buffer->save_modified = MODIFF;
2386 XFASTINT (current_buffer->save_length) = Z - BEG;
2387 current_buffer->filename = filename;
2388 }
2389 return val;
2390 }
2391
2392 #ifdef CLASH_DETECTION
2393 if (!auto_saving)
2394 lock_file (filename);
2395 #endif /* CLASH_DETECTION */
2396
2397 desc = -1;
2398 if (!NILP (append))
2399 desc = open (fn, O_WRONLY);
2400
2401 if (desc < 0)
2402 #ifdef VMS
2403 if (auto_saving) /* Overwrite any previous version of autosave file */
2404 {
2405 vms_truncate (fn); /* if fn exists, truncate to zero length */
2406 desc = open (fn, O_RDWR);
2407 if (desc < 0)
2408 desc = creat_copy_attrs (XTYPE (current_buffer->filename) == Lisp_String
2409 ? XSTRING (current_buffer->filename)->data : 0,
2410 fn);
2411 }
2412 else /* Write to temporary name and rename if no errors */
2413 {
2414 Lisp_Object temp_name;
2415 temp_name = Ffile_name_directory (filename);
2416
2417 if (!NILP (temp_name))
2418 {
2419 temp_name = Fmake_temp_name (concat2 (temp_name,
2420 build_string ("$$SAVE$$")));
2421 fname = XSTRING (filename)->data;
2422 fn = XSTRING (temp_name)->data;
2423 desc = creat_copy_attrs (fname, fn);
2424 if (desc < 0)
2425 {
2426 /* If we can't open the temporary file, try creating a new
2427 version of the original file. VMS "creat" creates a
2428 new version rather than truncating an existing file. */
2429 fn = fname;
2430 fname = 0;
2431 desc = creat (fn, 0666);
2432 #if 0 /* This can clobber an existing file and fail to replace it,
2433 if the user runs out of space. */
2434 if (desc < 0)
2435 {
2436 /* We can't make a new version;
2437 try to truncate and rewrite existing version if any. */
2438 vms_truncate (fn);
2439 desc = open (fn, O_RDWR);
2440 }
2441 #endif
2442 }
2443 }
2444 else
2445 desc = creat (fn, 0666);
2446 }
2447 #else /* not VMS */
2448 desc = creat (fn, auto_saving ? auto_save_mode_bits : 0666);
2449 #endif /* not VMS */
2450
2451 if (desc < 0)
2452 {
2453 #ifdef CLASH_DETECTION
2454 save_errno = errno;
2455 if (!auto_saving) unlock_file (filename);
2456 errno = save_errno;
2457 #endif /* CLASH_DETECTION */
2458 report_file_error ("Opening output file", Fcons (filename, Qnil));
2459 }
2460
2461 record_unwind_protect (close_file_unwind, make_number (desc));
2462
2463 if (!NILP (append))
2464 if (lseek (desc, 0, 2) < 0)
2465 {
2466 #ifdef CLASH_DETECTION
2467 if (!auto_saving) unlock_file (filename);
2468 #endif /* CLASH_DETECTION */
2469 report_file_error ("Lseek error", Fcons (filename, Qnil));
2470 }
2471
2472 #ifdef VMS
2473 /*
2474 * Kludge Warning: The VMS C RTL likes to insert carriage returns
2475 * if we do writes that don't end with a carriage return. Furthermore
2476 * it cannot handle writes of more then 16K. The modified
2477 * version of "sys_write" in SYSDEP.C (see comment there) copes with
2478 * this EXCEPT for the last record (iff it doesn't end with a carriage
2479 * return). This implies that if your buffer doesn't end with a carriage
2480 * return, you get one free... tough. However it also means that if
2481 * we make two calls to sys_write (a la the following code) you can
2482 * get one at the gap as well. The easiest way to fix this (honest)
2483 * is to move the gap to the next newline (or the end of the buffer).
2484 * Thus this change.
2485 *
2486 * Yech!
2487 */
2488 if (GPT > BEG && GPT_ADDR[-1] != '\n')
2489 move_gap (find_next_newline (GPT, 1));
2490 #endif
2491
2492 failure = 0;
2493 immediate_quit = 1;
2494
2495 if (XTYPE (start) == Lisp_String)
2496 {
2497 failure = 0 > e_write (desc, XSTRING (start)->data,
2498 XSTRING (start)->size);
2499 save_errno = errno;
2500 }
2501 else if (XINT (start) != XINT (end))
2502 {
2503 if (XINT (start) < GPT)
2504 {
2505 register int end1 = XINT (end);
2506 tem = XINT (start);
2507 failure = 0 > e_write (desc, &FETCH_CHAR (tem),
2508 min (GPT, end1) - tem);
2509 save_errno = errno;
2510 }
2511
2512 if (XINT (end) > GPT && !failure)
2513 {
2514 tem = XINT (start);
2515 tem = max (tem, GPT);
2516 failure = 0 > e_write (desc, &FETCH_CHAR (tem), XINT (end) - tem);
2517 save_errno = errno;
2518 }
2519 }
2520
2521 immediate_quit = 0;
2522
2523 #ifndef USG
2524 #ifndef VMS
2525 #ifndef BSD4_1
2526 /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
2527 Disk full in NFS may be reported here. */
2528 if (fsync (desc) < 0)
2529 failure = 1, save_errno = errno;
2530 #endif
2531 #endif
2532 #endif
2533
2534 /* Spurious "file has changed on disk" warnings have been
2535 observed on Suns as well.
2536 It seems that `close' can change the modtime, under nfs.
2537
2538 (This has supposedly been fixed in Sunos 4,
2539 but who knows about all the other machines with NFS?) */
2540 #if 0
2541
2542 /* On VMS and APOLLO, must do the stat after the close
2543 since closing changes the modtime. */
2544 #ifndef VMS
2545 #ifndef APOLLO
2546 /* Recall that #if defined does not work on VMS. */
2547 #define FOO
2548 fstat (desc, &st);
2549 #endif
2550 #endif
2551 #endif
2552
2553 /* NFS can report a write failure now. */
2554 if (close (desc) < 0)
2555 failure = 1, save_errno = errno;
2556
2557 #ifdef VMS
2558 /* If we wrote to a temporary name and had no errors, rename to real name. */
2559 if (fname)
2560 {
2561 if (!failure)
2562 failure = (rename (fn, fname) != 0), save_errno = errno;
2563 fn = fname;
2564 }
2565 #endif /* VMS */
2566
2567 #ifndef FOO
2568 stat (fn, &st);
2569 #endif
2570 /* Discard the unwind protect */
2571 specpdl_ptr = specpdl + count;
2572
2573 #ifdef CLASH_DETECTION
2574 if (!auto_saving)
2575 unlock_file (filename);
2576 #endif /* CLASH_DETECTION */
2577
2578 /* Do this before reporting IO error
2579 to avoid a "file has changed on disk" warning on
2580 next attempt to save. */
2581 if (EQ (visit, Qt))
2582 current_buffer->modtime = st.st_mtime;
2583
2584 if (failure)
2585 error ("IO error writing %s: %s", fn, err_str (save_errno));
2586
2587 if (EQ (visit, Qt))
2588 {
2589 current_buffer->save_modified = MODIFF;
2590 XFASTINT (current_buffer->save_length) = Z - BEG;
2591 current_buffer->filename = filename;
2592 }
2593 else if (!NILP (visit))
2594 return Qnil;
2595
2596 if (!auto_saving)
2597 message ("Wrote %s", fn);
2598
2599 return Qnil;
2600 }
2601
2602 int
2603 e_write (desc, addr, len)
2604 int desc;
2605 register char *addr;
2606 register int len;
2607 {
2608 char buf[16 * 1024];
2609 register char *p, *end;
2610
2611 if (!EQ (current_buffer->selective_display, Qt))
2612 return write (desc, addr, len) - len;
2613 else
2614 {
2615 p = buf;
2616 end = p + sizeof buf;
2617 while (len--)
2618 {
2619 if (p == end)
2620 {
2621 if (write (desc, buf, sizeof buf) != sizeof buf)
2622 return -1;
2623 p = buf;
2624 }
2625 *p = *addr++;
2626 if (*p++ == '\015')
2627 p[-1] = '\n';
2628 }
2629 if (p != buf)
2630 if (write (desc, buf, p - buf) != p - buf)
2631 return -1;
2632 }
2633 return 0;
2634 }
2635
2636 DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime,
2637 Sverify_visited_file_modtime, 1, 1, 0,
2638 "Return t if last mod time of BUF's visited file matches what BUF records.\n\
2639 This means that the file has not been changed since it was visited or saved.")
2640 (buf)
2641 Lisp_Object buf;
2642 {
2643 struct buffer *b;
2644 struct stat st;
2645 Lisp_Object handler;
2646
2647 CHECK_BUFFER (buf, 0);
2648 b = XBUFFER (buf);
2649
2650 if (XTYPE (b->filename) != Lisp_String) return Qt;
2651 if (b->modtime == 0) return Qt;
2652
2653 /* If the file name has special constructs in it,
2654 call the corresponding file handler. */
2655 handler = find_file_handler (b->filename);
2656 if (!NILP (handler))
2657 return call2 (handler, Qverify_visited_file_modtime, b->filename);
2658
2659 if (stat (XSTRING (b->filename)->data, &st) < 0)
2660 {
2661 /* If the file doesn't exist now and didn't exist before,
2662 we say that it isn't modified, provided the error is a tame one. */
2663 if (errno == ENOENT || errno == EACCES || errno == ENOTDIR)
2664 st.st_mtime = -1;
2665 else
2666 st.st_mtime = 0;
2667 }
2668 if (st.st_mtime == b->modtime
2669 /* If both are positive, accept them if they are off by one second. */
2670 || (st.st_mtime > 0 && b->modtime > 0
2671 && (st.st_mtime == b->modtime + 1
2672 || st.st_mtime == b->modtime - 1)))
2673 return Qt;
2674 return Qnil;
2675 }
2676
2677 DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime,
2678 Sclear_visited_file_modtime, 0, 0, 0,
2679 "Clear out records of last mod time of visited file.\n\
2680 Next attempt to save will certainly not complain of a discrepancy.")
2681 ()
2682 {
2683 current_buffer->modtime = 0;
2684 return Qnil;
2685 }
2686
2687 DEFUN ("set-visited-file-modtime", Fset_visited_file_modtime,
2688 Sset_visited_file_modtime, 0, 0, 0,
2689 "Update buffer's recorded modification time from the visited file's time.\n\
2690 Useful if the buffer was not read from the file normally\n\
2691 or if the file itself has been changed for some known benign reason.")
2692 ()
2693 {
2694 register Lisp_Object filename;
2695 struct stat st;
2696 Lisp_Object handler;
2697
2698 filename = Fexpand_file_name (current_buffer->filename, Qnil);
2699
2700 /* If the file name has special constructs in it,
2701 call the corresponding file handler. */
2702 handler = find_file_handler (filename);
2703 if (!NILP (handler))
2704 current_buffer->modtime = 0;
2705
2706 else if (stat (XSTRING (filename)->data, &st) >= 0)
2707 current_buffer->modtime = st.st_mtime;
2708
2709 return Qnil;
2710 }
2711 \f
2712 Lisp_Object
2713 auto_save_error ()
2714 {
2715 unsigned char *name = XSTRING (current_buffer->name)->data;
2716
2717 ring_bell ();
2718 message ("Autosaving...error for %s", name);
2719 Fsleep_for (make_number (1), Qnil);
2720 message ("Autosaving...error!for %s", name);
2721 Fsleep_for (make_number (1), Qnil);
2722 message ("Autosaving...error for %s", name);
2723 Fsleep_for (make_number (1), Qnil);
2724 return Qnil;
2725 }
2726
2727 Lisp_Object
2728 auto_save_1 ()
2729 {
2730 unsigned char *fn;
2731 struct stat st;
2732
2733 /* Get visited file's mode to become the auto save file's mode. */
2734 if (stat (XSTRING (current_buffer->filename)->data, &st) >= 0)
2735 /* But make sure we can overwrite it later! */
2736 auto_save_mode_bits = st.st_mode | 0600;
2737 else
2738 auto_save_mode_bits = 0666;
2739
2740 return
2741 Fwrite_region (Qnil, Qnil,
2742 current_buffer->auto_save_file_name,
2743 Qnil, Qlambda);
2744 }
2745
2746 DEFUN ("do-auto-save", Fdo_auto_save, Sdo_auto_save, 0, 2, "",
2747 "Auto-save all buffers that need it.\n\
2748 This is all buffers that have auto-saving enabled\n\
2749 and are changed since last auto-saved.\n\
2750 Auto-saving writes the buffer into a file\n\
2751 so that your editing is not lost if the system crashes.\n\
2752 This file is not the file you visited; that changes only when you save.\n\n\
2753 Non-nil first argument means do not print any message if successful.\n\
2754 Non-nil second argument means save only current buffer.")
2755 (nomsg)
2756 Lisp_Object nomsg;
2757 {
2758 struct buffer *old = current_buffer, *b;
2759 Lisp_Object tail, buf;
2760 int auto_saved = 0;
2761 char *omessage = echo_area_glyphs;
2762 extern minibuf_level;
2763
2764 /* No GCPRO needed, because (when it matters) all Lisp_Object variables
2765 point to non-strings reached from Vbuffer_alist. */
2766
2767 auto_saving = 1;
2768 if (minibuf_level)
2769 nomsg = Qt;
2770
2771 /* Vrun_hooks is nil before emacs is dumped, and inc-vers.el will
2772 eventually call do-auto-save, so don't err here in that case. */
2773 if (!NILP (Vrun_hooks))
2774 call1 (Vrun_hooks, intern ("auto-save-hook"));
2775
2776 for (tail = Vbuffer_alist; XGCTYPE (tail) == Lisp_Cons;
2777 tail = XCONS (tail)->cdr)
2778 {
2779 buf = XCONS (XCONS (tail)->car)->cdr;
2780 b = XBUFFER (buf);
2781 /* Check for auto save enabled
2782 and file changed since last auto save
2783 and file changed since last real save. */
2784 if (XTYPE (b->auto_save_file_name) == Lisp_String
2785 && b->save_modified < BUF_MODIFF (b)
2786 && b->auto_save_modified < BUF_MODIFF (b))
2787 {
2788 if ((XFASTINT (b->save_length) * 10
2789 > (BUF_Z (b) - BUF_BEG (b)) * 13)
2790 /* A short file is likely to change a large fraction;
2791 spare the user annoying messages. */
2792 && XFASTINT (b->save_length) > 5000
2793 /* These messages are frequent and annoying for `*mail*'. */
2794 && !EQ (b->filename, Qnil))
2795 {
2796 /* It has shrunk too much; turn off auto-saving here. */
2797 message ("Buffer %s has shrunk a lot; auto save turned off there",
2798 XSTRING (b->name)->data);
2799 /* User can reenable saving with M-x auto-save. */
2800 b->auto_save_file_name = Qnil;
2801 /* Prevent warning from repeating if user does so. */
2802 XFASTINT (b->save_length) = 0;
2803 Fsleep_for (make_number (1));
2804 continue;
2805 }
2806 set_buffer_internal (b);
2807 if (!auto_saved && NILP (nomsg))
2808 message1 ("Auto-saving...");
2809 internal_condition_case (auto_save_1, Qt, auto_save_error);
2810 auto_saved++;
2811 b->auto_save_modified = BUF_MODIFF (b);
2812 XFASTINT (current_buffer->save_length) = Z - BEG;
2813 set_buffer_internal (old);
2814 }
2815 }
2816
2817 if (auto_saved)
2818 record_auto_save ();
2819
2820 if (auto_saved && NILP (nomsg))
2821 message1 (omessage ? omessage : "Auto-saving...done");
2822
2823 auto_saving = 0;
2824 return Qnil;
2825 }
2826
2827 DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved,
2828 Sset_buffer_auto_saved, 0, 0, 0,
2829 "Mark current buffer as auto-saved with its current text.\n\
2830 No auto-save file will be written until the buffer changes again.")
2831 ()
2832 {
2833 current_buffer->auto_save_modified = MODIFF;
2834 XFASTINT (current_buffer->save_length) = Z - BEG;
2835 return Qnil;
2836 }
2837
2838 DEFUN ("recent-auto-save-p", Frecent_auto_save_p, Srecent_auto_save_p,
2839 0, 0, 0,
2840 "Return t if buffer has been auto-saved since last read in or saved.")
2841 ()
2842 {
2843 return (current_buffer->save_modified < current_buffer->auto_save_modified) ? Qt : Qnil;
2844 }
2845 \f
2846 /* Reading and completing file names */
2847 extern Lisp_Object Ffile_name_completion (), Ffile_name_all_completions ();
2848
2849 DEFUN ("read-file-name-internal", Fread_file_name_internal, Sread_file_name_internal,
2850 3, 3, 0,
2851 "Internal subroutine for read-file-name. Do not call this.")
2852 (string, dir, action)
2853 Lisp_Object string, dir, action;
2854 /* action is nil for complete, t for return list of completions,
2855 lambda for verify final value */
2856 {
2857 Lisp_Object name, specdir, realdir, val, orig_string;
2858
2859 if (XSTRING (string)->size == 0)
2860 {
2861 orig_string = Qnil;
2862 name = string;
2863 realdir = dir;
2864 if (EQ (action, Qlambda))
2865 return Qnil;
2866 }
2867 else
2868 {
2869 orig_string = string;
2870 string = Fsubstitute_in_file_name (string);
2871 name = Ffile_name_nondirectory (string);
2872 realdir = Ffile_name_directory (string);
2873 if (NILP (realdir))
2874 realdir = dir;
2875 else
2876 realdir = Fexpand_file_name (realdir, dir);
2877 }
2878
2879 if (NILP (action))
2880 {
2881 specdir = Ffile_name_directory (string);
2882 val = Ffile_name_completion (name, realdir);
2883 if (XTYPE (val) != Lisp_String)
2884 {
2885 if (NILP (Fstring_equal (string, orig_string)))
2886 return string;
2887 return (val);
2888 }
2889
2890 if (!NILP (specdir))
2891 val = concat2 (specdir, val);
2892 #ifndef VMS
2893 {
2894 register unsigned char *old, *new;
2895 register int n;
2896 int osize, count;
2897
2898 osize = XSTRING (val)->size;
2899 /* Quote "$" as "$$" to get it past substitute-in-file-name */
2900 for (n = osize, count = 0, old = XSTRING (val)->data; n > 0; n--)
2901 if (*old++ == '$') count++;
2902 if (count > 0)
2903 {
2904 old = XSTRING (val)->data;
2905 val = Fmake_string (make_number (osize + count), make_number (0));
2906 new = XSTRING (val)->data;
2907 for (n = osize; n > 0; n--)
2908 if (*old != '$')
2909 *new++ = *old++;
2910 else
2911 {
2912 *new++ = '$';
2913 *new++ = '$';
2914 old++;
2915 }
2916 }
2917 }
2918 #endif /* Not VMS */
2919 return (val);
2920 }
2921
2922 if (EQ (action, Qt))
2923 return Ffile_name_all_completions (name, realdir);
2924 /* Only other case actually used is ACTION = lambda */
2925 #ifdef VMS
2926 /* Supposedly this helps commands such as `cd' that read directory names,
2927 but can someone explain how it helps them? -- RMS */
2928 if (XSTRING (name)->size == 0)
2929 return Qt;
2930 #endif /* VMS */
2931 return Ffile_exists_p (string);
2932 }
2933
2934 DEFUN ("read-file-name", Fread_file_name, Sread_file_name, 1, 5, 0,
2935 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
2936 Value is not expanded---you must call `expand-file-name' yourself.\n\
2937 Default name to DEFAULT if user enters a null string.\n\
2938 (If DEFAULT is omitted, the visited file name is used.)\n\
2939 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
2940 Non-nil and non-t means also require confirmation after completion.\n\
2941 Fifth arg INITIAL specifies text to start with.\n\
2942 DIR defaults to current buffer's directory default.")
2943 (prompt, dir, defalt, mustmatch, initial)
2944 Lisp_Object prompt, dir, defalt, mustmatch, initial;
2945 {
2946 Lisp_Object val, insdef, insdef1, tem;
2947 struct gcpro gcpro1, gcpro2;
2948 register char *homedir;
2949 int count;
2950
2951 if (NILP (dir))
2952 dir = current_buffer->directory;
2953 if (NILP (defalt))
2954 defalt = current_buffer->filename;
2955
2956 /* If dir starts with user's homedir, change that to ~. */
2957 homedir = (char *) egetenv ("HOME");
2958 if (homedir != 0
2959 && XTYPE (dir) == Lisp_String
2960 && !strncmp (homedir, XSTRING (dir)->data, strlen (homedir))
2961 && XSTRING (dir)->data[strlen (homedir)] == '/')
2962 {
2963 dir = make_string (XSTRING (dir)->data + strlen (homedir) - 1,
2964 XSTRING (dir)->size - strlen (homedir) + 1);
2965 XSTRING (dir)->data[0] = '~';
2966 }
2967
2968 if (insert_default_directory)
2969 {
2970 insdef = dir;
2971 insdef1 = dir;
2972 if (!NILP (initial))
2973 {
2974 Lisp_Object args[2], pos;
2975
2976 args[0] = insdef;
2977 args[1] = initial;
2978 insdef = Fconcat (2, args);
2979 pos = make_number (XSTRING (dir)->size);
2980 insdef1 = Fcons (insdef, pos);
2981 }
2982 }
2983 else
2984 insdef = Qnil, insdef1 = Qnil;
2985
2986 #ifdef VMS
2987 count = specpdl_ptr - specpdl;
2988 specbind (intern ("completion-ignore-case"), Qt);
2989 #endif
2990
2991 GCPRO2 (insdef, defalt);
2992 val = Fcompleting_read (prompt, intern ("read-file-name-internal"),
2993 dir, mustmatch, insdef1,
2994 Qfile_name_history);
2995
2996 #ifdef VMS
2997 unbind_to (count, Qnil);
2998 #endif
2999
3000 UNGCPRO;
3001 if (NILP (val))
3002 error ("No file name specified");
3003 tem = Fstring_equal (val, insdef);
3004 if (!NILP (tem) && !NILP (defalt))
3005 return defalt;
3006 return Fsubstitute_in_file_name (val);
3007 }
3008
3009 #if 0 /* Old version */
3010 DEFUN ("read-file-name", Fread_file_name, Sread_file_name, 1, 5, 0,
3011 "Read file name, prompting with PROMPT and completing in directory DIR.\n\
3012 Value is not expanded---you must call `expand-file-name' yourself.\n\
3013 Default name to DEFAULT if user enters a null string.\n\
3014 (If DEFAULT is omitted, the visited file name is used.)\n\
3015 Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
3016 Non-nil and non-t means also require confirmation after completion.\n\
3017 Fifth arg INITIAL specifies text to start with.\n\
3018 DIR defaults to current buffer's directory default.")
3019 (prompt, dir, defalt, mustmatch, initial)
3020 Lisp_Object prompt, dir, defalt, mustmatch, initial;
3021 {
3022 Lisp_Object val, insdef, tem;
3023 struct gcpro gcpro1, gcpro2;
3024 register char *homedir;
3025 int count;
3026
3027 if (NILP (dir))
3028 dir = current_buffer->directory;
3029 if (NILP (defalt))
3030 defalt = current_buffer->filename;
3031
3032 /* If dir starts with user's homedir, change that to ~. */
3033 homedir = (char *) egetenv ("HOME");
3034 if (homedir != 0
3035 && XTYPE (dir) == Lisp_String
3036 && !strncmp (homedir, XSTRING (dir)->data, strlen (homedir))
3037 && XSTRING (dir)->data[strlen (homedir)] == '/')
3038 {
3039 dir = make_string (XSTRING (dir)->data + strlen (homedir) - 1,
3040 XSTRING (dir)->size - strlen (homedir) + 1);
3041 XSTRING (dir)->data[0] = '~';
3042 }
3043
3044 if (!NILP (initial))
3045 insdef = initial;
3046 else if (insert_default_directory)
3047 insdef = dir;
3048 else
3049 insdef = build_string ("");
3050
3051 #ifdef VMS
3052 count = specpdl_ptr - specpdl;
3053 specbind (intern ("completion-ignore-case"), Qt);
3054 #endif
3055
3056 GCPRO2 (insdef, defalt);
3057 val = Fcompleting_read (prompt, intern ("read-file-name-internal"),
3058 dir, mustmatch,
3059 insert_default_directory ? insdef : Qnil,
3060 Qfile_name_history);
3061
3062 #ifdef VMS
3063 unbind_to (count, Qnil);
3064 #endif
3065
3066 UNGCPRO;
3067 if (NILP (val))
3068 error ("No file name specified");
3069 tem = Fstring_equal (val, insdef);
3070 if (!NILP (tem) && !NILP (defalt))
3071 return defalt;
3072 return Fsubstitute_in_file_name (val);
3073 }
3074 #endif /* Old version */
3075 \f
3076 syms_of_fileio ()
3077 {
3078 Qcopy_file = intern ("copy-file");
3079 Qmake_directory = intern ("make-directory");
3080 Qdelete_directory = intern ("delete-directory");
3081 Qdelete_file = intern ("delete-file");
3082 Qrename_file = intern ("rename-file");
3083 Qadd_name_to_file = intern ("add-name-to-file");
3084 Qmake_symbolic_link = intern ("make-symbolic-link");
3085 Qfile_exists_p = intern ("file-exists-p");
3086 Qfile_executable_p = intern ("file-executable-p");
3087 Qfile_readable_p = intern ("file-readable-p");
3088 Qfile_symlink_p = intern ("file-symlink-p");
3089 Qfile_writable_p = intern ("file-writable-p");
3090 Qfile_directory_p = intern ("file-directory-p");
3091 Qfile_accessible_directory_p = intern ("file-accessible-directory-p");
3092 Qfile_modes = intern ("file-modes");
3093 Qset_file_modes = intern ("set-file-modes");
3094 Qfile_newer_than_file_p = intern ("file-newer-than-file-p");
3095 Qinsert_file_contents = intern ("insert-file-contents");
3096 Qwrite_region = intern ("write-region");
3097 Qverify_visited_file_modtime = intern ("verify-visited-file-modtime");
3098
3099 Qfile_name_history = intern ("file-name-history");
3100 Fset (Qfile_name_history, Qnil);
3101
3102 staticpro (&Qcopy_file);
3103 staticpro (&Qmake_directory);
3104 staticpro (&Qdelete_directory);
3105 staticpro (&Qdelete_file);
3106 staticpro (&Qrename_file);
3107 staticpro (&Qadd_name_to_file);
3108 staticpro (&Qmake_symbolic_link);
3109 staticpro (&Qfile_exists_p);
3110 staticpro (&Qfile_executable_p);
3111 staticpro (&Qfile_readable_p);
3112 staticpro (&Qfile_symlink_p);
3113 staticpro (&Qfile_writable_p);
3114 staticpro (&Qfile_directory_p);
3115 staticpro (&Qfile_accessible_directory_p);
3116 staticpro (&Qfile_modes);
3117 staticpro (&Qset_file_modes);
3118 staticpro (&Qfile_newer_than_file_p);
3119 staticpro (&Qinsert_file_contents);
3120 staticpro (&Qwrite_region);
3121 staticpro (&Qverify_visited_file_modtime);
3122 staticpro (&Qfile_name_history);
3123
3124 Qfile_error = intern ("file-error");
3125 staticpro (&Qfile_error);
3126 Qfile_already_exists = intern("file-already-exists");
3127 staticpro (&Qfile_already_exists);
3128
3129 Fput (Qfile_error, Qerror_conditions,
3130 Fcons (Qfile_error, Fcons (Qerror, Qnil)));
3131 Fput (Qfile_error, Qerror_message,
3132 build_string ("File error"));
3133
3134 Fput (Qfile_already_exists, Qerror_conditions,
3135 Fcons (Qfile_already_exists,
3136 Fcons (Qfile_error, Fcons (Qerror, Qnil))));
3137 Fput (Qfile_already_exists, Qerror_message,
3138 build_string ("File already exists"));
3139
3140 DEFVAR_BOOL ("insert-default-directory", &insert_default_directory,
3141 "*Non-nil means when reading a filename start with default dir in minibuffer.");
3142 insert_default_directory = 1;
3143
3144 DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm,
3145 "*Non-nil means write new files with record format `stmlf'.\n\
3146 nil means use format `var'. This variable is meaningful only on VMS.");
3147 vms_stmlf_recfm = 0;
3148
3149 DEFVAR_LISP ("file-name-handler-alist", &Vfile_name_handler_alist,
3150 "*Alist of elements (REGEXP . HANDLER) for file names handled specially.\n\
3151 If a file name matches REGEXP, then all I/O on that file is done by calling\n\
3152 HANDLER.\n\
3153 \n\
3154 The first argument given to HANDLER is the name of the I/O primitive\n\
3155 to be handled; the remaining arguments are the arguments that were\n\
3156 passed to that primitive. For example, if you do\n\
3157 (file-exists-p FILENAME)\n\
3158 and FILENAME is handled by HANDLER, then HANDLER is called like this:\n\
3159 (funcall HANDLER FILENAME)");
3160 defsubr (&Sfile_name_directory);
3161 defsubr (&Sfile_name_nondirectory);
3162 defsubr (&Sfile_name_as_directory);
3163 defsubr (&Sdirectory_file_name);
3164 defsubr (&Smake_temp_name);
3165 defsubr (&Sexpand_file_name);
3166 defsubr (&Ssubstitute_in_file_name);
3167 defsubr (&Scopy_file);
3168 defsubr (&Smake_directory);
3169 defsubr (&Sdelete_directory);
3170 defsubr (&Sdelete_file);
3171 defsubr (&Srename_file);
3172 defsubr (&Sadd_name_to_file);
3173 #ifdef S_IFLNK
3174 defsubr (&Smake_symbolic_link);
3175 #endif /* S_IFLNK */
3176 #ifdef VMS
3177 defsubr (&Sdefine_logical_name);
3178 #endif /* VMS */
3179 #ifdef HPUX_NET
3180 defsubr (&Ssysnetunam);
3181 #endif /* HPUX_NET */
3182 defsubr (&Sfile_name_absolute_p);
3183 defsubr (&Sfile_exists_p);
3184 defsubr (&Sfile_executable_p);
3185 defsubr (&Sfile_readable_p);
3186 defsubr (&Sfile_writable_p);
3187 defsubr (&Sfile_symlink_p);
3188 defsubr (&Sfile_directory_p);
3189 defsubr (&Sfile_accessible_directory_p);
3190 defsubr (&Sfile_modes);
3191 defsubr (&Sset_file_modes);
3192 defsubr (&Sset_umask);
3193 defsubr (&Sumask);
3194 defsubr (&Sfile_newer_than_file_p);
3195 defsubr (&Sinsert_file_contents);
3196 defsubr (&Swrite_region);
3197 defsubr (&Sverify_visited_file_modtime);
3198 defsubr (&Sclear_visited_file_modtime);
3199 defsubr (&Sset_visited_file_modtime);
3200 defsubr (&Sdo_auto_save);
3201 defsubr (&Sset_buffer_auto_saved);
3202 defsubr (&Srecent_auto_save_p);
3203
3204 defsubr (&Sread_file_name_internal);
3205 defsubr (&Sread_file_name);
3206
3207 defsubr (&Sunix_sync);
3208 }