perl-module: Avoid compiler warning from conflicting "my_strftime" macros.
[pspp-builds.git] / perl-module / PSPP.xs
1 /* PSPP - computes sample statistics.
2    Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
3
4    This program is free software; you can redistribute it and/or
5    modify it under the terms of the GNU General Public License as
6    published by the Free Software Foundation; either version 2 of the
7    License, or (at your option) any later version.
8
9    This program is distributed in the hope that it will be useful, but
10    WITHOUT ANY WARRANTY; without even the implied warranty of
11    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
12    General Public License for more details.
13
14    You should have received a copy of the GNU General Public License
15    along with this program; if not, write to the Free Software
16    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
17    02110-1301, USA. */
18
19
20 #include <config.h>
21
22 /* The Gnulib "strftime" module defines my_strftime in <config.h> for use by
23    gl/strftime.c.  Perl also defines my_strftime in embed.h for some other
24    purpose.  The former definition doesn't matter in this file, so suppress it
25    to avoid a compiler warning. */
26 #undef my_strftime
27
28 #include "EXTERN.h"
29 #include "perl.h"
30 #include "XSUB.h"
31
32 #include "ppport.h"
33
34 #include "minmax.h"
35 #include <libpspp/message.h>
36 #include <libpspp/version.h>
37 #include <gl/xalloc.h>
38 #include <data/dictionary.h>
39 #include <data/case.h>
40 #include <data/casereader.h>
41 #include <data/variable.h>
42 #include <data/attributes.h>
43 #include <data/file-handle-def.h>
44 #include <data/sys-file-writer.h>
45 #include <data/sys-file-reader.h>
46 #include <data/value.h>
47 #include <data/vardict.h>
48 #include <data/value-labels.h>
49 #include <data/format.h>
50 #include <data/data-in.h>
51 #include <data/data-out.h>
52 #include <string.h>
53
54 typedef struct fmt_spec input_format ;
55 typedef struct fmt_spec output_format ;
56
57
58 /*  A thin wrapper around sfm_writer */
59 struct sysfile_info
60 {
61   bool opened;
62
63   /* A pointer to the writer. The writer is owned by the struct */
64   struct casewriter *writer;
65
66   /* A pointer to the dictionary. Owned externally */
67   const struct dictionary *dict;
68
69   /* The scalar containing the dictionary */
70   SV *dict_sv;
71 };
72
73
74 /*  A thin wrapper around sfm_reader */
75 struct sysreader_info
76 {
77   struct sfm_read_info opts;
78
79   /* A pointer to the reader. The reader is owned by the struct */
80   struct casereader *reader;
81
82   /* A pointer to the dictionary. */
83   struct dictionary *dict;
84 };
85
86
87
88 /*  A message handler which writes messages to PSPP::errstr */
89 static void
90 message_handler (const struct msg *m)
91 {
92  SV *errstr = get_sv("PSPP::errstr", TRUE);
93  sv_setpv (errstr, m->text);
94 }
95
96 static int
97 sysfile_close (struct sysfile_info *sfi)
98 {
99   int retval ;
100   if ( ! sfi->opened )
101     return 0;
102
103   retval = casewriter_destroy (sfi->writer);
104   if (retval > 0 )
105     sfi->opened = false;
106
107   return retval;
108 }
109
110 static void
111 scalar_to_value (union value *val, SV *scalar, const struct variable *var)
112 {
113   if ( var_is_numeric (var))
114     {
115         if ( SvNOK (scalar) || SvIOK (scalar) )
116            val->f = SvNV (scalar);
117         else
118            val->f = SYSMIS;
119     }
120   else
121     {
122         STRLEN len;
123         const char *p = SvPV (scalar, len);
124         int width = var_get_width (var);
125         value_set_missing (val, width);
126         memcpy (value_str_rw (val, width), p, len);
127     }
128 }
129
130
131 static SV *
132 value_to_scalar (const union value *val, const struct variable *var)
133 {
134   if ( var_is_numeric (var))
135     {
136       if ( var_is_value_missing (var, val, MV_SYSTEM))
137         return newSVpvn ("", 0);
138
139       return newSVnv (val->f);
140     }
141   else
142     {
143       int width = var_get_width (var);
144       return newSVpvn (value_str (val, width), width);
145     }
146 }
147
148
149 static void
150 var_set_input_format (struct variable *v, input_format ip_fmt)
151 {
152   struct fmt_spec *if_copy = malloc (sizeof (*if_copy));
153   memcpy (if_copy, &ip_fmt, sizeof (ip_fmt));
154   var_attach_aux (v, if_copy, var_dtor_free);
155 }
156
157 static void
158 make_value_from_scalar (union value *uv, SV *val, const struct variable *var)
159 {
160  value_init (uv, var_get_width (var));
161  scalar_to_value (uv, val, var);
162 }
163
164
165 MODULE = PSPP
166
167 MODULE = PSPP           PACKAGE = PSPP
168
169 void
170 onBoot (ver)
171  const char *ver
172 CODE:
173  /* Check that the version is correct up to the length of 'ver'.
174     This allows PSPP autobuilders to add a "-build#" suffix to the
175     PSPP version without causing failures here. */
176  assert (0 == strncmp (ver, bare_version, strlen (ver)));
177
178  i18n_init ();
179  msg_init (NULL, message_handler);
180  settings_init (0, 0);
181  fh_init ();
182
183 SV *
184 format_value (val, var)
185  SV *val
186  struct variable *var
187 CODE:
188  SV *ret;
189  const struct fmt_spec *fmt = var_get_print_format (var);
190  union value uv;
191  char *s;
192  make_value_from_scalar (&uv, val, var);
193  s = data_out (&uv, var_get_encoding (var), fmt);
194  value_destroy (&uv, var_get_width (var));
195  ret = newSVpv (s, fmt->w);
196  free (s);
197  RETVAL = ret;
198  OUTPUT:
199 RETVAL
200
201
202 int
203 value_is_missing (val, var)
204  SV *val
205  struct variable *var
206 CODE:
207  union value uv;
208  int ret;
209  make_value_from_scalar (&uv, val, var);
210  ret = var_is_value_missing (var, &uv, MV_ANY);
211  value_destroy (&uv, var_get_width (var));
212  RETVAL = ret;
213  OUTPUT:
214 RETVAL
215
216
217
218 MODULE = PSPP           PACKAGE = PSPP::Dict
219
220 struct dictionary *
221 pxs_dict_new()
222 CODE:
223  RETVAL = dict_create ();
224 OUTPUT:
225  RETVAL
226
227
228 void
229 DESTROY (dict)
230  struct dictionary *dict
231 CODE:
232  dict_destroy (dict);
233
234
235 int
236 get_var_cnt (dict)
237  struct dictionary *dict
238 CODE:
239  RETVAL = dict_get_var_cnt (dict);
240 OUTPUT:
241 RETVAL
242
243 void
244 set_label (dict, label)
245  struct dictionary *dict
246  char *label
247 CODE:
248  dict_set_label (dict, label);
249
250 void
251 set_documents (dict, docs)
252  struct dictionary *dict
253  char *docs
254 CODE:
255  dict_set_documents (dict, docs);
256
257
258 void
259 add_document (dict, doc)
260  struct dictionary *dict
261  char *doc
262 CODE:
263  dict_add_document_line (dict, doc);
264
265
266 void
267 clear_documents (dict)
268  struct dictionary *dict
269 CODE:
270  dict_clear_documents (dict);
271
272
273 void
274 set_weight (dict, var)
275  struct dictionary *dict
276  struct variable *var
277 CODE:
278  dict_set_weight (dict, var);
279
280
281 struct variable *
282 pxs_get_variable (dict, idx)
283  struct dictionary *dict
284  SV *idx
285 INIT:
286  SV *errstr = get_sv("PSPP::errstr", TRUE);
287  sv_setpv (errstr, "");
288  if ( SvIV (idx) >= dict_get_var_cnt (dict))
289   {
290     sv_setpv (errstr, "The dictionary doesn't have that many variables.");
291     XSRETURN_UNDEF;
292   }
293 CODE:
294  RETVAL = dict_get_var (dict, SvIV (idx));
295  OUTPUT:
296 RETVAL
297
298
299 struct variable *
300 pxs_get_var_by_name (dict, name)
301  struct dictionary *dict
302  const char *name
303 INIT:
304  SV *errstr = get_sv("PSPP::errstr", TRUE);
305  sv_setpv (errstr, "");
306 CODE:
307  struct variable *var = dict_lookup_var (dict, name);
308  if ( ! var )
309       sv_setpv (errstr, "No such variable.");
310  RETVAL = var;
311  OUTPUT:
312 RETVAL
313
314
315 MODULE = PSPP           PACKAGE = PSPP::Var
316
317
318 struct variable *
319 pxs_dict_create_var (dict, name, ip_fmt)
320  struct dictionary * dict
321  char *name
322  input_format ip_fmt
323 INIT:
324  SV *errstr = get_sv("PSPP::errstr", TRUE);
325  sv_setpv (errstr, "");
326  if ( ! var_is_plausible_name (name, false))
327   {
328     sv_setpv (errstr, "The variable name is not valid.");
329     XSRETURN_UNDEF;
330   }
331 CODE:
332  struct fmt_spec op_fmt;
333
334  struct variable *v;
335  op_fmt = fmt_for_output_from_input (&ip_fmt);
336  v = dict_create_var (dict, name,
337         fmt_is_string (op_fmt.type) ? op_fmt.w : 0);
338  if ( NULL == v )
339   {
340     sv_setpv (errstr, "The variable could not be created (probably already exists).");
341     XSRETURN_UNDEF;
342   }
343  var_set_both_formats (v, &op_fmt);
344  var_set_input_format (v, ip_fmt);
345  RETVAL = v;
346 OUTPUT:
347  RETVAL
348
349
350 int
351 set_missing_values (var, v1, ...)
352  struct variable *var;
353  SV *v1;
354 INIT:
355  int i;
356  union value val[3];
357
358  if ( items > 4 )
359   croak ("No more than 3 missing values are permitted");
360
361  for (i = 0; i < items - 1; ++i)
362    scalar_to_value (&val[i], ST(i+1), var);
363 CODE:
364  struct missing_values mv;
365  mv_init (&mv, var_get_width (var));
366  for (i = 0 ; i < items - 1; ++i )
367    mv_add_value (&mv, &val[i]);
368  var_set_missing_values (var, &mv);
369
370
371 void
372 set_label (var, label)
373  struct variable *var;
374  char *label
375 CODE:
376   var_set_label (var, label);
377
378
379 void
380 clear_value_labels (var)
381  struct variable *var;
382 CODE:
383  var_clear_value_labels (var);
384
385 SV *
386 get_write_format (var)
387  struct variable *var
388 CODE:
389  HV *fmthash = (HV *) sv_2mortal ((SV *) newHV());
390  const struct fmt_spec *fmt = var_get_write_format (var);
391
392  hv_store (fmthash, "fmt", 3, newSVnv (fmt->type), 0);
393  hv_store (fmthash, "decimals", 8, newSVnv (fmt->d), 0);
394  hv_store (fmthash, "width", 5, newSVnv (fmt->w), 0);
395
396  RETVAL = newRV ((SV *) fmthash);
397  OUTPUT:
398 RETVAL
399
400 SV *
401 get_print_format (var)
402  struct variable *var
403 CODE:
404  HV *fmthash = (HV *) sv_2mortal ((SV *) newHV());
405  const struct fmt_spec *fmt = var_get_print_format (var);
406
407  hv_store (fmthash, "fmt", 3, newSVnv (fmt->type), 0);
408  hv_store (fmthash, "decimals", 8, newSVnv (fmt->d), 0);
409  hv_store (fmthash, "width", 5, newSVnv (fmt->w), 0);
410
411  RETVAL = newRV ((SV *) fmthash);
412  OUTPUT:
413 RETVAL
414
415
416 void
417 pxs_set_write_format (var, fmt)
418  struct variable *var
419  output_format fmt
420 CODE:
421  var_set_write_format (var, &fmt);
422
423
424 void
425 pxs_set_print_format (var, fmt)
426  struct variable *var
427  output_format fmt
428 CODE:
429  var_set_print_format (var, &fmt);
430
431 void
432 pxs_set_output_format (var, fmt)
433  struct variable *var
434  output_format fmt
435 CODE:
436  var_set_both_formats (var, &fmt);
437
438
439 int
440 add_value_label (var, key, label)
441  struct variable *var
442  SV *key
443  char *label
444 INIT:
445  SV *errstr = get_sv("PSPP::errstr", TRUE);
446  sv_setpv (errstr, "");
447 CODE:
448  union value the_value;
449  int width = var_get_width (var);
450  int ok;
451
452  value_init (&the_value, width);
453  if ( var_is_numeric (var))
454  {
455   if ( ! looks_like_number (key))
456     {
457       sv_setpv (errstr, "Cannot add label with string key to a numeric variable");
458       value_destroy (&the_value, width);
459       XSRETURN_IV (0);
460     }
461   the_value.f = SvNV (key);
462  }
463  else
464  {
465   value_copy_str_rpad (&the_value, width, SvPV_nolen(key), ' ');
466  }
467  ok = var_add_value_label (var, &the_value, label);
468  value_destroy (&the_value, width);
469  if (!ok)
470  {
471    sv_setpv (errstr, "Something went wrong");
472    XSRETURN_IV (0);
473  }
474  XSRETURN_IV (1);
475
476
477 SV *
478 get_attributes (var)
479  struct variable *var
480 CODE:
481  HV *attrhash = (HV *) sv_2mortal ((SV *) newHV());
482
483  struct attrset *as = var_get_attributes (var);
484
485  if ( as )
486    {
487      struct attrset_iterator iter;
488      struct attribute *attr;
489
490      for (attr = attrset_first (as, &iter);
491           attr;
492           attr = attrset_next (as, &iter))
493        {
494          int i;
495          const char *name = attribute_get_name (attr);
496
497          AV *values = newAV ();
498
499          for (i = 0 ; i < attribute_get_n_values (attr); ++i )
500            {
501              const char *value = attribute_get_value (attr, i);
502              av_push (values, newSVpv (value, 0));
503            }
504
505          hv_store (attrhash, name, strlen (name),
506                    newRV_noinc ((SV*) values), 0);
507        }
508    }
509
510  RETVAL = newRV ((SV *) attrhash);
511  OUTPUT:
512 RETVAL
513
514
515 const char *
516 get_name (var)
517  struct variable * var
518 CODE:
519  RETVAL = var_get_name (var);
520  OUTPUT:
521 RETVAL
522
523
524 const char *
525 get_label (var)
526  struct variable * var
527 CODE:
528  RETVAL = var_get_label (var);
529  OUTPUT:
530 RETVAL
531
532
533 SV *
534 get_value_labels (var)
535  struct variable *var
536 CODE:
537  HV *labelhash = (HV *) sv_2mortal ((SV *) newHV());
538  const struct val_lab *vl;
539  struct val_labs_iterator *viter = NULL;
540  const struct val_labs *labels = var_get_value_labels (var);
541
542  if ( labels )
543    {
544      for (vl = val_labs_first (labels);
545           vl;
546           vl = val_labs_next (labels, vl))
547        {
548          SV *sv = value_to_scalar (&vl->value, var);
549          STRLEN len;
550          const char *s = SvPV (sv, len);
551          hv_store (labelhash, s, len, newSVpv (val_lab_get_label (vl), 0), 0);
552        }
553    }
554
555  RETVAL = newRV ((SV *) labelhash);
556  OUTPUT:
557 RETVAL
558
559
560
561 MODULE = PSPP           PACKAGE = PSPP::Sysfile
562
563
564 struct sysfile_info *
565 pxs_create_sysfile (name, dict_ref, opts_hr)
566  char *name
567  SV *dict_ref
568  SV *opts_hr
569 INIT:
570  SV *dict_sv = SvRV (dict_ref);
571  struct dictionary *dict = (void *) SvIV (dict_sv);
572  struct sfm_write_options opts;
573  if (!SvROK (opts_hr))
574   {
575     opts = sfm_writer_default_options ();
576   }
577  else
578   {
579     HV *opt_h = (HV *) SvRV (opts_hr);
580     SV** readonly = hv_fetch(opt_h, "readonly", 8, 0);
581     SV** compress = hv_fetch(opt_h, "compress", 8, 0);
582     SV** version = hv_fetch(opt_h, "version", 7, 0);
583
584     opts.create_writeable = readonly ? ! SvIV (*readonly) : true;
585     opts.compress = compress ? SvIV (*compress) : false;
586     opts.version = version ? SvIV (*version) : 3 ;
587   }
588 CODE:
589  struct file_handle *fh =
590   fh_create_file (NULL, name, fh_default_properties () );
591  struct sysfile_info *sfi = xmalloc (sizeof (*sfi));
592  dict_set_encoding (dict, "UTF-8");
593  sfi->writer = sfm_open_writer (fh, dict, opts);
594  sfi->dict = dict;
595  sfi->opened = true;
596  sfi->dict_sv = dict_sv;
597  SvREFCNT_inc (sfi->dict_sv);
598  
599  RETVAL = sfi;
600  OUTPUT:
601 RETVAL
602
603 int
604 close (sfi)
605  struct sysfile_info *sfi
606 CODE:
607  RETVAL = sysfile_close (sfi);
608 OUTPUT:
609  RETVAL
610
611 void
612 DESTROY (sfi)
613  struct sysfile_info *sfi
614 CODE:
615  sysfile_close (sfi);
616  SvREFCNT_dec (sfi->dict_sv);
617  free (sfi);
618
619 int
620 append_case (sfi, ccase)
621  struct sysfile_info *sfi
622  SV *ccase
623 INIT:
624  SV *errstr = get_sv("PSPP::errstr", TRUE);
625  sv_setpv (errstr, "");
626  if ( (!SvROK(ccase)))
627   {
628     XSRETURN_UNDEF;
629   }
630 CODE:
631  int i = 0;
632  AV *av_case = (AV*) SvRV (ccase);
633
634  const struct variable **vv;
635  size_t nv;
636  struct ccase *c;
637  SV *sv;
638
639  if ( av_len (av_case) >= dict_get_var_cnt (sfi->dict))
640    XSRETURN_UNDEF;
641
642  c =  case_create (dict_get_proto (sfi->dict));
643
644  dict_get_vars (sfi->dict, &vv, &nv, 1u << DC_ORDINARY | 1u << DC_SYSTEM);
645
646  for (sv = av_shift (av_case); SvOK (sv);  sv = av_shift (av_case))
647  {
648     const struct variable *v = vv[i++];
649     const struct fmt_spec *ifmt = var_get_aux (v);
650
651     /* If an input format has been set, then use it.
652        Otherwise just convert the raw value.
653     */
654     if ( ifmt )
655       {
656         struct substring ss = ss_cstr (SvPV_nolen (sv));
657         if ( ! data_in (ss, LEGACY_NATIVE, ifmt->type, 0, 0, 0,
658                         sfi->dict,
659                         case_data_rw (c, v),
660                         var_get_width (v)) )
661           {
662             RETVAL = 0;
663             goto finish;
664           }
665       }
666     else
667       {
668         scalar_to_value (case_data_rw (c, v), sv, v);
669       }
670  }
671
672  /* The remaining variables must be sysmis or blank string */
673  while (i < dict_get_var_cnt (sfi->dict))
674  {
675    const struct variable *v = vv[i++];
676    union value *val = case_data_rw (c, v);
677    value_set_missing (val, var_get_width (v));
678  }
679  RETVAL = casewriter_write (sfi->writer, c);
680  finish:
681  free (vv);
682 OUTPUT:
683  RETVAL
684
685
686 \f
687
688 MODULE = PSPP           PACKAGE = PSPP::Reader
689
690 struct sysreader_info *
691 pxs_open_sysfile (name)
692  char * name
693 CODE:
694  struct casereader *reader;
695  struct sysreader_info *sri = NULL;
696  struct file_handle *fh =
697          fh_create_file (NULL, name, fh_default_properties () );
698
699  sri = xmalloc (sizeof (*sri));
700  sri->reader = sfm_open_reader (fh, &sri->dict, &sri->opts);
701
702  if ( NULL == sri->reader)
703  {
704    free (sri);
705    sri = NULL;
706  }
707
708  RETVAL = sri;
709  OUTPUT:
710 RETVAL
711
712
713 struct dictionary *
714 pxs_get_dict (reader)
715  struct sysreader_info *reader;
716 CODE:
717  RETVAL = reader->dict;
718  OUTPUT:
719 RETVAL
720
721
722 void
723 get_next_case (sfr)
724  struct sysreader_info *sfr;
725 PPCODE:
726  struct ccase *c;
727
728  if (c = casereader_read (sfr->reader))
729  {
730   int v;
731
732   EXTEND (SP, dict_get_var_cnt (sfr->dict));
733   for (v = 0; v < dict_get_var_cnt (sfr->dict); ++v )
734     {
735       const struct variable *var = dict_get_var (sfr->dict, v);
736       const union value *val = case_data (c, var);
737
738       PUSHs (sv_2mortal (value_to_scalar (val, var)));
739     }
740
741   case_unref (c);
742  }