160165Shibler /* File IO for GNU Emacs.
260165Shibler Copyright (C) 1985, 1986, 1987, 1988, 1990 Free Software Foundation, Inc.
360165Shibler
460165Shibler This file is part of GNU Emacs.
560165Shibler
660165Shibler GNU Emacs is free software; you can redistribute it and/or modify
760165Shibler it under the terms of the GNU General Public License as published by
860165Shibler the Free Software Foundation; either version 1, or (at your option)
960165Shibler any later version.
1060165Shibler
1160165Shibler GNU Emacs is distributed in the hope that it will be useful,
1260165Shibler but WITHOUT ANY WARRANTY; without even the implied warranty of
1360165Shibler MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1460165Shibler GNU General Public License for more details.
1560165Shibler
1660165Shibler You should have received a copy of the GNU General Public License
1760165Shibler along with GNU Emacs; see the file COPYING. If not, write to
1860165Shibler the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
1960165Shibler
2060165Shibler
2160165Shibler #include <sys/types.h>
2260165Shibler #ifdef hpux
2360165Shibler /* needed by <pwd.h> */
2460165Shibler #include <stdio.h>
2560165Shibler #undef NULL
2660165Shibler #endif
2760165Shibler #include <sys/stat.h>
2860165Shibler #include <pwd.h>
2960165Shibler #include <ctype.h>
3060165Shibler #include <sys/dir.h>
3160165Shibler #include <errno.h>
3260165Shibler
3360165Shibler #ifndef VMS
3460165Shibler extern int errno;
3560165Shibler extern char *sys_errlist[];
3660165Shibler extern int sys_nerr;
3760165Shibler #endif
3860165Shibler
3960165Shibler #define err_str(a) ((a) < sys_nerr ? sys_errlist[a] : "unknown error")
4060165Shibler
4160165Shibler #ifdef APOLLO
4260165Shibler #include <sys/time.h>
4360165Shibler #endif
4460165Shibler
4560165Shibler #ifdef NULL
4660165Shibler #undef NULL
4760165Shibler #endif
4860165Shibler #include "config.h"
4960165Shibler #include "lisp.h"
5060165Shibler #include "buffer.h"
5160165Shibler #include "window.h"
5260165Shibler
5360165Shibler #ifdef VMS
5460165Shibler #include <perror.h>
5560165Shibler #include <file.h>
5660165Shibler #include <rmsdef.h>
5760165Shibler #include <fab.h>
5860165Shibler #include <nam.h>
5960165Shibler #endif
6060165Shibler
6160165Shibler #ifdef HAVE_TIMEVAL
6260165Shibler #ifdef HPUX
6360165Shibler #include <time.h>
6460165Shibler #else
6560165Shibler #include <sys/time.h>
6660165Shibler #endif
6760165Shibler #endif
6860165Shibler
6960165Shibler #ifdef HPUX
7060165Shibler #include <netio.h>
7160165Shibler #include <errnet.h>
7260165Shibler #endif
7360165Shibler
7460165Shibler #ifndef O_WRONLY
7560165Shibler #define O_WRONLY 1
7660165Shibler #endif
7760165Shibler
7860165Shibler #define min(a, b) ((a) < (b) ? (a) : (b))
7960165Shibler #define max(a, b) ((a) > (b) ? (a) : (b))
8060165Shibler
8160165Shibler /* Nonzero during writing of auto-save files */
8260165Shibler int auto_saving;
8360165Shibler
8460165Shibler /* Nonzero means, when reading a filename in the minibuffer,
8560165Shibler start out by inserting the default directory into the minibuffer. */
8660165Shibler int insert_default_directory;
8760165Shibler
8860165Shibler /* On VMS, nonzero means write new files with record format stmlf.
8960165Shibler Zero means use var format. */
9060165Shibler int vms_stmlf_recfm;
9160165Shibler
9260165Shibler Lisp_Object Qfile_error, Qfile_already_exists;
9360165Shibler
report_file_error(string,data)9460165Shibler report_file_error (string, data)
9560165Shibler char *string;
9660165Shibler Lisp_Object data;
9760165Shibler {
9860165Shibler Lisp_Object errstring;
9960165Shibler
10060165Shibler if (errno >= 0 && errno < sys_nerr)
10160165Shibler errstring = build_string (sys_errlist[errno]);
10260165Shibler else
10360165Shibler errstring = build_string ("undocumented error code");
10460165Shibler
10560165Shibler /* System error messages are capitalized. Downcase the initial. */
10660165Shibler XSTRING (errstring)->data[0] = DOWNCASE (XSTRING (errstring)->data[0]);
10760165Shibler
10860165Shibler while (1)
10960165Shibler Fsignal (Qfile_error,
11060165Shibler Fcons (build_string (string), Fcons (errstring, data)));
11160165Shibler }
11260165Shibler
11360165Shibler DEFUN ("file-name-directory", Ffile_name_directory, Sfile_name_directory,
11460165Shibler 1, 1, 0,
11560165Shibler "Return the directory component in file name NAME.\n\
11660165Shibler Return nil if NAME does not include a directory.\n\
11760165Shibler Otherwise returns a directory spec.\n\
11860165Shibler Given a Unix syntax file name, returns a string ending in slash;\n\
11960165Shibler on VMS, perhaps instead a string ending in :, ] or >.")
12060165Shibler (file)
12160165Shibler Lisp_Object file;
12260165Shibler {
12360165Shibler register unsigned char *beg;
12460165Shibler register unsigned char *p;
12560165Shibler
12660165Shibler CHECK_STRING (file, 0);
12760165Shibler
12860165Shibler beg = XSTRING (file)->data;
12960165Shibler p = beg + XSTRING (file)->size;
13060165Shibler
13160165Shibler while (p != beg && p[-1] != '/'
13260165Shibler #ifdef VMS
13360165Shibler && p[-1] != ':' && p[-1] != ']' && p[-1] != '>'
13460165Shibler #endif /* VMS */
13560165Shibler ) p--;
13660165Shibler
13760165Shibler if (p == beg)
13860165Shibler return Qnil;
13960165Shibler return make_string (beg, p - beg);
14060165Shibler }
14160165Shibler
14260165Shibler DEFUN ("file-name-nondirectory", Ffile_name_nondirectory, Sfile_name_nondirectory,
14360165Shibler 1, 1, 0,
14460165Shibler "Return file name NAME sans its directory.\n\
14560165Shibler For example, in a Unix-syntax file name,\n\
14660165Shibler this is everything after the last slash,\n\
14760165Shibler or the entire name if it contains no slash.")
14860165Shibler (file)
14960165Shibler Lisp_Object file;
15060165Shibler {
15160165Shibler register unsigned char *beg, *p, *end;
15260165Shibler
15360165Shibler CHECK_STRING (file, 0);
15460165Shibler
15560165Shibler beg = XSTRING (file)->data;
15660165Shibler end = p = beg + XSTRING (file)->size;
15760165Shibler
15860165Shibler while (p != beg && p[-1] != '/'
15960165Shibler #ifdef VMS
16060165Shibler && p[-1] != ':' && p[-1] != ']' && p[-1] != '>'
16160165Shibler #endif /* VMS */
16260165Shibler ) p--;
16360165Shibler
16460165Shibler return make_string (p, end - p);
16560165Shibler }
16660165Shibler
16760165Shibler char *
file_name_as_directory(out,in)16860165Shibler file_name_as_directory (out, in)
16960165Shibler char *out, *in;
17060165Shibler {
17160165Shibler int size = strlen (in) - 1;
17260165Shibler
17360165Shibler strcpy (out, in);
17460165Shibler
17560165Shibler #ifdef VMS
17660165Shibler /* Is it already a directory string? */
17760165Shibler if (in[size] == ':' || in[size] == ']' || in[size] == '>')
17860165Shibler return out;
17960165Shibler /* Is it a VMS directory file name? If so, hack VMS syntax. */
18060165Shibler else if (! index (in, '/')
18160165Shibler && ((size > 3 && ! strcmp (&in[size - 3], ".DIR"))
18260165Shibler || (size > 3 && ! strcmp (&in[size - 3], ".dir"))
18360165Shibler || (size > 5 && (! strncmp (&in[size - 5], ".DIR", 4)
18460165Shibler || ! strncmp (&in[size - 5], ".dir", 4))
18560165Shibler && (in[size - 1] == '.' || in[size - 1] == ';')
18660165Shibler && in[size] == '1')))
18760165Shibler {
18860165Shibler register char *p, *dot;
18960165Shibler char brack;
19060165Shibler
19160165Shibler /* x.dir -> [.x]
19260165Shibler dir:x.dir --> dir:[x]
19360165Shibler dir:[x]y.dir --> dir:[x.y] */
19460165Shibler p = in + size;
19560165Shibler while (p != in && *p != ':' && *p != '>' && *p != ']') p--;
19660165Shibler if (p != in)
19760165Shibler {
19860165Shibler strncpy (out, in, p - in);
19960165Shibler out[p - in] = '\0';
20060165Shibler if (*p == ':')
20160165Shibler {
20260165Shibler brack = ']';
20360165Shibler strcat (out, ":[");
20460165Shibler }
20560165Shibler else
20660165Shibler {
20760165Shibler brack = *p;
20860165Shibler strcat (out, ".");
20960165Shibler }
21060165Shibler p++;
21160165Shibler }
21260165Shibler else
21360165Shibler {
21460165Shibler brack = ']';
21560165Shibler strcpy (out, "[.");
21660165Shibler }
21760165Shibler if (dot = index (p, '.'))
21860165Shibler {
21960165Shibler /* blindly remove any extension */
22060165Shibler size = strlen (out) + (dot - p);
22160165Shibler strncat (out, p, dot - p);
22260165Shibler }
22360165Shibler else
22460165Shibler {
22560165Shibler strcat (out, p);
22660165Shibler size = strlen (out);
22760165Shibler }
22860165Shibler out[size++] = brack;
22960165Shibler out[size] = '\0';
23060165Shibler }
23160165Shibler #else /* not VMS */
23260165Shibler /* For Unix syntax, Append a slash if necessary */
23360165Shibler if (out[size] != '/')
23460165Shibler strcat (out, "/");
23560165Shibler #endif /* not VMS */
23660165Shibler return out;
23760165Shibler }
23860165Shibler
23960165Shibler DEFUN ("file-name-as-directory", Ffile_name_as_directory,
24060165Shibler Sfile_name_as_directory, 1, 1, 0,
24160165Shibler "Return a string representing file FILENAME interpreted as a directory.\n\
24260165Shibler This string can be used as the value of default-directory\n\
24360165Shibler or passed as second argument to expand-file-name.\n\
24460165Shibler For a Unix-syntax file name, just appends a slash.\n\
24560165Shibler On VMS, converts \"[X]FOO.DIR\" to \"[X.FOO]\", etc.")
24660165Shibler (file)
24760165Shibler Lisp_Object file;
24860165Shibler {
24960165Shibler char *buf;
25060165Shibler
25160165Shibler CHECK_STRING (file, 0);
25260165Shibler if (NULL (file))
25360165Shibler return Qnil;
25460165Shibler buf = (char *) alloca (XSTRING (file)->size + 10);
25560165Shibler return build_string (file_name_as_directory (buf, XSTRING (file)->data));
25660165Shibler }
25760165Shibler
25860165Shibler /*
25960165Shibler * Convert from directory name to filename.
26060165Shibler * On VMS:
26160165Shibler * xyzzy:[mukesh.emacs] => xyzzy:[mukesh]emacs.dir.1
26260165Shibler * xyzzy:[mukesh] => xyzzy:[000000]mukesh.dir.1
26360165Shibler * On UNIX, it's simple: just make sure there is a terminating /
26460165Shibler
26560165Shibler * Value is nonzero if the string output is different from the input.
26660165Shibler */
26760165Shibler
directory_file_name(src,dst)26860165Shibler directory_file_name (src, dst)
26960165Shibler char *src, *dst;
27060165Shibler {
27160165Shibler long slen;
27260165Shibler #ifdef VMS
27360165Shibler long rlen;
27460165Shibler char * ptr, * rptr;
27560165Shibler char bracket;
27660165Shibler struct FAB fab = cc$rms_fab;
27760165Shibler struct NAM nam = cc$rms_nam;
27860165Shibler char esa[NAM$C_MAXRSS];
27960165Shibler #endif /* VMS */
28060165Shibler
28160165Shibler slen = strlen (src) - 1;
28260165Shibler #ifdef VMS
28360165Shibler if (! index (src, '/')
28460165Shibler && (src[slen] == ']' || src[slen] == ':' || src[slen] == '>'))
28560165Shibler {
28660165Shibler /* VMS style - convert [x.y.z] to [x.y]z, [x] to [000000]x */
28760165Shibler fab.fab$l_fna = src;
28860165Shibler fab.fab$b_fns = slen + 1;
28960165Shibler fab.fab$l_nam = &nam;
29060165Shibler fab.fab$l_fop = FAB$M_NAM;
29160165Shibler
29260165Shibler nam.nam$l_esa = esa;
29360165Shibler nam.nam$b_ess = sizeof esa;
29460165Shibler nam.nam$b_nop |= NAM$M_SYNCHK;
29560165Shibler
29660165Shibler /* We call SYS$PARSE to handle such things as [--] for us. */
29760165Shibler if (SYS$PARSE(&fab, 0, 0) == RMS$_NORMAL)
29860165Shibler {
29960165Shibler slen = nam.nam$b_esl - 1;
30060165Shibler if (esa[slen] == ';' && esa[slen - 1] == '.')
30160165Shibler slen -= 2;
30260165Shibler esa[slen + 1] = '\0';
30360165Shibler src = esa;
30460165Shibler }
30560165Shibler if (src[slen] != ']' && src[slen] != '>')
30660165Shibler {
30760165Shibler /* what about when we have logical_name:???? */
30860165Shibler if (src[slen] == ':')
30960165Shibler { /* Xlate logical name and see what we get */
31060165Shibler ptr = strcpy (dst, src); /* upper case for getenv */
31160165Shibler while (*ptr)
31260165Shibler {
31360165Shibler if ('a' <= *ptr && *ptr <= 'z')
31460165Shibler *ptr -= 040;
31560165Shibler ptr++;
31660165Shibler }
31760165Shibler dst[slen] = 0; /* remove colon */
31860165Shibler if (!(src = egetenv (dst)))
31960165Shibler return 0;
32060165Shibler /* should we jump to the beginning of this procedure?
32160165Shibler Good points: allows us to use logical names that xlate
32260165Shibler to Unix names,
32360165Shibler Bad points: can be a problem if we just translated to a device
32460165Shibler name...
32560165Shibler For now, I'll punt and always expect VMS names, and hope for
32660165Shibler the best! */
32760165Shibler slen = strlen (src) - 1;
32860165Shibler if (src[slen] != ']' && src[slen] != '>')
32960165Shibler { /* no recursion here! */
33060165Shibler strcpy (dst, src);
33160165Shibler return 0;
33260165Shibler }
33360165Shibler }
33460165Shibler else
33560165Shibler { /* not a directory spec */
33660165Shibler strcpy (dst, src);
33760165Shibler return 0;
33860165Shibler }
33960165Shibler }
34060165Shibler bracket = src[slen];
34160165Shibler if (!(ptr = index (src, bracket - 2)))
34260165Shibler { /* no opening bracket */
34360165Shibler strcpy (dst, src);
34460165Shibler return 0;
34560165Shibler }
34660165Shibler if (!(rptr = rindex (src, '.')))
34760165Shibler rptr = ptr;
34860165Shibler slen = rptr - src;
34960165Shibler strncpy (dst, src, slen);
35060165Shibler dst[slen] = '\0';
35160165Shibler if (*rptr == '.')
35260165Shibler {
35360165Shibler dst[slen++] = bracket;
35460165Shibler dst[slen] = '\0';
35560165Shibler }
35660165Shibler else
35760165Shibler {
35860165Shibler /* If we have the top-level of a rooted directory (i.e. xx:[000000]),
35960165Shibler then translate the device and recurse. */
36060165Shibler if (dst[slen - 1] == ':'
36160165Shibler && dst[slen - 2] != ':' /* skip decnet nodes */
36260165Shibler && strcmp(src + slen, "[000000]") == 0)
36360165Shibler {
36460165Shibler dst[slen - 1] = '\0';
36560165Shibler if ((ptr = egetenv (dst))
36660165Shibler && (rlen = strlen (ptr) - 1) > 0
36760165Shibler && (ptr[rlen] == ']' || ptr[rlen] == '>')
36860165Shibler && ptr[rlen - 1] == '.')
36960165Shibler {
37060165Shibler ptr[rlen - 1] = ']';
37160165Shibler ptr[rlen] = '\0';
37260165Shibler return directory_file_name (ptr, dst);
37360165Shibler }
37460165Shibler else
37560165Shibler dst[slen - 1] = ':';
37660165Shibler }
37760165Shibler strcat (dst, "[000000]");
37860165Shibler slen += 8;
37960165Shibler }
38060165Shibler rptr++;
38160165Shibler rlen = strlen (rptr) - 1;
38260165Shibler strncat (dst, rptr, rlen);
38360165Shibler dst[slen + rlen] = '\0';
38460165Shibler strcat (dst, ".DIR.1");
38560165Shibler return 1;
38660165Shibler }
38760165Shibler #endif /* VMS */
38860165Shibler /* Process as Unix format: just remove any final slash.
38960165Shibler But leave "/" unchanged; do not change it to "". */
39060165Shibler strcpy (dst, src);
39160165Shibler if (dst[slen] == '/' && slen > 1)
39260165Shibler dst[slen] = 0;
39360165Shibler return 1;
39460165Shibler }
39560165Shibler
39660165Shibler DEFUN ("directory-file-name", Fdirectory_file_name, Sdirectory_file_name,
39760165Shibler 1, 1, 0,
39860165Shibler "Returns the file name of the directory named DIR.\n\
39960165Shibler This is the name of the file that holds the data for the directory DIR.\n\
40060165Shibler In Unix-syntax, this just removes the final slash.\n\
40160165Shibler On VMS, given a VMS-syntax directory name such as \"[X.Y]\",\n\
40260165Shibler returns a file name such as \"[X]Y.DIR.1\".")
40360165Shibler (directory)
40460165Shibler Lisp_Object directory;
40560165Shibler {
40660165Shibler char *buf;
40760165Shibler
40860165Shibler CHECK_STRING (directory, 0);
40960165Shibler
41060165Shibler if (NULL (directory))
41160165Shibler return Qnil;
41260165Shibler #ifdef VMS
41360165Shibler /* 20 extra chars is insufficient for VMS, since we might perform a
41460165Shibler logical name translation. an equivalence string can be up to 255
41560165Shibler chars long, so grab that much extra space... - sss */
41660165Shibler buf = (char *) alloca (XSTRING (directory)->size + 20 + 255);
41760165Shibler #else
41860165Shibler buf = (char *) alloca (XSTRING (directory)->size + 20);
41960165Shibler #endif
42060165Shibler directory_file_name (XSTRING (directory)->data, buf);
42160165Shibler return build_string (buf);
42260165Shibler }
42360165Shibler
42460165Shibler DEFUN ("make-temp-name", Fmake_temp_name, Smake_temp_name, 1, 1, 0,
42560165Shibler "Generate temporary name (string) starting with PREFIX (a string).")
42660165Shibler (prefix)
42760165Shibler Lisp_Object prefix;
42860165Shibler {
42960165Shibler Lisp_Object val;
43060165Shibler val = concat2 (prefix, build_string ("XXXXXX"));
43160165Shibler mktemp (XSTRING (val)->data);
43260165Shibler return val;
43360165Shibler }
43460165Shibler
43560165Shibler DEFUN ("expand-file-name", Fexpand_file_name, Sexpand_file_name, 1, 2, 0,
43660165Shibler "Convert FILENAME to absolute, and canonicalize it.\n\
43760165Shibler Second arg DEFAULT is directory to start with if FILENAME is relative\n\
43860165Shibler (does not start with slash); if DEFAULT is nil or missing,\n\
43960165Shibler the current buffer's value of default-directory is used.\n\
44060165Shibler Filenames containing . or .. as components are simplified;\n\
44160165Shibler initial ~ is expanded. See also the function substitute-in-file-name.")
44260165Shibler (name, defalt)
44360165Shibler Lisp_Object name, defalt;
44460165Shibler {
44560165Shibler unsigned char *nm;
44660165Shibler
44760165Shibler register unsigned char *newdir, *p, *o;
44860165Shibler int tlen;
44960165Shibler unsigned char *target;
45060165Shibler struct passwd *pw;
45160165Shibler int lose;
45260165Shibler #ifdef VMS
45360165Shibler unsigned char * colon = 0;
45460165Shibler unsigned char * close = 0;
45560165Shibler unsigned char * slash = 0;
45660165Shibler unsigned char * brack = 0;
45760165Shibler int lbrack = 0, rbrack = 0;
45860165Shibler int dots = 0;
45960165Shibler #endif /* VMS */
46060165Shibler
46160165Shibler CHECK_STRING (name, 0);
46260165Shibler
46360165Shibler #ifdef VMS
46460165Shibler /* Filenames on VMS are always upper case. */
46560165Shibler name = Fupcase (name);
46660165Shibler #endif
46760165Shibler
46860165Shibler nm = XSTRING (name)->data;
46960165Shibler
47060165Shibler /* If nm is absolute, flush ...// and detect /./ and /../.
47160165Shibler If no /./ or /../ we can return right away. */
47260165Shibler if (
47360165Shibler nm[0] == '/'
47460165Shibler #ifdef VMS
47560165Shibler || index (nm, ':')
47660165Shibler #endif /* VMS */
47760165Shibler )
47860165Shibler {
47960165Shibler p = nm;
48060165Shibler lose = 0;
48160165Shibler while (*p)
48260165Shibler {
48360165Shibler if (p[0] == '/' && p[1] == '/'
48460165Shibler #ifdef APOLLO
48560165Shibler /* // at start of filename is meaningful on Apollo system */
48660165Shibler && nm != p
48760165Shibler #endif /* APOLLO */
48860165Shibler )
48960165Shibler nm = p + 1;
49060165Shibler if (p[0] == '/' && p[1] == '~')
49160165Shibler nm = p + 1, lose = 1;
49260165Shibler if (p[0] == '/' && p[1] == '.'
49360165Shibler && (p[2] == '/' || p[2] == 0
49460165Shibler || (p[2] == '.' && (p[3] == '/' || p[3] == 0))))
49560165Shibler lose = 1;
49660165Shibler #ifdef VMS
49760165Shibler if (p[0] == '\\')
49860165Shibler lose = 1;
49960165Shibler if (p[0] == '/') {
50060165Shibler /* if dev:[dir]/, move nm to / */
50160165Shibler if (!slash && p > nm && (brack || colon)) {
50260165Shibler nm = (brack ? brack + 1 : colon + 1);
50360165Shibler lbrack = rbrack = 0;
50460165Shibler brack = 0;
50560165Shibler colon = 0;
50660165Shibler }
50760165Shibler slash = p;
50860165Shibler }
50960165Shibler if (p[0] == '-')
51060165Shibler #ifndef VMS4_4
51160165Shibler /* VMS pre V4.4,convert '-'s in filenames. */
51260165Shibler if (lbrack == rbrack)
51360165Shibler {
51460165Shibler if (dots < 2) /* this is to allow negative version numbers */
51560165Shibler p[0] = '_';
51660165Shibler }
51760165Shibler else
51860165Shibler #endif /* VMS4_4 */
51960165Shibler if (lbrack > rbrack &&
52060165Shibler ((p[-1] == '.' || p[-1] == '[' || p[-1] == '<') &&
52160165Shibler (p[1] == '.' || p[1] == ']' || p[1] == '>')))
52260165Shibler lose = 1;
52360165Shibler #ifndef VMS4_4
52460165Shibler else
52560165Shibler p[0] = '_';
52660165Shibler #endif /* VMS4_4 */
52760165Shibler /* count open brackets, reset close bracket pointer */
52860165Shibler if (p[0] == '[' || p[0] == '<')
52960165Shibler lbrack++, brack = 0;
53060165Shibler /* count close brackets, set close bracket pointer */
53160165Shibler if (p[0] == ']' || p[0] == '>')
53260165Shibler rbrack++, brack = p;
53360165Shibler /* detect ][ or >< */
53460165Shibler if ((p[0] == ']' || p[0] == '>') && (p[1] == '[' || p[1] == '<'))
53560165Shibler lose = 1;
53660165Shibler if ((p[0] == ':' || p[0] == ']' || p[0] == '>') && p[1] == '~')
53760165Shibler nm = p + 1, lose = 1;
53860165Shibler if (p[0] == ':' && (colon || slash))
53960165Shibler /* if dev1:[dir]dev2:, move nm to dev2: */
54060165Shibler if (brack)
54160165Shibler {
54260165Shibler nm = brack + 1;
54360165Shibler brack = 0;
54460165Shibler }
54560165Shibler /* if /pathname/dev:, move nm to dev: */
54660165Shibler else if (slash)
54760165Shibler nm = slash + 1;
54860165Shibler /* if node::dev:, move colon following dev */
54960165Shibler else if (colon && colon[-1] == ':')
55060165Shibler colon = p;
55160165Shibler /* if dev1:dev2:, move nm to dev2: */
55260165Shibler else if (colon && colon[-1] != ':')
55360165Shibler {
55460165Shibler nm = colon + 1;
55560165Shibler colon = 0;
55660165Shibler }
55760165Shibler if (p[0] == ':' && !colon)
55860165Shibler {
55960165Shibler if (p[1] == ':')
56060165Shibler p++;
56160165Shibler colon = p;
56260165Shibler }
56360165Shibler if (lbrack == rbrack)
56460165Shibler if (p[0] == ';')
56560165Shibler dots = 2;
56660165Shibler else if (p[0] == '.')
56760165Shibler dots++;
56860165Shibler #endif /* VMS */
56960165Shibler p++;
57060165Shibler }
57160165Shibler if (!lose)
57260165Shibler {
57360165Shibler #ifdef VMS
57460165Shibler if (index (nm, '/'))
57560165Shibler return build_string (sys_translate_unix (nm));
57660165Shibler #endif /* VMS */
57760165Shibler if (nm == XSTRING (name)->data)
57860165Shibler return name;
57960165Shibler return build_string (nm);
58060165Shibler }
58160165Shibler }
58260165Shibler
58360165Shibler /* Now determine directory to start with and put it in NEWDIR. */
58460165Shibler
58560165Shibler newdir = 0;
58660165Shibler
58760165Shibler if (nm[0] == '~')
58860165Shibler {
58960165Shibler if (nm[1] == '/'
59060165Shibler #ifdef VMS
59160165Shibler || nm[1] == ':'
59260165Shibler #endif /* VMS */
59360165Shibler || nm[1] == 0)
59460165Shibler {
59560165Shibler /* Handle ~ on its own. */
59660165Shibler newdir = (unsigned char *) egetenv ("HOME");
59760165Shibler }
59860165Shibler else
59960165Shibler {
60060165Shibler /* Handle ~ followed by user name. */
60160165Shibler unsigned char *user = nm + 1;
60260165Shibler /* Find end of name. */
60360165Shibler unsigned char *ptr = (unsigned char *) index (user, '/');
60460165Shibler int len = ptr ? ptr - user : strlen (user);
60560165Shibler #ifdef VMS
60660165Shibler unsigned char *ptr1 = index (user, ':');
60760165Shibler if (ptr1 != 0 && ptr1 - user < len)
60860165Shibler len = ptr1 - user;
60960165Shibler #endif /* VMS */
61060165Shibler /* Copy the user name into temp storage. */
61160165Shibler o = (unsigned char *) alloca (len + 1);
61260165Shibler bcopy ((char *) user, o, len);
61360165Shibler o[len] = 0;
61460165Shibler
61560165Shibler /* Look up the user name. */
61660165Shibler pw = (struct passwd *) getpwnam (o);
61760165Shibler if (!pw)
61860165Shibler error ("User \"%s\" is not known", o);
61960165Shibler newdir = (unsigned char *) pw->pw_dir;
62060165Shibler
62160165Shibler /* Discard the user name from NM. */
62260165Shibler nm += len;
62360165Shibler }
62460165Shibler
62560165Shibler /* Discard the ~ from NM. */
62660165Shibler nm++;
62760165Shibler #ifdef VMS
62860165Shibler if (*nm != 0)
62960165Shibler nm++; /* Don't leave the slash in nm. */
63060165Shibler #endif /* VMS */
63160165Shibler
63260165Shibler if (newdir == 0)
63360165Shibler newdir = (unsigned char *) "";
63460165Shibler }
63560165Shibler
63660165Shibler if (nm[0] != '/'
63760165Shibler #ifdef VMS
63860165Shibler && !index (nm, ':')
63960165Shibler #endif /* not VMS */
64060165Shibler && !newdir)
64160165Shibler {
64260165Shibler if (NULL (defalt))
64360165Shibler defalt = current_buffer->directory;
64460165Shibler CHECK_STRING (defalt, 1);
64560165Shibler newdir = XSTRING (defalt)->data;
64660165Shibler }
64760165Shibler
64860165Shibler /* Now concatenate the directory and name to new space in the stack frame */
64960165Shibler
65060165Shibler tlen = (newdir ? strlen (newdir) + 1 : 0) + strlen (nm) + 1;
65160165Shibler target = (unsigned char *) alloca (tlen);
65260165Shibler *target = 0;
65360165Shibler
65460165Shibler if (newdir)
65560165Shibler {
65660165Shibler #ifndef VMS
65760165Shibler if (nm[0] == 0 || nm[0] == '/')
65860165Shibler strcpy (target, newdir);
65960165Shibler else
66060165Shibler #endif
66160165Shibler file_name_as_directory (target, newdir);
66260165Shibler }
66360165Shibler
66460165Shibler strcat (target, nm);
66560165Shibler #ifdef VMS
66660165Shibler if (index (target, '/'))
66760165Shibler strcpy (target, sys_translate_unix (target));
66860165Shibler #endif /* VMS */
66960165Shibler
67060165Shibler /* Now canonicalize by removing /. and /foo/.. if they appear */
67160165Shibler
67260165Shibler p = target;
67360165Shibler o = target;
67460165Shibler
67560165Shibler while (*p)
67660165Shibler {
67760165Shibler #ifdef VMS
67860165Shibler if (*p != ']' && *p != '>' && *p != '-')
67960165Shibler {
68060165Shibler if (*p == '\\')
68160165Shibler p++;
68260165Shibler *o++ = *p++;
68360165Shibler }
68460165Shibler else if ((p[0] == ']' || p[0] == '>') && p[0] == p[1] + 2)
68560165Shibler /* brackets are offset from each other by 2 */
68660165Shibler {
68760165Shibler p += 2;
68860165Shibler if (*p != '.' && *p != '-' && o[-1] != '.')
68960165Shibler /* convert [foo][bar] to [bar] */
69060165Shibler while (o[-1] != '[' && o[-1] != '<')
69160165Shibler o--;
69260165Shibler else if (*p == '-' && *o != '.')
69360165Shibler *--p = '.';
69460165Shibler }
69560165Shibler else if (p[0] == '-' && o[-1] == '.' &&
69660165Shibler (p[1] == '.' || p[1] == ']' || p[1] == '>'))
69760165Shibler /* flush .foo.- ; leave - if stopped by '[' or '<' */
69860165Shibler {
69960165Shibler do
70060165Shibler o--;
70160165Shibler while (o[-1] != '.' && o[-1] != '[' && o[-1] != '<');
70260165Shibler if (p[1] == '.') /* foo.-.bar ==> bar*/
70360165Shibler p += 2;
70460165Shibler else if (o[-1] == '.') /* '.foo.-]' ==> ']' */
70560165Shibler p++, o--;
70660165Shibler /* else [foo.-] ==> [-] */
70760165Shibler }
70860165Shibler else
70960165Shibler {
71060165Shibler #ifndef VMS4_4
71160165Shibler if (*p == '-' &&
71260165Shibler o[-1] != '[' && o[-1] != '<' && o[-1] != '.' &&
71360165Shibler p[1] != ']' && p[1] != '>' && p[1] != '.')
71460165Shibler *p = '_';
71560165Shibler #endif /* VMS4_4 */
71660165Shibler *o++ = *p++;
71760165Shibler }
71860165Shibler #else /* not VMS */
71960165Shibler if (*p != '/')
72060165Shibler {
72160165Shibler *o++ = *p++;
72260165Shibler }
72360165Shibler else if (!strncmp (p, "//", 2)
72460165Shibler #ifdef APOLLO
72560165Shibler /* // at start of filename is meaningful in Apollo system */
72660165Shibler && o != target
72760165Shibler #endif /* APOLLO */
72860165Shibler )
72960165Shibler {
73060165Shibler o = target;
73160165Shibler p++;
73260165Shibler }
73360165Shibler else if (p[0] == '/' && p[1] == '.' &&
73460165Shibler (p[2] == '/' || p[2] == 0))
73560165Shibler p += 2;
73660165Shibler else if (!strncmp (p, "/..", 3)
73760165Shibler /* `/../' is the "superroot" on certain file systems. */
73860165Shibler && o != target
73960165Shibler && (p[3] == '/' || p[3] == 0))
74060165Shibler {
74160165Shibler while (o != target && *--o != '/')
74260165Shibler ;
74360165Shibler #ifdef APOLLO
74460165Shibler if (o == target + 1 && o[-1] == '/' && o[0] == '/')
74560165Shibler ++o;
74660165Shibler else
74760165Shibler #endif APOLLO
74860165Shibler if (o == target && *o == '/')
74960165Shibler ++o;
75060165Shibler p += 3;
75160165Shibler }
75260165Shibler else
75360165Shibler {
75460165Shibler *o++ = *p++;
75560165Shibler }
75660165Shibler #endif /* not VMS */
75760165Shibler }
75860165Shibler
75960165Shibler return make_string (target, o - target);
76060165Shibler }
76160165Shibler
76260165Shibler DEFUN ("substitute-in-file-name", Fsubstitute_in_file_name,
76360165Shibler Ssubstitute_in_file_name, 1, 1, 0,
76460165Shibler "Substitute environment variables referred to in STRING.\n\
76560165Shibler A $ begins a request to substitute; the env variable name is the alphanumeric\n\
76660165Shibler characters and underscores after the $, or is surrounded by braces.\n\
76760165Shibler If a ~ appears following a /, everything through that / is discarded.\n\
76860165Shibler On VMS, $ substitution is not done; this function does little and only\n\
76960165Shibler duplicates what expand-file-name does.")
77060165Shibler (string)
77160165Shibler Lisp_Object string;
77260165Shibler {
77360165Shibler unsigned char *nm;
77460165Shibler
77560165Shibler register unsigned char *s, *p, *o, *x, *endp;
77660165Shibler unsigned char *target;
77760165Shibler int total = 0;
77860165Shibler int substituted = 0;
77960165Shibler unsigned char *xnm;
78060165Shibler
78160165Shibler CHECK_STRING (string, 0);
78260165Shibler
78360165Shibler nm = XSTRING (string)->data;
78460165Shibler endp = nm + XSTRING (string)->size;
78560165Shibler
78660165Shibler /* If /~ or // appears, discard everything through first slash. */
78760165Shibler
78860165Shibler for (p = nm; p != endp; p++)
78960165Shibler {
79060165Shibler if ((p[0] == '~' ||
79160165Shibler #ifdef APOLLO
79260165Shibler /* // at start of file name is meaningful in Apollo system */
79360165Shibler (p[0] == '/' && p - 1 != nm)
79460165Shibler #else /* not APOLLO */
79560165Shibler p[0] == '/'
79660165Shibler #endif /* not APOLLO */
79760165Shibler )
79860165Shibler && p != nm &&
79960165Shibler #ifdef VMS
80060165Shibler (p[-1] == ':' || p[-1] == ']' || p[-1] == '>' ||
80160165Shibler #endif /* VMS */
80260165Shibler p[-1] == '/')
80360165Shibler #ifdef VMS
80460165Shibler )
80560165Shibler #endif /* VMS */
80660165Shibler {
80760165Shibler nm = p;
80860165Shibler substituted = 1;
80960165Shibler }
81060165Shibler }
81160165Shibler
81260165Shibler #ifdef VMS
81360165Shibler return build_string (nm);
81460165Shibler #else
81560165Shibler
81660165Shibler /* See if any variables are substituted into the string
81760165Shibler and find the total length of their values in `total' */
81860165Shibler
81960165Shibler for (p = nm; p != endp;)
82060165Shibler if (*p != '$')
82160165Shibler p++;
82260165Shibler else
82360165Shibler {
82460165Shibler p++;
82560165Shibler if (p == endp)
82660165Shibler goto badsubst;
82760165Shibler else if (*p == '$')
82860165Shibler {
82960165Shibler /* "$$" means a single "$" */
83060165Shibler p++;
83160165Shibler total -= 1;
83260165Shibler substituted = 1;
83360165Shibler continue;
83460165Shibler }
83560165Shibler else if (*p == '{')
83660165Shibler {
83760165Shibler o = ++p;
83860165Shibler while (p != endp && *p != '}') p++;
83960165Shibler if (*p != '}') goto missingclose;
84060165Shibler s = p;
84160165Shibler }
84260165Shibler else
84360165Shibler {
84460165Shibler o = p;
84560165Shibler while (p != endp && (isalnum (*p) || *p == '_')) p++;
84660165Shibler s = p;
84760165Shibler }
84860165Shibler
84960165Shibler /* Copy out the variable name */
85060165Shibler target = (unsigned char *) alloca (s - o + 1);
85160165Shibler strncpy (target, o, s - o);
85260165Shibler target[s - o] = 0;
85360165Shibler
85460165Shibler /* Get variable value */
85560165Shibler o = (unsigned char *) egetenv (target);
85660165Shibler /* The presence of this code makes vax 5.0 crash, for reasons yet unknown */
85760165Shibler #if 0
85860165Shibler #ifdef USG
85960165Shibler if (!o && !strcmp (target, "USER"))
86060165Shibler o = egetenv ("LOGNAME");
86160165Shibler #endif /* USG */
86260165Shibler #endif /* 0 */
86360165Shibler if (!o) goto badvar;
86460165Shibler total += strlen (o);
86560165Shibler substituted = 1;
86660165Shibler }
86760165Shibler
86860165Shibler if (!substituted)
86960165Shibler return string;
87060165Shibler
87160165Shibler /* If substitution required, recopy the string and do it */
87260165Shibler /* Make space in stack frame for the new copy */
87360165Shibler xnm = (unsigned char *) alloca (XSTRING (string)->size + total + 1);
87460165Shibler x = xnm;
87560165Shibler
87660165Shibler /* Copy the rest of the name through, replacing $ constructs with values */
87760165Shibler for (p = nm; *p;)
87860165Shibler if (*p != '$')
87960165Shibler *x++ = *p++;
88060165Shibler else
88160165Shibler {
88260165Shibler p++;
88360165Shibler if (p == endp)
88460165Shibler goto badsubst;
88560165Shibler else if (*p == '$')
88660165Shibler {
88760165Shibler *x++ = *p++;
88860165Shibler continue;
88960165Shibler }
89060165Shibler else if (*p == '{')
89160165Shibler {
89260165Shibler o = ++p;
89360165Shibler while (p != endp && *p != '}') p++;
89460165Shibler if (*p != '}') goto missingclose;
89560165Shibler s = p++;
89660165Shibler }
89760165Shibler else
89860165Shibler {
89960165Shibler o = p;
90060165Shibler while (p != endp && (isalnum (*p) || *p == '_')) p++;
90160165Shibler s = p;
90260165Shibler }
90360165Shibler
90460165Shibler /* Copy out the variable name */
90560165Shibler target = (unsigned char *) alloca (s - o + 1);
90660165Shibler strncpy (target, o, s - o);
90760165Shibler target[s - o] = 0;
90860165Shibler
90960165Shibler /* Get variable value */
91060165Shibler o = (unsigned char *) egetenv (target);
91160165Shibler /* The presence of this code makes vax 5.0 crash, for reasons yet unknown */
91260165Shibler #if 0
91360165Shibler #ifdef USG
91460165Shibler if (!o && !strcmp (target, "USER"))
91560165Shibler o = egetenv ("LOGNAME");
91660165Shibler #endif /* USG */
91760165Shibler #endif /* 0 */
91860165Shibler if (!o)
91960165Shibler goto badvar;
92060165Shibler
92160165Shibler strcpy (x, o);
92260165Shibler x += strlen (o);
92360165Shibler }
92460165Shibler
92560165Shibler *x = 0;
92660165Shibler
92760165Shibler /* If /~ or // appears, discard everything through first slash. */
92860165Shibler
92960165Shibler for (p = xnm; p != x; p++)
93060165Shibler if ((p[0] == '~' ||
93160165Shibler #ifdef APOLLO
93260165Shibler /* // at start of file name is meaningful in Apollo system */
93360165Shibler (p[0] == '/' && p - 1 != xnm)
93460165Shibler #else /* not APOLLO */
93560165Shibler p[0] == '/'
93660165Shibler #endif /* not APOLLO */
93760165Shibler )
93860165Shibler && p != nm && p[-1] == '/')
93960165Shibler xnm = p;
94060165Shibler
94160165Shibler return make_string (xnm, x - xnm);
94260165Shibler
94360165Shibler badsubst:
94460165Shibler error ("Bad format environment-variable substitution");
94560165Shibler missingclose:
94660165Shibler error ("Missing \"}\" in environment-variable substitution");
94760165Shibler badvar:
94860165Shibler error ("Substituting nonexistent environment variable \"%s\"", target);
94960165Shibler
95060165Shibler /* NOTREACHED */
95160165Shibler #endif /* not VMS */
95260165Shibler }
95360165Shibler
95460165Shibler Lisp_Object
expand_and_dir_to_file(filename,defdir)95560165Shibler expand_and_dir_to_file (filename, defdir)
95660165Shibler Lisp_Object filename, defdir;
95760165Shibler {
95860165Shibler register Lisp_Object abspath;
95960165Shibler
96060165Shibler abspath = Fexpand_file_name (filename, defdir);
96160165Shibler #ifdef VMS
96260165Shibler {
96360165Shibler register int c = XSTRING (abspath)->data[XSTRING (abspath)->size - 1];
96460165Shibler if (c == ':' || c == ']' || c == '>')
96560165Shibler abspath = Fdirectory_file_name (abspath);
96660165Shibler }
96760165Shibler #else
96860165Shibler /* Remove final slash, if any (unless path is root).
96960165Shibler stat behaves differently depending! */
97060165Shibler if (XSTRING (abspath)->size > 1
97160165Shibler && XSTRING (abspath)->data[XSTRING (abspath)->size - 1] == '/')
97260165Shibler {
97360165Shibler if (EQ (abspath, filename))
97460165Shibler abspath = Fcopy_sequence (abspath);
97560165Shibler XSTRING (abspath)->data[XSTRING (abspath)->size - 1] = 0;
97660165Shibler }
97760165Shibler #endif
97860165Shibler return abspath;
97960165Shibler }
98060165Shibler
barf_or_query_if_file_exists(absname,querystring,interactive)98160165Shibler barf_or_query_if_file_exists (absname, querystring, interactive)
98260165Shibler Lisp_Object absname;
98360165Shibler unsigned char *querystring;
98460165Shibler int interactive;
98560165Shibler {
98660165Shibler register Lisp_Object tem;
98760165Shibler struct gcpro gcpro1;
98860165Shibler
98960165Shibler if (access (XSTRING (absname)->data, 4) >= 0)
99060165Shibler {
99160165Shibler if (! interactive)
99260165Shibler Fsignal (Qfile_already_exists,
99360165Shibler Fcons (build_string ("File already exists"),
99460165Shibler Fcons (absname, Qnil)));
99560165Shibler GCPRO1 (absname);
99660165Shibler tem = Fyes_or_no_p (format1 ("File %s already exists; %s anyway? ",
99760165Shibler XSTRING (absname)->data, querystring));
99860165Shibler UNGCPRO;
99960165Shibler if (NULL (tem))
100060165Shibler Fsignal (Qfile_already_exists,
100160165Shibler Fcons (build_string ("File already exists"),
100260165Shibler Fcons (absname, Qnil)));
100360165Shibler }
100460165Shibler return;
100560165Shibler }
100660165Shibler
100760165Shibler DEFUN ("copy-file", Fcopy_file, Scopy_file, 2, 4,
100860165Shibler "fCopy file: \nFCopy %s to file: \np",
100960165Shibler "Copy FILE to NEWNAME. Both args strings.\n\
101060165Shibler Signals a file-already-exists error if NEWNAME already exists,\n\
101160165Shibler unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.\n\
101260165Shibler A number as third arg means request confirmation if NEWNAME already exists.\n\
101360165Shibler This is what happens in interactive use with M-x.\n\
101460165Shibler Fourth arg non-nil means give the new file the same last-modified time\n\
101560165Shibler that the old one has. (This works on only some systems.)")
101660165Shibler (filename, newname, ok_if_already_exists, keep_date)
101760165Shibler Lisp_Object filename, newname, ok_if_already_exists, keep_date;
101860165Shibler {
101960165Shibler int ifd, ofd, n;
102060165Shibler char buf[16 * 1024];
102160165Shibler struct stat st;
102260165Shibler struct gcpro gcpro1, gcpro2;
102360165Shibler
102460165Shibler GCPRO2 (filename, newname);
102560165Shibler CHECK_STRING (filename, 0);
102660165Shibler CHECK_STRING (newname, 1);
102760165Shibler filename = Fexpand_file_name (filename, Qnil);
102860165Shibler newname = Fexpand_file_name (newname, Qnil);
102960165Shibler if (NULL (ok_if_already_exists)
103060165Shibler || XTYPE (ok_if_already_exists) == Lisp_Int)
103160165Shibler barf_or_query_if_file_exists (newname, "copy to it",
103260165Shibler XTYPE (ok_if_already_exists) == Lisp_Int);
103360165Shibler
103460165Shibler ifd = open (XSTRING (filename)->data, 0);
103560165Shibler if (ifd < 0)
103660165Shibler report_file_error ("Opening input file", Fcons (filename, Qnil));
103760165Shibler
103860165Shibler #ifdef VMS
103960165Shibler /* Create the copy file with the same record format as the input file */
104060165Shibler ofd = sys_creat (XSTRING (newname)->data, 0666, ifd);
104160165Shibler #else
104260165Shibler ofd = creat (XSTRING (newname)->data, 0666);
104360165Shibler #endif /* VMS */
104460165Shibler if (ofd < 0)
104560165Shibler {
104660165Shibler close (ifd);
104760165Shibler report_file_error ("Opening output file", Fcons (newname, Qnil));
104860165Shibler }
104960165Shibler
105060165Shibler while ((n = read (ifd, buf, sizeof buf)) > 0)
105160165Shibler if (write (ofd, buf, n) != n)
105260165Shibler {
105360165Shibler close (ifd);
105460165Shibler close (ofd);
105560165Shibler report_file_error ("I/O error", Fcons (newname, Qnil));
105660165Shibler }
105760165Shibler
105860165Shibler if (fstat (ifd, &st) >= 0)
105960165Shibler {
106060165Shibler #ifdef HAVE_TIMEVAL
106160165Shibler if (!NULL (keep_date))
106260165Shibler {
106360165Shibler #ifdef USE_UTIME
106460165Shibler /* AIX has utimes() in compatibility package, but it dies. So use good old
106560165Shibler utime interface instead. */
106660165Shibler struct {
106760165Shibler time_t atime;
106860165Shibler time_t mtime;
106960165Shibler } tv;
107060165Shibler tv.atime = st.st_atime;
107160165Shibler tv.mtime = st.st_mtime;
107260165Shibler utime (XSTRING (newname)->data, &tv);
107360165Shibler #else /* not USE_UTIME */
107460165Shibler struct timeval timevals[2];
107560165Shibler timevals[0].tv_sec = st.st_atime;
107660165Shibler timevals[1].tv_sec = st.st_mtime;
107760165Shibler timevals[0].tv_usec = timevals[1].tv_usec = 0;
107860165Shibler utimes (XSTRING (newname)->data, timevals);
107960165Shibler #endif /* not USE_UTIME */
108060165Shibler }
108160165Shibler #endif /* HAVE_TIMEVALS */
108260165Shibler
108360165Shibler #ifdef APOLLO
108460165Shibler if (!egetenv ("USE_DOMAIN_ACLS"))
108560165Shibler #endif
108660165Shibler chmod (XSTRING (newname)->data, st.st_mode & 07777);
108760165Shibler }
108860165Shibler
108960165Shibler close (ifd);
109060165Shibler if (close (ofd) < 0)
109160165Shibler report_file_error ("I/O error", Fcons (newname, Qnil));
109260165Shibler
109360165Shibler UNGCPRO;
109460165Shibler return Qnil;
109560165Shibler }
109660165Shibler
109760165Shibler DEFUN ("delete-file", Fdelete_file, Sdelete_file, 1, 1, "fDelete file: ",
109860165Shibler "Delete specified file. One argument, a file name string.\n\
109960165Shibler If file has multiple names, it continues to exist with the other names.")
110060165Shibler (filename)
110160165Shibler Lisp_Object filename;
110260165Shibler {
110360165Shibler CHECK_STRING (filename, 0);
110460165Shibler filename = Fexpand_file_name (filename, Qnil);
110560165Shibler if (0 > unlink (XSTRING (filename)->data))
110660165Shibler report_file_error ("Removing old name", Flist (1, &filename));
110760165Shibler return Qnil;
110860165Shibler }
110960165Shibler
111060165Shibler DEFUN ("rename-file", Frename_file, Srename_file, 2, 3,
111160165Shibler "fRename file: \nFRename %s to file: \np",
111260165Shibler "Rename FILE as NEWNAME. Both args strings.\n\
111360165Shibler If file has names other than FILE, it continues to have those names.\n\
111460165Shibler Signals a file-already-exists error if NEWNAME already exists\n\
111560165Shibler unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
111660165Shibler A number as third arg means request confirmation if NEWNAME already exists.\n\
111760165Shibler This is what happens in interactive use with M-x.")
111860165Shibler (filename, newname, ok_if_already_exists)
111960165Shibler Lisp_Object filename, newname, ok_if_already_exists;
112060165Shibler {
112160165Shibler #ifdef NO_ARG_ARRAY
112260165Shibler Lisp_Object args[2];
112360165Shibler #endif
112460165Shibler struct gcpro gcpro1, gcpro2;
112560165Shibler
112660165Shibler GCPRO2 (filename, newname);
112760165Shibler CHECK_STRING (filename, 0);
112860165Shibler CHECK_STRING (newname, 1);
112960165Shibler filename = Fexpand_file_name (filename, Qnil);
113060165Shibler newname = Fexpand_file_name (newname, Qnil);
113160165Shibler if (NULL (ok_if_already_exists)
113260165Shibler || XTYPE (ok_if_already_exists) == Lisp_Int)
113360165Shibler barf_or_query_if_file_exists (newname, "rename to it",
113460165Shibler XTYPE (ok_if_already_exists) == Lisp_Int);
113560165Shibler #ifndef BSD4_1
113660165Shibler if (0 > rename (XSTRING (filename)->data, XSTRING (newname)->data))
113760165Shibler #else
113860165Shibler if (0 > link (XSTRING (filename)->data, XSTRING (newname)->data)
113960165Shibler || 0 > unlink (XSTRING (filename)->data))
114060165Shibler #endif
114160165Shibler {
114260165Shibler if (errno == EXDEV)
114360165Shibler {
114460165Shibler Fcopy_file (filename, newname, ok_if_already_exists, Qt);
114560165Shibler Fdelete_file (filename);
114660165Shibler }
114760165Shibler else
114860165Shibler #ifdef NO_ARG_ARRAY
114960165Shibler {
115060165Shibler args[0] = filename;
115160165Shibler args[1] = newname;
115260165Shibler report_file_error ("Renaming", Flist (2, args));
115360165Shibler }
115460165Shibler #else
115560165Shibler report_file_error ("Renaming", Flist (2, &filename));
115660165Shibler #endif
115760165Shibler }
115860165Shibler UNGCPRO;
115960165Shibler return Qnil;
116060165Shibler }
116160165Shibler
116260165Shibler DEFUN ("add-name-to-file", Fadd_name_to_file, Sadd_name_to_file, 2, 3,
116360165Shibler "fAdd name to file: \nFName to add to %s: \np",
116460165Shibler "Give FILE additional name NEWNAME. Both args strings.\n\
116560165Shibler Signals a file-already-exists error if NEWNAME already exists\n\
116660165Shibler unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
116760165Shibler A number as third arg means request confirmation if NEWNAME already exists.\n\
116860165Shibler This is what happens in interactive use with M-x.")
116960165Shibler (filename, newname, ok_if_already_exists)
117060165Shibler Lisp_Object filename, newname, ok_if_already_exists;
117160165Shibler {
117260165Shibler #ifdef NO_ARG_ARRAY
117360165Shibler Lisp_Object args[2];
117460165Shibler #endif
117560165Shibler struct gcpro gcpro1, gcpro2;
117660165Shibler
117760165Shibler GCPRO2 (filename, newname);
117860165Shibler CHECK_STRING (filename, 0);
117960165Shibler CHECK_STRING (newname, 1);
118060165Shibler filename = Fexpand_file_name (filename, Qnil);
118160165Shibler newname = Fexpand_file_name (newname, Qnil);
118260165Shibler if (NULL (ok_if_already_exists)
118360165Shibler || XTYPE (ok_if_already_exists) == Lisp_Int)
118460165Shibler barf_or_query_if_file_exists (newname, "make it a new name",
118560165Shibler XTYPE (ok_if_already_exists) == Lisp_Int);
118660165Shibler unlink (XSTRING (newname)->data);
118760165Shibler if (0 > link (XSTRING (filename)->data, XSTRING (newname)->data))
118860165Shibler {
118960165Shibler #ifdef NO_ARG_ARRAY
119060165Shibler args[0] = filename;
119160165Shibler args[1] = newname;
119260165Shibler report_file_error ("Adding new name", Flist (2, args));
119360165Shibler #else
119460165Shibler report_file_error ("Adding new name", Flist (2, &filename));
119560165Shibler #endif
119660165Shibler }
119760165Shibler
119860165Shibler UNGCPRO;
119960165Shibler return Qnil;
120060165Shibler }
120160165Shibler
120260165Shibler #ifdef S_IFLNK
120360165Shibler DEFUN ("make-symbolic-link", Fmake_symbolic_link, Smake_symbolic_link, 2, 3,
120460165Shibler "FMake symbolic link to file: \nFMake symbolic link to file %s: \np",
120560165Shibler "Make a symbolic link to FILENAME, named LINKNAME. Both args strings.\n\
120660165Shibler Signals a file-already-exists error if NEWNAME already exists\n\
120760165Shibler unless optional third argument OK-IF-ALREADY-EXISTS is non-nil.\n\
120860165Shibler A number as third arg means request confirmation if NEWNAME already exists.\n\
120960165Shibler This happens for interactive use with M-x.")
121060165Shibler (filename, newname, ok_if_already_exists)
121160165Shibler Lisp_Object filename, newname, ok_if_already_exists;
121260165Shibler {
121360165Shibler #ifdef NO_ARG_ARRAY
121460165Shibler Lisp_Object args[2];
121560165Shibler #endif
121660165Shibler struct gcpro gcpro1, gcpro2;
121760165Shibler
121860165Shibler GCPRO2 (filename, newname);
121960165Shibler CHECK_STRING (filename, 0);
122060165Shibler CHECK_STRING (newname, 1);
122160165Shibler filename = Fexpand_file_name (filename, Qnil);
122260165Shibler newname = Fexpand_file_name (newname, Qnil);
122360165Shibler if (NULL (ok_if_already_exists)
122460165Shibler || XTYPE (ok_if_already_exists) == Lisp_Int)
122560165Shibler barf_or_query_if_file_exists (newname, "make it a link",
122660165Shibler XTYPE (ok_if_already_exists) == Lisp_Int);
122760165Shibler if (0 > symlink (XSTRING (filename)->data, XSTRING (newname)->data))
122860165Shibler {
122960165Shibler #ifdef NO_ARG_ARRAY
123060165Shibler args[0] = filename;
123160165Shibler args[1] = newname;
123260165Shibler report_file_error ("Making symbolic link", Flist (2, args));
123360165Shibler #else
123460165Shibler report_file_error ("Making symbolic link", Flist (2, &filename));
123560165Shibler #endif
123660165Shibler }
123760165Shibler UNGCPRO;
123860165Shibler return Qnil;
123960165Shibler }
124060165Shibler #endif /* S_IFLNK */
124160165Shibler
124260165Shibler #ifdef VMS
124360165Shibler
124460165Shibler DEFUN ("define-logical-name", Fdefine_logical_name, Sdefine_logical_name,
124560165Shibler 2, 2,
124660165Shibler "sDefine logical name: \nsDefine logical name %s as: ",
124760165Shibler "Define the job-wide logical name NAME to have the value STRING.\n\
124860165Shibler If STRING is nil or a null string, the logical name NAME is deleted.")
124960165Shibler (varname, string)
125060165Shibler Lisp_Object varname;
125160165Shibler Lisp_Object string;
125260165Shibler {
125360165Shibler CHECK_STRING (varname, 0);
125460165Shibler if (NULL (string))
125560165Shibler delete_logical_name (XSTRING (varname)->data);
125660165Shibler else
125760165Shibler {
125860165Shibler CHECK_STRING (string, 1);
125960165Shibler
126060165Shibler if (XSTRING (string)->size == 0)
126160165Shibler delete_logical_name (XSTRING (varname)->data);
126260165Shibler else
126360165Shibler define_logical_name (XSTRING (varname)->data, XSTRING (string)->data);
126460165Shibler }
126560165Shibler
126660165Shibler return string;
126760165Shibler }
126860165Shibler #endif /* VMS */
126960165Shibler
127060165Shibler #ifdef HPUX_NET
127160165Shibler
127260165Shibler DEFUN ("sysnetunam", Fsysnetunam, Ssysnetunam, 2, 2, 0,
127360165Shibler "Open a network connection to PATH using LOGIN as the login string.")
127460165Shibler (path, login)
127560165Shibler Lisp_Object path, login;
127660165Shibler {
127760165Shibler int netresult;
127860165Shibler
127960165Shibler CHECK_STRING (path, 0);
128060165Shibler CHECK_STRING (login, 0);
128160165Shibler
128260165Shibler netresult = netunam (XSTRING (path)->data, XSTRING (login)->data);
128360165Shibler
128460165Shibler if (netresult == -1)
128560165Shibler return Qnil;
128660165Shibler else
128760165Shibler return Qt;
128860165Shibler }
128960165Shibler #endif /* HPUX_NET */
129060165Shibler
129160165Shibler DEFUN ("file-name-absolute-p", Ffile_name_absolute_p, Sfile_name_absolute_p,
129260165Shibler 1, 1, 0,
129360165Shibler "Return t if file FILENAME specifies an absolute path name.")
129460165Shibler (filename)
129560165Shibler Lisp_Object filename;
129660165Shibler {
129760165Shibler unsigned char *ptr;
129860165Shibler
129960165Shibler CHECK_STRING (filename, 0);
130060165Shibler ptr = XSTRING (filename)->data;
130160165Shibler if (*ptr == '/' || *ptr == '~'
130260165Shibler #ifdef VMS
130360165Shibler /* ??? This criterion is probably wrong for '<'. */
130460165Shibler || index (ptr, ':') || index (ptr, '<')
130560165Shibler || (*ptr == '[' && (ptr[1] != '-' || (ptr[2] != '.' && ptr[2] != ']'))
130660165Shibler && ptr[1] != '.')
130760165Shibler #endif /* VMS */
130860165Shibler )
130960165Shibler return Qt;
131060165Shibler else
131160165Shibler return Qnil;
131260165Shibler }
131360165Shibler
131460165Shibler DEFUN ("file-exists-p", Ffile_exists_p, Sfile_exists_p, 1, 1, 0,
131560165Shibler "Return t if file FILENAME exists. (This does not mean you can read it.)\n\
131660165Shibler See also file-readable-p and file-attributes.")
131760165Shibler (filename)
131860165Shibler Lisp_Object filename;
131960165Shibler {
132060165Shibler Lisp_Object abspath;
132160165Shibler
132260165Shibler CHECK_STRING (filename, 0);
132360165Shibler abspath = Fexpand_file_name (filename, Qnil);
132460165Shibler return (access (XSTRING (abspath)->data, 0) >= 0) ? Qt : Qnil;
132560165Shibler }
132660165Shibler
132760165Shibler DEFUN ("file-readable-p", Ffile_readable_p, Sfile_readable_p, 1, 1, 0,
132860165Shibler "Return t if file FILENAME exists and you can read it.\n\
132960165Shibler See also file-exists-p and file-attributes.")
133060165Shibler (filename)
133160165Shibler Lisp_Object filename;
133260165Shibler {
133360165Shibler Lisp_Object abspath;
133460165Shibler
133560165Shibler CHECK_STRING (filename, 0);
133660165Shibler abspath = Fexpand_file_name (filename, Qnil);
133760165Shibler return (access (XSTRING (abspath)->data, 4) >= 0) ? Qt : Qnil;
133860165Shibler }
133960165Shibler
134060165Shibler DEFUN ("file-symlink-p", Ffile_symlink_p, Sfile_symlink_p, 1, 1, 0,
134160165Shibler "If file FILENAME is the name of a symbolic link\n\
134260165Shibler returns the name of the file to which it is linked.\n\
134360165Shibler Otherwise returns NIL.")
134460165Shibler (filename)
134560165Shibler Lisp_Object filename;
134660165Shibler {
134760165Shibler #ifdef S_IFLNK
134860165Shibler char *buf;
134960165Shibler int bufsize;
135060165Shibler int valsize;
135160165Shibler Lisp_Object val;
135260165Shibler
135360165Shibler CHECK_STRING (filename, 0);
135460165Shibler filename = Fexpand_file_name (filename, Qnil);
135560165Shibler
135660165Shibler bufsize = 100;
135760165Shibler while (1)
135860165Shibler {
135960165Shibler buf = (char *) xmalloc (bufsize);
136060165Shibler bzero (buf, bufsize);
136160165Shibler valsize = readlink (XSTRING (filename)->data, buf, bufsize);
136260165Shibler if (valsize < bufsize) break;
136360165Shibler /* Buffer was not long enough */
136460165Shibler free (buf);
136560165Shibler bufsize *= 2;
136660165Shibler }
136760165Shibler if (valsize == -1)
136860165Shibler {
136960165Shibler free (buf);
137060165Shibler return Qnil;
137160165Shibler }
137260165Shibler val = make_string (buf, valsize);
137360165Shibler free (buf);
137460165Shibler return val;
137560165Shibler #else /* not S_IFLNK */
137660165Shibler return Qnil;
137760165Shibler #endif /* not S_IFLNK */
137860165Shibler }
137960165Shibler
138060165Shibler /* Having this before file-symlink-p mysteriously caused it to be forgotten
138160165Shibler on the RT/PC. */
138260165Shibler DEFUN ("file-writable-p", Ffile_writable_p, Sfile_writable_p, 1, 1, 0,
138360165Shibler "Return t if file FILENAME can be written or created by you.")
138460165Shibler (filename)
138560165Shibler Lisp_Object filename;
138660165Shibler {
138760165Shibler Lisp_Object abspath, dir;
138860165Shibler
138960165Shibler CHECK_STRING (filename, 0);
139060165Shibler abspath = Fexpand_file_name (filename, Qnil);
139160165Shibler if (access (XSTRING (abspath)->data, 0) >= 0)
139260165Shibler return (access (XSTRING (abspath)->data, 2) >= 0) ? Qt : Qnil;
139360165Shibler dir = Ffile_name_directory (abspath);
139460165Shibler #ifdef VMS
139560165Shibler if (!NULL (dir))
139660165Shibler dir = Fdirectory_file_name (dir);
139760165Shibler #endif /* VMS */
139860165Shibler return (access (!NULL (dir) ? (char *) XSTRING (dir)->data : "", 2) >= 0
139960165Shibler ? Qt : Qnil);
140060165Shibler }
140160165Shibler
140260165Shibler DEFUN ("file-directory-p", Ffile_directory_p, Sfile_directory_p, 1, 1, 0,
140360165Shibler "Return t if file FILENAME is the name of a directory as a file.\n\
140460165Shibler A directory name spec may be given instead; then the value is t\n\
140560165Shibler if the directory so specified exists and really is a directory.")
140660165Shibler (filename)
140760165Shibler Lisp_Object filename;
140860165Shibler {
140960165Shibler register Lisp_Object abspath;
141060165Shibler struct stat st;
141160165Shibler
141260165Shibler abspath = expand_and_dir_to_file (filename, current_buffer->directory);
141360165Shibler
141460165Shibler if (stat (XSTRING (abspath)->data, &st) < 0)
141560165Shibler return Qnil;
141660165Shibler return (st.st_mode & S_IFMT) == S_IFDIR ? Qt : Qnil;
141760165Shibler }
141860165Shibler
141960165Shibler DEFUN ("file-modes", Ffile_modes, Sfile_modes, 1, 1, 0,
142060165Shibler "Return mode bits of FILE, as an integer.")
142160165Shibler (filename)
142260165Shibler Lisp_Object filename;
142360165Shibler {
142460165Shibler Lisp_Object abspath;
142560165Shibler struct stat st;
142660165Shibler
142760165Shibler abspath = expand_and_dir_to_file (filename, current_buffer->directory);
142860165Shibler
142960165Shibler if (stat (XSTRING (abspath)->data, &st) < 0)
143060165Shibler return Qnil;
143160165Shibler return make_number (st.st_mode & 07777);
143260165Shibler }
143360165Shibler
143460165Shibler DEFUN ("set-file-modes", Fset_file_modes, Sset_file_modes, 2, 2, 0,
143560165Shibler "Set mode bits of FILE to MODE (an integer).\n\
143660165Shibler Only the 12 low bits of MODE are used.")
143760165Shibler (filename, mode)
143860165Shibler Lisp_Object filename, mode;
143960165Shibler {
144060165Shibler Lisp_Object abspath;
144160165Shibler
144260165Shibler abspath = Fexpand_file_name (filename, current_buffer->directory);
144360165Shibler CHECK_NUMBER (mode, 1);
144460165Shibler
144560165Shibler #ifndef APOLLO
144660165Shibler if (chmod (XSTRING (abspath)->data, XINT (mode)) < 0)
144760165Shibler report_file_error ("Doing chmod", Fcons (abspath, Qnil));
144860165Shibler #else /* APOLLO */
144960165Shibler if (!egetenv ("USE_DOMAIN_ACLS"))
145060165Shibler {
145160165Shibler struct stat st;
145260165Shibler struct timeval tvp[2];
145360165Shibler
145460165Shibler /* chmod on apollo also change the file's modtime; need to save the
145560165Shibler modtime and then restore it. */
145660165Shibler if (stat (XSTRING (abspath)->data, &st) < 0)
145760165Shibler {
145860165Shibler report_file_error ("Doing chmod", Fcons (abspath, Qnil));
145960165Shibler return (Qnil);
146060165Shibler }
146160165Shibler
146260165Shibler if (chmod (XSTRING (abspath)->data, XINT (mode)) < 0)
146360165Shibler report_file_error ("Doing chmod", Fcons (abspath, Qnil));
146460165Shibler
146560165Shibler /* reset the old accessed and modified times. */
146660165Shibler tvp[0].tv_sec = st.st_atime + 1; /* +1 due to an Apollo roundoff bug */
146760165Shibler tvp[0].tv_usec = 0;
146860165Shibler tvp[1].tv_sec = st.st_mtime + 1; /* +1 due to an Apollo roundoff bug */
146960165Shibler tvp[1].tv_usec = 0;
147060165Shibler
147160165Shibler if (utimes (XSTRING (abspath)->data, tvp) < 0)
147260165Shibler report_file_error ("Doing utimes", Fcons (abspath, Qnil));
147360165Shibler }
147460165Shibler #endif /* APOLLO */
147560165Shibler
147660165Shibler return Qnil;
147760165Shibler }
147860165Shibler
147960165Shibler DEFUN ("file-newer-than-file-p", Ffile_newer_than_file_p, Sfile_newer_than_file_p, 2, 2, 0,
148060165Shibler "Return t if file FILE1 is newer than file FILE2.\n\
148160165Shibler If FILE1 does not exist, the answer is nil;\n\
148260165Shibler otherwise, if FILE2 does not exist, the answer is t.")
148360165Shibler (file1, file2)
148460165Shibler Lisp_Object file1, file2;
148560165Shibler {
148660165Shibler Lisp_Object abspath;
148760165Shibler struct stat st;
148860165Shibler int mtime1;
148960165Shibler
149060165Shibler CHECK_STRING (file1, 0);
149160165Shibler CHECK_STRING (file2, 0);
149260165Shibler
149360165Shibler abspath = expand_and_dir_to_file (file1, current_buffer->directory);
149460165Shibler
149560165Shibler if (stat (XSTRING (abspath)->data, &st) < 0)
149660165Shibler return Qnil;
149760165Shibler
149860165Shibler mtime1 = st.st_mtime;
149960165Shibler
150060165Shibler abspath = expand_and_dir_to_file (file2, current_buffer->directory);
150160165Shibler
150260165Shibler if (stat (XSTRING (abspath)->data, &st) < 0)
150360165Shibler return Qt;
150460165Shibler
150560165Shibler return (mtime1 > st.st_mtime) ? Qt : Qnil;
150660165Shibler }
150760165Shibler
close_file_unwind(fd)150860165Shibler close_file_unwind (fd)
150960165Shibler Lisp_Object fd;
151060165Shibler {
151160165Shibler close (XFASTINT (fd));
151260165Shibler }
151360165Shibler
151460165Shibler DEFUN ("insert-file-contents", Finsert_file_contents, Sinsert_file_contents,
151560165Shibler 1, 2, 0,
151660165Shibler "Insert contents of file FILENAME after point.\n\
151760165Shibler Returns list of absolute pathname and length of data inserted.\n\
151860165Shibler If second argument VISIT is non-nil, the buffer's visited filename\n\
151960165Shibler and last save file modtime are set, and it is marked unmodified.\n\
152060165Shibler If visiting and the file does not exist, visiting is completed\n\
152160165Shibler before the error is signaled.")
152260165Shibler (filename, visit)
152360165Shibler Lisp_Object filename, visit;
152460165Shibler {
152560165Shibler struct stat st;
152660165Shibler register int fd;
152760165Shibler register int inserted = 0;
152860165Shibler register int i = 0;
152960165Shibler int count = specpdl_ptr - specpdl;
153060165Shibler struct gcpro gcpro1;
153160165Shibler
153260165Shibler GCPRO1 (filename);
153360165Shibler if (!NULL (current_buffer->read_only))
153460165Shibler Fbarf_if_buffer_read_only();
153560165Shibler
153660165Shibler CHECK_STRING (filename, 0);
153760165Shibler filename = Fexpand_file_name (filename, Qnil);
153860165Shibler
153960165Shibler fd = -1;
154060165Shibler
154160165Shibler #ifndef APOLLO
154260165Shibler if (stat (XSTRING (filename)->data, &st) < 0
154360165Shibler || (fd = open (XSTRING (filename)->data, 0)) < 0)
154460165Shibler #else
154560165Shibler if ((fd = open (XSTRING (filename)->data, 0)) < 0
154660165Shibler || fstat (fd, &st) < 0)
154760165Shibler #endif /* not APOLLO */
154860165Shibler {
154960165Shibler if (fd >= 0) close (fd);
155060165Shibler if (NULL (visit))
155160165Shibler report_file_error ("Opening input file", Fcons (filename, Qnil));
155260165Shibler st.st_mtime = -1;
155360165Shibler goto notfound;
155460165Shibler }
155560165Shibler
155660165Shibler record_unwind_protect (close_file_unwind, make_number (fd));
155760165Shibler
155860165Shibler /* Supposedly happens on VMS. */
155960165Shibler if (st.st_size < 0)
156060165Shibler error ("File size is negative");
156160165Shibler {
156260165Shibler register Lisp_Object temp;
156360165Shibler
156460165Shibler /* Make sure point-max won't overflow after this insertion. */
156560165Shibler XSET (temp, Lisp_Int, st.st_size + Z);
156660165Shibler if (st.st_size + Z != XINT (temp))
156760165Shibler error ("maximum buffer size exceeded");
156860165Shibler }
156960165Shibler
157060165Shibler if (NULL (visit))
157160165Shibler prepare_to_modify_buffer ();
157260165Shibler
157360165Shibler move_gap (point);
157460165Shibler if (GAP_SIZE < st.st_size)
1575*60297Shibler make_gap ((int)st.st_size - GAP_SIZE);
157660165Shibler
157760165Shibler while (1)
157860165Shibler {
157960165Shibler int try = min (st.st_size - inserted, 64 << 10);
158060165Shibler int this = read (fd, &FETCH_CHAR (point + inserted - 1) + 1, try);
158160165Shibler
158260165Shibler if (this <= 0)
158360165Shibler {
158460165Shibler i = this;
158560165Shibler break;
158660165Shibler }
158760165Shibler
158860165Shibler GPT += this;
158960165Shibler GAP_SIZE -= this;
159060165Shibler ZV += this;
159160165Shibler Z += this;
159260165Shibler inserted += this;
159360165Shibler }
159460165Shibler
159560165Shibler if (inserted > 0)
159660165Shibler MODIFF++;
159760165Shibler record_insert (point, inserted);
159860165Shibler
159960165Shibler close (fd);
160060165Shibler
160160165Shibler /* Discard the unwind protect */
160260165Shibler specpdl_ptr = specpdl + count;
160360165Shibler
160460165Shibler if (i < 0)
160560165Shibler error ("IO error reading %s: %s",
160660165Shibler XSTRING (filename)->data, err_str (errno));
160760165Shibler
160860165Shibler notfound:
160960165Shibler
161060165Shibler if (!NULL (visit))
161160165Shibler {
161260165Shibler current_buffer->undo_list = Qnil;
161360165Shibler #ifdef APOLLO
161460165Shibler stat (XSTRING (filename)->data, &st);
161560165Shibler #endif
161660165Shibler current_buffer->modtime = st.st_mtime;
161760165Shibler current_buffer->save_modified = MODIFF;
161860165Shibler current_buffer->auto_save_modified = MODIFF;
161960165Shibler XFASTINT (current_buffer->save_length) = Z - BEG;
162060165Shibler #ifdef CLASH_DETECTION
162160165Shibler if (!NULL (current_buffer->filename))
162260165Shibler unlock_file (current_buffer->filename);
162360165Shibler unlock_file (filename);
162460165Shibler #endif /* CLASH_DETECTION */
162560165Shibler current_buffer->filename = filename;
162660165Shibler /* If visiting nonexistent file, return nil. */
162760165Shibler if (st.st_mtime == -1)
162860165Shibler report_file_error ("Opening input file", Fcons (filename, Qnil));
162960165Shibler }
163060165Shibler
163160165Shibler UNGCPRO;
163260165Shibler return Fcons (filename, Fcons (make_number (inserted), Qnil));
163360165Shibler }
163460165Shibler
163560165Shibler DEFUN ("write-region", Fwrite_region, Swrite_region, 3, 5,
163660165Shibler "r\nFWrite region to file: ",
163760165Shibler "Write current region into specified file.\n\
163860165Shibler When called from a program, takes three arguments:\n\
163960165Shibler START, END and FILENAME. START and END are buffer positions.\n\
164060165Shibler Optional fourth argument APPEND if non-nil means\n\
164160165Shibler append to existing file contents (if any).\n\
164260165Shibler Optional fifth argument VISIT if t means\n\
164360165Shibler set last-save-file-modtime of buffer to this file's modtime\n\
164460165Shibler and mark buffer not modified.\n\
164560165Shibler If VISIT is neither t nor nil, it means do not print\n\
164660165Shibler the \"Wrote file\" message.")
164760165Shibler (start, end, filename, append, visit)
164860165Shibler Lisp_Object start, end, filename, append, visit;
164960165Shibler {
165060165Shibler register int desc;
165160165Shibler int failure;
165260165Shibler int save_errno;
165360165Shibler unsigned char *fn;
165460165Shibler struct stat st;
165560165Shibler int tem;
165660165Shibler int count = specpdl_ptr - specpdl;
165760165Shibler #ifdef VMS
165860165Shibler unsigned char *fname = 0; /* If non-0, original filename (must rename) */
165960165Shibler #endif /* VMS */
166060165Shibler
166160165Shibler /* Special kludge to simplify auto-saving */
166260165Shibler if (NULL (start))
166360165Shibler {
166460165Shibler XFASTINT (start) = BEG;
166560165Shibler XFASTINT (end) = Z;
166660165Shibler }
166760165Shibler else
166860165Shibler validate_region (&start, &end);
166960165Shibler
167060165Shibler filename = Fexpand_file_name (filename, Qnil);
167160165Shibler fn = XSTRING (filename)->data;
167260165Shibler
167360165Shibler #ifdef CLASH_DETECTION
167460165Shibler if (!auto_saving)
167560165Shibler lock_file (filename);
167660165Shibler #endif /* CLASH_DETECTION */
167760165Shibler
167860165Shibler desc = -1;
167960165Shibler if (!NULL (append))
168060165Shibler desc = open (fn, O_WRONLY);
168160165Shibler
168260165Shibler if (desc < 0)
168360165Shibler #ifdef VMS
168460165Shibler if (auto_saving) /* Overwrite any previous version of autosave file */
168560165Shibler {
168660165Shibler vms_truncate (fn); /* if fn exists, truncate to zero length */
168760165Shibler desc = open (fn, O_RDWR);
168860165Shibler if (desc < 0)
168960165Shibler desc = creat_copy_attrs (XTYPE (current_buffer->filename) == Lisp_String
169060165Shibler ? XSTRING (current_buffer->filename)->data : 0,
169160165Shibler fn);
169260165Shibler }
169360165Shibler else /* Write to temporary name and rename if no errors */
169460165Shibler {
169560165Shibler Lisp_Object temp_name;
169660165Shibler temp_name = Ffile_name_directory (filename);
169760165Shibler
169860165Shibler if (!NULL (temp_name))
169960165Shibler {
170060165Shibler temp_name = Fmake_temp_name (concat2 (temp_name,
170160165Shibler build_string ("$$SAVE$$")));
170260165Shibler fname = XSTRING (filename)->data;
170360165Shibler fn = XSTRING (temp_name)->data;
170460165Shibler desc = creat_copy_attrs (fname, fn);
170560165Shibler if (desc < 0)
170660165Shibler {
170760165Shibler /* If we can't open the temporary file, try creating a new
170860165Shibler version of the original file. VMS "creat" creates a
170960165Shibler new version rather than truncating an existing file. */
171060165Shibler fn = fname;
171160165Shibler fname = 0;
171260165Shibler desc = creat (fn, 0666);
171360165Shibler if (desc < 0)
171460165Shibler {
171560165Shibler /* We can't make a new version;
171660165Shibler try to truncate and rewrite existing version if any. */
171760165Shibler vms_truncate (fn);
171860165Shibler desc = open (fn, O_RDWR);
171960165Shibler }
172060165Shibler }
172160165Shibler }
172260165Shibler else
172360165Shibler desc = creat (fn, 0666);
172460165Shibler }
172560165Shibler #else /* not VMS */
172660165Shibler desc = creat (fn, 0666);
172760165Shibler #endif /* not VMS */
172860165Shibler
172960165Shibler if (desc < 0)
173060165Shibler {
173160165Shibler #ifdef CLASH_DETECTION
173260165Shibler save_errno = errno;
173360165Shibler if (!auto_saving) unlock_file (filename);
173460165Shibler errno = save_errno;
173560165Shibler #endif /* CLASH_DETECTION */
173660165Shibler report_file_error ("Opening output file", Fcons (filename, Qnil));
173760165Shibler }
173860165Shibler
173960165Shibler record_unwind_protect (close_file_unwind, make_number (desc));
174060165Shibler
174160165Shibler if (!NULL (append))
1742*60297Shibler if (lseek (desc, (off_t) 0, 2) < 0)
174360165Shibler {
174460165Shibler #ifdef CLASH_DETECTION
174560165Shibler if (!auto_saving) unlock_file (filename);
174660165Shibler #endif /* CLASH_DETECTION */
174760165Shibler report_file_error ("Lseek error", Fcons (filename, Qnil));
174860165Shibler }
174960165Shibler
175060165Shibler #ifdef VMS
175160165Shibler /*
175260165Shibler * Kludge Warning: The VMS C RTL likes to insert carriage returns
175360165Shibler * if we do writes that don't end with a carriage return. Furthermore
175460165Shibler * it cannot handle writes of more then 16K. The modified
175560165Shibler * version of "sys_write" in SYSDEP.C (see comment there) copes with
175660165Shibler * this EXCEPT for the last record (iff it doesn't end with a carriage
175760165Shibler * return). This implies that if your buffer doesn't end with a carriage
175860165Shibler * return, you get one free... tough. However it also means that if
175960165Shibler * we make two calls to sys_write (a la the following code) you can
176060165Shibler * get one at the gap as well. The easiest way to fix this (honest)
176160165Shibler * is to move the gap to the next newline (or the end of the buffer).
176260165Shibler * Thus this change.
176360165Shibler *
176460165Shibler * Yech!
176560165Shibler */
176660165Shibler if (GPT > BEG && GPT_ADDR[-1] != '\n')
176760165Shibler move_gap (find_next_newline (GPT, 1));
176860165Shibler #endif
176960165Shibler
177060165Shibler failure = 0;
177160165Shibler if (XINT (start) != XINT (end))
177260165Shibler {
177360165Shibler if (XINT (start) < GPT)
177460165Shibler {
177560165Shibler register int end1 = XINT (end);
177660165Shibler tem = XINT (start);
177760165Shibler failure = 0 > e_write (desc, &FETCH_CHAR (tem),
177860165Shibler min (GPT, end1) - tem);
177960165Shibler save_errno = errno;
178060165Shibler }
178160165Shibler
178260165Shibler if (XINT (end) > GPT && !failure)
178360165Shibler {
178460165Shibler tem = XINT (start);
178560165Shibler tem = max (tem, GPT);
178660165Shibler failure = 0 > e_write (desc, &FETCH_CHAR (tem), XINT (end) - tem);
178760165Shibler save_errno = errno;
178860165Shibler }
178960165Shibler }
179060165Shibler
179160165Shibler #ifndef USG
179260165Shibler #ifndef VMS
179360165Shibler #ifndef BSD4_1
179460165Shibler #ifndef alliant /* trinkle@cs.purdue.edu says fsync can return EBUSY
179560165Shibler on alliant, for no visible reason. */
179660165Shibler /* Note fsync appears to change the modtime on BSD4.2 (both vax and sun).
179760165Shibler Disk full in NFS may be reported here. */
179860165Shibler if (fsync (desc) < 0)
179960165Shibler failure = 1, save_errno = errno;
180060165Shibler #endif
180160165Shibler #endif
180260165Shibler #endif
180360165Shibler #endif
180460165Shibler
180560165Shibler #if 0
180660165Shibler /* Spurious "file has changed on disk" warnings have been
180760165Shibler observed on Sun 3 as well. Maybe close changes the modtime
180860165Shibler with nfs as well. */
180960165Shibler
181060165Shibler /* On VMS and APOLLO, must do the stat after the close
181160165Shibler since closing changes the modtime. */
181260165Shibler #ifndef VMS
181360165Shibler #ifndef APOLLO
181460165Shibler /* Recall that #if defined does not work on VMS. */
181560165Shibler #define FOO
181660165Shibler fstat (desc, &st);
181760165Shibler #endif
181860165Shibler #endif
181960165Shibler #endif /* 0 */
182060165Shibler
182160165Shibler /* NFS can report a write failure now. */
182260165Shibler if (close (desc) < 0)
182360165Shibler failure = 1, save_errno = errno;
182460165Shibler
182560165Shibler #ifdef VMS
182660165Shibler /* If we wrote to a temporary name and had no errors, rename to real name. */
182760165Shibler if (fname)
182860165Shibler {
182960165Shibler if (!failure)
183060165Shibler failure = (rename (fn, fname) != 0), save_errno = errno;
183160165Shibler fn = fname;
183260165Shibler }
183360165Shibler #endif /* VMS */
183460165Shibler
183560165Shibler #ifndef FOO
183660165Shibler stat (fn, &st);
183760165Shibler #endif
183860165Shibler /* Discard the unwind protect */
183960165Shibler specpdl_ptr = specpdl + count;
184060165Shibler
184160165Shibler #ifdef CLASH_DETECTION
184260165Shibler if (!auto_saving)
184360165Shibler unlock_file (filename);
184460165Shibler #endif /* CLASH_DETECTION */
184560165Shibler
184660165Shibler /* Do this before reporting IO error
184760165Shibler to avoid a "file has changed on disk" warning on
184860165Shibler next attempt to save. */
184960165Shibler if (EQ (visit, Qt))
185060165Shibler current_buffer->modtime = st.st_mtime;
185160165Shibler
185260165Shibler if (failure)
185360165Shibler error ("IO error writing %s: %s", fn, err_str (save_errno));
185460165Shibler
185560165Shibler if (EQ (visit, Qt))
185660165Shibler {
185760165Shibler current_buffer->save_modified = MODIFF;
185860165Shibler XFASTINT (current_buffer->save_length) = Z - BEG;
185960165Shibler current_buffer->filename = filename;
186060165Shibler }
186160165Shibler else if (!NULL (visit))
186260165Shibler return Qnil;
186360165Shibler
186460165Shibler if (!auto_saving)
186560165Shibler message ("Wrote %s", fn);
186660165Shibler
186760165Shibler return Qnil;
186860165Shibler }
186960165Shibler
187060165Shibler int
e_write(desc,addr,len)187160165Shibler e_write (desc, addr, len)
187260165Shibler int desc;
187360165Shibler register char *addr;
187460165Shibler register int len;
187560165Shibler {
187660165Shibler char buf[16 * 1024];
187760165Shibler register char *p, *end;
187860165Shibler
187960165Shibler if (!EQ (current_buffer->selective_display, Qt))
188060165Shibler return write (desc, addr, len) - len;
188160165Shibler else
188260165Shibler {
188360165Shibler p = buf;
188460165Shibler end = p + sizeof buf;
188560165Shibler while (len--)
188660165Shibler {
188760165Shibler if (p == end)
188860165Shibler {
188960165Shibler if (write (desc, buf, sizeof buf) != sizeof buf)
189060165Shibler return -1;
189160165Shibler p = buf;
189260165Shibler }
189360165Shibler *p = *addr++;
189460165Shibler if (*p++ == '\015')
189560165Shibler p[-1] = '\n';
189660165Shibler }
189760165Shibler if (p != buf)
189860165Shibler if (write (desc, buf, p - buf) != p - buf)
189960165Shibler return -1;
190060165Shibler }
190160165Shibler return 0;
190260165Shibler }
190360165Shibler
190460165Shibler DEFUN ("verify-visited-file-modtime", Fverify_visited_file_modtime,
190560165Shibler Sverify_visited_file_modtime, 1, 1, 0,
190660165Shibler "Return t if last mod time of BUF's visited file matches what BUF records.\n\
190760165Shibler This means that the file has not been changed since it was visited or saved.")
190860165Shibler (buf)
190960165Shibler Lisp_Object buf;
191060165Shibler {
191160165Shibler struct buffer *b;
191260165Shibler struct stat st;
191360165Shibler
191460165Shibler CHECK_BUFFER (buf, 0);
191560165Shibler b = XBUFFER (buf);
191660165Shibler
191760165Shibler if (XTYPE (b->filename) != Lisp_String) return Qt;
191860165Shibler if (b->modtime == 0) return Qt;
191960165Shibler
192060165Shibler if (stat (XSTRING (b->filename)->data, &st) < 0)
192160165Shibler {
192260165Shibler /* If the file doesn't exist now and didn't exist before,
192360165Shibler we say that it isn't modified, provided the error is a tame one. */
192460165Shibler if (errno == ENOENT || errno == EACCES || errno == ENOTDIR)
192560165Shibler st.st_mtime = -1;
192660165Shibler else
192760165Shibler st.st_mtime = 0;
192860165Shibler }
192960165Shibler if (st.st_mtime == b->modtime
193060165Shibler /* If both are positive, accept them if they are off by one second. */
193160165Shibler || (st.st_mtime > 0 && b->modtime > 0
193260165Shibler && (st.st_mtime == b->modtime + 1
193360165Shibler || st.st_mtime == b->modtime - 1)))
193460165Shibler return Qt;
193560165Shibler return Qnil;
193660165Shibler }
193760165Shibler
193860165Shibler DEFUN ("clear-visited-file-modtime", Fclear_visited_file_modtime,
193960165Shibler Sclear_visited_file_modtime, 0, 0, 0,
194060165Shibler "Clear out records of last mod time of visited file.\n\
194160165Shibler Next attempt to save will certainly not complain of a discrepancy.")
194260165Shibler ()
194360165Shibler {
194460165Shibler current_buffer->modtime = 0;
194560165Shibler return Qnil;
194660165Shibler }
194760165Shibler
194860165Shibler Lisp_Object
auto_save_error()194960165Shibler auto_save_error ()
195060165Shibler {
195160165Shibler unsigned char *name = XSTRING (current_buffer->name)->data;
195260165Shibler
195360165Shibler bell ();
195460165Shibler message ("Autosaving...error for %s", name);
195560165Shibler Fsleep_for (make_number (1));
195660165Shibler message ("Autosaving...error!for %s", name);
195760165Shibler Fsleep_for (make_number (1));
195860165Shibler message ("Autosaving...error for %s", name);
195960165Shibler Fsleep_for (make_number (1));
196060165Shibler return Qnil;
196160165Shibler }
196260165Shibler
196360165Shibler Lisp_Object
auto_save_1()196460165Shibler auto_save_1 ()
196560165Shibler {
196660165Shibler return
196760165Shibler Fwrite_region (Qnil, Qnil,
196860165Shibler current_buffer->auto_save_file_name,
196960165Shibler Qnil, Qlambda);
197060165Shibler }
197160165Shibler
197260165Shibler DEFUN ("do-auto-save", Fdo_auto_save, Sdo_auto_save, 0, 1, "",
197360165Shibler "Auto-save all buffers that need it.\n\
197460165Shibler This is all buffers that have auto-saving enabled\n\
197560165Shibler and are changed since last auto-saved.\n\
197660165Shibler Auto-saving writes the buffer into a file\n\
197760165Shibler so that your editing is not lost if the system crashes.\n\
197860165Shibler This file is not the file you visited; that changes only when you save.\n\n\
197960165Shibler Non-nil argument means do not print any message if successful.")
198060165Shibler (nomsg)
198160165Shibler Lisp_Object nomsg;
198260165Shibler {
198360165Shibler struct buffer *old = current_buffer, *b;
198460165Shibler Lisp_Object tail, buf;
198560165Shibler int auto_saved = 0;
198660165Shibler int tried = 0;
198760165Shibler char *omessage = echo_area_contents;
198860165Shibler /* No GCPRO needed, because (when it matters) all Lisp_Object variables
198960165Shibler point to non-strings reached from Vbuffer_alist. */
199060165Shibler
199160165Shibler auto_saving = 1;
199260165Shibler if (minibuf_level)
199360165Shibler nomsg = Qt;
199460165Shibler
199560165Shibler for (tail = Vbuffer_alist; XGCTYPE (tail) == Lisp_Cons;
199660165Shibler tail = XCONS (tail)->cdr)
199760165Shibler {
199860165Shibler buf = XCONS (XCONS (tail)->car)->cdr;
199960165Shibler b = XBUFFER (buf);
200060165Shibler /* Check for auto save enabled
200160165Shibler and file changed since last auto save
200260165Shibler and file changed since last real save. */
200360165Shibler if (XTYPE (b->auto_save_file_name) == Lisp_String
200460165Shibler && b->save_modified < BUF_MODIFF (b)
200560165Shibler && b->auto_save_modified < BUF_MODIFF (b))
200660165Shibler {
200760165Shibler /* If we at least consider a buffer for auto-saving,
200860165Shibler don't try again for a suitable time. */
200960165Shibler tried++;
201060165Shibler if ((XFASTINT (b->save_length) * 10
201160165Shibler > (BUF_Z (b) - BUF_BEG (b)) * 13)
201260165Shibler /* A short file is likely to change a large fraction;
201360165Shibler spare the user annoying messages. */
201460165Shibler && XFASTINT (b->save_length) > 5000
201560165Shibler /* These messages are frequent and annoying for `*mail*'. */
201660165Shibler && !EQ (b->filename, Qnil))
201760165Shibler {
201860165Shibler /* It has shrunk too much; don't checkpoint. */
201960165Shibler message ("Buffer %s has shrunk a lot; not autosaving it",
202060165Shibler XSTRING (b->name)->data);
202160165Shibler Fsleep_for (make_number (1));
202260165Shibler continue;
202360165Shibler }
202460165Shibler set_buffer_internal (b);
202560165Shibler if (!auto_saved && NULL (nomsg))
202660165Shibler message1 ("Auto-saving...");
202760165Shibler internal_condition_case (auto_save_1, Qt, auto_save_error);
202860165Shibler auto_saved++;
202960165Shibler b->auto_save_modified = BUF_MODIFF (b);
203060165Shibler XFASTINT (current_buffer->save_length) = Z - BEG;
203160165Shibler set_buffer_internal (old);
203260165Shibler }
203360165Shibler }
203460165Shibler
203560165Shibler if (tried)
203660165Shibler record_auto_save ();
203760165Shibler
203860165Shibler if (auto_saved && NULL (nomsg))
203960165Shibler message1 (omessage ? omessage : "Auto-saving...done");
204060165Shibler
204160165Shibler auto_saving = 0;
204260165Shibler return Qnil;
204360165Shibler }
204460165Shibler
204560165Shibler DEFUN ("set-buffer-auto-saved", Fset_buffer_auto_saved,
204660165Shibler Sset_buffer_auto_saved, 0, 0, 0,
204760165Shibler "Mark current buffer as auto-saved with its current text.\n\
204860165Shibler No auto-save file will be written until the buffer changes again.")
204960165Shibler ()
205060165Shibler {
205160165Shibler current_buffer->auto_save_modified = MODIFF;
205260165Shibler XFASTINT (current_buffer->save_length) = Z - BEG;
205360165Shibler return Qnil;
205460165Shibler }
205560165Shibler
205660165Shibler DEFUN ("recent-auto-save-p", Frecent_auto_save_p, Srecent_auto_save_p,
205760165Shibler 0, 0, 0,
205860165Shibler "Return t if buffer has been auto-saved since last read in or saved.")
205960165Shibler ()
206060165Shibler {
206160165Shibler return (current_buffer->save_modified < current_buffer->auto_save_modified) ? Qt : Qnil;
206260165Shibler }
206360165Shibler
206460165Shibler /* Reading and completing file names */
206560165Shibler extern Lisp_Object Ffile_name_completion (), Ffile_name_all_completions ();
206660165Shibler
206760165Shibler DEFUN ("read-file-name-internal", Fread_file_name_internal, Sread_file_name_internal,
206860165Shibler 3, 3, 0,
206960165Shibler "Internal subroutine for read-file-name. Do not call this.")
207060165Shibler (string, dir, action)
207160165Shibler Lisp_Object string, dir, action;
207260165Shibler /* action is nil for complete, t for return list of completions,
207360165Shibler lambda for verify final value */
207460165Shibler {
207560165Shibler Lisp_Object name, specdir, realdir, val;
207660165Shibler if (XSTRING (string)->size == 0)
207760165Shibler {
207860165Shibler name = string;
207960165Shibler realdir = dir;
208060165Shibler if (EQ (action, Qlambda))
208160165Shibler return Qnil;
208260165Shibler }
208360165Shibler else
208460165Shibler {
208560165Shibler string = Fsubstitute_in_file_name (string);
208660165Shibler name = Ffile_name_nondirectory (string);
208760165Shibler realdir = Ffile_name_directory (string);
208860165Shibler if (NULL (realdir))
208960165Shibler realdir = dir;
209060165Shibler else
209160165Shibler realdir = Fexpand_file_name (realdir, dir);
209260165Shibler }
209360165Shibler
209460165Shibler if (NULL (action))
209560165Shibler {
209660165Shibler specdir = Ffile_name_directory (string);
209760165Shibler val = Ffile_name_completion (name, realdir);
209860165Shibler if (XTYPE (val) != Lisp_String)
209960165Shibler return (val);
210060165Shibler
210160165Shibler if (!NULL (specdir))
210260165Shibler val = concat2 (specdir, val);
210360165Shibler #ifndef VMS
210460165Shibler {
210560165Shibler register unsigned char *old, *new;
210660165Shibler register int n;
210760165Shibler int osize, count;
210860165Shibler
210960165Shibler osize = XSTRING (val)->size;
211060165Shibler /* Quote "$" as "$$" to get it past substitute-in-file-name */
211160165Shibler for (n = osize, count = 0, old = XSTRING (val)->data; n > 0; n--)
211260165Shibler if (*old++ == '$') count++;
211360165Shibler if (count > 0)
211460165Shibler {
211560165Shibler old = XSTRING (val)->data;
211660165Shibler val = Fmake_string (make_number (osize + count), make_number (0));
211760165Shibler new = XSTRING (val)->data;
211860165Shibler for (n = osize; n > 0; n--)
211960165Shibler if (*old != '$')
212060165Shibler *new++ = *old++;
212160165Shibler else
212260165Shibler {
212360165Shibler *new++ = '$';
212460165Shibler *new++ = '$';
212560165Shibler old++;
212660165Shibler }
212760165Shibler }
212860165Shibler }
212960165Shibler #endif /* Not VMS */
213060165Shibler return (val);
213160165Shibler }
213260165Shibler
213360165Shibler if (EQ (action, Qt))
213460165Shibler return Ffile_name_all_completions (name, realdir);
213560165Shibler /* Only other case actually used is ACTION = lambda */
213660165Shibler #ifdef VMS
213760165Shibler /* Supposedly this helps commands such as `cd' that read directory names,
213860165Shibler but can someone explain how it helps them? -- RMS */
213960165Shibler if (XSTRING (name)->size == 0)
214060165Shibler return Qt;
214160165Shibler #endif /* VMS */
214260165Shibler return Ffile_exists_p (string);
214360165Shibler }
214460165Shibler
214560165Shibler DEFUN ("read-file-name", Fread_file_name, Sread_file_name, 1, 4, 0,
214660165Shibler "Read file name, prompting with PROMPT and completing in directory DIR.\n\
214760165Shibler Value is not expanded! You must call expand-file-name yourself.\n\
214860165Shibler Default name to DEFAULT if user enters a null string.\n\
214960165Shibler Fourth arg MUSTMATCH non-nil means require existing file's name.\n\
215060165Shibler Non-nil and non-t means also require confirmation after completion.\n\
215160165Shibler DIR defaults to current buffer's directory default.")
215260165Shibler (prompt, dir, defalt, mustmatch)
215360165Shibler Lisp_Object prompt, dir, defalt, mustmatch;
215460165Shibler {
215560165Shibler Lisp_Object val, insdef, tem;
215660165Shibler struct gcpro gcpro1, gcpro2;
215760165Shibler register char *homedir;
215860165Shibler int count;
215960165Shibler
216060165Shibler if (NULL (dir))
216160165Shibler dir = current_buffer->directory;
216260165Shibler if (NULL (defalt))
216360165Shibler defalt = current_buffer->filename;
216460165Shibler
216560165Shibler /* If dir starts with user's homedir, change that to ~. */
216660165Shibler homedir = (char *) egetenv ("HOME");
216760165Shibler if (homedir != 0
216860165Shibler && XTYPE (dir) == Lisp_String
216960165Shibler && !strncmp (homedir, XSTRING (dir)->data, strlen (homedir))
217060165Shibler && XSTRING (dir)->data[strlen (homedir)] == '/')
217160165Shibler {
217260165Shibler dir = make_string (XSTRING (dir)->data + strlen (homedir) - 1,
217360165Shibler XSTRING (dir)->size - strlen (homedir) + 1);
217460165Shibler XSTRING (dir)->data[0] = '~';
217560165Shibler }
217660165Shibler
217760165Shibler if (insert_default_directory)
217860165Shibler insdef = dir;
217960165Shibler else
218060165Shibler insdef = build_string ("");
218160165Shibler
218260165Shibler #ifdef VMS
218360165Shibler count = specpdl_ptr - specpdl;
218460165Shibler specbind (intern ("completion-ignore-case"), Qt);
218560165Shibler #endif
218660165Shibler
218760165Shibler GCPRO2 (insdef, defalt);
218860165Shibler val = Fcompleting_read (prompt, intern ("read-file-name-internal"),
218960165Shibler dir, mustmatch,
219060165Shibler insert_default_directory ? insdef : Qnil);
219160165Shibler
219260165Shibler #ifdef VMS
219360165Shibler unbind_to (count);
219460165Shibler #endif
219560165Shibler
219660165Shibler UNGCPRO;
219760165Shibler if (NULL (val))
219860165Shibler error ("No file name specified");
219960165Shibler tem = Fstring_equal (val, insdef);
220060165Shibler if (!NULL (tem) && !NULL (defalt))
220160165Shibler return defalt;
220260165Shibler return Fsubstitute_in_file_name (val);
220360165Shibler }
220460165Shibler
syms_of_fileio()220560165Shibler syms_of_fileio ()
220660165Shibler {
220760165Shibler Qfile_error = intern ("file-error");
220860165Shibler staticpro (&Qfile_error);
220960165Shibler Qfile_already_exists = intern("file-already-exists");
221060165Shibler staticpro (&Qfile_already_exists);
221160165Shibler
221260165Shibler Fput (Qfile_error, Qerror_conditions,
221360165Shibler Fcons (Qfile_error, Fcons (Qerror, Qnil)));
221460165Shibler Fput (Qfile_error, Qerror_message,
221560165Shibler build_string ("File error"));
221660165Shibler
221760165Shibler Fput (Qfile_already_exists, Qerror_conditions,
221860165Shibler Fcons (Qfile_already_exists,
221960165Shibler Fcons (Qfile_error, Fcons (Qerror, Qnil))));
222060165Shibler Fput (Qfile_already_exists, Qerror_message,
222160165Shibler build_string ("File already exists"));
222260165Shibler
222360165Shibler DEFVAR_BOOL ("insert-default-directory", &insert_default_directory,
222460165Shibler "*Non-nil means when reading a filename start with default dir in minibuffer.");
222560165Shibler insert_default_directory = 1;
222660165Shibler
222760165Shibler DEFVAR_BOOL ("vms-stmlf-recfm", &vms_stmlf_recfm,
222860165Shibler "*Non-nil means write new files with record format `stmlf'.\n\
222960165Shibler nil means use format `var'. This variable is meaningful only on VMS.");
223060165Shibler vms_stmlf_recfm = 0;
223160165Shibler
223260165Shibler defsubr (&Sfile_name_directory);
223360165Shibler defsubr (&Sfile_name_nondirectory);
223460165Shibler defsubr (&Sfile_name_as_directory);
223560165Shibler defsubr (&Sdirectory_file_name);
223660165Shibler defsubr (&Smake_temp_name);
223760165Shibler defsubr (&Sexpand_file_name);
223860165Shibler defsubr (&Ssubstitute_in_file_name);
223960165Shibler defsubr (&Scopy_file);
224060165Shibler defsubr (&Sdelete_file);
224160165Shibler defsubr (&Srename_file);
224260165Shibler defsubr (&Sadd_name_to_file);
224360165Shibler #ifdef S_IFLNK
224460165Shibler defsubr (&Smake_symbolic_link);
224560165Shibler #endif /* S_IFLNK */
224660165Shibler #ifdef VMS
224760165Shibler defsubr (&Sdefine_logical_name);
224860165Shibler #endif /* VMS */
224960165Shibler #ifdef HPUX_NET
225060165Shibler defsubr (&Ssysnetunam);
225160165Shibler #endif /* HPUX_NET */
225260165Shibler defsubr (&Sfile_name_absolute_p);
225360165Shibler defsubr (&Sfile_exists_p);
225460165Shibler defsubr (&Sfile_readable_p);
225560165Shibler defsubr (&Sfile_writable_p);
225660165Shibler defsubr (&Sfile_symlink_p);
225760165Shibler defsubr (&Sfile_directory_p);
225860165Shibler defsubr (&Sfile_modes);
225960165Shibler defsubr (&Sset_file_modes);
226060165Shibler defsubr (&Sfile_newer_than_file_p);
226160165Shibler defsubr (&Sinsert_file_contents);
226260165Shibler defsubr (&Swrite_region);
226360165Shibler defsubr (&Sverify_visited_file_modtime);
226460165Shibler defsubr (&Sclear_visited_file_modtime);
226560165Shibler defsubr (&Sdo_auto_save);
226660165Shibler defsubr (&Sset_buffer_auto_saved);
226760165Shibler defsubr (&Srecent_auto_save_p);
226860165Shibler
226960165Shibler defsubr (&Sread_file_name_internal);
227060165Shibler defsubr (&Sread_file_name);
227160165Shibler }
2272