perl-module/PSPP.xs

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