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