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