perl-module/PSPP.xs

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