1 /*-
2 * Copyright (c) 2007-2019 Michael Scholz <mi-scholz@users.sourceforge.net>
3 * All rights reserved.
4 *
5 * Redistribution and use in source and binary forms, with or without
6 * modification, are permitted provided that the following conditions
7 * are met:
8 * 1. Redistributions of source code must retain the above copyright
9 * notice, this list of conditions and the following disclaimer.
10 * 2. Redistributions in binary form must reproduce the above copyright
11 * notice, this list of conditions and the following disclaimer in the
12 * documentation and/or other materials provided with the distribution.
13 *
14 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
15 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
16 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
17 * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
18 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
19 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
20 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
21 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
22 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
23 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
24 * SUCH DAMAGE.
25 *
26 * @(#)file.c 2.2 1/31/19
27 */
28
29 #if defined(HAVE_CONFIG_H)
30 #include "config.h"
31 #endif
32
33 #include "fth.h"
34 #include "utils.h"
35
36 #if defined(HAVE_SYS_STAT_H)
37 #include <sys/stat.h>
38 #endif
39 #if defined(HAVE_NETINET_IN_H)
40 #include <netinet/in.h>
41 #endif
42 #if defined(HAVE_ARPA_INET_H)
43 #include <arpa/inet.h>
44 #endif
45
46 static void ficl_close_pipe(ficlVm *);
47 static void ficl_file_atime(ficlVm *);
48 static void ficl_file_basename(ficlVm *);
49 static void ficl_file_chdir(ficlVm *);
50 static void ficl_file_chmod(ficlVm *);
51 static void ficl_file_chroot(ficlVm *);
52 static void ficl_file_copy(ficlVm *);
53 static void ficl_file_ctime(ficlVm *);
54 static void ficl_file_delete(ficlVm *);
55 static void ficl_file_dir(ficlVm *);
56 static void ficl_file_dirname(ficlVm *);
57 static void ficl_file_eval(ficlVm *);
58 static void ficl_file_exists_p(ficlVm *);
59 static void ficl_file_fullpath(ficlVm *);
60 static void ficl_file_install(ficlVm *);
61 static void ficl_file_length(ficlVm *);
62 static void ficl_file_mkdir(ficlVm *);
63 static void ficl_file_mkfifo(ficlVm *);
64 static void ficl_file_mtime(ficlVm *);
65 static void ficl_file_pwd(ficlVm *);
66 static void ficl_file_realpath(ficlVm *);
67 static void ficl_file_rename(ficlVm *);
68 static void ficl_file_rmdir(ficlVm *);
69 static void ficl_file_shell(ficlVm *);
70 static void ficl_file_split(ficlVm *);
71 static void ficl_file_symlink(ficlVm *);
72 static void ficl_file_system(ficlVm *);
73 static void ficl_file_touch(ficlVm *);
74 static void ficl_file_truncate(ficlVm *);
75 static void ficl_file_zero_p(ficlVm *);
76 static void ficl_open_pipe(ficlVm *);
77 static mode_t fth_stat(const char *, struct stat *);
78
79 /* === FILE === */
80
81 #define h_list_of_file_functions "\
82 *** FILE PRIMITIVES ***\n\
83 chdir alias for file-chdir\n\
84 close-pipe ( fp -- ior )\n\
85 file-atime ( name -- time )\n\
86 file-basename ( name ext -- base )\n\
87 file-chdir ( path -- )\n\
88 file-chmod ( name mode -- )\n\
89 file-chroot ( path -- )\n\
90 file-copy ( src dst -- )\n\
91 file-ctime ( name -- time )\n\
92 file-delete ( name -- )\n\
93 file-dir ( dir -- files-ary )\n\
94 file-dirname ( name -- path )\n\
95 file-eval ( name -- )\n\
96 file-fullpath ( name -- path )\n\
97 file-install ( src dst mode -- f )\n\
98 file-length ( name -- len )\n\
99 file-match-dir ( dir reg -- files-ary )\n\
100 file-mkdir ( name mode -- )\n\
101 file-mkfifo ( name mode -- )\n\
102 file-mtime ( name -- time )\n\
103 file-pwd ( -- path )\n\
104 file-realpath ( name -- path )\n\
105 file-rename ( src dst -- )\n\
106 file-rmdir ( name -- )\n\
107 file-shell ( cmd -- str )\n\
108 file-split ( name -- ary )\n\
109 file-symlink ( src dst -- )\n\
110 file-system ( cmd -- f )\n\
111 file-touch ( name time -- )\n\
112 file-truncate ( name size -- )\n\
113 open-pipe ( addr u fam -- fp ior )\n\
114 shell alias for file-shell\n\
115 File test:\n\
116 file-block? ( name -- f )\n\
117 file-character? ( name -- f )\n\
118 file-directory? ( name -- f )\n\
119 file-executable? ( name -- f )\n\
120 file-exists? ( name -- f )\n\
121 file-fifo? ( name -- f )\n\
122 file-grpowned? ( name -- f )\n\
123 file-owned? ( name -- f )\n\
124 file-readable? ( name -- f )\n\
125 file-setgid? ( name -- f )\n\
126 file-setuid? ( name -- f )\n\
127 file-socket? ( name -- f )\n\
128 file-sticky? ( name -- f )\n\
129 file-symlink? ( name -- f )\n\
130 file-writable? ( name -- f )\n\
131 file-zero? ( name -- f )"
132
133 #if defined(HAVE_ACCESS)
134 #define FTH_ACCESS_P(name, mode) (access(name, mode) == 0)
135 #else
136 #define FTH_ACCESS_P(name, mode) (0)
137 #endif
138
139 #define h_mode_info "\
140 You can write MODE with octal numbers: prepend the number with 0o, \
141 this is number zero '0' and lower letter 'o', \
142 similar to 0x for hexadecimal numbers."
143
144 #define h_system_error_info(Fnc) \
145 "Raise SYSTEM-ERROR exception if " Fnc " fails."
146 #define h_system_error_and_not_implemented_info(Fnc) \
147 "Raise SYSTEM-ERROR exception if " Fnc " fails, \
148 raise NOT-IMPLEMENTED exception if " Fnc " is not available."
149
150 void
fth_file_delete(const char * name)151 fth_file_delete(const char *name)
152 {
153 #if !defined(_WIN32)
154 if (fth_file_writable_p(name))
155 #endif
156 if (unlink(name) == -1)
157 FTH_SYSTEM_ERROR_ARG_THROW(unlink, name);
158 }
159
160 static void
ficl_file_delete(ficlVm * vm)161 ficl_file_delete(ficlVm *vm)
162 {
163 #define h_file_delete "( name -- ) delete file\n\
164 \"main.c\" file-delete\n\
165 If file NAME exist, delete it, otherwise do nothing (see unlink(2)). \
166 " h_system_error_info("unlink(2)")
167 FTH fs;
168
169 FTH_STACK_CHECK(vm, 1, 0);
170 fs = ficlStackPopFTH(vm->dataStack);
171
172 if (fth_string_length(fs) <= 0) {
173 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
174 /* NOTREACHED */
175 return;
176 }
177 fth_file_delete(fth_string_ref(fs));
178 }
179
180 void
fth_file_chmod(const char * name,mode_t mode)181 fth_file_chmod(const char *name, mode_t mode)
182 {
183 #if defined(HAVE_CHMOD)
184 if (chmod(name, mode) == -1)
185 FTH_SYSTEM_ERROR_ARG_THROW(chmod, name);
186 #else
187 FTH_NOT_IMPLEMENTED_ERROR(chmod);
188 #endif
189 }
190
191 static void
ficl_file_chmod(ficlVm * vm)192 ficl_file_chmod(ficlVm *vm)
193 {
194 #define h_file_chmod "( name mode -- ) change file access mode\n\
195 \"main.csh\" 0o755 file-chmod\n\
196 Change access mode of file NAME to MODE (see chmod(2)). \
197 " h_mode_info " " h_system_error_and_not_implemented_info("chmod(2)")
198 FTH fs;
199 mode_t mode;
200
201 FTH_STACK_CHECK(vm, 2, 0);
202 mode = (mode_t) ficlStackPopInteger(vm->dataStack);
203 fs = ficlStackPopFTH(vm->dataStack);
204
205 if (fth_string_length(fs) <= 0) {
206 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
207 /* NOTREACHED */
208 return;
209 }
210 fth_file_chmod(fth_string_ref(fs), mode);
211 }
212
213 void
fth_file_mkdir(const char * name,mode_t mode)214 fth_file_mkdir(const char *name, mode_t mode)
215 {
216 #if defined(HAVE_MKDIR)
217 #if defined(_WIN32)
218 if (mkdir(name) == -1)
219 #else
220 if (mkdir(name, mode) == -1)
221 #endif
222 FTH_SYSTEM_ERROR_ARG_THROW(mkdir, name);
223 #else
224 FTH_NOT_IMPLEMENTED_ERROR(mkdir);
225 #endif
226 }
227
228 static void
ficl_file_mkdir(ficlVm * vm)229 ficl_file_mkdir(ficlVm *vm)
230 {
231 #define h_file_mkdir "( name mode -- ) create new directory\n\
232 \"test-src\" 0o755 file-mkdir\n\
233 Create directory named NAME with access mode MODE (see mkdir(2)). \
234 " h_mode_info " " h_system_error_and_not_implemented_info("mkdir(2)")
235 FTH fs;
236 mode_t mode;
237
238 FTH_STACK_CHECK(vm, 2, 0);
239 mode = (mode_t) ficlStackPopInteger(vm->dataStack);
240 fs = ficlStackPopFTH(vm->dataStack);
241
242 if (fth_string_length(fs) <= 0) {
243 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
244 /* NOTREACHED */
245 return;
246 }
247 fth_file_mkdir(fth_string_ref(fs), mode);
248 }
249
250 void
fth_file_rmdir(const char * name)251 fth_file_rmdir(const char *name)
252 {
253 #if defined(HAVE_RMDIR)
254 if (rmdir(name) == -1)
255 FTH_SYSTEM_ERROR_ARG_THROW(rmdir, name);
256 #else
257 FTH_NOT_IMPLEMENTED_ERROR(rmdir);
258 #endif
259 }
260
261 static void
ficl_file_rmdir(ficlVm * vm)262 ficl_file_rmdir(ficlVm *vm)
263 {
264 #define h_file_rmdir "( name -- ) remove empty directory\n\
265 \"test-src\" file-rmdir\n\
266 Remove empty directory NAME (see rmdir(2)). \
267 " h_system_error_and_not_implemented_info("rmdir(2)")
268 FTH fs;
269
270 FTH_STACK_CHECK(vm, 1, 0);
271 fs = ficlStackPopFTH(vm->dataStack);
272
273 if (fth_string_length(fs) <= 0) {
274 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
275 /* NOTREACHED */
276 return;
277 }
278 fth_file_rmdir(fth_string_ref(fs));
279 }
280
281 void
fth_file_mkfifo(const char * name,mode_t mode)282 fth_file_mkfifo(const char *name, mode_t mode)
283 {
284 #if defined(HAVE_MKFIFO)
285 if (mkfifo(name, mode) == -1)
286 FTH_SYSTEM_ERROR_ARG_THROW(mkfifo, name);
287 #else
288 FTH_NOT_IMPLEMENTED_ERROR(mkfifo);
289 #endif
290 }
291
292 static void
ficl_file_mkfifo(ficlVm * vm)293 ficl_file_mkfifo(ficlVm *vm)
294 {
295 #define h_file_mkfifo "( name mode -- ) create fifo\n\
296 \"test-fifo\" 0o644 file-mkfifo\n\
297 Create fifo named NAME with access mode MODE (see mkfifo(2)). \
298 " h_mode_info " " h_system_error_and_not_implemented_info("mkfifo(2)")
299 FTH fs;
300 mode_t mode;
301
302 FTH_STACK_CHECK(vm, 2, 0);
303 mode = (mode_t) ficlStackPopInteger(vm->dataStack);
304 fs = ficlStackPopFTH(vm->dataStack);
305
306 if (fth_string_length(fs) <= 0) {
307 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
308 /* NOTREACHED */
309 return;
310 }
311 fth_file_mkfifo(fth_string_ref(fs), mode);
312 }
313
314 static char file_scratch[MAXPATHLEN];
315
316 void
fth_file_symlink(const char * src,const char * dst)317 fth_file_symlink(const char *src, const char *dst)
318 {
319 #if defined(HAVE_SYMLINK)
320 if (symlink(src, dst) == -1) {
321 char *buf;
322 size_t size;
323
324 buf = file_scratch;
325 size = sizeof(file_scratch);
326 fth_strcpy(buf, size, src);
327 fth_strcat(buf, size, " --> ");
328 fth_strcat(buf, size, dst);
329 FTH_SYSTEM_ERROR_ARG_THROW(symlink, buf);
330 }
331 #else
332 FTH_NOT_IMPLEMENTED_ERROR(symlink);
333 #endif
334 }
335
336 static void
ficl_file_symlink(ficlVm * vm)337 ficl_file_symlink(ficlVm *vm)
338 {
339 #define h_file_symlink "( src dst -- ) create symlink\n\
340 \"/usr/bin/clang\" \"/home/mike/bin/cc\" file-symlink\n\
341 Create symlink from SRC named DST (see symlink(2)). \
342 " h_system_error_and_not_implemented_info("symlink(2)")
343 FTH s, d;
344
345 FTH_STACK_CHECK(vm, 2, 0);
346 d = ficlStackPopFTH(vm->dataStack);
347 s = ficlStackPopFTH(vm->dataStack);
348
349 if (fth_string_length(s) <= 0) {
350 FTH_ASSERT_ARGS(FTH_STRING_P(s), s, FTH_ARG1, "a string");
351 /* NOTREACHED */
352 return;
353 }
354 if (fth_string_length(d) <= 0) {
355 FTH_ASSERT_ARGS(FTH_STRING_P(d), d, FTH_ARG2, "a string");
356 /* NOTREACHED */
357 return;
358 }
359 fth_file_symlink(fth_string_ref(s), fth_string_ref(d));
360 }
361
362 void
fth_file_rename(const char * src,const char * dst)363 fth_file_rename(const char *src, const char *dst)
364 {
365 #if defined(HAVE_RENAME)
366 if (rename(src, dst) == -1) {
367 char *buf;
368 size_t size;
369
370 buf = file_scratch;
371 size = sizeof(file_scratch);
372 fth_strcpy(buf, size, src);
373 fth_strcat(buf, size, " --> ");
374 fth_strcat(buf, size, dst);
375 FTH_SYSTEM_ERROR_ARG_THROW(rename, buf);
376 }
377 #else
378 fth_copy_file(src, dst);
379 fth_file_delete(src);
380 #endif
381 }
382
383 static void
ficl_file_rename(ficlVm * vm)384 ficl_file_rename(ficlVm *vm)
385 {
386 #define h_file_rename "( src dst -- ) rename file\n\
387 \"fth\" \"test-fth\" file-rename\n\
388 Rename SRC to DST (see rename(2)). \
389 " h_system_error_info("rename(2)")
390 FTH s, d;
391
392 FTH_STACK_CHECK(vm, 2, 0);
393 d = ficlStackPopFTH(vm->dataStack);
394 s = ficlStackPopFTH(vm->dataStack);
395
396 if (fth_string_length(s) <= 0) {
397 FTH_ASSERT_ARGS(FTH_STRING_P(s), s, FTH_ARG1, "a string");
398 /* NOTREACHED */
399 return;
400 }
401 if (fth_string_length(d) <= 0) {
402 FTH_ASSERT_ARGS(FTH_STRING_P(d), d, FTH_ARG2, "a string");
403 /* NOTREACHED */
404 return;
405 }
406 fth_file_rename(fth_string_ref(s), fth_string_ref(d));
407 }
408
409 void
fth_file_copy(const char * src,const char * dst)410 fth_file_copy(const char *src, const char *dst)
411 {
412 FILE *fpsrc, *fpdst;
413 int c;
414
415 fpsrc = fopen(src, "r");
416
417 if (fpsrc == NULL) {
418 FTH_SYSTEM_ERROR_ARG_THROW(fopen, src);
419 /* NOTREACHED */
420 return;
421 }
422 if (fth_file_directory_p(dst)) {
423 char *buf;
424 size_t size;
425
426 buf = file_scratch;
427 size = sizeof(file_scratch);
428 fth_strcpy(buf, size, dst);
429 fth_strcat(buf, size, "/");
430 fth_strcat(buf, size, src);
431 fpdst = fopen(buf, "w");
432 } else
433 fpdst = fopen(dst, "w");
434
435 if (fpdst == NULL) {
436 FTH_SYSTEM_ERROR_ARG_THROW(fopen, dst);
437 /* NOTREACHED */
438 return;
439 }
440 while ((c = fgetc(fpsrc)) != EOF)
441 fputc(c, fpdst);
442
443 fclose(fpsrc);
444 fclose(fpdst);
445 }
446
447 static void
ficl_file_copy(ficlVm * vm)448 ficl_file_copy(ficlVm *vm)
449 {
450 #define h_file_copy "( src dst -- ) copy file\n\
451 \"fth\" \"test-fth\" file-copy\n\
452 Copy file SRC to DST. \
453 If DST is a directory, copy SRC to DST/SRC. \
454 Raise SYSTEM-ERROR exception if fopen(3) fails on any of the two files."
455 FTH s, d;
456
457 FTH_STACK_CHECK(vm, 2, 0);
458 d = ficlStackPopFTH(vm->dataStack);
459 s = ficlStackPopFTH(vm->dataStack);
460
461 if (fth_string_length(s) <= 0) {
462 FTH_ASSERT_ARGS(FTH_STRING_P(s), s, FTH_ARG1, "a string");
463 /* NOTREACHED */
464 return;
465 }
466 if (fth_string_length(d) <= 0) {
467 FTH_ASSERT_ARGS(FTH_STRING_P(d), d, FTH_ARG2, "a string");
468 /* NOTREACHED */
469 return;
470 }
471 fth_file_copy(fth_string_ref(s), fth_string_ref(d));
472 }
473
474 int
fth_file_install(const char * src,const char * dst,mode_t mode)475 fth_file_install(const char *src, const char *dst, mode_t mode)
476 {
477 struct stat st_src, st_dst;
478 char *buf;
479 size_t size;
480
481 if (src == NULL || dst == NULL)
482 return (0);
483
484 buf = file_scratch;
485 size = sizeof(file_scratch);
486 fth_strcpy(buf, size, dst);
487
488 if (fth_file_directory_p(dst)) {
489 fth_strcat(buf, size, "/");
490 fth_strcat(buf, size, src);
491 }
492 if (!fth_file_exists_p(buf) ||
493 (fth_stat(src, &st_src) != 0 &&
494 fth_stat(buf, &st_dst) != 0 &&
495 st_src.st_mtime > st_dst.st_mtime)) {
496 fth_file_copy(src, buf);
497 fth_file_chmod(buf, mode);
498 return (1);
499 }
500 return (0);
501 }
502
503 static void
ficl_file_install(ficlVm * vm)504 ficl_file_install(ficlVm *vm)
505 {
506 #define h_file_install "( src dst mode -- f ) install file\n\
507 : install-lib { src dst mode -- }\n\
508 src dst mode file-install if\n\
509 \"%s --> %04o %s\" '( src mode dst )\n\
510 else\n\
511 \"%s is up-to-date\" '( dst )\n\
512 then fth-print cr\n\
513 ;\n\
514 \"libsndlib.so\" \"/usr/opt/lib/s7\" 0o755 install-lib\n\
515 Install SRC to DST with access mode MODE \
516 if DST doesn't exist or if modification time of SRC is greater than DST's. \
517 If DST is a directory, install SRC to DST/SRC. \
518 Return #t if SRC could be installed, otherwise #f. " h_mode_info
519 FTH s, d;
520 mode_t mode;
521 int flag;
522
523 FTH_STACK_CHECK(vm, 3, 1);
524 mode = (mode_t) ficlStackPopInteger(vm->dataStack);
525 d = ficlStackPopFTH(vm->dataStack);
526 s = ficlStackPopFTH(vm->dataStack);
527
528 if (fth_string_length(s) <= 0) {
529 FTH_ASSERT_ARGS(FTH_STRING_P(s), s, FTH_ARG1, "a string");
530 /* NOTREACHED */
531 return;
532 }
533 if (fth_string_length(d) <= 0) {
534 FTH_ASSERT_ARGS(FTH_STRING_P(d), d, FTH_ARG2, "a string");
535 /* NOTREACHED */
536 return;
537 }
538 flag = fth_file_install(fth_string_ref(s), fth_string_ref(d), mode);
539 ficlStackPushBoolean(vm->dataStack, flag);
540 }
541
542 FTH
fth_file_split(const char * name)543 fth_file_split(const char *name)
544 {
545 FTH dir, file;
546 char *idx;
547
548 if (name == NULL) {
549 dir = fth_make_empty_string();
550 file = fth_make_empty_string();
551 return (FTH_LIST_2(dir, file));
552 }
553 idx = strrchr(name, '/');
554
555 if (idx == NULL) {
556 dir = fth_make_empty_string();
557 file = fth_make_string(name);
558 return (FTH_LIST_2(dir, file));
559 }
560 dir = fth_make_string_len(name, idx - name);
561 file = fth_make_string(idx + 1);
562 return (FTH_LIST_2(dir, file));
563 }
564
565 static void
ficl_file_split(ficlVm * vm)566 ficl_file_split(ficlVm *vm)
567 {
568 #define h_file_split "( name -- #( path file ) ) split to dir/basename\n\
569 \"/home/mike/cage.snd\" file-split => #( \"/home/mike\" \"cage.snd\" )\n\
570 Split file NAME in dirname and basename and return result in array."
571 FTH fs, res;
572
573 FTH_STACK_CHECK(vm, 1, 1);
574 fs = ficlStackPopFTH(vm->dataStack);
575
576 if (fth_string_length(fs) <= 0) {
577 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
578 /* NOTREACHED */
579 return;
580 }
581 res = fth_file_split(fth_string_ref(fs));
582 ficlStackPushFTH(vm->dataStack, res);
583 }
584
585 FTH
fth_file_basename(const char * name,const char * ext)586 fth_file_basename(const char *name, const char *ext)
587 {
588 char *base;
589 size_t len;
590
591 if (name == NULL)
592 return (fth_make_empty_string());
593
594 base = strrchr(name, '/');
595
596 if (base == NULL)
597 base = (char *) name;
598 else
599 base++;
600
601 if (ext != NULL)
602 len = (size_t) (strstr(base, ext) - base);
603 else
604 len = (size_t) (strchr(base, '.') - base);
605
606 if (len < strlen(base))
607 return (fth_make_string_len(base, (ficlInteger) len));
608
609 return (fth_make_string(base));
610 }
611
612 static void
ficl_file_basename(ficlVm * vm)613 ficl_file_basename(ficlVm *vm)
614 {
615 #define h_file_basename "( name ext -- basename ) return basename\n\
616 \"/home/mike/cage.snd\" #f file-basename => \"cage.snd\"\n\
617 \"/home/mike/cage.snd\" nil file-basename => \"cage\"\n\
618 \"/home/mike/cage.snd\" \"nd\" file-basename => \"cage.s\"\n\
619 \"/home/mike/cage.snd\" /\\.(snd|wave)$/ file-basename => \"cage\"\n\
620 Return basename of file NAME depending on EXT. \
621 EXT may be #f, nil/undef, a string or a regexp. \
622 If EXT is #f, return filename without path name. \
623 If EXT is NIL or UNDEF, discard the part \
624 from the last dot to the end of basename NAME. \
625 If EXT is a string or a regexp, discard found EXT from basename NAME."
626 FTH ext, fs, result;
627 char *name;
628
629 FTH_STACK_CHECK(vm, 2, 1);
630 ext = ficlStackPopFTH(vm->dataStack);
631 fs = ficlStackPopFTH(vm->dataStack);
632
633 if (fth_string_length(fs) <= 0) {
634 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
635 /* NOTREACHED */
636 return;
637 }
638 name = fth_string_ref(fs);
639
640 if (FTH_FALSE_P(ext))
641 result = fth_make_string(fth_basename(name));
642 else if (FTH_NIL_P(ext) || FTH_UNDEF_P(ext))
643 result = fth_file_basename(name, NULL);
644 else if (fth_string_length(ext) > 0)
645 result = fth_file_basename(name, fth_string_ref(ext));
646 else if (FTH_REGEXP_P(ext)) {
647 char *base;
648 ficlInteger len;
649 FTH fbase;
650
651 base = strrchr(name, '/');
652
653 if (base == NULL)
654 base = (char *) name;
655 else
656 base++;
657
658 fbase = fth_make_string(base);
659 len = fth_regexp_search(ext, fbase, 0L, -1L);
660
661 if (len > 0)
662 result = fth_make_string_len(base, len);
663 else
664 result = fbase;
665 } else {
666 FTH_ASSERT_ARGS(0, ext, FTH_ARG2,
667 "a string, regexp, #f or nil");
668 /* NOTREACHED */
669 return;
670 }
671 ficlStackPushFTH(vm->dataStack, result);
672 }
673
674 FTH
fth_file_dirname(const char * name)675 fth_file_dirname(const char *name)
676 {
677 char *base;
678
679 if (name == NULL)
680 return (fth_make_empty_string());
681
682 base = strrchr(name, '/');
683
684 if (base != NULL)
685 return (fth_make_string_len(name, base - name));
686
687 return (fth_make_string("./"));
688 }
689
690 static void
ficl_file_dirname(ficlVm * vm)691 ficl_file_dirname(ficlVm *vm)
692 {
693 #define h_file_dirname "( name -- dirname ) return dirname\n\
694 \"/home/mike/cage.snd\" file-dirname => \"/home/mike\"\n\
695 Return directory part of file NAME."
696 FTH fs, res;
697
698 FTH_STACK_CHECK(vm, 1, 1);
699 fs = ficlStackPopFTH(vm->dataStack);
700 res = fth_file_dirname(fth_string_ref(fs));
701 ficlStackPushFTH(vm->dataStack, res);
702 }
703
704 static void
ficl_file_fullpath(ficlVm * vm)705 ficl_file_fullpath(ficlVm *vm)
706 {
707 #define h_file_fullpath "( name -- fullpath ) return full path\n\
708 \"cage.snd\" file-fullpath => \"/home/mike/cage.snd\"\n\
709 Return current working directory prepended to file NAME. \
710 If name starts with a slash, return NAME unchanged. \
711 " h_system_error_info("getcwd(3)")
712 FTH fs, res;
713 char *name;
714
715 FTH_STACK_CHECK(vm, 1, 1);
716 fs = ficlStackPopFTH(vm->dataStack);
717
718 if (fth_string_length(fs) <= 0) {
719 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
720 /* NOTREACHED */
721 return;
722 }
723 name = fth_string_ref(fs);
724 res = fs;
725
726 if (*name != '/') {
727 char *path;
728
729 path = file_scratch;
730
731 if (getcwd(path, sizeof(file_scratch)) == NULL) {
732 FTH_SYSTEM_ERROR_ARG_THROW(getcwd, path);
733 /* NOTREACHED */
734 return;
735 }
736 res = fth_make_string_format("%s/%s", path, name);
737 }
738 ficlStackPushFTH(vm->dataStack, res);
739 }
740
741 static char file_scratch_02[MAXPATHLEN];
742
743 FTH
fth_file_realpath(const char * name)744 fth_file_realpath(const char *name)
745 {
746 char *resolved, *path;
747 size_t size;
748
749 if (name == NULL)
750 return (fth_make_empty_string());
751
752 /* replace '~' at the beginning with $HOME */
753 path = file_scratch;
754 size = sizeof(file_scratch);
755
756 if (strlen(name) > 0 && *name == '~') {
757 fth_strcpy(path, size, fth_getenv("HOME", "/tmp"));
758 fth_strcat(path, size, name + 1);
759 } else
760 fth_strcpy(path, size, name);
761
762 resolved = file_scratch_02;
763 #if defined(HAVE_REALPATH)
764 if (realpath(path, resolved) == NULL)
765 FTH_SYSTEM_ERROR_ARG_THROW(realpath, resolved);
766 #else
767 fth_strcpy(resolved, size, path);
768 #endif
769 return (fth_make_string(resolved));
770 }
771
772 static void
ficl_file_realpath(ficlVm * vm)773 ficl_file_realpath(ficlVm *vm)
774 {
775 #define h_file_realpath "( path -- resolved-path ) return resolved path\n\
776 \"~\" file-realpath => \"/home/mike\"\n\
777 \"/usr/local\" file-chdir => \"/usr/local\"\n\
778 file-pwd => \"/usr/local\"\n\
779 \"../bin\" file-realpath => \"/usr/bin\"\n\
780 If PATH starts with '~', replace it with content \
781 of environment variable $HOME. \
782 If realpath(3) function exists , return resolved path, \
783 otherwise return PATH with '~' replacement. \
784 " h_system_error_info("realpath(3)")
785 FTH res, fs;
786
787 FTH_STACK_CHECK(vm, 1, 1);
788 fs = ficlStackPopFTH(vm->dataStack);
789 res = fth_file_realpath(fth_string_ref(fs));
790 ficlStackPushFTH(vm->dataStack, res);
791 }
792
793 static void
ficl_file_pwd(ficlVm * vm)794 ficl_file_pwd(ficlVm *vm)
795 {
796 #define h_file_pwd "( -- path ) return working directory\n\
797 file-pwd => \"/home/mike/src\"\n\
798 Return current working directory (see getcwd(3)). \
799 " h_system_error_info("getcwd(3)")
800 char *path;
801
802 FTH_STACK_CHECK(vm, 0, 1);
803 path = file_scratch;
804
805 if (getcwd(path, sizeof(file_scratch)) == NULL) {
806 FTH_SYSTEM_ERROR_ARG_THROW(getcwd, path);
807 /* NOTREACHED */
808 return;
809 }
810 push_cstring(vm, path);
811 }
812
813 static void
ficl_file_chdir(ficlVm * vm)814 ficl_file_chdir(ficlVm *vm)
815 {
816 #define h_file_chdir "( path -- ) change working directory\n\
817 \"/usr/local\" file-chdir => prints \"/usr/local\"\n\
818 Change working directory to PATH and, \
819 if in a repl, print result to current standard output. \
820 If PATH is NIL, change working directory to $HOME. \
821 PATH may contain `~' as an abbreviation for home directory (see chdir(2)). \
822 " h_system_error_and_not_implemented_info("chdir(2)")
823 char *path;
824 FTH dir;
825
826 FTH_STACK_CHECK(vm, 1, 0);
827 dir = fth_pop_ficl_cell(vm);
828 #if defined(HAVE_CHDIR)
829 if (FTH_NIL_P(dir))
830 path = fth_getenv("HOME", "/tmp");
831 else
832 path = fth_string_ref(fth_file_realpath(fth_string_ref(dir)));
833
834 if (chdir(path) == -1)
835 FTH_SYSTEM_ERROR_ARG_THROW(chdir, path);
836
837 if (CELL_INT_REF(&FTH_FICL_VM()->sourceId) == -1)
838 fth_print(path);
839 #else
840 FTH_NOT_IMPLEMENTED_ERROR(chdir);
841 #endif
842 }
843
844 static void
ficl_file_truncate(ficlVm * vm)845 ficl_file_truncate(ficlVm *vm)
846 {
847 #define h_file_truncate "( name size -- ) truncate file\n\
848 \"big-test.file\" 1024 file-truncate\n\
849 Truncate or extend file NAME to SIZE bytes (see truncate(2)). \
850 " h_system_error_and_not_implemented_info("truncate(2)")
851 char *path;
852 ficl2Unsigned size;
853
854 FTH_STACK_CHECK(vm, 2, 0);
855 size = ficlStackPop2Unsigned(vm->dataStack);
856 path = pop_cstring(vm);
857 #if defined(HAVE_TRUNCATE)
858 if (path != NULL)
859 if (truncate(path, (off_t) size) == -1)
860 FTH_SYSTEM_ERROR_ARG_THROW(truncate, path);
861 #else
862 FTH_NOT_IMPLEMENTED_ERROR(truncate);
863 #endif
864 }
865
866 static void
ficl_file_chroot(ficlVm * vm)867 ficl_file_chroot(ficlVm *vm)
868 {
869 #define h_file_chroot "( path -- ) change root directory\n\
870 \"/usr/local/var/ftp\" file-chroot\n\
871 Change root directory to PATH and, \
872 if in a repl, print result to current standard output. \
873 This function is restricted to the super-user (see chroot(2)). \
874 " h_system_error_and_not_implemented_info("chroot(2)")
875 char *path;
876
877 FTH_STACK_CHECK(vm, 1, 0);
878 path = pop_cstring(vm);
879 #if defined(HAVE_CHROOT)
880 if (path != NULL) {
881 if (chroot(path) == -1)
882 FTH_SYSTEM_ERROR_ARG_THROW(chroot, path);
883
884 if (CELL_INT_REF(&vm->sourceId) == -1)
885 fth_print(path);
886 }
887 #else
888 FTH_NOT_IMPLEMENTED_ERROR(chroot);
889 #endif
890 }
891
892 static void
ficl_file_eval(ficlVm * vm)893 ficl_file_eval(ficlVm *vm)
894 {
895 #define h_file_eval "( name -- ) load and eval file\n\
896 \"test.fs\" file-eval\n\
897 Load and eval content of file NAME \
898 and add NAME to *loaded-files* if it wasn't there. \
899 It's similar to INCLUDE except that filename \
900 must be on stack (INCLUDE is a parseword). \
901 With file-eval one can load files from within word definitions. \
902 Raise LOAD-ERROR exception if file-eval fails.\n\
903 See also include and require."
904 FTH fs;
905
906 FTH_STACK_CHECK(vm, 1, 0);
907 fs = ficlStackPopFTH(vm->dataStack);
908
909 if (fth_string_length(fs) <= 0) {
910 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
911 /* NOTREACHED */
912 return;
913 }
914 fth_load_file(fth_string_ref(fs));
915 }
916
917 static void
ficl_file_shell(ficlVm * vm)918 ficl_file_shell(ficlVm *vm)
919 {
920 #define h_file_shell "( cmd -- str ) execute command\n\
921 \"pwd\" file-shell string-chomp => \"/home/mike\"\n\
922 Open pipe for reading, feed it with CMD \
923 and collect string output as long as pipe is open. \
924 Afterwards close pipe, set read-only variable EXIT-STATUS \
925 and return collected string (with trailing CR).\n\
926 See also file-system and exit-status."
927 FTH cmd, io, fs;
928 char *line;
929
930 FTH_STACK_CHECK(vm, 1, 1);
931 cmd = fth_pop_ficl_cell(vm);
932 io = fth_io_popen(cmd, FICL_FAM_READ);
933 fs = fth_make_empty_string();
934
935 while ((line = fth_io_read(io)) != NULL)
936 fth_string_scat(fs, line);
937
938 fth_io_close(io);
939 ficlStackPushFTH(vm->dataStack, fs);
940 }
941
942 static void
ficl_file_system(ficlVm * vm)943 ficl_file_system(ficlVm *vm)
944 {
945 #define h_file_system "( cmd -- f ) execute command\n\
946 \"pwd\" file-system => #t\n\
947 Execute CMD as a shell command. \
948 Set read-only variable EXIT-STATUS and return #t for success, #f otherwise. \
949 In the latter case you can check EXIT-STATUS.\n\
950 See also file-shell and exit-status."
951 FTH fs;
952 int flag;
953
954 FTH_STACK_CHECK(vm, 1, 1);
955 fs = ficlStackPopFTH(vm->dataStack);
956
957 if (fth_string_length(fs) <= 0) {
958 FTH_ASSERT_ARGS(FTH_STRING_P(fs), fs, FTH_ARG1, "a string");
959 /* NOTREACHED */
960 return;
961 }
962 flag = fth_set_exit_status(system(fth_string_ref(fs))) == 0;
963 ficlStackPushBoolean(vm->dataStack, flag);
964 }
965
966 /* --- Forth-like file functions --- */
967
968 static void
ficl_open_pipe(ficlVm * vm)969 ficl_open_pipe(ficlVm *vm)
970 {
971 #define h_open_pipe "( addr u fam -- fp ior ) open pipe\n\
972 256 constant max-line\n\
973 create line-buffer max-line 2 + allot\n\
974 s\" pwd\" r/o open-pipe throw value FP\n\
975 line-buffer max-line FP read-line throw drop line-buffer swap type\n\
976 FP close-pipe throw\n\
977 Forth-like word.\n\
978 See also close-pipe, open-file, close-file."
979 ficlInteger fam;
980 size_t len;
981 char *mode, *cmd, *str;
982 FILE *fp;
983
984 FTH_STACK_CHECK(vm, 3, 2);
985 fam = ficlStackPopInteger(vm->dataStack);
986 len = (size_t) ficlStackPopUnsigned(vm->dataStack);
987 str = ficlStackPopPointer(vm->dataStack);
988
989 if (len == 0) {
990 ficlStackPushPointer(vm->dataStack, NULL);
991 ficlStackPushInteger(vm->dataStack, (ficlInteger) EINVAL);
992 return;
993 }
994 switch (FICL_FAM_OPEN_MODE(fam)) {
995 case FICL_FAM_READ:
996 mode = "r";
997 break;
998 case FICL_FAM_WRITE:
999 mode = "w";
1000 break;
1001 default:
1002 ficlStackPushPointer(vm->dataStack, NULL);
1003 ficlStackPushInteger(vm->dataStack, (ficlInteger) EINVAL);
1004 return;
1005 break;
1006 }
1007
1008 cmd = FTH_CALLOC(len + 1, sizeof(char));
1009 strncpy(cmd, str, len);
1010 fp = popen(cmd, mode);
1011
1012 if (fp == NULL) {
1013 perror("popen");
1014 ficlStackPushPointer(vm->dataStack, NULL);
1015 ficlStackPushInteger(vm->dataStack, (ficlInteger) errno);
1016 } else {
1017 ficlFile *ff;
1018
1019 ff = FTH_MALLOC(sizeof(ficlFile));
1020 ff->f = fp;
1021 ficlStackPushPointer(vm->dataStack, ff);
1022 ficlStackPushInteger(vm->dataStack, 0L);
1023 }
1024 FTH_FREE(cmd);
1025 }
1026
1027 static void
ficl_close_pipe(ficlVm * vm)1028 ficl_close_pipe(ficlVm *vm)
1029 {
1030 #define h_close_pipe "( fp -- ior ) close pipe\n\
1031 256 constant max-line\n\
1032 create line-buffer max-line 2 + allot\n\
1033 s\" pwd\" r/o open-pipe throw value FP\n\
1034 line-buffer max-line FP read-line throw drop line-buffer swap type\n\
1035 FP close-pipe throw\n\
1036 Forth-like word.\n\
1037 See also open-pipe, open-file, close-file."
1038 ficlFile *ff;
1039 int stat;
1040
1041 FTH_STACK_CHECK(vm, 1, 1);
1042 ff = (ficlFile *) ficlStackPopPointer(vm->dataStack);
1043 stat = fth_set_exit_status(pclose(ff->f));
1044 FTH_FREE(ff);
1045 ficlStackPushInteger(vm->dataStack, (ficlInteger) stat);
1046 }
1047
1048 /* === File Test Functions === */
1049
1050 #define MAKE_FILE_TEST_WORD(Name, Opt, Desc) \
1051 static void \
1052 ficl_file_ ## Name ## _p(ficlVm *vm) \
1053 { \
1054 int flag; \
1055 \
1056 FTH_STACK_CHECK(vm, 1, 1); \
1057 flag = fth_file_ ## Name ## _p(pop_cstring(vm)); \
1058 ficlStackPushBoolean(vm->dataStack, flag); \
1059 } \
1060 static char* h_file_ ## Name ## _p = \
1061 "( name -- f ) test if NAME " Desc "\n\
1062 \"abc\" file-" #Name "? => #t|#f\n\
1063 Return #t if NAME " Desc ", otherwise #f (see test(1) option -" #Opt ")."
1064
1065 static mode_t
fth_stat(const char * name,struct stat * buf)1066 fth_stat(const char *name, struct stat * buf)
1067 {
1068 buf->st_mode = 0;
1069 #if defined(HAVE_LSTAT)
1070 if (fth_strlen(name) > 0)
1071 lstat(name, buf);
1072 #else
1073 FTH_NOT_IMPLEMENTED_ERROR(lstat);
1074 #endif
1075 return (buf->st_mode);
1076 }
1077
1078 int
fth_file_block_p(const char * name)1079 fth_file_block_p(const char *name)
1080 {
1081 struct stat buf;
1082
1083 return (S_ISBLK(fth_stat(name, &buf)));
1084 }
1085
1086 MAKE_FILE_TEST_WORD(block, b, "is a block special file");
1087
1088 int
fth_file_character_p(const char * name)1089 fth_file_character_p(const char *name)
1090 {
1091 struct stat buf;
1092
1093 return (S_ISCHR(fth_stat(name, &buf)));
1094 }
1095
1096 MAKE_FILE_TEST_WORD(character, c, "is a character special file");
1097
1098 int
fth_file_directory_p(const char * name)1099 fth_file_directory_p(const char *name)
1100 {
1101 struct stat buf;
1102
1103 return (S_ISDIR(fth_stat(name, &buf)));
1104 }
1105
1106 MAKE_FILE_TEST_WORD(directory, d, "is a directory");
1107
1108 int
fth_file_exists_p(const char * name)1109 fth_file_exists_p(const char *name)
1110 {
1111 int flag;
1112 int old_errno;
1113
1114 flag = 0;
1115 old_errno = errno;
1116
1117 if (name != NULL && *name != '\0' && FTH_ACCESS_P(name, F_OK))
1118 flag = 1;
1119
1120 errno = old_errno;
1121 return (flag);
1122 }
1123
1124 static void
ficl_file_exists_p(ficlVm * vm)1125 ficl_file_exists_p(ficlVm *vm)
1126 {
1127 #define h_file_exists_p "( name -- f ) test if file exists\n\
1128 \"abc\" file-exists? => #t|#f\n\
1129 Return #t if NAME is an existing file, otherwise #f."
1130 int flag;
1131
1132 FTH_STACK_CHECK(vm, 1, 1);
1133 flag = fth_file_exists_p(pop_cstring(vm));
1134 ficlStackPushBoolean(vm->dataStack, flag);
1135 }
1136
1137 int
fth_file_fifo_p(const char * name)1138 fth_file_fifo_p(const char *name)
1139 {
1140 struct stat buf;
1141
1142 return (S_ISFIFO(fth_stat(name, &buf)));
1143 }
1144
1145 MAKE_FILE_TEST_WORD(fifo, p, "is a named pipe");
1146
1147 int
fth_file_symlink_p(const char * name)1148 fth_file_symlink_p(const char *name)
1149 {
1150 #if defined(_WIN32)
1151 return (0);
1152 #else
1153 struct stat buf;
1154
1155 return (S_ISLNK(fth_stat(name, &buf)));
1156 #endif
1157 }
1158
1159 MAKE_FILE_TEST_WORD(symlink, L, "is a symbolic link");
1160
1161 int
fth_file_socket_p(const char * name)1162 fth_file_socket_p(const char *name)
1163 {
1164 #if !defined(HAVE_SYS_SOCKET_H)
1165 return (0);
1166 #else
1167 struct stat buf;
1168
1169 return (S_ISSOCK(fth_stat(name, &buf)));
1170 #endif
1171 }
1172
1173 MAKE_FILE_TEST_WORD(socket, S, "is a socket");
1174
1175 int
fth_file_executable_p(const char * name)1176 fth_file_executable_p(const char *name)
1177 {
1178 #if defined(HAVE_GETEUID) && defined(HAVE_GETEGID)
1179 struct stat buf;
1180
1181 if (fth_stat(name, &buf)) {
1182 #if defined(S_IXUSR)
1183 if (buf.st_uid == geteuid())
1184 return (buf.st_mode & S_IXUSR);
1185 #endif
1186 #if defined(S_IXGRP)
1187 if (buf.st_gid == getegid())
1188 return (buf.st_mode & S_IXGRP);
1189 #endif
1190 #if defined(S_IXOTH)
1191 return (buf.st_mode & S_IXOTH);
1192 #endif
1193 }
1194 #endif /* HAVE_GETEUID */
1195 return (0);
1196 }
1197
1198 MAKE_FILE_TEST_WORD(executable, x, "is an executable file");
1199
1200 int
fth_file_readable_p(const char * name)1201 fth_file_readable_p(const char *name)
1202 {
1203 #if defined(HAVE_GETEUID) && defined(HAVE_GETEGID)
1204 struct stat buf;
1205
1206 if (fth_stat(name, &buf)) {
1207 #if defined(S_IRUSR)
1208 if (buf.st_uid == geteuid())
1209 return (buf.st_mode & S_IRUSR);
1210 #endif
1211 #if defined(S_IRGRP)
1212 if (buf.st_gid == getegid())
1213 return (buf.st_mode & S_IRGRP);
1214 #endif
1215 #if defined(S_IROTH)
1216 return (buf.st_mode & S_IROTH);
1217 #endif
1218 }
1219 #endif /* HAVE_GETEUID */
1220 return (0);
1221 }
1222
1223 MAKE_FILE_TEST_WORD(readable, r, "is a readable file");
1224
1225 int
fth_file_writable_p(const char * name)1226 fth_file_writable_p(const char *name)
1227 {
1228 #if defined(HAVE_GETEUID) && defined(HAVE_GETEGID)
1229 struct stat buf;
1230
1231 if (fth_stat(name, &buf)) {
1232 #if defined(S_IWUSR)
1233 if (buf.st_uid == geteuid())
1234 return (buf.st_mode & S_IWUSR);
1235 #endif
1236 #if defined(S_IWGRP)
1237 if (buf.st_gid == getegid())
1238 return (buf.st_mode & S_IWGRP);
1239 #endif
1240 #if defined(S_IWOTH)
1241 return (buf.st_mode & S_IWOTH);
1242 #endif
1243 }
1244 #endif /* HAVE_GETEUID */
1245 return (0);
1246 }
1247
1248 MAKE_FILE_TEST_WORD(writable, w, "is a writable file");
1249
1250 int
fth_file_owned_p(const char * name)1251 fth_file_owned_p(const char *name)
1252 {
1253 #if defined(HAVE_GETEUID)
1254 struct stat buf;
1255
1256 if (fth_stat(name, &buf))
1257 return (buf.st_uid == geteuid());
1258 #endif
1259 return (0);
1260 }
1261
1262 MAKE_FILE_TEST_WORD(owned, O, "matches effective uid");
1263
1264 int
fth_file_grpowned_p(const char * name)1265 fth_file_grpowned_p(const char *name)
1266 {
1267 #if defined(HAVE_GETEUID)
1268 struct stat buf;
1269
1270 if (fth_stat(name, &buf))
1271 return (buf.st_gid == geteuid());
1272 #endif
1273 return (0);
1274 }
1275
1276 MAKE_FILE_TEST_WORD(grpowned, G, "matches effective gid");
1277
1278 int
fth_file_setuid_p(const char * name)1279 fth_file_setuid_p(const char *name)
1280 {
1281 #if defined(S_ISUID)
1282 struct stat buf;
1283
1284 if (fth_stat(name, &buf))
1285 return (buf.st_mode & S_ISUID);
1286 #endif
1287 return (0);
1288 }
1289
1290 MAKE_FILE_TEST_WORD(setuid, u, "has set uid bit");
1291
1292 int
fth_file_setgid_p(const char * name)1293 fth_file_setgid_p(const char *name)
1294 {
1295 #if defined(S_ISGID)
1296 struct stat buf;
1297
1298 if (fth_stat(name, &buf))
1299 return (buf.st_mode & S_ISGID);
1300 #endif
1301 return (0);
1302 }
1303
1304 MAKE_FILE_TEST_WORD(setgid, g, "has set gid bit");
1305
1306 int
fth_file_sticky_p(const char * name)1307 fth_file_sticky_p(const char *name)
1308 {
1309 #if defined(S_ISVTX)
1310 struct stat buf;
1311
1312 if (fth_stat(name, &buf))
1313 return (buf.st_mode & S_ISVTX);
1314 #endif
1315 return (0);
1316 }
1317
1318 MAKE_FILE_TEST_WORD(sticky, k, "has set sticky bit");
1319
1320 int
fth_file_zero_p(const char * name)1321 fth_file_zero_p(const char *name)
1322 {
1323 struct stat buf;
1324
1325 if (fth_stat(name, &buf))
1326 return (buf.st_size == 0);
1327 return (0);
1328 }
1329
1330 static void
ficl_file_zero_p(ficlVm * vm)1331 ficl_file_zero_p(ficlVm *vm)
1332 {
1333 #define h_file_zero_p "( name -- f ) test if file length is zero\n\
1334 \"abc\" file-zero?\n\
1335 Return #t if file NAME length is zero, otherwise #f."
1336 int flag;
1337
1338 FTH_STACK_CHECK(vm, 1, 1);
1339 flag = fth_file_zero_p(pop_cstring(vm));
1340 ficlStackPushBoolean(vm->dataStack, flag);
1341 }
1342
1343 FTH
fth_file_length(const char * name)1344 fth_file_length(const char *name)
1345 {
1346 struct stat buf;
1347
1348 if (fth_stat(name, &buf))
1349 return (fth_make_long_long((ficl2Integer) buf.st_size));
1350 return (FTH_FALSE);
1351 }
1352
1353 static void
ficl_file_length(ficlVm * vm)1354 ficl_file_length(ficlVm *vm)
1355 {
1356 #define h_file_length "( name -- len ) return file length\n\
1357 \"abc\" file-length => 1024\n\
1358 If NAME is a file, return its length in bytes, otherwise #f."
1359 FTH res;
1360
1361 FTH_STACK_CHECK(vm, 1, 1);
1362 res = fth_file_length(pop_cstring(vm));
1363 fth_push_ficl_cell(vm, res);
1364 }
1365
1366 FTH
fth_file_atime(const char * name)1367 fth_file_atime(const char *name)
1368 {
1369 struct stat buf;
1370
1371 if (fth_stat(name, &buf))
1372 return (fth_make_long_long((ficl2Integer) buf.st_atime));
1373 return (FTH_FALSE);
1374 }
1375
1376 static void
ficl_file_atime(ficlVm * vm)1377 ficl_file_atime(ficlVm *vm)
1378 {
1379 #define h_file_atime "( name -- time ) return file access\n\
1380 \"abc\" file-atime time->string => \"Mon Aug 23 01:24:02 CEST 2010\"\n\
1381 If NAME is a file, return its last access time, otherwise #f. \
1382 One can convert the number in a readable string with time->string.\n\
1383 See also file-ctime, file-mtime and time->string."
1384 FTH res;
1385
1386 FTH_STACK_CHECK(vm, 1, 1);
1387 res = fth_file_atime(pop_cstring(vm));
1388 fth_push_ficl_cell(vm, res);
1389 }
1390
1391 FTH
fth_file_ctime(const char * name)1392 fth_file_ctime(const char *name)
1393 {
1394 struct stat buf;
1395
1396 if (fth_stat(name, &buf))
1397 return (fth_make_long_long((ficl2Integer) buf.st_ctime));
1398 return (FTH_FALSE);
1399 }
1400
1401 static void
ficl_file_ctime(ficlVm * vm)1402 ficl_file_ctime(ficlVm *vm)
1403 {
1404 #define h_file_ctime "( name -- time ) return file change time\n\
1405 \"abc\" file-ctime time->string => \"Mon Aug 23 01:24:02 CEST 2010\"\n\
1406 If NAME is a file, return its status change time, otherwise #f. \
1407 One can convert the number in a readable string with time->string.\n\
1408 See also file-atime, file-mtime and time->string."
1409 FTH res;
1410
1411 FTH_STACK_CHECK(vm, 1, 1);
1412 res = fth_file_ctime(pop_cstring(vm));
1413 fth_push_ficl_cell(vm, res);
1414 }
1415
1416 FTH
fth_file_mtime(const char * name)1417 fth_file_mtime(const char *name)
1418 {
1419 struct stat buf;
1420
1421 if (fth_stat(name, &buf))
1422 return (fth_make_long_long((ficl2Integer) buf.st_mtime));
1423 return (FTH_FALSE);
1424 }
1425
1426 static void
ficl_file_mtime(ficlVm * vm)1427 ficl_file_mtime(ficlVm *vm)
1428 {
1429 #define h_file_mtime "( name -- time ) return file modification time\n\
1430 \"abc\" file-mtime time->string => \"Mon Aug 23 01:24:02 CEST 2010\"\n\
1431 If NAME is a file, return its last modification time, otherwise #f. \
1432 One can convert the number in a readable string with time->string.\n\
1433 See also file-atime, file-ctime and time->string."
1434 FTH res;
1435
1436 FTH_STACK_CHECK(vm, 1, 1);
1437 res = fth_file_mtime(pop_cstring(vm));
1438 fth_push_ficl_cell(vm, res);
1439 }
1440
1441 #if defined(HAVE_UTIMES)
1442 #if defined(HAVE_SYS_TIME_H)
1443 #include <sys/time.h>
1444 #endif
1445 #if defined(HAVE_TIME_H)
1446 #include <time.h>
1447 #endif
1448 #endif
1449
1450 static void
ficl_file_touch(ficlVm * vm)1451 ficl_file_touch(ficlVm *vm)
1452 {
1453 #define h_file_touch "( name time|nil -- ) change file modification time\n\
1454 \"foo.bar\" current-time file-touch\n\
1455 \"foo.bar\" nil file-touch\n\
1456 Change modification time of NAME to TIME. \
1457 If TIME is nil, use current time. \
1458 " h_system_error_info("utimes(2)")
1459 FTH tm;
1460 char *name;
1461
1462 FTH_STACK_CHECK(vm, 2, 0);
1463 tm = fth_pop_ficl_cell(vm);
1464 name = pop_cstring(vm);
1465
1466 if (name == NULL)
1467 return;
1468
1469 if (!fth_file_exists_p(name)) {
1470 FILE *fp;
1471
1472 fp = fopen(name, "w");
1473
1474 if (fp == NULL)
1475 FTH_SYSTEM_ERROR_ARG_THROW(fopen, name);
1476
1477 fclose(fp);
1478 }
1479 #if defined(HAVE_UTIMES)
1480 if (FTH_NUMBER_P(tm)) { /* use specified time */
1481 static struct timeval tv[2];
1482
1483 /*-
1484 * tv[0]: access time
1485 * tv[1]: modification time
1486 */
1487 tv[0].tv_sec = (time_t) fth_ulong_long_ref(tm);
1488 tv[0].tv_usec = 0;
1489 tv[1] = tv[0];
1490
1491 if (utimes(name, tv) == -1)
1492 FTH_SYSTEM_ERROR_ARG_THROW(utimes, name);
1493 } else if (utimes(name, NULL) == -1) /* use current time */
1494 FTH_SYSTEM_ERROR_ARG_THROW(utimes, name);
1495 #endif
1496 }
1497
1498 /* === DIRECTORY === */
1499
1500 #if defined(HAVE_DIRENT_H)
1501 #include <dirent.h>
1502 #endif
1503
1504 static void
ficl_file_dir(ficlVm * vm)1505 ficl_file_dir(ficlVm *vm)
1506 {
1507 #define h_file_dir "( dir -- files-array ) return files in dir\n\
1508 \".\" file-dir => #( \"./xdef\" \"./xdef.bak\" ... )\n\
1509 Return an array of all filenames found in DIR. \
1510 " h_system_error_info("opendir(3)")
1511 FTH dir, res;
1512
1513 FTH_STACK_CHECK(vm, 1, 1);
1514 dir = ficlStackPopFTH(vm->dataStack);
1515 res = fth_file_match_dir(dir, fth_make_regexp(".*"));
1516 ficlStackPushFTH(vm->dataStack, res);
1517 }
1518
1519 FTH
fth_file_match_dir(FTH string,FTH regexp)1520 fth_file_match_dir(FTH string, FTH regexp)
1521 {
1522 #define h_f_match_dir "( dir reg -- files-array ) return matching files\n\
1523 \".\" /(bak|out)$/ file-match-dir\n\
1524 => #( \"./xdef.bak\" \"./xdef.out\" ... )\n\
1525 Return an array of filenames in DIR matching regexp REG. \
1526 " h_system_error_info("opendir(3)")
1527 #if defined(HAVE_OPENDIR)
1528 FTH array, fs;
1529 DIR *dir;
1530 char *path, *npath;
1531 struct dirent *d;
1532 size_t len, flen;
1533
1534 array = fth_make_empty_array();
1535
1536 if (!FTH_STRING_P(string))
1537 return (array);
1538
1539 len = (size_t) fth_string_length(string);
1540 path = fth_string_ref(string);
1541
1542 if (len > 1 && path[len - 1] == '/')
1543 path[len - 1] = '\0';
1544
1545 dir = opendir(path);
1546
1547 if (dir == NULL) {
1548 FTH_SYSTEM_ERROR_ARG_THROW(opendir, path);
1549 /* NOTREACHED */
1550 return (FTH_FALSE);
1551 }
1552 if (FTH_STRING_P(regexp))
1553 regexp = fth_make_regexp(fth_string_ref(regexp));
1554
1555 while ((d = readdir(dir)) != NULL) {
1556 npath = (len == 1 && path[0] == '/') ? "" : path;
1557 #if defined(HAVE_STRUCT_DIRENT_D_NAMLEN)
1558 flen = d->d_namlen;
1559 #else
1560 flen = fth_strlen(d->d_name);
1561 #endif
1562 #if defined(HAVE_STRUCT_DIRENT_D_INO)
1563 if (d->d_ino == 0) /* skip deleted files */
1564 continue;
1565 #elif defined(HAVE_STRUCT_DIRENT_D_FILENO)
1566 if (d->d_fileno == 0)
1567 continue;
1568 #endif
1569 if (flen == 1 &&
1570 d->d_name[0] == '.')
1571 continue;
1572
1573 if (flen == 2 &&
1574 d->d_name[0] == '.' &&
1575 d->d_name[1] == '.')
1576 continue;
1577
1578 fs = fth_make_string(d->d_name);
1579
1580 if (fth_regexp_search(regexp, fs, 0L, -1L) >= 0) {
1581 FTH s;
1582
1583 s = fth_make_string_format("%s/%.*s",
1584 npath, flen, d->d_name);
1585 fth_array_push(array, s);
1586 }
1587 }
1588
1589 if (closedir(dir) == -1)
1590 FTH_SYSTEM_ERROR_ARG_THROW(closedir, path);
1591
1592 return (array);
1593 #else /* !HAVE_OPENDIR */
1594 return (fth_make_empty_array());
1595 #endif /* HAVE_OPENDIR */
1596 }
1597
1598 void
init_file(void)1599 init_file(void)
1600 {
1601 /* file */
1602 FTH_PRI1("file-delete", ficl_file_delete, h_file_delete);
1603 FTH_PRI1("file-chmod", ficl_file_chmod, h_file_chmod);
1604 FTH_PRI1("file-mkdir", ficl_file_mkdir, h_file_mkdir);
1605 FTH_PRI1("file-rmdir", ficl_file_rmdir, h_file_rmdir);
1606 FTH_PRI1("file-mkfifo", ficl_file_mkfifo, h_file_mkfifo);
1607 FTH_PRI1("file-symlink", ficl_file_symlink, h_file_symlink);
1608 FTH_PRI1("file-rename", ficl_file_rename, h_file_rename);
1609 FTH_PRI1("file-copy", ficl_file_copy, h_file_copy);
1610 FTH_PRI1("file-install", ficl_file_install, h_file_install);
1611 FTH_PRI1("file-split", ficl_file_split, h_file_split);
1612 FTH_PRI1("file-basename", ficl_file_basename, h_file_basename);
1613 FTH_PRI1("file-dirname", ficl_file_dirname, h_file_dirname);
1614 FTH_PRI1("file-fullpath", ficl_file_fullpath, h_file_fullpath);
1615 FTH_PRI1("file-realpath", ficl_file_realpath, h_file_realpath);
1616 FTH_PRI1("file-pwd", ficl_file_pwd, h_file_pwd);
1617 FTH_PRI1("file-chdir", ficl_file_chdir, h_file_chdir);
1618 FTH_PRI1("chdir", ficl_file_chdir, h_file_chdir);
1619 FTH_PRI1("file-truncate", ficl_file_truncate, h_file_truncate);
1620 FTH_PRI1("file-chroot", ficl_file_chroot, h_file_chroot);
1621 FTH_PRI1("file-eval", ficl_file_eval, h_file_eval);
1622 FTH_PRI1("file-shell", ficl_file_shell, h_file_shell);
1623 FTH_PRI1("shell", ficl_file_shell, h_file_shell);
1624 FTH_PRI1("file-system", ficl_file_system, h_file_system);
1625 FTH_PRI1("open-pipe", ficl_open_pipe, h_open_pipe);
1626 FTH_PRI1("close-pipe", ficl_close_pipe, h_close_pipe);
1627
1628 /* file test */
1629 FTH_PRI1("file-block?", ficl_file_block_p, h_file_block_p);
1630 FTH_PRI1("file-character?", ficl_file_character_p, h_file_character_p);
1631 FTH_PRI1("file-directory?", ficl_file_directory_p, h_file_directory_p);
1632 FTH_PRI1("file-exists?", ficl_file_exists_p, h_file_exists_p);
1633 FTH_PRI1("file-fifo?", ficl_file_fifo_p, h_file_fifo_p);
1634 FTH_PRI1("file-symlink?", ficl_file_symlink_p, h_file_symlink_p);
1635 FTH_PRI1("file-socket?", ficl_file_socket_p, h_file_socket_p);
1636 FTH_PRI1("file-executable?", ficl_file_executable_p, h_file_executable_p);
1637 FTH_PRI1("file-readable?", ficl_file_readable_p, h_file_readable_p);
1638 FTH_PRI1("file-writable?", ficl_file_writable_p, h_file_writable_p);
1639 FTH_PRI1("file-owned?", ficl_file_owned_p, h_file_owned_p);
1640 FTH_PRI1("file-grpowned?", ficl_file_grpowned_p, h_file_grpowned_p);
1641 FTH_PRI1("file-setuid?", ficl_file_setuid_p, h_file_setuid_p);
1642 FTH_PRI1("file-setgid?", ficl_file_setgid_p, h_file_setgid_p);
1643 FTH_PRI1("file-sticky?", ficl_file_sticky_p, h_file_sticky_p);
1644 FTH_PRI1("file-zero?", ficl_file_zero_p, h_file_zero_p);
1645 FTH_PRI1("file-length", ficl_file_length, h_file_length);
1646 FTH_PRI1("file-atime", ficl_file_atime, h_file_atime);
1647 FTH_PRI1("file-ctime", ficl_file_ctime, h_file_ctime);
1648 FTH_PRI1("file-mtime", ficl_file_mtime, h_file_mtime);
1649 FTH_PRI1("file-touch", ficl_file_touch, h_file_touch);
1650 FTH_PRI1("file-dir", ficl_file_dir, h_file_dir);
1651 FTH_PROC("file-match-dir", fth_file_match_dir, 2, 0, 0, h_f_match_dir);
1652 FTH_ADD_FEATURE_AND_INFO("file", h_list_of_file_functions);
1653 }
1654
1655 /*
1656 * file.c ends here
1657 */
1658