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