1 /*-
2 * Copyright (c) 2005-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 * @(#)utils.c 2.10 11/18/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_SIGNAL_H)
40 #include <signal.h>
41 #endif
42
43 static char *do_strncat(char *, size_t, const char *, size_t);
44 static char *do_strncpy(char *, size_t, const char *, size_t);
45 static void ficl_cold(ficlVm *);
46 #if defined(HAVE_LIBTECLA)
47 static void ficl_ps_cb(ficlVm *);
48 #endif
49 static void ficl_fgl_erase(ficlVm *);
50 static void ficl_repl_cb(ficlVm *);
51 static void *fixup_null_alloc(size_t, const char *);
52 static int get_pos_from_buffer(ficlVm *, char *);
53 static ficlString parse_input_buffer_0(ficlVm *, int pos);
54 static void utils_throw_error(FTH, FTH, int);
55
56 char *
fth_strerror(int n)57 fth_strerror(int n)
58 {
59 #if defined(HAVE_STRERROR)
60 return (strerror(n));
61 #else
62 static char mesg[32];
63
64 if (n < 0 || n >= sys_nerr) {
65 snprintf(mesg, sizeof(mesg), "Unknown error (%d)", n);
66 return (mesg);
67 }
68 return ((char *) sys_errlist[n]);
69 #endif
70 }
71
72 /* === xmalloc.c === */
73
74 #if defined(STDC_HEADERS)
75 #include <stdio.h>
76 #include <stdlib.h>
77 #else
78 void *malloc();
79 void *realloc();
80 void free();
81 #endif
82
83 static void *
fixup_null_alloc(size_t n,const char * name)84 fixup_null_alloc(size_t n, const char *name)
85 {
86 void *p = NULL;
87
88 if (n == 0)
89 p = malloc(1L);
90
91 if (p == NULL) {
92 fprintf(stderr,
93 "FTH (%s): memory exhausted, last size %zu\n", name, n);
94 abort(); /* Not exit() here, a debugger should have a
95 * chance. */
96 }
97 return (p);
98 }
99
100 void *
fth_malloc(size_t n)101 fth_malloc(size_t n)
102 {
103 void *p;
104
105 p = malloc(n);
106
107 if (p == NULL)
108 p = fixup_null_alloc(n, "fth_malloc");
109
110 return (p);
111 }
112
113 void *
fth_realloc(void * p,size_t n)114 fth_realloc(void *p, size_t n)
115 {
116 if (p == NULL)
117 return (fth_malloc(n));
118
119 p = realloc(p, n);
120
121 if (p == NULL)
122 p = fixup_null_alloc(n, "fth_realloc");
123
124 return (p);
125 }
126
127 void *
fth_calloc(size_t count,size_t eltsize)128 fth_calloc(size_t count, size_t eltsize)
129 {
130 void *p;
131
132 p = calloc(count, eltsize);
133
134 if (p == NULL) {
135 p = fixup_null_alloc(count * eltsize, "fth_calloc");
136 memset(p, 0, 1);
137 }
138 return (p);
139 }
140
141 void
fth_free(void * ptr)142 fth_free(void *ptr)
143 {
144 if (ptr != NULL)
145 free(ptr);
146
147 ptr = NULL;
148 }
149
150 char *
fth_strdup(const char * s)151 fth_strdup(const char *s)
152 {
153 if (s != NULL) {
154 size_t len;
155
156 len = strlen(s) + 1;
157
158 if (len > 1)
159 return ((char *) memcpy(FTH_MALLOC(len), s, len));
160 }
161 return (NULL);
162 }
163
164 size_t
fth_strlen(const char * s)165 fth_strlen(const char *s)
166 {
167 if (s != NULL)
168 return (strlen(s));
169
170 return (0);
171 }
172
173 /*-
174 * fth_strcpy
175 * fth_strncpy
176 * fth_strcat
177 * fth_strncat
178 *
179 * char *D: destination
180 * size_t SIZE: max size of destination
181 * const char *S: source
182 * size_t COUNT: count chars to copy/append from s to d
183 *
184 * return: address of filled destination
185 *
186 * Copy not more than SIZE - 1 chars to D and append '\0'.
187 */
188
189 #define CHECK_STR3ARGS(Dst, Siz, Src) \
190 if ((Dst) == NULL || (Siz) == 0 || (Src) == NULL) \
191 return (Dst)
192
193 #define CHECK_STR4ARGS(Dst, Siz, Src, Cnt) \
194 if ((Dst) == NULL || (Siz) == 0 || (Src) == NULL || (Cnt) == 0) \
195 return (Dst)
196
197 static char *
do_strncpy(char * d,size_t size,const char * s,size_t count)198 do_strncpy(char *d, size_t size, const char *s, size_t count)
199 {
200 size--;
201
202 if (size < count)
203 count = size;
204
205 d[0] = '\0';
206 return (strncat(d, s, count));
207 }
208
209 static char *
do_strncat(char * d,size_t size,const char * s,size_t count)210 do_strncat(char *d, size_t size, const char *s, size_t count)
211 {
212 size -= strlen(d);
213 size--;
214
215 if (size < count)
216 count = size;
217
218 return (strncat(d, s, count));
219 }
220
221 char *
fth_strcpy(char * d,size_t size,const char * s)222 fth_strcpy(char *d, size_t size, const char *s)
223 {
224 CHECK_STR3ARGS(d, size, s);
225 return (do_strncpy(d, size, s, strlen(s)));
226 }
227
228 char *
fth_strncpy(char * d,size_t size,const char * s,size_t count)229 fth_strncpy(char *d, size_t size, const char *s, size_t count)
230 {
231 CHECK_STR4ARGS(d, size, s, count);
232 return (do_strncpy(d, size, s, count));
233 }
234
235 char *
fth_strcat(char * d,size_t size,const char * s)236 fth_strcat(char *d, size_t size, const char *s)
237 {
238 CHECK_STR3ARGS(d, size, s);
239 return (do_strncat(d, size, s, strlen(s)));
240 }
241
242 char *
fth_strncat(char * d,size_t size,const char * s,size_t count)243 fth_strncat(char *d, size_t size, const char *s, size_t count)
244 {
245 CHECK_STR4ARGS(d, size, s, count);
246 return (do_strncat(d, size, s, count));
247 }
248
249 char *
fth_getenv(const char * name,char * def)250 fth_getenv(const char *name, char *def)
251 {
252 char *value;
253
254 value = NULL;
255 #if defined(HAVE_ISSETUGID)
256 if (issetugid() == 0)
257 #endif
258 #if defined(HAVE_GETENV)
259 value = getenv(name);
260 #endif
261 return (value != NULL ? value : def);
262 }
263
264 /* === Eval and Execute Wrapper === */
265
266 #if !defined(_WIN32)
267 /* Evaluate input lines. */
268 int
fth_evaluate(ficlVm * vm,const char * buffer)269 fth_evaluate(ficlVm *vm, const char *buffer)
270 {
271 volatile int status, sig;
272
273 status = FICL_VM_STATUS_OUT_OF_TEXT;
274
275 if (buffer != NULL) {
276 gc_push(vm->runningWord);
277 sig = sigsetjmp(fth_sig_toplevel, 1);
278
279 if (sig == 0)
280 status = ficlVmEvaluate(vm, (char *) buffer);
281 else
282 signal_check(sig);
283
284 gc_pop();
285 }
286 return (status);
287 }
288
289 /* Execute one word. */
290 int
fth_execute_xt(ficlVm * vm,ficlWord * word)291 fth_execute_xt(ficlVm *vm, ficlWord *word)
292 {
293 volatile int status, sig;
294
295 status = FICL_VM_STATUS_OUT_OF_TEXT;
296
297 if (word != NULL) {
298 gc_push(word);
299 sig = sigsetjmp(fth_sig_toplevel, 1);
300
301 if (sig == 0)
302 status = ficlVmExecuteXT(vm, word);
303 else
304 signal_check(sig);
305
306 gc_pop();
307 }
308 return (status);
309 }
310
311 #else /* _WIN32 */
312
313 int
fth_evaluate(ficlVm * vm,const char * buffer)314 fth_evaluate(ficlVm *vm, const char *buffer)
315 {
316 int status;
317
318 status = FICL_VM_STATUS_OUT_OF_TEXT;
319
320 if (buffer != NULL)
321 status = ficlVmEvaluate(vm, (char *) buffer);
322
323 return (status);
324 }
325
326 int
fth_execute_xt(ficlVm * vm,ficlWord * word)327 fth_execute_xt(ficlVm *vm, ficlWord *word)
328 {
329 int status;
330
331 status = FICL_VM_STATUS_OUT_OF_TEXT;
332
333 if (word != NULL)
334 status = ficlVmExecuteXT(vm, word);
335
336 return (status);
337 }
338 #endif /* _WIN32 */
339
340 /* === Utilities === */
341
342 char *
pop_cstring(ficlVm * vm)343 pop_cstring(ficlVm *vm)
344 {
345 return (fth_string_ref(ficlStackPopFTH(vm->dataStack)));
346 }
347
348 void
push_cstring(ficlVm * vm,char * s)349 push_cstring(ficlVm *vm, char *s)
350 {
351 ficlStackPushFTH(vm->dataStack, fth_make_string(s));
352 }
353
354 void
push_forth_string(ficlVm * vm,char * string)355 push_forth_string(ficlVm *vm, char *string)
356 {
357 if (string == NULL)
358 string = "";
359
360 ficlStackPushPointer(vm->dataStack, string);
361 ficlStackPushUnsigned(vm->dataStack, strlen(string));
362 }
363
364 void
fth_throw(FTH obj,const char * fmt,...)365 fth_throw(FTH obj, const char *fmt,...)
366 {
367 ficlVm *vm;
368 FTH fs, exc;
369
370 vm = FTH_FICL_VM();
371 fs = fth_make_empty_string();
372 exc = fth_symbol_or_exception_ref(obj);
373
374 if (FTH_NOT_FALSE_P(exc))
375 fth_variable_set("*last-exception*", fth_last_exception = exc);
376
377 fth_hit_error_p = 0;
378
379 if (FTH_NOT_FALSE_P(exc))
380 fth_string_sformat(fs, "%s", fth_exception_ref(exc));
381
382 if (fmt != NULL) {
383 va_list ap;
384
385 if (FTH_NOT_FALSE_P(exc))
386 fth_string_sformat(fs, " in ");
387
388 va_start(ap, fmt);
389 fth_string_vsformat(fs, fmt, ap);
390 va_end(ap);
391 } else if (FTH_FALSE_P(exc)) {
392 fth_string_sformat(fs, "fth_throw");
393
394 if (errno != 0)
395 fth_string_sformat(fs, ": %s", fth_strerror(errno));
396 } else
397 fth_string_sformat(fs, ": %S", fth_exception_message_ref(exc));
398
399 fth_set_backtrace(exc);
400 fth_exception_last_message_set(exc, fs);
401
402 /* We don't come from fth-catch, do we? */
403 if (!vm->fth_catch_p) {
404 fth_hit_error_p = 1;
405 if (fth_eval_p)
406 fth_errorf("\n");
407 fth_errorf("#<%S>\n", fs);
408 fth_show_backtrace(0);
409 errno = 0;
410 fth_reset_loop_and_depth();
411 ficlVmReset(vm);
412 }
413 ficlVmThrow(vm, FICL_VM_STATUS_ABORT);
414 /*
415 * XXX: abort/error-exit
416 * ficlVmThrow(vm, FICL_VM_STATUS_ERROR_EXIT);
417 */
418 }
419
420 /*-
421 * Throw exception EXC with text built from ARGS.
422 * If ARGS is not an array, ARGS's string representation is used.
423 * If ARGS is FTH_NIL or an empty array, a default string is used.
424 * If ARGS is an array with one element, this string is used.
425 * If ARGS is an array and its first element is a format string with N
426 * %s-format signs, ARGS should have N more elements with corresponding
427 * values.
428 *
429 * ARGS: any object => string representation of ARGS
430 * nil or #() => default exception message
431 * #( str ) => STR
432 * #( fmt arg1 arg2 ... ) => formatted string
433 *
434 * fth_throw_error(FTH_BAD_ARITY, proc);
435 * => #<bad-arity in test-proc>
436 *
437 * fth_throw_error(FTH_BAD_ARITY, FTH_NIL);
438 * => #<bad-arity: proc has bad arity>
439 *
440 * fth_throw_error(FTH_BAD_ARITY, FTH_LIST_1(fth_make_string("test-proc")));
441 * => #<bad-arity in test-proc>
442 *
443 * fth_throw_error(FTH_BAD_ARITY,
444 * FTH_LIST_4(fth_make_string("%s: %s args required, got %s"),
445 * proc,
446 * FTH_TWO,
447 * FTH_THREE));
448 * => #<bad-arity in test-proc: 2 args required, got 2>
449 */
450 void
fth_throw_error(FTH exc,FTH args)451 fth_throw_error(FTH exc, FTH args)
452 {
453 utils_throw_error(exc, args, 0);
454 }
455
456 /*
457 * The same like fth_throw_error except for replacing format signs ~A
458 * and ~S with %s. This Function exists for usage in Snd where these
459 * signs appear.
460 */
461 void
fth_throw_list(FTH exc,FTH args)462 fth_throw_list(FTH exc, FTH args)
463 {
464 utils_throw_error(exc, args, 1);
465 }
466
467 static void
utils_throw_error(FTH exc,FTH args,int with_lisp_fmt_p)468 utils_throw_error(FTH exc, FTH args, int with_lisp_fmt_p)
469 {
470 ficlInteger len;
471 FTH fmt;
472
473 if (!fth_symbol_or_exception_p(exc))
474 exc = FTH_FORTH_ERROR;
475
476 len = fth_array_length(args);
477
478 switch (len) {
479 case -1:
480 /*
481 * non-array object
482 */
483 if (!FTH_NIL_P(args)) {
484 fth_throw(exc, "%S", args);
485 /* NOTREACHED */
486 break;
487 } /* else */
488 /* FALLTHROUGH */
489 case 0:
490 /*
491 * nil, #()
492 */
493 fth_throw(exc, NULL);
494 /* NOTREACHED */
495 break;
496 case 1:
497 /*
498 * #( str )
499 * [0]: simple string
500 */
501 fth_throw(exc, "%S", fth_array_ref(args, 0L));
502 /* NOTREACHED */
503 break;
504 default:
505 /*
506 * #( fmt arg1 arg2 ... )
507 * [0]: format string
508 * [1..-1]: arguments required by format string
509 */
510 fmt = fth_array_shift(args);
511
512 if (with_lisp_fmt_p && fth_string_length(fmt) > 1) {
513 FTH fmt_s;
514
515 fmt_s = fth_make_string("%s");
516 fth_string_replace(fmt, fth_make_string("~A"), fmt_s);
517 fth_string_replace(fmt, fth_make_string("~S"), fmt_s);
518 }
519 fth_throw(exc, "%S", fth_string_format(fmt, args));
520 /* NOTREACHED */
521 break;
522 }
523 }
524
525 static int
get_pos_from_buffer(ficlVm * vm,char * delim)526 get_pos_from_buffer(ficlVm *vm, char *delim)
527 {
528 char *str, *tmp;
529
530 tmp = str = ficlVmGetInBuf(vm);
531
532 while ((tmp = strstr(tmp, delim)) != NULL && (*(tmp - 1) == '\\'))
533 tmp++;
534
535 return ((tmp != NULL && tmp >= str) ? (int) (tmp - str) : -1);
536 }
537
538 #define FTH_BUFFER_LENGTH (8192 * sizeof(FTH))
539 static char buffer_result[FTH_BUFFER_LENGTH + 1];
540
541 /*
542 * Returned string must be freed.
543 */
544 char *
parse_tib_with_restart(ficlVm * vm,char * delim,int skip,ficlString (* parse_buffer)(ficlVm * vm,int pos))545 parse_tib_with_restart(ficlVm *vm, char *delim, int skip,
546 ficlString (*parse_buffer) (ficlVm *vm, int pos))
547 {
548 char *buf = NULL;
549 int pos;
550 ficlString s;
551
552 pos = get_pos_from_buffer(vm, delim);
553
554 if (pos == -1)
555 skip = -1;
556 else if (pos >= skip)
557 skip += pos;
558
559 s = (*parse_buffer) (vm, skip);
560 fth_strncat(buffer_result, sizeof(buffer_result), s.text, s.length);
561
562 if (pos == -1)
563 ficlVmThrow(vm, FICL_VM_STATUS_RESTART);
564 else {
565 if (strlen(buffer_result) > 0)
566 buf = FTH_STRDUP(buffer_result);
567
568 buffer_result[0] = '\0';
569 }
570 return (buf);
571 }
572
573 static ficlString
parse_input_buffer_0(ficlVm * vm,int pos)574 parse_input_buffer_0(ficlVm *vm, int pos)
575 {
576 char *trace, *stop, *tmp;
577 int esc, cur_pos;
578 ficlString s;
579
580 trace = ficlVmGetInBuf(vm);
581 stop = ficlVmGetInBufEnd(vm);
582 tmp = trace;
583 FICL_STRING_SET_POINTER(s, trace);
584
585 for (cur_pos = 0, esc = 0;
586 trace != stop && (esc != 0 || cur_pos != pos);
587 cur_pos++, trace++) {
588 if (*trace == '\\' || esc == 1)
589 esc++;
590
591 if (esc == 1)
592 continue;
593
594 if (esc == 2) {
595 switch (*trace) {
596 case 'a':
597 *tmp++ = '\a';
598 break;
599 case 'b':
600 *tmp++ = '\b';
601 break;
602 case 'e':
603 *tmp++ = '\e';
604 break;
605 case 'f':
606 *tmp++ = '\f';
607 break;
608 case 'n':
609 *tmp++ = '\n';
610 break;
611 case 'r':
612 *tmp++ = '\r';
613 break;
614 case 't':
615 *tmp++ = '\t';
616 break;
617 case 'v':
618 *tmp++ = '\v';
619 break;
620 case '"':
621 *tmp++ = '\"';
622 break;
623 case '\\':
624 *tmp++ = '\\';
625 break;
626 case '\n': /* discard trailing \n */
627 break;
628 default:
629 *tmp++ = *trace;
630 break;
631 }
632
633 esc = 0;
634 continue;
635 }
636 *tmp++ = *trace;
637 }
638
639 FICL_STRING_SET_LENGTH(s, tmp - s.text);
640
641 if (trace != stop && cur_pos == pos)
642 trace++;
643
644 ficlVmUpdateTib(vm, trace);
645 return (s);
646 }
647
648 /*
649 * Returned string must be freed.
650 * TIB points after first char of delim.
651 */
652 char *
parse_input_buffer(ficlVm * vm,char * delim)653 parse_input_buffer(ficlVm *vm, char *delim)
654 {
655 return (parse_tib_with_restart(vm, delim, 0, parse_input_buffer_0));
656 }
657
658 /* === Simple Array === */
659
660 simple_array *
make_simple_array(int incr)661 make_simple_array(int incr)
662 {
663 simple_array *ary;
664
665 if (incr <= 0)
666 incr = 8;
667
668 if (incr > 128)
669 incr = 128;
670
671 ary = FTH_MALLOC(sizeof(simple_array));
672 ary->incr = (unsigned int) incr;
673 ary->length = 0;
674 ary->data = NULL;
675 return (ary);
676 }
677
678 simple_array *
make_simple_array_var(int len,...)679 make_simple_array_var(int len,...)
680 {
681 int i;
682 va_list list;
683 simple_array *ary;
684
685 ary = make_simple_array(len);
686 va_start(list, len);
687
688 for (i = 0; i < len; i++)
689 simple_array_push(ary, (void *) va_arg(list, void *));
690
691 va_end(list);
692 return (ary);
693 }
694
695 int
simple_array_length(simple_array * ary)696 simple_array_length(simple_array *ary)
697 {
698 if (ary == NULL)
699 return (-1);
700
701 return ((int) ary->length);
702 }
703
704 int
simple_array_equal_p(simple_array * ary1,simple_array * ary2)705 simple_array_equal_p(simple_array *ary1, simple_array *ary2)
706 {
707 if ((ary1 != NULL && ary2 != NULL) &&
708 (ary1->length == ary2->length &&
709 ary1->incr == ary2->incr)) {
710 unsigned int i;
711
712 for (i = 0; i < ary1->length; i++)
713 if (!fth_object_equal_p((FTH) ary1->data[i],
714 (FTH) ary2->data[i]))
715 return (0);
716
717 return (1);
718 }
719 return (0);
720 }
721
722 void *
simple_array_ref(simple_array * ary,int i)723 simple_array_ref(simple_array *ary, int i)
724 {
725 if (ary != NULL && i >= 0 && i < (int) ary->length)
726 return (ary->data[i]);
727
728 return (NULL);
729 }
730
731 void
simple_array_set(simple_array * ary,int i,void * obj)732 simple_array_set(simple_array *ary, int i, void *obj)
733 {
734 if (ary != NULL && i >= 0 && i < (int) ary->length)
735 ary->data[i] = obj;
736 }
737
738 void
simple_array_push(simple_array * ary,void * obj)739 simple_array_push(simple_array *ary, void *obj)
740 {
741 if (ary == NULL)
742 return;
743
744 if (ary->data == NULL || (ary->length % ary->incr) == 0)
745 ary->data = FTH_REALLOC(ary->data,
746 (ary->length + ary->incr) * sizeof(void *));
747
748 ary->data[ary->length++] = obj;
749 }
750
751 void *
simple_array_pop(simple_array * ary)752 simple_array_pop(simple_array *ary)
753 {
754 void *obj = NULL;
755
756 if (ary != NULL && ary->length > 0) {
757 ary->length--;
758 obj = ary->data[ary->length];
759
760 if (ary->length == 0)
761 simple_array_clear(ary);
762 }
763 return (obj);
764 }
765
766 int
simple_array_index(simple_array * ary,void * obj)767 simple_array_index(simple_array *ary, void *obj)
768 {
769 if (ary != NULL && ary->length > 0) {
770 unsigned int i;
771
772 for (i = 0; i < ary->length; i++)
773 if (ary->data[i] == obj)
774 return ((int) i);
775 }
776 return (-1);
777 }
778
779 int
simple_array_rindex(simple_array * ary,void * obj)780 simple_array_rindex(simple_array *ary, void *obj)
781 {
782 if (ary != NULL && ary->length > 0) {
783 int i;
784
785 for (i = (int) ary->length - 1; i >= 0; i--)
786 if (ary->data[i] == obj)
787 return (i);
788 }
789 return (-1);
790 }
791
792 int
simple_array_member_p(simple_array * ary,void * obj)793 simple_array_member_p(simple_array *ary, void *obj)
794 {
795 return (simple_array_index(ary, obj) != -1);
796 }
797
798 void *
simple_array_delete(simple_array * ary,void * obj)799 simple_array_delete(simple_array *ary, void *obj)
800 {
801 int i;
802 unsigned int ui;
803
804 i = simple_array_index(ary, obj);
805
806 if (i == -1)
807 return (NULL);
808
809 ui = (unsigned int) i;
810 ary->length--;
811
812 if (ary->length == 0)
813 simple_array_clear(ary);
814 else if (ui < ary->length)
815 memmove(ary->data + ui, ary->data + ui + 1,
816 sizeof(void *) * (ary->length - ui));
817
818 return (obj);
819 }
820
821 void *
simple_array_rdelete(simple_array * ary,void * obj)822 simple_array_rdelete(simple_array *ary, void *obj)
823 {
824 int i;
825 unsigned int ui;
826
827 i = simple_array_rindex(ary, obj);
828
829 if (i == -1)
830 return (NULL);
831
832 ui = (unsigned int) i;
833 ary->length--;
834
835 if (ary->length == 0)
836 simple_array_clear(ary);
837 else if (ui < ary->length)
838 memmove(ary->data + ui, ary->data + ui + 1,
839 sizeof(void *) * (ary->length - ui));
840
841 return (obj);
842 }
843
844 simple_array *
simple_array_reverse(simple_array * ary)845 simple_array_reverse(simple_array *ary)
846 {
847 if (ary != NULL && ary->length > 0) {
848 int i;
849 simple_array *new;
850
851 new = make_simple_array((int) ary->incr);
852
853 for (i = (int) ary->length - 1; i >= 0; i--)
854 simple_array_push(new, ary->data[i]);
855
856 return (new);
857 }
858 return (NULL);
859 }
860
861 simple_array *
simple_array_clear(simple_array * ary)862 simple_array_clear(simple_array *ary)
863 {
864 if (ary == NULL)
865 return (NULL);
866
867 FTH_FREE(ary->data);
868 ary->data = NULL;
869 ary->length = 0;
870 return (ary);
871 }
872
873 void
simple_array_free(simple_array * ary)874 simple_array_free(simple_array *ary)
875 {
876 if (ary == NULL)
877 return;
878
879 simple_array_clear(ary);
880 FTH_FREE(ary);
881 ary = NULL;
882 }
883
884 FTH
simple_array_to_array(simple_array * ary)885 simple_array_to_array(simple_array *ary)
886 {
887 if (ary != NULL && ary->length > 0) {
888 ficlInteger i;
889 FTH array;
890
891 array = fth_make_array_len((ficlInteger) ary->length);
892
893 for (i = 0; i < (int) ary->length; i++)
894 fth_array_fast_set(array, i, (FTH) ary->data[i]);
895
896 return (array);
897 }
898 return (fth_make_empty_array());
899 }
900
901 FTH
fth_set_argv(int from,int to,char ** argv)902 fth_set_argv(int from, int to, char **argv)
903 {
904 int i;
905 FTH args;
906
907 if (from >= to || argv == NULL) {
908 fth_variable_set("*argc*", FTH_ZERO);
909 return (fth_variable_set("*argv*", FTH_NIL));
910 }
911 args = FTH_LIST_1(fth_make_string(fth_basename(argv[from++])));
912
913 for (i = from; i < to; i++)
914 fth_array_push(args, fth_make_string(argv[i]));
915
916 fth_variable_set("*argc*", INT_TO_FIX(fth_array_length(args)));
917 return (fth_variable_set("*argv*", args));
918 }
919
920 static FTH before_repl_hook;
921 static FTH after_repl_hook;
922 static FTH before_prompt_hook;
923 static int fth_in_repl_p = 0;
924
925 #define FTH_REPL_PROMPT "ok "
926 #define FTH_REPL_PROMPT2 "c> "
927 #define FTH_HIST_FILE ".fth-history"
928 #define FTH_HIST_LEN 100
929
930 #define FGL_COMMENT "\\"
931 #define FGL_BUFFER 4096
932
933 static FTH fgl_all; /* gl-all to *histdup* */
934 static FTH fgl_prev; /* gl-prev to *histdup* */
935
936 static FTH fgl_vi; /* edit-mode vi */
937 static FTH fgl_emacs; /* edit-mode emacs */
938 static FTH fgl_none; /* edit-mode none */
939 static FTH fgl_nobeep; /* nobeep */
940
941 /* constant (string) */
942 #define FGL_HISTDUP_REF() fth_variable_ref("*histdup*")
943 #define FGL_HISTDUP_ALL_P() (FGL_HISTDUP_REF() == fgl_all)
944 #define FGL_HISTDUP_PREV_P() (FGL_HISTDUP_REF() == fgl_prev)
945 #define FGL_HISTDUP_UNDEF_P() FTH_UNDEF_P(FGL_HISTDUP_REF())
946
947 /* string */
948 #define FGL_HISTFILE_REF() fth_variable_ref("*histfile*")
949 #define FGL_HISTFILE_SET(Val) fth_variable_set("*histfile*", (Val))
950 #define FGL_HISTFILE_CSTR() fth_string_ref(FGL_HISTFILE_REF())
951
952 /* integer */
953 #define FGL_HISTORY_REF() fth_variable_ref("*history*")
954 #define FGL_HISTORY_SET(Val) fth_variable_set("*history*", (Val))
955 #define FGL_HISTORY_CINT() FIX_TO_INT(FGL_HISTORY_REF())
956 #define FGL_HISTORY_CSET(Val) FGL_HISTORY_SET(INT_TO_FIX(Val))
957
958 /* boolean */
959 #define FGL_PROMPTSTYLE_P() FTH_TRUE_P(fth_variable_ref("*promptstyle*"))
960 #define FGL_SAVEHIST_P() FTH_TRUE_P(fth_variable_ref("*savehist*"))
961
962 #if defined(HAVE_LIBTECLA)
963
964 #if defined(HAVE_LIBTECLA_H)
965 #include <libtecla.h>
966 #endif
967
968 static GetLine *repl_gl_init(void);
969 static void ficl_history(ficlVm *);
970 static void ficl_history_lineno(ficlVm *);
971 static void ficl_history_next(ficlVm *);
972 static void ficl_history_prev(ficlVm *);
973 static int gl_config(GetLine *, FTH);
974 static void ficl_bindkey(ficlVm *);
975
976 static int repl_command_generator(WordCompletion *,
977 void *, const char *, int);
978 static int repl_init_history(void);
979 static int repl_append_history(GetLine *, char *);
980 static char *repl_expand_history(GetLine *, char *);
981 static char *repl_replace_history(GetLine *, char *);
982
983 static simple_array *fgl_getline_config;
984 static simple_array *fgl_getline_bindkey;
985
986 #define FTH_GET_LINE_ERROR fth_exception("getline-error")
987 #define FTH_GL_ERROR(gl) \
988 fth_throw(FTH_GET_LINE_ERROR, \
989 "%s: %s", RUNNING_WORD(), gl_error_message(gl, NULL, 0))
990
991 static FTH fgl_show; /* gl-show [n] history */
992 static FTH fgl_load; /* gl-load [fname] history */
993 static FTH fgl_save; /* gl-save [fname] history */
994 static FTH fgl_add; /* gl-add line history */
995 static FTH fgl_clear; /* gl-clear history */
996
997 static ficlUnsigned gl_cur_event;
998
999 static GetLine *
repl_gl_init(void)1000 repl_gl_init(void)
1001 {
1002 ficlVm *vm;
1003 GetLine *gl;
1004
1005 vm = FTH_FICL_VM();
1006 gl = ficlVmGetRepl(vm);
1007
1008 if (gl == NULL) {
1009 gl = new_GetLine(FGL_BUFFER, FGL_BUFFER * repl_init_history());
1010
1011 if (gl == NULL) {
1012 fprintf(stderr, "cannot initialize GetLine\n");
1013 return (NULL);
1014 }
1015 gl_automatic_history(gl, 0);
1016 gl_customize_completion(gl, NULL, repl_command_generator);
1017 gl_prompt_style(gl, GL_FORMAT_PROMPT);
1018 gl_bind_keyseq(gl, GL_USER_KEY, "^C", "user-interrupt");
1019 gl_bind_keyseq(gl, GL_USER_KEY, "^G", "ring-bell");
1020 ficlVmGetRepl(vm) = gl;
1021 }
1022 return (gl);
1023 }
1024
1025 static void
ficl_history(ficlVm * vm)1026 ficl_history(ficlVm *vm)
1027 {
1028 #define h_history "( :optional action arg -- ) handle history events\n\
1029 history => return entire history as string\n\
1030 gl-show history => same as above\n\
1031 10 history => show 10 last history events\n\
1032 gl-show 10 history => same as above\n\
1033 gl-load history => load from *histfile*\n\
1034 gl-load nil history => same as above\n\
1035 gl-load file history => load from file\n\
1036 gl-save history => save to *histfile*\n\
1037 gl-save nil history => same as above\n\
1038 gl-save file history => save to file\n\
1039 gl-add line history => add line to history\n\
1040 gl-clear history => clear all history events\n\
1041 gl-show: return ARG or all history events as string.\n\
1042 gl-load: load from ARG or *histfile* (~/" FTH_HIST_FILE ").\n\
1043 gl-save: save to ARG or *histfile*.\n\
1044 gl-add: add event ARG to history.\n\
1045 gl-clear: clear all history events."
1046 GetLine *gl;
1047 int len, n;
1048 FTH action, arg;
1049
1050 arg = FTH_FALSE;
1051 n = -1;
1052 gl = ficlVmGetRepl(vm);
1053
1054 if (gl == NULL)
1055 gl = repl_gl_init();
1056
1057 len = FTH_STACK_DEPTH(vm);
1058
1059 if (len == 0)
1060 action = fgl_show;
1061 else if (len == 1) {
1062 action = fth_pop_ficl_cell(vm);
1063
1064 if (FTH_INTEGER_P(action)) {
1065 n = (int) FTH_INT_REF(action);
1066 action = fgl_show;
1067 }
1068 } else {
1069 arg = fth_pop_ficl_cell(vm);
1070 action = fth_pop_ficl_cell(vm);
1071 }
1072 if (action == fgl_load) {
1073 char *fname;
1074
1075 fname = fth_string_ref(arg);
1076
1077 if (fname == NULL)
1078 fname = FGL_HISTFILE_CSTR();
1079
1080 if (gl_load_history(gl, fname, FGL_COMMENT) != 0) {
1081 fth_warning("%s: can't load %s", RUNNING_WORD(), fname);
1082 return;
1083 }
1084 } else if (action == fgl_save) {
1085 char *fname;
1086
1087 fname = fth_string_ref(arg);
1088
1089 if (fname == NULL)
1090 fname = FGL_HISTFILE_CSTR();
1091
1092 if (gl_save_history(gl, fname, FGL_COMMENT, -1) != 0) {
1093 fth_warning("%s: can't save %s", RUNNING_WORD(), fname);
1094 return;
1095 }
1096 } else if (action == fgl_add) {
1097 char *line;
1098
1099 line = fth_string_ref(arg);
1100
1101 if (line == NULL || *line == '\0')
1102 return;
1103
1104 repl_append_history(gl, line);
1105 } else if (action == fgl_clear)
1106 gl_clear_history(gl, 1);
1107 else {
1108 FILE *fp;
1109 int fd;
1110 char b[16] = "";
1111 char buf[BUFSIZ];
1112 FTH fs;
1113
1114 snprintf(b, sizeof(b), "/tmp/fth.XXXXXX");
1115 fp = NULL;
1116 fd = mkstemp(b);
1117
1118 if (fd != -1)
1119 fp = fdopen(fd, "w+");
1120
1121 if (fp == NULL) {
1122 if (fd != -1) {
1123 unlink(b);
1124 close(fd);
1125 }
1126 fth_warning("%s: %s %s",
1127 RUNNING_WORD(), b, fth_strerror(errno));
1128 return;
1129 }
1130 if (FTH_INTEGER_P(arg))
1131 n = (int) FTH_INT_REF(arg);
1132
1133 /*
1134 * XXX: gl_show_history and stdout
1135 * We send stdout to a tmp file, read it from
1136 * there and put it on stack.
1137 * This works well in Snd's listener.
1138 */
1139 gl_show_history(gl, fp, "%N %T %H\n", 1, n);
1140 rewind(fp);
1141 fs = fth_make_empty_string();
1142
1143 while (fgets(buf, sizeof(buf), fp) != NULL)
1144 fth_string_scat(fs, buf);
1145
1146 unlink(b);
1147 fclose(fp);
1148 ficlStackPushFTH(vm->dataStack, fs);
1149 }
1150 }
1151
1152 static void
ficl_history_lineno(ficlVm * vm)1153 ficl_history_lineno(ficlVm *vm)
1154 {
1155 #define h_hist_lineno "( -- line )"
1156 GetLine *gl;
1157 GlHistoryRange range;
1158
1159 gl = ficlVmGetRepl(vm);
1160
1161 if (gl == NULL)
1162 gl = repl_gl_init();
1163
1164 gl_range_of_history(gl, &range);
1165 gl_cur_event = range.newest;
1166 ficlStackPushUnsigned(vm->dataStack, gl_cur_event);
1167 }
1168
1169 static void
ficl_history_next(ficlVm * vm)1170 ficl_history_next(ficlVm *vm)
1171 {
1172 #define h_hist_next "( -- line )"
1173 const char *line;
1174 GetLine *gl;
1175 GlHistoryRange range;
1176 GlHistoryLine hline;
1177
1178 gl = ficlVmGetRepl(vm);
1179
1180 if (gl == NULL)
1181 gl = repl_gl_init();
1182
1183 gl_range_of_history(gl, &range);
1184 gl_cur_event++;
1185
1186 /*
1187 * If greater than newest, start from the end.
1188 */
1189 if (gl_cur_event > range.newest || gl_cur_event < range.oldest)
1190 gl_cur_event = range.oldest;
1191
1192 line = "";
1193
1194 if (gl_lookup_history(gl, gl_cur_event, &hline))
1195 line = hline.line;
1196
1197 fth_push_ficl_cell(vm, fth_make_string(line));
1198 }
1199
1200 static void
ficl_history_prev(ficlVm * vm)1201 ficl_history_prev(ficlVm *vm)
1202 {
1203 #define h_hist_prev "( -- line )"
1204 const char *line;
1205 GetLine *gl;
1206 GlHistoryRange range;
1207 GlHistoryLine hline;
1208
1209 gl = ficlVmGetRepl(vm);
1210
1211 if (gl == NULL)
1212 gl = repl_gl_init();
1213
1214 gl_range_of_history(gl, &range);
1215 gl_cur_event--;
1216
1217 /*
1218 * If less than oldest, start from the beginning.
1219 */
1220 if (gl_cur_event < range.oldest || gl_cur_event > range.newest)
1221 gl_cur_event = range.newest;
1222
1223 line = "";
1224
1225 if (gl_lookup_history(gl, gl_cur_event, &hline))
1226 line = hline.line;
1227
1228 fth_push_ficl_cell(vm, fth_make_string(line));
1229 }
1230
1231 #define FGL_TECLA_RC "~/.teclarc"
1232
1233 static int
gl_config(GetLine * gl,FTH action)1234 gl_config(GetLine * gl, FTH action)
1235 {
1236 char *app;
1237
1238 if (action == fgl_vi)
1239 app = "edit-mode vi";
1240 else if (action == fgl_emacs)
1241 app = "edit-mode emacs";
1242 else if (action == fgl_none)
1243 app = "edit-mode none";
1244 else if (action == fgl_nobeep)
1245 app = "nobeep";
1246 else
1247 app = fth_string_ref(action);
1248
1249 simple_array_push(fgl_getline_config, app);
1250
1251 if (gl != NULL)
1252 return (gl_configure_getline(gl, app, NULL, NULL));
1253
1254 return (0);
1255 }
1256
1257 static void
ficl_bindkey(ficlVm * vm)1258 ficl_bindkey(ficlVm *vm)
1259 {
1260 #define h_bindkey "( :optional key action -- ) bind or unbind keys\n\
1261 bindkey => show user-defined key-bindings\n\
1262 \"edit-mode vi \\n nobeep\" bindkey => configure getline\n\
1263 gl-vi bindkey => set getline to vi mode\n\
1264 \"^G\" \"user-interrupt\" bindkey => bind user-interrupt to Ctrl-G\n\
1265 \"^G\" #f bindkey => unbind last bind from Ctrl-G\n\
1266 No argument:\n\
1267 Show user-defined key-bindings set for example in ~/.fthrc.\n\
1268 One argument (KEY):\n\
1269 If KEY is a string, take it as configure string. \
1270 If KEY is a predefined constant, set specific value as configure string.\n\
1271 Valid constants:\n\
1272 gl-vi => edit-mode vi\n\
1273 gl-emacs => edit-mode emacs\n\
1274 gl-none => edit-mode none\n\
1275 gl-nobeep => nobeep\n\
1276 Two arguments (KEY ACTION):\n\
1277 If KEY and ACTION are strings, bind ACTION to KEY. \
1278 If KEY is a string and ACTION is anything else, unbind KEY from last bind.\n\
1279 See tecla(7) for key-bindings and actions."
1280 GetLine *gl;
1281 FTH key, action;
1282 char *k, *a;
1283 int i, l, len;
1284
1285 gl = ficlVmGetRepl(vm);
1286 len = FTH_STACK_DEPTH(vm);
1287
1288 switch (len) {
1289 case 0:
1290 /*-
1291 * show current key-bindings and configurations
1292 */
1293 l = simple_array_length(fgl_getline_config);
1294
1295 for (i = 0; i < l; i++) {
1296 k = simple_array_ref(fgl_getline_config, i);
1297 fth_printf("config[%d]: %s\n", i, k);
1298 }
1299
1300 l = simple_array_length(fgl_getline_bindkey);
1301
1302 for (i = 0; i < l; i += 2) {
1303 k = simple_array_ref(fgl_getline_bindkey, i);
1304 a = simple_array_ref(fgl_getline_bindkey, i + 1);
1305 if (a == NULL)
1306 a = "undef";
1307 fth_printf("bindkey[%d]: %s => %s\n", i, k, a);
1308 }
1309 break;
1310 case 1:
1311 /*-
1312 * gl_config()
1313 *
1314 * KEY is string:
1315 * "edit-mode vi \n nobeep" bindkey
1316 *
1317 * KEY is one of the predefined constants:
1318 * gl-vi bindkey
1319 * gl-emacs bindkey
1320 * gl-none bindkey
1321 * gl-nobeep bindkey
1322 */
1323 key = fth_pop_ficl_cell(vm);
1324
1325 if (gl_config(gl, key)) {
1326 FTH_GL_ERROR(gl);
1327 /* NOTREACHED */
1328 return;
1329 }
1330 break;
1331 case 2:
1332 default:
1333 /*-
1334 * gl_bind_keyseq()
1335 *
1336 * KEY must be a string!
1337 * ACTION can be a string: "^G" "user-interrupt" bindkey
1338 * binds ACTION to KEY
1339 * ACTION is anything else: "^G" #f bindkey
1340 * unbinds KEY from previous bound ACTION
1341 */
1342 action = fth_pop_ficl_cell(vm);
1343 key = fth_pop_ficl_cell(vm);
1344 FTH_ASSERT_ARGS(FTH_STRING_P(key), key, FTH_ARG1, "a string");
1345 k = fth_string_ref(key);
1346 a = fth_string_ref(action);
1347 simple_array_push(fgl_getline_bindkey, k);
1348 simple_array_push(fgl_getline_bindkey, a);
1349
1350 if (gl != NULL)
1351 if (gl_bind_keyseq(gl, GL_USER_KEY, k, a)) {
1352 FTH_GL_ERROR(gl);
1353 /* NOTREACHED */
1354 return;
1355 }
1356 break;
1357 }
1358 }
1359
1360 /* ARGSUSED */
1361 static int
repl_command_generator(WordCompletion * cpl,void * data,const char * line,int word_end)1362 repl_command_generator(WordCompletion * cpl,
1363 void *data, const char *line, int word_end)
1364 {
1365 ficlDictionary *dict;
1366 ficlHash *hash;
1367 ficlWord *word;
1368 CplMatches *matches;
1369 const char *text;
1370 size_t len;
1371 int i, j;
1372
1373 (void) data;
1374
1375 /*
1376 * Find begin of word.
1377 */
1378 for (i = word_end; i >= 0; i--)
1379 if (isspace((int) line[i]))
1380 break;
1381
1382 len = (size_t) (word_end - ++i);
1383 text = line + i;
1384 dict = FTH_FICL_DICT();
1385
1386 /*
1387 * Search for words beginning with TEXT.
1388 */
1389 for (i = (int) dict->wordlistCount - 1; i >= 0; i--)
1390 for (hash = dict->wordlists[i];
1391 hash != NULL;
1392 hash = hash->link)
1393 for (j = (int) hash->size - 1; j >= 0; j--)
1394 for (word = hash->table[j];
1395 word != NULL;
1396 word = word->link)
1397 if (word->length > 0 &&
1398 strncmp(word->name, text, len) == 0)
1399 /*
1400 * If found word is the only
1401 * completion, append a
1402 * space.
1403 */
1404 cpl_add_completion(cpl,
1405 line, i, word_end,
1406 word->name + len,
1407 NULL, " ");
1408 matches = cpl_recall_matches(cpl);
1409
1410 /*
1411 * If nothing was found, check for filename completion.
1412 */
1413 if (matches->nmatch == 0)
1414 cpl_file_completions(cpl, NULL, line, word_end);
1415
1416 return (0);
1417 }
1418
1419 static int
repl_init_history(void)1420 repl_init_history(void)
1421 {
1422 int hist_len;
1423 char *tmp_str;
1424 FTH fs , fn;
1425
1426 /*-
1427 * Set history file.
1428 *
1429 * Check for:
1430 * - Fth variable *histfile*
1431 * - environment variable $FTH_HISTORY
1432 * - otherwise default to FTH_HIST_FILE
1433 */
1434 fs = FGL_HISTFILE_REF();
1435
1436 if (fth_string_length(fs) <= 0) {
1437 tmp_str = getenv(FTH_ENV_HIST);
1438
1439 if (tmp_str == NULL)
1440 fs = fth_make_string_format("%s/" FTH_HIST_FILE,
1441 fth_getenv("HOME", "/tmp"));
1442 else
1443 fs = fth_make_string(tmp_str);
1444
1445 FGL_HISTFILE_SET(fs);
1446 }
1447
1448 /*-
1449 * Set history length.
1450 *
1451 * Check for:
1452 * - Fth variable *history*
1453 * - environment variable $FTH_HISTORY_LENGTH
1454 * - otherwise default to FTH_HIST_LEN
1455 */
1456 fn = FGL_HISTORY_REF();
1457 hist_len = (int) fth_int_ref_or_else(fn, -1);
1458
1459 if (hist_len == -1) {
1460 tmp_str = getenv(FTH_ENV_HIST_LEN);
1461
1462 if (tmp_str != NULL)
1463 hist_len = (int) strtol(tmp_str, NULL, 10);
1464 }
1465 if (hist_len < FTH_HIST_LEN)
1466 hist_len = FTH_HIST_LEN;
1467
1468 FGL_HISTORY_CSET(hist_len);
1469 return (hist_len);
1470 }
1471
1472 /*-
1473 * XXX: gl_append_history() (Wed Jan 15 18:10:07 CET 2014)
1474 *
1475 * According to libtecla's source files, gl_append_history() adds only
1476 * unique history lines. But this doesn't seem to work.
1477 *
1478 * Here we try a tcsh-like scheme where *histdup* can be set to
1479 * gl-all (uniq events only), gl-prev (not again if previous is
1480 * the same), or undef (all is added, the default).
1481 */
1482 static int
repl_append_history(GetLine * gl,char * line)1483 repl_append_history(GetLine * gl, char *line)
1484 {
1485 unsigned long id;
1486 GlHistoryRange range;
1487 GlHistoryLine hline;
1488 size_t size;
1489 char *s;
1490
1491 /* replace '\n' */
1492 s = strchr(line, '\n');
1493 if (s)
1494 size = s - line;
1495 else
1496 size = fth_strlen(line);
1497
1498 if (FGL_HISTDUP_ALL_P()) {
1499 gl_range_of_history(gl, &range);
1500
1501 for (id = range.newest; id > range.oldest; id--)
1502 if (gl_lookup_history(gl, id, &hline))
1503 if (strncmp(hline.line, line, size) == 0)
1504 return (0);
1505 } else if (FGL_HISTDUP_PREV_P()) {
1506 gl_range_of_history(gl, &range);
1507
1508 if (gl_lookup_history(gl, range.newest, &hline))
1509 if (strncmp(hline.line, line, size) == 0)
1510 return (0);
1511 }
1512 gl_append_history(gl, line);
1513 return (0);
1514 }
1515
1516 static char hist_buffer[FGL_BUFFER + 1];
1517
1518 /*-
1519 * If command line starts with !, try to substitute with commands from
1520 * previous history events.
1521 *
1522 * !123 repeat event 123
1523 * !-123 repeat 123rd last event
1524 * !! repeat last event (same as !-1)
1525 * !?sub_string(?) repeat last event containing SUB_STRING
1526 * !start_of_string repeat last event starting with START_OF_STRING
1527 */
1528 static char *
repl_expand_history(GetLine * gl,char * line)1529 repl_expand_history(GetLine * gl, char *line)
1530 {
1531 unsigned long id;
1532 GlHistoryRange range;
1533 GlHistoryLine hline;
1534 long ld;
1535 int i;
1536 size_t ln;
1537 char s[FGL_BUFFER + 1], *r;
1538
1539 ln = fth_strlen(line);
1540
1541 if (ln < 2)
1542 return (line);
1543
1544 /* skip '!' sign */
1545 fth_strcpy(s, sizeof(s), line + 1);
1546 ln--;
1547 /* adjust length minus trailing '\n' */
1548 ln--;
1549 /* remove trailing '\n' */
1550 s[ln] = '\0';
1551 gl_range_of_history(gl, &range);
1552 id = range.newest;
1553 r = hist_buffer;
1554
1555 if (isdigit((int) *s) || *s == '-') {
1556 /* !123 or !-123 */
1557 ld = strtol(s, NULL, 10);
1558
1559 if (ld < 0)
1560 id += ++ld;
1561 else
1562 id = ld;
1563
1564 if (gl_lookup_history(gl, id, &hline))
1565 return (fth_strcpy(r, FGL_BUFFER, hline.line));
1566 } else if (*s == '!') {
1567 /* !! */
1568 if (gl_lookup_history(gl, id, &hline))
1569 return (fth_strcpy(r, FGL_BUFFER, hline.line));
1570 } else if (*s == '?') {
1571 /* !?sub_string(?) */
1572 size_t sl;
1573 char *re;
1574
1575 re = s + 1;
1576 sl = fth_strlen(re);
1577
1578 if (re[sl] == '?')
1579 re[sl] = '\0';
1580
1581 for (; id > range.oldest; id--)
1582 if (gl_lookup_history(gl, id, &hline))
1583 if (fth_regexp_find(re, hline.line) != -1) {
1584 fth_strcpy(r, FGL_BUFFER, hline.line);
1585 return (r);
1586 }
1587 } else
1588 /* !start_of_string */
1589 for (; id > range.oldest; id--)
1590 if (gl_lookup_history(gl, id, &hline))
1591 if (strncmp(s, hline.line, ln) == 0) {
1592 fth_strcpy(r, FGL_BUFFER, hline.line);
1593 return (r);
1594 }
1595 i = 0;
1596
1597 if (*s == '!')
1598 i++;
1599
1600 if (*s == '?')
1601 i++;
1602
1603 fth_printf("%s: event not found\n", s + i);
1604 return (NULL);
1605 }
1606
1607 /*-
1608 * If command line starts with ^, try a search from previous history
1609 * events and replace it with second part of ^search^replace.
1610 *
1611 * ^search^replace(^)
1612 */
1613 static char *
repl_replace_history(GetLine * gl,char * line)1614 repl_replace_history(GetLine * gl, char *line)
1615 {
1616 unsigned long id;
1617 GlHistoryRange range;
1618 GlHistoryLine hline;
1619 size_t i, j;
1620 char src[FGL_BUFFER], dst[FGL_BUFFER];
1621
1622 if (strlen(line) < 4)
1623 return (line);
1624
1625 i = 0;
1626 j = 1; /* skip 1st ^ */
1627
1628 while (line[j] != '^' && !isspace((int) line[j]))
1629 src[i++] = line[j++];
1630
1631 src[i] = '\0';
1632 i = 0;
1633 j++; /* skip 2nd ^ */
1634
1635 while (line[j] != '^' && !isspace((int) line[j]))
1636 dst[i++] = line[j++];
1637
1638 dst[i] = '\0';
1639 gl_range_of_history(gl, &range);
1640 id = range.newest;
1641
1642 for (; id > range.oldest; id--)
1643 if (gl_lookup_history(gl, id, &hline))
1644 if (fth_regexp_find(src, hline.line) != -1) {
1645 FTH reg , str, rep, rpl;
1646
1647 reg = fth_make_regexp(src);
1648 str = fth_make_string(hline.line);
1649 rep = fth_make_string(dst);
1650 rpl = fth_regexp_replace(reg, str, rep);
1651 return (fth_string_ref(rpl));
1652 }
1653 fth_printf("%s: event not found\n", src);
1654 return (NULL);
1655 }
1656
1657 #else /* !HAVE_LIBTECLA */
1658
1659 static void ficl_bindkey(ficlVm *vm);
1660 static char *get_line(char *prompt, char *dummy);
1661 static char utils_readline_buffer[BUFSIZ];
1662
1663 static void
ficl_bindkey(ficlVm * vm)1664 ficl_bindkey(ficlVm *vm)
1665 {
1666 #define h_bindkey "( :optional key action -- ) noop without libtecla"
1667 int len;
1668
1669 /* clear at most 2 stack entries */
1670 len = FTH_STACK_DEPTH(vm);
1671
1672 switch (len) {
1673 case 2:
1674 fth_pop_ficl_cell(vm);
1675 /* FALLTHROUGH */
1676 case 1:
1677 fth_pop_ficl_cell(vm);
1678 /* FALLTHROUGH */
1679 default:
1680 break;
1681 }
1682 }
1683
1684 /* ARGSUSED */
1685 static char *
get_line(char * prompt,char * dummy)1686 get_line(char *prompt, char *dummy)
1687 {
1688 char *buf;
1689
1690 (void) dummy;
1691
1692 if (prompt != NULL)
1693 fth_print(prompt);
1694
1695 buf = utils_readline_buffer;
1696 buf[0] = '\0';
1697 fgets(buf, BUFSIZ, stdin);
1698
1699 if (*buf == '\0') /* Ctrl-D */
1700 return (NULL);
1701
1702 return (buf);
1703 }
1704
1705 #endif /* !HAVE_LIBTECLA */
1706
1707 void
fth_repl(int argc,char ** argv)1708 fth_repl(int argc, char **argv)
1709 {
1710 static ficlInteger lineno;
1711 ficlVm *vm;
1712 char *line;
1713 char *volatile prompt;
1714 char *volatile err_line;
1715 volatile int compile_p;
1716 volatile int status;
1717 #if !defined(_WIN32)
1718 volatile int sig;
1719 #endif
1720 int i, len;
1721 #if defined(HAVE_LIBTECLA)
1722 GetLine *gl;
1723 GlHistoryRange range;
1724 GlReturnStatus rs;
1725 #endif
1726
1727 vm = FTH_FICL_VM();
1728 prompt = NULL;
1729 err_line = NULL;
1730 compile_p = 0;
1731 status = FICL_VM_STATUS_OUT_OF_TEXT;
1732 fth_current_file = fth_make_string("repl-eval");
1733 fth_in_repl_p = 1;
1734 #if defined(HAVE_LIBTECLA)
1735 gl = new_GetLine(FGL_BUFFER, FGL_BUFFER * repl_init_history());
1736
1737 if (gl == NULL) {
1738 fprintf(stderr, "cannot initialize GetLine\n");
1739 fth_exit(EXIT_FAILURE);
1740 }
1741 ficlVmGetRepl(vm) = gl;
1742
1743 /*
1744 * We have to load explicitely ~/.teclarc. Subsequent calls of
1745 * gl_configure_getline() will trigger gl->configure = 1 and GetLine
1746 * will skip further implicite calls of gl_configure_getline() (via
1747 * gl_get_line() etc).
1748 */
1749 if (gl_configure_getline(gl, NULL, NULL, FGL_TECLA_RC)) {
1750 FTH_GL_ERROR(gl);
1751 /* NOTREACHED */
1752 return;
1753 }
1754
1755 /*
1756 * Delayed init of config and bindkey sequences from ~/.fthrc.
1757 */
1758 len = simple_array_length(fgl_getline_config);
1759
1760 for (i = 0; i < len; i++) {
1761 char *app;
1762
1763 app = simple_array_ref(fgl_getline_config, i);
1764
1765 if (gl_configure_getline(gl, app, NULL, NULL)) {
1766 FTH_GL_ERROR(gl);
1767 /* NOTREACHED */
1768 return;
1769 }
1770 }
1771 len = simple_array_length(fgl_getline_bindkey);
1772
1773 for (i = 0; i < len; i += 2) {
1774 char *k, *a;
1775
1776 k = simple_array_ref(fgl_getline_bindkey, i);
1777 a = simple_array_ref(fgl_getline_bindkey, i + 1);
1778
1779 if (gl_bind_keyseq(gl, GL_USER_KEY, k, a)) {
1780 FTH_GL_ERROR(gl);
1781 /* NOTREACHED */
1782 return;
1783 }
1784 }
1785
1786 gl_automatic_history(gl, 0);
1787 gl_customize_completion(gl, NULL, repl_command_generator);
1788 gl_prompt_style(gl,
1789 FGL_PROMPTSTYLE_P() ? GL_FORMAT_PROMPT : GL_LITERAL_PROMPT);
1790 gl_load_history(gl, FGL_HISTFILE_CSTR(), FGL_COMMENT);
1791 gl_range_of_history(gl, &range);
1792 lineno = (ficlInteger) range.newest;
1793 #else
1794 lineno = 1;
1795 #endif
1796 fth_set_argv(0, argc, argv);
1797
1798 /*
1799 * Call hook before starting repl.
1800 */
1801 if (!fth_hook_empty_p(before_repl_hook))
1802 fth_run_hook(before_repl_hook, 0);
1803
1804 fth_current_line = lineno;
1805 fth_interactive_p = 1;
1806
1807 /*
1808 * Main loop.
1809 */
1810 while (status != FTH_BYE) {
1811 line = NULL;
1812 prompt = NULL;
1813 #if defined(HAVE_LIBTECLA)
1814 gl_range_of_history(gl, &range);
1815 lineno = (ficlInteger) range.newest + 1;
1816 #endif
1817 if (compile_p)
1818 prompt = FTH_REPL_PROMPT2; /* continue prompt */
1819 else if (!fth_hook_empty_p(before_prompt_hook)) {
1820 FTH fs;
1821
1822 fs = fth_run_hook_again(before_prompt_hook,
1823 2,
1824 fth_make_string(prompt),
1825 INT_TO_FIX(lineno));
1826 prompt = fth_string_ref(fs);
1827 }
1828 if (prompt == NULL)
1829 prompt = FTH_REPL_PROMPT;
1830
1831 fth_print_p = 0;
1832 #if !defined(_WIN32)
1833 sig = sigsetjmp(fth_sig_toplevel, 1);
1834
1835 if (sig != 0) {
1836 signal_check(sig);
1837 errno = 0;
1838 ficlVmReset(vm);
1839 continue;
1840 }
1841 #endif
1842 #if defined(HAVE_LIBTECLA)
1843 line = gl_get_line(gl, prompt, err_line, -1);
1844
1845 if (line == NULL) {
1846 rs = gl_return_status(gl);
1847
1848 if (rs == GLR_EOF) {
1849 status = FTH_BYE;
1850 continue;
1851 }
1852 if (rs == GLR_ERROR) {
1853 FTH_GL_ERROR(gl);
1854 /* NOTREACHED */
1855 return;
1856 }
1857 continue;
1858 }
1859
1860 /*
1861 * If command line starts with !, try to substitute with
1862 * commands from previous history events.
1863 */
1864 if (*line == '!') {
1865 line = repl_expand_history(gl, line);
1866
1867 if (line == NULL)
1868 continue;
1869
1870 fth_printf("%s\n", line);
1871 }
1872
1873 /*
1874 * If command line starts with ^, try a search from previous
1875 * history events and replace it with second part of
1876 * ^search^replace.
1877 */
1878 if (*line == '^') {
1879 line = repl_replace_history(gl, line);
1880
1881 if (line == NULL)
1882 continue;
1883
1884 fth_printf("%s\n", line);
1885 }
1886 #else /* !HAVE_LIBTECLA */
1887 line = get_line(prompt, err_line);
1888
1889 if (line == NULL) /* Ctrl-D finishes repl */
1890 break;
1891 #endif /* HAVE_LIBTECLA */
1892 if (*line == '\n') { /* empty line */
1893 if (fth_true_repl_p)
1894 fth_printf("%S\n", FTH_UNDEF);
1895 continue;
1896 }
1897 status = fth_catch_eval(line);
1898
1899 if (status == FTH_ERROR) {
1900 /*
1901 * If an error occures, show wrong command again.
1902 */
1903 err_line = line;
1904 continue;
1905 }
1906 err_line = NULL;
1907
1908 if (status == FTH_BYE)
1909 break;
1910
1911 fth_current_line = lineno++;
1912 compile_p = (vm->state == FICL_VM_STATE_COMPILE);
1913
1914 if (compile_p)
1915 continue;
1916
1917 #if defined(HAVE_LIBTECLA)
1918 repl_append_history(gl, line);
1919 #endif
1920
1921 status = FTH_OKAY;
1922
1923 if (!fth_true_repl_p) { /* forth repl */
1924 if (fth_print_p)
1925 fth_print("\n");
1926 continue;
1927 }
1928 len = FTH_STACK_DEPTH(vm);
1929
1930 switch (len) {
1931 case 0:
1932 if (!fth_print_p)
1933 fth_printf("%S", FTH_UNDEF);
1934 break;
1935 case 1:
1936 fth_printf("%S", fth_pop_ficl_cell(vm));
1937 break;
1938 default:
1939 for (i = len - 1; i >= 0; i--) {
1940 ficlStackRoll(vm->dataStack, i);
1941 fth_printf("%S ", fth_pop_ficl_cell(vm));
1942 }
1943 break;
1944 }
1945
1946 fth_print("\n");
1947 } /* while */
1948 #if defined(HAVE_LIBTECLA)
1949 if (FGL_SAVEHIST_P())
1950 gl_save_history(gl, FGL_HISTFILE_CSTR(), FGL_COMMENT,
1951 FGL_HISTORY_CINT());
1952
1953 ficlVmGetRepl(vm) = del_GetLine(gl);
1954 #endif
1955 if (fth_print_p)
1956 fth_print("\n");
1957
1958 /*
1959 * Call hook after finishing repl.
1960 */
1961 if (!fth_hook_empty_p(after_repl_hook))
1962 fth_run_hook(after_repl_hook, 1, FGL_HISTFILE_REF());
1963
1964 fth_exit(EXIT_SUCCESS);
1965 }
1966
1967 static void
ficl_repl_cb(ficlVm * vm)1968 ficl_repl_cb(ficlVm *vm)
1969 {
1970 #define h_repl_cb "( -- ) show some hints at startup\n\
1971 A hard coded before-repl-hook. \
1972 Before adding your own:\n\
1973 before-repl-hook reset-hook!."
1974 (void) vm;
1975 if (FTH_TRUE_P(fth_variable_ref("*fth-verbose*"))) {
1976 fth_print("\\\n");
1977 fth_print("\\ type help <word> to get help, \
1978 e.g. `help make-array'\n");
1979 fth_print("\\ type C-c for break\n");
1980 fth_print("\\ type C-\\ for fast exit\n");
1981 fth_print("\\ type C-d or `bye' for exit\n");
1982 fth_print("\\\n");
1983 }
1984 }
1985
1986 static void
ficl_cold(ficlVm * vm)1987 ficl_cold(ficlVm *vm)
1988 {
1989 #define h_cold "( -- ) reset ficl system."
1990 fth_reset_loop_and_depth();
1991 ficlVmReset(vm);
1992
1993 if (fth_in_repl_p)
1994 if (!fth_hook_empty_p(before_repl_hook))
1995 fth_run_hook(before_repl_hook, 0);
1996
1997 errno = 0;
1998 ficlVmThrow(vm, FICL_VM_STATUS_QUIT);
1999 }
2000
2001 #if defined(HAVE_LIBTECLA)
2002 static void
ficl_ps_cb(ficlVm * vm)2003 ficl_ps_cb(ficlVm *vm)
2004 {
2005 #define h_ps_cb "( val -- res ) callback for setting *promptstyle*."
2006 int fp;
2007 GetLine *gl;
2008
2009 FTH_STACK_CHECK(vm, 1, 1);
2010 fp = ficlStackPopBoolean(vm->dataStack);
2011 gl = ficlVmGetRepl(vm);
2012 gl_prompt_style(gl, fp ? GL_FORMAT_PROMPT : GL_LITERAL_PROMPT);
2013 ficlStackPushBoolean(vm->dataStack, fp);
2014 }
2015 #endif
2016
2017 static void
ficl_fgl_erase(ficlVm * vm)2018 ficl_fgl_erase(ficlVm *vm)
2019 {
2020 ficlStackPushFTH(vm->dataStack, fgl_all);
2021 }
2022
2023 static void
ficl_pos_xx(ficlVm * vm)2024 ficl_pos_xx(ficlVm *vm)
2025 {
2026 ficlStackPushFTH(vm->dataStack, fth_variable_ref("*line*"));
2027 }
2028
2029 static void
ficl_print_pos_xx(ficlVm * vm)2030 ficl_print_pos_xx(ficlVm *vm)
2031 {
2032 (void) vm;
2033 fth_printf("%S", fth_variable_ref("*line*"));
2034 }
2035
2036 #define MAKE_POSITION_WORDS(Numb) \
2037 static void \
2038 ficl_pos_0 ## Numb(ficlVm *vm) \
2039 { \
2040 FTH ary; \
2041 FTH val; \
2042 \
2043 ary = fth_variable_ref("*farray*"); \
2044 \
2045 if (fth_array_length(ary) > Numb) \
2046 val = fth_array_ref(ary, Numb); \
2047 else \
2048 val = fth_make_empty_string(); \
2049 \
2050 ficlStackPushFTH(vm->dataStack, val); \
2051 } \
2052 \
2053 static void \
2054 ficl_print_pos_0 ## Numb(ficlVm *vm) \
2055 { \
2056 FTH ary; \
2057 \
2058 (void) vm; \
2059 ary = fth_variable_ref("*farray*"); \
2060 \
2061 if (fth_array_length(ary) > Numb) \
2062 fth_printf("%S", fth_array_ref(ary, Numb)); \
2063 else \
2064 fth_printf(""); \
2065 \
2066 fth_printf("%S", fth_variable_ref("*ofs*")); \
2067 }
2068
2069 MAKE_POSITION_WORDS(0);
2070 MAKE_POSITION_WORDS(1);
2071 MAKE_POSITION_WORDS(2);
2072 MAKE_POSITION_WORDS(3);
2073 MAKE_POSITION_WORDS(4);
2074 MAKE_POSITION_WORDS(5);
2075 MAKE_POSITION_WORDS(6);
2076 MAKE_POSITION_WORDS(7);
2077 MAKE_POSITION_WORDS(8);
2078
2079 void
init_utils(void)2080 init_utils(void)
2081 {
2082 #define FGL_MAKE_STRING_CONSTANT(Str) \
2083 fth_define_constant(Str, fth_make_string(Str), NULL)
2084 #define FGL_SET_CONSTANT(Name) \
2085 fgl_ ##Name = FGL_MAKE_STRING_CONSTANT("gl-" #Name)
2086 #if defined(HAVE_LIBTECLA)
2087 fth_add_feature("tecla");
2088 fth_add_feature("libtecla");
2089
2090 FTH_GET_LINE_ERROR;
2091 fgl_getline_config = make_simple_array(16);
2092 fgl_getline_bindkey = make_simple_array(16);
2093
2094 /* history constants */
2095 FGL_SET_CONSTANT(show);
2096 FGL_SET_CONSTANT(load);
2097 FGL_SET_CONSTANT(save);
2098 FGL_SET_CONSTANT(add);
2099 FGL_SET_CONSTANT(clear);
2100 FTH_PRI1("history-lineno", ficl_history_lineno, h_hist_lineno);
2101 FTH_PRI1("history-next", ficl_history_next, h_hist_next);
2102 FTH_PRI1("history-prev", ficl_history_prev, h_hist_prev);
2103 FTH_PRI1("history", ficl_history, h_history);
2104 #endif
2105 /* bindkey constants */
2106 FGL_SET_CONSTANT(vi);
2107 FGL_SET_CONSTANT(emacs);
2108 FGL_SET_CONSTANT(none);
2109 FGL_SET_CONSTANT(nobeep);
2110 FTH_PRI1("bindkey", ficl_bindkey, h_bindkey);
2111
2112 /* *histdup* constants */
2113 FGL_SET_CONSTANT(all);
2114 FGL_SET_CONSTANT(prev);
2115 /*
2116 * XXX: for backwards compatibility, returns fgl_all.
2117 */
2118 FTH_PRI1("gl-erase", ficl_fgl_erase, NULL);
2119 fth_define_variable("*histdup*", FTH_UNDEF,
2120 "History variable (constant).\n\
2121 If set to GL-ALL, only unique history events are entered in the history list. \
2122 If set to GL-PREV and the last history event is the same as the current, \
2123 the current command is not entered. \
2124 If not defined (undef, the default), all history events are entered.");
2125 fth_define_variable("*histfile*", FTH_UNDEF,
2126 "History variable (string).\n\
2127 Can be set to the pathname where history is going to be saved and restored. \
2128 If not set, use $FTH_HISTORY or ~/" FTH_HIST_FILE ".\n\
2129 Default is undef.");
2130 fth_define_variable("*history*", FTH_UNDEF,
2131 "History variable (numeric).\n\
2132 Can be given a numeric value to control the size of the history list. \
2133 If not set, use $FTH_HISTORY_LENGTH or " FTH_XString(FTH_HIST_LEN) ".\n\
2134 Default is undef.");
2135 fth_define_variable("*savehist*", FTH_TRUE,
2136 "History variable (boolean).\n\
2137 If true, save history events, otherwise not.\n\
2138 Default is #t.");
2139 fth_define_variable("*argc*", FTH_ZERO,
2140 "number of arguments in *argv*");
2141 fth_define_variable("*argv*", fth_make_empty_array(),
2142 "command line args array");
2143 fth_define_variable("*line*", fth_make_string(""),
2144 "current in-place processing line");
2145 fth_define_variable("*farray*", FTH_FALSE,
2146 "auto-splitted array of current line");
2147 fth_define_variable("*fname*", fth_make_string("-"),
2148 "current in-place filename");
2149 fth_define_variable("*fs*", fth_make_string(" "),
2150 "input field separator");
2151 fth_define_variable("*ofs*", fth_make_string(" "),
2152 "output field separator");
2153 fth_define_variable("*fnr*", FTH_ZERO,
2154 "input record number in current file");
2155 fth_define_variable("*nr*", FTH_ZERO,
2156 "input record number since beginning");
2157 FTH_PRI1("*0*", ficl_pos_xx, "entire current line");
2158 FTH_PRI1("*1*", ficl_pos_00, "1st word of current line");
2159 FTH_PRI1("*2*", ficl_pos_01, "2nd word of current line");
2160 FTH_PRI1("*3*", ficl_pos_02, "3rd word of current line");
2161 FTH_PRI1("*4*", ficl_pos_03, "4th word of current line");
2162 FTH_PRI1("*5*", ficl_pos_04, "5th word of current line");
2163 FTH_PRI1("*6*", ficl_pos_05, "6th word of current line");
2164 FTH_PRI1("*7*", ficl_pos_06, "7th word of current line");
2165 FTH_PRI1("*8*", ficl_pos_07, "8th word of current line");
2166 FTH_PRI1("*9*", ficl_pos_08, "9th word of current line");
2167 FTH_PRI1(".*0*", ficl_print_pos_xx, "print entire current line");
2168 FTH_PRI1(".*1*", ficl_print_pos_00, "print 1st word of current line");
2169 FTH_PRI1(".*2*", ficl_print_pos_01, "print 2nd word of current line");
2170 FTH_PRI1(".*3*", ficl_print_pos_02, "print 3rd word of current line");
2171 FTH_PRI1(".*4*", ficl_print_pos_03, "print 4th word of current line");
2172 FTH_PRI1(".*5*", ficl_print_pos_04, "print 5th word of current line");
2173 FTH_PRI1(".*6*", ficl_print_pos_05, "print 6th word of current line");
2174 FTH_PRI1(".*7*", ficl_print_pos_06, "print 7th word of current line");
2175 FTH_PRI1(".*8*", ficl_print_pos_07, "print 8th word of current line");
2176 FTH_PRI1(".*9*", ficl_print_pos_08, "print 9th word of current line");
2177 FTH_PRI1("cold", ficl_cold, h_cold);
2178 before_repl_hook = fth_make_hook("before-repl-hook", 0,
2179 "before-repl-hook ( -- ) \
2180 Called after initializing the tecla(7) command-line \
2181 editing library but before starting the repl. \
2182 A predefined hook showing some help lines can be \
2183 replaced by your own message:\n\
2184 before-repl-hook reset-hook!\n\
2185 before-repl-hook lambda: <{ -- }>\n\
2186 .\" \\\" cr\n\
2187 .\" \\ Starting FTH on \" date .string .\" !\" cr\n\
2188 .\" \\\" cr\n\
2189 ; add-hook!");
2190 after_repl_hook = fth_make_hook("after-repl-hook", 1,
2191 "after-repl-hook ( history-file -- ) \
2192 Called after leaving the repl and writing the \
2193 history file but before leaving the program. \
2194 Its only argument is the history filename. \
2195 You may manipulate the history data entries. \
2196 One history entry consists of two lines: \
2197 a time stamp preceded by a Forth comment backslash \
2198 and the actual history line.\n\
2199 after-repl-hook lambda: <{ history -- }>\n\
2200 \\ Remove duplicates from history file.\n\
2201 history readlines array-reverse! { hary }\n\
2202 #() \"\" \"\" { nhary hline tline }\n\
2203 hary array-length 0 ?do\n\
2204 hary i array-ref to hline\n\
2205 hary i 1+ array-ref to tline\n\
2206 nhary hline array-member? unless\n\
2207 hary hline array-unshift tline array-unshift drop\n\
2208 then\n\
2209 2 +loop\n\
2210 history nhary writelines\n\
2211 ; add-hook!");
2212 before_prompt_hook = fth_make_hook("before-prompt-hook", 2,
2213 "before-prompt-hook ( prompt pos -- new-prompt ) \
2214 Called before printing a new prompt to customize the output of it. \
2215 PROMPT is the old prompt and POS the current history position. \
2216 The return value, preferable a string, is the \
2217 PROMPT argument for the next hook procedure if any.\n\
2218 before-prompt-hook lambda: <{ prompt pos -- new-prompt }>\n\
2219 \"fth (%d)> \" #( pos ) string-format\n\
2220 ; add-hook!");
2221 {
2222 ficlWord *ps, *rcb;
2223 #if defined(HAVE_LIBTECLA)
2224 ficlWord *pscb;
2225 #endif
2226
2227 ps = FTH_CONSTANT_SET("*promptstyle*", FTH_FALSE);
2228 fth_word_doc_set(ps, "Prompt style variable (boolean).\n\
2229 If true, enable special formatting directives within the prompt, \
2230 see gl_prompt_style(3).\n\
2231 Default is #f.");
2232 #if defined(HAVE_LIBTECLA)
2233 pscb = FTH_PRI1("prompt-style-cb", ficl_ps_cb, h_ps_cb);
2234 fth_trace_var((FTH) ps, (FTH) pscb);
2235 #endif
2236 rcb = FTH_PRI1("repl-cb", ficl_repl_cb, h_repl_cb);
2237 fth_add_hook(before_repl_hook, (FTH) rcb);
2238 }
2239 }
2240
2241 /*
2242 * utils.c ends here
2243 */
2244