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