1 /*
2 * Copyright (c) 2021 Calvin Rose
3 *
4 * Permission is hereby granted, free of charge, to any person obtaining a copy
5 * of this software and associated documentation files (the "Software"), to
6 * deal in the Software without restriction, including without limitation the
7 * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
8 * sell copies of the Software, and to permit persons to whom the Software is
9 * furnished to do so, subject to the following conditions:
10 *
11 * The above copyright notice and this permission notice shall be included in
12 * all copies or substantial portions of the Software.
13 *
14 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
15 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
16 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
17 * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
18 * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
19 * FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
20 * IN THE SOFTWARE.
21 */
22
23 #ifndef JANET_AMALG
24 #include "features.h"
25 #include <janet.h>
26 #include "util.h"
27 #endif
28
29 #include <stdio.h>
30 #include <errno.h>
31
32 #ifndef JANET_WINDOWS
33 #include <fcntl.h>
34 #include <sys/wait.h>
35 #include <unistd.h>
36 #endif
37
38 static int cfun_io_gc(void *p, size_t len);
39 static int io_file_get(void *p, Janet key, Janet *out);
40 static void io_file_marshal(void *p, JanetMarshalContext *ctx);
41 static void *io_file_unmarshal(JanetMarshalContext *ctx);
42 static Janet io_file_next(void *p, Janet key);
43
44 const JanetAbstractType janet_file_type = {
45 "core/file",
46 cfun_io_gc,
47 NULL,
48 io_file_get,
49 NULL,
50 io_file_marshal,
51 io_file_unmarshal,
52 NULL, /* tostring */
53 NULL, /* compare */
54 NULL, /* hash */
55 io_file_next,
56 JANET_ATEND_NEXT
57 };
58
59 /* Check arguments to fopen */
checkflags(const uint8_t * str)60 static int32_t checkflags(const uint8_t *str) {
61 int32_t flags = 0;
62 int32_t i;
63 int32_t len = janet_string_length(str);
64 if (!len || len > 10)
65 janet_panic("file mode must have a length between 1 and 10");
66 switch (*str) {
67 default:
68 janet_panicf("invalid flag %c, expected w, a, or r", *str);
69 break;
70 case 'w':
71 flags |= JANET_FILE_WRITE;
72 break;
73 case 'a':
74 flags |= JANET_FILE_APPEND;
75 break;
76 case 'r':
77 flags |= JANET_FILE_READ;
78 break;
79 }
80 for (i = 1; i < len; i++) {
81 switch (str[i]) {
82 default:
83 janet_panicf("invalid flag %c, expected +, b, or n", str[i]);
84 break;
85 case '+':
86 if (flags & JANET_FILE_UPDATE) return -1;
87 flags |= JANET_FILE_UPDATE;
88 break;
89 case 'b':
90 if (flags & JANET_FILE_BINARY) return -1;
91 flags |= JANET_FILE_BINARY;
92 break;
93 case 'n':
94 if (flags & JANET_FILE_NONIL) return -1;
95 flags |= JANET_FILE_NONIL;
96 break;
97 }
98 }
99 return flags;
100 }
101
makef(FILE * f,int32_t flags)102 static void *makef(FILE *f, int32_t flags) {
103 JanetFile *iof = (JanetFile *) janet_abstract(&janet_file_type, sizeof(JanetFile));
104 iof->file = f;
105 iof->flags = flags;
106 #ifndef JANET_WINDOWS
107 /* While we would like fopen to set cloexec by default (like O_CLOEXEC) with the e flag, that is
108 * not standard. */
109 if (!(flags & JANET_FILE_NOT_CLOSEABLE))
110 fcntl(fileno(f), F_SETFD, FD_CLOEXEC);
111 #endif
112 return iof;
113 }
114
115 /* Open a process */
116 #ifndef JANET_NO_PROCESSES
117 JANET_CORE_FN(cfun_io_popen,
118 "(file/popen command &opt mode) (DEPRECATED for os/spawn)",
119 "Open a file that is backed by a process. The file must be opened in either "
120 "the :r (read) or the :w (write) mode. In :r mode, the stdout of the "
121 "process can be read from the file. In :w mode, the stdin of the process "
122 "can be written to. Returns the new file.") {
123 janet_arity(argc, 1, 2);
124 const uint8_t *fname = janet_getstring(argv, 0);
125 const uint8_t *fmode = NULL;
126 int32_t flags;
127 if (argc == 2) {
128 fmode = janet_getkeyword(argv, 1);
129 flags = JANET_FILE_PIPED | checkflags(fmode);
130 if (flags & (JANET_FILE_UPDATE | JANET_FILE_BINARY | JANET_FILE_APPEND)) {
131 janet_panicf("invalid popen file mode :%S, expected :r or :w", fmode);
132 }
133 fmode = (const uint8_t *)((fmode[0] == 'r') ? "r" : "w");
134 } else {
135 fmode = (const uint8_t *)"r";
136 flags = JANET_FILE_PIPED | JANET_FILE_READ;
137 }
138 #ifdef JANET_WINDOWS
139 #define popen _popen
140 #endif
141 FILE *f = popen((const char *)fname, (const char *)fmode);
142 if (!f) {
143 if (flags & JANET_FILE_NONIL)
144 janet_panicf("failed to popen %s: %s", fname, strerror(errno));
145 return janet_wrap_nil();
146 }
147 return janet_makefile(f, flags);
148 }
149 #endif
150
151 JANET_CORE_FN(cfun_io_temp,
152 "(file/temp)",
153 "Open an anonymous temporary file that is removed on close. "
154 "Raises an error on failure.") {
155 (void)argv;
156 janet_fixarity(argc, 0);
157 // XXX use mkostemp when we can to avoid CLOEXEC race.
158 FILE *tmp = tmpfile();
159 if (!tmp)
160 janet_panicf("unable to create temporary file - %s", strerror(errno));
161 return janet_makefile(tmp, JANET_FILE_WRITE | JANET_FILE_READ | JANET_FILE_BINARY);
162 }
163
164 JANET_CORE_FN(cfun_io_fopen,
165 "(file/open path &opt mode)",
166 "Open a file. `path` is an absolute or relative path, and "
167 "`mode` is a set of flags indicating the mode to open the file in. "
168 "`mode` is a keyword where each character represents a flag. If the file "
169 "cannot be opened, returns nil, otherwise returns the new file handle. "
170 "Mode flags:\n\n"
171 "* r - allow reading from the file\n\n"
172 "* w - allow writing to the file\n\n"
173 "* a - append to the file\n\n"
174 "Following one of the initial flags, 0 or more of the following flags can be appended:\n\n"
175 "* b - open the file in binary mode (rather than text mode)\n\n"
176 "* + - append to the file instead of overwriting it\n\n"
177 "* n - error if the file cannot be opened instead of returning nil") {
178 janet_arity(argc, 1, 2);
179 const uint8_t *fname = janet_getstring(argv, 0);
180 const uint8_t *fmode;
181 int32_t flags;
182 if (argc == 2) {
183 fmode = janet_getkeyword(argv, 1);
184 flags = checkflags(fmode);
185 } else {
186 fmode = (const uint8_t *)"r";
187 flags = JANET_FILE_READ;
188 }
189 FILE *f = fopen((const char *)fname, (const char *)fmode);
190 return f ? janet_makefile(f, flags)
191 : (flags & JANET_FILE_NONIL) ? (janet_panicf("failed to open file %s: %s", fname, strerror(errno)), janet_wrap_nil())
192 : janet_wrap_nil();
193 }
194
195 /* Read up to n bytes into buffer. */
read_chunk(JanetFile * iof,JanetBuffer * buffer,int32_t nBytesMax)196 static void read_chunk(JanetFile *iof, JanetBuffer *buffer, int32_t nBytesMax) {
197 if (!(iof->flags & (JANET_FILE_READ | JANET_FILE_UPDATE)))
198 janet_panic("file is not readable");
199 janet_buffer_extra(buffer, nBytesMax);
200 size_t ntoread = nBytesMax;
201 size_t nread = fread((char *)(buffer->data + buffer->count), 1, ntoread, iof->file);
202 if (nread != ntoread && ferror(iof->file))
203 janet_panic("could not read file");
204 buffer->count += (int32_t) nread;
205 }
206
207 /* Read a certain number of bytes into memory */
208 JANET_CORE_FN(cfun_io_fread,
209 "(file/read f what &opt buf)",
210 "Read a number of bytes from a file `f` into a buffer. A buffer `buf` can "
211 "be provided as an optional third argument, otherwise a new buffer "
212 "is created. `what` can either be an integer or a keyword. Returns the "
213 "buffer with file contents. "
214 "Values for `what`:\n\n"
215 "* :all - read the whole file\n\n"
216 "* :line - read up to and including the next newline character\n\n"
217 "* n (integer) - read up to n bytes from the file") {
218 janet_arity(argc, 2, 3);
219 JanetFile *iof = janet_getabstract(argv, 0, &janet_file_type);
220 if (iof->flags & JANET_FILE_CLOSED) janet_panic("file is closed");
221 JanetBuffer *buffer;
222 if (argc == 2) {
223 buffer = janet_buffer(0);
224 } else {
225 buffer = janet_getbuffer(argv, 2);
226 }
227 int32_t bufstart = buffer->count;
228 if (janet_checktype(argv[1], JANET_KEYWORD)) {
229 const uint8_t *sym = janet_unwrap_keyword(argv[1]);
230 if (!janet_cstrcmp(sym, "all")) {
231 int32_t sizeBefore;
232 do {
233 sizeBefore = buffer->count;
234 read_chunk(iof, buffer, 4096);
235 } while (sizeBefore < buffer->count);
236 /* Never return nil for :all */
237 return janet_wrap_buffer(buffer);
238 } else if (!janet_cstrcmp(sym, "line")) {
239 for (;;) {
240 int x = fgetc(iof->file);
241 if (x != EOF) janet_buffer_push_u8(buffer, (uint8_t)x);
242 if (x == EOF || x == '\n') break;
243 }
244 } else {
245 janet_panicf("expected one of :all, :line, got %v", argv[1]);
246 }
247 } else {
248 int32_t len = janet_getinteger(argv, 1);
249 if (len < 0) janet_panic("expected positive integer");
250 read_chunk(iof, buffer, len);
251 }
252 if (bufstart == buffer->count) return janet_wrap_nil();
253 return janet_wrap_buffer(buffer);
254 }
255
256 /* Write bytes to a file */
257 JANET_CORE_FN(cfun_io_fwrite,
258 "(file/write f bytes)",
259 "Writes to a file. 'bytes' must be string, buffer, or symbol. Returns the "
260 "file.") {
261 janet_arity(argc, 1, -1);
262 JanetFile *iof = janet_getabstract(argv, 0, &janet_file_type);
263 if (iof->flags & JANET_FILE_CLOSED)
264 janet_panic("file is closed");
265 if (!(iof->flags & (JANET_FILE_WRITE | JANET_FILE_APPEND | JANET_FILE_UPDATE)))
266 janet_panic("file is not writeable");
267 int32_t i;
268 /* Verify all arguments before writing to file */
269 for (i = 1; i < argc; i++)
270 janet_getbytes(argv, i);
271 for (i = 1; i < argc; i++) {
272 JanetByteView view = janet_getbytes(argv, i);
273 if (view.len) {
274 if (!fwrite(view.bytes, view.len, 1, iof->file)) {
275 janet_panic("error writing to file");
276 }
277 }
278 }
279 return argv[0];
280 }
281
282 /* Flush the bytes in the file */
283 JANET_CORE_FN(cfun_io_fflush,
284 "(file/flush f)",
285 "Flush any buffered bytes to the file system. In most files, writes are "
286 "buffered for efficiency reasons. Returns the file handle.") {
287 janet_fixarity(argc, 1);
288 JanetFile *iof = janet_getabstract(argv, 0, &janet_file_type);
289 if (iof->flags & JANET_FILE_CLOSED)
290 janet_panic("file is closed");
291 if (!(iof->flags & (JANET_FILE_WRITE | JANET_FILE_APPEND | JANET_FILE_UPDATE)))
292 janet_panic("file is not writeable");
293 if (fflush(iof->file))
294 janet_panic("could not flush file");
295 return argv[0];
296 }
297
298 #ifdef JANET_WINDOWS
299 #define pclose _pclose
300 #define WEXITSTATUS(x) x
301 #endif
302
303 /* For closing files from C API */
janet_file_close(JanetFile * file)304 int janet_file_close(JanetFile *file) {
305 int ret = 0;
306 if (!(file->flags & (JANET_FILE_NOT_CLOSEABLE | JANET_FILE_CLOSED))) {
307 #ifndef JANET_NO_PROCESSES
308 if (file->flags & JANET_FILE_PIPED) {
309 ret = pclose(file->file);
310 } else
311 #endif
312 {
313 ret = fclose(file->file);
314 }
315 file->flags |= JANET_FILE_CLOSED;
316 return ret;
317 }
318 return 0;
319 }
320
321 /* Cleanup a file */
cfun_io_gc(void * p,size_t len)322 static int cfun_io_gc(void *p, size_t len) {
323 (void) len;
324 JanetFile *iof = (JanetFile *)p;
325 janet_file_close(iof);
326 return 0;
327 }
328
329 /* Close a file */
330 JANET_CORE_FN(cfun_io_fclose,
331 "(file/close f)",
332 "Close a file and release all related resources. When you are "
333 "done reading a file, close it to prevent a resource leak and let "
334 "other processes read the file. If the file is the result of a file/popen "
335 "call, close waits for and returns the process exit status.") {
336 janet_fixarity(argc, 1);
337 JanetFile *iof = janet_getabstract(argv, 0, &janet_file_type);
338 if (iof->flags & JANET_FILE_CLOSED)
339 return janet_wrap_nil();
340 if (iof->flags & (JANET_FILE_NOT_CLOSEABLE))
341 janet_panic("file not closable");
342 if (iof->flags & JANET_FILE_PIPED) {
343 #ifndef JANET_NO_PROCESSES
344 int status = pclose(iof->file);
345 iof->flags |= JANET_FILE_CLOSED;
346 if (status == -1) janet_panic("could not close file");
347 return janet_wrap_integer(WEXITSTATUS(status));
348 #else
349 return janet_wrap_nil();
350 #endif
351 } else {
352 if (fclose(iof->file)) {
353 iof->flags |= JANET_FILE_NOT_CLOSEABLE;
354 janet_panic("could not close file");
355 }
356 iof->flags |= JANET_FILE_CLOSED;
357 }
358 return janet_wrap_nil();
359 }
360
361 /* Seek a file */
362 JANET_CORE_FN(cfun_io_fseek,
363 "(file/seek f &opt whence n)",
364 "Jump to a relative location in the file `f`. `whence` must be one of:\n\n"
365 "* :cur - jump relative to the current file location\n\n"
366 "* :set - jump relative to the beginning of the file\n\n"
367 "* :end - jump relative to the end of the file\n\n"
368 "By default, `whence` is :cur. Optionally a value `n` may be passed "
369 "for the relative number of bytes to seek in the file. `n` may be a real "
370 "number to handle large files of more than 4GB. Returns the file handle.") {
371 janet_arity(argc, 2, 3);
372 JanetFile *iof = janet_getabstract(argv, 0, &janet_file_type);
373 if (iof->flags & JANET_FILE_CLOSED)
374 janet_panic("file is closed");
375 long int offset = 0;
376 int whence = SEEK_CUR;
377 if (argc >= 2) {
378 const uint8_t *whence_sym = janet_getkeyword(argv, 1);
379 if (!janet_cstrcmp(whence_sym, "cur")) {
380 whence = SEEK_CUR;
381 } else if (!janet_cstrcmp(whence_sym, "set")) {
382 whence = SEEK_SET;
383 } else if (!janet_cstrcmp(whence_sym, "end")) {
384 whence = SEEK_END;
385 } else {
386 janet_panicf("expected one of :cur, :set, :end, got %v", argv[1]);
387 }
388 if (argc == 3) {
389 offset = (long) janet_getinteger64(argv, 2);
390 }
391 }
392 if (fseek(iof->file, offset, whence)) janet_panic("error seeking file");
393 return argv[0];
394 }
395
396 static JanetMethod io_file_methods[] = {
397 {"close", cfun_io_fclose},
398 {"flush", cfun_io_fflush},
399 {"read", cfun_io_fread},
400 {"seek", cfun_io_fseek},
401 {"write", cfun_io_fwrite},
402 {NULL, NULL}
403 };
404
io_file_get(void * p,Janet key,Janet * out)405 static int io_file_get(void *p, Janet key, Janet *out) {
406 (void) p;
407 if (!janet_checktype(key, JANET_KEYWORD))
408 return 0;
409 return janet_getmethod(janet_unwrap_keyword(key), io_file_methods, out);
410 }
411
io_file_next(void * p,Janet key)412 static Janet io_file_next(void *p, Janet key) {
413 (void) p;
414 return janet_nextmethod(io_file_methods, key);
415 }
416
io_file_marshal(void * p,JanetMarshalContext * ctx)417 static void io_file_marshal(void *p, JanetMarshalContext *ctx) {
418 JanetFile *iof = (JanetFile *)p;
419 if (ctx->flags & JANET_MARSHAL_UNSAFE) {
420 janet_marshal_abstract(ctx, p);
421 #ifdef JANET_WINDOWS
422 janet_marshal_int(ctx, _fileno(iof->file));
423 #else
424 janet_marshal_int(ctx, fileno(iof->file));
425 #endif
426 janet_marshal_int(ctx, iof->flags);
427 } else {
428 janet_panic("cannot marshal file in safe mode");
429 }
430 }
431
io_file_unmarshal(JanetMarshalContext * ctx)432 static void *io_file_unmarshal(JanetMarshalContext *ctx) {
433 if (ctx->flags & JANET_MARSHAL_UNSAFE) {
434 JanetFile *iof = janet_unmarshal_abstract(ctx, sizeof(JanetFile));
435 int32_t fd = janet_unmarshal_int(ctx);
436 int32_t flags = janet_unmarshal_int(ctx);
437 char fmt[4] = {0};
438 int index = 0;
439 if (flags & JANET_FILE_READ) fmt[index++] = 'r';
440 if (flags & JANET_FILE_APPEND) {
441 fmt[index++] = 'a';
442 } else if (flags & JANET_FILE_WRITE) {
443 fmt[index++] = 'w';
444 }
445 #ifdef JANET_WINDOWS
446 iof->file = _fdopen(fd, fmt);
447 #else
448 iof->file = fdopen(fd, fmt);
449 #endif
450 if (iof->file == NULL) {
451 iof->flags = JANET_FILE_CLOSED;
452 } else {
453 iof->flags = flags;
454 }
455 return iof;
456 } else {
457 janet_panic("cannot unmarshal file in safe mode");
458 }
459 }
460
janet_dynfile(const char * name,FILE * def)461 FILE *janet_dynfile(const char *name, FILE *def) {
462 Janet x = janet_dyn(name);
463 if (!janet_checktype(x, JANET_ABSTRACT)) return def;
464 void *abstract = janet_unwrap_abstract(x);
465 if (janet_abstract_type(abstract) != &janet_file_type) return def;
466 JanetFile *iofile = abstract;
467 return iofile->file;
468 }
469
cfun_io_print_impl_x(int32_t argc,Janet * argv,int newline,FILE * dflt_file,int32_t offset,Janet x)470 static Janet cfun_io_print_impl_x(int32_t argc, Janet *argv, int newline,
471 FILE *dflt_file, int32_t offset, Janet x) {
472 FILE *f;
473 switch (janet_type(x)) {
474 default:
475 janet_panicf("cannot print to %v", x);
476 case JANET_BUFFER: {
477 /* Special case buffer */
478 JanetBuffer *buf = janet_unwrap_buffer(x);
479 for (int32_t i = offset; i < argc; ++i) {
480 janet_to_string_b(buf, argv[i]);
481 }
482 if (newline)
483 janet_buffer_push_u8(buf, '\n');
484 return janet_wrap_nil();
485 }
486 case JANET_FUNCTION: {
487 /* Special case function */
488 JanetFunction *fun = janet_unwrap_function(x);
489 JanetBuffer *buf = janet_buffer(0);
490 for (int32_t i = offset; i < argc; ++i) {
491 janet_to_string_b(buf, argv[i]);
492 }
493 if (newline)
494 janet_buffer_push_u8(buf, '\n');
495 Janet args[1] = { janet_wrap_buffer(buf) };
496 janet_call(fun, 1, args);
497 return janet_wrap_nil();
498 }
499 case JANET_NIL:
500 f = dflt_file;
501 if (f == NULL) janet_panic("cannot print to nil");
502 break;
503 case JANET_ABSTRACT: {
504 void *abstract = janet_unwrap_abstract(x);
505 if (janet_abstract_type(abstract) != &janet_file_type)
506 return janet_wrap_nil();
507 JanetFile *iofile = abstract;
508 f = iofile->file;
509 break;
510 }
511 }
512 for (int32_t i = offset; i < argc; ++i) {
513 int32_t len;
514 const uint8_t *vstr;
515 if (janet_checktype(argv[i], JANET_BUFFER)) {
516 JanetBuffer *b = janet_unwrap_buffer(argv[i]);
517 vstr = b->data;
518 len = b->count;
519 } else {
520 vstr = janet_to_string(argv[i]);
521 len = janet_string_length(vstr);
522 }
523 if (len) {
524 if (1 != fwrite(vstr, len, 1, f)) {
525 if (f == dflt_file) {
526 janet_panicf("cannot print %d bytes", len);
527 } else {
528 janet_panicf("cannot print %d bytes to %v", len, x);
529 }
530 }
531 }
532 }
533 if (newline)
534 putc('\n', f);
535 return janet_wrap_nil();
536 }
537
538
cfun_io_print_impl(int32_t argc,Janet * argv,int newline,const char * name,FILE * dflt_file)539 static Janet cfun_io_print_impl(int32_t argc, Janet *argv,
540 int newline, const char *name, FILE *dflt_file) {
541 Janet x = janet_dyn(name);
542 return cfun_io_print_impl_x(argc, argv, newline, dflt_file, 0, x);
543 }
544
545 JANET_CORE_FN(cfun_io_print,
546 "(print & xs)",
547 "Print values to the console (standard out). Value are converted "
548 "to strings if they are not already. After printing all values, a "
549 "newline character is printed. Use the value of (dyn :out stdout) to determine "
550 "what to push characters to. Expects (dyn :out stdout) to be either a core/file or "
551 "a buffer. Returns nil.") {
552 return cfun_io_print_impl(argc, argv, 1, "out", stdout);
553 }
554
555 JANET_CORE_FN(cfun_io_prin,
556 "(prin & xs)",
557 "Same as print, but does not add trailing newline.") {
558 return cfun_io_print_impl(argc, argv, 0, "out", stdout);
559 }
560
561 JANET_CORE_FN(cfun_io_eprint,
562 "(eprint & xs)",
563 "Same as print, but uses (dyn :err stderr) instead of (dyn :out stdout).") {
564 return cfun_io_print_impl(argc, argv, 1, "err", stderr);
565 }
566
567 JANET_CORE_FN(cfun_io_eprin,
568 "(eprin & xs)",
569 "Same as prin, but uses (dyn :err stderr) instead of (dyn :out stdout).") {
570 return cfun_io_print_impl(argc, argv, 0, "err", stderr);
571 }
572
573 JANET_CORE_FN(cfun_io_xprint,
574 "(xprint to & xs)",
575 "Print to a file or other value explicitly (no dynamic bindings) with a trailing "
576 "newline character. The value to print "
577 "to is the first argument, and is otherwise the same as print. Returns nil.") {
578 janet_arity(argc, 1, -1);
579 return cfun_io_print_impl_x(argc, argv, 1, NULL, 1, argv[0]);
580 }
581
582 JANET_CORE_FN(cfun_io_xprin,
583 "(xprin to & xs)",
584 "Print to a file or other value explicitly (no dynamic bindings). The value to print "
585 "to is the first argument, and is otherwise the same as prin. Returns nil.") {
586 janet_arity(argc, 1, -1);
587 return cfun_io_print_impl_x(argc, argv, 0, NULL, 1, argv[0]);
588 }
589
cfun_io_printf_impl_x(int32_t argc,Janet * argv,int newline,FILE * dflt_file,int32_t offset,Janet x)590 static Janet cfun_io_printf_impl_x(int32_t argc, Janet *argv, int newline,
591 FILE *dflt_file, int32_t offset, Janet x) {
592 FILE *f;
593 const char *fmt = janet_getcstring(argv, offset);
594 switch (janet_type(x)) {
595 default:
596 janet_panicf("cannot print to %v", x);
597 case JANET_BUFFER: {
598 /* Special case buffer */
599 JanetBuffer *buf = janet_unwrap_buffer(x);
600 janet_buffer_format(buf, fmt, offset, argc, argv);
601 if (newline) janet_buffer_push_u8(buf, '\n');
602 return janet_wrap_nil();
603 }
604 case JANET_NIL:
605 f = dflt_file;
606 if (f == NULL) janet_panic("cannot print to nil");
607 break;
608 case JANET_ABSTRACT: {
609 void *abstract = janet_unwrap_abstract(x);
610 if (janet_abstract_type(abstract) != &janet_file_type)
611 return janet_wrap_nil();
612 JanetFile *iofile = abstract;
613 f = iofile->file;
614 break;
615 }
616 }
617 JanetBuffer *buf = janet_buffer(10);
618 janet_buffer_format(buf, fmt, offset, argc, argv);
619 if (newline) janet_buffer_push_u8(buf, '\n');
620 if (buf->count) {
621 if (1 != fwrite(buf->data, buf->count, 1, f)) {
622 janet_panicf("could not print %d bytes to file", buf->count);
623 }
624 }
625 /* Clear buffer to make things easier for GC */
626 buf->count = 0;
627 buf->capacity = 0;
628 janet_free(buf->data);
629 buf->data = NULL;
630 return janet_wrap_nil();
631 }
632
cfun_io_printf_impl(int32_t argc,Janet * argv,int newline,const char * name,FILE * dflt_file)633 static Janet cfun_io_printf_impl(int32_t argc, Janet *argv, int newline,
634 const char *name, FILE *dflt_file) {
635 janet_arity(argc, 1, -1);
636 Janet x = janet_dyn(name);
637 return cfun_io_printf_impl_x(argc, argv, newline, dflt_file, 0, x);
638
639 }
640
641 JANET_CORE_FN(cfun_io_printf,
642 "(printf fmt & xs)",
643 "Prints output formatted as if with (string/format fmt ;xs) to (dyn :out stdout) with a trailing newline.") {
644 return cfun_io_printf_impl(argc, argv, 1, "out", stdout);
645 }
646
647 JANET_CORE_FN(cfun_io_prinf,
648 "(prinf fmt & xs)",
649 "Like printf but with no trailing newline.") {
650 return cfun_io_printf_impl(argc, argv, 0, "out", stdout);
651 }
652
653 JANET_CORE_FN(cfun_io_eprintf,
654 "(eprintf fmt & xs)",
655 "Prints output formatted as if with (string/format fmt ;xs) to (dyn :err stderr) with a trailing newline.") {
656 return cfun_io_printf_impl(argc, argv, 1, "err", stderr);
657 }
658
659 JANET_CORE_FN(cfun_io_eprinf,
660 "(eprinf fmt & xs)",
661 "Like eprintf but with no trailing newline.") {
662 return cfun_io_printf_impl(argc, argv, 0, "err", stderr);
663 }
664
665 JANET_CORE_FN(cfun_io_xprintf,
666 "(xprintf to fmt & xs)",
667 "Like printf but prints to an explicit file or value to. Returns nil.") {
668 janet_arity(argc, 2, -1);
669 return cfun_io_printf_impl_x(argc, argv, 1, NULL, 1, argv[0]);
670 }
671
672 JANET_CORE_FN(cfun_io_xprinf,
673 "(xprinf to fmt & xs)",
674 "Like prinf but prints to an explicit file or value to. Returns nil.") {
675 janet_arity(argc, 2, -1);
676 return cfun_io_printf_impl_x(argc, argv, 0, NULL, 1, argv[0]);
677 }
678
janet_flusher(const char * name,FILE * dflt_file)679 static void janet_flusher(const char *name, FILE *dflt_file) {
680 Janet x = janet_dyn(name);
681 switch (janet_type(x)) {
682 default:
683 break;
684 case JANET_NIL:
685 fflush(dflt_file);
686 break;
687 case JANET_ABSTRACT: {
688 void *abstract = janet_unwrap_abstract(x);
689 if (janet_abstract_type(abstract) != &janet_file_type) break;
690 JanetFile *iofile = abstract;
691 fflush(iofile->file);
692 break;
693 }
694 }
695 }
696
697 JANET_CORE_FN(cfun_io_flush,
698 "(flush)",
699 "Flush (dyn :out stdout) if it is a file, otherwise do nothing.") {
700 janet_fixarity(argc, 0);
701 (void) argv;
702 janet_flusher("out", stdout);
703 return janet_wrap_nil();
704 }
705
706 JANET_CORE_FN(cfun_io_eflush,
707 "(eflush)",
708 "Flush (dyn :err stderr) if it is a file, otherwise do nothing.") {
709 janet_fixarity(argc, 0);
710 (void) argv;
711 janet_flusher("err", stderr);
712 return janet_wrap_nil();
713 }
714
janet_dynprintf(const char * name,FILE * dflt_file,const char * format,...)715 void janet_dynprintf(const char *name, FILE *dflt_file, const char *format, ...) {
716 va_list args;
717 va_start(args, format);
718 Janet x = janet_dyn(name);
719 JanetType xtype = janet_type(x);
720 switch (xtype) {
721 default:
722 /* Other values simply do nothing */
723 break;
724 case JANET_NIL:
725 case JANET_ABSTRACT: {
726 FILE *f = dflt_file;
727 JanetBuffer buffer;
728 int32_t len = 0;
729 while (format[len]) len++;
730 janet_buffer_init(&buffer, len);
731 janet_formatbv(&buffer, format, args);
732 if (xtype == JANET_ABSTRACT) {
733 void *abstract = janet_unwrap_abstract(x);
734 if (janet_abstract_type(abstract) != &janet_file_type)
735 break;
736 JanetFile *iofile = abstract;
737 f = iofile->file;
738 }
739 fwrite(buffer.data, buffer.count, 1, f);
740 janet_buffer_deinit(&buffer);
741 break;
742 }
743 case JANET_BUFFER:
744 janet_formatbv(janet_unwrap_buffer(x), format, args);
745 break;
746 }
747 va_end(args);
748 return;
749 }
750
751 /* C API */
752
janet_getjfile(const Janet * argv,int32_t n)753 JanetFile *janet_getjfile(const Janet *argv, int32_t n) {
754 return janet_getabstract(argv, n, &janet_file_type);
755 }
756
janet_getfile(const Janet * argv,int32_t n,int * flags)757 FILE *janet_getfile(const Janet *argv, int32_t n, int *flags) {
758 JanetFile *iof = janet_getabstract(argv, n, &janet_file_type);
759 if (NULL != flags) *flags = iof->flags;
760 return iof->file;
761 }
762
janet_makejfile(FILE * f,int flags)763 JanetFile *janet_makejfile(FILE *f, int flags) {
764 return makef(f, flags);
765 }
766
janet_makefile(FILE * f,int flags)767 Janet janet_makefile(FILE *f, int flags) {
768 return janet_wrap_abstract(makef(f, flags));
769 }
770
janet_checkfile(Janet j)771 JanetAbstract janet_checkfile(Janet j) {
772 return janet_checkabstract(j, &janet_file_type);
773 }
774
janet_unwrapfile(Janet j,int * flags)775 FILE *janet_unwrapfile(Janet j, int *flags) {
776 JanetFile *iof = janet_unwrap_abstract(j);
777 if (NULL != flags) *flags = iof->flags;
778 return iof->file;
779 }
780
781 /* Module entry point */
janet_lib_io(JanetTable * env)782 void janet_lib_io(JanetTable *env) {
783 JanetRegExt io_cfuns[] = {
784 JANET_CORE_REG("print", cfun_io_print),
785 JANET_CORE_REG("prin", cfun_io_prin),
786 JANET_CORE_REG("printf", cfun_io_printf),
787 JANET_CORE_REG("prinf", cfun_io_prinf),
788 JANET_CORE_REG("eprin", cfun_io_eprin),
789 JANET_CORE_REG("eprint", cfun_io_eprint),
790 JANET_CORE_REG("eprintf", cfun_io_eprintf),
791 JANET_CORE_REG("eprinf", cfun_io_eprinf),
792 JANET_CORE_REG("xprint", cfun_io_xprint),
793 JANET_CORE_REG("xprin", cfun_io_xprin),
794 JANET_CORE_REG("xprintf", cfun_io_xprintf),
795 JANET_CORE_REG("xprinf", cfun_io_xprinf),
796 JANET_CORE_REG("flush", cfun_io_flush),
797 JANET_CORE_REG("eflush", cfun_io_eflush),
798 JANET_CORE_REG("file/temp", cfun_io_temp),
799 JANET_CORE_REG("file/open", cfun_io_fopen),
800 JANET_CORE_REG("file/close", cfun_io_fclose),
801 JANET_CORE_REG("file/read", cfun_io_fread),
802 JANET_CORE_REG("file/write", cfun_io_fwrite),
803 JANET_CORE_REG("file/flush", cfun_io_fflush),
804 JANET_CORE_REG("file/seek", cfun_io_fseek),
805 #ifndef JANET_NO_PROCESSES
806 JANET_CORE_REG("file/popen", cfun_io_popen),
807 #endif
808 JANET_REG_END
809 };
810 janet_core_cfuns_ext(env, NULL, io_cfuns);
811 janet_register_abstract_type(&janet_file_type);
812 int default_flags = JANET_FILE_NOT_CLOSEABLE | JANET_FILE_SERIALIZABLE;
813 /* stdout */
814 JANET_CORE_DEF(env, "stdout",
815 janet_makefile(stdout, JANET_FILE_APPEND | default_flags),
816 "The standard output file.");
817 /* stderr */
818 JANET_CORE_DEF(env, "stderr",
819 janet_makefile(stderr, JANET_FILE_APPEND | default_flags),
820 "The standard error file.");
821 /* stdin */
822 JANET_CORE_DEF(env, "stdin",
823 janet_makefile(stdin, JANET_FILE_READ | default_flags),
824 "The standard input file.");
825
826 }
827