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 * builtin.c -- Many interpreter builtin functions
26 * Copyright(c) 1992-95 by T.T. Wetmore IV; all rights reserved
27 * 2.3.4 - 24 Jun 93 2.3.5 - 07 Sep 93
28 * 3.0.0 - 07 May 94 3.0.2 - 03 Jan 95
29 * 3.0.3 - 02 Jul 96
30 *===========================================================*/
31
32 #include "sys_inc.h"
33 #include "llstdlib.h"
34 #include "table.h"
35 #include "translat.h"
36 #include "gedcom.h"
37 #include "cache.h"
38 #include "indiseq.h"
39 #include "rptui.h"
40 #include "feedback.h"
41 #include "lloptions.h"
42 #include "date.h"
43 #include "zstr.h"
44 #include "codesets.h"
45 #include "arch.h"
46
47 #include "interpi.h"
48
49 /*********************************************
50 * external/imported variables
51 *********************************************/
52
53 extern STRING qSaskstr,qSchoostrttl;
54
55 /*********************************************
56 * local function prototypes
57 *********************************************/
58
59 static ZSTR decode(STRING str, INT * offset);
60 static FLOAT julianday(GDATEVAL gdv);
61 static INT normalize_year(INT yr);
62
63 /*********************************************
64 * local variables
65 *********************************************/
66
67 static struct tag_rfmt rpt_long_rfmt; /* short form report format */
68 static struct tag_rfmt rpt_shrt_rfmt; /* long form report format */
69
70 /*********************************************
71 * local function definitions
72 * body of module
73 *********************************************/
74
75 /*========================================+
76 * llrpt_getint -- Have user provide integer
77 * usage: getint(IDEN [,STRING]) --> VOID
78 *=======================================*/
79 PVALUE
llrpt_getint(PNODE node,SYMTAB stab,BOOLEAN * eflg)80 llrpt_getint (PNODE node, SYMTAB stab, BOOLEAN *eflg)
81 {
82 PNODE argvar = builtin_args(node);
83 PNODE argvar2=0;
84 INT num;
85 STRING msg = 0;
86 PVALUE val = NULL;
87 if (!iistype(argvar, IIDENT)) {
88 prog_var_error(node, stab, argvar, NULL, nonvarx, "getint", "1");
89 *eflg = TRUE;
90 return NULL;
91 }
92 if ((argvar2 = inext(argvar)) != NULL) {
93 val = eval_and_coerce(PSTRING, argvar2, stab, eflg);
94 if (*eflg) {
95 prog_var_error(node, stab, argvar2, val, nonstrx, "getint", "2");
96 delete_pvalue(val);
97 return NULL;
98 }
99 msg = pvalue_to_string(val);
100 }
101 if (!msg)
102 msg = _("Enter integer for program");
103 if (!rptui_ask_for_int(msg, &num)) {
104 *eflg = TRUE;
105 return NULL;
106 }
107 assign_iden(stab, iident_name(argvar), create_pvalue_from_int(num));
108 delete_pvalue(val);
109 return NULL;
110 }
111 /*========================================+
112 * llrpt_getstr -- Have user provide string
113 * usage: getstr(IDEN [,STRING]) --> VOID
114 *=======================================*/
115 PVALUE
llrpt_getstr(PNODE node,SYMTAB stab,BOOLEAN * eflg)116 llrpt_getstr (PNODE node, SYMTAB stab, BOOLEAN *eflg)
117 {
118 PNODE argvar = builtin_args(node);
119 PNODE argvar2=0;
120 STRING msg = _(qSchoostrttl);
121 PVALUE val = NULL, ansval;
122 char buffer[MAXPATHLEN];
123 if (!iistype(argvar, IIDENT)) {
124 prog_var_error(node, stab, argvar, NULL, nonvarx, "getstr", "1");
125 *eflg = TRUE;
126 return NULL;
127 }
128 if ((argvar2 = inext(argvar)) != NULL) {
129 val = eval_and_coerce(PSTRING, argvar2, stab, eflg);
130 if (*eflg) {
131 prog_var_error(node, stab, argvar2, val, nonstrx, "getstr", "2");
132 delete_pvalue(val);
133 return NULL;
134 }
135 msg = pvalue_to_string(val);
136 }
137 if (!ask_for_string(msg, _(qSaskstr), buffer, sizeof(buffer))) {
138 /* Cancel yields empty string */
139 buffer[0]=0;
140 }
141 ansval = create_pvalue_from_string(buffer);
142 assign_iden(stab, iident_name(argvar), ansval);
143 delete_pvalue(val);
144 return NULL;
145 }
146 /*=========================================+
147 * llrpt_getindi -- Have user identify person
148 * usage: getindi(IDEN [,STRING]) --> VOID
149 *========================================*/
150 PVALUE
llrpt_getindi(PNODE node,SYMTAB stab,BOOLEAN * eflg)151 llrpt_getindi (PNODE node, SYMTAB stab, BOOLEAN *eflg)
152 {
153 PNODE argvar = builtin_args(node);
154 PNODE argvar2=0;
155 STRING key=0, msg = 0;
156 PVALUE val = NULL;
157 if (!iistype(argvar, IIDENT)) {
158 prog_var_error(node, stab, argvar, NULL, nonvarx, "getindi", "1");
159 *eflg = TRUE;
160 return NULL;
161 }
162 if ((argvar2 = inext(argvar)) != 0) {
163 val = eval_and_coerce(PSTRING, argvar2, stab, eflg);
164 if (*eflg) {
165 prog_var_error(node, stab, argvar2, val, nonstrx, "getindi", "2");
166 delete_pvalue(val);
167 return NULL;
168 }
169 msg = pvalue_to_string(val);
170 }
171 if (!msg)
172 msg = _("Identify person for program:");
173 assign_iden(stab, iident_name(argvar), create_pvalue_from_indi(NULL));
174 key = rptui_ask_for_indi_key(msg, DOASK1);
175 if (key) {
176 assign_iden(stab, iident_name(argvar)
177 , create_pvalue_from_indi_key(key));
178 }
179 delete_pvalue_ptr(&val);
180 return NULL;
181 }
182 /*=====================================+
183 * llrpt_getfam -- Have user identify family
184 * usage: getfam(IDEN) --> VOID
185 *====================================*/
186 PVALUE
llrpt_getfam(PNODE node,SYMTAB stab,BOOLEAN * eflg)187 llrpt_getfam (PNODE node, SYMTAB stab, BOOLEAN *eflg)
188 {
189 PNODE argvar = builtin_args(node);
190 NODE fam=0;
191 if (!iistype(argvar, IIDENT)) {
192 prog_var_error(node, stab, argvar, NULL, nonvar1, "getfam");
193 *eflg = TRUE;
194 return NULL;
195 }
196 assign_iden(stab, iident_name(argvar), NULL);
197 fam = nztop(rptui_ask_for_fam(_("Enter a spouse from family."),
198 _("Enter a sibling from family.")));
199 assign_iden(stab, iident_name(argvar), create_pvalue_from_fam(fam));
200 return NULL;
201 }
202 /*=================================================+
203 * llrpt_getindiset -- Have user identify set of persons
204 * usage: getindiset(IDEN [,STRING]) --> VOID
205 * This introduces both null value indiseqs and null
206 * indiseqs into reports so report code must handle them
207 *================================================*/
208 PVALUE
llrpt_getindiset(PNODE node,SYMTAB stab,BOOLEAN * eflg)209 llrpt_getindiset (PNODE node, SYMTAB stab, BOOLEAN *eflg)
210 {
211 PNODE argvar = builtin_args(node);
212 PNODE argvar2=0;
213 INDISEQ seq=0;
214 STRING msg = 0;
215 PVALUE val = NULL;
216 if (!iistype(argvar, IIDENT)) {
217 prog_var_error(node, stab, argvar, NULL, nonvarx, "getindiset", "1");
218 *eflg = TRUE;
219 return NULL;
220 }
221 if ((argvar2 = inext(argvar)) != NULL) {
222 val = eval_and_coerce(PSTRING, argvar2, stab, eflg);
223 if (*eflg) {
224 prog_var_error(node, stab, argvar2, val, nonstrx, "getindiset", "2");
225 delete_pvalue(val);
226 return NULL;
227 }
228 msg = pvalue_to_string(val);
229 }
230 if (!msg)
231 msg = _("Identify list of persons for program:");
232 seq = rptui_ask_for_indi_list(msg, TRUE);
233 if (seq)
234 namesort_indiseq(seq); /* in case uilocale != rptlocale */
235 delete_pvalue_ptr(&val);
236 assign_iden(stab, iident_name(argvar), create_pvalue_from_seq(seq));
237 return NULL;
238 }
239 /*==================================+
240 * llrpt_gettext -- translate to ambient locale
241 * usage: gettext(STRING) --> STRING
242 *=================================*/
243 PVALUE
llrpt_gettext(PNODE node,SYMTAB stab,BOOLEAN * eflg)244 llrpt_gettext (PNODE node, SYMTAB stab, BOOLEAN *eflg)
245 {
246 STRING str=0;
247 #ifdef ENABLE_NLS
248 STRING str2=0,textdomain=0,localepath=0;
249 #endif /* ENABLE_NLS */
250 PNODE argvar = builtin_args(node);
251 PVALUE val = eval_and_coerce(PSTRING, argvar, stab, eflg);
252 PVALUE newval=0;
253 if (*eflg) {
254 prog_var_error(node, stab, argvar, val, nonstr1, "gettext");
255 return NULL;
256 }
257 str = pvalue_to_string(val);
258 #ifdef ENABLE_NLS
259 textdomain = zs_str(irptinfo(node)->textdomain);
260 localepath = zs_str(irptinfo(node)->localepath);
261 ll_bindtextdomain(textdomain, localepath);
262 set_gettext_codeset(textdomain, "work_around_set_gettext_codeset_cache");
263 set_gettext_codeset(textdomain, int_codeset);
264 str2 = irptinfo(node)->fullpath;
265 str2 = _(str);
266 ll_bindtextdomain(PACKAGE, localepath);
267 str = str2;
268 #endif
269 newval = create_pvalue_from_string(str);
270 delete_pvalue_ptr(&val);
271 return newval;
272 }
273 /*==================================+
274 * llrpt_gettoday -- Create today's event
275 * usage: gettoday() --> EVENT
276 *=================================*/
277 PVALUE
llrpt_gettoday(PNODE node,SYMTAB stab,BOOLEAN * eflg)278 llrpt_gettoday (PNODE node, SYMTAB stab, BOOLEAN *eflg)
279 {
280 NODE prnt = create_temp_node(NULL, "EVEN", NULL, NULL);
281 NODE chil = create_temp_node(NULL, "DATE", get_todays_date(), prnt);
282 node=node; /* unused */
283 stab=stab; /* unused */
284 eflg=eflg; /* unused */
285
286 nchild(prnt) = chil;
287 return create_pvalue_from_node(prnt);
288 }
289 /*====================================+
290 * llrpt_name -- Find person's name
291 * usage: name(INDI[,BOOL]) -> STRING
292 *===================================*/
293 PVALUE
llrpt_name(PNODE node,SYMTAB stab,BOOLEAN * eflg)294 llrpt_name (PNODE node, SYMTAB stab, BOOLEAN *eflg)
295 {
296 PNODE argvar = builtin_args(node);
297 PNODE argvar2=0;
298 NODE name, indi = eval_indi(argvar, stab, eflg, NULL);
299 SURCAPTYPE captype = DOSURCAP;
300 PVALUE val=0;
301 STRING outname = 0;
302 if (*eflg) {
303 prog_var_error(node, stab, argvar, NULL, nonindx, "name", "1");
304 return NULL;
305 }
306 if (!indi) return create_pvalue_from_string("");
307 if ((argvar2 = inext(argvar)) != NULL) {
308 val = eval_and_coerce(PBOOL, argvar2, stab, eflg);
309 if (*eflg) {
310 prog_var_error(node, stab, argvar2, val, nonboox, "name", "2");
311 delete_pvalue(val);
312 return NULL;
313 }
314 captype = pvalue_to_bool(val) ? DOSURCAP : NOSURCAP;
315 delete_pvalue_ptr(&val);
316 }
317 if (!(name = find_tag(nchild(indi), "NAME"))) {
318 if (getlloptint("RequireNames", 0)) {
319 *eflg = TRUE;
320 prog_var_error(node, stab, argvar, NULL, _("name: person does not have a name"));
321 return NULL;
322 }
323 return create_pvalue_from_string(0);
324 }
325 outname = manip_name(nval(name), captype, REGORDER, 68);
326 return create_pvalue_from_string(outname);
327 }
328 /*==================================================+
329 * llrpt_fullname -- Process person's name
330 * usage: fullname(INDI, BOOL, BOOL, INT) -> STRING
331 *=================================================*/
332 PVALUE
llrpt_fullname(PNODE node,SYMTAB stab,BOOLEAN * eflg)333 llrpt_fullname (PNODE node, SYMTAB stab, BOOLEAN *eflg)
334 {
335 PNODE argvar = builtin_args(node);
336 NODE name=0, indi=0;
337 PVALUE val=0;
338 SURCAPTYPE caps = DOSURCAP;
339 SURORDER regorder = REGORDER;
340 INT len=0;
341 STRING outname=0;
342
343 indi = eval_indi(argvar, stab, eflg, NULL);
344 if (*eflg || !indi) {
345 *eflg = TRUE;
346 prog_var_error(node, stab, argvar, NULL, nonindx, "fullname", "1");
347 return NULL;
348 }
349 val = eval_and_coerce(PBOOL, argvar = inext(argvar), stab, eflg);
350 if (*eflg) {
351 prog_var_error(node, stab, argvar, val, nonboox, "fullname", "2");
352 delete_pvalue(val);
353 return NULL;
354 }
355 caps = pvalue_to_bool(val) ? DOSURCAP : NOSURCAP;
356 delete_pvalue_ptr(&val);
357 val = eval_and_coerce(PBOOL, argvar = inext(argvar), stab, eflg);
358 if (*eflg) {
359 prog_var_error(node, stab, argvar, val, nonboox, "fullname", "3");
360 delete_pvalue(val);
361 return NULL;
362 }
363 regorder = pvalue_to_bool(val) ? REGORDER : SURFIRST;
364 delete_pvalue_ptr(&val);
365 val = eval_and_coerce(PINT, argvar = inext(argvar), stab, eflg);
366 if (*eflg) {
367 prog_var_error(node, stab, argvar, val, nonintx, "fullname", "4");
368 delete_pvalue(val);
369 return NULL;
370 }
371 len = pvalue_to_int(val);
372 delete_pvalue_ptr(&val);
373 if (!(name = NAME(indi)) || !nval(name)) {
374 if (getlloptint("RequireNames", 0)) {
375 *eflg = TRUE;
376 prog_var_error(node, stab, NULL, NULL, _("fullname: person does not have a name"));
377 return NULL;
378 }
379 return create_pvalue_from_string(0);
380 }
381 outname = manip_name(nval(name), caps, regorder, len);
382 return create_pvalue_from_string(outname);
383 }
384 /*==================================+
385 * llrpt_surname -- Find person's surname using new getasurname() routine.
386 * usage: surname(INDI) -> STRING
387 *=================================*/
388 PVALUE
llrpt_surname(PNODE node,SYMTAB stab,BOOLEAN * eflg)389 llrpt_surname (PNODE node, SYMTAB stab, BOOLEAN *eflg)
390 {
391 PNODE argvar = builtin_args(node);
392 NODE name=0, indi = eval_indi(argvar, stab, eflg, NULL);
393 CNSTRING str=0;
394
395 if (*eflg) {
396 prog_var_error(node, stab, argvar, NULL, nonvar1, "surname");
397 return NULL;
398 }
399 if (!indi) return create_pvalue_from_string("");
400 if (!(name = NAME(indi)) || !nval(name)) {
401 if (getlloptint("RequireNames", 0)) {
402 *eflg = TRUE;
403 prog_var_error(node, stab, argvar, NULL, _("surname: person does not have a name"));
404 return NULL;
405 }
406 return create_pvalue_from_string(0);
407 }
408 str = getasurname(nval(name));
409 return create_pvalue_from_string(str);
410 }
411 /*========================================+
412 * llrpt_soundex -- SOUNDEX function on persons
413 * usage: soundex(INDI) -> STRING
414 *=======================================*/
415 PVALUE
llrpt_soundex(PNODE node,SYMTAB stab,BOOLEAN * eflg)416 llrpt_soundex (PNODE node, SYMTAB stab, BOOLEAN *eflg)
417 {
418 PNODE argvar = builtin_args(node);
419 NODE name, indi = eval_indi(argvar, stab, eflg, NULL);
420 if (*eflg || !indi) {
421 *eflg = TRUE;
422 prog_var_error(node, stab, argvar, NULL, nonvar1, "soundex");
423 return NULL;
424 }
425 if (!(name = NAME(indi)) || !nval(name)) {
426 if (getlloptint("RequireNames", 0)) {
427 *eflg = TRUE;
428 prog_var_error(node, stab, argvar, NULL, _("soundex: person does not have a name"));
429 return NULL;
430 }
431 return create_pvalue_from_string(0);
432 }
433 return create_pvalue_from_string(trad_soundex(getsxsurname(nval(name))));
434 }
435 /*===========================================+
436 * llrpt_strsoundex -- SOUNDEX function on strings
437 * usage: strsoundex(STRING) -> STRING
438 *==========================================*/
439 PVALUE
llrpt_strsoundex(PNODE node,SYMTAB stab,BOOLEAN * eflg)440 llrpt_strsoundex (PNODE node, SYMTAB stab, BOOLEAN *eflg)
441 {
442 PNODE argvar = builtin_args(node);
443 PVALUE newval=0, val = NULL;
444 CNSTRING str=0;
445 val = eval_and_coerce(PSTRING, argvar, stab, eflg);
446 if (*eflg) {
447 prog_var_error(node, stab, argvar, val, nonstr1, "strsoundex");
448 delete_pvalue(val);
449 return NULL;
450 }
451 str = trad_soundex(pvalue_to_string(val));
452 newval = create_pvalue_from_string(str);
453 delete_pvalue(val);
454 return newval;
455 }
456 /*===========================================+
457 * llrpt_bytecode -- Input string with escape codes
458 * and optionally specified codeset
459 * eg, bytecode("I$C3$B1$C3$A1rritu", "UTF-8")
460 * usage: bytecode(STRING, [STRING]) -> STRING
461 *==========================================*/
462 PVALUE
llrpt_bytecode(PNODE node,SYMTAB stab,BOOLEAN * eflg)463 llrpt_bytecode (PNODE node, SYMTAB stab, BOOLEAN *eflg)
464 {
465 PNODE argvar = builtin_args(node);
466 PVALUE val = eval_and_coerce(PSTRING, argvar, stab, eflg);
467 PVALUE newval=0;
468 STRING codeset=0;
469 INT offset=0;
470 ZSTR zstr=0;
471 STRING str=0;
472 if (*eflg) {
473 prog_var_error(node, stab, argvar, val, nonstrx, "bytecode", "1");
474 goto bytecode_exit;
475 }
476 if (argvar) {
477 PVALUE val2 = eval_and_coerce(PSTRING, argvar = inext(argvar), stab, eflg);
478 if (*eflg) {
479 prog_var_error(node, stab, argvar, NULL, nonstrx, "bytecode", "2");
480 goto bytecode_exit;
481 }
482 codeset = strsave(pvalue_to_string(val2));
483 delete_pvalue_ptr(&val2);
484 } else {
485 codeset = strsave(report_codeset_in);
486 }
487 str = pvalue_to_string(val);
488 zstr = decode(str, &offset);
489 if (offset >= 0) {
490 prog_var_error(node, stab, argvar, val
491 , _("Bad escape code at offset %d in bytecode string <%s>")
492 , offset+1, str);
493 *eflg = TRUE;
494 goto bytecode_exit;
495 }
496 /* raw is a special case meaning do NOT go to internal */
497 /* raw is for use in test scripts, testing codeconvert */
498 if (!eqstr(codeset, "raw")) {
499 /* now translate to internal, if possible */
500 XLAT xlat = transl_get_xlat_to_int(codeset);
501 if (xlat)
502 transl_xlat(xlat, zstr);
503 }
504 newval = create_pvalue_from_string(zs_str(zstr));
505 bytecode_exit:
506 zs_free(&zstr);
507 delete_pvalue_ptr(&val);
508 strfree(&codeset);
509 return newval;
510 }
511 /*===========================================+
512 * llrpt_convertcode -- Convert string to another codeset
513 * eg, convertcode(str, "UTF-8//html")
514 * or for use in self-tests, convertcode(bytecode("$C3$B1$C3$A1"), "UTF-8", "ISO-8859-1")
515 * (which should come out "��"
516 * usage: convertcode(STRING, STRING, [STRING]) -> STRING
517 *==========================================*/
518 PVALUE
llrpt_convertcode(PNODE node,SYMTAB stab,BOOLEAN * eflg)519 llrpt_convertcode (PNODE node, SYMTAB stab, BOOLEAN *eflg)
520 {
521 PNODE argvar = builtin_args(node);
522 PVALUE val = eval_and_coerce(PSTRING, argvar, stab, eflg);
523 PVALUE newval=0;
524 PVALUE tempval=0;
525 ZSTR zstr=0;
526 STRING cs_src=0, cs_dest=0;
527 XLAT xlat=0;
528 if (*eflg) {
529 prog_var_error(node, stab, argvar, NULL, nonstrx, "convertcode", "1");
530 goto convertcode_exit;
531 }
532 argvar = inext(argvar);
533 ASSERT(argvar);
534 tempval = eval_and_coerce(PSTRING, argvar, stab, eflg);
535 if (*eflg) {
536 prog_var_error(node, stab, argvar, NULL, nonstrx, "convertcode", "2");
537 goto convertcode_exit;
538 }
539 cs_dest = strsave(pvalue_to_string(tempval));
540 delete_pvalue_ptr(&tempval);
541 argvar = inext(argvar);
542 if (argvar) {
543 cs_src = cs_dest;
544 tempval = eval_and_coerce(PSTRING, argvar, stab, eflg);
545 if (*eflg) {
546 prog_var_error(node, stab, argvar, NULL, nonstrx, "convertcode", "3");
547 goto convertcode_exit;
548 }
549 cs_dest = strsave(pvalue_to_string(tempval));
550 delete_pvalue_ptr(&tempval);
551 }
552 if (!cs_src)
553 cs_src = strsave(int_codeset);
554 zstr = zs_news(pvalue_to_string(val));
555 xlat = transl_get_xlat(cs_src, cs_dest);
556 if (xlat)
557 transl_xlat(xlat, zstr);
558 newval = create_pvalue_from_string(zs_str(zstr));
559 convertcode_exit:
560 strfree(&cs_src);
561 strfree(&cs_dest);
562 zs_free(&zstr);
563 delete_pvalue(val);
564 return newval;
565 }
566
567 /*===============================+
568 * decode -- Convert any embedded escape codes into bytes
569 * str: [IN] string with embedded escape codes, eg: "I$C3$B1$C3$A1rritu"
570 * offset: [OUT] -1 if ok, else 0-based offset of failure
571 *==============================*/
572 static ZSTR
decode(STRING str,INT * offset)573 decode (STRING str, INT * offset)
574 {
575 ZSTR zstr = zs_newn((unsigned int)((strlen(str)*2+2)));
576 STRING ptr=0;
577 *offset = -1;
578 for (ptr=str; *ptr; ++ptr) {
579 if (*ptr == '$') {
580 INT n = get_hexidecimal(ptr+1);
581 /* error if bad hex escape */
582 if (n == -1) {
583 *offset = ptr - str;
584 goto decode_exit;
585 }
586 ptr += 2;
587 zs_appc(zstr, (uchar)(unsigned int)n);
588 } else {
589 zs_appc(zstr, *ptr);
590 }
591 }
592 decode_exit:
593 return zstr;
594 }
595 /*===========================================+
596 * llrpt_setlocale -- Set current locale
597 * usage: setlocale(STRING) -> STRING
598 *==========================================*/
599 PVALUE
llrpt_setlocale(PNODE node,SYMTAB stab,BOOLEAN * eflg)600 llrpt_setlocale (PNODE node, SYMTAB stab, BOOLEAN *eflg)
601 {
602 PNODE argvar = builtin_args(node);
603 PVALUE newval=0;
604 PVALUE val = eval_and_coerce(PSTRING, argvar, stab, eflg);
605 STRING str=0;
606 if (*eflg) {
607 prog_var_error(node, stab, argvar, val, nonstr1, "setlocale");
608 delete_pvalue(val);
609 return NULL;
610 }
611 str = pvalue_to_string(val);
612 str = rpt_setlocale(str);
613 str = str ? str : "C";
614 newval = create_pvalue_from_string(str);
615 delete_pvalue(val);
616 return newval;
617 }
618 /*===============================+
619 * llrpt_givens -- Find given names
620 * usage: givens(INDI) -> STRING
621 *==============================*/
622 PVALUE
llrpt_givens(PNODE node,SYMTAB stab,BOOLEAN * eflg)623 llrpt_givens (PNODE node, SYMTAB stab, BOOLEAN *eflg)
624 {
625 PNODE argvar = builtin_args(node);
626 NODE name=0;
627 NODE indi = eval_indi(argvar, stab, eflg, NULL);
628 CNSTRING str=0;
629 if (*eflg) {
630 prog_var_error(node, stab, argvar, NULL, _(nonindx), "givens", "1");
631 return NULL;
632 }
633 if (!indi) return create_pvalue_from_string("");
634 if (!(name = NAME(indi)) || !nval(name)) {
635 if (getlloptint("RequireNames", 0)) {
636 *eflg = TRUE;
637 prog_error(node, _("(givens) person does not have a name"));
638 return NULL;
639 }
640 return create_pvalue_from_string(0);
641 }
642 str = givens(nval(name));
643 return create_pvalue_from_string(str);
644 }
645 /*===============================+
646 * llrpt_set -- Assignment operation
647 * usage: set(IDEN, ANY) -> VOID
648 *==============================*/
649 PVALUE
llrpt_set(PNODE node,SYMTAB stab,BOOLEAN * eflg)650 llrpt_set (PNODE node, SYMTAB stab, BOOLEAN *eflg)
651 {
652 PNODE argvar = builtin_args(node);
653 PNODE argvar2 = inext(argvar);
654 PVALUE val=0;
655 if (!iistype(argvar, IIDENT)) {
656 *eflg = TRUE;
657 prog_var_error(node, stab, argvar, NULL, nonvarx, "set", "1");
658 return NULL;
659 }
660 val = evaluate(argvar2, stab, eflg);
661 if (*eflg || !val) {
662 if (!(*eflg) && !val) {
663 *eflg = TRUE;
664 prog_var_error(node, stab, argvar2, val, _("set(%s, <Null>) is invalid"), iident_name(argvar));
665 } else {
666 *eflg = TRUE;
667 prog_var_error(node, stab, argvar2, val, badargx, "set", "2");
668 }
669 return NULL;
670 }
671 assign_iden(stab, iident_name(argvar), val);
672 return NULL;
673 }
674 /*===========================================+
675 * llrpt_setdate -- Date assignment operation
676 * usage: setdate(IDEN, STRING) -> VOID
677 * creation: Patrick Texier 2005/05/22
678 * Added to cvs: 2006/06/10
679 *===========================================*/
680 PVALUE
llrpt_setdate(PNODE node,SYMTAB stab,BOOLEAN * eflg)681 llrpt_setdate (PNODE node, SYMTAB stab, BOOLEAN *eflg)
682 {
683 PNODE argvar = builtin_args(node);
684 PNODE argvar2=0;
685 STRING str = 0;
686 PVALUE val = NULL;
687 NODE prnt=0, chil=0;
688
689 if (!iistype(argvar, IIDENT)) {
690 prog_var_error(node, stab, argvar, NULL, nonvarx, "setdate", "1");
691 *eflg = TRUE;
692 return NULL;
693 }
694 if ((argvar2 = inext(argvar)) != NULL) {
695 val = eval_and_coerce(PSTRING, argvar2, stab, eflg);
696 if (*eflg) {
697 prog_var_error(node, stab, argvar2, val, nonstrx, "setdate", "2");
698 delete_pvalue(val);
699 return NULL;
700 }
701 str = pvalue_to_string(val);
702 }
703 /* Create an EVEN node with subordinate DATE node */
704 prnt = create_temp_node(NULL, "EVEN", NULL, NULL);
705 chil = create_temp_node(NULL, "DATE", str, prnt);
706 nchild(prnt) = chil;
707 /* Assign new EVEN node to new pvalue, and assign that to specified identifier */
708 assign_iden(stab, iident_name(argvar), create_pvalue_from_node(prnt));
709 return NULL;
710 }
711 /*=========================================+
712 * llrpt_husband -- Find first husband of family
713 * usage: husband(FAM) -> INDI
714 *========================================*/
715 PVALUE
llrpt_husband(PNODE node,SYMTAB stab,BOOLEAN * eflg)716 llrpt_husband (PNODE node, SYMTAB stab, BOOLEAN *eflg)
717 {
718 PNODE argvar = builtin_args(node);
719 NODE fam = eval_fam(argvar, stab, eflg, NULL);
720 if (*eflg || !fam) {
721 *eflg = TRUE;
722 prog_var_error(node, stab, argvar, NULL, nonfam1, "husband");
723 return NULL;
724 }
725 return create_pvalue_from_indi(fam_to_husb_node(fam));
726 }
727 /*===================================+
728 * llrpt_wife -- Find first wife of family
729 * usage: wife(FAM) -> INDI
730 *==================================*/
731 PVALUE
llrpt_wife(PNODE node,SYMTAB stab,BOOLEAN * eflg)732 llrpt_wife (PNODE node, SYMTAB stab, BOOLEAN *eflg)
733 {
734 PNODE argvar = builtin_args(node);
735 NODE fam = eval_fam(argvar, stab, eflg, NULL);
736 if (*eflg || !fam) {
737 *eflg = TRUE;
738 prog_var_error(node, stab, argvar, NULL, nonfam1, "wife");
739 return NULL;
740 }
741 return create_pvalue_from_indi(fam_to_wife_node(fam));
742 }
743 /*==========================================+
744 * llrpt_firstchild -- Find first child of family
745 * usage: firstchild(FAM) -> INDI
746 *=========================================*/
747 PVALUE
llrpt_firstchild(PNODE node,SYMTAB stab,BOOLEAN * eflg)748 llrpt_firstchild (PNODE node, SYMTAB stab, BOOLEAN *eflg)
749 {
750 PNODE argvar = builtin_args(node);
751 NODE fam = eval_fam(argvar, stab, eflg, NULL);
752 if (*eflg || !fam) {
753 *eflg = TRUE;
754 prog_var_error(node, stab, argvar, NULL, nonfam1, "firstchild");
755 return NULL;
756 }
757 return create_pvalue_from_indi(fam_to_first_chil(fam));
758 }
759 /*========================================+
760 * llrpt_lastchild -- Find last child of family
761 * usage: lastchild(FAM) -> INDI
762 *=======================================*/
763 PVALUE
llrpt_lastchild(PNODE node,SYMTAB stab,BOOLEAN * eflg)764 llrpt_lastchild (PNODE node, SYMTAB stab, BOOLEAN *eflg)
765 {
766 PNODE argvar = builtin_args(node);
767 NODE fam = eval_fam(argvar, stab, eflg, NULL);
768 if (*eflg || !fam) {
769 *eflg = TRUE;
770 prog_var_error(node, stab, argvar, NULL, nonfam1, "lastchild");
771 return NULL;
772 }
773 return create_pvalue_from_indi(fam_to_last_chil(fam));
774 }
775 /*=================================+
776 * llrpt_marr -- Find marriage of family
777 * usage: marriage(FAM) -> EVENT
778 *================================*/
779 PVALUE
llrpt_marr(PNODE node,SYMTAB stab,BOOLEAN * eflg)780 llrpt_marr (PNODE node, SYMTAB stab, BOOLEAN *eflg)
781 {
782 PNODE argvar = builtin_args(node);
783 NODE fam = eval_fam(argvar, stab, eflg, NULL);
784 NODE event = NULL;
785 if (*eflg) {
786 prog_var_error(node, stab, argvar, NULL, nonfam1, "marriage");
787 return NULL;
788 }
789 if (fam)
790 event = MARR(fam);
791 return create_pvalue_from_node(event);
792 }
793 /*==========================================+
794 * llrpt_birt -- Find first birth event of person
795 * usage: birth(INDI) -> EVENT
796 *=========================================*/
797 PVALUE
llrpt_birt(PNODE node,SYMTAB stab,BOOLEAN * eflg)798 llrpt_birt (PNODE node, SYMTAB stab, BOOLEAN *eflg)
799 {
800 PNODE argvar = builtin_args(node);
801 NODE indi = eval_indi(argvar, stab, eflg, NULL);
802 NODE event = NULL;
803 if (*eflg) {
804 prog_var_error(node, stab, argvar, NULL, _(nonind1), "birth");
805 return NULL;
806 }
807 if (indi)
808 event = BIRT(indi);
809 return create_pvalue_from_node(event);
810 }
811 /*==========================================+
812 * llrpt_deat -- Find first death event of person
813 * usage: death(INDI) -> EVENT
814 *=========================================*/
815 PVALUE
llrpt_deat(PNODE node,SYMTAB stab,BOOLEAN * eflg)816 llrpt_deat (PNODE node, SYMTAB stab, BOOLEAN *eflg)
817 {
818 PNODE argvar = builtin_args(node);
819 NODE indi = eval_indi(argvar, stab, eflg, NULL);
820 NODE event = NULL;
821 if (*eflg) {
822 prog_var_error(node, stab, argvar, NULL, _(nonind1), "death");
823 return NULL;
824 }
825 if (indi)
826 event = DEAT(indi);
827 return create_pvalue_from_node(event);
828 }
829 /*============================================+
830 * llrpt_bapt -- Find first baptism event of person
831 * usage: baptism(INDI) -> EVENT
832 *===========================================*/
833 PVALUE
llrpt_bapt(PNODE node,SYMTAB stab,BOOLEAN * eflg)834 llrpt_bapt (PNODE node, SYMTAB stab, BOOLEAN *eflg)
835 {
836 PNODE argvar = builtin_args(node);
837 NODE indi = eval_indi(argvar, stab, eflg, NULL);
838 NODE event = NULL;
839 if (*eflg) {
840 prog_var_error(node, stab, argvar, NULL, _(nonind1), "baptism");
841 return NULL;
842 }
843 if (indi)
844 event = BAPT(indi);
845 return create_pvalue_from_node(event);
846 }
847 /*===========================================+
848 * llrpt_buri -- Find first burial event of person
849 * usage: burial(INDI) -> EVENT
850 *==========================================*/
851 PVALUE
llrpt_buri(PNODE node,SYMTAB stab,BOOLEAN * eflg)852 llrpt_buri (PNODE node, SYMTAB stab, BOOLEAN *eflg)
853 {
854 PNODE argvar = builtin_args(node);
855 NODE indi = eval_indi(argvar, stab, eflg, NULL);
856 NODE event = NULL;
857 if (*eflg) {
858 prog_var_error(node, stab, argvar, NULL, _(nonind1), "burial");
859 return NULL;
860 }
861 if (indi)
862 event = BURI(indi);
863 return create_pvalue_from_node(event);
864 }
865 /*====================================+
866 * llrpt_titl -- Find first title of person
867 * usage: title(INDI) -> STRING
868 *===================================*/
869 PVALUE
llrpt_titl(PNODE node,SYMTAB stab,BOOLEAN * eflg)870 llrpt_titl (PNODE node, SYMTAB stab, BOOLEAN *eflg)
871 {
872 PNODE argvar = builtin_args(node);
873 NODE titl=0;
874 NODE indi = eval_indi(argvar, stab, eflg, NULL);
875 STRING titlstr = "";
876 if (*eflg) {
877 prog_var_error(node, stab, argvar, NULL, _(nonind1), "title");
878 return NULL;
879 }
880 if (indi) {
881 titl = find_tag(nchild(indi), "TITL");
882 if (titl)
883 titlstr = nval(titl);
884 }
885 return create_pvalue_from_string(titlstr);
886 }
887 /*=======================================================
888 * rpt_shrt_format_date -- short form of date for reports
889 * This is used by the report "short" function.
890 * Created: 2001/10/29 (Perry Rapp)
891 *=====================================================*/
892 static STRING
rpt_shrt_format_date(STRING date)893 rpt_shrt_format_date (STRING date)
894 {
895 /* TO DO - customizing options */
896 /*static unsigned char buffer[MAXLINELEN+1];*/
897 if (!date) return NULL;
898 return shorten_date(date);
899 }
900 /*========================================================
901 * rpt_shrt_format_plac -- short form of place for reports
902 * This is used by the report "short" function.
903 * Created: 2001/10/29 (Perry Rapp)
904 *======================================================*/
905 static STRING
rpt_shrt_format_plac(STRING plac)906 rpt_shrt_format_plac (STRING plac)
907 {
908 /* TO DO - add customization */
909 if (!plac) return NULL;
910 return shorten_plac(plac);
911 }
912 /*==============================================================
913 * init_rpt_reformat -- set up formatting structures for reports
914 * Created: 2001/10/29 (Perry Rapp)
915 *============================================================*/
916 static void
init_rpt_reformat(void)917 init_rpt_reformat (void)
918 {
919 /* reformats are transforms applied to strings (date or place)
920 before they are finally output */
921
922 /* Set up long reformats */
923 memset(&rpt_long_rfmt, 0, sizeof(rpt_long_rfmt));
924 rpt_long_rfmt.rfmt_date = 0; /* use date as is */
925 rpt_long_rfmt.rfmt_plac = 0; /* use place as is */
926 rpt_long_rfmt.combopic = "%1, %2";
927 /* Set up short reformats */
928 memset(&rpt_shrt_rfmt, 0, sizeof(rpt_shrt_rfmt));
929 rpt_shrt_rfmt.rfmt_date = &rpt_shrt_format_date;
930 rpt_shrt_rfmt.rfmt_plac = &rpt_shrt_format_plac;
931 rpt_shrt_rfmt.combopic = "%1, %2";
932 }
933 /*===================================+
934 * llrpt_long -- Return long form of event
935 * usage: long(EVENT) -> STRING
936 *==================================*/
937 PVALUE
llrpt_long(PNODE node,SYMTAB stab,BOOLEAN * eflg)938 llrpt_long (PNODE node, SYMTAB stab, BOOLEAN *eflg)
939 {
940 PNODE argvar = builtin_args(node);
941 PVALUE val = eval_and_coerce(PGNODE, argvar, stab, eflg);
942 NODE even=0;
943 STRING str=0;
944 if (*eflg) {
945 prog_var_error(node, stab, argvar, val, nonnod1, "long");
946 return NULL;
947 }
948 even = pvalue_to_node(val);
949 delete_pvalue_ptr(&val);
950
951 /* if we were cleverer, we wouldn't call this every time */
952 init_rpt_reformat();
953
954 str = event_to_string(even, &rpt_long_rfmt);
955 return create_pvalue_from_string(str);
956 }
957 /*=====================================+
958 * llrpt_short -- Return short form of event
959 * usage: short(EVENT) -> STRING
960 *====================================*/
961 PVALUE
llrpt_short(PNODE node,SYMTAB stab,BOOLEAN * eflg)962 llrpt_short (PNODE node, SYMTAB stab, BOOLEAN *eflg)
963 {
964 PNODE argvar = builtin_args(node);
965 PVALUE val = eval_and_coerce(PGNODE, argvar, stab, eflg);
966 NODE even=0;
967 /* RFMT rfmt = NULL; */ /* currently no reformatting for reports */
968 STRING str;
969 if (*eflg) {
970 prog_var_error(node, stab, argvar, val, nonnod1, "short");
971 return NULL;
972 }
973 even = pvalue_to_node(val);
974 delete_pvalue_ptr(&val);
975
976 /* if we were cleverer, we wouldn't call this every time */
977 init_rpt_reformat();
978
979 str = event_to_string(even, &rpt_shrt_rfmt);
980 return create_pvalue_from_string(str);
981 }
982 /*===============================+
983 * llrpt_fath -- Find father of person
984 * usage: father(INDI) -> INDI
985 *==============================*/
986 PVALUE
llrpt_fath(PNODE node,SYMTAB stab,BOOLEAN * eflg)987 llrpt_fath (PNODE node, SYMTAB stab, BOOLEAN *eflg)
988 {
989 PNODE argvar = builtin_args(node);
990 PVALUE indival=0;
991 NODE indi = eval_indi2(argvar, stab, eflg, NULL, &indival);
992 NODE fath = NULL;
993 if (*eflg) {
994 prog_var_error(node, stab, argvar, indival, _(nonind1), "father");
995 delete_pvalue(indival);
996 return NULL;
997 }
998 delete_pvalue_ptr(&indival);
999 if (indi)
1000 fath = indi_to_fath(indi);
1001 return create_pvalue_from_indi(fath);
1002 }
1003 /*===============================+
1004 * llrpt_moth -- Find mother of person
1005 * usage: mother(INDI) -> INDI
1006 *==============================*/
1007 PVALUE
llrpt_moth(PNODE node,SYMTAB stab,BOOLEAN * eflg)1008 llrpt_moth (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1009 {
1010 PNODE argvar = builtin_args(node);
1011 PVALUE indival=0;
1012 NODE indi = eval_indi2(argvar, stab, eflg, NULL, &indival);
1013 if (*eflg) {
1014 prog_var_error(node, stab, argvar, indival, _(nonind1), "mother");
1015 return NULL;
1016 }
1017 if (!indi) return create_pvalue_from_indi(NULL);
1018 return create_pvalue_from_indi(indi_to_moth(indi));
1019 }
1020 /*===========================================+
1021 * llrpt_parents -- Find parents' family of person
1022 * usage: parents(INDI) -> FAM
1023 *==========================================*/
1024 PVALUE
llrpt_parents(PNODE node,SYMTAB stab,BOOLEAN * eflg)1025 llrpt_parents (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1026 {
1027 PNODE argvar = builtin_args(node);
1028 PVALUE indival=0;
1029 NODE indi = eval_indi2(argvar, stab, eflg, NULL, &indival);
1030 if (*eflg) {
1031 prog_var_error(node, stab, argvar, indival, _(nonind1), "parents");
1032 return NULL;
1033 }
1034 if (!indi) return create_pvalue_from_fam(NULL);
1035 return create_pvalue_from_fam(indi_to_famc(indi));
1036 }
1037 /*==========================================+
1038 * llrpt_nextsib -- Find person's younger sibling
1039 * usage: nextsib(INDI) -> INDI
1040 *=========================================*/
1041 PVALUE
llrpt_nextsib(PNODE node,SYMTAB stab,BOOLEAN * eflg)1042 llrpt_nextsib (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1043 {
1044 PNODE argvar = builtin_args(node);
1045 PVALUE indival=0;
1046 NODE indi = eval_indi2(argvar, stab, eflg, NULL, &indival);
1047 if (*eflg) {
1048 prog_var_error(node, stab, argvar, indival, _(nonind1), "nextsib");
1049 return NULL;
1050 }
1051 if (!indi) return create_pvalue_from_indi(NULL);
1052 return create_pvalue_from_indi(indi_to_next_sib_old(indi));
1053 }
1054 /*========================================+
1055 * llrpt_prevsib -- Find person's older sibling
1056 * usage: prevsib(INDI) -> INDI
1057 *=======================================*/
1058 PVALUE
llrpt_prevsib(PNODE node,SYMTAB stab,BOOLEAN * eflg)1059 llrpt_prevsib (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1060 {
1061 PNODE argvar = builtin_args(node);
1062 PVALUE indival=0;
1063 NODE indi = eval_indi2(argvar, stab, eflg, NULL, &indival);
1064 if (*eflg) {
1065 prog_var_error(node, stab, argvar, indival, _(nonind1), "prevsib");
1066 return NULL;
1067 }
1068 if (!indi) return create_pvalue_from_indi(NULL);
1069 return create_pvalue_from_indi(indi_to_prev_sib_old(indi));
1070 }
1071 /*========================================+
1072 * llrpt_d -- Return cardinal integer as string
1073 * usage: d(INT) -> STRING
1074 *=======================================*/
1075 PVALUE
llrpt_d(PNODE node,SYMTAB stab,BOOLEAN * eflg)1076 llrpt_d (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1077 {
1078 static char scratch[20] = "";
1079 PNODE argvar = builtin_args(node);
1080 PVALUE val=0;
1081 INT i=0;
1082 val = eval_and_coerce(PINT, argvar, stab, eflg);
1083 if (*eflg) {
1084 prog_var_error(node, stab, argvar, val, nonint1, "d", "1");
1085 return NULL;
1086 }
1087 i = pvalue_to_int(val);
1088 sprintf(scratch, "%ld", i);
1089 set_pvalue_string(val, scratch);
1090 return val;
1091 }
1092 /*=============================================+
1093 * llrpt_f -- Return floating point number as string
1094 * usage: f(FLOAT[,INT]) -> STRING
1095 *============================================*/
1096 PVALUE
llrpt_f(PNODE node,SYMTAB stab,BOOLEAN * eflg)1097 llrpt_f (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1098 {
1099 char scratch[20]="";
1100 char format[10]="";
1101 INT prec = 2;
1102 PNODE argvar = builtin_args(node);
1103 PVALUE val = eval_and_coerce(PFLOAT, argvar, stab, eflg);
1104 float fval;
1105 if (*eflg) {
1106 prog_var_error(node, stab, argvar, val, nonflox, "f", "1");
1107 return NULL;
1108 }
1109 fval = pvalue_to_float(val);
1110 argvar = inext(argvar);
1111 if (argvar) {
1112 val = eval_and_coerce(PINT, argvar, stab, eflg);
1113 if (*eflg) {
1114 prog_var_error(node, stab, argvar, val, nonintx, "f", "2");
1115 return NULL;
1116 }
1117 prec = pvalue_to_int(val);
1118 if (prec < 0) prec = 0;
1119 if (prec > 10) prec = 10;
1120 }
1121 sprintf(format, "%%.%ldf", prec);
1122
1123 sprintf(scratch, format, fval);
1124 set_pvalue_string(val, scratch);
1125 return val;
1126 }
1127 /*==========================================+
1128 * llrpt_alpha -- Convert small integer to letter
1129 * usage: alpha(INT) -> STRING
1130 *=========================================*/
1131 PVALUE
llrpt_alpha(PNODE node,SYMTAB stab,BOOLEAN * eflg)1132 llrpt_alpha (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1133 {
1134 static char scratch[2];
1135 INT i;
1136 PNODE argvar = builtin_args(node);
1137 PVALUE val = eval_and_coerce(PINT, argvar, stab, eflg);
1138 if (*eflg) {
1139 prog_var_error(node, stab, argvar, val, nonint1, "alpha");
1140 return NULL;
1141 }
1142 i = pvalue_to_int(val);
1143 delete_pvalue_ptr(&val);
1144 if (i < 1 || i > 26)
1145 sprintf(scratch, "XX");
1146 else
1147 sprintf(scratch, "%c", 'a' + i - 1);
1148 return create_pvalue_from_string(scratch);
1149 }
1150 /*================================================+
1151 * llrpt_ord -- Convert small integer to ordinal string
1152 * usage: ord(INT) -> STRING
1153 *===============================================*/
1154 static char *ordinals[] = {
1155 N_("first"), N_("second"), N_("third"), N_("fourth"), N_("fifth"),
1156 N_("sixth"), N_("seventh"), N_("eighth"), N_("ninth"), N_("tenth"),
1157 N_("eleventh"), N_("twelfth")
1158 };
1159 PVALUE
llrpt_ord(PNODE node,SYMTAB stab,BOOLEAN * eflg)1160 llrpt_ord (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1161 {
1162 static char scratch[12];
1163 INT i;
1164 PNODE argvar = builtin_args(node);
1165 PVALUE val = eval_and_coerce(PINT, argvar, stab, eflg);
1166 if (*eflg) {
1167 prog_var_error(node, stab, argvar, val, nonint1, "ord");
1168 return NULL;
1169 }
1170 i = pvalue_to_int(val);
1171 delete_pvalue_ptr(&val);
1172 if (*eflg || i < 1) return NULL;
1173 if (i > 12)
1174 sprintf(scratch, _("%ldth"), i);
1175 else
1176 sprintf(scratch, _(ordinals[i - 1]));
1177 return create_pvalue_from_string(scratch);
1178 }
1179 /*==================================================+
1180 * llrpt_card -- Convert small integer to cardinal string
1181 * usage: card(INT) -> STRING
1182 *=================================================*/
1183 static char *cardinals[] = {
1184 N_("zero"), N_("one"), N_("two"), N_("three"), N_("four"), N_("five"),
1185 N_("six"), N_("seven"), N_("eight"), N_("nine"), N_("ten"),
1186 N_("eleven"), N_("twelve")
1187 };
1188 PVALUE
llrpt_card(PNODE node,SYMTAB stab,BOOLEAN * eflg)1189 llrpt_card (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1190 {
1191 static char scratch[8];
1192 INT i;
1193 PNODE argvar = builtin_args(node);
1194 PVALUE val = eval_and_coerce(PINT, argvar, stab, eflg);
1195 if (*eflg) {
1196 prog_var_error(node, stab, argvar, val, nonint1, "card");
1197 return NULL;
1198 }
1199 i = pvalue_to_int(val);
1200 delete_pvalue_ptr(&val);
1201 if (i < 0 || i > 12)
1202 sprintf(scratch, "%ld", i);
1203 else
1204 sprintf(scratch, _(cardinals[i]));
1205 return create_pvalue_from_string(scratch);
1206 }
1207 /*==========================================+
1208 * llrpt_roman -- Convert integer to Roman numeral
1209 * usage: roman(INT) -> STRING
1210 * The roman system only expressed positive numbers (>0).
1211 * Numbers larger than 3000 were expressed by adding a bar
1212 * above a symbol to indicate multiply by 1000. This usage
1213 * no longer current, as the largest numbers usually expressed
1214 * are dates. So this code handles 1 thru 3999.
1215 *=========================================*/
1216 static char *rodigits[] = {
1217 "", "i", "ii", "iii", "iv", "v", "vi", "vii", "viii", "ix"
1218 };
1219 static char *rotens[] = {
1220 "", "x", "xx", "xxx", "xl", "l", "lx", "lxx", "lxxx", "xc"
1221 };
1222 static char *rohuns[] = {
1223 "", "c", "cc", "ccc", "cd", "d", "dc", "dcc", "dccc", "cm"
1224 };
1225 static char *rothou[] = {
1226 "", "m", "mm", "mmm"
1227 };
1228 PVALUE
llrpt_roman(PNODE node,SYMTAB stab,BOOLEAN * eflg)1229 llrpt_roman (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1230 {
1231 static char scratch[20];
1232 INT i;
1233 PNODE argvar = builtin_args(node);
1234 PVALUE val = eval_and_coerce(PINT, argvar, stab, eflg);
1235 if (*eflg) {
1236 prog_var_error(node, stab, argvar, val, nonint1, "roman");
1237 return NULL;
1238 }
1239 i = pvalue_to_int(val);
1240 delete_pvalue_ptr(&val);
1241 if (i < 1 || i > 3999)
1242 sprintf(scratch, "%ld", i);
1243 else {
1244 int t;
1245 int m = i/1000;
1246 i = i%1000;
1247 t = i/100;
1248 i = i%100;
1249
1250 sprintf(scratch, "%s%s%s%s", rothou[m], rohuns[t],
1251 rotens[i/10], rodigits[i%10]);
1252 }
1253 return create_pvalue_from_string(scratch);
1254 }
1255 /*================================================+
1256 * llrpt_nchildren -- Find number of children in family
1257 * usage: nchildren(FAM) -> INT
1258 *===============================================*/
1259 PVALUE
llrpt_nchildren(PNODE node,SYMTAB stab,BOOLEAN * eflg)1260 llrpt_nchildren (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1261 {
1262 PNODE argvar = builtin_args(node);
1263 NODE fam = eval_fam(argvar, stab, eflg, NULL);
1264 if (*eflg) {
1265 prog_var_error(node, stab, argvar, NULL, nonfam1, "nchildren");
1266 return NULL;
1267 }
1268 if (!fam) return create_pvalue_from_int(0);
1269 return create_pvalue_from_int(length_nodes(CHIL(fam)));
1270 }
1271 /*===================================================+
1272 * llrpt_nfamilies -- Find number of families person is in
1273 * usage: nfamilies(INDI) -> INT
1274 *==================================================*/
1275 PVALUE
llrpt_nfamilies(PNODE node,SYMTAB stab,BOOLEAN * eflg)1276 llrpt_nfamilies (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1277 {
1278 PNODE argvar = builtin_args(node);
1279 NODE indi = eval_indi(argvar, stab, eflg, NULL);
1280 if (*eflg) {
1281 prog_var_error(node, stab, argvar, NULL, nonind1, "nfamilies");
1282 return NULL;
1283 }
1284 if (!indi) return create_pvalue_from_int(0);
1285 return create_pvalue_from_int(length_nodes(FAMS(indi)));
1286 }
1287 /*===============================================+
1288 * llrpt_nspouses -- Find number of spouses person has
1289 * usage: nspouses(INDI) -> INT
1290 *==============================================*/
1291 PVALUE
llrpt_nspouses(PNODE node,SYMTAB stab,BOOLEAN * eflg)1292 llrpt_nspouses (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1293 {
1294 INT nspouses=0, nactual=0;
1295 PNODE argvar = builtin_args(node);
1296 NODE indi = eval_indi(argvar, stab, eflg, NULL);
1297 if (*eflg) {
1298 prog_var_error(node, stab, argvar, NULL, nonind1, "nspouses");
1299 return NULL;
1300 }
1301 if (!indi) return create_pvalue_from_int(0);
1302 FORSPOUSES(indi,spouse,fam,nspouses)
1303 ++nactual;
1304 ENDSPOUSES
1305 /* nspouses is number of pointers, nactual is number of valid pointers */
1306 return create_pvalue_from_int(nactual);
1307 }
1308 /*=============================+
1309 * llrpt_eq -- Equal operation
1310 * usage: eq(ANY, ANY) -> BOOL
1311 *============================*/
1312 PVALUE
llrpt_eq(PNODE node,SYMTAB stab,BOOLEAN * eflg)1313 llrpt_eq (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1314 {
1315 PNODE argvar = builtin_args(node);
1316 PVALUE val2=0, val1 = evaluate(argvar, stab, eflg);
1317 ZSTR zerr=0;
1318 if (*eflg) {
1319 prog_var_error(node, stab, argvar, val1, badargx, "eq", "1");
1320 return NULL;
1321 }
1322 val2 = evaluate(argvar=inext(argvar), stab, eflg);
1323 if (*eflg) {
1324 prog_var_error(node, stab, argvar, val2, badargx, "eq", "2");
1325 return NULL;
1326 }
1327 eq_pvalues(val1, val2, eflg, &zerr); /* result in val1, val2 deleted */
1328 if (*eflg) {
1329 prog_error(node, zs_str(zerr));
1330 zs_free(&zerr);
1331 return NULL;
1332 }
1333 return val1;
1334 }
1335 /*=============================+
1336 * llrpt_ne -- Not equal operation
1337 * usage: ne(ANY, ANY) -> BOOL
1338 *============================*/
1339 PVALUE
llrpt_ne(PNODE node,SYMTAB stab,BOOLEAN * eflg)1340 llrpt_ne (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1341 {
1342 PNODE argvar = builtin_args(node);
1343 PVALUE val2, val1 = evaluate(argvar, stab, eflg);
1344 ZSTR zerr=0;
1345 if (*eflg) {
1346 prog_var_error(node, stab, argvar, val1, badargx, "ne", "1");
1347 return NULL;
1348 }
1349 val2 = evaluate(argvar=inext(argvar), stab, eflg);
1350 if (*eflg) {
1351 prog_var_error(node, stab, argvar, val2, badargx, "ne", "2");
1352 return NULL;
1353 }
1354 ne_pvalues(val1, val2, eflg, &zerr); /* result in val1, val2 deleted */
1355 if (*eflg) {
1356 prog_error(node, zs_str(zerr));
1357 zs_free(&zerr);
1358 return NULL;
1359 }
1360 return val1;
1361 }
1362 /*===============================+
1363 * llrpt_le -- Less or equal operation
1364 * usage: le(ANY, ANY) -> BOOL
1365 *==============================*/
1366 PVALUE
llrpt_le(PNODE node,SYMTAB stab,BOOLEAN * eflg)1367 llrpt_le (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1368 {
1369 PNODE argvar = builtin_args(node);
1370 PVALUE val2, val1 = evaluate(argvar, stab, eflg);
1371 ZSTR zerr=0;
1372 if (*eflg) {
1373 prog_var_error(node, stab, argvar, val1, badargx, "le", "1");
1374 return NULL;
1375 }
1376 val2 = evaluate(argvar=inext(argvar), stab, eflg);
1377 if (*eflg) {
1378 prog_var_error(node, stab, argvar, val2, badargx, "le", "2");
1379 return NULL;
1380 }
1381 le_pvalues(val1, val2, eflg, &zerr); /* result in val1, val2 deleted */
1382 if (*eflg) {
1383 prog_error(node, zs_str(zerr));
1384 zs_free(&zerr);
1385 return NULL;
1386 }
1387 return val1;
1388 }
1389 /*==================================+
1390 * llrpt_ge -- Greater or equal operation
1391 * usage: ge(ANY, ANY) -> BOOL
1392 *=================================*/
1393 PVALUE
llrpt_ge(PNODE node,SYMTAB stab,BOOLEAN * eflg)1394 llrpt_ge (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1395 {
1396 PNODE argvar = builtin_args(node);
1397 PVALUE val2, val1 = evaluate(argvar, stab, eflg);
1398 ZSTR zerr=0;
1399 if (*eflg) {
1400 prog_var_error(node, stab, argvar, val1, badargx, "ge", "1");
1401 return NULL;
1402 }
1403 val2 = evaluate(argvar=inext(argvar), stab, eflg);
1404 if (*eflg) {
1405 prog_var_error(node, stab, argvar, val2, badargx, "le", "2");
1406 return NULL;
1407 }
1408 ge_pvalues(val1, val2, eflg, &zerr); /* result in val1, val2 deleted */
1409 if (*eflg) {
1410 prog_error(node, zs_str(zerr));
1411 zs_free(&zerr);
1412 return NULL;
1413 }
1414 return val1;
1415 }
1416 /*============================+
1417 * llrpt_lt -- Less than operation
1418 * usage: lt(ANY,ANY) -> BOOL
1419 *===========================*/
1420 PVALUE
llrpt_lt(PNODE node,SYMTAB stab,BOOLEAN * eflg)1421 llrpt_lt (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1422 {
1423 PNODE argvar = builtin_args(node);
1424 PVALUE val2, val1 = evaluate(argvar, stab, eflg);
1425 ZSTR zerr=0;
1426 if (*eflg) {
1427 prog_var_error(node, stab, argvar, val1, badargx, "lt", "1");
1428 return NULL;
1429 }
1430 val2 = evaluate(argvar=inext(argvar), stab, eflg);
1431 if (*eflg) {
1432 prog_var_error(node, stab, argvar, val2, badargx, "lt", "2");
1433 return NULL;
1434 }
1435 lt_pvalues(val1, val2, eflg, &zerr); /* result in val1, val2 deleted */
1436 if (*eflg) {
1437 prog_error(node, zs_str(zerr));
1438 zs_free(&zerr);
1439 return NULL;
1440 }
1441 return val1;
1442 }
1443 /*==============================+
1444 * llrpt_gt -- Greater than operation
1445 * usage: gt(ANY, ANY) -> BOOL
1446 *=============================*/
1447 PVALUE
llrpt_gt(PNODE node,SYMTAB stab,BOOLEAN * eflg)1448 llrpt_gt (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1449 {
1450 PNODE argvar = builtin_args(node);
1451 PVALUE val2, val1 = evaluate(argvar, stab, eflg);
1452 ZSTR zerr=0;
1453 if (*eflg) {
1454 prog_var_error(node, stab, argvar, val1, badargx, "gt", "1");
1455 return NULL;
1456 }
1457 val2 = evaluate(argvar=inext(argvar), stab, eflg);
1458 if (*eflg) {
1459 prog_var_error(node, stab, argvar, val2, badargx, "gt", "2");
1460 return NULL;
1461 }
1462 gt_pvalues(val1, val2, eflg, &zerr); /* result in val1, val2 deleted */
1463 if (*eflg) {
1464 prog_error(node, zs_str(zerr));
1465 zs_free(&zerr);
1466 return NULL;
1467 }
1468 return val1;
1469 }
1470 /*=================================+
1471 * llrpt_and -- And operation
1472 * usage: and(ANY [,ANY]+) -> BOOL
1473 *================================*/
1474 PVALUE
llrpt_and(PNODE node,SYMTAB stab,BOOLEAN * eflg)1475 llrpt_and (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1476 {
1477 PNODE argvar = builtin_args(node);
1478 BOOLEAN rc = TRUE; /* result of function */
1479 PVALUE val2, val1 = eval_and_coerce(PBOOL, argvar, stab, eflg);
1480 INT argix=1; /* count arguments for error message */
1481 if (*eflg) {
1482 prog_var_error(node, stab, argvar, val1, nonboox, "and", "1");
1483 return NULL;
1484 }
1485 rc = rc && pvalue_to_bool(val1);
1486 delete_pvalue_ptr(&val1);
1487 while ((argvar = inext(argvar))) {
1488 ++argix;
1489 if (rc) {
1490 val2 = eval_and_coerce(PBOOL, argvar, stab, eflg);
1491 if (*eflg) {
1492 char numstr[33];
1493 snprintf(numstr, sizeof(numstr), "%ld", argix);
1494 prog_var_error(node, stab, argvar, val2, nonboox, "and", numstr);
1495 return NULL;
1496 }
1497 rc = rc && pvalue_to_bool(val2);
1498 delete_pvalue_ptr(&val2);
1499 }
1500 }
1501 return create_pvalue_from_bool(rc);
1502 }
1503 /*================================+
1504 * llrpt_or -- Or operation
1505 * usage: or(ANY [,ANY]+) -> BOOL
1506 *===============================*/
1507 PVALUE
llrpt_or(PNODE node,SYMTAB stab,BOOLEAN * eflg)1508 llrpt_or (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1509 {
1510 PNODE argvar = builtin_args(node);
1511 BOOLEAN rc = FALSE; /* result of function */
1512 PVALUE val2, val1 = eval_and_coerce(PBOOL, argvar, stab, eflg);
1513 INT argix=1; /* count arguments for error message */
1514 if (*eflg) {
1515 prog_var_error(node, stab, argvar, val1, nonboox, "or", "1");
1516 return NULL;
1517 }
1518 rc = rc || pvalue_to_bool(val1);
1519 delete_pvalue_ptr(&val1);
1520 while ((argvar = inext(argvar))) {
1521 ++argix;
1522 if (!rc) {
1523 val2 = eval_and_coerce(PBOOL, argvar, stab, eflg);
1524 if (*eflg) {
1525 char numstr[33];
1526 snprintf(numstr, sizeof(numstr), "%ld", argix);
1527 prog_var_error(node, stab, argvar, val2, nonboox, "or", numstr);
1528 return NULL;
1529 }
1530 rc = rc || pvalue_to_bool(val2);
1531 delete_pvalue_ptr(&val2);
1532 }
1533 }
1534 return create_pvalue_from_bool(rc);
1535 }
1536 /*================================+
1537 * llrpt_add -- Add operation
1538 * usage: add(INT [,INT]+) -> INT
1539 *===============================*/
1540 PVALUE
llrpt_add(PNODE node,SYMTAB stab,BOOLEAN * eflg)1541 llrpt_add (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1542 {
1543 PNODE argvar = builtin_args(node);
1544 PVALUE val2, val1 = evaluate(argvar, stab, eflg);
1545 ZSTR zerr=0;
1546 INT argix=1; /* count arguments for error message */
1547 if (*eflg) {
1548 prog_var_error(node, stab, argvar, val1, badargx, "add", "1");
1549 return NULL;
1550 }
1551 while ((argvar = inext(argvar))) {
1552 ++argix;
1553 val2 = evaluate(argvar, stab, eflg);
1554 if (*eflg) {
1555 char numstr[33];
1556 snprintf(numstr, sizeof(numstr), "%ld", argix);
1557 prog_var_error(node, stab, argvar, val2, badargx, "add", numstr);
1558 return NULL;
1559 }
1560 add_pvalues(val1, val2, eflg, &zerr); /* result in val1, val2 deleted */
1561 if (*eflg) {
1562 prog_error(node, zs_str(zerr));
1563 zs_free(&zerr);
1564 return NULL;
1565 }
1566 }
1567 return val1;
1568 }
1569 /*=============================+
1570 * llrpt_sub -- Subtract operation
1571 * usage: sub(INT, INT) -> INT
1572 *============================*/
1573 PVALUE
llrpt_sub(PNODE node,SYMTAB stab,BOOLEAN * eflg)1574 llrpt_sub (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1575 {
1576 PNODE argvar = builtin_args(node);
1577 PVALUE val2, val1 = evaluate(argvar, stab, eflg);
1578 ZSTR zerr=0;
1579 if (*eflg) {
1580 prog_var_error(node, stab, argvar, val1, badargx, "sub", "1");
1581 return NULL;
1582 }
1583 val2 = evaluate(argvar=inext(argvar), stab, eflg);
1584 if (*eflg) {
1585 prog_var_error(node, stab, argvar, val2, badargx, "sub", 2);
1586 return NULL;
1587 }
1588 sub_pvalues(val1, val2, eflg, &zerr); /* result in val1, val2 deleted */
1589 if (*eflg) {
1590 prog_error(node, zs_str(zerr));
1591 zs_free(&zerr);
1592 return NULL;
1593 }
1594 return val1;
1595 }
1596 /*================================+
1597 * llrpt_mul -- Multiply operation
1598 * usage: mul(INT [,INT]+) -> INT
1599 *===============================*/
1600 PVALUE
llrpt_mul(PNODE node,SYMTAB stab,BOOLEAN * eflg)1601 llrpt_mul (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1602 {
1603 PNODE argvar = builtin_args(node);
1604 PVALUE val2, val1 = evaluate(argvar, stab, eflg);
1605 ZSTR zerr=0;
1606 INT iarg=1;
1607 if (*eflg) {
1608 prog_var_error(node, stab, argvar, val1, badargx, "mul", "1");
1609 return NULL;
1610 }
1611 while ((argvar = inext(argvar))) {
1612 ++iarg;
1613 val2 = evaluate(argvar, stab, eflg);
1614 if (*eflg) {
1615 char numstr[33];
1616 snprintf(numstr, sizeof(numstr), "%ld", iarg);
1617 prog_var_error(node, stab, argvar, val2, badargx, "mul", numstr);
1618 return NULL;
1619 }
1620 mul_pvalues(val1, val2, eflg, &zerr); /* result in val1, val2 deleted */
1621 if (*eflg) {
1622 prog_error(node, zs_str(zerr));
1623 zs_free(&zerr);
1624 return NULL;
1625 }
1626 }
1627 return val1;
1628 }
1629 /*=============================+
1630 * llrpt_div -- Divide operation
1631 * usage: div(INT, INT) -> INT
1632 *============================*/
1633 PVALUE
llrpt_div(PNODE node,SYMTAB stab,BOOLEAN * eflg)1634 llrpt_div (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1635 {
1636 PNODE argvar = builtin_args(node);
1637 PVALUE val2, val1 = evaluate(argvar, stab, eflg);
1638 ZSTR zerr=0;
1639 if (*eflg) {
1640 prog_var_error(node, stab, argvar, val1, badargx, "div", "1");
1641 return NULL;
1642 }
1643 val2 = evaluate(argvar=inext(argvar), stab, eflg);
1644 if (*eflg) {
1645 prog_var_error(node, stab, argvar, val2, badargx, "div", 2);
1646 return NULL;
1647 }
1648 div_pvalues(val1, val2, eflg, &zerr); /* result in val1, val2 deleted */
1649 if (*eflg) {
1650 prog_error(node, zs_str(zerr));
1651 zs_free(&zerr);
1652 return NULL;
1653 }
1654 return val1;
1655 }
1656 /*=============================+
1657 * llrpt_mod -- Modulus operation
1658 * usage: mod(INT, INT) -> INT
1659 *============================*/
1660 PVALUE
llrpt_mod(PNODE node,SYMTAB stab,BOOLEAN * eflg)1661 llrpt_mod (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1662 {
1663 PNODE argvar = builtin_args(node);
1664 PVALUE val2, val1 = evaluate(argvar, stab, eflg);
1665 ZSTR zerr=0;
1666 if (*eflg) {
1667 prog_var_error(node, stab, argvar, val1, badargx, "mod", "1");
1668 return NULL;
1669 }
1670 val2 = evaluate(argvar=inext(argvar), stab, eflg);
1671 if (*eflg) {
1672 prog_var_error(node, stab, argvar, val2, badargx, "mod", 2);
1673 return NULL;
1674 }
1675 mod_pvalues(val1, val2, eflg, &zerr); /* result in val1, val2 deleted */
1676 if (*eflg) {
1677 prog_error(node, zs_str(zerr));
1678 zs_free(&zerr);
1679 return NULL;
1680 }
1681 return val1;
1682 }
1683 /*=================================+
1684 * llrpt_exp -- Exponentiation operation
1685 * usage: exp(INT, INT) -> INT
1686 *================================*/
1687 PVALUE
llrpt_exp(PNODE node,SYMTAB stab,BOOLEAN * eflg)1688 llrpt_exp (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1689 {
1690 PNODE argvar = builtin_args(node);
1691 PVALUE val2, val1 = evaluate(argvar, stab, eflg);
1692 ZSTR zerr=0;
1693 if (*eflg) {
1694 prog_var_error(node, stab, argvar, val1, badargx, "sub", "1");
1695 return NULL;
1696 }
1697 val2 = evaluate(argvar=inext(argvar), stab, eflg);
1698 if (*eflg) {
1699 prog_var_error(node, stab, argvar, val2, badargx, "sub", 2);
1700 return NULL;
1701 }
1702 exp_pvalues(val1, val2, eflg, &zerr); /* result in val1, val2 deleted */
1703 if (*eflg) {
1704 prog_error(node, zs_str(zerr));
1705 zs_free(&zerr);
1706 return NULL;
1707 }
1708 return val1;
1709 }
1710 /*===========================+
1711 * llrpt_neg -- Negation operation
1712 * usage: neg(INT) -> INT
1713 *==========================*/
1714 PVALUE
llrpt_neg(PNODE node,SYMTAB stab,BOOLEAN * eflg)1715 llrpt_neg (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1716 {
1717 PNODE argvar = builtin_args(node);
1718 PVALUE val = evaluate(argvar, stab, eflg);
1719 ZSTR zerr=0;
1720 if (*eflg) {
1721 prog_var_error(node, stab, argvar, val, badarg1, "neg");
1722 return NULL;
1723 }
1724 if (*eflg) return NULL;
1725 neg_pvalue(val, eflg, &zerr); /* result in val */
1726 if (*eflg) {
1727 prog_error(node, zs_str(zerr));
1728 zs_free(&zerr);
1729 return NULL;
1730 }
1731 return val;
1732 }
1733 /*===========================+
1734 * llrpt_incr -- Increment variable
1735 * usage: incr(VARB [, number]) -> VOID
1736 *==========================*/
1737 PVALUE
llrpt_incr(PNODE node,SYMTAB stab,BOOLEAN * eflg)1738 llrpt_incr (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1739 {
1740 PNODE argvar = builtin_args(node);
1741 PNODE argvar2=0;
1742 PVALUE val=0;
1743 ZSTR zerr=0;
1744 if (!iistype(argvar, IIDENT)) {
1745 *eflg = TRUE;
1746 prog_error(node, "arg to incr must be a variable");
1747 return NULL;
1748 }
1749 val = evaluate(argvar, stab, eflg);
1750 if (*eflg || !val) {
1751 *eflg = TRUE;
1752 prog_var_error(node, stab, argvar, val, badarg1, "incr");
1753 return NULL;
1754 }
1755
1756 if ((argvar2 = inext(argvar))) {
1757 PVALUE val2 = evaluate(argvar2, stab, eflg);
1758 if (*eflg) {
1759 prog_var_error(node, stab, argvar2, val2, badargx, "incr", "2");
1760 return NULL;
1761 }
1762 add_pvalues(val, val2, eflg, &zerr); /* adds into val */
1763 } else {
1764 incr_pvalue(val, eflg, &zerr);
1765 }
1766 if (*eflg) {
1767 prog_error(node, zs_str(zerr));
1768 zs_free(&zerr);
1769 return NULL;
1770 }
1771 assign_iden(stab, iident_name(argvar), val);
1772 return NULL;
1773 }
1774 /*============================+
1775 * llrpt_decr -- Decrement variable
1776 * usage: decr(VARB [, number]) -> VOID
1777 *===========================*/
1778 PVALUE
llrpt_decr(PNODE node,SYMTAB stab,BOOLEAN * eflg)1779 llrpt_decr (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1780 {
1781 PNODE argvar = builtin_args(node);
1782 PNODE argvar2=0;
1783 PVALUE val=0;
1784 ZSTR zerr=0;
1785 if (!iistype(argvar, IIDENT)) {
1786 *eflg = TRUE;
1787 prog_error(node, "arg to decr must be a variable");
1788 return NULL;
1789 }
1790 val = evaluate(argvar, stab, eflg);
1791 if (*eflg || !val) {
1792 *eflg = TRUE;
1793 prog_var_error(node, stab, argvar, val, badarg1, "decr");
1794 return NULL;
1795 }
1796 if ((argvar2 = inext(argvar))) {
1797 PVALUE val2 = evaluate(argvar2, stab, eflg);
1798 if (*eflg) {
1799 prog_var_error(node, stab, argvar2, val2, badargx, "decr", "2");
1800 return NULL;
1801 }
1802 sub_pvalues(val, val2, eflg, &zerr); /* subtracts into val */
1803 } else {
1804 decr_pvalue(val, eflg, &zerr);
1805 }
1806 if (*eflg) {
1807 prog_error(node, zs_str(zerr));
1808 zs_free(&zerr);
1809 return NULL;
1810 }
1811 assign_iden(stab, iident_name(argvar), val);
1812 return NULL;
1813 }
1814 /*======================================+
1815 * llrpt_strcmp -- Compare two strings
1816 * usage: strcmp(STRING, STRING) -> INT
1817 *=====================================*/
1818 PVALUE
llrpt_strcmp(PNODE node,SYMTAB stab,BOOLEAN * eflg)1819 llrpt_strcmp (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1820 {
1821 PNODE argvar = builtin_args(node);
1822 STRING str1=0, str2=0, emp = (STRING) "";
1823 PVALUE val2=0, val1 = eval_and_coerce(PSTRING, argvar, stab, eflg);
1824 if (*eflg) {
1825 /* TODO - use std errors */
1826 prog_error(node, "1st arg to strcmp is not a string");
1827 return NULL;
1828 }
1829 val2 = eval_and_coerce(PSTRING, argvar=inext(argvar), stab, eflg);
1830 if (*eflg) {
1831 prog_error(node, "2nd arg to strcmp is not a string");
1832 return NULL;
1833 }
1834 str1 = pvalue_to_string(val1);
1835 str2 = pvalue_to_string(val2);
1836 if (!str1) str1 = emp;
1837 if (!str2) str2 = emp;
1838
1839 set_pvalue_int(val1, cmpstrloc(str1, str2));
1840 delete_pvalue_ptr(&val2);
1841 return val1;
1842 }
1843 /*=========================================+
1844 * llrpt_nestr -- Compare two strings
1845 * usage: nestr(STRING, STRING) -> BOOLEAN
1846 * calls nestr function
1847 *========================================*/
1848 PVALUE
llrpt_nestr(PNODE node,SYMTAB stab,BOOLEAN * eflg)1849 llrpt_nestr (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1850 {
1851 PNODE argvar = builtin_args(node);
1852 STRING str1=0, str2=0, emp = (STRING) "";
1853 PVALUE val2=0, val1 = eval_and_coerce(PSTRING, argvar, stab, eflg);
1854 if (*eflg) {
1855 /* TODO: use std errors */
1856 prog_error(node, "1st arg to nestr is not a string");
1857 return NULL;
1858 }
1859 val2 = eval_and_coerce(PSTRING, argvar=inext(argvar), stab, eflg);
1860 if (*eflg) {
1861 prog_error(node, "2nd arg to nestr is not a string");
1862 return NULL;
1863 }
1864 str1 = pvalue_to_string(val1);
1865 str2 = pvalue_to_string(val2);
1866 if (!str1) str1 = emp;
1867 if (!str2) str2 = emp;
1868 set_pvalue_bool(val1,(nestr(str1, str2) != 0));
1869 delete_pvalue(val2);
1870 return val1;
1871 }
1872 /*=========================================+
1873 * llrpt_eqstr -- Compare two strings
1874 * usage: eqstr(STRING, STRING) -> BOOLEAN
1875 * calls eqstr function
1876 *========================================*/
1877 PVALUE
llrpt_eqstr(PNODE node,SYMTAB stab,BOOLEAN * eflg)1878 llrpt_eqstr (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1879 {
1880 PNODE argvar = builtin_args(node);
1881 STRING str1=0, str2=0, emp = (STRING) "";
1882 PVALUE val2=0, val1 = eval_and_coerce(PSTRING, argvar, stab, eflg);
1883 if (*eflg) {
1884 /* TODO: use std errors */
1885 prog_error(node, "1st arg to eqstr is not a string");
1886 return NULL;
1887 }
1888 val2 = eval_and_coerce(PSTRING, argvar=inext(argvar), stab, eflg);
1889 if (*eflg) {
1890 prog_error(node, "2nd arg to eqstr is not a string");
1891 return NULL;
1892 }
1893 str1 = pvalue_to_string(val1);
1894 str2 = pvalue_to_string(val2);
1895 if (!str1) str1 = emp;
1896 if (!str2) str2 = emp;
1897 set_pvalue_bool(val1, (eqstr(str1, str2) != 0));
1898 delete_pvalue(val2);
1899 return val1;
1900 }
1901 /*=======================================+
1902 * llrpt_strtoint -- Convert string to integer
1903 * usage: strtoint(STRING) -> INT
1904 * calls atoi function
1905 *======================================*/
1906 PVALUE
llrpt_strtoint(PNODE node,SYMTAB stab,BOOLEAN * eflg)1907 llrpt_strtoint (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1908 {
1909 PNODE argvar = builtin_args(node);
1910 PVALUE val=NULL;
1911 STRING str=0;
1912 val = eval_and_coerce(PSTRING, argvar, stab, eflg);
1913 if (*eflg) {
1914 prog_var_error(node, stab, argvar, val, nonstr1, "strtoint");
1915 delete_pvalue(val);
1916 return NULL;
1917 }
1918 str = pvalue_to_string(val);
1919 set_pvalue_int(val, str ? atoi(str): 0);
1920 return val;
1921 }
1922 /*=================================+
1923 * llrpt_empty -- Check if list is empty
1924 * usage: empty(LIST/TABLE/SET) -> BOOL
1925 *================================*/
1926 PVALUE
llrpt_empty(PNODE node,SYMTAB stab,BOOLEAN * eflg)1927 llrpt_empty (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1928 {
1929 PNODE argvar = builtin_args(node);
1930 PVALUE val = eval_without_coerce(argvar, stab, eflg);
1931 int type = which_pvalue_type(val);
1932 BOOLEAN bEmpty = TRUE;
1933
1934 if (val && (type == PLIST))
1935 {
1936 LIST list = pvalue_to_list(val);
1937 set_pvalue_int(val, length_list(list));
1938 bEmpty = !list || !length_list(list);
1939 }
1940 else if (val && (type == PTABLE))
1941 {
1942 TABLE table = pvalue_to_table(val);
1943 bEmpty = !table || !get_table_count(table);
1944 }
1945 else if (val && (type == PSET))
1946 {
1947 INDISEQ seq = pvalue_to_seq(val);
1948 bEmpty = !seq || !length_indiseq(seq);
1949 }
1950 else
1951 {
1952 prog_error(node, _("the arg to empty is not a list, table or set"));
1953 *eflg = TRUE;
1954 return NULL;
1955 }
1956
1957 set_pvalue_bool(val, bEmpty);
1958 return val;
1959 }
1960 /*==================================================+
1961 * llrpt_length -- Find length of list, indiseq or table
1962 * usage: length(LIST/TABLE/SET) -> INT
1963 *==================================================*/
1964 PVALUE
llrpt_length(PNODE node,SYMTAB stab,BOOLEAN * eflg)1965 llrpt_length (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1966 {
1967 PNODE argvar = builtin_args(node);
1968 PVALUE val = eval_without_coerce(argvar, stab, eflg);
1969 INT len=-1;
1970
1971 if (val) {
1972 INT type = which_pvalue_type(val);
1973 if (type == PLIST) {
1974 LIST list = pvalue_to_list(val);
1975 len = (list ? length_list(list) : 0);
1976 } else if (type == PTABLE) {
1977 TABLE table = pvalue_to_table(val);
1978 len = (table ? get_table_count(table) : 0);
1979 } else if (type == PSET) {
1980 INDISEQ seq = pvalue_to_seq(val);
1981 len = (seq ? length_indiseq(seq) : 0);
1982 }
1983 }
1984 if (len == -1) {
1985 prog_error(node, _("the arg to length is not a list, table or set"));
1986 *eflg = TRUE;
1987 return NULL;
1988 }
1989
1990 set_pvalue_int(val, len);
1991 return val;
1992 }
1993 /*==========================+
1994 * llrpt_not -- Not operation
1995 * usage: not(BOOL) -> BOOL
1996 *=========================*/
1997 PVALUE
llrpt_not(PNODE node,SYMTAB stab,BOOLEAN * eflg)1998 llrpt_not (PNODE node, SYMTAB stab, BOOLEAN *eflg)
1999 {
2000 PNODE argvar = builtin_args(node);
2001 PVALUE val = eval_and_coerce(PBOOL, argvar, stab, eflg);
2002 if (*eflg) {
2003 prog_error(node, "the arg to not is not boolean");
2004 return NULL;
2005 }
2006 set_pvalue_bool(val, !pvalue_to_bool(val));
2007 return val;
2008 }
2009 /*===============================+
2010 * llrpt_save -- Copy string
2011 * usage: save(STRING) -> STRING
2012 *==============================*/
2013 PVALUE
llrpt_save(PNODE node,SYMTAB stab,BOOLEAN * eflg)2014 llrpt_save (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2015 {
2016 PNODE argvar = builtin_args(node);
2017 PVALUE val = eval_and_coerce(PSTRING, argvar, stab, eflg);
2018 if (*eflg) {
2019 prog_var_error(node, stab, argvar, val, nonstr1, "save");
2020 delete_pvalue(val);
2021 return NULL;
2022 }
2023 return val;
2024 }
2025 /*=================================+
2026 * llrpt_strlen -- Find length of string
2027 * usage: strlen(STRING) -> INT
2028 *================================*/
2029 PVALUE
llrpt_strlen(PNODE node,SYMTAB stab,BOOLEAN * eflg)2030 llrpt_strlen (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2031 {
2032 PNODE argvar = builtin_args(node);
2033 PVALUE val = eval_and_coerce(PSTRING, argvar, stab, eflg);
2034 INT len=0;
2035 STRING str;
2036 if (*eflg) {
2037 prog_var_error(node, stab, argvar, val, nonstr1, "save");
2038 delete_pvalue(val);
2039 return NULL;
2040 }
2041 str = pvalue_to_string(val);
2042 len = str ? strlen(str) : 0;
2043 set_pvalue_int(val, len);
2044 return val;
2045 }
2046 /*=============================================+
2047 * llrpt_concat -- Catenate strings
2048 * usage: concat(STRING [, STRING]+) -> STRING
2049 *============================================*/
2050 PVALUE
llrpt_concat(PNODE node,SYMTAB stab,BOOLEAN * eflg)2051 llrpt_concat (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2052 {
2053 PNODE argvar = builtin_args(node);
2054 INT argcnt = 0;
2055 STRING str;
2056 PVALUE val;
2057 ZSTR zstr = zs_new();
2058
2059 while (argvar) {
2060 val = eval_and_coerce(PSTRING, argvar, stab, eflg);
2061 if (*eflg) {
2062 char argnum[8];
2063 sprintf(argnum, "%ld", argcnt+1);
2064 prog_var_error(node, stab, argvar, val, nonstrx, "concat", argnum);
2065 return NULL;
2066 }
2067 str = pvalue_to_string(val);
2068 zs_apps(zstr, str);
2069 argvar = inext(argvar);
2070 ++argcnt;
2071 delete_pvalue(val);
2072 }
2073 val = create_pvalue_from_zstr(&zstr);
2074 return val;
2075 }
2076 /*=======================================+
2077 * llrpt_lower -- Convert string to lower case
2078 * usage: lower(STRING) -> STRING
2079 *======================================*/
2080 PVALUE
llrpt_lower(PNODE node,SYMTAB stab,BOOLEAN * eflg)2081 llrpt_lower (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2082 {
2083 PNODE argvar = builtin_args(node);
2084 PVALUE val = eval_and_coerce(PSTRING, argvar, stab, eflg);
2085 STRING str;
2086 if (*eflg) {
2087 prog_var_error(node, stab, argvar, val, nonstr1, "lower");
2088 delete_pvalue(val);
2089 return NULL;
2090 }
2091 str = pvalue_to_string(val);
2092 if (str) {
2093 ZSTR zstr = ll_tolowerz(str, uu8);
2094 set_pvalue_string(val, zs_str(zstr));
2095 zs_free(&zstr);
2096 }
2097 return val;
2098 }
2099 /*=======================================+
2100 * llrpt_upper -- Convert string to upper case
2101 * usage: upper(STRING) -> STRING
2102 *======================================*/
2103 PVALUE
llrpt_upper(PNODE node,SYMTAB stab,BOOLEAN * eflg)2104 llrpt_upper (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2105 {
2106 PNODE argvar = builtin_args(node);
2107 PVALUE val = eval_and_coerce(PSTRING, argvar, stab, eflg);
2108 STRING str;
2109 if (*eflg) {
2110 prog_var_error(node, stab, argvar, val, nonstr1, "upper");
2111 delete_pvalue(val);
2112 return NULL;
2113 }
2114 str = pvalue_to_string(val);
2115 if (str) {
2116 ZSTR zstr = ll_toupperz(str, uu8);
2117 set_pvalue_string(val, zs_str(zstr));
2118 zs_free(&zstr);
2119 }
2120 return val;
2121 }
2122 /*=====================================+
2123 * llrpt_capitalize -- Capitalize string
2124 * usage: capitalize(STRING) -> STRING
2125 *====================================*/
2126 PVALUE
llrpt_capitalize(PNODE node,SYMTAB stab,BOOLEAN * eflg)2127 llrpt_capitalize (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2128 {
2129 PNODE argvar = builtin_args(node);
2130 PVALUE val = eval_and_coerce(PSTRING, argvar, stab, eflg);
2131 STRING str;
2132 if (*eflg) {
2133 prog_var_error(node, stab, argvar, val, nonstr1, "capitalize");
2134 delete_pvalue(val);
2135 return NULL;
2136 }
2137 str = pvalue_to_string(val);
2138 if (str) {
2139 ZSTR zstr = ll_tocapitalizedz(str, uu8);
2140 set_pvalue_string(val, zs_str(zstr));
2141 zs_free(&zstr);
2142 }
2143 return val;
2144 }
2145 /*=====================================+
2146 * llrpt_titlcase -- Titlecase string
2147 * usage: capitalize(STRING) -> STRING
2148 * Created: 2001/12/30 (Perry Rapp)
2149 *====================================*/
2150 PVALUE
llrpt_titlcase(PNODE node,SYMTAB stab,BOOLEAN * eflg)2151 llrpt_titlcase (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2152 {
2153 PNODE argvar = builtin_args(node);
2154 PVALUE val = eval_and_coerce(PSTRING, argvar, stab, eflg);
2155 STRING str;
2156 if (*eflg) {
2157 prog_var_error(node, stab, argvar, val, nonstr1, "titlecase");
2158 delete_pvalue(val);
2159 return NULL;
2160 }
2161 str = pvalue_to_string(val);
2162 if (str) {
2163 ZSTR zstr = ll_totitlecasez(str, uu8);
2164 set_pvalue_string(val, zs_str(zstr));
2165 zs_free(&zstr);
2166 }
2167 return val;
2168 }
2169 /*================================+
2170 * llrpt_pn -- Generate pronoun
2171 * usage: pn(INDI, INT) -> STRING
2172 *===============================*/
2173 static char *mpns[] = { N_("He"), N_("he"), N_("His"), N_("his"), N_("him") };
2174 /* "her_" = object form (Doug hit her) (do not include underscore in translation) */
2175 static char *fpns[] = { N_("She"), N_("she"), N_("Her"), N_("her"), N_("her_") };
2176 PVALUE
llrpt_pn(PNODE node,SYMTAB stab,BOOLEAN * eflg)2177 llrpt_pn (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2178 {
2179 INT typ;
2180 PVALUE val;
2181 PNODE argvar = builtin_args(node);
2182 NODE indi = eval_indi(argvar, stab, eflg, NULL);
2183 STRING str="";
2184 if (*eflg || !indi) {
2185 *eflg = TRUE;
2186 prog_error(node, "1st arg to pn must be a person");
2187 return NULL;
2188 }
2189 val = eval_and_coerce(PINT, argvar=inext(argvar), stab, eflg);
2190 typ = pvalue_to_int(val);
2191 if (*eflg || typ < 0 || typ > 4) {
2192 *eflg = TRUE;
2193 prog_error(node, "2nd arg to pn must be between 0 and 4");
2194 return NULL;
2195 }
2196 if (SEX(indi) == SEX_FEMALE) {
2197 str = _(fpns[typ]);
2198 /* disambiguation of object & possessive for l10n */
2199 if (eqstr(str, "her_"))
2200 str = "her";
2201 } else {
2202 str = _(mpns[typ]);
2203 }
2204 set_pvalue_string(val, str);
2205 return val;
2206 }
2207 /*==================================+
2208 * llrpt_print -- Print to stdout window
2209 * usage: print([STRING]+,) -> VOID
2210 *=================================*/
2211 PVALUE
llrpt_print(PNODE node,SYMTAB stab,BOOLEAN * eflg)2212 llrpt_print (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2213 {
2214 PNODE argvar = builtin_args(node);
2215 PVALUE val=0;
2216 INT narg=1;
2217 while (argvar) {
2218 STRING str;
2219 val = eval_and_coerce(PSTRING, argvar, stab, eflg);
2220 if (*eflg || !val) {
2221 char nargstr[33];
2222 sprintf(nargstr, "%d", narg);
2223 prog_var_error(node, stab, argvar, val, nonstrx, "print", nargstr);
2224 delete_pvalue(val);
2225 return NULL;
2226 }
2227 str = pvalue_to_string(val);
2228 if (str) {
2229 uilocale();
2230 rpt_print(str);
2231 rptlocale();
2232 }
2233 delete_pvalue(val);
2234 argvar = inext(argvar);
2235 ++narg;
2236 }
2237 return NULL;
2238 }
2239 /*=================================================+
2240 * llrpt_sex -- Find sex, as string M, F or U, of person
2241 * usage: sex(INDI) -> STRING
2242 *================================================*/
2243 PVALUE
llrpt_sex(PNODE node,SYMTAB stab,BOOLEAN * eflg)2244 llrpt_sex (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2245 {
2246 PNODE argvar = builtin_args(node);
2247 STRING str = (STRING) "U";
2248 INT sex;
2249 NODE indi = eval_indi(argvar, stab, eflg, NULL);
2250 if (*eflg) {
2251 prog_error(node, "the arg to sex is not a person");
2252 return NULL;
2253 }
2254 if (!indi) return create_pvalue_from_string(str);
2255 if ((sex = SEX(indi)) == SEX_MALE) str = (STRING) "M";
2256 else if (sex == SEX_FEMALE) str = (STRING) "F";
2257 return create_pvalue_from_string(str);
2258 }
2259 /*=================================+
2260 * llrpt_male -- Check if person is male
2261 * usage: male(INDI) -> BOOL
2262 *================================*/
2263 PVALUE
llrpt_male(PNODE node,SYMTAB stab,BOOLEAN * eflg)2264 llrpt_male (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2265 {
2266 PNODE argvar = builtin_args(node);
2267 NODE indi = eval_indi(argvar, stab, eflg, NULL);
2268 if (*eflg) {
2269 prog_error(node, "the arg to male is not a person");
2270 return NULL;
2271 }
2272 if (!indi) return create_pvalue_from_bool(FALSE);
2273 return create_pvalue_from_bool((SEX(indi) == SEX_MALE));
2274 }
2275 /*=====================================+
2276 * llrpt_female -- Check if person is female
2277 * usage: female(INDI) -> BOOL
2278 *====================================*/
2279 PVALUE
llrpt_female(PNODE node,SYMTAB stab,BOOLEAN * eflg)2280 llrpt_female (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2281 {
2282 PNODE argvar = builtin_args(node);
2283 NODE indi = eval_indi(argvar, stab, eflg, NULL);
2284 if (*eflg) {
2285 prog_error(node, "the arg to female is not a person");
2286 return NULL;
2287 }
2288 if (!indi) return create_pvalue_from_bool(FALSE);
2289 return create_pvalue_from_bool((SEX(indi) == SEX_FEMALE));
2290 }
2291 /*========================================+
2292 * llrpt_key -- Return person or family key
2293 * usage: key(INDI|FAM|EVEN|SOUR|OTHR [,BOOL]) -> STRING
2294 *=======================================*/
2295 PVALUE
llrpt_key(PNODE node,SYMTAB stab,BOOLEAN * eflg)2296 llrpt_key (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2297 {
2298 PNODE argvar = builtin_args(node);
2299 PVALUE val = evaluate(argvar, stab, eflg);
2300 CACHEEL cel;
2301 BOOLEAN strip = FALSE;
2302 CNSTRING key=0;
2303 if (*eflg || !val || !is_record_pvalue(val)) {
2304 *eflg = TRUE;
2305 prog_var_error(node, stab, argvar, val, nonrecx, "key", "1");
2306 return NULL;
2307 }
2308 cel = pvalue_to_cel(val); /* may return NULL */
2309 delete_pvalue(val);
2310 if (!cel) return create_pvalue_from_string("");
2311 argvar = inext(argvar);
2312 if (argvar) {
2313 val = eval_and_coerce(PBOOL, argvar, stab, eflg);
2314 if (*eflg) {
2315 prog_error(node, "2nd arg to key is not boolean");
2316 return NULL;
2317 }
2318 strip = pvalue_to_bool(val);
2319 delete_pvalue(val);
2320 }
2321 key = cacheel_to_key(cel);
2322 return create_pvalue_from_string(strip ? key + 1 : key);
2323 }
2324 /*==============================================+
2325 * llrpt_root -- Return root of cached record
2326 * usage: root(INDI|FAM|EVEN|SOUR|OTHR) -> NODE
2327 *=============================================*/
2328 PVALUE
llrpt_rot(PNODE node,SYMTAB stab,BOOLEAN * eflg)2329 llrpt_rot (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2330 {
2331 PNODE argvar = builtin_args(node);
2332 PVALUE val = evaluate(argvar, stab, eflg);
2333 if (*eflg || !val) {
2334 *eflg = TRUE;
2335 prog_error(node, "error in the arg to root");
2336 return NULL;
2337 }
2338 if (!is_record_pvalue(val)) {
2339 *eflg = TRUE;
2340 prog_error(node, "the arg to root must be a record");
2341 return NULL;
2342 }
2343 if (!record_to_node(val)) {
2344 *eflg = TRUE;
2345 prog_error(node, "record passed to root missing from database");
2346 return NULL;
2347 }
2348 return val;
2349 }
2350 /*==============================================+
2351 * record_to_node -- Extract root node from record
2352 * used by root & for implicit conversion
2353 * Created: 2002/02/16, Perry Rapp (pulled out of root)
2354 *=============================================*/
2355 BOOLEAN
record_to_node(PVALUE val)2356 record_to_node (PVALUE val)
2357 {
2358 RECORD rec = pvalue_to_record(val); /* may be NULL */
2359 NODE gnode=0;
2360
2361 if (!rec) return FALSE;
2362
2363 /* pvalue_to_record loads the record into direct cache */
2364
2365 gnode = nztop(rec);
2366 set_pvalue_node(val, gnode);
2367 ASSERT(gnode);
2368 return TRUE;
2369 }
2370 /*================================+
2371 * llrpt_inode -- Return root of person
2372 * usage: inode(INDI) -> NODE
2373 *==============================*/
2374 PVALUE
llrpt_inode(PNODE node,SYMTAB stab,BOOLEAN * eflg)2375 llrpt_inode (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2376 {
2377 PNODE argvar = builtin_args(node);
2378 NODE indi = eval_indi(argvar, stab, eflg, NULL);
2379 if (*eflg || !indi) {
2380 *eflg = TRUE;
2381 prog_error(node, _(nonind1), "inode");
2382 return NULL;
2383 }
2384 return create_pvalue_from_node(indi);
2385 }
2386 /*================================+
2387 * llrpt_fnode -- Return root of family
2388 * usage: fnode(FAM) -> NODE
2389 *===============================*/
2390 PVALUE
llrpt_fnode(PNODE node,SYMTAB stab,BOOLEAN * eflg)2391 llrpt_fnode (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2392 {
2393 PNODE argvar = builtin_args(node);
2394 NODE fam = eval_fam(argvar, stab, eflg, NULL);
2395 if (*eflg) {
2396 prog_error(node, nonfam1, "fnode");
2397 return NULL;
2398 }
2399 /* fam may be NULL */
2400 return create_pvalue_from_node(fam);
2401 }
2402 /*=============================+
2403 * llrpt_table -- Create table
2404 * usage: table(IDENT) -> VOID
2405 *============================*/
2406 PVALUE
llrpt_table(PNODE node,SYMTAB stab,BOOLEAN * eflg)2407 llrpt_table (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2408 {
2409 PVALUE newval=0;
2410 PNODE argvar = builtin_args(node);
2411 if (!iistype(argvar, IIDENT)) {
2412 *eflg = TRUE;
2413 prog_var_error(node, stab, argvar, NULL, nonvar1, "table");
2414 return NULL;
2415 }
2416 newval = create_new_pvalue_table();
2417
2418 assign_iden(stab, iident_name(argvar), newval);
2419 return NULL;
2420 }
2421 /*=========================================+
2422 * llrpt_insert -- Add element to table
2423 * usage: insert(TAB, STRING, ANY) -> VOID
2424 *========================================*/
2425 PVALUE
llrpt_insert(PNODE node,SYMTAB stab,BOOLEAN * eflg)2426 llrpt_insert (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2427 {
2428 PNODE argvar = builtin_args(node);
2429 PVALUE val=NULL;
2430 PVALUE valtab = eval_and_coerce(PTABLE, argvar, stab, eflg);
2431 TABLE tab=0;
2432 STRING str=0;
2433
2434 if (*eflg || !valtab) {
2435 *eflg = TRUE;
2436 prog_var_error(node, stab, argvar, valtab, nontabx, "insert", "1");
2437 delete_pvalue(valtab);
2438 valtab = 0;
2439 goto exit_insert;
2440 }
2441 tab = pvalue_to_table(valtab);
2442
2443 argvar = inext(argvar);
2444 val = eval_and_coerce(PSTRING, argvar, stab, eflg);
2445 if (*eflg || !val || !pvalue_to_string(val)) {
2446 *eflg = TRUE;
2447 prog_var_error(node, stab, argvar, val, nonstrx, "insert", "2");
2448 delete_pvalue(val);
2449 goto exit_insert;
2450 }
2451 str = pvalue_to_string(val);
2452 if (str)
2453 str = strsave(str);
2454 delete_pvalue(val);
2455
2456 val = evaluate(argvar=inext(argvar), stab, eflg);
2457 if (*eflg || !val) {
2458 *eflg = TRUE;
2459 prog_error(node, "3rd arg to insert is in error");
2460 delete_pvalue(val);
2461 goto exit_insert;
2462 }
2463
2464 insert_table_ptr(tab, str, val);
2465
2466 exit_insert: /* free memory and leave */
2467
2468 delete_pvalue(valtab); /* finished with our copy of table */
2469 strfree(&str);
2470 return NULL;
2471 }
2472 /*====================================+
2473 * prot -- protect string (replace if NULL)
2474 *===================================*/
2475 STRING
prot(STRING str)2476 prot (STRING str)
2477 {
2478 return str ? str : "<NULL>";
2479 }
2480 /*====================================+
2481 * llrpt_lookup -- Look up element in table
2482 * usage: lookup(TAB, STRING) -> ANY
2483 *===================================*/
2484 PVALUE
llrpt_lookup(PNODE node,SYMTAB stab,BOOLEAN * eflg)2485 llrpt_lookup (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2486 {
2487 PNODE argvar = builtin_args(node);
2488 PVALUE newv, val;
2489 TABLE tab;
2490 STRING str;
2491
2492 val = eval_and_coerce(PTABLE, argvar, stab, eflg);
2493 if (*eflg || !val) {
2494 *eflg = TRUE;
2495 prog_error(node, "1st arg to lookup is not a table");
2496 delete_pvalue(val);
2497 return NULL;
2498 }
2499 tab = pvalue_to_table(val);
2500 delete_pvalue(val);
2501 val = eval_and_coerce(PSTRING, argvar=inext(argvar), stab, eflg);
2502 if (*eflg) {
2503 prog_error(node, nonstrx, "lookup", "2");
2504 delete_pvalue(val);
2505 return NULL;
2506 }
2507 str = pvalue_to_string(val);
2508 newv = valueof_ptr(tab, str);
2509 delete_pvalue(val);
2510 newv = (newv ? copy_pvalue(newv) : create_pvalue_any());
2511 if (prog_trace) {
2512 trace_out("lookup(,%s)->", prot(str));
2513 trace_pvalue(newv);
2514 trace_endl();
2515 }
2516 return newv;
2517 }
2518 /*====================================+
2519 * llrpt_trim -- Trim string if too long
2520 * usage: trim(STRING, INT) -> STRING
2521 *===================================*/
2522 PVALUE
llrpt_trim(PNODE node,SYMTAB stab,BOOLEAN * eflg)2523 llrpt_trim (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2524 {
2525 PNODE argvar = builtin_args(node);
2526 STRING str;
2527 PVALUE val1, val2;
2528 INT len;
2529 val1 = eval_and_coerce(PSTRING, argvar, stab, eflg);
2530 if (*eflg) {
2531 prog_error(node, nonstrx, "trim", "1");
2532 delete_pvalue(val1);
2533 return NULL;
2534 }
2535 val2 = eval_and_coerce(PINT, argvar=inext(argvar), stab, eflg);
2536 if (*eflg) {
2537 prog_error(node, nonintx, "trim", "2");
2538 delete_pvalue(val2);
2539 return NULL;
2540 }
2541 str = pvalue_to_string(val1);
2542 len = pvalue_to_int(val2);
2543 set_pvalue_string(val2, trim(str, len));
2544 delete_pvalue(val1);
2545 return val2;
2546 }
2547 /*======================================+
2548 * llrpt_trimname -- Trim name if too long
2549 * usage: trimname(INDI, INT) -> STRING
2550 *=====================================*/
2551 PVALUE
llrpt_trimname(PNODE node,SYMTAB stab,BOOLEAN * eflg)2552 llrpt_trimname (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2553 {
2554 PNODE argvar = builtin_args(node);
2555 INT len;
2556 PVALUE val=NULL;
2557 NODE indi = eval_indi(argvar, stab, eflg, (CACHEEL *) NULL);
2558 STRING str=NULL;
2559 if (*eflg) {
2560 prog_error(node, nonindx, "trimname", "1");
2561 return NULL;
2562 }
2563 if (!indi) return create_pvalue_from_string("");
2564 if (!(indi = NAME(indi)) || !nval(indi)) {
2565 if (getlloptint("RequireNames", 0)) {
2566 *eflg = TRUE;
2567 prog_error(node, _("(trimname) person does not have a name"));
2568 return NULL;
2569 }
2570 return create_pvalue_from_string(0);
2571 }
2572 *eflg = FALSE;
2573 val = eval_and_coerce(PINT, argvar=inext(argvar), stab, eflg);
2574 if (*eflg) {
2575 prog_error(node, nonintx, "trimname", "2");
2576 delete_pvalue(val);
2577 return NULL;
2578 }
2579 len = pvalue_to_int(val);
2580 str = name_string(trim_name(nval(indi), len));
2581 if (str)
2582 str = strsave(str);
2583 set_pvalue_string(val, str);
2584 strfree(&str);
2585 return val;
2586 }
2587 /*==============================+
2588 * llrpt_date -- Return date of event
2589 * usage: date(EVENT) -> STRING
2590 *=============================*/
2591 PVALUE
llrpt_date(PNODE node,SYMTAB stab,BOOLEAN * eflg)2592 llrpt_date (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2593 {
2594 NODE line=NULL;
2595 STRING str=NULL;
2596 PNODE argvar = builtin_args(node);
2597 PVALUE val = eval_and_coerce(PGNODE, argvar, stab, eflg);
2598 if (*eflg) {
2599 prog_error(node, nonnod1, "date");
2600 delete_pvalue(val);
2601 return NULL;
2602 }
2603 line = pvalue_to_node(val);
2604 str = event_to_date(line, FALSE);
2605 /* save string in case node is temp (will get deleted in create_pvalue) */
2606 if (str)
2607 str = strsave(str);
2608 delete_pvalue(val);
2609 val = create_pvalue_from_string(str);
2610 strfree(&str);
2611 return val;
2612 }
2613 /*==========================================+
2614 * llrpt_date2jd -- Return julian day of date
2615 * usage: date2jd(EVENT) -> FLOAT
2616 * date2jd(STRING) -> FLOAT
2617 * creation : Patrick Texier 2006/05/22
2618 * Added to cvs: 2006/06/10
2619 * =========================================*/
2620 PVALUE
llrpt_date2jd(PNODE node,SYMTAB stab,BOOLEAN * eflg)2621 llrpt_date2jd (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2622 {
2623 STRING str=0;
2624 GDATEVAL gdv;
2625 PNODE argvar = builtin_args(node);
2626
2627 FLOAT jd = 0;
2628 PVALUE val = eval_without_coerce(argvar, stab, eflg);
2629 /* Handle string input */
2630 if (val && which_pvalue_type(val) == PSTRING) {
2631 str = pvalue_to_string(val);
2632 }
2633 else /* handle NODE input */
2634 {
2635 NODE evnt;
2636 coerce_pvalue(PGNODE, val, eflg);
2637 if (*eflg) {
2638 /* Input neither string nor node, error */
2639 prog_error(node, nonnodstr1, "date2jd");
2640 return NULL;
2641 }
2642 evnt = pvalue_to_node(val);
2643 str = event_to_date(evnt, FALSE);
2644 }
2645 /* Parse into lifelines date structure (GDATEVAL) */
2646 gdv = extract_date(str);
2647 /* Compute julian date value as float */
2648 jd = julianday(gdv);
2649
2650 free_gdateval(gdv);
2651 *eflg = FALSE;
2652 return create_pvalue_from_float(jd);
2653 }
2654 /*=============================================+
2655 * llrpt_dayofweek -- Return day of week
2656 * usage: dayofweek(EVENT) -> STRING
2657 * dayofweek(STRING) -> STRING
2658 * creation: Patrick Texier 2006/05/22
2659 * Added to cvs: 2006/06/10
2660 *=============================================*/
2661 static char *dofw[] = { N_("Sunday"), N_("Monday"), N_("Tuesday"),
2662 N_("Wednesday"), N_("Thursday"), N_("Friday"), N_("Saturday") };
2663 PVALUE
llrpt_dayofweek(PNODE node,SYMTAB stab,BOOLEAN * eflg)2664 llrpt_dayofweek (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2665 {
2666 STRING str = 0, str2 = 0;
2667 GDATEVAL gdv;
2668 INT weekdaynum = 0;
2669 PNODE argvar = builtin_args(node);
2670
2671 FLOAT jd = 0;
2672 PVALUE val = eval_without_coerce(argvar, stab, eflg);
2673 /* Handle string input */
2674 if (val && which_pvalue_type(val) == PSTRING) {
2675 str = pvalue_to_string(val);
2676 }
2677 else /* handle NODE input */
2678 {
2679 NODE evnt;
2680 coerce_pvalue(PGNODE, val, eflg);
2681 if (*eflg) {
2682 prog_error(node, nonnodstr1, "dayofweek");
2683 return NULL;
2684 }
2685 evnt = pvalue_to_node(val);
2686 str = event_to_date(evnt, FALSE);
2687 }
2688 /* Parse into lifelines date structure (GDATEVAL) */
2689 gdv = extract_date(str);
2690 /* Compute julian date value as float */
2691 jd = julianday(gdv);
2692 /* Compute which day of week */
2693 weekdaynum = (INT)(jd + 1.5) % 7;
2694 /* Convert to localized name */
2695 str2 = _(dofw[weekdaynum]);
2696
2697 free_gdateval(gdv);
2698 *eflg = FALSE;
2699 return create_pvalue_from_string(str2);
2700 }
2701 /*===============================================+
2702 * llrpt_jd2date -- Return date from Julian Day
2703 * usage : jd2date(FLOAT) -> EVENT
2704 * creation : Patrick Texier 2006/05/22
2705 * Added to cvs: 2006/06/10
2706 * =============================================== */
2707 static char *gedmonths[] = { "JAN", "FEB","MAR", "APR", "MAY", "JUN",
2708 "JUL", "AUG", "SEP", "OCT", "NOV", "DEC" };
2709 /* TODO Use an existing .h */
2710
2711 PVALUE
llrpt_jd2date(PNODE node,SYMTAB stab,BOOLEAN * eflg)2712 llrpt_jd2date (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2713 {
2714 PNODE argvar = builtin_args(node);
2715 FLOAT val2;
2716 FLOAT f, z, a, ab, b, c, d, e;
2717 INT yr, mo, dy;
2718 NODE prnt, chil;
2719 static char str[12];
2720
2721 PVALUE val = eval_and_coerce(PFLOAT, argvar, stab, eflg);
2722
2723 if (*eflg) {
2724 prog_error(node, nonflox, "jd2date", "1");
2725 return NULL;
2726 }
2727 /* Extract julian date float value */
2728 val2 = pvalue_to_float(val);
2729 z = floor(val2 + 0.5);
2730 f = floor(val2 + 0.5 - z);
2731 /* Gregorian correction */
2732 if (z >= 2299159.5) {
2733 ab = floor((z - 1867216.25) / 36524.25);
2734 a = z + 1 + ab - floor(ab / 4);
2735 } else {
2736 a = z;
2737 }
2738 b = a + 1524;
2739 c = floor((b - 122.1) / 365.25);
2740 d = floor(365.25 * c);
2741 e = floor((b - d) / 30.6001);
2742 dy = (INT)(b - d - floor(30.6001 * e) + f);
2743 if (e <= 13) {
2744 mo = (INT)(e - 1);
2745 } else {
2746 mo = (INT)(e - 13);
2747 }
2748 if (mo >= 2) {
2749 yr = (INT)(c - 4716);
2750 } else {
2751 yr = (INT)(c - 4715);
2752 }
2753 /* Now print GEDCOM style date string */
2754 sprintf(str, "%ld %s %ld", dy, gedmonths[mo - 1], yr);
2755 /* Create an EVEN node with subordinate DATE node */
2756 prnt = create_temp_node(NULL, "EVEN", NULL, NULL);
2757 chil = create_temp_node(NULL, "DATE", str, prnt);
2758 nchild(prnt) = chil;
2759
2760 *eflg = FALSE;
2761
2762 return create_pvalue_from_node(prnt);
2763 }
2764
2765 /*======================================
2766 * Julian day calculation
2767 * Creation: Patrick Texier 2006/05/22
2768 * Added to cvs: 2006/06/10
2769 * ===================================== */
2770 static FLOAT
julianday(GDATEVAL gdv)2771 julianday (GDATEVAL gdv)
2772 {
2773 INT da = 0, mo = 0, yr = 0;
2774 INT mmo = 0, yyr = 0;
2775 FLOAT jd = 0.0;
2776
2777 da = date_get_day(gdv);
2778 /* 1th if no day */
2779 if (da == 0)
2780 da = 1;
2781 mo = date_get_month(gdv);
2782 /* January if no month */
2783 if (mo == 0)
2784 mo = 1;
2785 yr = date_get_year(gdv);
2786
2787 if (mo < 3) {
2788 yyr = yr - 1;
2789 mmo = mo + 12;
2790 } else {
2791 yyr = yr;
2792 mmo = mo;
2793 }
2794 jd = floor(yyr * 365.25);
2795 jd += floor(30.6001 * (mmo + 1));
2796 jd += da + 1720994.5;
2797 /* gregorian correction after 1582/10/14 */
2798 if ( jd > 2299159.5 )
2799 jd = jd + 2.0 - floor(yyr/100.0) + floor(yyr / 400.0);
2800 return jd;
2801 }
2802 /*=====================================================+
2803 * normalize_year -- Modify year before returning to report
2804 * historical behavior is that 0 is the return for unknown year
2805 *====================================================*/
2806 static INT
normalize_year(INT yr)2807 normalize_year (INT yr)
2808 {
2809 return (yr == BAD_YEAR) ? 0 : yr;
2810 }
2811 /*=====================================================+
2812 * llrpt_extractdate -- Extract date from EVENT or DATE NODE
2813 * usage: extractdate(NODE, VARB, VARB, VARB) -> VOID
2814 *====================================================*/
2815 PVALUE
llrpt_extractdate(PNODE node,SYMTAB stab,BOOLEAN * eflg)2816 llrpt_extractdate (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2817 {
2818 STRING str;
2819 NODE line;
2820 INT da = 0, mo = 0, yr = 0;
2821 PNODE argvar = builtin_args(node);
2822 PVALUE val = eval_and_coerce(PGNODE, argvar, stab, eflg);
2823 PNODE dvar = inext(argvar);
2824 PNODE mvar = inext(dvar);
2825 PNODE yvar = inext(mvar);
2826 GDATEVAL gdv = 0;
2827 if (*eflg) {
2828 prog_var_error(node, stab, argvar, val, nonnodx, "extractdate", "1");
2829 return NULL;
2830 }
2831 line = pvalue_to_node(val);
2832 *eflg = TRUE; /* error if we don't make it all the way through */
2833 if (!line) {
2834 prog_var_error(node, stab, argvar, val, nonnodx, "extractdate", "1");
2835 return NULL;
2836 }
2837 if (!iistype(dvar, IIDENT)) {
2838 prog_error(node, nonvarx, "extractdate", "2");
2839 return NULL;
2840 }
2841 if (!iistype(mvar, IIDENT)) {
2842 prog_error(node, nonvarx, "extractdate", "3");
2843 return NULL;
2844 }
2845 if (!iistype(yvar, IIDENT)) {
2846 prog_error(node, nonvarx, "extractdate", "4");
2847 return NULL;
2848 }
2849 if (nestr("DATE", ntag(line)))
2850 str = event_to_date(line, FALSE);
2851 else
2852 str = nval(line);
2853 if (str)
2854 str = strsave(str); /* save in case we delete line node */
2855 delete_pvalue(val);
2856 gdv = extract_date(str);
2857 strfree(&str);
2858 /* TODO: deal with date information */
2859 da = date_get_day(gdv);
2860 mo = date_get_month(gdv);
2861 yr = date_get_year(gdv);
2862 yr = normalize_year(yr);
2863 assign_iden(stab, iident_name(dvar), create_pvalue_from_int(da));
2864 assign_iden(stab, iident_name(mvar), create_pvalue_from_int(mo));
2865 assign_iden(stab, iident_name(yvar), create_pvalue_from_int(yr));
2866 free_gdateval(gdv);
2867 *eflg = FALSE;
2868 return NULL;
2869 }
2870 /*==================================================================+
2871 * llrpt_extractdatestr -- Extract date from STRING
2872 * usage: extractdatestr(VARB, VARB, VARB, VARB, VARB[, STRING]) -> VOID
2873 *==================================================================*/
2874 PVALUE
llrpt_extractdatestr(PNODE node,SYMTAB stab,BOOLEAN * eflg)2875 llrpt_extractdatestr (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2876 {
2877 STRING str = NULL, yrstr;
2878 INT mod=0, da=0, mo=0, yr=0;
2879 PVALUE val=0;
2880 PNODE date;
2881 PNODE modvar = builtin_args(node);
2882 PNODE dvar = inext(modvar);
2883 PNODE mvar = inext(dvar);
2884 PNODE yvar = inext(mvar);
2885 PNODE ystvar = inext(yvar);
2886 GDATEVAL gdv = 0;
2887 if (!iistype(modvar, IIDENT)) {
2888 *eflg = TRUE;
2889 prog_error(node, nonvarx, "extractdatestr", "1");
2890 return NULL;
2891 }
2892 if (!iistype(dvar, IIDENT)) {
2893 *eflg = TRUE;
2894 prog_error(node, nonvarx, "extractdatestr", "2");
2895 return NULL;
2896 }
2897 if (!iistype(mvar, IIDENT)) {
2898 *eflg = TRUE;
2899 prog_error(node, nonvarx, "extractdatestr", "3");
2900 return NULL;
2901 }
2902 if (!iistype(yvar, IIDENT)) {
2903 *eflg = TRUE;
2904 prog_error(node, nonvarx, "extractdatestr", "4");
2905 return NULL;
2906 }
2907 if (!iistype(ystvar, IIDENT)) {
2908 *eflg = TRUE;
2909 prog_error(node, nonvarx, "extractdatestr", "5");
2910 return NULL;
2911 }
2912 if ((date = inext(ystvar))) {
2913 val = eval_and_coerce(PSTRING, date, stab, eflg);
2914 if (*eflg || !val) {
2915 *eflg = TRUE;
2916 prog_error(node, nonstrx, "extractdatestr", "6");
2917 delete_pvalue(val);
2918 return NULL;
2919 }
2920 str = pvalue_to_string(val);
2921 }
2922 gdv = extract_date(str);
2923 delete_pvalue_ptr(&val);
2924 str = NULL;
2925 /* TODO: deal with date information */
2926 mod = date_get_mod(gdv);
2927 da = date_get_day(gdv);
2928 mo = date_get_month(gdv);
2929 yr = date_get_year(gdv);
2930 yr = normalize_year(yr);
2931 yrstr = date_get_year_string(gdv);
2932 if (!yrstr) yrstr="";
2933 assign_iden(stab, iident_name(modvar), create_pvalue_from_int(mod));
2934 assign_iden(stab, iident_name(dvar), create_pvalue_from_int(da));
2935 assign_iden(stab, iident_name(mvar), create_pvalue_from_int(mo));
2936 assign_iden(stab, iident_name(yvar), create_pvalue_from_int(yr));
2937 assign_iden(stab, iident_name(ystvar), create_pvalue_from_string(yrstr));
2938 free_gdateval(gdv);
2939 return NULL;
2940 }
2941 /*=================================================+
2942 * llrpt_stddate -- Return standard date format of event
2943 * usage: stddate(EVENT) -> STRING
2944 * or stddate(STRING) -> STRING
2945 *================================================*/
2946 static INT daycode = 0;
2947 static INT monthcode = 3;
2948 static INT yearcode = 0;
2949 static INT datecode = 0;
2950 static INT eratimecode = 0;
2951 static INT cmplxcode = 1;
2952 PVALUE
llrpt_stddate(PNODE node,SYMTAB stab,BOOLEAN * eflg)2953 llrpt_stddate (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2954 {
2955 STRING str=0;
2956 PNODE argvar = builtin_args(node);
2957 PVALUE val = eval_without_coerce(argvar, stab, eflg);
2958 if (val && which_pvalue_type(val) == PSTRING) {
2959 str = pvalue_to_string(val);
2960 } else {
2961 NODE evnt;
2962 coerce_pvalue(PGNODE, val, eflg);
2963 if (*eflg) {
2964 prog_error(node, nonnodstr1, "stddate");
2965 return NULL;
2966 }
2967 evnt = pvalue_to_node(val);
2968 str = event_to_date(evnt, FALSE);
2969 }
2970 set_pvalue_string(val, do_format_date(str,
2971 daycode, monthcode, yearcode, datecode, eratimecode, FALSE));
2972 return val;
2973 }
2974 /*========================================================================+
2975 * llrpt_complexdate -- Return standard date format of event, including modifiers
2976 * usage: complexdate(EVENT) -> STRING
2977 * or complexdate(STRING) -> STRING
2978 *=======================================================================*/
2979 PVALUE
llrpt_complexdate(PNODE node,SYMTAB stab,BOOLEAN * eflg)2980 llrpt_complexdate (PNODE node, SYMTAB stab, BOOLEAN *eflg)
2981 {
2982 STRING str=0;
2983 PNODE argvar = builtin_args(node);
2984 PVALUE val = eval_without_coerce(argvar, stab, eflg);
2985 if (val && which_pvalue_type(val) == PSTRING) {
2986 str = pvalue_to_string(val);
2987 } else {
2988 NODE evnt;
2989 coerce_pvalue(PGNODE, val, eflg);
2990 if (*eflg) {
2991 prog_error(node, nonnodstr1, "complexdate");
2992 return NULL;
2993 }
2994 evnt = pvalue_to_node(val);
2995 str = event_to_date(evnt, FALSE);
2996 }
2997 set_pvalue_string(val, do_format_date(str,
2998 daycode, monthcode, yearcode, datecode, eratimecode, cmplxcode));
2999 return val;
3000 }
3001 /*===============================================+
3002 * llrpt_dayformat -- Set day format
3003 * usage: dayformat(INT) -> NULL
3004 *==============================================*/
3005 PVALUE
llrpt_dayformat(PNODE node,SYMTAB stab,BOOLEAN * eflg)3006 llrpt_dayformat (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3007 {
3008 PNODE argvar = builtin_args(node);
3009 INT value;
3010 PVALUE val = eval_and_coerce(PINT, argvar, stab, eflg);
3011 if (*eflg) {
3012 prog_error(node, nonint1, "dayformat");
3013 return NULL;
3014 }
3015 value = pvalue_to_int(val);
3016 delete_pvalue(val);
3017 if (value < 0) value = 0;
3018 if (!is_valid_dayfmt(value)) value = 2;
3019 daycode = value;
3020 return NULL;
3021 }
3022 /*===============================================+
3023 * llrpt_monthformat -- Set month format
3024 * usage: monthformat(INT) -> NULL
3025 *==============================================*/
3026 PVALUE
llrpt_monthformat(PNODE node,SYMTAB stab,BOOLEAN * eflg)3027 llrpt_monthformat (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3028 {
3029 PNODE argvar = builtin_args(node);
3030 INT value;
3031 PVALUE val = eval_and_coerce(PINT, argvar, stab, eflg);
3032 if (*eflg) {
3033 prog_error(node, nonint1, "monthformat");
3034 return NULL;
3035 }
3036 value = pvalue_to_int(val);
3037 delete_pvalue(val);
3038 if (value < 0) value = 0;
3039 if (!is_valid_monthfmt(value)) value = 8;
3040 monthcode = value;
3041 return NULL;
3042 }
3043 /*===============================================+
3044 * llrpt_yearformat -- Set month format
3045 * usage: yearformat(INT) -> NULL
3046 * Created: 2001/12/24, Perry Rapp
3047 *==============================================*/
3048 PVALUE
llrpt_yearformat(PNODE node,SYMTAB stab,BOOLEAN * eflg)3049 llrpt_yearformat (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3050 {
3051 PNODE argvar = builtin_args(node);
3052 INT value;
3053 PVALUE val = eval_and_coerce(PINT, argvar, stab, eflg);
3054 if (*eflg) {
3055 prog_error(node, nonint1, "yearformat");
3056 return NULL;
3057 }
3058 value = pvalue_to_int(val);
3059 delete_pvalue(val);
3060 if (value < 0) value = 0;
3061 yearcode = value;
3062 return NULL;
3063 }
3064 /*=================================================+
3065 * llrpt_dateformat -- Set date format
3066 * usage: dateformat(INT) -> NULL
3067 *================================================*/
3068 PVALUE
llrpt_dateformat(PNODE node,SYMTAB stab,BOOLEAN * eflg)3069 llrpt_dateformat (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3070 {
3071 PNODE argvar = builtin_args(node);
3072 INT value;
3073 PVALUE val = eval_and_coerce(PINT, argvar, stab, eflg);
3074 if (*eflg) {
3075 prog_error(node, nonint1, "dateformat");
3076 return NULL;
3077 }
3078 value = pvalue_to_int(val);
3079 delete_pvalue(val);
3080 if (value < 0) value = 0;
3081 if (value > 14) value = 14;
3082 datecode = value;
3083 return NULL;
3084 }
3085 /*===============================================+
3086 * llrpt_eraformat -- Set format for AD/BC trailer
3087 * usage: eraformat(INT) -> NULL
3088 * Created: 2001/12/28, Perry Rapp
3089 *==============================================*/
3090 PVALUE
llrpt_eraformat(PNODE node,SYMTAB stab,BOOLEAN * eflg)3091 llrpt_eraformat (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3092 {
3093 PNODE argvar = builtin_args(node);
3094 INT value;
3095 PVALUE val = eval_and_coerce(PINT, argvar, stab, eflg);
3096 if (*eflg) {
3097 prog_error(node, nonint1, "eraformat");
3098 return NULL;
3099 }
3100 value = pvalue_to_int(val);
3101 delete_pvalue(val);
3102 if (value < 0) value = 0;
3103 eratimecode = value;
3104 return NULL;
3105 }
3106 /*===============================================+
3107 * llrpt_complexformat -- Set complex format
3108 * usage: complexformat(INT) -> NULL
3109 * Created: 2001/12/24, Perry Rapp
3110 *==============================================*/
3111 PVALUE
llrpt_complexformat(PNODE node,SYMTAB stab,BOOLEAN * eflg)3112 llrpt_complexformat (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3113 {
3114 PNODE argvar = builtin_args(node);
3115 INT value;
3116 PVALUE val = eval_and_coerce(PINT, argvar, stab, eflg);
3117 if (*eflg) {
3118 prog_error(node, nonint1, "complexformat");
3119 return NULL;
3120 }
3121 value = pvalue_to_int(val);
3122 delete_pvalue(val);
3123 if (value < 0) value = 0;
3124 cmplxcode = value;
3125 return NULL;
3126 }
3127 /*===============================================+
3128 * llrpt_datepic -- Set custom ymd date picture string
3129 * usage: datepic(STRING) -> NULL
3130 * Created: 2001/12/30, Perry Rapp
3131 *==============================================*/
3132 PVALUE
llrpt_datepic(PNODE node,SYMTAB stab,BOOLEAN * eflg)3133 llrpt_datepic (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3134 {
3135 PNODE argvar = builtin_args(node);
3136 STRING str;
3137 PVALUE val = eval_and_coerce(PSTRING, argvar, stab, eflg);
3138 if (*eflg) {
3139 prog_error(node, nonstrx, "datepic", "1");
3140 return NULL;
3141 }
3142 str = pvalue_to_string(val);
3143 set_date_pic(str);
3144 delete_pvalue(val);
3145 return NULL;
3146 }
3147 /*===============================================+
3148 * llrpt_complexpic -- Set custom picture string for
3149 * a complex date
3150 * usage: complexpic(INT, STRING) -> NULL
3151 * Created: 2001/12/30, Perry Rapp
3152 * TODO: We could add a 3rd argument giving language specifier
3153 * when we are localizing
3154 *==============================================*/
3155 PVALUE
llrpt_complexpic(PNODE node,SYMTAB stab,BOOLEAN * eflg)3156 llrpt_complexpic (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3157 {
3158 PNODE argvar = builtin_args(node);
3159 INT ecmplx;
3160 STRING str;
3161 BOOLEAN ok;
3162 PVALUE val = eval_and_coerce(PINT, argvar, stab, eflg);
3163 if (*eflg) {
3164 prog_error(node, nonintx, "complexpic", "1");
3165 return NULL;
3166 }
3167 ecmplx = pvalue_to_int(val);
3168 delete_pvalue(val);
3169 val = eval_and_coerce(PSTRING, argvar=inext(argvar), stab, eflg);
3170 if (*eflg) {
3171 prog_error(node, nonstrx, "complexpic", "2");
3172 delete_pvalue(val);
3173 return NULL;
3174 }
3175 str = pvalue_to_string(val);
3176 ok = set_cmplx_pic(ecmplx, str);
3177 delete_pvalue(val);
3178 if (!ok) {
3179 *eflg = TRUE;
3180 prog_error(node, badargs, "complexpic");
3181 return NULL;
3182 }
3183 return NULL;
3184 }
3185 /*==============================+
3186 * llrpt_year -- Return year of event
3187 * usage: year(EVENT) -> STRING
3188 * or year(STRING) -> STRING
3189 *=============================*/
3190 PVALUE
llrpt_year(PNODE node,SYMTAB stab,BOOLEAN * eflg)3191 llrpt_year (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3192 {
3193 STRING str=0;
3194 char buff[20];
3195 GDATEVAL gdv;
3196 PNODE argvar = builtin_args(node);
3197 PVALUE val = eval_without_coerce(argvar, stab, eflg);
3198 if (val && which_pvalue_type(val) == PSTRING) {
3199 str = pvalue_to_string(val);
3200 } else {
3201 NODE evnt;
3202 coerce_pvalue(PGNODE, val, eflg);
3203 if (*eflg) {
3204 prog_error(node, nonnodstr1, "year");
3205 return NULL;
3206 }
3207 evnt = pvalue_to_node(val);
3208 str = event_to_date(evnt, FALSE);
3209 }
3210 gdv = extract_date(str);
3211 /* prefer year's string if it has one */
3212 str = date_get_year_string(gdv);
3213 if (str && str[0]) {
3214 /* we'll use year string, now in str */
3215 } else {
3216 INT yr = date_get_year(gdv);
3217 if (yr != BAD_YEAR) {
3218 /* no year string, so must have been a simple number */
3219 snprintf(buff, sizeof(buff), "%ld", yr);
3220 str = buff;
3221 } else {
3222 str = 0;
3223 }
3224 }
3225 set_pvalue_string(val, str);
3226 free_gdateval(gdv);
3227 return val;
3228 }
3229 /*================================+
3230 * llrpt_place -- Return place of event
3231 * usage: place(EVENT) -> STRING
3232 *===============================*/
3233 PVALUE
llrpt_place(PNODE node,SYMTAB stab,BOOLEAN * eflg)3234 llrpt_place (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3235 {
3236 NODE evnt=NULL;
3237 PNODE argvar = builtin_args(node);
3238 STRING str=NULL;
3239 PVALUE val = eval_and_coerce(PGNODE, argvar, stab, eflg);
3240
3241 if (*eflg) {
3242 prog_var_error(node, stab, argvar, val, nonnod1, "place");
3243 delete_pvalue(val);
3244 return NULL;
3245 }
3246 evnt = pvalue_to_node(val);
3247 str = event_to_plac(evnt, FALSE);
3248 if (str)
3249 str = strsave(str);
3250 set_pvalue_string(val, str);
3251 strfree(&str);
3252 return val;
3253 }
3254 /*============================+
3255 * llrpt_tag -- Return tag of node
3256 * usage: tag(NODE) -> STRING
3257 *===========================*/
3258 PVALUE
llrpt_tag(PNODE node,SYMTAB stab,BOOLEAN * eflg)3259 llrpt_tag (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3260 {
3261 NODE ged=NULL;
3262 PNODE argvar = builtin_args(node);
3263 PVALUE val = eval_and_coerce(PGNODE, argvar, stab, eflg);
3264 STRING str=NULL;
3265 if (*eflg) {
3266 prog_var_error(node, stab, argvar, val, nonnod1, "tag");
3267 delete_pvalue(val);
3268 return NULL;
3269 }
3270 ged = pvalue_to_node(val);
3271 if (ged)
3272 str = ntag(ged);
3273 if (str)
3274 str = strsave(str);
3275 set_pvalue_string(val, str);
3276 strfree(&str);
3277 return val;
3278 }
3279 /*===============================+
3280 * llrpt_value -- Return value of node
3281 * usage: value(NODE) -> STRING
3282 *==============================*/
3283 PVALUE
llrpt_value(PNODE node,SYMTAB stab,BOOLEAN * eflg)3284 llrpt_value (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3285 {
3286 NODE ged=NULL;
3287 PNODE argvar = builtin_args(node);
3288 PVALUE val = eval_and_coerce(PGNODE, argvar, stab, eflg);
3289 STRING str = 0;
3290 if (*eflg) {
3291 prog_var_error(node, stab, argvar, val, nonnod1, "value");
3292 delete_pvalue(val);
3293 return NULL;
3294 }
3295 ged = pvalue_to_node(val);
3296 if (!ged) {
3297 *eflg = TRUE;
3298 prog_var_error(node, stab, argvar, val, nullarg1, "value");
3299 delete_pvalue(val);
3300 return NULL;
3301 }
3302 /*
3303 save away string, so it doesn't die when val is cleared for
3304 assignment below
3305 */
3306 str = nval(ged);
3307 if (str)
3308 str = strsave(str);
3309 set_pvalue_string(val, str);
3310 strfree(&str);
3311 return val;
3312 }
3313 /*=============================+
3314 * llrpt_xref -- Return xref of node
3315 * usage: xref(NODE) -> STRING
3316 *============================*/
3317 PVALUE
llrpt_xref(PNODE node,SYMTAB stab,BOOLEAN * eflg)3318 llrpt_xref (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3319 {
3320 NODE ged;
3321 PNODE argvar = builtin_args(node);
3322 PVALUE val = eval_and_coerce(PGNODE, argvar, stab, eflg);
3323 if (*eflg) {
3324 prog_var_error(node, stab, argvar, val, nonnod1, "xref");
3325 delete_pvalue(val);
3326 return NULL;
3327 }
3328 ged = pvalue_to_node(val);
3329 if (!ged) {
3330 *eflg = TRUE;
3331 prog_var_error(node, stab, argvar, val, nullarg1, "xref");
3332 delete_pvalue(val);
3333 return NULL;
3334 }
3335 set_pvalue_string(val, nxref(ged));
3336 return val;
3337 }
3338 /*===============================+
3339 * llrpt_child -- Return child of node
3340 * usage: child(NODE) -> NODE
3341 *==============================*/
3342 PVALUE
llrpt_child(PNODE node,SYMTAB stab,BOOLEAN * eflg)3343 llrpt_child (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3344 {
3345 NODE ged;
3346 PNODE argvar = builtin_args(node);
3347 PVALUE val = eval_and_coerce(PGNODE, argvar, stab, eflg);
3348 if (*eflg) {
3349 prog_var_error(node, stab, argvar, val, nonnod1, "child");
3350 delete_pvalue(val);
3351 return NULL;
3352 }
3353 ged = pvalue_to_node(val);
3354 if (!ged) {
3355 *eflg = TRUE;
3356 prog_var_error(node, stab, argvar, val, nullarg1, "child");
3357 delete_pvalue(val);
3358 return NULL;
3359 }
3360 set_pvalue_node(val, nchild(ged));
3361 return val;
3362 }
3363 /*=================================+
3364 * llrpt_parent -- Return parent of node
3365 * usage: parent(NODE) -> NODE
3366 *================================*/
3367 PVALUE
llrpt_parent(PNODE node,SYMTAB stab,BOOLEAN * eflg)3368 llrpt_parent (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3369 {
3370 NODE ged;
3371 PNODE argvar = builtin_args(node);
3372 PVALUE val = eval_and_coerce(PGNODE, argvar, stab, eflg);
3373 if (*eflg) {
3374 prog_var_error(node, stab, argvar, val, nonnod1, "parent");
3375 delete_pvalue(val);
3376 return NULL;
3377 }
3378 ged = pvalue_to_node(val);
3379 if (!ged) {
3380 *eflg = TRUE;
3381 prog_var_error(node, stab, argvar, val, nullarg1, "parent");
3382 delete_pvalue(val);
3383 return NULL;
3384 }
3385 set_pvalue_node(val, nparent(ged));
3386 return val;
3387 }
3388 /*========================================+
3389 * llrpt_sibling -- Return next sibling of node
3390 * usage: sibling(NODE) -> NODE
3391 *=======================================*/
3392 PVALUE
llrpt_sibling(PNODE node,SYMTAB stab,BOOLEAN * eflg)3393 llrpt_sibling (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3394 {
3395 NODE ged;
3396 PNODE argvar = builtin_args(node);
3397 PVALUE val = eval_and_coerce(PGNODE, argvar, stab, eflg);
3398 if (*eflg) {
3399 prog_var_error(node, stab, argvar, val, nonnod1, "sibling");
3400 delete_pvalue(val);
3401 return NULL;
3402 }
3403 ged = pvalue_to_node(val);
3404 if (!ged) {
3405 *eflg = TRUE;
3406 prog_var_error(node, stab, argvar, val, nullarg1, "sibling");
3407 delete_pvalue(val);
3408 return NULL;
3409 }
3410 set_pvalue_node(val, nsibling(ged));
3411 return val;
3412 }
3413 /*===============================+
3414 * llrpt_level -- Return level of node
3415 * usage: level(NODE) -> INT
3416 *==============================*/
3417 PVALUE
llrpt_level(PNODE node,SYMTAB stab,BOOLEAN * eflg)3418 llrpt_level (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3419 {
3420 NODE ged;
3421 INT lev = -1;
3422 PNODE argvar = builtin_args(node);
3423 PVALUE val = eval_and_coerce(PGNODE, argvar, stab, eflg);
3424 if (*eflg) {
3425 prog_var_error(node, stab, argvar, val, nonnod1, "level");
3426 delete_pvalue(val);
3427 return NULL;
3428 }
3429 ged = pvalue_to_node(val);
3430 while (ged) {
3431 lev++;
3432 ged = nparent(ged);
3433 }
3434 set_pvalue_int(val, lev);
3435 return val;
3436 }
3437 /*=================================+
3438 * llrpt_copyfile -- Copy file to output
3439 * usage: copyfile(STRING) -> VOID
3440 *================================*/
3441 PVALUE
llrpt_copyfile(PNODE node,SYMTAB stab,BOOLEAN * eflg)3442 llrpt_copyfile (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3443 {
3444 FILE *cfp=NULL;
3445 STRING fname;
3446 PNODE argvar = builtin_args(node);
3447 PVALUE val = eval_and_coerce(PSTRING, argvar, stab, eflg);
3448 char buffer[1024];
3449 STRING programsdir = getlloptstr("LLPROGRAMS", ".");
3450 if (*eflg) {
3451 prog_error(node, nonstr1, "copyfile");
3452 goto copyfile_end;
3453 }
3454 fname = pvalue_to_string(val);
3455 if (!(cfp = fopenpath(fname, LLREADTEXT, programsdir
3456 , (STRING)NULL, uu8, (STRING *)NULL))) {
3457 *eflg = TRUE;
3458 prog_var_error(node, stab, argvar, val, nonfname1, "copyfile");
3459 goto copyfile_end;
3460 }
3461 delete_pvalue(val);
3462 while (fgets(buffer, sizeof(buffer), cfp)) {
3463 poutput(buffer, eflg);
3464 if (*eflg)
3465 goto copyfile_end;
3466 }
3467 copyfile_end:
3468 if (cfp) fclose(cfp);
3469 return NULL;
3470 }
3471 /*========================+
3472 * llrpt_nl -- Newline function
3473 * usage: nl() -> STRING
3474 *=======================*/
3475 PVALUE
llrpt_nl(PNODE node,SYMTAB stab,BOOLEAN * eflg)3476 llrpt_nl (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3477 {
3478 node=node; /* unused */
3479 stab=stab; /* unused */
3480 *eflg = FALSE;
3481 return create_pvalue_from_string("\n");
3482 }
3483 /*=========================+
3484 * llrpt_space -- Space function
3485 * usage: sp() -> STRING
3486 *========================*/
3487 PVALUE
llrpt_space(PNODE node,SYMTAB stab,BOOLEAN * eflg)3488 llrpt_space (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3489 {
3490 node=node; /* unused */
3491 stab=stab; /* unused */
3492 *eflg = FALSE;
3493 return create_pvalue_from_string(" ");
3494 }
3495 /*=============================+
3496 * llrpt_qt -- Double quote function
3497 * usage: qt() -> STRING
3498 *============================*/
3499 PVALUE
llrpt_qt(PNODE node,SYMTAB stab,BOOLEAN * eflg)3500 llrpt_qt (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3501 {
3502 node=node; /* unused */
3503 stab=stab; /* unused */
3504 *eflg = FALSE;
3505 return create_pvalue_from_string("\"");
3506 }
3507 /*=============================+
3508 * llrpt_indi -- Convert key to INDI
3509 * usage: indi(STRING) -> INDI
3510 *============================*/
3511 PVALUE
llrpt_indi(PNODE node,SYMTAB stab,BOOLEAN * eflg)3512 llrpt_indi (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3513 {
3514 STRING str=0;
3515 char scratch[200], *p, *q = scratch;
3516 int strip_at = 0;
3517 INT c;
3518 PNODE argvar = builtin_args(node);
3519 PVALUE val = eval_and_coerce(PSTRING, argvar, stab, eflg);
3520 if (*eflg) {
3521 prog_error(node, nonstr1, "indi");
3522 return NULL;
3523 }
3524 p = str = pvalue_to_string(val);
3525 if (p && *p == '@') {
3526 strip_at = 1;
3527 p++;
3528 }
3529 if (!p || *p++ != 'I' || *p == 0) {
3530 delete_pvalue(val);
3531 return create_pvalue_of_null_indi();
3532 }
3533 *q++ = 'I';
3534 while (chartype(c = (uchar)*p++) == DIGIT)
3535 *q++ = c;
3536 *q = 0;
3537 delete_pvalue(val);
3538 if (c != 0 && (strip_at == 0 || c != '@')) {
3539 return create_pvalue_of_null_indi();
3540 }
3541 if (strlen(scratch) == 1)
3542 return create_pvalue_of_null_indi();
3543
3544 val = create_pvalue_from_indi_key(scratch);
3545 return val;
3546 }
3547 /*===========================+
3548 * llrpt_fam -- Convert key to FAM
3549 * usage: fam(STRING) -> FAM
3550 *==========================*/
3551 PVALUE
llrpt_fam(PNODE node,SYMTAB stab,BOOLEAN * eflg)3552 llrpt_fam (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3553 {
3554 STRING str=0;
3555 char scratch[200]="", *p=0, *q = scratch;
3556 int strip_at = 0;
3557 INT c;
3558 PNODE argvar = builtin_args(node);
3559 PVALUE val = eval_and_coerce(PSTRING, argvar, stab, eflg);
3560 if (*eflg) {
3561 prog_error(node, nonstr1, "fam");
3562 return NULL;
3563 }
3564 p = str = pvalue_to_string(val);
3565 if (p && *p == '@') {
3566 strip_at = 1;
3567 p++;
3568 }
3569 if (!p || *p++ != 'F' || *p == 0) {
3570 delete_pvalue(val);
3571 return create_pvalue_of_null_fam();
3572 }
3573 *q++ = 'F';
3574 while (chartype(c = (uchar)*p++) == DIGIT)
3575 *q++ = c;
3576 *q = 0;
3577 delete_pvalue(val);
3578 if (c != 0 && (strip_at == 0 || c != '@')) {
3579 return create_pvalue_of_null_fam();
3580 }
3581 if (strlen(scratch) == 1)
3582 return create_pvalue_of_null_fam();
3583
3584 val = create_pvalue_from_fam_key(scratch);
3585 return val;
3586 }
3587 /*=======================================+
3588 * eval_indi -- Evaluate person expression
3589 * if any error occurs, *eflg is set to non-null
3590 * if caller wants pointer to cache element, pass in non-null pcel
3591 *======================================*/
3592 NODE
eval_indi(PNODE expr,SYMTAB stab,BOOLEAN * eflg,CACHEEL * pcel)3593 eval_indi (PNODE expr, SYMTAB stab, BOOLEAN *eflg, CACHEEL *pcel)
3594 {
3595 return eval_indi2(expr, stab, eflg, pcel, NULL);
3596 }
3597 /*=======================================+
3598 * eval_indi2 -- Evaluate person expression
3599 * If pval is non-null, it will be used to return
3600 * the evaluation PVALUE in case of error (*eflag set to non-zero)
3601 * in this case, caller must delete it
3602 *======================================*/
3603 NODE
eval_indi2(PNODE expr,SYMTAB stab,BOOLEAN * eflg,CACHEEL * pcel,PVALUE * pval)3604 eval_indi2 (PNODE expr, SYMTAB stab, BOOLEAN *eflg, CACHEEL *pcel, PVALUE *pval)
3605 {
3606 NODE indi=0;
3607 CACHEEL cel=0;
3608 PVALUE val = eval_and_coerce(PINDI, expr, stab, eflg);
3609
3610 if (*eflg || !val) {
3611 if (val) {
3612 if (pval) {
3613 *pval = val;
3614 /* now caller owns val */
3615 } else {
3616 delete_pvalue(val);
3617 val=NULL;
3618 }
3619 }
3620 return NULL;
3621 }
3622 cel = pvalue_to_cel(val);
3623 delete_pvalue(val);
3624 if (!cel) return NULL;
3625 indi = cacheel_to_node(cel);
3626 if (nestr("INDI", ntag(indi))) {
3627 *eflg = TRUE;
3628 return NULL;
3629 }
3630 if (pcel) *pcel = cel;
3631 return indi;
3632 }
3633 /*======================================+
3634 * eval_fam -- Evaluate family expression
3635 *=====================================*/
3636 NODE
eval_fam(PNODE expr,SYMTAB stab,BOOLEAN * eflg,CACHEEL * pcel)3637 eval_fam (PNODE expr, SYMTAB stab, BOOLEAN *eflg, CACHEEL *pcel)
3638 {
3639 NODE fam=0;
3640 CACHEEL cel=0;
3641 PVALUE val = eval_and_coerce(PFAM, expr, stab, eflg);
3642 if (*eflg || !val) return NULL;
3643 cel = pvalue_to_cel(val);
3644 delete_pvalue(val);
3645 if (!cel) return NULL;
3646 fam = cacheel_to_node(cel);
3647 if (nestr("FAM", ntag(fam))) {
3648 *eflg = TRUE;
3649 return NULL;
3650 }
3651 if (pcel) *pcel = cel;
3652 return fam;
3653 }
3654 /*=================================================+
3655 * llrpt_free -- free up data associated with a variable
3656 * usage: free(IDEN]) --> VOID
3657 *=======================================*/
3658 PVALUE
llrpt_free(PNODE node,SYMTAB stab,BOOLEAN * eflg)3659 llrpt_free (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3660 {
3661 PNODE argvar = builtin_args(node);
3662 BOOLEAN there;
3663 PVALUE val=0;
3664 if (!iistype(argvar, IIDENT)) {
3665 prog_error(node, "arg to free must be a variable");
3666 *eflg = TRUE;
3667 return NULL;
3668 }
3669 val = symtab_valueofbool(stab, iident_name(argvar), &there);
3670 if (!there) {
3671 val = symtab_valueofbool(globtab, iident_name(argvar), &there);
3672 }
3673 if (there && val) {
3674 clear_pvalue(val);
3675 val->type = PNULL;
3676 val->value.pxd = 0;
3677 }
3678 return NULL;
3679 }
3680 /*=============================================+
3681 * llrpt_float -- Converts a NUMBER to a FLOAT
3682 * usage: float(NUMBER) -> FLOAT
3683 *============================================*/
3684 PVALUE
llrpt_float(PNODE node,SYMTAB stab,BOOLEAN * eflg)3685 llrpt_float (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3686 {
3687 PNODE argvar = builtin_args(node);
3688 PVALUE val = eval_and_coerce(PFLOAT, argvar, stab, eflg);
3689 if (*eflg) {
3690 prog_var_error(node, stab, argvar, val, nonflox, "f", "1");
3691 delete_pvalue(val);
3692 return NULL;
3693 }
3694 return val;
3695 }
3696 /*=============================================+
3697 * llrpt_int -- Converts a NUMBER to an INT
3698 * usage: int(NUMBER) -> INT
3699 *============================================*/
3700 PVALUE
llrpt_int(PNODE node,SYMTAB stab,BOOLEAN * eflg)3701 llrpt_int (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3702 {
3703 PNODE argvar = builtin_args(node);
3704 PVALUE val = eval_and_coerce(PINT, argvar, stab, eflg);
3705 if (*eflg) {
3706 prog_var_error(node, stab, argvar, val, nonflox, "f", "1");
3707 return NULL;
3708 }
3709 return val;
3710 }
3711 /*=============================================+
3712 * llrpt_test -- Perform tests on a file or
3713 * directory parameter.
3714 * usage: test(STRING, STRING) -> BOOL
3715 *============================================*/
3716 PVALUE
llrpt_test(PNODE node,SYMTAB stab,BOOLEAN * eflg)3717 llrpt_test (PNODE node, SYMTAB stab, BOOLEAN *eflg)
3718 {
3719 PNODE arg1=0, arg2=0;
3720 PVALUE arg1val=0, arg2val=0, val = NULL;
3721 STRING arg1str=0, arg2str=0;
3722 struct stat statdata;
3723 int rc;
3724
3725 arg1 = builtin_args(node);
3726 arg1val = eval_and_coerce(PSTRING, arg1, stab, eflg);
3727 if (*eflg) {
3728 prog_var_error(node, stab, arg1, arg1val, nonstrx, "test", "1");
3729 goto end_test;
3730 }
3731 arg1str = pvalue_to_string(arg1val);
3732
3733 arg2 = (PNODE) inext(arg1);
3734 arg2val = eval_and_coerce(PSTRING, arg2, stab, eflg);
3735 if (*eflg) {
3736 prog_var_error(node, stab, arg2, arg2val, nonstrx, "test", "2");
3737 goto end_test;
3738 }
3739 arg2str = pvalue_to_string(arg2val);
3740
3741 if (arg1str == 0 ) {
3742 prog_var_error(node, stab, arg1, arg1val, nonstrx, "test", "1");
3743 goto end_test;
3744 }
3745 if (arg2str == 0 ) {
3746 prog_var_error(node, stab, arg2, arg2val, nonstrx, "test", "2");
3747 goto end_test;
3748 }
3749
3750 rc = stat(arg2str, &statdata);
3751 if (rc) {
3752 val = create_pvalue_from_bool(FALSE);
3753 goto end_test;
3754 }
3755
3756 if (eqstr(arg1str,"r")) {
3757 if (access(arg2str,R_OK)==0)
3758 val = create_pvalue_from_bool(TRUE);
3759
3760 } else if (eqstr(arg1str,"w")) {
3761 if (access(arg2str,W_OK)==0)
3762 val = create_pvalue_from_bool(TRUE);
3763
3764 } else if (eqstr(arg1str,"e")) {
3765 val = create_pvalue_from_bool(TRUE);
3766
3767 } else if (eqstr(arg1str,"z")) {
3768 if (statdata.st_size == 0)
3769 val = create_pvalue_from_bool(TRUE);
3770
3771 } else if (eqstr(arg1str,"s")) {
3772 if (statdata.st_size != 0)
3773 val = create_pvalue_from_bool(TRUE);
3774
3775 } else if (eqstr(arg1str,"f")) {
3776 if ((statdata.st_mode & S_IFMT) & S_IFREG)
3777 val = create_pvalue_from_bool(TRUE);
3778
3779 } else if (eqstr(arg1str,"d")) {
3780 if ((statdata.st_mode & S_IFMT) & S_IFDIR)
3781 val = create_pvalue_from_bool(TRUE);
3782 } else {
3783 prog_var_error(node, stab, arg1, arg1val, badargx, "test", "1");
3784 goto end_test;
3785 }
3786
3787 end_test:
3788 if (val == NULL)
3789 val = create_pvalue_from_bool(FALSE);
3790 if (arg1val) delete_pvalue(arg1val);
3791 if (arg2val) delete_pvalue(arg2val);
3792 return val;
3793 }
3794