1 /*
2 * gretl -- Gnu Regression, Econometrics and Time-series Library
3 * Copyright (C) 2001 Allin Cottrell and Riccardo "Jack" Lucchetti
4 *
5 * This program is free software: you can redistribute it and/or modify
6 * it under the terms of the GNU General Public License as published by
7 * the Free Software Foundation, either version 3 of the License, or
8 * (at your option) any later version.
9 *
10 * This program is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 * GNU General Public License for more details.
14 *
15 * You should have received a copy of the GNU General Public License
16 * along with this program. If not, see <http://www.gnu.org/licenses/>.
17 *
18 */
19
20 #define FULL_XML_HEADERS 1
21
22 #include "libgretl.h"
23 #include "gretl_func.h"
24 #include "uservar.h"
25 #include "gretl_mt.h"
26 #include "gretl_xml.h"
27 #include "gretl_foreign.h"
28 #include "gretl_typemap.h"
29 #include "genparse.h"
30 #include "kalman.h"
31 #include "var.h"
32 #include "system.h"
33 #include "matrix_extra.h"
34 #include "gretl_array.h"
35 #include "gretl_bundle.h"
36
37 #define BDEBUG 0
38
39 /**
40 * gretl_bundle:
41 *
42 * An opaque type; use the relevant accessor functions.
43 */
44
45 struct gretl_bundle_ {
46 BundleType type; /* see enum in gretl_bundle.h */
47 GHashTable *ht; /* holds key/value pairs */
48 char *creator; /* name of function that built the bundle */
49 void *data; /* holds pointer to struct for some uses */
50 };
51
52 /**
53 * bundled_item:
54 *
55 * An item of data within a gretl_bundle. This is an
56 * opaque type; use the relevant accessor functions.
57 */
58
59 struct bundled_item_ {
60 GretlType type;
61 int size;
62 gpointer data;
63 char *note;
64 char *name; /* pointer to associated key */
65 };
66
67 static gretl_bundle *sysinfo_bundle;
68
69 static int real_bundle_set_data (gretl_bundle *b, const char *key,
70 void *ptr, GretlType type,
71 int size, int copy,
72 const char *note);
73
gretl_bundle_is_stacked(gretl_bundle * b)74 int gretl_bundle_is_stacked (gretl_bundle *b)
75 {
76 user_var *u = get_user_var_by_data(b);
77
78 return u != NULL;
79 }
80
81 /* gets the number of keys in the bundle's hash table */
82
gretl_bundle_get_n_keys(gretl_bundle * b)83 int gretl_bundle_get_n_keys (gretl_bundle *b)
84 {
85 int n_items = 0;
86
87 if (b != NULL && b->ht != NULL) {
88 n_items = g_hash_table_size(b->ht);
89 }
90
91 return n_items;
92 }
93
94 /* gets total number of members including any "special"
95 contents outside of the hash table */
96
gretl_bundle_get_n_members(gretl_bundle * b)97 int gretl_bundle_get_n_members (gretl_bundle *b)
98 {
99 int nmemb = 0;
100
101 if (b != NULL) {
102 if (b->type == BUNDLE_KALMAN) {
103 nmemb += kalman_bundle_n_members(b);
104 }
105 if (b->ht != NULL) {
106 nmemb += g_hash_table_size(b->ht);
107 }
108 }
109
110 return nmemb;
111 }
112
maybe_append_list(gpointer key,gpointer value,gpointer p)113 static void maybe_append_list (gpointer key, gpointer value, gpointer p)
114 {
115 bundled_item *item = (bundled_item *) value;
116 GList **plist = (GList **) p;
117
118 if (item->type == GRETL_TYPE_LIST) {
119 *plist = g_list_append(*plist, item->data);
120 }
121 }
122
123 /* If bundle @b contains any members of type list, compose
124 and return a GList that contains all of them.
125 */
126
gretl_bundle_get_lists(gretl_bundle * b)127 GList *gretl_bundle_get_lists (gretl_bundle *b)
128 {
129 GList *list = NULL;
130
131 g_hash_table_foreach(b->ht, maybe_append_list, &list);
132
133 return list;
134 }
135
gretl_bundle_has_content(gretl_bundle * b)136 int gretl_bundle_has_content (gretl_bundle *b)
137 {
138 int ret = 0;
139
140 if (b != NULL && b->ht != NULL &&
141 (b->type == BUNDLE_KALMAN ||
142 g_hash_table_size(b->ht) > 0)) {
143 ret = 1;
144 }
145
146 return ret;
147 }
148
type_can_be_bundled(GretlType type)149 int type_can_be_bundled (GretlType type)
150 {
151 if (type == GRETL_TYPE_INT ||
152 type == GRETL_TYPE_UNSIGNED ||
153 type == GRETL_TYPE_BOOL) {
154 type = GRETL_TYPE_DOUBLE;
155 }
156
157 return (type == GRETL_TYPE_DOUBLE ||
158 type == GRETL_TYPE_STRING ||
159 type == GRETL_TYPE_MATRIX ||
160 type == GRETL_TYPE_SERIES ||
161 type == GRETL_TYPE_BUNDLE ||
162 type == GRETL_TYPE_ARRAY ||
163 type == GRETL_TYPE_LIST);
164 }
165
166 #define bundled_scalar(t) (t == GRETL_TYPE_DOUBLE || \
167 t == GRETL_TYPE_INT || \
168 t == GRETL_TYPE_UNSIGNED)
169
bundled_item_copy_in_data(bundled_item * item,void * ptr,int size)170 static int bundled_item_copy_in_data (bundled_item *item,
171 void *ptr, int size)
172 {
173 int err = 0;
174
175 switch (item->type) {
176 case GRETL_TYPE_DOUBLE:
177 item->data = malloc(sizeof(double));
178 if (item->data != NULL) {
179 double *dp = item->data;
180
181 *dp = *(double *) ptr;
182 }
183 break;
184 case GRETL_TYPE_INT:
185 item->data = malloc(sizeof(int));
186 if (item->data != NULL) {
187 int *ip = item->data;
188
189 *ip = *(int *) ptr;
190 }
191 break;
192 case GRETL_TYPE_UNSIGNED:
193 item->data = malloc(sizeof(unsigned int));
194 if (item->data != NULL) {
195 unsigned int *up = item->data;
196
197 *up = *(unsigned int *) ptr;
198 }
199 break;
200 case GRETL_TYPE_STRING:
201 item->data = gretl_strdup((char *) ptr);
202 break;
203 case GRETL_TYPE_MATRIX:
204 item->data = gretl_matrix_copy((gretl_matrix *) ptr);
205 break;
206 case GRETL_TYPE_SERIES:
207 item->data = copyvec((const double *) ptr, size);
208 item->size = size;
209 break;
210 case GRETL_TYPE_LIST:
211 item->data = gretl_list_copy((const int *) ptr);
212 break;
213 case GRETL_TYPE_BUNDLE:
214 item->data = gretl_bundle_copy((gretl_bundle *) ptr, &err);
215 break;
216 case GRETL_TYPE_ARRAY:
217 item->data = gretl_array_copy((gretl_array *) ptr, &err);
218 break;
219 default:
220 err = E_TYPES;
221 break;
222 }
223
224 if (!err && item->data == NULL) {
225 err = E_ALLOC;
226 }
227
228 return err;
229 }
230
231 /* allocate and fill out a 'value' (type plus data pointer) that will
232 be inserted into a bundle's hash table */
233
bundled_item_new(GretlType type,void * ptr,int size,int copy,const char * note,int * err)234 static bundled_item *bundled_item_new (GretlType type, void *ptr,
235 int size, int copy,
236 const char *note,
237 int *err)
238 {
239 bundled_item *item = malloc(sizeof *item);
240
241 if (item == NULL) {
242 *err = E_ALLOC;
243 return NULL;
244 }
245
246 item->type = type;
247 item->size = 0;
248 item->name = NULL;
249 item->note = NULL;
250
251 if (!copy && !bundled_scalar(item->type)) {
252 item->data = ptr;
253 if (item->type == GRETL_TYPE_SERIES) {
254 item->size = size;
255 }
256 } else {
257 *err = bundled_item_copy_in_data(item, ptr, size);
258 if (*err) {
259 free(item);
260 item = NULL;
261 }
262 }
263
264 if (item != NULL && note != NULL) {
265 item->note = gretl_strdup(note);
266 }
267
268 return item;
269 }
270
bundled_item_free_data(GretlType type,void * data)271 static void bundled_item_free_data (GretlType type, void *data)
272 {
273 if (type == GRETL_TYPE_MATRIX) {
274 gretl_matrix_free((gretl_matrix *) data);
275 } else if (type == GRETL_TYPE_BUNDLE) {
276 gretl_bundle_destroy((gretl_bundle *) data);
277 } else if (type == GRETL_TYPE_ARRAY) {
278 gretl_array_destroy((gretl_array *) data);
279 } else {
280 free(data);
281 }
282 }
283
284 /* note: we come here only if the replacement type is the
285 same as the original type
286 */
287
bundled_item_replace_data(bundled_item * item,void * ptr,int size,int copy)288 static int bundled_item_replace_data (bundled_item *item,
289 void *ptr, int size,
290 int copy)
291 {
292 int err = 0;
293
294 if (ptr == item->data) {
295 return 0;
296 }
297
298 if (bundled_scalar(item->type)) {
299 /* storage is already available */
300 if (item->type == GRETL_TYPE_DOUBLE) {
301 double *dp = item->data;
302
303 *dp = *(double *) ptr;
304 } else if (item->type == GRETL_TYPE_INT) {
305 int *ip = item->data;
306
307 *ip = *(int *) ptr;
308 } else if (item->type == GRETL_TYPE_UNSIGNED) {
309 unsigned int *up = item->data;
310
311 *up = *(unsigned int *) ptr;
312 }
313 } else {
314 /* free then copy or donate */
315 bundled_item_free_data(item->type, item->data);
316 if (copy) {
317 err = bundled_item_copy_in_data(item, ptr, size);
318 } else {
319 item->data = ptr;
320 }
321 }
322
323 if (!err && item->data == NULL) {
324 err = E_ALLOC;
325 }
326
327 if (item->note != NULL) {
328 free(item->note);
329 item->note = NULL;
330 }
331
332 return err;
333 }
334
335 /* callback invoked when a bundle's hash table is destroyed */
336
bundle_item_destroy(gpointer data)337 static void bundle_item_destroy (gpointer data)
338 {
339 bundled_item *item = data;
340
341 #if BDEBUG
342 fprintf(stderr, "bundled_item_destroy: %s\t'%s'\tdata %p\n",
343 gretl_type_get_name(item->type), item->name, (void *) item->data);
344 if (item->type == GRETL_TYPE_STRING) {
345 fprintf(stderr, " string: '%s'\n", (char *) item->data);
346 }
347 #endif
348
349 bundled_item_free_data(item->type, item->data);
350 g_free(item->name);
351 free(item->note);
352 free(item);
353 }
354
355 /**
356 * gretl_bundle_destroy:
357 * @bundle: bundle to destroy.
358 *
359 * Frees all contents of @bundle as well as the pointer itself.
360 */
361
gretl_bundle_destroy(gretl_bundle * bundle)362 void gretl_bundle_destroy (gretl_bundle *bundle)
363 {
364 if (bundle != NULL) {
365 if (bundle->ht != NULL) {
366 g_hash_table_destroy(bundle->ht);
367 }
368 free(bundle->creator);
369 if (bundle->type == BUNDLE_KALMAN) {
370 kalman_free(bundle->data);
371 }
372 free(bundle);
373 }
374 }
375
376 /**
377 * gretl_bundle_void_content:
378 * @bundle: target bundle.
379 *
380 * Frees all contents of @bundle.
381 */
382
gretl_bundle_void_content(gretl_bundle * bundle)383 void gretl_bundle_void_content (gretl_bundle *bundle)
384 {
385 if (bundle == NULL) {
386 return;
387 }
388
389 if (bundle->creator != NULL) {
390 free(bundle->creator);
391 bundle->creator = NULL;
392 }
393
394 if (bundle->ht != NULL && g_hash_table_size(bundle->ht) > 0) {
395 g_hash_table_destroy(bundle->ht);
396 bundle->ht = g_hash_table_new_full(g_str_hash, g_str_equal,
397 NULL, bundle_item_destroy);
398 }
399
400 if (bundle->type == BUNDLE_KALMAN) {
401 kalman_free(bundle->data);
402 bundle->data = NULL;
403 bundle->type = BUNDLE_PLAIN;
404 }
405 }
406
407 /**
408 * gretl_bundle_new:
409 *
410 * Returns: a newly allocated, empty gretl bundle.
411 */
412
gretl_bundle_new(void)413 gretl_bundle *gretl_bundle_new (void)
414 {
415 gretl_bundle *b = malloc(sizeof *b);
416
417 if (b != NULL) {
418 b->type = BUNDLE_PLAIN;
419 b->ht = g_hash_table_new_full(g_str_hash, g_str_equal,
420 NULL, bundle_item_destroy);
421 b->creator = NULL;
422 b->data = NULL;
423 }
424
425 return b;
426 }
427
428 /* Determine whether @name is the name of a saved bundle. */
429
gretl_is_bundle(const char * name)430 int gretl_is_bundle (const char *name)
431 {
432 return get_user_var_of_type_by_name(name, GRETL_TYPE_BUNDLE) != NULL;
433 }
434
435 /**
436 * get_bundle_by_name:
437 * @name: the name to look up.
438 *
439 * Returns: pointer to a saved bundle, if found, else NULL.
440 */
441
get_bundle_by_name(const char * name)442 gretl_bundle *get_bundle_by_name (const char *name)
443 {
444 gretl_bundle *b = NULL;
445
446 if (name != NULL && *name != '\0') {
447 user_var *u = get_user_var_of_type_by_name(name, GRETL_TYPE_BUNDLE);
448
449 if (u != NULL) {
450 b = user_var_get_value(u);
451 }
452 }
453
454 return b;
455 }
456
gretl_bundle_has_data(gretl_bundle * b,const char * key)457 static int gretl_bundle_has_data (gretl_bundle *b, const char *key)
458 {
459 gpointer p = g_hash_table_lookup(b->ht, key);
460
461 return (p != NULL);
462 }
463
464 /**
465 * gretl_bundle_get_data:
466 * @bundle: bundle to access.
467 * @key: name of key to access.
468 * @type: location to receive data type, or NULL.
469 * @size: location to receive size of data (= series
470 * length for GRETL_TYPE_SERIES, otherwise 0), or NULL.
471 * @err: location to receive error code, or NULL.
472 *
473 * Returns: the item pointer associated with @key in the
474 * specified @bundle, or NULL if there is no such item.
475 * If @err is non-NULL, its content is set to a non-zero
476 * value if @bundle contains no item with key @key. If
477 * the intent is simply to determine whether @bundle contains
478 * an item under the specified @key, @err should generally be
479 * left NULL.
480 *
481 * Note that the value returned is the actual data pointer from
482 * within the bundle, not a copy of the data; so the pointer
483 * must not be freed, and in general its content should not
484 * be modified.
485 */
486
gretl_bundle_get_data(gretl_bundle * bundle,const char * key,GretlType * type,int * size,int * err)487 void *gretl_bundle_get_data (gretl_bundle *bundle, const char *key,
488 GretlType *type, int *size, int *err)
489 {
490 void *ret = NULL;
491 int reserved = 0;
492 int myerr = 0;
493
494 if (bundle == NULL) {
495 myerr = E_DATA;
496 goto finish;
497 }
498
499 if (bundle->type == BUNDLE_KALMAN) {
500 ret = maybe_retrieve_kalman_element(bundle->data, key,
501 type, &reserved,
502 &myerr);
503 }
504
505 if (!myerr && ret == NULL && !reserved) {
506 gpointer p = g_hash_table_lookup(bundle->ht, key);
507
508 if (p != NULL) {
509 bundled_item *item = p;
510
511 ret = item->data;
512 if (type != NULL) {
513 *type = item->type;
514 }
515 if (size != NULL) {
516 *size = item->size;
517 }
518 } else {
519 if (err != NULL) {
520 gretl_errmsg_sprintf("\"%s\": %s", key, _("no such item"));
521 }
522 myerr = E_DATA;
523 }
524 }
525
526 finish:
527
528 if (err != NULL) {
529 *err = myerr;
530 }
531
532 return ret;
533 }
534
535 /**
536 * gretl_bundle_steal_data:
537 * @bundle: bundle to access.
538 * @key: name of key to access.
539 * @type: location to receive data type, or NULL.
540 * @size: location to receive size of data (= series
541 * length for GRETL_TYPE_SERIES, otherwise 0), or NULL.
542 * @err: location to receive error code, or NULL.
543 *
544 * Works like gretl_bundle_get_data() except that the data
545 * pointer in question is removed from @bundle before it is
546 * returned to the caller; so in effect the caller assumes
547 * ownership of the item.
548 *
549 * Returns: the item pointer associated with @key in the
550 * specified @bundle, or NULL if there is no such item.
551 */
552
gretl_bundle_steal_data(gretl_bundle * bundle,const char * key,GretlType * type,int * size,int * err)553 void *gretl_bundle_steal_data (gretl_bundle *bundle, const char *key,
554 GretlType *type, int *size, int *err)
555 {
556 void *ret = NULL;
557
558 if (bundle == NULL) {
559 if (err != NULL) {
560 *err = E_DATA;
561 }
562 } else {
563 gpointer p = g_hash_table_lookup(bundle->ht, key);
564
565 if (p != NULL) {
566 GList *keys = g_hash_table_get_keys(bundle->ht);
567 bundled_item *item = p;
568 gchar *keycpy = NULL;
569
570 ret = item->data;
571 if (type != NULL) {
572 *type = item->type;
573 }
574 if (size != NULL) {
575 *size = item->size;
576 }
577 while (keys) {
578 if (!strcmp(keys->data, key)) {
579 keycpy = keys->data;
580 break;
581 } else if (keys->next) {
582 keys = keys->next;
583 } else {
584 break;
585 }
586 }
587 g_hash_table_steal(bundle->ht, key);
588 g_free(keycpy);
589 g_list_free(keys);
590 free(item);
591 } else if (err != NULL) {
592 gretl_errmsg_sprintf("\"%s\": %s", key, _("no such item"));
593 *err = E_DATA;
594 }
595 }
596
597 return ret;
598 }
599
gretl_bundle_get_private_data(gretl_bundle * bundle)600 void *gretl_bundle_get_private_data (gretl_bundle *bundle)
601 {
602 return bundle->data;
603 }
604
gretl_bundle_get_type(gretl_bundle * bundle)605 BundleType gretl_bundle_get_type (gretl_bundle *bundle)
606 {
607 return bundle->type;
608 }
609
610 /**
611 * gretl_bundle_get_member_type:
612 * @bundle: bundle to access.
613 * @key: name of key to access.
614 * @err:location to receive error code, or NULL.
615 *
616 * Returns: the data type associated with @key in the
617 * specified @bundle, or 0 on failure. Set the @err
618 * argument to NULL if you do not want an error flagged
619 * in case there's no such key in @bundle.
620 */
621
gretl_bundle_get_member_type(gretl_bundle * bundle,const char * key,int * err)622 GretlType gretl_bundle_get_member_type (gretl_bundle *bundle,
623 const char *key,
624 int *err)
625 {
626 GretlType ret = GRETL_TYPE_NONE;
627 int reserved = 0;
628 int myerr = 0;
629
630 if (bundle == NULL) {
631 myerr = E_DATA;
632 } else if (bundle->type == BUNDLE_KALMAN) {
633 maybe_retrieve_kalman_element(bundle->data, key,
634 &ret, &reserved,
635 &myerr);
636 }
637
638 if (!myerr && ret == GRETL_TYPE_NONE && !reserved) {
639 gpointer p = g_hash_table_lookup(bundle->ht, key);
640
641 if (p != NULL) {
642 bundled_item *item = p;
643
644 ret = item->type;
645 } else if (err != NULL) {
646 gretl_errmsg_sprintf("\"%s\": %s", key, _("no such item"));
647 myerr = E_DATA;
648 }
649 }
650
651 if (err != NULL) {
652 *err = myerr;
653 }
654
655 return ret;
656 }
657
658 /**
659 * gretl_bundle_has_key:
660 * @bundle: bundle to access.
661 * @key: name of key to test.
662 *
663 * Returns: 1 if there is an item under the given @key in the
664 * specified @bundle, 0 otherwise.
665 */
666
gretl_bundle_has_key(gretl_bundle * bundle,const char * key)667 int gretl_bundle_has_key (gretl_bundle *bundle,
668 const char *key)
669 {
670 int ret = 0;
671
672 if (bundle != NULL && key != NULL) {
673 gpointer p = g_hash_table_lookup(bundle->ht, key);
674
675 ret = (p != NULL);
676 }
677
678 return ret;
679 }
680
681 /**
682 * gretl_bundle_get_matrix:
683 * @bundle: bundle to access.
684 * @key: name of key to access.
685 * @err: location to receive error code.
686 *
687 * Returns: the matrix associated with @key in the
688 * specified @bundle, if any; otherwise NULL.
689 */
690
gretl_bundle_get_matrix(gretl_bundle * bundle,const char * key,int * err)691 gretl_matrix *gretl_bundle_get_matrix (gretl_bundle *bundle,
692 const char *key,
693 int *err)
694 {
695 gretl_matrix *m = NULL;
696 GretlType type;
697 void *ptr;
698 int myerr = 0;
699
700 ptr = gretl_bundle_get_data(bundle, key, &type, NULL, err);
701
702 if (ptr != NULL && type != GRETL_TYPE_MATRIX) {
703 myerr = E_TYPES;
704 }
705
706 if (ptr != NULL && !myerr) {
707 m = (gretl_matrix *) ptr;
708 }
709
710 if (err != NULL) {
711 *err = myerr;
712 }
713
714 return m;
715 }
716
717 /**
718 * gretl_bundle_get_array:
719 * @bundle: bundle to access.
720 * @key: name of key to access.
721 * @err: location to receive error code.
722 *
723 * Returns: the array associated with @key in the
724 * specified @bundle, if any; otherwise NULL.
725 */
726
gretl_bundle_get_array(gretl_bundle * bundle,const char * key,int * err)727 gretl_array *gretl_bundle_get_array (gretl_bundle *bundle,
728 const char *key,
729 int *err)
730 {
731 gretl_array *a = NULL;
732 GretlType type;
733 void *ptr;
734 int myerr = 0;
735
736 ptr = gretl_bundle_get_data(bundle, key, &type, NULL, err);
737 if (ptr != NULL && type != GRETL_TYPE_ARRAY) {
738 myerr = E_TYPES;
739 }
740
741 if (ptr != NULL && !myerr) {
742 a = (gretl_array *) ptr;
743 }
744
745 if (err != NULL) {
746 *err = myerr;
747 }
748
749 return a;
750 }
751
752 /**
753 * gretl_bundle_get_bundle:
754 * @bundle: bundle to access.
755 * @key: name of key to access.
756 * @err: location to receive error code.
757 *
758 * Returns: the bundle associated with @key in the
759 * specified @bundle, if any; otherwise NULL.
760 */
761
gretl_bundle_get_bundle(gretl_bundle * bundle,const char * key,int * err)762 gretl_bundle *gretl_bundle_get_bundle (gretl_bundle *bundle,
763 const char *key,
764 int *err)
765 {
766 gretl_bundle *ret = NULL;
767 GretlType type;
768 void *ptr;
769 int myerr = 0;
770
771 ptr = gretl_bundle_get_data(bundle, key, &type, NULL, err);
772 if (ptr != NULL && type != GRETL_TYPE_BUNDLE) {
773 myerr = E_TYPES;
774 }
775
776 if (ptr != NULL && !myerr) {
777 ret = (gretl_bundle *) ptr;
778 }
779
780 if (err != NULL) {
781 *err = myerr;
782 }
783
784 return ret;
785 }
786
787 /**
788 * gretl_bundle_get_series:
789 * @bundle: bundle to access.
790 * @key: name of key to access.
791 * @n: location to receive length of series.
792 * @err: location to receive error code.
793 *
794 * Returns: the series associated with @key in the
795 * specified @bundle, if any; otherwise NULL.
796 */
797
gretl_bundle_get_series(gretl_bundle * bundle,const char * key,int * n,int * err)798 double *gretl_bundle_get_series (gretl_bundle *bundle,
799 const char *key,
800 int *n, int *err)
801 {
802 double *x = NULL;
803 GretlType type;
804 void *ptr;
805 int myerr = 0;
806
807 ptr = gretl_bundle_get_data(bundle, key, &type, n, err);
808 if (ptr != NULL && type != GRETL_TYPE_SERIES) {
809 myerr = E_TYPES;
810 }
811
812 if (ptr != NULL && !myerr) {
813 x = (double *) ptr;
814 }
815
816 if (err != NULL) {
817 *err = myerr;
818 }
819
820 return x;
821 }
822
823 /**
824 * gretl_bundle_get_list:
825 * @bundle: bundle to access.
826 * @key: name of key to access.
827 * @err: location to receive error code.
828 *
829 * Returns: the list associated with @key in the
830 * specified @bundle, if any; otherwise NULL.
831 */
832
gretl_bundle_get_list(gretl_bundle * bundle,const char * key,int * err)833 int *gretl_bundle_get_list (gretl_bundle *bundle,
834 const char *key,
835 int *err)
836 {
837 int *list = NULL;
838 GretlType type;
839 void *ptr;
840 int myerr = 0;
841
842 ptr = gretl_bundle_get_data(bundle, key, &type, NULL, err);
843 if (ptr != NULL && type != GRETL_TYPE_LIST) {
844 myerr = E_TYPES;
845 }
846
847 if (ptr != NULL && !myerr) {
848 list = (int *) ptr;
849 }
850
851 if (err != NULL) {
852 *err = myerr;
853 }
854
855 return list;
856 }
857
858 /**
859 * gretl_bundle_get_scalar:
860 * @bundle: bundle to access.
861 * @key: name of key to access.
862 * @err: location to receive error code, or NULL.
863 *
864 * Returns: the scalar value associated with @key in the
865 * specified @bundle, if any; otherwise #NADBL.
866 */
867
gretl_bundle_get_scalar(gretl_bundle * bundle,const char * key,int * err)868 double gretl_bundle_get_scalar (gretl_bundle *bundle,
869 const char *key,
870 int *err)
871 {
872 double x = NADBL;
873 GretlType type;
874 void *ptr;
875 int myerr = 0;
876
877 ptr = gretl_bundle_get_data(bundle, key, &type, NULL, err);
878
879 if (ptr == NULL) {
880 myerr = E_DATA;
881 } else if (type != GRETL_TYPE_DOUBLE &&
882 type != GRETL_TYPE_INT &&
883 type != GRETL_TYPE_UNSIGNED &&
884 type != GRETL_TYPE_MATRIX) {
885 myerr = E_TYPES;
886 }
887
888 if (ptr != NULL && !myerr) {
889 if (type == GRETL_TYPE_DOUBLE) {
890 double *px = (double *) ptr;
891
892 x = *px;
893 } else if (type == GRETL_TYPE_INT) {
894 int *pi = (int *) ptr;
895
896 x = (double) *pi;
897 } else if (type == GRETL_TYPE_UNSIGNED) {
898 unsigned int *pu = (unsigned int *) ptr;
899
900 x = (double) *pu;
901 } else {
902 /* must be a matrix */
903 gretl_matrix *m = ptr;
904
905 if (gretl_matrix_is_scalar(m)) {
906 x = m->val[0];
907 } else {
908 myerr = E_TYPES;
909 }
910 }
911 }
912
913 if (err != NULL) {
914 *err = myerr;
915 }
916
917 return x;
918 }
919
920 /**
921 * gretl_bundle_get_int:
922 * @bundle: bundle to access.
923 * @key: name of key to access.
924 * @err: location to receive error code.
925 *
926 * Returns: the integer value associated with @key in the
927 * specified @bundle, if any; otherwise 0.
928 */
929
gretl_bundle_get_int(gretl_bundle * bundle,const char * key,int * err)930 int gretl_bundle_get_int (gretl_bundle *bundle,
931 const char *key,
932 int *err)
933 {
934 int i = 0;
935 GretlType type;
936 void *ptr;
937 int myerr = 0;
938
939 ptr = gretl_bundle_get_data(bundle, key, &type, NULL, err);
940
941 if (ptr != NULL) {
942 if (type == GRETL_TYPE_INT) {
943 int *pi = (int *) ptr;
944
945 i = *pi;
946 } else if (type == GRETL_TYPE_UNSIGNED) {
947 unsigned int u, *pu = (unsigned int *) ptr;
948
949 u = *pu;
950 if (u <= INT_MAX) {
951 i = (int) u;
952 } else {
953 myerr = E_TYPES;
954 }
955 } else if (type == GRETL_TYPE_DOUBLE) {
956 double x, *px = (double *) ptr;
957
958 x = *px;
959 if (x >= INT_MIN && x <= INT_MAX && x == floor(x)) {
960 i = (int) x;
961 } else {
962 myerr = E_TYPES;
963 }
964 } else {
965 myerr = E_TYPES;
966 }
967 }
968
969 if (err != NULL) {
970 *err = myerr;
971 }
972
973 return i;
974 }
975
976 /**
977 * gretl_bundle_get_int_deflt:
978 * @bundle: bundle to access.
979 * @key: name of key to access.
980 * @deflt: default integer value.
981 *
982 * Returns: the integer value associated with @key in the
983 * specified @bundle, if any; otherwise @deflt.
984 */
985
gretl_bundle_get_int_deflt(gretl_bundle * bundle,const char * key,int deflt)986 int gretl_bundle_get_int_deflt (gretl_bundle *bundle,
987 const char *key,
988 int deflt)
989 {
990 int val = deflt;
991 GretlType type;
992 void *ptr;
993
994 ptr = gretl_bundle_get_data(bundle, key, &type, NULL, NULL);
995
996 if (ptr != NULL) {
997 if (type == GRETL_TYPE_INT) {
998 int *pi = (int *) ptr;
999
1000 val = *pi;
1001 } else if (type == GRETL_TYPE_UNSIGNED) {
1002 unsigned int *pu = (unsigned int *) ptr;
1003
1004 val = (int) *pu;
1005 } else if (type == GRETL_TYPE_DOUBLE) {
1006 double *px = (double *) ptr;
1007
1008 val = (int) *px;
1009 }
1010 }
1011
1012 return val;
1013 }
1014
1015 /**
1016 * gretl_bundle_get_bool:
1017 * @bundle: bundle to access.
1018 * @key: name of key to access, if present.
1019 * @deflt: default boolean value.
1020 *
1021 * Returns: the boolean value associated with @key in the
1022 * specified @bundle, if any; otherwise @deflt.
1023 */
1024
gretl_bundle_get_bool(gretl_bundle * bundle,const char * key,int deflt)1025 int gretl_bundle_get_bool (gretl_bundle *bundle,
1026 const char *key,
1027 int deflt)
1028 {
1029 int val = deflt;
1030 GretlType type;
1031 void *ptr;
1032
1033 ptr = gretl_bundle_get_data(bundle, key, &type, NULL, NULL);
1034
1035 if (ptr != NULL) {
1036 if (type == GRETL_TYPE_INT) {
1037 int *pi = (int *) ptr;
1038
1039 val = (*pi != 0);
1040 } else if (type == GRETL_TYPE_UNSIGNED) {
1041 unsigned int *pu = (unsigned int *) ptr;
1042
1043 val = (*pu != 0);
1044 } else if (type == GRETL_TYPE_DOUBLE) {
1045 double *px = (double *) ptr;
1046
1047 val = (*px != 0);
1048 }
1049 }
1050
1051 return val;
1052 }
1053
1054 /**
1055 * gretl_bundle_get_unsigned:
1056 * @bundle: bundle to access.
1057 * @key: name of key to access.
1058 * @err: location to receive error code.
1059 *
1060 * Returns: the unsigned integer value associated with @key in the
1061 * specified @bundle, if any; otherwise 0.
1062 */
1063
gretl_bundle_get_unsigned(gretl_bundle * bundle,const char * key,int * err)1064 unsigned int gretl_bundle_get_unsigned (gretl_bundle *bundle,
1065 const char *key,
1066 int *err)
1067 {
1068 unsigned int u = 0;
1069 GretlType type;
1070 void *ptr;
1071 int myerr = 0;
1072
1073 ptr = gretl_bundle_get_data(bundle, key, &type, NULL, err);
1074
1075 if (ptr != NULL) {
1076 if (type == GRETL_TYPE_UNSIGNED) {
1077 unsigned int *pu = (unsigned int *) ptr;
1078
1079 u = *pu;
1080 } else if (type == GRETL_TYPE_INT) {
1081 int i, *pi = (int *) ptr;
1082
1083 i = *pi;
1084 if (i >= 0) {
1085 u = (unsigned int) i;
1086 } else {
1087 myerr = E_TYPES;
1088 }
1089 } else if (type == GRETL_TYPE_DOUBLE) {
1090 double x, *px = (double *) ptr;
1091
1092 x = *px;
1093 if (x >= 0 && x <= UINT_MAX && x == floor(x)) {
1094 u = (unsigned int) x;
1095 } else {
1096 myerr = E_TYPES;
1097 }
1098 } else {
1099 myerr = E_TYPES;
1100 }
1101 }
1102
1103 if (err != NULL) {
1104 *err = myerr;
1105 }
1106
1107 return u;
1108 }
1109
1110 /**
1111 * gretl_bundle_get_string:
1112 * @bundle: bundle to access.
1113 * @key: name of key to access.
1114 * @err: location to receive error code.
1115 *
1116 * Returns: the string value associated with @key in the
1117 * specified @bundle, if any; otherwise NULL.
1118 */
1119
gretl_bundle_get_string(gretl_bundle * bundle,const char * key,int * err)1120 const char *gretl_bundle_get_string (gretl_bundle *bundle,
1121 const char *key,
1122 int *err)
1123 {
1124 const char *ret = NULL;
1125 GretlType type;
1126 void *ptr;
1127 int myerr = 0;
1128
1129 ptr = gretl_bundle_get_data(bundle, key, &type, NULL, err);
1130 if (ptr != NULL && type != GRETL_TYPE_STRING) {
1131 myerr = E_TYPES;
1132 }
1133
1134 if (ptr != NULL && !myerr) {
1135 ret = (const char *) ptr;
1136 }
1137
1138 if (err != NULL) {
1139 *err = myerr;
1140 }
1141
1142 return ret;
1143 }
1144
1145 /**
1146 * gretl_bundle_get_note:
1147 * @bundle: bundle to access.
1148 * @key: name of key to access.
1149 *
1150 * Returns: the note associated with @key in the
1151 * specified @bundle, if any; otherwise NULL.
1152 */
1153
gretl_bundle_get_note(gretl_bundle * bundle,const char * key)1154 const char *gretl_bundle_get_note (gretl_bundle *bundle,
1155 const char *key)
1156 {
1157 const char *ret = NULL;
1158
1159 if (bundle != NULL) {
1160 gpointer p = g_hash_table_lookup(bundle->ht, key);
1161
1162 if (p != NULL) {
1163 bundled_item *item = p;
1164
1165 ret = item->note;
1166 }
1167 }
1168
1169 return ret;
1170 }
1171
1172 /**
1173 * gretl_bundle_get_creator:
1174 * @bundle: bundle to access.
1175 *
1176 * Returns: the name of the package that created @bundle, if any,
1177 * otherwise NULL.
1178 */
1179
gretl_bundle_get_creator(gretl_bundle * bundle)1180 const char *gretl_bundle_get_creator (gretl_bundle *bundle)
1181 {
1182 return (bundle != NULL)? bundle->creator : NULL;
1183 }
1184
1185 /**
1186 * bundled_item_get_data:
1187 * @item: bundled item to access.
1188 * @type: location to receive data type.
1189 * @size: location to receive size of data (= series
1190 * length for GRETL_TYPE_SERIES, otherwise 0).
1191 *
1192 * Returns: the data pointer associated with @item, or
1193 * NULL on failure.
1194 */
1195
bundled_item_get_data(bundled_item * item,GretlType * type,int * size)1196 void *bundled_item_get_data (bundled_item *item, GretlType *type,
1197 int *size)
1198 {
1199 *type = item->type;
1200
1201 if (size != NULL) {
1202 *size = item->size;
1203 }
1204
1205 return item->data;
1206 }
1207
1208 /**
1209 * bundled_item_get_key:
1210 * @item: bundled item.
1211 *
1212 * Returns: the key associated with @item.
1213 */
1214
bundled_item_get_key(bundled_item * item)1215 const char *bundled_item_get_key (bundled_item *item)
1216 {
1217 return item->name;
1218 }
1219
1220 /**
1221 * bundled_item_get_note:
1222 * @item: bundled item.
1223 *
1224 * Returns: the note string associated with @item, if any,
1225 * otherwise NULL.
1226 */
1227
bundled_item_get_note(bundled_item * item)1228 const char *bundled_item_get_note (bundled_item *item)
1229 {
1230 return item->note;
1231 }
1232
1233 /**
1234 * gretl_bundle_get_content:
1235 * @bundle: bundle to access.
1236 *
1237 * Returns: the content of @bundle, which is in fact
1238 * a GHashTable object.
1239 */
1240
gretl_bundle_get_content(gretl_bundle * bundle)1241 void *gretl_bundle_get_content (gretl_bundle *bundle)
1242 {
1243 return (bundle == NULL)? NULL : (void *) bundle->ht;
1244 }
1245
1246 /**
1247 * gretl_bundles_swap_content:
1248 * @b1: first bundle.
1249 * @b2: second bundle.
1250 *
1251 * Exchanges the entire contents of the two bundles.
1252 *
1253 * Returns: 0 on success, error code on failure.
1254 */
1255
gretl_bundles_swap_content(gretl_bundle * b1,gretl_bundle * b2)1256 int gretl_bundles_swap_content (gretl_bundle *b1, gretl_bundle *b2)
1257 {
1258 if (b1 == NULL || b1->type != BUNDLE_PLAIN ||
1259 b2 == NULL || b2->type != BUNDLE_PLAIN) {
1260 return E_DATA;
1261 } else {
1262 void *tmp = b1->ht;
1263
1264 b1->ht = b2->ht;
1265 b2->ht = tmp;
1266 return 0;
1267 }
1268 }
1269
real_bundle_set_data(gretl_bundle * b,const char * key,void * ptr,GretlType type,int size,int copy,const char * note)1270 static int real_bundle_set_data (gretl_bundle *b, const char *key,
1271 void *ptr, GretlType type,
1272 int size, int copy,
1273 const char *note)
1274 {
1275 int err = 0, done = 0;
1276
1277 if (key == NULL || key[0] == '\0') {
1278 gretl_errmsg_sprintf("real_bundle_set_data: missing key string");
1279 return E_DATA;
1280 }
1281
1282 /* Should we restrict the length of bundle keys to that of
1283 regular gretl identifiers? That's what we were doing until
1284 July 2018, when we relaxed to support long keys coming
1285 from dbnomics sources.
1286 */
1287 #if 0
1288 if (strlen(key) >= VNAMELEN) {
1289 gretl_errmsg_sprintf("'%s': invalid key string", key);
1290 return E_DATA;
1291 }
1292 #endif
1293
1294 if (b->type == BUNDLE_KALMAN) {
1295 done = maybe_set_kalman_element(b->data, key,
1296 ptr, type, copy,
1297 &err);
1298 }
1299
1300 if (!done && !err) {
1301 bundled_item *item = g_hash_table_lookup(b->ht, key);
1302 int replace = 0;
1303
1304 if (item != NULL) {
1305 replace = 1;
1306 if (item->type == type) {
1307 /* we can take a shortcut */
1308 return bundled_item_replace_data(item, ptr, size, copy);
1309 }
1310 }
1311
1312 item = bundled_item_new(type, ptr, size, copy, note, &err);
1313
1314 if (!err) {
1315 item->name = g_strdup(key);
1316 if (replace) {
1317 g_hash_table_replace(b->ht, item->name, item);
1318 } else {
1319 g_hash_table_insert(b->ht, item->name, item);
1320 }
1321 }
1322 }
1323
1324 return err;
1325 }
1326
1327 /**
1328 * gretl_bundle_donate_data:
1329 * @bundle: target bundle.
1330 * @key: name of key to create or replace.
1331 * @ptr: data pointer.
1332 * @type: type of data.
1333 * @size: if @type == GRETL_TYPE_SERIES, the length of
1334 * the series, otherwise 0.
1335 *
1336 * Sets the data type and pointer to be associated with @key in
1337 * the bundle given by @name. If @key is already present in
1338 * the bundle's hash table the original value is replaced
1339 * and destroyed. The value of @ptr is transcribed into the
1340 * bundle, which therefore "takes ownership" of the data;
1341 * compare gretl_bundle_set_data().
1342 *
1343 * Returns: 0 on success, error code on error.
1344 */
1345
gretl_bundle_donate_data(gretl_bundle * bundle,const char * key,void * ptr,GretlType type,int size)1346 int gretl_bundle_donate_data (gretl_bundle *bundle, const char *key,
1347 void *ptr, GretlType type, int size)
1348 {
1349 if (key != NULL && ptr == NULL) {
1350 gretl_errmsg_sprintf("'%s': got NULL data value", key);
1351 return E_DATA;
1352 }
1353
1354 return real_bundle_set_data(bundle, key, ptr, type, size, 0, NULL);
1355 }
1356
1357 /**
1358 * gretl_bundle_set_data:
1359 * @bundle: target bundle.
1360 * @key: name of key to create or replace.
1361 * @ptr: data pointer.
1362 * @type: type of data.
1363 * @size: if @type == GRETL_TYPE_SERIES, the length of
1364 * the series, otherwise 0.
1365 *
1366 * Sets the data type and pointer to be associated with @key in
1367 * the bundle given by @name. If @key is already present in
1368 * the bundle's hash table the original value is replaced
1369 * and destroyed. The content of @ptr is copied into the
1370 * bundle; compare gretl_bundle_donate_data().
1371 *
1372 * Returns: 0 on success, error code on error.
1373 */
1374
gretl_bundle_set_data(gretl_bundle * bundle,const char * key,void * ptr,GretlType type,int size)1375 int gretl_bundle_set_data (gretl_bundle *bundle, const char *key,
1376 void *ptr, GretlType type, int size)
1377 {
1378 int err;
1379
1380 if (bundle == NULL) {
1381 err = E_UNKVAR;
1382 } else {
1383 err = real_bundle_set_data(bundle, key, ptr, type,
1384 size, 1, NULL);
1385 }
1386
1387 return err;
1388 }
1389
1390 /**
1391 * gretl_bundle_set_string:
1392 * @bundle: target bundle.
1393 * @key: name of key to create or replace.
1394 * @str: the string to set.
1395 *
1396 * Sets @str as a member of @bundle under the name @key.
1397 * If @key is already present in the bundle the original
1398 * value is replaced and destroyed.
1399 *
1400 * Returns: 0 on success, error code on error.
1401 */
1402
gretl_bundle_set_string(gretl_bundle * bundle,const char * key,const char * str)1403 int gretl_bundle_set_string (gretl_bundle *bundle, const char *key,
1404 const char *str)
1405 {
1406 return gretl_bundle_set_data(bundle, key, (void *) str,
1407 GRETL_TYPE_STRING, 0);
1408 }
1409
1410 /**
1411 * gretl_bundle_set_scalar:
1412 * @bundle: target bundle.
1413 * @key: name of key to create or replace.
1414 * @val: the value to set.
1415 *
1416 * Sets @val as a member of @bundle under the name @key.
1417 * If @key is already present in the bundle the original
1418 * value is replaced and destroyed.
1419 *
1420 * Returns: 0 on success, error code on error.
1421 */
1422
gretl_bundle_set_scalar(gretl_bundle * bundle,const char * key,double val)1423 int gretl_bundle_set_scalar (gretl_bundle *bundle, const char *key,
1424 double val)
1425 {
1426 return gretl_bundle_set_data(bundle, key, &val,
1427 GRETL_TYPE_DOUBLE, 0);
1428 }
1429
1430 /**
1431 * gretl_bundle_set_int:
1432 * @bundle: target bundle.
1433 * @key: name of key to create or replace.
1434 * @val: the integer value to set.
1435 *
1436 * Sets @val as a member of @bundle under the name @key.
1437 * If @key is already present in the bundle the original
1438 * value is replaced and destroyed.
1439 *
1440 * Returns: 0 on success, error code on error.
1441 */
1442
gretl_bundle_set_int(gretl_bundle * bundle,const char * key,int val)1443 int gretl_bundle_set_int (gretl_bundle *bundle, const char *key,
1444 int val)
1445 {
1446 return gretl_bundle_set_data(bundle, key, &val,
1447 GRETL_TYPE_INT, 0);
1448 }
1449
1450 /**
1451 * gretl_bundle_set_unsigned:
1452 * @bundle: target bundle.
1453 * @key: name of key to create or replace.
1454 * @val: the unsigned integer value to set.
1455 *
1456 * Sets @val as a member of @bundle under the name @key.
1457 * If @key is already present in the bundle the original
1458 * value is replaced and destroyed.
1459 *
1460 * Returns: 0 on success, error code on error.
1461 */
1462
gretl_bundle_set_unsigned(gretl_bundle * bundle,const char * key,unsigned int val)1463 int gretl_bundle_set_unsigned (gretl_bundle *bundle, const char *key,
1464 unsigned int val)
1465 {
1466 return gretl_bundle_set_data(bundle, key, &val,
1467 GRETL_TYPE_UNSIGNED, 0);
1468 }
1469
1470 /**
1471 * gretl_bundle_set_series:
1472 * @bundle: target bundle.
1473 * @key: name of key to create or replace.
1474 * @x: array of doubles.
1475 * @n: the length of @x.
1476 *
1477 * Sets @x as a member of @bundle under the name @key.
1478 * If @key is already present in the bundle the original
1479 * value is replaced and destroyed.
1480 *
1481 * Returns: 0 on success, error code on error.
1482 */
1483
gretl_bundle_set_series(gretl_bundle * bundle,const char * key,const double * x,int n)1484 int gretl_bundle_set_series (gretl_bundle *bundle, const char *key,
1485 const double *x, int n)
1486 {
1487 return gretl_bundle_set_data(bundle, key, (void *) x,
1488 GRETL_TYPE_SERIES, n);
1489 }
1490
1491 /**
1492 * gretl_bundle_set_list:
1493 * @bundle: target bundle.
1494 * @key: name of key to create or replace.
1495 * @list: gretl list.
1496 *
1497 * Sets @list as a member of @bundle under the name @key.
1498 * If @key is already present in the bundle the original
1499 * value is replaced and destroyed.
1500 *
1501 * Returns: 0 on success, error code on error.
1502 */
1503
gretl_bundle_set_list(gretl_bundle * bundle,const char * key,const int * list)1504 int gretl_bundle_set_list (gretl_bundle *bundle, const char *key,
1505 const int *list)
1506 {
1507 return gretl_bundle_set_data(bundle, key, (void *) list,
1508 GRETL_TYPE_LIST, 0);
1509 }
1510
1511 /**
1512 * gretl_bundle_set_matrix:
1513 * @bundle: target bundle.
1514 * @key: name of key to create or replace.
1515 * @m: gretl matrix.
1516 *
1517 * Sets @m as a member of @bundle under the name @key.
1518 * If @key is already present in the bundle the original
1519 * value is replaced and destroyed.
1520 *
1521 * Returns: 0 on success, error code on error.
1522 */
1523
gretl_bundle_set_matrix(gretl_bundle * bundle,const char * key,const gretl_matrix * m)1524 int gretl_bundle_set_matrix (gretl_bundle *bundle, const char *key,
1525 const gretl_matrix *m)
1526 {
1527 return gretl_bundle_set_data(bundle, key, (void *) m,
1528 GRETL_TYPE_MATRIX, 0);
1529 }
1530
1531 /**
1532 * gretl_bundle_delete_data:
1533 * @bundle: target bundle.
1534 * @key: name of key to delete.
1535 *
1536 * Deletes the data item under @key from @bundle, if
1537 * such an item is present.
1538 */
1539
gretl_bundle_delete_data(gretl_bundle * bundle,const char * key)1540 int gretl_bundle_delete_data (gretl_bundle *bundle, const char *key)
1541 {
1542 int done = 0;
1543 int err = 0;
1544
1545 if (bundle == NULL) {
1546 return E_DATA;
1547 }
1548
1549 if (bundle->type == BUNDLE_KALMAN) {
1550 done = maybe_delete_kalman_element(bundle->data, key, &err);
1551 }
1552
1553 if (!done && !err) {
1554 done = g_hash_table_remove(bundle->ht, key);
1555 if (!done) {
1556 err = E_DATA;
1557 }
1558 }
1559
1560 return err;
1561 }
1562
1563 /**
1564 * gretl_bundle_rekey_data:
1565 * @bundle: target bundle.
1566 * @oldkey: name of key to access.
1567 * @newkey: revised key.
1568 *
1569 * If @bundle contains an item under the key @oldkey, changes
1570 * the string by which the item is identified to @newkey.
1571 *
1572 * Returns: 0 on success, error code on failure.
1573 */
1574
gretl_bundle_rekey_data(gretl_bundle * bundle,const char * oldkey,const char * newkey)1575 int gretl_bundle_rekey_data (gretl_bundle *bundle,
1576 const char *oldkey,
1577 const char *newkey)
1578 {
1579 bundled_item *item = NULL;
1580 int err = 0;
1581
1582 if (strcmp(oldkey, newkey) == 0) {
1583 return 0;
1584 }
1585
1586 if (bundle != NULL) {
1587 item = g_hash_table_lookup(bundle->ht, oldkey);
1588 }
1589
1590 if (item == NULL) {
1591 err = E_DATA;
1592 } else {
1593 g_hash_table_steal(bundle->ht, oldkey);
1594 g_free(item->name);
1595 item->name = g_strdup(newkey);
1596 g_hash_table_insert(bundle->ht, item->name, item);
1597 }
1598
1599 return err;
1600 }
1601
1602 /**
1603 * gretl_bundle_set_note:
1604 * @bundle: target bundle.
1605 * @key: name of key to access.
1606 * @note: note to add.
1607 *
1608 * Adds a descriptive note to the item under @key in @bundle.
1609 * If a note is already present it is replaced by the new one.
1610 *
1611 * Returns: 0 on success, error code on error.
1612 */
1613
gretl_bundle_set_note(gretl_bundle * bundle,const char * key,const char * note)1614 int gretl_bundle_set_note (gretl_bundle *bundle, const char *key,
1615 const char *note)
1616 {
1617 int err = 0;
1618
1619 if (bundle == NULL) {
1620 err = E_UNKVAR;
1621 } else {
1622 gpointer p = g_hash_table_lookup(bundle->ht, key);
1623
1624 if (p == NULL) {
1625 err = E_DATA;
1626 } else {
1627 bundled_item *item = p;
1628
1629 free(item->note);
1630 item->note = gretl_strdup(note);
1631 }
1632 }
1633
1634 return err;
1635 }
1636
1637 /**
1638 * gretl_bundle_set_creator:
1639 * @bundle: target bundle.
1640 * @name: name of function package that built the bundle.
1641 *
1642 * Sets the "creator" attribute of @bundle. This is called
1643 * automatically when a bundle is returned to top-level
1644 * userspace by a packaged function.
1645 *
1646 * Returns: 0 on success, error code on error.
1647 */
1648
gretl_bundle_set_creator(gretl_bundle * bundle,const char * name)1649 int gretl_bundle_set_creator (gretl_bundle *bundle, const char *name)
1650 {
1651 int err = 0;
1652
1653 if (bundle == NULL) {
1654 err = E_DATA;
1655 } else {
1656 free(bundle->creator);
1657 if (name == NULL) {
1658 bundle->creator = NULL;
1659 } else {
1660 bundle->creator = gretl_strdup(name);
1661 if (bundle->creator == NULL) {
1662 err = E_ALLOC;
1663 }
1664 }
1665 }
1666
1667 return err;
1668 }
1669
1670 /* replicate on a target bundle a bundled_item from some other
1671 other bundle, provided the target bundle does not already
1672 have a bundled_item under the same key
1673 */
1674
copy_new_bundled_item(gpointer key,gpointer value,gpointer p)1675 static void copy_new_bundled_item (gpointer key, gpointer value, gpointer p)
1676 {
1677 bundled_item *item = (bundled_item *) value;
1678 gretl_bundle *targ = (gretl_bundle *) p;
1679
1680 if (!gretl_bundle_has_data(targ, (const char *) key)) {
1681 real_bundle_set_data(targ, (const char *) key,
1682 item->data, item->type,
1683 item->size, 1, item->note);
1684 }
1685 }
1686
1687 /* replicate on a target bundle a bundled_item from some other
1688 bundle */
1689
copy_bundled_item(gpointer key,gpointer value,gpointer p)1690 static void copy_bundled_item (gpointer key, gpointer value, gpointer p)
1691 {
1692 bundled_item *item = (bundled_item *) value;
1693 gretl_bundle *targ = (gretl_bundle *) p;
1694
1695 real_bundle_set_data(targ, (const char *) key,
1696 item->data, item->type,
1697 item->size, 1, item->note);
1698 }
1699
1700 /* Create a new bundle as the union of two existing bundles:
1701 we first copy bundle1 in its entirety, then append any elements
1702 of bundle2 whose keys that are not already present in the
1703 copy-target. In case bundle1 and bundle2 share any keys, the
1704 value copied to the target is therefore that from bundle1.
1705 */
1706
gretl_bundle_union(const gretl_bundle * bundle1,const gretl_bundle * bundle2,int * err)1707 gretl_bundle *gretl_bundle_union (const gretl_bundle *bundle1,
1708 const gretl_bundle *bundle2,
1709 int *err)
1710 {
1711 gretl_bundle *b = NULL;
1712
1713 if (bundle2->type == BUNDLE_KALMAN) {
1714 gretl_errmsg_set("bundle union: the right-hand operand cannot "
1715 "be a kalman bundle");
1716 *err = E_DATA;
1717 } else {
1718 b = gretl_bundle_copy(bundle1, err);
1719 }
1720
1721 if (!*err) {
1722 g_hash_table_foreach(bundle2->ht, copy_new_bundled_item, b);
1723 }
1724
1725 return b;
1726 }
1727
1728 /* argument-bundle checking apparatus */
1729
1730 struct bchecker {
1731 gretl_bundle *b;
1732 int *ret;
1733 int *err;
1734 PRN *prn;
1735 };
1736
check_bundled_item(gpointer key,gpointer value,gpointer p)1737 static void check_bundled_item (gpointer key, gpointer value, gpointer p)
1738 {
1739 bundled_item *targ, *src = (bundled_item *) value;
1740 struct bchecker *bchk = (struct bchecker *) p;
1741
1742 if (*bchk->ret || *bchk->err) {
1743 /* don't waste time if we already hit an error */
1744 return;
1745 }
1746
1747 /* look up @key (from input) in the template bundle */
1748 targ = g_hash_table_lookup(bchk->b->ht, (const char *) key);
1749
1750 if (targ == NULL) {
1751 /* extraneous key in input */
1752 pprintf(bchk->prn, "bcheck: unrecognized key '%s'\n", key);
1753 *bchk->ret = 2;
1754 } else if (targ->type == GRETL_TYPE_MATRIX &&
1755 src->type == GRETL_TYPE_DOUBLE) {
1756 double x = *(double *) src->data;
1757 gretl_matrix *m = gretl_matrix_from_scalar(x);
1758
1759 *bchk->err = bundled_item_replace_data(targ, m, 0, 0);
1760 } else if (targ->type == GRETL_TYPE_DOUBLE &&
1761 src->type == GRETL_TYPE_MATRIX) {
1762 gretl_matrix *m = src->data;
1763
1764 if (gretl_matrix_is_scalar(m)) {
1765 *bchk->err = bundled_item_replace_data(targ, &m->val[0], 0, 0);
1766 } else {
1767 *bchk->ret = 3;
1768 }
1769 } else if (src->type != targ->type) {
1770 *bchk->ret = 3;
1771 } else {
1772 /* transcribe input value -> template */
1773 *bchk->err = bundled_item_replace_data(targ, src->data, 0, 1);
1774 if (*bchk->err) {
1775 pprintf(bchk->prn, "bcheck: failed to copy '%s'\n", key);
1776 }
1777 }
1778
1779 if (*bchk->ret == 3) {
1780 pprintf(bchk->prn, "bcheck: '%s' should be %s, is %s\n", key,
1781 gretl_type_get_name(targ->type),
1782 gretl_type_get_name(src->type));
1783 }
1784 }
1785
1786 /**
1787 * gretl_bundle_extract_args:
1788 * @defaults: bundle containing keys for all supported
1789 * inputs, both optional and required (if any).
1790 * @input: bundle supplied by caller.
1791 * @reqd: array of strings identifying required keys, if any
1792 * (or NULL).
1793 * @prn: pointer to printing struct for display of error
1794 * messages.
1795 * @err:location to receive error code.
1796 *
1797 * This function checks @input against @defaults. It flags an
1798 * error (a) if a required element is missing, (b) if @input
1799 * contains an unrecognized key, or (c) if the type of any element
1800 * in @input fails to match the type of the corresponding element
1801 * in @defaults. If there's no error the content of @defaults
1802 * is updated from @input; that is, default values are replaced by
1803 * values selected by the caller.
1804 *
1805 * Note the the @err pointer receives a non-zero value only
1806 * if this function fails, which is distinct from the case
1807 * where it successfully diagnoses an error in @input.
1808 *
1809 * Returns: 0 if @input is deemed valid in light of @defaults,
1810 * non-zero otherwise.
1811 */
1812
gretl_bundle_extract_args(gretl_bundle * defaults,gretl_bundle * input,gretl_array * reqd,PRN * prn,int * err)1813 int gretl_bundle_extract_args (gretl_bundle *defaults,
1814 gretl_bundle *input,
1815 gretl_array *reqd,
1816 PRN *prn, int *err)
1817 {
1818 int ret = 0;
1819
1820 if (reqd != NULL && gretl_array_get_type(reqd) != GRETL_TYPE_STRINGS) {
1821 *err = E_TYPES;
1822 return *err;
1823 }
1824
1825 if (reqd != NULL) {
1826 int i, n = gretl_array_get_length(reqd);
1827 const char *key;
1828
1829 for (i=0; i<n; i++) {
1830 key = gretl_array_get_data(reqd, i);
1831 if (!gretl_bundle_has_key(input, key)) {
1832 pprintf(prn, "bcheck: required key '%s' is missing\n", key);
1833 ret = 1;
1834 break;
1835 }
1836 }
1837 }
1838
1839 if (ret == 0) {
1840 struct bchecker bchk = {defaults, &ret, err, prn};
1841
1842 g_hash_table_foreach(input->ht, check_bundled_item, &bchk);
1843 }
1844
1845 return ret;
1846 }
1847
gretl_bundle_append(gretl_bundle * bundle1,const gretl_bundle * bundle2)1848 int gretl_bundle_append (gretl_bundle *bundle1,
1849 const gretl_bundle *bundle2)
1850 {
1851 if (bundle2->type == BUNDLE_KALMAN) {
1852 gretl_errmsg_set("bundle union: the right-hand operand cannot "
1853 "be a kalman bundle");
1854 return E_DATA;
1855 } else {
1856 g_hash_table_foreach(bundle2->ht, copy_new_bundled_item, bundle1);
1857 return 0;
1858 }
1859 }
1860
1861 /**
1862 * gretl_bundle_copy:
1863 * @bundle: gretl bundle to be copied.
1864 * @err: location to receive error code.
1865 *
1866 * Returns: a "deep copy" of @bundle (all the items in @bundle
1867 * are themselves copied), or NULL on failure.
1868 */
1869
gretl_bundle_copy(const gretl_bundle * bundle,int * err)1870 gretl_bundle *gretl_bundle_copy (const gretl_bundle *bundle, int *err)
1871 {
1872 gretl_bundle *bcpy = NULL;
1873
1874 if (bundle == NULL) {
1875 *err = E_DATA;
1876 } else {
1877 if (bundle->type == BUNDLE_KALMAN) {
1878 bcpy = kalman_bundle_copy(bundle, err);
1879 } else {
1880 bcpy = gretl_bundle_new();
1881 if (bcpy == NULL) {
1882 *err = E_ALLOC;
1883 }
1884 }
1885 if (!*err) {
1886 g_hash_table_foreach(bundle->ht, copy_bundled_item, bcpy);
1887 }
1888 }
1889
1890 return bcpy;
1891 }
1892
1893 /**
1894 * gretl_bundle_copy_as:
1895 * @name: name of source bundle.
1896 * @copyname: name for copy.
1897 *
1898 * Look for a saved bundle specified by @name, and if found,
1899 * make a full copy and save it under @copyname. This is
1900 * called from geneval.c on completion of assignment to a
1901 * bundle named @copyname, where the returned value on the
1902 * right-hand side is a pre-existing saved bundle.
1903 *
1904 * Returns: 0 on success, non-zero code on error.
1905 */
1906
gretl_bundle_copy_as(const char * name,const char * copyname)1907 int gretl_bundle_copy_as (const char *name, const char *copyname)
1908 {
1909 gretl_bundle *b0, *b1 = NULL;
1910 user_var *u;
1911 int prev = 0;
1912 int err = 0;
1913
1914 if (!strcmp(name, "$sysinfo")) {
1915 b0 = sysinfo_bundle;
1916 } else {
1917 u = get_user_var_of_type_by_name(name, GRETL_TYPE_BUNDLE);
1918 if (u == NULL) {
1919 return E_DATA;
1920 } else {
1921 b0 = user_var_get_value(u);
1922 }
1923 }
1924
1925 u = get_user_var_of_type_by_name(copyname, GRETL_TYPE_BUNDLE);
1926
1927 if (u != NULL) {
1928 b1 = user_var_steal_value(u);
1929 if (b1 != NULL) {
1930 gretl_bundle_destroy(b1);
1931 }
1932 prev = 1;
1933 }
1934
1935 b1 = gretl_bundle_copy(b0, &err);
1936
1937 if (!err) {
1938 if (prev) {
1939 err = user_var_replace_value(u, b1, GRETL_TYPE_BUNDLE);
1940 } else {
1941 err = user_var_add(copyname, GRETL_TYPE_BUNDLE, b1);
1942 }
1943 }
1944
1945 return err;
1946 }
1947
1948 struct b_item_printer {
1949 PRN *prn;
1950 int indent;
1951 int tree;
1952 };
1953
print_bundled_item(gpointer value,gpointer p)1954 static void print_bundled_item (gpointer value, gpointer p)
1955 {
1956 bundled_item *item = value;
1957 GretlType t = item->type;
1958 const gchar *kstr = item->name;
1959 struct b_item_printer *bip = p;
1960 PRN *prn = bip->prn;
1961 int indent;
1962
1963 if (bip->tree && t == GRETL_TYPE_BUNDLE) {
1964 return;
1965 }
1966
1967 indent = 2 + 2 * bip->indent;
1968 bufspace(indent, prn);
1969
1970 if (t == GRETL_TYPE_DOUBLE) {
1971 double x = *(double *) item->data;
1972
1973 if (na(x)) {
1974 pprintf(prn, "%s = NA", kstr);
1975 } else {
1976 pprintf(prn, "%s = %g", kstr, x);
1977 }
1978 } else if (t == GRETL_TYPE_INT) {
1979 int i = *(int *) item->data;
1980
1981 pprintf(prn, "%s = %d", kstr, i);
1982 } else if (t == GRETL_TYPE_UNSIGNED) {
1983 unsigned int u = *(unsigned int *) item->data;
1984
1985 pprintf(prn, "%s = %u", kstr, u);
1986 } else if (t == GRETL_TYPE_STRING) {
1987 char *s = (char *) item->data;
1988 int n = strlen(s);
1989
1990 if (n + indent < 70) {
1991 if (strchr(s, '"') != NULL) {
1992 pprintf(prn, "%s = '%s'", kstr, s);
1993 } else {
1994 pprintf(prn, "%s = \"%s\"", kstr, s);
1995 }
1996 } else {
1997 pprintf(prn, "%s (%s, %d bytes)", kstr,
1998 gretl_type_get_name(t), n);
1999 }
2000 } else if (t == GRETL_TYPE_BUNDLE) {
2001 pprintf(prn, "%s (%s)", kstr, gretl_type_get_name(t));
2002 } else if (t == GRETL_TYPE_MATRIX) {
2003 gretl_matrix *m = item->data;
2004
2005 if (m->rows == 1 && m->cols == 1) {
2006 pprintf(prn, "%s = %g", kstr, m->val[0]);
2007 } else {
2008 pprintf(prn, "%s (%s: %d x %d)", kstr,
2009 gretl_type_get_name(t),
2010 m->rows, m->cols);
2011 }
2012 } else if (t == GRETL_TYPE_SERIES) {
2013 pprintf(prn, "%s (%s: length %d)", kstr,
2014 gretl_type_get_name(t), item->size);
2015 } else if (t == GRETL_TYPE_LIST) {
2016 pprintf(prn, "%s (%s)", kstr, gretl_type_get_name(t));
2017 } else if (t == GRETL_TYPE_ARRAY) {
2018 gretl_array *a = item->data;
2019 int n = gretl_array_get_length(a);
2020
2021 t = gretl_array_get_type(a);
2022 pprintf(prn, "%s = array of %s, length %d", kstr,
2023 gretl_type_get_name(t), n);
2024 }
2025
2026 if (item->note != NULL) {
2027 pprintf(prn, " %s\n", item->note);
2028 } else {
2029 pputc(prn, '\n');
2030 }
2031 }
2032
bundle_header(const char * name,const char * creator,int empty,PRN * prn)2033 static void bundle_header (const char *name,
2034 const char *creator,
2035 int empty, PRN *prn)
2036 {
2037 if (name != NULL) {
2038 if (empty) {
2039 pprintf(prn, "bundle %s: empty\n", name);
2040 } else if (creator != NULL) {
2041 pprintf(prn, "bundle %s, created by %s:\n", name, creator);
2042 } else {
2043 pprintf(prn, "bundle %s:\n", name);
2044 }
2045 } else {
2046 if (empty) {
2047 pputs(prn, "bundle: empty\n");
2048 } else if (creator != NULL) {
2049 pprintf(prn, "bundle created by %s:\n", creator);
2050 } else {
2051 pputs(prn, "bundle:\n");
2052 }
2053 }
2054 }
2055
real_bundle_print(gretl_bundle * bundle,int indent,int tree,PRN * prn)2056 static int real_bundle_print (gretl_bundle *bundle, int indent,
2057 int tree, PRN *prn)
2058 {
2059 struct b_item_printer bip = {prn, indent, tree};
2060 GList *L;
2061
2062 if (bundle == NULL) {
2063 return E_DATA;
2064 }
2065
2066 L = gretl_bundle_get_sorted_items(bundle);
2067
2068 if (indent > 0) {
2069 /* child, when printing tree */
2070 int n_items = g_hash_table_size(bundle->ht);
2071
2072 if (bundle->type == BUNDLE_PLAIN && n_items == 0) {
2073 pputs(prn, "empty\n");
2074 } else if (bundle->type == BUNDLE_KALMAN) {
2075 print_kalman_bundle_info(bundle->data, prn);
2076 if (n_items > 0) {
2077 pputs(prn, "\nOther content\n");
2078 g_list_foreach(L, print_bundled_item, &bip);
2079 }
2080 } else if (n_items > 0) {
2081 g_list_foreach(L, print_bundled_item, &bip);
2082 }
2083 } else {
2084 int n_items = g_hash_table_size(bundle->ht);
2085 user_var *u = get_user_var_by_data(bundle);
2086 const char *name = NULL;
2087
2088 if (u != NULL) {
2089 name = user_var_get_name(u);
2090 }
2091
2092 if (bundle->type == BUNDLE_PLAIN && n_items == 0) {
2093 bundle_header(name, NULL, 1, prn);
2094 } else {
2095 bundle_header(name, bundle->creator, 0, prn);
2096 if (bundle->type == BUNDLE_KALMAN) {
2097 print_kalman_bundle_info(bundle->data, prn);
2098 if (n_items > 0) {
2099 pputs(prn, "\nOther content\n");
2100 g_list_foreach(L, print_bundled_item, &bip);
2101 }
2102 } else if (n_items > 0) {
2103 g_list_foreach(L, print_bundled_item, &bip);
2104 }
2105 }
2106 }
2107
2108 g_list_free(L);
2109
2110 return 0;
2111 }
2112
print_bundle_tree(gretl_bundle * b,int level,PRN * prn)2113 static int print_bundle_tree (gretl_bundle *b, int level, PRN *prn)
2114 {
2115 gretl_array *K = gretl_bundle_get_keys(b, NULL);
2116 gretl_array *A;
2117 gretl_bundle *bj;
2118 char **keys;
2119 int i, j, nb, n = 0;
2120
2121 real_bundle_print(b, level, 1, prn);
2122
2123 keys = gretl_array_get_strings(K, &n);
2124 if (n == 0) {
2125 bufspace(2*(level+1), prn);
2126 pputs(prn, "empty\n");
2127 }
2128
2129 for (i=0; i<n; i++) {
2130 const char *key = keys[i];
2131 bundled_item *item = g_hash_table_lookup(b->ht, key);
2132
2133 if (item->type == GRETL_TYPE_BUNDLE) {
2134 int nmemb = gretl_bundle_get_n_members(item->data);
2135
2136 bufspace(2*(level+1), prn);
2137 if (nmemb == 0) {
2138 pprintf(prn, "%s = bundle (empty)\n", key);
2139 } else {
2140 pprintf(prn, "%s = bundle (%d members)\n", key, nmemb);
2141 print_bundle_tree((gretl_bundle *) item->data, level + 1, prn);
2142 }
2143 continue;
2144 } else if (item->type == GRETL_TYPE_ARRAY) {
2145 GretlType atype;
2146
2147 A = (gretl_array *) item->data;
2148 atype = gretl_array_get_content_type(A);
2149 if (atype == GRETL_TYPE_BUNDLE) {
2150 nb = gretl_array_get_length(A);
2151 for (j=0; j<nb; j++) {
2152 bj = gretl_array_get_bundle(A, j);
2153 bufspace(2*(level+2), prn);
2154 pprintf(prn, "%s[%d]:\n", key, j + 1);
2155 print_bundle_tree(bj, level + 2, prn);
2156 }
2157 continue;
2158 }
2159 }
2160 }
2161
2162 gretl_array_destroy(K);
2163
2164 return 0;
2165 }
2166
2167 /**
2168 * gretl_bundle_print:
2169 * @bundle: gretl bundle.
2170 * @prn: gretl printer.
2171 *
2172 * Prints to @prn a list of the keys defined in @bundle, along
2173 * with descriptive notes, if any.
2174 *
2175 * Returns: 0 on success, non-zero code on failure.
2176 */
2177
gretl_bundle_print(gretl_bundle * bundle,PRN * prn)2178 int gretl_bundle_print (gretl_bundle *bundle, PRN *prn)
2179 {
2180 int err = real_bundle_print(bundle, 0, 0, prn);
2181
2182 if (!err) {
2183 pputc(prn, '\n');
2184 }
2185
2186 return err;
2187 }
2188
2189 /**
2190 * gretl_bundle_debug_print:
2191 * @bundle: gretl bundle.
2192 * @msg: extra string to print, or NULL.
2193 *
2194 * Prints to stderr a list of the keys defined in @bundle, along
2195 * with descriptive notes, if any. If @msg is non-NULL it is
2196 * printed first.
2197 */
2198
gretl_bundle_debug_print(gretl_bundle * bundle,const char * msg)2199 void gretl_bundle_debug_print (gretl_bundle *bundle, const char *msg)
2200 {
2201 PRN *prn = gretl_print_new(GRETL_PRINT_STDERR, NULL);
2202
2203 if (msg != NULL) {
2204 pputs(prn, msg);
2205 pputc(prn, '\n');
2206 }
2207 real_bundle_print(bundle, 0, 0, prn);
2208 pputc(prn, '\n');
2209 gretl_print_destroy(prn);
2210 }
2211
gretl_bundle_print_tree(gretl_bundle * bundle,PRN * prn)2212 int gretl_bundle_print_tree (gretl_bundle *bundle, PRN *prn)
2213 {
2214 int err;
2215
2216 if (bundle == NULL) {
2217 err = E_DATA;
2218 } else {
2219 err = print_bundle_tree(bundle, 0, prn);
2220 if (!err) {
2221 pputc(prn, '\n');
2222 }
2223 }
2224
2225 return err;
2226 }
2227
2228 /* Called from gretl_func.c on return, to remove
2229 a given bundle from the stack of named bundles in
2230 preparation for handing it over to the caller,
2231 who will take ownership of it.
2232 */
2233
gretl_bundle_pull_from_stack(const char * name,int * err)2234 gretl_bundle *gretl_bundle_pull_from_stack (const char *name,
2235 int *err)
2236 {
2237 gretl_bundle *b = NULL;
2238 user_var *u;
2239
2240 u = get_user_var_of_type_by_name(name, GRETL_TYPE_BUNDLE);
2241
2242 if (u != NULL) {
2243 b = user_var_unstack_value(u);
2244 }
2245
2246 if (b == NULL) {
2247 *err = E_DATA;
2248 }
2249
2250 return b;
2251 }
2252
2253 /* serialize a gretl bundled item as XML */
2254
xml_put_bundled_item(gpointer keyp,gpointer value,gpointer p)2255 static void xml_put_bundled_item (gpointer keyp, gpointer value, gpointer p)
2256 {
2257 const char *key = keyp;
2258 bundled_item *item = value;
2259 PRN *prn = p;
2260 int j;
2261
2262 if (item->type == GRETL_TYPE_STRING) {
2263 if (item->data == NULL) {
2264 fprintf(stderr, "bundle -> XML: skipping NULL string %s\n", key);
2265 return;
2266 }
2267 }
2268
2269 pprintf(prn, "<bundled-item key=\"%s\" type=\"%s\"", key,
2270 gretl_type_get_name(item->type));
2271
2272 if (item->note != NULL) {
2273 pprintf(prn, " note=\"%s\"", item->note);
2274 }
2275
2276 if (item->size > 0) {
2277 pprintf(prn, " size=\"%d\">\n", item->size);
2278 } else if (item->type == GRETL_TYPE_STRING) {
2279 pputc(prn, '>');
2280 } else {
2281 pputs(prn, ">\n");
2282 }
2283
2284 if (item->type == GRETL_TYPE_DOUBLE) {
2285 double x = *(double *) item->data;
2286
2287 if (na(x)) {
2288 pputs(prn, "NA");
2289 } else {
2290 pprintf(prn, "%.16g", x);
2291 }
2292 } else if (item->type == GRETL_TYPE_INT) {
2293 int i = *(int *) item->data;
2294
2295 pprintf(prn, "%d", i);
2296 } else if (item->type == GRETL_TYPE_UNSIGNED) {
2297 unsigned int u = *(unsigned int *) item->data;
2298
2299 pprintf(prn, "%u", u);
2300 } else if (item->type == GRETL_TYPE_SERIES) {
2301 double *vals = (double *) item->data;
2302
2303 for (j=0; j<item->size; j++) {
2304 if (na(vals[j])) {
2305 pputs(prn, "NA ");
2306 } else {
2307 pprintf(prn, "%.16g ", vals[j]);
2308 }
2309 }
2310 } else if (item->type == GRETL_TYPE_STRING) {
2311 gretl_xml_put_string((char *) item->data, prn);
2312 } else if (item->type == GRETL_TYPE_MATRIX) {
2313 gretl_matrix *m = (gretl_matrix *) item->data;
2314
2315 gretl_matrix_serialize(m, NULL, prn);
2316 } else if (item->type == GRETL_TYPE_BUNDLE) {
2317 gretl_bundle *b = (gretl_bundle *) item->data;
2318
2319 gretl_bundle_serialize(b, NULL, prn);
2320 } else if (item->type == GRETL_TYPE_ARRAY) {
2321 gretl_array *a = (gretl_array *) item->data;
2322
2323 gretl_array_serialize(a, prn);
2324 } else if (item->type == GRETL_TYPE_LIST) {
2325 int *list = (int *) item->data;
2326
2327 gretl_list_serialize(list, NULL, prn);
2328 } else {
2329 fprintf(stderr, "bundle -> XML: skipping %s\n", key);
2330 }
2331
2332 pputs(prn, "</bundled-item>\n");
2333 }
2334
gretl_bundle_serialize(gretl_bundle * b,const char * name,PRN * prn)2335 void gretl_bundle_serialize (gretl_bundle *b, const char *name,
2336 PRN *prn)
2337 {
2338 pputs(prn, "<gretl-bundle");
2339 if (name != NULL) {
2340 pprintf(prn, " name=\"%s\"", name);
2341 }
2342 if (b->creator != NULL && *b->creator != '\0') {
2343 pprintf(prn, " creator=\"%s\"", b->creator);
2344 }
2345 if (b->type == BUNDLE_KALMAN) {
2346 pputs(prn, " type=\"kalman\"");
2347 }
2348 pputs(prn, ">\n");
2349
2350 if (b->type == BUNDLE_KALMAN) {
2351 kalman_serialize(b->data, prn);
2352 }
2353
2354 if (b->ht != NULL) {
2355 g_hash_table_foreach(b->ht, xml_put_bundled_item, prn);
2356 }
2357
2358 pputs(prn, "</gretl-bundle>\n");
2359 }
2360
load_bundled_items(gretl_bundle * b,xmlNodePtr cur,xmlDocPtr doc)2361 static int load_bundled_items (gretl_bundle *b, xmlNodePtr cur, xmlDocPtr doc)
2362 {
2363 GretlType type;
2364 char *key;
2365 int err = 0;
2366
2367 while (cur != NULL && !err) {
2368 if (!xmlStrcmp(cur->name, (XUC) "bundled-item")) {
2369 key = (char *) xmlGetProp(cur, (XUC) "key");
2370 type = gretl_xml_get_type_property(cur);
2371 if (key == NULL || type == 0) {
2372 err = E_DATA;
2373 } else {
2374 int size = 0;
2375
2376 if (type == GRETL_TYPE_DOUBLE) {
2377 double x;
2378
2379 if (!gretl_xml_node_get_double(cur, doc, &x)) {
2380 err = E_DATA;
2381 } else {
2382 err = gretl_bundle_set_data(b, key, &x, type, size);
2383 }
2384 } else if (type == GRETL_TYPE_INT) {
2385 int i;
2386
2387 if (!gretl_xml_node_get_int(cur, doc, &i)) {
2388 err = E_DATA;
2389 } else {
2390 err = gretl_bundle_set_data(b, key, &i, type, size);
2391 }
2392 } else if (type == GRETL_TYPE_UNSIGNED) {
2393 unsigned int u;
2394
2395 if (!gretl_xml_node_get_unsigned(cur, doc, &u)) {
2396 err = E_DATA;
2397 } else {
2398 err = gretl_bundle_set_data(b, key, &u, type, size);
2399 }
2400 } else if (type == GRETL_TYPE_STRING) {
2401 char *s;
2402
2403 if (!gretl_xml_node_get_trimmed_string(cur, doc, &s)) {
2404 err = E_DATA;
2405 } else {
2406 err = gretl_bundle_donate_data(b, key, s, type, size);
2407 }
2408 } else if (type == GRETL_TYPE_SERIES) {
2409 double *xvec = gretl_xml_get_double_array(cur, doc, &size, &err);
2410
2411 if (!err) {
2412 err = gretl_bundle_donate_data(b, key, xvec, type, size);
2413 }
2414 } else if (type == GRETL_TYPE_MATRIX) {
2415 xmlNodePtr child = cur->xmlChildrenNode;
2416 gretl_matrix *m;
2417
2418 if (child == NULL) {
2419 err = E_DATA;
2420 } else {
2421 m = gretl_xml_get_matrix(child, doc, &err);
2422 if (!err) {
2423 err = gretl_bundle_donate_data(b, key, m, type, size);
2424 }
2425 }
2426 } else if (type == GRETL_TYPE_BUNDLE) {
2427 xmlNodePtr child = cur->xmlChildrenNode;
2428 gretl_bundle *baby;
2429
2430 if (child == NULL) {
2431 err = E_DATA;
2432 } else {
2433 baby = gretl_bundle_deserialize(child, doc, &err);
2434 if (!err) {
2435 err = gretl_bundle_donate_data(b, key, baby, type, size);
2436 }
2437 }
2438 } else if (type == GRETL_TYPE_ARRAY) {
2439 xmlNodePtr child = cur->xmlChildrenNode;
2440 gretl_array *a;
2441
2442 if (child == NULL) {
2443 err = E_DATA;
2444 } else {
2445 a = gretl_array_deserialize(child, doc, &err);
2446 if (!err) {
2447 err = gretl_bundle_donate_data(b, key, a, type, size);
2448 }
2449 }
2450 } else if (type == GRETL_TYPE_LIST) {
2451 xmlNodePtr child = cur->xmlChildrenNode;
2452 int *list;
2453
2454 if (child == NULL) {
2455 err = E_DATA;
2456 } else {
2457 list = gretl_xml_get_list(child, doc, &err);
2458 if (!err) {
2459 err = gretl_bundle_donate_data(b, key, list, type, size);
2460 }
2461 }
2462 } else {
2463 fprintf(stderr, "bundle: ignoring unhandled type %d\n", type);
2464 }
2465
2466 if (!err) {
2467 char *note = (char *) xmlGetProp(cur, (XUC) "note");
2468
2469 if (note != NULL) {
2470 gretl_bundle_set_note(b, key, note);
2471 xmlFree(note);
2472 }
2473 }
2474
2475 xmlFree(key);
2476 }
2477 }
2478 cur = cur->next;
2479 }
2480
2481 return err;
2482 }
2483
2484 /* For internal use only: @p1 should be of type xmlNodePtr and @p2
2485 should be an xmlDocPtr. We suppress the actual pointer types in the
2486 signature so that it's possible for a module to include
2487 gretl_bundle.h without including the full libxml headers.
2488 */
2489
gretl_bundle_deserialize(void * p1,void * p2,int * err)2490 gretl_bundle *gretl_bundle_deserialize (void *p1, void *p2,
2491 int *err)
2492 {
2493 xmlNodePtr cur, node = p1;
2494 xmlDocPtr doc = p2;
2495 gretl_bundle *b = NULL;
2496 char *btype = NULL;
2497 char *creator = NULL;
2498
2499 btype = (char *) xmlGetProp(node, (XUC) "type");
2500 creator = (char *) xmlGetProp(node, (XUC) "creator");
2501
2502 cur = node->xmlChildrenNode;
2503
2504 if (btype != NULL && !strcmp(btype, "kalman")) {
2505 b = kalman_deserialize(cur, doc, err);
2506 } else {
2507 b = gretl_bundle_new();
2508 if (b == NULL) {
2509 *err = E_ALLOC;
2510 } else if (creator != NULL) {
2511 b->creator = creator;
2512 creator = NULL;
2513 }
2514 }
2515
2516 free(btype);
2517 free(creator);
2518
2519 if (b != NULL) {
2520 *err = load_bundled_items(b, cur, doc);
2521 if (*err) {
2522 fprintf(stderr, "deserialize bundle: "
2523 "bundle is broken (err = %d)\n", *err);
2524 gretl_bundle_destroy(b);
2525 b = NULL;
2526 }
2527 }
2528
2529 return b;
2530 }
2531
call_bundle_to_json(gretl_bundle * b,const char * fname,int control)2532 static int call_bundle_to_json (gretl_bundle *b,
2533 const char *fname,
2534 int control)
2535 {
2536 int (*jfunc) (gretl_bundle *, const char *, gretlopt);
2537
2538 jfunc = get_plugin_function("bundle_to_json");
2539 if (jfunc == NULL) {
2540 return E_FOPEN;
2541 } else {
2542 gretlopt opt = OPT_NONE;
2543
2544 if (control & 2) {
2545 opt |= OPT_A;
2546 }
2547 if (control & 4) {
2548 opt |= OPT_P;
2549 }
2550 return jfunc(b, fname, opt);
2551 }
2552 }
2553
gretl_bundle_write_to_file(gretl_bundle * b,const char * fname,int control)2554 int gretl_bundle_write_to_file (gretl_bundle *b,
2555 const char *fname,
2556 int control)
2557 {
2558 char fullname[FILENAME_MAX];
2559 PRN *prn = NULL;
2560 int err = 0;
2561
2562 if (control & 1) {
2563 gretl_build_path(fullname, gretl_dotdir(), fname, NULL);
2564 } else {
2565 strcpy(fullname, fname);
2566 gretl_maybe_switch_dir(fullname);
2567 }
2568
2569 if (has_suffix(fname, ".json") || has_suffix(fname, ".geojson")) {
2570 return call_bundle_to_json(b, fullname, control);
2571 }
2572
2573 if (has_suffix(fname, ".gz")) {
2574 prn = gretl_gzip_print_new(fullname, -1, &err);
2575 } else {
2576 prn = gretl_print_new_with_filename(fullname, &err);
2577 }
2578
2579 if (prn != NULL) {
2580 gretl_push_c_numeric_locale();
2581 gretl_xml_header(prn);
2582 gretl_bundle_serialize(b, NULL, prn);
2583 gretl_print_destroy(prn);
2584 gretl_pop_c_numeric_locale();
2585 }
2586
2587 return err;
2588 }
2589
gretl_bundle_write_to_buffer(gretl_bundle * b,int rank,int * bytes,int * err)2590 char *gretl_bundle_write_to_buffer (gretl_bundle *b,
2591 int rank,
2592 int *bytes,
2593 int *err)
2594 {
2595 char *buf = NULL;
2596 PRN *prn;
2597
2598 prn = gretl_print_new(GRETL_PRINT_BUFFER, err);
2599
2600 if (!*err) {
2601 gretl_push_c_numeric_locale();
2602 gretl_xml_header(prn);
2603 gretl_bundle_serialize(b, NULL, prn);
2604 buf = gretl_print_steal_buffer(prn);
2605 *bytes = strlen(buf) + 1;
2606 gretl_pop_c_numeric_locale();
2607 gretl_print_destroy(prn);
2608 }
2609
2610 return buf;
2611 }
2612
read_json_bundle(const char * fname,int * err)2613 static gretl_bundle *read_json_bundle (const char *fname,
2614 int *err)
2615 {
2616 gretl_bundle *(*jfunc) (const char *, const char *, int *);
2617 gretl_bundle *b = NULL;
2618 GError *gerr = NULL;
2619 gchar *JSON = NULL;
2620 gsize len = 0;
2621 gboolean ok;
2622
2623 ok = g_file_get_contents(fname, &JSON, &len, &gerr);
2624
2625 if (ok) {
2626 jfunc = get_plugin_function("json_get_bundle");
2627 if (jfunc == NULL) {
2628 *err = E_FOPEN;
2629 } else {
2630 b = jfunc(JSON, NULL, err);
2631 }
2632 g_free(JSON);
2633 } else if (gerr != NULL) {
2634 *err = E_FOPEN;
2635 gretl_errmsg_set(gerr->message);
2636 g_error_free(gerr);
2637 }
2638
2639 return b;
2640 }
2641
read_shapefile_bundle(const char * fname,int * err)2642 static gretl_bundle *read_shapefile_bundle (const char *fname,
2643 int *err)
2644 {
2645 gretl_bundle *(*bfunc) (const char *, int *);
2646 gretl_bundle *b = NULL;
2647
2648 bfunc = get_plugin_function("shp_get_bundle");
2649 if (bfunc == NULL) {
2650 *err = E_FOPEN;
2651 } else {
2652 b = bfunc(fname, err);
2653 }
2654
2655 return b;
2656 }
2657
gretl_bundle_read_from_file(const char * fname,int from_dotdir,int * err)2658 gretl_bundle *gretl_bundle_read_from_file (const char *fname,
2659 int from_dotdir,
2660 int *err)
2661 {
2662 char fullname[FILENAME_MAX];
2663 xmlDocPtr doc = NULL;
2664 xmlNodePtr cur = NULL;
2665 gretl_bundle *b = NULL;
2666
2667 if (from_dotdir) {
2668 gretl_build_path(fullname, gretl_dotdir(), fname, NULL);
2669 } else {
2670 strcpy(fullname, fname);
2671 gretl_maybe_prepend_dir(fullname);
2672 }
2673
2674 if (has_suffix(fname, ".json") || has_suffix(fname, ".geojson")) {
2675 b = read_json_bundle(fullname, err);
2676 } else if (has_suffix(fname, ".shp")) {
2677 b = read_shapefile_bundle(fullname, err);
2678 } else {
2679 *err = gretl_xml_open_doc_root(fullname, "gretl-bundle", &doc, &cur);
2680 if (!*err) {
2681 gretl_push_c_numeric_locale();
2682 b = gretl_bundle_deserialize(cur, doc, err);
2683 gretl_pop_c_numeric_locale();
2684 xmlFreeDoc(doc);
2685 }
2686 }
2687
2688 if (*err && b != NULL) {
2689 gretl_bundle_destroy(b);
2690 b = NULL;
2691 }
2692
2693 return b;
2694 }
2695
gretl_bundle_read_from_buffer(const char * buf,int len,int * err)2696 gretl_bundle *gretl_bundle_read_from_buffer (const char *buf,
2697 int len,
2698 int *err)
2699 {
2700 xmlDocPtr doc = NULL;
2701 gretl_bundle *b = NULL;
2702
2703 xmlKeepBlanksDefault(0);
2704 doc = xmlParseMemory(buf, len);
2705
2706 if (doc == NULL) {
2707 gretl_errmsg_set(_("xmlParseMemory failed"));
2708 *err = 1;
2709 } else {
2710 xmlNodePtr cur = xmlDocGetRootElement(doc);
2711
2712 if (cur == NULL) {
2713 gretl_errmsg_set(_("xmlDocGetRootElement failed"));
2714 *err = 1;
2715 } else {
2716 gretl_push_c_numeric_locale();
2717 b = gretl_bundle_deserialize(cur, doc, err);
2718 gretl_pop_c_numeric_locale();
2719 }
2720 xmlFreeDoc(doc);
2721 }
2722
2723 if (*err && b != NULL) {
2724 gretl_bundle_destroy(b);
2725 b = NULL;
2726 }
2727
2728 return b;
2729 }
2730
2731 /* get the key strings from @b in the form of a gretl_array */
2732
gretl_bundle_get_keys(gretl_bundle * b,int * err)2733 gretl_array *gretl_bundle_get_keys (gretl_bundle *b, int *err)
2734 {
2735 gretl_array *A = NULL;
2736 int myerr = 0;
2737
2738 if (b == NULL || b->ht == NULL) {
2739 myerr = E_DATA;
2740 } else {
2741 GList *keys = g_hash_table_get_keys(b->ht);
2742 guint n;
2743
2744 if (keys != NULL && (n = g_list_length(keys)) > 0) {
2745 A = gretl_array_new(GRETL_TYPE_STRINGS, n, &myerr);
2746 if (!myerr) {
2747 GList *L = g_list_first(keys);
2748 int i = 0;
2749
2750 while (L != NULL) {
2751 gretl_array_set_string(A, i, L->data, 1);
2752 i++;
2753 L = g_list_next(L);
2754 }
2755 }
2756 } else {
2757 A = gretl_array_new(GRETL_TYPE_STRINGS, 0, &myerr);
2758 }
2759 if (keys != NULL) {
2760 g_list_free(keys);
2761 }
2762 }
2763
2764 if (err != NULL) {
2765 *err = myerr;
2766 }
2767
2768 return A;
2769 }
2770
2771 /* get the key strings from @b in the form of a "raw" array
2772 of C type char *
2773 */
2774
gretl_bundle_get_keys_raw(gretl_bundle * b,int * ns)2775 char **gretl_bundle_get_keys_raw (gretl_bundle *b, int *ns)
2776 {
2777 char **S = NULL;
2778
2779 *ns = 0;
2780
2781 if (b != NULL && b->ht != NULL) {
2782 GList *keys = g_hash_table_get_keys(b->ht);
2783 guint n;
2784
2785 if (keys != NULL && (n = g_list_length(keys)) > 0) {
2786 S = strings_array_new(n + 1);
2787 if (S != NULL) {
2788 GList *L = g_list_first(keys);
2789 int i = 0;
2790
2791 while (L != NULL) {
2792 S[i++] = gretl_strdup(L->data);
2793 L = g_list_next(L);
2794 }
2795 *ns = n;
2796 S[i] = NULL; /* terminator */
2797 }
2798 }
2799 if (keys != NULL) {
2800 g_list_free(keys);
2801 }
2802 }
2803
2804 return S;
2805 }
2806
get_sysinfo_bundle(int * err)2807 gretl_bundle *get_sysinfo_bundle (int *err)
2808 {
2809 gretl_matrix *memvals = NULL;
2810
2811 if (sysinfo_bundle == NULL) {
2812 gretl_bundle *b = gretl_bundle_new();
2813
2814 if (b == NULL) {
2815 *err = E_ALLOC;
2816 } else {
2817 gretl_bundle *fb;
2818 char *s1, *s2;
2819 int ival = 0;
2820
2821 #if HAVE_MPI
2822 ival = check_for_mpiexec();
2823 #endif
2824 gretl_bundle_set_scalar(b, "mpi", (double) ival);
2825 ival = gretl_max_mpi_processes();
2826 gretl_bundle_set_scalar(b, "mpimax", (double) ival);
2827 ival = gretl_n_processors();
2828 gretl_bundle_set_scalar(b, "nproc", (double) ival);
2829 ival = gretl_n_physical_cores();
2830 gretl_bundle_set_scalar(b, "ncores", (double) ival);
2831 ival = 0;
2832 #ifdef _OPENMP
2833 ival = 1;
2834 #endif
2835 gretl_bundle_set_scalar(b, "omp", (double) ival);
2836 ival = sizeof(void*) == 8 ? 64 : 32;
2837 gretl_bundle_set_scalar(b, "wordlen", (double) ival);
2838 #if defined(G_OS_WIN32)
2839 gretl_bundle_set_string(b, "os", "windows");
2840 #elif defined(OS_OSX)
2841 gretl_bundle_set_string(b, "os", "osx");
2842 #elif defined(linux)
2843 gretl_bundle_set_string(b, "os", "linux");
2844 #else
2845 gretl_bundle_set_string(b, "os", "other");
2846 #endif
2847 gretl_bundle_set_string(b, "hostname", g_get_host_name());
2848 gretl_bundle_set_string(b, "blas", blas_variant_string());
2849 if (get_openblas_details(&s1, &s2)) {
2850 gretl_bundle_set_string(b, "blascore", s1);
2851 gretl_bundle_set_string(b, "blas_parallel", s2);
2852 }
2853 fb = foreign_info();
2854 if (fb != NULL) {
2855 gretl_bundle_donate_data(b, "foreign", fb,
2856 GRETL_TYPE_BUNDLE, 0);
2857 }
2858 }
2859 sysinfo_bundle = b;
2860 }
2861
2862 memvals = gretl_matrix_alloc(1, 2);
2863 if (memvals != NULL) {
2864 char **S = malloc(2 * sizeof *S);
2865
2866 memory_stats(memvals->val);
2867 S[0] = gretl_strdup("MBtotal");
2868 S[1] = gretl_strdup("MBfree");
2869 gretl_matrix_set_colnames(memvals, S);
2870 gretl_bundle_donate_data(sysinfo_bundle, "mem", memvals,
2871 GRETL_TYPE_MATRIX, 0);
2872 }
2873
2874 return sysinfo_bundle;
2875 }
2876
sysinfo_bundle_get_data(const char * key,GretlType * type,int * err)2877 void *sysinfo_bundle_get_data (const char *key, GretlType *type,
2878 int *err)
2879 {
2880 gretl_bundle *b = get_sysinfo_bundle(err);
2881 void *ret = NULL;
2882
2883 if (b != NULL) {
2884 ret = gretl_bundle_get_data(b, key, type, NULL, err);
2885 }
2886
2887 return ret;
2888 }
2889
2890 /* For a single-equation model, create a bundle containing
2891 all the data available via $-accessors.
2892 */
2893
bundle_from_model(MODEL * pmod,DATASET * dset,int * err)2894 gretl_bundle *bundle_from_model (MODEL *pmod,
2895 DATASET *dset,
2896 int *err)
2897 {
2898 gretl_bundle *b = NULL;
2899 gretl_matrix *m;
2900 gretl_array *a;
2901 double *x;
2902 double val;
2903 int *list;
2904 const char *s;
2905 const char *key;
2906 int i, t, berr;
2907
2908 if (pmod == NULL) {
2909 GretlObjType type = 0;
2910 void *p = get_genr_model(&type);
2911
2912 if (p == NULL || type != GRETL_OBJ_EQN) {
2913 p = get_last_model(&type);
2914 if (p == NULL || type != GRETL_OBJ_EQN) {
2915 gretl_errmsg_sprintf(_("%s: no data available"), "$model");
2916 *err = E_DATA;
2917 return NULL;
2918 }
2919 }
2920 pmod = p;
2921 }
2922
2923 x = malloc(dset->n * sizeof *x);
2924 if (x == NULL) {
2925 *err = E_ALLOC;
2926 return NULL;
2927 }
2928
2929 b = gretl_bundle_new();
2930 if (b == NULL) {
2931 free(x);
2932 *err = E_ALLOC;
2933 return NULL;
2934 }
2935
2936 for (i=M_ESS; i<M_SCALAR_MAX && !*err; i++) {
2937 berr = 0;
2938 if (i == M_DWPVAL) {
2939 /* Durbin-Watson p-value: don't include this unless
2940 it has already been computed and attached to the
2941 model, since it may involve heavy computation.
2942 */
2943 val = gretl_model_get_double(pmod, "dwpval");
2944 if (!na(val)) {
2945 *err = gretl_bundle_set_scalar(b, "dwpval", val);
2946 }
2947 } else {
2948 val = gretl_model_get_scalar(pmod, i, dset, &berr);
2949 if (!berr) {
2950 key = mvarname(i) + 1;
2951 *err = gretl_bundle_set_scalar(b, key, val);
2952 }
2953 }
2954 }
2955
2956 for (i=M_SCALAR_MAX+1; i<M_SERIES_MAX && !*err; i++) {
2957 for (t=0; t<dset->n; t++) {
2958 x[t] = NADBL;
2959 }
2960 berr = gretl_model_get_series(x, pmod, dset, i);
2961 if (!berr) {
2962 key = mvarname(i) + 1;
2963 *err = gretl_bundle_set_series(b, key, x, dset->n);
2964 }
2965 }
2966
2967 for (i=M_SERIES_MAX+1; i<M_MATRIX_MAX && !*err; i++) {
2968 berr = 0;
2969 m = gretl_model_get_matrix(pmod, i, &berr);
2970 if (!berr) {
2971 key = mvarname(i) + 1;
2972 *err = gretl_bundle_donate_data(b, key, m,
2973 GRETL_TYPE_MATRIX,
2974 0);
2975 }
2976 }
2977
2978 for (i=M_MBUILD_MAX+1; i<M_LIST_MAX && !*err; i++) {
2979 list = NULL;
2980 if (i == M_XLIST) {
2981 list = gretl_model_get_x_list(pmod);
2982 } else if (i == M_YLIST) {
2983 list = gretl_model_get_y_list(pmod);
2984 }
2985 if (list != NULL) {
2986 key = mvarname(i) + 1;
2987 *err = gretl_bundle_donate_data(b, key, list,
2988 GRETL_TYPE_LIST,
2989 0);
2990 }
2991 }
2992
2993 for (i=M_LIST_MAX+1; i<M_PARNAMES && !*err; i++) {
2994 s = NULL;
2995 if (i == M_DEPVAR) {
2996 s = gretl_model_get_depvar_name(pmod, dset);
2997 } else if (i == M_COMMAND) {
2998 s = gretl_command_word(pmod->ci);
2999 }
3000 if (s != NULL && *s != '\0') {
3001 key = mvarname(i) + 1;
3002 *err = gretl_bundle_set_string(b, key, s);
3003 }
3004 }
3005
3006 for (i=M_PARNAMES; i<M_MAX && !*err; i++) {
3007 a = NULL;
3008 if (i == M_PARNAMES) {
3009 a = gretl_model_get_param_names(pmod, dset, err);
3010 }
3011 if (a != NULL) {
3012 key = mvarname(i) + 1;
3013 *err = gretl_bundle_donate_data(b, key, a,
3014 GRETL_TYPE_ARRAY,
3015 0);
3016 }
3017 }
3018
3019 if (!*err) {
3020 *err = bundlize_model_data_items(pmod, b);
3021 }
3022
3023 free(x);
3024
3025 /* don't return a broken bundle */
3026 if (*err && b != NULL) {
3027 gretl_bundle_destroy(b);
3028 b = NULL;
3029 }
3030
3031 return b;
3032 }
3033
3034 /* For an estimated system of some sort, create a bundle containing
3035 relevant data.
3036 */
3037
bundle_from_system(void * ptr,int type,DATASET * dset,int * err)3038 gretl_bundle *bundle_from_system (void *ptr,
3039 int type,
3040 DATASET *dset,
3041 int *err)
3042 {
3043 GRETL_VAR *var = NULL;
3044 GretlObjType otype = type;
3045 equation_system *sys = NULL;
3046 gretl_bundle *b = NULL;
3047
3048 if (ptr == NULL) {
3049 ptr = get_genr_model(&otype);
3050 if (ptr == NULL || otype == GRETL_OBJ_EQN) {
3051 ptr = get_last_model(&otype);
3052 }
3053 }
3054
3055 if (ptr == NULL) {
3056 gretl_errmsg_sprintf(_("%s: no data available"), "$system");
3057 *err = E_DATA;
3058 } else if (otype == GRETL_OBJ_VAR) {
3059 var = (GRETL_VAR *) ptr;
3060 } else if (otype == GRETL_OBJ_SYS) {
3061 sys = (equation_system *) ptr;
3062 } else {
3063 gretl_errmsg_sprintf(_("%s: no data available"), "$system");
3064 *err = E_DATA;
3065 }
3066
3067 if (!*err) {
3068 b = gretl_bundle_new();
3069 if (b == NULL) {
3070 *err = E_ALLOC;
3071 return NULL;
3072 }
3073 }
3074
3075 if (var != NULL) {
3076 *err = gretl_VAR_bundlize(var, dset, b);
3077 } else if (sys != NULL) {
3078 *err = equation_system_bundlize(sys, b);
3079 }
3080
3081 /* don't return a broken bundle */
3082 if (*err && b != NULL) {
3083 gretl_bundle_destroy(b);
3084 b = NULL;
3085 }
3086
3087 return b;
3088 }
3089
kalman_bundle_new(gretl_matrix * M[],int copy[],int nmat,int * err)3090 gretl_bundle *kalman_bundle_new (gretl_matrix *M[],
3091 int copy[], int nmat,
3092 int *err)
3093 {
3094 gretl_bundle *b = gretl_bundle_new();
3095
3096 if (b == NULL) {
3097 *err = E_ALLOC;
3098 } else {
3099 b->type = BUNDLE_KALMAN;
3100 b->data = kalman_new_minimal(M, copy, nmat, err);
3101 }
3102
3103 /* don't return a broken bundle */
3104 if (*err && b != NULL) {
3105 gretl_bundle_destroy(b);
3106 b = NULL;
3107 }
3108
3109 return b;
3110 }
3111
sort_bundled_items(const void * a,const void * b)3112 static gint sort_bundled_items (const void *a, const void *b)
3113 {
3114 const bundled_item *ia = a;
3115 const bundled_item *ib = b;
3116 int ta = gretl_type_get_order(ia->type);
3117 int tb = gretl_type_get_order(ib->type);
3118 int ret = ta - tb;
3119
3120 if (ret == 0) {
3121 ret = g_ascii_strcasecmp(ia->name, ib->name);
3122 }
3123
3124 return ret;
3125 }
3126
gretl_bundle_get_sorted_items(gretl_bundle * b)3127 GList *gretl_bundle_get_sorted_items (gretl_bundle *b)
3128 {
3129 GList *blist;
3130
3131 blist = g_hash_table_get_values(b->ht);
3132 blist = g_list_sort(blist, sort_bundled_items);
3133
3134 return blist;
3135 }
3136
gretl_bundle_cleanup(void)3137 void gretl_bundle_cleanup (void)
3138 {
3139 if (sysinfo_bundle != NULL) {
3140 gretl_bundle_destroy(sysinfo_bundle);
3141 sysinfo_bundle = NULL;
3142 }
3143 }
3144