1 /*
2 Copyright (c) 1991-1999 Thomas T. Wetmore IV
3
4 Permission is hereby granted, free of charge, to any person
5 obtaining a copy of this software and associated documentation
6 files (the "Software"), to deal in the Software without
7 restriction, including without limitation the rights to use, copy,
8 modify, merge, publish, distribute, sublicense, and/or sell copies
9 of the Software, and to permit persons to whom the Software is
10 furnished to do so, subject to the following conditions:
11
12 The above copyright notice and this permission notice shall be
13 included in all copies or substantial portions of the Software.
14
15 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16 EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17 MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
18 NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
19 BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
20 ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
21 CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
22 SOFTWARE.
23 */
24 /*=============================================================
25 * Copyright(c) 1991-95 by T.T. Wetmore IV; all rights reserved
26 * pre-SourceForge version information:
27 * 2.3.4 - 24 Jun 93 2.3.5 - 26 Sep 93
28 * 3.0.0 - 28 Jun 94 3.0.2 - 04 Apr 95
29 * 3.0.3 - 25 Aug 95
30 *===========================================================*/
31
32 #include "llstdlib.h"
33 /* llstdlib.h pulls in standard.h, config.h, sys_inc.h */
34 #include "table.h"
35 #include "translat.h"
36 #include "gedcom.h"
37 #include "interpi.h"
38 #include "liflines.h"
39 #include "lloptions.h"
40 #include "feedback.h" /* call_system_cmd */
41 #include "zstr.h"
42 #include "version.h"
43
44 /*********************************************
45 * external/imported variables
46 *********************************************/
47
48 extern STRING qSnotonei, qSifonei;
49
50 /*********************************************
51 * local function prototypes
52 *********************************************/
53
54 /* alphabetical */
55 static STRING allocsubstring(STRING s, INT i, INT j);
56 static void compute_pi(STRING pi, STRING sub);
57 static double deg2rad(double deg);
58 static INT ll_index(STRING str, STRING sub, INT num);
59 static INT kmp_search(STRING pi, STRING str, STRING sub, INT num);
60 static void makestring(PVALUE val, STRING str, INT len, BOOLEAN *eflg);
61 static double rad2deg(double rad);
62 static STRING rightjustify(STRING str, INT len);
63
64 /*********************************************
65 * local variables
66 *********************************************/
67
68 BOOLEAN prog_trace = FALSE;
69
70 /*********************************************
71 * local function definitions
72 * body of module
73 *********************************************/
74
75 /*=============================================================+
76 * llrpt_extractnames -- Extract name parts from person or NAME node
77 * usage: extractnames(NODE, LIST, VARB, VARB) -> VOID
78 *============================================================*/
79 PVALUE
llrpt_extractnames(PNODE node,SYMTAB stab,BOOLEAN * eflg)80 llrpt_extractnames (PNODE node, SYMTAB stab, BOOLEAN *eflg)
81 {
82 LIST list=0;
83 STRING str=0, str2=0;
84 INT len=0, sind=0;
85 PNODE nexp = builtin_args(node);
86 PNODE lexp = inext(nexp);
87 PNODE lvar = inext(lexp);
88 PNODE svar = inext(lvar);
89 NODE line=0;
90 PVALUE val = eval_and_coerce(PGNODE, nexp, stab, eflg);
91 if (*eflg) {
92 prog_var_error(node, stab, nexp, val, nonnodx, "extractnames", "1");
93 delete_pvalue_ptr(&val);
94 return NULL;
95 }
96 line = pvalue_to_node(val);
97 delete_pvalue(val);
98 val = eval_and_coerce(PLIST, lexp, stab, eflg);
99 if (*eflg) {
100 prog_var_error(node, stab, lexp, val, nonlstx, "extractnames", "2");
101 delete_pvalue_ptr(&val);
102 return NULL;
103 }
104 list = pvalue_to_list(val);
105 delete_pvalue_ptr(&val);
106 if (list)
107 make_list_empty(list);
108 else
109 list = create_list();
110 *eflg = TRUE;
111 if (!iistype(lvar, IIDENT)) {
112 prog_var_error(node, stab, lvar, NULL, nonvarx, "extractnames", "3");
113 return NULL;
114 }
115 if (!iistype(svar, IIDENT)) {
116 prog_var_error(node, stab, svar, NULL, nonvarx, "extractnames", "4");
117 return NULL;
118 }
119 /* if it isn't a NAME line, look under it for a NAME line */
120 if (!eqstr("NAME", ntag(line)))
121 line = NAME(line);
122 /* now create all the values, whether or not we found a NAME line */
123 *eflg = FALSE;
124 str = (line ? nval(line) : 0);
125 if (str && str[0]) {
126 LIST temp = name_to_list(str, &len, &sind);
127 /* list has string elements */
128 FORLIST(temp, el)
129 str2 = (STRING)el;
130 push_list(list, create_pvalue_from_string(str2));
131 ENDLIST
132 destroy_list(temp);
133 } else {
134 /* no NAME line or empty NAME line */
135 len = 0;
136 sind = 0;
137 }
138 insert_symtab(stab, iident_name(lvar), create_pvalue_from_int(len));
139 insert_symtab(stab, iident_name(svar), create_pvalue_from_int(sind));
140 return NULL;
141 }
142 /*==============================================================+
143 * llrpt_extractplaces -- Extract place parts from event or PLAC NODE
144 * usage: extractplaces(NODE, LIST, VARB) -> VOID
145 *=============================================================*/
146 PVALUE
llrpt_extractplaces(PNODE node,SYMTAB stab,BOOLEAN * eflg)147 llrpt_extractplaces (PNODE node, SYMTAB stab, BOOLEAN *eflg)
148 {
149 LIST list=0, temp=0;
150 STRING str=0, str2=0;
151 INT len=0;
152 PNODE nexp = builtin_args(node);
153 PNODE lexp = inext(nexp);
154 PNODE lvar = inext(lexp);
155 NODE line;
156 PVALUE val = eval_and_coerce(PGNODE, nexp, stab, eflg);
157 if (*eflg) {
158 prog_var_error(node, stab, nexp, val, nonnodx, "extractplaces", "1");
159 delete_pvalue_ptr(&val);
160 return NULL;
161 }
162 line = pvalue_to_node(val);
163 delete_pvalue_ptr(&val);
164 val = eval_and_coerce(PLIST, lexp, stab, eflg);
165 if (*eflg) {
166 prog_var_error(node, stab, lexp, val, nonlstx, "extractplaces", "2");
167 delete_pvalue_ptr(&val);
168 return NULL;
169 }
170 list = pvalue_to_list(val);
171 delete_pvalue_ptr(&val); /* Could this inadvertently delete the list? */
172 if (list)
173 make_list_empty(list);
174 else
175 list = create_list();
176 *eflg = TRUE;
177 if (!iistype(lvar, IIDENT)) {
178 prog_var_error(node, stab, lvar, NULL, nonvarx, "extractplaces", "3");
179 return NULL;
180 }
181 insert_symtab(stab, iident_name(lvar), create_pvalue_from_int(0));
182 *eflg = FALSE;
183 if (!line) return NULL;
184 if (strcmp("PLAC", ntag(line)) && !(line = PLAC(line))) return NULL;
185 str = nval(line);
186 if (!str || *str == 0) return NULL;
187 temp = place_to_list(str, &len);
188 FORLIST(temp, el)
189 str2 = (STRING)el; /* place_to_list made list of strings */
190 push_list(list, create_pvalue_from_string(str2));
191 ENDLIST
192 insert_symtab(stab, iident_name(lvar), create_pvalue_from_int(len));
193 return NULL;
194 }
195 /*==========================================================+
196 * llrpt_extracttokens -- Extract tokens from a STRING value
197 * usage: extracttokens(STRING, LIST, VARB, STRING) -> VOID
198 *=========================================================*/
199 PVALUE
llrpt_extracttokens(PNODE node,SYMTAB stab,BOOLEAN * eflg)200 llrpt_extracttokens (PNODE node, SYMTAB stab, BOOLEAN *eflg)
201 {
202 LIST list=0, temp=0;
203 INT len;
204 STRING str, dlm;
205 PNODE sexp = builtin_args(node);
206 PNODE lexp = inext(sexp);
207 PNODE lvar = inext(lexp);
208 PNODE dexp = inext(lvar);
209 PVALUE val1 = eval_and_coerce(PSTRING, sexp, stab, eflg);
210 PVALUE val2=0;
211
212 if (*eflg) {
213 prog_var_error(node, stab, sexp, val1, nonstrx, "extracttokens", "1");
214 delete_pvalue_ptr(&val1);
215 return NULL;
216 }
217 str = pvalue_to_string(val1);
218 val2 = eval_and_coerce(PLIST, lexp, stab, eflg);
219 if (*eflg) {
220 prog_var_error(node, stab, lexp, val2, nonlstx, "extracttokens", "2");
221 delete_pvalue_ptr(&val1);
222 delete_pvalue_ptr(&val2);
223 return NULL;
224 }
225 list = pvalue_to_list(val2);
226 delete_pvalue(val2);
227 make_list_empty(list);
228 val2 = eval_and_coerce(PSTRING, dexp, stab, eflg);
229 if (*eflg) {
230 prog_var_error(node, stab, dexp, val2, nonstrx, "extracttokens", "4");
231 delete_pvalue_ptr(&val1);
232 delete_pvalue_ptr(&val2);
233 return NULL;
234 }
235 dlm = pvalue_to_string(val2);
236 if (!iistype(lvar, IIDENT)) {
237 *eflg = TRUE;
238 prog_var_error(node, stab, lvar, NULL, nonvarx, "extracttokens", "3");
239 delete_pvalue_ptr(&val1);
240 delete_pvalue_ptr(&val2);
241 return NULL;
242 }
243 insert_symtab(stab, iident_name(lvar), create_pvalue_from_int(0));
244 temp = value_to_list(str, &len, dlm);
245 FORLIST(temp, el)
246 push_list(list, create_pvalue_from_string((STRING)el));
247 ENDLIST
248 insert_symtab(stab, iident_name(lvar), create_pvalue_from_int(len));
249 delete_pvalue_ptr(&val1);
250 delete_pvalue_ptr(&val2);
251 return NULL;
252 }
253 /*===================================+
254 * llrpt_database -- Return database name
255 * usage: database([BOOL]) -> STRING
256 *==================================*/
257 PVALUE
llrpt_database(PNODE node,SYMTAB stab,BOOLEAN * eflg)258 llrpt_database (PNODE node, SYMTAB stab, BOOLEAN *eflg)
259 {
260 extern STRING readpath;
261 BOOLEAN full = FALSE;
262 PVALUE val=0;
263 PNODE argvar = builtin_args(node);
264 *eflg = FALSE;
265 if (argvar) {
266 val = eval_and_coerce(PBOOL, argvar, stab, eflg);
267 if (*eflg) {
268 prog_var_error(node, stab, argvar, val, nonboo1, "database");
269 delete_pvalue_ptr(&val);
270 return NULL;
271 }
272 full = pvalue_to_bool(val);
273 delete_pvalue_ptr(&val);
274 }
275 return create_pvalue_from_string(
276 (full ? readpath : lastpathname(readpath)));
277 }
278 /*===========================================+
279 * llrpt_index -- Find nth occurrence of substring
280 * usage: index(STRING, STRING, INT) -> INT
281 *==========================================*/
282 PVALUE
llrpt_index(PNODE node,SYMTAB stab,BOOLEAN * eflg)283 llrpt_index (PNODE node, SYMTAB stab, BOOLEAN *eflg)
284 {
285 INT num=0;
286 PNODE argvar = builtin_args(node);
287 STRING sub=0, str=0;
288 PVALUE val3=0, val2=0;
289 PVALUE val1 = eval_and_coerce(PSTRING, argvar, stab, eflg);
290 if (*eflg) {
291 prog_var_error(node, stab, argvar, val1, nonstrx, "index", "1");
292 delete_pvalue_ptr(&val1);
293 return NULL;
294 }
295 str = pvalue_to_string(val1);
296 val2 = eval_and_coerce(PSTRING, argvar=inext(argvar), stab, eflg);
297 if (*eflg) {
298 prog_var_error(node, stab, argvar, val2, nonstrx, "index", "2");
299 delete_pvalue_ptr(&val1);
300 delete_pvalue_ptr(&val2);
301 return NULL;
302 }
303 sub = pvalue_to_string(val2);
304 val3 = eval_and_coerce(PINT, argvar=inext(argvar), stab, eflg);
305 if (*eflg) {
306 prog_var_error(node, stab, argvar, val3, nonintx, "index", "3");
307 delete_pvalue_ptr(&val1);
308 delete_pvalue_ptr(&val2);
309 delete_pvalue_ptr(&val3);
310 return NULL;
311 }
312 num = pvalue_to_int(val3);
313 set_pvalue_int(val3, ll_index(str, sub, num));
314 delete_pvalue_ptr(&val1);
315 delete_pvalue_ptr(&val2);
316 return val3;
317 }
318 /*==============================================+
319 * llrpt_substring -- Find substring of string.
320 * usage: substring(STRING, INT, INT) -> STRING
321 *=============================================*/
322 PVALUE
llrpt_substring(PNODE node,SYMTAB stab,BOOLEAN * eflg)323 llrpt_substring (PNODE node, SYMTAB stab, BOOLEAN *eflg)
324 {
325 INT lo, hi;
326 PNODE argvar = builtin_args(node);
327 STRING str=0, substr=0;
328 PVALUE val2=0;
329 PVALUE val1 = eval_and_coerce(PSTRING, argvar, stab, eflg);
330 if (*eflg) {
331 prog_var_error(node, stab, argvar, val1, nonstrx, "substring", "1");
332 delete_pvalue_ptr(&val1);
333 return NULL;
334 }
335 str = pvalue_to_string(val1);
336 val2 = eval_and_coerce(PINT, argvar=inext(argvar), stab, eflg);
337 if (*eflg) {
338 prog_var_error(node, stab, argvar, val2, nonintx, "substring", "2");
339 delete_pvalue_ptr(&val1);
340 delete_pvalue_ptr(&val2);
341 return NULL;
342 }
343 lo = pvalue_to_int(val2);
344 delete_pvalue_ptr(&val2);
345 val2 = eval_and_coerce(PINT, argvar=inext(argvar), stab, eflg);
346 if (*eflg) {
347 prog_var_error(node, stab, argvar, val2, nonintx, "substring", "3");
348 delete_pvalue_ptr(&val1);
349 delete_pvalue_ptr(&val2);
350 return NULL;
351 }
352 hi = pvalue_to_int(val2);
353 /* substr can handle str==NULL */
354 substr = allocsubstring(str, lo, hi);
355 set_pvalue_string(val2, substr);
356 stdfree(substr);
357 delete_pvalue_ptr(&val1);
358 return val2;
359 }
360 /*======================================================
361 * index -- Find nth occurrence of sub in str (uses KMP)
362 * STRING str: the text being searched
363 * STRING sub: the substring being sought
364 * INT num: which occurrence we want
365 * return value is 1-based index (or 0 if not found)
366 *====================================================*/
367 static INT
ll_index(STRING str,STRING sub,INT num)368 ll_index (STRING str, STRING sub, INT num)
369 {
370 INT result=0;
371 STRING pi=0;
372 if (!str || !sub || *str == 0 || *sub == 0) return 0;
373 pi = stdalloc(strlen(sub)+1);
374 compute_pi(pi, sub);
375 result = kmp_search(pi, str, sub, num);
376 strfree(&pi);
377 return result;
378 }
379 /*===============================================
380 * kmp_search -- Perform KMP search for substring
381 * STRING pi: the KMP index to avoid backtracking
382 * STRING str: the text being searched
383 * STRING sub: the substring being sought
384 * INT num: which occurrence we want
385 * return value is 1-based index (or 0 if not found)
386 *=============================================*/
387 static INT
kmp_search(STRING pi,STRING str,STRING sub,INT num)388 kmp_search (STRING pi, STRING str, STRING sub, INT num)
389 {
390 INT i, q = 0, found = 0;
391 INT n = strlen(str);
392 INT m = strlen(sub);
393 for (i = 1; i <= n; i++) {
394 while (q > 0 && sub[q] != str[i-1])
395 q = pi[q];
396 if (sub[q] == str[i-1]) q++;
397 if (q == m) {
398 if (++found == num) return i - m + 1;
399 q = pi[q];
400 }
401 }
402 return 0;
403 }
404 /*========================================
405 * compute_pi -- Support routine for index
406 *======================================*/
407 static void
compute_pi(STRING pi,STRING sub)408 compute_pi (STRING pi, STRING sub)
409 {
410 INT m = strlen(sub), k = 0, q;
411 pi[1] = 0;
412 for (q = 2; q <= m; q++) {
413 while (k > 0 && sub[k] != sub[q-1])
414 k = pi[k];
415 if (sub[k] == sub[q-1]) k++;
416 pi[q] = k;
417 }
418 }
419 /*==============================
420 * allocsubstring -- Return substring
421 * handles NULL input
422 * returns alloc'd memory or NULL
423 * i is 1-based start character, j is 1-based end char
424 *============================*/
425 static STRING
allocsubstring(STRING s,INT i,INT j)426 allocsubstring (STRING s, INT i, INT j)
427 {
428 INT startch=i-1; /* startch is 0-based, validated below */
429 INT numch=j+1-i; /* #characters to copy */
430 INT maxlen = s ? strlen(s) : 0;
431 /* NULL if NULL or empty string or nonpositive range */
432 if (!s || !s[0] || numch<1)
433 return NULL;
434 /* validate startch */
435 if (startch<0)
436 startch=0;
437 if (0 && uu8) { /* don't turn this on -- index isn't ready for UTF-8 */
438 INT start=0, num=0; /* byte units */
439 STRING ptr = s;
440 while (startch) {
441 start += utf8len(ptr[start]);
442 if (start >= maxlen)
443 return NULL;
444 --startch;
445 }
446 ptr = s + start;
447 while (numch) {
448 num += utf8len(ptr[0]);
449 if (start+num>maxlen) {
450 num=maxlen-start;
451 break;
452 }
453 ptr += num;
454 --numch;
455 }
456 return allocsubbytes(s, start, num);
457 } else {
458 /* 1 byte codeset */
459 if (startch + numch > maxlen)
460 numch=maxlen-startch;
461 return allocsubbytes(s, startch, numch);
462 }
463 }
464 /*===============================================
465 * llrpt_chooseindi -- Have user choose person from set
466 * usage: chooseindi(SET) -> INDI
467 *=============================================*/
468 PVALUE
llrpt_chooseindi(PNODE node,SYMTAB stab,BOOLEAN * eflg)469 llrpt_chooseindi (PNODE node, SYMTAB stab, BOOLEAN * eflg)
470 {
471 PNODE argvar = builtin_args(node);
472 NODE indi=0;
473 INDISEQ seq=0;
474 PVALUE val = eval_and_coerce(PSET, argvar, stab, eflg);
475 if (*eflg) {
476 prog_var_error(node, stab, argvar, val, nonset1, "chooseindi");
477 delete_pvalue_ptr(&val);
478 return NULL;
479 }
480 seq = pvalue_to_seq(val);
481 delete_pvalue_ptr(&val);
482 if (!seq || length_indiseq(seq) < 1) return NULL;
483 indi = nztop(choose_from_indiseq(seq, DOASK1, _(qSifonei), _(qSnotonei)));
484 if (!indi) return NULL;
485 return create_pvalue_from_indi(indi);
486 }
487 /*================================================+
488 * llrpt_choosesubset -- Have user choose subset from set
489 * usage: choosesubset(SET) -> SET
490 *===============================================*/
491 PVALUE
llrpt_choosesubset(PNODE node,SYMTAB stab,BOOLEAN * eflg)492 llrpt_choosesubset (PNODE node, SYMTAB stab, BOOLEAN * eflg)
493 {
494 PNODE argvar = builtin_args(node);
495 STRING msg=0;
496 INDISEQ newseq=0, seq=0;
497 PVALUE val = eval_and_coerce(PSET, argvar, stab, eflg);
498 if (*eflg) {
499 prog_var_error(node, stab, argvar, val, nonset1, "choosesubset");
500 delete_pvalue_ptr(&val);
501 return NULL;
502 }
503 seq = pvalue_to_seq(val);
504 delete_pvalue_ptr(&val);
505 if (!seq || length_indiseq(seq) < 1) return NULL;
506 newseq = copy_indiseq(seq);
507 msg = (length_indiseq(newseq) > 1) ? _(qSnotonei): _(qSifonei);
508 if (-1 == choose_list_from_indiseq(msg, newseq)) {
509 remove_indiseq(newseq);
510 newseq = NULL;
511 }
512 return create_pvalue_from_seq(newseq);
513 }
514 /*=========================================================+
515 * llrpt_choosechild -- Have user choose child of person or family
516 * usage: choosechild(INDI|FAM) -> INDI
517 *========================================================*/
518 PVALUE
llrpt_choosechild(PNODE node,SYMTAB stab,BOOLEAN * eflg)519 llrpt_choosechild (PNODE node, SYMTAB stab, BOOLEAN *eflg)
520 {
521 INT type=0;
522 CNSTRING key=0;
523 CACHEEL cel=0;
524 INDISEQ seq=0;
525 NODE indi=0;
526 PNODE argvar = builtin_args(node);
527 PVALUE val = evaluate(argvar, stab, eflg);
528 if (*eflg || !val || ((type = which_pvalue_type(val)) != PINDI && type != PFAM)) {
529 *eflg = TRUE;
530 prog_var_error(node, stab, argvar, val, nonif1, "choosechild");
531 delete_pvalue_ptr(&val);
532 return NULL;
533 }
534 cel = pvalue_to_cel(val);
535 delete_pvalue_ptr(&val);
536 if (!cel) return create_pvalue_from_indi(NULL);
537 if (*key == 'I') {
538 NODE indi1 = cacheel_to_node(cel);
539 seq = indi_to_children(indi1);
540 } else if (*key == 'F') {
541 NODE fam1 = cacheel_to_node(cel);
542 seq = fam_to_children(fam1);
543 } else {
544 *eflg = TRUE;
545 prog_error(node, "major error in choosechild");
546 return NULL;
547 }
548 if (!seq || length_indiseq(seq) < 1)
549 return create_pvalue_from_indi(NULL);
550 indi = nztop(choose_from_indiseq(seq, DOASK1, _(qSifonei), _(qSnotonei)));
551 remove_indiseq(seq);
552 return create_pvalue_from_indi(indi); /* indi may be NULL */
553 }
554 /*=================================================+
555 * llrpt_choosespouse -- Have user choose spouse of person
556 * usage: choosespouse(INDI|FAM) -> INDI
557 *================================================*/
558 PVALUE
llrpt_choosespouse(PNODE node,SYMTAB stab,BOOLEAN * eflg)559 llrpt_choosespouse (PNODE node, SYMTAB stab, BOOLEAN *eflg)
560 {
561 INT type=0;
562 CNSTRING key=0;
563 CACHEEL cel=0;
564 INDISEQ seq=0;
565 NODE indi=0;
566 PNODE argvar = builtin_args(node);
567 PVALUE val = evaluate(argvar, stab, eflg);
568 if (*eflg || !val || ((type = which_pvalue_type(val)) != PINDI && type != PFAM)) {
569 *eflg = TRUE;
570 prog_var_error(node, stab, argvar, val, nonif1, "choosespouse");
571 delete_pvalue_ptr(&val);
572 return NULL;
573 }
574 cel = pvalue_to_cel(val);
575 delete_pvalue_ptr(&val);
576 if (!cel) return create_pvalue_from_indi(NULL);
577 key = cacheel_to_key(cel);
578
579 if (*key == 'I') {
580 NODE indi1 = cacheel_to_node(cel);
581 seq = indi_to_spouses(indi1);
582 } else if (*key == 'F') {
583 NODE fam1 = cacheel_to_node(cel);
584 seq = fam_to_spouses(fam1);
585 } else {
586 *eflg = TRUE;
587 prog_error(node, "major error in choosespouse");
588 return NULL;
589 }
590 if (!seq || length_indiseq(seq) < 1)
591 return create_pvalue_from_indi(NULL);
592 indi = nztop(choose_from_indiseq(seq, DOASK1, _(qSifonei), _(qSnotonei)));
593 remove_indiseq(seq);
594 return create_pvalue_from_indi(indi); /* indi may be NULL */
595
596 }
597 /*==============================================+
598 * llrpt_choosefam -- Have user choose family of person
599 * usage: choosefam (INDI) -> FAM
600 *=============================================*/
601 PVALUE
llrpt_choosefam(PNODE node,SYMTAB stab,BOOLEAN * eflg)602 llrpt_choosefam (PNODE node, SYMTAB stab, BOOLEAN *eflg)
603 {
604 PNODE argvar = builtin_args(node);
605 NODE fam, indi = eval_indi(argvar, stab, eflg, NULL);
606 INDISEQ seq;
607 if (*eflg) {
608 prog_var_error(node, stab, argvar, NULL, nonind1, "choosefam");
609 prog_error(node, "the arg to choosefam must be a person");
610 return NULL;
611 }
612 seq = indi_to_families(indi, TRUE);
613 if (!seq || length_indiseq(seq) < 1)
614 return create_pvalue_from_fam(NULL);
615 fam = nztop(choose_from_indiseq(seq, DOASK1, _(qSifonei), _(qSnotonei)));
616 remove_indiseq(seq);
617 return create_pvalue_from_fam(fam); /* fam may be NULL */
618 }
619 /*===================================================+
620 * makestring -- turn any pvalue into a string
621 * val is input; val,len, and eflg are outputs
622 * Created: 2001/04/13, Perry Rapp
623 *==================================================*/
624 static void
makestring(PVALUE val,STRING str,INT len,BOOLEAN * eflg)625 makestring (PVALUE val, STRING str, INT len, BOOLEAN *eflg)
626 {
627 str[0]=0;
628
629 switch(which_pvalue_type(val)) {
630 case PNULL:
631 llstrapps(str, len, uu8, "<NULL>");
632 break;
633 case PINT:
634 case PFLOAT:
635 llstrappf(str, len, uu8, "%f", pvalue_to_float(val));
636 break;
637 case PBOOL:
638 /* TODO: Should we localize this ? */
639 llstrapps(str, len, uu8, pvalue_to_bool(val) ? "True" : "False");
640 break;
641 case PSTRING:
642 llstrapps(str, len, uu8, pvalue_to_string(val));
643 break;
644 case PGNODE:
645 {
646 /* TODO: report codeset conversion */
647 NODE node = pvalue_to_node(val);
648 if (ntag(node)) {
649 llstrappf(str, len, uu8, "%s: ", ntag(node));
650 }
651 if (nval(node))
652 llstrapps(str, len, uu8, nval(node));
653 }
654 break;
655 case PINDI:
656 case PFAM:
657 case PSOUR:
658 case PEVEN:
659 case POTHR:
660 {
661 RECORD rec = pvalue_to_record(val);
662 NODE node = nztop(rec);
663 STRING txt = generic_to_list_string(node, NULL, len, " ", NULL, TRUE);
664 llstrapps(str, len, uu8, txt);
665 }
666 break;
667 case PLIST:
668 llstrapps(str, len, uu8, "<LIST>");
669 break;
670 case PTABLE:
671 llstrapps(str, len, uu8, "<TABLE>");
672 break;
673 case PSET:
674 llstrapps(str, len, uu8, "<SET>");
675 break;
676 default:
677 *eflg = TRUE;
678 }
679 }
680 /*===================================================+
681 * llrpt_menuchoose -- Have user choose from list of options
682 * usage: menuchoose (LIST [,STRING]) -> INT
683 *==================================================*/
684 PVALUE
llrpt_menuchoose(PNODE node,SYMTAB stab,BOOLEAN * eflg)685 llrpt_menuchoose (PNODE node, SYMTAB stab, BOOLEAN *eflg)
686 {
687 INT i, j, len;
688 STRING msg, *strngs;
689 STRING ttl = _("Please choose from the following list.");
690 PNODE argvar = builtin_args(node);
691 LIST list=0;
692 PVALUE vel=0, val=0;
693 INT nsize=0;
694 val = eval_and_coerce(PLIST, argvar, stab, eflg);
695 if (*eflg) {
696 prog_var_error(node, stab, argvar, val, "menuchoose", "1");
697 delete_pvalue_ptr(&val);
698 return NULL;
699 }
700 list = pvalue_to_list(val);
701 delete_pvalue_ptr(&val);
702 if (!list || length_list(list) < 1)
703 return create_pvalue_from_int(0);
704 msg = NULL;
705 argvar = inext(argvar);
706 if (argvar) {
707 val = eval_and_coerce(PSTRING, argvar, stab, eflg);
708 if (*eflg) {
709 prog_var_error(node, stab, argvar, val, nonstrx, "menuchoose", "2");
710 delete_pvalue_ptr(&val);
711 return NULL;
712 }
713 msg = pvalue_to_string(val);
714 }
715 if (msg && *msg) ttl = msg;
716 len = length_list(list);
717 strngs = (STRING *) stdalloc(len*sizeof(STRING));
718 i = 0;
719 nsize = 80;
720 FORLIST(list, el)
721 vel = (PVALUE) el;
722 strngs[i] = (STRING)stdalloc(nsize);
723 makestring(vel, strngs[i], nsize, eflg);
724 if (*eflg) {
725 STOPLIST
726 prog_error(node, _("Illegal type found in list in menuchoose"));
727 return NULL;
728 }
729 ++i;
730 ENDLIST
731 i = choose_from_array(ttl, len, strngs);
732 for (j=0; j<len; j++)
733 stdfree(strngs[j]);
734 stdfree(strngs);
735 delete_pvalue_ptr(&val);
736 return create_pvalue_from_int(i + 1);
737 }
738 /*================================+
739 * llrpt_runsystem -- Run shell command
740 * usage: runsystem (STRING) -> VOID
741 *===============================*/
742 PVALUE
llrpt_runsystem(PNODE node,SYMTAB stab,BOOLEAN * eflg)743 llrpt_runsystem (PNODE node, SYMTAB stab, BOOLEAN *eflg)
744 {
745 STRING cmd=0;
746 PNODE argvar = builtin_args(node);
747 PVALUE val = eval_and_coerce(PSTRING, argvar, stab, eflg);
748 if (*eflg) {
749 prog_var_error(node, stab, argvar, val, nonstr1, "system");
750 delete_pvalue_ptr(&val);
751 return NULL;
752 }
753 cmd = pvalue_to_string(val);
754 if (!cmd || *cmd == 0) {
755 delete_pvalue_ptr(&val);
756 return NULL;
757 }
758 if (!getlloptint("DenySystemCalls", 0)) {
759 call_system_cmd(cmd);
760 } else {
761 /* llwprintf("Suppressing system(%s) call", cmd); */
762 }
763 delete_pvalue_ptr(&val);
764 return NULL;
765 }
766 /*============================================+
767 * llrpt_firstindi -- Return first person in database
768 * usage: firstindi() -> INDI
769 *===========================================*/
770 PVALUE
llrpt_firstindi(PNODE node,SYMTAB stab,BOOLEAN * eflg)771 llrpt_firstindi (PNODE node, SYMTAB stab, BOOLEAN *eflg)
772 {
773 node=node; /* unused */
774 stab=stab; /* unused */
775 *eflg = FALSE;
776 return create_pvalue_from_indi_keynum(xref_firsti());
777 }
778 /*==========================================+
779 * llrpt_nextindi -- Return next person in database
780 * usage: nextindi(INDI) -> INDI
781 *=========================================*/
782 PVALUE
llrpt_nextindi(PNODE node,SYMTAB stab,BOOLEAN * eflg)783 llrpt_nextindi (PNODE node, SYMTAB stab, BOOLEAN *eflg)
784 {
785 PNODE argvar = builtin_args(node);
786 NODE indi = eval_indi(argvar, stab, eflg, NULL);
787 static char key[10];
788 INT i;
789 if (*eflg) {
790 prog_var_error(node, stab, argvar, NULL, nonind1, "nextindi");
791 return NULL;
792 }
793 if (!indi)
794 return create_pvalue_from_indi_keynum(0);
795 strcpy(key, indi_to_key(indi));
796 i = atoi(&key[1]);
797 i = xref_nexti(i);
798 return create_pvalue_from_indi_keynum(i);
799 }
800 /*==============================================+
801 * llrpt_previndi -- Return previous person in database
802 * usage: previndi(INDI) -> INDI
803 *=============================================*/
804 PVALUE
llrpt_previndi(PNODE node,SYMTAB stab,BOOLEAN * eflg)805 llrpt_previndi (PNODE node, SYMTAB stab, BOOLEAN *eflg)
806 {
807 PNODE argvar = builtin_args(node);
808 NODE indi = eval_indi(argvar, stab, eflg, NULL);
809 static char key[10];
810 INT i;
811 if (*eflg) {
812 prog_var_error(node, stab, argvar, NULL, nonind1, "previndi");
813 return NULL;
814 }
815 if (!indi)
816 return create_pvalue_from_indi_keynum(0);
817 strcpy(key, indi_to_key(indi));
818 i = atoi(&key[1]);
819 i = xref_previ(i);
820 return create_pvalue_from_indi_keynum(i);
821 }
822 /*===========================================
823 * llrpt_lastindi -- Return last person in database
824 * usage: lastindi() -> INDI
825 *=========================================*/
826 PVALUE
llrpt_lastindi(PNODE node,SYMTAB stab,BOOLEAN * eflg)827 llrpt_lastindi (PNODE node, SYMTAB stab, BOOLEAN *eflg)
828 {
829 node=node; /* unused */
830 stab=stab; /* unused */
831 *eflg = FALSE;
832 return create_pvalue_from_indi_keynum(xref_lasti());
833 }
834 /*===========================================+
835 * llrpt_firstfam -- Return first family in database
836 * usage: firstfam() -> FAM
837 *==========================================*/
838 PVALUE
llrpt_firstfam(PNODE node,SYMTAB stab,BOOLEAN * eflg)839 llrpt_firstfam (PNODE node, SYMTAB stab, BOOLEAN *eflg)
840 {
841 node=node; /* unused */
842 stab=stab; /* unused */
843 *eflg = FALSE;
844 return create_pvalue_from_fam_keynum(xref_firstf());
845 }
846 /*=========================================+
847 * llrpt_nextfam -- Return next family in database
848 * usage: nextfam(FAM) -> FAM
849 *========================================*/
850 PVALUE
llrpt_nextfam(PNODE node,SYMTAB stab,BOOLEAN * eflg)851 llrpt_nextfam (PNODE node, SYMTAB stab, BOOLEAN *eflg)
852 {
853 PNODE argvar = builtin_args(node);
854 NODE fam = eval_fam(argvar, stab, eflg, NULL);
855 static char key[10];
856 INT i;
857 if (*eflg) {
858 prog_var_error(node, stab, argvar, NULL, nonfam1, "nextfam");
859 return NULL;
860 }
861 if (!fam)
862 return create_pvalue_from_fam_keynum(0);
863 strcpy(key, fam_to_key(fam));
864 i = atoi(&key[1]);
865 i = xref_nextf(i);
866 return create_pvalue_from_fam_keynum(i);
867 }
868 /*=============================================+
869 * llrpt_prevfam -- Return previous family in database
870 * usage: prevfam(FAM) -> FAM
871 *============================================*/
872 PVALUE
llrpt_prevfam(PNODE node,SYMTAB stab,BOOLEAN * eflg)873 llrpt_prevfam (PNODE node, SYMTAB stab, BOOLEAN *eflg)
874 {
875 PNODE argvar = builtin_args(node);
876 NODE fam = eval_fam(argvar, stab, eflg, NULL);
877 static char key[10];
878 INT i;
879 if (*eflg) {
880 prog_var_error(node, stab, argvar, NULL, nonfam1, "prevfam");
881 return NULL;
882 }
883 if (!fam)
884 return create_pvalue_from_fam_keynum(0);
885 strcpy(key, fam_to_key(fam));
886 i = atoi(&key[1]);
887 i = xref_prevf(i);
888 return create_pvalue_from_fam_keynum(i);
889 }
890 /*=========================================+
891 * llrpt_lastfam -- Return last family in database
892 * usage: lastfam() -> FAM
893 *========================================*/
894 PVALUE
llrpt_lastfam(PNODE node,SYMTAB stab,BOOLEAN * eflg)895 llrpt_lastfam (PNODE node, SYMTAB stab, BOOLEAN *eflg)
896 {
897 node=node; /* unused */
898 stab=stab; /* unused */
899 *eflg = FALSE;
900 return create_pvalue_from_fam_keynum(xref_lastf());
901 }
902 /*=============================================+
903 * llrpt_dereference -- Read top node of GEDCOM record from database
904 * usage: dereference(STRING) -> NODE
905 * NOTE: persons and families NOT cached!
906 *============================================*/
907 PVALUE
llrpt_dereference(PNODE node,SYMTAB stab,BOOLEAN * eflg)908 llrpt_dereference (PNODE node, SYMTAB stab, BOOLEAN *eflg)
909 {
910 STRING key=0;
911 PNODE argvar = builtin_args(node);
912 PVALUE val = eval_and_coerce(PSTRING, argvar, stab, eflg);
913 INT len;
914 STRING rawrec = NULL;
915 NODE node2 = NULL;
916 if (*eflg) {
917 prog_var_error(node, stab, argvar, val, nonstr1, "dereference");
918 delete_pvalue_ptr(&val);
919 return NULL;
920 }
921 key = pvalue_to_string(val);
922 if (*key == '@') key = rmvat(key);
923 if (!key) key=""; /* rmvat can return null */
924 if (*key == 'I' || *key == 'F' || *key == 'S' ||
925 *key == 'E' || *key == 'X') {
926 rawrec = retrieve_raw_record(key, &len);
927 if (rawrec)
928 node2 = string_to_node(rawrec);
929 }
930 delete_pvalue_ptr(&val);
931 val = create_pvalue_from_node(node2);
932 if (rawrec) stdfree(rawrec);
933 return val;
934 }
935 /*================================================+
936 * llrpt_reference -- Check if STRING is record reference
937 * usage: reference(STRING) -> BOOLEAN
938 *===============================================*/
939 PVALUE
llrpt_reference(PNODE node,SYMTAB stab,BOOLEAN * eflg)940 llrpt_reference (PNODE node, SYMTAB stab, BOOLEAN *eflg)
941 {
942 STRING key=0;
943 BOOLEAN rc;
944 PNODE argvar = builtin_args(node);
945 PVALUE val = eval_and_coerce(PSTRING, argvar, stab, eflg);
946 if (*eflg) {
947 prog_var_error(node, stab, argvar, val, nonstr1, "reference");
948 delete_pvalue_ptr(&val);
949 return NULL;
950 }
951 key = pvalue_to_string(val);
952 rc = (key && *key && (strlen(key) > 2) && (*key == '@') &&
953 (key[strlen(key)-1] == '@'));
954 set_pvalue_bool(val, rc);
955 return val;
956 }
957 /*========================================+
958 * llrpt_rjustify -- Right justify string value
959 * usage: rjustify(STRING, INT) -> STRING
960 *=======================================*/
961 PVALUE
llrpt_rjustify(PNODE node,SYMTAB stab,BOOLEAN * eflg)962 llrpt_rjustify (PNODE node, SYMTAB stab, BOOLEAN *eflg)
963 {
964 PNODE sargvar = builtin_args(node);
965 PNODE largvar = inext(sargvar);
966 INT len;
967 STRING str=0;
968 PVALUE val2;
969 PVALUE val1 = eval_and_coerce(PSTRING, sargvar, stab, eflg);
970 if (*eflg) {
971 prog_var_error(node, stab, sargvar, val1, nonstrx, "rjustify", "1");
972 delete_pvalue_ptr(&val1);
973 return NULL;
974 }
975 str = pvalue_to_string(val1);
976 val2 = eval_and_coerce(PINT, largvar, stab, eflg);
977 if (*eflg) {
978 prog_var_error(node, stab, largvar, val2, nonintx, "rjustify", "2");
979 delete_pvalue_ptr(&val1);
980 delete_pvalue_ptr(&val2);
981 return NULL;
982 }
983 len = pvalue_to_int(val2);
984 delete_pvalue_ptr(&val2);
985 str = rightjustify(str, len); /* newly alloc'd */
986 set_pvalue_string(val1, str);
987 strfree(&str);
988 return val1;
989 }
990 /*===========================================
991 * rightjustify -- Right justify string value
992 * returns heap-allocated string
993 *=========================================*/
994 static STRING
rightjustify(STRING str,INT len)995 rightjustify (STRING str, INT len)
996 {
997 STRING newstr=0;
998 INT lstr, nsp, i, j;
999 if (len < 1) return NULL;
1000 if (len > 512) len = 512;
1001 newstr = (STRING) stdalloc(len + 1);
1002 lstr = strlen(str);
1003 nsp = len - lstr;
1004 if (nsp < 0) nsp = 0;
1005 for (i = 0; i < nsp; i++)
1006 newstr[i] = ' ';
1007 for (i = nsp, j = 0; i < len; i++, j++)
1008 newstr[i] = str[j];
1009 newstr[i] = 0;
1010 return newstr;
1011 }
1012 /*=========================================+
1013 * llrpt_lock -- Lock person or family in memory
1014 * usage: lock(INDI|FAM|EVEN|SOUR|OTHR) -> VOID
1015 *========================================*/
1016 PVALUE
llrpt_lock(PNODE node,SYMTAB stab,BOOLEAN * eflg)1017 llrpt_lock (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1018 {
1019 CACHEEL cel=0;
1020 PNODE argvar = builtin_args(node);
1021 PVALUE val = evaluate(argvar, stab, eflg);
1022 if (*eflg) {
1023 prog_var_error(node, stab, argvar, val
1024 , _("error evaluating arg to lock"));
1025 delete_pvalue_ptr(&val);
1026 return NULL;
1027 }
1028 if (!val) {
1029 *eflg = TRUE;
1030 prog_var_error(node, stab, argvar, val
1031 , _("null arg in lock"));
1032 return NULL;
1033 }
1034 if (is_record_pvalue(val)) {
1035 cel = pvalue_to_cel(val);
1036 } else if (is_node_pvalue(val)) {
1037 NODE nd = pvalue_to_node(val);
1038 cel = ncel(nd);
1039 if (!cel) {
1040 *eflg = TRUE;
1041 prog_var_error(node, stab, argvar, val
1042 , _("node passed to lock must be inside a record"));
1043 delete_pvalue_ptr(&val);
1044 return NULL;
1045 }
1046 } else {
1047 *eflg = TRUE;
1048 prog_var_error(node, stab, argvar, val
1049 , _("the arg to lock must be a record or node"));
1050 delete_pvalue_ptr(&val);
1051 return NULL;
1052 }
1053 delete_pvalue_ptr(&val);
1054 if (cel) {
1055 if (cel_rptlocks(cel)>999999) {
1056 *eflg = TRUE;
1057 prog_var_error(node, stab, argvar, val
1058 , _("Error: there are 999,999 locks on arg to lock"));
1059 return NULL;
1060 }
1061 lockrpt_cache(cel);
1062 }
1063 /* TO DO - ought to ensure this gets freed */
1064 return NULL;
1065 }
1066 /*===============================================+
1067 * llrpt_unlock -- Unlock person or family from memory
1068 * usage: unlock(INDI|FAM|EVEN|SOUR|OTHR) -> VOID
1069 *==============================================*/
1070 PVALUE
llrpt_unlock(PNODE node,SYMTAB stab,BOOLEAN * eflg)1071 llrpt_unlock (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1072 {
1073 CACHEEL cel=0;
1074 PNODE argvar = builtin_args(node);
1075 PVALUE val = evaluate(argvar, stab, eflg);
1076 if (*eflg) {
1077 prog_var_error(node, stab, argvar, val
1078 , _("error evaluating arg to unlock"));
1079 delete_pvalue_ptr(&val);
1080 return NULL;
1081 }
1082 if (!val) {
1083 *eflg = TRUE;
1084 prog_var_error(node, stab, argvar, val
1085 , _("null arg in unlock"));
1086 return NULL;
1087 }
1088 if (is_record_pvalue(val)) {
1089 cel = pvalue_to_cel(val);
1090 } else if (is_node_pvalue(val)) {
1091 NODE nd = pvalue_to_node(val);
1092 cel = ncel(nd);
1093 if (!cel) {
1094 *eflg = TRUE;
1095 prog_var_error(node, stab, argvar, val
1096 , _("node passed to unlock must be inside a record"));
1097 delete_pvalue_ptr(&val);
1098 return NULL;
1099 }
1100 } else {
1101 *eflg = TRUE;
1102 prog_var_error(node, stab, argvar, val
1103 , _("the arg to unlock must be a record or node"));
1104 delete_pvalue_ptr(&val);
1105 return NULL;
1106 }
1107 delete_pvalue_ptr(&val);
1108 if (cel) {
1109 unlockrpt_cache(cel);
1110 }
1111 return NULL;
1112 }
1113 /*==========================================+
1114 * llrpt_savenode -- Save GEDCOM tree permanently
1115 * usage: savenode(NODE) -> NODE
1116 *=========================================*/
1117 PVALUE
llrpt_savenode(PNODE node,SYMTAB stab,BOOLEAN * eflg)1118 llrpt_savenode (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1119 {
1120 NODE line;
1121 PNODE argvar = builtin_args(node);
1122 PVALUE val = eval_and_coerce(PGNODE, argvar, stab, eflg);
1123 if (*eflg) {
1124 prog_var_error(node, stab, argvar, val, nonnod1, "savenode");
1125 delete_pvalue_ptr(&val);
1126 return NULL;
1127 }
1128 line = pvalue_to_node(val);
1129 if (!line) return val;
1130 line = copy_nodes(line, TRUE, TRUE);
1131 set_pvalue_node(val, line);
1132 return val;
1133 }
1134 /*===================================================+
1135 * llrpt_genindiset -- Generate set of persons from a name
1136 * usage: genindiset(STRING, SET) -> VOID
1137 *==================================================*/
1138 PVALUE
llrpt_genindiset(PNODE node,SYMTAB stab,BOOLEAN * eflg)1139 llrpt_genindiset (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1140 {
1141 PNODE argvar = builtin_args(node);
1142 STRING name=0;
1143 PVALUE seqval=0;
1144 PVALUE val1 = eval_and_coerce(PSTRING, argvar, stab, eflg);
1145 if (*eflg) {
1146 prog_var_error(node, stab, argvar, val1, nonstrx, "genindiset" , "1");
1147 delete_pvalue_ptr(&val1);
1148 return NULL;
1149 }
1150 name = pvalue_to_string(val1);
1151 if(name) name = strsave(name);
1152 delete_pvalue_ptr(&val1);
1153 argvar = inext(argvar);
1154 if (!iistype(argvar, IIDENT)) {
1155 *eflg = TRUE;
1156 prog_var_error(node, stab, argvar, NULL, nonvarx, "genindiset", "2");
1157 return NULL;
1158 }
1159 seqval = create_pvalue_from_seq(NULL);
1160 assign_iden(stab, iident_name(argvar), seqval);
1161 if (!name || *name == 0) return NULL;
1162 seqval = create_pvalue_from_seq(str_to_indiseq(name, 'I'));
1163 assign_iden(stab, iident_name(argvar), seqval);
1164 return NULL;
1165 }
1166 /*================================================+
1167 * llrpt_version -- Return the LifeLines version string
1168 * usage: version() -> STRING
1169 *===============================================*/
1170 PVALUE
llrpt_version(PNODE node,SYMTAB stab,BOOLEAN * eflg)1171 llrpt_version (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1172 {
1173 node=node; /* unused */
1174 stab=stab; /* unused */
1175 *eflg = FALSE;
1176 return create_pvalue_from_string(get_lifelines_version(120));
1177 }
1178 /*========================================+
1179 * llrpt_pvalue -- Show a PVALUE -- Debug routine
1180 * usage: pvalue(ANY) -> STRING
1181 *=======================================*/
1182 PVALUE
llrpt_pvalue(PNODE node,SYMTAB stab,BOOLEAN * eflg)1183 llrpt_pvalue (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1184 {
1185 PNODE argvar = builtin_args(node);
1186 PVALUE val = evaluate(argvar, stab, eflg);
1187 ZSTR zstr=0;
1188 #ifdef DEBUG
1189 debug_show_one_pnode(node);
1190 llwprintf("\npvalue: %d ",val);
1191 if(val)
1192 llwprintf("%d\n",ptype(val));
1193 else
1194 printf("BLECH\n");
1195 show_pvalue(val);
1196 llwprintf("\n");
1197 #endif
1198 zstr = describe_pvalue(val);
1199 val = create_pvalue_from_string(zs_str(zstr));
1200 zs_free(&zstr);
1201 return val;
1202 }
1203 /*============================================+
1204 * llrpt_program -- Returns name of current program
1205 * usage: program() -> STRING
1206 *===========================================*/
1207 PVALUE
llrpt_program(PNODE node,SYMTAB stab,BOOLEAN * eflg)1208 llrpt_program (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1209 {
1210 stab=stab; /* unused */
1211 eflg=eflg; /* unused */
1212 return create_pvalue_from_string(irptinfo(node)->fullpath);
1213 }
1214 /*============================================+
1215 * llrpt_debug -- Turn on/off programming debugging
1216 * usage: debug(BOOLEAN) -> VOID
1217 *===========================================*/
1218 PVALUE
llrpt_debug(PNODE node,SYMTAB stab,BOOLEAN * eflg)1219 llrpt_debug (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1220 {
1221 PNODE argvar = builtin_args(node);
1222 PVALUE val = eval_and_coerce(PBOOL, argvar, stab, eflg);
1223 if (*eflg) {
1224 prog_var_error(node, stab, argvar, val, nonboo1, "debug");
1225 delete_pvalue_ptr(&val);
1226 return NULL;
1227 }
1228 prog_trace = pvalue_to_bool(val);
1229 delete_pvalue_ptr(&val);
1230 return NULL;
1231 }
1232 /*========================================
1233 * llrpt_getproperty -- Return property string
1234 * usage: getproperty(STRING) -> STRING
1235 *======================================*/
1236 PVALUE
llrpt_getproperty(PNODE node,SYMTAB stab,BOOLEAN * eflg)1237 llrpt_getproperty(PNODE node, SYMTAB stab, BOOLEAN *eflg)
1238 {
1239 PNODE argvar = builtin_args(node);
1240 PVALUE val = eval_and_coerce(PSTRING, argvar, stab, eflg);
1241 STRING str=0;
1242 if (*eflg) {
1243 prog_var_error(node, stab, argvar, val, nonstr1, "getproperty");
1244 delete_pvalue_ptr(&val);
1245 return NULL;
1246 }
1247 str = pvalue_to_string(val);
1248 str = str ? get_property(str) : 0;
1249 set_pvalue_string(val, str);
1250 return val;
1251 }
1252 /*========================================
1253 * deg2rad -- trigonometric conversion: degrees to radians
1254 * Helper function since C trig functions expect radians
1255 *======================================*/
1256 static double
deg2rad(double deg)1257 deg2rad (double deg)
1258 {
1259 return ((fmod(deg,360.0))/180.0*M_PI);
1260 }
1261 /*========================================
1262 * rad2deg -- trigonometric conversion: radians to degrees
1263 * Helper function since C trig functions return radians
1264 *======================================*/
1265 static double
rad2deg(double rad)1266 rad2deg (double rad)
1267 {
1268 return (fmod((rad/M_PI*180.0),360.0));
1269 }
1270 /*========================================
1271 * llrpt_dms2deg -- convert degrees in DMS format to decimal degrees
1272 * usage: dms2deg(INT, INT, INT, VARB) -> VOID
1273 *======================================*/
1274 PVALUE
llrpt_dms2deg(PNODE node,SYMTAB stab,BOOLEAN * eflg)1275 llrpt_dms2deg (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1276 {
1277 PNODE argvar = builtin_args(node);
1278 FLOAT decdeg = 0.0;
1279 INT neg=0;
1280
1281 PVALUE val = eval_and_coerce(PINT, argvar, stab, eflg);
1282 if (*eflg) {
1283 prog_var_error(node, stab, argvar, val, nonintx, "dms2deg", "1");
1284 delete_pvalue_ptr(&val);
1285 return NULL;
1286 }
1287 decdeg += pvalue_to_int(val);
1288 if (decdeg < 0) {
1289 decdeg *= -1;
1290 neg = 1;
1291 }
1292
1293 val = eval_and_coerce(PINT, argvar=inext(argvar), stab, eflg);
1294 if (*eflg) {
1295 prog_var_error(node, stab, argvar, val, nonintx, "dms2deg", "2");
1296 delete_pvalue_ptr(&val);
1297 return NULL;
1298 }
1299 decdeg += (pvalue_to_int(val) / 60.0);
1300
1301 val = eval_and_coerce(PINT, argvar=inext(argvar), stab, eflg);
1302 if (*eflg) {
1303 prog_var_error(node, stab, argvar, val, nonintx, "dms2deg", "3");
1304 delete_pvalue_ptr(&val);
1305 return NULL;
1306 }
1307 decdeg += (pvalue_to_int(val) / 3600.0);
1308 if (neg == 1) {
1309 decdeg *= -1;
1310 }
1311 delete_pvalue_ptr(&val);
1312
1313 argvar = inext(argvar);
1314 if (!iistype(argvar, IIDENT)) {
1315 *eflg = TRUE;
1316 prog_var_error(node, stab, argvar, NULL, nonvarx, "dms2deg", "4");
1317 return NULL;
1318 }
1319 insert_symtab(stab, iident_name(argvar), create_pvalue_from_float(decdeg));
1320 return NULL;
1321 }
1322 /*========================================
1323 * llrpt_deg2dms -- convert decimal degrees to DMS format
1324 * usage: deg2dms(FLOAT, VARB, VARB, VARB) -> VOID
1325 *======================================*/
1326 PVALUE
llrpt_deg2dms(PNODE node,SYMTAB stab,BOOLEAN * eflg)1327 llrpt_deg2dms (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1328 {
1329 PNODE argvar1 = builtin_args(node);
1330 PNODE retvar1 = inext(argvar1);
1331 PNODE retvar2 = inext(retvar1);
1332 PNODE retvar3 = inext(retvar2);
1333 FLOAT decdeg;
1334 INT deg, min, sec, neg=0;
1335
1336 PVALUE val = eval_and_coerce(PFLOAT, argvar1, stab, eflg);
1337 if (*eflg) {
1338 prog_var_error(node, stab, argvar1, val, nonflox, "deg2dms", "1");
1339 delete_pvalue_ptr(&val);
1340 return NULL;
1341 }
1342
1343 decdeg = pvalue_to_float(val);
1344 if (decdeg < 0) {
1345 decdeg *= -1;
1346 neg = 1;
1347 }
1348 delete_pvalue_ptr(&val);
1349
1350 if (!iistype(retvar1, IIDENT)) {
1351 *eflg = TRUE;
1352 prog_var_error(node, stab, retvar1, NULL, nonvarx, "dms2deg", "2");
1353 return NULL;
1354 }
1355 if (!iistype(retvar2, IIDENT)) {
1356 *eflg = TRUE;
1357 prog_var_error(node, stab, retvar2, NULL, nonvarx, "dms2deg", "3");
1358 return NULL;
1359 }
1360 if (!iistype(retvar3, IIDENT)) {
1361 *eflg = TRUE;
1362 prog_var_error(node, stab, retvar3, NULL, nonvarx, "dms2deg", "4");
1363 return NULL;
1364 }
1365
1366 deg = (int)(decdeg);
1367 decdeg -= deg;
1368 decdeg *= 60;
1369 min = (int)(decdeg);
1370 decdeg -= min;
1371 decdeg *= 60;
1372 sec = (int)(decdeg);
1373
1374 if (neg == 1) { deg *= -1; }
1375
1376 insert_symtab(stab, iident_name(retvar1), create_pvalue_from_int(deg));
1377 insert_symtab(stab, iident_name(retvar2), create_pvalue_from_int(min));
1378 insert_symtab(stab, iident_name(retvar3), create_pvalue_from_int(sec));
1379 return NULL;
1380 }
1381 /*========================================
1382 * llrpt_sin -- trigonometric SINE function
1383 * usage: sin(FLOAT) -> FLOAT
1384 *======================================*/
1385 PVALUE
llrpt_sin(PNODE node,SYMTAB stab,BOOLEAN * eflg)1386 llrpt_sin (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1387 {
1388 PNODE argvar = builtin_args(node);
1389 PVALUE val = eval_and_coerce(PFLOAT, argvar, stab, eflg);
1390 FLOAT fval=0;
1391 if (*eflg) {
1392 prog_var_error(node, stab, argvar, val, nonflo1, "sin");
1393 delete_pvalue_ptr(&val);
1394 return NULL;
1395 }
1396 fval = pvalue_to_float(val);
1397 delete_pvalue_ptr(&val);
1398
1399 return create_pvalue_from_float(sin(deg2rad(fval)));
1400 }
1401 /*========================================
1402 * llrpt_cos -- trigonometric COSINE function
1403 * usage: cos(FLOAT) -> FLOAT
1404 *======================================*/
1405 PVALUE
llrpt_cos(PNODE node,SYMTAB stab,BOOLEAN * eflg)1406 llrpt_cos (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1407 {
1408 PNODE argvar = builtin_args(node);
1409 PVALUE val = eval_and_coerce(PFLOAT, argvar, stab, eflg);
1410 float fval=0;
1411
1412 if (*eflg) {
1413 prog_var_error(node, stab, argvar, val, nonflox, "cos", "1");
1414 delete_pvalue_ptr(&val);
1415 return NULL;
1416 }
1417 fval = pvalue_to_float(val);
1418 delete_pvalue_ptr(&val);
1419 return create_pvalue_from_float(cos(deg2rad(fval)));
1420 }
1421 /*========================================
1422 * llrpt_tan -- trigonometric TANGENT function
1423 * usage: tan(FLOAT) -> FLOAT
1424 *======================================*/
1425 PVALUE
llrpt_tan(PNODE node,SYMTAB stab,BOOLEAN * eflg)1426 llrpt_tan (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1427 {
1428 PNODE argvar = builtin_args(node);
1429 PVALUE val = eval_and_coerce(PFLOAT, argvar, stab, eflg);
1430 FLOAT fval=0;
1431
1432 if (*eflg) {
1433 prog_var_error(node, stab, argvar, val, nonflox, "tan", "1");
1434 delete_pvalue_ptr(&val);
1435 return NULL;
1436 }
1437
1438 fval = pvalue_to_float(val);
1439
1440 /* avoid SIGFPE caused by invalid input */
1441 if (fmod((fval - 90),180) == 0) {
1442 *eflg = 1;
1443 prog_var_error(node, stab, argvar, val, badtrig, "tan", "1");
1444 delete_pvalue_ptr(&val);
1445 return NULL;
1446 }
1447 delete_pvalue_ptr(&val);
1448
1449 return create_pvalue_from_float(tan(deg2rad(fval)));
1450 }
1451 /*========================================
1452 * llrpt_arcsin -- trigonometric inverse SINE function
1453 * usage: arcsin(FLOAT) -> FLOAT
1454 *======================================*/
1455 PVALUE
llrpt_arcsin(PNODE node,SYMTAB stab,BOOLEAN * eflg)1456 llrpt_arcsin (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1457 {
1458 PNODE argvar = builtin_args(node);
1459 PVALUE val = eval_and_coerce(PFLOAT, argvar, stab, eflg);
1460 FLOAT fval=0;
1461
1462 if (*eflg) {
1463 prog_var_error(node, stab, argvar, val, nonflox, "arcsin", "1");
1464 delete_pvalue_ptr(&val);
1465 return NULL;
1466 }
1467
1468 fval = pvalue_to_float(val);
1469
1470 /* avoid SIGFPE caused by invalid input */
1471 if (fval > 1.0 || fval < -1.0) {
1472 *eflg = 1;
1473 prog_var_error(node, stab, argvar, val, badtrig, "arcsin", "1");
1474 delete_pvalue_ptr(&val);
1475 return NULL;
1476 }
1477 delete_pvalue_ptr(&val);
1478
1479 return create_pvalue_from_float(rad2deg(asin(fval)));
1480 }
1481 /*========================================
1482 * llrpt_arccos -- trigonometric inverse COSINE function
1483 * usage: arccos(FLOAT) -> FLOAT
1484 *======================================*/
1485 PVALUE
llrpt_arccos(PNODE node,SYMTAB stab,BOOLEAN * eflg)1486 llrpt_arccos (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1487 {
1488 PNODE argvar = builtin_args(node);
1489 PVALUE val = eval_and_coerce(PFLOAT, argvar, stab, eflg);
1490 FLOAT fval=0;
1491
1492 if (*eflg) {
1493 prog_var_error(node, stab, argvar, val, nonflox, "arccos", "1");
1494 delete_pvalue_ptr(&val);
1495 return NULL;
1496 }
1497
1498 fval = pvalue_to_float(val);
1499
1500 /* avoid SIGFPE caused by invalid input */
1501 if (fval > 1.0 || fval < -1.0) {
1502 *eflg = 1;
1503 prog_var_error(node, stab, argvar, val, badtrig, "arccos", "1");
1504 delete_pvalue_ptr(&val);
1505 return NULL;
1506 }
1507 delete_pvalue_ptr(&val);
1508
1509 return create_pvalue_from_float(rad2deg(acos(fval)));
1510 }
1511 /*========================================
1512 * llrpt_arctan -- trigonometric inverse TANGENT function
1513 * usage: arctan(FLOAT) -> FLOAT
1514 *======================================*/
1515 PVALUE
llrpt_arctan(PNODE node,SYMTAB stab,BOOLEAN * eflg)1516 llrpt_arctan (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1517 {
1518 PNODE argvar = builtin_args(node);
1519 PVALUE val = eval_and_coerce(PFLOAT, argvar, stab, eflg);
1520 FLOAT fval=0;
1521
1522 if (*eflg) {
1523 prog_var_error(node, stab, argvar, val, nonflox, "arctan", "1");
1524 delete_pvalue_ptr(&val);
1525 return NULL;
1526 }
1527 fval = pvalue_to_float(val);
1528 delete_pvalue_ptr(&val);
1529
1530 return create_pvalue_from_float(rad2deg(atan(fval)));
1531 }
1532 /*========================================
1533 * llrpt_spdist -- spherical distance calculator
1534 * usage: spdist(FLOAT, FLOAT, FLOAT, FLOAT) -> FLOAT
1535 * (lat0, lon0, lat1, lon1) -> distance (in km)
1536 *======================================*/
1537 PVALUE
llrpt_spdist(PNODE node,SYMTAB stab,BOOLEAN * eflg)1538 llrpt_spdist (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1539 {
1540 PNODE argvar1 = builtin_args(node);
1541 PNODE argvar2 = inext(argvar1);
1542 PNODE argvar3 = inext(argvar2);
1543 PNODE argvar4 = inext(argvar3);
1544 PVALUE val1, val2, val3, val4;
1545 FLOAT lat0, lon0, lat1, lon1;
1546 FLOAT dist, dist1, dist2;
1547
1548 val1 = eval_and_coerce(PFLOAT, argvar1, stab, eflg);
1549 if (*eflg) {
1550 prog_var_error(node, stab, argvar1, val1, nonflox, "spdist", "1");
1551 delete_pvalue_ptr(&val1);
1552 return NULL;
1553 }
1554 lat0 = pvalue_to_float(val1);
1555 delete_pvalue_ptr(&val1);
1556
1557 val2 = eval_and_coerce(PFLOAT, argvar2, stab, eflg);
1558 if (*eflg) {
1559 prog_var_error(node, stab, argvar2, val2, nonflox, "spdist", "2");
1560 delete_pvalue_ptr(&val2);
1561 return NULL;
1562 }
1563 lon0 = pvalue_to_float(val2);
1564 delete_pvalue_ptr(&val2);
1565
1566 val3 = eval_and_coerce(PFLOAT, argvar3, stab, eflg);
1567 if (*eflg) {
1568 prog_var_error(node, stab, argvar3, val3, nonflox, "spdist", "3");
1569 delete_pvalue_ptr(&val3);
1570 return NULL;
1571 }
1572 lat1 = pvalue_to_float(val3);
1573 delete_pvalue_ptr(&val3);
1574
1575 val4 = eval_and_coerce(PFLOAT, argvar4, stab, eflg);
1576 if (*eflg) {
1577 prog_var_error(node, stab, argvar4, val4, nonflox, "spdist", "4");
1578 delete_pvalue_ptr(&val4);
1579 return NULL;
1580 }
1581 lon1 = pvalue_to_float(val4);
1582 delete_pvalue_ptr(&val4);
1583
1584 /* Suggested by Patrick Texier, and verified by the following sites*/
1585 /* 1) http://www.skimountaineer.com/CascadeSki/CascadeDistance.php */
1586 /* 2) http://www.indo.com/distance/dist.pl */
1587 /* NOTE: Must convert degrees to radians, since that's what the C */
1588 /* library functions expect! */
1589 dist1 = cos(deg2rad(lat0)) * cos(deg2rad(lat1)) * cos(deg2rad(lon0)-deg2rad(lon1));
1590 dist2 = sin(deg2rad(lat0)) * sin(deg2rad(lat1));
1591 dist = 6380.0 * acos(dist1 + dist2);
1592
1593 return create_pvalue_from_float(dist);
1594 }
1595