pintos-os.org Git - pspp/blob - perl-module/PSPP.xs

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